{-# LANGUAGE RecordWildCards #-}
module Clash.Shake
    ( HDL(..)
    , nestedPhony
    , (|>)

    , useConfig
    , RunClash(..), ClashKit(..)
    , clashRules
    , SynthKit(..)

    , binImage

    , toolchain

    , withTargets
    ) where

import Development.Shake
import Development.Shake.FilePath
import Development.Shake.Config
import Development.Shake.Util (parseMakefile)

import qualified Clash.Main as Clash

import Data.List.Split
import Text.Printf

import qualified Data.Text as T
import qualified Data.HashMap.Strict as HM
import Data.Char (isUpper, toLower)
import Control.Monad (forM_)
import qualified Data.ByteString as BS
import qualified System.Directory as Dir
import Control.Exception (bracket)
import Data.Maybe (fromJust)
import Data.Bits

import Clash.Driver.Manifest
import Clash.Prelude (pack)

data HDL
    = VHDL
    | Verilog
    | SystemVerilog
    deriving (HDL -> HDL -> Bool
(HDL -> HDL -> Bool) -> (HDL -> HDL -> Bool) -> Eq HDL
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HDL -> HDL -> Bool
$c/= :: HDL -> HDL -> Bool
== :: HDL -> HDL -> Bool
$c== :: HDL -> HDL -> Bool
Eq, Int -> HDL
HDL -> Int
HDL -> [HDL]
HDL -> HDL
HDL -> HDL -> [HDL]
HDL -> HDL -> HDL -> [HDL]
(HDL -> HDL)
-> (HDL -> HDL)
-> (Int -> HDL)
-> (HDL -> Int)
-> (HDL -> [HDL])
-> (HDL -> HDL -> [HDL])
-> (HDL -> HDL -> [HDL])
-> (HDL -> HDL -> HDL -> [HDL])
-> Enum HDL
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: HDL -> HDL -> HDL -> [HDL]
$cenumFromThenTo :: HDL -> HDL -> HDL -> [HDL]
enumFromTo :: HDL -> HDL -> [HDL]
$cenumFromTo :: HDL -> HDL -> [HDL]
enumFromThen :: HDL -> HDL -> [HDL]
$cenumFromThen :: HDL -> HDL -> [HDL]
enumFrom :: HDL -> [HDL]
$cenumFrom :: HDL -> [HDL]
fromEnum :: HDL -> Int
$cfromEnum :: HDL -> Int
toEnum :: Int -> HDL
$ctoEnum :: Int -> HDL
pred :: HDL -> HDL
$cpred :: HDL -> HDL
succ :: HDL -> HDL
$csucc :: HDL -> HDL
Enum, HDL
HDL -> HDL -> Bounded HDL
forall a. a -> a -> Bounded a
maxBound :: HDL
$cmaxBound :: HDL
minBound :: HDL
$cminBound :: HDL
Bounded, Int -> HDL -> ShowS
[HDL] -> ShowS
HDL -> String
(Int -> HDL -> ShowS)
-> (HDL -> String) -> ([HDL] -> ShowS) -> Show HDL
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HDL] -> ShowS
$cshowList :: [HDL] -> ShowS
show :: HDL -> String
$cshow :: HDL -> String
showsPrec :: Int -> HDL -> ShowS
$cshowsPrec :: Int -> HDL -> ShowS
Show, ReadPrec [HDL]
ReadPrec HDL
Int -> ReadS HDL
ReadS [HDL]
(Int -> ReadS HDL)
-> ReadS [HDL] -> ReadPrec HDL -> ReadPrec [HDL] -> Read HDL
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [HDL]
$creadListPrec :: ReadPrec [HDL]
readPrec :: ReadPrec HDL
$creadPrec :: ReadPrec HDL
readList :: ReadS [HDL]
$creadList :: ReadS [HDL]
readsPrec :: Int -> ReadS HDL
$creadsPrec :: Int -> ReadS HDL
Read)

hdlDir :: HDL -> FilePath
hdlDir :: HDL -> String
hdlDir HDL
VHDL = String
"vhdl"
hdlDir HDL
Verilog = String
"verilog"
hdlDir HDL
SystemVerilog = String
"systemverilog"

hdlExt :: HDL -> FilePath
hdlExt :: HDL -> String
hdlExt HDL
VHDL = String
"vhdl"
hdlExt HDL
Verilog = String
"v"
hdlExt HDL
SystemVerilog = String
"sv"

hdlClashFlag :: HDL -> String
hdlClashFlag :: HDL -> String
hdlClashFlag HDL
VHDL = String
"--vhdl"
hdlClashFlag HDL
Verilog = String
"--verilog"
hdlClashFlag HDL
SystemVerilog = String
"--systemverilog"

type RunClash = [String] -> Action ()

data ClashKit = ClashKit
    { ClashKit -> Action [String]
manifestSrcs :: Action [FilePath]
    }

instance Semigroup ClashKit where
    ClashKit
kit <> :: ClashKit -> ClashKit -> ClashKit
<> ClashKit
kit' = ClashKit :: Action [String] -> ClashKit
ClashKit
        { manifestSrcs :: Action [String]
manifestSrcs = [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
(<>) ([String] -> [String] -> [String])
-> Action [String] -> Action ([String] -> [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClashKit -> Action [String]
manifestSrcs ClashKit
kit Action ([String] -> [String]) -> Action [String] -> Action [String]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ClashKit -> Action [String]
manifestSrcs ClashKit
kit'
        }

instance Monoid ClashKit where
    mempty :: ClashKit
mempty = ClashKit :: Action [String] -> ClashKit
ClashKit
        { manifestSrcs :: Action [String]
manifestSrcs = [String] -> Action [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String]
forall a. Monoid a => a
mempty
        }

withWorkingDirectory :: FilePath -> IO a -> IO a
withWorkingDirectory :: String -> IO a -> IO a
withWorkingDirectory String
dir IO a
act =
    IO String -> (String -> IO ()) -> (String -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO String
Dir.getCurrentDirectory String -> IO ()
Dir.setCurrentDirectory ((String -> IO a) -> IO a) -> (String -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \String
_ ->
        String -> IO ()
Dir.setCurrentDirectory String
dir IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO a
act

clashRules :: FilePath -> HDL -> [FilePath] -> FilePath -> [String] -> Action () -> Rules (RunClash, ClashKit)
clashRules :: String
-> HDL
-> [String]
-> String
-> [String]
-> Action ()
-> Rules (RunClash, ClashKit)
clashRules String
outDir HDL
hdl [String]
srcDirs String
src [String]
clashFlags Action ()
extraGenerated = do
    let clash :: [String] -> m ()
clash [String]
args = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            let srcFlags :: [String]
srcFlags = [String
"-i" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
srcDir | String
srcDir <- [String]
srcDirs]
            let args' :: [String]
args' = [String
"-outputdir", String
outDir] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
clashFlags [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
srcFlags [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
args
            String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Clash.defaultMain " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unwords [String]
args'
            [String] -> IO ()
Clash.defaultMain [String]
args'

    -- TODO: ideally, Clash should return the manifest, or at least its file location...
    let synModule :: String
synModule
          | String -> Bool
isModuleName String
src = String
src
          | Bool
otherwise = String
"Main"

        clashTopName :: String
clashTopName = String
"topEntity"
        synOut :: String
synOut = String
outDir String -> ShowS
</> String
synModule String -> ShowS
<.> String
clashTopName
        manifestFile :: String
manifestFile = String
synOut String -> ShowS
</> String
"clash-manifest.json"
        manifest :: Action Manifest
manifest = do
            Partial => RunClash
RunClash
need [String
manifestFile]
            Just Manifest
manifest <- IO (Maybe Manifest) -> Action (Maybe Manifest)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Manifest) -> Action (Maybe Manifest))
-> IO (Maybe Manifest) -> Action (Maybe Manifest)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe Manifest)
readManifest String
manifestFile
            Manifest -> Action Manifest
forall (m :: * -> *) a. Monad m => a -> m a
return Manifest
manifest

    let manifestSrcs :: Action [String]
manifestSrcs = do
            Manifest{Int
[(String, ByteString)]
[Text]
[ManifestPort]
(Int, Int, Bool)
Text
HashMap Text VDomainConfiguration
manifestHash :: Manifest -> Int
successFlags :: Manifest -> (Int, Int, Bool)
inPorts :: Manifest -> [ManifestPort]
outPorts :: 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]
outPorts :: [ManifestPort]
inPorts :: [ManifestPort]
successFlags :: (Int, Int, Bool)
manifestHash :: Int
..} <- Action Manifest
manifest
            let clashSrcs :: [String]
clashSrcs = (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack [Text]
componentNames [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<>
                            [ (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
clashTopName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"_types" | HDL
hdl HDL -> HDL -> Bool
forall a. Eq a => a -> a -> Bool
== HDL
VHDL ]
            [String] -> Action [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [ String
synOut String -> ShowS
</> String
c String -> ShowS
<.> HDL -> String
hdlExt HDL
hdl | String
c <- [String]
clashSrcs ]

    String
outDir String -> ShowS
</> String
"ghc-deps.make" Partial => String -> (String -> Action ()) -> Rules ()
String -> (String -> Action ()) -> Rules ()
%> \String
out -> do
        Action ()
alwaysRerun
        -- By writing to a temp file and using `copyFileChanged`,
        -- we avoid spurious reruns
        -- (https://stackoverflow.com/a/64277431/477476)
        String -> (String -> Action ()) -> Action ()
forall a. String -> (String -> Action a) -> Action a
withTempFileWithin String
outDir ((String -> Action ()) -> Action ())
-> (String -> Action ()) -> Action ()
forall a b. (a -> b) -> a -> b
$ \String
tmp -> do
            RunClash
forall (m :: * -> *). MonadIO m => [String] -> m ()
clash [String
"-M", String
"-dep-suffix", String
"", String
"-dep-makefile", String
tmp, String
src]
            IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> IO ()
removeFiles String
outDir [ShowS
takeBaseName String
tmp String -> ShowS
<.> String
"bak"]
            Partial => String -> String -> Action ()
String -> String -> Action ()
copyFileChanged String
tmp String
out

    String
manifestFile Partial => String -> (String -> Action ()) -> Rules ()
String -> (String -> Action ()) -> Rules ()
%> \String
_out -> do
        let depFile :: String
depFile = String
outDir String -> ShowS
</> String
"ghc-deps.make"
        Partial => RunClash
RunClash
need [String
depFile]
        [(String, [String])]
deps <- String -> [(String, [String])]
parseMakefile (String -> [(String, [String])])
-> Action String -> Action [(String, [String])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String -> Action String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO String
readFile String
depFile)
        let isHsSource :: String -> Bool
isHsSource String
fn
              | String
ext String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
".hi"] = Bool
False
              | String
ext String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
".hs", String
".lhs"] = Bool
True
              | Bool
otherwise = String -> Bool
forall a. Partial => String -> a
error (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String
"Unrecognized source file: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
fn
              where
                ext :: String
ext = ShowS
takeExtension String
fn
            hsDeps :: [String]
hsDeps = [String
fn | (String
_, [String]
fns) <- [(String, [String])]
deps, String
fn <- [String]
fns, String -> Bool
isHsSource String
fn]
        Partial => RunClash
RunClash
need [String]
hsDeps
        Action ()
extraGenerated
        RunClash
forall (m :: * -> *). MonadIO m => [String] -> m ()
clash [HDL -> String
hdlClashFlag HDL
hdl, String
src]

    (RunClash, ClashKit) -> Rules (RunClash, ClashKit)
forall (m :: * -> *) a. Monad m => a -> m a
return (RunClash
forall (m :: * -> *). MonadIO m => [String] -> m ()
clash, ClashKit :: Action [String] -> ClashKit
ClashKit{Action [String]
manifestSrcs :: Action [String]
manifestSrcs :: Action [String]
..})

data SynthKit = SynthKit
    { SynthKit -> String
bitfile :: FilePath
    , SynthKit -> [(String, Action ())]
phonies :: [(String, Action ())]
    }

nestedPhony :: String -> String -> Action () -> Rules ()
nestedPhony :: String -> String -> Action () -> Rules ()
nestedPhony String
target String
name = Partial => String -> Action () -> Rules ()
String -> Action () -> Rules ()
phony (String
target String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
name)

useConfig :: FilePath -> Rules ()
useConfig :: String -> Rules ()
useConfig String
file = do
    HashMap String String
cfg <- do
        Bool
haveConfig <- IO Bool -> Rules Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Rules Bool) -> IO Bool -> Rules Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
Dir.doesFileExist String
file
        if Bool
haveConfig then do
            String -> Rules ()
usingConfigFile String
file
            IO (HashMap String String) -> Rules (HashMap String String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (HashMap String String) -> Rules (HashMap String String))
-> IO (HashMap String String) -> Rules (HashMap String String)
forall a b. (a -> b) -> a -> b
$ String -> IO (HashMap String String)
readConfigFile String
file
          else do
            HashMap String String -> Rules ()
usingConfig HashMap String String
forall a. Monoid a => a
mempty
            HashMap String String -> Rules (HashMap String String)
forall (m :: * -> *) a. Monad m => a -> m a
return HashMap String String
forall a. Monoid a => a
mempty

    Maybe String -> (String -> Rules ()) -> Rules ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (String -> HashMap String String -> Maybe String
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup String
"TARGET" HashMap String String
cfg) ((String -> Rules ()) -> Rules ())
-> (String -> Rules ()) -> Rules ()
forall a b. (a -> b) -> a -> b
$ \String
target ->
      Partial => [String] -> Rules ()
[String] -> Rules ()
want [String
target String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"bitfile"]

binImage :: Maybe Int -> FilePath -> FilePath -> Action ()
binImage :: Maybe Int -> String -> String -> Action ()
binImage Maybe Int
size String
src String
out = do
    Partial => RunClash
RunClash
need [String
src]
    [String]
lines <- IO [String] -> Action [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> Action [String]) -> IO [String] -> Action [String]
forall a b. (a -> b) -> a -> b
$ Maybe Int -> ByteString -> [String]
binLines Maybe Int
size (ByteString -> [String]) -> IO ByteString -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS.readFile String
src
    String -> String -> Action ()
forall (m :: * -> *).
(MonadIO m, Partial) =>
String -> String -> m ()
writeFileChanged String
out ([String] -> String
unlines [String]
lines)

binLines :: Maybe Int -> BS.ByteString -> [String]
binLines :: Maybe Int -> ByteString -> [String]
binLines Maybe Int
size ByteString
bs = (Word8 -> String) -> [Word8] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> String
forall a. FiniteBits a => a -> String
bitsOf [Word8]
bytes
  where
    bytes :: [Word8]
bytes = ([Word8] -> [Word8])
-> (Int -> [Word8] -> [Word8]) -> Maybe Int -> [Word8] -> [Word8]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Word8] -> [Word8]
forall a. a -> a
id Int -> [Word8] -> [Word8]
forall a. Num a => Int -> [a] -> [a]
ensureSize Maybe Int
size ([Word8] -> [Word8]) -> [Word8] -> [Word8]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
BS.unpack ByteString
bs
    ensureSize :: Int -> [a] -> [a]
ensureSize Int
size [a]
bs = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
size ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [a]
bs [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> a -> [a]
forall a. a -> [a]
repeat a
0x00

bitsOf :: (FiniteBits a) => a -> [Char]
bitsOf :: a -> String
bitsOf a
x = ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> a -> String
forall t t. (Num t, Bits t, Eq t) => t -> t -> String
go (a -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize a
x) a
x
  where
    go :: t -> t -> String
go t
0 t
_ = []
    go t
n t
x = (if t -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit t
x Int
0 then Char
'1' else Char
'0') Char -> ShowS
forall a. a -> [a] -> [a]
: t -> t -> String
go (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) (t
x t -> Int -> t
forall a. Bits a => a -> Int -> a
`shiftR` Int
1)

isModuleName :: String -> Bool
isModuleName :: String -> Bool
isModuleName = (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> Bool
isUpper (Char -> Bool) -> (String -> Char) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Char
forall a. [a] -> a
head) ([String] -> Bool) -> (String -> [String]) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"."

toolchain :: String -> FilePath -> [String] -> Action [String]
toolchain :: String -> String -> [String] -> Action [String]
toolchain String
name String
tool [String]
args = do
    Maybe String
wrap <- String -> Action (Maybe String)
getConfig String
name
    Maybe String
root <- String -> Action (Maybe String)
getConfig (String -> Action (Maybe String))
-> String -> Action (Maybe String)
forall a b. (a -> b) -> a -> b
$ String
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"_ROOT"
    let exe :: [String]
exe = case (Maybe String
wrap, Maybe String
root) of
            (Just String
wrap, Maybe String
_) -> [String
wrap, String
tool]
            (Maybe String
Nothing, Just String
root) -> [String
root String -> ShowS
</> String
tool]
            (Maybe String
Nothing, Maybe String
Nothing) -> [String
tool]
    [String] -> Action [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> Action [String]) -> [String] -> Action [String]
forall a b. (a -> b) -> a -> b
$ [String]
exe [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args

(|>) :: String -> Action () -> (String, Action ())
|> :: String -> Action () -> (String, Action ())
(|>) = (,)

withTargets :: [String] -> Rules a -> Rules a
withTargets :: [String] -> Rules a -> Rules a
withTargets [String]
targets Rules a
rules
  | [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
targets = Rules a
rules
  | Bool
otherwise = Partial => [String] -> Rules ()
[String] -> Rules ()
want [String]
targets Rules () -> Rules a -> Rules a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Rules a -> Rules a
forall a. Rules a -> Rules a
withoutActions Rules a
rules