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

    {-# LANGUAGE CPP #-}
    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE NamedFieldPuns #-}
    {-# LANGUAGE QuasiQuotes #-}

    module Clash.GHCi.Common
      ( checkImportDirs
      , checkMonoLocalBinds
      , checkMonoLocalBindsMod
      , getMainTopEntity
      ) where

    -- Clash
    import           Clash.Driver.Types     (ClashOpts (..), ClashDesign(..))
    import           Clash.Netlist.Types    (TopEntityT(..))

    -- The GHC interface
    #if MIN_VERSION_ghc(9,0,0)
    import qualified GHC.Data.EnumSet       as GHC (member)
    import           GHC.Utils.Panic        (GhcException (..), throwGhcException)
    import qualified GHC
      (DynFlags, ModSummary (..), extensionFlags, moduleName, moduleNameString)
    #else
    import qualified EnumSet                as GHC (member)
    import           Panic                  (GhcException (..), throwGhcException)
    import qualified GHC                    (DynFlags, ModSummary (..), Module (..),
                                             extensionFlags, moduleNameString)
    #endif
    import           Clash.Core.Name        (nameOcc)
    import           Clash.Core.Var         (varName)
    import           Clash.Normalize.Util   (collectCallGraphUniques, callGraph)
    import qualified Clash.Util.Interpolate as I
    import           Clash.Util             (ClashException(..), noSrcSpan)
    import           Clash.Unique           (getUnique)
    import           Control.Exception      (throw)
    import           Data.List              (isSuffixOf)
    import qualified Data.Text              as Text
    import qualified Data.HashSet           as HashSet
    import qualified GHC.LanguageExtensions as LangExt (Extension (..))
    import           GHC.Stack              (HasCallStack)

    import           Control.Monad          (forM_, unless, when)
    import           System.Directory       (doesDirectoryExist)
    import           System.IO              (hPutStrLn, stderr)

    getMainTopEntity
      :: HasCallStack
      => String
      -- ^ Module name
      -> ClashDesign
      -> String
      -- ^ string passed with -main-is
      -> IO (TopEntityT, [TopEntityT])
      -- ^ Throws exception if -main-is was set, but no such top entity was found.
      -- Otherwise, returns main top entity and all top entities (transitively) used
      -- in the main top entity.
    getMainTopEntity :: HasCallStack =>
    String -> ClashDesign -> String -> IO (TopEntityT, [TopEntityT])
    getMainTopEntity String
    modName ClashDesign
    design String
    nm =
      case (TopEntityT -> Bool) -> [TopEntityT] -> [TopEntityT]
    forall a. (a -> Bool) -> [a] -> [a]
    filter TopEntityT -> Bool
    isNm (ClashDesign -> [TopEntityT]
    designEntities ClashDesign
    design) of
        [] -> ClashException -> IO (TopEntityT, [TopEntityT])
    forall a e. Exception e => e -> a
    throw (ClashException -> IO (TopEntityT, [TopEntityT]))
    -> ClashException -> IO (TopEntityT, [TopEntityT])
    forall a b. (a -> b) -> a -> b
    $ SrcSpan -> String -> Maybe String -> ClashException
    ClashException SrcSpan
    noSrcSpan [I.i|
          Could not find top entity called #{show nm} in #{show modName}
        |] Maybe String
    forall a. Maybe a
    Nothing
        [TopEntityT
    t] ->
          let
            bindingMap :: BindingMap
    bindingMap = ClashDesign -> BindingMap
    designBindings ClashDesign
    design
            closure0 :: HashSet Unique
    closure0 = CallGraph -> HashSet Unique
    collectCallGraphUniques (BindingMap -> Id -> CallGraph
    callGraph BindingMap
    bindingMap (TopEntityT -> Id
    topId TopEntityT
    t))
            closure1 :: HashSet Unique
    closure1 = Unique -> HashSet Unique -> HashSet Unique
    forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
    HashSet.delete (Id -> Unique
    forall a. Uniquable a => a -> Unique
    getUnique (TopEntityT -> Id
    topId TopEntityT
    t)) HashSet Unique
    closure0
          in
            (TopEntityT, [TopEntityT]) -> IO (TopEntityT, [TopEntityT])
    forall a. a -> IO a
    forall (f :: Type -> Type) a. Applicative f => a -> f a
    pure (TopEntityT
    t, (TopEntityT -> Bool) -> [TopEntityT] -> [TopEntityT]
    forall a. (a -> Bool) -> [a] -> [a]
    filter ((Unique -> HashSet Unique -> Bool
    forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
    `HashSet.member` HashSet Unique
    closure1) (Unique -> Bool) -> (TopEntityT -> Unique) -> TopEntityT -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Id -> Unique
    forall a. Uniquable a => a -> Unique
    getUnique (Id -> Unique) -> (TopEntityT -> Id) -> TopEntityT -> Unique
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . TopEntityT -> Id
    topId) (ClashDesign -> [TopEntityT]
    designEntities ClashDesign
    design))
        [TopEntityT]
    ts ->
          String -> IO (TopEntityT, [TopEntityT])
    forall a. HasCallStack => String -> a
    error (String -> IO (TopEntityT, [TopEntityT]))
    -> String -> IO (TopEntityT, [TopEntityT])
    forall a b. (a -> b) -> a -> b
    $ [I.i|
            Internal error: multiple top entities called #{nm} (#{map topId ts})
            found in #{modName}.
          |]
     where
      isNm :: TopEntityT -> Bool
    isNm (TopEntityT{Id
    topId :: TopEntityT -> Id
    topId :: Id
    topId}) =
        let topIdNm :: String
    topIdNm = Text -> String
    Text.unpack (Name Term -> Text
    forall a. Name a -> Text
    nameOcc (Id -> Name Term
    forall a. Var a -> Name a
    varName Id
    topId)) in
        String
    topIdNm String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    == String
    nm Bool -> Bool -> Bool
    || (Char
    '.'Char -> String -> String
    forall a. a -> [a] -> [a]
    :String
    nm) String -> String -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isSuffixOf` String
    topIdNm

    -- | Checks whether MonoLocalBinds and MonomorphismRestricton language extensions
    -- are enabled or not in modules.
    checkMonoLocalBindsMod :: GHC.ModSummary -> IO ()
    checkMonoLocalBindsMod :: ModSummary -> IO ()
    checkMonoLocalBindsMod ModSummary
    x = do
      Bool -> IO () -> IO ()
    forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
    unless (Extension -> DynFlags -> Bool
    active Extension
    LangExt.MonoLocalBinds (DynFlags -> Bool)
    -> (ModSummary -> DynFlags) -> ModSummary -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ModSummary -> DynFlags
    GHC.ms_hspp_opts (ModSummary -> Bool) -> ModSummary -> Bool
    forall a b. (a -> b) -> a -> b
    $ ModSummary
    x)
             (Handle -> String -> IO ()
    hPutStrLn Handle
    stderr (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Extension -> ModSummary -> String
    msg Extension
    LangExt.MonoLocalBinds ModSummary
    x)
      Bool -> IO () -> IO ()
    forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
    unless (Extension -> DynFlags -> Bool
    active Extension
    LangExt.MonomorphismRestriction (DynFlags -> Bool)
    -> (ModSummary -> DynFlags) -> ModSummary -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ModSummary -> DynFlags
    GHC.ms_hspp_opts (ModSummary -> Bool) -> ModSummary -> Bool
    forall a b. (a -> b) -> a -> b
    $ ModSummary
    x)
             (Handle -> String -> IO ()
    hPutStrLn Handle
    stderr (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Extension -> ModSummary -> String
    msg Extension
    LangExt.MonomorphismRestriction ModSummary
    x)
      where
        msg :: Extension -> ModSummary -> String
    msg Extension
    ext = Extension -> String -> String
    messageWith Extension
    ext (String -> String)
    -> (ModSummary -> String) -> ModSummary -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ModuleName -> String
    GHC.moduleNameString (ModuleName -> String)
    -> (ModSummary -> ModuleName) -> ModSummary -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . GenModule Unit -> ModuleName
    forall unit. GenModule unit -> ModuleName
    GHC.moduleName (GenModule Unit -> ModuleName)
    -> (ModSummary -> GenModule Unit) -> ModSummary -> ModuleName
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ModSummary -> GenModule Unit
    GHC.ms_mod

    -- | Checks whether MonoLocalBinds and MonomorphismRestriction language extensions
    -- are enabled when generating the HDL directly e.g. in GHCi. modules.
    checkMonoLocalBinds :: GHC.DynFlags -> IO ()
    checkMonoLocalBinds :: DynFlags -> IO ()
    checkMonoLocalBinds DynFlags
    dflags = do
      Bool -> IO () -> IO ()
    forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
    unless (Extension -> DynFlags -> Bool
    active Extension
    LangExt.MonoLocalBinds DynFlags
    dflags)
             (Handle -> String -> IO ()
    hPutStrLn Handle
    stderr (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Extension -> String -> String
    messageWith Extension
    LangExt.MonoLocalBinds String
    "")
      Bool -> IO () -> IO ()
    forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
    unless (Extension -> DynFlags -> Bool
    active Extension
    LangExt.MonomorphismRestriction DynFlags
    dflags)
             (Handle -> String -> IO ()
    hPutStrLn Handle
    stderr (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Extension -> String -> String
    messageWith Extension
    LangExt.MonomorphismRestriction String
    "")

    messageWith :: LangExt.Extension -> String -> String
    messageWith :: Extension -> String -> String
    messageWith Extension
    ext String
    srcModule
      | String
    srcModule String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    == []  = String
    msgStem String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "."
      | Bool
    otherwise = String
    msgStem String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " in module: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    srcModule
      where
        msgStem :: String
    msgStem = String
    "Warning: Extension " String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> Extension -> String
    forall a. Show a => a -> String
    show Extension
    ext String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>
                  String
    " is disabled. This might lead to unexpected logic duplication"

    active :: LangExt.Extension -> GHC.DynFlags -> Bool
    active :: Extension -> DynFlags -> Bool
    active Extension
    ext = Extension -> EnumSet Extension -> Bool
    forall a. Enum a => a -> EnumSet a -> Bool
    GHC.member Extension
    ext (EnumSet Extension -> Bool)
    -> (DynFlags -> EnumSet Extension) -> DynFlags -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DynFlags -> EnumSet Extension
    GHC.extensionFlags

    checkImportDirs :: Foldable t => ClashOpts -> t FilePath -> IO ()
    checkImportDirs :: forall (t :: Type -> Type).
    Foldable t =>
    ClashOpts -> t String -> IO ()
    checkImportDirs ClashOpts
    opts t String
    idirs = Bool -> IO () -> IO ()
    forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
    when (ClashOpts -> Bool
    opt_checkIDir ClashOpts
    opts) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
      t String -> (String -> IO ()) -> IO ()
    forall (t :: Type -> Type) (m :: Type -> Type) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ t String
    idirs ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \String
    dir -> do
        String -> IO Bool
    doesDirectoryExist String
    dir IO Bool -> (Bool -> IO ()) -> IO ()
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \case
          Bool
    False -> GhcException -> IO ()
    forall a. GhcException -> a
    throwGhcException (String -> GhcException
    CmdLineError (String -> GhcException) -> String -> GhcException
    forall a b. (a -> b) -> a -> b
    $ String
    "Missing directory: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    dir)
          Bool
    _     -> () -> IO ()
    forall a. a -> IO a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return ()