diff --git a/Language/MSH/BuiltIn.hs b/Language/MSH/BuiltIn.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/BuiltIn.hs @@ -0,0 +1,10 @@ +module Language.MSH.BuiltIn where + +newClassName :: String +newClassName = "New" + +newArgsTypeName :: String +newArgsTypeName = "Args" + +newKwdName :: String +newKwdName = "new" diff --git a/Language/MSH/CodeGen.hs b/Language/MSH/CodeGen.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/CodeGen.hs @@ -0,0 +1,7 @@ +module Language.MSH.CodeGen ( + module Language.MSH.CodeGen.Decls, + module Language.MSH.CodeGen.New +) where + +import Language.MSH.CodeGen.Decls +import Language.MSH.CodeGen.New diff --git a/Language/MSH/CodeGen/Class.hs b/Language/MSH/CodeGen/Class.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/CodeGen/Class.hs @@ -0,0 +1,167 @@ +module Language.MSH.CodeGen.Class where + +import Control.Applicative ((<$>)) + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import Language.MSH.StateDecl +import Language.MSH.StateEnv +import Language.MSH.CodeGen.Shared +import Language.MSH.CodeGen.Interop +import Language.MSH.CodeGen.Inheritance + +{- + Type class +-} + +data SCV = SCV { + scvObject :: Name, + scvState :: Name, + scvMonad :: Name +} + +-- | Generates the context for the type class. +genClassContext :: [String] -> Maybe Type -> SCV -> Q Cxt +genClassContext vars Nothing (SCV o s m) = do + --return [foldl AppT (ConT $ mkName "Monad") [VarT m]] + let + cn = ConT $ mkName "Object" + fa = appN (VarT o) vars + --sa = foldl AppT (ConT $ mkName "Selector") [appN (VarT o) vars, appN (VarT s) vars, VarT m, VarT $ mkName "r"] + sa = appN (VarT s) vars + ma = VarT m + --ma = ConT $ mkName "Identity" + return [foldl AppT cn [fa, sa, ma]] + --return [foldl AppT (ConT $ mkName "Object") [appN (VarT o) vars, appN (VarT s) vars, VarT m]] +genClassContext vars (Just p) (SCV o s m) = do + return [foldl AppT (ConT pcname) vars] + where + (Name pn _) = parentName p + pcname = mkName $ occString pn ++ "Like" + vars = [VarT o, VarT s, VarT m] ++ parentArgs p + +-- | Generates the typing for the `invoke' function. +genInvokeDecl :: [String] -> String -> SCV -> Q Dec +genInvokeDecl tyvars c (SCV o s m) = do + o' <- newName "o'" + d' <- newName "d'" + r <- newName "r" + let + name = mkName $ "_" ++ c ++ "_invoke" + cname = mkName $ c ++ "Like" + base = AppT (AppT (ConT (mkName "StateT")) (appN (VarT s) tyvars)) (VarT m) + ctx = [foldl AppT (ConT cname) ([VarT o', VarT d', base] ++ [VarT $ mkName n | n <- tyvars])] + ovs = appN (VarT o) tyvars + ovs' = appN (VarT o') tyvars + sigma = ovs' `arr` (ovs' `arr` AppT base (tuple [VarT r, ovs'])) `arr` ovs `arr` AppT (VarT m) (tuple [VarT r, ovs, ovs']) + ty = ForallT [PlainTV o', PlainTV d', PlainTV r] ctx sigma + return $ SigD name ty + +getterName :: String -> String +getterName n = "_get_" ++ n + +setterName :: String -> String +setterName n = "_set_" ++ n + +fieldType :: Type -> Type -> Name -> Type -> Type +fieldType ovs svs m ft = + foldl AppT (ConT (mkName "Selector")) [PromotedT (mkName "Field"), ovs, svs, (VarT m), ft ] + +genModDeclsFor :: SCV -> [String] -> StateMemberDecl -> Q [Dec] +genModDeclsFor (SCV o s m) vars (StateDataDecl field _ typ) = do + let + ft = parseType typ + ovs = appN (VarT o) vars + svs = appN (VarT s) vars + stt = AppT (AppT (ConT (mkName "StateT")) svs) (VarT m) + -- external getter + getterT = ovs `arr` AppT (VarT m) (tuple [ft, ovs]) + getter = SigD (mkName (getterName field)) getterT + -- internal getter + getterT' = AppT stt ft + getter' = SigD (mkName (getterName field ++ "'")) getterT' + -- external setter + setterT = ovs `arr` ft `arr` AppT (VarT m) (tuple [TupleT 0,ovs]) + setter = SigD (mkName (setterName field)) setterT + -- internal setter + setterT' = ft `arr` AppT stt (TupleT 0) + setter' = SigD (mkName (setterName field ++ "'")) setterT' + -- field + fieldT = fieldType ovs svs m ft + fieldS = SigD (mkName field) fieldT + return [getter,getter',setter,setter',fieldS] + +genModsDecls :: SCV -> [String] -> [StateMemberDecl] -> Q [Dec] +genModsDecls scv vars fields = do + decls <- mapM (genModDeclsFor scv vars) fields + return $ concat decls + +splitMethodType :: Type -> ([Type], Type) +splitMethodType (ForallT tvs cxt t) = splitMethodType t +splitMethodType (AppT (AppT ArrowT arg) ret) = (arg : args, ret') + where + (args,ret') = splitMethodType ret +splitMethodType rt = ([],rt) + + + +methodType :: Type -> Type -> Name -> [Type] -> Type -> Type +methodType ovs svs m args rt = parameterise args st + where + st = foldl AppT (ConT (mkName "Selector")) [PromotedT (mkName "Method"), ovs, svs, VarT m, rt] + + + +genMethodDecls' :: StateEnv -> Maybe String -> SCV -> [String] -> Name -> Type -> Q [Dec] +genMethodDecls' env mp (SCV o s m) vars name ty = do + let + ovs = appN (VarT o) vars + svs = appN (VarT s) vars + stt = AppT (AppT (ConT (mkName "StateT")) svs) (VarT m) + -- external + inty = ovs `arr` wrapMethodType False (\rt -> AppT (VarT m) (tuple [rt,ovs])) ty + internal = SigD (mkName $ "_ecall_" ++ nameBase name) inty --(unwrapForalls ty exty) + -- internal + exty = wrapMethodType False (\rt -> AppT stt rt) ty + external = SigD (mkName $ "_icall_" ++ nameBase name) exty --(unwrapForalls ty inty) + -- method + (args,ret) = splitMethodType ty + mty = methodType ovs svs m args ret + method = SigD name mty + ov <- isInherited env mp name + if ov then return [] + else return [external, internal, method] + +genMethodDecls :: StateEnv -> Maybe String -> SCV -> [String] -> Dec -> Q [Dec] +genMethodDecls env mp scv vars (SigD name ty) = + genMethodDecls' env mp scv vars name ty +genMethodDecls _ _ _ _ _ = return [] + +genMethodsDecls :: StateEnv -> Maybe String -> SCV -> [String] -> [Dec] -> Q [Dec] +genMethodsDecls env mp scv vars ds = do + decls <- mapM (genMethodDecls env mp scv vars) ds + return $ concat decls + +-- | Generates the type class for a state declaration +genStateClass :: StateEnv -> [TyVarBndr] -> [Dec] -> StateDecl -> Q Dec +genStateClass env tyvars fs (StateDecl { + stateName = name, + stateParams = vs, + stateParentN = p, + stateData = ds + }) = do + o <- newName "o" + s <- newName "s" + m <- newName "m" + let + fam = FamilyD TypeFam (mkName $ name ++ "St") ([PlainTV o] {- ++ tyvars -}) (Just (VarT $ mkName "p")) + scv = SCV o s m + cname = mkName $ name ++ "Like" + vars = [PlainTV o, PlainTV s, PlainTV m] ++ tyvars + deps = [FunDep [o] [s], FunDep [s] [o]] + cxt <- genClassContext vs (parseType <$> p) scv + inv <- genInvokeDecl vs name scv + mds <- genModsDecls scv vs ds + ms <- genMethodsDecls env p scv vs fs + return $ ClassD cxt cname vars deps ([fam,inv] ++ mds ++ ms) diff --git a/Language/MSH/CodeGen/Constructors.hs b/Language/MSH/CodeGen/Constructors.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/CodeGen/Constructors.hs @@ -0,0 +1,116 @@ +module Language.MSH.CodeGen.Constructors ( + genConstructors +) where + +import Control.Applicative ((<$>)) +import Control.Monad (replicateM) + +import qualified Data.Map as M + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import Language.MSH.Constructor +import Language.MSH.StateDecl +import Language.MSH.StateEnv +import Language.MSH.CodeGen.Shared +import Language.MSH.CodeGen.Interop + +{- + Constructors +-} + +genCtrParams :: StateDecl -> Q [(String, Name)] +genCtrParams (StateDecl { + stateName = name, + stateData = ds +}) = mapM (\(n,_) -> newName n >>= \v -> return (n,v)) (getFields ds) + +-- | This is a hack to change the names of type variables in imported types from +-- unique names to unqualified names +unqualifyName :: Name -> Name +unqualifyName (Name occ flavour) = case flavour of + NameU _ -> Name occ NameS + _ -> Name occ flavour + +unqualifyBndr :: TyVarBndr -> TyVarBndr +unqualifyBndr (PlainTV n) = PlainTV (unqualifyName n) +unqualifyBndr (KindedTV n k) = KindedTV (unqualifyName n) k + +--unqualifyPred :: Pred -> Pred +--unqualifyPred (AppT (AppT EqualityT a) b) = AppT (AppT EqualityT (normaliseType a)) (normaliseType b) +--unqualifyPred (ClassP n ts) = foldl AppT (ConT n) (map normaliseType ts) + +normaliseType :: Type -> Type +normaliseType (ForallT bs ctx t) = ForallT (map unqualifyBndr bs) (map normaliseType ctx) (normaliseType t) +normaliseType (AppT f a) = AppT (normaliseType f) (normaliseType a) +normaliseType (SigT t k) = SigT (normaliseType t) k +normaliseType (VarT n) = VarT (unqualifyName n) +normaliseType t = t + +genPCtrParams :: StateEnv -> String -> Q [(Type,Name)] +genPCtrParams env pn = case M.lookup pn env of + (Just s) -> do + ts <- getFieldTypes $ stateData s + mapM (\(n,t) -> newName n >>= \n' -> return (t,n')) ts + Nothing -> do + mn <- lookupValueName $ "_mk" ++ pn + case mn of + Nothing -> fail $ "Constructor for `" ++ pn ++ "' is not in scope." + (Just n) -> do + (VarI _ t _ _) <- reify n + mapM (\t -> newName "arg" >>= \n -> return (t,n)) (typeArgs $ normaliseType t) + +genStateExpr :: StateDecl -> [(String, Name)] -> Exp +genStateExpr (StateDecl { + stateName = name, + stateData = ds +}) vs = RecConE (mkName $ "Mk" ++ name ++ "State") baseFs + where + baseFs = [(mkName $ "_" ++ name ++ "_" ++ n, VarE v) | (n,v) <- vs] + +-- | Generates the internal constructor `_mkS' for a class `S'. +genBaseConstructor :: StateEnv -> StateDecl -> Q StateCtr +genBaseConstructor env s@(StateDecl { stateName = name, stateParentN = mp, stateData = ds }) = do + vs <- genCtrParams s + ts <- map snd <$> getFieldTypes ds + let + baseName = mkName $ "_mk" ++ name + stateExp = genStateExpr s vs + ps = map (VarP . snd) vs + case mp of + Nothing -> do + let + cn = mkName $ name ++ "Data" + con = RecConE cn [(mkName $ "_" ++ name ++ "_data", stateExp)] + return $ SCtr { + sctrDec = FunD baseName [Clause ps (NormalB con) []], + sctrTypes = ts + } + (Just p) -> do + let + cn = mkName $ name ++ "End" + Name pn _ = parentName $ parseType p + pctr = "_mk" ++ occString pn + pps <- genPCtrParams env (occString pn) + let + pvs = map snd pps + supExp = VarE $ mkName pctr + appSup = appEs supExp (map VarE pvs) + con = RecConE cn [(mkName $ "_" ++ name ++ "_data",stateExp), (mkName $ "_" ++ name ++ "_sup",appSup)] + return $ SCtr { + sctrDec = FunD baseName [Clause (map VarP pvs ++ ps) (NormalB con) []], + sctrTypes = map fst pps ++ ts + } + +{-genSuperConstructor :: StateDecl -> Q Dec +genSuperConstructor (StateDecl m name vars p decls) = do + let + supName = mkName $ "_mk" ++ name ++ "_super" + supFs = [(mkName $ "_" ++ n, parseExp e) | (n,e) <- getFields decls] + supExp = RecConE (mkName $ name ++ "Start") + return $ FunD supName [Clause [] (NormalB supExp) []]-} + +genConstructors :: StateEnv -> StateDecl -> Q StateCtr +genConstructors env s = + genBaseConstructor env s diff --git a/Language/MSH/CodeGen/Data.hs b/Language/MSH/CodeGen/Data.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/CodeGen/Data.hs @@ -0,0 +1,28 @@ +module Language.MSH.CodeGen.Data where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import Language.MSH.StateDecl +import Language.MSH.CodeGen.Interop + +genDataField :: String -> String -> String -> Q VarStrictType +genDataField cl name typ = do + let + fname = mkName $ "_" ++ cl ++ "_" ++ name + return (fname, NotStrict, parseType typ) + +genDataFields :: String -> [StateMemberDecl] -> Q [VarStrictType] +genDataFields cl [] = return [] +genDataFields cl (StateDataDecl n _ t : ds) = do + v <- genDataField cl n t + vs <- genDataFields cl ds + return $ v : vs + +genStateData :: [TyVarBndr] -> StateDecl -> Q Dec +genStateData tyvars (StateDecl { stateName = name, stateData = ds }) = do + let + dname = mkName $ name ++ "State" + dctrname = mkName $ "Mk" ++ name ++ "State" + fs <- genDataFields name ds + return $ DataD [] dname tyvars [RecC dctrname fs] [] diff --git a/Language/MSH/CodeGen/Decls.hs b/Language/MSH/CodeGen/Decls.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/CodeGen/Decls.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Language.MSH.CodeGen.Decls ( + genStateDecls +) where + +import Control.Applicative ((<$>)) +import Control.Monad (replicateM) +import Control.Monad.Except (runExcept) +--import Control.Monad.State + +import Data.Char (toLower) +import Data.Graph (stronglyConnComp) +import qualified Data.Map as M + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import Control.Lens.TH +import Control.Lens.Internal.FieldTH + +-- needed to parse Haskell syntax and to convert it into TH syntax +import qualified Language.Haskell.Exts.Syntax as Syntax +import qualified Language.Haskell.Exts.Parser as Exts +import Language.Haskell.Exts.Extension +import Language.Haskell.Meta.Syntax.Translate (toType, toDecs, toExp) + +import Language.MSH.StateDecl +import Language.MSH.StateEnv +import Language.MSH.Constructor +import Language.MSH.Parsers +import Language.MSH.CodeGen.Shared +import Language.MSH.CodeGen.Interop +import Language.MSH.CodeGen.Data +import Language.MSH.CodeGen.Object +import Language.MSH.CodeGen.Monad +import Language.MSH.CodeGen.Class +import Language.MSH.CodeGen.Instances +import Language.MSH.CodeGen.Methods +import Language.MSH.CodeGen.Constructors +import Language.MSH.CodeGen.MiscInstances +import Language.MSH.CodeGen.Inheritance + +genIdentityInstance :: Q Dec +genIdentityInstance = do + let + ty = tuple [] + return $ InstanceD [] ty [] + + +{- + External interface +-} + +-- | Appends "_lens" to the lens names +lensLookup :: Name -> [Name] -> Name -> [DefName] +lensLookup _ fs field = [TopName $ mkName $ nameBase field ++ "_lens"] + +stateLensRules :: LensRules +stateLensRules = lensRules -- { _fieldToDef = lensLookup } + +-- | Generates top-level declarations for a state declaration +genStateDecl :: StateEnv -> StateDecl -> Q [Dec] +genStateDecl env s@(StateDecl { stateParams = vars, stateBody = decls }) = do + let + tyvars = map (PlainTV . mkName) vars + d <- genStateData tyvars s + ls <- makeFieldOpticsForDec stateLensRules d + t <- genStateType tyvars s + o <- genStateObject tyvars s + c <- genStateClass env tyvars decls s + is <- genStateInstances env c decls s + cs <- genConstructors env s + misc <- genMiscInstances s o cs + ms <- genMethods env s (stateName s) vars decls + return $ [d,t,o,c] ++ is ++ ls ++ [sctrDec cs] ++ ms ++ misc + +genStateDecls :: StateEnv -> Q [Dec] +genStateDecls env = case runExcept $ buildStateGraph env of + (Left err) -> fail $ show err + (Right env') -> do + dss <- mapM (genStateDecl env') (M.elems env') + return $ concat dss + + + + + diff --git a/Language/MSH/CodeGen/Inheritance.hs b/Language/MSH/CodeGen/Inheritance.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/CodeGen/Inheritance.hs @@ -0,0 +1,69 @@ +module Language.MSH.CodeGen.Inheritance where + +import qualified Data.Map as M + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import Language.MSH.StateDecl +import Language.MSH.StateEnv +import Language.MSH.MethodTable +import Language.MSH.CodeGen.Shared +import Language.MSH.CodeGen.Interop + +data HasMethodResult = DefResult Bool | ContResult String + +class HasMethod a where + hasMethod :: Name -> a -> Bool + +instance HasMethod Dec where + hasMethod name (SigD n _) = nameBase n == nameBase name + hasMethod name _ = False + +isOverridenEnv :: StateEnv -> StateDecl -> Name -> Q Bool +isOverridenEnv env (StateDecl { + stateParentN = mp, + stateBody = body +}) name = case mp of + Nothing -> return $ any (hasMethod name) body + (Just p) -> isInheritedFromParent env p name + +{-parentFromInfo :: Cxt -> Maybe String +parentFromInfo [] = Nothing +parentFromInfo (ClassP n _ : cs) + | nameBase n /= "Object" = Just (nameBase n) -- TODO: REmove "Like"? + | otherwise = parentFromInfo cs +parentFromInfo (_ : cs) = parentFromInfo cs-} + +isInheritedFromInfo :: StateEnv -> Info -> Name -> Q Bool +isInheritedFromInfo env (ClassI (ClassD cxt _ _ _ ds) _) name = error "Inheritance:isInheritedFromInfo" {-case parentFromInfo cxt of + Nothing -> return $ any (hasMethod name) ds + (Just p) -> fail $ show cxt -- TODO: we should search `p'-} + +isInheritedFromParent :: StateEnv -> String -> Name -> Q Bool +isInheritedFromParent env p name = let pn = nameBase $ parentName $ parseType p in case M.lookup pn env of + (Just s) -> isOverridenEnv env s name + Nothing -> do + mn <- lookupTypeName (pn ++ "Like") + case mn of + Nothing -> fail $ "`" ++ pn ++ "' is not in scope." + (Just n) -> do + i <- reify n + isInheritedFromInfo env i name + +-- | `isInherited env mp name' determines whether a method `name' is inherited from `mp' +isInherited :: StateEnv -> Maybe String -> Name -> Q Bool +isInherited env Nothing name = return False +isInherited env (Just p) name = isInheritedFromParent env p name + +declByParent :: Name -> StateDecl -> Bool +declByParent _ (StateDecl { stateParent = Nothing }) = False +declByParent n (StateDecl { stateParent = (Just p) }) = + M.member (nameBase n) (methodSigs $ stateMethods p) || declByParent n p + +-- | Determines whether a method is abstract. +isAbstract :: Name -> StateDecl -> Bool +isAbstract n (StateDecl { stateParent = Nothing, stateMethods = tbl }) = + M.notMember (nameBase n) (methodDefs tbl) +isAbstract n (StateDecl { stateParent = Just p, stateMethods = tbl }) = + M.notMember (nameBase n) (methodDefs tbl) && isAbstract n p diff --git a/Language/MSH/CodeGen/Instances.hs b/Language/MSH/CodeGen/Instances.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/CodeGen/Instances.hs @@ -0,0 +1,344 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Language.MSH.CodeGen.Instances where + +import Control.Applicative ((<$>)) +import Control.Monad (replicateM) + +import Data.Char (toLower) +import qualified Data.Map as M + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import Language.MSH.StateDecl +import Language.MSH.StateEnv +import Language.MSH.CodeGen.Shared +import Language.MSH.CodeGen.Interop +import Language.MSH.CodeGen.Inheritance +import Language.MSH.CodeGen.SharedInstance (genInvokeDef, genRunStateT, genInvoke) +import Language.MSH.CodeGen.ObjectInstance (genObjectInstance) +import Language.MSH.CodeGen.PrimaryInstance (genPrimaryInstance, genIdentityInstance, genParentalInstance) + +{-------------------------------------------------------------------------- + Type class instances +--------------------------------------------------------------------------} + + + +-- | Enumerates different member generation modes. +data MemberGenMode = Primary -- ^ Generated members will correspond to their implementations + | Lift -- ^ Generated members will forward calls to the parent, unless overriden + | Invoke -- ^ Generates members will call the `_invoke' method to construct a monad stack + +genDataClause :: MemberGenMode -> String -> [Name] -> Exp -> Q Clause +-- [Primary] (Data d) x0..xn = do { (r,d') <- runStateT expr d; return (r, Data d') } +genDataClause Primary name vars expr = do + d <- newName "d" + r <- newName "r" + d' <- newName "d'" + let + ctr = mkName $ name ++ "Data" + pat = ConP ctr [VarP d] : map VarP vars + bpat = TupP [VarP r, VarP d'] + ret = AppE (VarE $ mkName "return") (TupE [VarE r, AppE (ConE ctr) (VarE d')]) + body = DoE [BindS bpat (genRunStateT expr (VarE d)), NoBindS ret] + return $ Clause pat (NormalB body) [] +-- [Invoke] (Data d) x0..xn = error "" +genDataClause Invoke name vars expr = do + d <- newName "d" + r <- newName "r" + d' <- newName "d'" + let + ctr = mkName $ name ++ "Data" + pat = ConP ctr [VarP d] : map VarP vars + body = AppE (VarE $ mkName "error") (VarE $ mkName "_msh_rt_invalid_call_state") + return $ Clause pat (NormalB body) [] + +genStartClause :: MemberGenMode -> String -> [Name] -> (Exp -> Exp) -> Q Clause +-- (Start d s) x0...xn = do { ((r,s'),d') <- runStateT (expr s); return (r, Start d' s') } +genStartClause Primary name vars expr = do + d <- newName "d" + s <- newName "s" + r <- newName "r" + d' <- newName "d'" + s' <- newName "s'" + let + ctr = mkName $ name ++ "Start" + pat = ConP ctr [VarP d, VarP s] : map VarP vars + bpat = TupP [TupP [VarP r, VarP s'], VarP d'] + ret = AppE (VarE $ mkName "return") (TupE [VarE r, AppE (AppE (ConE ctr) (VarE d')) (VarE s')]) + body = DoE [BindS bpat (genRunStateT (expr (VarE s)) (VarE d)), NoBindS ret] + return $ Clause pat (NormalB body) [] +genStartClause Invoke name vars expr = do + d <- newName "d" + s <- newName "s" + let + ctr = mkName $ name ++ "Start" + pat = ConP ctr [VarP d, VarP s] : map VarP vars + body = AppE (VarE $ mkName "error") (VarE $ mkName "_msh_rt_invalid_call_state") + return $ Clause pat (NormalB body) [] + +genMiddleClause :: MemberGenMode -> StateDecl -> [Name] -> Exp -> Q Clause +{-genMiddleClause Primary (StateDecl { stateName = name }) vars expr = do + d <- newName "d" + s <- newName "s" + r <- newName "r" + d' <- newName "d'" + s' <- newName "s'" + p <- newName "p" + let + ctr = mkName $ name ++ "Middle" + pat = ConP ctr [VarP p, VarP d, VarP s] : map VarP vars + bpat = TupP [TupP [VarP r, VarP s'], VarP d'] + ret = AppE (VarE $ mkName "return") (TupE [VarE r, foldl AppE (ConE ctr) [VarE p, VarE d', VarE s']]) + body = DoE [BindS bpat (genRunStateT (expr (VarE s)) (VarE d)), NoBindS ret] + return $ Clause pat (NormalB body) []-} +genMiddleClause Invoke (StateDecl { stateName = name, stateParent = Just parent }) vars expr = do + p <- newName "p" + d <- newName "d" + s <- newName "s" + r <- newName "r" + o <- newName "o" + p' <- newName "p'" + obj <- newName "obj" + let + ctr = mkName $ name ++ "Middle" + pat = (AsP obj $ ConP ctr [VarP p, VarP d, VarP s]) : map VarP vars + dn = mkName $ "_" ++ name ++ "_data" + sn = mkName $ "_" ++ name ++ "_sub" + ret = AppE (VarE $ mkName "return") (TupE [VarE r, foldl AppE (ConE ctr) [VarE p', AppE (VarE dn) (VarE o), AppE (VarE sn) (VarE o)]]) + bpat = TupP [VarP r, VarP p', VarP o] + body = DoE [BindS bpat (genInvoke (stateName parent) (VarE obj) expr (VarE s)), NoBindS ret] + return $ Clause pat (NormalB body) [] + +genEndClause :: MemberGenMode -> String -> [Name] -> Exp -> Q Clause +genEndClause Primary name vars expr = do + d <- newName "d" + r <- newName "r" + d' <- newName "d'" + p <- newName "p" + let + ctr = mkName $ name ++ "End" + pat = ConP ctr [VarP p, VarP d] : map VarP vars + bpat = TupP [VarP r, VarP d'] + ret = AppE (VarE $ mkName "return") (TupE [VarE r, foldl AppE (ConE ctr) [VarE p, VarE d']]) + body = DoE [BindS bpat (genRunStateT expr (VarE d)), NoBindS ret] + return $ Clause pat (NormalB body) [] + +findClassMethodType :: [Dec] -> String -> Type +findClassMethodType [] m = error $ "Method not defined: " ++ m +findClassMethodType (SigD n t : ds) m + | nameBase n == m = t + | otherwise = findClassMethodType ds m +findClassMethodType (_ : ds) m = findClassMethodType ds m + + + +numArgsForMethod :: Dec -> String -> Int +numArgsForMethod (ClassD _ _ _ _ ds) n = + countTypeArgs $ findClassMethodType ds n + +{-------------------------------------------------------------------------- + Fields +--------------------------------------------------------------------------} + +{-lensName :: String -> String +lensName (x:xs) = toLower x : xs + +genGetterBody :: MemberGenMode -> String -> Name -> Exp +genGetterBody Primary lens self = AppE (VarE $ mkName "use") (VarE $ mkName lens) +genGetterBody Lift lens self = AppE (VarE $ mkName "lift") (VarE self) +genGetterBody Invoke lens self = AppE (VarE $ mkName "error") (LitE $ + StringL "Invalid call: trying to construct monad stack in an internal getter call.") + +-- | `genModDefs mode name fname' generates the getter, the setter, and the +-- field selector for a field named `fname' in a state class named `name' +-- using routing mode `mode'. +genModDefs :: MemberGenMode -> String -> String -> Q [Dec] +genModDefs mode name fname = do + let + bname = "_" ++ fname -- the base name of the field + gname = "_get" ++ bname -- the name of the getter + sname = "_set" ++ bname -- the name of the setter + lname = lensName name ++ "_" ++ fname -- the name of the lens for this field + gdcl <- genDataClause mode name [] (VarE $ mkName $ gname ++ "'") + gscl <- genStartClause mode name [] (AppE (VarE $ mkName gname)) + let + gcls = [gdcl,gscl] + ext_g = mkName gname + int_g = mkName $ gname ++ "'" + getter = FunD ext_g gcls + getter' = FunD int_g [Clause [] (NormalB $ genGetterBody mode lname int_g) []] + v <- newName "v" + sdcl <- genDataClause mode name [v] (AppE (VarE $ mkName $ sname ++ "'") (VarE v)) + sscl <- genStartClause mode name [v] (\s -> AppE (AppE (VarE $ mkName sname) s) (VarE v)) + let + scls = [sdcl,sscl] + ext_s = mkName sname + int_s = mkName $ sname ++ "'" + setter = FunD ext_s scls + setter' = FunD int_s [Clause [] (NormalB (AppE (VarE $ mkName "assign") (VarE $ mkName lname))) []] + field = FunD (mkName fname) [Clause [] (NormalB $ appEs (ConE $ mkName "MkField") [VarE $ mkName gname, VarE $ mkName $ gname ++ "'", VarE $ mkName sname, VarE $ mkName $ sname ++ "'" ]) []] + return [getter,getter',setter,setter',field] + +-- | `genModsDefs mode name ds' generates getters, setters, and field selectors +-- for the fields in `ds' which are part of a state class named `name'. `mode' +-- determines how these calls will be routed. +genModsDefs :: MemberGenMode -> String -> [StateMemberDecl] -> Q [Dec] +genModsDefs mode name ds = + concat <$> mapM (genModDefs mode name) (map stateDataName ds) + +genSelectorWrapper :: [Name] -> Exp -> Exp +genSelectorWrapper [] exp = exp +genSelectorWrapper ns exp = LamE (map VarP ns) exp + +genInternalWrapper :: Name -> [Name] -> Exp +genInternalWrapper iname [] = VarE iname --AppE (VarE $ mkName "const") (VarE iname) +genInternalWrapper iname vs = appEs (VarE iname) (map VarE vs) -- LamE [TupP $ map VarP vs] (AppE (VarE iname) (TupE $ map VarE vs)) + +genExternalWrapper :: Name -> [Name] -> Exp +genExternalWrapper ename [] = LamE [VarP obj] $ AppE (VarE ename) (VarE obj) + where + obj = mkName "obj" +genExternalWrapper ename vs = LamE [VarP obj] $ appEs (AppE (VarE ename) (VarE obj)) (map VarE vs) + where + obj = mkName "obj" + +genMethodDef' :: MemberGenMode -> StateEnv -> StateDecl -> MethodTable -> Dec -> Maybe String -> String -> String -> Q [Dec] +genMethodDef' mode env decl tbl cls mp cn name = do + ov <- isInherited env mp (mkName name) + if ov then return [] + else do + let + argc = numArgsForMethod cls ("_icall_" ++ name) + -- external call name + ename = mkName $ "_ecall_" ++ name + -- internal call name + iname = mkName $ "_icall_" ++ name + vs <- replicateM argc (newName "v") + -- TODO: these should be generated per call? + edcl <- genDataClause mode cn vs (appEs (VarE iname) (map VarE vs)) + escl <- genStartClause mode cn vs (\s -> appEs (AppE (VarE ename) s) (map VarE vs)) + --emcl <- genMiddleClause mode cn vs (VarE iname) + let + -- external + eclauses = [edcl, escl] -- TODO: this should match the avail. constructors + external = FunD ename eclauses + -- internal + mname = mkName $ "_" ++ cn ++ "_" ++ name + iclauses = if isAbstract (mkName name) tbl + then [Clause [] (NormalB (AppE (VarE $ mkName "error") (VarE $ mkName "_msh_rt_invalid_call_abstract"))) []] + else [Clause [] (NormalB (VarE mname)) []] + internal = FunD iname iclauses + -- method + iwrapper = genInternalWrapper iname vs + ewrapper = genExternalWrapper ename vs + swrapper = genSelectorWrapper vs (appEs (ConE $ mkName "MkMethod") [iwrapper, ewrapper]) + mclauses = [Clause [] (NormalB swrapper) []] + method = FunD (mkName $ name) mclauses + return [external, internal, method] + +-- | `genMethodDef env cls mp cn d' generates a method for based on `d'. +genMethodDef :: MemberGenMode -> StateEnv -> StateDecl -> MethodTable -> Dec -> Maybe String -> String -> Dec -> Q [Dec] +genMethodDef mode env decl tbl cls mp cn (SigD name _) = genMethodDef' mode env decl tbl cls mp cn (nameBase name) +--genMethodDef env tbl cls mp cn (FunD name _) = genMethodDef' env cls mp cn (nameBase name) +--genMethodDef env tbl cls mp cn (ValD (VarP name) _ _) = genMethodDef' env cls mp cn (nameBase name) +genMethodDef _ _ _ _ _ _ _ _ = return [] + +genMethodsDefs :: MemberGenMode -> StateEnv -> Dec -> StateDecl -> MethodTable -> Maybe String -> String -> Q [Dec] +genMethodsDefs mode env cls decl tbl mp cn = + concat <$> mapM (genMethodDef mode env decl tbl cls mp cn) (M.elems $ methodSigs tbl) + +getBaseMonad :: Maybe String -> Type +getBaseMonad Nothing = ConT $ mkName "Identity" +getBaseMonad (Just p) = renameParent (\n -> n ++ "M") $ parseType p-} + +{-genPrimaryInstance :: StateEnv -> Dec -> [Dec] -> StateDecl -> Q Dec +genPrimaryInstance env cls decs decl@(StateDecl { + stateName = name, + stateParams = vars, + stateData = ds, + stateParentN = mp, + stateMethods = methods +}) = do + let + cxt = [] + cn = mkName $ name ++ "Like" + on = mkName name + sn = mkName $ name ++ "State" + bt = getBaseMonad mp + ty = appN (AppT (AppT (AppT (ConT cn) (ConT on)) (ConT sn)) bt) vars + fam = TySynInstD (mkName $ name ++ "St") $ TySynEqn [ConT on] (ConT sn) + invk <- genInvokeDef name + mods <- genModsDefs Primary name ds + ms <- genMethodsDefs Primary env cls decl methods mp name + return $ InstanceD cxt ty ([fam,invk] ++ mods ++ ms)-} + +{-genIdentityInstance :: StateEnv -> Dec -> [Dec] -> StateDecl -> Q Dec +genIdentityInstance env cls decs decl@(StateDecl { + stateName = name, + stateParams = vars, + stateData = ds, + stateParentN = mp, + stateMethods = methods +}) = do + let + cxt = [] + cn = mkName $ name ++ "Like" + on = mkName name + sn = mkName $ name ++ "State" + bt = ConT $ mkName "Identity" + ty = appN (AppT (AppT (AppT (ConT cn) (ConT on)) (ConT sn)) bt) vars + fam = TySynInstD (mkName $ name ++ "St") $ TySynEqn [ConT on] (ConT sn) + invk <- genInvokeDef name + mods <- genModsDefs Invoke name ds + ms <- genMethodsDefs Invoke env cls decl methods mp name + return $ InstanceD cxt ty ([fam,invk] ++ mods ++ ms)-} + +-- TODO: do this recursively +-- TODO: method bodies +{-genParentalInstance :: StateDecl -> StateDecl -> Q [Dec] +genParentalInstance sub parent = do + let + cxt = [] + cn = mkName $ (stateName parent) ++ "Like" + on = mkName (stateName sub) + sn = mkName $ (stateName sub) ++ "State" + bt = getBaseMonad (stateParentN sub) + -- TODO: not sure if the parameters should be from the parent or inferred from the parent type? + ty = foldl AppT (ConT cn) ([ConT on, ConT sn, bt] ++ map (VarT . mkName) (stateParams parent)) + idty = foldl AppT (ConT cn) ([ConT on, ConT sn, ConT $ mkName "Identity"] ++ map (VarT . mkName) (stateParams parent)) + rs <- case stateParent parent of + Nothing -> return [] + (Just p) -> genParentalInstance sub p + return $ [ InstanceD cxt ty [] + , InstanceD cxt idty []] ++ rs-} + +-- | Generates instances of the parental type classes. +genParentalInstances :: StateEnv -> StateDecl -> Q [Dec] +genParentalInstances _ (StateDecl { stateParent = Nothing }) = do + return [] +genParentalInstances env s@(StateDecl { stateParent = Just parent }) = do + genParentalInstance s parent + +-- | Generates type class instances for a state declaration +-- For a base class, there will be one instance of the corresponding type class +-- For sub-classes, there will be two instances of the corresponding type class, +-- as well as instances of all parent classes +genStateInstances :: StateEnv -> Dec -> [Dec] -> StateDecl -> Q [Dec] +genStateInstances env cls decs s = do + -- generate the instance for the `Object' class -- one per state class + obj <- genObjectInstance s + -- generate the primary instance (CLike C CData PMonad) + p <- genPrimaryInstance env cls decs s + -- generate the parental instances (PLike C CData AMonad) + ii <- if isBaseClass s + then return [] + else do + -- generate the identity instance (CLike C CData Identity) + i <- genIdentityInstance env cls decs s + -- generate the parental instances (PLike C CData PPMonad & PLike C CData Identity) + ps <- genParentalInstances env s + return $ i : ps + return $ [p] ++ ii ++ obj diff --git a/Language/MSH/CodeGen/Interop.hs b/Language/MSH/CodeGen/Interop.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/CodeGen/Interop.hs @@ -0,0 +1,42 @@ +module Language.MSH.CodeGen.Interop ( + parseType, + parseDecs, + parseExp +) where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import qualified Language.Haskell.Exts.Syntax as Syntax +import qualified Language.Haskell.Exts.Parser as Exts +import Language.Haskell.Exts.Extension +import Language.Haskell.Meta.Syntax.Translate (toType, toDecs, toExp) + +{- + Utility functions to parse and convert Haskell syntax +-} + +-- | Haskell language extensions we want to allow +extensions = map EnableExtension [GADTs, + TypeFamilies, + RankNTypes, + FunctionalDependencies, + ScopedTypeVariables, + MultiParamTypeClasses, + FlexibleInstances, + FlexibleContexts, + TypeOperators, + LambdaCase] + +-- | Configuration for the Haskell parser +parseMode = Exts.ParseMode "" Haskell2010 extensions True True Nothing + +-- | Parses a string into a TH type +parseType :: String -> Type +parseType = toType . Exts.fromParseResult . Exts.parseTypeWithMode parseMode + +parseDecs :: String -> [Dec] +parseDecs xs = let (Syntax.Module _ _ _ _ _ _ ds) = Exts.fromParseResult $ Exts.parseModuleWithMode parseMode xs in toDecs ds + +parseExp :: String -> Exp +parseExp = toExp . Exts.fromParseResult . Exts.parseExpWithMode parseMode diff --git a/Language/MSH/CodeGen/Methods.hs b/Language/MSH/CodeGen/Methods.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/CodeGen/Methods.hs @@ -0,0 +1,54 @@ +module Language.MSH.CodeGen.Methods ( + genMethods +) where + +import qualified Data.Map as M + +import Debug.Trace + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import Language.MSH.StateDecl +import Language.MSH.StateEnv +import Language.MSH.CodeGen.Shared +import Language.MSH.CodeGen.Inheritance + +{- + Methods +-} + + + +-- | Generates a method belonging to a state class. +genMethod :: StateEnv -> StateDecl -> String -> [String] -> Dec -> Q [Dec] +genMethod env decl n vars (SigD name ty) + | isAbstract name decl = trace (nameBase name ++ " is abstract in " ++ show decl) $ return [] + | otherwise = do + o <- newName "o" + s <- newName "s" + m <- newName "m" + let + n' = mkName $ "_" ++ n ++ "_" ++ nameBase name + svs = appN (VarT s) vars + stt = AppT (AppT (ConT (mkName "StateT")) svs) (VarT m) + tvs = [PlainTV o, PlainTV s, PlainTV m] + cxt = [foldl AppT (ConT $ mkName $ n ++ "Like") ([VarT o, VarT s, VarT m] ++ map (VarT . mkName) vars)] + return [ + SigD n' $ unwrapForalls ty $ ForallT tvs cxt $ wrapMethodType False (\rt -> AppT stt rt) ty] +genMethod env decl n vars (ValD (VarP name) body wh) = do + let + n' = mkName $ "_" ++ n ++ "_" ++ nameBase name + return [ValD (VarP n') body wh] +genMethod env decl n vars (FunD name cs) = do + let + n' = mkName $ "_" ++ n ++ "_" ++ nameBase name + return [FunD n' cs] +genMethod env decl n vars dec = fail $ + "Unsupported type of definition within a state class:\n" ++ show dec + +-- | Generates methods for a state class. +genMethods :: StateEnv -> StateDecl -> String -> [String] -> [Dec] -> Q [Dec] +genMethods env decl n vars ds = do + concat `fmap` mapM (genMethod env decl n vars) ds + diff --git a/Language/MSH/CodeGen/MiscInstances.hs b/Language/MSH/CodeGen/MiscInstances.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/CodeGen/MiscInstances.hs @@ -0,0 +1,129 @@ +module Language.MSH.CodeGen.MiscInstances ( + genMiscInstances +) where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import Language.MSH.StateDecl +import Language.MSH.Constructor +import Language.MSH.CodeGen.Interop +import Language.MSH.CodeGen.Shared +import Language.MSH.CodeGen.NewInstance + +{- + Misc. Instances +-} + +-- | Generates a caluse which extracts the data from an object's constructor. +genObjectDataExtractor :: String -> Name -> Q Clause +genObjectDataExtractor n ctr = do + d <- newName "d" + let + pat = RecP ctr [(mkName $ "_" ++ n ++ "_data", VarP d)] + body = VarE d + return $ Clause [pat] (NormalB body) [] + +-- | Generates a function which extracts the data from an object's constructors. +genObjectInstanceDec :: String -> [Con] -> Q Dec +genObjectInstanceDec n ctrs = do + cs <- mapM (genObjectDataExtractor n) (map conName ctrs) + return $ FunD (mkName "extractData") cs + +-- | Generates an instance of the `Object' class. +genDataInstance :: StateDecl -> Dec -> Q Dec +genDataInstance (StateDecl { + stateName = name, + stateParams = vars +}) (DataD _ oname tyvars cs _) = do + let + ct = ConT $ mkName "HasData" + ty = appN (ConT $ mkName name) vars + dt = appN (ConT $ mkName $ name ++ "State") vars + decs <- genObjectInstanceDec name cs + return $ InstanceD [] (AppT (AppT ct ty) dt) [decs] + +genParentPattern :: Name -> Name -> StateDecl -> Pat +genParentPattern pd pp p + | isBaseClass p = ConP (mkName $ stateName p ++ "Data") [VarP pd] + | otherwise = ConP (mkName $ stateName p ++ "End") [VarP pp, VarP pd] + +genParentCtr :: Name -> Name -> StateDecl -> Exp -> Exp +genParentCtr pd pp p s + | isBaseClass p = + foldl AppE (ConE (mkName $ stateName p ++ "Start")) [VarE pd, s] + | otherwise = + foldl AppE (ConE (mkName $ stateName p ++ "Middle")) [VarE pp, VarE pd, s] + +-- downcast (CEnd ) +genCastFromEnd :: StateDecl -> Q Clause +genCastFromEnd (StateDecl { stateName = name, stateParent = Just p }) = do + d <- newName "d" -- represents the data of this object + pd <- newName "pd" -- represents the data of the parent + pp <- newName "pp" -- represents the parent of the parent + let + ctrName = mkName $ name ++ "End" + + parPat = genParentPattern pd pp p + + exp = AppE (ConE $ mkName $ name ++ "Data") (VarE d) + pattern = ConP ctrName [parPat, VarP d] + body = genParentCtr pd pp p exp + return $ Clause [pattern] (NormalB body) [] + +genCastFromMid :: StateDecl -> Q Clause +genCastFromMid (StateDecl { stateName = name, stateParent = Just p }) = do + d <- newName "d" -- represents the data of this object + ss <- newName "s" -- represents the delta-object of the child + pd <- newName "pd" -- represents the data of the parent + pp <- newName "pp" -- represents the parent of the parent + let + ctrName = mkName $ name ++ "Middle" + + parPat = genParentPattern pd pp p + + exp = foldl AppE (ConE $ mkName $ name ++ "Start") [VarE d, VarE ss] + pattern = ConP ctrName [parPat, VarP d, VarP ss] + body = genParentCtr pd pp p exp + return $ Clause [pattern] (NormalB body) [] + +-- | `genDowncastClauses s' generates the clauses for the `downcast' +-- function in an instance of `Cast' for state class `s'. +genDowncastClauses :: StateDecl -> Q [Clause] +genDowncastClauses s = do + castFromEnd <- genCastFromEnd s + castFromMid <- genCastFromMid s + case stateMod s of + Nothing -> return [castFromMid, castFromEnd] + Just Abstract -> return [castFromMid] + Just Final -> return [castFromEnd] + +-- | `genCastInstance s' generates an instance of the `Cast' typeclass for +-- state class `s' if `s' is not a base class. +genCastInstance :: StateDecl -> Q [Dec] +genCastInstance s@(StateDecl { + stateName = name, + stateParams = vars, + stateParent = mp +}) = case mp of + Nothing -> return [] + (Just p) -> do + body <- genDowncastClauses s + let + ct = ConT $ mkName "Cast" + ty = appN (ConT $ mkName name) vars + dwn = FunD (mkName "downcast") body + return $ [InstanceD [] (AppT (AppT ct ty) (parseType (stateName p))) [dwn]] + + +genMiscInstances :: StateDecl -> Dec -> StateCtr -> Q [Dec] +genMiscInstances decl dec ctr + | isAbstractClass decl = do + d <- genDataInstance decl dec + cs <- genCastInstance decl + return $ d : cs + | otherwise = do + d <- genDataInstance decl dec + n <- genNewInstance ctr decl + cs <- genCastInstance decl + return $ d : n : cs diff --git a/Language/MSH/CodeGen/Monad.hs b/Language/MSH/CodeGen/Monad.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/CodeGen/Monad.hs @@ -0,0 +1,26 @@ +module Language.MSH.CodeGen.Monad ( + genStateType +) where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import Language.MSH.StateDecl +import Language.MSH.CodeGen.Shared +import Language.MSH.CodeGen.Interop + +genStateType :: [TyVarBndr] -> StateDecl -> Q Dec +genStateType tyvars (StateDecl { stateName = name, stateParams = vars, stateParentN = mp }) = do + let + -- unlike in the paper, the type synonym isn't just the name of the class + tname = mkName $ name ++ "M" + stype = appN (ConT (mkName $ name ++ "State")) vars + case mp of + Nothing -> return $ TySynD tname tyvars (AppT (ConT (mkName "State")) stype) + (Just p) -> do + let + ptype = parseType p + -- we want the monad, not the object + fixpt t@(ConT _) = renameT (\n -> n ++ "M") t + fixpt (AppT f a) = AppT (fixpt f) a + return $ TySynD tname tyvars (AppT (AppT (ConT (mkName "StateT")) stype) (fixpt ptype)) diff --git a/Language/MSH/CodeGen/New.hs b/Language/MSH/CodeGen/New.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/CodeGen/New.hs @@ -0,0 +1,13 @@ +module Language.MSH.CodeGen.New ( + genNewExp +) where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import Language.MSH.NewExpr +import Language.MSH.CodeGen.Interop + +genNewExp :: NewExpr -> Q Exp +genNewExp (NewExpr ty args) = do + return $ (VarE $ mkName $ "_mk" ++ ty) diff --git a/Language/MSH/CodeGen/NewInstance.hs b/Language/MSH/CodeGen/NewInstance.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/CodeGen/NewInstance.hs @@ -0,0 +1,26 @@ +module Language.MSH.CodeGen.NewInstance ( + genNewInstance +) where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import Language.MSH.Constructor +import Language.MSH.BuiltIn +import Language.MSH.StateDecl +import Language.MSH.CodeGen.Interop +import Language.MSH.CodeGen.Shared + +genNewInstance :: StateCtr -> StateDecl -> Q Dec +genNewInstance (SCtr (FunD cn [Clause ps _ _]) ts) (StateDecl { + stateName = name, + stateParams = vars +}) = do + ns <- mapM (\(VarP n) -> return n) ps + let + ct = ConT $ mkName newClassName + ty = appN (ConT $ mkName name) vars + appCtr = appEs (VarE cn) (map VarE ns) + synInst = TySynInstD (mkName newArgsTypeName) $ TySynEqn [ty] (tuple ts) + eq = FunD (mkName newKwdName) [Clause [TupP ps] (NormalB appCtr) []] + return $ InstanceD [] (AppT ct ty) [synInst,eq] diff --git a/Language/MSH/CodeGen/Object.hs b/Language/MSH/CodeGen/Object.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/CodeGen/Object.hs @@ -0,0 +1,107 @@ +module Language.MSH.CodeGen.Object where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import Language.MSH.StateDecl +import Language.MSH.CodeGen.Shared +import Language.MSH.CodeGen.Interop + +supField :: String -> Type -> VarStrictType +supField c pt = (fname, NotStrict, ftype) + where + fname = mkName $ "_" ++ c ++ "_sup" + ftype = pt + +dataField :: String -> [String] -> VarStrictType +dataField c vars = (fname, NotStrict, ftype) + where + fname = mkName $ "_" ++ c ++ "_data" + ftype = appN (ConT $ mkName $ c ++ "State") vars + +subField :: String -> Name -> [String] -> VarStrictType +subField c s vars = (fname, NotStrict, ftype) + where + fname = mkName $ "_" ++ c ++ "_sub" + ftype = appN (VarT s) vars + +objectCtrCxt :: String -> [String] -> Name -> Name -> Q Cxt +objectCtrCxt name vars s d = do + let + clname = mkName $ name ++ "Like" + tyname = mkName $ name ++ "M" + ty = appN (ConT tyname) vars + tyvars = map (VarT . mkName) vars + return [foldl AppT (ConT clname) ([VarT s, VarT d, ty] ++ tyvars)] + +dataCtr :: String -> [String] -> Q Con +dataCtr name vars = do + let + cname = mkName $ name ++ "Data" + return $ RecC cname [dataField name vars] + +startCtr :: String -> [String] -> Q Con +startCtr name vars = do + s <- newName "s" + d <- newName "d" + cxt <- objectCtrCxt name vars s d + let + cname = mkName $ name ++ "Start" + return $ ForallC [PlainTV s, PlainTV d] cxt $ RecC cname [ + dataField name vars, + subField name s vars] + +endCtr :: String -> [String] -> Type -> Q Con +endCtr name vars p = do + let + cname = mkName $ name ++ "End" + return $ RecC cname [ + supField name p, + dataField name vars] + +middleCtr :: String -> [String] -> Type -> Q Con +middleCtr name vars p = do + s <- newName "s" + d <- newName "d" + cxt <- objectCtrCxt name vars s d + let + cname = mkName $ name ++ "Middle" + return $ ForallC [PlainTV s, PlainTV d] cxt $ RecC cname [ + supField name p, + dataField name vars, + subField name s vars] + +genObjectCtrs :: StateDecl -> Q [Con] +genObjectCtrs (StateDecl { + stateMod = m, + stateName = name, + stateParams = vars, + stateParent = Nothing}) = do + dctr <- dataCtr name vars + case m of + Just Final -> return [dctr] + _ -> do + sctr <- startCtr name vars + return [dctr, sctr] +genObjectCtrs (StateDecl { + stateMod = m, + stateName = name, + stateParams = vars, + stateParentN = (Just p) } ) = do + sctr <- startCtr name vars + mctr <- middleCtr name vars (parseType p) + dctr <- dataCtr name vars + ectr <- endCtr name vars (parseType p) + case m of + Nothing -> return [dctr, sctr, ectr, mctr] + Just Abstract -> return [sctr, mctr] + Just Final -> return [dctr, ectr] + +-- | Generates the object type for a state declaration +genStateObject :: [TyVarBndr] -> StateDecl -> Q Dec +genStateObject tyvars s@(StateDecl { stateName = name }) = do + let + -- unlike in the paper, we use just the name for the object + oname = mkName $ name {- ++ "Object" -} + cs <- genObjectCtrs s + return $ DataD [] oname tyvars cs [] diff --git a/Language/MSH/CodeGen/ObjectInstance.hs b/Language/MSH/CodeGen/ObjectInstance.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/CodeGen/ObjectInstance.hs @@ -0,0 +1,49 @@ +module Language.MSH.CodeGen.ObjectInstance ( + genObjectInstance +) where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import Language.MSH.StateDecl +import Language.MSH.CodeGen.Shared + +genObjectTypeInsts :: Type -> Type -> Q [Dec] +genObjectTypeInsts obj st = do + m <- VarT `fmap` newName "m" + s <- VarT `fmap` newName "st" + r <- VarT `fmap` newName "r" + t <- VarT `fmap` newName "ty" + return [ TySynInstD (mkName "QueryObject") $ TySynEqn [obj] obj + , TySynInstD (mkName "QueryMonad") $ TySynEqn [obj, m] m + , TySynInstD (mkName "QueryResult") $ TySynEqn [obj, t, s, m, r] + (foldl AppT (ConT $ mkName "RunnableQuery") [ ConT (mkName "ExtCall") + , obj, st, m, r ])] + +-- | `genObjectInstance decl' generates an instance of `Object' +-- for the state declaration `decl'. Note: only one such instance +-- is needed per state decl. +genObjectInstance :: StateDecl -> Q [Dec] +genObjectInstance (StateDecl { stateName = name, stateParams = bars{-, stateParent = (Just ps)-} }) = do + let + obj = appN (ConT $ mkName name) bars + st = appN (ConT $ mkName $ name ++ "State") bars + -- The name of the arbitrary monad this instance is for. + m <- newName "m" + let + --p = parseType ps + --(Name pn _) = parentName p + --pcname = mkName $ occString pn ++ "M" + --vars = parentArgs p + cxt = [AppT (ConT $ mkName "Monad") (VarT m)] + --m = (appN' (ConT pcname) vars) + --m = ConT $ mkName "Identity" + ty = AppT (AppT (AppT (ConT $ mkName "Object") obj) st) (VarT m) + ost = TySynInstD (mkName "ObjSt") $ TySynEqn [obj] st + cl1 = Clause [VarP $ mkName "obj", ConP (mkName "MkMethod") [WildP, VarP $ mkName "e"]] (NormalB $ AppE (ConE $ mkName "MkExtCall") (AppE (VarE $ mkName "e") (VarE $ mkName "obj"))) [] + cl2 = Clause [VarP $ mkName "obj", ConP (mkName "MkField") [VarP $ mkName "eg", WildP, WildP, WildP]] (NormalB $ AppE (ConE $ mkName "MkExtCall") (AppE (VarE $ mkName "eg") (VarE $ mkName "obj"))) [] + eqn = FunD (mkName ".!") [cl1, cl2] + ds = [{- ost, -} eqn] + fams <- genObjectTypeInsts obj st + return $ InstanceD cxt ty ds : fams +genObjectInstance _ = return [] diff --git a/Language/MSH/CodeGen/PrimaryInstance.hs b/Language/MSH/CodeGen/PrimaryInstance.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/CodeGen/PrimaryInstance.hs @@ -0,0 +1,82 @@ +module Language.MSH.CodeGen.PrimaryInstance ( + genPrimaryInstance, + genIdentityInstance, + genParentalInstance +) where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import Language.MSH.StateEnv +import Language.MSH.StateDecl +import Language.MSH.CodeGen.Shared (renameParent) +import Language.MSH.CodeGen.SharedInstance +import Language.MSH.CodeGen.Interop (parseType) + +getBaseMonad :: Maybe String -> Type +getBaseMonad Nothing = ConT $ mkName "Identity" +getBaseMonad (Just p) = renameParent (\n -> n ++ "M") $ parseType p + +genPrimaryInstance :: StateEnv -> Dec -> [Dec] -> StateDecl -> Q Dec +genPrimaryInstance env cls decs decl@(StateDecl { + stateName = name, + stateParams = vars, + stateData = ds, + stateParentN = mp, + stateMethods = methods +}) = do + let + cxt = [] + cn = mkName $ name ++ "Like" + on = mkName name + sn = mkName $ name ++ "State" + bt = getBaseMonad mp + ty = foldl AppT (AppT (AppT (AppT (ConT cn) (ConT on)) (ConT sn)) bt) (map (VarT . mkName) vars) + fam = TySynInstD (mkName $ name ++ "St") $ TySynEqn [ConT on] (ConT sn) + invk <- genInvokeDef name + mods <- genFields decl PrimaryInst + ms <- genMethods PrimaryInst decl decl methods name + return $ InstanceD cxt ty ([fam,invk] ++ mods ++ ms) + +genIdentityInstance :: StateEnv -> Dec -> [Dec] -> StateDecl -> Q Dec +genIdentityInstance env cls decs decl@(StateDecl { + stateName = name, + stateParams = vars, + stateData = ds, + stateParentN = mp, + stateMethods = methods +}) = do + let + cxt = [] + cn = mkName $ name ++ "Like" + on = mkName name + sn = mkName $ name ++ "State" + bt = ConT $ mkName "Identity" + ty = foldl AppT (AppT (AppT (AppT (ConT cn) (ConT on)) (ConT sn)) bt) (map (VarT . mkName) vars) + fam = TySynInstD (mkName $ name ++ "St") $ TySynEqn [ConT on] (ConT sn) + invk <- genInvokeDef name + fs <- genFields decl IdentityInst + ms <- genMethods IdentityInst decl decl methods name + return $ InstanceD cxt ty ([fam,invk] ++ fs ++ ms) + +genParentalInstance :: StateDecl -> StateDecl -> Q [Dec] +genParentalInstance sub parent = do + let + cxt = [] + cn = mkName $ (stateName parent) ++ "Like" + on = mkName (stateName sub) + sn = mkName $ (stateName sub) ++ "State" + bt = getBaseMonad (stateParentN sub) + -- TODO: not sure if the parameters should be from the parent or inferred from the parent type? + ps = map (VarT . mkName) (stateParams parent) + ty = foldl AppT (ConT cn) ([ConT on, ConT sn, bt] ++ ps) + idty = foldl AppT (ConT cn) ([ConT on, ConT sn, ConT $ mkName "Identity"] ++ ps) + fs <- genFields parent SecondaryInst + ms <- genMethods SecondaryInst parent sub (stateMethods sub) (stateName parent) + ifs <- genFields parent IdentityInst + ims <- genMethods IdentityInst parent sub (stateMethods sub) (stateName parent) + rs <- case stateParent parent of + Nothing -> return [] + (Just p) -> genParentalInstance sub p + return $ [InstanceD cxt ty (fs ++ ms) + , InstanceD cxt idty (ifs ++ ims)] ++ rs diff --git a/Language/MSH/CodeGen/Shared.hs b/Language/MSH/CodeGen/Shared.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/CodeGen/Shared.hs @@ -0,0 +1,91 @@ +module Language.MSH.CodeGen.Shared where + +import qualified Data.Map as M + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import Language.MSH.StateDecl +import Language.MSH.CodeGen.Interop + +typeArgs :: Type -> [Type] +typeArgs (ForallT _ _ t) = typeArgs t +typeArgs (AppT (AppT ArrowT arg) a) = arg : typeArgs a +typeArgs _ = [] + +countTypeArgs :: Type -> Int +countTypeArgs (ForallT _ _ t) = countTypeArgs t +countTypeArgs (AppT (AppT ArrowT _) a) = 1 + countTypeArgs a +countTypeArgs _ = 0 + +renameT :: (String -> String) -> Type -> Type +renameT f (ConT (Name n _)) = ConT $ mkName $ f $ occString n + +conName :: Con -> Name +conName (NormalC n _) = n +conName (RecC n _) = n +conName (InfixC _ n _) = n +conName (ForallC _ _ c) = conName c + +appN :: Type -> [String] -> Type +appN t [] = t +appN t (a:as) = appN (AppT t (VarT $ mkName a)) as + +appN' :: Type -> [Type] -> Type +appN' t [] = t +appN' t (a:as) = appN' (AppT t a) as + +appEs :: Exp -> [Exp] -> Exp +appEs f [] = f +appEs f (a:as) = appEs (AppE f a) as + +infixr 5 `arr` +arr :: Type -> Type -> Type +arr f a = AppT (AppT ArrowT f) a + +tuple2 :: Type -> Type -> Type +tuple2 a b = AppT (AppT (TupleT 2) a) b + +tuple :: [Type] -> Type +tuple ts = appN' (TupleT $ length ts) ts + +renameParent :: (String -> String) -> Type -> Type +renameParent f (ConT (Name n _)) = ConT $ mkName $ f $ occString n +renameParent f (AppT (ConT (Name n _)) a) = AppT (ConT $ mkName $ f $ occString n) a + +parentName :: Type -> Name +parentName (ConT n) = n +parentName (AppT (ConT n) _) = n +parentName _ = error "parentName: Invalid parent type" + +parentArgs :: Type -> [Type] +parentArgs (ConT n) = [] +parentArgs (AppT p a) = parentArgs p ++ [a] + +getFields :: [StateMemberDecl] -> [(String, String)] +getFields [] = [] +getFields (StateDataDecl n me _ : ds) = case me of + (Just e) -> (n,e) : getFields ds + Nothing -> (n,"undefined") : getFields ds +getFields (_ : ds) = getFields ds + +getFieldTypes :: [StateMemberDecl] -> Q [(String,Type)] +getFieldTypes [] = return [] +getFieldTypes (StateDataDecl n _ t : ds) = do + ts <- getFieldTypes ds + return $ (n, parseType t) : ts + +-- | Applies a type `m' to the return type of a function. +wrapMethodType :: Bool -> (Type -> Type) -> Type -> Type +wrapMethodType False m (ForallT tvs cxt t) = wrapMethodType False m t +wrapMethodType True m (ForallT tvs cxt t) = ForallT tvs cxt $ wrapMethodType True m t +wrapMethodType k m (AppT (AppT ArrowT f) a) = AppT (AppT ArrowT f) (wrapMethodType k m a) +wrapMethodType _ m a = m a + +unwrapForalls :: Type -> Type -> Type +unwrapForalls (ForallT tvs cxt t) b = ForallT tvs cxt (unwrapForalls t b) +unwrapForalls _ b = b + +parameterise :: [Type] -> Type -> Type +parameterise [] t = t +parameterise (p:ps) t = AppT (AppT ArrowT p) (parameterise ps t) diff --git a/Language/MSH/CodeGen/SharedInstance.hs b/Language/MSH/CodeGen/SharedInstance.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/CodeGen/SharedInstance.hs @@ -0,0 +1,335 @@ +module Language.MSH.CodeGen.SharedInstance where + +import Debug.Trace + +import Control.Applicative ((<$>)) +import Control.Monad (replicateM) + +import Data.Char (toLower) +import qualified Data.Map as M +import Data.Maybe (catMaybes) + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import Language.MSH.StateDecl +import Language.MSH.StateEnv +import Language.MSH.CodeGen.Shared (countTypeArgs) +import Language.MSH.CodeGen.Inheritance + +-- | Enumerates different member generation modes. +data ImplMode = PrimaryInst | SecondaryInst | IdentityInst + deriving Show + +{-------------------------------------------------------------------------- + Control flow +--------------------------------------------------------------------------} + +genUndefined :: Exp +genUndefined = VarE $ mkName "undefined" + +-- | `lifted exp' wraps `exp' in a call to `lift'. +lifted :: Exp -> Exp +lifted = AppE (VarE $ mkName "lift") + +composed :: Exp -> Exp -> Exp +composed f g = AppE (AppE (VarE $ mkName ".") f) g + +-- | `genRunStateT f d' generates a call to `runStateT' where `f` is the +-- computation to be run and `d' is the initial state. +genRunStateT :: Exp -> Exp -> Exp +genRunStateT f d = AppE (AppE (VarE $ mkName "runStateT") f) d + +-- | `genInvoke pn obj exp st' generates a call to `_pn_invoke' for some +-- state class named `pn' where `obj' is the base delta-object, `exp' +-- is the expression to run and `st' is the state(of what?) +genInvoke :: String -> Exp -> Exp -> Exp -> Exp +genInvoke pn obj exp st = foldl AppE (VarE invk_name) [obj, exp, st] + where + invk_name = mkName $ "_" ++ pn ++ "_invoke" + +-- | Generates the implementation of the `_C_invoke' function. +-- The purpose of the `_C_invoke' functions is to allow a sub-class to +-- pass an arbitrary method to the super-class. It works as follows: +-- +genInvokeDef :: String -> Q Dec +genInvokeDef n = do + s <- newName "s" + f <- newName "f" + o <- newName "o" + r <- newName "r" + d' <- newName "d'" + s' <- newName "s'" + let + name = mkName $ "_" ++ n ++ "_invoke" + fn = mkName $ "_" ++ n ++ "_data" + ps = [VarP s, VarP f, VarP o] + runs = BindS (TupP [TupP [VarP r, VarP s'], VarP d']) (genRunStateT (AppE (VarE f) (VarE s)) (AppE (VarE $ mkName "extractData") (VarE o))) + rets = AppE (VarE $ mkName "return") (TupE [VarE r, RecUpdE (VarE o) [(fn,VarE d')], VarE s']) + body = NormalB $ DoE [runs, NoBindS rets] + return $ FunD name [Clause ps body []] + +genPrimaryClause :: StateDecl -> [Name] -> Exp -> (Exp -> Exp) -> StateObjCtr -> Q Clause +genPrimaryClause decl args call exp DataCtr = do + d <- newName "d" + r <- newName "r" + d' <- newName "d'" + let + ctr = mkName $ stateName decl ++ "Data" + pat = ConP ctr [VarP d] : map VarP args + bpat = TupP [VarP r, VarP d'] + ret = AppE (VarE $ mkName "return") (TupE [VarE r, AppE (ConE ctr) (VarE d')]) + body = DoE [BindS bpat (genRunStateT call (VarE d)), NoBindS ret] + return $ Clause pat (NormalB body) [] +genPrimaryClause decl args call exp StartCtr = do + d <- newName "d" + s <- newName "s" + r <- newName "r" + d' <- newName "d'" + s' <- newName "s'" + let + ctr = mkName $ stateName decl ++ "Start" + pat = ConP ctr [VarP d, VarP s] : map VarP args + bpat = TupP [TupP [VarP r, VarP s'], VarP d'] + ret = AppE (VarE $ mkName "return") (TupE [VarE r, AppE (AppE (ConE ctr) (VarE d')) (VarE s')]) + body = DoE [BindS bpat (genRunStateT (exp (VarE s)) (VarE d)), NoBindS ret] + return $ Clause pat (NormalB body) [] +genPrimaryClause decl args call exp MiddleCtr = do + p <- newName "p" + d <- newName "d" + s <- newName "s" + r <- newName "r" + d' <- newName "d'" + s' <- newName "s'" + let + ctr = mkName $ stateName decl ++ "Middle" + pat = ConP ctr [VarP p, VarP d, VarP s] : map VarP args + bpat = TupP [TupP [VarP r, VarP s'], VarP d'] + ret = AppE (VarE $ mkName "return") (TupE [VarE r, foldl AppE (ConE ctr) [VarE p, VarE d', VarE s']]) + body = DoE [BindS bpat (genRunStateT (exp (VarE s)) (VarE d)), NoBindS ret] + return $ Clause pat (NormalB body) [] +genPrimaryClause decl args call exp EndCtr = do + p <- newName "p" + d <- newName "d" + r <- newName "r" + d' <- newName "d'" + let + ctr = mkName $ stateName decl ++ "End" + pat = ConP ctr [VarP p, VarP d] : map VarP args + bpat = TupP [VarP r, VarP d'] + ret = AppE (VarE $ mkName "return") (TupE [VarE r, foldl AppE (ConE ctr) [VarE p, VarE d']]) + body = DoE [BindS bpat (genRunStateT call (VarE d)), NoBindS ret] + return $ Clause pat (NormalB body) [] + +genIdentityClause :: StateDecl -> [Name] -> Exp -> StateObjCtr -> Q (Maybe Clause) +genIdentityClause (decl@StateDecl { stateParentN = Just pn }) args call MiddleCtr = do + o <- newName "o" + p <- newName "p" + d <- newName "d" + s <- newName "s" + r <- newName "r" + p' <- newName "p'" + d' <- newName "d'" + s' <- newName "s'" + let + ctr = mkName $ stateName decl ++ "Middle" + pat = AsP o (ConP ctr [VarP p, VarP d, VarP s]) : map VarP args + opat = ConP ctr [WildP, VarP d', VarP s'] + bpat = TupP [VarP r, VarP p', opat] + ret = AppE (VarE $ mkName "return") (TupE [VarE r, foldl AppE (ConE ctr) [VarE p', VarE d', VarE s']]) + body = DoE [BindS bpat (genInvoke pn (VarE o) call (VarE p)), NoBindS ret] + return $ Just $ Clause pat (NormalB body) [] +genIdentityClause (decl@StateDecl { stateParentN = Just pn }) args call EndCtr = do + o <- newName "o" + p <- newName "p" + d <- newName "d" + r <- newName "r" + p' <- newName "p'" + d' <- newName "d'" + s' <- newName "s'" + let + ctr = mkName $ stateName decl ++ "End" + pat = AsP o (ConP ctr [VarP p, VarP d]) : map VarP args + opat = ConP ctr [WildP, VarP d'] + bpat = TupP [VarP r, VarP p', opat] + ret = AppE (VarE $ mkName "return") (TupE [VarE r, foldl AppE (ConE ctr) [VarE p', VarE d']]) + body = DoE [BindS bpat (genInvoke pn (VarE o) call (VarE p)), NoBindS ret] + return $ Just $ Clause pat (NormalB body) [] +genIdentityClause decl args call _ = return Nothing + +{-------------------------------------------------------------------------- + Fields +--------------------------------------------------------------------------} + +lensName :: String -> String +lensName (x:xs) = toLower x : xs + +genGetterBody :: Bool -> ImplMode -> String -> Name -> Exp +genGetterBody _ PrimaryInst lens self = AppE (VarE $ mkName "use") (VarE $ mkName lens) +genGetterBody _ SecondaryInst lens self = lifted (VarE self) +genGetterBody _ IdentityInst lens self = genUndefined + +genSetterBody :: Bool -> ImplMode -> String -> Name -> Exp +genSetterBody _ PrimaryInst lens self = AppE (VarE $ mkName "assign") (VarE $ mkName lens) +genSetterBody _ SecondaryInst lens self = (VarE $ mkName "lift") `composed` (VarE self) +genSetterBody _ IdentityInst lens self = genUndefined + +genIntGetter :: Bool -> ImplMode -> String -> Name -> Dec +genIntGetter isBase mode lens name = + FunD name [Clause [] (NormalB $ genGetterBody isBase mode lens name) []] + +genIntSetter :: Bool -> ImplMode -> String -> Name -> Dec +genIntSetter isBase mode lens name = + FunD name [Clause [] (NormalB $ genSetterBody isBase mode lens name) []] + +genGetterClauses :: ImplMode -> StateDecl -> String -> Q [Clause] +genGetterClauses PrimaryInst decl name = mapM (genPrimaryClause decl [] call exp) (ctrsForClass decl) + where + call = VarE $ mkName $ name ++ "'" + exp = AppE (VarE $ mkName $ name) +genGetterClauses IdentityInst decl name = catMaybes <$> mapM (genIdentityClause decl [] call) (ctrsForClass decl) + where + call = VarE $ mkName $ name + +genSetterClauses :: ImplMode -> StateDecl -> String -> Name -> Q [Clause] +genSetterClauses PrimaryInst decl name var = mapM (genPrimaryClause decl [var] call exp) (ctrsForClass decl) + where + call = AppE (VarE $ mkName $ name ++ "'") (VarE var) + exp = \s -> AppE (AppE (VarE $ mkName name) s) (VarE var) +genSetterClauses IdentityInst decl name var = do + obj <- newName "obj" + let + call = LamE [VarP obj] $ foldl AppE (VarE $ mkName $ name) [VarE obj, VarE var] + catMaybes <$> mapM (genIdentityClause decl [var] call) (ctrsForClass decl) + +-- | `genModDefs mode name fname' generates the getter, the setter, and the +-- field selector for a field named `fname' in a state class named `name' +-- using routing mode `mode'. +genField :: StateDecl -> ImplMode -> String -> String -> Q [Dec] +genField dec mode name fname = do + let + bname = "_" ++ fname -- the base name of the field + gname = "_get" ++ bname -- the name of the getter + sname = "_set" ++ bname -- the name of the setter + lname = lensName name ++ "_" ++ fname -- the name of the lens for this field + --gdcl <- genDataClause mode name [] (VarE $ mkName $ gname ++ "'") + --gscl <- genStartClause mode name [] (AppE (VarE $ mkName gname)) + gcls <- genGetterClauses mode dec gname + let + --gcls = [gdcl,gscl] + ext_g = mkName gname + int_g = mkName $ gname ++ "'" + getter = FunD ext_g gcls + getter' = genIntGetter (isBaseClass dec) mode lname int_g + v <- newName "v" + --sdcl <- genDataClause mode name [v] (AppE (VarE $ mkName $ sname ++ "'") (VarE v)) + --sscl <- genStartClause mode name [v] (\s -> AppE (AppE (VarE $ mkName sname) s) (VarE v)) + scls <- genSetterClauses mode dec sname v + let + --scls = [sdcl,sscl] + ext_s = mkName sname + int_s = mkName $ sname ++ "'" + setter = FunD ext_s scls + setter' = genIntSetter (isBaseClass dec) mode lname int_s + field = FunD (mkName fname) [Clause [] (NormalB $ foldl AppE (ConE $ mkName "MkField") [VarE $ mkName gname, VarE $ mkName $ gname ++ "'", VarE $ mkName sname, VarE $ mkName $ sname ++ "'" ]) []] + return [getter,getter',setter,setter',field] + +-- | `genModsDefs mode name ds' generates getters, setters, and field selectors +-- for the fields in `ds' which are part of a state class named `name'. `mode' +-- determines how these calls will be routed. +genFields :: StateDecl -> ImplMode -> Q [Dec] +genFields dec mode = + concat <$> mapM (genField dec mode (stateName dec)) (map stateDataName (stateData dec)) + +{-------------------------------------------------------------------------- + Methods +--------------------------------------------------------------------------} + +findClassMethodType :: [Dec] -> String -> Type +findClassMethodType [] m = error $ "Method not defined: " ++ m +findClassMethodType (SigD n t : ds) m + | nameBase n == m = t + | otherwise = findClassMethodType ds m +findClassMethodType (_ : ds) m = findClassMethodType ds m + +numArgsForMethod :: Dec -> String -> Int +numArgsForMethod (ClassD _ _ _ _ ds) n = + countTypeArgs $ findClassMethodType ds n + +genSelectorWrapper :: [Name] -> Exp -> Exp +genSelectorWrapper [] exp = exp +genSelectorWrapper ns exp = LamE (map VarP ns) exp + +genInternalWrapper :: Name -> [Name] -> Exp +genInternalWrapper iname [] = VarE iname --AppE (VarE $ mkName "const") (VarE iname) +genInternalWrapper iname vs = foldl AppE (VarE iname) (map VarE vs) -- LamE [TupP $ map VarP vs] (AppE (VarE iname) (TupE $ map VarE vs)) + +genExternalWrapper :: Name -> [Name] -> Exp +genExternalWrapper ename [] = LamE [VarP obj] $ AppE (VarE ename) (VarE obj) + where + obj = mkName "obj" +genExternalWrapper ename vs = LamE [VarP obj] $ foldl AppE (AppE (VarE ename) (VarE obj)) (map VarE vs) + where + obj = mkName "obj" + +genMethodClauses :: ImplMode -> StateDecl -> StateDecl -> Name -> Name -> [Name] -> Q [Clause] +genMethodClauses PrimaryInst decl instanceOf iname ename vs = mapM (genPrimaryClause instanceOf vs call exp) (ctrsForClass instanceOf) + where + call = foldl AppE (VarE iname) (map VarE vs) + exp = \s -> foldl AppE (AppE (VarE ename) s) (map VarE vs) +genMethodClauses IdentityInst decl instanceOf iname ename vs = do + obj <- newName "obj" + let + call = LamE [VarP obj] $ foldl AppE (VarE ename) (VarE obj : map VarE vs) + catMaybes <$> mapM (genIdentityClause instanceOf vs call) (ctrsForClass instanceOf) + +genMethodClauses SecondaryInst decl instanceOf iname ename vs = mapM (genPrimaryClause instanceOf vs call exp) (ctrsForClass instanceOf) + where + call = foldl AppE (VarE iname) (map VarE vs) + exp = \s -> foldl AppE (AppE (VarE ename) s) (map VarE vs) + +genMethod' :: ImplMode -> StateDecl -> StateDecl -> MethodTable -> String -> String -> Type -> Q [Dec] +genMethod' mode decl instanceOf tbl cn name typ = do + -- if this method was declared by a parent, it belongs to + -- a different type, so we don't implement it here + if declByParent (mkName name) decl then return [] + else do + let + argc = countTypeArgs typ -- numArgsForMethod cls ("_icall_" ++ name) + -- external call name + ename = mkName $ "_ecall_" ++ name + -- internal call name + iname = mkName $ "_icall_" ++ name + vs <- replicateM argc (newName "v") + eclauses <- genMethodClauses mode decl instanceOf iname ename vs + let + -- external + external = FunD ename eclauses + -- internal + mname = mkName $ "_" ++ (stateName instanceOf) ++ "_" ++ name + iclauses = if isAbstract (mkName name) instanceOf + then [Clause [] (NormalB (AppE (VarE $ mkName "error") (VarE $ mkName "_msh_rt_invalid_call_abstract"))) []] + else if isImplemented (mkName name) tbl + then [Clause [] (NormalB (VarE mname)) []] + else [Clause [] (NormalB (lifted $ VarE iname)) []] + internal = FunD iname iclauses + -- method + iwrapper = genInternalWrapper iname vs + ewrapper = genExternalWrapper ename vs + swrapper = genSelectorWrapper vs (foldl AppE (ConE $ mkName "MkMethod") [iwrapper, ewrapper]) + mclauses = [Clause [] (NormalB swrapper) []] + method = FunD (mkName $ name) mclauses + trace (show ename ++ show mode) $ return [external, internal, method] + +-- | `genMethod env cls mp cn d' generates a method for based on `d'. +genMethod :: ImplMode -> StateDecl -> StateDecl -> MethodTable -> String -> (String, Dec) -> Q [Dec] +genMethod mode decl instanceOf tbl cn (name, SigD _ ty) = + genMethod' mode decl instanceOf tbl cn name ty +--genMethodDef env tbl cls mp cn (FunD name _) = genMethodDef' env cls mp cn (nameBase name) +--genMethodDef env tbl cls mp cn (ValD (VarP name) _ _) = genMethodDef' env cls mp cn (nameBase name) +genMethod _ _ _ _ _ _ = return [] + +genMethods :: ImplMode -> StateDecl -> StateDecl -> MethodTable -> String -> Q [Dec] +genMethods mode decl instanceOf tbl cn = + concat <$> mapM (genMethod mode decl instanceOf tbl cn) (M.toList $ methodSigs tbl) + diff --git a/Language/MSH/Constructor.hs b/Language/MSH/Constructor.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/Constructor.hs @@ -0,0 +1,9 @@ +module Language.MSH.Constructor where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +data StateCtr = SCtr { + sctrDec :: Dec, + sctrTypes :: [Type] +} diff --git a/Language/MSH/MethodTable.hs b/Language/MSH/MethodTable.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/MethodTable.hs @@ -0,0 +1,43 @@ +module Language.MSH.MethodTable where + +import qualified Data.Map as M + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +{- + Methods +-} + +data MethodTable = MkMethodTable { + methodSigs :: M.Map String Dec, + methodDefs :: M.Map String Dec +} deriving Show + +emptyMethodTable :: MethodTable +emptyMethodTable = MkMethodTable M.empty M.empty + +addMethodSig :: Name -> Dec -> MethodTable -> MethodTable +addMethodSig name dec tbl = tbl { + methodSigs = M.insert (nameBase name) dec (methodSigs tbl) } + +addMethodDef :: Name -> Dec -> MethodTable -> MethodTable +addMethodDef name dec tbl = tbl { + methodDefs = M.insert (nameBase name) dec (methodDefs tbl) } + + + +isImplemented :: Name -> MethodTable -> Bool +isImplemented n tbl = M.member (nameBase n) (methodDefs tbl) + +-- | `preProcessMethods ds' builds a value of type `MethodTable' from a list +-- of top-level declarations. +preProcessMethods :: [Dec] -> MethodTable +preProcessMethods ds = go emptyMethodTable ds + where + go tbl [] = tbl + go tbl (d@(SigD name ty) : ds) = go (addMethodSig name d tbl) ds + go tbl (d@(FunD name cs) : ds) = go (addMethodDef name d tbl) ds + go tbl (d@(ValD (VarP name) body wh) : ds) = go (addMethodDef name d tbl) ds + go tbl (d : ds) = go tbl ds + diff --git a/Language/MSH/NewExpr.hs b/Language/MSH/NewExpr.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/NewExpr.hs @@ -0,0 +1,6 @@ +module Language.MSH.NewExpr where + +data NewExpr = NewExpr { + newClassName :: String, + newArgs :: String +} diff --git a/Language/MSH/Parsers.hs b/Language/MSH/Parsers.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/Parsers.hs @@ -0,0 +1,160 @@ +module Language.MSH.Parsers ( + parseStateDecl, + parseNewExpr +) where + +import Language.Haskell.TH + +import Text.Parsec.Char +import Text.ParserCombinators.Parsec + +import Control.Monad (void) + +import Data.Char (isSpace) +import Data.Text (pack, unpack, strip) +import qualified Data.Map as M + +import Language.MSH.StateDecl +import Language.MSH.NewExpr +import Language.MSH.CodeGen.Interop (parseDecs) + +trim :: String -> String +trim = unpack . strip . pack + +isSpaceNoNL :: GenParser Char a Char +isSpaceNoNL = satisfy (\c -> isSpace c && c /= '\n' && c /= '\r') + +-- | Parses state declarations +parseStateDecl :: String -> Q (M.Map String StateDecl) +parseStateDecl code = case parse stateDecls "" code of + (Left err) -> fail $ show err + (Right r) -> return r + +parseNewExpr :: String -> Q NewExpr +parseNewExpr code = case parse newExpr "" code of + (Left err) -> fail $ show err + (Right r) -> return r + +-- | Parses a variable identifier (starting with a lower-case character) +varid :: GenParser Char a String +varid = do + c <- lower + cs <- many (alphaNum <|> char '\'') + return (c:cs) + +-- | Parses a type/constructor identifier (starting with an upper-case character) +ctrid :: GenParser Char a String +ctrid = do + c <- upper + cs <- many (alphaNum <|> char '\'') + return (c:cs) + +tyVar :: GenParser Char a String +tyVar = do + v <- varid + if v == "where" then fail "is keyword" + else do + spaces + return v + +abstract :: GenParser Char a (Maybe StateMod) +abstract = string "abstract" >> return (Just Abstract) + +final :: GenParser Char a (Maybe StateMod) +final = string "final" >> return (Just Final) + +classModifier :: GenParser Char a (Maybe StateMod) +classModifier = abstract <|> final <|> return Nothing + +parentClass :: GenParser Char a (Maybe String) +parentClass = (char ':' >> manyTill anyChar (try $ string "where") >>= \r -> return $ Just (trim r)) <|> + (string "where" >> return Nothing) + +dataInit :: GenParser Char a String +dataInit = do + string "=" + spaces + r <- manyTill anyChar (try $ string "::") -- TODO: improve this, so that it takes the last :: + return r + +dataDecl :: GenParser Char a StateMemberDecl +dataDecl = do + string "data" + spaces + id <- varid + spaces + val <- optionMaybe dataInit + case val of + Nothing -> string "::" + otherwise -> return "" + spaces + ty <- manyTill anyChar (try $ (void newline) <|> eof) + return $ StateDataDecl { + stateDataName = id, + stateDataExpr = val, + stateDataType = ty + } + +valueLine :: GenParser Char a String +valueLine = do + ws <- many1 isSpaceNoNL + rs <- manyTill anyChar $ try (void endOfLine <|> eof) + return (ws ++ rs ++ "\r\n") + +emptyLine :: GenParser Char a String +emptyLine = do + many isSpaceNoNL + void endOfLine {-<|> eof-} + return "\n" + +valueDecl :: GenParser Char a String +valueDecl = do + ls <- many (valueLine <|> emptyLine) + --error $ concat ls + return $ concat ls + +stateMember :: GenParser Char a StateMemberDecl +stateMember = do + spaces + dataDecl + +stateDecl :: GenParser Char a StateDecl +stateDecl = do + spaces + mod <- classModifier + spaces + string "state" + spaces + id <- ctrid + spaces + tyvars <- many (try tyVar) + p <- parentClass + many isSpaceNoNL + many newline + ms <- many $ try stateMember + vm <- valueDecl + let + body = parseDecs vm + return $ StateDecl { + stateMod = mod, + stateName = trim id, + stateParams = tyvars, + stateParentN = p, + stateParent = Nothing, + stateData = ms, + stateBody = body, + stateMethods = preProcessMethods body + } + +stateDecls :: GenParser Char a (M.Map String StateDecl) +stateDecls = do + ds <- many stateDecl + return $ M.fromList [(stateName d ,d) | d <- ds] + +newExpr :: GenParser Char a NewExpr +newExpr = do + spaces + id <- ctrid + spaces + args <- many anyChar + return $ NewExpr id args diff --git a/Language/MSH/QuasiQuoters.hs b/Language/MSH/QuasiQuoters.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/QuasiQuoters.hs @@ -0,0 +1,32 @@ +module Language.MSH.QuasiQuoters where + +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +import Language.MSH.Parsers +import Language.MSH.CodeGen + +state = QuasiQuoter { + quoteExp = undefined, + quotePat = undefined, + quoteType = undefined, + quoteDec = stateParser +} + +stateParser :: String -> Q [Dec] +stateParser code = do + r <- parseStateDecl code + genStateDecls r + +{-new = QuasiQuoter { + quoteExp = newParser, + quotePat = undefined, + quoteType = undefined, + quoteDec = undefined +} + +newParser :: String -> Q Exp +newParser code = do + r <- parseNewExpr code + genNewExp r-} + diff --git a/Language/MSH/RuntimeError.hs b/Language/MSH/RuntimeError.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/RuntimeError.hs @@ -0,0 +1,7 @@ +module Language.MSH.RuntimeError where + +_msh_rt_invalid_call_abstract :: String +_msh_rt_invalid_call_abstract = "Invalid call: the method is abstract." + +_msh_rt_invalid_call_state :: String +_msh_rt_invalid_call_state = "Invalid call: not supported by this object state" diff --git a/Language/MSH/Selectors.hs b/Language/MSH/Selectors.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/Selectors.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses, KindSignatures #-} +{-# LANGUAGE Rank2Types, FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds, FlexibleContexts #-} + +module Language.MSH.Selectors where + +import Control.Applicative ((<$>)) +import Control.Monad.Identity +import Control.Monad.State + +-- | Enumerates call types. +data CallType = ExtCall -- ^ The call is to a method, externally. + +-- | Represents a query which can be run by combinators such as `result', `object', etc. +data RunnableQuery (ty :: CallType) obj st ctx r where + MkExtCall :: ctx (r, obj) -> RunnableQuery ExtCall obj st ctx r + +-- | Represents a context in which combinators may be used. +class Functor ctx => CallCtx (ty :: CallType) ctx where + type CtxResult ty ctx r :: * + + result :: RunnableQuery ty obj st ctx r -> CtxResult ty ctx r + object :: RunnableQuery ty obj st ctx r -> CtxResult ty ctx obj + --(<:) :: RunnableQuery ty obj ctx r -> r -> ctx () + +{-instance Functor ctx => CallCtx ThisCall ctx where + type CtxResult ThisCall ctx r = () + + getResult _ = () + getObject _ = ()-} + +instance (ctx ~ Identity) => CallCtx ExtCall ctx where + type CtxResult ExtCall ctx r = r + + result (MkExtCall call) = fst $ runIdentity call + object (MkExtCall call) = snd $ runIdentity call + --(<:) (MkExtCall call) v = undefined + +data MemberType = Mutable | Immutable +data FieldType = Method | Field + +type family FieldComposeResult (lhs :: FieldType) (rhs :: FieldType) :: FieldType where + FieldComposeResult Method Method = Method + FieldComposeResult Method Field = Method + FieldComposeResult Field Method = Method + FieldComposeResult Field Field = Field + +data Selector (ty :: FieldType) o s m a where + MkMethod :: StateT s m a -> + (o -> m (a, o)) -> + Selector Method o s m a + MkField :: (o -> m (a, o)) -> + StateT s m a -> + (o -> a -> m ((), o)) -> + (a -> StateT s m ()) -> + Selector Field o s m a + +data This o s (m :: * -> *) a where + MkThis :: This o s m a + +type family QueryObject obj :: * +type family QueryMonad obj (m :: * -> *) :: * -> * +type family QueryResult obj (ty :: FieldType) st (m :: * -> *) r :: * + +infixr 8 .! +class Monad m => Object obj st m where + this :: This obj st m obj + this = MkThis + + (.!) :: forall r ty.obj -> + Selector ty (QueryObject obj) st (QueryMonad obj m) r -> + QueryResult obj ty st m r + +-- | If `s' returns a value whose type is a `Functor', then `s.$m' calls `m' on the +-- inner value of `s' via `fmap'. +(.$) :: (Monad ctx, Functor f) => Selector lty obj st ctx (f a) -> Selector rty a st' Identity b -> Selector (FieldComposeResult lty rty) obj st ctx (f b) +(MkField eg ig es is) .$ (MkMethod ri re) = MkMethod + (ig >>= \x -> let p = fmap (runIdentity . re) x in is (fmap snd p) >> return (fmap fst p)) + (\s -> eg s >>= \(x,s') -> let p = fmap (runIdentity . re) x in es s' (fmap snd p) >>= \(_,s'') -> return (fmap fst p, s'')) +(MkField eg ig es is) .$ (MkField reg rig res ris) = MkField + undefined + undefined + undefined + undefined +(MkMethod li le) .$ (MkMethod ri re) = MkMethod + undefined + undefined +(MkMethod li le) .$ (MkField reg rig res ris) = MkMethod + undefined + undefined + +{- +type instance QueryMonad (RunnableQuery ThisCall obj st ctx r) ctx' = ctx +type instance QueryObject (RunnableQuery ThisCall obj st ctx r) = obj + +type instance QueryMonad (RunnableQuery Call obj st ctx r) ctx' = Identity +type instance QueryMonad (RunnableQuery IntCall obj st ctx r) ctx' = Identity +type instance QueryMonad (RunnableQuery ExtCall obj st ctx r) ctx' = Identity + +type instance QueryObject (RunnableQuery Call obj st ctx r) = r +type instance QueryObject (RunnableQuery IntCall obj st ctx r) = r +type instance QueryObject (RunnableQuery ExtCall obj st ctx r) = r + +type instance QueryResult (RunnableQuery ty obj st ctx r) st' m x = + RunnableQuery ty obj st m x + +instance (Object obj cake ctx, cake ~ cake) => + Object (RunnableQuery ThisCall obj cake ctx obj) cake ctx where + + type ObjSt (RunnableQuery ThisCall obj cake ctx obj) = cake + + (.!) _ _ = undefined + +instance (Object obj st ctx, Object r st' Identity, ctx ~ ctx') => + Object (RunnableQuery Call obj st ctx r) st' Identity where + + type ObjSt (RunnableQuery Call obj st ctx r) = st + + (.!) (MkCall li le) (MkMethod ri re) = MkCall undefined undefined + (.!) (MkCall li le) (MkField ge gi se si) = MkCall undefined undefined + +instance (Object obj st ctx, Object r st' Identity, ctx ~ ctx') => + Object (RunnableQuery IntCall obj st ctx r) st' ctx' where + + type ObjSt (RunnableQuery IntCall obj st ctx r) = st + + -- NOTE: This discards the state of the sub-call, which can easily be worked around + -- by splitting up the query, but maybe we should provide an alternative + (.!) (MkIntCall li) (MkMethod _ re) = MkIntCall (li >>= \r -> return $ fst $ runIdentity $ re r) + --(.!) (MkIntCall li) (MkField ge _ _ _) = MkIntCall (li >>= \r -> ) + +instance (Object obj st ctx, Object r st' Identity, ctx ~ ctx') => + Object (RunnableQuery ExtCall obj st ctx r) st' ctx' where + + type ObjSt (RunnableQuery ExtCall obj st ctx r) = st + + (.!) (MkExtCall le) (MkMethod _ re) = MkExtCall undefined +-} + +-- For fields: +-- * run the internal call (if the selector on the RHS is a method) +-- * run the internal getter (if the selector on the RHS is a field) +type instance QueryMonad (Selector Method obj st ctx r) ctx' = ctx' +type instance QueryObject (Selector Method obj st ctx r) = r +type instance QueryResult (Selector Method obj st ctx r) ty st' m x = + Selector Method obj st ctx x +instance (Object obj st ctx, Object r st' Identity, m ~ Identity) => + Object (Selector Method obj st ctx r) st' m where + + (.!) (MkMethod li le) (MkMethod ri re) = MkMethod + (li >>= \r -> return $ fst $ runIdentity $ re r) + (\s -> le s >>= \(r, obj) -> return (fst $ runIdentity $ re r, obj)) + + (.!) (MkMethod li le) (MkField eg ig es is) = MkMethod + (li >>= \r -> return $ fst $ runIdentity $ eg r) + (\s -> le s >>= \(r, obj) -> return (fst $ runIdentity $ eg r, obj)) + +-- For fields: +-- * run the internal call (if the selector on the RHS is a method) +-- * run the internal getter (if the selector on the RHS is a field) +type instance QueryMonad (Selector Field obj st ctx r) ctx' = ctx' +type instance QueryObject (Selector Field obj st ctx r) = r +type instance QueryResult (Selector Field obj st ctx r) Method st' m x = + Selector Method obj st ctx x +type instance QueryResult (Selector Field obj st ctx r) Field st' m x = + Selector Field obj st ctx x +instance (Object obj st ctx, Object r st' Identity, m ~ Identity) => + Object (Selector Field obj st ctx r) st' m where + + -- get the value of the field on the LHS, run the RHS method on it, then + -- set the value of the field to the object returned by the RHS method + (.!) (MkField eg ig es is) (MkMethod ri re) = MkMethod + (ig >>= \r -> let (r',s) = runIdentity (re r) in is s >> return r') + (\s -> eg s >>= \(r',s') -> let (r'',s'') = runIdentity (re r') in es s' s'' >>= \(_,s''') -> return (r'',s''')) + + {-(.!) (MkField eg ig es is) (MkField reg rig res ris) = MkField + undefined + undefined + undefined + undefined-} + +-- For `this': +-- * run the internal call (if the selector on the RHS is a method) +-- * run the internal getter (if the selector on the RHS is a field) +type instance QueryMonad (This obj st ctx r) ctx' = ctx' +type instance QueryObject (This obj st ctx r) = obj +type instance QueryResult (This obj st ctx r) ty st' m x = StateT st' ctx x +instance (Object obj st ctx, Object r st' ctx', ctx ~ ctx', st ~ st') => + Object (This obj st ctx r) st' ctx' where + + (.!) _ (MkMethod ri re) = ri + (.!) _ (MkField ge gi se si) = gi diff --git a/Language/MSH/StateDecl.hs b/Language/MSH/StateDecl.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/StateDecl.hs @@ -0,0 +1,66 @@ +module Language.MSH.StateDecl ( + module Language.MSH.MethodTable, + + StateMod(..), + StateObjCtr(..), + StateMemberDecl(..), + StateDecl(..), + + isBaseClass, + isAbstractClass, + isFinalClass, + ctrsForClass +) where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import Language.MSH.MethodTable + +data StateMod = Abstract | Final deriving Show +data StateObjCtr = DataCtr | StartCtr | MiddleCtr | EndCtr deriving Show + +data StateMemberDecl = StateDataDecl { + stateDataName :: String, + stateDataExpr :: Maybe String, + stateDataType :: String +} deriving Show + +data StateDecl = StateDecl { + stateMod :: Maybe StateMod, + stateName :: String, + stateParams :: [String], + stateParentN :: Maybe String, + stateParent :: Maybe StateDecl, + stateData :: [StateMemberDecl], + stateBody :: [Dec], + stateMethods :: MethodTable +} deriving Show + +isBaseClass :: StateDecl -> Bool +isBaseClass (StateDecl { stateParentN = Nothing } ) = True +isBaseClass _ = False + +isAbstractClass :: StateDecl -> Bool +isAbstractClass (StateDecl { stateMod = Just Abstract }) = True +isAbstractClass _ = False + +isFinalClass :: StateDecl -> Bool +isFinalClass (StateDecl { stateMod = Just Final }) = True +isFinalClass _ = False + +--isOverriden :: String -> StateDecl -> Bool +--isOverriden name (StateDecl { stateMethods = ms }) = + +-- | `ctrsForClass dec' returns a list of object states for the state class +-- described by `dec' +ctrsForClass :: StateDecl -> [StateObjCtr] +ctrsForClass (StateDecl { stateParentN = p, stateMod = m }) = case p of + Nothing -> case m of + Nothing -> [DataCtr, StartCtr] + (Just Abstract) -> [StartCtr] + (Just Final) -> [DataCtr] + (Just _) -> case m of + Nothing -> [DataCtr, StartCtr, MiddleCtr, EndCtr] + (Just Abstract) -> [StartCtr, MiddleCtr] + (Just Final) -> [DataCtr, EndCtr] diff --git a/Language/MSH/StateEnv.hs b/Language/MSH/StateEnv.hs new file mode 100644 --- /dev/null +++ b/Language/MSH/StateEnv.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Language.MSH.StateEnv where + +import Control.Monad.Except + +import Data.Graph +import Data.List (intersperse) +import qualified Data.Map as M + +import Language.MSH.StateDecl + +data StateGraphError = ClassNotFound String + | CyclicInheritance [String] + +instance Show StateGraphError where + show (ClassNotFound cls) = "`" ++ cls ++ "' is not in scope." + show (CyclicInheritance cs) = "The following state classes form a cyclic inheritance hierarchy: " ++ concat (intersperse ", " cs) + +type StateEnv = M.Map String StateDecl + +-- | `buildStateGraph env' resolves types. +buildStateGraph :: StateEnv -> Except StateGraphError StateEnv +buildStateGraph = go M.empty . stronglyConnCompR . toGraph + where + go env [] = return env + go env (CyclicSCC cs : ds) = throwError $ CyclicInheritance [c | (_,c,_) <- cs] + go env (AcyclicSCC (dec,n,[]) : ds) = go (M.insert n dec env) ds + go env (AcyclicSCC (dec,n,[p]) : ds) = case M.lookup p env of + Nothing -> throwError (ClassNotFound p) + (Just pd) -> go (M.insert n (dec { stateParent = Just pd }) env) ds + +-- | `toGraph env' turns `env' into a suitable graph for the SCC algorithm. +toGraph :: StateEnv -> [(StateDecl, String, [String])] +toGraph = map (\(k,v) -> (v, k, dep v)) . M.toList + where + -- a state class either has zero dependencies if it is a base class, + -- or exactly one dependency if it inherits from another class + dep (StateDecl { stateParentN = Nothing }) = [] + dep (StateDecl { stateParentN = (Just p) }) = [p] + + diff --git a/msh.cabal b/msh.cabal --- a/msh.cabal +++ b/msh.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.0.1 +version: 0.1.0.2 -- A short (one-line) description of the package. synopsis: Object-Oriented Programming in Haskell @@ -57,7 +57,35 @@ exposed-modules: Language.MSH -- Modules included in this library but not exported. - -- other-modules: + other-modules: + Language.MSH.BuiltIn + Language.MSH.CodeGen + Language.MSH.Constructor + Language.MSH.MethodTable + Language.MSH.NewExpr + Language.MSH.Parsers + Language.MSH.QuasiQuoters + Language.MSH.RuntimeError + Language.MSH.Selectors + Language.MSH.StateDecl + Language.MSH.StateEnv + Language.MSH.CodeGen.Class + Language.MSH.CodeGen.Constructors + Language.MSH.CodeGen.Data + Language.MSH.CodeGen.Decls + Language.MSH.CodeGen.Inheritance + Language.MSH.CodeGen.Instances + Language.MSH.CodeGen.Interop + Language.MSH.CodeGen.Methods + Language.MSH.CodeGen.MiscInstances + Language.MSH.CodeGen.Monad + Language.MSH.CodeGen.New + Language.MSH.CodeGen.NewInstance + Language.MSH.CodeGen.Object + Language.MSH.CodeGen.ObjectInstance + Language.MSH.CodeGen.PrimaryInstance + Language.MSH.CodeGen.Shared + Language.MSH.CodeGen.SharedInstance -- LANGUAGE extensions used by modules in this package. other-extensions: TemplateHaskell, QuasiQuotes @@ -75,7 +103,7 @@ text -- Directories containing source files. - hs-source-dirs: + hs-source-dirs: -- Base language which the package is written in. default-language: Haskell2010