{-|
Copyright  : (C) 2021-2023, QBayLogic B.V.
License    : BSD2 (see the file LICENSE)
Maintainer : QBayLogic B.V. <devops@qbaylogic.com>

Functions to read, write, and handle manifest files.
-}

{-# 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.Bool (OverridingBool(..))
import           Clash.Driver.Types
import           Clash.Primitives.Types
import           Clash.Core.Var (Id, varName)
import           Clash.Netlist.Types
  (TopEntityT, Component(..), HWType (Clock, ClockN), 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)

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
$cfrom :: forall x. PortDirection -> Rep PortDirection x
from :: forall x. PortDirection -> Rep PortDirection x
$cto :: forall x. Rep PortDirection x -> PortDirection
to :: forall x. Rep PortDirection x -> PortDirection
Generic, PortDirection -> PortDirection -> Bool
(PortDirection -> PortDirection -> Bool)
-> (PortDirection -> PortDirection -> Bool) -> Eq PortDirection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PortDirection -> PortDirection -> Bool
== :: PortDirection -> PortDirection -> Bool
$c/= :: PortDirection -> PortDirection -> Bool
/= :: 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
$creadsPrec :: Int -> ReadS PortDirection
readsPrec :: Int -> ReadS PortDirection
$creadList :: ReadS [PortDirection]
readList :: ReadS [PortDirection]
$creadPrec :: ReadPrec PortDirection
readPrec :: ReadPrec PortDirection
$creadListPrec :: ReadPrec [PortDirection]
readListPrec :: ReadPrec [PortDirection]
Read, Int -> PortDirection -> ShowS
[PortDirection] -> ShowS
PortDirection -> String
(Int -> PortDirection -> ShowS)
-> (PortDirection -> String)
-> ([PortDirection] -> ShowS)
-> Show PortDirection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PortDirection -> ShowS
showsPrec :: Int -> PortDirection -> ShowS
$cshow :: PortDirection -> String
show :: PortDirection -> String
$cshowList :: [PortDirection] -> ShowS
showList :: [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
    { Aeson.constructorTagModifier = fmap 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
    { Aeson.constructorTagModifier = fmap toLower }

data ManifestPort = ManifestPort
  { ManifestPort -> Text
mpName :: Text
  -- ^ Port name (as rendered in HDL)
  , ManifestPort -> Text
mpTypeName :: Text
  -- ^ Type name (as rendered in HDL)
  , ManifestPort -> PortDirection
mpDirection :: PortDirection
  -- ^ Port direction (in / out / inout)
  , ManifestPort -> Int
mpWidth :: Int
  -- ^ Port width in bits
  , ManifestPort -> Bool
mpIsClock :: Bool
  -- ^ Is this port a clock?
  , ManifestPort -> Maybe Text
mpDomain :: Maybe Text
  -- ^ Domain this port belongs to. This is currently only included for clock,
  -- reset, and enable ports. TODO: add to all ports originally defined as a
  -- @Signal@ too.
  } deriving (Int -> ManifestPort -> ShowS
[ManifestPort] -> ShowS
ManifestPort -> String
(Int -> ManifestPort -> ShowS)
-> (ManifestPort -> String)
-> ([ManifestPort] -> ShowS)
-> Show ManifestPort
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ManifestPort -> ShowS
showsPrec :: Int -> ManifestPort -> ShowS
$cshow :: ManifestPort -> String
show :: ManifestPort -> String
$cshowList :: [ManifestPort] -> ShowS
showList :: [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
$creadsPrec :: Int -> ReadS ManifestPort
readsPrec :: Int -> ReadS ManifestPort
$creadList :: ReadS [ManifestPort]
readList :: ReadS [ManifestPort]
$creadPrec :: ReadPrec ManifestPort
readPrec :: ReadPrec ManifestPort
$creadListPrec :: ReadPrec [ManifestPort]
readListPrec :: ReadPrec [ManifestPort]
Read,ManifestPort -> ManifestPort -> Bool
(ManifestPort -> ManifestPort -> Bool)
-> (ManifestPort -> ManifestPort -> Bool) -> Eq ManifestPort
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ManifestPort -> ManifestPort -> Bool
== :: ManifestPort -> ManifestPort -> Bool
$c/= :: ManifestPort -> ManifestPort -> Bool
/= :: ManifestPort -> ManifestPort -> Bool
Eq)

instance ToJSON ManifestPort where
  toJSON :: ManifestPort -> Value
toJSON (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
mpName :: Text
mpTypeName :: Text
mpDirection :: PortDirection
mpWidth :: Int
mpIsClock :: Bool
mpDomain :: Maybe Text
..}) =
    [Pair] -> Value
Aeson.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
      [ Key
"name" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
mpName
      , Key
"type_name" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
mpTypeName
      , Key
"direction" Key -> PortDirection -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= PortDirection
mpDirection
      , Key
"width" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
mpWidth
      , Key
"is_clock" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e 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 v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
dom]
        Maybe Text
Nothing -> [] )

instance FromJSON ManifestPort where
  parseJSON :: Value -> Parser ManifestPort
parseJSON = String
-> (Object -> Parser ManifestPort) -> Value -> Parser ManifestPort
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"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 a b. Parser (a -> b) -> Parser a -> Parser b
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 a b. Parser (a -> b) -> Parser a -> Parser b
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 a b. Parser (a -> b) -> Parser a -> Parser b
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 a b. Parser (a -> b) -> Parser a -> Parser b
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 a b. Parser (a -> b) -> Parser a -> Parser b
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"

-- | Just the 'fileNames' part of 'Manifest'
newtype FilesManifest = FilesManifest [(FilePath, ByteString)]

instance FromJSON FilesManifest where
  parseJSON :: Value -> Parser FilesManifest
parseJSON = String
-> (Object -> Parser FilesManifest)
-> Value
-> Parser FilesManifest
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"FilesManifest" ((Object -> Parser FilesManifest) -> Value -> Parser FilesManifest)
-> (Object -> Parser FilesManifest)
-> Value
-> Parser FilesManifest
forall a b. (a -> b) -> a -> b
$ ([(String, ByteString)] -> FilesManifest)
-> Parser [(String, ByteString)] -> Parser FilesManifest
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap [(String, ByteString)] -> FilesManifest
FilesManifest (Parser [(String, ByteString)] -> Parser FilesManifest)
-> (Object -> Parser [(String, ByteString)])
-> Object
-> Parser FilesManifest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Parser [(String, ByteString)]
parseFiles

-- | Per-input subhashes of the @manifestHash@. Exposed as @__debug_hash@ in
-- the JSON manifest purely as a debugging aid: when two manifests disagree on
-- @hash@, comparing these fields tells you *which* input changed. The leading
-- double underscore and @debug@ in the name signal that downstream tools
-- should not rely on these — their existence, names, and contents may change
-- between Clash versions.
data DebugSubHashes = DebugSubHashes
  { DebugSubHashes -> ByteString
dshTops :: ByteString
    -- ^ Hash of the full @[TopEntityT]@ list discovered in the design.
  , DebugSubHashes -> ByteString
dshPrimMap :: ByteString
    -- ^ Hash of the compiled primitive map.
  , DebugSubHashes -> ByteString
dshClashModDate :: ByteString
    -- ^ Hash of the @clash@ executable's modification time.
  , DebugSubHashes -> ByteString
dshCallGraph :: ByteString
    -- ^ Hash of the call-graph closure of the top entity (i.e., the bindings
    -- that actually contribute to the generated HDL).
  , DebugSubHashes -> ByteString
dshOpts :: ByteString
    -- ^ Hash of the (HDL-affecting subset of the) 'ClashOpts'.
  } deriving (Int -> DebugSubHashes -> ShowS
[DebugSubHashes] -> ShowS
DebugSubHashes -> String
(Int -> DebugSubHashes -> ShowS)
-> (DebugSubHashes -> String)
-> ([DebugSubHashes] -> ShowS)
-> Show DebugSubHashes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DebugSubHashes -> ShowS
showsPrec :: Int -> DebugSubHashes -> ShowS
$cshow :: DebugSubHashes -> String
show :: DebugSubHashes -> String
$cshowList :: [DebugSubHashes] -> ShowS
showList :: [DebugSubHashes] -> ShowS
Show, ReadPrec [DebugSubHashes]
ReadPrec DebugSubHashes
Int -> ReadS DebugSubHashes
ReadS [DebugSubHashes]
(Int -> ReadS DebugSubHashes)
-> ReadS [DebugSubHashes]
-> ReadPrec DebugSubHashes
-> ReadPrec [DebugSubHashes]
-> Read DebugSubHashes
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS DebugSubHashes
readsPrec :: Int -> ReadS DebugSubHashes
$creadList :: ReadS [DebugSubHashes]
readList :: ReadS [DebugSubHashes]
$creadPrec :: ReadPrec DebugSubHashes
readPrec :: ReadPrec DebugSubHashes
$creadListPrec :: ReadPrec [DebugSubHashes]
readListPrec :: ReadPrec [DebugSubHashes]
Read, DebugSubHashes -> DebugSubHashes -> Bool
(DebugSubHashes -> DebugSubHashes -> Bool)
-> (DebugSubHashes -> DebugSubHashes -> Bool) -> Eq DebugSubHashes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DebugSubHashes -> DebugSubHashes -> Bool
== :: DebugSubHashes -> DebugSubHashes -> Bool
$c/= :: DebugSubHashes -> DebugSubHashes -> Bool
/= :: DebugSubHashes -> DebugSubHashes -> Bool
Eq)

-- | Information about the generated HDL between (sub)runs of the compiler
data Manifest
  = Manifest
  { Manifest -> ByteString
manifestHash :: ByteString
    -- ^ Hash digest of the TopEntity and all its dependencies.
  , Manifest -> Maybe DebugSubHashes
manifestDebugSubHashes :: Maybe DebugSubHashes
    -- ^ Per-input subhashes that feed into 'manifestHash'. Debug-only — see
    -- 'DebugSubHashes'. 'Nothing' when reading an older manifest that
    -- predates this field.
  , Manifest -> (Int, Int)
successFlags  :: (Int, Int)
    -- ^ Compiler flags used to achieve successful compilation:
    --
    --   * opt_inlineLimit
    --   * opt_specLimit
  , Manifest -> [ManifestPort]
ports :: [ManifestPort]
    -- ^ Ports in the generated @TopEntity@.
  , Manifest -> [Text]
componentNames :: [Text]
    -- ^ Names of all the generated components for the @TopEntity@ (does not
    -- include the names of the components of the @TestBench@ accompanying
    -- the @TopEntity@).
    --
    -- This list is reverse topologically sorted. I.e., a component might depend
    -- on any component listed before it, but not after it.
  , Manifest -> Text
topComponent :: Text
    -- ^ Design entry point. This is usually the component annotated with a
    -- @TopEntity@ annotation.
  , Manifest -> [(String, ByteString)]
fileNames :: [(FilePath, ByteString)]
    -- ^ Names and hashes of all the generated files for the @TopEntity@. Hashes
    -- are SHA256.
    --
    -- This list is reverse topologically sorted. I.e., a component might depend
    -- on any component listed before it, but not after it.
  , Manifest -> HashMap Text VDomainConfiguration
domains :: HashMap Text VDomainConfiguration
    -- ^ Domains encountered in design
  , Manifest -> [Text]
transitiveDependencies :: [Text]
    -- ^ Dependencies of this design (fully qualified binder names). Is a
    -- transitive closure of all dependencies.
    --
    -- This list is reverse topologically sorted. I.e., a component might depend
    -- on any component listed before it, but not after it.
  } deriving (Int -> Manifest -> ShowS
[Manifest] -> ShowS
Manifest -> String
(Int -> Manifest -> ShowS)
-> (Manifest -> String) -> ([Manifest] -> ShowS) -> Show Manifest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Manifest -> ShowS
showsPrec :: Int -> Manifest -> ShowS
$cshow :: Manifest -> String
show :: Manifest -> String
$cshowList :: [Manifest] -> ShowS
showList :: [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
$creadsPrec :: Int -> ReadS Manifest
readsPrec :: Int -> ReadS Manifest
$creadList :: ReadS [Manifest]
readList :: ReadS [Manifest]
$creadPrec :: ReadPrec Manifest
readPrec :: ReadPrec Manifest
$creadListPrec :: ReadPrec [Manifest]
readListPrec :: ReadPrec [Manifest]
Read,Manifest -> Manifest -> Bool
(Manifest -> Manifest -> Bool)
-> (Manifest -> Manifest -> Bool) -> Eq Manifest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Manifest -> Manifest -> Bool
== :: Manifest -> Manifest -> Bool
$c/= :: Manifest -> Manifest -> Bool
/= :: Manifest -> Manifest -> Bool
Eq)

-- | JSON shape for 'DebugSubHashes'. All values are hex-encoded SHA256 digests.
instance ToJSON DebugSubHashes where
  toJSON :: DebugSubHashes -> Value
toJSON DebugSubHashes{ByteString
dshTops :: DebugSubHashes -> ByteString
dshPrimMap :: DebugSubHashes -> ByteString
dshClashModDate :: DebugSubHashes -> ByteString
dshCallGraph :: DebugSubHashes -> ByteString
dshOpts :: DebugSubHashes -> ByteString
dshTops :: ByteString
dshPrimMap :: ByteString
dshClashModDate :: ByteString
dshCallGraph :: ByteString
dshOpts :: ByteString
..} = [Pair] -> Value
Aeson.object
    [ Key
"tops" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
toHexDigest ByteString
dshTops
    , Key
"prim_map" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
toHexDigest ByteString
dshPrimMap
    , Key
"clash_mod_date" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
toHexDigest ByteString
dshClashModDate
    , Key
"call_graph" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
toHexDigest ByteString
dshCallGraph
    , Key
"opts" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
toHexDigest ByteString
dshOpts
    ]

instance FromJSON DebugSubHashes where
  parseJSON :: Value -> Parser DebugSubHashes
parseJSON = String
-> (Object -> Parser DebugSubHashes)
-> Value
-> Parser DebugSubHashes
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"DebugSubHashes" ((Object -> Parser DebugSubHashes)
 -> Value -> Parser DebugSubHashes)
-> (Object -> Parser DebugSubHashes)
-> Value
-> Parser DebugSubHashes
forall a b. (a -> b) -> a -> b
$ \Object
v ->
    ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> DebugSubHashes
DebugSubHashes
      -- See Note [Failed hex digest decodes]
      (ByteString
 -> ByteString
 -> ByteString
 -> ByteString
 -> ByteString
 -> DebugSubHashes)
-> Parser ByteString
-> Parser
     (ByteString
      -> ByteString -> ByteString -> ByteString -> DebugSubHashes)
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
"tops")
      Parser
  (ByteString
   -> ByteString -> ByteString -> ByteString -> DebugSubHashes)
-> Parser ByteString
-> Parser
     (ByteString -> ByteString -> ByteString -> DebugSubHashes)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: Type -> Type) a b.
Applicative f =>
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
"prim_map")
      Parser (ByteString -> ByteString -> ByteString -> DebugSubHashes)
-> Parser ByteString
-> Parser (ByteString -> ByteString -> DebugSubHashes)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: Type -> Type) a b.
Applicative f =>
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
"clash_mod_date")
      Parser (ByteString -> ByteString -> DebugSubHashes)
-> Parser ByteString -> Parser (ByteString -> DebugSubHashes)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: Type -> Type) a b.
Applicative f =>
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
"call_graph")
      Parser (ByteString -> DebugSubHashes)
-> Parser ByteString -> Parser DebugSubHashes
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: Type -> Type) a b.
Applicative f =>
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
"opts")

instance ToJSON Manifest where
  toJSON :: Manifest -> Value
toJSON (Manifest{[(String, ByteString)]
[Text]
[ManifestPort]
Maybe DebugSubHashes
(Int, Int)
HashMap Text VDomainConfiguration
Text
ByteString
fileNames :: Manifest -> [(String, ByteString)]
manifestHash :: Manifest -> ByteString
manifestDebugSubHashes :: Manifest -> Maybe DebugSubHashes
successFlags :: Manifest -> (Int, Int)
ports :: Manifest -> [ManifestPort]
componentNames :: Manifest -> [Text]
topComponent :: Manifest -> Text
domains :: Manifest -> HashMap Text VDomainConfiguration
transitiveDependencies :: Manifest -> [Text]
manifestHash :: ByteString
manifestDebugSubHashes :: Maybe DebugSubHashes
successFlags :: (Int, Int)
ports :: [ManifestPort]
componentNames :: [Text]
topComponent :: Text
fileNames :: [(String, ByteString)]
domains :: HashMap Text VDomainConfiguration
transitiveDependencies :: [Text]
..}) =
    [Pair] -> Value
Aeson.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
      [ Key
"version" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"unstable" :: Text)
      , Key
"hash" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
toHexDigest ByteString
manifestHash
      ] [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<>
      (case Maybe DebugSubHashes
manifestDebugSubHashes of
        Just DebugSubHashes
sh -> [Key
"__debug_hash" Key -> DebugSubHashes -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= DebugSubHashes
sh]
        Maybe DebugSubHashes
Nothing -> []) [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<>
      [ Key
"flags" Key -> (Int, Int) -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Int, Int)
successFlags
        -- TODO: add nested ports (i.e., how Clash split/filtered arguments)
      , Key
"components" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Text]
componentNames
      , Key
"top_component" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
Aeson.object
        [ Key
"name" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
topComponent
        , Key
"ports_flat" Key -> [ManifestPort] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [ManifestPort]
ports
        ]
      , Key
"files" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.=
        [ [Pair] -> Value
Aeson.object
          [ Key
"name" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
fName
          , Key
"sha256" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
toHexDigest ByteString
fHash
            -- TODO: Add Edam like fields
          ]
        | (String
fName, ByteString
fHash) <- [(String, ByteString)]
fileNames]
      , Key
"domains" Key -> HashMap Text Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [(Text, Value)] -> HashMap Text Value
forall k v. Hashable k => [(k, v)] -> HashMap k v
HashMap.fromList
        [ ( Text
domNm
          , [Pair] -> Value
Aeson.object
            [ Key
"period" Key -> Natural -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Natural
vPeriod
            , Key
"active_edge" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ActiveEdge -> String
forall a. Show a => a -> String
show ActiveEdge
vActiveEdge
            , Key
"reset_kind" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ResetKind -> String
forall a. Show a => a -> String
show ResetKind
vResetKind
            , Key
"init_behavior" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= InitBehavior -> String
forall a. Show a => a -> String
show InitBehavior
vInitBehavior
            , Key
"reset_polarity" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ResetPolarity -> String
forall a. Show a => a -> String
show ResetPolarity
vResetPolarity
            ]
          )
        | (Text
domNm, VDomainConfiguration{Natural
String
ActiveEdge
InitBehavior
ResetKind
ResetPolarity
vPeriod :: Natural
vActiveEdge :: ActiveEdge
vResetKind :: ResetKind
vInitBehavior :: InitBehavior
vResetPolarity :: ResetPolarity
vName :: String
vActiveEdge :: VDomainConfiguration -> ActiveEdge
vInitBehavior :: VDomainConfiguration -> InitBehavior
vName :: VDomainConfiguration -> String
vPeriod :: VDomainConfiguration -> Natural
vResetKind :: VDomainConfiguration -> ResetKind
vResetPolarity :: VDomainConfiguration -> ResetPolarity
..}) <- 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 v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
Aeson.object
        [ Key
"transitive" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Text]
transitiveDependencies ]
      ]

-- Note [Failed hex digest decodes]
--
-- 'unsafeFromHexDigest' may fail to decode a hex digest if it contains characters
-- outside of [a-fA-F0-9]. In this case, it will return a broken digest. Because
-- this module discards any data covered by the broken digest if it does not match
-- a freshly calculated one, this poses no problem.

-- | Decode a hex digest to a ByteString. Returns a broken digest if the decode
-- fails - hence it being marked as unsafe.
unsafeFromHexDigest :: Text -> ByteString
unsafeFromHexDigest :: Text -> ByteString
unsafeFromHexDigest =
#if MIN_VERSION_base16_bytestring(1,0,0)
  ByteString -> Either String ByteString -> ByteString
forall b a. b -> Either a b -> b
fromRight ByteString
"failed decode" (Either String ByteString -> ByteString)
-> (Text -> Either String ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String ByteString
Base16.decode (ByteString -> Either String ByteString)
-> (Text -> ByteString) -> Text -> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8
#else
  fst . Base16.decode . Text.encodeUtf8
#endif

-- | Encode a ByteString to a hex digest.
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

-- | Parse @files@ part of a Manifest file
parseFiles :: Aeson.Object -> Parser [(FilePath, ByteString)]
parseFiles :: Object -> Parser [(String, 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 (String, ByteString))
-> Parser [(String, 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 (String, ByteString))
 -> Parser [(String, ByteString)])
-> (Object -> Parser (String, ByteString))
-> Parser [(String, ByteString)]
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
    String
fName <- Object
obj Object -> Key -> Parser String
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"
    -- See Note [Failed hex digest decodes]
    (String, ByteString) -> Parser (String, ByteString)
forall a. a -> Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (String
fName, Text -> ByteString
unsafeFromHexDigest Text
sha256)

instance FromJSON Manifest where
  parseJSON :: Value -> Parser Manifest
parseJSON = String -> (Object -> Parser Manifest) -> Value -> Parser Manifest
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"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
-> Maybe DebugSubHashes
-> (Int, Int)
-> [ManifestPort]
-> [Text]
-> Text
-> [(String, ByteString)]
-> HashMap Text VDomainConfiguration
-> [Text]
-> Manifest
Manifest
            -- See Note [Failed hex digest decodes]
        (ByteString
 -> Maybe DebugSubHashes
 -> (Int, Int)
 -> [ManifestPort]
 -> [Text]
 -> Text
 -> [(String, ByteString)]
 -> HashMap Text VDomainConfiguration
 -> [Text]
 -> Manifest)
-> Parser ByteString
-> Parser
     (Maybe DebugSubHashes
      -> (Int, Int)
      -> [ManifestPort]
      -> [Text]
      -> Text
      -> [(String, 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
  (Maybe DebugSubHashes
   -> (Int, Int)
   -> [ManifestPort]
   -> [Text]
   -> Text
   -> [(String, ByteString)]
   -> HashMap Text VDomainConfiguration
   -> [Text]
   -> Manifest)
-> Parser (Maybe DebugSubHashes)
-> Parser
     ((Int, Int)
      -> [ManifestPort]
      -> [Text]
      -> Text
      -> [(String, ByteString)]
      -> HashMap Text VDomainConfiguration
      -> [Text]
      -> Manifest)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe DebugSubHashes)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"__debug_hash"
        Parser
  ((Int, Int)
   -> [ManifestPort]
   -> [Text]
   -> Text
   -> [(String, ByteString)]
   -> HashMap Text VDomainConfiguration
   -> [Text]
   -> Manifest)
-> Parser (Int, Int)
-> Parser
     ([ManifestPort]
      -> [Text]
      -> Text
      -> [(String, ByteString)]
      -> HashMap Text VDomainConfiguration
      -> [Text]
      -> Manifest)
forall a b. Parser (a -> b) -> Parser a -> Parser b
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
   -> [(String, ByteString)]
   -> HashMap Text VDomainConfiguration
   -> [Text]
   -> Manifest)
-> Parser [ManifestPort]
-> Parser
     ([Text]
      -> Text
      -> [(String, ByteString)]
      -> HashMap Text VDomainConfiguration
      -> [Text]
      -> Manifest)
forall a b. Parser (a -> b) -> Parser a -> Parser b
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 a b. Parser a -> (a -> Parser b) -> Parser b
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
   -> [(String, ByteString)]
   -> HashMap Text VDomainConfiguration
   -> [Text]
   -> Manifest)
-> Parser [Text]
-> Parser
     (Text
      -> [(String, ByteString)]
      -> HashMap Text VDomainConfiguration
      -> [Text]
      -> Manifest)
forall a b. Parser (a -> b) -> Parser a -> Parser b
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
   -> [(String, ByteString)]
   -> HashMap Text VDomainConfiguration
   -> [Text]
   -> Manifest)
-> Parser Text
-> Parser
     ([(String, ByteString)]
      -> HashMap Text VDomainConfiguration -> [Text] -> Manifest)
forall a b. Parser (a -> b) -> Parser a -> Parser b
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 a b. Parser a -> (a -> Parser b) -> Parser b
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
  ([(String, ByteString)]
   -> HashMap Text VDomainConfiguration -> [Text] -> Manifest)
-> Parser [(String, ByteString)]
-> Parser (HashMap Text VDomainConfiguration -> [Text] -> Manifest)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Object -> Parser [(String, ByteString)]
parseFiles Object
v
        Parser (HashMap Text VDomainConfiguration -> [Text] -> Manifest)
-> Parser (HashMap Text VDomainConfiguration)
-> Parser ([Text] -> Manifest)
forall a b. Parser (a -> b) -> Parser a -> Parser b
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 a b. Parser a -> (a -> Parser b) -> Parser b
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 a b. Parser (a -> b) -> Parser a -> Parser b
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 a b. Parser a -> (a -> Parser b) -> Parser b
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 =
      String
-> Natural
-> ActiveEdge
-> ResetKind
-> InitBehavior
-> ResetPolarity
-> VDomainConfiguration
VDomainConfiguration
        (String
 -> Natural
 -> ActiveEdge
 -> ResetKind
 -> InitBehavior
 -> ResetPolarity
 -> VDomainConfiguration)
-> Parser String
-> Parser
     (Natural
      -> ActiveEdge
      -> ResetKind
      -> InitBehavior
      -> ResetPolarity
      -> VDomainConfiguration)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Parser String
forall a. a -> Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Text -> String
Text.unpack Text
nm)
        Parser
  (Natural
   -> ActiveEdge
   -> ResetKind
   -> InitBehavior
   -> ResetPolarity
   -> VDomainConfiguration)
-> Parser Natural
-> Parser
     (ActiveEdge
      -> ResetKind
      -> InitBehavior
      -> ResetPolarity
      -> VDomainConfiguration)
forall a b. Parser (a -> b) -> Parser a -> Parser b
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 a b. Parser (a -> b) -> Parser a -> Parser b
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 a b. Parser (a -> b) -> Parser a -> Parser b
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 a b. Parser (a -> b) -> Parser a -> Parser b
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 a b. Parser (a -> b) -> Parser a -> Parser b
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 String
v <- Object
obj Object -> Key -> Parser (Maybe String)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
field
      case String -> Maybe b
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe b) -> Maybe String -> Maybe b
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe String
v of
        Just b
a -> b -> Parser b
forall a. a -> Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure b
a
        Maybe b
Nothing -> String -> Parser b
forall a. String -> Parser a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Parser b) -> String -> Parser b
forall a b. (a -> b) -> a -> b
$ String
"Could not read field: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Key -> String
forall a. Show a => a -> String
show Key
field

data UnexpectedModification
  -- | Clash generated file was modified
  = Modified FilePath
  -- | Non-clash generated file was added
  | Added FilePath
  -- | Clash generated file was removed
  | Removed FilePath
  deriving (Int -> UnexpectedModification -> ShowS
[UnexpectedModification] -> ShowS
UnexpectedModification -> String
(Int -> UnexpectedModification -> ShowS)
-> (UnexpectedModification -> String)
-> ([UnexpectedModification] -> ShowS)
-> Show UnexpectedModification
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UnexpectedModification -> ShowS
showsPrec :: Int -> UnexpectedModification -> ShowS
$cshow :: UnexpectedModification -> String
show :: UnexpectedModification -> String
$cshowList :: [UnexpectedModification] -> ShowS
showList :: [UnexpectedModification] -> ShowS
Show)

mkManifestPort ::
  Backend backend =>
  -- | Backend used to lookup port type names
  backend ->
  -- | Port name
  Id.Identifier ->
  -- | Port type
  HWType ->
  PortDirection ->
  ManifestPort
mkManifestPort :: forall backend.
Backend backend =>
backend -> Identifier -> HWType -> PortDirection -> ManifestPort
mkManifestPort backend
backend Identifier
portId HWType
portType PortDirection
portDir = ManifestPort{Bool
Int
Maybe Text
Text
PortDirection
mpName :: Text
mpTypeName :: Text
mpDirection :: PortDirection
mpWidth :: Int
mpIsClock :: Bool
mpDomain :: Maybe Text
mpName :: Text
mpWidth :: Int
mpDirection :: PortDirection
mpIsClock :: Bool
mpDomain :: Maybe Text
mpTypeName :: 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; ClockN 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 (StateT backend Identity) Text -> State backend Text
forall {k} (f :: k -> Type) (a :: k). Ap f a -> f a
getAp (Ap (StateT backend Identity) Text -> State backend Text)
-> Ap (StateT backend Identity) 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 (StateT backend Identity) (Doc ())
-> Ap (StateT backend Identity) Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Usage -> HWType -> Ap (StateT backend Identity) (Doc ())
forall state.
Backend state =>
Usage -> HWType -> Ap (State state) (Doc ())
hdlType (Text -> Usage
External Text
mpName) HWType
portType

-- | Filename manifest file should be written to and read from
manifestFilename :: IsString a => a
manifestFilename :: forall a. IsString a => a
manifestFilename = a
"clash-manifest.json"

mkManifest ::
  Backend backend =>
  -- | Backend used to lookup port type names
  backend ->
  -- | Domains encountered in design
  HashMap Text VDomainConfiguration ->
  -- | Options Clash was run with
  ClashOpts ->
  -- | Component of top entity
  Component ->
  -- | All other entities
  [Component] ->
  -- | Names of dependencies (transitive closure)
  [Id] ->
  -- | Files and  their hashes
  [(FilePath, ByteString)] ->
  -- | Hash and per-input subhashes returned by 'readFreshManifest'
  (ByteString, DebugSubHashes) ->
  -- | New manifest
  Manifest
mkManifest :: forall backend.
Backend backend =>
backend
-> HashMap Text VDomainConfiguration
-> ClashOpts
-> Component
-> [Component]
-> [Id]
-> [(String, ByteString)]
-> (ByteString, DebugSubHashes)
-> Manifest
mkManifest backend
backend HashMap Text VDomainConfiguration
domains ClashOpts{Bool
Int
[String]
Maybe String
Maybe (Maybe Int)
Maybe Text
Word
Period
OverridingBool
PreserveCase
HdlSyn
DebugOpts
opt_werror :: Bool
opt_inlineLimit :: Int
opt_specLimit :: Int
opt_inlineFunctionLimit :: Word
opt_inlineConstantLimit :: Word
opt_evaluatorFuelLimit :: Word
opt_debug :: DebugOpts
opt_ghcDebugLevel :: Int
opt_cachehdl :: Bool
opt_clear :: Bool
opt_primWarn :: Bool
opt_color :: OverridingBool
opt_intWidth :: Int
opt_hdlDir :: Maybe String
opt_hdlSyn :: HdlSyn
opt_errorExtra :: Bool
opt_importPaths :: [String]
opt_componentPrefix :: Maybe Text
opt_newInlineStrat :: Bool
opt_escapedIds :: Bool
opt_lowerCaseBasicIds :: PreserveCase
opt_ultra :: Bool
opt_forceUndefined :: Maybe (Maybe Int)
opt_checkIDir :: Bool
opt_aggressiveXOpt :: Bool
opt_aggressiveXOptBB :: Bool
opt_inlineWFCacheLimit :: Word
opt_edalize :: Bool
opt_renderEnums :: Bool
opt_timescalePrecision :: Period
opt_ignoreBrokenGhcs :: Bool
opt_concurrentTopEntities :: Bool
opt_debugManifestHash :: Bool
opt_werror :: ClashOpts -> Bool
opt_inlineLimit :: ClashOpts -> Int
opt_specLimit :: ClashOpts -> Int
opt_inlineFunctionLimit :: ClashOpts -> Word
opt_inlineConstantLimit :: ClashOpts -> Word
opt_evaluatorFuelLimit :: ClashOpts -> Word
opt_debug :: ClashOpts -> DebugOpts
opt_ghcDebugLevel :: ClashOpts -> Int
opt_cachehdl :: ClashOpts -> Bool
opt_clear :: ClashOpts -> Bool
opt_primWarn :: ClashOpts -> Bool
opt_color :: ClashOpts -> OverridingBool
opt_intWidth :: ClashOpts -> Int
opt_hdlDir :: ClashOpts -> Maybe String
opt_hdlSyn :: ClashOpts -> HdlSyn
opt_errorExtra :: ClashOpts -> Bool
opt_importPaths :: ClashOpts -> [String]
opt_componentPrefix :: ClashOpts -> Maybe Text
opt_newInlineStrat :: ClashOpts -> Bool
opt_escapedIds :: ClashOpts -> Bool
opt_lowerCaseBasicIds :: ClashOpts -> PreserveCase
opt_ultra :: ClashOpts -> Bool
opt_forceUndefined :: ClashOpts -> Maybe (Maybe Int)
opt_checkIDir :: ClashOpts -> Bool
opt_aggressiveXOpt :: ClashOpts -> Bool
opt_aggressiveXOptBB :: ClashOpts -> Bool
opt_inlineWFCacheLimit :: ClashOpts -> Word
opt_edalize :: ClashOpts -> Bool
opt_renderEnums :: ClashOpts -> Bool
opt_timescalePrecision :: ClashOpts -> Period
opt_ignoreBrokenGhcs :: ClashOpts -> Bool
opt_concurrentTopEntities :: ClashOpts -> Bool
opt_debugManifestHash :: ClashOpts -> Bool
..} Component{[(Identifier, HWType)]
[(Usage, (Identifier, HWType), Maybe Expr)]
[Declaration]
Identifier
componentName :: Identifier
inputs :: [(Identifier, HWType)]
outputs :: [(Usage, (Identifier, HWType), Maybe Expr)]
declarations :: [Declaration]
componentName :: Component -> Identifier
inputs :: Component -> [(Identifier, HWType)]
outputs :: Component -> [(Usage, (Identifier, HWType), Maybe Expr)]
declarations :: Component -> [Declaration]
..} [Component]
components [Id]
deps [(String, ByteString)]
files (ByteString
topHash, DebugSubHashes
subHashes) = Manifest
  { manifestHash :: ByteString
manifestHash = ByteString
topHash
  , manifestDebugSubHashes :: Maybe DebugSubHashes
manifestDebugSubHashes = if Bool
opt_debugManifestHash then DebugSubHashes -> Maybe DebugSubHashes
forall a. a -> Maybe a
Just DebugSubHashes
subHashes else Maybe DebugSubHashes
forall a. Maybe a
Nothing
  , 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 :: [(String, ByteString)]
fileNames = [(String, 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 | (Usage
_, (Identifier
pName, HWType
pType), Maybe Expr
_) <- [(Usage, (Identifier, HWType), Maybe Expr)]
outputs]

-- | Pretty print an unexpected modification as a list item.
pprintUnexpectedModification :: UnexpectedModification -> String
pprintUnexpectedModification :: UnexpectedModification -> String
pprintUnexpectedModification = \case
  Modified String
p -> String
"Unexpected modification in " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
p
  Added String
p -> String
"Unexpected extra file " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
p
  Removed String
p -> String
"Unexpected removed file " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
p

-- | Pretty print a list of unexpected modifications. Print a maximum of /n/
-- modifications.
pprintUnexpectedModifications :: Int -> [UnexpectedModification] -> String
pprintUnexpectedModifications :: Int -> [UnexpectedModification] -> String
pprintUnexpectedModifications Int
0 [UnexpectedModification]
us = Int -> [UnexpectedModification] -> String
pprintUnexpectedModifications Int
forall a. Bounded a => a
maxBound [UnexpectedModification]
us
pprintUnexpectedModifications Int
_ [] = []
pprintUnexpectedModifications Int
_ [UnexpectedModification
u] = String
"* " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> UnexpectedModification -> String
pprintUnexpectedModification UnexpectedModification
u
pprintUnexpectedModifications Int
1 (UnexpectedModification
u:[UnexpectedModification]
us) =
  String
"* and " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([UnexpectedModification] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length (UnexpectedModification
uUnexpectedModification
-> [UnexpectedModification] -> [UnexpectedModification]
forall a. a -> [a] -> [a]
:[UnexpectedModification]
us)) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" more unexpected changes"
pprintUnexpectedModifications Int
n (UnexpectedModification
u:[UnexpectedModification]
us) =
  String
"* " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> UnexpectedModification -> String
pprintUnexpectedModification UnexpectedModification
u
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [UnexpectedModification] -> String
pprintUnexpectedModifications (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [UnexpectedModification]
us

-- | Reads a manifest file. Does not return manifest file if:
--
--  * Caching is disabled through @-fclash-no-cache@.
--  * Manifest could not be found.
--  * Cache is stale. This could be triggered by any of the given arguments.
--
-- Raises an exception if the manifest file or any of the files it is referring
-- to was inaccessible.
--
readFreshManifest ::
  -- | "This" top entity plus all that depend on it.
  [TopEntityT] ->
  -- | Core expressions and entry point. Any changes in the call graph will
  -- trigger a recompile.
  (BindingMap, Id) ->
  -- | Any changes in any primitive will trigger a recompile.
  CompiledPrimMap ->
  -- | Certain options will trigger recompiles if changed
  ClashOpts ->
  -- | Clash modification date
  UTCTime ->
  -- | Path to manifest file.
  FilePath ->
  -- | ( Nothing if no manifest file was found
  --   , Nothing on stale cache, disabled cache, or not manifest file found
  --   , Top-level hash plus per-input subhashes used to derive it )
  IO (Maybe [UnexpectedModification], Maybe Manifest, (ByteString, DebugSubHashes))
readFreshManifest :: [TopEntityT]
-> (BindingMap, Id)
-> CompiledPrimMap
-> ClashOpts
-> UTCTime
-> String
-> IO
     (Maybe [UnexpectedModification], Maybe Manifest,
      (ByteString, DebugSubHashes))
readFreshManifest [TopEntityT]
tops (BindingMap
bindingsMap, Id
topId) CompiledPrimMap
primMap opts :: ClashOpts
opts@(ClashOpts{Bool
Int
[String]
Maybe String
Maybe (Maybe Int)
Maybe Text
Word
Period
OverridingBool
PreserveCase
HdlSyn
DebugOpts
opt_werror :: ClashOpts -> Bool
opt_inlineLimit :: ClashOpts -> Int
opt_specLimit :: ClashOpts -> Int
opt_inlineFunctionLimit :: ClashOpts -> Word
opt_inlineConstantLimit :: ClashOpts -> Word
opt_evaluatorFuelLimit :: ClashOpts -> Word
opt_debug :: ClashOpts -> DebugOpts
opt_ghcDebugLevel :: ClashOpts -> Int
opt_cachehdl :: ClashOpts -> Bool
opt_clear :: ClashOpts -> Bool
opt_primWarn :: ClashOpts -> Bool
opt_color :: ClashOpts -> OverridingBool
opt_intWidth :: ClashOpts -> Int
opt_hdlDir :: ClashOpts -> Maybe String
opt_hdlSyn :: ClashOpts -> HdlSyn
opt_errorExtra :: ClashOpts -> Bool
opt_importPaths :: ClashOpts -> [String]
opt_componentPrefix :: ClashOpts -> Maybe Text
opt_newInlineStrat :: ClashOpts -> Bool
opt_escapedIds :: ClashOpts -> Bool
opt_lowerCaseBasicIds :: ClashOpts -> PreserveCase
opt_ultra :: ClashOpts -> Bool
opt_forceUndefined :: ClashOpts -> Maybe (Maybe Int)
opt_checkIDir :: ClashOpts -> Bool
opt_aggressiveXOpt :: ClashOpts -> Bool
opt_aggressiveXOptBB :: ClashOpts -> Bool
opt_inlineWFCacheLimit :: ClashOpts -> Word
opt_edalize :: ClashOpts -> Bool
opt_renderEnums :: ClashOpts -> Bool
opt_timescalePrecision :: ClashOpts -> Period
opt_ignoreBrokenGhcs :: ClashOpts -> Bool
opt_concurrentTopEntities :: ClashOpts -> Bool
opt_debugManifestHash :: ClashOpts -> Bool
opt_werror :: Bool
opt_inlineLimit :: Int
opt_specLimit :: Int
opt_inlineFunctionLimit :: Word
opt_inlineConstantLimit :: Word
opt_evaluatorFuelLimit :: Word
opt_debug :: DebugOpts
opt_ghcDebugLevel :: Int
opt_cachehdl :: Bool
opt_clear :: Bool
opt_primWarn :: Bool
opt_color :: OverridingBool
opt_intWidth :: Int
opt_hdlDir :: Maybe String
opt_hdlSyn :: HdlSyn
opt_errorExtra :: Bool
opt_importPaths :: [String]
opt_componentPrefix :: Maybe Text
opt_newInlineStrat :: Bool
opt_escapedIds :: Bool
opt_lowerCaseBasicIds :: PreserveCase
opt_ultra :: Bool
opt_forceUndefined :: Maybe (Maybe Int)
opt_checkIDir :: Bool
opt_aggressiveXOpt :: Bool
opt_aggressiveXOptBB :: Bool
opt_inlineWFCacheLimit :: Word
opt_edalize :: Bool
opt_renderEnums :: Bool
opt_timescalePrecision :: Period
opt_ignoreBrokenGhcs :: Bool
opt_concurrentTopEntities :: Bool
opt_debugManifestHash :: Bool
..}) UTCTime
clashModDate String
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)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (String -> FilesManifest -> IO [UnexpectedModification]
isUserModified String
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
=<< String -> IO (Maybe FilesManifest)
forall a. FromJSON a => String -> IO (Maybe a)
readManifest String
path

  Maybe Manifest
manifestM <- String -> IO (Maybe Manifest)
forall a. FromJSON a => String -> IO (Maybe a)
readManifest String
path
  (Maybe [UnexpectedModification], Maybe Manifest,
 (ByteString, DebugSubHashes))
-> IO
     (Maybe [UnexpectedModification], Maybe Manifest,
      (ByteString, DebugSubHashes))
forall a. a -> IO a
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, DebugSubHashes
subHashes)
    )

 where
  optsHash :: Int
optsHash = ClashOpts -> Int
forall a. Hashable a => a -> Int
hash ClashOpts
opts {
      -- Ignore the following settings, they don't affect the generated HDL:

      -- 1. Debug
      opt_debug = opt_debug
        { dbg_invariants = False
        , dbg_transformations = Set.empty
        , dbg_historyFile = Nothing
        }

      -- 2. Caching
    , opt_cachehdl = True

      -- 3. Warnings / errors
    , opt_primWarn = True
    , opt_color = Auto
    , opt_errorExtra = False
    , opt_checkIDir = True
    , opt_ignoreBrokenGhcs = False

      -- 4. Optional output
    , opt_edalize = False

      -- Ignore the following settings, they don't affect the generated HDL. However,
      -- they do influence whether HDL can be generated at all.
      --
      -- We therefore check whether the new flags changed in such a way that
      -- they could affect successful compilation, and use that information
      -- to decide whether to use caching or not (see: XXXX).
      --
      -- 5. termination measures
    , opt_inlineLimit = 20
    , opt_specLimit = 20

      -- Finally, also ignore the HDL dir setting, because when a user moves the
      -- entire dir with generated HDL, they probably still want to use that as
      -- a cache
    , opt_hdlDir = Nothing
    }

  -- TODO: Binary encoding does not account for alpha equivalence (nor should
  --       it?), so the cache behaves more pessimisticly than it could.
  --
  -- Compute each input's digest independently so that they can be surfaced
  -- via 'manifestDebugSubHashes'. The top-level hash is then a digest of the
  -- subhashes — keeping it a deterministic function of the same inputs while
  -- making it mechanically obvious which input changed between two runs.
  subHashes :: DebugSubHashes
subHashes = DebugSubHashes
    { dshTops :: ByteString
dshTops = ByteString -> ByteString
Sha256.hashlazy ([TopEntityT] -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode [TopEntityT]
tops)
    , dshPrimMap :: ByteString
dshPrimMap = ByteString -> ByteString
Sha256.hashlazy (Int -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode (CompiledPrimMap -> Int
hashCompiledPrimMap CompiledPrimMap
primMap))
    , dshClashModDate :: ByteString
dshClashModDate = ByteString -> ByteString
Sha256.hashlazy (String -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode (UTCTime -> String
forall a. Show a => a -> String
show UTCTime
clashModDate))
    , dshCallGraph :: ByteString
dshCallGraph = ByteString -> ByteString
Sha256.hashlazy ([Term] -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode (BindingMap -> Id -> [Term]
callGraphBindings BindingMap
bindingsMap Id
topId))
    , dshOpts :: ByteString
dshOpts = ByteString -> ByteString
Sha256.hashlazy (Int -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode Int
optsHash)
    }

  topHash :: ByteString
topHash = ByteString -> ByteString
Sha256.hashlazy (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString, ByteString, ByteString, ByteString)
-> ByteString
forall a. Binary a => a -> ByteString
Binary.encode
    ( DebugSubHashes -> ByteString
dshTops DebugSubHashes
subHashes
    , DebugSubHashes -> ByteString
dshPrimMap DebugSubHashes
subHashes
    , DebugSubHashes -> ByteString
dshClashModDate DebugSubHashes
subHashes
    , DebugSubHashes -> ByteString
dshCallGraph DebugSubHashes
subHashes
    , DebugSubHashes -> ByteString
dshOpts DebugSubHashes
subHashes
    )

  checkManifest :: Manifest -> Maybe Manifest
checkManifest manifest :: Manifest
manifest@Manifest{ByteString
manifestHash :: Manifest -> ByteString
manifestHash :: ByteString
manifestHash,(Int, Int)
successFlags :: Manifest -> (Int, Int)
successFlags :: (Int, Int)
successFlags}
    | (Int
cachedInline, Int
cachedSpec) <- (Int, Int)
successFlags

    -- Higher limits shouldn't affect HDL
    , 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

    -- Callgraph hashes should correspond
    , 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

    -- One or more checks failed
    | Bool
otherwise = Maybe Manifest
forall a. Maybe a
Nothing

-- | Determines whether the HDL directory the given 'LocatedManifest' was found
-- in contains any user made modifications. This is used by Clash to protect the
-- user against lost work.
isUserModified :: FilePath -> FilesManifest -> IO [UnexpectedModification]
isUserModified :: String -> FilesManifest -> IO [UnexpectedModification]
isUserModified (ShowS
takeDirectory -> String
topDir) (FilesManifest [(String, ByteString)]
fileNames) = do
  let
    manifestFiles :: Set String
manifestFiles = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList (((String, ByteString) -> String)
-> [(String, ByteString)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, ByteString) -> String
forall a b. (a, b) -> a
fst [(String, ByteString)]
fileNames)

  Set String
currentFiles <- (String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.delete String
forall a. IsString a => a
manifestFilename (Set String -> Set String)
-> ([String] -> Set String) -> [String] -> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList) ([String] -> Set String) -> IO [String] -> IO (Set String)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
listDirectory String
topDir

  let
    removedFiles :: [String]
removedFiles = Set String -> [String]
forall a. Set a -> [a]
Set.toList (Set String
manifestFiles Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set String
currentFiles)
    addedFiles :: [String]
addedFiles = Set String -> [String]
forall a. Set a -> [a]
Set.toList (Set String
currentFiles Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set String
manifestFiles)

  [String]
changedFiles <- [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe String] -> [String]) -> IO [Maybe String] -> IO [String]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((String, ByteString) -> IO (Maybe String))
-> [(String, ByteString)] -> IO [Maybe String]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM (String, ByteString) -> IO (Maybe String)
detectModification [(String, ByteString)]
fileNames

  [UnexpectedModification] -> IO [UnexpectedModification]
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure
    (  (String -> UnexpectedModification)
-> [String] -> [UnexpectedModification]
forall a b. (a -> b) -> [a] -> [b]
map String -> UnexpectedModification
Removed [String]
removedFiles
    [UnexpectedModification]
-> [UnexpectedModification] -> [UnexpectedModification]
forall a. Semigroup a => a -> a -> a
<> (String -> UnexpectedModification)
-> [String] -> [UnexpectedModification]
forall a b. (a -> b) -> [a] -> [b]
map String -> UnexpectedModification
Added [String]
addedFiles
    [UnexpectedModification]
-> [UnexpectedModification] -> [UnexpectedModification]
forall a. Semigroup a => a -> a -> a
<> (String -> UnexpectedModification)
-> [String] -> [UnexpectedModification]
forall a b. (a -> b) -> [a] -> [b]
map String -> UnexpectedModification
Modified [String]
changedFiles )
 where
  detectModification :: (FilePath, ByteString) -> IO (Maybe FilePath)
  detectModification :: (String, ByteString) -> IO (Maybe String)
detectModification (String
filename, ByteString
manifestDigest) = do
    let fullPath :: String
fullPath = String
topDir String -> ShowS
</> String
filename
    Bool
fileExists <- String -> IO Bool
doesFileExist String
fullPath
    if Bool
fileExists then do
      ByteString
contents <- String -> IO ByteString
ByteStringLazy.readFile String
fullPath
      if ByteString
manifestDigest ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> ByteString
Sha256.hashlazy ByteString
contents
      then Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
      else Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (String -> Maybe String
forall a. a -> Maybe a
Just String
filename)
    else
      -- Will be caught by @removedFiles@
      Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing

-- | Read a manifest file from disk. Returns 'Nothing' if file does not exist.
-- Any other IO exception is re-raised.
readManifest :: FromJSON a => FilePath -> IO (Maybe a)
readManifest :: forall a. FromJSON a => String -> IO (Maybe a)
readManifest String
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) (String -> IO (Maybe a)
forall a. FromJSON a => String -> IO (Maybe a)
Aeson.decodeFileStrict String
path)
  Maybe a -> IO (Maybe a)
forall a. a -> IO 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)

-- | Write manifest file to disk
writeManifest :: FilePath -> Manifest -> IO ()
writeManifest :: String -> Manifest -> IO ()
writeManifest String
path = String -> ByteString -> IO ()
ByteStringLazy.writeFile String
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

-- | Serialize a manifest.
--
-- TODO: This should really yield a 'ByteString'.
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