diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,8 @@ Changelog for Derive +2.5.17 + Upgrade to haskell-src-exts-1.16 + Remove GHC 7.2 support 2.5.16 Allow transformers-0.4 and above 2.5.15 diff --git a/Data/Derive/Arbitrary.hs b/Data/Derive/Arbitrary.hs --- a/Data/Derive/Arbitrary.hs +++ b/Data/Derive/Arbitrary.hs @@ -35,36 +35,36 @@ makeArbitrary = derivationCustomDSL "Arbitrary" custom $ List [Instance [] "Arbitrary" (List [App "InsDecl" (List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [String - "arbitrary"])]),App "Nothing" (List []),App "UnGuardedRhs" (List [ - App "Do" (List [List [App "Generator" (List [App "PVar" (List [App - "Ident" (List [String "x"])]),App "App" (List [App "Var" (List [ - App "UnQual" (List [App "Ident" (List [String "choose"])])]),App - "Tuple" (List [App "Boxed" (List []),List [App "ExpTypeSig" (List - [App "Lit" (List [App "Int" (List [Int 0])]),App "TyCon" (List [ - App "UnQual" (List [App "Ident" (List [String "Int"])])])]),App - "InfixApp" (List [App "App" (List [App "Var" (List [App "UnQual" ( - List [App "Ident" (List [String "length"])])]),App "List" (List [ - MapCtor (App "RecConstr" (List [App "UnQual" (List [App "Ident" ( - List [CtorName])]),List []]))])]),App "QVarOp" (List [App "UnQual" - (List [App "Symbol" (List [String "-"])])]),App "Lit" (List [App - "Int" (List [Int 1])])])]])])]),App "Qualifier" (List [App "Case" - (List [App "Var" (List [App "UnQual" (List [App "Ident" (List [ - String "x"])])]),Concat (List [MapCtor (App "Alt" (List [App - "PLit" (List [App "Int" (List [CtorIndex])]),App "UnGuardedAlt" ( - List [App "Do" (List [Concat (List [MapField (App "Generator" ( - List [App "PVar" (List [App "Ident" (List [Concat (List [String - "x",ShowInt FieldIndex])])]),App "Var" (List [App "UnQual" (List [ - App "Ident" (List [String "arbitrary"])])])])),List [App - "Qualifier" (List [App "App" (List [App "Var" (List [App "UnQual" - (List [App "Ident" (List [String "return"])])]),App "Paren" (List - [Application (Concat (List [List [App "Con" (List [App "UnQual" ( - List [App "Ident" (List [CtorName])])])],MapField (App "Var" (List - [App "UnQual" (List [App "Ident" (List [Concat (List [String "x", - ShowInt FieldIndex])])])]))]))])])])]])])]),App "BDecls" (List [ - List []])])),List [App "Alt" (List [App "PWildCard" (List []),App - "UnGuardedAlt" (List [App "App" (List [App "Var" (List [App - "UnQual" (List [App "Ident" (List [String "error"])])]),App "Lit" - (List [App "String" (List [String + "arbitrary"])]),App "UnGuardedRhs" (List [App "Do" (List [List [ + App "Generator" (List [App "PVar" (List [App "Ident" (List [String + "x"])]),App "App" (List [App "Var" (List [App "UnQual" (List [App + "Ident" (List [String "choose"])])]),App "Tuple" (List [App + "Boxed" (List []),List [App "ExpTypeSig" (List [App "Lit" (List [ + App "Int" (List [Int 0])]),App "TyCon" (List [App "UnQual" (List [ + App "Ident" (List [String "Int"])])])]),App "InfixApp" (List [App + "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" ( + List [String "length"])])]),App "List" (List [MapCtor (App + "RecConstr" (List [App "UnQual" (List [App "Ident" (List [CtorName + ])]),List []]))])]),App "QVarOp" (List [App "UnQual" (List [App + "Symbol" (List [String "-"])])]),App "Lit" (List [App "Int" (List + [Int 1])])])]])])]),App "Qualifier" (List [App "Case" (List [App + "Var" (List [App "UnQual" (List [App "Ident" (List [String "x"])]) + ]),Concat (List [MapCtor (App "Alt" (List [App "PLit" (List [App + "Signless" (List []),App "Int" (List [CtorIndex])]),App + "UnGuardedRhs" (List [App "Do" (List [Concat (List [MapField (App + "Generator" (List [App "PVar" (List [App "Ident" (List [Concat ( + List [String "x",ShowInt FieldIndex])])]),App "Var" (List [App + "UnQual" (List [App "Ident" (List [String "arbitrary"])])])])), + List [App "Qualifier" (List [App "App" (List [App "Var" (List [App + "UnQual" (List [App "Ident" (List [String "return"])])]),App + "Paren" (List [Application (Concat (List [List [App "Con" (List [ + App "UnQual" (List [App "Ident" (List [CtorName])])])],MapField ( + App "Var" (List [App "UnQual" (List [App "Ident" (List [Concat ( + List [String "x",ShowInt FieldIndex])])])]))]))])])])]])])]),App + "BDecls" (List [List []])])),List [App "Alt" (List [App + "PWildCard" (List []),App "UnGuardedRhs" (List [App "App" (List [ + App "Var" (List [App "UnQual" (List [App "Ident" (List [String + "error"])])]),App "Lit" (List [App "String" (List [String "FATAL ERROR: Arbitrary instance, logic bug"])])])]),App "BDecls" (List [List []])])]])])])]])]),App "BDecls" (List [List []])])])]) ] @@ -76,7 +76,7 @@ -- C a b => Arbitrary a, Arbitrary b -- a -> b => CoArbitrary a, Arbitrary b context :: FullDataDecl -> Context -> Context -context (_,d) _ = nub $ concatMap (f True . fromBangType . snd) $ concatMap ctorDeclFields $ dataDeclCtors d +context (_,d) _ = nub $ concatMap (f True . snd) $ concatMap ctorDeclFields $ dataDeclCtors d where f b (TyVar x) = [ClassA (qname $ b ? "Arbitrary" $ "CoArbitrary") [TyVar x]] f b (TyFun x y) = f (not b) x ++ f b y diff --git a/Data/Derive/ArbitraryOld.hs b/Data/Derive/ArbitraryOld.hs --- a/Data/Derive/ArbitraryOld.hs +++ b/Data/Derive/ArbitraryOld.hs @@ -31,44 +31,44 @@ dslArbitraryOld = List [Instance ["Arbitrary"] "Arbitrary" (List [App "InsDecl" ( List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [ - String "arbitrary"])]),App "Nothing" (List []),App "UnGuardedRhs" - (List [App "Do" (List [List [App "Generator" (List [App "PVar" ( - List [App "Ident" (List [String "x"])]),App "App" (List [App "Var" - (List [App "UnQual" (List [App "Ident" (List [String "choose"])])] - ),App "Tuple" (List [App "Boxed" (List []),List [App "Lit" (List [ - App "Int" (List [Int 0])]),App "InfixApp" (List [App "App" (List [ - App "Var" (List [App "UnQual" (List [App "Ident" (List [String - "length"])])]),App "List" (List [MapCtor (App "RecConstr" (List [ - App "UnQual" (List [App "Ident" (List [CtorName])]),List []]))])]) - ,App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [ - String "-"])])]),App "Lit" (List [App "Int" (List [Int 1])])])]])] - )]),App "Qualifier" (List [App "Case" (List [App "Var" (List [App - "UnQual" (List [App "Ident" (List [String "x"])])]),MapCtor (App - "Alt" (List [App "PLit" (List [App "Int" (List [CtorIndex])]),App - "UnGuardedAlt" (List [App "Do" (List [Concat (List [MapField (App - "Generator" (List [App "PVar" (List [App "Ident" (List [Concat ( - List [String "x",ShowInt FieldIndex])])]),App "Var" (List [App - "UnQual" (List [App "Ident" (List [String "arbitrary"])])])])), - List [App "Qualifier" (List [App "App" (List [App "Var" (List [App - "UnQual" (List [App "Ident" (List [String "return"])])]),App - "Paren" (List [Application (Concat (List [List [App "Con" (List [ - App "UnQual" (List [App "Ident" (List [CtorName])])])],MapField ( - App "Var" (List [App "UnQual" (List [App "Ident" (List [Concat ( - List [String "x",ShowInt FieldIndex])])])]))]))])])])]])])]),App - "BDecls" (List [List []])]))])])]])]),App "BDecls" (List [List []] - )])]),App "InsDecl" (List [App "FunBind" (List [MapCtor (App - "Match" (List [App "Ident" (List [String "coarbitrary"]),List [App - "PParen" (List [App "PApp" (List [App "UnQual" (List [App "Ident" - (List [CtorName])]),MapField (App "PVar" (List [App "Ident" (List - [Concat (List [String "x",ShowInt FieldIndex])])]))])])],App - "Nothing" (List []),App "UnGuardedRhs" (List [Fold (App "InfixApp" - (List [Head,App "QVarOp" (List [App "UnQual" (List [App "Symbol" ( - List [String "."])])]),Tail])) (Concat (List [List [App "App" ( - List [App "Var" (List [App "UnQual" (List [App "Ident" (List [ - String "variant"])])]),App "Lit" (List [App "Int" (List [CtorIndex - ])])])],MapField (App "App" (List [App "Var" (List [App "UnQual" ( - List [App "Ident" (List [String "coarbitrary"])])]),App "Var" ( - List [App "UnQual" (List [App "Ident" (List [Concat (List [String - "x",ShowInt FieldIndex])])])])]))]))]),App "BDecls" (List [List [] - ])]))])])])] + String "arbitrary"])]),App "UnGuardedRhs" (List [App "Do" (List [ + List [App "Generator" (List [App "PVar" (List [App "Ident" (List [ + String "x"])]),App "App" (List [App "Var" (List [App "UnQual" ( + List [App "Ident" (List [String "choose"])])]),App "Tuple" (List [ + App "Boxed" (List []),List [App "Lit" (List [App "Int" (List [Int + 0])]),App "InfixApp" (List [App "App" (List [App "Var" (List [App + "UnQual" (List [App "Ident" (List [String "length"])])]),App + "List" (List [MapCtor (App "RecConstr" (List [App "UnQual" (List [ + App "Ident" (List [CtorName])]),List []]))])]),App "QVarOp" (List + [App "UnQual" (List [App "Symbol" (List [String "-"])])]),App + "Lit" (List [App "Int" (List [Int 1])])])]])])]),App "Qualifier" ( + List [App "Case" (List [App "Var" (List [App "UnQual" (List [App + "Ident" (List [String "x"])])]),MapCtor (App "Alt" (List [App + "PLit" (List [App "Signless" (List []),App "Int" (List [CtorIndex] + )]),App "UnGuardedRhs" (List [App "Do" (List [Concat (List [ + MapField (App "Generator" (List [App "PVar" (List [App "Ident" ( + List [Concat (List [String "x",ShowInt FieldIndex])])]),App "Var" + (List [App "UnQual" (List [App "Ident" (List [String "arbitrary"]) + ])])])),List [App "Qualifier" (List [App "App" (List [App "Var" ( + List [App "UnQual" (List [App "Ident" (List [String "return"])])]) + ,App "Paren" (List [Application (Concat (List [List [App "Con" ( + List [App "UnQual" (List [App "Ident" (List [CtorName])])])], + MapField (App "Var" (List [App "UnQual" (List [App "Ident" (List [ + Concat (List [String "x",ShowInt FieldIndex])])])]))]))])])])]])]) + ]),App "BDecls" (List [List []])]))])])]])]),App "BDecls" (List [ + List []])])]),App "InsDecl" (List [App "FunBind" (List [MapCtor ( + App "Match" (List [App "Ident" (List [String "coarbitrary"]),List + [App "PParen" (List [App "PApp" (List [App "UnQual" (List [App + "Ident" (List [CtorName])]),MapField (App "PVar" (List [App + "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])])]))] + )])],App "Nothing" (List []),App "UnGuardedRhs" (List [Fold (App + "InfixApp" (List [Head,App "QVarOp" (List [App "UnQual" (List [App + "Symbol" (List [String "."])])]),Tail])) (Concat (List [List [App + "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" ( + List [String "variant"])])]),App "Lit" (List [App "Int" (List [ + CtorIndex])])])],MapField (App "App" (List [App "Var" (List [App + "UnQual" (List [App "Ident" (List [String "coarbitrary"])])]),App + "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (List [ + String "x",ShowInt FieldIndex])])])])]))]))]),App "BDecls" (List [ + List []])]))])])])] -- GENERATED STOP diff --git a/Data/Derive/Binary.hs b/Data/Derive/Binary.hs --- a/Data/Derive/Binary.hs +++ b/Data/Derive/Binary.hs @@ -64,7 +64,7 @@ List [String "x"])])]),MapCtor (App "Alt" (List [App "PApp" (List [App "UnQual" (List [App "Ident" (List [CtorName])]),MapField (App "PVar" (List [App "Ident" (List [Concat (List [String "x",ShowInt - FieldIndex])])]))]),App "UnGuardedAlt" (List [App "Do" (List [ + FieldIndex])])]))]),App "UnGuardedRhs" (List [App "Do" (List [ Concat (List [List [App "Qualifier" (List [App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" (List [String "putTag"])])]),App "Lit" (List [App "Int" (List [CtorIndex])])])]) @@ -74,61 +74,61 @@ List [String "x",ShowInt FieldIndex])])])])])]))])])]),App "BDecls" (List [List []])]))])]),App "BDecls" (List [List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [String - "useTag"])]),App "Nothing" (List []),App "UnGuardedRhs" (List [App - "InfixApp" (List [App "App" (List [App "Var" (List [App "UnQual" ( - List [App "Ident" (List [String "length"])])]),App "List" (List [ - MapCtor (App "RecConstr" (List [App "UnQual" (List [App "Ident" ( - List [CtorName])]),List []]))])]),App "QVarOp" (List [App "UnQual" - (List [App "Symbol" (List [String ">"])])]),App "Lit" (List [App - "Int" (List [Int 1])])])]),App "BDecls" (List [List []])]),App - "FunBind" (List [List [App "Match" (List [App "Ident" (List [ - String "putTag"]),List [App "PVar" (List [App "Ident" (List [ - String "x"])])],App "Nothing" (List []),App "UnGuardedRhs" (List [ - Application (List [App "Var" (List [App "UnQual" (List [App - "Ident" (List [String "when"])])]),App "Var" (List [App "UnQual" ( - List [App "Ident" (List [String "useTag"])])]),App "Paren" (List [ - App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" - (List [Concat (List [String "putWord",ShowInt (Int 8)])])])]),App - "Var" (List [App "UnQual" (List [App "Ident" (List [String "x"])]) - ])])])])]),App "BDecls" (List [List []])])]])]])])]])]),App - "InsDecl" (List [App "PatBind" (List [App "PVar" (List [App - "Ident" (List [String "get"])]),App "Nothing" (List []),App - "UnGuardedRhs" (List [App "Do" (List [List [App "Generator" (List - [App "PVar" (List [App "Ident" (List [String "i"])]),App "Var" ( - List [App "UnQual" (List [App "Ident" (List [String "getTag"])])]) - ]),App "Qualifier" (List [App "Case" (List [App "Var" (List [App - "UnQual" (List [App "Ident" (List [String "i"])])]),Concat (List [ - MapCtor (App "Alt" (List [App "PLit" (List [App "Int" (List [ - CtorIndex])]),App "UnGuardedAlt" (List [App "Do" (List [Concat ( - List [MapField (App "Generator" (List [App "PVar" (List [App - "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])])]), + "useTag"])]),App "UnGuardedRhs" (List [App "InfixApp" (List [App + "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" ( + List [String "length"])])]),App "List" (List [MapCtor (App + "RecConstr" (List [App "UnQual" (List [App "Ident" (List [CtorName + ])]),List []]))])]),App "QVarOp" (List [App "UnQual" (List [App + "Symbol" (List [String ">"])])]),App "Lit" (List [App "Int" (List + [Int 1])])])]),App "BDecls" (List [List []])]),App "FunBind" (List + [List [App "Match" (List [App "Ident" (List [String "putTag"]), + List [App "PVar" (List [App "Ident" (List [String "x"])])],App + "Nothing" (List []),App "UnGuardedRhs" (List [Application (List [ App "Var" (List [App "UnQual" (List [App "Ident" (List [String - "get"])])])])),List [App "Qualifier" (List [App "App" (List [App - "Var" (List [App "UnQual" (List [App "Ident" (List [String - "return"])])]),App "Paren" (List [Application (Concat (List [List - [App "Con" (List [App "UnQual" (List [App "Ident" (List [CtorName] - )])])],MapField (App "Var" (List [App "UnQual" (List [App "Ident" - (List [Concat (List [String "x",ShowInt FieldIndex])])])]))]))])]) - ])]])])]),App "BDecls" (List [List []])])),List [App "Alt" (List [ - App "PWildCard" (List []),App "UnGuardedAlt" (List [App "App" ( - List [App "Var" (List [App "UnQual" (List [App "Ident" (List [ - String "error"])])]),App "Lit" (List [App "String" (List [Concat ( - List [String "Corrupted binary data for ",DataName])])])])]),App - "BDecls" (List [List []])])]])])])]])]),App "BDecls" (List [List [ + "when"])])]),App "Var" (List [App "UnQual" (List [App "Ident" ( + List [String "useTag"])])]),App "Paren" (List [App "App" (List [ + App "Var" (List [App "UnQual" (List [App "Ident" (List [Concat ( + List [String "putWord",ShowInt (Int 8)])])])]),App "Var" (List [ + App "UnQual" (List [App "Ident" (List [String "x"])])])])])])]), + App "BDecls" (List [List []])])]])]])])]])]),App "InsDecl" (List [ App "PatBind" (List [App "PVar" (List [App "Ident" (List [String - "useTag"])]),App "Nothing" (List []),App "UnGuardedRhs" (List [App - "InfixApp" (List [App "App" (List [App "Var" (List [App "UnQual" ( - List [App "Ident" (List [String "length"])])]),App "List" (List [ - MapCtor (App "RecConstr" (List [App "UnQual" (List [App "Ident" ( - List [CtorName])]),List []]))])]),App "QVarOp" (List [App "UnQual" - (List [App "Symbol" (List [String ">"])])]),App "Lit" (List [App - "Int" (List [Int 1])])])]),App "BDecls" (List [List []])]),App - "PatBind" (List [App "PVar" (List [App "Ident" (List [String - "getTag"])]),App "Nothing" (List []),App "UnGuardedRhs" (List [App - "If" (List [App "Var" (List [App "UnQual" (List [App "Ident" (List - [String "useTag"])])]),App "Var" (List [App "UnQual" (List [App - "Ident" (List [Concat (List [String "getWord",ShowInt (Int 8)])])] - )]),App "App" (List [App "Var" (List [App "UnQual" (List [App - "Ident" (List [String "return"])])]),App "Lit" (List [App "Int" ( - List [Int 0])])])])]),App "BDecls" (List [List []])])]])])])])] + "get"])]),App "UnGuardedRhs" (List [App "Do" (List [List [App + "Generator" (List [App "PVar" (List [App "Ident" (List [String "i" + ])]),App "Var" (List [App "UnQual" (List [App "Ident" (List [ + String "getTag"])])])]),App "Qualifier" (List [App "Case" (List [ + App "Var" (List [App "UnQual" (List [App "Ident" (List [String "i" + ])])]),Concat (List [MapCtor (App "Alt" (List [App "PLit" (List [ + App "Signless" (List []),App "Int" (List [CtorIndex])]),App + "UnGuardedRhs" (List [App "Do" (List [Concat (List [MapField (App + "Generator" (List [App "PVar" (List [App "Ident" (List [Concat ( + List [String "x",ShowInt FieldIndex])])]),App "Var" (List [App + "UnQual" (List [App "Ident" (List [String "get"])])])])),List [App + "Qualifier" (List [App "App" (List [App "Var" (List [App "UnQual" + (List [App "Ident" (List [String "return"])])]),App "Paren" (List + [Application (Concat (List [List [App "Con" (List [App "UnQual" ( + List [App "Ident" (List [CtorName])])])],MapField (App "Var" (List + [App "UnQual" (List [App "Ident" (List [Concat (List [String "x", + ShowInt FieldIndex])])])]))]))])])])]])])]),App "BDecls" (List [ + List []])])),List [App "Alt" (List [App "PWildCard" (List []),App + "UnGuardedRhs" (List [App "App" (List [App "Var" (List [App + "UnQual" (List [App "Ident" (List [String "error"])])]),App "Lit" + (List [App "String" (List [Concat (List [String + "Corrupted binary data for ",DataName])])])])]),App "BDecls" (List + [List []])])]])])])]])]),App "BDecls" (List [List [App "PatBind" ( + List [App "PVar" (List [App "Ident" (List [String "useTag"])]),App + "UnGuardedRhs" (List [App "InfixApp" (List [App "App" (List [App + "Var" (List [App "UnQual" (List [App "Ident" (List [String + "length"])])]),App "List" (List [MapCtor (App "RecConstr" (List [ + App "UnQual" (List [App "Ident" (List [CtorName])]),List []]))])]) + ,App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [ + String ">"])])]),App "Lit" (List [App "Int" (List [Int 1])])])]), + App "BDecls" (List [List []])]),App "PatBind" (List [App "PVar" ( + List [App "Ident" (List [String "getTag"])]),App "UnGuardedRhs" ( + List [App "If" (List [App "Var" (List [App "UnQual" (List [App + "Ident" (List [String "useTag"])])]),App "Var" (List [App "UnQual" + (List [App "Ident" (List [Concat (List [String "getWord",ShowInt ( + Int 8)])])])]),App "App" (List [App "Var" (List [App "UnQual" ( + List [App "Ident" (List [String "return"])])]),App "Lit" (List [ + App "Int" (List [Int 0])])])])]),App "BDecls" (List [List []])])]] + )])])])] -- GENERATED STOP diff --git a/Data/Derive/BinaryDefer.hs b/Data/Derive/BinaryDefer.hs --- a/Data/Derive/BinaryDefer.hs +++ b/Data/Derive/BinaryDefer.hs @@ -30,34 +30,34 @@ dslBinaryDefer = List [Instance ["BinaryDefer"] "BinaryDefer" (List [App "InsDecl" (List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [ - String "bothDefer"])]),App "Nothing" (List []),App "UnGuardedRhs" + String "bothDefer"])]),App "UnGuardedRhs" (List [App "App" (List [ + App "Var" (List [App "UnQual" (List [App "Ident" (List [String + "defer"])])]),App "List" (List [MapCtor (App "Lambda" (List [List + [App "PIrrPat" (List [App "PParen" (List [App "PAsPat" (List [App + "Ident" (List [String "o"]),App "PParen" (List [App "PApp" (List [ + App "UnQual" (List [App "Ident" (List [CtorName])]),MapField (App + "PVar" (List [App "Ident" (List [Concat (List [String "x",ShowInt + FieldIndex])])]))])])])])])],App "If" (List [App "App" (List [App + "Var" (List [App "UnQual" (List [App "Ident" (List [String "null"] + )])]),App "List" (List [MapField (Application (List [App "Var" ( + List [App "UnQual" (List [App "Ident" (List [String "const"])])]), + App "Con" (List [App "Special" (List [App "UnitCon" (List [])])]), + App "Var" (List [App "UnQual" (List [App "Ident" (List [Concat ( + List [String "x",ShowInt FieldIndex])])])])]))])]),App "InfixApp" (List [App "App" (List [App "Var" (List [App "UnQual" (List [App - "Ident" (List [String "defer"])])]),App "List" (List [MapCtor (App - "Lambda" (List [List [App "PIrrPat" (List [App "PParen" (List [App - "PAsPat" (List [App "Ident" (List [String "o"]),App "PParen" (List - [App "PApp" (List [App "UnQual" (List [App "Ident" (List [CtorName - ])]),MapField (App "PVar" (List [App "Ident" (List [Concat (List [ - String "x",ShowInt FieldIndex])])]))])])])])])],App "If" (List [ - App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" - (List [String "null"])])]),App "List" (List [MapField (Application - (List [App "Var" (List [App "UnQual" (List [App "Ident" (List [ - String "const"])])]),App "Con" (List [App "Special" (List [App - "UnitCon" (List [])])]),App "Var" (List [App "UnQual" (List [App + "Ident" (List [String "unit"])])]),App "Paren" (List [Application + (Concat (List [List [App "Con" (List [App "UnQual" (List [App + "Ident" (List [CtorName])])])],MapField (App "Var" (List [App + "UnQual" (List [App "Ident" (List [Concat (List [String "x", + ShowInt FieldIndex])])])]))]))])]),App "QVarOp" (List [App + "UnQual" (List [App "Symbol" (List [String "< OList xs)) = foldl1 (\a b -> OApp "App" [a,b]) xs - f (MapCtor dsl) = OList [ applyEnv dsl env{envCtor=c} + f (MapCtor dsl) = OList [applyEnv dsl env{envCtor=c} | c <- dataCtors input] f (MapField dsl) = OList [applyEnv dsl env{envField=i} | i <- [1.. fromIntegral $ ctorArity ctor]] diff --git a/Data/Derive/DSL/Derive.hs b/Data/Derive/DSL/Derive.hs --- a/Data/Derive/DSL/Derive.hs +++ b/Data/Derive/DSL/Derive.hs @@ -24,16 +24,17 @@ guess :: Output -> [Guess] - -guess (OApp "InstDecl" [OList ctxt,name,typ,bod]) +guess (OApp "InstDecl" [OApp "Nothing" [], OList [], OList ctxt,name,typ,bod]) | OApp "UnQual" [OApp "Ident" [OString name]] <- name , OList [OApp "TyParen" [OApp "TyApp" [OApp "TyCon" [OApp "UnQual" [OApp "Ident" [OString nam]]] ,OApp "TyVar" [OApp "Ident" [OString var]]]]] <- typ , nam == dataName sample - , ctxt <- [x | OApp "ClassA" [OApp "UnQual" [OApp "Ident" [OString x]],_] <- ctxt] + , ctxt <- [x | OApp "ClassA" [OApp "UnQual" [OApp "Ident" [OString x]],_] <- map unparenA ctxt] = [Guess $ Instance ctxt name y | Guess y <- guess bod] - + where + unparenA (OApp "ParenA" [x]) = unparenA x + unparenA x = x guess (OList xs) = guessList xs guess o@(OApp op xs) = gssFold o ++ gssApp o ++ map (lift (App op)) (guessList xs) diff --git a/Data/Derive/DSL/HSE.hs b/Data/Derive/DSL/HSE.hs --- a/Data/Derive/DSL/HSE.hs +++ b/Data/Derive/DSL/HSE.hs @@ -26,7 +26,7 @@ sample = DataDecl sl DataType [] (name "Sample") [tyVarBind "a"] ctrs [] where ctrs = [ctr "First" 0, ctr "Second" 2, ctr "Third" 1] - ctr s i = QualConDecl sl [] [] $ ConDecl (name s) $ replicate i $ UnBangedTy $ tyVar "a" + ctr s i = QualConDecl sl [] [] $ ConDecl (name s) $ replicate i $ tyVar "a" --------------------------------------------------------------------- diff --git a/Data/Derive/DSL/SYB.hs b/Data/Derive/DSL/SYB.hs --- a/Data/Derive/DSL/SYB.hs +++ b/Data/Derive/DSL/SYB.hs @@ -70,7 +70,7 @@ dinstance x = do Instance _ name bod <- return x bod <- syb bod - return $ InstDecl sl + return $ InstDecl sl Nothing [] [ClassA (UnQual $ Ident "Data") [TyVar $ Ident "d_type"]] (UnQual $ Ident name) [TyVar $ Ident "d_type"] bod diff --git a/Data/Derive/Data.hs b/Data/Derive/Data.hs --- a/Data/Derive/Data.hs +++ b/Data/Derive/Data.hs @@ -79,66 +79,66 @@ "Ident" (List [String "c"])])])]),App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String "-"])])]),App "Lit" (List [App "Int" (List [Int 1])])]),Concat (List [MapCtor (App "Alt" (List [ - App "PLit" (List [App "Int" (List [CtorIndex])]),App - "UnGuardedAlt" (List [Fold (App "InfixApp" (List [Head,App - "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String "$" - ])])]),Tail])) (Concat (List [MapField (Application (List [App - "Var" (List [App "UnQual" (List [App "Ident" (List [String "const" - ])])]),App "Var" (List [App "UnQual" (List [App "Ident" (List [ - String "k"])])]),App "Lit" (List [App "Int" (List [FieldIndex])])] - )),List [App "App" (List [App "Var" (List [App "UnQual" (List [App - "Ident" (List [String "z"])])]),App "Con" (List [App "UnQual" ( - List [App "Ident" (List [CtorName])])])])]]))]),App "BDecls" (List - [List []])])),List [App "Alt" (List [App "PVar" (List [App "Ident" - (List [String "i"])]),App "UnGuardedAlt" (List [App "InfixApp" ( + App "PLit" (List [App "Signless" (List []),App "Int" (List [ + CtorIndex])]),App "UnGuardedRhs" (List [Fold (App "InfixApp" (List + [Head,App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [ + String "$"])])]),Tail])) (Concat (List [MapField (Application ( List [App "Var" (List [App "UnQual" (List [App "Ident" (List [ - String "error"])])]),App "QVarOp" (List [App "UnQual" (List [App - "Symbol" (List [String "$"])])]),App "InfixApp" (List [App "Paren" - (List [App "InfixApp" (List [App "Lit" (List [App "String" (List [ - Concat (List [String "Data.gunfold for ",DataName])])]),App + String "const"])])]),App "Var" (List [App "UnQual" (List [App + "Ident" (List [String "k"])])]),App "Lit" (List [App "Int" (List [ + FieldIndex])])])),List [App "App" (List [App "Var" (List [App + "UnQual" (List [App "Ident" (List [String "z"])])]),App "Con" ( + List [App "UnQual" (List [App "Ident" (List [CtorName])])])])]]))] + ),App "BDecls" (List [List []])])),List [App "Alt" (List [App + "PVar" (List [App "Ident" (List [String "i"])]),App "UnGuardedRhs" + (List [App "InfixApp" (List [App "Var" (List [App "UnQual" (List [ + App "Ident" (List [String "error"])])]),App "QVarOp" (List [App + "UnQual" (List [App "Symbol" (List [String "$"])])]),App + "InfixApp" (List [App "Paren" (List [App "InfixApp" (List [App + "Lit" (List [App "String" (List [Concat (List [String + "Data.gunfold for ",DataName])])]),App "QVarOp" (List [App + "UnQual" (List [App "Symbol" (List [String "++"])])]),App "Lit" ( + List [App "String" (List [String ", unknown index: "])])])]),App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String - "++"])])]),App "Lit" (List [App "String" (List [String - ", unknown index: "])])])]),App "QVarOp" (List [App "UnQual" (List - [App "Symbol" (List [String "++"])])]),App "App" (List [App "Var" - (List [App "UnQual" (List [App "Ident" (List [String "show"])])]), - App "Var" (List [App "UnQual" (List [App "Ident" (List [String "i" - ])])])])])])]),App "BDecls" (List [List []])])]])])]),App "BDecls" - (List [List []])])]])]),App "InsDecl" (List [App "FunBind" (List [ - MapCtor (App "Match" (List [App "Ident" (List [String "toConstr"]) - ,List [App "PAsPat" (List [App "Ident" (List [String "x"]),App - "PRec" (List [App "UnQual" (List [App "Ident" (List [CtorName])]), - List []])])],App "Nothing" (List []),App "UnGuardedRhs" (List [ - Application (List [App "Var" (List [App "UnQual" (List [App - "Ident" (List [String "indexConstr"])])]),App "Paren" (List [App - "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" ( - List [String "dataTypeOf"])])]),App "Var" (List [App "UnQual" ( - List [App "Ident" (List [String "x"])])])])]),App "Paren" (List [ - App "InfixApp" (List [App "Lit" (List [App "Int" (List [CtorIndex] - )]),App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [ - String "+"])])]),App "Lit" (List [App "Int" (List [Int 1])])])])]) - ]),App "BDecls" (List [List []])]))])]),App "InsDecl" (List [App + "++"])])]),App "App" (List [App "Var" (List [App "UnQual" (List [ + App "Ident" (List [String "show"])])]),App "Var" (List [App + "UnQual" (List [App "Ident" (List [String "i"])])])])])])]),App + "BDecls" (List [List []])])]])])]),App "BDecls" (List [List []])]) + ]])]),App "InsDecl" (List [App "FunBind" (List [MapCtor (App + "Match" (List [App "Ident" (List [String "toConstr"]),List [App + "PAsPat" (List [App "Ident" (List [String "x"]),App "PRec" (List [ + App "UnQual" (List [App "Ident" (List [CtorName])]),List []])])], + App "Nothing" (List []),App "UnGuardedRhs" (List [Application ( + List [App "Var" (List [App "UnQual" (List [App "Ident" (List [ + String "indexConstr"])])]),App "Paren" (List [App "App" (List [App + "Var" (List [App "UnQual" (List [App "Ident" (List [String + "dataTypeOf"])])]),App "Var" (List [App "UnQual" (List [App + "Ident" (List [String "x"])])])])]),App "Paren" (List [App + "InfixApp" (List [App "Lit" (List [App "Int" (List [CtorIndex])]), + App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String + "+"])])]),App "Lit" (List [App "Int" (List [Int 1])])])])])]),App + "BDecls" (List [List []])]))])]),App "InsDecl" (List [App "FunBind" (List [List [App "Match" (List [App "Ident" (List [ String "dataTypeOf"]),List [App "PWildCard" (List [])],App "Nothing" (List []),App "UnGuardedRhs" (List [App "Var" (List [App "UnQual" (List [App "Ident" (List [String "ty"])])])]),App "BDecls" (List [List [App "PatBind" (List [App "PVar" (List [App - "Ident" (List [String "ty"])]),App "Nothing" (List []),App - "UnGuardedRhs" (List [Application (List [App "Var" (List [App - "UnQual" (List [App "Ident" (List [String "mkDataType"])])]),App - "SpliceExp" (List [App "ParenSplice" (List [App "Var" (List [App - "UnQual" (List [App "Ident" (List [String "dataName"])])])])]),App - "List" (List [MapCtor (Application (List [App "Var" (List [App - "UnQual" (List [App "Ident" (List [String "mkConstr"])])]),App - "Var" (List [App "UnQual" (List [App "Ident" (List [String "ty"])] - )]),App "Lit" (List [App "String" (List [CtorName])]),App - "SpliceExp" (List [App "ParenSplice" (List [App "App" (List [App - "Var" (List [App "UnQual" (List [App "Ident" (List [String - "ctorFields"])])]),App "Lit" (List [App "Int" (List [CtorIndex])]) - ])])]),App "SpliceExp" (List [App "ParenSplice" (List [App "App" ( - List [App "Var" (List [App "UnQual" (List [App "Ident" (List [ - String "ctorFixity"])])]),App "Lit" (List [App "Int" (List [ - CtorIndex])])])])])]))])])]),App "BDecls" (List [List []])])]])])] - ])])])] + "Ident" (List [String "ty"])]),App "UnGuardedRhs" (List [ + Application (List [App "Var" (List [App "UnQual" (List [App + "Ident" (List [String "mkDataType"])])]),App "SpliceExp" (List [ + App "ParenSplice" (List [App "Var" (List [App "UnQual" (List [App + "Ident" (List [String "dataName"])])])])]),App "List" (List [ + MapCtor (Application (List [App "Var" (List [App "UnQual" (List [ + App "Ident" (List [String "mkConstr"])])]),App "Var" (List [App + "UnQual" (List [App "Ident" (List [String "ty"])])]),App "Lit" ( + List [App "String" (List [CtorName])]),App "SpliceExp" (List [App + "ParenSplice" (List [App "App" (List [App "Var" (List [App + "UnQual" (List [App "Ident" (List [String "ctorFields"])])]),App + "Lit" (List [App "Int" (List [CtorIndex])])])])]),App "SpliceExp" + (List [App "ParenSplice" (List [App "App" (List [App "Var" (List [ + App "UnQual" (List [App "Ident" (List [String "ctorFixity"])])]), + App "Lit" (List [App "Int" (List [CtorIndex])])])])])]))])])]),App + "BDecls" (List [List []])])]])])]])])])] -- GENERATED STOP diff --git a/Data/Derive/DataAbstract.hs b/Data/Derive/DataAbstract.hs --- a/Data/Derive/DataAbstract.hs +++ b/Data/Derive/DataAbstract.hs @@ -34,26 +34,23 @@ ]),App "Var" (List [App "UnQual" (List [App "Ident" (List [String "x"])])])])]),App "BDecls" (List [List []])])]])]),App "InsDecl" ( List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [ - String "gunfold"])]),App "Nothing" (List []),App "UnGuardedRhs" ( - List [App "App" (List [App "Var" (List [App "UnQual" (List [App - "Ident" (List [String "error"])])]),App "Lit" (List [App "String" - (List [Concat (List [String - "Data.gunfold not implemented on abstract data type: ",DataName])] - )])])]),App "BDecls" (List [List []])])]),App "InsDecl" (List [App - "PatBind" (List [App "PVar" (List [App "Ident" (List [String - "toConstr"])]),App "Nothing" (List []),App "UnGuardedRhs" (List [ - App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" - (List [String "error"])])]),App "Lit" (List [App "String" (List [ - Concat (List [String - "Data.gunfold not implemented on abstract data type: ",DataName])] - )])])]),App "BDecls" (List [List []])])]),App "InsDecl" (List [App - "PatBind" (List [App "PVar" (List [App "Ident" (List [String - "dataTypeOf"])]),App "Nothing" (List []),App "UnGuardedRhs" (List - [App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" - (List [String "error"])])]),App "Lit" (List [App "String" (List [ - Concat (List [String - "Data.gunfold not implemented on abstract data type: ",DataName])] - )])])]),App "BDecls" (List [List []])])])])] + String "gunfold"])]),App "UnGuardedRhs" (List [App "App" (List [ + App "Var" (List [App "UnQual" (List [App "Ident" (List [String + "error"])])]),App "Lit" (List [App "String" (List [Concat (List [ + String "Data.gunfold not implemented on abstract data type: ", + DataName])])])])]),App "BDecls" (List [List []])])]),App "InsDecl" + (List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [ + String "toConstr"])]),App "UnGuardedRhs" (List [App "App" (List [ + App "Var" (List [App "UnQual" (List [App "Ident" (List [String + "error"])])]),App "Lit" (List [App "String" (List [Concat (List [ + String "Data.gunfold not implemented on abstract data type: ", + DataName])])])])]),App "BDecls" (List [List []])])]),App "InsDecl" + (List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [ + String "dataTypeOf"])]),App "UnGuardedRhs" (List [App "App" (List + [App "Var" (List [App "UnQual" (List [App "Ident" (List [String + "error"])])]),App "Lit" (List [App "String" (List [Concat (List [ + String "Data.gunfold not implemented on abstract data type: ", + DataName])])])])]),App "BDecls" (List [List []])])])])] -- GENERATED STOP custom = customContext context diff --git a/Data/Derive/Default.hs b/Data/Derive/Default.hs --- a/Data/Derive/Default.hs +++ b/Data/Derive/Default.hs @@ -20,14 +20,13 @@ dslDefault = List [Instance ["Default"] "Default" (List [App "InsDecl" (List [ App "PatBind" (List [App "PVar" (List [App "Ident" (List [String - "def"])]),App "Nothing" (List []),App "UnGuardedRhs" (List [App - "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" ( - List [String "head"])])]),App "List" (List [MapCtor (Application ( - Concat (List [List [App "Con" (List [App "UnQual" (List [App - "Ident" (List [CtorName])])])],MapField (App "Paren" (List [ - Application (List [App "Var" (List [App "UnQual" (List [App - "Ident" (List [String "const"])])]),App "Var" (List [App "UnQual" - (List [App "Ident" (List [String "def"])])]),App "Lit" (List [App - "Int" (List [FieldIndex])])])]))])))])])]),App "BDecls" (List [ - List []])])])])] + "def"])]),App "UnGuardedRhs" (List [App "App" (List [App "Var" ( + List [App "UnQual" (List [App "Ident" (List [String "head"])])]), + App "List" (List [MapCtor (Application (Concat (List [List [App + "Con" (List [App "UnQual" (List [App "Ident" (List [CtorName])])]) + ],MapField (App "Paren" (List [Application (List [App "Var" (List + [App "UnQual" (List [App "Ident" (List [String "const"])])]),App + "Var" (List [App "UnQual" (List [App "Ident" (List [String "def"]) + ])]),App "Lit" (List [App "Int" (List [FieldIndex])])])]))])))])]) + ]),App "BDecls" (List [List []])])])])] -- GENERATED STOP diff --git a/Data/Derive/Enum.hs b/Data/Derive/Enum.hs --- a/Data/Derive/Enum.hs +++ b/Data/Derive/Enum.hs @@ -26,27 +26,28 @@ dslEnum = List [Instance [] "Enum" (List [App "InsDecl" (List [App "FunBind" (List [Concat (List [MapCtor (App "Match" (List [App "Ident" (List - [String "toEnum"]),List [App "PLit" (List [App "Int" (List [ - CtorIndex])])],App "Nothing" (List []),App "UnGuardedRhs" (List [ - App "RecConstr" (List [App "UnQual" (List [App "Ident" (List [ - CtorName])]),List []])]),App "BDecls" (List [List []])])),List [ - App "Match" (List [App "Ident" (List [String "toEnum"]),List [App - "PVar" (List [App "Ident" (List [String "n"])])],App "Nothing" ( - List []),App "UnGuardedRhs" (List [App "InfixApp" (List [App "Var" - (List [App "UnQual" (List [App "Ident" (List [String "error"])])]) - ,App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [ - String "$"])])]),Fold (App "InfixApp" (List [Head,App "QVarOp" ( - List [App "UnQual" (List [App "Symbol" (List [String "++"])])]), - Tail])) (List [App "Lit" (List [App "String" (List [String - "toEnum "])]),App "App" (List [App "Var" (List [App "UnQual" (List - [App "Ident" (List [String "show"])])]),App "Var" (List [App - "UnQual" (List [App "Ident" (List [String "n"])])])]),App "Lit" ( - List [App "String" (List [String ", not defined for "])]),App - "Lit" (List [App "String" (List [DataName])])])])]),App "BDecls" ( - List [List []])])]])])]),App "InsDecl" (List [App "FunBind" (List - [MapCtor (App "Match" (List [App "Ident" (List [String "fromEnum"] - ),List [App "PParen" (List [App "PRec" (List [App "UnQual" (List [ - App "Ident" (List [CtorName])]),List []])])],App "Nothing" (List [ - ]),App "UnGuardedRhs" (List [App "Lit" (List [App "Int" (List [ - CtorIndex])])]),App "BDecls" (List [List []])]))])])])] + [String "toEnum"]),List [App "PLit" (List [App "Signless" (List [] + ),App "Int" (List [CtorIndex])])],App "Nothing" (List []),App + "UnGuardedRhs" (List [App "RecConstr" (List [App "UnQual" (List [ + App "Ident" (List [CtorName])]),List []])]),App "BDecls" (List [ + List []])])),List [App "Match" (List [App "Ident" (List [String + "toEnum"]),List [App "PVar" (List [App "Ident" (List [String "n"]) + ])],App "Nothing" (List []),App "UnGuardedRhs" (List [App + "InfixApp" (List [App "Var" (List [App "UnQual" (List [App "Ident" + (List [String "error"])])]),App "QVarOp" (List [App "UnQual" (List + [App "Symbol" (List [String "$"])])]),Fold (App "InfixApp" (List [ + Head,App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [ + String "++"])])]),Tail])) (List [App "Lit" (List [App "String" ( + List [String "toEnum "])]),App "App" (List [App "Var" (List [App + "UnQual" (List [App "Ident" (List [String "show"])])]),App "Var" ( + List [App "UnQual" (List [App "Ident" (List [String "n"])])])]), + App "Lit" (List [App "String" (List [String ", not defined for "]) + ]),App "Lit" (List [App "String" (List [DataName])])])])]),App + "BDecls" (List [List []])])]])])]),App "InsDecl" (List [App + "FunBind" (List [MapCtor (App "Match" (List [App "Ident" (List [ + String "fromEnum"]),List [App "PParen" (List [App "PRec" (List [ + App "UnQual" (List [App "Ident" (List [CtorName])]),List []])])], + App "Nothing" (List []),App "UnGuardedRhs" (List [App "Lit" (List + [App "Int" (List [CtorIndex])])]),App "BDecls" (List [List []])])) + ])])])] -- GENERATED STOP diff --git a/Data/Derive/EnumCyclic.hs b/Data/Derive/EnumCyclic.hs --- a/Data/Derive/EnumCyclic.hs +++ b/Data/Derive/EnumCyclic.hs @@ -33,22 +33,22 @@ dslEnumCyclic = List [Instance [] "Enum" (List [App "InsDecl" (List [App "FunBind" (List [Concat (List [MapCtor (App "Match" (List [App "Ident" (List - [String "toEnum"]),List [App "PLit" (List [App "Int" (List [ - CtorIndex])])],App "Nothing" (List []),App "UnGuardedRhs" (List [ - App "RecConstr" (List [App "UnQual" (List [App "Ident" (List [ - CtorName])]),List []])]),App "BDecls" (List [List []])])),List [ - App "Match" (List [App "Ident" (List [String "toEnum"]),List [App - "PVar" (List [App "Ident" (List [String "n"])])],App "Nothing" ( - List []),App "UnGuardedRhs" (List [App "InfixApp" (List [App "Var" - (List [App "UnQual" (List [App "Ident" (List [String "error"])])]) - ,App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [ - String "$"])])]),Fold (App "InfixApp" (List [Head,App "QVarOp" ( - List [App "UnQual" (List [App "Symbol" (List [String "++"])])]), - Tail])) (List [App "Lit" (List [App "String" (List [String - "toEnum "])]),App "App" (List [App "Var" (List [App "UnQual" (List - [App "Ident" (List [String "show"])])]),App "Var" (List [App - "UnQual" (List [App "Ident" (List [String "n"])])])]),App "Lit" ( - List [App "String" (List [Concat (List [String + [String "toEnum"]),List [App "PLit" (List [App "Signless" (List [] + ),App "Int" (List [CtorIndex])])],App "Nothing" (List []),App + "UnGuardedRhs" (List [App "RecConstr" (List [App "UnQual" (List [ + App "Ident" (List [CtorName])]),List []])]),App "BDecls" (List [ + List []])])),List [App "Match" (List [App "Ident" (List [String + "toEnum"]),List [App "PVar" (List [App "Ident" (List [String "n"]) + ])],App "Nothing" (List []),App "UnGuardedRhs" (List [App + "InfixApp" (List [App "Var" (List [App "UnQual" (List [App "Ident" + (List [String "error"])])]),App "QVarOp" (List [App "UnQual" (List + [App "Symbol" (List [String "$"])])]),Fold (App "InfixApp" (List [ + Head,App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [ + String "++"])])]),Tail])) (List [App "Lit" (List [App "String" ( + List [String "toEnum "])]),App "App" (List [App "Var" (List [App + "UnQual" (List [App "Ident" (List [String "show"])])]),App "Var" ( + List [App "UnQual" (List [App "Ident" (List [String "n"])])])]), + App "Lit" (List [App "String" (List [Concat (List [String ", not defined for ",DataName])])])])])]),App "BDecls" (List [List []])])]])])]),App "InsDecl" (List [App "FunBind" (List [MapCtor ( App "Match" (List [App "Ident" (List [String "fromEnum"]),List [ @@ -74,32 +74,31 @@ List [App "UnQual" (List [App "Symbol" (List [String "+"])])]),App "Lit" (List [App "Int" (List [Int 1])])])])])])]),App "BDecls" ( List [List [App "PatBind" (List [App "PVar" (List [App "Ident" ( - List [String "b"])]),App "Nothing" (List []),App "UnGuardedRhs" ( - List [App "App" (List [App "Var" (List [App "UnQual" (List [App - "Ident" (List [String "fromEnum"])])]),App "Var" (List [App - "UnQual" (List [App "Ident" (List [String "a"])])])])]),App - "BDecls" (List [List []])])]])])]])]),App "InsDecl" (List [App - "FunBind" (List [List [App "Match" (List [App "Ident" (List [ - String "pred"]),List [App "PVar" (List [App "Ident" (List [String - "a"])])],App "Nothing" (List []),App "UnGuardedRhs" (List [App - "If" (List [App "InfixApp" (List [App "Var" (List [App "UnQual" ( - List [App "Ident" (List [String "b"])])]),App "QVarOp" (List [App - "UnQual" (List [App "Symbol" (List [String "=="])])]),App "Lit" ( - List [App "Int" (List [Int 0])])]),App "App" (List [App "Var" ( - List [App "UnQual" (List [App "Ident" (List [String "toEnum"])])]) - ,App "Paren" (List [App "App" (List [App "Var" (List [App "UnQual" - (List [App "Ident" (List [String "length"])])]),App "List" (List [ - MapCtor (App "RecConstr" (List [App "UnQual" (List [App "Ident" ( - List [CtorName])]),List []]))])])])]),App "App" (List [App "Var" ( - List [App "UnQual" (List [App "Ident" (List [String "toEnum"])])]) - ,App "Paren" (List [App "InfixApp" (List [App "Var" (List [App - "UnQual" (List [App "Ident" (List [String "b"])])]),App "QVarOp" ( - List [App "UnQual" (List [App "Symbol" (List [String "-"])])]),App - "Lit" (List [App "Int" (List [Int 1])])])])])])]),App "BDecls" ( - List [List [App "PatBind" (List [App "PVar" (List [App "Ident" ( - List [String "b"])]),App "Nothing" (List []),App "UnGuardedRhs" ( - List [App "App" (List [App "Var" (List [App "UnQual" (List [App - "Ident" (List [String "fromEnum"])])]),App "Var" (List [App - "UnQual" (List [App "Ident" (List [String "a"])])])])]),App - "BDecls" (List [List []])])]])])]])])])] + List [String "b"])]),App "UnGuardedRhs" (List [App "App" (List [ + App "Var" (List [App "UnQual" (List [App "Ident" (List [String + "fromEnum"])])]),App "Var" (List [App "UnQual" (List [App "Ident" + (List [String "a"])])])])]),App "BDecls" (List [List []])])]])])]] + )]),App "InsDecl" (List [App "FunBind" (List [List [App "Match" ( + List [App "Ident" (List [String "pred"]),List [App "PVar" (List [ + App "Ident" (List [String "a"])])],App "Nothing" (List []),App + "UnGuardedRhs" (List [App "If" (List [App "InfixApp" (List [App + "Var" (List [App "UnQual" (List [App "Ident" (List [String "b"])]) + ]),App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [ + String "=="])])]),App "Lit" (List [App "Int" (List [Int 0])])]), + App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" + (List [String "toEnum"])])]),App "Paren" (List [App "App" (List [ + App "Var" (List [App "UnQual" (List [App "Ident" (List [String + "length"])])]),App "List" (List [MapCtor (App "RecConstr" (List [ + App "UnQual" (List [App "Ident" (List [CtorName])]),List []]))])]) + ])]),App "App" (List [App "Var" (List [App "UnQual" (List [App + "Ident" (List [String "toEnum"])])]),App "Paren" (List [App + "InfixApp" (List [App "Var" (List [App "UnQual" (List [App "Ident" + (List [String "b"])])]),App "QVarOp" (List [App "UnQual" (List [ + App "Symbol" (List [String "-"])])]),App "Lit" (List [App "Int" ( + List [Int 1])])])])])])]),App "BDecls" (List [List [App "PatBind" + (List [App "PVar" (List [App "Ident" (List [String "b"])]),App + "UnGuardedRhs" (List [App "App" (List [App "Var" (List [App + "UnQual" (List [App "Ident" (List [String "fromEnum"])])]),App + "Var" (List [App "UnQual" (List [App "Ident" (List [String "a"])]) + ])])]),App "BDecls" (List [List []])])]])])]])])])] -- GENERATED STOP diff --git a/Data/Derive/Fold.hs b/Data/Derive/Fold.hs --- a/Data/Derive/Fold.hs +++ b/Data/Derive/Fold.hs @@ -62,5 +62,5 @@ where dt = dataDeclType d v = head $ map (tyVar . return) ['a'..] \\ universe dt - f c = TyParen $ tyFun $ map (fromBangType . snd) (ctorDeclFields c) ++ [v] + f c = TyParen $ tyFun $ map snd (ctorDeclFields c) ++ [v] diff --git a/Data/Derive/From.hs b/Data/Derive/From.hs --- a/Data/Derive/From.hs +++ b/Data/Derive/From.hs @@ -43,7 +43,7 @@ from = "from" ++ n typ = TyFun (dataDeclType d) - (tyTuple $ map (fromBangType . snd) $ ctorDeclFields c) + (tyTuple $ map snd $ ctorDeclFields c) match = Match sl (name from) [pat] Nothing (UnGuardedRhs rhs) (BDecls []) pat = (length vars == 0 ? id $ PParen) $ PApp (qname n) (map pVar vars) diff --git a/Data/Derive/Instance/Arities.hs b/Data/Derive/Instance/Arities.hs --- a/Data/Derive/Instance/Arities.hs +++ b/Data/Derive/Instance/Arities.hs @@ -7,7 +7,7 @@ import Data.Derive.Internal.Instance -instance (Data d_type) => Arities d_type where +instance Data d_type => Arities d_type where arities _ = [const (d_ctorArity d_ctor) (d_ctorValue d_ctor :: d_type) | d_ctor <- d_dataCtors (undefined :: d_type)] diff --git a/Data/Derive/Internal/Derivation.hs b/Data/Derive/Internal/Derivation.hs --- a/Data/Derive/Internal/Derivation.hs +++ b/Data/Derive/Internal/Derivation.hs @@ -43,7 +43,7 @@ customContext :: (FullDataDecl -> Context -> Context) -> (FullDataDecl -> [Decl] -> [Decl]) -customContext custom d = map f +customContext custom ds = map f where - f (InstDecl sl ctx a b c) = InstDecl sl (custom d ctx) a b c + f (InstDecl sl a b ctx c d e) = InstDecl sl a b (custom ds ctx) c d e f x = x diff --git a/Data/Derive/Internal/Traversal.hs b/Data/Derive/Internal/Traversal.hs --- a/Data/Derive/Internal/Traversal.hs +++ b/Data/Derive/Internal/Traversal.hs @@ -12,7 +12,7 @@ -- NOTE: Cannot be guessed as it relies on type information -- | Derives 'Functor' and similair classes, as discussed on the Haskell-prime mailing list: --- . +-- . module Data.Derive.Internal.Traversal( TraveralType(..), defaultTraversalType, traversalDerivation1, @@ -29,27 +29,27 @@ import Data.Generics.Uniplate.DataOnly import Data.Maybe ---------------------------------------------------------------------------------- --- Information datatype, public interface - --- | An expression representing a traversal of a subpart of the data -type Trav = Exp - --- | What kind of traversal are we deriving? -data TraveralType = TraveralType - { traversalArg :: Int -- ^ On what position are we traversing? - , traversalCo :: Bool -- ^ covariant? - , traversalName :: QName -- ^ name of the traversal function - , traversalId :: Trav -- ^ Identity traversal - , traversalDirect :: Trav -- ^ Traversal of 'a' - , traversalFunc :: QName -> Trav -> Trav -- ^ Apply the sub-traversal function - , traversalPlus :: Trav -> Trav -> Trav -- ^ Apply two non-identity traversals in sequence - , traverseArrow :: Maybe (Trav -> Trav -> Trav) -- ^ Traverse a function type - , traverseTuple :: [Exp] -> Exp -- ^ Construct a tuple from applied traversals - , traverseCtor :: String -> [Exp] -> Exp -- ^ Construct a data type from applied traversals - , traverseFunc :: Pat -> Exp -> Match -- ^ Construct a clause of the traversal function - } +--------------------------------------------------------------------------------- +-- Information datatype, public interface +-- | An expression representing a traversal of a subpart of the data +type Trav = Exp + +-- | What kind of traversal are we deriving? +data TraveralType = TraveralType + { traversalArg :: Int -- ^ On what position are we traversing? + , traversalCo :: Bool -- ^ covariant? + , traversalName :: QName -- ^ name of the traversal function + , traversalId :: Trav -- ^ Identity traversal + , traversalDirect :: Trav -- ^ Traversal of 'a' + , traversalFunc :: QName -> Trav -> Trav -- ^ Apply the sub-traversal function + , traversalPlus :: Trav -> Trav -> Trav -- ^ Apply two non-identity traversals in sequence + , traverseArrow :: Maybe (Trav -> Trav -> Trav) -- ^ Traverse a function type + , traverseTuple :: [Exp] -> Exp -- ^ Construct a tuple from applied traversals + , traverseCtor :: String -> [Exp] -> Exp -- ^ Construct a data type from applied traversals + , traverseFunc :: Pat -> Exp -> Match -- ^ Construct a clause of the traversal function + } + defaultTraversalType = TraveralType { traversalArg = 1 , traversalCo = False @@ -78,7 +78,7 @@ --------------------------------------------------------------------------------- --- Deriving traversals +-- Deriving traversals -- | Derivation for a Traversable like class with just 1 method @@ -97,7 +97,7 @@ -- | Instance for a Traversable like class traversalInstance :: TraveralType -> String -> DataDecl -> [WithInstances Decl] -> [Decl] -traversalInstance tt nameBase dat bodyM = [simplify $ InstDecl sl ctx nam args (map InsDecl body)] +traversalInstance tt nameBase dat bodyM = [simplify $ InstDecl sl Nothing [] ctx nam args (map InsDecl body)] where (body, required) = runWriter (sequence bodyM) ctx = [ ClassA (qname $ className p) (tyVar n : vars tyVar 's' (p - 1)) @@ -128,7 +128,7 @@ deriveTraversalCtor tt ap ctor = do let nam = ctorDeclName ctor arity = ctorDeclArity ctor - tTypes <- mapM (deriveTraversalType tt ap) (map (fromBangType . snd) $ ctorDeclFields ctor) + tTypes <- mapM (deriveTraversalType tt ap) (map snd $ ctorDeclFields ctor) return $ traverseFunc tt (PParen $ PApp (qname nam) (vars pVar 'a' arity)) $ traverseCtor tt nam (zipWith App tTypes (vars var 'a' arity)) diff --git a/Data/Derive/JSON.hs b/Data/Derive/JSON.hs --- a/Data/Derive/JSON.hs +++ b/Data/Derive/JSON.hs @@ -17,7 +17,7 @@ import qualified Language.Haskell as H import Language.Haskell ( - Exp, Pat, Alt, CtorDecl, Decl, FullDataDecl, FieldDecl, BangType, Stmt, + Exp, Pat, Alt, CtorDecl, Decl, FullDataDecl, FieldDecl, Type, Stmt, (~=), var, pVar, con, strE, strP, apps, qname, sl, ctorDeclFields, ctorDeclName, dataDeclCtors) @@ -106,7 +106,7 @@ in H.Case (var "fromJSObject" `H.App` var "x") $ map mkReadCtor (dataDeclCtors d) ++ - [H.Alt H.sl H.PWildCard (H.UnGuardedAlt readError) (H.BDecls [])] + [H.Alt H.sl H.PWildCard (H.UnGuardedRhs readError) (H.BDecls [])] mkReadCtor :: CtorDecl -> Alt mkReadCtor c = let @@ -117,19 +117,19 @@ | otherwise = mkReadPlain cn fs in H.Alt sl (H.PList [H.PTuple H.Boxed [strP cn, pVar "y"]]) - (H.UnGuardedAlt body) (H.BDecls []) + (H.UnGuardedRhs body) (H.BDecls []) mkReadRecord :: String -> FieldDecl -> Exp mkReadRecord cn fs = H.Do $ [H.Generator sl (H.PApp (qname "JSObject") [pVar "z"]) (var "return" `H.App` var "y")] ++ - [H.LetStmt $ H.BDecls [H.PatBind sl (pVar "d") Nothing + [H.LetStmt $ H.BDecls [H.PatBind sl (pVar "d") (H.UnGuardedRhs $ var "fromJSObject" `H.App` var "z") (H.BDecls [])]] ++ zipWith (mkReadRecordField cn) (pVars "x" fs) fs ++ mkReadTrailer cn fs -mkReadRecordField :: String -> Pat -> (String, BangType) -> Stmt +mkReadRecordField :: String -> Pat -> (String, Type) -> Stmt mkReadRecordField cn xi (fn, _) = H.Generator sl xi $ apps (var "maybe") [ var "fail" `H.App` strE (unwords ["readJSON: missing field", fn, diff --git a/Data/Derive/LazySet.hs b/Data/Derive/LazySet.hs --- a/Data/Derive/LazySet.hs +++ b/Data/Derive/LazySet.hs @@ -32,7 +32,7 @@ where fun = "set" ++ title field typ = t `TyFun` (dataDeclType d `TyFun` dataDeclType d) - (t,c):tc = [(fromBangType t,c) | c <- dataDeclCtors d, (n,t) <- ctorDeclFields c, n == field] + (t,c):tc = [(t,c) | c <- dataDeclCtors d, (n,t) <- ctorDeclFields c, n == field] bod | null tc = apps (con $ ctorDeclName c) [n == field ? var "v" $ Paren $ App (var n) (var "x") | (n,t) <- ctorDeclFields c] | otherwise = RecUpdate (var "x") [FieldUpdate (qname field) (var "v")] diff --git a/Data/Derive/Lens.hs b/Data/Derive/Lens.hs --- a/Data/Derive/Lens.hs +++ b/Data/Derive/Lens.hs @@ -33,7 +33,7 @@ makeLensField d field = [TypeSig sl [name ref] typ, bind ref [] bod] where ref = "lens" ++ title field - typ = tyApps (tyCon "Lens") [dataDeclType d, fromBangType t] + typ = tyApps (tyCon "Lens") [dataDeclType d, t] Just t = lookup field $ concatMap ctorDeclFields $ dataDeclCtors d bod = apps (var "lens") diff --git a/Data/Derive/Monoid.hs b/Data/Derive/Monoid.hs --- a/Data/Derive/Monoid.hs +++ b/Data/Derive/Monoid.hs @@ -27,43 +27,43 @@ dslMonoid = List [Instance ["Monoid"] "Monoid" (List [App "InsDecl" (List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [String - "mempty"])]),App "Nothing" (List []),App "UnGuardedRhs" (List [App - "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" ( - List [String "head"])])]),App "List" (List [MapCtor (Application ( - Concat (List [List [App "Con" (List [App "UnQual" (List [App - "Ident" (List [CtorName])])])],MapField (App "Paren" (List [ - Application (List [App "Var" (List [App "UnQual" (List [App - "Ident" (List [String "const"])])]),App "Var" (List [App "UnQual" - (List [App "Ident" (List [String "mempty"])])]),App "Lit" (List [ - App "Int" (List [FieldIndex])])])]))])))])])]),App "BDecls" (List - [List []])])]),App "InsDecl" (List [App "FunBind" (List [Concat ( - List [MapCtor (App "Match" (List [App "Ident" (List [String - "mappend"]),List [App "PParen" (List [App "PApp" (List [App - "UnQual" (List [App "Ident" (List [CtorName])]),MapField (App - "PVar" (List [App "Ident" (List [Concat (List [String "x",ShowInt - FieldIndex])])]))])]),App "PParen" (List [App "PApp" (List [App - "UnQual" (List [App "Ident" (List [CtorName])]),MapField (App - "PVar" (List [App "Ident" (List [Concat (List [String "y",ShowInt - FieldIndex])])]))])])],App "Nothing" (List []),App "UnGuardedRhs" - (List [Application (Concat (List [List [App "Con" (List [App - "UnQual" (List [App "Ident" (List [CtorName])])])],MapField (App - "Paren" (List [Application (List [App "Var" (List [App "UnQual" ( - List [App "Ident" (List [String "mappend"])])]),App "Var" (List [ - App "UnQual" (List [App "Ident" (List [Concat (List [String "x", - ShowInt FieldIndex])])])]),App "Var" (List [App "UnQual" (List [ - App "Ident" (List [Concat (List [String "y",ShowInt FieldIndex])]) - ])])])]))]))]),App "BDecls" (List [List []])])),List [App "Match" - (List [App "Ident" (List [String "mappend"]),List [App "PWildCard" - (List []),App "PWildCard" (List [])],App "Nothing" (List []),App - "GuardedRhss" (List [List [App "GuardedRhs" (List [List [App - "Qualifier" (List [App "InfixApp" (List [App "App" (List [App + "mempty"])]),App "UnGuardedRhs" (List [App "App" (List [App "Var" + (List [App "UnQual" (List [App "Ident" (List [String "head"])])]), + App "List" (List [MapCtor (Application (Concat (List [List [App + "Con" (List [App "UnQual" (List [App "Ident" (List [CtorName])])]) + ],MapField (App "Paren" (List [Application (List [App "Var" (List + [App "UnQual" (List [App "Ident" (List [String "const"])])]),App "Var" (List [App "UnQual" (List [App "Ident" (List [String - "length"])])]),App "List" (List [MapCtor (App "RecConstr" (List [ - App "UnQual" (List [App "Ident" (List [CtorName])]),List []]))])]) - ,App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [ - String ">"])])]),App "Lit" (List [App "Int" (List [Int 1])])])])], - App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" - (List [String "error"])])]),App "Lit" (List [App "String" (List [ - Concat (List [String "Monoid.mappend: Different constructors for " - ,DataName])])])])])]]),App "BDecls" (List [List []])])]])])])])] + "mempty"])])]),App "Lit" (List [App "Int" (List [FieldIndex])])])] + ))])))])])]),App "BDecls" (List [List []])])]),App "InsDecl" (List + [App "FunBind" (List [Concat (List [MapCtor (App "Match" (List [ + App "Ident" (List [String "mappend"]),List [App "PParen" (List [ + App "PApp" (List [App "UnQual" (List [App "Ident" (List [CtorName] + )]),MapField (App "PVar" (List [App "Ident" (List [Concat (List [ + String "x",ShowInt FieldIndex])])]))])]),App "PParen" (List [App + "PApp" (List [App "UnQual" (List [App "Ident" (List [CtorName])]), + MapField (App "PVar" (List [App "Ident" (List [Concat (List [ + String "y",ShowInt FieldIndex])])]))])])],App "Nothing" (List []), + App "UnGuardedRhs" (List [Application (Concat (List [List [App + "Con" (List [App "UnQual" (List [App "Ident" (List [CtorName])])]) + ],MapField (App "Paren" (List [Application (List [App "Var" (List + [App "UnQual" (List [App "Ident" (List [String "mappend"])])]),App + "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (List [ + String "x",ShowInt FieldIndex])])])]),App "Var" (List [App + "UnQual" (List [App "Ident" (List [Concat (List [String "y", + ShowInt FieldIndex])])])])])]))]))]),App "BDecls" (List [List []]) + ])),List [App "Match" (List [App "Ident" (List [String "mappend"]) + ,List [App "PWildCard" (List []),App "PWildCard" (List [])],App + "Nothing" (List []),App "GuardedRhss" (List [List [App + "GuardedRhs" (List [List [App "Qualifier" (List [App "InfixApp" ( + List [App "App" (List [App "Var" (List [App "UnQual" (List [App + "Ident" (List [String "length"])])]),App "List" (List [MapCtor ( + App "RecConstr" (List [App "UnQual" (List [App "Ident" (List [ + CtorName])]),List []]))])]),App "QVarOp" (List [App "UnQual" (List + [App "Symbol" (List [String ">"])])]),App "Lit" (List [App "Int" ( + List [Int 1])])])])],App "App" (List [App "Var" (List [App + "UnQual" (List [App "Ident" (List [String "error"])])]),App "Lit" + (List [App "String" (List [Concat (List [String + "Monoid.mappend: Different constructors for ",DataName])])])])])]] + ),App "BDecls" (List [List []])])]])])])])] -- GENERATED STOP diff --git a/Data/Derive/Read.hs b/Data/Derive/Read.hs --- a/Data/Derive/Read.hs +++ b/Data/Derive/Read.hs @@ -155,7 +155,7 @@ matchStr :: String -> Int -> QualStmt -matchStr s i = QualStmt $ Generator sl (PTuple Boxed [PLit $ H.String s, pVar $ 'r':show (i+1)]) (var "lex" `H.App` var ('r':show i)) +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)) diff --git a/Data/Derive/Serial.hs b/Data/Derive/Serial.hs --- a/Data/Derive/Serial.hs +++ b/Data/Derive/Serial.hs @@ -30,37 +30,36 @@ dslSerial = List [Instance ["Serial"] "Serial" (List [App "InsDecl" (List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [String - "series"])]),App "Nothing" (List []),App "UnGuardedRhs" (List [ - Fold (App "InfixApp" (List [Tail,App "QVarOp" (List [App "UnQual" - (List [App "Symbol" (List [String "\\/"])])]),Head])) (Reverse ( - MapCtor (App "App" (List [App "Var" (List [App "UnQual" (List [App - "Ident" (List [Concat (List [String "cons",ShowInt CtorArity])])]) - ]),App "Con" (List [App "UnQual" (List [App "Ident" (List [ - CtorName])])])]))))]),App "BDecls" (List [List []])])]),App - "InsDecl" (List [App "FunBind" (List [List [App "Match" (List [App - "Ident" (List [String "coseries"]),List [App "PVar" (List [App - "Ident" (List [String "rs"])]),App "PVar" (List [App "Ident" (List - [String "d"])])],App "Nothing" (List []),App "UnGuardedRhs" (List - [App "ListComp" (List [App "Lambda" (List [List [App "PVar" (List - [App "Ident" (List [String "t"])])],App "Case" (List [App "Var" ( - List [App "UnQual" (List [App "Ident" (List [String "t"])])]), - MapCtor (App "Alt" (List [App "PApp" (List [App "UnQual" (List [ - App "Ident" (List [CtorName])]),MapField (App "PVar" (List [App - "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])])]))] - ),App "UnGuardedAlt" (List [Application (Concat (List [List [App + "series"])]),App "UnGuardedRhs" (List [Fold (App "InfixApp" (List + [Tail,App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [ + String "\\/"])])]),Head])) (Reverse (MapCtor (App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (List [ - String "t",ShowInt CtorIndex])])])])],MapField (App "Var" (List [ - App "UnQual" (List [App "Ident" (List [Concat (List [String "x", - ShowInt FieldIndex])])])]))]))]),App "BDecls" (List [List []])]))] - )]),MapCtor (App "QualStmt" (List [App "Generator" (List [App - "PVar" (List [App "Ident" (List [Concat (List [String "t",ShowInt - CtorIndex])])]),App "InfixApp" (List [Application (List [App "Var" - (List [App "UnQual" (List [App "Ident" (List [Concat (List [String - "alts",ShowInt CtorArity])])])]),App "Var" (List [App "UnQual" ( - List [App "Ident" (List [String "rs"])])]),App "Var" (List [App - "UnQual" (List [App "Ident" (List [String "d"])])])]),App "QVarOp" - (List [App "UnQual" (List [App "Ident" (List [String "const"])])]) - ,App "RecConstr" (List [App "UnQual" (List [App "Ident" (List [ - CtorName])]),List []])])])]))])]),App "BDecls" (List [List []])])] - ])])])] + String "cons",ShowInt CtorArity])])])]),App "Con" (List [App + "UnQual" (List [App "Ident" (List [CtorName])])])]))))]),App + "BDecls" (List [List []])])]),App "InsDecl" (List [App "FunBind" ( + List [List [App "Match" (List [App "Ident" (List [String + "coseries"]),List [App "PVar" (List [App "Ident" (List [String + "rs"])]),App "PVar" (List [App "Ident" (List [String "d"])])],App + "Nothing" (List []),App "UnGuardedRhs" (List [App "ListComp" (List + [App "Lambda" (List [List [App "PVar" (List [App "Ident" (List [ + String "t"])])],App "Case" (List [App "Var" (List [App "UnQual" ( + List [App "Ident" (List [String "t"])])]),MapCtor (App "Alt" (List + [App "PApp" (List [App "UnQual" (List [App "Ident" (List [CtorName + ])]),MapField (App "PVar" (List [App "Ident" (List [Concat (List [ + String "x",ShowInt FieldIndex])])]))]),App "UnGuardedRhs" (List [ + Application (Concat (List [List [App "Var" (List [App "UnQual" ( + List [App "Ident" (List [Concat (List [String "t",ShowInt + CtorIndex])])])])],MapField (App "Var" (List [App "UnQual" (List [ + App "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])]) + ])]))]))]),App "BDecls" (List [List []])]))])]),MapCtor (App + "QualStmt" (List [App "Generator" (List [App "PVar" (List [App + "Ident" (List [Concat (List [String "t",ShowInt CtorIndex])])]), + App "InfixApp" (List [Application (List [App "Var" (List [App + "UnQual" (List [App "Ident" (List [Concat (List [String "alts", + ShowInt CtorArity])])])]),App "Var" (List [App "UnQual" (List [App + "Ident" (List [String "rs"])])]),App "Var" (List [App "UnQual" ( + List [App "Ident" (List [String "d"])])])]),App "QVarOp" (List [ + App "UnQual" (List [App "Ident" (List [String "const"])])]),App + "RecConstr" (List [App "UnQual" (List [App "Ident" (List [CtorName + ])]),List []])])])]))])]),App "BDecls" (List [List []])])]])])])] -- GENERATED STOP diff --git a/Data/Derive/Serialize.hs b/Data/Derive/Serialize.hs --- a/Data/Derive/Serialize.hs +++ b/Data/Derive/Serialize.hs @@ -64,7 +64,7 @@ (List [String "x"])])]),MapCtor (App "Alt" (List [App "PApp" (List [App "UnQual" (List [App "Ident" (List [CtorName])]),MapField (App "PVar" (List [App "Ident" (List [Concat (List [String "x",ShowInt - FieldIndex])])]))]),App "UnGuardedAlt" (List [App "Do" (List [ + FieldIndex])])]))]),App "UnGuardedRhs" (List [App "Do" (List [ Concat (List [List [App "Qualifier" (List [App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" (List [String "putTag"])])]),App "Lit" (List [App "Int" (List [CtorIndex])])])]) @@ -74,61 +74,61 @@ List [String "x",ShowInt FieldIndex])])])])])]))])])]),App "BDecls" (List [List []])]))])]),App "BDecls" (List [List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [String - "useTag"])]),App "Nothing" (List []),App "UnGuardedRhs" (List [App - "InfixApp" (List [App "App" (List [App "Var" (List [App "UnQual" ( - List [App "Ident" (List [String "length"])])]),App "List" (List [ - MapCtor (App "RecConstr" (List [App "UnQual" (List [App "Ident" ( - List [CtorName])]),List []]))])]),App "QVarOp" (List [App "UnQual" - (List [App "Symbol" (List [String ">"])])]),App "Lit" (List [App - "Int" (List [Int 1])])])]),App "BDecls" (List [List []])]),App - "FunBind" (List [List [App "Match" (List [App "Ident" (List [ - String "putTag"]),List [App "PVar" (List [App "Ident" (List [ - String "x"])])],App "Nothing" (List []),App "UnGuardedRhs" (List [ - Application (List [App "Var" (List [App "UnQual" (List [App - "Ident" (List [String "when"])])]),App "Var" (List [App "UnQual" ( - List [App "Ident" (List [String "useTag"])])]),App "Paren" (List [ - App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" - (List [Concat (List [String "putWord",ShowInt (Int 8)])])])]),App - "Var" (List [App "UnQual" (List [App "Ident" (List [String "x"])]) - ])])])])]),App "BDecls" (List [List []])])]])]])])]])]),App - "InsDecl" (List [App "PatBind" (List [App "PVar" (List [App - "Ident" (List [String "get"])]),App "Nothing" (List []),App - "UnGuardedRhs" (List [App "Do" (List [List [App "Generator" (List - [App "PVar" (List [App "Ident" (List [String "i"])]),App "Var" ( - List [App "UnQual" (List [App "Ident" (List [String "getTag"])])]) - ]),App "Qualifier" (List [App "Case" (List [App "Var" (List [App - "UnQual" (List [App "Ident" (List [String "i"])])]),Concat (List [ - MapCtor (App "Alt" (List [App "PLit" (List [App "Int" (List [ - CtorIndex])]),App "UnGuardedAlt" (List [App "Do" (List [Concat ( - List [MapField (App "Generator" (List [App "PVar" (List [App - "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])])]), + "useTag"])]),App "UnGuardedRhs" (List [App "InfixApp" (List [App + "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" ( + List [String "length"])])]),App "List" (List [MapCtor (App + "RecConstr" (List [App "UnQual" (List [App "Ident" (List [CtorName + ])]),List []]))])]),App "QVarOp" (List [App "UnQual" (List [App + "Symbol" (List [String ">"])])]),App "Lit" (List [App "Int" (List + [Int 1])])])]),App "BDecls" (List [List []])]),App "FunBind" (List + [List [App "Match" (List [App "Ident" (List [String "putTag"]), + List [App "PVar" (List [App "Ident" (List [String "x"])])],App + "Nothing" (List []),App "UnGuardedRhs" (List [Application (List [ App "Var" (List [App "UnQual" (List [App "Ident" (List [String - "get"])])])])),List [App "Qualifier" (List [App "App" (List [App - "Var" (List [App "UnQual" (List [App "Ident" (List [String - "return"])])]),App "Paren" (List [Application (Concat (List [List - [App "Con" (List [App "UnQual" (List [App "Ident" (List [CtorName] - )])])],MapField (App "Var" (List [App "UnQual" (List [App "Ident" - (List [Concat (List [String "x",ShowInt FieldIndex])])])]))]))])]) - ])]])])]),App "BDecls" (List [List []])])),List [App "Alt" (List [ - App "PWildCard" (List []),App "UnGuardedAlt" (List [App "App" ( - List [App "Var" (List [App "UnQual" (List [App "Ident" (List [ - String "error"])])]),App "Lit" (List [App "String" (List [Concat ( - List [String "Corrupted binary data for ",DataName])])])])]),App - "BDecls" (List [List []])])]])])])]])]),App "BDecls" (List [List [ + "when"])])]),App "Var" (List [App "UnQual" (List [App "Ident" ( + List [String "useTag"])])]),App "Paren" (List [App "App" (List [ + App "Var" (List [App "UnQual" (List [App "Ident" (List [Concat ( + List [String "putWord",ShowInt (Int 8)])])])]),App "Var" (List [ + App "UnQual" (List [App "Ident" (List [String "x"])])])])])])]), + App "BDecls" (List [List []])])]])]])])]])]),App "InsDecl" (List [ App "PatBind" (List [App "PVar" (List [App "Ident" (List [String - "useTag"])]),App "Nothing" (List []),App "UnGuardedRhs" (List [App - "InfixApp" (List [App "App" (List [App "Var" (List [App "UnQual" ( - List [App "Ident" (List [String "length"])])]),App "List" (List [ - MapCtor (App "RecConstr" (List [App "UnQual" (List [App "Ident" ( - List [CtorName])]),List []]))])]),App "QVarOp" (List [App "UnQual" - (List [App "Symbol" (List [String ">"])])]),App "Lit" (List [App - "Int" (List [Int 1])])])]),App "BDecls" (List [List []])]),App - "PatBind" (List [App "PVar" (List [App "Ident" (List [String - "getTag"])]),App "Nothing" (List []),App "UnGuardedRhs" (List [App - "If" (List [App "Var" (List [App "UnQual" (List [App "Ident" (List - [String "useTag"])])]),App "Var" (List [App "UnQual" (List [App - "Ident" (List [Concat (List [String "getWord",ShowInt (Int 8)])])] - )]),App "App" (List [App "Var" (List [App "UnQual" (List [App - "Ident" (List [String "return"])])]),App "Lit" (List [App "Int" ( - List [Int 0])])])])]),App "BDecls" (List [List []])])]])])])])] + "get"])]),App "UnGuardedRhs" (List [App "Do" (List [List [App + "Generator" (List [App "PVar" (List [App "Ident" (List [String "i" + ])]),App "Var" (List [App "UnQual" (List [App "Ident" (List [ + String "getTag"])])])]),App "Qualifier" (List [App "Case" (List [ + App "Var" (List [App "UnQual" (List [App "Ident" (List [String "i" + ])])]),Concat (List [MapCtor (App "Alt" (List [App "PLit" (List [ + App "Signless" (List []),App "Int" (List [CtorIndex])]),App + "UnGuardedRhs" (List [App "Do" (List [Concat (List [MapField (App + "Generator" (List [App "PVar" (List [App "Ident" (List [Concat ( + List [String "x",ShowInt FieldIndex])])]),App "Var" (List [App + "UnQual" (List [App "Ident" (List [String "get"])])])])),List [App + "Qualifier" (List [App "App" (List [App "Var" (List [App "UnQual" + (List [App "Ident" (List [String "return"])])]),App "Paren" (List + [Application (Concat (List [List [App "Con" (List [App "UnQual" ( + List [App "Ident" (List [CtorName])])])],MapField (App "Var" (List + [App "UnQual" (List [App "Ident" (List [Concat (List [String "x", + ShowInt FieldIndex])])])]))]))])])])]])])]),App "BDecls" (List [ + List []])])),List [App "Alt" (List [App "PWildCard" (List []),App + "UnGuardedRhs" (List [App "App" (List [App "Var" (List [App + "UnQual" (List [App "Ident" (List [String "error"])])]),App "Lit" + (List [App "String" (List [Concat (List [String + "Corrupted binary data for ",DataName])])])])]),App "BDecls" (List + [List []])])]])])])]])]),App "BDecls" (List [List [App "PatBind" ( + List [App "PVar" (List [App "Ident" (List [String "useTag"])]),App + "UnGuardedRhs" (List [App "InfixApp" (List [App "App" (List [App + "Var" (List [App "UnQual" (List [App "Ident" (List [String + "length"])])]),App "List" (List [MapCtor (App "RecConstr" (List [ + App "UnQual" (List [App "Ident" (List [CtorName])]),List []]))])]) + ,App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [ + String ">"])])]),App "Lit" (List [App "Int" (List [Int 1])])])]), + App "BDecls" (List [List []])]),App "PatBind" (List [App "PVar" ( + List [App "Ident" (List [String "getTag"])]),App "UnGuardedRhs" ( + List [App "If" (List [App "Var" (List [App "UnQual" (List [App + "Ident" (List [String "useTag"])])]),App "Var" (List [App "UnQual" + (List [App "Ident" (List [Concat (List [String "getWord",ShowInt ( + Int 8)])])])]),App "App" (List [App "Var" (List [App "UnQual" ( + List [App "Ident" (List [String "return"])])]),App "Lit" (List [ + App "Int" (List [Int 0])])])])]),App "BDecls" (List [List []])])]] + )])])])] -- GENERATED STOP diff --git a/Data/Derive/Set.hs b/Data/Derive/Set.hs --- a/Data/Derive/Set.hs +++ b/Data/Derive/Set.hs @@ -35,6 +35,6 @@ where set = "set" ++ title field typ = typField `TyFun` (dataDeclType d `TyFun` dataDeclType d) - typField = fromBangType $ fromJust $ lookup field $ concatMap ctorDeclFields $ dataDeclCtors d + typField = fromJust $ lookup field $ concatMap ctorDeclFields $ dataDeclCtors d bod = RecUpdate (var "x") [FieldUpdate (qname field) (var "v")] diff --git a/Data/Derive/Typeable.hs b/Data/Derive/Typeable.hs --- a/Data/Derive/Typeable.hs +++ b/Data/Derive/Typeable.hs @@ -76,7 +76,7 @@ mkTypeable :: String -> DataDecl -> [Decl] mkTypeable modu d = [TypeSig sl [name fun] (tyCon "TyCon")] ++ - [PatBind sl (pVar fun) Nothing (UnGuardedRhs bod) (BDecls []) | + [PatBind sl (pVar fun) (UnGuardedRhs bod) (BDecls []) | let bod = apps (var "mkTyCon3") [Lit $ String "package", Lit $ String modu, Lit $ String nam]] ++ [inst [] (showN n) [tyCon nam] [PWildCard] $ apps (var "mkTyConApp") [var fun, List []]] ++ [inst [ClassA (qname "Typeable") [v] | v <- tvs] i [TyParen $ tyApp (tyCon nam) tvs] [] $ var $ "typeOf" ++ i ++ "Default" @@ -89,7 +89,7 @@ inst ctxt n typ pat expr = - InstDecl sl ctxt (qname $ "Typeable" ++ n) typ + InstDecl sl Nothing [] ctxt (qname $ "Typeable" ++ n) typ [InsDecl $ bind ("typeOf" ++ n) pat expr] showN 0 = "" diff --git a/Data/Derive/UniplateDirect.hs b/Data/Derive/UniplateDirect.hs --- a/Data/Derive/UniplateDirect.hs +++ b/Data/Derive/UniplateDirect.hs @@ -103,14 +103,14 @@ make :: Bool -> (String -> DataDecl) -> Type -> Type -> Either String [Decl] -make uni grab from to = Right [InstDecl sl [] (UnQual $ Ident $ if uni then "Uniplate" else "Biplate") (from : [to | not uni]) +make uni grab from to = Right [InstDecl sl Nothing [] [] (UnQual $ Ident $ if uni then "Uniplate" else "Biplate") (from : [to | not uni]) [InsDecl $ InlineSig sl True AlwaysActive (qname $ if uni then "uniplate" else "biplate"), InsDecl ms]] where ty = grab $ tyRoot from match pat bod = Match sl (Ident $ if uni then "uniplate" else "biplate") [pat] Nothing (UnGuardedRhs bod) (BDecls []) ms = if uni || from /= to then FunBind $ map (uncurry match) (catMaybes bods) ++ [match (pVar "x") (var "plate" `App` var "x") | any isNothing bods] - else PatBind sl (pVar "biplate") Nothing (UnGuardedRhs $ var "plateSelf") (BDecls []) + else PatBind sl (pVar "biplate") (UnGuardedRhs $ var "plateSelf") (BDecls []) bods = run (fromTyParens to) $ mapM (make1 grab) $ substData from ty @@ -179,7 +179,7 @@ subst ty x = Right $ substData ty x substData :: Type -> Decl -> [(String,[Type])] -substData ty dat = [(ctorDeclName x, map (fromTyParens . transform f . fromBangType . snd) $ ctorDeclFields x) | x <- dataDeclCtors dat] +substData ty dat = [(ctorDeclName x, map (fromTyParens . transform f . snd) $ ctorDeclFields x) | x <- dataDeclCtors dat] where rep = zip (dataDeclVars dat) (snd $ fromTyApps $ fromTyParen ty) f (TyVar x) = fromMaybe (TyVar x) $ lookup (prettyPrint x) rep @@ -212,9 +212,9 @@ listCtor = DataDecl sl DataType [] (Ident "[]") [UnkindedVar $ Ident "a"] [QualConDecl sl [] [] $ ConDecl (Ident "[]") [] - ,QualConDecl sl [] [] $ ConDecl (Ident "(:)") [UnBangedTy $ tyVar "a", UnBangedTy $ TyList $ tyVar "a"]] [] + ,QualConDecl sl [] [] $ ConDecl (Ident "(:)") [tyVar "a", TyList $ tyVar "a"]] [] tupleDefn :: Int -> Decl -tupleDefn n = DataDecl sl DataType [] (Ident s) (map (UnkindedVar . Ident) vars) [QualConDecl sl [] [] $ ConDecl (Ident s) (map (UnBangedTy . tyVar) vars)] [] +tupleDefn n = DataDecl sl DataType [] (Ident s) (map (UnkindedVar . Ident) vars) [QualConDecl sl [] [] $ ConDecl (Ident s) (map tyVar vars)] [] where s = "(" ++ replicate (n - 1) ',' ++ ")" vars = ['v':show i | i <- [1..n]] diff --git a/Data/Derive/UniplateTypeable.hs b/Data/Derive/UniplateTypeable.hs --- a/Data/Derive/UniplateTypeable.hs +++ b/Data/Derive/UniplateTypeable.hs @@ -32,41 +32,42 @@ makeUniplateTypeable :: Derivation makeUniplateTypeable = derivationCustomDSL "UniplateTypeable" custom $ - List [App "InstDecl" (List [List [App "ClassA" (List [App "UnQual" - (List [App "Ident" (List [String "Typeable"])]),List [App "TyVar" - (List [App "Ident" (List [String "a"])])]]),App "ClassA" (List [ - App "UnQual" (List [App "Ident" (List [String "PlateAll"])]),List - [App "TyVar" (List [App "Ident" (List [String "a"])]),App "TyVar" - (List [App "Ident" (List [String "to"])])]]),App "ClassA" (List [ - App "UnQual" (List [App "Ident" (List [String "Uniplate"])]),List - [App "TyVar" (List [App "Ident" (List [String "to"])])]]),App - "ClassA" (List [App "UnQual" (List [App "Ident" (List [String + List [App "InstDecl" (List [App "Nothing" (List []),List [],List [ + App "ClassA" (List [App "UnQual" (List [App "Ident" (List [String "Typeable"])]),List [App "TyVar" (List [App "Ident" (List [String - "to"])])]])],App "UnQual" (List [App "Ident" (List [String - "PlateAll"])]),List [App "TyParen" (List [App "TyApp" (List [App - "TyCon" (List [App "UnQual" (List [App "Ident" (List [DataName])]) - ]),App "TyVar" (List [App "Ident" (List [String "a"])])])]),App - "TyVar" (List [App "Ident" (List [String "to"])])],List [App - "InsDecl" (List [App "FunBind" (List [MapCtor (App "Match" (List [ - App "Ident" (List [String "plateAll"]),List [App "PParen" (List [ - App "PApp" (List [App "UnQual" (List [App "Ident" (List [CtorName] - )]),MapField (App "PVar" (List [App "Ident" (List [Concat (List [ - String "x",ShowInt FieldIndex])])]))])])],App "Nothing" (List []), - App "UnGuardedRhs" (List [Fold (App "InfixApp" (List [Tail,App - "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String - "|+"])])]),Head])) (Concat (List [Reverse (MapField (App "Var" ( - List [App "UnQual" (List [App "Ident" (List [Concat (List [String - "x",ShowInt FieldIndex])])])]))),List [App "App" (List [App "Var" - (List [App "UnQual" (List [App "Ident" (List [String "plate"])])]) - ,App "Con" (List [App "UnQual" (List [App "Ident" (List [CtorName] - )])])])]]))]),App "BDecls" (List [List []])]))])])]])] + "a"])])]]),App "ClassA" (List [App "UnQual" (List [App "Ident" ( + List [String "PlateAll"])]),List [App "TyVar" (List [App "Ident" ( + List [String "a"])]),App "TyVar" (List [App "Ident" (List [String + "to"])])]]),App "ClassA" (List [App "UnQual" (List [App "Ident" ( + List [String "Uniplate"])]),List [App "TyVar" (List [App "Ident" ( + List [String "to"])])]]),App "ClassA" (List [App "UnQual" (List [ + App "Ident" (List [String "Typeable"])]),List [App "TyVar" (List [ + App "Ident" (List [String "to"])])]])],App "UnQual" (List [App + "Ident" (List [String "PlateAll"])]),List [App "TyParen" (List [ + App "TyApp" (List [App "TyCon" (List [App "UnQual" (List [App + "Ident" (List [DataName])])]),App "TyVar" (List [App "Ident" (List + [String "a"])])])]),App "TyVar" (List [App "Ident" (List [String + "to"])])],List [App "InsDecl" (List [App "FunBind" (List [MapCtor + (App "Match" (List [App "Ident" (List [String "plateAll"]),List [ + App "PParen" (List [App "PApp" (List [App "UnQual" (List [App + "Ident" (List [CtorName])]),MapField (App "PVar" (List [App + "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])])]))] + )])],App "Nothing" (List []),App "UnGuardedRhs" (List [Fold (App + "InfixApp" (List [Tail,App "QVarOp" (List [App "UnQual" (List [App + "Symbol" (List [String "|+"])])]),Head])) (Concat (List [Reverse ( + MapField (App "Var" (List [App "UnQual" (List [App "Ident" (List [ + Concat (List [String "x",ShowInt FieldIndex])])])]))),List [App + "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" ( + List [String "plate"])])]),App "Con" (List [App "UnQual" (List [ + App "Ident" (List [CtorName])])])])]]))]),App "BDecls" (List [List + []])]))])])]])] -- GENERATED STOP -custom (_,d) [InstDecl x1 _ x3 _ x5] = [InstDecl x1 x2 x3 x4 x5] +custom (_,d) [InstDecl x1 x2 x3 _ x5 _ x7] = [InstDecl x1 x2 x3 x4 x5 x6 x7] where vars = dataDeclVars d dd = (if null vars then id else TyParen) $ tyApps (tyCon $ dataDeclName d) (map tyVar vars) - x2 = concatMap f vars ++ [ClassA (qname x) [tyVar "to"] | x <- ["Typeable","Uniplate"]] - x4 = [dd, tyVar "to"] + x4 = concatMap f vars ++ [ClassA (qname x) [tyVar "to"] | x <- ["Typeable","Uniplate"]] + x6 = [dd, tyVar "to"] f v = [ClassA (qname "Typeable") [tyVar v], ClassA (qname "PlateAll") [tyVar v, tyVar "to"]] diff --git a/Data/Derive/Update.hs b/Data/Derive/Update.hs --- a/Data/Derive/Update.hs +++ b/Data/Derive/Update.hs @@ -44,4 +44,4 @@ set = field ++ "_s" upd = field ++ "_u" typR = dataDeclType d `TyFun` dataDeclType d - typF = fromBangType $ fromJust $ lookup field $ concatMap ctorDeclFields $ dataDeclCtors d + typF = fromJust $ lookup field $ concatMap ctorDeclFields $ dataDeclCtors d diff --git a/Derive/Derivation.hs b/Derive/Derivation.hs --- a/Derive/Derivation.hs +++ b/Derive/Derivation.hs @@ -34,7 +34,7 @@ where f (DataDecl _ _ _ name vars _ deriv) = g name vars deriv f (GDataDecl _ _ _ name vars _ _ deriv) = g name vars deriv - f (DerivDecl _ _ name args) = [TyCon name `tyApps` args] + f (DerivDecl _ _ _ _ name args) = [TyCon name `tyApps` args] f _ = [] g name vars deriv = [TyCon a `tyApps` (b:bs) | (a,bs) <- deriv] diff --git a/Derive/Generate.hs b/Derive/Generate.hs --- a/Derive/Generate.hs +++ b/Derive/Generate.hs @@ -12,7 +12,7 @@ import Data.List -evil = words $ "TTypeable Uniplate" +evil = words "TTypeable Uniplate" -- generate extra information for each derivation generate :: IO () @@ -115,5 +115,3 @@ f (x:xs) = let (a,b) = f xs in (x:a,b) f [] = ([],[]) lexeme (x:xs) = ([x], xs) - - diff --git a/Derive/Test.hs b/Derive/Test.hs --- a/Derive/Test.hs +++ b/Derive/Test.hs @@ -21,7 +21,7 @@ -- REASONS: -- UniplateDirect: Doesn't work through Template Haskell -exclude = ["ArbitraryOld","UniplateDirect","Ref","Serial"] +exclude = ["ArbitraryOld","UniplateDirect","Ref","Serial","Binary"] -- These must be first and in every set priority = ["Eq","Typeable"] @@ -31,8 +31,8 @@ listType = DataDecl sl DataType [] (Ident "[]") [UnkindedVar $ Ident "a"] [QualConDecl sl [] [] (ConDecl (Ident "[]") []) ,QualConDecl sl [] [] (ConDecl (Ident "Cons") - [UnBangedTy (TyVar (Ident "a")) - ,UnBangedTy (TyApp (TyCon (UnQual (Ident "List"))) (TyVar (Ident "a")))])] + [TyVar (Ident "a") + ,TyApp (TyCon (UnQual (Ident "List"))) (TyVar (Ident "a"))])] [] diff --git a/Language/Haskell.hs b/Language/Haskell.hs --- a/Language/Haskell.hs +++ b/Language/Haskell.hs @@ -91,7 +91,7 @@ where x2 = Var $ UnQual x fExp (Case (ExpTypeSig _ x@Lit{} _) alts) = fExp $ Case x alts fExp (Case (Lit x) alts) | good /= [] = head good - where good = [z | Alt _ (PLit y) (UnGuardedAlt z) (BDecls []) <- alts, y == x] + where good = [z | Alt _ (PLit Signless y) (UnGuardedRhs z) (BDecls []) <- alts, y == x] fExp (If x t f) | x ~= "True" = t | x ~= "False" = f @@ -123,18 +123,18 @@ fMatch (Match sl nam pat sig (GuardedRhss [GuardedRhs _ [Qualifier x] bod]) decls) | x ~= "True" = fMatch $ Match sl nam pat sig (UnGuardedRhs bod) decls - fMatch (Match sl nam [PVar x] sig (UnGuardedRhs (Case (Var (UnQual x2)) [Alt _ pat (UnGuardedAlt y) (BDecls [])])) decls) + fMatch (Match sl nam [PVar x] sig (UnGuardedRhs (Case (Var (UnQual x2)) [Alt _ pat (UnGuardedRhs y) (BDecls [])])) decls) | x == x2 = fMatch $ Match sl nam [PParen pat] sig (UnGuardedRhs y) decls fMatch o@(Match a b c d e bind) = fBinds (Match a b (minPat o c) d e) bind - fDecl (PatBind a b c d bind) = fBinds (PatBind a b c d) bind + fDecl (PatBind a b c bind) = fBinds (PatBind a b c) bind fDecl (FunBind xs) = FunBind $ filter (not . isGuardFalse) xs fDecl x = x fBinds context (BDecls bind) | inline /= [] = simplify $ subst (Var $ UnQual from) to $ context $ BDecls $ take i bind ++ drop (i+1) bind where - f (PatBind _ (PVar x) Nothing (UnGuardedRhs bod) (BDecls [])) = [(x,bod)] + f (PatBind _ (PVar x) (UnGuardedRhs bod) (BDecls [])) = [(x,bod)] f (FunBind [Match _ x [PVar v] Nothing (UnGuardedRhs (Paren (App bod (Var v2)))) (BDecls [])]) | UnQual v == v2 = [(x,bod)] f (FunBind [Match sl x pat Nothing (UnGuardedRhs bod) (BDecls [])]) = [(x,Paren $ Lambda sl pat bod)] @@ -203,7 +203,7 @@ -- A declaration that is either a DataDecl of GDataDecl type DataDecl = Decl type CtorDecl = Either QualConDecl GadtDecl -type FieldDecl = [(String, BangType)] +type FieldDecl = [(String, Type)] type FullDataDecl = (ModuleName, DataDecl) @@ -233,13 +233,8 @@ bind s p e = binds s [(p,e)] binds :: String -> [([Pat], Exp)] -> Decl -binds n [([],e)] = PatBind sl (pVar n) Nothing (UnGuardedRhs e) (BDecls []) +binds n [([],e)] = PatBind sl (pVar n) (UnGuardedRhs e) (BDecls []) binds n xs = FunBind [Match sl (name n) p Nothing (UnGuardedRhs e) (BDecls []) | (p,e) <- xs] - - -fromBangType (BangedTy x) = x -fromBangType (UnBangedTy x) = x -fromBangType (UnpackedTy x) = x isDataDecl :: Decl -> Bool diff --git a/Language/Haskell/Convert.hs b/Language/Haskell/Convert.hs --- a/Language/Haskell/Convert.hs +++ b/Language/Haskell/Convert.hs @@ -60,11 +60,11 @@ conv (RecC n xs) = RecDecl (c n) [([c x], c (y,z)) | (x,y,z) <- xs] conv (InfixC x n y) = InfixConDecl (c x) (c n) (c y) -instance Convert TH.StrictType HS.BangType where - conv (IsStrict, x) = BangedTy $ c x - conv (NotStrict, x) = UnBangedTy $ c x +instance Convert TH.StrictType HS.Type where + conv (IsStrict, x) = TyBang BangedTy $ c x + conv (NotStrict, x) = c x #if __GLASGOW_HASKELL__ >= 704 - conv (Unpacked, x) = BangedTy $ c x + conv (Unpacked, x) = TyBang UnpackedTy $ c x #endif instance Convert TH.Type HS.Type where @@ -87,9 +87,9 @@ instance Convert HS.Decl TH.Dec where - conv (InstDecl _ cxt nam typ ds) = InstanceD (c cxt) (c $ tyApp (TyCon nam) typ) [c d | InsDecl d <- ds] + conv (InstDecl _ _ _ cxt nam typ ds) = InstanceD (c cxt) (c $ tyApp (TyCon nam) typ) [c d | InsDecl d <- ds] conv (FunBind ms@(HS.Match _ nam _ _ _ _:_)) = FunD (c nam) (c ms) - conv (PatBind _ p _ bod ds) = ValD (c p) (c bod) (c ds) + conv (PatBind _ p bod ds) = ValD (c p) (c bod) (c ds) conv (TypeSig _ [nam] typ) = SigD (c nam) (c $ foralls typ) conv (DataDecl _ DataType ctx nam typ cs ds) = DataD (c ctx) (c nam) (c typ) (c cs) (c (map fst ds)) @@ -105,11 +105,16 @@ conv (InfixConDecl l nam r) = InfixC (c l) (c nam) (c r) conv (RecDecl nam fs) = RecC (c nam) (concatMap c fs) -instance Convert HS.BangType TH.StrictType where - conv (BangedTy t) = (IsStrict,c t) - conv (UnBangedTy t) = (NotStrict,c t) +instance Convert HS.Type TH.StrictType where + conv (TyBang BangedTy t) = (IsStrict, c t) +#if __GLASGOW_HASKELL__ >= 704 + conv (TyBang UnpackedTy t) = (Unpacked, c t) +#else + conv (TyBang UnpackedTy t) = (IsStrict, c t) +#endif + conv t = (NotStrict, c t) -instance Convert ([HS.Name],HS.BangType) [TH.VarStrictType] where +instance Convert ([HS.Name],HS.Type) [TH.VarStrictType] where conv (names,bt) = [(c name,s,t) | name <- names] where (s,t) = c bt @@ -174,7 +179,7 @@ instance Convert HS.Pat TH.Pat where conv (PParen x) = c x - conv (PLit x) = LitP (c x) + conv (PLit Signless x) = LitP (c x) conv (PTuple _ x) = TupP (c x) conv (PApp x y) = ConP (c x) (c y) conv (PVar x) = VarP (c x) @@ -224,14 +229,6 @@ instance Convert HS.TyVarBind TH.Name where conv (UnkindedVar x) = c x - -instance Convert HS.GuardedAlts TH.Body where - conv (UnGuardedAlt x) = NormalB (c x) - conv (GuardedAlts x) = GuardedB (c x) - -instance Convert HS.GuardedAlt (TH.Guard, TH.Exp) where - conv (GuardedAlt _ x y) = (PatG (c x), c y) - #if __GLASGOW_HASKELL__ >= 612 instance Convert TH.TyVarBndr HS.TyVarBind where diff --git a/derive.cabal b/derive.cabal --- a/derive.cabal +++ b/derive.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.6 build-type: Default name: derive -version: 2.5.16 +version: 2.5.17 build-type: Simple copyright: Neil Mitchell 2006-2014 author: Neil Mitchell @@ -20,7 +20,7 @@ extra-source-files: derive.htm CHANGES.txt -tested-with: GHC==7.8.2, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2 +tested-with: GHC==7.8.2, GHC==7.6.3, GHC==7.4.2 source-repository head type: git @@ -34,7 +34,7 @@ base == 4.*, filepath, syb, template-haskell, containers, pretty, directory, process, bytestring, - haskell-src-exts >= 1.14 && < 1.16, + haskell-src-exts >= 1.16 && < 1.17, transformers >= 0.2, uniplate >= 1.5 && < 1.7