-- | Compile Copilot specifications to C99 code.
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

-- | 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
    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]

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

    -- Make buffer and index declarations for streams.
    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

    -- Make generator functions, including trigger arguments.
    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

-- | 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
    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

    -- 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 [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

            -- 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. [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

-- * 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