{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
module Text.Read.Deriving.Internal (
deriveRead
, deriveReadOptions
, makeReadsPrec
, makeReadPrec
, deriveRead1
, deriveRead1Options
#if defined(NEW_FUNCTOR_CLASSES)
, makeLiftReadsPrec
# if __GLASGOW_HASKELL__ >= 801
, makeLiftReadPrec
, makeReadPrec1
# endif
#endif
, makeReadsPrec1
#if defined(NEW_FUNCTOR_CLASSES)
, deriveRead2
, deriveRead2Options
, makeLiftReadsPrec2
# if __GLASGOW_HASKELL__ >= 801
, makeLiftReadPrec2
, makeReadPrec2
# endif
, makeReadsPrec2
#endif
, ReadOptions(..)
, defaultReadOptions
) where
import Data.Deriving.Internal
import Data.List (intersperse, partition)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import GHC.Show (appPrec, appPrec1)
import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
newtype ReadOptions = ReadOptions
{ ReadOptions -> Bool
useReadPrec :: Bool
} deriving (ReadOptions -> ReadOptions -> Bool
(ReadOptions -> ReadOptions -> Bool)
-> (ReadOptions -> ReadOptions -> Bool) -> Eq ReadOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReadOptions -> ReadOptions -> Bool
$c/= :: ReadOptions -> ReadOptions -> Bool
== :: ReadOptions -> ReadOptions -> Bool
$c== :: ReadOptions -> ReadOptions -> Bool
Eq, Eq ReadOptions
Eq ReadOptions =>
(ReadOptions -> ReadOptions -> Ordering)
-> (ReadOptions -> ReadOptions -> Bool)
-> (ReadOptions -> ReadOptions -> Bool)
-> (ReadOptions -> ReadOptions -> Bool)
-> (ReadOptions -> ReadOptions -> Bool)
-> (ReadOptions -> ReadOptions -> ReadOptions)
-> (ReadOptions -> ReadOptions -> ReadOptions)
-> Ord ReadOptions
ReadOptions -> ReadOptions -> Bool
ReadOptions -> ReadOptions -> Ordering
ReadOptions -> ReadOptions -> ReadOptions
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ReadOptions -> ReadOptions -> ReadOptions
$cmin :: ReadOptions -> ReadOptions -> ReadOptions
max :: ReadOptions -> ReadOptions -> ReadOptions
$cmax :: ReadOptions -> ReadOptions -> ReadOptions
>= :: ReadOptions -> ReadOptions -> Bool
$c>= :: ReadOptions -> ReadOptions -> Bool
> :: ReadOptions -> ReadOptions -> Bool
$c> :: ReadOptions -> ReadOptions -> Bool
<= :: ReadOptions -> ReadOptions -> Bool
$c<= :: ReadOptions -> ReadOptions -> Bool
< :: ReadOptions -> ReadOptions -> Bool
$c< :: ReadOptions -> ReadOptions -> Bool
compare :: ReadOptions -> ReadOptions -> Ordering
$ccompare :: ReadOptions -> ReadOptions -> Ordering
$cp1Ord :: Eq ReadOptions
Ord, ReadPrec [ReadOptions]
ReadPrec ReadOptions
Int -> ReadS ReadOptions
ReadS [ReadOptions]
(Int -> ReadS ReadOptions)
-> ReadS [ReadOptions]
-> ReadPrec ReadOptions
-> ReadPrec [ReadOptions]
-> Read ReadOptions
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ReadOptions]
$creadListPrec :: ReadPrec [ReadOptions]
readPrec :: ReadPrec ReadOptions
$creadPrec :: ReadPrec ReadOptions
readList :: ReadS [ReadOptions]
$creadList :: ReadS [ReadOptions]
readsPrec :: Int -> ReadS ReadOptions
$creadsPrec :: Int -> ReadS ReadOptions
Read, Int -> ReadOptions -> ShowS
[ReadOptions] -> ShowS
ReadOptions -> String
(Int -> ReadOptions -> ShowS)
-> (ReadOptions -> String)
-> ([ReadOptions] -> ShowS)
-> Show ReadOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReadOptions] -> ShowS
$cshowList :: [ReadOptions] -> ShowS
show :: ReadOptions -> String
$cshow :: ReadOptions -> String
showsPrec :: Int -> ReadOptions -> ShowS
$cshowsPrec :: Int -> ReadOptions -> ShowS
Show)
defaultReadOptions :: ReadOptions
defaultReadOptions :: ReadOptions
defaultReadOptions = ReadOptions :: Bool -> ReadOptions
ReadOptions { useReadPrec :: Bool
useReadPrec = Bool
True }
deriveRead :: Name -> Q [Dec]
deriveRead :: Name -> Q [Dec]
deriveRead = ReadOptions -> Name -> Q [Dec]
deriveReadOptions ReadOptions
defaultReadOptions
deriveReadOptions :: ReadOptions -> Name -> Q [Dec]
deriveReadOptions :: ReadOptions -> Name -> Q [Dec]
deriveReadOptions = ReadClass -> ReadOptions -> Name -> Q [Dec]
deriveReadClass ReadClass
Read
makeReadsPrec :: Name -> Q Exp
makeReadsPrec :: Name -> Q Exp
makeReadsPrec = ReadClass -> Bool -> Name -> Q Exp
makeReadPrecClass ReadClass
Read Bool
False
makeReadPrec :: Name -> Q Exp
makeReadPrec :: Name -> Q Exp
makeReadPrec = ReadClass -> Bool -> Name -> Q Exp
makeReadPrecClass ReadClass
Read Bool
True
deriveRead1 :: Name -> Q [Dec]
deriveRead1 :: Name -> Q [Dec]
deriveRead1 = ReadOptions -> Name -> Q [Dec]
deriveRead1Options ReadOptions
defaultReadOptions
deriveRead1Options :: ReadOptions -> Name -> Q [Dec]
deriveRead1Options :: ReadOptions -> Name -> Q [Dec]
deriveRead1Options = ReadClass -> ReadOptions -> Name -> Q [Dec]
deriveReadClass ReadClass
Read1
#if defined(NEW_FUNCTOR_CLASSES)
makeLiftReadsPrec :: Name -> Q Exp
makeLiftReadsPrec :: Name -> Q Exp
makeLiftReadsPrec = ReadClass -> Bool -> Name -> Q Exp
makeReadPrecClass ReadClass
Read1 Bool
False
# if __GLASGOW_HASKELL__ >= 801
makeLiftReadPrec :: Name -> Q Exp
makeLiftReadPrec :: Name -> Q Exp
makeLiftReadPrec = ReadClass -> Bool -> Name -> Q Exp
makeReadPrecClass ReadClass
Read1 Bool
True
makeReadPrec1 :: Name -> Q Exp
makeReadPrec1 :: Name -> Q Exp
makeReadPrec1 name :: Name
name = Name -> Q Exp
makeLiftReadPrec Name
name
Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
readPrecValName
Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
readListPrecValName
# endif
makeReadsPrec1 :: Name -> Q Exp
makeReadsPrec1 :: Name -> Q Exp
makeReadsPrec1 name :: Name
name = Name -> Q Exp
makeLiftReadsPrec Name
name
Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
readsPrecValName
Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
readListValName
#else
makeReadsPrec1 :: Name -> Q Exp
makeReadsPrec1 = makeReadPrecClass Read1 False
#endif
#if defined(NEW_FUNCTOR_CLASSES)
deriveRead2 :: Name -> Q [Dec]
deriveRead2 :: Name -> Q [Dec]
deriveRead2 = ReadOptions -> Name -> Q [Dec]
deriveRead2Options ReadOptions
defaultReadOptions
deriveRead2Options :: ReadOptions -> Name -> Q [Dec]
deriveRead2Options :: ReadOptions -> Name -> Q [Dec]
deriveRead2Options = ReadClass -> ReadOptions -> Name -> Q [Dec]
deriveReadClass ReadClass
Read2
makeLiftReadsPrec2 :: Name -> Q Exp
makeLiftReadsPrec2 :: Name -> Q Exp
makeLiftReadsPrec2 = ReadClass -> Bool -> Name -> Q Exp
makeReadPrecClass ReadClass
Read2 Bool
False
# if __GLASGOW_HASKELL__ >= 801
makeLiftReadPrec2 :: Name -> Q Exp
makeLiftReadPrec2 :: Name -> Q Exp
makeLiftReadPrec2 = ReadClass -> Bool -> Name -> Q Exp
makeReadPrecClass ReadClass
Read2 Bool
True
makeReadPrec2 :: Name -> Q Exp
makeReadPrec2 :: Name -> Q Exp
makeReadPrec2 name :: Name
name = Name -> Q Exp
makeLiftReadPrec2 Name
name
Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
readPrecValName
Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
readListPrecValName
Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
readPrecValName
Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
readListPrecValName
# endif
makeReadsPrec2 :: Name -> Q Exp
makeReadsPrec2 :: Name -> Q Exp
makeReadsPrec2 name :: Name
name = Name -> Q Exp
makeLiftReadsPrec2 Name
name
Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
readsPrecValName
Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
readListValName
Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
readsPrecValName
Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
readListValName
#endif
deriveReadClass :: ReadClass -> ReadOptions -> Name -> Q [Dec]
deriveReadClass :: ReadClass -> ReadOptions -> Name -> Q [Dec]
deriveReadClass rClass :: ReadClass
rClass opts :: ReadOptions
opts name :: Name
name = do
DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
case DatatypeInfo
info of
DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext = Cxt
ctxt
, datatypeName :: DatatypeInfo -> Name
datatypeName = Name
parentName
, datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
instTypes
, datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant = DatatypeVariant
variant
, datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons
} -> do
(instanceCxt :: Cxt
instanceCxt, instanceType :: Type
instanceType)
<- ReadClass -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance ReadClass
rClass Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
(Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD (Cxt -> CxtQ
forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
instanceCxt)
(Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceType)
(ReadClass -> ReadOptions -> Cxt -> [ConstructorInfo] -> [Q Dec]
readPrecDecs ReadClass
rClass ReadOptions
opts Cxt
instTypes [ConstructorInfo]
cons)
readPrecDecs :: ReadClass -> ReadOptions -> [Type] -> [ConstructorInfo] -> [Q Dec]
readPrecDecs :: ReadClass -> ReadOptions -> Cxt -> [ConstructorInfo] -> [Q Dec]
readPrecDecs rClass :: ReadClass
rClass opts :: ReadOptions
opts instTypes :: Cxt
instTypes cons :: [ConstructorInfo]
cons =
[ Name -> [ClauseQ] -> Q Dec
funD ((if Bool
defineReadPrec then ReadClass -> Name
readPrecName else ReadClass -> Name
readsPrecName) ReadClass
rClass)
[ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ ReadClass -> Bool -> Cxt -> [ConstructorInfo] -> Q Exp
makeReadForCons ReadClass
rClass Bool
defineReadPrec Cxt
instTypes [ConstructorInfo]
cons)
[]
]
] [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. [a] -> [a] -> [a]
++ if Bool
defineReadPrec
then [ Name -> [ClauseQ] -> Q Dec
funD (ReadClass -> Name
readListPrecName ReadClass
rClass)
[ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> (Name -> Q Exp) -> Name -> BodyQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Exp
varE (Name -> BodyQ) -> Name -> BodyQ
forall a b. (a -> b) -> a -> b
$ ReadClass -> Name
readListPrecDefaultName ReadClass
rClass)
[]
]
]
else []
where
defineReadPrec :: Bool
defineReadPrec :: Bool
defineReadPrec = ReadClass -> ReadOptions -> Bool
shouldDefineReadPrec ReadClass
rClass ReadOptions
opts
makeReadPrecClass :: ReadClass -> Bool -> Name -> Q Exp
makeReadPrecClass :: ReadClass -> Bool -> Name -> Q Exp
makeReadPrecClass rClass :: ReadClass
rClass urp :: Bool
urp name :: Name
name = do
DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
case DatatypeInfo
info of
DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext = Cxt
ctxt
, datatypeName :: DatatypeInfo -> Name
datatypeName = Name
parentName
, datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
instTypes
, datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant = DatatypeVariant
variant
, datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons
} -> do
ReadClass -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance ReadClass
rClass Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
Q (Cxt, Type) -> Q Exp -> Q Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadClass -> Bool -> Cxt -> [ConstructorInfo] -> Q Exp
makeReadForCons ReadClass
rClass Bool
urp Cxt
instTypes [ConstructorInfo]
cons
makeReadForCons :: ReadClass -> Bool -> [Type] -> [ConstructorInfo] -> Q Exp
makeReadForCons :: ReadClass -> Bool -> Cxt -> [ConstructorInfo] -> Q Exp
makeReadForCons rClass :: ReadClass
rClass urp :: Bool
urp instTypes :: Cxt
instTypes cons :: [ConstructorInfo]
cons = do
Name
p <- String -> Q Name
newName "p"
[Name]
rps <- String -> Int -> Q [Name]
newNameList "rp" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ ReadClass -> Int
forall a. ClassRep a => a -> Int
arity ReadClass
rClass
[Name]
rls <- String -> Int -> Q [Name]
newNameList "rl" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ ReadClass -> Int
forall a. ClassRep a => a -> Int
arity ReadClass
rClass
let rpls :: [(Name, Name)]
rpls = [Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
rps [Name]
rls
_rpsAndRls :: [Name]
_rpsAndRls = [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
interleave [Name]
rps [Name]
rls
lastTyVars :: [Name]
lastTyVars = (Type -> Name) -> Cxt -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName (Cxt -> [Name]) -> Cxt -> [Name]
forall a b. (a -> b) -> a -> b
$ Int -> Cxt -> Cxt
forall a. Int -> [a] -> [a]
drop (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
instTypes Int -> Int -> Int
forall a. Num a => a -> a -> a
- ReadClass -> Int
forall a. Enum a => a -> Int
fromEnum ReadClass
rClass) Cxt
instTypes
rplMap :: Map Name (OneOrTwoNames Two)
rplMap = [(Name, OneOrTwoNames Two)] -> Map Name (OneOrTwoNames Two)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, OneOrTwoNames Two)] -> Map Name (OneOrTwoNames Two))
-> [(Name, OneOrTwoNames Two)] -> Map Name (OneOrTwoNames Two)
forall a b. (a -> b) -> a -> b
$ (Name -> (Name, Name) -> (Name, OneOrTwoNames Two))
-> [Name] -> [(Name, Name)] -> [(Name, OneOrTwoNames Two)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\x :: Name
x (y :: Name
y, z :: Name
z) -> (Name
x, Name -> Name -> OneOrTwoNames Two
TwoNames Name
y Name
z)) [Name]
lastTyVars [(Name, Name)]
rpls
let nullaryCons, nonNullaryCons :: [ConstructorInfo]
(nullaryCons :: [ConstructorInfo]
nullaryCons, nonNullaryCons :: [ConstructorInfo]
nonNullaryCons) = (ConstructorInfo -> Bool)
-> [ConstructorInfo] -> ([ConstructorInfo], [ConstructorInfo])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ConstructorInfo -> Bool
isNullaryCon [ConstructorInfo]
cons
readConsExpr :: Q Exp
readConsExpr :: Q Exp
readConsExpr = do
[Exp]
readNonNullaryCons <- (ConstructorInfo -> Q Exp) -> [ConstructorInfo] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ReadClass
-> Bool -> Map Name (OneOrTwoNames Two) -> ConstructorInfo -> Q Exp
makeReadForCon ReadClass
rClass Bool
urp Map Name (OneOrTwoNames Two)
rplMap)
[ConstructorInfo]
nonNullaryCons
(Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Q Exp -> Q Exp -> Q Exp
mkAlt ([Q Exp]
readNullaryCons [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ (Exp -> Q Exp) -> [Exp] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [Exp]
readNonNullaryCons)
readNullaryCons :: [Q Exp]
readNullaryCons :: [Q Exp]
readNullaryCons = case [ConstructorInfo]
nullaryCons of
[] -> []
[con :: ConstructorInfo
con]
| Name -> String
nameBase (ConstructorInfo -> Name
constructorName ConstructorInfo
con) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "()"
-> [Name -> Q Exp
varE Name
parenValName Q Exp -> Q Exp -> Q Exp
`appE`
[Q Stmt] -> Q Exp -> Q Exp
mkDoStmts [] (Name -> Q Exp
varE Name
returnValName Q Exp -> Q Exp -> Q Exp
`appE` [Q Exp] -> Q Exp
tupE [])]
| Bool
otherwise -> [[Q Stmt] -> Q Exp -> Q Exp
mkDoStmts (ConstructorInfo -> [Q Stmt]
matchCon ConstructorInfo
con)
(Name -> [Exp] -> Q Exp
resultExpr (ConstructorInfo -> Name
constructorName ConstructorInfo
con) [])]
_ -> [Name -> Q Exp
varE Name
chooseValName Q Exp -> Q Exp -> Q Exp
`appE` [Q Exp] -> Q Exp
listE ((ConstructorInfo -> Q Exp) -> [ConstructorInfo] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map ConstructorInfo -> Q Exp
mkPair [ConstructorInfo]
nullaryCons)]
mkAlt :: Q Exp -> Q Exp -> Q Exp
mkAlt :: Q Exp -> Q Exp -> Q Exp
mkAlt e1 :: Q Exp
e1 e2 :: Q Exp
e2 = Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp Q Exp
e1 (Name -> Q Exp
varE Name
altValName) Q Exp
e2
mkPair :: ConstructorInfo -> Q Exp
mkPair :: ConstructorInfo -> Q Exp
mkPair con :: ConstructorInfo
con = [Q Exp] -> Q Exp
tupE [ String -> Q Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> String
dataConStr ConstructorInfo
con
, Name -> [Exp] -> Q Exp
resultExpr (ConstructorInfo -> Name
constructorName ConstructorInfo
con) []
]
matchCon :: ConstructorInfo -> [Q Stmt]
matchCon :: ConstructorInfo -> [Q Stmt]
matchCon con :: ConstructorInfo
con
| String -> Bool
isSym String
conStr = [String -> Q Stmt
symbolPat String
conStr]
| Bool
otherwise = String -> [Q Stmt]
identHPat String
conStr
where
conStr :: String
conStr = ConstructorInfo -> String
dataConStr ConstructorInfo
con
mainRhsExpr :: Q Exp
mainRhsExpr :: Q Exp
mainRhsExpr
| [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons = Name -> Q Exp
varE Name
pfailValName
| Bool
otherwise = Name -> Q Exp
varE Name
parensValName Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
readConsExpr
[PatQ] -> Q Exp -> Q Exp
lamE ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP ([Name] -> [PatQ]) -> [Name] -> [PatQ]
forall a b. (a -> b) -> a -> b
$
#if defined(NEW_FUNCTOR_CLASSES)
[Name]
_rpsAndRls [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++
#endif
if Bool
urp then [] else [Name
p]
) (Q Exp -> Q Exp) -> ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Exp] -> Q Exp
appsE
([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [ Name -> Q Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ (if Bool
urp then ReadClass -> Name
readPrecConstName else ReadClass -> Name
readsPrecConstName) ReadClass
rClass
, if Bool
urp
then Q Exp
mainRhsExpr
else Name -> Q Exp
varE Name
readPrec_to_SValName Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
mainRhsExpr Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
p
]
#if defined(NEW_FUNCTOR_CLASSES)
[Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
varE [Name]
_rpsAndRls
#endif
[Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ if Bool
urp then [] else [Name -> Q Exp
varE Name
p]
makeReadForCon :: ReadClass
-> Bool
-> TyVarMap2
-> ConstructorInfo
-> Q Exp
makeReadForCon :: ReadClass
-> Bool -> Map Name (OneOrTwoNames Two) -> ConstructorInfo -> Q Exp
makeReadForCon rClass :: ReadClass
rClass urp :: Bool
urp tvMap :: Map Name (OneOrTwoNames Two)
tvMap
(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
conName
, constructorContext :: ConstructorInfo -> Cxt
constructorContext = Cxt
ctxt
, constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
NormalConstructor
, constructorFields :: ConstructorInfo -> Cxt
constructorFields = Cxt
argTys }) = do
Cxt
argTys' <- (Type -> TypeQ) -> Cxt -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TypeQ
resolveTypeSynonyms Cxt
argTys
[Name]
args <- String -> Int -> Q [Name]
newNameList "arg" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
argTys'
let conStr :: String
conStr = Name -> String
nameBase Name
conName
isTup :: Bool
isTup = String -> Bool
isNonUnitTupleString String
conStr
(readStmts :: [Q Stmt]
readStmts, varExps :: [Exp]
varExps) <-
(Type -> Name -> Q (Q Stmt, Exp))
-> Cxt -> [Name] -> Q ([Q Stmt], [Exp])
forall (m :: * -> *) a b c d.
Monad m =>
(a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d])
zipWithAndUnzipM (ReadClass
-> Bool
-> Bool
-> Map Name (OneOrTwoNames Two)
-> Name
-> Type
-> Name
-> Q (Q Stmt, Exp)
makeReadForArg ReadClass
rClass Bool
isTup Bool
urp Map Name (OneOrTwoNames Two)
tvMap Name
conName) Cxt
argTys' [Name]
args
let body :: Q Exp
body = Name -> [Exp] -> Q Exp
resultExpr Name
conName [Exp]
varExps
ReadClass
-> Map Name (OneOrTwoNames Two) -> Cxt -> Name -> Q Exp -> Q Exp
forall a b c.
ClassRep a =>
a -> TyVarMap b -> Cxt -> Name -> Q c -> Q c
checkExistentialContext ReadClass
rClass Map Name (OneOrTwoNames Two)
tvMap Cxt
ctxt Name
conName (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
if Bool
isTup
then let tupleStmts :: [Q Stmt]
tupleStmts = Q Stmt -> [Q Stmt] -> [Q Stmt]
forall a. a -> [a] -> [a]
intersperse (String -> Q Stmt
readPunc ",") [Q Stmt]
readStmts
in Name -> Q Exp
varE Name
parenValName Q Exp -> Q Exp -> Q Exp
`appE` [Q Stmt] -> Q Exp -> Q Exp
mkDoStmts [Q Stmt]
tupleStmts Q Exp
body
else let prefixStmts :: [Q Stmt]
prefixStmts = String -> [Q Stmt]
readPrefixCon String
conStr [Q Stmt] -> [Q Stmt] -> [Q Stmt]
forall a. [a] -> [a] -> [a]
++ [Q Stmt]
readStmts
in Int -> [Q Stmt] -> Q Exp -> Q Exp
mkParser Int
appPrec [Q Stmt]
prefixStmts Q Exp
body
makeReadForCon rClass :: ReadClass
rClass urp :: Bool
urp tvMap :: Map Name (OneOrTwoNames Two)
tvMap
(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
conName
, constructorContext :: ConstructorInfo -> Cxt
constructorContext = Cxt
ctxt
, constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = RecordConstructor argNames :: [Name]
argNames
, constructorFields :: ConstructorInfo -> Cxt
constructorFields = Cxt
argTys }) = do
Cxt
argTys' <- (Type -> TypeQ) -> Cxt -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TypeQ
resolveTypeSynonyms Cxt
argTys
[Name]
args <- String -> Int -> Q [Name]
newNameList "arg" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
argTys'
(readStmts :: [[Q Stmt]]
readStmts, varExps :: [Exp]
varExps) <- (Name -> Type -> Name -> Q ([Q Stmt], Exp))
-> [Name] -> Cxt -> [Name] -> Q ([[Q Stmt]], [Exp])
forall (m :: * -> *) a b c d e.
Monad m =>
(a -> b -> c -> m (d, e)) -> [a] -> [b] -> [c] -> m ([d], [e])
zipWith3AndUnzipM
(\argName :: Name
argName argTy :: Type
argTy arg :: Name
arg -> ReadClass
-> Bool
-> Map Name (OneOrTwoNames Two)
-> Name
-> String
-> Type
-> Name
-> Q ([Q Stmt], Exp)
makeReadForField ReadClass
rClass Bool
urp Map Name (OneOrTwoNames Two)
tvMap Name
conName
(Name -> String
nameBase Name
argName) Type
argTy Name
arg)
[Name]
argNames Cxt
argTys' [Name]
args
let body :: Q Exp
body = Name -> [Exp] -> Q Exp
resultExpr Name
conName [Exp]
varExps
conStr :: String
conStr = Name -> String
nameBase Name
conName
recordStmts :: [Q Stmt]
recordStmts = String -> [Q Stmt]
readPrefixCon String
conStr [Q Stmt] -> [Q Stmt] -> [Q Stmt]
forall a. [a] -> [a] -> [a]
++ [String -> Q Stmt
readPunc "{"]
[Q Stmt] -> [Q Stmt] -> [Q Stmt]
forall a. [a] -> [a] -> [a]
++ [[Q Stmt]] -> [Q Stmt]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Q Stmt] -> [[Q Stmt]] -> [[Q Stmt]]
forall a. a -> [a] -> [a]
intersperse [String -> Q Stmt
readPunc ","] [[Q Stmt]]
readStmts)
[Q Stmt] -> [Q Stmt] -> [Q Stmt]
forall a. [a] -> [a] -> [a]
++ [String -> Q Stmt
readPunc "}"]
ReadClass
-> Map Name (OneOrTwoNames Two) -> Cxt -> Name -> Q Exp -> Q Exp
forall a b c.
ClassRep a =>
a -> TyVarMap b -> Cxt -> Name -> Q c -> Q c
checkExistentialContext ReadClass
rClass Map Name (OneOrTwoNames Two)
tvMap Cxt
ctxt Name
conName (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
Int -> [Q Stmt] -> Q Exp -> Q Exp
mkParser Int
appPrec1 [Q Stmt]
recordStmts Q Exp
body
makeReadForCon rClass :: ReadClass
rClass urp :: Bool
urp tvMap :: Map Name (OneOrTwoNames Two)
tvMap
(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
conName
, constructorContext :: ConstructorInfo -> Cxt
constructorContext = Cxt
ctxt
, constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
InfixConstructor
, constructorFields :: ConstructorInfo -> Cxt
constructorFields = Cxt
argTys }) = do
[alTy :: Type
alTy, arTy :: Type
arTy] <- (Type -> TypeQ) -> Cxt -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TypeQ
resolveTypeSynonyms Cxt
argTys
Name
al <- String -> Q Name
newName "argL"
Name
ar <- String -> Q Name
newName "argR"
Fixity
fi <- Fixity -> Maybe Fixity -> Fixity
forall a. a -> Maybe a -> a
fromMaybe Fixity
defaultFixity (Maybe Fixity -> Fixity) -> Q (Maybe Fixity) -> Q Fixity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> Q (Maybe Fixity)
reifyFixityCompat Name
conName
([readStmt1 :: Q Stmt
readStmt1, readStmt2 :: Q Stmt
readStmt2], varExps :: [Exp]
varExps) <-
(Type -> Name -> Q (Q Stmt, Exp))
-> Cxt -> [Name] -> Q ([Q Stmt], [Exp])
forall (m :: * -> *) a b c d.
Monad m =>
(a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d])
zipWithAndUnzipM (ReadClass
-> Bool
-> Bool
-> Map Name (OneOrTwoNames Two)
-> Name
-> Type
-> Name
-> Q (Q Stmt, Exp)
makeReadForArg ReadClass
rClass Bool
False Bool
urp Map Name (OneOrTwoNames Two)
tvMap Name
conName)
[Type
alTy, Type
arTy] [Name
al, Name
ar]
let conPrec :: Int
conPrec = case Fixity
fi of Fixity prec :: Int
prec _ -> Int
prec
body :: Q Exp
body = Name -> [Exp] -> Q Exp
resultExpr Name
conName [Exp]
varExps
conStr :: String
conStr = Name -> String
nameBase Name
conName
readInfixCon :: [Q Stmt]
readInfixCon
| String -> Bool
isSym String
conStr = [String -> Q Stmt
symbolPat String
conStr]
| Bool
otherwise = [String -> Q Stmt
readPunc "`"] [Q Stmt] -> [Q Stmt] -> [Q Stmt]
forall a. [a] -> [a] -> [a]
++ String -> [Q Stmt]
identHPat String
conStr [Q Stmt] -> [Q Stmt] -> [Q Stmt]
forall a. [a] -> [a] -> [a]
++ [String -> Q Stmt
readPunc "`"]
infixStmts :: [Q Stmt]
infixStmts = [Q Stmt
readStmt1] [Q Stmt] -> [Q Stmt] -> [Q Stmt]
forall a. [a] -> [a] -> [a]
++ [Q Stmt]
readInfixCon [Q Stmt] -> [Q Stmt] -> [Q Stmt]
forall a. [a] -> [a] -> [a]
++ [Q Stmt
readStmt2]
ReadClass
-> Map Name (OneOrTwoNames Two) -> Cxt -> Name -> Q Exp -> Q Exp
forall a b c.
ClassRep a =>
a -> TyVarMap b -> Cxt -> Name -> Q c -> Q c
checkExistentialContext ReadClass
rClass Map Name (OneOrTwoNames Two)
tvMap Cxt
ctxt Name
conName (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
Int -> [Q Stmt] -> Q Exp -> Q Exp
mkParser Int
conPrec [Q Stmt]
infixStmts Q Exp
body
makeReadForArg :: ReadClass
-> Bool
-> Bool
-> TyVarMap2
-> Name
-> Type
-> Name
-> Q (Q Stmt, Exp)
makeReadForArg :: ReadClass
-> Bool
-> Bool
-> Map Name (OneOrTwoNames Two)
-> Name
-> Type
-> Name
-> Q (Q Stmt, Exp)
makeReadForArg rClass :: ReadClass
rClass isTup :: Bool
isTup urp :: Bool
urp tvMap :: Map Name (OneOrTwoNames Two)
tvMap conName :: Name
conName ty :: Type
ty tyExpName :: Name
tyExpName = do
(rExp :: Exp
rExp, varExp :: Exp
varExp) <- ReadClass
-> Bool
-> Map Name (OneOrTwoNames Two)
-> Name
-> Name
-> Bool
-> Type
-> Q (Exp, Exp)
makeReadForType ReadClass
rClass Bool
urp Map Name (OneOrTwoNames Two)
tvMap Name
conName Name
tyExpName Bool
False Type
ty
let readStmt :: Q Stmt
readStmt = PatQ -> Q Exp -> Q Stmt
bindS (Name -> PatQ
varP Name
tyExpName) (Q Exp -> Q Stmt) -> Q Exp -> Q Stmt
forall a b. (a -> b) -> a -> b
$
(if (Bool -> Bool
not Bool
isTup) then Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
stepValName) else Q Exp -> Q Exp
forall a. a -> a
id) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
Bool -> Q Exp -> Q Exp
wrapReadS Bool
urp (Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
rExp)
(Q Stmt, Exp) -> Q (Q Stmt, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Q Stmt
readStmt, Exp
varExp)
makeReadForField :: ReadClass
-> Bool
-> TyVarMap2
-> Name
-> String
-> Type
-> Name
-> Q ([Q Stmt], Exp)
makeReadForField :: ReadClass
-> Bool
-> Map Name (OneOrTwoNames Two)
-> Name
-> String
-> Type
-> Name
-> Q ([Q Stmt], Exp)
makeReadForField rClass :: ReadClass
rClass urp :: Bool
urp tvMap :: Map Name (OneOrTwoNames Two)
tvMap conName :: Name
conName lblStr :: String
lblStr ty :: Type
ty tyExpName :: Name
tyExpName = do
(rExp :: Exp
rExp, varExp :: Exp
varExp) <- ReadClass
-> Bool
-> Map Name (OneOrTwoNames Two)
-> Name
-> Name
-> Bool
-> Type
-> Q (Exp, Exp)
makeReadForType ReadClass
rClass Bool
urp Map Name (OneOrTwoNames Two)
tvMap Name
conName Name
tyExpName Bool
False Type
ty
let readStmt :: Q Stmt
readStmt = PatQ -> Q Exp -> Q Stmt
bindS (Name -> PatQ
varP Name
tyExpName) (Q Exp -> Q Stmt) -> Q Exp -> Q Stmt
forall a b. (a -> b) -> a -> b
$
Q Exp
read_field Q Exp -> Q Exp -> Q Exp
`appE`
(Name -> Q Exp
varE Name
resetValName Q Exp -> Q Exp -> Q Exp
`appE` Bool -> Q Exp -> Q Exp
wrapReadS Bool
urp (Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
rExp))
([Q Stmt], Exp) -> Q ([Q Stmt], Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Q Stmt
readStmt], Exp
varExp)
where
mk_read_field :: Name -> String -> Q Exp
mk_read_field readFieldName :: Name
readFieldName lbl :: String
lbl
= Name -> Q Exp
varE Name
readFieldName Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
stringE String
lbl
read_field :: Q Exp
read_field
| String -> Bool
isSym String
lblStr
= Name -> String -> Q Exp
mk_read_field Name
readSymFieldValName String
lblStr
| Just (ss :: String
ss, '#') <- String -> Maybe (String, Char)
forall a. [a] -> Maybe ([a], a)
snocView String
lblStr
= Name -> String -> Q Exp
mk_read_field Name
readFieldHashValName String
ss
| Bool
otherwise
= Name -> String -> Q Exp
mk_read_field Name
readFieldValName String
lblStr
makeReadForType :: ReadClass
-> Bool
-> TyVarMap2
-> Name
-> Name
-> Bool
-> Type
-> Q (Exp, Exp)
#if defined(NEW_FUNCTOR_CLASSES)
makeReadForType :: ReadClass
-> Bool
-> Map Name (OneOrTwoNames Two)
-> Name
-> Name
-> Bool
-> Type
-> Q (Exp, Exp)
makeReadForType _ urp :: Bool
urp tvMap :: Map Name (OneOrTwoNames Two)
tvMap _ tyExpName :: Name
tyExpName rl :: Bool
rl (VarT tyName :: Name
tyName) =
let tyExp :: Exp
tyExp = Name -> Exp
VarE Name
tyExpName
in (Exp, Exp) -> Q (Exp, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Exp, Exp) -> Q (Exp, Exp)) -> (Exp, Exp) -> Q (Exp, Exp)
forall a b. (a -> b) -> a -> b
$ case Name -> Map Name (OneOrTwoNames Two) -> Maybe (OneOrTwoNames Two)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
tyName Map Name (OneOrTwoNames Two)
tvMap of
Just (TwoNames rpExp :: Name
rpExp rlExp :: Name
rlExp) -> (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ if Bool
rl then Name
rlExp else Name
rpExp, Exp
tyExp)
Nothing -> (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> ReadClass -> Name
readsOrReadName Bool
urp Bool
rl ReadClass
Read, Exp
tyExp)
#else
makeReadForType _ urp _ _ tyExpName _ VarT{} =
return (VarE $ readsOrReadName urp False Read, VarE tyExpName)
#endif
makeReadForType rClass :: ReadClass
rClass urp :: Bool
urp tvMap :: Map Name (OneOrTwoNames Two)
tvMap conName :: Name
conName tyExpName :: Name
tyExpName rl :: Bool
rl (SigT ty :: Type
ty _) =
ReadClass
-> Bool
-> Map Name (OneOrTwoNames Two)
-> Name
-> Name
-> Bool
-> Type
-> Q (Exp, Exp)
makeReadForType ReadClass
rClass Bool
urp Map Name (OneOrTwoNames Two)
tvMap Name
conName Name
tyExpName Bool
rl Type
ty
makeReadForType rClass :: ReadClass
rClass urp :: Bool
urp tvMap :: Map Name (OneOrTwoNames Two)
tvMap conName :: Name
conName tyExpName :: Name
tyExpName rl :: Bool
rl (ForallT _ _ ty :: Type
ty) =
ReadClass
-> Bool
-> Map Name (OneOrTwoNames Two)
-> Name
-> Name
-> Bool
-> Type
-> Q (Exp, Exp)
makeReadForType ReadClass
rClass Bool
urp Map Name (OneOrTwoNames Two)
tvMap Name
conName Name
tyExpName Bool
rl Type
ty
#if defined(NEW_FUNCTOR_CLASSES)
makeReadForType rClass :: ReadClass
rClass urp :: Bool
urp tvMap :: Map Name (OneOrTwoNames Two)
tvMap conName :: Name
conName tyExpName :: Name
tyExpName rl :: Bool
rl ty :: Type
ty = do
let tyCon :: Type
tyArgs :: [Type]
tyCon :: Type
tyCon:tyArgs :: Cxt
tyArgs = Type -> Cxt
unapplyTy Type
ty
numLastArgs :: Int
numLastArgs :: Int
numLastArgs = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (ReadClass -> Int
forall a. ClassRep a => a -> Int
arity ReadClass
rClass) (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tyArgs)
lhsArgs, rhsArgs :: [Type]
(lhsArgs :: Cxt
lhsArgs, rhsArgs :: Cxt
rhsArgs) = Int -> Cxt -> (Cxt, Cxt)
forall a. Int -> [a] -> ([a], [a])
splitAt (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tyArgs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numLastArgs) Cxt
tyArgs
tyVarNames :: [Name]
tyVarNames :: [Name]
tyVarNames = Map Name (OneOrTwoNames Two) -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name (OneOrTwoNames Two)
tvMap
Bool
itf <- Type -> Q Bool
isTyFamily Type
tyCon
if (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
lhsArgs
Bool -> Bool -> Bool
|| Bool
itf Bool -> Bool -> Bool
&& (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
tyArgs
then ReadClass -> Name -> Q (Exp, Exp)
forall a b. ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError ReadClass
rClass Name
conName
else if (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
rhsArgs
then do
Exp
readExp <- [Q Exp] -> Q Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [ Name -> Q Exp
varE (Name -> Q Exp) -> (ReadClass -> Name) -> ReadClass -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool -> ReadClass -> Name
readsOrReadName Bool
urp Bool
rl (ReadClass -> Q Exp) -> ReadClass -> Q Exp
forall a b. (a -> b) -> a -> b
$ Int -> ReadClass
forall a. Enum a => Int -> a
toEnum Int
numLastArgs]
[Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ (Bool -> Type -> Q Exp) -> [Bool] -> Cxt -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\b :: Bool
b -> ((Exp, Exp) -> Exp) -> Q (Exp, Exp) -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Exp, Exp) -> Exp
forall a b. (a, b) -> a
fst
(Q (Exp, Exp) -> Q Exp) -> (Type -> Q (Exp, Exp)) -> Type -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadClass
-> Bool
-> Map Name (OneOrTwoNames Two)
-> Name
-> Name
-> Bool
-> Type
-> Q (Exp, Exp)
makeReadForType ReadClass
rClass Bool
urp Map Name (OneOrTwoNames Two)
tvMap Name
conName Name
tyExpName Bool
b)
([Bool] -> [Bool]
forall a. [a] -> [a]
cycle [Bool
False,Bool
True])
(Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
interleave Cxt
rhsArgs Cxt
rhsArgs)
(Exp, Exp) -> Q (Exp, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
readExp, Name -> Exp
VarE Name
tyExpName)
else (Exp, Exp) -> Q (Exp, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> ReadClass -> Name
readsOrReadName Bool
urp Bool
rl ReadClass
Read, Name -> Exp
VarE Name
tyExpName)
#else
makeReadForType rClass urp tvMap conName tyExpName _ ty = do
let varNames = Map.keys tvMap
rpExpr = VarE $ readsOrReadName urp False Read
rp1Expr = VarE $ readsOrReadName urp False Read1
tyExpr = VarE tyExpName
case varNames of
[] -> return (rpExpr, tyExpr)
varName:_ -> do
if mentionsName ty varNames
then do
applyExp <- makeFmapApplyPos rClass conName ty varName
return (rp1Expr, applyExp `AppE` tyExpr)
else return (rpExpr, tyExpr)
#endif
data ReadClass = Read
| Read1
#if defined(NEW_FUNCTOR_CLASSES)
| Read2
#endif
deriving (ReadClass
ReadClass -> ReadClass -> Bounded ReadClass
forall a. a -> a -> Bounded a
maxBound :: ReadClass
$cmaxBound :: ReadClass
minBound :: ReadClass
$cminBound :: ReadClass
Bounded, Int -> ReadClass
ReadClass -> Int
ReadClass -> [ReadClass]
ReadClass -> ReadClass
ReadClass -> ReadClass -> [ReadClass]
ReadClass -> ReadClass -> ReadClass -> [ReadClass]
(ReadClass -> ReadClass)
-> (ReadClass -> ReadClass)
-> (Int -> ReadClass)
-> (ReadClass -> Int)
-> (ReadClass -> [ReadClass])
-> (ReadClass -> ReadClass -> [ReadClass])
-> (ReadClass -> ReadClass -> [ReadClass])
-> (ReadClass -> ReadClass -> ReadClass -> [ReadClass])
-> Enum ReadClass
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ReadClass -> ReadClass -> ReadClass -> [ReadClass]
$cenumFromThenTo :: ReadClass -> ReadClass -> ReadClass -> [ReadClass]
enumFromTo :: ReadClass -> ReadClass -> [ReadClass]
$cenumFromTo :: ReadClass -> ReadClass -> [ReadClass]
enumFromThen :: ReadClass -> ReadClass -> [ReadClass]
$cenumFromThen :: ReadClass -> ReadClass -> [ReadClass]
enumFrom :: ReadClass -> [ReadClass]
$cenumFrom :: ReadClass -> [ReadClass]
fromEnum :: ReadClass -> Int
$cfromEnum :: ReadClass -> Int
toEnum :: Int -> ReadClass
$ctoEnum :: Int -> ReadClass
pred :: ReadClass -> ReadClass
$cpred :: ReadClass -> ReadClass
succ :: ReadClass -> ReadClass
$csucc :: ReadClass -> ReadClass
Enum)
instance ClassRep ReadClass where
arity :: ReadClass -> Int
arity = ReadClass -> Int
forall a. Enum a => a -> Int
fromEnum
allowExQuant :: ReadClass -> Bool
allowExQuant _ = Bool
False
fullClassName :: ReadClass -> Name
fullClassName Read = Name
readTypeName
fullClassName Read1 = Name
read1TypeName
#if defined(NEW_FUNCTOR_CLASSES)
fullClassName Read2 = Name
read2TypeName
#endif
classConstraint :: ReadClass -> Int -> Maybe Name
classConstraint rClass :: ReadClass
rClass i :: Int
i
| Int
rMin Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
rMax = Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ ReadClass -> Name
forall a. ClassRep a => a -> Name
fullClassName (Int -> ReadClass
forall a. Enum a => Int -> a
toEnum Int
i :: ReadClass)
| Bool
otherwise = Maybe Name
forall a. Maybe a
Nothing
where
rMin, rMax :: Int
rMin :: Int
rMin = ReadClass -> Int
forall a. Enum a => a -> Int
fromEnum (ReadClass
forall a. Bounded a => a
minBound :: ReadClass)
rMax :: Int
rMax = ReadClass -> Int
forall a. Enum a => a -> Int
fromEnum ReadClass
rClass
readsPrecConstName :: ReadClass -> Name
readsPrecConstName :: ReadClass -> Name
readsPrecConstName Read = Name
readsPrecConstValName
#if defined(NEW_FUNCTOR_CLASSES)
readsPrecConstName Read1 = Name
liftReadsPrecConstValName
readsPrecConstName Read2 = Name
liftReadsPrec2ConstValName
#else
readsPrecConstName Read1 = readsPrec1ConstValName
#endif
readPrecConstName :: ReadClass -> Name
readPrecConstName :: ReadClass -> Name
readPrecConstName Read = Name
readPrecConstValName
readPrecConstName Read1 = Name
liftReadPrecConstValName
#if defined(NEW_FUNCTOR_CLASSES)
readPrecConstName Read2 = Name
liftReadPrec2ConstValName
#endif
readsPrecName :: ReadClass -> Name
readsPrecName :: ReadClass -> Name
readsPrecName Read = Name
readsPrecValName
#if defined(NEW_FUNCTOR_CLASSES)
readsPrecName Read1 = Name
liftReadsPrecValName
readsPrecName Read2 = Name
liftReadsPrec2ValName
#else
readsPrecName Read1 = readsPrec1ValName
#endif
readPrecName :: ReadClass -> Name
readPrecName :: ReadClass -> Name
readPrecName Read = Name
readPrecValName
readPrecName Read1 = Name
liftReadPrecValName
#if defined(NEW_FUNCTOR_CLASSES)
readPrecName Read2 = Name
liftReadPrec2ValName
#endif
readListPrecDefaultName :: ReadClass -> Name
readListPrecDefaultName :: ReadClass -> Name
readListPrecDefaultName Read = Name
readListPrecDefaultValName
readListPrecDefaultName Read1 = Name
liftReadListPrecDefaultValName
#if defined(NEW_FUNCTOR_CLASSES)
readListPrecDefaultName Read2 = Name
liftReadListPrec2DefaultValName
#endif
readListPrecName :: ReadClass -> Name
readListPrecName :: ReadClass -> Name
readListPrecName Read = Name
readListPrecValName
readListPrecName Read1 = Name
liftReadListPrecValName
#if defined(NEW_FUNCTOR_CLASSES)
readListPrecName Read2 = Name
liftReadListPrec2ValName
#endif
readListName :: ReadClass -> Name
readListName :: ReadClass -> Name
readListName Read = Name
readListValName
#if defined(NEW_FUNCTOR_CLASSES)
readListName Read1 = Name
liftReadListValName
readListName Read2 = Name
liftReadList2ValName
#else
readListName Read1 = error "Text.Read.Deriving.Internal.readListName"
#endif
readsPrecOrListName :: Bool
-> ReadClass
-> Name
readsPrecOrListName :: Bool -> ReadClass -> Name
readsPrecOrListName False = ReadClass -> Name
readsPrecName
readsPrecOrListName True = ReadClass -> Name
readListName
readPrecOrListName :: Bool
-> ReadClass
-> Name
readPrecOrListName :: Bool -> ReadClass -> Name
readPrecOrListName False = ReadClass -> Name
readPrecName
readPrecOrListName True = ReadClass -> Name
readListPrecName
readsOrReadName :: Bool
-> Bool
-> ReadClass
-> Name
readsOrReadName :: Bool -> Bool -> ReadClass -> Name
readsOrReadName False = Bool -> ReadClass -> Name
readsPrecOrListName
readsOrReadName True = Bool -> ReadClass -> Name
readPrecOrListName
mkParser :: Int -> [Q Stmt] -> Q Exp -> Q Exp
mkParser :: Int -> [Q Stmt] -> Q Exp -> Q Exp
mkParser p :: Int
p ss :: [Q Stmt]
ss b :: Q Exp
b = Name -> Q Exp
varE Name
precValName Q Exp -> Q Exp -> Q Exp
`appE` Int -> Q Exp
integerE Int
p Q Exp -> Q Exp -> Q Exp
`appE` [Q Stmt] -> Q Exp -> Q Exp
mkDoStmts [Q Stmt]
ss Q Exp
b
mkDoStmts :: [Q Stmt] -> Q Exp -> Q Exp
mkDoStmts :: [Q Stmt] -> Q Exp -> Q Exp
mkDoStmts ss :: [Q Stmt]
ss b :: Q Exp
b = [Q Stmt] -> Q Exp
doE ([Q Stmt]
ss [Q Stmt] -> [Q Stmt] -> [Q Stmt]
forall a. [a] -> [a] -> [a]
++ [Q Exp -> Q Stmt
noBindS Q Exp
b])
resultExpr :: Name -> [Exp] -> Q Exp
resultExpr :: Name -> [Exp] -> Q Exp
resultExpr conName :: Name
conName as :: [Exp]
as = Name -> Q Exp
varE Name
returnValName Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
conApp
where
conApp :: Q Exp
conApp :: Q Exp
conApp = [Q Exp] -> Q Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
conE Name
conName Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: (Exp -> Q Exp) -> [Exp] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [Exp]
as
identHPat :: String -> [Q Stmt]
identHPat :: String -> [Q Stmt]
identHPat s :: String
s
| Just (ss :: String
ss, '#') <- String -> Maybe (String, Char)
forall a. [a] -> Maybe ([a], a)
snocView String
s = [String -> Q Stmt
identPat String
ss, String -> Q Stmt
symbolPat "#"]
| Bool
otherwise = [String -> Q Stmt
identPat String
s]
bindLex :: Q Exp -> Q Stmt
bindLex :: Q Exp -> Q Stmt
bindLex pat :: Q Exp
pat = Q Exp -> Q Stmt
noBindS (Q Exp -> Q Stmt) -> Q Exp -> Q Stmt
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE Name
expectPValName Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
pat
identPat :: String -> Q Stmt
identPat :: String -> Q Stmt
identPat s :: String
s = Q Exp -> Q Stmt
bindLex (Q Exp -> Q Stmt) -> Q Exp -> Q Stmt
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
conE Name
identDataName Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
stringE String
s
symbolPat :: String -> Q Stmt
symbolPat :: String -> Q Stmt
symbolPat s :: String
s = Q Exp -> Q Stmt
bindLex (Q Exp -> Q Stmt) -> Q Exp -> Q Stmt
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
conE Name
symbolDataName Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
stringE String
s
readPunc :: String -> Q Stmt
readPunc :: String -> Q Stmt
readPunc c :: String
c = Q Exp -> Q Stmt
bindLex (Q Exp -> Q Stmt) -> Q Exp -> Q Stmt
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
conE Name
puncDataName Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
stringE String
c
snocView :: [a] -> Maybe ([a],a)
snocView :: [a] -> Maybe ([a], a)
snocView [] = Maybe ([a], a)
forall a. Maybe a
Nothing
snocView xs :: [a]
xs = [a] -> [a] -> Maybe ([a], a)
forall a. [a] -> [a] -> Maybe ([a], a)
go [] [a]
xs
where
go :: [a] -> [a] -> Maybe ([a], a)
go acc :: [a]
acc [a :: 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 acc :: [a]
acc (a :: a
a:as :: [a]
as) = [a] -> [a] -> Maybe ([a], a)
go (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
acc) [a]
as
go _ [] = String -> Maybe ([a], a)
forall a. HasCallStack => String -> a
error "Util: snocView"
dataConStr :: ConstructorInfo -> String
dataConStr :: ConstructorInfo -> String
dataConStr = Name -> String
nameBase (Name -> String)
-> (ConstructorInfo -> Name) -> ConstructorInfo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorInfo -> Name
constructorName
readPrefixCon :: String -> [Q Stmt]
readPrefixCon :: String -> [Q Stmt]
readPrefixCon conStr :: String
conStr
| String -> Bool
isSym String
conStr = [String -> Q Stmt
readPunc "(", String -> Q Stmt
symbolPat String
conStr, String -> Q Stmt
readPunc ")"]
| Bool
otherwise = String -> [Q Stmt]
identHPat String
conStr
wrapReadS :: Bool -> Q Exp -> Q Exp
wrapReadS :: Bool -> Q Exp -> Q Exp
wrapReadS urp :: Bool
urp e :: Q Exp
e = if Bool
urp then Q Exp
e
else Name -> Q Exp
varE Name
readS_to_PrecValName Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
e
shouldDefineReadPrec :: ReadClass -> ReadOptions -> Bool
shouldDefineReadPrec :: ReadClass -> ReadOptions -> Bool
shouldDefineReadPrec rClass :: ReadClass
rClass opts :: ReadOptions
opts = ReadOptions -> Bool
useReadPrec ReadOptions
opts Bool -> Bool -> Bool
&& Bool
baseCompatible
where
base4'10OrLater :: Bool
#if __GLASGOW_HASKELL__ >= 801
base4'10OrLater :: Bool
base4'10OrLater = Bool
True
#else
base4'10OrLater = False
#endif
baseCompatible :: Bool
baseCompatible :: Bool
baseCompatible = case ReadClass
rClass of
Read -> Bool
True
Read1 -> Bool
base4'10OrLater
#if defined(NEW_FUNCTOR_CLASSES)
Read2 -> Bool
base4'10OrLater
#endif