Tue Dec 9 04:32:09 WET 2008 hpacheco@di.uminho.pt
* Corrected Observable dependencies
{
hunk ./DrHylo.cabal 26
- Build-Depends: base >= 4, pointless-haskell, mtl, haskell-src-exts >= 0.4.4, syb
+ Build-Depends: base >= 4, pointless-haskell, mtl, haskell-src-exts == 0.4.4.1, syb
hunk ./Sample.hs 51
-data Tree a = Leaf | Node a (Tree a) (Tree a)
+data Tree a = Leaf | Node a (Tree a) (Tree a) deriving Show
hunk ./src/DrHylo.hs 89
-observableTypeSig :: Decl -> Decl
-observableTypeSig (TypeSig loc names t) = TypeSig loc names (aux t)
+addTypeSig :: Decl -> Decl
+addTypeSig (TypeSig loc names t) = TypeSig loc names (aux t)
hunk ./src/DrHylo.hs 92
- aux (TyForall mb ctx (TyFun a b)) = TyForall mb (ctx++obs a b) (TyFun a b)
- aux (TyFun a b) = TyForall Nothing (obs a b) (TyFun a b)
+ aux (TyForall mb ctx (TyFun a b)) = TyForall mb (ctx++inst typeable a b++inst observable a b) (TyFun a b)
+ aux (TyFun a b) = TyForall Nothing (inst typeable a b++inst observable a b) (TyFun a b)
hunk ./src/DrHylo.hs 95
- obs a b = map mkObservableIns (vars a b)
+ inst cl a b = map (mkInsVar cl) (vars a b)
hunk ./src/DrHylo.hs 97
-mkObservableIns :: Name -> Asst
-mkObservableIns n = ClassA (UnQual (Ident "Observable")) [TyVar n]
+mkInsVar :: Name -> Name -> Asst
+mkInsVar cl n = ClassA (UnQual cl) [TyVar n]
hunk ./src/DrHylo.hs 100
-addObservableIns :: String -> [Decl] -> [Decl]
-addObservableIns n [] = []
-addObservableIns n (d:ds) = if (isTypeSig n d) then observableTypeSig d : ds else d : addObservableIns n ds
+addTypeableObservableIns :: String -> [Decl] -> [Decl]
+addTypeableObservableIns n [] = []
+addTypeableObservableIns n (d:ds) | isTypeSig n d = addTypeSig d : addTypeableObservableIns n ds
+ | otherwise = d : addTypeableObservableIns n ds
hunk ./src/DrHylo.hs 108
-pwpfModule f c (Module loc name pragmas warnings exports imports decls) = Module loc name pragmas warnings exports imports decls''
+pwpfModule f c (Module loc name pragmas warnings exports imports decls) = Module loc name pragmas' warnings exports imports decls''
hunk ./src/DrHylo.hs 111
- decls'' = foldr addObservableIns decls' obs
+ decls'' = if (obrequired f) then foldr addTypeableObservableIns decls' obs else decls'
+ pragmaNames = if (obrequired f) then ["TypeFamilies,","DeriveDataTypeable"] else ["TypeFamilies"]
+ pragmas' = LanguagePragma loc (map Ident pragmaNames) : pragmas
hunk ./src/DrHylo.hs 157
- let aux True = ["Generics.Pointless.Combinators", "Generics.Pointless.Functors", "Generics.Pointless.RecursionPatterns", "Debug.Observe","Generics.Pointless.Observe.Functors", "Generics.Pointless.Observe.RecursionPatterns"]
+ let aux True = ["Generics.Pointless.Combinators", "Generics.Pointless.Functors", "Generics.Pointless.RecursionPatterns", "Data.Typeable", "Debug.Observe", "Generics.Pointless.Observe.Functors", "Generics.Pointless.Observe.RecursionPatterns"]
hunk ./src/DrHylo.hs 176
- hsModule2 <- return (pwpfModule flags (getCtx hsModule0) hsModule1)
+ hsModule2 <- return (pwpfModule flags (getCtx hsModule1) hsModule1)
hunk ./src/FunctorOf.hs 6
+ , typeable
+ , observable
hunk ./src/FunctorOf.hs 53
-type St = StateT (String,Int) Maybe
+type St = StateT ((String,Int),[Type]) Maybe
hunk ./src/FunctorOf.hs 62
- map (\x -> evalStateT (getInstances ob x) (seed,0)) decls
- in Module a b c d e i (decls ++ newDecls)
+ map (\x -> evalStateT (getInstances ob x) ((seed,0),[])) decls
+ in Module a b c d e i (newDecls)
+
+addConst t = modify (\(s,l) -> (s,t:l))
hunk ./src/FunctorOf.hs 86
-i arg t@(TyVar hsName) = return $ TyApp (TyCon $ UnQual $ Ident "Const") t
-i arg t@(TyCon hsQName) = return $ TyApp (TyCon $ UnQual $ Ident "Const") t
+i arg t@(TyVar hsName) = addConst t >> (return $ TyApp (TyCon $ UnQual $ Ident "Const") t)
+i arg t@(TyCon hsQName) = addConst t >> (return $ TyApp (TyCon $ UnQual $ Ident "Const") t)
hunk ./src/FunctorOf.hs 150
-getDataDeclFunctor :: Type -> [QualConDecl] -> St Type
-getDataDeclFunctor arg lConDecl = do
+getDataDeclFunctor :: Type -> [QualConDecl] -> St (Type,[Type])
+getDataDeclFunctor arg lConDecl = withStateT (\((s,n),_) -> ((s,n),[])) $ do
hunk ./src/FunctorOf.hs 154
- return functor
+ (_,consts) <- get
+ return (functor,consts)
+
+deriveTypeable :: Decl -> Decl
+deriveTypeable (DataDecl loc dn ctx hsName lName lConDecl derive) =
+ DataDecl loc dn ctx hsName lName lConDecl (nub $ UnQual typeable : derive)
hunk ./src/FunctorOf.hs 166
- functor <- getDataDeclFunctor arg lConDecl
+ (functor,consts) <- getDataDeclFunctor arg lConDecl
hunk ./src/FunctorOf.hs 171
- let observableInst = getObservableInst loc arg
- if ob then return [pfTInst,muInst,observableInst]
- else return [pfTInst,muInst]
+ let observableInst = getObservableInst loc consts arg
+ if ob then return [deriveTypeable d,pfTInst,muInst,observableInst]
+ else return [d,pfTInst,muInst]
hunk ./src/FunctorOf.hs 183
-getInstances _ _ = fail "not a data declaration"
+getInstances _ d = return [d]
hunk ./src/FunctorOf.hs 190
-constNil = TyApp (TyCon $ UnQual $ Ident "Const") (TyCon $ UnQual $ Ident "One")
+constNil = TyApp (TyCon $ UnQual $ Ident "Const") nil
+nil = TyCon $ UnQual $ Ident "One"
hunk ./src/FunctorOf.hs 205
- (seed,n) <- gets id
- modify (\_->(seed,n+1))
+ ((seed,n),l) <- gets id
+ modify (\_->((seed,n+1),l))
hunk ./src/FunctorOf.hs 209
-getObservableInst :: SrcLoc -> Type -> Decl
-getObservableInst loc a = InstDecl loc [ClassA (UnQual (Ident "FunctorO")) [TyApp (TyCon (UnQual (Ident "PF"))) a]] (UnQual (Ident "Observable")) [a] [InsDecl (FunBind [Exts.Match loc (Ident "observer") [PVar (Ident "x")] (UnGuardedRhs (App (App (Exts.Var (UnQual (Ident "send"))) (Lit (String ""))) (Paren (InfixApp (InfixApp (App (App (App (Exts.Var (UnQual (Ident "omap"))) (Paren (ExpTypeSig loc (Exts.Var (UnQual (Ident "_L"))) a))) (Exts.Var (UnQual (Ident "thk")))) (Paren (App (Exts.Var (UnQual (Ident "out"))) (Exts.Var (UnQual (Ident "x")))))) (QVarOp (UnQual (Symbol ">>="))) (Exts.Var (UnQual (Ident "return")))) (QVarOp (UnQual (Symbol "."))) (Exts.Var (UnQual (Ident "inn"))))))) (BDecls [PatBind loc (PVar (Ident "thk")) (UnGuardedRhs (ExpTypeSig loc (Exts.Var (UnQual (Ident "thunk"))) (TyFun a (TyApp (TyCon (UnQual (Ident "ObserverM"))) a)))) (BDecls [])])])]
+getObservableInst :: SrcLoc -> [Type] -> Type -> Decl
+getObservableInst loc cts a = InstDecl loc ctx (UnQual (Ident "Observable")) [a] [InsDecl (FunBind [Exts.Match loc (Ident "observer") [PVar (Ident "x")] (UnGuardedRhs (App (App (Exts.Var (UnQual (Ident "send"))) (Lit (String ""))) (Paren (InfixApp (InfixApp (App (App (App (Exts.Var (UnQual (Ident "omap"))) (Paren (ExpTypeSig loc (Exts.Var (UnQual (Ident "_L"))) a))) (Exts.Var (UnQual (Ident "thk")))) (Paren (App (Exts.Var (UnQual (Ident "out"))) (Exts.Var (UnQual (Ident "x")))))) (QVarOp (UnQual (Symbol ">>="))) (Exts.Var (UnQual (Ident "return")))) (QVarOp (UnQual (Symbol "."))) (Exts.Var (UnQual (Ident "inn"))))))) (BDecls [PatBind loc (PVar (Ident "thk")) (UnGuardedRhs (ExpTypeSig loc (Exts.Var (UnQual (Ident "thunk"))) thunkSig )) (BDecls [])])])]
+ where ctx = foldr (\c b -> mkIns typeable c : mkIns observable c : b) [] cts
+ thunkSig = TyForall Nothing ctx $ TyFun a (TyApp (TyCon (UnQual (Ident "ObserverM"))) a)
hunk ./src/FunctorOf.hs 214
+typeable :: Name
+typeable = Ident "Typeable"
+observable :: Name
+observable = Ident "Observable"
hunk ./src/FunctorOf.hs 219
+mkIns :: Name -> Type -> Asst
+mkIns cl t = ClassA (UnQual cl) [t]
}