module Data.Derive.Read(makeRead) where
import Data.Derive.DSL.HSE
import qualified Language.Haskell as H
import Data.Derive.DSL.DSL
import Data.Derive.Internal.Derivation
makeRead :: Derivation
makeRead = derivationCustomDSL "Read" custom $
List [Instance ["Read"] "Read" (List [App "InsDecl" (List [App
"FunBind" (List [List [App "Match" (List [App "Ident" (List [
String "readsPrec"]),List [App "PVar" (List [App "Ident" (List [
Concat (List [String "p",ShowInt (Int 0)])])]),App "PVar" (List [
App "Ident" (List [String "r"])])],App "Nothing" (List []),App
"UnGuardedRhs" (List [Fold (App "InfixApp" (List [Head,App
"QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String
"++"])])]),Tail])) (Concat (List [MapCtor (Application (List [App
"Var" (List [App "UnQual" (List [App "Ident" (List [String
"readParen"])])]),App "SpliceExp" (List [App "ParenSplice" (List [
App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident"
(List [String "bracket"])])]),App "Lit" (List [App "Int" (List [
CtorIndex])])])])]),App "Paren" (List [App "Lambda" (List [List [
App "PVar" (List [App "Ident" (List [Concat (List [String "r",
ShowInt (Int 0)])])])],App "SpliceExp" (List [App "ParenSplice" (
List [Application (List [App "Var" (List [App "UnQual" (List [App
"Ident" (List [String "comp"])])]),App "Lit" (List [App "Int" (
List [CtorIndex])]),App "Con" (List [App "UnQual" (List [App
"Ident" (List [CtorName])])])])])])])]),App "Var" (List [App
"UnQual" (List [App "Ident" (List [String "r"])])])])),List [App
"List" (List [List []])]]))]),App "BDecls" (List [List []])])]])])
])]
custom = customSplice splice
getCtor d i = dataDeclCtors (snd d) !! fromIntegral i
hasFields c = any ((/=) "" . fst) $ ctorDeclFields c
splice :: FullDataDecl -> Exp -> Exp
splice d (H.App x (H.Lit (H.Int y))) | x ~= "bracket", let c = getCtor d y =
if hasFields c || null (ctorDeclFields c)
then con "False"
else Paren $ InfixApp (var "p0") (QVarOp $ UnQual $ Symbol ">") (H.Lit $ H.Int 10)
splice d (H.App (H.App x (H.Lit (H.Int y))) _) | x ~= "comp" =
if hasFields c then readFields c else readCtor c
where c = getCtor d y
readCtor :: CtorDecl -> Exp
readCtor c =
ListComp (Tuple Boxed [cpat, var ('r':show (cn+1))]) $
matchStr (ctorDeclName c) 0 :
[QualStmt $ Generator sl
(PTuple Boxed [pVar $ v 'x' 0, pVar $ v 'r' 1])
(apps (var "readsPrec") [H.Lit $ H.Int 11, var $ v 'r' 0])
| i <- [1..cn], let v c j = c : show (i+j)]
where
cn = ctorDeclArity c
cpat = apps (Con $ UnQual $ ctorDeclName' c) $ map (var . ('x':) . show) [1..cn]
readFields :: CtorDecl -> Exp
readFields c =
ListComp (Tuple Boxed [cpat, var $ 'r':show ((cn*4)+2)]) $
matchStr (ctorDeclName c) 0 :
concat [
matchStr (r == 1 ? "{" $ ",") r :
matchStr fld (r+1) :
matchStr "=" (r+2) :
QualStmt (Generator sl
(PTuple Boxed [pVar $ 'x':show i, pVar $ 'r':show (r+4)])
(apps (var "readsPrec") [H.Lit $ H.Int 0, var $ 'r':show (r+3)]))
: []
| (i,r,(fld,_)) <- zip3 [1..] [1,5..] (ctorDeclFields c)
] ++
[matchStr "}" ((cn*4)+1)]
where
cn = ctorDeclArity c
cpat = apps (Con $ UnQual $ ctorDeclName' c) $ map (var . ('x':) . show) [1..cn]
matchStr :: String -> Int -> QualStmt
matchStr s i = QualStmt $ Generator sl (PTuple Boxed [PLit H.Signless $ H.String s, pVar $ 'r':show (i+1)]) (var "lex" `H.App` var ('r':show i))