{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
module Clash.Driver.Manifest where
import Control.Exception (tryJust)
import Control.Monad (guard, forM)
import Control.Monad.State (evalState)
import qualified Crypto.Hash.SHA256 as Sha256
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encode.Pretty as Aeson
import Data.Aeson
(ToJSON(toJSON), FromJSON(parseJSON), KeyValue ((.=)), (.:), (.:?))
import Data.Aeson.Types (Parser)
import qualified Data.Binary as Binary
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Lazy as ByteStringLazy
import Data.ByteString (ByteString)
import Data.Char (toLower)
#if MIN_VERSION_base16_bytestring(1,0,0)
import Data.Either (fromRight)
#endif
import Data.Hashable (hash)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (catMaybes)
import Data.Monoid (Ap(getAp))
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Lazy as LText
import qualified Data.Text.Lazy.Encoding as LText
import Data.Text (Text)
import Data.Text.Prettyprint.Doc.Extra (renderOneLine)
import Data.Time (UTCTime)
import qualified Data.Set as Set
import Data.String (IsString)
import GHC.Generics (Generic)
import System.IO.Error (isDoesNotExistError)
import System.FilePath (takeDirectory, (</>))
import System.Directory (listDirectory, doesFileExist)
import Text.Read (readMaybe)
import Clash.Annotations.TopEntity.Extra ()
import Clash.Backend (Backend (hdlType), Usage (External))
import Clash.Core.Name (nameOcc)
import Clash.Driver.Types
import Clash.Primitives.Types
import Clash.Core.Var (Id, varName)
import Clash.Netlist.Types
(TopEntityT, Component(..), HWType (Clock), hwTypeDomain)
import qualified Clash.Netlist.Types as Netlist
import qualified Clash.Netlist.Id as Id
import Clash.Netlist.Util (typeSize)
import Clash.Primitives.Util (hashCompiledPrimMap)
import Clash.Signal (VDomainConfiguration(..))
import Clash.Util.Graph (callGraphBindings)
#if MIN_VERSION_ghc(9,0,0)
import GHC.Utils.Misc (OverridingBool(..))
#else
import Util (OverridingBool(..))
#endif
data PortDirection
= In | Out | InOut
deriving ((forall x. PortDirection -> Rep PortDirection x)
-> (forall x. Rep PortDirection x -> PortDirection)
-> Generic PortDirection
forall x. Rep PortDirection x -> PortDirection
forall x. PortDirection -> Rep PortDirection x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PortDirection x -> PortDirection
$cfrom :: forall x. PortDirection -> Rep PortDirection x
Generic, PortDirection -> PortDirection -> Bool
(PortDirection -> PortDirection -> Bool)
-> (PortDirection -> PortDirection -> Bool) -> Eq PortDirection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PortDirection -> PortDirection -> Bool
$c/= :: PortDirection -> PortDirection -> Bool
== :: PortDirection -> PortDirection -> Bool
$c== :: PortDirection -> PortDirection -> Bool
Eq, ReadPrec [PortDirection]
ReadPrec PortDirection
Int -> ReadS PortDirection
ReadS [PortDirection]
(Int -> ReadS PortDirection)
-> ReadS [PortDirection]
-> ReadPrec PortDirection
-> ReadPrec [PortDirection]
-> Read PortDirection
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PortDirection]
$creadListPrec :: ReadPrec [PortDirection]
readPrec :: ReadPrec PortDirection
$creadPrec :: ReadPrec PortDirection
readList :: ReadS [PortDirection]
$creadList :: ReadS [PortDirection]
readsPrec :: Int -> ReadS PortDirection
$creadsPrec :: Int -> ReadS PortDirection
Read, Int -> PortDirection -> ShowS
[PortDirection] -> ShowS
PortDirection -> FilePath
(Int -> PortDirection -> ShowS)
-> (PortDirection -> FilePath)
-> ([PortDirection] -> ShowS)
-> Show PortDirection
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [PortDirection] -> ShowS
$cshowList :: [PortDirection] -> ShowS
show :: PortDirection -> FilePath
$cshow :: PortDirection -> FilePath
showsPrec :: Int -> PortDirection -> ShowS
$cshowsPrec :: Int -> PortDirection -> ShowS
Show)
instance ToJSON PortDirection where
toJSON :: PortDirection -> Value
toJSON = Options -> PortDirection -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
Aeson.genericToJSON Options
Aeson.defaultOptions
{ constructorTagModifier :: ShowS
Aeson.constructorTagModifier = (Char -> Char) -> ShowS
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
toLower }
instance FromJSON PortDirection where
parseJSON :: Value -> Parser PortDirection
parseJSON = Options -> Value -> Parser PortDirection
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
Aeson.genericParseJSON Options
Aeson.defaultOptions
{ constructorTagModifier :: ShowS
Aeson.constructorTagModifier = (Char -> Char) -> ShowS
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
toLower }
data ManifestPort = ManifestPort
{ ManifestPort -> Text
mpName :: Text
, ManifestPort -> Text
mpTypeName :: Text
, ManifestPort -> PortDirection
mpDirection :: PortDirection
, ManifestPort -> Int
mpWidth :: Int
, ManifestPort -> Bool
mpIsClock :: Bool
, ManifestPort -> Maybe Text
mpDomain :: Maybe Text
} deriving (Int -> ManifestPort -> ShowS
[ManifestPort] -> ShowS
ManifestPort -> FilePath
(Int -> ManifestPort -> ShowS)
-> (ManifestPort -> FilePath)
-> ([ManifestPort] -> ShowS)
-> Show ManifestPort
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ManifestPort] -> ShowS
$cshowList :: [ManifestPort] -> ShowS
show :: ManifestPort -> FilePath
$cshow :: ManifestPort -> FilePath
showsPrec :: Int -> ManifestPort -> ShowS
$cshowsPrec :: Int -> ManifestPort -> ShowS
Show,ReadPrec [ManifestPort]
ReadPrec ManifestPort
Int -> ReadS ManifestPort
ReadS [ManifestPort]
(Int -> ReadS ManifestPort)
-> ReadS [ManifestPort]
-> ReadPrec ManifestPort
-> ReadPrec [ManifestPort]
-> Read ManifestPort
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ManifestPort]
$creadListPrec :: ReadPrec [ManifestPort]
readPrec :: ReadPrec ManifestPort
$creadPrec :: ReadPrec ManifestPort
readList :: ReadS [ManifestPort]
$creadList :: ReadS [ManifestPort]
readsPrec :: Int -> ReadS ManifestPort
$creadsPrec :: Int -> ReadS ManifestPort
Read,ManifestPort -> ManifestPort -> Bool
(ManifestPort -> ManifestPort -> Bool)
-> (ManifestPort -> ManifestPort -> Bool) -> Eq ManifestPort
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ManifestPort -> ManifestPort -> Bool
$c/= :: ManifestPort -> ManifestPort -> Bool
== :: ManifestPort -> ManifestPort -> Bool
$c== :: ManifestPort -> ManifestPort -> Bool
Eq)
instance ToJSON ManifestPort where
toJSON :: ManifestPort -> Value
toJSON (ManifestPort{Bool
Int
Maybe Text
Text
PortDirection
mpDomain :: Maybe Text
mpIsClock :: Bool
mpWidth :: Int
mpDirection :: PortDirection
mpTypeName :: Text
mpName :: Text
mpDomain :: ManifestPort -> Maybe Text
mpIsClock :: ManifestPort -> Bool
mpWidth :: ManifestPort -> Int
mpDirection :: ManifestPort -> PortDirection
mpTypeName :: ManifestPort -> Text
mpName :: ManifestPort -> Text
..}) =
[Pair] -> Value
Aeson.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
[ Key
"name" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
mpName
, Key
"type_name" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
mpTypeName
, Key
"direction" Key -> PortDirection -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= PortDirection
mpDirection
, Key
"width" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
mpWidth
, Key
"is_clock" Key -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
mpIsClock
] [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<>
(case Maybe Text
mpDomain of
Just Text
dom -> [Key
"domain" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
dom]
Maybe Text
Nothing -> [] )
instance FromJSON ManifestPort where
parseJSON :: Value -> Parser ManifestPort
parseJSON = FilePath
-> (Object -> Parser ManifestPort) -> Value -> Parser ManifestPort
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject FilePath
"ManifestPort" ((Object -> Parser ManifestPort) -> Value -> Parser ManifestPort)
-> (Object -> Parser ManifestPort) -> Value -> Parser ManifestPort
forall a b. (a -> b) -> a -> b
$ \Object
v ->
Text
-> Text
-> PortDirection
-> Int
-> Bool
-> Maybe Text
-> ManifestPort
ManifestPort
(Text
-> Text
-> PortDirection
-> Int
-> Bool
-> Maybe Text
-> ManifestPort)
-> Parser Text
-> Parser
(Text
-> PortDirection -> Int -> Bool -> Maybe Text -> ManifestPort)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name"
Parser
(Text
-> PortDirection -> Int -> Bool -> Maybe Text -> ManifestPort)
-> Parser Text
-> Parser
(PortDirection -> Int -> Bool -> Maybe Text -> ManifestPort)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"type_name"
Parser (PortDirection -> Int -> Bool -> Maybe Text -> ManifestPort)
-> Parser PortDirection
-> Parser (Int -> Bool -> Maybe Text -> ManifestPort)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser PortDirection
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"direction"
Parser (Int -> Bool -> Maybe Text -> ManifestPort)
-> Parser Int -> Parser (Bool -> Maybe Text -> ManifestPort)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"width"
Parser (Bool -> Maybe Text -> ManifestPort)
-> Parser Bool -> Parser (Maybe Text -> ManifestPort)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser Bool
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"is_clock"
Parser (Maybe Text -> ManifestPort)
-> Parser (Maybe Text) -> Parser ManifestPort
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"domain"
newtype FilesManifest = FilesManifest [(FilePath, ByteString)]
instance FromJSON FilesManifest where
parseJSON :: Value -> Parser FilesManifest
parseJSON = FilePath
-> (Object -> Parser FilesManifest)
-> Value
-> Parser FilesManifest
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject FilePath
"FilesManifest" ((Object -> Parser FilesManifest) -> Value -> Parser FilesManifest)
-> (Object -> Parser FilesManifest)
-> Value
-> Parser FilesManifest
forall a b. (a -> b) -> a -> b
$ ([(FilePath, ByteString)] -> FilesManifest)
-> Parser [(FilePath, ByteString)] -> Parser FilesManifest
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap [(FilePath, ByteString)] -> FilesManifest
FilesManifest (Parser [(FilePath, ByteString)] -> Parser FilesManifest)
-> (Object -> Parser [(FilePath, ByteString)])
-> Object
-> Parser FilesManifest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Parser [(FilePath, ByteString)]
parseFiles
data Manifest
= Manifest
{ Manifest -> ByteString
manifestHash :: ByteString
, Manifest -> (Int, Int)
successFlags :: (Int, Int)
, Manifest -> [ManifestPort]
ports :: [ManifestPort]
, Manifest -> [Text]
componentNames :: [Text]
, Manifest -> Text
topComponent :: Text
, Manifest -> [(FilePath, ByteString)]
fileNames :: [(FilePath, ByteString)]
, Manifest -> HashMap Text VDomainConfiguration
domains :: HashMap Text VDomainConfiguration
, Manifest -> [Text]
transitiveDependencies :: [Text]
} deriving (Int -> Manifest -> ShowS
[Manifest] -> ShowS
Manifest -> FilePath
(Int -> Manifest -> ShowS)
-> (Manifest -> FilePath) -> ([Manifest] -> ShowS) -> Show Manifest
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Manifest] -> ShowS
$cshowList :: [Manifest] -> ShowS
show :: Manifest -> FilePath
$cshow :: Manifest -> FilePath
showsPrec :: Int -> Manifest -> ShowS
$cshowsPrec :: Int -> Manifest -> ShowS
Show,ReadPrec [Manifest]
ReadPrec Manifest
Int -> ReadS Manifest
ReadS [Manifest]
(Int -> ReadS Manifest)
-> ReadS [Manifest]
-> ReadPrec Manifest
-> ReadPrec [Manifest]
-> Read Manifest
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Manifest]
$creadListPrec :: ReadPrec [Manifest]
readPrec :: ReadPrec Manifest
$creadPrec :: ReadPrec Manifest
readList :: ReadS [Manifest]
$creadList :: ReadS [Manifest]
readsPrec :: Int -> ReadS Manifest
$creadsPrec :: Int -> ReadS Manifest
Read,Manifest -> Manifest -> Bool
(Manifest -> Manifest -> Bool)
-> (Manifest -> Manifest -> Bool) -> Eq Manifest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Manifest -> Manifest -> Bool
$c/= :: Manifest -> Manifest -> Bool
== :: Manifest -> Manifest -> Bool
$c== :: Manifest -> Manifest -> Bool
Eq)
instance ToJSON Manifest where
toJSON :: Manifest -> Value
toJSON (Manifest{[(FilePath, ByteString)]
[Text]
[ManifestPort]
(Int, Int)
ByteString
Text
HashMap Text VDomainConfiguration
transitiveDependencies :: [Text]
domains :: HashMap Text VDomainConfiguration
fileNames :: [(FilePath, ByteString)]
topComponent :: Text
componentNames :: [Text]
ports :: [ManifestPort]
successFlags :: (Int, Int)
manifestHash :: ByteString
transitiveDependencies :: Manifest -> [Text]
domains :: Manifest -> HashMap Text VDomainConfiguration
fileNames :: Manifest -> [(FilePath, ByteString)]
topComponent :: Manifest -> Text
componentNames :: Manifest -> [Text]
ports :: Manifest -> [ManifestPort]
successFlags :: Manifest -> (Int, Int)
manifestHash :: Manifest -> ByteString
..}) =
[Pair] -> Value
Aeson.object
[ Key
"version" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"unstable" :: Text)
, Key
"hash" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
toHexDigest ByteString
manifestHash
, Key
"flags" Key -> (Int, Int) -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Int, Int)
successFlags
, Key
"components" Key -> [Text] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Text]
componentNames
, Key
"top_component" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
Aeson.object
[ Key
"name" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
topComponent
, Key
"ports_flat" Key -> [ManifestPort] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [ManifestPort]
ports
]
, Key
"files" Key -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=
[ [Pair] -> Value
Aeson.object
[ Key
"name" Key -> FilePath -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= FilePath
fName
, Key
"sha256" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
toHexDigest ByteString
fHash
]
| (FilePath
fName, ByteString
fHash) <- [(FilePath, ByteString)]
fileNames]
, Key
"domains" Key -> HashMap Text Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [(Text, Value)] -> HashMap Text Value
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList
[ ( Text
domNm
, [Pair] -> Value
Aeson.object
[ Key
"period" Key -> Natural -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Natural
vPeriod
, Key
"active_edge" Key -> FilePath -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ActiveEdge -> FilePath
forall a. Show a => a -> FilePath
show ActiveEdge
vActiveEdge
, Key
"reset_kind" Key -> FilePath -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ResetKind -> FilePath
forall a. Show a => a -> FilePath
show ResetKind
vResetKind
, Key
"init_behavior" Key -> FilePath -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= InitBehavior -> FilePath
forall a. Show a => a -> FilePath
show InitBehavior
vInitBehavior
, Key
"reset_polarity" Key -> FilePath -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ResetPolarity -> FilePath
forall a. Show a => a -> FilePath
show ResetPolarity
vResetPolarity
]
)
| (Text
domNm, VDomainConfiguration{Natural
FilePath
ActiveEdge
InitBehavior
ResetKind
ResetPolarity
vResetPolarity :: VDomainConfiguration -> ResetPolarity
vResetKind :: VDomainConfiguration -> ResetKind
vPeriod :: VDomainConfiguration -> Natural
vName :: VDomainConfiguration -> FilePath
vInitBehavior :: VDomainConfiguration -> InitBehavior
vActiveEdge :: VDomainConfiguration -> ActiveEdge
vName :: FilePath
vResetPolarity :: ResetPolarity
vInitBehavior :: InitBehavior
vResetKind :: ResetKind
vActiveEdge :: ActiveEdge
vPeriod :: Natural
..}) <- HashMap Text VDomainConfiguration -> [(Text, VDomainConfiguration)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Text VDomainConfiguration
domains ]
, Key
"dependencies" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
Aeson.object
[ Key
"transitive" Key -> [Text] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Text]
transitiveDependencies ]
]
unsafeFromHexDigest :: Text -> ByteString
unsafeFromHexDigest :: Text -> ByteString
unsafeFromHexDigest =
#if MIN_VERSION_base16_bytestring(1,0,0)
ByteString -> Either FilePath ByteString -> ByteString
forall b a. b -> Either a b -> b
fromRight ByteString
"failed decode" (Either FilePath ByteString -> ByteString)
-> (Text -> Either FilePath ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either FilePath ByteString
Base16.decode (ByteString -> Either FilePath ByteString)
-> (Text -> ByteString) -> Text -> Either FilePath ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8
#else
fst . Base16.decode . Text.encodeUtf8
#endif
toHexDigest :: ByteString -> Text
toHexDigest :: ByteString -> Text
toHexDigest = ByteString -> Text
Text.decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode
parseFiles :: Aeson.Object -> Parser [(FilePath, ByteString)]
parseFiles :: Object -> Parser [(FilePath, ByteString)]
parseFiles Object
v = do
[Object]
files <- Object
v Object -> Key -> Parser [Object]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"files"
[Object]
-> (Object -> Parser (FilePath, ByteString))
-> Parser [(FilePath, ByteString)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Object]
files ((Object -> Parser (FilePath, ByteString))
-> Parser [(FilePath, ByteString)])
-> (Object -> Parser (FilePath, ByteString))
-> Parser [(FilePath, ByteString)]
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
FilePath
fName <- Object
obj Object -> Key -> Parser FilePath
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name"
Text
sha256 <- Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"sha256"
(FilePath, ByteString) -> Parser (FilePath, ByteString)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (FilePath
fName, Text -> ByteString
unsafeFromHexDigest Text
sha256)
instance FromJSON Manifest where
parseJSON :: Value -> Parser Manifest
parseJSON = FilePath -> (Object -> Parser Manifest) -> Value -> Parser Manifest
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject FilePath
"Manifest" ((Object -> Parser Manifest) -> Value -> Parser Manifest)
-> (Object -> Parser Manifest) -> Value -> Parser Manifest
forall a b. (a -> b) -> a -> b
$ \Object
v ->
let
topComponent :: Parser Object
topComponent = Object
v Object -> Key -> Parser Object
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"top_component"
in
ByteString
-> (Int, Int)
-> [ManifestPort]
-> [Text]
-> Text
-> [(FilePath, ByteString)]
-> HashMap Text VDomainConfiguration
-> [Text]
-> Manifest
Manifest
(ByteString
-> (Int, Int)
-> [ManifestPort]
-> [Text]
-> Text
-> [(FilePath, ByteString)]
-> HashMap Text VDomainConfiguration
-> [Text]
-> Manifest)
-> Parser ByteString
-> Parser
((Int, Int)
-> [ManifestPort]
-> [Text]
-> Text
-> [(FilePath, ByteString)]
-> HashMap Text VDomainConfiguration
-> [Text]
-> Manifest)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> ByteString
unsafeFromHexDigest (Text -> ByteString) -> Parser Text -> Parser ByteString
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"hash")
Parser
((Int, Int)
-> [ManifestPort]
-> [Text]
-> Text
-> [(FilePath, ByteString)]
-> HashMap Text VDomainConfiguration
-> [Text]
-> Manifest)
-> Parser (Int, Int)
-> Parser
([ManifestPort]
-> [Text]
-> Text
-> [(FilePath, ByteString)]
-> HashMap Text VDomainConfiguration
-> [Text]
-> Manifest)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Int, Int)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"flags"
Parser
([ManifestPort]
-> [Text]
-> Text
-> [(FilePath, ByteString)]
-> HashMap Text VDomainConfiguration
-> [Text]
-> Manifest)
-> Parser [ManifestPort]
-> Parser
([Text]
-> Text
-> [(FilePath, ByteString)]
-> HashMap Text VDomainConfiguration
-> [Text]
-> Manifest)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (Parser Object
topComponent Parser Object
-> (Object -> Parser [ManifestPort]) -> Parser [ManifestPort]
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Object -> Key -> Parser [ManifestPort]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"ports_flat"))
Parser
([Text]
-> Text
-> [(FilePath, ByteString)]
-> HashMap Text VDomainConfiguration
-> [Text]
-> Manifest)
-> Parser [Text]
-> Parser
(Text
-> [(FilePath, ByteString)]
-> HashMap Text VDomainConfiguration
-> [Text]
-> Manifest)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser [Text]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"components"
Parser
(Text
-> [(FilePath, ByteString)]
-> HashMap Text VDomainConfiguration
-> [Text]
-> Manifest)
-> Parser Text
-> Parser
([(FilePath, ByteString)]
-> HashMap Text VDomainConfiguration -> [Text] -> Manifest)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (Parser Object
topComponent Parser Object -> (Object -> Parser Text) -> Parser Text
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name"))
Parser
([(FilePath, ByteString)]
-> HashMap Text VDomainConfiguration -> [Text] -> Manifest)
-> Parser [(FilePath, ByteString)]
-> Parser (HashMap Text VDomainConfiguration -> [Text] -> Manifest)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Object -> Parser [(FilePath, ByteString)]
parseFiles Object
v
Parser (HashMap Text VDomainConfiguration -> [Text] -> Manifest)
-> Parser (HashMap Text VDomainConfiguration)
-> Parser ([Text] -> Manifest)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (Object
v Object -> Key -> Parser (HashMap Text Object)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"domains" Parser (HashMap Text Object)
-> (HashMap Text Object
-> Parser (HashMap Text VDomainConfiguration))
-> Parser (HashMap Text VDomainConfiguration)
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Text -> Object -> Parser VDomainConfiguration)
-> HashMap Text Object
-> Parser (HashMap Text VDomainConfiguration)
forall (f :: Type -> Type) k v1 v2.
Applicative f =>
(k -> v1 -> f v2) -> HashMap k v1 -> f (HashMap k v2)
HashMap.traverseWithKey Text -> Object -> Parser VDomainConfiguration
parseDomain)
Parser ([Text] -> Manifest) -> Parser [Text] -> Parser Manifest
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (Object
v Object -> Key -> Parser Object
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"dependencies" Parser Object -> (Object -> Parser [Text]) -> Parser [Text]
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Object -> Key -> Parser [Text]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"transitive"))
where
parseDomain :: Text -> Aeson.Object -> Parser VDomainConfiguration
parseDomain :: Text -> Object -> Parser VDomainConfiguration
parseDomain Text
nm Object
v =
FilePath
-> Natural
-> ActiveEdge
-> ResetKind
-> InitBehavior
-> ResetPolarity
-> VDomainConfiguration
VDomainConfiguration
(FilePath
-> Natural
-> ActiveEdge
-> ResetKind
-> InitBehavior
-> ResetPolarity
-> VDomainConfiguration)
-> Parser FilePath
-> Parser
(Natural
-> ActiveEdge
-> ResetKind
-> InitBehavior
-> ResetPolarity
-> VDomainConfiguration)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> Parser FilePath
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Text -> FilePath
Text.unpack Text
nm)
Parser
(Natural
-> ActiveEdge
-> ResetKind
-> InitBehavior
-> ResetPolarity
-> VDomainConfiguration)
-> Parser Natural
-> Parser
(ActiveEdge
-> ResetKind
-> InitBehavior
-> ResetPolarity
-> VDomainConfiguration)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (Object
v Object -> Key -> Parser Natural
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"period")
Parser
(ActiveEdge
-> ResetKind
-> InitBehavior
-> ResetPolarity
-> VDomainConfiguration)
-> Parser ActiveEdge
-> Parser
(ResetKind
-> InitBehavior -> ResetPolarity -> VDomainConfiguration)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Key -> Object -> Parser ActiveEdge
forall {b}. Read b => Key -> Object -> Parser b
parseWithRead Key
"active_edge" Object
v
Parser
(ResetKind
-> InitBehavior -> ResetPolarity -> VDomainConfiguration)
-> Parser ResetKind
-> Parser (InitBehavior -> ResetPolarity -> VDomainConfiguration)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Key -> Object -> Parser ResetKind
forall {b}. Read b => Key -> Object -> Parser b
parseWithRead Key
"reset_kind" Object
v
Parser (InitBehavior -> ResetPolarity -> VDomainConfiguration)
-> Parser InitBehavior
-> Parser (ResetPolarity -> VDomainConfiguration)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Key -> Object -> Parser InitBehavior
forall {b}. Read b => Key -> Object -> Parser b
parseWithRead Key
"init_behavior" Object
v
Parser (ResetPolarity -> VDomainConfiguration)
-> Parser ResetPolarity -> Parser VDomainConfiguration
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Key -> Object -> Parser ResetPolarity
forall {b}. Read b => Key -> Object -> Parser b
parseWithRead Key
"reset_polarity" Object
v
parseWithRead :: Key -> Object -> Parser b
parseWithRead Key
field Object
obj = do
Maybe FilePath
v <- Object
obj Object -> Key -> Parser (Maybe FilePath)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
field
case FilePath -> Maybe b
forall a. Read a => FilePath -> Maybe a
readMaybe (FilePath -> Maybe b) -> Maybe FilePath -> Maybe b
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe FilePath
v of
Just b
a -> b -> Parser b
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure b
a
Maybe b
Nothing -> FilePath -> Parser b
forall (m :: Type -> Type) a. MonadFail m => FilePath -> m a
fail (FilePath -> Parser b) -> FilePath -> Parser b
forall a b. (a -> b) -> a -> b
$ FilePath
"Could not read field: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Key -> FilePath
forall a. Show a => a -> FilePath
show Key
field
data UnexpectedModification
= Modified FilePath
| Added FilePath
| Removed FilePath
deriving (Int -> UnexpectedModification -> ShowS
[UnexpectedModification] -> ShowS
UnexpectedModification -> FilePath
(Int -> UnexpectedModification -> ShowS)
-> (UnexpectedModification -> FilePath)
-> ([UnexpectedModification] -> ShowS)
-> Show UnexpectedModification
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [UnexpectedModification] -> ShowS
$cshowList :: [UnexpectedModification] -> ShowS
show :: UnexpectedModification -> FilePath
$cshow :: UnexpectedModification -> FilePath
showsPrec :: Int -> UnexpectedModification -> ShowS
$cshowsPrec :: Int -> UnexpectedModification -> ShowS
Show)
mkManifestPort ::
Backend backend =>
backend ->
Id.Identifier ->
HWType ->
PortDirection ->
ManifestPort
mkManifestPort :: forall backend.
Backend backend =>
backend -> Identifier -> HWType -> PortDirection -> ManifestPort
mkManifestPort backend
backend Identifier
portId HWType
portType PortDirection
portDir = ManifestPort :: Text
-> Text
-> PortDirection
-> Int
-> Bool
-> Maybe Text
-> ManifestPort
ManifestPort{Bool
Int
Maybe Text
Text
PortDirection
mpTypeName :: Text
mpDomain :: Maybe Text
mpIsClock :: Bool
mpDirection :: PortDirection
mpWidth :: Int
mpName :: Text
mpDomain :: Maybe Text
mpIsClock :: Bool
mpWidth :: Int
mpDirection :: PortDirection
mpTypeName :: Text
mpName :: Text
..}
where
mpName :: Text
mpName = Identifier -> Text
Id.toText Identifier
portId
mpWidth :: Int
mpWidth = HWType -> Int
typeSize HWType
portType
mpDirection :: PortDirection
mpDirection = PortDirection
portDir
mpIsClock :: Bool
mpIsClock = case HWType
portType of {Clock Text
_ -> Bool
True; HWType
_ -> Bool
False}
mpDomain :: Maybe Text
mpDomain = HWType -> Maybe Text
hwTypeDomain HWType
portType
mpTypeName :: Text
mpTypeName = (State backend Text -> backend -> Text)
-> backend -> State backend Text -> Text
forall a b c. (a -> b -> c) -> b -> a -> c
flip State backend Text -> backend -> Text
forall s a. State s a -> s -> a
evalState backend
backend (State backend Text -> Text) -> State backend Text -> Text
forall a b. (a -> b) -> a -> b
$ Ap (State backend) Text -> State backend Text
forall {k} (f :: k -> Type) (a :: k). Ap f a -> f a
getAp (Ap (State backend) Text -> State backend Text)
-> Ap (State backend) Text -> State backend Text
forall a b. (a -> b) -> a -> b
$ do
Text -> Text
LText.toStrict (Text -> Text) -> (Doc () -> Text) -> Doc () -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc () -> Text
forall ann. Doc ann -> Text
renderOneLine (Doc () -> Text)
-> Ap (State backend) (Doc ()) -> Ap (State backend) Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Usage -> HWType -> Ap (State backend) (Doc ())
forall state.
Backend state =>
Usage -> HWType -> Ap (State state) (Doc ())
hdlType (Text -> Usage
External Text
mpName) HWType
portType
manifestFilename :: IsString a => a
manifestFilename :: forall a. IsString a => a
manifestFilename = a
"clash-manifest.json"
mkManifest ::
Backend backend =>
backend ->
HashMap Text VDomainConfiguration ->
ClashOpts ->
Component ->
[Component] ->
[Id] ->
[(FilePath, ByteString)] ->
ByteString ->
Manifest
mkManifest :: forall backend.
Backend backend =>
backend
-> HashMap Text VDomainConfiguration
-> ClashOpts
-> Component
-> [Component]
-> [Id]
-> [(FilePath, ByteString)]
-> ByteString
-> Manifest
mkManifest backend
backend HashMap Text VDomainConfiguration
domains ClashOpts{Bool
Int
[FilePath]
Maybe FilePath
Maybe (Maybe Int)
Maybe Text
Word
OverridingBool
PreserveCase
HdlSyn
DebugOpts
opt_renderEnums :: ClashOpts -> Bool
opt_edalize :: ClashOpts -> Bool
opt_inlineWFCacheLimit :: ClashOpts -> Word
opt_aggressiveXOptBB :: ClashOpts -> Bool
opt_aggressiveXOpt :: ClashOpts -> Bool
opt_checkIDir :: ClashOpts -> Bool
opt_forceUndefined :: ClashOpts -> Maybe (Maybe Int)
opt_ultra :: ClashOpts -> Bool
opt_lowerCaseBasicIds :: ClashOpts -> PreserveCase
opt_escapedIds :: ClashOpts -> Bool
opt_newInlineStrat :: ClashOpts -> Bool
opt_componentPrefix :: ClashOpts -> Maybe Text
opt_importPaths :: ClashOpts -> [FilePath]
opt_errorExtra :: ClashOpts -> Bool
opt_hdlSyn :: ClashOpts -> HdlSyn
opt_hdlDir :: ClashOpts -> Maybe FilePath
opt_intWidth :: ClashOpts -> Int
opt_color :: ClashOpts -> OverridingBool
opt_primWarn :: ClashOpts -> Bool
opt_clear :: ClashOpts -> Bool
opt_cachehdl :: ClashOpts -> Bool
opt_debug :: ClashOpts -> DebugOpts
opt_evaluatorFuelLimit :: ClashOpts -> Word
opt_inlineConstantLimit :: ClashOpts -> Word
opt_inlineFunctionLimit :: ClashOpts -> Word
opt_specLimit :: ClashOpts -> Int
opt_inlineLimit :: ClashOpts -> Int
opt_werror :: ClashOpts -> Bool
opt_renderEnums :: Bool
opt_edalize :: Bool
opt_inlineWFCacheLimit :: Word
opt_aggressiveXOptBB :: Bool
opt_aggressiveXOpt :: Bool
opt_checkIDir :: Bool
opt_forceUndefined :: Maybe (Maybe Int)
opt_ultra :: Bool
opt_lowerCaseBasicIds :: PreserveCase
opt_escapedIds :: Bool
opt_newInlineStrat :: Bool
opt_componentPrefix :: Maybe Text
opt_importPaths :: [FilePath]
opt_errorExtra :: Bool
opt_hdlSyn :: HdlSyn
opt_hdlDir :: Maybe FilePath
opt_intWidth :: Int
opt_color :: OverridingBool
opt_primWarn :: Bool
opt_clear :: Bool
opt_cachehdl :: Bool
opt_debug :: DebugOpts
opt_evaluatorFuelLimit :: Word
opt_inlineConstantLimit :: Word
opt_inlineFunctionLimit :: Word
opt_specLimit :: Int
opt_inlineLimit :: Int
opt_werror :: Bool
..} Component{[(Identifier, HWType)]
[(WireOrReg, (Identifier, HWType), Maybe Expr)]
[Declaration]
Identifier
declarations :: Component -> [Declaration]
outputs :: Component -> [(WireOrReg, (Identifier, HWType), Maybe Expr)]
inputs :: Component -> [(Identifier, HWType)]
componentName :: Component -> Identifier
declarations :: [Declaration]
outputs :: [(WireOrReg, (Identifier, HWType), Maybe Expr)]
inputs :: [(Identifier, HWType)]
componentName :: Identifier
..} [Component]
components [Id]
deps [(FilePath, ByteString)]
files ByteString
topHash = Manifest :: ByteString
-> (Int, Int)
-> [ManifestPort]
-> [Text]
-> Text
-> [(FilePath, ByteString)]
-> HashMap Text VDomainConfiguration
-> [Text]
-> Manifest
Manifest
{ manifestHash :: ByteString
manifestHash = ByteString
topHash
, ports :: [ManifestPort]
ports = [ManifestPort]
inPorts [ManifestPort] -> [ManifestPort] -> [ManifestPort]
forall a. Semigroup a => a -> a -> a
<> [ManifestPort]
inOutPorts [ManifestPort] -> [ManifestPort] -> [ManifestPort]
forall a. Semigroup a => a -> a -> a
<> [ManifestPort]
outPorts
, componentNames :: [Text]
componentNames = (Identifier -> Text) -> [Identifier] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Identifier -> Text
Id.toText [Identifier]
compNames
, topComponent :: Text
topComponent = Identifier -> Text
Id.toText Identifier
componentName
, fileNames :: [(FilePath, ByteString)]
fileNames = [(FilePath, ByteString)]
files
, successFlags :: (Int, Int)
successFlags = (Int
opt_inlineLimit, Int
opt_specLimit)
, domains :: HashMap Text VDomainConfiguration
domains = HashMap Text VDomainConfiguration
domains
, transitiveDependencies :: [Text]
transitiveDependencies = (Id -> Text) -> [Id] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Name Term -> Text
forall a. Name a -> Text
nameOcc (Name Term -> Text) -> (Id -> Name Term) -> Id -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name Term
forall a. Var a -> Name a
varName) [Id]
deps
}
where
compNames :: [Identifier]
compNames = (Component -> Identifier) -> [Component] -> [Identifier]
forall a b. (a -> b) -> [a] -> [b]
map Component -> Identifier
Netlist.componentName [Component]
components
inPorts :: [ManifestPort]
inPorts =
[backend -> Identifier -> HWType -> PortDirection -> ManifestPort
forall backend.
Backend backend =>
backend -> Identifier -> HWType -> PortDirection -> ManifestPort
mkManifestPort backend
backend Identifier
pName HWType
pType PortDirection
In | p :: (Identifier, HWType)
p@(Identifier
pName, HWType
pType) <- [(Identifier, HWType)]
inputs, Bool -> Bool
not ((Identifier, HWType) -> Bool
Netlist.isBiDirectional (Identifier, HWType)
p)]
inOutPorts :: [ManifestPort]
inOutPorts =
[backend -> Identifier -> HWType -> PortDirection -> ManifestPort
forall backend.
Backend backend =>
backend -> Identifier -> HWType -> PortDirection -> ManifestPort
mkManifestPort backend
backend Identifier
pName HWType
pType PortDirection
InOut | p :: (Identifier, HWType)
p@(Identifier
pName, HWType
pType) <- [(Identifier, HWType)]
inputs, (Identifier, HWType) -> Bool
Netlist.isBiDirectional (Identifier, HWType)
p]
outPorts :: [ManifestPort]
outPorts =
[backend -> Identifier -> HWType -> PortDirection -> ManifestPort
forall backend.
Backend backend =>
backend -> Identifier -> HWType -> PortDirection -> ManifestPort
mkManifestPort backend
backend Identifier
pName HWType
pType PortDirection
Out | (WireOrReg
_, (Identifier
pName, HWType
pType), Maybe Expr
_) <- [(WireOrReg, (Identifier, HWType), Maybe Expr)]
outputs]
pprintUnexpectedModification :: UnexpectedModification -> String
pprintUnexpectedModification :: UnexpectedModification -> FilePath
pprintUnexpectedModification = \case
Modified FilePath
p -> FilePath
"Unexpected modification in " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
p
Added FilePath
p -> FilePath
"Unexpected extra file " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
p
Removed FilePath
p -> FilePath
"Unexpected removed file " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
p
pprintUnexpectedModifications :: Int -> [UnexpectedModification] -> String
pprintUnexpectedModifications :: Int -> [UnexpectedModification] -> FilePath
pprintUnexpectedModifications Int
0 [UnexpectedModification]
us = Int -> [UnexpectedModification] -> FilePath
pprintUnexpectedModifications Int
forall a. Bounded a => a
maxBound [UnexpectedModification]
us
pprintUnexpectedModifications Int
_ [] = []
pprintUnexpectedModifications Int
_ [UnexpectedModification
u] = FilePath
"* " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> UnexpectedModification -> FilePath
pprintUnexpectedModification UnexpectedModification
u
pprintUnexpectedModifications Int
1 (UnexpectedModification
u:[UnexpectedModification]
us) =
FilePath
"* and " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show ([UnexpectedModification] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length (UnexpectedModification
uUnexpectedModification
-> [UnexpectedModification] -> [UnexpectedModification]
forall a. a -> [a] -> [a]
:[UnexpectedModification]
us)) FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" more unexpected changes"
pprintUnexpectedModifications Int
n (UnexpectedModification
u:[UnexpectedModification]
us) =
FilePath
"* " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> UnexpectedModification -> FilePath
pprintUnexpectedModification UnexpectedModification
u
FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"\n" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [UnexpectedModification] -> FilePath
pprintUnexpectedModifications (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [UnexpectedModification]
us
readFreshManifest ::
[TopEntityT] ->
(BindingMap, Id) ->
CompiledPrimMap ->
ClashOpts ->
UTCTime ->
FilePath ->
IO (Maybe [UnexpectedModification], Maybe Manifest, ByteString)
readFreshManifest :: [TopEntityT]
-> (BindingMap, Id)
-> CompiledPrimMap
-> ClashOpts
-> UTCTime
-> FilePath
-> IO (Maybe [UnexpectedModification], Maybe Manifest, ByteString)
readFreshManifest [TopEntityT]
tops (BindingMap
bindingsMap, Id
topId) CompiledPrimMap
primMap opts :: ClashOpts
opts@(ClashOpts{Bool
Int
[FilePath]
Maybe FilePath
Maybe (Maybe Int)
Maybe Text
Word
OverridingBool
PreserveCase
HdlSyn
DebugOpts
opt_renderEnums :: Bool
opt_edalize :: Bool
opt_inlineWFCacheLimit :: Word
opt_aggressiveXOptBB :: Bool
opt_aggressiveXOpt :: Bool
opt_checkIDir :: Bool
opt_forceUndefined :: Maybe (Maybe Int)
opt_ultra :: Bool
opt_lowerCaseBasicIds :: PreserveCase
opt_escapedIds :: Bool
opt_newInlineStrat :: Bool
opt_componentPrefix :: Maybe Text
opt_importPaths :: [FilePath]
opt_errorExtra :: Bool
opt_hdlSyn :: HdlSyn
opt_hdlDir :: Maybe FilePath
opt_intWidth :: Int
opt_color :: OverridingBool
opt_primWarn :: Bool
opt_clear :: Bool
opt_cachehdl :: Bool
opt_debug :: DebugOpts
opt_evaluatorFuelLimit :: Word
opt_inlineConstantLimit :: Word
opt_inlineFunctionLimit :: Word
opt_specLimit :: Int
opt_inlineLimit :: Int
opt_werror :: Bool
opt_renderEnums :: ClashOpts -> Bool
opt_edalize :: ClashOpts -> Bool
opt_inlineWFCacheLimit :: ClashOpts -> Word
opt_aggressiveXOptBB :: ClashOpts -> Bool
opt_aggressiveXOpt :: ClashOpts -> Bool
opt_checkIDir :: ClashOpts -> Bool
opt_forceUndefined :: ClashOpts -> Maybe (Maybe Int)
opt_ultra :: ClashOpts -> Bool
opt_lowerCaseBasicIds :: ClashOpts -> PreserveCase
opt_escapedIds :: ClashOpts -> Bool
opt_newInlineStrat :: ClashOpts -> Bool
opt_componentPrefix :: ClashOpts -> Maybe Text
opt_importPaths :: ClashOpts -> [FilePath]
opt_errorExtra :: ClashOpts -> Bool
opt_hdlSyn :: ClashOpts -> HdlSyn
opt_hdlDir :: ClashOpts -> Maybe FilePath
opt_intWidth :: ClashOpts -> Int
opt_color :: ClashOpts -> OverridingBool
opt_primWarn :: ClashOpts -> Bool
opt_clear :: ClashOpts -> Bool
opt_cachehdl :: ClashOpts -> Bool
opt_debug :: ClashOpts -> DebugOpts
opt_evaluatorFuelLimit :: ClashOpts -> Word
opt_inlineConstantLimit :: ClashOpts -> Word
opt_inlineFunctionLimit :: ClashOpts -> Word
opt_specLimit :: ClashOpts -> Int
opt_inlineLimit :: ClashOpts -> Int
opt_werror :: ClashOpts -> Bool
..}) UTCTime
clashModDate FilePath
path = do
Maybe [UnexpectedModification]
modificationsM <- (FilesManifest -> IO [UnexpectedModification])
-> Maybe FilesManifest -> IO (Maybe [UnexpectedModification])
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (FilePath -> FilesManifest -> IO [UnexpectedModification]
isUserModified FilePath
path) (Maybe FilesManifest -> IO (Maybe [UnexpectedModification]))
-> IO (Maybe FilesManifest) -> IO (Maybe [UnexpectedModification])
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO (Maybe FilesManifest)
forall a. FromJSON a => FilePath -> IO (Maybe a)
readManifest FilePath
path
Maybe Manifest
manifestM <- FilePath -> IO (Maybe Manifest)
forall a. FromJSON a => FilePath -> IO (Maybe a)
readManifest FilePath
path
(Maybe [UnexpectedModification], Maybe Manifest, ByteString)
-> IO (Maybe [UnexpectedModification], Maybe Manifest, ByteString)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure
( Maybe [UnexpectedModification]
modificationsM
, Manifest -> Maybe Manifest
checkManifest (Manifest -> Maybe Manifest) -> Maybe Manifest -> Maybe Manifest
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< if Bool
opt_cachehdl then Maybe Manifest
manifestM else Maybe Manifest
forall a. Maybe a
Nothing
, ByteString
topHash
)
where
optsHash :: Int
optsHash = ClashOpts -> Int
forall a. Hashable a => a -> Int
hash ClashOpts
opts {
opt_debug :: DebugOpts
opt_debug = DebugOpts
opt_debug
{ dbg_invariants :: Bool
dbg_invariants = Bool
False
, dbg_transformations :: Set FilePath
dbg_transformations = Set FilePath
forall a. Set a
Set.empty
, dbg_historyFile :: Maybe FilePath
dbg_historyFile = Maybe FilePath
forall a. Maybe a
Nothing
}
, opt_cachehdl :: Bool
opt_cachehdl = Bool
True
, opt_primWarn :: Bool
opt_primWarn = Bool
True
, opt_color :: OverridingBool
opt_color = OverridingBool
Auto
, opt_errorExtra :: Bool
opt_errorExtra = Bool
False
, opt_checkIDir :: Bool
opt_checkIDir = Bool
True
, opt_edalize :: Bool
opt_edalize = Bool
False
, opt_inlineLimit :: Int
opt_inlineLimit = Int
20
, opt_specLimit :: Int
opt_specLimit = Int
20
, opt_hdlDir :: Maybe FilePath
opt_hdlDir = Maybe FilePath
forall a. Maybe a
Nothing
}
topHash :: ByteString
topHash = ByteString -> ByteString
Sha256.hashlazy (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ([TopEntityT], Int, FilePath, [Term], Int) -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode
( [TopEntityT]
tops
, CompiledPrimMap -> Int
hashCompiledPrimMap CompiledPrimMap
primMap
, UTCTime -> FilePath
forall a. Show a => a -> FilePath
show UTCTime
clashModDate
, BindingMap -> Id -> [Term]
callGraphBindings BindingMap
bindingsMap Id
topId
, Int
optsHash
)
checkManifest :: Manifest -> Maybe Manifest
checkManifest manifest :: Manifest
manifest@Manifest{ByteString
manifestHash :: ByteString
manifestHash :: Manifest -> ByteString
manifestHash,(Int, Int)
successFlags :: (Int, Int)
successFlags :: Manifest -> (Int, Int)
successFlags}
| (Int
cachedInline, Int
cachedSpec) <- (Int, Int)
successFlags
, Int
cachedInline Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
opt_inlineLimit
, Int
cachedSpec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
opt_specLimit
, ByteString
manifestHash ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
topHash
= Manifest -> Maybe Manifest
forall a. a -> Maybe a
Just Manifest
manifest
| Bool
otherwise = Maybe Manifest
forall a. Maybe a
Nothing
isUserModified :: FilePath -> FilesManifest -> IO [UnexpectedModification]
isUserModified :: FilePath -> FilesManifest -> IO [UnexpectedModification]
isUserModified (ShowS
takeDirectory -> FilePath
topDir) (FilesManifest [(FilePath, ByteString)]
fileNames) = do
let
manifestFiles :: Set FilePath
manifestFiles = [FilePath] -> Set FilePath
forall a. Ord a => [a] -> Set a
Set.fromList (((FilePath, ByteString) -> FilePath)
-> [(FilePath, ByteString)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, ByteString) -> FilePath
forall a b. (a, b) -> a
fst [(FilePath, ByteString)]
fileNames)
Set FilePath
currentFiles <- (FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => a -> Set a -> Set a
Set.delete FilePath
forall a. IsString a => a
manifestFilename (Set FilePath -> Set FilePath)
-> ([FilePath] -> Set FilePath) -> [FilePath] -> Set FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> Set FilePath
forall a. Ord a => [a] -> Set a
Set.fromList) ([FilePath] -> Set FilePath) -> IO [FilePath] -> IO (Set FilePath)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
listDirectory FilePath
topDir
let
removedFiles :: [FilePath]
removedFiles = Set FilePath -> [FilePath]
forall a. Set a -> [a]
Set.toList (Set FilePath
manifestFiles Set FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set FilePath
currentFiles)
addedFiles :: [FilePath]
addedFiles = Set FilePath -> [FilePath]
forall a. Set a -> [a]
Set.toList (Set FilePath
currentFiles Set FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set FilePath
manifestFiles)
[FilePath]
changedFiles <- [Maybe FilePath] -> [FilePath]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe FilePath] -> [FilePath])
-> IO [Maybe FilePath] -> IO [FilePath]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((FilePath, ByteString) -> IO (Maybe FilePath))
-> [(FilePath, ByteString)] -> IO [Maybe FilePath]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FilePath, ByteString) -> IO (Maybe FilePath)
detectModification [(FilePath, ByteString)]
fileNames
[UnexpectedModification] -> IO [UnexpectedModification]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure
( (FilePath -> UnexpectedModification)
-> [FilePath] -> [UnexpectedModification]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> UnexpectedModification
Removed [FilePath]
removedFiles
[UnexpectedModification]
-> [UnexpectedModification] -> [UnexpectedModification]
forall a. Semigroup a => a -> a -> a
<> (FilePath -> UnexpectedModification)
-> [FilePath] -> [UnexpectedModification]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> UnexpectedModification
Added [FilePath]
addedFiles
[UnexpectedModification]
-> [UnexpectedModification] -> [UnexpectedModification]
forall a. Semigroup a => a -> a -> a
<> (FilePath -> UnexpectedModification)
-> [FilePath] -> [UnexpectedModification]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> UnexpectedModification
Modified [FilePath]
changedFiles )
where
detectModification :: (FilePath, ByteString) -> IO (Maybe FilePath)
detectModification :: (FilePath, ByteString) -> IO (Maybe FilePath)
detectModification (FilePath
filename, ByteString
manifestDigest) = do
let fullPath :: FilePath
fullPath = FilePath
topDir FilePath -> ShowS
</> FilePath
filename
Bool
fileExists <- FilePath -> IO Bool
doesFileExist FilePath
fullPath
if Bool
fileExists then do
ByteString
contents <- FilePath -> IO ByteString
ByteStringLazy.readFile FilePath
fullPath
if ByteString
manifestDigest ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> ByteString
Sha256.hashlazy ByteString
contents
then Maybe FilePath -> IO (Maybe FilePath)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe FilePath
forall a. Maybe a
Nothing
else Maybe FilePath -> IO (Maybe FilePath)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
filename)
else
Maybe FilePath -> IO (Maybe FilePath)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe FilePath
forall a. Maybe a
Nothing
readManifest :: FromJSON a => FilePath -> IO (Maybe a)
readManifest :: forall a. FromJSON a => FilePath -> IO (Maybe a)
readManifest FilePath
path = do
Either () (Maybe a)
contentsE <- (IOError -> Maybe ()) -> IO (Maybe a) -> IO (Either () (Maybe a))
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust (Bool -> Maybe ()
forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError) (FilePath -> IO (Maybe a)
forall a. FromJSON a => FilePath -> IO (Maybe a)
Aeson.decodeFileStrict FilePath
path)
Maybe a -> IO (Maybe a)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((() -> Maybe a)
-> (Maybe a -> Maybe a) -> Either () (Maybe a) -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> () -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) Maybe a -> Maybe a
forall a. a -> a
id Either () (Maybe a)
contentsE)
writeManifest :: FilePath -> Manifest -> IO ()
writeManifest :: FilePath -> Manifest -> IO ()
writeManifest FilePath
path = FilePath -> ByteString -> IO ()
ByteStringLazy.writeFile FilePath
path (ByteString -> IO ())
-> (Manifest -> ByteString) -> Manifest -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Manifest -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encodePretty
serializeManifest :: Manifest -> Text
serializeManifest :: Manifest -> Text
serializeManifest = Text -> Text
LText.toStrict (Text -> Text) -> (Manifest -> Text) -> Manifest -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
LText.decodeUtf8 (ByteString -> Text)
-> (Manifest -> ByteString) -> Manifest -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Manifest -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encodePretty