packages feed

msh 0.1.0.1 → 0.1.0.2

raw patch · 29 files changed

+2373/−3 lines, 29 files

Files

+ Language/MSH/BuiltIn.hs view
@@ -0,0 +1,10 @@+module Language.MSH.BuiltIn where++newClassName :: String +newClassName = "New"++newArgsTypeName :: String+newArgsTypeName = "Args"++newKwdName :: String +newKwdName = "new"
+ Language/MSH/CodeGen.hs view
@@ -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
+ Language/MSH/CodeGen/Class.hs view
@@ -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)
+ Language/MSH/CodeGen/Constructors.hs view
@@ -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
+ Language/MSH/CodeGen/Data.hs view
@@ -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] []
+ Language/MSH/CodeGen/Decls.hs view
@@ -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+++++
+ Language/MSH/CodeGen/Inheritance.hs view
@@ -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
+ Language/MSH/CodeGen/Instances.hs view
@@ -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
+ Language/MSH/CodeGen/Interop.hs view
@@ -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
+ Language/MSH/CodeGen/Methods.hs view
@@ -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+
+ Language/MSH/CodeGen/MiscInstances.hs view
@@ -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
+ Language/MSH/CodeGen/Monad.hs view
@@ -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))
+ Language/MSH/CodeGen/New.hs view
@@ -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)
+ Language/MSH/CodeGen/NewInstance.hs view
@@ -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]
+ Language/MSH/CodeGen/Object.hs view
@@ -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 []
+ Language/MSH/CodeGen/ObjectInstance.hs view
@@ -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 []
+ Language/MSH/CodeGen/PrimaryInstance.hs view
@@ -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
+ Language/MSH/CodeGen/Shared.hs view
@@ -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)
+ Language/MSH/CodeGen/SharedInstance.hs view
@@ -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)+
+ Language/MSH/Constructor.hs view
@@ -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]+}
+ Language/MSH/MethodTable.hs view
@@ -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+
+ Language/MSH/NewExpr.hs view
@@ -0,0 +1,6 @@+module Language.MSH.NewExpr where++data NewExpr = NewExpr {+    newClassName :: String,+    newArgs      :: String+}
+ Language/MSH/Parsers.hs view
@@ -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
+ Language/MSH/QuasiQuoters.hs view
@@ -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-}+
+ Language/MSH/RuntimeError.hs view
@@ -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"
+ Language/MSH/Selectors.hs view
@@ -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
+ Language/MSH/StateDecl.hs view
@@ -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]
+ Language/MSH/StateEnv.hs view
@@ -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]++
msh.cabal view
@@ -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