{-# LANGUAGE RecordWildCards, OverloadedStrings, ViewPatterns #-}
{-# LANGUAGE TemplateHaskell, CPP #-}
module Clash.Clashilator (generateFiles) where

import Clash.Driver.Manifest

import Control.Monad (forM_)
import Data.List (partition)

import System.FilePath

import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Development.Shake (writeFileChanged)

import Text.Mustache
import qualified Text.Mustache.Compile.TH as TH
import Data.Aeson hiding (Options)
#if MIN_VERSION_aeson(2, 0, 0)
import qualified Data.Aeson.KeyMap as Aeson
#else
import qualified Data.HashMap.Strict as Aeson
#endif

data Port = Port Text Int
    deriving Int -> Port -> ShowS
[Port] -> ShowS
Port -> String
(Int -> Port -> ShowS)
-> (Port -> String) -> ([Port] -> ShowS) -> Show Port
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Port] -> ShowS
$cshowList :: [Port] -> ShowS
show :: Port -> String
$cshow :: Port -> String
showsPrec :: Int -> Port -> ShowS
$cshowsPrec :: Int -> Port -> ShowS
Show

data FFIType
    = FFIBit
    | FFIU8
    | FFIU16
    | FFIU32
    | FFIU64

ffiType :: Int -> FFIType
ffiType :: Int -> FFIType
ffiType Int
1 = FFIType
FFIBit
ffiType Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
8 = FFIType
FFIU8
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
16 = FFIType
FFIU16
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
32 = FFIType
FFIU32
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
64 = FFIType
FFIU64
  | Bool
otherwise = String -> FFIType
forall a. HasCallStack => String -> a
error (String -> FFIType) -> String -> FFIType
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"ffiType:", Int -> String
forall a. Show a => a -> String
show Int
n]

cType :: FFIType -> Text
cType :: FFIType -> Text
cType FFIType
FFIBit = Text
"bit"
cType FFIType
FFIU8 = Text
"uint8_t"
cType FFIType
FFIU16 = Text
"uint16_t"
cType FFIType
FFIU32 = Text
"uint32_t"
cType FFIType
FFIU64 = Text
"uint64_t"

hsType :: FFIType -> Text
hsType :: FFIType -> Text
hsType FFIType
FFIBit = Text
"Bit"
hsType FFIType
FFIU8 = Text
"Word8"
hsType FFIType
FFIU16 = Text
"Word16"
hsType FFIType
FFIU32 = Text
"Word32"
hsType FFIType
FFIU64 = Text
"Word64"

cName :: Text -> Text
cName :: Text -> Text
cName = Text -> Text
forall a. a -> a
id

hsName :: Text -> Text -> Text
hsName :: Text -> Text -> Text
hsName Text
tag Text
s = Text
tag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s

getClockAndInPorts :: Maybe Text -> [ManifestPort] -> (Maybe Text, [Port])
getClockAndInPorts :: Maybe Text -> [ManifestPort] -> (Maybe Text, [Port])
getClockAndInPorts Maybe Text
clkName [ManifestPort]
inPorts = (Maybe Text
clk, [ Text -> Int -> Port
Port Text
mpName Int
mpWidth | ManifestPort{Bool
Int
Maybe Text
Text
PortDirection
mpName :: ManifestPort -> Text
mpTypeName :: ManifestPort -> Text
mpDirection :: ManifestPort -> PortDirection
mpWidth :: ManifestPort -> Int
mpIsClock :: ManifestPort -> Bool
mpDomain :: ManifestPort -> Maybe Text
mpDomain :: Maybe Text
mpIsClock :: Bool
mpDirection :: PortDirection
mpTypeName :: Text
mpWidth :: Int
mpName :: Text
..} <- [ManifestPort]
inPorts' ])
  where
    ((ManifestPort -> Text) -> [ManifestPort] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ManifestPort -> Text
mpName -> [Text]
clks, [ManifestPort]
inPorts') = (ManifestPort -> Bool)
-> [ManifestPort] -> ([ManifestPort], [ManifestPort])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ManifestPort -> Bool
mpIsClock [ManifestPort]
inPorts
    clk :: Maybe Text
clk = case (Maybe Text
clkName, [Text]
clks) of
        (Just Text
clkName, [Text]
clks) | Text
clkName Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
clks -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
clkName
        (Maybe Text
Nothing, [Text
clk]) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
clk
        (Maybe Text, [Text])
_ -> Maybe Text
forall a. Maybe a
Nothing

portInfo :: Text -> Port -> Value
portInfo :: Text -> Port -> Value
portInfo Text
tag (Port Text
name Int
width) = [Pair] -> Value
object
    [ Key
"cName" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Text
cName Text
name
    , Key
"cType" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= FFIType -> Text
cType FFIType
ty
    , Key
"hsName" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Text -> Text
hsName Text
tag Text
name
    , Key
"hsType" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= FFIType -> Text
hsType FFIType
ty
    ]
  where
    ty :: FFIType
ty = Int -> FFIType
ffiType Int
width

manifestInfo :: Maybe String -> FilePath -> FilePath -> Maybe Text -> Manifest -> Value
manifestInfo :: Maybe String -> String -> String -> Maybe Text -> Manifest -> Value
manifestInfo Maybe String
cflags String
srcDir String
outputDir Maybe Text
clkName Manifest{[(String, ByteString)]
[Text]
[ManifestPort]
(Int, Int)
ByteString
Text
HashMap Text VDomainConfiguration
manifestHash :: Manifest -> ByteString
successFlags :: Manifest -> (Int, Int)
ports :: Manifest -> [ManifestPort]
componentNames :: Manifest -> [Text]
topComponent :: Manifest -> Text
fileNames :: Manifest -> [(String, ByteString)]
domains :: Manifest -> HashMap Text VDomainConfiguration
transitiveDependencies :: Manifest -> [Text]
transitiveDependencies :: [Text]
domains :: HashMap Text VDomainConfiguration
fileNames :: [(String, ByteString)]
topComponent :: Text
componentNames :: [Text]
ports :: [ManifestPort]
successFlags :: (Int, Int)
manifestHash :: ByteString
..} = [Pair] -> Value
object
    [ Key
"inPorts"      Key -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ([Value] -> [Value]
markEnds ([Value] -> [Value]) -> [Value] -> [Value]
forall a b. (a -> b) -> a -> b
$ (Port -> Value) -> [Port] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Port -> Value
portInfo Text
"i") [Port]
ins)
    , Key
"outPorts"     Key -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ([Value] -> [Value]
markEnds ([Value] -> [Value]) -> [Value] -> [Value]
forall a b. (a -> b) -> a -> b
$ (Port -> Value) -> [Port] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Port -> Value
portInfo Text
"o") [Port]
outs)
    , Key
"clock"        Key -> Maybe Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text -> Value) -> Maybe Text -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Text
clock -> [Pair] -> Value
object [Key
"cName" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Text
cName Text
clock]) Maybe Text
clock
    , Key
"hdlDir"       Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
srcDir
    , Key
"srcs"         Key -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [ [Pair] -> Value
object [Key
"verilogPath" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String -> Text
TL.pack (String
srcDir String -> ShowS
</> Text -> String
T.unpack Text
component String -> ShowS
<.> String
"v")]
                        | Text
component <- [Text]
componentNames
                        ]
    , Key
"verilator"    Key -> Maybe Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (String -> Value) -> Maybe String -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\String
cflags -> [Pair] -> Value
object [ Key
"cflags" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Text
TL.strip (String -> Text
TL.pack String
cflags) ]) Maybe String
cflags
    , Key
"outputDir"    Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
outputDir
    ]
  where
#if MIN_VERSION_clash_lib(1, 6, 0)
    inPorts :: [ManifestPort]
inPorts = [ ManifestPort
port | port :: ManifestPort
port@ManifestPort{Bool
Int
Maybe Text
Text
PortDirection
mpDomain :: Maybe Text
mpIsClock :: Bool
mpWidth :: Int
mpDirection :: PortDirection
mpTypeName :: Text
mpName :: Text
mpName :: ManifestPort -> Text
mpTypeName :: ManifestPort -> Text
mpDirection :: ManifestPort -> PortDirection
mpWidth :: ManifestPort -> Int
mpIsClock :: ManifestPort -> Bool
mpDomain :: ManifestPort -> Maybe Text
..} <- [ManifestPort]
ports, PortDirection
mpDirection PortDirection -> [PortDirection] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PortDirection
In, PortDirection
InOut] ]
    outPorts :: [ManifestPort]
outPorts = [ ManifestPort
port | port :: ManifestPort
port@ManifestPort{Bool
Int
Maybe Text
Text
PortDirection
mpDomain :: Maybe Text
mpIsClock :: Bool
mpWidth :: Int
mpDirection :: PortDirection
mpTypeName :: Text
mpName :: Text
mpName :: ManifestPort -> Text
mpTypeName :: ManifestPort -> Text
mpDirection :: ManifestPort -> PortDirection
mpWidth :: ManifestPort -> Int
mpIsClock :: ManifestPort -> Bool
mpDomain :: ManifestPort -> Maybe Text
..} <- [ManifestPort]
ports, PortDirection
mpDirection PortDirection -> [PortDirection] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PortDirection
InOut, PortDirection
Out] ]
#endif

    (Maybe Text
clock, [Port]
ins) = Maybe Text -> [ManifestPort] -> (Maybe Text, [Port])
getClockAndInPorts Maybe Text
clkName [ManifestPort]
inPorts
    outs :: [Port]
outs = [ Text -> Int -> Port
Port Text
mpName Int
mpWidth | ManifestPort{Bool
Int
Maybe Text
Text
PortDirection
mpDomain :: Maybe Text
mpIsClock :: Bool
mpDirection :: PortDirection
mpTypeName :: Text
mpWidth :: Int
mpName :: Text
mpName :: ManifestPort -> Text
mpTypeName :: ManifestPort -> Text
mpDirection :: ManifestPort -> PortDirection
mpWidth :: ManifestPort -> Int
mpIsClock :: ManifestPort -> Bool
mpDomain :: ManifestPort -> Maybe Text
..} <- [ManifestPort]
outPorts ]

markEnds :: [Value] -> [Value]
markEnds :: [Value] -> [Value]
markEnds [] = []
markEnds (Value
v:[Value]
vs) = Value -> Value
markStart Value
v Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
: [Value]
vs
  where
    markStart :: Value -> Value
markStart (Object Object
o) = Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Object
o Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
<> [Pair] -> Object
forall v. [(Key, v)] -> KeyMap v
Aeson.fromList [ Key
"first" Key -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
True ]

templates :: [(String, Template)]
templates =
    [ (String
"src/Interface.h", $(TH.compileMustacheFile "template/Interface.h.mustache"))
    , (String
"src/Impl.cpp", $(TH.compileMustacheFile "template/Impl.cpp.mustache"))
    , (String
"src/Impl.h", $(TH.compileMustacheFile "template/Impl.h.mustache"))
    , (String
"Makefile",  $(TH.compileMustacheFile "template/Makefile.mustache"))
    , (String
"src/Clash/Clashilator/FFI.hsc", $(TH.compileMustacheFile "template/FFI.hsc.mustache"))
    ]

generateFiles :: Maybe String -> FilePath -> FilePath -> Maybe Text -> Manifest -> IO ()
generateFiles :: Maybe String -> String -> String -> Maybe Text -> Manifest -> IO ()
generateFiles Maybe String
cflags String
inputDir String
outputDir Maybe Text
clkName Manifest
manifest = do
    let vals :: Value
vals = Maybe String -> String -> String -> Maybe Text -> Manifest -> Value
manifestInfo Maybe String
cflags String
inputDir String
outputDir Maybe Text
clkName Manifest
manifest
    [(String, Template)] -> ((String, Template) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, Template)]
templates (((String, Template) -> IO ()) -> IO ())
-> ((String, Template) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(String
fname, Template
template) -> do
        String -> String -> IO ()
forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
String -> String -> m ()
writeFileChanged (String
outputDir String -> ShowS
</> String
fname) (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> String
TL.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Template -> Value -> Text
renderMustache Template
template Value
vals