{-# LANGUAGE OverloadedStrings, RecordWildCards, TemplateHaskell #-}
module Clash.Shake.Intel
    ( Target(..)
    , de0Nano, arrowDeca

    , quartus
    ) where

import Clash.Shake

import Development.Shake
import Development.Shake.Command
import Development.Shake.FilePath
import Development.Shake.Config

import Text.Mustache
import qualified Text.Mustache.Compile.TH as TH
import Data.Aeson

import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.IO as T

data Target = Target
    { Target -> String
targetFamily :: String
    , Target -> String
targetDevice :: String
    }

targetMustache :: Target -> [a]
targetMustache Target{String
targetDevice :: String
targetFamily :: String
targetDevice :: Target -> String
targetFamily :: Target -> String
..} =
    [ Key
"targetFamily"  Key -> Text -> a
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String -> Text
T.pack String
targetFamily
    , Key
"targetDevice"  Key -> Text -> a
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String -> Text
T.pack String
targetDevice
    ]

de0Nano :: Target
de0Nano :: Target
de0Nano = String -> String -> Target
Target String
"Cyclone IV E" String
"EP4CE22F17C6"

arrowDeca :: Target
arrowDeca :: Target
arrowDeca = String -> String -> Target
Target String
"MAX 10" String
"10M50DAF484C6GES"

quartus :: Target -> ClashKit -> FilePath -> FilePath -> String -> Rules SynthKit
quartus :: Target -> ClashKit -> String -> String -> String -> Rules SynthKit
quartus Target
fpga kit :: ClashKit
kit@ClashKit{Action [String]
manifestSrcs :: ClashKit -> Action [String]
manifestSrcs :: Action [String]
..} String
outDir String
srcDir String
topName = do
    let projectName :: String
projectName = String
topName
        rootDir :: String
rootDir = [String] -> String
joinPath ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
forall a b. a -> b -> a
const String
"..") ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
splitPath (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
outDir

    let quartus :: String -> [String] -> Action ()
quartus String
tool [String]
args = (CmdOption -> [String] -> Action ()) :-> Action ()
forall args. (Partial, CmdArguments args, Unit args) => args
cmd_ (String -> CmdOption
Cwd String
outDir) ([String] -> Action ()) -> Action [String] -> Action ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> String -> [String] -> Action [String]
toolchain String
"QUARTUS" String
tool [String]
args

    let getFiles :: String -> [String] -> Action [String]
getFiles String
dir [String]
pats = String -> [String] -> Action [String]
getDirectoryFiles String
srcDir [ String
dir String -> String -> String
</> String
pat | String
pat <- [String]
pats ]
        hdlSrcs :: Action [String]
hdlSrcs = String -> [String] -> Action [String]
getFiles String
"src-hdl" [String
"*.vhdl", String
"*.v", String
"*.sv"]
        tclSrcs :: Action [String]
tclSrcs = String -> [String] -> Action [String]
getFiles String
"src-hdl" [String
"*.tcl"]
        constrSrcs :: Action [String]
constrSrcs = String -> [String] -> Action [String]
getFiles String
"src-hdl" [String
"*.sdc"]
        ipCores :: Action [String]
ipCores = String -> [String] -> Action [String]
getFiles String
"ip" [String
"//*.qip"]

    String
outDir String -> String -> String
<//> String
"*.tcl" Partial => String -> (String -> Action ()) -> Rules ()
String -> (String -> Action ()) -> Rules ()
%> \String
out -> do
        [String]
srcs1 <- Action [String]
manifestSrcs
        [String]
srcs2 <- Action [String]
hdlSrcs
        [String]
tcls <- Action [String]
tclSrcs
        [String]
constrs <- Action [String]
constrSrcs
        [String]
cores <- Action [String]
ipCores

        let template :: Template
template = $(TH.compileMustacheFile "template/intel-quartus/project.tcl.mustache")
        let values :: Value
values = [Pair] -> Value
object ([Pair] -> Value) -> ([[Pair]] -> [Pair]) -> [[Pair]] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Pair]] -> [Pair]
forall a. Monoid a => [a] -> a
mconcat ([[Pair]] -> Value) -> [[Pair]] -> Value
forall a b. (a -> b) -> a -> b
$
                [ [ Key
"project" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String -> Text
T.pack String
projectName ]
                  , [ Key
"top" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String -> Text
T.pack String
topName ]
                  , Target -> [Pair]
forall a. KeyValue a => Target -> [a]
targetMustache Target
fpga
                  , [ Key
"srcs" Key -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [[Value]] -> [Value]
forall a. Monoid a => [a] -> a
mconcat
                             [ [ [Pair] -> Value
object [ Key
"fileName" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (String
rootDir String -> String -> String
</> String
src) ] | String
src <- [String]
srcs1 ]
                               , [ [Pair] -> Value
object [ Key
"fileName" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (String
rootDir String -> String -> String
</> String
srcDir String -> String -> String
</> String
src) ] | String
src <- [String]
srcs2 ]
                             ]
                    ]
                  , [ Key
"tclSrcs" Key -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [ [Pair] -> Value
object [ Key
"fileName" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (String
rootDir String -> String -> String
</> String
srcDir String -> String -> String
</> String
src) ] | String
src <- [String]
tcls ] ]
                  , [ Key
"ipcores" Key -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [ [Pair] -> Value
object [ Key
"fileName" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (String
rootDir String -> String -> String
</> String
srcDir String -> String -> String
</> String
core) ] | String
core <- [String]
cores ] ]
                  , [ Key
"constraintSrcs" Key -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [ [Pair] -> Value
object [ Key
"fileName" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (String
rootDir String -> String -> String
</> String
srcDir String -> String -> String
</> String
src) ] | String
src <- [String]
constrs ] ]
                ]
        String -> String -> Action ()
forall (m :: * -> *).
(MonadIO m, Partial) =>
String -> String -> m ()
writeFileChanged String
out (String -> Action ()) -> (Text -> String) -> Text -> Action ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
TL.unpack (Text -> Action ()) -> Text -> Action ()
forall a b. (a -> b) -> a -> b
$ Template -> Value -> Text
renderMustache Template
template Value
values

    String
outDir String -> String -> String
</> String
"ip" String -> String -> String
<//> String
"*" Partial => String -> (String -> Action ()) -> Rules ()
String -> (String -> Action ()) -> Rules ()
%> \String
out -> do
            let src :: String
src = String
srcDir String -> String -> String
</> String -> String -> String
makeRelative String
outDir String
out
            Partial => String -> String -> Action ()
String -> String -> Action ()
copyFileChanged String
src String
out

    let bitfile :: String
bitfile = String
outDir String -> String -> String
</> String
topName String -> String -> String
<.> String
"sof"

    String
bitfile Partial => String -> (String -> Action ()) -> Rules ()
String -> (String -> Action ()) -> Rules ()
%> \String
_out -> do
        [String]
srcs1 <- Action [String]
manifestSrcs
        [String]
srcs2 <- Action [String]
hdlSrcs
        [String]
cores <- Action [String]
ipCores
        Partial => [String] -> Action ()
[String] -> Action ()
need ([String] -> Action ()) -> [String] -> Action ()
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall a. Monoid a => [a] -> a
mconcat
            [ [ String
outDir String -> String -> String
</> String
projectName String -> String -> String
<.> String
"tcl" ]
              , [ String
src | String
src <- [String]
srcs1 ]
              , [ String
srcDir String -> String -> String
</> String
src | String
src <- [String]
srcs2 ]
              , [ String
outDir String -> String -> String
</> String
core | String
core <- [String]
cores ]
            ]
        String -> [String] -> Action ()
quartus String
"quartus_sh" [String
"-t", String
projectName String -> String -> String
<.> String
"tcl"]

    String
outDir String -> String -> String
</> String
topName String -> String -> String
<.> String
"rbf" Partial => String -> (String -> Action ()) -> Rules ()
String -> (String -> Action ()) -> Rules ()
%> \String
out -> do
        let sof :: String
sof = String
out String -> String -> String
-<.> String
"sof"
        Partial => [String] -> Action ()
[String] -> Action ()
need [String
sof]
        String -> [String] -> Action ()
quartus String
"quartus_cpf"
          [ String
"--option=bitstream_compression=off"
          , String
"-c", String -> String -> String
makeRelative String
outDir String
sof
          , String -> String -> String
makeRelative String
outDir String
out
          ]

    SynthKit -> Rules SynthKit
forall (m :: * -> *) a. Monad m => a -> m a
return (SynthKit -> Rules SynthKit) -> SynthKit -> Rules SynthKit
forall a b. (a -> b) -> a -> b
$ SynthKit :: String -> [(String, Action ())] -> SynthKit
SynthKit
        { bitfile :: String
bitfile = String
bitfile
          , phonies :: [(String, Action ())]
phonies =
              [ String
"quartus" String -> Action () -> (String, Action ())
|> do
                    Partial => [String] -> Action ()
[String] -> Action ()
need [String
outDir String -> String -> String
</> String
projectName String -> String -> String
<.> String
"tcl"]
                    String -> [String] -> Action ()
quartus String
"quartus_sh" [String
"-t", String
projectName String -> String -> String
<.> String
"tcl"]
              , String
"upload" String -> Action () -> (String, Action ())
|> do
                    Partial => [String] -> Action ()
[String] -> Action ()
need [String
bitfile]
                    String -> [String] -> Action ()
quartus String
"quartus_pgm" [String
"-m", String
"jtag", String
"-o", String
"p;" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String -> String
makeRelative String
outDir String
bitfile]
              ]
        }