{-# LANGUAGE GADTs #-}
-- | Compile Copilot specifications to C99 code.
module Copilot.Compile.C99.Compile
  ( compile
  , compileWith
  ) where

-- External imports
import           Data.List           ( nub, union )
import           Data.Maybe          ( mapMaybe )
import           Data.Typeable       ( Typeable )
import           Language.C99.Pretty ( pretty )
import qualified Language.C99.Simple as C
import           System.Directory    ( createDirectoryIfMissing )
import           System.Exit         ( exitFailure )
import           System.FilePath     ( (</>) )
import           System.IO           ( hPutStrLn, stderr )
import           Text.PrettyPrint    ( render )

-- Internal imports: Copilot
import Copilot.Core ( Expr (..), Spec (..), Stream (..), Struct (..),
                      Trigger (..), Type (..), UExpr (..), UType (..),
                      Value (..) )

-- Internal imports
import Copilot.Compile.C99.CodeGen  ( mkAccessDecln, mkBuffDecln, mkExtCpyDecln,
                                      mkExtDecln, mkGenFun, mkGenFunArray,
                                      mkIndexDecln, mkStep, mkStructDecln,
                                      mkStructForwDecln )
import Copilot.Compile.C99.External ( External, gatherExts )
import Copilot.Compile.C99.Name     ( argNames, generatorName,
                                      generatorOutputArgName, guardName )
import Copilot.Compile.C99.Settings ( CSettings, cSettingsOutputDirectory,
                                      cSettingsStepFunctionName,
                                      mkDefaultCSettings )
import Copilot.Compile.C99.Type     ( transType )

-- | Compile a specification to a .h and a .c file.
--
-- The first argument is the settings for the C code generated.
--
-- The second argument is used as prefix for the .h and .c files generated.
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 a specification to a .h and a .c file.
--
-- The first argument is used as prefix for the .h and .c files generated.
compile :: String -> Spec -> IO ()
compile :: String -> Spec -> IO ()
compile = CSettings -> String -> Spec -> IO ()
compileWith CSettings
mkDefaultCSettings

-- | Generate the .c file from a 'Spec'.
--
-- The generated C file has the following structure:
--
-- * Include .h file.
-- * Declarations of global buffers and indices.
-- * Generator functions for streams, guards and trigger arguments.
-- * Declaration of the @step()@ function.
compileC :: CSettings -> Spec -> C.TransUnit
compileC :: CSettings -> Spec -> TransUnit
compileC CSettings
cSettings Spec
spec = [Decln] -> [FunDef] -> TransUnit
C.TransUnit [Decln]
declns [FunDef]
funs
  where
    declns :: [Decln]
declns =  [External] -> [Decln]
mkExts [External]
exts
           forall a. [a] -> [a] -> [a]
++ [Stream] -> [Decln]
mkGlobals [Stream]
streams

    funs :: [FunDef]
funs =  [Stream] -> [Trigger] -> [FunDef]
mkGenFuns [Stream]
streams [Trigger]
triggers
         forall a. [a] -> [a] -> [a]
++ [CSettings -> [Stream] -> [Trigger] -> [External] -> FunDef
mkStep CSettings
cSettings [Stream]
streams [Trigger]
triggers [External]
exts]

    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

    -- Make declarations for copies of external variables.
    mkExts :: [External] -> [C.Decln]
    mkExts :: [External] -> [Decln]
mkExts = forall a b. (a -> b) -> [a] -> [b]
map External -> Decln
mkExtCpyDecln

    -- Make buffer and index declarations for streams.
    mkGlobals :: [Stream] -> [C.Decln]
    mkGlobals :: [Stream] -> [Decln]
mkGlobals [Stream]
streamList =  forall a b. (a -> b) -> [a] -> [b]
map Stream -> Decln
buffDecln [Stream]
streamList
                         forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Stream -> Decln
indexDecln [Stream]
streamList
      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

    -- Make generator functions, including trigger arguments.
    mkGenFuns :: [Stream] -> [Trigger] -> [C.FunDef]
    mkGenFuns :: [Stream] -> [Trigger] -> [FunDef]
mkGenFuns [Stream]
streamList [Trigger]
triggerList =  forall a b. (a -> b) -> [a] -> [b]
map Stream -> FunDef
accessDecln [Stream]
streamList
                                     forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Stream -> FunDef
streamGen [Stream]
streamList
                                     forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Trigger -> [FunDef]
triggerGen [Trigger]
triggerList
      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 ty :: Type a
ty@(Array Type t
_)) =
          forall a. String -> String -> Expr a -> Type a -> FunDef
mkGenFunArray (Id -> String
generatorName Id
sId) (Id -> String
generatorOutputArgName Id
sId) Expr a
expr Type a
ty
        streamGen (Stream Id
sId [a]
_ Expr a
expr Type a
ty) = forall a. String -> Expr a -> Type a -> FunDef
mkGenFun (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
mkGenFun (String -> String
guardName String
name) Expr Bool
guard Type Bool
Bool
            argDefs :: [FunDef]
argDefs  = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> UExpr -> FunDef
argGen (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
mkGenFun String
argName Expr a
expr Type a
ty

-- | Generate the .h file from a 'Spec'.
compileH :: CSettings -> Spec -> C.TransUnit
compileH :: CSettings -> Spec -> TransUnit
compileH CSettings
cSettings Spec
spec = [Decln] -> [FunDef] -> TransUnit
C.TransUnit [Decln]
declns []
  where
    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]

    exprs :: [UExpr]
exprs    = [Stream] -> [Trigger] -> [UExpr]
gatherExprs [Stream]
streams [Trigger]
triggers
    exts :: [External]
exts     = [Stream] -> [Trigger] -> [External]
gatherExts [Stream]
streams [Trigger]
triggers
    streams :: [Stream]
streams  = Spec -> [Stream]
specStreams Spec
spec
    triggers :: [Trigger]
triggers = Spec -> [Trigger]
specTriggers Spec
spec

    mkStructForwDeclns :: [UExpr] -> [C.Decln]
    mkStructForwDeclns :: [UExpr] -> [Decln]
mkStructForwDeclns [UExpr]
es = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe UType -> Maybe Decln
mkDecln [UType]
uTypes
      where
        mkDecln :: UType -> Maybe Decln
mkDecln (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
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

    -- Make declarations for external variables.
    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 = forall a b. (a -> b) -> [a] -> [b]
map Trigger -> Decln
extFunDecln
      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 c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> UExpr -> Param
mkParam (String -> [String]
argNames String
name) [UExpr]
args

            mkParam :: String -> UExpr -> Param
mkParam String
paramName (UExpr Type a
ty Expr a
_) = Type -> String -> Param
C.Param (forall {a}. Type a -> Type
mkParamTy Type a
ty) String
paramName

            -- Special case for Struct, to pass struct arguments by reference.
            -- Arrays are also passed by reference, but using C's array type
            -- does that automatically.
            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

    -- Declaration for the step function.
    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) []

-- | Generate a C translation unit that contains all type declarations needed
-- by the Copilot specification.
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

    -- Generate type declarations.
    mkTypeDeclns :: [UExpr] -> [C.Decln]
    mkTypeDeclns :: [UExpr] -> [Decln]
mkTypeDeclns [UExpr]
es = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe 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

-- * Auxiliary definitions

-- | Render a C.TransUnit to a String, accounting for the case in which the
-- translation unit is empty.
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

-- ** Obtain information from Copilot Core Exprs and Types.

-- | List all types of an expression, returns items uniquely.
exprTypes :: Typeable a => Expr a -> [UType]
exprTypes :: forall a. Typeable a => Expr a -> [UType]
exprTypes Expr a
e = case Expr a
e of
  Const Type a
ty a
_            -> forall a. Typeable a => Type a -> [UType]
typeTypes Type a
ty
  Local Type a1
ty1 Type a
ty2 String
_ Expr a1
e1 Expr a
e2 -> forall a. Typeable a => Type a -> [UType]
typeTypes Type a1
ty1 forall a. Eq a => [a] -> [a] -> [a]
`union` forall a. Typeable a => Type a -> [UType]
typeTypes Type a
ty2
                             forall a. Eq a => [a] -> [a] -> [a]
`union` forall a. Typeable a => Expr a -> [UType]
exprTypes Expr a1
e1 forall a. Eq a => [a] -> [a] -> [a]
`union` forall a. Typeable a => Expr a -> [UType]
exprTypes Expr a
e2
  Var Type a
ty String
_              -> forall a. Typeable a => Type a -> [UType]
typeTypes Type a
ty
  Drop Type a
ty DropIdx
_ Id
_           -> forall a. Typeable a => Type a -> [UType]
typeTypes Type a
ty
  ExternVar Type a
ty String
_ Maybe [a]
_      -> forall a. Typeable a => Type a -> [UType]
typeTypes Type a
ty
  Op1 Op1 a1 a
_ Expr a1
e1              -> forall a. Typeable a => Expr a -> [UType]
exprTypes Expr a1
e1
  Op2 Op2 a1 b a
_ Expr a1
e1 Expr b
e2           -> forall a. Typeable a => Expr a -> [UType]
exprTypes Expr a1
e1 forall a. Eq a => [a] -> [a] -> [a]
`union` forall a. Typeable a => Expr a -> [UType]
exprTypes Expr b
e2
  Op3 Op3 a1 b c a
_ Expr a1
e1 Expr b
e2 Expr c
e3        -> forall a. Typeable a => Expr a -> [UType]
exprTypes Expr a1
e1 forall a. Eq a => [a] -> [a] -> [a]
`union` forall a. Typeable a => Expr a -> [UType]
exprTypes Expr b
e2
                             forall a. Eq a => [a] -> [a] -> [a]
`union` forall a. Typeable a => Expr a -> [UType]
exprTypes Expr c
e3
  Label Type a
ty String
_ Expr a
_          -> forall a. Typeable a => Type a -> [UType]
typeTypes Type a
ty

-- | List all types of a type, returns items uniquely.
typeTypes :: Typeable a => Type a -> [UType]
typeTypes :: forall a. Typeable a => Type a -> [UType]
typeTypes Type a
ty = case Type a
ty of
  Array Type t
ty' -> forall a. Typeable a => Type a -> [UType]
typeTypes Type t
ty' forall a. Eq a => [a] -> [a] -> [a]
`union` [forall a. Typeable a => Type a -> UType
UType Type a
ty]
  Struct a
x  -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Value Type t
ty' Field s t
_) -> forall a. Typeable a => Type a -> [UType]
typeTypes Type t
ty') (forall a. Struct a => a -> [Value a]
toValues a
x)
                 forall a. Eq a => [a] -> [a] -> [a]
`union` [forall a. Typeable a => Type a -> UType
UType Type a
ty]
  Type a
_         -> [forall a. Typeable a => Type a -> UType
UType Type a
ty]

-- | Collect all expression of a list of streams and triggers and wrap them
-- into an UEXpr.
gatherExprs :: [Stream] -> [Trigger] -> [UExpr]
gatherExprs :: [Stream] -> [Trigger] -> [UExpr]
gatherExprs [Stream]
streams [Trigger]
triggers =  forall a b. (a -> b) -> [a] -> [b]
map Stream -> UExpr
streamUExpr [Stream]
streams
                             forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Trigger -> [UExpr]
triggerUExpr [Trigger]
triggers
  where
    streamUExpr :: Stream -> UExpr
streamUExpr  (Stream Id
_ [a]
_ Expr a
expr Type a
ty)   = forall a. Typeable a => Type a -> Expr a -> UExpr
UExpr Type a
ty Expr a
expr
    triggerUExpr :: Trigger -> [UExpr]
triggerUExpr (Trigger String
_ Expr Bool
guard [UExpr]
args) = forall a. Typeable a => Type a -> Expr a -> UExpr
UExpr Type Bool
Bool Expr Bool
guard forall a. a -> [a] -> [a]
: [UExpr]
args