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
#if MIN_VERSION_template_haskell(2,11,0)
import Control.Monad ((<=<))
import Data.Maybe (fromMaybe, isJust)
#endif
import Data.Deriving.Internal
import Data.List (intersperse, partition)
import qualified Data.Map as Map
import GHC.Show (appPrec, appPrec1)
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
#if defined(MIN_VERSION_ghc_boot)
import GHC.Lexeme (startsConSym, startsVarSym)
#else
import Data.Char (isSymbol, ord)
#endif
newtype ReadOptions = ReadOptions
{ useReadPrec :: Bool
} deriving (Eq, Ord, Read, Show)
defaultReadOptions :: ReadOptions
defaultReadOptions = ReadOptions { useReadPrec = True }
deriveRead :: Name -> Q [Dec]
deriveRead = deriveReadOptions defaultReadOptions
deriveReadOptions :: ReadOptions -> Name -> Q [Dec]
deriveReadOptions = deriveReadClass Read
makeReadsPrec :: Name -> Q Exp
makeReadsPrec = makeReadPrecClass Read False
makeReadPrec :: Name -> Q Exp
makeReadPrec = makeReadPrecClass Read True
deriveRead1 :: Name -> Q [Dec]
deriveRead1 = deriveRead1Options defaultReadOptions
deriveRead1Options :: ReadOptions -> Name -> Q [Dec]
deriveRead1Options = deriveReadClass Read1
#if defined(NEW_FUNCTOR_CLASSES)
makeLiftReadsPrec :: Name -> Q Exp
makeLiftReadsPrec = makeReadPrecClass Read1 False
# if __GLASGOW_HASKELL__ >= 801
makeLiftReadPrec :: Name -> Q Exp
makeLiftReadPrec = makeReadPrecClass Read1 True
makeReadPrec1 :: Name -> Q Exp
makeReadPrec1 name = makeLiftReadPrec name
`appE` varE readPrecValName
`appE` varE readListPrecValName
# endif
makeReadsPrec1 :: Name -> Q Exp
makeReadsPrec1 name = makeLiftReadsPrec name
`appE` varE readsPrecValName
`appE` varE readListValName
#else
makeReadsPrec1 :: Name -> Q Exp
makeReadsPrec1 = makeReadPrecClass Read1 False
#endif
#if defined(NEW_FUNCTOR_CLASSES)
deriveRead2 :: Name -> Q [Dec]
deriveRead2 = deriveRead2Options defaultReadOptions
deriveRead2Options :: ReadOptions -> Name -> Q [Dec]
deriveRead2Options = deriveReadClass Read2
makeLiftReadsPrec2 :: Name -> Q Exp
makeLiftReadsPrec2 = makeReadPrecClass Read2 False
# if __GLASGOW_HASKELL__ >= 801
makeLiftReadPrec2 :: Name -> Q Exp
makeLiftReadPrec2 = makeReadPrecClass Read2 True
makeReadPrec2 :: Name -> Q Exp
makeReadPrec2 name = makeLiftReadPrec2 name
`appE` varE readPrecValName
`appE` varE readListPrecValName
`appE` varE readPrecValName
`appE` varE readListPrecValName
# endif
makeReadsPrec2 :: Name -> Q Exp
makeReadsPrec2 name = makeLiftReadsPrec2 name
`appE` varE readsPrecValName
`appE` varE readListValName
`appE` varE readsPrecValName
`appE` varE readListValName
#endif
deriveReadClass :: ReadClass -> ReadOptions -> Name -> Q [Dec]
deriveReadClass rClass opts name = withType name fromCons
where
fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec]
fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do
(instanceCxt, instanceType)
<- buildTypeInstance rClass name' ctxt tvbs mbTys
instanceD (return instanceCxt)
(return instanceType)
(readPrecDecs rClass opts cons)
readPrecDecs :: ReadClass -> ReadOptions -> [Con] -> [Q Dec]
readPrecDecs rClass opts cons =
[ funD ((if defineReadPrec then readPrecName else readsPrecName) rClass)
[ clause []
(normalB $ makeReadForCons rClass defineReadPrec cons)
[]
]
] ++ if defineReadPrec
then [ funD (readListPrecName rClass)
[ clause []
(normalB . varE $ readListPrecDefaultName rClass)
[]
]
]
else []
where
defineReadPrec :: Bool
defineReadPrec = shouldDefineReadPrec rClass opts
makeReadPrecClass :: ReadClass -> Bool -> Name -> Q Exp
makeReadPrecClass rClass urp name = withType name fromCons
where
fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp
fromCons name' ctxt tvbs cons mbTys =
buildTypeInstance rClass name' ctxt tvbs mbTys
`seq` makeReadForCons rClass urp cons
makeReadForCons :: ReadClass -> Bool -> [Con] -> Q Exp
makeReadForCons rClass urp cons = do
p <- newName "p"
rps <- newNameList "rp" $ arity rClass
rls <- newNameList "rl" $ arity rClass
let rpls = zip rps rls
_rpsAndRls = interleave rps rls
let nullaryCons, nonNullaryCons :: [Con]
(nullaryCons, nonNullaryCons) = partition isNullaryCon cons
readConsExpr :: Q Exp
readConsExpr
| null cons = varE pfailValName
| otherwise = do
readNonNullaryCons <- concatMapM (makeReadForCon rClass urp rpls)
nonNullaryCons
foldr1 mkAlt (readNullaryCons ++ map return readNonNullaryCons)
readNullaryCons :: [Q Exp]
readNullaryCons = case nullaryCons of
[] -> []
[con]
| nameBase (constructorName con) == "()"
-> [varE parenValName `appE`
mkDoStmts [] (varE returnValName `appE` tupE [])]
| otherwise -> [mkDoStmts (matchCon con)
(resultExpr (constructorName con) [])]
_ -> [varE chooseValName `appE` listE (map mkPair nullaryCons)]
mkAlt :: Q Exp -> Q Exp -> Q Exp
mkAlt e1 e2 = infixApp e1 (varE altValName) e2
mkPair :: Con -> Q Exp
mkPair con = tupE [ stringE $ dataConStr con
, resultExpr (constructorName con) []
]
matchCon :: Con -> [Q Stmt]
matchCon con
| isSym conStr = [symbolPat conStr]
| otherwise = identHPat conStr
where
conStr = dataConStr con
mainRhsExpr :: Q Exp
mainRhsExpr = varE parensValName `appE` readConsExpr
lamE (map varP $
#if defined(NEW_FUNCTOR_CLASSES)
_rpsAndRls ++
#endif
if urp then [] else [p]
) . appsE
$ [ varE $ (if urp then readPrecConstName else readsPrecConstName) rClass
, if urp
then mainRhsExpr
else varE readPrec_to_SValName `appE` mainRhsExpr `appE` varE p
]
#if defined(NEW_FUNCTOR_CLASSES)
++ map varE _rpsAndRls
#endif
++ if urp then [] else [varE p]
makeReadForCon :: ReadClass
-> Bool
-> [(Name, Name)]
-> Con
-> Q [Exp]
makeReadForCon rClass urp rpls (NormalC conName _) = do
(argTys, tvMap) <- reifyConTys2 rClass rpls conName
args <- newNameList "arg" $ length argTys
let conStr = nameBase conName
isTup = isNonUnitTupleString conStr
(readStmts, varExps) <-
zipWithAndUnzipM (makeReadForArg rClass isTup urp tvMap conName) argTys args
let body = resultExpr conName varExps
e <- if isTup
then let tupleStmts = intersperse (readPunc ",") readStmts
in varE parenValName `appE` mkDoStmts tupleStmts body
else let prefixStmts = readPrefixCon conStr ++ readStmts
in mkParser appPrec prefixStmts body
return [e]
makeReadForCon rClass urp rpls (RecC conName ts) = do
(argTys, tvMap) <- reifyConTys2 rClass rpls conName
args <- newNameList "arg" $ length argTys
(readStmts, varExps) <- zipWith3AndUnzipM
(\(argName, _, _) argTy arg -> makeReadForField rClass urp tvMap conName
(nameBase argName) argTy arg)
ts argTys args
let body = resultExpr conName varExps
conStr = nameBase conName
recordStmts = readPrefixCon conStr ++ [readPunc "{"]
++ concat (intersperse [readPunc ","] readStmts)
++ [readPunc "}"]
e <- mkParser appPrec1 recordStmts body
return [e]
makeReadForCon rClass urp rpls (InfixC _ conName _) = do
([alTy, arTy], tvMap) <- reifyConTys2 rClass rpls conName
al <- newName "argL"
ar <- newName "argR"
([readStmt1, readStmt2], varExps) <-
zipWithAndUnzipM (makeReadForArg rClass False urp tvMap conName)
[alTy, arTy] [al, ar]
info <- reify conName
#if MIN_VERSION_template_haskell(2,11,0)
conPrec <- case info of
DataConI{} -> do
fi <- fromMaybe defaultFixity <$> reifyFixity conName
case fi of
Fixity prec _ -> return prec
#else
let conPrec = case info of
DataConI _ _ _ (Fixity prec _) -> prec
#endif
_ -> error $ "Text.Read.Deriving.Internal.makeReadForCon: Unsupported type: " ++ show info
let body = resultExpr conName varExps
conStr = nameBase conName
readInfixCon
| isSym conStr = [symbolPat conStr]
| otherwise = [readPunc "`"] ++ identHPat conStr ++ [readPunc "`"]
infixStmts = [readStmt1] ++ readInfixCon ++ [readStmt2]
e <- mkParser conPrec infixStmts body
return [e]
makeReadForCon rClass urp rpls (ForallC _ _ con) =
makeReadForCon rClass urp rpls con
#if MIN_VERSION_template_haskell(2,11,0)
makeReadForCon rClass urp rpls (GadtC conNames ts _) =
let con :: Name -> Q Con
con conName = do
mbFi <- reifyFixity conName
return $ if startsConSym (head $ nameBase conName)
&& length ts == 2
&& isJust mbFi
then let [t1, t2] = ts in InfixC t1 conName t2
else NormalC conName ts
in concatMapM (makeReadForCon rClass urp rpls <=< con) conNames
makeReadForCon rClass urp rpls (RecGadtC conNames ts _) =
concatMapM (makeReadForCon rClass urp rpls . flip RecC ts) conNames
#endif
makeReadForArg :: ReadClass
-> Bool
-> Bool
-> TyVarMap2
-> Name
-> Type
-> Name
-> Q (Q Stmt, Exp)
makeReadForArg rClass isTup urp tvMap conName ty tyExpName = do
(rExp, varExp) <- makeReadForType rClass urp tvMap conName tyExpName False ty
let readStmt = bindS (varP tyExpName) $
(if (not isTup) then appE (varE stepValName) else id) $
wrapReadS urp (return rExp)
return (readStmt, varExp)
makeReadForField :: ReadClass
-> Bool
-> TyVarMap2
-> Name
-> String
-> Type
-> Name
-> Q ([Q Stmt], Exp)
makeReadForField rClass urp tvMap conName lblStr ty tyExpName = do
(rExp, varExp) <- makeReadForType rClass urp tvMap conName tyExpName False ty
let readStmt = bindS (varP tyExpName) $
varE resetValName `appE` wrapReadS urp (return rExp)
return (readLbl ++ [readStmt], varExp)
where
readLbl | isSym lblStr
= [readPunc "(", symbolPat lblStr, readPunc ")"]
| otherwise
= identHPat lblStr
makeReadForType :: ReadClass
-> Bool
-> TyVarMap2
-> Name
-> Name
-> Bool
-> Type
-> Q (Exp, Exp)
#if defined(NEW_FUNCTOR_CLASSES)
makeReadForType _ urp tvMap _ tyExpName rl (VarT tyName) =
let tyExp = VarE tyExpName
in return $ case Map.lookup tyName tvMap of
Just (TwoNames rpExp rlExp) -> (VarE $ if rl then rlExp else rpExp, tyExp)
Nothing -> (VarE $ readsOrReadName urp rl Read, tyExp)
#else
makeReadForType _ urp _ _ tyExpName _ VarT{} =
return (VarE $ readsOrReadName urp False Read, VarE tyExpName)
#endif
makeReadForType rClass urp tvMap conName tyExpName rl (SigT ty _) =
makeReadForType rClass urp tvMap conName tyExpName rl ty
makeReadForType rClass urp tvMap conName tyExpName rl (ForallT _ _ ty) =
makeReadForType rClass urp tvMap conName tyExpName rl ty
#if defined(NEW_FUNCTOR_CLASSES)
makeReadForType rClass urp tvMap conName tyExpName rl ty = do
let tyCon :: Type
tyArgs :: [Type]
tyCon:tyArgs = unapplyTy ty
numLastArgs :: Int
numLastArgs = min (arity rClass) (length tyArgs)
lhsArgs, rhsArgs :: [Type]
(lhsArgs, rhsArgs) = splitAt (length tyArgs numLastArgs) tyArgs
tyVarNames :: [Name]
tyVarNames = Map.keys tvMap
itf <- isTyFamily tyCon
if any (`mentionsName` tyVarNames) lhsArgs
|| itf && any (`mentionsName` tyVarNames) tyArgs
then outOfPlaceTyVarError rClass conName
else do
readExp <- appsE $ [ varE . readsOrReadName urp rl $ toEnum numLastArgs]
++ zipWith (\b -> fmap fst
. makeReadForType rClass urp tvMap conName tyExpName b)
(cycle [False,True])
(interleave rhsArgs rhsArgs)
return (readExp, VarE 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 (Bounded, Enum)
instance ClassRep ReadClass where
arity = fromEnum
allowExQuant _ = False
fullClassName Read = readTypeName
fullClassName Read1 = read1TypeName
#if defined(NEW_FUNCTOR_CLASSES)
fullClassName Read2 = read2TypeName
#endif
classConstraint rClass i
| rMin <= i && i <= rMax = Just $ fullClassName (toEnum i :: ReadClass)
| otherwise = Nothing
where
rMin, rMax :: Int
rMin = fromEnum (minBound :: ReadClass)
rMax = fromEnum rClass
readsPrecConstName :: ReadClass -> Name
readsPrecConstName Read = readsPrecConstValName
#if defined(NEW_FUNCTOR_CLASSES)
readsPrecConstName Read1 = liftReadsPrecConstValName
readsPrecConstName Read2 = liftReadsPrec2ConstValName
#else
readsPrecConstName Read1 = readsPrec1ConstValName
#endif
readPrecConstName :: ReadClass -> Name
readPrecConstName Read = readPrecConstValName
readPrecConstName Read1 = liftReadPrecConstValName
#if defined(NEW_FUNCTOR_CLASSES)
readPrecConstName Read2 = liftReadPrec2ConstValName
#endif
readsPrecName :: ReadClass -> Name
readsPrecName Read = readsPrecValName
#if defined(NEW_FUNCTOR_CLASSES)
readsPrecName Read1 = liftReadsPrecValName
readsPrecName Read2 = liftReadsPrec2ValName
#else
readsPrecName Read1 = readsPrec1ValName
#endif
readPrecName :: ReadClass -> Name
readPrecName Read = readPrecValName
readPrecName Read1 = liftReadPrecValName
#if defined(NEW_FUNCTOR_CLASSES)
readPrecName Read2 = liftReadPrec2ValName
#endif
readListPrecDefaultName :: ReadClass -> Name
readListPrecDefaultName Read = readListPrecDefaultValName
readListPrecDefaultName Read1 = liftReadListPrecDefaultValName
#if defined(NEW_FUNCTOR_CLASSES)
readListPrecDefaultName Read2 = liftReadListPrec2DefaultValName
#endif
readListPrecName :: ReadClass -> Name
readListPrecName Read = readListPrecValName
readListPrecName Read1 = liftReadListPrecValName
#if defined(NEW_FUNCTOR_CLASSES)
readListPrecName Read2 = liftReadListPrec2ValName
#endif
readListName :: ReadClass -> Name
readListName Read = readListValName
#if defined(NEW_FUNCTOR_CLASSES)
readListName Read1 = liftReadListValName
readListName Read2 = liftReadList2ValName
#else
readListName Read1 = error "Text.Read.Deriving.Internal.readListName"
#endif
readsPrecOrListName :: Bool
-> ReadClass
-> Name
readsPrecOrListName False = readsPrecName
readsPrecOrListName True = readListName
readPrecOrListName :: Bool
-> ReadClass
-> Name
readPrecOrListName False = readPrecName
readPrecOrListName True = readListPrecName
readsOrReadName :: Bool
-> Bool
-> ReadClass
-> Name
readsOrReadName False = readsPrecOrListName
readsOrReadName True = readPrecOrListName
mkParser :: Int -> [Q Stmt] -> Q Exp -> Q Exp
mkParser p ss b = varE precValName `appE` integerE p `appE` mkDoStmts ss b
mkDoStmts :: [Q Stmt] -> Q Exp -> Q Exp
mkDoStmts ss b = doE (ss ++ [noBindS b])
resultExpr :: Name -> [Exp] -> Q Exp
resultExpr conName as = varE returnValName `appE` conApp
where
conApp :: Q Exp
conApp = appsE $ conE conName : map return as
isSym :: String -> Bool
isSym "" = False
isSym (c : _) = startsVarSym c || startsConSym c
#if !defined(MIN_VERSION_ghc_boot)
startsVarSym, startsConSym :: Char -> Bool
startsVarSym c = startsVarSymASCII c || (ord c > 0x7f && isSymbol c)
startsConSym c = c == ':'
startsVarSymASCII :: Char -> Bool
startsVarSymASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
#endif
identHPat :: String -> [Q Stmt]
identHPat s
| Just (ss, '#') <- snocView s = [identPat ss, symbolPat "#"]
| otherwise = [identPat s]
bindLex :: Q Exp -> Q Stmt
bindLex pat = noBindS $ varE expectPValName `appE` pat
identPat :: String -> Q Stmt
identPat s = bindLex $ conE identDataName `appE` stringE s
symbolPat :: String -> Q Stmt
symbolPat s = bindLex $ conE symbolDataName `appE` stringE s
readPunc :: String -> Q Stmt
readPunc c = bindLex $ conE puncDataName `appE` stringE c
snocView :: [a] -> Maybe ([a],a)
snocView [] = Nothing
snocView xs = go [] xs
where
go acc [a] = Just (reverse acc, a)
go acc (a:as) = go (a:acc) as
go _ [] = error "Util: snocView"
dataConStr :: Con -> String
dataConStr = nameBase . constructorName
readPrefixCon :: String -> [Q Stmt]
readPrefixCon conStr
| isSym conStr = [readPunc "(", symbolPat conStr, readPunc ")"]
| otherwise = identHPat conStr
wrapReadS :: Bool -> Q Exp -> Q Exp
wrapReadS urp e = if urp then e
else varE readS_to_PrecValName `appE` e
shouldDefineReadPrec :: ReadClass -> ReadOptions -> Bool
shouldDefineReadPrec rClass opts = useReadPrec opts && baseCompatible
where
base4'10OrLater :: Bool
#if __GLASGOW_HASKELL__ >= 801
base4'10OrLater = True
#else
base4'10OrLater = False
#endif
baseCompatible :: Bool
baseCompatible = case rClass of
Read -> True
Read1 -> base4'10OrLater
#if defined(NEW_FUNCTOR_CLASSES)
Read2 -> base4'10OrLater
#endif