packages feed

hoop (empty) → 0.3.0.0

raw patch · 40 files changed

+3597/−0 lines, 40 filesdep +basedep +containersdep +haskell-src-exts

Dependencies added: base, containers, haskell-src-exts, haskell-src-meta, hoop, hspec, lens, mtl, parsec, pretty, template-haskell, text

Files

+ LICENSE view
@@ -0,0 +1,22 @@+The MIT License (MIT)++Copyright (c) 2015 Michael Gale++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.+
+ README.md view
@@ -0,0 +1,72 @@+# hoop++A Haskell library for object-oriented programming which allows programmers to use objects in ordinary Haskell programs. In particular, the library achieves the following design objectives (to avoid ambiguity with Haskell's type classes, we refer to classes in the object-oriented sense as _object classes_):++- No extensions to the Haskell language are required beyond what is already implemented in GHC. Object classes are generated from Template Haskell quasi quotations using an OO-like syntax where the methods are defined as ordinary Haskell expressions. +- Object classes can be instantiated from ordinary Haskell code (with an overloaded function named `new`). The resulting objects are ordinary Haskell values and can be used as such.+- Calling methods on objects can be done from within ordinary Haskell code. +- The objects do not rely on IO. Instantiating objects and calling methods on the resulting objects is pure. +- Object classes can inherit from other object classes, which also established subtyping relations between them. There is no limit to how deep these inheritance trees may grow.+- Class hierarchies are open for extension. I.e. the library does not need to know about all subclasses of a given class in order to generate the code for that class, allowing modular compilation.+- Casting from subtype objects to their supertypes is supported and the types are correctly reflected in Haskell's type system (e.g. assuming that we have `Duck <: Bird` and that `obj :: Duck` then `upcast obj :: Bird`) and pure.+- Type annotations are generally not required except where something would logically be ambiguous otherwise (e.g. instantiating an object with the `new` function).++## Examples++The [test](https://github.com/mbg/hoop/tree/master/test) folder contains a number of examples of the library in action, illustrating the various features. ++As a quick tutorial, a simple expression language can be implemented using the library as shown below. Note that the bodies of the two implementations of the `eval` method are ordinary Haskell expressions. The `.!` operator is an ordinary Haskell operator used to call methods on objects and `this` is just an ordinary Haskell definition, too.++```haskell+[state|+abstract state Expr where+    eval :: Int++state Val : Expr where+    data val = 0 :: Int++    eval = do+        r <- this.!val+        return r++state Add : Expr where +    data left :: Expr +    data right :: Expr ++    eval = do +        x <- this.!left.!eval +        y <- this.!right.!eval +        return (x+y)+|]++someExpr :: Add +someExpr = new @Add (upcast $ new @Val 4, upcast $ new @Val 7)++someExprResult :: Int +someExprResult = result (someExpr.!eval)+```++If we evaluate `someExprResult`, the result is `11` as expected. We can note some points of interest here that differ from popular object-oriented programming languages:++- The type annotations on `someExpr` and `someExprResult` are optional and just provided for clarity. The type applications for the calls to `new` are required (alternatively, type annotations on the sub-expression would work, too).+- Casts must be explicit: in the example, the objects of type `Val` must be explicitly cast to `Expr` values to instantiate the `Add` object.+- Since everything is pure, calling a method on an object produces two results: the result of the method call and a (potentially) updated object. The `result` function returns the result of calling `eval` on the `someExpr` object, discarding the resulting object.+- It does not matter what type of object we call `eval` on, as long as it is of type `Expr` or is a sub-type of `Expr`.++Indeed, we can cast the `Add` object to an `Expr` object, call `eval` on it, and still get the correct result:++```haskell+> let e = upcast someExpr in result (e.!eval)+11+```++- Casting from supertype objects to a subtype is possible, but may fail (returning `Nothing`). E.g. assuming `Duck <: Bird` and that `obj :: Bird` then `downcast obj :: Maybe Duck`.++## Overview of the process++* `QuasiQuoters.hs` contains the entry point+* First, the state declarations are parsed (`Parsers.hs`) via `parseStateDecl`+* The parsed declarations are then passed to `genStateDecls` (`Language.MSH.CodeGen.Decls` / `Decls.hs`)+* This turns the declarations into a dependency graph (via `buildStateGraph` in `Language.MSH.StateEnv` / `StateEnv.hs`)+* If successful, the graph is written to `graph.log`+* The `genStateDecl` function is then applied to every state declaration in dependency order (i.e. starting from no dependencies)
+ hoop.cabal view
@@ -0,0 +1,108 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: a948da575e196b0d66adfd7612a3981b09f6fd74be52eff6cf33f774f9810940++name:           hoop+version:        0.3.0.0+synopsis:       Object-Oriented Programming in Haskell+description:    Library for object-oriented programming in Haskell.+category:       Language+homepage:       https://github.com/mbg/hoop#readme+bug-reports:    https://github.com/mbg/hoop/issues+author:         Michael B. Gale+maintainer:     m.gale@warwick.ac.uk+copyright:      Copyright (c) Michael B. Gale+license:        MIT+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md++source-repository head+  type: git+  location: https://github.com/mbg/hoop++library+  exposed-modules:+      Language.MSH+      Language.MSH.BuiltIn+      Language.MSH.CodeGen+      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.Invoke+      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.MSH.Constructor+      Language.MSH.MethodTable+      Language.MSH.NewExpr+      Language.MSH.Parsers+      Language.MSH.Pretty+      Language.MSH.QuasiQuoters+      Language.MSH.RuntimeError+      Language.MSH.Selectors+      Language.MSH.StateDecl+      Language.MSH.StateEnv+  other-modules:+      Paths_hoop+  hs-source-dirs:+      src+  default-extensions: TemplateHaskell QuasiQuotes RecordWildCards+  ghc-options: -Wall+  build-depends:+      base >=4.7 && <5.0+    , containers+    , haskell-src-exts >=1.16+    , haskell-src-meta >=0.6+    , lens >=4.10+    , mtl >=2.1+    , parsec >=3.1.9+    , pretty+    , template-haskell >=2.14+    , text+  default-language: Haskell2010++test-suite hoop-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Counter+      Expr+      Expr2+      List+      Stack+      Paths_hoop+  hs-source-dirs:+      test+  default-extensions: TemplateHaskell QuasiQuotes RecordWildCards+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5.0+    , containers+    , haskell-src-exts >=1.16+    , haskell-src-meta >=0.6+    , hoop+    , hspec+    , lens >=4.10+    , mtl >=2.1+    , parsec >=3.1.9+    , pretty+    , template-haskell >=2.14+    , text+  default-language: Haskell2010
+ src/Language/MSH.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE RankNTypes, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts #-}+{-# LANGUAGE TypeFamilies, DataKinds, KindSignatures, FlexibleInstances, DefaultSignatures #-}+module Language.MSH (+    module Control.Lens,+    module Control.Monad.Identity,+    module Control.Monad.State,+    module Language.MSH.QuasiQuoters,+    module Language.MSH.Selectors,+    module Language.MSH.RuntimeError,++    SetterContext(..),+    ValueContext(..),+    HasData(..),+    Cast(..),+    New(..),+    Void,+    switch,+    (<:),+    Identity(..)+) where++import Control.Lens+import Control.Monad.Identity+import Control.Monad.State hiding (state)+import Control.Monad.Fail+import Language.MSH.QuasiQuoters+import Language.MSH.Selectors+import Language.MSH.RuntimeError++class HasData obj d | obj -> d where+    extractData :: obj -> d++class Cast sub sup | sub -> sup where+    upcast :: sub -> sup++class New obj where+    type Args obj :: *+    new :: Args obj -> obj++type Void = ()++infixl 7 <:+class SetterContext r o s m where+    (>:) :: Selector Field o s m val -> val -> r++class ValueContext r val where+    type VCSt  r :: *+    type VCM   r :: * -> *+    --value :: Selector o (VCSt r) (VCM r) arg val -> r++{-instance SetterContext (StateT s m ()) o s m where+    (MkField g g' s s') <: v = s' v-}++instance ValueContext (StateT s m val) val where+    type VCSt (StateT s m val) = s+    type VCM (StateT s m val) = m+    --value (MkField g g' s s') = g'+++(<:) :: Monad m => Selector Field o s m val -> val -> StateT s m ()+(MkField g g' s s') <: v = s' v++switch :: Monad m => Selector ty o s m val -> (val -> StateT s m b) -> StateT s m b+switch (MkMethod im em)      m = im >>= m+switch (MkField eg ig es is) m = ig >>= m++instance MonadFail Identity where +    fail = error
+ src/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"
+ src/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
+ src/Language/MSH/CodeGen/Class.hs view
@@ -0,0 +1,168 @@+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 -> [String] -> 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) vs (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] ++ map (VarT . mkName) vs++-- -- | 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,+        stateParentPs = pvs,+        stateData = ds+    }) = do+        o   <- newName "o"+        s   <- newName "s"+        m   <- newName "m"+        let+            fam   = OpenTypeFamilyD $ TypeFamilyHead (mkName $ name ++ "St") ([PlainTV o] {- ++ tyvars -}) (KindSig (VarT $ mkName "p")) Nothing+            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) pvs 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)
+ src/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
+ src/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, Bang NoSourceUnpackedness NoSourceStrictness, 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 Nothing [RecC dctrname fs] []
+ src/Language/MSH/CodeGen/Decls.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE TemplateHaskell #-}++module Language.MSH.CodeGen.Decls (+    genStateDecls+) where++--------------------------------------------------------------------------------++import Debug.Trace (trace)++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 (genStateInstances)+import Language.MSH.CodeGen.Methods+import Language.MSH.CodeGen.Constructors+import Language.MSH.CodeGen.MiscInstances+import Language.MSH.CodeGen.Inheritance+import Language.MSH.CodeGen.Invoke++--------------------------------------------------------------------------------++genIdentityInstance :: Q Dec+genIdentityInstance = do+    let+        ty = tuple []+    return $ InstanceD Nothing [] 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 } = trace ("---------------\nClass: " ++ stateName s) $ do+    let+        tyvars   = map (PlainTV . mkName) vars+    -- generate the type for the class data+    d  <- genStateData tyvars s+    -- generate lenses+    ls <- makeFieldOpticsForDec stateLensRules d+    -- generate the state monad+    t  <- genStateType tyvars s+    -- generate the object type+    o  <- genStateObject tyvars s+    -- generat the _C_invoke function+    invk <- genInvoke tyvars s+    -- generate the type classes+    c  <- genStateClass env tyvars decls s+    -- generate the type class instances+    is <- genStateInstances env c decls s+    -- generate constructors+    cs <- genConstructors env s+    -- generate misc. type class instances+    misc <- genMiscInstances s o cs+    -- generate method implementations+    ms <- genMethods s (stateName s) vars +    -- concatenate all the new declarations+    return $ [d,t,o] ++ invk ++ [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+        runIO $ writeFile "graph.log" (ppStateEnv env')+        dss <- mapM (genStateDecl env') (M.elems env')+        return $ concat dss
+ src/Language/MSH/CodeGen/Inheritance.hs view
@@ -0,0 +1,71 @@+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 $ "Can't inherit from `" ++ pn ++ "': it 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++-- | `isAbstract` @name decl@ determines whether @name@ is abstract in @decl@.+isAbstract :: Name -> StateDecl -> Bool+isAbstract n (StateDecl { {- stateParent = Nothing, -} stateMethods = tbl }) =+    let nb = nameBase n+    in case M.lookup (nameBase n) (methods tbl) of+        Nothing -> error $ "[isAbstract] " ++ nb ++ " does not exist"+        Just e -> abstractEntry e+-- isAbstract n (StateDecl { stateParent = Just p, stateMethods = tbl }) =+--     let nb = nameBase n+--     in case M.lookup (nameBase n) (methods tbl) of+--         Nothing -> isAbstract n p+--         Just e -> abstractEntry e+--     M.notMember (nameBase n) (methods tbl) && isAbstract n p
+ src/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 (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 } =+    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
+ src/Language/MSH/CodeGen/Interop.hs view
@@ -0,0 +1,44 @@+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 as HS+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 HS.EnableExtension [+    HS.GADTs,+    HS.TypeFamilies,+    HS.RankNTypes,+    HS.FunctionalDependencies,+    HS.ScopedTypeVariables,+    HS.MultiParamTypeClasses,+    HS.FlexibleInstances,+    HS.FlexibleContexts,+    HS.TypeOperators,+    HS.LambdaCase]++-- | Configuration for the Haskell parser+parseMode :: Exts.ParseMode+parseMode = Exts.ParseMode "" Haskell2010 extensions True True Nothing True++-- | 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
+ src/Language/MSH/CodeGen/Invoke.hs view
@@ -0,0 +1,105 @@+--------------------------------------------------------------------------------+-- Monadic State Hierarchies                                                  --+-- Copyright 2013-2019 Michael B. Gale (m.gale@warwick.ac.uk)                 --+--------------------------------------------------------------------------------++module Language.MSH.CodeGen.Invoke (genInvoke) where ++--------------------------------------------------------------------------------++import Language.Haskell.TH+import Language.Haskell.TH.Syntax++import Language.MSH.StateDecl+import Language.MSH.CodeGen.Shared+import Language.MSH.CodeGen.SharedInstance (genRunStateT)++--------------------------------------------------------------------------------++-- | Generates the typing for the `invoke' function.+genInvokeDecl :: [TyVarBndr] -> StateDecl -> Q Dec+genInvokeDecl tyvars StateDecl{..} = do+    -- initialise some fresh type variables+    o' <- newName "o'"+    d' <- newName "d'"+    r  <- newName "r"+    let+        objName = mkName stateName+        identity = mkName "Identity"+        objTy = appN (ConT objName) stateParams+        -- the name of the invoke function (e.g. _Expr_invoke)+        name  = mkName $ "_" ++ stateName ++ "_invoke"+        -- the name of the corresponding type class (e.g. ExprLike)+        cname = mkName $ stateName ++ "Like"+        -- the name of the corresponding monad (TODO: apply tyvars )+        base  = appN (ConT (mkName $ stateName ++ "M")) (stateParams)+        -- type class constraints (the context) on the type of the invoke function+        ctx   = [ foldl AppT (ConT cname) ([ConT objName, ConT $ mkName $ stateName ++ "State", ConT identity] ++ [VarT $ mkName n | n <- stateParams])+                , foldl AppT (ConT cname) ([VarT o', VarT d', base] ++ [VarT $ mkName n | n <- stateParams])+                ]+        -- ovs   = appN (VarT o) tyvars+        ovs'  = appN (VarT o') stateParams+        sigma = ovs' `arr` (ovs' `arr` AppT base (tuple [VarT r, ovs'])) `arr` +                objTy `arr` AppT (ConT identity) (tuple [VarT r, objTy, ovs'])+        -- the type of the invoke function+        ty    = ForallT ([PlainTV o', PlainTV d', PlainTV r] ++ [PlainTV (mkName v) | v <- stateParams]) ctx sigma+    return $ SigD name ty++-- | 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 :: [TyVarBndr] -> StateDecl -> Q Dec+genInvokeDef tyvars decl = case stateParent decl of +    Nothing -> do+        s <- newName "s"+        f <- newName "f"+        o <- newName "o"+        r <- newName "r"+        d' <- newName "d'"+        s' <- newName "s'"+        let+            name = mkName $ "_" ++ stateName decl ++ "_invoke"+            fn   = mkName $ "_" ++ stateName decl ++ "_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 []]+    Just pDecl -> do+        subObj <- newName "subObj"+        fun <- newName "fun"+        obj <- newName "obj"+        p <- newName "p"+        d <- newName "d"+        r <- newName "r"+        subObj' <- newName "subObj'"+        p' <- newName "p'"+        obj' <- newName "obj'"+        r0 <- newName "r0"+        subObj0 <- newName "subObj0"+        d0 <- newName "d0"+        let+            name = mkName $ "_" ++ stateName decl ++ "_invoke"+            pname = mkName $ "_" ++ stateName pDecl ++ "_invoke"+            endCtr = mkName $ stateName decl ++ "End"+            ps = [VarP subObj, VarP fun, AsP obj (ConP endCtr [VarP p, VarP d])]+            ed = AppE (VarE $ mkName "extractData") (VarE obj')+            innerRun = BindS (TupP [TupP [VarP r0, VarP subObj0], VarP d0]) (genRunStateT (AppE (VarE fun) (VarE subObj)) (VarE d))+            innerRet = appEs (VarE $ mkName "return") [TupE [TupE [VarE r0, VarE subObj0], appEs (ConE endCtr) [VarE p, VarE d0]]]+            wrapper = LamE [WildP] $ DoE [innerRun, NoBindS innerRet]+            subInvoke = appEs (VarE $ pname) [VarE obj, wrapper, VarE p]+            runs = BindS (TupP [TupP [VarP r, VarP subObj'], VarP p', VarP obj']) subInvoke+            rets = AppE (VarE $ mkName "return") (TupE [VarE r, appEs (ConE endCtr) [VarE p', ed], VarE subObj'])+            body = NormalB $ DoE [runs, NoBindS rets]+        return $ FunD name [Clause ps body []]++-- | `genInvoke` @decl@ generates the code for the @_C_invoke@ function of+-- a state class @decl@.+genInvoke :: [TyVarBndr] -> StateDecl -> Q [Dec]+genInvoke tyvars decl = do +    dec <- genInvokeDecl tyvars decl +    def <- genInvokeDef tyvars decl +    return [dec, def]++--------------------------------------------------------------------------------
+ src/Language/MSH/CodeGen/Methods.hs view
@@ -0,0 +1,82 @@+--------------------------------------------------------------------------------+-- Monadic State Hierarchies                                                  --+-- Copyright 2013-2019 Michael B. Gale (m.gale@warwick.ac.uk)                 --+--------------------------------------------------------------------------------++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.MethodTable+import Language.MSH.CodeGen.Shared +import Language.MSH.CodeGen.Inheritance++--------------------------------------------------------------------------------++genMethodBody :: Name -> Dec -> Dec +genMethodBody name (ValD (VarP _) body wh) =  ValD (VarP name) body wh+genMethodBody name (FunD _ cs) = FunD name cs++genMethod' :: String -> String -> [String] -> Type -> Dec -> Q [Dec]+genMethod' className name vars ty def = do +    o <- newName "o"+    s <- newName "s"+    m <- newName "m"+    let+        n'  = mkName $ "_" ++ className ++ "_" ++ name+        svs = appN (VarT s) vars+        stt = AppT (AppT (ConT (mkName "StateT")) svs) (VarT m)+        tvs = [PlainTV o, PlainTV s, PlainTV m] ++ [PlainTV (mkName v) | v <- vars]+        cxt = [foldl AppT (ConT $ mkName $ className ++ "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+     ,  genMethodBody n' def+     ]++-- | Generates a method belonging to a state class.+genMethod :: StateDecl -> String -> [String] -> (String, MethodEntry) -> Q [Dec]+genMethod decl n vars (name, entry)+    | abstractEntry entry = trace (name ++ " is abstract in " ++ show decl) $ return []+    | otherwise = case entry of +        GenesisMethod _ (Just (SigD _ ty)) (Just def) -> +            genMethod' n name vars ty def+        OverridenMethod (SigD _ ty) def -> +            genMethod' n name vars ty def+        InheritedMethod _ (SigD _ ty) (Just def) ->+            genMethod' n name vars ty def+        _ -> error $ "[genMethod] Unexpected method table entry:\n " ++ show entry++-- 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++-- | `genMethods` Generates methods for a state class.+genMethods :: StateDecl -> String -> [String] -> Q [Dec]+genMethods decl n vars =+    concat <$> mapM (genMethod decl n vars) ms+    where ms = M.toList $ methods $ stateMethods decl++--------------------------------------------------------------------------------
+ src/Language/MSH/CodeGen/MiscInstances.hs view
@@ -0,0 +1,131 @@+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 Nothing [] (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,+    stateParentPs = ps+}) = 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 "upcast") body+            pty = appN (parseType (stateName p)) ps+        return $ [InstanceD Nothing [] (AppT (AppT ct ty) pty) [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
+ src/Language/MSH/CodeGen/Monad.hs view
@@ -0,0 +1,30 @@+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++import Debug.Trace++--stateName = name, stateParams = vars, stateParentN = mp+genStateType :: [TyVarBndr] -> StateDecl -> Q Dec+genStateType tyvars (StateDecl {..}) = do+    let+        -- unlike in the paper, the type synonym isn't just the name of the class+        tname = mkName $ stateName ++ "M"+        stype = appN (ConT (mkName $ stateName ++ "State")) stateParams+    case stateParentN of+        Nothing  -> return $+            TySynD tname tyvars (AppT (ConT (mkName "State")) stype)+        (Just p) -> do+            let+                ptype = appN (parseType p) stateParentPs+                -- we want the monad, not the object+                fixpt t@(ConT _) = renameT (\n -> n ++ "M") t+                fixpt (AppT f a) = AppT (fixpt f) a+            trace (show stateParentPs ++ show ptype) $ return $ TySynD tname tyvars (AppT (AppT (ConT (mkName "StateT")) stype) (fixpt ptype))
+ src/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)
+ src/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 Nothing [] (AppT ct ty) [synInst,eq]
+ src/Language/MSH/CodeGen/Object.hs view
@@ -0,0 +1,112 @@+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++ns :: Bang+ns = Bang SourceNoUnpack NoSourceStrictness++supField :: String -> Type -> VarBangType+supField c pt = (fname, ns, ftype)+    where+        fname = mkName $ "_" ++ c ++ "_sup"+        ftype = pt++dataField :: String -> [String] -> VarStrictType+dataField c vars = (fname, ns, ftype)+    where+        fname = mkName $ "_" ++ c ++ "_data"+        ftype = appN (ConT $ mkName $ c ++ "State") vars++subField :: String -> Name -> [String] -> VarStrictType+subField c s vars = (fname, ns, 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),+    stateParentPs = ps } ) = do+        let pt = appN (parseType p) ps+        sctr <- startCtr name vars+        mctr <- middleCtr name vars pt+        dctr <- dataCtr name vars+        ectr <- endCtr name vars pt+        case m of+            Nothing       -> return [dctr, sctr, ectr, mctr]+            Just Abstract -> return [sctr, ectr, 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 Nothing cs []
+ src/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 Nothing cxt ty ds : fams+--genObjectInstance _ = return []
+ src/Language/MSH/CodeGen/PrimaryInstance.hs view
@@ -0,0 +1,111 @@+module Language.MSH.CodeGen.PrimaryInstance (+    genPrimaryInstance,+    genIdentityInstance,+    genParentalInstance+) where++import Debug.Trace++import Language.Haskell.TH+import Language.Haskell.TH.Syntax++import Language.MSH.StateEnv+import Language.MSH.StateDecl+import Language.MSH.CodeGen.Shared (renameParent, appN)+import Language.MSH.CodeGen.SharedInstance+import Language.MSH.CodeGen.Interop (parseType)++-- | Gets the name of the base monad. This is Identity for base classes+-- or the parent class's monad type for subclasses+getBaseMonad :: Maybe String -> [String] -> Type+getBaseMonad Nothing  _  = ConT $ mkName "Identity"+getBaseMonad (Just p) vs = appN (renameParent (\n -> n ++ "M") $ parseType p) vs++-- | Generates the primary instance for a state class. This is the CLike+-- instance with CObj CSt PMonad+genPrimaryInstance :: StateEnv -> Dec -> [Dec] -> StateDecl -> Q Dec+genPrimaryInstance env cls decs decl@(StateDecl {+    stateName    = name,+    stateParams  = vars,+    stateData    = ds,+    stateParentN  = mp,+    stateParentPs = ps,+    stateMethods = methods+}) = do+    let+        cxt = []+        -- the name of the type class (CLike)+        cn  = mkName $ name ++ "Like"+        -- the name of the object type (C)+        on  = mkName name+        -- the name of the state type (CState)+        sn  = mkName $ name ++ "State"+        -- the name of the parent class's monad (PMonad)+        bt  = getBaseMonad mp ps+        -- CLike C CState PMonad tvars+        ty  = foldl AppT (AppT (AppT (AppT (ConT cn) (ConT on)) (ConT sn)) bt) (map (VarT . mkName) vars)+        -- a type function which returns the state type+        -- CSt C = CState+        fam = TySynInstD (mkName $ name ++ "St") $ TySynEqn [ConT on] (ConT sn)+    -- generate the invoke method body+    -- invk <- genInvokeDef name+    -- generate the field definitions+    mods <- genFields decl decl PrimaryInst+    -- generate the methods+    ms   <- genMethods PrimaryInst decl decl methods name+    -- return the type class instance+    return $ InstanceD Nothing cxt ty ([fam {-,invk -}] ++ mods ++ ms)++-- | Generates the identity instance for a state class. This is the CLike+-- instance with CObj CSt Identity+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)+        -- generate the invoke method body+    -- invk <- genInvokeDef name+    -- generate the field definitions+    fs   <- genFields decl decl IdentityInst+    -- generate the methods+    ms   <- genMethods IdentityInst decl decl methods name+    -- return the type class instance+    return $ InstanceD Nothing cxt ty ([fam {- ,invk -}] ++ fs ++ ms)++-- | Generates the parental instances for a state class. The first argument to+-- this function is the state class for which these parental instances are+-- being generated. The second argument is the ancestor for which the instances+-- are currently being generated. +genParentalInstance :: StateDecl -> StateDecl -> Q [Dec]+genParentalInstance sub parent = trace ("PARENTAL INSTANCE (secondary+identity) OF " ++ stateName parent ++ " for " ++ stateName sub) $ do+    let+        cxt = []+        cn  = mkName $ (stateName parent) ++ "Like"+        on  = mkName (stateName sub)+        sn  = mkName $ (stateName sub) ++ "State"+        bt  = getBaseMonad (stateParentN sub) (stateParentPs 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 sub SecondaryInst+    ms <- genMethods SecondaryInst parent sub (stateMethods sub) (stateName parent)+    ifs <- genFields parent sub IdentityInst+    ims <- genMethods IdentityInst parent sub (stateMethods sub) (stateName parent)+    rs <- case stateParent parent of+        Nothing  -> return []+        (Just p) -> genParentalInstance sub p+    return $ [ InstanceD Nothing cxt ty (fs ++ ms)+             , InstanceD Nothing cxt idty (ifs ++ ims)+             ] ++ rs
+ src/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)
+ src/Language/MSH/CodeGen/SharedInstance.hs view
@@ -0,0 +1,434 @@+--------------------------------------------------------------------------------++module Language.MSH.CodeGen.SharedInstance (+    ImplMode(..),++    genFields,+    genMethods,+    -- genInvokeDef,+    genInvoke,+    genRunStateT+) 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 (Eq, Show)++{--------------------------------------------------------------------------+    Control flow+--------------------------------------------------------------------------}++-- `genTrace` @msg @exp generates a call to the trace function from Debug.Trace+-- with the message @msg around the expression @exp.+genTrace :: String -> Exp -> Exp+genTrace msg e = AppE (AppE (VarE $ mkName "trace") (LitE $ StringL msg)) e++-- `genUndefined` generates `undefined`.+genUndefined :: Exp+genUndefined = VarE $ mkName "undefined"++-- | `lifted' @exp wraps @exp in a call to @lift.+lifted :: Exp -> Exp+lifted = AppE (VarE $ mkName "lift")++-- | `composed` @f @g composes @f and @g.+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 -> StateDecl -> [Name] -> Exp -> StateObjCtr -> Q (Maybe Clause)+genIdentityClause p (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 p (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 p decl args call ctr = trace ("Nothing" ++ show ctr) $ 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 -- genInvoke++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 -> StateDecl -> String -> Q [Clause]+genGetterClauses PrimaryInst decl instanceOf name = trace ("Primary:" ++ name ++ show (ctrsForClass instanceOf)) $+    mapM (genPrimaryClause decl [] call exp) (ctrsForClass instanceOf)+    where+        call = VarE $ mkName $ name ++ "'"+        exp  = AppE (VarE $ mkName $ name)+genGetterClauses IdentityInst decl instanceOf name = trace ("Identity:" ++ name ++ show (ctrsForClass instanceOf)) $+    catMaybes <$> mapM (genIdentityClause decl instanceOf [] call) (ctrsForClass instanceOf)+    where+        call = VarE $ mkName $ name+genGetterClauses SecondaryInst decl instanceOf name = trace ("Secondary:" ++ name ++ show (ctrsForClass instanceOf)) $+    mapM (genPrimaryClause instanceOf [] call exp) (ctrsForClass instanceOf)+    where+        call = VarE $ mkName $ name ++ "'"+        exp  = AppE (VarE $ mkName $ name)-- TODO: error "SecondaryInst in genGetterClauses"++genSetterClauses :: ImplMode -> StateDecl -> StateDecl -> String -> Name -> Q [Clause]+genSetterClauses PrimaryInst decl instanceOf name var =+    mapM (genPrimaryClause decl [var] call exp) (ctrsForClass instanceOf)+    where+        call = AppE (VarE $ mkName $ name ++ "'") (VarE var)+        exp  = \s -> AppE (AppE (VarE $ mkName name) s) (VarE var)+genSetterClauses IdentityInst decl instanceOf name var = trace name $ do+    obj <- newName "obj"+    let+        call = LamE [VarP obj] $ foldl AppE (VarE $ mkName $ name) [VarE obj, VarE var]+    catMaybes <$> mapM (genIdentityClause decl instanceOf [var] call) (ctrsForClass instanceOf)+genSetterClauses SecondaryInst decl instanceOf name var =+    mapM (genPrimaryClause instanceOf [var] call exp) (ctrsForClass instanceOf)+        where+            call = AppE (VarE $ mkName $ name ++ "'") (VarE var)+            exp  = \s -> AppE (AppE (VarE $ mkName name) s) (VarE var) -- TODO+-- | `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 -> StateDecl -> ImplMode -> String -> String -> Q [Dec]+genField dec instanceOf 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 instanceOf 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 instanceOf 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]++-- | `genFields dec mode' generates getters, setters, and field selectors+--   for the fields in `ds' which are part of a state class @dec. `mode'+--   determines how these calls will be routed.+genFields :: StateDecl -> StateDecl -> ImplMode -> Q [Dec]+genFields dec instanceOf mode =+    trace ("Generating fields for " ++ stateName dec ++ ":" ++ stateName instanceOf ++ " in mode " ++ show mode) $+    concat <$> mapM (genField dec instanceOf mode (stateName dec)) fs+    where+        -- the names of the fields in dec+        fs = map stateDataName (stateData dec)++{--------------------------------------------------------------------------+    Methods+--------------------------------------------------------------------------}++-- | `findClassMethodType` @decs @+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 decl 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)++genInheritedClauses :: ImplMode -> Name -> Bool -> Q [Clause]+genInheritedClauses SecondaryInst mname abstract +    | abstract = return [Clause [] (NormalB (AppE (VarE $ mkName "error") (VarE $ mkName "_msh_rt_invalid_call_abstract"))) []]+    | otherwise = return [Clause [] (NormalB (lifted $ VarE mname)) []] +genInheritedClauses IdentityInst mname _ = do+    return [Clause [] (NormalB (AppE (VarE $ mkName "error") (VarE $ mkName "_msh_rt_invalid_call_internal"))) []]++genInheritedMethod :: ImplMode -> StateDecl -> StateDecl -> MethodTable -> String -> String -> Type -> Bool -> Q [Dec]+genInheritedMethod mode decl instanceOf tbl cn name typ abstract = trace ("genInheritedMethod:" ++ name) $ do+    if isGenesisIn name (stateMethods decl)+    then trace (name ++ " is first defined in " ++ (stateName decl) ++ ":" ++ (stateName instanceOf)) $ do+        let+            -- count the number of arguments the method has+            argc = countTypeArgs typ+            -- construct the name for external calls+            ename = mkName $ "_ecall_" ++ name+            -- construct the name for internal calls+            iname = mkName $ "_icall_" ++ name+            -- the name of the inherited method (this should refer to the actual+            -- implementation rather than a handle so that it can be lifted)+            mname    = mkName $ "_" ++ (stateName decl) ++ "_" ++ name+        -- generate fresh variables for the parameters of the method+        vs <- replicateM argc (newName "v")+        -- generate the clauses for the external call+        eclauses <- genMethodClauses mode decl instanceOf iname ename vs+        -- generate the clauses for the internal call+        iclauses <- genInheritedClauses mode mname abstract+        let+            -- generate the function definition for the external call+            external = FunD ename eclauses++            {-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 mname)) []]-}+            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]+    else trace (name ++ " is not genesis in " ++ (stateName decl) ++ ":" ++ (stateName instanceOf)) $ return []++-- | Generates a method handler+genGenesisMethod :: ImplMode -> StateDecl -> StateDecl -> MethodTable -> String -> String -> Type -> Q [Dec]+genGenesisMethod mode decl instanceOf tbl cn name typ = trace ("genGenesisMethod:" ++ name) $ do+    -- if this method was declared by a parent, it belongs to+    -- a different type, so we don't implement it here+    if not (isGenesisIn name (stateMethods decl)) -- declByParent (mkName name) decl || not (M.member name (methods $ stateMethods decl))+    then trace ("**** Declared by other class: " ++ name) $ return []+    else trace ("genGenesisMethod (" ++ stateName decl ++ "," ++ stateName instanceOf ++  "): " ++ name ++ "is proceeding") $ do+        let+            -- count the number of arguments the method has+            argc = countTypeArgs typ -- numArgsForMethod cls ("_icall_" ++ name)+            -- construct the name for external calls+            ename = mkName $ "_ecall_" ++ name+            -- construct the name for internal calls+            iname = mkName $ "_icall_" ++ name+        -- generate fresh variables for the parameters of the method+        vs <- replicateM argc (newName "v")+        -- generate the clauses for the external call+        eclauses <- genMethodClauses mode decl instanceOf iname ename vs+        let+            -- generate the function definition for the external call+            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, MethodEntry) -> Q [Dec]+genMethod mode decl instanceOf tbl cn (name, GenesisMethod abst (Just (SigD _ ty)) mdef) +    | otherwise = genGenesisMethod mode decl instanceOf tbl cn name ty+genMethod mode decl instanceOf tbl cn (name, OverridenMethod (SigD _ ty) def) =+    trace (name ++ " is overriden") $ genGenesisMethod mode decl instanceOf tbl cn name ty+genMethod mode decl instanceOf tbl cn (name, InheritedMethod abstract (SigD _ ty) mdef) =+    genInheritedMethod mode decl instanceOf tbl cn name ty abstract+--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 mode decl instanceOf tbl cn (name,_)                         = +    trace ("!!! Not generating a method for " ++ name ++ " in " ++ stateName decl) $ return []++-- | `genMethods` @impl decl instanceOf table className@ generates a list+-- of method definitions+genMethods :: ImplMode -> StateDecl -> StateDecl -> MethodTable -> String -> Q [Dec]+genMethods mode decl instanceOf tbl cn = trace ("Generating methods: " ++ show (M.toList $ methods tbl)) $+    concat <$> mapM (genMethod mode decl instanceOf tbl cn) (M.toList $ methods tbl)++--------------------------------------------------------------------------------
+ src/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]+}
+ src/Language/MSH/MethodTable.hs view
@@ -0,0 +1,144 @@+module Language.MSH.MethodTable where++--------------------------------------------------------------------------------++import qualified Data.Map as M++import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import qualified Language.Haskell.TH.Ppr as Ppr+import Language.MSH.Pretty++--------------------------------------------------------------------------------++-- | Represents an entry in the method table.+data MethodEntry+    -- |+    = OverridenMethod Dec Dec+    -- | The method is inherited (possibly abstract) from its parent.+    | InheritedMethod Bool Dec (Maybe Dec)+    -- | This is the first place the method is defined (possibly abstract).+    | GenesisMethod Bool (Maybe Dec) (Maybe Dec)+    deriving Show++-- | `abstractEntry` @methodEntry@ determines whether @methodEntry@ is abstract.+abstractEntry :: MethodEntry -> Bool+abstractEntry (OverridenMethod _ _) = False+abstractEntry (InheritedMethod a _ _) = a+abstractEntry (GenesisMethod a _ _) = a++instance Pretty MethodEntry where+    pp (OverridenMethod dec def) = +        text "[OVERRIDEN]" <+> +        text (pprint dec) $+$+        text (pprint def)+    pp (InheritedMethod abs dec mdef) = +        conditionally abs (text "[ABSTRACT]") <+>+        text "[INHERITED]" <+> +        text (pprint dec) $+$+        optionally mdef (text . pprint)+    pp (GenesisMethod abs dec mdef) = +        conditionally abs (text "[ABSTRACT]") <+> +        optionally dec (text . pprint) $+$+        optionally mdef (text . pprint)++-- | Represents the method table, containing signatures and definitions.+data MethodTable = MkMethodTable {+    methods :: M.Map String MethodEntry+} deriving Show++-- | `isGenesisIn` @name table@ determines whether @name@ is originally+-- defined in @table@.+isGenesisIn :: String -> MethodTable -> Bool+isGenesisIn n tbl = case M.lookup n (methods tbl) of+    Just (GenesisMethod _ _ _) -> True+    _ -> False++-- | `ppMethodTable` @table@ pretty-prints @table@.+ppMethodTable :: MethodTable -> Doc+ppMethodTable (MkMethodTable methods) = +    vcat (map (\(n,d) -> pp d) (M.toList methods))++-- | `emptyMethodTable` represents an empty method table.+emptyMethodTable :: MethodTable+emptyMethodTable = MkMethodTable M.empty++-- | `addMethodSig` @name entry table@ adds @entry@ for a method named @name@+-- to @table@.+addMethodSig :: Name -> Dec -> MethodTable -> MethodTable+addMethodSig name dec tbl =+    let+        ms = methods tbl+        nb = nameBase name+    in case M.lookup nb ms of+        Nothing -> tbl { +            methods = M.insert nb (GenesisMethod True (Just dec) Nothing) ms +        }+        Just (GenesisMethod _ dec _) -> +            error $ "Multiple typings for " ++ nb ++ " in class"+        Just (InheritedMethod _ _ _) -> +            error $ "Trying to add typing for inherited method: " ++ nb -- tbl { methodSigs = M.insert nb dec sigs }+        Just _                   -> error $ "Multiple typings for " ++ nb ++ " in class"++-- override :: MethodEntry -> MethodEntry+-- override (InheritedMethod _ d) = OverridenMethod d+-- override d = d++addOverride :: Name -> Dec -> MethodTable -> MethodTable +addOverride name def tbl = +    let+        nb = nameBase name +    in case M.lookup nb (methods tbl) of +        Nothing -> error $ "Cannot override " ++ nb +        Just (InheritedMethod _ dec _) -> tbl {+            methods = M.insert nb (OverridenMethod dec def) (methods tbl)+        }+        _ -> error "Unexpected case in `addOverride`"++addGenesisDef :: Name -> Dec -> MethodTable -> MethodTable+addGenesisDef name def tbl = +    let+        nb = nameBase name +    in case M.lookup nb (methods tbl) of +        Nothing -> tbl {+            methods = M.insert nb (GenesisMethod False Nothing (Just def)) (methods tbl)+        }+        Just (GenesisMethod _ dec mdef) -> case mdef of+            Just _ -> error $ "Multiple definitions for " ++ nb+            Nothing -> tbl {+                methods = M.insert nb (GenesisMethod False dec (Just def)) (methods tbl)+            }+        _ -> error "Unexpected case in `addGenesisDef`"++-- addMethodDef :: Name -> MethodEntry -> MethodTable -> MethodTable+-- addMethodDef name dec@(OverridenMethod d) tbl =+--     let+--         sigs = methodSigs tbl+--         defs = methodDefs tbl+--         nb   = nameBase name++--         success = case M.lookup nb sigs of+--             Nothing  -> tbl { methods = M.insert nb dec defs }+--             Just sig -> tbl { methods = M.insert nb dec defs,+--                               methods = M.insert nb (override sig) sigs }+--     in case M.lookup nb defs of+--         Nothing                    -> success+--         Just (InheritedMethod _ _) -> success+--         Just _                     -> +--             error $ "Multiple definitions for " ++ nb ++ " in class"+-- addMethodDef name dec tbl =+--     let+--         defs = methods tbl+--         nb   = nameBase name+--     in case M.lookup nb defs of+--         Nothing                    -> tbl { methods = M.insert nb dec defs }+--         Just (InheritedMethod _ _) -> tbl { methods = M.insert nb dec defs }+--         Just _                     -> +--             error $ "Multiple definitions for " ++ nb ++ " in class"++++isImplemented :: Name -> MethodTable -> Bool+isImplemented n tbl = M.member (nameBase n) (methods tbl)++--------------------------------------------------------------------------------
+ src/Language/MSH/NewExpr.hs view
@@ -0,0 +1,6 @@+module Language.MSH.NewExpr where++data NewExpr = NewExpr {+    newClassName :: String,+    newArgs      :: String+}
+ src/Language/MSH/Parsers.hs view
@@ -0,0 +1,171 @@+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)++import Debug.Trace++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, [String])+parentClass = (do char ':'+                  spaces+                  ctr <- ctrid+                  spaces+                  tyvars <- many (try tyVar)+                  spaces+                  string "where"+                  return $ (Just ctr,tyvars))+          <|> (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)+    spaces+    (p,ps) <- 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,+        stateParentPs = ps,+        stateParent   = Nothing,+        stateData     = ms,+        stateBody     = body,+        stateMethods  = emptyMethodTable -- 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
+ src/Language/MSH/Pretty.hs view
@@ -0,0 +1,20 @@+module Language.MSH.Pretty (+    module Text.PrettyPrint,++    Pretty(..),+    conditionally,+    optionally+) where++import Text.PrettyPrint++class Pretty a where+    pp :: a -> Doc++optionally :: Maybe a -> (a -> Doc) -> Doc+optionally Nothing f = empty+optionally (Just x) f = f x++conditionally :: Bool -> Doc -> Doc +conditionally False _ = empty+conditionally True f = f
+ src/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-}+
+ src/Language/MSH/RuntimeError.hs view
@@ -0,0 +1,10 @@+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"++_msh_rt_invalid_call_internal :: String+_msh_rt_invalid_call_internal = "Invalid call: internal call not supported by this object state"
+ src/Language/MSH/Selectors.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses, KindSignatures #-}+{-# LANGUAGE Rank2Types, FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds, FlexibleContexts #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++module Language.MSH.Selectors where++--------------------------------------------------------------------------------++import Control.Applicative ((<$>))+import Control.Monad.Identity+import Control.Monad.State++--------------------------------------------------------------------------------++-- | Represents a query which can be run by combinators such as `result',+-- `object', etc.+data RunnableQuery obj st ctx r where+    MkExtCall  :: ctx (r, obj) -> RunnableQuery obj st ctx r++-- | `result` @selector obtains the result from invoking @selector.+result :: (ctx ~ Identity) => RunnableQuery obj st ctx r -> r+result (MkExtCall call) = fst $ runIdentity call++-- | `object` @selector obtains an updated object from invoking @selector.+object :: (ctx ~ Identity) => RunnableQuery obj st ctx r -> obj+object (MkExtCall call) = snd $ runIdentity call++--value :: Selector Field o s m a -> a+--value (MkField eg _ _ _) = eg++-- | Enumerates types of object class members.+data MemberType = Method | Field++-- | Determines the type of selector that results from composing two+-- selectors.+type family MemberComposeResult (lhs :: MemberType) (rhs :: MemberType) :: MemberType where+    MemberComposeResult Method Method = Method+    MemberComposeResult Method Field  = Method+    MemberComposeResult Field  Method = Method+    MemberComposeResult Field  Field  = Field++--type Selector ty o s m a =++-- | A selector is a container for object class members.+data Selector (ty :: MemberType) 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++-- | Proxy type used to capture the type variables of an object.+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 :: MemberType) 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)-} 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 (MemberComposeResult lty rty) obj st ctx (f b)+(MkField eg ig es is) .$ (MkMethod ri re) = MkMethod+    (do box <- ig+        let r = fmap (runIdentity . re) box+        is (fmap snd r)+        return (fmap fst r))+    (\this -> do (box,this') <- eg this+                 let r = fmap (runIdentity . re) box+                 (_,this'') <- es this' (fmap snd r)+                 return (fmap fst r, this''))+(MkField eg ig es is) .$ (MkField reg rig res ris) = MkField+    (\this -> do (box,this') <- eg this+                 let r = fmap (runIdentity . reg) box+                 (_,this'') <- es this' (fmap snd r)+                 return (fmap fst r, this''))+    (do box <- ig+        let r = fmap (runIdentity . reg) box+        is (fmap snd r)+        return (fmap fst r))+    -- TODO: the definition of Selector is too restrictive to+    -- implement the following two cases: we need to split the 'a' type+    -- parameter into two: one for the type of values to get and one for+    -- the type of values to set+    undefined+    {-(\this v -> do (box,this') <- eg this+                   let r = fmap (\obj -> runIdentity (res obj v)) box+                   (_,this'') <- es this' (fmap snd r)+                   return ((), this''))-}+    undefined+    {-(\v -> do box <- ig+              )-}+(MkMethod li le) .$ (MkMethod _ re) = MkMethod+    (do box <- li+        let r = fmap (runIdentity . re) box+        return (fmap fst r))+    (\this -> do (box, this') <- le this+                 let r = fmap (runIdentity . re) box+                 return (fmap fst r, this'))+(MkMethod li le) .$ (MkField reg _ _ _) = MkMethod+    (do box <- li+        let r = fmap (runIdentity . reg) box+        return (fmap fst r))+    (\this -> do (box, this') <- le this+                 let r = fmap (runIdentity . reg) box+                 return (fmap fst r, this'))++-- 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+        (do obj <- li+            let (r,obj') = runIdentity (re obj)+            return r)+        (\this -> do (obj,this') <- le this+                     let (r,obj') = runIdentity (re obj)+                     return (r, this'))++    (.!) (MkMethod li le) (MkField eg ig es is) = MkMethod+        (do obj <- li+            let (r,obj') = runIdentity (eg obj)+            return r)+        (\this -> do (obj, this') <- le this+                     let (r,obj') = runIdentity (eg obj)+                     return (r, this'))++-- 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+        (do obj <- ig+            -- * obj is the value (an object) of the field on the left+            -- * use obj as object for the method on the right+            let (r,obj') = runIdentity (re obj)+            -- * update the current object with obj', the updated obj+            is obj'+            -- * return the result of the method on the right+            return r)+        (\this -> do (obj,this') <- eg this+                     -- * use obj as object for the method on the right+                     let (r,obj') = runIdentity (re obj)+                     -- * update the current object with s, the updated r+                     (_,this'') <- es this' obj'+                     return (r,this''))++    (.!) (MkField eg ig es is) (MkField reg rig res ris) = MkField+        (\this -> do (obj,this') <- eg this+                     let (r,obj') = runIdentity (reg obj)+                     (_,this'') <- es this' obj'+                     return (r,this''))+        (do obj <- ig+            let (r,obj') = runIdentity (reg obj)+            is obj'+            return r)+        (\this v -> do (obj,this') <- eg this+                       let (r,obj') = runIdentity (res obj v)+                       (_,this'') <- es this' obj'+                       return (r,this''))+        (\v -> do obj <- ig+                  let (r,obj') = runIdentity (res obj v)+                  is obj'+                  return r)++-- 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
+ src/Language/MSH/StateDecl.hs view
@@ -0,0 +1,128 @@+--------------------------------------------------------------------------------++module Language.MSH.StateDecl (+    module Language.MSH.MethodTable,++    StateMod(..),+    StateObjCtr(..),+    StateMemberDecl(..),+    StateDecl(..),++    isBaseClass,+    isAbstractClass,+    isFinalClass,+    ctrsForClass,++    declByParent+) where++--------------------------------------------------------------------------------++import Prelude hiding ((<>))+import qualified Data.Map as M++import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import qualified Language.Haskell.TH.Ppr as Ppr++import Language.MSH.MethodTable+import Language.MSH.Pretty++--------------------------------------------------------------------------------++-- | Enumerates class modifiers.+data StateMod = Abstract | Final deriving Show++-- | Enumerates object constructor types.+data StateObjCtr = DataCtr | StartCtr | MiddleCtr | EndCtr deriving Show++-- | Used to represent fields in state classes.+data StateMemberDecl = StateDataDecl {+    -- | The name of the field.+    stateDataName   :: String,+    -- | The (optional) expression which specifies the default value.+    stateDataExpr   :: Maybe String,+    -- | The type of the field.+    stateDataType   :: String+} deriving Show++instance Pretty StateMemberDecl where+    pp (StateDataDecl{..}) =+        text stateDataName <+>+        optionally stateDataExpr (\e -> text "=" <+> text e) <+>+        text "::" <+>+        text stateDataType++-- | Represents a state class definition.+data StateDecl = StateDecl {+    -- | The class modifier, if any.+    stateMod      :: Maybe StateMod,+    -- | The name of the class.+    stateName     :: String,+    -- | The list of type parameters.+    stateParams   :: [String],+    -- | The name of the parent class, if any.+    stateParentN  :: Maybe String,+    -- | The type argument for the parent class.+    stateParentPs :: [String],+    -- | The parent class, once resolved.+    stateParent   :: Maybe StateDecl,+    -- | The field declarations.+    stateData     :: [StateMemberDecl],+    -- | The method signatures and definitions.+    stateBody     :: [Dec],+    -- | The method table for this class, once computed.+    stateMethods  :: MethodTable+}++instance Pretty StateDecl where+    pp (StateDecl{..}) =+        text "CLASS" <+> parens (text stateName) <> colon $$ nest 4 (vcat [+            optionally stateParentN (\p -> text "PARENT:" <+> text p <+> hsep (map text stateParentPs)),+            optionally stateParent (\_ -> text "PARENT RESOLVED"),+            optionally stateMod (\m -> text "MODIFIER:" <+> text (show m)),+            text "PARAMS:" <+> hsep (map text stateParams),+            text "DATA" <> colon $$ nest 4 (vcat (map pp stateData)),+            text "BODY (TH AST)" <> colon $$ nest 4 (vcat (map (text . Ppr.pprint) stateBody)),+            text "METHOD TABLE" <> colon $$ nest 4 (ppMethodTable stateMethods)+        ])++instance Show StateDecl where+    show = render . pp++--------------------------------------------------------------------------------++-- | `isBaseClass` @class determines whether @class is a base class.+isBaseClass :: StateDecl -> Bool+isBaseClass (StateDecl { stateParentN = Nothing } ) = True+isBaseClass _ = False++-- | `isAbstractClass` @class determines whether @class is abstract.+isAbstractClass :: StateDecl -> Bool+isAbstractClass (StateDecl { stateMod = Just Abstract }) = True+isAbstractClass _ = False++-- | `isFinalClass` @class determines whether @class is final.+isFinalClass :: StateDecl -> Bool+isFinalClass (StateDecl { stateMod = Just Final }) = True+isFinalClass _ = False++-- | `declByParent' @name @class determines whether a method named @name+-- was declared by a parent of @class.+declByParent :: Name -> StateDecl -> Bool+declByParent _ (StateDecl { stateParent = Nothing })  = False+declByParent n (StateDecl { stateParent = (Just p) }) =+    M.member (nameBase n) (methods $ stateMethods p) || declByParent n p++-- | `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]
+ src/Language/MSH/StateEnv.hs view
@@ -0,0 +1,142 @@+{-# 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.Haskell.TH.Syntax++import Language.MSH.StateDecl+import Language.MSH.Pretty++--------------------------------------------------------------------------------++-- | Represents different errors that can arise during the construction of+-- a class graph.+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++ppStateEnv :: StateEnv -> String+ppStateEnv env = render $ vcat $ map (\(k,d) -> pp d) $ M.toList env++--------------------------------------------------------------------------------++-- | `preProcessMethods' @ds builds a method table from a list of decls that+-- make up an object class.+{-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-}++-- | `inherit` @decl@ extracts the method table from @decl@ (the parent of+-- another state class) and marks all method table entries as inherited.+inherit :: StateDecl -> MethodTable+inherit StateDecl{..} = go stateMethods+    where+        go (MkMethodTable methods) =+            MkMethodTable (M.mapWithKey transform methods)++        -- if @n@ originated in the parent, we inherit it (possibly abstract)+        transform n (GenesisMethod a (Just d) mdef) = InheritedMethod a d mdef+        -- if @n@ was overriden in the parent, we inherit it (never abstract)+        transform n (OverridenMethod dec def) = InheritedMethod False dec (Just def)+        -- otherwise @n@ was inherited by the parent and we continue to inherit it+        transform n d = d++-- | `buildMethodTable` @decl@ builds a method table for @decl@.+buildMethodTable :: StateDecl -> StateDecl+buildMethodTable s@StateDecl{..} =+    s { stateMethods = checkMethodTable s (go initialTable stateBody) }+    where+        initialTable :: MethodTable+        initialTable = case stateParent of+            Just p  -> inherit p+            Nothing -> emptyMethodTable++        go :: MethodTable -> [Dec] -> MethodTable+        go tbl [] = tbl+        -- is this a function signature?+        go tbl (d@(SigD name ty)             : ds)+            | declByParent name s = error $ +                "Method typing for inherited method `" ++ nameBase name ++ "`"+            | otherwise = go (addMethodSig name d tbl) ds+        -- is this a function/value definition (annoyingly: two different+        -- constructors)+        go tbl (d@(FunD name cs)             : ds)+            | declByParent name s = go (addOverride name d tbl) ds+            | otherwise = go (addGenesisDef name d tbl) ds+        go tbl (d@(ValD (VarP name) body wh) : ds)+            | declByParent name s = go (addOverride name d tbl) ds+            | otherwise = go (addGenesisDef name d tbl) ds+        -- otherwise it is some type of Haskell definition we don't care about;+        -- just ignore it+        go tbl (d                            : ds) = go tbl ds++--------------------------------------------------------------------------------++-- | `checkMethodTable` @decl tbl@ performs sanity checks on @tbl@ for @decl@:+-- this function fails if @tbl@ contains abstract methods and @decl@ is not+-- marked as abstract+checkMethodTable :: StateDecl -> MethodTable -> MethodTable+checkMethodTable s tbl = +    MkMethodTable $ M.mapWithKey check (methods tbl)+    where check k v | abstractEntry v && not (isAbstractClass s) = +                        error $ "Abstract member `" ++ k ++ +                                "` in non-abstract class `" +++                                stateName s ++ "`"+                    | otherwise = v++--------------------------------------------------------------------------------++-- | `buildStateGraph` @env@ constructs a strongly-connected graph from @env@.+buildStateGraph :: StateEnv -> Except StateGraphError StateEnv+buildStateGraph = {- throwError . ClassNotFound . show . toGraph -} +    go M.empty . stronglyConnCompR . toGraph+    where+        -- nothing more to add+        go env []                            = return env+        -- we found a cyclic dependency group, raise an error+        go env (CyclicSCC cs           : ds) = +            throwError $ CyclicInheritance [c | (_,c,_) <- cs]+        -- we found an acyclic node without dependencies, so+        -- we just construct the method table for it+        go env (AcyclicSCC (dec,n,[])  : ds) = +            go (M.insert n (buildMethodTable dec) env) ds+        -- we found an acyclic node with dependencies, try to resolve+        -- the parent or throw an error if it cannot be found+        go env (AcyclicSCC (dec,n,[p]) : ds) = case M.lookup p env of+            Nothing   -> throwError (ClassNotFound p)+            (Just pd) -> go (M.insert n (buildMethodTable dec') env) ds+                where dec' = dec { stateParent = Just pd }++-- | `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]++--------------------------------------------------------------------------------
+ test/Counter.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# OPTIONS_GHC -ddump-splices -ddump-to-file #-}++module Counter where++import Language.MSH++[state| +state Counter where+    data count :: Int+ +    next :: Int +    next = do+        r <- this.!count +        count <: (r+1)+        return r++state NameGen : Counter where+    data prefix :: String++    newName :: String +    newName = do +        n <- this.!next +        p <- this.!prefix+        return (p ++ show n)+|]++c :: Counter+c = new 0 ++ng :: NameGen+ng = new (0,"var")
+ test/Expr.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# OPTIONS_GHC -ddump-splices -ddump-to-file #-}++module Expr where++--------------------------------------------------------------------------------++import Language.MSH++--------------------------------------------------------------------------------++[state|+abstract state Expr where+    eval :: Int++state Val : Expr where+    data val = 0 :: Int++    eval = do+        r <- this.!val+        return r++state Add : Expr where +    data left :: Expr +    data right :: Expr ++    eval = do +        x <- this.!left.!eval +        y <- this.!right.!eval +        return (x+y)++state Mul : Expr where+    data mleft  :: Expr+    data mright :: Expr++    eval = do+        l <- this.!mleft.!eval+        r <- this.!mright.!eval+        return (l*r)+|]++v :: Val+v = new 5++e :: Expr+e = upcast v++a :: Add+a = new (e,e)++bar = (result $ v.!eval)+    + (result $ a.!eval)+    + (result $ e.!eval)
+ test/Expr2.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# OPTIONS_GHC -ddump-splices -ddump-to-file #-}++module Expr2 where++--------------------------------------------------------------------------------++import Language.MSH++--------------------------------------------------------------------------------++[state|+abstract state Expr where+    eval :: Int++state Val : Expr where+    data val = 0 :: Int++    eval = do+        r <- this.!val+        return r++abstract state BinOp : Expr where +    data left :: Expr +    data right :: Expr +    data opr :: Int -> Int -> Int++state Add : BinOp where +    eval = do +        x <- this.!left.!eval +        y <- this.!right.!eval +        f <- this.!opr +        return (f x y)+|]++v :: Val+v = new 5++e :: Expr+e = upcast v++a :: Add+a = new (e,e,(+))++b :: BinOp +b = upcast a++bar = (result $ v.!eval)+    + (result $ a.!eval)+    + (result $ e.!eval)+    + (result $ b.!eval)
+ test/List.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -ddump-splices -ddump-to-file #-}++module List where++import Debug.Trace+import Language.MSH++[state|+state MListItem a where+    data val  = error "val" :: a+    data next = Nothing     :: Maybe (MListItem a)++    insertEnd :: MListItem a -> Void+    insertEnd item = do+        switch next $ \x -> case x of+            Nothing  -> next <: Just item+            (Just n) -> next <: Just (object (n.!insertEnd item))+        return ()++    setNext :: Maybe (MListItem a) -> Void+    setNext item = next <: item++    toListItems :: [a]+    toListItems = do+        v <- this.!val+        switch next $ \x -> case x of+            Nothing  -> return [v]+            (Just n) -> do+                let+                    vs = result (n.!toListItems)+                return (v:vs)++state MList a where+    data root = Nothing :: Maybe (MListItem a)++    insert :: a -> Void+    insert val = do+        let+            item = new (val, Nothing)+        switch root $ \x -> case x of+            Nothing  -> root <: Just item+            (Just r) -> do+                this.!root.$insertEnd item+                return ()++    toList :: [a]+    toList = do+        switch root $ \x -> case x of+            Nothing  -> return []+            (Just r) -> return $ result (r.!toListItems)++state SList a : MList a where+    data predicate :: a -> a -> Bool++    --insert :: a -> Void+    insert val = do+        let+            item = new (val, Nothing)+        switch root $ \x -> case x of+            Nothing -> root <: Just item+            Just r  -> do+                p <- this.!predicate+                root <: Just (helper val p r)++state Program where+    data l :: MList Int++    run :: MList Int -> [Int]+    run arg = do+        l <: arg+        this.!l.!insert 23+        this.!l.!insert 16+        this.!l.!insert 42+        this.!l.!insert 24+        r <- this.!l.!toList+        return r+|]++mkItem :: a -> MListItem a+mkItem v = new (v, Nothing)++helper :: a -> (a -> a -> Bool) -> MListItem a -> MListItem a+helper v p i =+    let rv = result (i.!val)+        item = mkItem v+    in if p v rv then case result (i.!next) of+            Nothing -> object (i.!setNext (Just item))+            Just n  -> object (i.!setNext (Just $ helper v p n))+       else object (item.!setNext (Just i))++instance Show (MList Int) where+    show o = show $ result $ o.!toList++test :: MList Int -> [Int]+test l = let+    --l = new Nothing :: MList Int+    a = object (l.!insert 23)+    b = object (a.!insert 16)+    c = object (b.!insert 42)+    d = object (c.!insert 24) in result (d.!toList)++foo :: MListItem Int+foo = new (5, Nothing)++--bar = result $ foo.!insertEnd foo.!toListItems++baz :: Program+baz = new (new Nothing)
+ test/Spec.hs view
@@ -0,0 +1,39 @@++--------------------------------------------------------------------------------++import Test.Hspec++import Language.MSH+import qualified Counter as C+import qualified Expr as E+import qualified Expr2 as E2+import qualified List as L+import qualified Stack as S++--------------------------------------------------------------------------------++main :: IO ()+main = hspec $ do+    describe "Counter" $ do +        describe "Counter" $ do +            it "c.!next is 0" $ result (C.c.!C.next) `shouldBe` 0+            it "(object (c.!next)).!next is 1" $ result ((object (C.c.!C.next)).!C.next) `shouldBe` 1+        describe "NameGen" $ do +            it "ng.!newName is \"var0\"" $ result (C.ng.!C.newName) `shouldBe` "var0"+    describe "Expr" $ do+        it "v is 5" $ result (E.v.!E.eval) `shouldBe` 5+        it "e is 5" $ result (E.e.!E.eval) `shouldBe` 5+        it "a is 10" $ result (E.a.!E.eval) `shouldBe` 10+        it "bar is 20" $ E.bar `shouldBe` 20+    describe "Expr2" $ do+        it "v is 5" $ result (E2.v.!E2.eval) `shouldBe` 5+        it "e is 5" $ result (E2.e.!E2.eval) `shouldBe` 5+        it "a is 10" $ result (E2.a.!E2.eval) `shouldBe` 10+        it "b is 10" $ result (E2.b.!E2.eval) `shouldBe` 10+        it "bar is 30" $ E2.bar `shouldBe` 30+    describe "List" $ do+        it "should build lists" $ L.test (new Nothing) `shouldBe` [23,16,42,24]+        it "should sort lists" $ L.test (upcast (new (Nothing,(>)) :: L.SList Int)) `shouldBe` [16,23,24,42]+    describe "Stack" $ do+        it "pattern synonyms are working" $+            (S.emptyStack :: S.Stack Int) `shouldSatisfy` S.isEmptyStack
+ test/Stack.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -ddump-splices -ddump-to-file #-}++module Stack where++import Language.MSH++[state| +state Stack a where+    data stack :: [a]++    push :: a -> Void+    push x = do+        st <- this.!stack+        stack <: (x : st)++    pushMany :: [a] -> Void +    pushMany = mapM_ (\x -> this.!push x)+ +    pop :: a+    pop = do+        xs <- this.!stack+        stack <: (tail xs)+        return (head xs)+|]++instance Show a => Show (Stack a) where +    show s = show $ result (s.!stack)++pattern Stack :: [a] -> Stack a+pattern Stack xs <- (extractData -> MkStackState xs) where +    Stack xs = new xs++emptyStack :: Stack a +emptyStack = Stack []++isEmptyStack :: Stack a -> Bool+isEmptyStack (Stack []) = True+isEmptyStack (Stack _)  = False++example :: Int +example = let s = object (emptyStack.!pushMany [1,2,3])+          in result (s.!pop)