{-# 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 -> 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 -> 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 -> 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 -> 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 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)
<- 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 ReadClass
rClass ReadOptions
opts Cxt
instTypes [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 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
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 ReadClass
rClass Bool
urp Cxt
instTypes [ConstructorInfo]
cons = do
Name
p <- String -> Q Name
newName String
"p"
[Name]
rps <- String -> Int -> Q [Name]
newNameList String
"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 String
"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 (\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) = (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
[] -> []
[ConstructorInfo
con]
| Name -> String
nameBase (ConstructorInfo -> Name
constructorName ConstructorInfo
con) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"()"
-> [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) [])]
[ConstructorInfo]
_ -> [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 Q Exp
e1 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 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 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 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' <- (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 String
"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
([Q Stmt]
readStmts, [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 String
",") [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 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' <- (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 String
"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'
([[Q Stmt]]
readStmts, [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
(\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 [Q Stmt] -> [Q Stmt] -> [Q Stmt]
forall a. [a] -> [a] -> [a]
++ [String -> Q Stmt
readPunc String
"{"]
[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 String
","] [[Q Stmt]]
readStmts)
[Q Stmt] -> [Q Stmt] -> [Q Stmt]
forall a. [a] -> [a] -> [a]
++ [String -> Q Stmt
readPunc String
"}"]
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 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] <- (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 String
"argL"
Name
ar <- String -> Q Name
newName String
"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
([Q Stmt
readStmt1, Q Stmt
readStmt2], [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 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
"`"] [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 String
"`"]
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 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 = 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 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 = 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 Name
readFieldName 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 (String
ss, Char
'#') <- 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 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 (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 Name
rpExp 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)
Maybe (OneOrTwoNames Two)
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 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]
_ 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 = 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]
(Cxt
lhsArgs, 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 <- [Name] -> Type -> Cxt -> Q Bool
isInTypeFamilyApp [Name]
tyVarNames Type
tyCon Cxt
tyArgs
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 (\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 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 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 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 = 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 [Q Stmt]
ss 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 Name
conName [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 String
s
| Just (String
ss, Char
'#') <- String -> Maybe (String, 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 = 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 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 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 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 [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 [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"
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 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 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 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