module Copilot.Compile.C99.Compile
( compile
, compileWith
) where
import Text.PrettyPrint (render)
import Data.List (nub)
import Data.Maybe (catMaybes)
import System.Directory (createDirectoryIfMissing)
import System.Exit (exitFailure)
import System.FilePath ((</>))
import System.IO (hPutStrLn, stderr)
import Language.C99.Pretty (pretty)
import qualified Language.C99.Simple as C
import Copilot.Core
import Copilot.Compile.C99.Util
import Copilot.Compile.C99.External
import Copilot.Compile.C99.Settings
import Copilot.Compile.C99.Translate
import Copilot.Compile.C99.CodeGen
compileWith :: CSettings -> String -> Spec -> IO ()
compileWith :: CSettings -> String -> Spec -> IO ()
compileWith CSettings
cSettings String
prefix Spec
spec
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Spec -> [Trigger]
specTriggers Spec
spec)
= do Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$
String
"Copilot error: attempt at compiling empty specification.\n"
forall a. [a] -> [a] -> [a]
++ String
"You must define at least one trigger to generate C monitors."
forall a. IO a
exitFailure
| Bool
otherwise
= do let cfile :: String
cfile = Doc -> String
render forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
pretty forall a b. (a -> b) -> a -> b
$ TransUnit -> TransUnit
C.translate forall a b. (a -> b) -> a -> b
$ CSettings -> Spec -> TransUnit
compilec CSettings
cSettings Spec
spec
hfile :: String
hfile = Doc -> String
render forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
pretty forall a b. (a -> b) -> a -> b
$ TransUnit -> TransUnit
C.translate forall a b. (a -> b) -> a -> b
$ CSettings -> Spec -> TransUnit
compileh CSettings
cSettings Spec
spec
typeDeclnsFile :: String
typeDeclnsFile = TransUnit -> String
safeCRender forall a b. (a -> b) -> a -> b
$ CSettings -> Spec -> TransUnit
compileTypeDeclns CSettings
cSettings Spec
spec
cmacros :: String
cmacros = [String] -> String
unlines [ String
"#include <stdint.h>"
, String
"#include <stdbool.h>"
, String
"#include <string.h>"
, String
"#include <stdlib.h>"
, String
"#include <math.h>"
, String
""
, String
"#include \"" forall a. [a] -> [a] -> [a]
++ String
prefix forall a. [a] -> [a] -> [a]
++ String
"_types.h\""
, String
"#include \"" forall a. [a] -> [a] -> [a]
++ String
prefix forall a. [a] -> [a] -> [a]
++ String
".h\""
, String
""
]
let dir :: String
dir = CSettings -> String
cSettingsOutputDirectory CSettings
cSettings
Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
dir
String -> String -> IO ()
writeFile (String
dir String -> String -> String
</> String
prefix forall a. [a] -> [a] -> [a]
++ String
".c") forall a b. (a -> b) -> a -> b
$ String
cmacros forall a. [a] -> [a] -> [a]
++ String
cfile
String -> String -> IO ()
writeFile (String
dir String -> String -> String
</> String
prefix forall a. [a] -> [a] -> [a]
++ String
".h") String
hfile
String -> String -> IO ()
writeFile (String
dir String -> String -> String
</> String
prefix forall a. [a] -> [a] -> [a]
++ String
"_types.h") String
typeDeclnsFile
compile :: String -> Spec -> IO ()
compile :: String -> Spec -> IO ()
compile = CSettings -> String -> Spec -> IO ()
compileWith CSettings
mkDefaultCSettings
compilec :: CSettings -> Spec -> C.TransUnit
compilec :: CSettings -> Spec -> TransUnit
compilec CSettings
cSettings Spec
spec = [Decln] -> [FunDef] -> TransUnit
C.TransUnit [Decln]
declns [FunDef]
funs
where
streams :: [Stream]
streams = Spec -> [Stream]
specStreams Spec
spec
triggers :: [Trigger]
triggers = Spec -> [Trigger]
specTriggers Spec
spec
exts :: [External]
exts = [Stream] -> [Trigger] -> [External]
gatherexts [Stream]
streams [Trigger]
triggers
declns :: [Decln]
declns = [External] -> [Decln]
mkexts [External]
exts forall a. [a] -> [a] -> [a]
++ [Stream] -> [Decln]
mkglobals [Stream]
streams
funs :: [FunDef]
funs = [Stream] -> [Trigger] -> [FunDef]
genfuns [Stream]
streams [Trigger]
triggers forall a. [a] -> [a] -> [a]
++ [CSettings -> [Stream] -> [Trigger] -> [External] -> FunDef
mkstep CSettings
cSettings [Stream]
streams [Trigger]
triggers [External]
exts]
mkexts :: [External] -> [C.Decln]
mkexts :: [External] -> [Decln]
mkexts [External]
exts = forall a b. (a -> b) -> [a] -> [b]
map External -> Decln
mkextcpydecln [External]
exts
mkglobals :: [Stream] -> [C.Decln]
mkglobals :: [Stream] -> [Decln]
mkglobals [Stream]
streams = forall a b. (a -> b) -> [a] -> [b]
map Stream -> Decln
buffdecln [Stream]
streams forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Stream -> Decln
indexdecln [Stream]
streams
where
buffdecln :: Stream -> Decln
buffdecln (Stream Id
sid [a]
buff Expr a
_ Type a
ty) = forall a. Id -> Type a -> [a] -> Decln
mkbuffdecln Id
sid Type a
ty [a]
buff
indexdecln :: Stream -> Decln
indexdecln (Stream Id
sid [a]
_ Expr a
_ Type a
_ ) = Id -> Decln
mkindexdecln Id
sid
genfuns :: [Stream] -> [Trigger] -> [C.FunDef]
genfuns :: [Stream] -> [Trigger] -> [FunDef]
genfuns [Stream]
streams [Trigger]
triggers = forall a b. (a -> b) -> [a] -> [b]
map Stream -> FunDef
accessdecln [Stream]
streams
forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Stream -> FunDef
streamgen [Stream]
streams
forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Trigger -> [FunDef]
triggergen [Trigger]
triggers
where
accessdecln :: Stream -> C.FunDef
accessdecln :: Stream -> FunDef
accessdecln (Stream Id
sid [a]
buff Expr a
_ Type a
ty) = forall a. Id -> Type a -> [a] -> FunDef
mkaccessdecln Id
sid Type a
ty [a]
buff
streamgen :: Stream -> C.FunDef
streamgen :: Stream -> FunDef
streamgen (Stream Id
sid [a]
_ Expr a
expr Type a
ty) = forall a. String -> Expr a -> Type a -> FunDef
genfun (Id -> String
generatorname Id
sid) Expr a
expr Type a
ty
triggergen :: Trigger -> [C.FunDef]
triggergen :: Trigger -> [FunDef]
triggergen (Trigger String
name Expr Bool
guard [UExpr]
args) = FunDef
guarddef forall a. a -> [a] -> [a]
: [FunDef]
argdefs
where
guarddef :: FunDef
guarddef = forall a. String -> Expr a -> Type a -> FunDef
genfun (String -> String
guardname String
name) Expr Bool
guard Type Bool
Bool
argdefs :: [FunDef]
argdefs = forall a b. (a -> b) -> [a] -> [b]
map (String, UExpr) -> FunDef
arggen (forall a b. [a] -> [b] -> [(a, b)]
zip (String -> [String]
argnames String
name) [UExpr]
args)
arggen :: (String, UExpr) -> C.FunDef
arggen :: (String, UExpr) -> FunDef
arggen (String
argname, UExpr Type a
ty Expr a
expr) = forall a. String -> Expr a -> Type a -> FunDef
genfun String
argname Expr a
expr Type a
ty
compileh :: CSettings -> Spec -> C.TransUnit
compileh :: CSettings -> Spec -> TransUnit
compileh CSettings
cSettings Spec
spec = [Decln] -> [FunDef] -> TransUnit
C.TransUnit [Decln]
declns []
where
streams :: [Stream]
streams = Spec -> [Stream]
specStreams Spec
spec
triggers :: [Trigger]
triggers = Spec -> [Trigger]
specTriggers Spec
spec
exts :: [External]
exts = [Stream] -> [Trigger] -> [External]
gatherexts [Stream]
streams [Trigger]
triggers
exprs :: [UExpr]
exprs = [Stream] -> [Trigger] -> [UExpr]
gatherexprs [Stream]
streams [Trigger]
triggers
declns :: [Decln]
declns = [UExpr] -> [Decln]
mkstructforwdeclns [UExpr]
exprs
forall a. [a] -> [a] -> [a]
++ [External] -> [Decln]
mkexts [External]
exts
forall a. [a] -> [a] -> [a]
++ [Trigger] -> [Decln]
extfundeclns [Trigger]
triggers
forall a. [a] -> [a] -> [a]
++ [Decln
stepdecln]
mkstructforwdeclns :: [UExpr] -> [C.Decln]
mkstructforwdeclns :: [UExpr] -> [Decln]
mkstructforwdeclns [UExpr]
es = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map UType -> Maybe Decln
mkdecln [UType]
utypes
where
mkdecln :: UType -> Maybe Decln
mkdecln (UType Type a
ty) = case Type a
ty of
Struct a
x -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Struct a => Type a -> Decln
mkstructforwdecln Type a
ty
Type a
_ -> forall a. Maybe a
Nothing
utypes :: [UType]
utypes = forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(UExpr Type a
_ Expr a
e) -> forall a. Typeable a => Expr a -> [UType]
exprtypes Expr a
e) [UExpr]
es
mkexts :: [External] -> [C.Decln]
mkexts :: [External] -> [Decln]
mkexts = forall a b. (a -> b) -> [a] -> [b]
map External -> Decln
mkextdecln
extfundeclns :: [Trigger] -> [C.Decln]
extfundeclns :: [Trigger] -> [Decln]
extfundeclns [Trigger]
triggers = forall a b. (a -> b) -> [a] -> [b]
map Trigger -> Decln
extfundecln [Trigger]
triggers
where
extfundecln :: Trigger -> C.Decln
extfundecln :: Trigger -> Decln
extfundecln (Trigger String
name Expr Bool
_ [UExpr]
args) = Maybe StorageSpec -> Type -> String -> [Param] -> Decln
C.FunDecln forall a. Maybe a
Nothing Type
cty String
name [Param]
params
where
cty :: Type
cty = TypeSpec -> Type
C.TypeSpec TypeSpec
C.Void
params :: [Param]
params = forall a b. (a -> b) -> [a] -> [b]
map (String, UExpr) -> Param
mkparam forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (String -> [String]
argnames String
name) [UExpr]
args
mkparam :: (String, UExpr) -> Param
mkparam (String
name, UExpr Type a
ty Expr a
_) = Type -> String -> Param
C.Param (forall {a}. Type a -> Type
mkParamTy Type a
ty) String
name
mkParamTy :: Type a -> Type
mkParamTy Type a
ty =
case Type a
ty of
Struct a
_ -> Type -> Type
C.Ptr (forall {a}. Type a -> Type
transtype Type a
ty)
Type a
_ -> forall {a}. Type a -> Type
transtype Type a
ty
stepdecln :: C.Decln
stepdecln :: Decln
stepdecln = Maybe StorageSpec -> Type -> String -> [Param] -> Decln
C.FunDecln forall a. Maybe a
Nothing (TypeSpec -> Type
C.TypeSpec TypeSpec
C.Void)
(CSettings -> String
cSettingsStepFunctionName CSettings
cSettings) []
compileTypeDeclns :: CSettings -> Spec -> C.TransUnit
compileTypeDeclns :: CSettings -> Spec -> TransUnit
compileTypeDeclns CSettings
_cSettings Spec
spec = [Decln] -> [FunDef] -> TransUnit
C.TransUnit [Decln]
declns []
where
declns :: [Decln]
declns = [UExpr] -> [Decln]
mkTypeDeclns [UExpr]
exprs
exprs :: [UExpr]
exprs = [Stream] -> [Trigger] -> [UExpr]
gatherexprs [Stream]
streams [Trigger]
triggers
streams :: [Stream]
streams = Spec -> [Stream]
specStreams Spec
spec
triggers :: [Trigger]
triggers = Spec -> [Trigger]
specTriggers Spec
spec
mkTypeDeclns :: [UExpr] -> [C.Decln]
mkTypeDeclns :: [UExpr] -> [Decln]
mkTypeDeclns [UExpr]
es = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map UType -> Maybe Decln
mkTypeDecln [UType]
uTypes
where
uTypes :: [UType]
uTypes = forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(UExpr Type a
_ Expr a
e) -> forall a. Typeable a => Expr a -> [UType]
exprtypes Expr a
e) [UExpr]
es
mkTypeDecln :: UType -> Maybe Decln
mkTypeDecln (UType Type a
ty) = case Type a
ty of
Struct a
_ -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Struct a => Type a -> Decln
mkstructdecln Type a
ty
Type a
_ -> forall a. Maybe a
Nothing
safeCRender :: C.TransUnit -> String
safeCRender :: TransUnit -> String
safeCRender (C.TransUnit [] []) = String
""
safeCRender TransUnit
transUnit = Doc -> String
render forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
pretty forall a b. (a -> b) -> a -> b
$ TransUnit -> TransUnit
C.translate TransUnit
transUnit