{-| Derives @Read@. This is as defined by the Haskell report, except there is no support for infix constructors. If you attempt to derive @Read@ for a data type with infix constructors, the constructors are handled as if they were prefix constructors, using the @(@/consym/@)@ syntax. -} module Data.Derive.Read(makeRead) where {- import Prelude example :: Custom instance Read a => Read (Sample a) where readsPrec p0 r = readParen $(bracket 0) (\r0 -> $(comp 0 First )) r ++ readParen $(bracket 1) (\r0 -> $(comp 1 Second)) r ++ readParen $(bracket 2) (\r0 -> $(comp 2 Third )) r ++ [] test :: Sample instance Read a => Read (Sample a) where readsPrec p0 r = readParen (p0 > 10) (\r0 -> [ (First, r1) | ("First", r1) <- lex r0]) r ++ readParen (p0 > 10) (\r0 -> [ (Second x1 x2, r3) | ("Second", r1) <- lex r0 , (x1, r2) <- readsPrec 11 r1 , (x2, r3) <- readsPrec 11 r2]) r ++ readParen (p0 > 10) (\r0 -> [ (Third x1, r2) | ("Third", r1) <- lex r0 , (x1, r2) <- readsPrec 11 r1]) r test :: Computer instance Read Computer where readsPrec _ r = readParen False (\r0 -> [ (Laptop x1 x2, r10) | ("Laptop", r1) <- lex r0 , ("{", r2) <- lex r1 , ("weight", r3) <- lex r2 , ("=", r4) <- lex r3 , (x1, r5) <- readsPrec 0 r4 , (",", r6) <- lex r5 , ("speed", r7) <- lex r6 , ("=", r8) <- lex r7 , (x2, r9) <- readsPrec 0 r8 , ("}", r10) <- lex r9]) r ++ readParen False (\r0 -> [ (Desktop x1, r6) | ("Desktop", r1) <- lex r0 , ("{", r2) <- lex r1 , ("speed", r3) <- lex r2 , ("=", r4) <- lex r3 , (x1, r5) <- readsPrec 0 r4 , ("}", r6) <- lex r5]) r test :: (:*:) instance (Read a, Read b) => Read ((:*:) a b) where readsPrec p0 r = readParen (p0 > 10) (\r0 -> [ ((:*:) x1 x2, r3) | ("(:*:)", r1) <- lex r0 , (x1, r2) <- readsPrec 11 r1 , (x2, r3) <- readsPrec 11 r2]) r -} import Data.Derive.DSL.HSE import qualified Language.Haskell as H -- GENERATED START 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 []])])]])]) ])] -- GENERATED STOP 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" = if hasFields $ getCtor d y 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 [cpat, var ('r':show (cn+1))]) $ matchStr (ctorDeclName c) 0 : [QualStmt $ Generator sl (PTuple [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 [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 [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 [PLit $ H.String s, pVar $ 'r':show (i+1)]) (var "lex" `H.App` var ('r':show i)) {- read' dat = [instance_default "Read" dat [funN "readsPrec" [sclause [vr "p0", vr "r"] body]]] where body = (++::) [ readit ctr | ctr <- dataCtors dat ] readit ctr = case ctorFields ctr of [] -> norm fl -> flds fl where norm = lK "readParen" [vr "p0" >: lit (10::Integer), "r0" ->: runComp (pName . foldr (.) id (map (pRead 11) (ctv ctr 'x'))) (ctp ctr 'x'), l0 "r"] flds f = lK "readParen" [false, "r0" ->: runComp (pName . pLex "{" . foldr (.) id (intersperse (pLex ",") (zipWith pField (ctv ctr 'x') f)) . pLex "}") (ctp ctr 'x'), l0 "r"] runComp fn ex = CompE $ fn (\k -> [ NoBindS (tup [ex, vrn 'r' k]) ]) 0 pArse pat fun ct k = BindS (tup [pat, vrn 'r' (k+1)]) (AppE fun (vrn 'r' k)) : ct (k+1) pLex pat = pArse (lit pat) (l0 "lex") name = ctorName ctr pName | isAlpha (head name) || head name == '_' = pLex name | otherwise = pLex "(" . pLex name . pLex ")" pRead pc pat = pArse pat (l1 "readsPrec" (lit (pc :: Integer))) pField pat fld = pLex fld . pLex "=" . pRead 0 pat -}