{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Compile Copilot specifications to Bluespec code.
module Copilot.Compile.Bluespec.Compile
  ( compile
  , compileWith
  ) where

-- External imports
import Data.List                      (nub, union)
import Data.Maybe                     (catMaybes, maybeToList)
import Data.String                    (IsString (..))
import Data.Typeable                  (Typeable)
import qualified Language.Bluespec.Classic.AST as BS
import qualified Language.Bluespec.Classic.AST.Builtin.Ids as BS
import qualified Language.Bluespec.Classic.AST.Builtin.Types as BS
import Text.PrettyPrint.HughesPJClass (Pretty (..), render)
import System.Directory               (createDirectoryIfMissing)
import System.Exit                    (exitFailure)
import System.FilePath                ((</>))
import System.IO                      (hPutStrLn, stderr)

-- Internal imports: Copilot
import Copilot.Core

-- Internal imports
import Copilot.Compile.Bluespec.CodeGen
import Copilot.Compile.Bluespec.External
import Copilot.Compile.Bluespec.Name
import Copilot.Compile.Bluespec.Settings

-- | Compile a specification to a Bluespec file.
--
-- The first argument is the settings for the Bluespec code generated.
--
-- The second argument is used as a module name and the prefix for the .bs files
-- that are generated.
compileWith :: BluespecSettings -> String -> Spec -> IO ()
compileWith :: BluespecSettings -> [Char] -> Spec -> IO ()
compileWith BluespecSettings
bsSettings [Char]
prefix Spec
spec
  | [Trigger] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Spec -> [Trigger]
specTriggers Spec
spec)
  = do Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
         [Char]
"Copilot error: attempt at compiling empty specification.\n"
         [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"You must define at least one trigger to generate Bluespec monitors."
       IO ()
forall a. IO a
exitFailure

  | Bool
otherwise
  = do let typesBsFile :: [Char]
typesBsFile = Doc -> [Char]
render (Doc -> [Char]) -> Doc -> [Char]
forall a b. (a -> b) -> a -> b
$ CPackage -> Doc
forall a. Pretty a => a -> Doc
pPrint (CPackage -> Doc) -> CPackage -> Doc
forall a b. (a -> b) -> a -> b
$ BluespecSettings -> [Char] -> Spec -> CPackage
compileTypesBS BluespecSettings
bsSettings [Char]
prefix Spec
spec
           ifcBsFile :: [Char]
ifcBsFile   = Doc -> [Char]
render (Doc -> [Char]) -> Doc -> [Char]
forall a b. (a -> b) -> a -> b
$ CPackage -> Doc
forall a. Pretty a => a -> Doc
pPrint (CPackage -> Doc) -> CPackage -> Doc
forall a b. (a -> b) -> a -> b
$ BluespecSettings -> [Char] -> Spec -> CPackage
compileIfcBS   BluespecSettings
bsSettings [Char]
prefix Spec
spec
           bsFile :: [Char]
bsFile      = Doc -> [Char]
render (Doc -> [Char]) -> Doc -> [Char]
forall a b. (a -> b) -> a -> b
$ CPackage -> Doc
forall a. Pretty a => a -> Doc
pPrint (CPackage -> Doc) -> CPackage -> Doc
forall a b. (a -> b) -> a -> b
$ BluespecSettings -> [Char] -> Spec -> CPackage
compileBS      BluespecSettings
bsSettings [Char]
prefix Spec
spec

       let dir :: [Char]
dir = BluespecSettings -> [Char]
bluespecSettingsOutputDirectory BluespecSettings
bsSettings
       Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
dir
       [Char] -> [Char] -> IO ()
writeFile ([Char]
dir [Char] -> [Char] -> [Char]
</> [Char] -> [Char]
specTypesPkgName [Char]
prefix [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".bs") [Char]
typesBsFile
       [Char] -> [Char] -> IO ()
writeFile ([Char]
dir [Char] -> [Char] -> [Char]
</> [Char] -> [Char]
specIfcPkgName [Char]
prefix [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".bs") [Char]
ifcBsFile
       [Char] -> [Char] -> IO ()
writeFile ([Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
prefix [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".bs") [Char]
bsFile

-- | Compile a specification to a Bluespec.
--
-- The first argument is used as a prefix for the generated .bs files.
compile :: String -> Spec -> IO ()
compile :: [Char] -> Spec -> IO ()
compile = BluespecSettings -> [Char] -> Spec -> IO ()
compileWith BluespecSettings
mkDefaultBluespecSettings

-- | Generate a @<prefix>.bs@ file from a 'Spec'. This is the main payload of
-- the Bluespec backend.
--
-- The generated Bluespec file will import a handful of files from the standard
-- library, as well as the following generated files:
--
-- * @<prefix>Ifc.bs@, which defines the interface containing the trigger
--   functions and external variables.
--
-- * @<prefix>Types.bs@, which defines any structs used in the 'Spec'.
--
-- It will also generate a @mk<prefix> :: Module <prefix>Ifc -> Module Empty@
-- function, which defines the module structure for this 'Spec'. The
-- @mk<prefix>@ function has the following structure:
--
-- * First, bind the argument of type @Module <prefix>Ifc@ so that trigger
--   functions can be invoked and external variables can be used.
--
-- * Next, declare stream buffers and indices.
--
-- * Next, declare generator functions for streams, accessor functions for
--   streams, and guard functions for triggers.
--
-- * Next, declare rules for each trigger function.
--
-- * Finally, declare a single rule that updates the stream buffers and
--   indices.
compileBS :: BluespecSettings -> String -> Spec -> BS.CPackage
compileBS :: BluespecSettings -> [Char] -> Spec -> CPackage
compileBS BluespecSettings
_bsSettings [Char]
prefix Spec
spec =
    Id
-> Either [CExport] [CExport]
-> [CImport]
-> [CFixity]
-> [CDefn]
-> [CInclude]
-> CPackage
BS.CPackage
      (Position -> FString -> Id
BS.mkId Position
BS.NoPos ([Char] -> FString
forall a. IsString a => [Char] -> a
fromString [Char]
prefix))
      ([CExport] -> Either [CExport] [CExport]
forall a b. b -> Either a b
Right [])
      ([CImport]
stdLibImports [CImport] -> [CImport] -> [CImport]
forall a. [a] -> [a] -> [a]
++ [CImport]
genImports)
      []
      [CDefn
moduleDef]
      []
  where
    -- import <prefix>Types
    -- import <prefix>Ifc
    genImports :: [BS.CImport]
    genImports :: [CImport]
genImports =
      [ Bool -> Id -> CImport
BS.CImpId Bool
False (Id -> CImport) -> Id -> CImport
forall a b. (a -> b) -> a -> b
$ Position -> FString -> Id
BS.mkId Position
BS.NoPos (FString -> Id) -> FString -> Id
forall a b. (a -> b) -> a -> b
$ [Char] -> FString
forall a. IsString a => [Char] -> a
fromString
                        ([Char] -> FString) -> [Char] -> FString
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
specTypesPkgName [Char]
prefix
      , Bool -> Id -> CImport
BS.CImpId Bool
False (Id -> CImport) -> Id -> CImport
forall a b. (a -> b) -> a -> b
$ Position -> FString -> Id
BS.mkId Position
BS.NoPos (FString -> Id) -> FString -> Id
forall a b. (a -> b) -> a -> b
$ [Char] -> FString
forall a. IsString a => [Char] -> a
fromString
                        ([Char] -> FString) -> [Char] -> FString
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
specIfcPkgName [Char]
prefix
      ]

    moduleDef :: BS.CDefn
    moduleDef :: CDefn
moduleDef = CDef -> CDefn
BS.CValueSign (CDef -> CDefn) -> CDef -> CDefn
forall a b. (a -> b) -> a -> b
$
      Id -> CQType -> [CClause] -> CDef
BS.CDef
        (Position -> FString -> Id
BS.mkId Position
BS.NoPos (FString -> Id) -> FString -> Id
forall a b. (a -> b) -> a -> b
$ [Char] -> FString
forall a. IsString a => [Char] -> a
fromString ([Char] -> FString) -> [Char] -> FString
forall a b. (a -> b) -> a -> b
$ [Char]
"mk" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
prefix)
        -- :: Module <prefix>Ifc -> Module Empty
        ([CPred] -> CType -> CQType
BS.CQType
          []
          (CType
BS.tArrow
            CType -> CType -> CType
`BS.TAp` (CType
BS.tModule CType -> CType -> CType
`BS.TAp` CType
ifcTy)
            CType -> CType -> CType
`BS.TAp` (CType
BS.tModule CType -> CType -> CType
`BS.TAp` CType
emptyTy)))
        [ [CPat] -> [CQual] -> CExpr -> CClause
BS.CClause [Id -> CPat
BS.CPVar Id
ifcModId] [] (CExpr -> CClause) -> CExpr -> CClause
forall a b. (a -> b) -> a -> b
$
          Position -> [CMStmt] -> CExpr
BS.Cmodule Position
BS.NoPos ([CMStmt] -> CExpr) -> [CMStmt] -> CExpr
forall a b. (a -> b) -> a -> b
$
              CStmt -> CMStmt
BS.CMStmt
                (CPat -> Maybe CExpr -> [(Position, PProp)] -> CExpr -> CStmt
BS.CSBind (Id -> CPat
BS.CPVar Id
ifcArgId) Maybe CExpr
forall a. Maybe a
Nothing [] (Id -> CExpr
BS.CVar Id
ifcModId))
            CMStmt -> [CMStmt] -> [CMStmt]
forall a. a -> [a] -> [a]
: (CStmt -> CMStmt) -> [CStmt] -> [CMStmt]
forall a b. (a -> b) -> [a] -> [b]
map CStmt -> CMStmt
BS.CMStmt [CStmt]
mkGlobals [CMStmt] -> [CMStmt] -> [CMStmt]
forall a. [a] -> [a] -> [a]
++
            [ CStmt -> CMStmt
BS.CMStmt (CStmt -> CMStmt) -> CStmt -> CMStmt
forall a b. (a -> b) -> a -> b
$ [CDefl] -> CStmt
BS.CSletrec [CDefl]
genFuns
            , CExpr -> CMStmt
BS.CMrules (CExpr -> CMStmt) -> CExpr -> CMStmt
forall a b. (a -> b) -> a -> b
$ [CSchedulePragma] -> [CRule] -> CExpr
BS.Crules [] [CRule]
rules
            ]
        ]

    ifcArgId :: Id
ifcArgId = Position -> FString -> Id
BS.mkId Position
BS.NoPos (FString -> Id) -> FString -> Id
forall a b. (a -> b) -> a -> b
$ [Char] -> FString
forall a. IsString a => [Char] -> a
fromString [Char]
ifcArgName
    ifcModId :: Id
ifcModId = Position -> FString -> Id
BS.mkId Position
BS.NoPos FString
"ifcMod"

    rules :: [BS.CRule]
    rules :: [CRule]
rules = (Trigger -> CRule) -> [Trigger] -> [CRule]
forall a b. (a -> b) -> [a] -> [b]
map Trigger -> CRule
mkTriggerRule [Trigger]
triggers [CRule] -> [CRule] -> [CRule]
forall a. [a] -> [a] -> [a]
++ Maybe CRule -> [CRule]
forall a. Maybe a -> [a]
maybeToList ([Stream] -> Maybe CRule
mkStepRule [Stream]
streams)

    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

    ifcId :: Id
ifcId     = Position -> FString -> Id
BS.mkId Position
BS.NoPos (FString -> Id) -> FString -> Id
forall a b. (a -> b) -> a -> b
$ [Char] -> FString
forall a. IsString a => [Char] -> a
fromString ([Char] -> FString) -> [Char] -> FString
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
specIfcName [Char]
prefix
    ifcFields :: [CField]
ifcFields = [Trigger] -> [External] -> [CField]
mkSpecIfcFields [Trigger]
triggers [External]
exts
    ifcTy :: CType
ifcTy     = TyCon -> CType
BS.TCon (BS.TyCon
                  { tcon_name :: Id
BS.tcon_name = Id
ifcId
                  , tcon_kind :: Maybe Kind
BS.tcon_kind = Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
BS.KStar
                  , tcon_sort :: TISort
BS.tcon_sort = StructSubType -> [Id] -> TISort
BS.TIstruct
                                     ([IfcPragma] -> StructSubType
BS.SInterface [])
                                     ((CField -> Id) -> [CField] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map CField -> Id
BS.cf_name [CField]
ifcFields)
                  })

    emptyTy :: CType
emptyTy = TyCon -> CType
BS.TCon (BS.TyCon
                { tcon_name :: Id
BS.tcon_name = Id
BS.idEmpty
                , tcon_kind :: Maybe Kind
BS.tcon_kind = Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
BS.KStar
                , tcon_sort :: TISort
BS.tcon_sort = StructSubType -> [Id] -> TISort
BS.TIstruct ([IfcPragma] -> StructSubType
BS.SInterface []) []
                })

    -- Make buffer and index declarations for streams.
    mkGlobals :: [BS.CStmt]
    mkGlobals :: [CStmt]
mkGlobals = (Stream -> [CStmt]) -> [Stream] -> [CStmt]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Stream -> [CStmt]
buffDecln [Stream]
streams [CStmt] -> [CStmt] -> [CStmt]
forall a. [a] -> [a] -> [a]
++ (Stream -> CStmt) -> [Stream] -> [CStmt]
forall a b. (a -> b) -> [a] -> [b]
map Stream -> CStmt
indexDecln [Stream]
streams
      where
        buffDecln :: Stream -> [CStmt]
buffDecln  (Stream Id
sId [a]
buff Expr a
_ Type a
ty) = Id -> Type a -> [a] -> [CStmt]
forall a. Id -> Type a -> [a] -> [CStmt]
mkBuffDecln  Id
sId Type a
ty [a]
buff
        indexDecln :: Stream -> CStmt
indexDecln (Stream Id
sId [a]
_    Expr a
_ Type a
_ ) = Id -> CStmt
mkIndexDecln Id
sId

    -- Make generator functions, including trigger arguments.
    genFuns :: [BS.CDefl]
    genFuns :: [CDefl]
genFuns =  (Stream -> CDefl) -> [Stream] -> [CDefl]
forall a b. (a -> b) -> [a] -> [b]
map Stream -> CDefl
accessDecln [Stream]
streams
            [CDefl] -> [CDefl] -> [CDefl]
forall a. [a] -> [a] -> [a]
++ (Stream -> CDefl) -> [Stream] -> [CDefl]
forall a b. (a -> b) -> [a] -> [b]
map Stream -> CDefl
streamGen [Stream]
streams
            [CDefl] -> [CDefl] -> [CDefl]
forall a. [a] -> [a] -> [a]
++ (Trigger -> [CDefl]) -> [Trigger] -> [CDefl]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Trigger -> [CDefl]
triggerGen [Trigger]
triggers
      where
        accessDecln :: Stream -> BS.CDefl
        accessDecln :: Stream -> CDefl
accessDecln (Stream Id
sId [a]
buff Expr a
_ Type a
ty) = Id -> Type a -> [a] -> CDefl
forall a. Id -> Type a -> [a] -> CDefl
mkAccessDecln Id
sId Type a
ty [a]
buff

        streamGen :: Stream -> BS.CDefl
        streamGen :: Stream -> CDefl
streamGen (Stream Id
sId [a]
_ Expr a
expr Type a
ty) = [Char] -> Expr a -> Type a -> CDefl
forall a. [Char] -> Expr a -> Type a -> CDefl
mkGenFun (Id -> [Char]
generatorName Id
sId) Expr a
expr Type a
ty

        triggerGen :: Trigger -> [BS.CDefl]
        triggerGen :: Trigger -> [CDefl]
triggerGen (Trigger [Char]
name Expr Bool
guard [UExpr]
args) = CDefl
guardDef CDefl -> [CDefl] -> [CDefl]
forall a. a -> [a] -> [a]
: [CDefl]
argDefs
          where
            guardDef :: CDefl
guardDef = [Char] -> Expr Bool -> Type Bool -> CDefl
forall a. [Char] -> Expr a -> Type a -> CDefl
mkGenFun ([Char] -> [Char]
guardName [Char]
name) Expr Bool
guard Type Bool
Bool
            argDefs :: [CDefl]
argDefs  = (([Char], UExpr) -> CDefl) -> [([Char], UExpr)] -> [CDefl]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], UExpr) -> CDefl
argGen ([[Char]] -> [UExpr] -> [([Char], UExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Char] -> [[Char]]
argNames [Char]
name) [UExpr]
args)

            argGen :: (String, UExpr) -> BS.CDefl
            argGen :: ([Char], UExpr) -> CDefl
argGen ([Char]
argName, UExpr Type a
ty Expr a
expr) = [Char] -> Expr a -> Type a -> CDefl
forall a. [Char] -> Expr a -> Type a -> CDefl
mkGenFun [Char]
argName Expr a
expr Type a
ty

-- | Generate a @<prefix>Ifc.bs@ file from a 'Spec'. This contains the
-- definition of the @<prefix>Ifc@ interface, which declares the types of all
-- trigger functions and external variables. This is put in a separate file so
-- that larger applications can use it separately.
compileIfcBS :: BluespecSettings -> String -> Spec -> BS.CPackage
compileIfcBS :: BluespecSettings -> [Char] -> Spec -> CPackage
compileIfcBS BluespecSettings
_bsSettings [Char]
prefix Spec
spec =
    Id
-> Either [CExport] [CExport]
-> [CImport]
-> [CFixity]
-> [CDefn]
-> [CInclude]
-> CPackage
BS.CPackage
      Id
ifcPkgId
      ([CExport] -> Either [CExport] [CExport]
forall a b. b -> Either a b
Right [])
      ([CImport]
stdLibImports [CImport] -> [CImport] -> [CImport]
forall a. [a] -> [a] -> [a]
++ [CImport]
genImports)
      []
      [CDefn
ifcDef]
      []
  where
    -- import <prefix>Types
    genImports :: [BS.CImport]
    genImports :: [CImport]
genImports =
      [ Bool -> Id -> CImport
BS.CImpId Bool
False (Id -> CImport) -> Id -> CImport
forall a b. (a -> b) -> a -> b
$ Position -> FString -> Id
BS.mkId Position
BS.NoPos (FString -> Id) -> FString -> Id
forall a b. (a -> b) -> a -> b
$ [Char] -> FString
forall a. IsString a => [Char] -> a
fromString
                        ([Char] -> FString) -> [Char] -> FString
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
specTypesPkgName [Char]
prefix
      ]

    ifcId :: Id
ifcId     = Position -> FString -> Id
BS.mkId Position
BS.NoPos (FString -> Id) -> FString -> Id
forall a b. (a -> b) -> a -> b
$ [Char] -> FString
forall a. IsString a => [Char] -> a
fromString ([Char] -> FString) -> [Char] -> FString
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
specIfcName [Char]
prefix
    ifcPkgId :: Id
ifcPkgId  = Position -> FString -> Id
BS.mkId Position
BS.NoPos (FString -> Id) -> FString -> Id
forall a b. (a -> b) -> a -> b
$ [Char] -> FString
forall a. IsString a => [Char] -> a
fromString ([Char] -> FString) -> [Char] -> FString
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
specIfcPkgName [Char]
prefix
    ifcFields :: [CField]
ifcFields = [Trigger] -> [External] -> [CField]
mkSpecIfcFields [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

    ifcDef :: BS.CDefn
    ifcDef :: CDefn
ifcDef = Bool
-> StructSubType
-> IdK
-> [Id]
-> [CField]
-> [CTypeclass]
-> CDefn
BS.Cstruct
               Bool
True
               ([IfcPragma] -> StructSubType
BS.SInterface [])
               (Id -> IdK
BS.IdK Id
ifcId)
               [] -- No type variables
               [CField]
ifcFields
               [] -- No derived instances

-- | Generate a @<prefix>Types.bs@ file from a 'Spec'. This declares the types
-- of any structs used by the Copilot specification. This is put in a separate
-- file so that larger applications can more easily substitute their own struct
-- definitions if desired.
compileTypesBS :: BluespecSettings -> String -> Spec -> BS.CPackage
compileTypesBS :: BluespecSettings -> [Char] -> Spec -> CPackage
compileTypesBS BluespecSettings
_bsSettings [Char]
prefix Spec
spec =
    Id
-> Either [CExport] [CExport]
-> [CImport]
-> [CFixity]
-> [CDefn]
-> [CInclude]
-> CPackage
BS.CPackage
      Id
typesId
      ([CExport] -> Either [CExport] [CExport]
forall a b. b -> Either a b
Right [])
      [CImport]
stdLibImports
      []
      [CDefn]
structDefs
      []
  where
    typesId :: Id
typesId = Position -> FString -> Id
BS.mkId Position
BS.NoPos (FString -> Id) -> FString -> Id
forall a b. (a -> b) -> a -> b
$ [Char] -> FString
forall a. IsString a => [Char] -> a
fromString ([Char] -> FString) -> [Char] -> FString
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
specTypesPkgName [Char]
prefix

    structDefs :: [CDefn]
structDefs = [UExpr] -> [CDefn]
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] -> [BS.CDefn]
    mkTypeDeclns :: [UExpr] -> [CDefn]
mkTypeDeclns [UExpr]
es = [Maybe CDefn] -> [CDefn]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe CDefn] -> [CDefn]) -> [Maybe CDefn] -> [CDefn]
forall a b. (a -> b) -> a -> b
$ (UType -> Maybe CDefn) -> [UType] -> [Maybe CDefn]
forall a b. (a -> b) -> [a] -> [b]
map UType -> Maybe CDefn
mkTypeDecln [UType]
uTypes
      where
        uTypes :: [UType]
uTypes = [UType] -> [UType]
forall a. Eq a => [a] -> [a]
nub ([UType] -> [UType]) -> [UType] -> [UType]
forall a b. (a -> b) -> a -> b
$ (UExpr -> [UType]) -> [UExpr] -> [UType]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(UExpr Type a
_ Expr a
e) -> Expr a -> [UType]
forall a. Typeable a => Expr a -> [UType]
exprTypes Expr a
e) [UExpr]
es

        mkTypeDecln :: UType -> Maybe CDefn
mkTypeDecln (UType Type a
ty) = case Type a
ty of
          Struct a
x -> CDefn -> Maybe CDefn
forall a. a -> Maybe a
Just (CDefn -> Maybe CDefn) -> CDefn -> Maybe CDefn
forall a b. (a -> b) -> a -> b
$ a -> CDefn
forall a. Struct a => a -> CDefn
mkStructDecln a
x
          Type a
_        -> Maybe CDefn
forall a. Maybe a
Nothing

-- | Imports from the Bluespec standard library.
stdLibImports :: [BS.CImport]
stdLibImports :: [CImport]
stdLibImports =
  [ Bool -> Id -> CImport
BS.CImpId Bool
False (Id -> CImport) -> Id -> CImport
forall a b. (a -> b) -> a -> b
$ Position -> FString -> Id
BS.mkId Position
BS.NoPos FString
"FloatingPoint"
  , Bool -> Id -> CImport
BS.CImpId Bool
False (Id -> CImport) -> Id -> CImport
forall a b. (a -> b) -> a -> b
$ Position -> FString -> Id
BS.mkId Position
BS.NoPos FString
"Vector"
  ]

-- ** 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
_            -> Type a -> [UType]
forall a. Typeable a => Type a -> [UType]
typeTypes Type a
ty
  Local Type a1
ty1 Type a
ty2 [Char]
_ Expr a1
e1 Expr a
e2 -> Type a1 -> [UType]
forall a. Typeable a => Type a -> [UType]
typeTypes Type a1
ty1 [UType] -> [UType] -> [UType]
forall a. Eq a => [a] -> [a] -> [a]
`union` Type a -> [UType]
forall a. Typeable a => Type a -> [UType]
typeTypes Type a
ty2
                             [UType] -> [UType] -> [UType]
forall a. Eq a => [a] -> [a] -> [a]
`union` Expr a1 -> [UType]
forall a. Typeable a => Expr a -> [UType]
exprTypes Expr a1
e1 [UType] -> [UType] -> [UType]
forall a. Eq a => [a] -> [a] -> [a]
`union` Expr a -> [UType]
forall a. Typeable a => Expr a -> [UType]
exprTypes Expr a
e2
  Var Type a
ty [Char]
_              -> Type a -> [UType]
forall a. Typeable a => Type a -> [UType]
typeTypes Type a
ty
  Drop Type a
ty DropIdx
_ Id
_           -> Type a -> [UType]
forall a. Typeable a => Type a -> [UType]
typeTypes Type a
ty
  ExternVar Type a
ty [Char]
_ Maybe [a]
_      -> Type a -> [UType]
forall a. Typeable a => Type a -> [UType]
typeTypes Type a
ty
  Op1 Op1 a1 a
_ Expr a1
e1              -> Expr a1 -> [UType]
forall a. Typeable a => Expr a -> [UType]
exprTypes Expr a1
e1
  Op2 Op2 a1 b a
_ Expr a1
e1 Expr b
e2           -> Expr a1 -> [UType]
forall a. Typeable a => Expr a -> [UType]
exprTypes Expr a1
e1 [UType] -> [UType] -> [UType]
forall a. Eq a => [a] -> [a] -> [a]
`union` Expr b -> [UType]
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        -> Expr a1 -> [UType]
forall a. Typeable a => Expr a -> [UType]
exprTypes Expr a1
e1 [UType] -> [UType] -> [UType]
forall a. Eq a => [a] -> [a] -> [a]
`union` Expr b -> [UType]
forall a. Typeable a => Expr a -> [UType]
exprTypes Expr b
e2
                             [UType] -> [UType] -> [UType]
forall a. Eq a => [a] -> [a] -> [a]
`union` Expr c -> [UType]
forall a. Typeable a => Expr a -> [UType]
exprTypes Expr c
e3
  Label Type a
ty [Char]
_ Expr a
_          -> Type a -> [UType]
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' -> Type t -> [UType]
forall a. Typeable a => Type a -> [UType]
typeTypes Type t
ty' [UType] -> [UType] -> [UType]
forall a. Eq a => [a] -> [a] -> [a]
`union` [Type a -> UType
forall a. Typeable a => Type a -> UType
UType Type a
ty]
  Struct a
x  -> (Value a -> [UType]) -> [Value a] -> [UType]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Value Type t
ty' Field s t
_) -> Type t -> [UType]
forall a. Typeable a => Type a -> [UType]
typeTypes Type t
ty') (a -> [Value a]
forall a. Struct a => a -> [Value a]
toValues a
x)
                 [UType] -> [UType] -> [UType]
forall a. Eq a => [a] -> [a] -> [a]
`union` [Type a -> UType
forall a. Typeable a => Type a -> UType
UType Type a
ty]
  Type a
_         -> [Type a -> UType
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 =  (Stream -> UExpr) -> [Stream] -> [UExpr]
forall a b. (a -> b) -> [a] -> [b]
map Stream -> UExpr
streamUExpr [Stream]
streams
                             [UExpr] -> [UExpr] -> [UExpr]
forall a. [a] -> [a] -> [a]
++ (Trigger -> [UExpr]) -> [Trigger] -> [UExpr]
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)   = Type a -> Expr a -> UExpr
forall a. Typeable a => Type a -> Expr a -> UExpr
UExpr Type a
ty Expr a
expr
    triggerUExpr :: Trigger -> [UExpr]
triggerUExpr (Trigger [Char]
_ Expr Bool
guard [UExpr]
args) = Type Bool -> Expr Bool -> UExpr
forall a. Typeable a => Type a -> Expr a -> UExpr
UExpr Type Bool
Bool Expr Bool
guard UExpr -> [UExpr] -> [UExpr]
forall a. a -> [a] -> [a]
: [UExpr]
args