{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, FlexibleInstances, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances #-} {-| This module provides a simple way to use HOAS (higher order abstract syntax) to emit C++ code. This is an AST-free method! It doesn't define a complete model for C++ code, just an easier way of emitting concretes syntax than using strings. -} module Intel.Cnc.EasyEmit where import Intel.Cnc.Spec.Util hiding (app, commasep) import Intel.Cnc.Spec.AST import Control.Monad import qualified Control.Monad.State.Strict as S import Data.Data import Data.List import GHC.Exts -- For IsString import StringTable.Atom import Text.PrettyPrint.HughesPJ import Text.PrettyPrint.HughesPJClass import Test.HUnit import qualified Prelude as P import Prelude hiding ((&&), (||), (==), (/=), not, Eq , Ord, (<), (<=), (>), (>=), max, min -- , compare ) ---------------------------------------------------------------------------------------------------- -- Monad plus HOAS for C++ ---------------------------------------------------------------------------------------------------- -- | A monad for generating syntax: -- The state consists of an accumulator for lines of syntax, plus a counter for temporary variables. newtype EasyEmit a = EE (S.State EEState a) type EEState = ([Doc],Int) -- | Run a syntax-emitting computation and render it to a document. runEasyEmit :: EasyEmit a -> (a,Doc) runEasyEmit m = (a,b) where (a,_,b) = rawRunEasyEmit 0 m -- This full version includes the counter: rawRunEasyEmit :: Int -> EasyEmit a -> (a, Int, Doc) rawRunEasyEmit start (EE m) = (a, cnt, vcat (reverse ls)) where (a,(ls,cnt)) = S.runState m ([], start) execEasyEmit :: EasyEmit a -> Doc execEasyEmit = snd . runEasyEmit evalEasyEmit :: EasyEmit a -> a evalEasyEmit = fst . runEasyEmit -- This runs a subcomputation only for value -- discards its emission side effects. forValueOnly :: EasyEmit a -> EasyEmit a forValueOnly (EE m) = do (ls,c) <- S.get let (val,(_,c2)) = S.runState m ([], c) S.put (ls,c2) return val -- BOILERPLATE, because of newtype rather than type synonym for EasyEmit: instance Monad EasyEmit where -- Whew, need to verify that this has no perfermance overhead: (EE ma) >>= fn = EE (ma >>= (\x -> case fn x of EE m -> m)) return x = EE (return x) instance S.MonadState EEState EasyEmit where get = EE S.get put x = EE (S.put x) instance StringBuilder EasyEmit where --instance StringBuilder (S.State ([Doc], Int)) where putS s = S.modify (\ (ls,cnt) -> (text s:ls, cnt) ) runSB (EE m) = let (res, (ls,cnt)) = S.runState m ([],0) in (render$ vcat$ reverse ls, res) instance ToAtom Syntax where toAtom d = toAtom$ deSyn d -------------------------------------------------------------------------------- -- First, simple helpers / utilities: -------------------------------------------------------------------------------- instance P.Eq Doc where -- Would be nice to memoize this! a == b = render a P.== render b -- | The EasyEmit monad uses this Syntax type internally: data Syntax = Syn Doc deriving (Show, P.Eq) deSyn (Syn s) = s synToStr = render . deSyn fromInt = Syn . int atomToSyn = Syn . text . fromAtom strToSyn = Syn . text (Syn a) +++ (Syn b) = Syn (a <> b) (Syn a) `dot` (Syn b) = Syn (a <> text "." <> b) (Syn a) `arrow` (Syn b) = Syn (a <> text "->" <> b) dereference (Syn a) = Syn$ parens (text "*" <> a) addressOf (Syn a) = Syn$ parens (text "&" <> a) -- Array subscript operator: arrsub (Syn a) (Syn b) = Syn$ (a <> text "[" <> b <> text "]") -- Adds implicit newline at the end: addChunk :: Syntax -> EasyEmit () addChunk (Syn doc) = do (ls,c) <- S.get S.put (doc : ls, c) -- A bit ugly, this adds the chunk to the end of the previous line. addChunkPrevLine (Syn doc) = do (ls,c) <- S.get S.put $ case ls of [] -> (doc : ls, c) (hd:tl) -> (hd <> doc : tl, c) -- Adds the semi-colon at the end also: addLine (Syn doc) = addChunk (Syn$ doc <> semi) -- Also, overloading the string constants themselves is nice: instance IsString Syntax where fromString s = Syn (text s) -- instance IsString Doc where -- fromString s = (text s) -- Comma separate Docs either horizontally or vertically: -- TEMP: MAKING THIS HCAT FOR NOW UNTIL I CAN FIGURE OUT SOME OF THE INDENTATION PROBELMS: commasep ls = hcat$ intersperse (text", ") ls -- (This version includes parens) --pcommasep = parens . commasep pcommasep ls = parens$ fcat$ intersperse (text", ") ls -------------------------------------------------------------------------------- -- C++ Expressions -------------------------------------------------------------------------------- (Syn a) ? (Syn b) = Syn ("(" <> a <> " ? " <> b ) -- Hack, these must always be used together to get balanced parens: (Syn a) .: (Syn b) = Syn ( a <> " : " <> b <> ")") -- The most important class of expressions are generated by overloaded -- standard operators, as follows: instance Num Syntax where (Syn a) + (Syn b) = Syn (parens $ a <> " + " <> b ) (Syn a) * (Syn b) = Syn (parens $ a <> " * " <> b ) (Syn a) - (Syn b) = Syn (parens $ a <> " - " <> b ) abs (Syn a) = Syn ("abs" <> parens a ) negate (Syn a) = Syn (parens ("-" <> parens a)) fromInteger n = Syn (text $ show n) -- Could implement this I suppose... signum _ = "__ERROR__" instance Fractional Syntax where (Syn a) / (Syn b) = Syn (parens $ a <> " / " <> b ) recip (Syn a) = Syn (parens $ "1 / " <> a ) fromRational rat = Syn ( text$ show rat ) instance Boolean Syntax where (Syn a) && (Syn b) = Syn (parens $ a <> " && " <> b ) (Syn a) || (Syn b) = Syn (parens $ a <> " || " <> b ) not (Syn a) = Syn ("!" <> parens a ) false = Syn "false" true = Syn "true" instance Ord Syntax Syntax where (Syn a) < (Syn b) = Syn (parens $ a <> " < " <> b ) (Syn a) > (Syn b) = Syn (parens $ a <> " > " <> b ) (Syn a) <= (Syn b) = Syn (parens $ a <> " <= " <> b ) (Syn a) >= (Syn b) = Syn (parens $ a <> " >= " <> b ) max (Syn a) (Syn b) = Syn ("max" <> pcommasep [a,b] ) min (Syn a) (Syn b) = Syn ("min" <> pcommasep [a,b] ) -- conditional (Syn a) b c = Syn (parens $ a <> " ? " <> b <> ":" <> c ) instance Eq Syntax Syntax where (Syn a) == (Syn b) = Syn (parens $ a <> " == " <> b ) -- Use a C++ constant constant :: String -> Syntax constant = fromString stringconst :: String -> Syntax stringconst str = Syn$ dubquotes$ escapeString str -- new :: Syntax -> [Syntax] -> Syntax new :: Type -> [Syntax] -> Syntax new ty args = Syn$ "new" <+> (deSyn$ function (Syn$ pPrint ty) args) -------------------------------------------------------------------------------- -- Declaring variables -------------------------------------------------------------------------------- -- With names: var :: Type -> Syntax -> EasyEmit Syntax var ty (Syn name) = do addLine (Syn (cppType ty <+> name )) return (Syn name) -- With initialization expression: varinit :: Type -> Syntax -> Syntax -> EasyEmit Syntax varinit ty (Syn name) (Syn rhs) = do addLine (Syn (cppType ty <+> name <+> "=" <+> rhs)) return (Syn name) -- A var declaration with a constructor invocation. classvar :: Type -> Syntax -> [Syntax] -> EasyEmit Syntax classvar ty (Syn name) args = do addLine (Syn (cppType ty <+> name <+> pcommasep (map deSyn args))) return (Syn name) -- Without names: ---------------------------------------- gensym root = do (ls,cnt) <- S.get S.put (ls,cnt+1) return$ Syn$ root <> int cnt tmpvar :: Type -> EasyEmit Syntax tmpvar ty = do name <- gensym "tmp" var ty name tmpvarinit :: Type -> Syntax -> EasyEmit Syntax tmpvarinit ty rhs = do name <- gensym "tmp" varinit ty name rhs -- A var declaration with a constructor invocation. tmpclassvar :: Type -> [Syntax] -> EasyEmit Syntax tmpclassvar ty args = do name <- gensym "obj" classvar ty name args ------------------------------------------------------------ -- C++ Statements ------------------------------------------------------------ -- This is a function in the meta language that represents a function -- in the object language. type ObjFun = ([Syntax] -> Syntax) -- Variable Assignment: set :: Syntax -> Syntax -> EasyEmit () set (Syn x) (Syn v) = addLine$ Syn$ x <+> "=" <+> v -- Assignment for array locations: arrset :: Syntax -> Syntax -> Syntax -> EasyEmit () arrset arr i rhs = set (arr `arrsub` i) rhs -- Assignment for a field R.x. fieldset :: Syntax -> Syntax -> Syntax -> EasyEmit () fieldset arr x rhs = set (arr `dot` x) rhs -- Function application (command context): app :: ObjFun -> [Syntax] -> EasyEmit () app fn ls = addLine$ fn ls -- A shorthand that looks C-ish: (Syn x) += (Syn n) = addLine$ Syn$ x <+> "+=" <+> n (Syn x) -= (Syn n) = addLine$ Syn$ x <+> "-=" <+> n -- Comments: --comm :: Doc -> EasyEmit () comm :: String -> EasyEmit () comm x = addChunk$ Syn$ txt where txt = text$ maybeInit$ unlines lns -- init strips the last newline maybeInit [] = [] maybeInit ls = init ls lns = map fn $ lines x --(render x) fn "" = "" fn other = "// " ++ other if_ (Syn a) m1 m2 = do let bod1 = execEasyEmit m1 bod2 = execEasyEmit m2 addChunk$ Syn$ hangbraces ("if " <> parens a) indent bod1 addChunk$ Syn$ "else" addChunk$ Syn$ hangbraces (empty) indent bod2 ret (Syn x) = addLine$ Syn$ "return " <> x assert (Syn exp) = do addLine$ Syn ("assert" <> pcommasep [exp]) ------------------------------------------------------------ -- C++ Definitions & Declarations ------------------------------------------------------------ -- The funDef function creates a function definition as well as -- returning a Haskell function that can be used to construct -- applications of that function. class FunDefable args where -- This is VERY painful, but need to expose separate keywords for pre- and post- the function name/args. funDefAttr :: String -> String -> Type -> Syntax -> [Type] -> (args -> EasyEmit ()) -> EasyEmit ObjFun instance FunDefable () where funDefAttr pre post r n ts fn = funDefShared pre post r n ts fn (\ [] -> ()) instance FunDefable Syntax where funDefAttr pre post r n ts fn = funDefShared pre post r n ts fn (\ [a] -> a) instance FunDefable (Syntax,Syntax) where funDefAttr pre post r n ts fn = funDefShared pre post r n ts fn (\ [a,b] -> (a,b)) instance FunDefable (Syntax,Syntax,Syntax) where funDefAttr pre post r n ts fn = funDefShared pre post r n ts fn (\ [a,b,c] -> (a,b,c)) instance FunDefable (Syntax,Syntax,Syntax,Syntax) where funDefAttr pre post r n ts fn = funDefShared pre post r n ts fn (\ [a,b,c,d] -> (a,b,c,d)) instance FunDefable [Syntax] where funDefAttr pre post r n ts fn = funDefShared pre post r n ts fn id -- Terrible ugliness just to deal with those darn const qualifiers: funDef :: FunDefable args => Type -> Syntax -> [Type] -> (args -> EasyEmit ()) -> EasyEmit ObjFun constFunDef :: FunDefable args => Type -> Syntax -> [Type] -> (args -> EasyEmit ()) -> EasyEmit ObjFun inlineFunDef :: FunDefable args => Type -> Syntax -> [Type] -> (args -> EasyEmit ()) -> EasyEmit ObjFun funDef = funDefAttr "" "" constFunDef = funDefAttr "" "const" inlineFunDef = funDefAttr "inline" "" -- Internal helper function used above: funDefShared pre postqualifiers retty (Syn name) tyls fn formTup = do (ls,c) <- S.get --args <- mapM (forValueOnly . tmpvar) tyls -- Generate temp names only (emit nothing). args <- sequence$ take (length tyls) (repeat$ gensym "arg") -- Generate temp names only (emit nothing). let body = execEasyEmit (fn$ formTup args) formals = map (\ (t,a) -> cppType t <+> deSyn a) (zip tyls args) addChunk$ Syn$ hangbraces ((if pre P.== "" then empty else text (pre++" ")) <> cppType retty <+> name <> pcommasep formals <+> (text postqualifiers)) indent body -- addChunk$ "\n" return (\ args -> Syn$ name <> (pcommasep (map deSyn args))) -- This applies a C++ function referred to by name (defined elsewhere): function :: Syntax -> ObjFun function (Syn name) = \ args -> Syn$ name <> (pcommasep$ map deSyn args) -- Shortcut for applying a method given an object or object reference. methcall :: Syntax -> Syntax -> ObjFun methcall obj meth args = obj `dot` (function meth args) -- Common case: for loop over a range with integer index: ------------------------------------------------------------ -- Input is [Inclusive,Exclusive) range. forLoopSimple :: (Syntax,Syntax) -> (Syntax -> EasyEmit ()) -> EasyEmit () forLoopSimple (start,end) fn = do Syn var <- gensym "i" (ls,oldcnt) <- S.get let (_,newcnt,body) = rawRunEasyEmit oldcnt $ fn (Syn var) -- To maintain uniqueness we take the counter mods from the body. -- TODO: A cleaner way to do this would be to include the indent level in the state monad and NOT LEAVE IT. S.put (ls, newcnt) addChunk$ Syn$ hangbraces ("for " <> parens ( cppType TInt <+> var <+> "=" <+> deSyn start <> semi <+> var <+> "<" <+> deSyn end <> semi <+> var <> "++" )) indent $ body -- Helper used below: a <++> b | a P.== "" = b a <++> b | b P.== "" = a a <++> b = a <+> b -- This creates a class-decl-like pattern with a ':' -- It is parameterized by a little prefix which could be "class" or "struct" or anything else. -- Similarly, there's a postfix which is usually ";". classLike :: String -> String -> Syntax -> Syntax -> EasyEmit () -> EasyEmit () classLike prefix postfix (Syn name) (Syn inherits) m = do putD$ t prefix <++> hsep (if inherits P.== empty then [name] else [name <+> colon, inherits]) block m addChunkPrevLine$ strToSyn postfix -- | Takes: name, inheritance expression, and a body. cppClass :: Syntax -> Syntax -> EasyEmit () -> EasyEmit () cppClass = classLike "class" ";" -- | Takes: name, inheritance expression, and a body. cppStruct :: Syntax -> Syntax -> EasyEmit () -> EasyEmit () cppStruct = classLike "struct" ";" -- Arg list is (type,argname) and init list is (name,expression/value) cppConstructor :: Syntax -> [(Type,Syntax)] -> [(Syntax,Syntax)] -> EasyEmit () -> EasyEmit () cppConstructor (Syn name) args inits body = let fn (t,x) = pPrint t <+> deSyn x in classLike "" "" (Syn$ name <> parens (commasep$ map fn args)) (Syn$ commasep$ map (\ (a,b) -> deSyn a <> parens (deSyn b)) inits) body -- Constructor method prototypes just look like applications constructorPrototype :: Syntax -> [Syntax] -> EasyEmit () constructorPrototype name args = app (function name) args -- Curly-brace delimited, indented block: -- POSSIBLY INEFFICIENT! -- TODO: Implement this by tracking the indent level in the monad: block :: EasyEmit () -> EasyEmit () block m = do let body = execEasyEmit m addChunk "{" addChunk$ Syn$ nest indent body addChunk "}" ---------------------------------------------------------------------------------------------------- -- Overloaded booleans and predicates from Lennart Augustsson: ---------------------------------------------------------------------------------------------------- -- | Generalization of the 'Bool' type. Used by the generalized 'Eq' and 'Ord'. class Boolean bool where (&&) :: bool -> bool -> bool -- ^Logical conjunction. (||) :: bool -> bool -> bool -- ^Logical disjunction. not :: bool -> bool -- ^Locical negation. false :: bool -- ^Truth. true :: bool -- ^Falsity. fromBool :: Bool -> bool -- ^Convert a 'Bool' to the generalized Boolean type. fromBool b = if b then true else false -- Why not just make this part of the above class? -- | Generalization of the @if@ construct. --class (Boolean bool) => Conditional bool a where -- orig --class (Boolean bool) => Conditional bool where -- conditional :: bool -> a -> a -> a -- ^Pick the first argument if the 'Boolean' value is true, otherwise the second argument. --class (Boolean bool) => Eq a bool {- x | a -> bool -} where class (Boolean bool) => Eq a bool | a -> bool where (==) :: a -> a -> bool (/=) :: a -> a -> bool x /= y = not (x == y) x == y = not (x /= y) --class (Conditional bool Ordering, Eq a bool) => Ord a bool | a -> bool where --class (Conditional bool, Eq a bool) => Ord a bool | a -> bool where class (Boolean bool, Eq a bool) => Ord a bool | a -> bool where (<), (<=), (>), (>=) :: a -> a -> bool max, min :: a -> a -> a -- Need to define precedence because these new operations really have nothing to do with the originals: infix 4 ==, /=, <, <=, >=, > infixr 3 && infixr 2 || ---------------------------------------------------------------------------------------------------- -- Internal helpers: ---------------------------------------------------------------------------------------------------- ---------------------------------------------------------------------------------------------------- -- Testing: ---------------------------------------------------------------------------------------------------- t1 = cppClass "foo" "bar" $ comm "body" t2 = execEasyEmit$ funDef TInt "foo" [TInt] $ \(Syn y) -> do comm "Body" funDef TInt "nested" [] $ \ () -> comm "Inner body" return () ee_example :: EasyEmit () ee_example = do comm "\nFirst some global vars:\n " y <- tmpvar TInt x <- var TInt "x" bar <- funDef (TSym "void") "bar" [TInt, TInt] $ \ (z,q) -> do set y (z + q) comm "\nA function declaration:" foo <- funDef TInt "foo" [TInt] $ \y -> do x += (x + y * 3) x -= 4 ret x let baz = function "baz" quux = fromString "quux" app baz [quux, quux] forLoopSimple (0,10) $ \i -> do if_ (i == 10 || i > 100) (app foo [foo [i / 10]]) (app foo [i ? 3 .: 4]) -- cppClass "blah" $ do -- if_ (app f x) x x -- -- funDef "method" [TInt, TFloat] $ \(y,z) -> y + z ee_test1 = testCase "" "Code emission example"$ 391 ~=? (length$ render$ execEasyEmit ee_example) tests_easyemit = testSet "EasyEmit" [ee_test1]