{-# 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
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
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
Ord, ReadPrec [ReadOptions]
ReadPrec ReadOptions
Int -> ReadS ReadOptions
ReadS [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
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 { 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 -> Q Exp
makeLiftReadPrec Name
name
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
readPrecValName
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
readListPrecValName
# endif
makeReadsPrec1 :: Name -> Q Exp
makeReadsPrec1 :: Name -> Q Exp
makeReadsPrec1 Name
name = Name -> Q Exp
makeLiftReadsPrec Name
name
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
readsPrecValName
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m 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 -> Q Exp
makeLiftReadPrec2 Name
name
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
readPrecValName
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
readListPrecValName
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
readPrecValName
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
readListPrecValName
# endif
makeReadsPrec2 :: Name -> Q Exp
makeReadsPrec2 :: Name -> Q Exp
makeReadsPrec2 Name
name = Name -> Q Exp
makeLiftReadsPrec2 Name
name
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
readsPrecValName
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
readListValName
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
readsPrecValName
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
readListValName
#endif
deriveReadClass :: ReadClass -> ReadOptions -> Name -> Q [Dec]
deriveReadClass :: ReadClass -> ReadOptions -> Name -> Q [Dec]
deriveReadClass ReadClass
rClass ReadOptions
opts 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
(Cxt
instanceCxt, Type
instanceType)
<- forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance ReadClass
rClass Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
(forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
instanceCxt)
(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 ReadClass
rClass ReadOptions
opts Cxt
instTypes [ConstructorInfo]
cons =
[ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ((if Bool
defineReadPrec then ReadClass -> Name
readPrecName else ReadClass -> Name
readsPrecName) ReadClass
rClass)
[ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause []
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ ReadClass -> Bool -> Cxt -> [ConstructorInfo] -> Q Exp
makeReadForCons ReadClass
rClass Bool
defineReadPrec Cxt
instTypes [ConstructorInfo]
cons)
[]
]
] forall a. [a] -> [a] -> [a]
++ if Bool
defineReadPrec
then [ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (ReadClass -> Name
readListPrecName ReadClass
rClass)
[ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause []
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => Name -> m Exp
varE 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 ReadClass
rClass Bool
urp 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
forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance ReadClass
rClass Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
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 ReadClass
rClass Bool
urp Cxt
instTypes [ConstructorInfo]
cons = do
Name
p <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"p"
[Name]
rps <- String -> Int -> Q [Name]
newNameList String
"rp" forall a b. (a -> b) -> a -> b
$ forall a. ClassRep a => a -> Int
arity ReadClass
rClass
[Name]
rls <- String -> Int -> Q [Name]
newNameList String
"rl" forall a b. (a -> b) -> a -> b
$ forall a. ClassRep a => a -> Int
arity ReadClass
rClass
let rpls :: [(Name, Name)]
rpls = forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
rps [Name]
rls
_rpsAndRls :: [Name]
_rpsAndRls = forall a. [a] -> [a] -> [a]
interleave [Name]
rps [Name]
rls
lastTyVars :: [Name]
lastTyVars = forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
instTypes forall a. Num a => a -> a -> a
- forall a. Enum a => a -> Int
fromEnum ReadClass
rClass) Cxt
instTypes
rplMap :: Map Name (OneOrTwoNames Two)
rplMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Name
x (Name
y, Name
z) -> (Name
x, Name -> Name -> OneOrTwoNames Two
TwoNames Name
y Name
z)) [Name]
lastTyVars [(Name, Name)]
rpls
let nullaryCons, nonNullaryCons :: [ConstructorInfo]
([ConstructorInfo]
nullaryCons, [ConstructorInfo]
nonNullaryCons) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ConstructorInfo -> Bool
isNullaryCon [ConstructorInfo]
cons
readConsExpr :: Q Exp
readConsExpr :: Q Exp
readConsExpr = do
[Exp]
readNonNullaryCons <- 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
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Q Exp -> Q Exp -> Q Exp
mkAlt ([Q Exp]
readNullaryCons forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *) a. Monad m => a -> m a
return [Exp]
readNonNullaryCons)
readNullaryCons :: [Q Exp]
readNullaryCons :: [Q Exp]
readNullaryCons = case [ConstructorInfo]
nullaryCons of
[] -> []
[ConstructorInfo
con]
| Name -> String
nameBase (ConstructorInfo -> Name
constructorName ConstructorInfo
con) forall a. Eq a => a -> a -> Bool
== String
"()"
-> [forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
parenValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
[Q Stmt] -> Q Exp -> Q Exp
mkDoStmts [] (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
returnValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => [m Exp] -> m 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) [])]
[ConstructorInfo]
_ -> [forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
chooseValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE (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 Q Exp
e1 Q Exp
e2 = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp Q Exp
e1 (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
altValName) Q Exp
e2
mkPair :: ConstructorInfo -> Q Exp
mkPair :: ConstructorInfo -> Q Exp
mkPair ConstructorInfo
con = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE [ forall (m :: * -> *). Quote m => String -> m Exp
stringE 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 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
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
pfailValName
| Bool
otherwise = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
parensValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
readConsExpr
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP forall a b. (a -> b) -> a -> b
$
#if defined(NEW_FUNCTOR_CLASSES)
[Name]
_rpsAndRls forall a. [a] -> [a] -> [a]
++
#endif
if Bool
urp then [] else [Name
p]
) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE
forall a b. (a -> b) -> a -> b
$ [ forall (m :: * -> *). Quote m => Name -> m Exp
varE 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 forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
readPrec_to_SValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
mainRhsExpr forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
p
]
#if defined(NEW_FUNCTOR_CLASSES)
forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
_rpsAndRls
#endif
forall a. [a] -> [a] -> [a]
++ if Bool
urp then [] else [forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
p]
makeReadForCon :: ReadClass
-> Bool
-> TyVarMap2
-> ConstructorInfo
-> Q Exp
makeReadForCon :: ReadClass
-> Bool -> Map Name (OneOrTwoNames Two) -> ConstructorInfo -> Q Exp
makeReadForCon ReadClass
rClass Bool
urp 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' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveTypeSynonyms Cxt
argTys
[Name]
args <- String -> Int -> Q [Name]
newNameList String
"arg" forall a b. (a -> b) -> a -> b
$ 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
([Q Stmt]
readStmts, [Exp]
varExps) <-
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
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 forall a b. (a -> b) -> a -> b
$
if Bool
isTup
then let tupleStmts :: [Q Stmt]
tupleStmts = forall a. a -> [a] -> [a]
intersperse (String -> Q Stmt
readPunc String
",") [Q Stmt]
readStmts
in forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
parenValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m 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 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 ReadClass
rClass Bool
urp Map Name (OneOrTwoNames Two)
tvMap
(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
conName
, constructorContext :: ConstructorInfo -> Cxt
constructorContext = Cxt
ctxt
, constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = RecordConstructor [Name]
argNames
, constructorFields :: ConstructorInfo -> Cxt
constructorFields = Cxt
argTys }) = do
Cxt
argTys' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveTypeSynonyms Cxt
argTys
[Name]
args <- String -> Int -> Q [Name]
newNameList String
"arg" forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
argTys'
([[Q Stmt]]
readStmts, [Exp]
varExps) <- forall (m :: * -> *) a b c d e.
Monad m =>
(a -> b -> c -> m (d, e)) -> [a] -> [b] -> [c] -> m ([d], [e])
zipWith3AndUnzipM
(\Name
argName Type
argTy 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 forall a. [a] -> [a] -> [a]
++ [String -> Q Stmt
readPunc String
"{"]
forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. a -> [a] -> [a]
intersperse [String -> Q Stmt
readPunc String
","] [[Q Stmt]]
readStmts)
forall a. [a] -> [a] -> [a]
++ [String -> Q Stmt
readPunc String
"}"]
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 forall a b. (a -> b) -> a -> b
$
Int -> [Q Stmt] -> Q Exp -> Q Exp
mkParser Int
appPrec1 [Q Stmt]
recordStmts Q Exp
body
makeReadForCon ReadClass
rClass Bool
urp 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
[Type
alTy, Type
arTy] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveTypeSynonyms Cxt
argTys
Name
al <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"argL"
Name
ar <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"argR"
Fixity
fi <- forall a. a -> Maybe a -> a
fromMaybe Fixity
defaultFixity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> Q (Maybe Fixity)
reifyFixityCompat Name
conName
([Q Stmt
readStmt1, Q Stmt
readStmt2], [Exp]
varExps) <-
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 Int
prec FixityDirection
_ -> 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 String
"`"] forall a. [a] -> [a] -> [a]
++ String -> [Q Stmt]
identHPat String
conStr forall a. [a] -> [a] -> [a]
++ [String -> Q Stmt
readPunc String
"`"]
infixStmts :: [Q Stmt]
infixStmts = [Q Stmt
readStmt1] forall a. [a] -> [a] -> [a]
++ [Q Stmt]
readInfixCon forall a. [a] -> [a] -> [a]
++ [Q Stmt
readStmt2]
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 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 ReadClass
rClass Bool
isTup Bool
urp Map Name (OneOrTwoNames Two)
tvMap Name
conName Type
ty Name
tyExpName = do
(Exp
rExp, 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 = forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
bindS (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
tyExpName) forall a b. (a -> b) -> a -> b
$
(if (Bool -> Bool
not Bool
isTup) then forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
stepValName) else forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
Bool -> Q Exp -> Q Exp
wrapReadS Bool
urp (forall (m :: * -> *) a. Monad m => a -> m a
return Exp
rExp)
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 ReadClass
rClass Bool
urp Map Name (OneOrTwoNames Two)
tvMap Name
conName String
lblStr Type
ty Name
tyExpName = do
(Exp
rExp, 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 = forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
bindS (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
tyExpName) forall a b. (a -> b) -> a -> b
$
Q Exp
read_field forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
(forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
resetValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Bool -> Q Exp -> Q Exp
wrapReadS Bool
urp (forall (m :: * -> *) a. Monad m => a -> m a
return Exp
rExp))
forall (m :: * -> *) a. Monad m => a -> m a
return ([Q Stmt
readStmt], Exp
varExp)
where
mk_read_field :: Name -> String -> m Exp
mk_read_field Name
readFieldName String
lbl
= forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
readFieldName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => String -> m Exp
stringE String
lbl
read_field :: Q Exp
read_field
| String -> Bool
isSym String
lblStr
= forall {m :: * -> *}. Quote m => Name -> String -> m Exp
mk_read_field Name
readSymFieldValName String
lblStr
| Just (String
ss, Char
'#') <- forall a. [a] -> Maybe ([a], a)
snocView String
lblStr
= forall {m :: * -> *}. Quote m => Name -> String -> m Exp
mk_read_field Name
readFieldHashValName String
ss
| Bool
otherwise
= forall {m :: * -> *}. Quote m => Name -> String -> m 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 ReadClass
_ Bool
urp Map Name (OneOrTwoNames Two)
tvMap Name
_ Name
tyExpName Bool
rl (VarT Name
tyName) =
let tyExp :: Exp
tyExp = Name -> Exp
VarE Name
tyExpName
in forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
tyName Map Name (OneOrTwoNames Two)
tvMap of
Just (TwoNames Name
rpExp Name
rlExp) -> (Name -> Exp
VarE forall a b. (a -> b) -> a -> b
$ if Bool
rl then Name
rlExp else Name
rpExp, Exp
tyExp)
Maybe (OneOrTwoNames Two)
Nothing -> (Name -> Exp
VarE 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 ReadClass
rClass Bool
urp Map Name (OneOrTwoNames Two)
tvMap Name
conName Name
tyExpName Bool
rl (SigT Type
ty Type
_) =
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 ReadClass
rClass Bool
urp Map Name (OneOrTwoNames Two)
tvMap Name
conName Name
tyExpName Bool
rl (ForallT [TyVarBndr Specificity]
_ Cxt
_ 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 ReadClass
rClass Bool
urp Map Name (OneOrTwoNames Two)
tvMap Name
conName Name
tyExpName Bool
rl Type
ty = do
let tyCon :: Type
tyArgs :: [Type]
(Type
tyCon, Cxt
tyArgs) = Type -> (Type, Cxt)
unapplyTy Type
ty
numLastArgs :: Int
numLastArgs :: Int
numLastArgs = forall a. Ord a => a -> a -> a
min (forall a. ClassRep a => a -> Int
arity ReadClass
rClass) (forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tyArgs)
lhsArgs, rhsArgs :: [Type]
(Cxt
lhsArgs, Cxt
rhsArgs) = forall a. Int -> [a] -> ([a], [a])
splitAt (forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tyArgs forall a. Num a => a -> a -> a
- Int
numLastArgs) Cxt
tyArgs
tyVarNames :: [Name]
tyVarNames :: [Name]
tyVarNames = forall k a. Map k a -> [k]
Map.keys Map Name (OneOrTwoNames Two)
tvMap
Bool
itf <- [Name] -> Type -> Cxt -> Q Bool
isInTypeFamilyApp [Name]
tyVarNames Type
tyCon Cxt
tyArgs
if 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
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
tyArgs
then forall a b. ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError ReadClass
rClass Name
conName
else if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
rhsArgs
then do
Exp
readExp <- forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE forall a b. (a -> b) -> a -> b
$ [ forall (m :: * -> *). Quote m => Name -> m Exp
varE forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool -> ReadClass -> Name
readsOrReadName Bool
urp Bool
rl forall a b. (a -> b) -> a -> b
$ forall a. Enum a => Int -> a
toEnum Int
numLastArgs]
forall a. [a] -> [a] -> [a]
++ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Bool
b -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst
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)
(forall a. [a] -> [a]
cycle [Bool
False,Bool
True])
(forall a. [a] -> [a] -> [a]
interleave Cxt
rhsArgs Cxt
rhsArgs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
readExp, Name -> Exp
VarE Name
tyExpName)
else forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Exp
VarE 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
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]
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 = forall a. Enum a => a -> Int
fromEnum
allowExQuant :: ReadClass -> Bool
allowExQuant ReadClass
_ = Bool
False
fullClassName :: ReadClass -> Name
fullClassName ReadClass
Read = Name
readTypeName
fullClassName ReadClass
Read1 = Name
read1TypeName
#if defined(NEW_FUNCTOR_CLASSES)
fullClassName ReadClass
Read2 = Name
read2TypeName
#endif
classConstraint :: ReadClass -> Int -> Maybe Name
classConstraint ReadClass
rClass Int
i
| Int
rMin forall a. Ord a => a -> a -> Bool
<= Int
i Bool -> Bool -> Bool
&& Int
i forall a. Ord a => a -> a -> Bool
<= Int
rMax = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. ClassRep a => a -> Name
fullClassName (forall a. Enum a => Int -> a
toEnum Int
i :: ReadClass)
| Bool
otherwise = forall a. Maybe a
Nothing
where
rMin, rMax :: Int
rMin :: Int
rMin = forall a. Enum a => a -> Int
fromEnum (forall a. Bounded a => a
minBound :: ReadClass)
rMax :: Int
rMax = forall a. Enum a => a -> Int
fromEnum ReadClass
rClass
readsPrecConstName :: ReadClass -> Name
readsPrecConstName :: ReadClass -> Name
readsPrecConstName ReadClass
Read = Name
readsPrecConstValName
#if defined(NEW_FUNCTOR_CLASSES)
readsPrecConstName ReadClass
Read1 = Name
liftReadsPrecConstValName
readsPrecConstName ReadClass
Read2 = Name
liftReadsPrec2ConstValName
#else
readsPrecConstName Read1 = readsPrec1ConstValName
#endif
readPrecConstName :: ReadClass -> Name
readPrecConstName :: ReadClass -> Name
readPrecConstName ReadClass
Read = Name
readPrecConstValName
readPrecConstName ReadClass
Read1 = Name
liftReadPrecConstValName
#if defined(NEW_FUNCTOR_CLASSES)
readPrecConstName ReadClass
Read2 = Name
liftReadPrec2ConstValName
#endif
readsPrecName :: ReadClass -> Name
readsPrecName :: ReadClass -> Name
readsPrecName ReadClass
Read = Name
readsPrecValName
#if defined(NEW_FUNCTOR_CLASSES)
readsPrecName ReadClass
Read1 = Name
liftReadsPrecValName
readsPrecName ReadClass
Read2 = Name
liftReadsPrec2ValName
#else
readsPrecName Read1 = readsPrec1ValName
#endif
readPrecName :: ReadClass -> Name
readPrecName :: ReadClass -> Name
readPrecName ReadClass
Read = Name
readPrecValName
readPrecName ReadClass
Read1 = Name
liftReadPrecValName
#if defined(NEW_FUNCTOR_CLASSES)
readPrecName ReadClass
Read2 = Name
liftReadPrec2ValName
#endif
readListPrecDefaultName :: ReadClass -> Name
readListPrecDefaultName :: ReadClass -> Name
readListPrecDefaultName ReadClass
Read = Name
readListPrecDefaultValName
readListPrecDefaultName ReadClass
Read1 = Name
liftReadListPrecDefaultValName
#if defined(NEW_FUNCTOR_CLASSES)
readListPrecDefaultName ReadClass
Read2 = Name
liftReadListPrec2DefaultValName
#endif
readListPrecName :: ReadClass -> Name
readListPrecName :: ReadClass -> Name
readListPrecName ReadClass
Read = Name
readListPrecValName
readListPrecName ReadClass
Read1 = Name
liftReadListPrecValName
#if defined(NEW_FUNCTOR_CLASSES)
readListPrecName ReadClass
Read2 = Name
liftReadListPrec2ValName
#endif
readListName :: ReadClass -> Name
readListName :: ReadClass -> Name
readListName ReadClass
Read = Name
readListValName
#if defined(NEW_FUNCTOR_CLASSES)
readListName ReadClass
Read1 = Name
liftReadListValName
readListName ReadClass
Read2 = Name
liftReadList2ValName
#else
readListName Read1 = error "Text.Read.Deriving.Internal.readListName"
#endif
readsPrecOrListName :: Bool
-> ReadClass
-> Name
readsPrecOrListName :: Bool -> ReadClass -> Name
readsPrecOrListName Bool
False = ReadClass -> Name
readsPrecName
readsPrecOrListName Bool
True = ReadClass -> Name
readListName
readPrecOrListName :: Bool
-> ReadClass
-> Name
readPrecOrListName :: Bool -> ReadClass -> Name
readPrecOrListName Bool
False = ReadClass -> Name
readPrecName
readPrecOrListName Bool
True = ReadClass -> Name
readListPrecName
readsOrReadName :: Bool
-> Bool
-> ReadClass
-> Name
readsOrReadName :: Bool -> Bool -> ReadClass -> Name
readsOrReadName Bool
False = Bool -> ReadClass -> Name
readsPrecOrListName
readsOrReadName Bool
True = Bool -> ReadClass -> Name
readPrecOrListName
mkParser :: Int -> [Q Stmt] -> Q Exp -> Q Exp
mkParser :: Int -> [Q Stmt] -> Q Exp -> Q Exp
mkParser Int
p [Q Stmt]
ss Q Exp
b = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
precValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Q Exp
integerE Int
p forall (m :: * -> *). Quote m => m Exp -> m Exp -> m 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 [Q Stmt]
ss Q Exp
b = forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
doE ([Q Stmt]
ss forall a. [a] -> [a] -> [a]
++ [forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS Q Exp
b])
resultExpr :: Name -> [Exp] -> Q Exp
resultExpr :: Name -> [Exp] -> Q Exp
resultExpr Name
conName [Exp]
as = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
returnValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
conApp
where
conApp :: Q Exp
conApp :: Q Exp
conApp = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *) a. Monad m => a -> m a
return [Exp]
as
identHPat :: String -> [Q Stmt]
identHPat :: String -> [Q Stmt]
identHPat String
s
| Just (String
ss, Char
'#') <- forall a. [a] -> Maybe ([a], a)
snocView String
s = [String -> Q Stmt
identPat String
ss, String -> Q Stmt
symbolPat String
"#"]
| Bool
otherwise = [String -> Q Stmt
identPat String
s]
bindLex :: Q Exp -> Q Stmt
bindLex :: Q Exp -> Q Stmt
bindLex Q Exp
pat = forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
expectPValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
pat
identPat :: String -> Q Stmt
identPat :: String -> Q Stmt
identPat String
s = Q Exp -> Q Stmt
bindLex forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
identDataName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => String -> m Exp
stringE String
s
symbolPat :: String -> Q Stmt
symbolPat :: String -> Q Stmt
symbolPat String
s = Q Exp -> Q Stmt
bindLex forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
symbolDataName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => String -> m Exp
stringE String
s
readPunc :: String -> Q Stmt
readPunc :: String -> Q Stmt
readPunc String
c = Q Exp -> Q Stmt
bindLex forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
puncDataName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => String -> m Exp
stringE String
c
snocView :: [a] -> Maybe ([a],a)
snocView :: forall a. [a] -> Maybe ([a], a)
snocView [] = forall a. Maybe a
Nothing
snocView [a]
xs = forall {a}. [a] -> [a] -> Maybe ([a], a)
go [] [a]
xs
where
go :: [a] -> [a] -> Maybe ([a], a)
go [a]
acc [a
a] = forall a. a -> Maybe a
Just (forall a. [a] -> [a]
reverse [a]
acc, a
a)
go [a]
acc (a
a:[a]
as) = [a] -> [a] -> Maybe ([a], a)
go (a
aforall a. a -> [a] -> [a]
:[a]
acc) [a]
as
go [a]
_ [] = forall a. HasCallStack => String -> a
error String
"Util: snocView"
dataConStr :: ConstructorInfo -> String
dataConStr :: ConstructorInfo -> String
dataConStr = Name -> String
nameBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorInfo -> Name
constructorName
readPrefixCon :: String -> [Q Stmt]
readPrefixCon :: String -> [Q Stmt]
readPrefixCon String
conStr
| String -> Bool
isSym String
conStr = [String -> Q Stmt
readPunc String
"(", String -> Q Stmt
symbolPat String
conStr, String -> Q Stmt
readPunc String
")"]
| Bool
otherwise = String -> [Q Stmt]
identHPat String
conStr
wrapReadS :: Bool -> Q Exp -> Q Exp
wrapReadS :: Bool -> Q Exp -> Q Exp
wrapReadS Bool
urp Q Exp
e = if Bool
urp then Q Exp
e
else forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
readS_to_PrecValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
e
shouldDefineReadPrec :: ReadClass -> ReadOptions -> Bool
shouldDefineReadPrec :: ReadClass -> ReadOptions -> Bool
shouldDefineReadPrec ReadClass
rClass 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
ReadClass
Read -> Bool
True
ReadClass
Read1 -> Bool
base4'10OrLater
#if defined(NEW_FUNCTOR_CLASSES)
ReadClass
Read2 -> Bool
base4'10OrLater
#endif