content: {-|
  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 (Generic, Eq, Read, Show)
  
  instance ToJSON PortDirection where
    toJSON = Aeson.genericToJSON Aeson.defaultOptions
      { Aeson.constructorTagModifier = fmap toLower }
  
  instance FromJSON PortDirection where
    parseJSON = Aeson.genericParseJSON Aeson.defaultOptions
      { Aeson.constructorTagModifier = fmap toLower }
  
  data ManifestPort = ManifestPort
    { mpName :: Text
    -- ^ Port name (as rendered in HDL)
    , mpTypeName :: Text
    -- ^ Type name (as rendered in HDL)
    , mpDirection :: PortDirection
    -- ^ Port direction (in / out / inout)
    , mpWidth :: Int
    -- ^ Port width in bits
    , mpIsClock :: Bool
    -- ^ Is this port a clock?
    , 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 (Show,Read,Eq)
  
  instance ToJSON ManifestPort where
    toJSON (ManifestPort{..}) =
      Aeson.object $
        [ "name" .= mpName
        , "type_name" .= mpTypeName
        , "direction" .= mpDirection
        , "width" .= mpWidth
        , "is_clock" .= mpIsClock
        ] <>
        (case mpDomain of
          Just dom -> ["domain" .= dom]
          Nothing -> [] )
  
  instance FromJSON ManifestPort where
    parseJSON = Aeson.withObject "ManifestPort" $ \v ->
      ManifestPort
        <$> v .: "name"
        <*> v .: "type_name"
        <*> v .: "direction"
        <*> v .: "width"
        <*> v .: "is_clock"
        <*> v .:? "domain"
  
  -- | Just the 'fileNames' part of 'Manifest'
  newtype FilesManifest = FilesManifest [(FilePath, ByteString)]
  
  instance FromJSON FilesManifest where
    parseJSON = Aeson.withObject "FilesManifest" $ fmap FilesManifest . parseFiles
  
  -- | Information about the generated HDL between (sub)runs of the compiler
  data Manifest
    = Manifest
    { manifestHash :: ByteString
      -- ^ Hash digest of the TopEntity and all its dependencies.
    , successFlags  :: (Int, Int)
      -- ^ Compiler flags used to achieve successful compilation:
      --
      --   * opt_inlineLimit
      --   * opt_specLimit
    , ports :: [ManifestPort]
      -- ^ Ports in the generated @TopEntity@.
    , 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.
    , topComponent :: Text
      -- ^ Design entry point. This is usually the component annotated with a
      -- @TopEntity@ annotation.
    , 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.
    , domains :: HashMap Text VDomainConfiguration
      -- ^ Domains encountered in design
    , 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 (Show,Read,Eq)
  
  instance ToJSON Manifest where
    toJSON (Manifest{..}) =
      Aeson.object
        [ "version" .= ("unstable" :: Text)
        , "hash" .= toHexDigest manifestHash
        , "flags" .= successFlags
          -- TODO: add nested ports (i.e., how Clash split/filtered arguments)
        , "components" .= componentNames
        , "top_component" .= Aeson.object
          [ "name" .= topComponent
          , "ports_flat" .= ports
          ]
        , "files" .=
          [ Aeson.object
            [ "name" .= fName
            , "sha256" .= toHexDigest fHash
              -- TODO: Add Edam like fields
            ]
          | (fName, fHash) <- fileNames]
        , "domains" .= HashMap.fromList
          [ ( domNm
            , Aeson.object
              [ "period" .= vPeriod
              , "active_edge" .= show vActiveEdge
              , "reset_kind" .= show vResetKind
              , "init_behavior" .= show vInitBehavior
              , "reset_polarity" .= show vResetPolarity
              ]
            )
          | (domNm, VDomainConfiguration{..}) <- HashMap.toList domains ]
        , "dependencies" .= Aeson.object
          [ "transitive" .= 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 =
  #if MIN_VERSION_base16_bytestring(1,0,0)
    fromRight "failed decode" . Base16.decode . Text.encodeUtf8
  #else
    fst . Base16.decode . Text.encodeUtf8
  #endif
  
  -- | Encode a ByteString to a hex digest.
  toHexDigest :: ByteString -> Text
  toHexDigest = Text.decodeUtf8 . Base16.encode
  
  -- | Parse @files@ part of a Manifest file
  parseFiles :: Aeson.Object -> Parser [(FilePath, ByteString)]
  parseFiles v = do
    files <- v .: "files"
    forM files $ \obj -> do
      fName <- obj .: "name"
      sha256 <- obj .: "sha256"
      -- See Note [Failed hex digest decodes]
      pure (fName, unsafeFromHexDigest sha256)
  
  instance FromJSON Manifest where
    parseJSON = Aeson.withObject "Manifest" $ \v ->
      let
        topComponent = v .: "top_component"
      in
        Manifest
              -- See Note [Failed hex digest decodes]
          <$> (unsafeFromHexDigest <$> v .: "hash")
          <*> v .: "flags"
          <*> (topComponent >>= (.: "ports_flat"))
          <*> v .: "components"
          <*> (topComponent >>= (.: "name"))
          <*> parseFiles v
          <*> (v .: "domains" >>= HashMap.traverseWithKey parseDomain)
          <*> (v .: "dependencies" >>= (.: "transitive"))
     where
      parseDomain :: Text -> Aeson.Object -> Parser VDomainConfiguration
      parseDomain nm v =
        VDomainConfiguration
          <$> pure (Text.unpack nm)
          <*> (v .: "period")
          <*> parseWithRead "active_edge" v
          <*> parseWithRead "reset_kind" v
          <*> parseWithRead "init_behavior" v
          <*> parseWithRead "reset_polarity" v
  
      parseWithRead field obj = do
        v <- obj .:? field
        case readMaybe =<< v of
          Just a -> pure a
          Nothing -> fail $ "Could not read field: " <> show 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 (Show)
  
  mkManifestPort ::
    Backend backend =>
    -- | Backend used to lookup port type names
    backend ->
    -- | Port name
    Id.Identifier ->
    -- | Port type
    HWType ->
    PortDirection ->
    ManifestPort
  mkManifestPort backend portId portType portDir = ManifestPort{..}
   where
    mpName = Id.toText portId
    mpWidth = typeSize portType
    mpDirection = portDir
    mpIsClock = case portType of {Clock _ -> True; ClockN _ -> True; _ -> False}
    mpDomain = hwTypeDomain portType
    mpTypeName = flip evalState backend $ getAp $ do
       LText.toStrict . renderOneLine <$> hdlType (External mpName) portType
  
  -- | Filename manifest file should be written to and read from
  manifestFilename :: IsString a => a
  manifestFilename = "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 returned by 'readFreshManifest'
    ByteString ->
    -- | New manifest
    Manifest
  mkManifest backend domains ClashOpts{..} Component{..} components deps files topHash = Manifest
    { manifestHash = topHash
    , ports = inPorts <> inOutPorts <> outPorts
    , componentNames = map Id.toText compNames
    , topComponent = Id.toText componentName
    , fileNames = files
    , successFlags = (opt_inlineLimit, opt_specLimit)
    , domains = domains
    , transitiveDependencies = map (nameOcc . varName) deps
    }
   where
    compNames = map Netlist.componentName components
  
    inPorts =
      [mkManifestPort backend pName pType In | p@(pName, pType) <- inputs, not (Netlist.isBiDirectional p)]
  
    inOutPorts =
      [mkManifestPort backend pName pType InOut | p@(pName, pType) <- inputs, Netlist.isBiDirectional p]
  
    outPorts =
      [mkManifestPort backend pName pType Out | (_, (pName, pType), _) <- outputs]
  
  -- | Pretty print an unexpected modification as a list item.
  pprintUnexpectedModification :: UnexpectedModification -> String
  pprintUnexpectedModification = \case
    Modified p -> "Unexpected modification in " <> p
    Added p -> "Unexpected extra file " <> p
    Removed p -> "Unexpected removed file " <> p
  
  -- | Pretty print a list of unexpected modifications. Print a maximum of /n/
  -- modifications.
  pprintUnexpectedModifications :: Int -> [UnexpectedModification] -> String
  pprintUnexpectedModifications 0 us = pprintUnexpectedModifications maxBound us
  pprintUnexpectedModifications _ [] = []
  pprintUnexpectedModifications _ [u] = "* " <> pprintUnexpectedModification u
  pprintUnexpectedModifications 1 (u:us) =
    "* and " <> show (length (u:us)) <> " more unexpected changes"
  pprintUnexpectedModifications n (u:us) =
    "* " <> pprintUnexpectedModification u
          <> "\n" <> pprintUnexpectedModifications (n-1) 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 )
    IO (Maybe [UnexpectedModification], Maybe Manifest, ByteString)
  readFreshManifest tops (bindingsMap, topId) primMap opts@(ClashOpts{..}) clashModDate path = do
    modificationsM <- traverse (isUserModified path) =<< readManifest path
  
    manifestM <- readManifest path
    pure
      ( modificationsM
      , checkManifest =<< if opt_cachehdl then manifestM else Nothing
      , topHash
      )
  
   where
    optsHash = hash 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.
    topHash = Sha256.hashlazy $ Binary.encode
      ( tops
      , hashCompiledPrimMap primMap
      , show clashModDate
      , callGraphBindings bindingsMap topId
      , optsHash
      )
  
    checkManifest manifest@Manifest{manifestHash,successFlags}
      | (cachedInline, cachedSpec) <- successFlags
  
      -- Higher limits shouldn't affect HDL
      , cachedInline <= opt_inlineLimit
      , cachedSpec <= opt_specLimit
  
      -- Callgraph hashes should correspond
      , manifestHash == topHash
      = Just manifest
  
      -- One or more checks failed
      | otherwise = 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 (takeDirectory -> topDir) (FilesManifest fileNames) = do
    let
      manifestFiles = Set.fromList (map fst fileNames)
  
    currentFiles <- (Set.delete manifestFilename . Set.fromList) <$> listDirectory topDir
  
    let
      removedFiles = Set.toList (manifestFiles `Set.difference` currentFiles)
      addedFiles = Set.toList (currentFiles `Set.difference` manifestFiles)
  
    changedFiles <- catMaybes <$> mapM detectModification fileNames
  
    pure
      (  map Removed removedFiles
      <> map Added addedFiles
      <> map Modified changedFiles )
   where
    detectModification :: (FilePath, ByteString) -> IO (Maybe FilePath)
    detectModification (filename, manifestDigest) = do
      let fullPath = topDir </> filename
      fileExists <- doesFileExist fullPath
      if fileExists then do
        contents <- ByteStringLazy.readFile fullPath
        if manifestDigest == Sha256.hashlazy contents
        then pure Nothing
        else pure (Just filename)
      else
        -- Will be caught by @removedFiles@
        pure 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 path = do
    contentsE <- tryJust (guard . isDoesNotExistError) (Aeson.decodeFileStrict path)
    pure (either (const Nothing) id contentsE)
  
  -- | Write manifest file to disk
  writeManifest :: FilePath -> Manifest -> IO ()
  writeManifest path = ByteStringLazy.writeFile path . Aeson.encodePretty
  
  -- | Serialize a manifest.
  --
  -- TODO: This should really yield a 'ByteString'.
  serializeManifest :: Manifest -> Text
  serializeManifest = LText.toStrict . LText.decodeUtf8 . Aeson.encodePretty
  