{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE Trustworthy #-}

-- | Generic implementation of Read
--
-- === Warning
--
-- This is an internal module: it is not subject to any versioning policy,
-- breaking changes can happen at any time.
--
-- If something here seems useful, please report it or create a pull request to
-- export it from an external module.

module Generic.Data.Internal.Read where

import Data.Coerce
import Data.Functor.Classes (Read1(..))
import Data.Functor.Identity
import Data.Proxy
import Generic.Data.Internal.Utils (isSymDataCon, isSymVar)
import GHC.Generics hiding (prec)
import GHC.Read (expectP, list)
import GHC.Show (appPrec, appPrec1)
import Text.ParserCombinators.ReadPrec
import Text.Read (Read(..), parens)
import Text.Read.Lex (Lexeme(..))

-- | Generic 'readPrec'.
--
-- @
-- instance 'Read' MyType where
--   'readPrec' = 'greadPrec'
--   'readListPrec' = 'readListPrecDefault'
-- @
greadPrec :: (Generic a, GRead0 (Rep a)) => ReadPrec a
greadPrec :: ReadPrec a
greadPrec = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> a) -> ReadPrec (Rep a Any) -> ReadPrec a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy (ReadPrec Any, ReadPrec [Any]) -> ReadPrec (Rep a Any)
forall (p :: * -> *) (f :: * -> *) a.
GRead p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
gPrecRead Proxy (ReadPrec Any, ReadPrec [Any])
forall k (t :: k). Proxy t
Proxy

-- | Generic representation of 'Read' types.
type GRead0 = GRead Proxy

-- | Generic 'liftReadPrec'.
gliftReadPrec
  :: (Generic1 f, GRead1 (Rep1 f))
  => ReadPrec a -> ReadPrec [a]
  -> ReadPrec (f a)
gliftReadPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec (f a)
gliftReadPrec ReadPrec a
readPrec' ReadPrec [a]
readList' =
  Rep1 f a -> f a
forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1 (Rep1 f a -> f a) -> ReadPrec (Rep1 f a) -> ReadPrec (f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Identity (ReadPrec a, ReadPrec [a]) -> ReadPrec (Rep1 f a)
forall (p :: * -> *) (f :: * -> *) a.
GRead p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
gPrecRead ((ReadPrec a, ReadPrec [a]) -> Identity (ReadPrec a, ReadPrec [a])
forall a. a -> Identity a
Identity (ReadPrec a
readPrec', ReadPrec [a]
readList'))

-- | Generic representation of 'Data.Functor.Classes.Read1' types.
type GRead1 = GRead Identity

class GRead p f where
  gPrecRead :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)

instance (GRead p f, IsNullaryDataType f) => GRead p (M1 D d f) where
  gPrecRead :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec (M1 D d f a)
gPrecRead p (ReadPrec a, ReadPrec [a])
p = ReadPrec (f a) -> ReadPrec (M1 D d f a)
forall (f :: * -> *) p i (c :: Meta).
ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerceM1 (ReadPrec (f a) -> ReadPrec (f a)
forall a. ReadPrec a -> ReadPrec a
parensIfNonNullary (p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
forall (p :: * -> *) (f :: * -> *) a.
GRead p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
gPrecRead p (ReadPrec a, ReadPrec [a])
p))
    where
      x :: f a
      x :: f a
x = f a
forall a. HasCallStack => a
undefined

      parensIfNonNullary :: ReadPrec a -> ReadPrec a
      parensIfNonNullary :: ReadPrec a -> ReadPrec a
parensIfNonNullary = if f Any -> Bool
forall (f :: * -> *) a. IsNullaryDataType f => f a -> Bool
isNullaryDataType f Any
forall a. f a
x
                              then ReadPrec a -> ReadPrec a
forall a. a -> a
id
                              else ReadPrec a -> ReadPrec a
forall a. ReadPrec a -> ReadPrec a
parens

instance (GRead p f, GRead p g) => GRead p (f :+: g) where
  gPrecRead :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec ((:+:) f g a)
gPrecRead p (ReadPrec a, ReadPrec [a])
p = (f a -> (:+:) f g a) -> ReadPrec (f a) -> ReadPrec ((:+:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
forall (p :: * -> *) (f :: * -> *) a.
GRead p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
gPrecRead p (ReadPrec a, ReadPrec [a])
p) ReadPrec ((:+:) f g a)
-> ReadPrec ((:+:) f g a) -> ReadPrec ((:+:) f g a)
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
+++ (g a -> (:+:) f g a) -> ReadPrec (g a) -> ReadPrec ((:+:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap g a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (p (ReadPrec a, ReadPrec [a]) -> ReadPrec (g a)
forall (p :: * -> *) (f :: * -> *) a.
GRead p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
gPrecRead p (ReadPrec a, ReadPrec [a])
p)

instance (Constructor c, GReadC p c f) => GRead p (M1 C c f) where
  gPrecRead :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec (M1 C c f a)
gPrecRead p (ReadPrec a, ReadPrec [a])
p = p (ReadPrec a, ReadPrec [a])
-> String -> Fixity -> ReadPrec (M1 C c f a)
forall (p :: * -> *) (c :: Meta) (f :: * -> *) a.
GReadC p c f =>
p (ReadPrec a, ReadPrec [a])
-> String -> Fixity -> ReadPrec (M1 C c f a)
gPrecReadC p (ReadPrec a, ReadPrec [a])
p (M1 C c f Any -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName M1 C c f Any
forall a. M1 C c f a
x) (M1 C c f Any -> Fixity
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Fixity
conFixity M1 C c f Any
forall a. M1 C c f a
x)
    where
      x :: M1 C c f a
      x :: M1 C c f a
x = M1 C c f a
forall a. HasCallStack => a
undefined

instance GRead p V1 where
  gPrecRead :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec (V1 a)
gPrecRead p (ReadPrec a, ReadPrec [a])
_ = ReadPrec (V1 a)
forall a. ReadPrec a
pfail

class IsNullaryDataType f where
  isNullaryDataType :: f a -> Bool

instance IsNullaryDataType (f :+: g) where
  isNullaryDataType :: (:+:) f g a -> Bool
isNullaryDataType (:+:) f g a
_ = Bool
False

instance IsNullaryDataType (C1 c f) where
  isNullaryDataType :: C1 c f a -> Bool
isNullaryDataType C1 c f a
_ = Bool
False

instance IsNullaryDataType V1 where
  isNullaryDataType :: V1 a -> Bool
isNullaryDataType V1 a
_ = Bool
True

class GReadC p c f where
  gPrecReadC :: p (ReadPrec a, ReadPrec [a]) -> String -> Fixity -> ReadPrec (M1 C c f a)

instance GReadFields p f => GReadC p ('MetaCons s y 'False) f where
  gPrecReadC :: forall a. p (ReadPrec a, ReadPrec [a]) -> String -> Fixity
             -> ReadPrec (M1 C ('MetaCons s y 'False) f a)
  gPrecReadC :: p (ReadPrec a, ReadPrec [a])
-> String -> Fixity -> ReadPrec (M1 C ('MetaCons s y 'False) f a)
gPrecReadC p (ReadPrec a, ReadPrec [a])
p String
name Fixity
fixity
    | Infix Associativity
_ Int
fy <- Fixity
fixity, Branch ReadPrecTree (f a)
k1 ReadPrecTree (g a)
k2 <- ReadPrecTree (f a)
fields
    = ReadPrec ((:*:) f g a)
-> ReadPrec (M1 C ('MetaCons s y 'False) (f :*: g) a)
forall (f :: * -> *) p i (c :: Meta).
ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerceM1 (ReadPrec ((:*:) f g a)
 -> ReadPrec (M1 C ('MetaCons s y 'False) (f :*: g) a))
-> ReadPrec ((:*:) f g a)
-> ReadPrec (M1 C ('MetaCons s y 'False) (f :*: g) a)
forall a b. (a -> b) -> a -> b
$ Int -> ReadPrec ((:*:) f g a) -> ReadPrec ((:*:) f g a)
forall a. Int -> ReadPrec a -> ReadPrec a
prec Int
fy (ReadPrec ((:*:) f g a) -> ReadPrec ((:*:) f g a))
-> ReadPrec ((:*:) f g a) -> ReadPrec ((:*:) f g a)
forall a b. (a -> b) -> a -> b
$ do
        f a
k1' <- ReadPrecTree (f a) -> ReadPrec (f a)
forall a. ReadPrecTree a -> ReadPrec a
toReadPrec ReadPrecTree (f a)
k1
        if String -> Bool
isSymDataCon String
name
           then Lexeme -> ReadPrec ()
expectP (String -> Lexeme
Symbol String
name)
           else (Lexeme -> ReadPrec ()) -> [Lexeme] -> ReadPrec ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Lexeme -> ReadPrec ()
expectP ([String -> Lexeme
Punc String
"`"] [Lexeme] -> [Lexeme] -> [Lexeme]
forall a. [a] -> [a] -> [a]
++ String -> [Lexeme]
identHLexemes String
name [Lexeme] -> [Lexeme] -> [Lexeme]
forall a. [a] -> [a] -> [a]
++ [String -> Lexeme
Punc String
"`"])
        g a
k2' <- ReadPrecTree (g a) -> ReadPrec (g a)
forall a. ReadPrecTree a -> ReadPrec a
toReadPrec ReadPrecTree (g a)
k2
        (:*:) f g a -> ReadPrec ((:*:) f g a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f a
k1' f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g a
k2')
    | Bool
otherwise
    = ReadPrec (f a) -> ReadPrec (M1 C ('MetaCons s y 'False) f a)
forall (f :: * -> *) p i (c :: Meta).
ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerceM1 (ReadPrec (f a) -> ReadPrec (M1 C ('MetaCons s y 'False) f a))
-> ReadPrec (f a) -> ReadPrec (M1 C ('MetaCons s y 'False) f a)
forall a b. (a -> b) -> a -> b
$ Int -> ReadPrec (f a) -> ReadPrec (f a)
forall a. Int -> ReadPrec a -> ReadPrec a
prec Int
appPrec (ReadPrec (f a) -> ReadPrec (f a))
-> ReadPrec (f a) -> ReadPrec (f a)
forall a b. (a -> b) -> a -> b
$ do
        String -> ReadPrec ()
readPrefixCon String
name
        ReadPrecTree (f a) -> ReadPrec (f a)
forall a. ReadPrecTree a -> ReadPrec a
toReadPrec ReadPrecTree (f a)
fields
    where
      fields :: ReadPrecTree (f a)
      fields :: ReadPrecTree (f a)
fields = p (ReadPrec a, ReadPrec [a]) -> ReadPrecTree (f a)
forall (p :: * -> *) (f :: * -> *) a.
GReadFields p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrecTree (f a)
gPrecReadFields p (ReadPrec a, ReadPrec [a])
p

instance GReadNamed p f => GReadC p ('MetaCons s y 'True) f where
  gPrecReadC :: p (ReadPrec a, ReadPrec [a])
-> String -> Fixity -> ReadPrec (M1 C ('MetaCons s y 'True) f a)
gPrecReadC p (ReadPrec a, ReadPrec [a])
p String
name Fixity
_fixity = ReadPrec (f a) -> ReadPrec (M1 C ('MetaCons s y 'True) f a)
forall (f :: * -> *) p i (c :: Meta).
ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerceM1 (ReadPrec (f a) -> ReadPrec (M1 C ('MetaCons s y 'True) f a))
-> ReadPrec (f a) -> ReadPrec (M1 C ('MetaCons s y 'True) f a)
forall a b. (a -> b) -> a -> b
$ Int -> ReadPrec (f a) -> ReadPrec (f a)
forall a. Int -> ReadPrec a -> ReadPrec a
prec Int
appPrec1 (ReadPrec (f a) -> ReadPrec (f a))
-> ReadPrec (f a) -> ReadPrec (f a)
forall a b. (a -> b) -> a -> b
$ do
    String -> ReadPrec ()
readPrefixCon String
name
    Char -> ReadPrec (f a) -> Char -> ReadPrec (f a)
forall a. Char -> ReadPrec a -> Char -> ReadPrec a
readSurround Char
'{' ReadPrec (f a)
fields Char
'}'
    where
      fields :: ReadPrec (f a)
fields = p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
forall (p :: * -> *) (f :: * -> *) a.
GReadNamed p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
gPrecReadNamed p (ReadPrec a, ReadPrec [a])
p

class GReadFields p f where
  gPrecReadFields :: p (ReadPrec a, ReadPrec [a]) -> ReadPrecTree (f a)

instance (GReadFields p f, GReadFields p g) => GReadFields p (f :*: g) where
  gPrecReadFields :: p (ReadPrec a, ReadPrec [a]) -> ReadPrecTree ((:*:) f g a)
gPrecReadFields p (ReadPrec a, ReadPrec [a])
p = ReadPrecTree (f a)
-> ReadPrecTree (g a) -> ReadPrecTree ((:*:) f g a)
forall (i :: * -> *) c (g :: * -> *).
ReadPrecTree (i c)
-> ReadPrecTree (g c) -> ReadPrecTree ((:*:) i g c)
Branch (p (ReadPrec a, ReadPrec [a]) -> ReadPrecTree (f a)
forall (p :: * -> *) (f :: * -> *) a.
GReadFields p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrecTree (f a)
gPrecReadFields p (ReadPrec a, ReadPrec [a])
p) (p (ReadPrec a, ReadPrec [a]) -> ReadPrecTree (g a)
forall (p :: * -> *) (f :: * -> *) a.
GReadFields p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrecTree (f a)
gPrecReadFields p (ReadPrec a, ReadPrec [a])
p)

instance GReadSingle p f => GReadFields p (M1 S c f) where
  gPrecReadFields :: p (ReadPrec a, ReadPrec [a]) -> ReadPrecTree (M1 S c f a)
gPrecReadFields p (ReadPrec a, ReadPrec [a])
p = ReadPrec (f a) -> ReadPrecTree (M1 S c f a)
forall (f :: * -> *) a i (c :: Meta).
ReadPrec (f a) -> ReadPrecTree (M1 i c f a)
M1Leaf (ReadPrec (f a) -> ReadPrec (f a)
forall a. ReadPrec a -> ReadPrec a
step (p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
forall (p :: * -> *) (f :: * -> *) a.
GReadSingle p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
gPrecReadSingle p (ReadPrec a, ReadPrec [a])
p))

instance GReadFields p U1 where
  gPrecReadFields :: p (ReadPrec a, ReadPrec [a]) -> ReadPrecTree (U1 a)
gPrecReadFields p (ReadPrec a, ReadPrec [a])
_ = ReadPrecTree (U1 a)
forall a. ReadPrecTree (U1 a)
U1Leaf

class GReadNamed p f where
  gPrecReadNamed :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)

instance (GReadNamed p f, GReadNamed p g) => GReadNamed p (f :*: g) where
  gPrecReadNamed :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec ((:*:) f g a)
gPrecReadNamed p (ReadPrec a, ReadPrec [a])
p = do
    f a
l <- p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
forall (p :: * -> *) (f :: * -> *) a.
GReadNamed p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
gPrecReadNamed p (ReadPrec a, ReadPrec [a])
p
    Lexeme -> ReadPrec ()
expectP (String -> Lexeme
Punc String
",")
    g a
r <- p (ReadPrec a, ReadPrec [a]) -> ReadPrec (g a)
forall (p :: * -> *) (f :: * -> *) a.
GReadNamed p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
gPrecReadNamed p (ReadPrec a, ReadPrec [a])
p
    (:*:) f g a -> ReadPrec ((:*:) f g a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f a
l f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g a
r)

instance (Selector c, GReadSingle p f) => GReadNamed p (M1 S c f) where
  gPrecReadNamed :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec (M1 S c f a)
gPrecReadNamed p (ReadPrec a, ReadPrec [a])
p = ReadPrec (f a) -> ReadPrec (M1 S c f a)
forall (f :: * -> *) p i (c :: Meta).
ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerceM1 (ReadPrec (f a) -> ReadPrec (M1 S c f a))
-> ReadPrec (f a) -> ReadPrec (M1 S c f a)
forall a b. (a -> b) -> a -> b
$ do
    (Lexeme -> ReadPrec ()) -> [Lexeme] -> ReadPrec ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Lexeme -> ReadPrec ()
expectP [Lexeme]
snameLexemes
    Lexeme -> ReadPrec ()
expectP (String -> Lexeme
Punc String
"=")
    ReadPrec (f a) -> ReadPrec (f a)
forall a. ReadPrec a -> ReadPrec a
reset (p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
forall (p :: * -> *) (f :: * -> *) a.
GReadSingle p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
gPrecReadSingle p (ReadPrec a, ReadPrec [a])
p)
    where
      x :: M1 S c f a
      x :: M1 S c f a
x = M1 S c f a
forall a. HasCallStack => a
undefined

      sname :: String
      sname :: String
sname = M1 S c f Any -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName M1 S c f Any
forall a. M1 S c f a
x

      snameLexemes :: [Lexeme]
      snameLexemes :: [Lexeme]
snameLexemes | String -> Bool
isSymVar String
sname
                   = [String -> Lexeme
Punc String
"(", String -> Lexeme
Symbol String
sname, String -> Lexeme
Punc String
")"]
                   | Bool
otherwise
                   = String -> [Lexeme]
identHLexemes String
sname

instance GReadNamed p U1 where
  gPrecReadNamed :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec (U1 a)
gPrecReadNamed p (ReadPrec a, ReadPrec [a])
_ = U1 a -> ReadPrec (U1 a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 a
forall k (p :: k). U1 p
U1

class GReadSingle p f where
  gPrecReadSingle :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)

instance Read a => GReadSingle p (K1 i a) where
  gPrecReadSingle :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec (K1 i a a)
gPrecReadSingle p (ReadPrec a, ReadPrec [a])
_ = ReadPrec a -> ReadPrec (K1 i a a)
forall x. ReadPrec a -> ReadPrec (K1 i a x)
coerceK1 ReadPrec a
forall a. Read a => ReadPrec a
readPrec
    where
      coerceK1 :: ReadPrec a -> ReadPrec (K1 i a x)
      coerceK1 :: ReadPrec a -> ReadPrec (K1 i a x)
coerceK1 = ReadPrec a -> ReadPrec (K1 i a x)
coerce

instance Read1 f => GReadSingle Identity (Rec1 f) where
  gPrecReadSingle :: Identity (ReadPrec a, ReadPrec [a]) -> ReadPrec (Rec1 f a)
gPrecReadSingle (Identity (ReadPrec a, ReadPrec [a])
p) = ReadPrec (f a) -> ReadPrec (Rec1 f a)
forall a. ReadPrec (f a) -> ReadPrec (Rec1 f a)
coerceRec1 ((ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
forall (f :: * -> *) a.
Read1 f =>
(ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
liftReadPrecCompat (ReadPrec a, ReadPrec [a])
p)
    where
      coerceRec1 :: ReadPrec (f a) -> ReadPrec (Rec1 f a)
      coerceRec1 :: ReadPrec (f a) -> ReadPrec (Rec1 f a)
coerceRec1 = ReadPrec (f a) -> ReadPrec (Rec1 f a)
coerce

instance GReadSingle Identity Par1 where
  gPrecReadSingle :: Identity (ReadPrec a, ReadPrec [a]) -> ReadPrec (Par1 a)
gPrecReadSingle (Identity (ReadPrec a
readPrec', ReadPrec [a]
_)) = ReadPrec a -> ReadPrec (Par1 a)
forall p. ReadPrec p -> ReadPrec (Par1 p)
coercePar1 ReadPrec a
readPrec'
    where
      coercePar1 :: ReadPrec p -> ReadPrec (Par1 p)
      coercePar1 :: ReadPrec p -> ReadPrec (Par1 p)
coercePar1 = ReadPrec p -> ReadPrec (Par1 p)
coerce

instance (Read1 f, GReadSingle p g) => GReadSingle p (f :.: g) where
  gPrecReadSingle :: forall a. p (ReadPrec a, ReadPrec [a]) -> ReadPrec ((f :.: g) a)
  gPrecReadSingle :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec ((:.:) f g a)
gPrecReadSingle p (ReadPrec a, ReadPrec [a])
p = ReadPrec (f (g a)) -> ReadPrec ((:.:) f g a)
coerceComp1 ((ReadPrec (g a), ReadPrec [g a]) -> ReadPrec (f (g a))
forall (f :: * -> *) a.
Read1 f =>
(ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
liftReadPrecCompat (ReadPrec (g a)
readPrec_, ReadPrec [g a]
readList_))
    where
      readPrec_ :: ReadPrec (g a)
      readPrec_ :: ReadPrec (g a)
readPrec_ = p (ReadPrec a, ReadPrec [a]) -> ReadPrec (g a)
forall (p :: * -> *) (f :: * -> *) a.
GReadSingle p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
gPrecReadSingle p (ReadPrec a, ReadPrec [a])
p

      readList_ :: ReadPrec [g a]
      readList_ :: ReadPrec [g a]
readList_ = ReadPrec (g a) -> ReadPrec [g a]
forall a. ReadPrec a -> ReadPrec [a]
list ReadPrec (g a)
readPrec_

      coerceComp1 :: ReadPrec (f (g a)) -> ReadPrec ((f :.: g) a)
      coerceComp1 :: ReadPrec (f (g a)) -> ReadPrec ((:.:) f g a)
coerceComp1 = ReadPrec (f (g a)) -> ReadPrec ((:.:) f g a)
coerce

-- Helpers

coerceM1 :: ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerceM1 :: ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerceM1 = ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerce

-- | A backwards-compatible version of 'liftReadPrec'. This is needed for
-- compatibility with @base-4.9@, where 'Read1' only offers 'liftReadsPrec',
-- not 'liftReadPrec'.
liftReadPrecCompat :: Read1 f => (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
liftReadPrecCompat :: (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
liftReadPrecCompat (ReadPrec a
readPrec', ReadPrec [a]
readList') =
#if MIN_VERSION_base(4,10,0)
    ReadPrec a -> ReadPrec [a] -> ReadPrec (f a)
forall (f :: * -> *) a.
Read1 f =>
ReadPrec a -> ReadPrec [a] -> ReadPrec (f a)
liftReadPrec ReadPrec a
readPrec' ReadPrec [a]
readList'
#else
    readS_to_Prec (liftReadsPrec (readPrec_to_S readPrec')
                                 (readPrec_to_S readList' 0))
#endif

data ReadPrecTree a where
  U1Leaf :: ReadPrecTree (U1 a)
  M1Leaf :: ReadPrec (f a) -> ReadPrecTree (M1 i c f a)
  Branch :: ReadPrecTree (f a) -> ReadPrecTree (g a) -> ReadPrecTree ((f :*: g) a)

toReadPrec :: ReadPrecTree a -> ReadPrec a
toReadPrec :: ReadPrecTree a -> ReadPrec a
toReadPrec ReadPrecTree a
U1Leaf       = U1 a -> ReadPrec (U1 a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 a
forall k (p :: k). U1 p
U1
toReadPrec (M1Leaf ReadPrec (f a)
f)   = ReadPrec (f a) -> ReadPrec (M1 i c f a)
forall (f :: * -> *) p i (c :: Meta).
ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerceM1 ReadPrec (f a)
f
toReadPrec (Branch ReadPrecTree (f a)
f ReadPrecTree (g a)
g) = f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (f a -> g a -> (:*:) f g a)
-> ReadPrec (f a) -> ReadPrec (g a -> (:*:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadPrecTree (f a) -> ReadPrec (f a)
forall a. ReadPrecTree a -> ReadPrec a
toReadPrec ReadPrecTree (f a)
f ReadPrec (g a -> (:*:) f g a)
-> ReadPrec (g a) -> ReadPrec ((:*:) f g a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadPrecTree (g a) -> ReadPrec (g a)
forall a. ReadPrecTree a -> ReadPrec a
toReadPrec ReadPrecTree (g a)
g

identHLexemes :: String -> [Lexeme]
identHLexemes :: String -> [Lexeme]
identHLexemes String
s | Just (String
ss, Char
'#') <- String -> Maybe (String, Char)
forall a. [a] -> Maybe ([a], a)
snocView String
s = [String -> Lexeme
Ident String
ss, String -> Lexeme
Symbol String
"#"]
                | Bool
otherwise                    = [String -> Lexeme
Ident String
s]

readPrefixCon :: String -> ReadPrec ()
readPrefixCon :: String -> ReadPrec ()
readPrefixCon String
name
  | String -> Bool
isSymDataCon String
name
  = Char -> ReadPrec () -> Char -> ReadPrec ()
forall a. Char -> ReadPrec a -> Char -> ReadPrec a
readSurround Char
'(' (Lexeme -> ReadPrec ()
expectP (String -> Lexeme
Symbol String
name)) Char
')'
  | Bool
otherwise
  = (Lexeme -> ReadPrec ()) -> [Lexeme] -> ReadPrec ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Lexeme -> ReadPrec ()
expectP (String -> [Lexeme]
identHLexemes String
name)

readSurround :: Char -> ReadPrec a -> Char -> ReadPrec a
readSurround :: Char -> ReadPrec a -> Char -> ReadPrec a
readSurround Char
c1 ReadPrec a
r Char
c2 = do
  Lexeme -> ReadPrec ()
expectP (String -> Lexeme
Punc [Char
c1])
  a
r' <- ReadPrec a
r
  Lexeme -> ReadPrec ()
expectP (String -> Lexeme
Punc [Char
c2])
  a -> ReadPrec a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r'

-- Split off the last element.
snocView :: [a] -> Maybe ([a], a)
snocView :: [a] -> Maybe ([a], a)
snocView [] = Maybe ([a], a)
forall a. Maybe a
Nothing
snocView [a]
xs = [a] -> [a] -> Maybe ([a], a)
forall a. [a] -> [a] -> Maybe ([a], a)
go [] [a]
xs
  where
    -- Invariant: second arg is non-empty
    go :: [a] -> [a] -> Maybe ([a], a)
go [a]
acc [a
a]    = ([a], a) -> Maybe ([a], a)
forall a. a -> Maybe a
Just ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
acc, a
a)
    go [a]
acc (a
a:[a]
as) = [a] -> [a] -> Maybe ([a], a)
go (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
acc) [a]
as
    go [a]
_   []     = String -> Maybe ([a], a)
forall a. HasCallStack => String -> a
error String
"Util: snocView"