{-# LANGUAGE CPP        #-}
{-# LANGUAGE LambdaCase #-}

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

-- Clash
import           Clash.Driver.Types     (ClashOpts (..))

-- The GHC interface
#if MIN_VERSION_base(4,11,0)
import qualified EnumSet                as GHC (member) -- ghc84, ghc86
#else
import qualified Data.IntSet            as IntSet -- ghc82
#endif
import qualified GHC                    (DynFlags, ModSummary (..), Module (..),
                                         extensionFlags, moduleNameString)
import qualified GHC.LanguageExtensions as LangExt (Extension (..))
import           Panic                  (GhcException (..), throwGhcException)

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

-- | Checks whether MonoLocalBinds language extension is enabled or not in
-- modules.
checkMonoLocalBindsMod :: GHC.ModSummary -> IO ()
checkMonoLocalBindsMod :: ModSummary -> IO ()
checkMonoLocalBindsMod x :: ModSummary
x =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DynFlags -> Bool
active (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
$ ModSummary -> String
msg ModSummary
x)
  where
    msg :: ModSummary -> String
msg = String -> String
messageWith (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
. Module -> ModuleName
GHC.moduleName (Module -> ModuleName)
-> (ModSummary -> Module) -> ModSummary -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Module
GHC.ms_mod

-- | Checks whether MonoLocalBinds language extension is enabled when generating
-- the HDL directly e.g. in GHCi. modules.
checkMonoLocalBinds :: GHC.DynFlags -> IO ()
checkMonoLocalBinds :: DynFlags -> IO ()
checkMonoLocalBinds dflags :: DynFlags
dflags =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DynFlags -> Bool
active DynFlags
dflags) (Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String
messageWith "")

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

active :: GHC.DynFlags -> Bool
#if MIN_VERSION_base(4,11,0)
-- ghc84, ghc86
active :: DynFlags -> Bool
active = Extension -> EnumSet Extension -> Bool
forall a. Enum a => a -> EnumSet a -> Bool
GHC.member Extension
LangExt.MonoLocalBinds (EnumSet Extension -> Bool)
-> (DynFlags -> EnumSet Extension) -> DynFlags -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> EnumSet Extension
GHC.extensionFlags
#else
-- ghc82
active = member LangExt.MonoLocalBinds . GHC.extensionFlags

member :: Enum a => a -> IntSet.IntSet -> Bool
member = IntSet.member . fromEnum
#endif

checkImportDirs :: Foldable t => ClashOpts -> t FilePath -> IO ()
checkImportDirs :: ClashOpts -> t String -> IO ()
checkImportDirs opts :: ClashOpts
opts idirs :: t String
idirs = Bool -> IO () -> IO ()
forall (f :: * -> *). 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 :: * -> *) (m :: * -> *) 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
$ \dir :: String
dir -> do
    String -> IO Bool
doesDirectoryExist String
dir IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      False -> GhcException -> IO ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$ "Missing directory: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dir)
      _     -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()