{-|
  Copyright   :  (C) 2013-2016, University of Twente,
                     2016-2017, Myrtle Software Ltd,
                     2017     , Google Inc.
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}

module Clash.GHC.LoadModules
  ( loadModules
  , ghcLibDir
  , setWantedLanguageExtensions
  )
where

#ifndef USE_GHC_PATHS
#ifndef TOOL_VERSION_ghc
#error TOOL_VERSION_ghc undefined
#endif
#endif

-- External Modules
import           Clash.Annotations.Primitive     (HDL, PrimitiveGuard)
import           Clash.Annotations.TopEntity     (TopEntity (..))
import           Clash.Primitives.Types          (UnresolvedPrimitive)
import           Clash.Util                      (ClashException(..), pkgIdFromTypeable)
import qualified Clash.Util.Interpolate          as I
import           Control.Arrow                   (first, second)
import           Control.DeepSeq                 (deepseq)
import           Control.Exception               (throw)
#if MIN_VERSION_ghc(8,6,0)
import           Control.Exception               (throwIO)
#endif
import           Control.Monad.IO.Class          (liftIO)
import           Data.Char                       (isDigit)
import           Data.Generics.Uniplate.DataOnly (transform)
import           Data.Data                       (Data)
import           Data.Typeable                   (Typeable)
import           Data.List                       (foldl', nub)
import           Data.Maybe                      (catMaybes, listToMaybe)
import qualified Data.Text                       as Text
import qualified Data.Time.Clock                 as Clock
import           Language.Haskell.TH.Syntax      (lift)

#ifdef USE_GHC_PATHS
import           GHC.Paths                       (libdir)
#else
import           System.Exit                     (ExitCode (..))
import           System.IO                       (hGetLine)
import           System.IO.Error                 (tryIOError)
import           System.Process                  (runInteractiveCommand,
                                                  waitForProcess)
#endif

-- GHC API
import qualified Annotations
import qualified CoreFVs
import qualified CoreSyn
import qualified Digraph
#if MIN_VERSION_ghc(8,6,0)
import qualified DynamicLoading
#endif
import           DynFlags                        (GeneralFlag (..))
import qualified DynFlags
import qualified GHC
import qualified HscMain
import qualified HscTypes
import qualified MonadUtils
import qualified Panic
import qualified GhcPlugins                      (deserializeWithData, installedUnitIdString)
import qualified TcRnMonad
import qualified TcRnTypes
import qualified TidyPgm
import qualified Unique
import qualified UniqFM
import qualified FamInst
import qualified FamInstEnv
import qualified GHC.LanguageExtensions          as LangExt
import qualified Name
import qualified OccName
import           Outputable                      (ppr)
import qualified Outputable
import qualified UniqSet
import           Util (OverridingBool)
import qualified Var

-- Internal Modules
import           Clash.GHC.GHC2Core                           (modNameM, qualifiedNameString')
import           Clash.GHC.LoadInterfaceFiles                 (loadExternalExprs, unresolvedPrimitives)
import           Clash.GHCi.Common                            (checkMonoLocalBindsMod)
import           Clash.Util                                   (curLoc, noSrcSpan, reportTimeDiff
                                                              ,wantedLanguageExtensions, unwantedLanguageExtensions)
import           Clash.Annotations.BitRepresentation.Internal
  (DataRepr', dataReprAnnToDataRepr')

ghcLibDir :: IO FilePath
#ifdef USE_GHC_PATHS
ghcLibDir = return libdir
#else
ghcLibDir :: IO FilePath
ghcLibDir = do
  (libDirM :: Maybe FilePath
libDirM,exitCode :: ExitCode
exitCode) <- FilePath -> IO (Maybe FilePath, ExitCode)
getProcessOutput (FilePath -> IO (Maybe FilePath, ExitCode))
-> FilePath -> IO (Maybe FilePath, ExitCode)
forall a b. (a -> b) -> a -> b
$ "ghc-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ TOOL_VERSION_ghc ++ " --print-libdir"
  case ExitCode
exitCode of
     ExitSuccess   -> case Maybe FilePath
libDirM of
       Just libDir :: FilePath
libDir -> FilePath -> IO FilePath
forall (m :: Type -> Type) a. Monad m => a -> m a
return FilePath
libDir
       Nothing     -> FilePath -> IO FilePath
forall a. FilePath -> a
Panic.pgmError FilePath
noGHC
     ExitFailure i :: Int
i -> case Int
i of
       127         -> FilePath -> IO FilePath
forall a. FilePath -> a
Panic.pgmError FilePath
noGHC
       i' :: Int
i'          -> FilePath -> IO FilePath
forall a. FilePath -> a
Panic.pgmError (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ "Calling GHC failed with error code: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i'
  where
    noGHC :: FilePath
noGHC = "Clash needs the GHC compiler it was built with, ghc-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ TOOL_VERSION_ghc ++
            ", but it was not found. Make sure its location is in your PATH variable."

getProcessOutput :: String -> IO (Maybe String, ExitCode)
getProcessOutput :: FilePath -> IO (Maybe FilePath, ExitCode)
getProcessOutput command :: FilePath
command =
     -- Create the process
  do (_, pOut :: Handle
pOut, _, handle :: ProcessHandle
handle) <- FilePath -> IO (Handle, Handle, Handle, ProcessHandle)
runInteractiveCommand FilePath
command
     -- Wait for the process to finish and store its exit code
     ExitCode
exitCode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
handle
     -- Get the standard output.
     Maybe FilePath
output   <- (IOError -> Maybe FilePath)
-> (FilePath -> Maybe FilePath)
-> Either IOError FilePath
-> Maybe FilePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe FilePath -> IOError -> Maybe FilePath
forall a b. a -> b -> a
const Maybe FilePath
forall a. Maybe a
Nothing) FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (Either IOError FilePath -> Maybe FilePath)
-> IO (Either IOError FilePath) -> IO (Maybe FilePath)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FilePath -> IO (Either IOError FilePath)
forall a. IO a -> IO (Either IOError a)
tryIOError (Handle -> IO FilePath
hGetLine Handle
pOut)
     -- return both the output and the exit code.
     (Maybe FilePath, ExitCode) -> IO (Maybe FilePath, ExitCode)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe FilePath
output, ExitCode
exitCode)
#endif

loadModules
  :: OverridingBool
  -- ^ Use color
  -> HDL
  -- ^ HDL target
  -> String
  -- ^ Module name
  -> Maybe (DynFlags.DynFlags)
  -- ^ Flags to run GHC with
  -> [FilePath]
  -- ^ Import dirs to use when no DynFlags are provided
  -> IO ( [CoreSyn.CoreBind]                     -- Binders
        , [(CoreSyn.CoreBndr,Int)]               -- Class operations
        , [CoreSyn.CoreBndr]                     -- Unlocatable Expressions
        , FamInstEnv.FamInstEnvs
        , [( CoreSyn.CoreBndr                    -- topEntity bndr
           , Maybe TopEntity                     -- (maybe) TopEntity annotation
           , Maybe CoreSyn.CoreBndr)]            -- (maybe) testBench bndr
        , [Either UnresolvedPrimitive FilePath]
        , [DataRepr']
        , [(Text.Text, PrimitiveGuard ())]
        )
loadModules :: OverridingBool
-> HDL
-> FilePath
-> Maybe DynFlags
-> [FilePath]
-> IO
     ([CoreBind], [(CoreBndr, Int)], [CoreBndr], FamInstEnvs,
      [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)],
      [Either UnresolvedPrimitive FilePath], [DataRepr'],
      [(Text, PrimitiveGuard ())])
loadModules useColor :: OverridingBool
useColor hdl :: HDL
hdl modName :: FilePath
modName dflagsM :: Maybe DynFlags
dflagsM idirs :: [FilePath]
idirs = do
  FilePath
libDir <- IO FilePath -> IO FilePath
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
MonadUtils.liftIO IO FilePath
ghcLibDir
  UTCTime
startTime <- IO UTCTime
Clock.getCurrentTime
  Maybe FilePath
-> Ghc
     ([CoreBind], [(CoreBndr, Int)], [CoreBndr], FamInstEnvs,
      [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)],
      [Either UnresolvedPrimitive FilePath], [DataRepr'],
      [(Text, PrimitiveGuard ())])
-> IO
     ([CoreBind], [(CoreBndr, Int)], [CoreBndr], FamInstEnvs,
      [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)],
      [Either UnresolvedPrimitive FilePath], [DataRepr'],
      [(Text, PrimitiveGuard ())])
forall a. Maybe FilePath -> Ghc a -> IO a
GHC.runGhc (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
libDir) (Ghc
   ([CoreBind], [(CoreBndr, Int)], [CoreBndr], FamInstEnvs,
    [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)],
    [Either UnresolvedPrimitive FilePath], [DataRepr'],
    [(Text, PrimitiveGuard ())])
 -> IO
      ([CoreBind], [(CoreBndr, Int)], [CoreBndr], FamInstEnvs,
       [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)],
       [Either UnresolvedPrimitive FilePath], [DataRepr'],
       [(Text, PrimitiveGuard ())]))
-> Ghc
     ([CoreBind], [(CoreBndr, Int)], [CoreBndr], FamInstEnvs,
      [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)],
      [Either UnresolvedPrimitive FilePath], [DataRepr'],
      [(Text, PrimitiveGuard ())])
-> IO
     ([CoreBind], [(CoreBndr, Int)], [CoreBndr], FamInstEnvs,
      [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)],
      [Either UnresolvedPrimitive FilePath], [DataRepr'],
      [(Text, PrimitiveGuard ())])
forall a b. (a -> b) -> a -> b
$ do
    DynFlags
dflags <- case Maybe DynFlags
dflagsM of
                Just df :: DynFlags
df -> DynFlags -> Ghc DynFlags
forall (m :: Type -> Type) a. Monad m => a -> m a
return DynFlags
df
                Nothing -> do
#if MIN_VERSION_ghc(8,6,0)
                  -- Make sure we read the .ghc environment files
                  DynFlags
df <- do { DynFlags
df <- Ghc DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
                           ; [InstalledUnitId]
_ <- DynFlags -> Ghc [InstalledUnitId]
forall (m :: Type -> Type).
GhcMonad m =>
DynFlags -> m [InstalledUnitId]
GHC.setSessionDynFlags DynFlags
df {pkgDatabase :: Maybe [(FilePath, [PackageConfig])]
DynFlags.pkgDatabase = Maybe [(FilePath, [PackageConfig])]
forall a. Maybe a
Nothing}
                           ; Ghc DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
                           }
#else
                  df <- GHC.getSessionDynFlags
#endif
                  let df1 :: DynFlags
df1 = DynFlags -> DynFlags
setWantedLanguageExtensions DynFlags
df
                  let ghcTyLitNormPlugin :: ModuleName
ghcTyLitNormPlugin = FilePath -> ModuleName
GHC.mkModuleName "GHC.TypeLits.Normalise"
                      ghcTyLitExtrPlugin :: ModuleName
ghcTyLitExtrPlugin = FilePath -> ModuleName
GHC.mkModuleName "GHC.TypeLits.Extra.Solver"
                      ghcTyLitKNPlugin :: ModuleName
ghcTyLitKNPlugin   = FilePath -> ModuleName
GHC.mkModuleName "GHC.TypeLits.KnownNat.Solver"
                  let dfPlug :: DynFlags
dfPlug = DynFlags
df1 { pluginModNames :: [ModuleName]
DynFlags.pluginModNames = [ModuleName] -> [ModuleName]
forall a. Eq a => [a] -> [a]
nub ([ModuleName] -> [ModuleName]) -> [ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$
                                          ModuleName
ghcTyLitNormPlugin ModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
: ModuleName
ghcTyLitExtrPlugin ModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
:
                                          ModuleName
ghcTyLitKNPlugin ModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
: DynFlags -> [ModuleName]
DynFlags.pluginModNames DynFlags
df1
                                     , useColor :: OverridingBool
DynFlags.useColor = OverridingBool
useColor
                                     , importPaths :: [FilePath]
DynFlags.importPaths = [FilePath]
idirs
                                     }
                  DynFlags -> Ghc DynFlags
forall (m :: Type -> Type) a. Monad m => a -> m a
return DynFlags
dfPlug

    let dflags1 :: DynFlags
dflags1 = DynFlags
dflags
                    { optLevel :: Int
DynFlags.optLevel = 2
                    , ghcMode :: GhcMode
DynFlags.ghcMode  = GhcMode
GHC.CompManager
                    , ghcLink :: GhcLink
DynFlags.ghcLink  = GhcLink
GHC.LinkInMemory
                    , hscTarget :: HscTarget
DynFlags.hscTarget
                        = if Bool
DynFlags.rtsIsProfiled
                             then HscTarget
DynFlags.HscNothing
                             else Platform -> HscTarget
DynFlags.defaultObjectTarget
                                    (DynFlags -> Platform
DynFlags.targetPlatform DynFlags
dflags)
                    , reductionDepth :: IntWithInf
DynFlags.reductionDepth = 1000
                    }
    let dflags2 :: DynFlags
dflags2 = DynFlags -> DynFlags
unwantedOptimizationFlags DynFlags
dflags1
    let ghcDynamic :: Bool
ghcDynamic = case FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "GHC Dynamic" (DynFlags -> [(FilePath, FilePath)]
DynFlags.compilerInfo DynFlags
dflags) of
                      Just "YES" -> Bool
True
                      _          -> Bool
False
    let dflags3 :: DynFlags
dflags3 = if Bool
ghcDynamic then DynFlags -> GeneralFlag -> DynFlags
DynFlags.gopt_set DynFlags
dflags2 GeneralFlag
DynFlags.Opt_BuildDynamicToo
                                else DynFlags
dflags2
#if MIN_VERSION_ghc(8,6,0)
    HscEnv
hscenv <- Ghc HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
    DynFlags
dflags4 <- IO DynFlags -> Ghc DynFlags
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
MonadUtils.liftIO (HscEnv -> DynFlags -> IO DynFlags
DynamicLoading.initializePlugins HscEnv
hscenv DynFlags
dflags3)
    [InstalledUnitId]
_ <- DynFlags -> Ghc [InstalledUnitId]
forall (m :: Type -> Type).
GhcMonad m =>
DynFlags -> m [InstalledUnitId]
GHC.setSessionDynFlags DynFlags
dflags4
#else
    _ <- GHC.setSessionDynFlags dflags3
#endif
    Target
target <- FilePath -> Maybe Phase -> Ghc Target
forall (m :: Type -> Type).
GhcMonad m =>
FilePath -> Maybe Phase -> m Target
GHC.guessTarget FilePath
modName Maybe Phase
forall a. Maybe a
Nothing
    [Target] -> Ghc ()
forall (m :: Type -> Type). GhcMonad m => [Target] -> m ()
GHC.setTargets [Target
target]
    ModuleGraph
modGraph <- [ModuleName] -> Bool -> Ghc ModuleGraph
forall (m :: Type -> Type).
GhcMonad m =>
[ModuleName] -> Bool -> m ModuleGraph
GHC.depanal [] Bool
False
#if MIN_VERSION_ghc(8,4,1)
    let modGraph' :: ModuleGraph
modGraph' = (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph
GHC.mapMG ModSummary -> ModSummary
disableOptimizationsFlags ModuleGraph
modGraph
#else
    let modGraph' = map disableOptimizationsFlags modGraph
#endif
        -- 'topSortModuleGraph' ensures that modGraph2, and hence tidiedMods
        -- are in topological order, i.e. the root module is last.
        modGraph2 :: [ModSummary]
modGraph2 = [SCC ModSummary] -> [ModSummary]
forall a. [SCC a] -> [a]
Digraph.flattenSCCs (Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModSummary]
GHC.topSortModuleGraph Bool
True ModuleGraph
modGraph' Maybe ModuleName
forall a. Maybe a
Nothing)
    [([CoreBind], FamInstEnv)]
tidiedMods <- (ModSummary -> Ghc ([CoreBind], FamInstEnv))
-> [ModSummary] -> Ghc [([CoreBind], FamInstEnv)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\m :: ModSummary
m -> do { DynFlags
oldDFlags <- Ghc DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
                                 ; ParsedModule
pMod  <- ModSummary -> Ghc ParsedModule
forall (m :: Type -> Type).
GhcMonad m =>
ModSummary -> m ParsedModule
parseModule ModSummary
m
                                 ; [InstalledUnitId]
_ <- DynFlags -> Ghc [InstalledUnitId]
forall (m :: Type -> Type).
GhcMonad m =>
DynFlags -> m [InstalledUnitId]
GHC.setSessionDynFlags (ModSummary -> DynFlags
GHC.ms_hspp_opts (ParsedModule -> ModSummary
GHC.pm_mod_summary ParsedModule
pMod))
                                 ; TypecheckedModule
tcMod <- ParsedModule -> Ghc TypecheckedModule
forall (m :: Type -> Type).
GhcMonad m =>
ParsedModule -> m TypecheckedModule
GHC.typecheckModule (ParsedModule -> ParsedModule
removeStrictnessAnnotations ParsedModule
pMod)
                                 -- The purpose of the home package table (HPT) is to track
                                 -- the already compiled modules, so subsequent modules can
                                 -- rely/use those compilation results
                                 --
                                 -- We need to update the home package table (HPT) ourselves
                                 -- as we can no longer depend on 'GHC.load' to create a
                                 -- proper HPT.
                                 --
                                 -- The reason we have to cannot rely on 'GHC.load' is that
                                 -- it runs the rename/type-checker, which we also run in
                                 -- the code above. This would mean that the renamer/type-checker
                                 -- is run twice, which in turn means that template haskell
                                 -- splices are run twice.
                                 --
                                 -- Given that TH splices can do non-trivial computation and I/O,
                                 -- running TH twice must be avoid.
                                 ; TypecheckedModule
tcMod' <- TypecheckedModule -> Ghc TypecheckedModule
forall mod (m :: Type -> Type).
(TypecheckedMod mod, GhcMonad m) =>
mod -> m mod
GHC.loadModule TypecheckedModule
tcMod
                                 ; ModGuts
dsMod <- (DesugaredModule -> ModGuts) -> Ghc DesugaredModule -> Ghc ModGuts
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap DesugaredModule -> ModGuts
forall m. DesugaredMod m => m -> ModGuts
GHC.coreModule (Ghc DesugaredModule -> Ghc ModGuts)
-> Ghc DesugaredModule -> Ghc ModGuts
forall a b. (a -> b) -> a -> b
$ TypecheckedModule -> Ghc DesugaredModule
forall (m :: Type -> Type).
GhcMonad m =>
TypecheckedModule -> m DesugaredModule
GHC.desugarModule TypecheckedModule
tcMod'
                                 ; HscEnv
hsc_env <- Ghc HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
#if MIN_VERSION_ghc(8,4,1)
                                 ; ModGuts
simpl_guts <- IO ModGuts -> Ghc ModGuts
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
MonadUtils.liftIO (IO ModGuts -> Ghc ModGuts) -> IO ModGuts -> Ghc ModGuts
forall a b. (a -> b) -> a -> b
$ HscEnv -> [FilePath] -> ModGuts -> IO ModGuts
HscMain.hscSimplify HscEnv
hsc_env [] ModGuts
dsMod
#else
                                 ; simpl_guts <- MonadUtils.liftIO $ HscMain.hscSimplify hsc_env dsMod
#endif
                                 ; ModGuts -> Ghc ()
forall (m :: Type -> Type). Monad m => ModGuts -> m ()
checkForInvalidPrelude ModGuts
simpl_guts
                                 ; (tidy_guts :: CgGuts
tidy_guts,_) <- IO (CgGuts, ModDetails) -> Ghc (CgGuts, ModDetails)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
MonadUtils.liftIO (IO (CgGuts, ModDetails) -> Ghc (CgGuts, ModDetails))
-> IO (CgGuts, ModDetails) -> Ghc (CgGuts, ModDetails)
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
TidyPgm.tidyProgram HscEnv
hsc_env ModGuts
simpl_guts
                                 ; let pgm :: [CoreBind]
pgm        = CgGuts -> [CoreBind]
HscTypes.cg_binds CgGuts
tidy_guts
                                 ; let modFamInstEnv :: FamInstEnv
modFamInstEnv = TcGblEnv -> FamInstEnv
TcRnTypes.tcg_fam_inst_env (TcGblEnv -> FamInstEnv) -> TcGblEnv -> FamInstEnv
forall a b. (a -> b) -> a -> b
$ (TcGblEnv, ModDetails) -> TcGblEnv
forall a b. (a, b) -> a
fst ((TcGblEnv, ModDetails) -> TcGblEnv)
-> (TcGblEnv, ModDetails) -> TcGblEnv
forall a b. (a -> b) -> a -> b
$ TypecheckedModule -> (TcGblEnv, ModDetails)
GHC.tm_internals_ TypecheckedModule
tcMod
                                 ; [InstalledUnitId]
_ <- DynFlags -> Ghc [InstalledUnitId]
forall (m :: Type -> Type).
GhcMonad m =>
DynFlags -> m [InstalledUnitId]
GHC.setSessionDynFlags DynFlags
oldDFlags
                                 ; ([CoreBind], FamInstEnv) -> Ghc ([CoreBind], FamInstEnv)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([CoreBind]
pgm,FamInstEnv
modFamInstEnv)
                                 }
                         ) [ModSummary]
modGraph2

    let (binders :: [[CoreBind]]
binders,modFamInstEnvs :: [FamInstEnv]
modFamInstEnvs) = [([CoreBind], FamInstEnv)] -> ([[CoreBind]], [FamInstEnv])
forall a b. [(a, b)] -> ([a], [b])
unzip [([CoreBind], FamInstEnv)]
tidiedMods
        bindersC :: [CoreBind]
bindersC                 = [[CoreBind]] -> [CoreBind]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[CoreBind]]
binders
        binderIds :: [CoreBndr]
binderIds                = ((CoreBndr, Expr CoreBndr) -> CoreBndr)
-> [(CoreBndr, Expr CoreBndr)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, Expr CoreBndr) -> CoreBndr
forall a b. (a, b) -> a
fst ([CoreBind] -> [(CoreBndr, Expr CoreBndr)]
forall b. [Bind b] -> [(b, Expr b)]
CoreSyn.flattenBinds [CoreBind]
bindersC)
        plusFamInst :: FamInstEnv -> FamInstEnv -> FamInstEnv
plusFamInst f1 :: FamInstEnv
f1 f2 :: FamInstEnv
f2        = FamInstEnv -> [FamInst] -> FamInstEnv
FamInstEnv.extendFamInstEnvList FamInstEnv
f1 (FamInstEnv -> [FamInst]
FamInstEnv.famInstEnvElts FamInstEnv
f2)
        modFamInstEnvs' :: FamInstEnv
modFamInstEnvs'          = (FamInstEnv -> FamInstEnv -> FamInstEnv)
-> FamInstEnv -> [FamInstEnv] -> FamInstEnv
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' FamInstEnv -> FamInstEnv -> FamInstEnv
plusFamInst FamInstEnv
FamInstEnv.emptyFamInstEnv [FamInstEnv]
modFamInstEnvs

    UTCTime
modTime <- UTCTime
startTime UTCTime -> Int -> Int
forall a b. NFData a => a -> b -> b
`deepseq` [CoreBndr] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [CoreBndr]
binderIds Int -> Ghc UTCTime -> Ghc UTCTime
forall a b. NFData a => a -> b -> b
`deepseq` IO UTCTime -> Ghc UTCTime
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
MonadUtils.liftIO IO UTCTime
Clock.getCurrentTime
    let modStartDiff :: FilePath
modStartDiff = UTCTime -> UTCTime -> FilePath
reportTimeDiff UTCTime
modTime UTCTime
startTime
    IO () -> Ghc ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
MonadUtils.liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "GHC: Parsing and optimising modules took: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
modStartDiff

    (externalBndrs :: [(CoreBndr, Expr CoreBndr)]
externalBndrs,clsOps :: [(CoreBndr, Int)]
clsOps,unlocatable :: [CoreBndr]
unlocatable,unresolvedPrimitives0 :: [Either UnresolvedPrimitive FilePath]
unresolvedPrimitives0,reprs :: [DataRepr']
reprs) <-
      HDL
-> UniqSet CoreBndr
-> [CoreBind]
-> Ghc
     ([(CoreBndr, Expr CoreBndr)], [(CoreBndr, Int)], [CoreBndr],
      [Either UnresolvedPrimitive FilePath], [DataRepr'])
forall (m :: Type -> Type).
GhcMonad m =>
HDL
-> UniqSet CoreBndr
-> [CoreBind]
-> m ([(CoreBndr, Expr CoreBndr)], [(CoreBndr, Int)], [CoreBndr],
      [Either UnresolvedPrimitive FilePath], [DataRepr'])
loadExternalExprs HDL
hdl ([CoreBndr] -> UniqSet CoreBndr
forall a. Uniquable a => [a] -> UniqSet a
UniqSet.mkUniqSet [CoreBndr]
binderIds) [CoreBind]
bindersC

    let externalBndrIds :: [CoreBndr]
externalBndrIds = ((CoreBndr, Expr CoreBndr) -> CoreBndr)
-> [(CoreBndr, Expr CoreBndr)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, Expr CoreBndr) -> CoreBndr
forall a b. (a, b) -> a
fst [(CoreBndr, Expr CoreBndr)]
externalBndrs
    let allBinderIds :: [CoreBndr]
allBinderIds = [CoreBndr]
externalBndrIds [CoreBndr] -> [CoreBndr] -> [CoreBndr]
forall a. [a] -> [a] -> [a]
++ [CoreBndr]
binderIds

    UTCTime
extTime <- UTCTime
modTime UTCTime -> Int -> Int
forall a b. NFData a => a -> b -> b
`deepseq` [CoreBndr] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [CoreBndr]
unlocatable Int -> Ghc UTCTime -> Ghc UTCTime
forall a b. NFData a => a -> b -> b
`deepseq` IO UTCTime -> Ghc UTCTime
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
MonadUtils.liftIO IO UTCTime
Clock.getCurrentTime
    let extModDiff :: FilePath
extModDiff = UTCTime -> UTCTime -> FilePath
reportTimeDiff UTCTime
extTime UTCTime
modTime
    IO () -> Ghc ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
MonadUtils.liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "GHC: Loading external modules from interface files took: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
extModDiff

    -- Find local primitive annotations
    [Either UnresolvedPrimitive FilePath]
unresolvedPrimitives1 <- HDL -> [CoreBndr] -> Ghc [Either UnresolvedPrimitive FilePath]
forall (m :: Type -> Type).
GhcMonad m =>
HDL -> [CoreBndr] -> m [Either UnresolvedPrimitive FilePath]
findPrimitiveAnnotations HDL
hdl [CoreBndr]
binderIds

    HscEnv
hscEnv <- Ghc HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
#if MIN_VERSION_ghc(8,6,0)
    FamInstEnvs
famInstEnvs <- do { (msgs :: Messages
msgs,m :: Maybe FamInstEnvs
m) <- IO (Messages, Maybe FamInstEnvs)
-> Ghc (Messages, Maybe FamInstEnvs)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
TcRnMonad.liftIO (IO (Messages, Maybe FamInstEnvs)
 -> Ghc (Messages, Maybe FamInstEnvs))
-> IO (Messages, Maybe FamInstEnvs)
-> Ghc (Messages, Maybe FamInstEnvs)
forall a b. (a -> b) -> a -> b
$ HscEnv -> TcM FamInstEnvs -> IO (Messages, Maybe FamInstEnvs)
forall a. HscEnv -> TcM a -> IO (Messages, Maybe a)
TcRnMonad.initTcInteractive HscEnv
hscEnv TcM FamInstEnvs
FamInst.tcGetFamInstEnvs
                      ; case Maybe FamInstEnvs
m of
                          Nothing -> IO FamInstEnvs -> Ghc FamInstEnvs
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
TcRnMonad.liftIO (IO FamInstEnvs -> Ghc FamInstEnvs)
-> IO FamInstEnvs -> Ghc FamInstEnvs
forall a b. (a -> b) -> a -> b
$ SourceError -> IO FamInstEnvs
forall e a. Exception e => e -> IO a
throwIO (ErrorMessages -> SourceError
HscTypes.mkSrcErr (Messages -> ErrorMessages
forall a b. (a, b) -> b
snd Messages
msgs))
                          Just x :: FamInstEnvs
x  -> FamInstEnvs -> Ghc FamInstEnvs
forall (m :: Type -> Type) a. Monad m => a -> m a
return FamInstEnvs
x
                      }
#else
    famInstEnvs <- TcRnMonad.liftIO $ TcRnMonad.initTcForLookup hscEnv FamInst.tcGetFamInstEnvs
#endif

    -- Because tidiedMods is in topological order, binders is also, and hence
    -- the binders belonging to the "root" module are the last binders
    let rootModule :: ModuleName
rootModule = ModSummary -> ModuleName
GHC.ms_mod_name (ModSummary -> ModuleName)
-> ([ModSummary] -> ModSummary) -> [ModSummary] -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ModSummary] -> ModSummary
forall a. [a] -> a
last ([ModSummary] -> ModuleName) -> [ModSummary] -> ModuleName
forall a b. (a -> b) -> a -> b
$ [ModSummary]
modGraph2
        rootIds :: [CoreBndr]
rootIds    = ((CoreBndr, Expr CoreBndr) -> CoreBndr)
-> [(CoreBndr, Expr CoreBndr)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, Expr CoreBndr) -> CoreBndr
forall a b. (a, b) -> a
fst ([(CoreBndr, Expr CoreBndr)] -> [CoreBndr])
-> ([CoreBind] -> [(CoreBndr, Expr CoreBndr)])
-> [CoreBind]
-> [CoreBndr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CoreBind] -> [(CoreBndr, Expr CoreBndr)]
forall b. [Bind b] -> [(b, Expr b)]
CoreSyn.flattenBinds ([CoreBind] -> [CoreBndr]) -> [CoreBind] -> [CoreBndr]
forall a b. (a -> b) -> a -> b
$ [[CoreBind]] -> [CoreBind]
forall a. [a] -> a
last [[CoreBind]]
binders

    -- Because tidiedMods is in topological order, binders is also, and hence
    -- allSyn is in topological order. This means that the "root" 'topEntity'
    -- will be compiled last.
    [(CoreBndr, Maybe TopEntity)]
allSyn     <- ((CoreBndr, TopEntity) -> (CoreBndr, Maybe TopEntity))
-> [(CoreBndr, TopEntity)] -> [(CoreBndr, Maybe TopEntity)]
forall a b. (a -> b) -> [a] -> [b]
map ((TopEntity -> Maybe TopEntity)
-> (CoreBndr, TopEntity) -> (CoreBndr, Maybe TopEntity)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second TopEntity -> Maybe TopEntity
forall a. a -> Maybe a
Just) ([(CoreBndr, TopEntity)] -> [(CoreBndr, Maybe TopEntity)])
-> Ghc [(CoreBndr, TopEntity)] -> Ghc [(CoreBndr, Maybe TopEntity)]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [CoreBndr] -> Ghc [(CoreBndr, TopEntity)]
forall (m :: Type -> Type).
GhcMonad m =>
[CoreBndr] -> m [(CoreBndr, TopEntity)]
findSynthesizeAnnotations [CoreBndr]
binderIds
    [(CoreBndr, Maybe TopEntity)]
topSyn     <- ((CoreBndr, TopEntity) -> (CoreBndr, Maybe TopEntity))
-> [(CoreBndr, TopEntity)] -> [(CoreBndr, Maybe TopEntity)]
forall a b. (a -> b) -> [a] -> [b]
map ((TopEntity -> Maybe TopEntity)
-> (CoreBndr, TopEntity) -> (CoreBndr, Maybe TopEntity)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second TopEntity -> Maybe TopEntity
forall a. a -> Maybe a
Just) ([(CoreBndr, TopEntity)] -> [(CoreBndr, Maybe TopEntity)])
-> Ghc [(CoreBndr, TopEntity)] -> Ghc [(CoreBndr, Maybe TopEntity)]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [CoreBndr] -> Ghc [(CoreBndr, TopEntity)]
forall (m :: Type -> Type).
GhcMonad m =>
[CoreBndr] -> m [(CoreBndr, TopEntity)]
findSynthesizeAnnotations [CoreBndr]
rootIds
    [(CoreBndr, CoreBndr)]
benchAnn   <- [CoreBndr] -> Ghc [(CoreBndr, CoreBndr)]
forall (m :: Type -> Type).
GhcMonad m =>
[CoreBndr] -> m [(CoreBndr, CoreBndr)]
findTestBenchAnnotations [CoreBndr]
binderIds
    [DataRepr']
reprs'     <- Ghc [DataRepr']
forall (m :: Type -> Type). GhcMonad m => m [DataRepr']
findCustomReprAnnotations
    [(Text, PrimitiveGuard ())]
primGuards <- [CoreBndr] -> Ghc [(Text, PrimitiveGuard ())]
forall (m :: Type -> Type).
GhcMonad m =>
[CoreBndr] -> m [(Text, PrimitiveGuard ())]
findPrimitiveGuardAnnotations [CoreBndr]
allBinderIds
    let varNameString :: CoreBndr -> FilePath
varNameString = OccName -> FilePath
OccName.occNameString (OccName -> FilePath)
-> (CoreBndr -> OccName) -> CoreBndr -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
Name.nameOccName (Name -> OccName) -> (CoreBndr -> Name) -> CoreBndr -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> Name
Var.varName
        topEntities :: [CoreBndr]
topEntities = (CoreBndr -> Bool) -> [CoreBndr] -> [CoreBndr]
forall a. (a -> Bool) -> [a] -> [a]
filter ((FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "topEntity") (FilePath -> Bool) -> (CoreBndr -> FilePath) -> CoreBndr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> FilePath
varNameString) [CoreBndr]
rootIds
        benches :: [CoreBndr]
benches     = (CoreBndr -> Bool) -> [CoreBndr] -> [CoreBndr]
forall a. (a -> Bool) -> [a] -> [a]
filter ((FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "testBench") (FilePath -> Bool) -> (CoreBndr -> FilePath) -> CoreBndr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> FilePath
varNameString) [CoreBndr]
rootIds
        mergeBench :: (CoreBndr, b) -> (CoreBndr, b, Maybe CoreBndr)
mergeBench (x :: CoreBndr
x,y :: b
y) = (CoreBndr
x,b
y,CoreBndr -> [(CoreBndr, CoreBndr)] -> Maybe CoreBndr
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CoreBndr
x [(CoreBndr, CoreBndr)]
benchAnn)
        allSyn' :: [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)]
allSyn'     = ((CoreBndr, Maybe TopEntity)
 -> (CoreBndr, Maybe TopEntity, Maybe CoreBndr))
-> [(CoreBndr, Maybe TopEntity)]
-> [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, Maybe TopEntity)
-> (CoreBndr, Maybe TopEntity, Maybe CoreBndr)
forall b. (CoreBndr, b) -> (CoreBndr, b, Maybe CoreBndr)
mergeBench [(CoreBndr, Maybe TopEntity)]
allSyn

    [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)]
topEntities' <-
      case ([CoreBndr]
topEntities, [(CoreBndr, Maybe TopEntity)]
topSyn) of
        ([], []) ->
          let modName1 :: FilePath
modName1 = SDoc -> FilePath
Outputable.showSDocUnsafe (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
rootModule) in
          FilePath -> Ghc [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)]
forall a. FilePath -> a
Panic.pgmError [I.i|
            No top-level function called 'topEntity' found, nor a function with
            a 'Synthesize' annotation in module #{modName1}. Did you forget to
            export them?

            For more information on 'Synthesize' annotations, check out the
            documentation of "Clash.Annotations.TopEntity".
          |]
        ([], _) ->
          [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)]
-> Ghc [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)]
allSyn'
        ([x :: CoreBndr
x], _) ->
          case CoreBndr
-> [(CoreBndr, Maybe TopEntity)] -> Maybe (Maybe TopEntity)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CoreBndr
x [(CoreBndr, Maybe TopEntity)]
topSyn of
            Nothing ->
              case CoreBndr -> [(CoreBndr, CoreBndr)] -> Maybe CoreBndr
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CoreBndr
x [(CoreBndr, CoreBndr)]
benchAnn of
                Nothing -> [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)]
-> Ghc [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((CoreBndr
x,Maybe TopEntity
forall a. Maybe a
Nothing,[CoreBndr] -> Maybe CoreBndr
forall a. [a] -> Maybe a
listToMaybe [CoreBndr]
benches)(CoreBndr, Maybe TopEntity, Maybe CoreBndr)
-> [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)]
-> [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)]
forall a. a -> [a] -> [a]
:[(CoreBndr, Maybe TopEntity, Maybe CoreBndr)]
allSyn')
                Just y :: CoreBndr
y  -> [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)]
-> Ghc [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((CoreBndr
x,Maybe TopEntity
forall a. Maybe a
Nothing,CoreBndr -> Maybe CoreBndr
forall a. a -> Maybe a
Just CoreBndr
y)(CoreBndr, Maybe TopEntity, Maybe CoreBndr)
-> [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)]
-> [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)]
forall a. a -> [a] -> [a]
:[(CoreBndr, Maybe TopEntity, Maybe CoreBndr)]
allSyn')
            Just _ ->
              [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)]
-> Ghc [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)]
allSyn'
        (_, _) ->
          FilePath -> Ghc [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)]
forall a. FilePath -> a
Panic.pgmError (FilePath -> Ghc [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)])
-> FilePath -> Ghc [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)]
forall a b. (a -> b) -> a -> b
$ $(curLoc) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "Multiple 'topEntities' found."

    let unresolvedPrimitives2 :: [Either UnresolvedPrimitive FilePath]
unresolvedPrimitives2 = [Either UnresolvedPrimitive FilePath]
unresolvedPrimitives0 [Either UnresolvedPrimitive FilePath]
-> [Either UnresolvedPrimitive FilePath]
-> [Either UnresolvedPrimitive FilePath]
forall a. [a] -> [a] -> [a]
++ [Either UnresolvedPrimitive FilePath]
unresolvedPrimitives1
        reprs1 :: [DataRepr']
reprs1 = [DataRepr']
reprs [DataRepr'] -> [DataRepr'] -> [DataRepr']
forall a. [a] -> [a] -> [a]
++ [DataRepr']
reprs'

    UTCTime
annTime <-
      UTCTime
extTime
        UTCTime -> Int -> Int
forall a b. NFData a => a -> b -> b
`deepseq` [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)]
topEntities'
        Int
-> [Either UnresolvedPrimitive FilePath]
-> [Either UnresolvedPrimitive FilePath]
forall a b. NFData a => a -> b -> b
`deepseq` [Either UnresolvedPrimitive FilePath]
unresolvedPrimitives2
        [Either UnresolvedPrimitive FilePath] -> [DataRepr'] -> [DataRepr']
forall a b. NFData a => a -> b -> b
`deepseq` [DataRepr']
reprs1
        [DataRepr']
-> [(Text, PrimitiveGuard ())] -> [(Text, PrimitiveGuard ())]
forall a b. NFData a => a -> b -> b
`deepseq` [(Text, PrimitiveGuard ())]
primGuards
        [(Text, PrimitiveGuard ())] -> Ghc UTCTime -> Ghc UTCTime
forall a b. NFData a => a -> b -> b
`deepseq` IO UTCTime -> Ghc UTCTime
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
MonadUtils.liftIO IO UTCTime
Clock.getCurrentTime

    let annExtDiff :: FilePath
annExtDiff = UTCTime -> UTCTime -> FilePath
reportTimeDiff UTCTime
annTime UTCTime
extTime
    IO () -> Ghc ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
MonadUtils.liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "GHC: Parsing annotations took: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
annExtDiff
    IO () -> Ghc ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
MonadUtils.liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ (ModSummary -> IO ()) -> [ModSummary] -> IO ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ModSummary -> IO ()
checkMonoLocalBindsMod [ModSummary]
modGraph2

    ([CoreBind], [(CoreBndr, Int)], [CoreBndr], FamInstEnvs,
 [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)],
 [Either UnresolvedPrimitive FilePath], [DataRepr'],
 [(Text, PrimitiveGuard ())])
-> Ghc
     ([CoreBind], [(CoreBndr, Int)], [CoreBndr], FamInstEnvs,
      [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)],
      [Either UnresolvedPrimitive FilePath], [DataRepr'],
      [(Text, PrimitiveGuard ())])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ( [CoreBind]
bindersC [CoreBind] -> [CoreBind] -> [CoreBind]
forall a. [a] -> [a] -> [a]
++ [(CoreBndr, Expr CoreBndr)] -> [CoreBind]
makeRecursiveGroups [(CoreBndr, Expr CoreBndr)]
externalBndrs
           , [(CoreBndr, Int)]
clsOps
           , [CoreBndr]
unlocatable
           , (FamInstEnvs -> FamInstEnv
forall a b. (a, b) -> a
fst FamInstEnvs
famInstEnvs, FamInstEnv
modFamInstEnvs')
           , [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)]
topEntities'
           , [Either UnresolvedPrimitive FilePath]
unresolvedPrimitives2
           , [DataRepr']
reprs1
           , [(Text, PrimitiveGuard ())]
primGuards
           )

-- | Given a set of bindings, make explicit non-recursive bindings and
-- recursive binding groups.
--
-- Needed because:
-- 1. GHC does not preserve this information in interface files,
-- 2. Binders in Clash's BindingsMap are not allowed to be mutually recursive,
--    only self-recursive.
-- 3. Clash.GHC.GenerateBindings.mkBindings turns groups of mutually recursive
--    bindings into self-recursive bindings which can go into the BindingsMap.
makeRecursiveGroups
  :: [(CoreSyn.CoreBndr,CoreSyn.CoreExpr)]
  -> [CoreSyn.CoreBind]
makeRecursiveGroups :: [(CoreBndr, Expr CoreBndr)] -> [CoreBind]
makeRecursiveGroups
  = (SCC (CoreBndr, Expr CoreBndr) -> CoreBind)
-> [SCC (CoreBndr, Expr CoreBndr)] -> [CoreBind]
forall a b. (a -> b) -> [a] -> [b]
map SCC (CoreBndr, Expr CoreBndr) -> CoreBind
makeBind
  ([SCC (CoreBndr, Expr CoreBndr)] -> [CoreBind])
-> ([(CoreBndr, Expr CoreBndr)] -> [SCC (CoreBndr, Expr CoreBndr)])
-> [(CoreBndr, Expr CoreBndr)]
-> [CoreBind]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node Unique (CoreBndr, Expr CoreBndr)]
-> [SCC (CoreBndr, Expr CoreBndr)]
forall key payload.
Uniquable key =>
[Node key payload] -> [SCC payload]
Digraph.stronglyConnCompFromEdgedVerticesUniq
  ([Node Unique (CoreBndr, Expr CoreBndr)]
 -> [SCC (CoreBndr, Expr CoreBndr)])
-> ([(CoreBndr, Expr CoreBndr)]
    -> [Node Unique (CoreBndr, Expr CoreBndr)])
-> [(CoreBndr, Expr CoreBndr)]
-> [SCC (CoreBndr, Expr CoreBndr)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CoreBndr, Expr CoreBndr)
 -> Node Unique (CoreBndr, Expr CoreBndr))
-> [(CoreBndr, Expr CoreBndr)]
-> [Node Unique (CoreBndr, Expr CoreBndr)]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, Expr CoreBndr) -> Node Unique (CoreBndr, Expr CoreBndr)
makeNode
  where
    makeNode
      :: (CoreSyn.CoreBndr,CoreSyn.CoreExpr)
      -> Digraph.Node Unique.Unique (CoreSyn.CoreBndr,CoreSyn.CoreExpr)
    makeNode :: (CoreBndr, Expr CoreBndr) -> Node Unique (CoreBndr, Expr CoreBndr)
makeNode (b :: CoreBndr
b,e :: Expr CoreBndr
e) =
#if MIN_VERSION_ghc(8,4,1)
      (CoreBndr, Expr CoreBndr)
-> Unique -> [Unique] -> Node Unique (CoreBndr, Expr CoreBndr)
forall key payload. payload -> key -> [key] -> Node key payload
Digraph.DigraphNode
        (CoreBndr
b,Expr CoreBndr
e)
        (CoreBndr -> Unique
Var.varUnique CoreBndr
b)
        (UniqSet CoreBndr -> [Unique]
forall elt. UniqSet elt -> [Unique]
UniqSet.nonDetKeysUniqSet (Expr CoreBndr -> UniqSet CoreBndr
CoreFVs.exprFreeIds Expr CoreBndr
e))
#else
      ((b,e)
      ,Var.varUnique b
      ,UniqSet.nonDetKeysUniqSet (CoreFVs.exprFreeIds e))
#endif

    makeBind
      :: Digraph.SCC (CoreSyn.CoreBndr,CoreSyn.CoreExpr)
      -> CoreSyn.CoreBind
    makeBind :: SCC (CoreBndr, Expr CoreBndr) -> CoreBind
makeBind (Digraph.AcyclicSCC (b :: CoreBndr
b,e :: Expr CoreBndr
e)) = CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
CoreSyn.NonRec CoreBndr
b Expr CoreBndr
e
    makeBind (Digraph.CyclicSCC bs :: [(CoreBndr, Expr CoreBndr)]
bs)     = [(CoreBndr, Expr CoreBndr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
CoreSyn.Rec [(CoreBndr, Expr CoreBndr)]
bs

errOnDuplicateAnnotations
  :: String
  -- ^ Name of annotation
  -> [CoreSyn.CoreBndr]
  -- ^ Binders searched for
  -> [[a]]
  -- ^ Parsed annotations
  -> [(CoreSyn.CoreBndr, a)]
errOnDuplicateAnnotations :: FilePath -> [CoreBndr] -> [[a]] -> [(CoreBndr, a)]
errOnDuplicateAnnotations nm :: FilePath
nm bndrs :: [CoreBndr]
bndrs anns :: [[a]]
anns =
  [(CoreBndr, [a])] -> [(CoreBndr, a)]
forall a. [(CoreBndr, [a])] -> [(CoreBndr, a)]
go ([CoreBndr] -> [[a]] -> [(CoreBndr, [a])]
forall a b. [a] -> [b] -> [(a, b)]
zip [CoreBndr]
bndrs [[a]]
anns)
 where
  go
    :: [(CoreSyn.CoreBndr, [a])]
    -> [(CoreSyn.CoreBndr, a)]
  go :: [(CoreBndr, [a])] -> [(CoreBndr, a)]
go []             = []
  go ((_, []):ps :: [(CoreBndr, [a])]
ps)   = [(CoreBndr, [a])] -> [(CoreBndr, a)]
forall a. [(CoreBndr, [a])] -> [(CoreBndr, a)]
go [(CoreBndr, [a])]
ps
  go ((b :: CoreBndr
b, [p :: a
p]):ps :: [(CoreBndr, [a])]
ps)  = (CoreBndr
b, a
p) (CoreBndr, a) -> [(CoreBndr, a)] -> [(CoreBndr, a)]
forall a. a -> [a] -> [a]
: ([(CoreBndr, [a])] -> [(CoreBndr, a)]
forall a. [(CoreBndr, [a])] -> [(CoreBndr, a)]
go [(CoreBndr, [a])]
ps)
  go ((b :: CoreBndr
b, _):_)  =
    FilePath -> [(CoreBndr, a)]
forall a. FilePath -> a
Panic.pgmError (FilePath -> [(CoreBndr, a)]) -> FilePath -> [(CoreBndr, a)]
forall a b. (a -> b) -> a -> b
$ "The following value has multiple "
                  FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "'" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
nm FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "' annotations: "
                  FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SDoc -> FilePath
Outputable.showSDocUnsafe (CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
b)

-- | Find annotations by given targets
findAnnotationsByTargets
  :: GHC.GhcMonad m
  => Typeable a
  => Data a
  => [Annotations.AnnTarget Name.Name]
  -> m [[a]]
findAnnotationsByTargets :: [AnnTarget Name] -> m [[a]]
findAnnotationsByTargets targets :: [AnnTarget Name]
targets =
  (AnnTarget Name -> m [a]) -> [AnnTarget Name] -> m [[a]]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (([Word8] -> a) -> AnnTarget Name -> m [a]
forall (m :: Type -> Type) a.
(GhcMonad m, Typeable a) =>
([Word8] -> a) -> AnnTarget Name -> m [a]
GHC.findGlobalAnns [Word8] -> a
forall a. Data a => [Word8] -> a
GhcPlugins.deserializeWithData) [AnnTarget Name]
targets

-- | Find all annotations of a certain type in all modules seen so far.
findAllModuleAnnotations
  :: GHC.GhcMonad m
  => Data a
  => Typeable a
  => m [a]
findAllModuleAnnotations :: m [a]
findAllModuleAnnotations = do
  HscEnv
hsc_env <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
  AnnEnv
ann_env <- IO AnnEnv -> m AnnEnv
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO AnnEnv -> m AnnEnv) -> IO AnnEnv -> m AnnEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> Maybe ModGuts -> IO AnnEnv
HscTypes.prepareAnnotations HscEnv
hsc_env Maybe ModGuts
forall a. Maybe a
Nothing
  [a] -> m [a]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([a] -> m [a]) -> [a] -> m [a]
forall a b. (a -> b) -> a -> b
$ [[a]] -> [a]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat
         ([[a]] -> [a]) -> [[a]] -> [a]
forall a b. (a -> b) -> a -> b
$ UniqFM [a] -> [[a]]
forall elt. UniqFM elt -> [elt]
UniqFM.nonDetEltsUFM
         (UniqFM [a] -> [[a]]) -> UniqFM [a] -> [[a]]
forall a b. (a -> b) -> a -> b
$ ([Word8] -> a) -> AnnEnv -> UniqFM [a]
forall a. Typeable a => ([Word8] -> a) -> AnnEnv -> UniqFM [a]
Annotations.deserializeAnns [Word8] -> a
forall a. Data a => [Word8] -> a
GhcPlugins.deserializeWithData AnnEnv
ann_env

-- | Find all annotations belonging to all binders seen so far.
findNamedAnnotations
  :: GHC.GhcMonad m
  => Data a
  => Typeable a
  => [CoreSyn.CoreBndr]
  -> m [[a]]
findNamedAnnotations :: [CoreBndr] -> m [[a]]
findNamedAnnotations bndrs :: [CoreBndr]
bndrs =
  [AnnTarget Name] -> m [[a]]
forall (m :: Type -> Type) a.
(GhcMonad m, Typeable a, Data a) =>
[AnnTarget Name] -> m [[a]]
findAnnotationsByTargets ((CoreBndr -> AnnTarget Name) -> [CoreBndr] -> [AnnTarget Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> AnnTarget Name
forall name. name -> AnnTarget name
Annotations.NamedTarget (Name -> AnnTarget Name)
-> (CoreBndr -> Name) -> CoreBndr -> AnnTarget Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> Name
Var.varName) [CoreBndr]
bndrs)

findPrimitiveGuardAnnotations
  :: GHC.GhcMonad m
  => [CoreSyn.CoreBndr]
  -> m [(Text.Text, (PrimitiveGuard ()))]
findPrimitiveGuardAnnotations :: [CoreBndr] -> m [(Text, PrimitiveGuard ())]
findPrimitiveGuardAnnotations bndrs :: [CoreBndr]
bndrs = do
  [[PrimitiveGuard ()]]
anns0 <- [CoreBndr] -> m [[PrimitiveGuard ()]]
forall (m :: Type -> Type) a.
(GhcMonad m, Data a, Typeable a) =>
[CoreBndr] -> m [[a]]
findNamedAnnotations [CoreBndr]
bndrs
  let anns1 :: [(CoreBndr, PrimitiveGuard ())]
anns1 = FilePath
-> [CoreBndr]
-> [[PrimitiveGuard ()]]
-> [(CoreBndr, PrimitiveGuard ())]
forall a. FilePath -> [CoreBndr] -> [[a]] -> [(CoreBndr, a)]
errOnDuplicateAnnotations "PrimitiveGuard" [CoreBndr]
bndrs [[PrimitiveGuard ()]]
anns0
  [(Text, PrimitiveGuard ())] -> m [(Text, PrimitiveGuard ())]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (((CoreBndr, PrimitiveGuard ()) -> (Text, PrimitiveGuard ()))
-> [(CoreBndr, PrimitiveGuard ())] -> [(Text, PrimitiveGuard ())]
forall a b. (a -> b) -> [a] -> [b]
map ((CoreBndr -> Text)
-> (CoreBndr, PrimitiveGuard ()) -> (Text, PrimitiveGuard ())
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Name -> Text
qualifiedNameString' (Name -> Text) -> (CoreBndr -> Name) -> CoreBndr -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> Name
Var.varName)) [(CoreBndr, PrimitiveGuard ())]
anns1)

-- | Find annotations of type @DataReprAnn@ and convert them to @DataRepr'@
findCustomReprAnnotations
  :: GHC.GhcMonad m
  => m [DataRepr']
findCustomReprAnnotations :: m [DataRepr']
findCustomReprAnnotations =
  (DataReprAnn -> DataRepr') -> [DataReprAnn] -> [DataRepr']
forall a b. (a -> b) -> [a] -> [b]
map DataReprAnn -> DataRepr'
dataReprAnnToDataRepr' ([DataReprAnn] -> [DataRepr']) -> m [DataReprAnn] -> m [DataRepr']
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m [DataReprAnn]
forall (m :: Type -> Type) a.
(GhcMonad m, Data a, Typeable a) =>
m [a]
findAllModuleAnnotations

-- | Find synthesize annotations and make sure each binder has no more than
-- a single annotation.
findSynthesizeAnnotations
  :: GHC.GhcMonad m
  => [CoreSyn.CoreBndr]
  -> m [(CoreSyn.CoreBndr, TopEntity)]
findSynthesizeAnnotations :: [CoreBndr] -> m [(CoreBndr, TopEntity)]
findSynthesizeAnnotations bndrs :: [CoreBndr]
bndrs = do
  [[TopEntity]]
anns <- [CoreBndr] -> m [[TopEntity]]
forall (m :: Type -> Type) a.
(GhcMonad m, Data a, Typeable a) =>
[CoreBndr] -> m [[a]]
findNamedAnnotations [CoreBndr]
bndrs
  [(CoreBndr, TopEntity)] -> m [(CoreBndr, TopEntity)]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (FilePath -> [CoreBndr] -> [[TopEntity]] -> [(CoreBndr, TopEntity)]
forall a. FilePath -> [CoreBndr] -> [[a]] -> [(CoreBndr, a)]
errOnDuplicateAnnotations "Synthesize" [CoreBndr]
bndrs (([TopEntity] -> [TopEntity]) -> [[TopEntity]] -> [[TopEntity]]
forall a b. (a -> b) -> [a] -> [b]
map ((TopEntity -> Bool) -> [TopEntity] -> [TopEntity]
forall a. (a -> Bool) -> [a] -> [a]
filter TopEntity -> Bool
isSyn) [[TopEntity]]
anns))
 where
  isSyn :: TopEntity -> Bool
isSyn (Synthesize {}) = Bool
True
  isSyn _               = Bool
False

-- | Find testbench annotations and make sure that each binder has no more than
-- a single annotation.
findTestBenchAnnotations
  :: GHC.GhcMonad m
  => [CoreSyn.CoreBndr]
  -> m [(CoreSyn.CoreBndr,CoreSyn.CoreBndr)]
findTestBenchAnnotations :: [CoreBndr] -> m [(CoreBndr, CoreBndr)]
findTestBenchAnnotations bndrs :: [CoreBndr]
bndrs = do
  [[TopEntity]]
anns0 <- [CoreBndr] -> m [[TopEntity]]
forall (m :: Type -> Type) a.
(GhcMonad m, Data a, Typeable a) =>
[CoreBndr] -> m [[a]]
findNamedAnnotations [CoreBndr]
bndrs
  let anns1 :: [[TopEntity]]
anns1 = ([TopEntity] -> [TopEntity]) -> [[TopEntity]] -> [[TopEntity]]
forall a b. (a -> b) -> [a] -> [b]
map ((TopEntity -> Bool) -> [TopEntity] -> [TopEntity]
forall a. (a -> Bool) -> [a] -> [a]
filter TopEntity -> Bool
isTB) [[TopEntity]]
anns0
      anns2 :: [(CoreBndr, TopEntity)]
anns2 = FilePath -> [CoreBndr] -> [[TopEntity]] -> [(CoreBndr, TopEntity)]
forall a. FilePath -> [CoreBndr] -> [[a]] -> [(CoreBndr, a)]
errOnDuplicateAnnotations "TestBench" [CoreBndr]
bndrs [[TopEntity]]
anns1
  [(CoreBndr, CoreBndr)] -> m [(CoreBndr, CoreBndr)]
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((CoreBndr, TopEntity) -> (CoreBndr, CoreBndr))
-> [(CoreBndr, TopEntity)] -> [(CoreBndr, CoreBndr)]
forall a b. (a -> b) -> [a] -> [b]
map ((TopEntity -> CoreBndr)
-> (CoreBndr, TopEntity) -> (CoreBndr, CoreBndr)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second TopEntity -> CoreBndr
findTB) [(CoreBndr, TopEntity)]
anns2)
  where
    isTB :: TopEntity -> Bool
isTB (TestBench {}) = Bool
True
    isTB _              = Bool
False

    findTB :: TopEntity -> CoreSyn.CoreBndr
    findTB :: TopEntity -> CoreBndr
findTB (TestBench tb :: Name
tb) = case [CoreBndr] -> Maybe CoreBndr
forall a. [a] -> Maybe a
listToMaybe ((CoreBndr -> Bool) -> [CoreBndr] -> [CoreBndr]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> CoreBndr -> Bool
forall a. Show a => a -> CoreBndr -> Bool
eqNm Name
tb) [CoreBndr]
bndrs) of
      Just tb' :: CoreBndr
tb' -> CoreBndr
tb'
      Nothing  -> FilePath -> CoreBndr
forall a. FilePath -> a
Panic.pgmError (FilePath -> CoreBndr) -> FilePath -> CoreBndr
forall a b. (a -> b) -> a -> b
$
        "TestBench named: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Name -> FilePath
forall a. Show a => a -> FilePath
show Name
tb FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " not found"
    findTB _ = FilePath -> CoreBndr
forall a. FilePath -> a
Panic.pgmError "Unexpected Synthesize"

    eqNm :: a -> CoreBndr -> Bool
eqNm thNm :: a
thNm bndr :: CoreBndr
bndr = FilePath -> Text
Text.pack (a -> FilePath
forall a. Show a => a -> FilePath
show a
thNm) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
qualNm
      where
        bndrNm :: Name
bndrNm  = CoreBndr -> Name
Var.varName CoreBndr
bndr
        qualNm :: Text
qualNm  = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
occName (\modName :: Text
modName -> Text
modName Text -> Text -> Text
`Text.append` ('.' Char -> Text -> Text
`Text.cons` Text
occName)) (Name -> Maybe Text
modNameM Name
bndrNm)
        occName :: Text
occName = FilePath -> Text
Text.pack (OccName -> FilePath
OccName.occNameString (Name -> OccName
Name.nameOccName Name
bndrNm))

-- | Find primitive annotations bound to given binders, or annotations made
-- in modules of those binders.
findPrimitiveAnnotations
  :: GHC.GhcMonad m
  => HDL
  -> [CoreSyn.CoreBndr]
  -> m [Either UnresolvedPrimitive FilePath]
findPrimitiveAnnotations :: HDL -> [CoreBndr] -> m [Either UnresolvedPrimitive FilePath]
findPrimitiveAnnotations hdl :: HDL
hdl bndrs :: [CoreBndr]
bndrs = do
  let
    annTargets :: [Maybe (AnnTarget name)]
annTargets =
     (Name -> Maybe (AnnTarget name))
-> [Name] -> [Maybe (AnnTarget name)]
forall a b. (a -> b) -> [a] -> [b]
map
       ((Module -> AnnTarget name)
-> Maybe Module -> Maybe (AnnTarget name)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Module -> AnnTarget name
forall name. Module -> AnnTarget name
Annotations.ModuleTarget (Maybe Module -> Maybe (AnnTarget name))
-> (Name -> Maybe Module) -> Name -> Maybe (AnnTarget name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Maybe Module
Name.nameModule_maybe)
       ((CoreBndr -> Name) -> [CoreBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map CoreBndr -> Name
Var.varName [CoreBndr]
bndrs)

  let
    targets :: [AnnTarget Name]
targets =
      ([Maybe (AnnTarget Name)] -> [AnnTarget Name]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (AnnTarget Name)]
forall name. [Maybe (AnnTarget name)]
annTargets) [AnnTarget Name] -> [AnnTarget Name] -> [AnnTarget Name]
forall a. [a] -> [a] -> [a]
++
        ((CoreBndr -> AnnTarget Name) -> [CoreBndr] -> [AnnTarget Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> AnnTarget Name
forall name. name -> AnnTarget name
Annotations.NamedTarget (Name -> AnnTarget Name)
-> (CoreBndr -> Name) -> CoreBndr -> AnnTarget Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> Name
Var.varName) [CoreBndr]
bndrs)

  [[Primitive]]
anns <- [AnnTarget Name] -> m [[Primitive]]
forall (m :: Type -> Type) a.
(GhcMonad m, Typeable a, Data a) =>
[AnnTarget Name] -> m [[a]]
findAnnotationsByTargets [AnnTarget Name]
targets

  [[Either UnresolvedPrimitive FilePath]]
-> [Either UnresolvedPrimitive FilePath]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[Either UnresolvedPrimitive FilePath]]
 -> [Either UnresolvedPrimitive FilePath])
-> m [[Either UnresolvedPrimitive FilePath]]
-> m [Either UnresolvedPrimitive FilePath]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
    ((AnnTarget Name, Primitive)
 -> m [Either UnresolvedPrimitive FilePath])
-> [(AnnTarget Name, Primitive)]
-> m [[Either UnresolvedPrimitive FilePath]]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HDL
-> (AnnTarget Name, Primitive)
-> m [Either UnresolvedPrimitive FilePath]
forall (m :: Type -> Type).
MonadIO m =>
HDL
-> (AnnTarget Name, Primitive)
-> m [Either UnresolvedPrimitive FilePath]
unresolvedPrimitives HDL
hdl)
    ([[(AnnTarget Name, Primitive)]] -> [(AnnTarget Name, Primitive)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[(AnnTarget Name, Primitive)]] -> [(AnnTarget Name, Primitive)])
-> [[(AnnTarget Name, Primitive)]] -> [(AnnTarget Name, Primitive)]
forall a b. (a -> b) -> a -> b
$ (AnnTarget Name -> [Primitive] -> [(AnnTarget Name, Primitive)])
-> [AnnTarget Name]
-> [[Primitive]]
-> [[(AnnTarget Name, Primitive)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\t :: AnnTarget Name
t -> (Primitive -> (AnnTarget Name, Primitive))
-> [Primitive] -> [(AnnTarget Name, Primitive)]
forall a b. (a -> b) -> [a] -> [b]
map ((,) AnnTarget Name
t)) [AnnTarget Name]
targets [[Primitive]]
anns)

parseModule :: GHC.GhcMonad m => GHC.ModSummary -> m GHC.ParsedModule
parseModule :: ModSummary -> m ParsedModule
parseModule modSum :: ModSummary
modSum = do
  (GHC.ParsedModule pmModSum :: ModSummary
pmModSum pmParsedSource :: ParsedSource
pmParsedSource extraSrc :: [FilePath]
extraSrc anns :: ApiAnns
anns) <-
    ModSummary -> m ParsedModule
forall (m :: Type -> Type).
GhcMonad m =>
ModSummary -> m ParsedModule
GHC.parseModule ModSummary
modSum
  ParsedModule -> m ParsedModule
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ModSummary -> ParsedSource -> [FilePath] -> ApiAnns -> ParsedModule
GHC.ParsedModule
            (ModSummary -> ModSummary
disableOptimizationsFlags ModSummary
pmModSum)
            ParsedSource
pmParsedSource [FilePath]
extraSrc ApiAnns
anns)

disableOptimizationsFlags :: GHC.ModSummary -> GHC.ModSummary
disableOptimizationsFlags :: ModSummary -> ModSummary
disableOptimizationsFlags ms :: ModSummary
ms@(GHC.ModSummary {..})
  = ModSummary
ms {ms_hspp_opts :: DynFlags
GHC.ms_hspp_opts = DynFlags
dflags}
  where
    dflags :: DynFlags
dflags = DynFlags -> DynFlags
unwantedOptimizationFlags (DynFlags
ms_hspp_opts
              { optLevel :: Int
DynFlags.optLevel = 2
              , reductionDepth :: IntWithInf
DynFlags.reductionDepth = 1000
              })

unwantedOptimizationFlags :: GHC.DynFlags -> GHC.DynFlags
unwantedOptimizationFlags :: DynFlags -> DynFlags
unwantedOptimizationFlags df :: DynFlags
df =
  (DynFlags -> Extension -> DynFlags)
-> DynFlags -> [Extension] -> DynFlags
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> Extension -> DynFlags
DynFlags.xopt_unset
    ((DynFlags -> GeneralFlag -> DynFlags)
-> DynFlags -> [GeneralFlag] -> DynFlags
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> GeneralFlag -> DynFlags
DynFlags.gopt_unset DynFlags
df [GeneralFlag]
unwanted) [Extension]
unwantedLang
  where
    unwanted :: [GeneralFlag]
unwanted = [ GeneralFlag
Opt_LiberateCase -- Perform unrolling of recursive RHS: avoid
               , GeneralFlag
Opt_SpecConstr -- Creates local-functions: avoid
               , GeneralFlag
Opt_IgnoreAsserts -- We don't care about assertions
               , GeneralFlag
Opt_DoEtaReduction -- We want eta-expansion
               , GeneralFlag
Opt_UnboxStrictFields -- Unboxed types are not handled properly: avoid
               , GeneralFlag
Opt_UnboxSmallStrictFields -- Unboxed types are not handled properly: avoid
#if !MIN_VERSION_ghc(8,6,0)
               , Opt_Vectorise -- Don't care
               , Opt_VectorisationAvoidance -- Don't care
#endif
               , GeneralFlag
Opt_RegsGraph -- Don't care
               , GeneralFlag
Opt_RegsGraph -- Don't care
               , GeneralFlag
Opt_PedanticBottoms -- Stops eta-expansion through case: avoid
               , GeneralFlag
Opt_LlvmTBAA -- Don't care
               , GeneralFlag
Opt_CmmSink -- Don't care
               , GeneralFlag
Opt_CmmElimCommonBlocks -- Don't care
               , GeneralFlag
Opt_OmitYields -- Don't care
               , GeneralFlag
Opt_IgnoreInterfacePragmas -- We need all the unfoldings we can get
               , GeneralFlag
Opt_OmitInterfacePragmas -- We need all the unfoldings we can get
               , GeneralFlag
Opt_IrrefutableTuples -- Introduce irrefutPatError: avoid
               , GeneralFlag
Opt_Loopification -- STG pass, don't care
               , GeneralFlag
Opt_CprAnal -- The worker/wrapper introduced by CPR breaks Clash, see [NOTE: CPR breaks Clash]
               , GeneralFlag
Opt_FullLaziness -- increases sharing, but seems to result in worse circuits (in both area and propagation delay)
               ]

    -- Coercions between Integer and Clash' numeric primitives cause Clash to
    -- fail. As strictness only affects simulation behavior, removing them
    -- is perfectly safe.
    unwantedLang :: [Extension]
unwantedLang = [ Extension
LangExt.Strict
                   , Extension
LangExt.StrictData
                   ]

-- [NOTE: CPR breaks Clash]
-- We used to completely disable strictness analysis because it causes GHC to
-- do the so-called "Constructed Product Result" (CPR) analysis, which in turn
-- creates an annoying worker/wrapper which does the following:
--
--   * Scrutinise a Signal, and pack the head and tail of the
--     Signal in an unboxed tuple.
--   * Scrutinise on the unboxed tuple, and recreate the Signal.
--
-- This is problematic because the 'Signal' type is essentially treated as a "transparent"
-- type by the Clash compiler, so observing its constructor leads to all kinds
-- of problems.
--
-- The current solution is to disable strictness analysis in "Clash.Signal.Internal"
-- so that functions manipulating 'Signal' constructor do not get a strictness/
-- demand/CPR annotation, which in turn ensures GHC doesn't create worker/wrappers
-- for when these functions are called in user code.
--
-- Ultimately we should stop treating Signal as a "transparent" type and deal
-- handling of the Signal type, and the involved co-recursive functions,
-- properly. At the moment, Clash cannot deal with this recursive type and the
-- recursive functions involved, and hence we need to disable this useful transformation. After
-- everything is done properly, we should enable it again.


setWantedLanguageExtensions :: GHC.DynFlags -> GHC.DynFlags
setWantedLanguageExtensions :: DynFlags -> DynFlags
setWantedLanguageExtensions df :: DynFlags
df =
   (DynFlags -> GeneralFlag -> DynFlags)
-> DynFlags -> [GeneralFlag] -> DynFlags
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> GeneralFlag -> DynFlags
DynFlags.gopt_set
    ((DynFlags -> Extension -> DynFlags)
-> DynFlags -> [Extension] -> DynFlags
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> Extension -> DynFlags
DynFlags.xopt_unset
      ((DynFlags -> Extension -> DynFlags)
-> DynFlags -> [Extension] -> DynFlags
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> Extension -> DynFlags
DynFlags.xopt_set DynFlags
df [Extension]
wantedLanguageExtensions) [Extension]
unwantedLanguageExtensions)
      [GeneralFlag]
wantedOptimizations
 where
  wantedOptimizations :: [GeneralFlag]
wantedOptimizations =
    [ GeneralFlag
Opt_CSE -- CSE
    , GeneralFlag
Opt_Specialise -- Specialise on types, specialise type-class-overloaded function defined in this module for the types
    , GeneralFlag
Opt_DoLambdaEtaExpansion -- transform nested series of lambdas into one with multiple arguments, helps us achieve only top-level lambdas
    , GeneralFlag
Opt_CaseMerge -- We want fewer case-statements
    , GeneralFlag
Opt_DictsCheap -- Makes dictionaries seem cheap to optimizer: hopefully inline
    , GeneralFlag
Opt_ExposeAllUnfoldings -- We need all the unfoldings we can get
    , GeneralFlag
Opt_ForceRecomp -- Force recompilation: never bad
    , GeneralFlag
Opt_EnableRewriteRules -- Reduce number of functions
    , GeneralFlag
Opt_SimplPreInlining -- Inlines simple functions, we only care about the major first-order structure
    , GeneralFlag
Opt_StaticArgumentTransformation -- Turn on the static argument transformation, which turns a recursive function into a non-recursive one with a local recursive loop.
    , GeneralFlag
Opt_FloatIn -- Moves let-bindings inwards, although it defeats the normal-form with a single top-level let-binding, it helps with other transformations
    , GeneralFlag
Opt_DictsStrict -- Hopefully helps remove class method selectors
    , GeneralFlag
Opt_DmdTxDictSel -- I think demand and strictness are related, strictness helps with dead-code, enable
    , GeneralFlag
Opt_Strictness -- Strictness analysis helps with dead-code analysis. However, see [NOTE: CPR breaks Clash]
    , GeneralFlag
Opt_SpecialiseAggressively -- Needed to compile Fixed point number functions quickly
    , GeneralFlag
Opt_CrossModuleSpecialise -- Needed to compile Fixed point number functions quickly
    ]

-- | Remove all strictness annotations:
--
-- * Remove strictness annotations from data type declarations
--   (only works for data types that are currently being compiled, i.e.,
--    that are not part of a pre-compiled imported library)
--
-- We need to remove strictness annotations because GHC will introduce casts
-- between Integer and Clash' numeric primitives otherwise, where Clash will
-- error when it sees such casts. The reason it does this is because
-- Integer is a completely unconstrained integer type and is currently
-- (erroneously) translated to a 64-bit integer in the HDL; this means that
-- we could lose bits when the original numeric type had more bits than 64.
--
-- Removing these strictness annotations is perfectly safe, as they only
-- affect simulation behavior.
removeStrictnessAnnotations ::
     GHC.ParsedModule
  -> GHC.ParsedModule
removeStrictnessAnnotations :: ParsedModule -> ParsedModule
removeStrictnessAnnotations pm :: ParsedModule
pm =
    ParsedModule
pm {pm_parsed_source :: ParsedSource
GHC.pm_parsed_source = (HsModule GhcPs -> HsModule GhcPs) -> ParsedSource -> ParsedSource
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap HsModule GhcPs -> HsModule GhcPs
rmPS (ParsedModule -> ParsedSource
GHC.pm_parsed_source ParsedModule
pm)}
  where
    -- rmPS :: GHC.DataId name => GHC.HsModule name -> GHC.HsModule name
    rmPS :: HsModule GhcPs -> HsModule GhcPs
rmPS hsm :: HsModule GhcPs
hsm = HsModule GhcPs
hsm {hsmodDecls :: [LHsDecl GhcPs]
GHC.hsmodDecls = ((LHsDecl GhcPs -> LHsDecl GhcPs)
-> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LHsDecl GhcPs -> LHsDecl GhcPs)
 -> [LHsDecl GhcPs] -> [LHsDecl GhcPs])
-> ((HsDecl GhcPs -> HsDecl GhcPs)
    -> LHsDecl GhcPs -> LHsDecl GhcPs)
-> (HsDecl GhcPs -> HsDecl GhcPs)
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsDecl GhcPs -> HsDecl GhcPs) -> LHsDecl GhcPs -> LHsDecl GhcPs
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap) HsDecl GhcPs -> HsDecl GhcPs
rmHSD (HsModule GhcPs -> [LHsDecl GhcPs]
forall pass. HsModule pass -> [LHsDecl pass]
GHC.hsmodDecls HsModule GhcPs
hsm)}

    -- rmHSD :: GHC.DataId name => GHC.HsDecl name -> GHC.HsDecl name
#if MIN_VERSION_ghc(8,6,0)
    rmHSD :: HsDecl GhcPs -> HsDecl GhcPs
rmHSD (GHC.TyClD x :: XTyClD GhcPs
x tyClDecl :: TyClDecl GhcPs
tyClDecl) = XTyClD GhcPs -> TyClDecl GhcPs -> HsDecl GhcPs
forall p. XTyClD p -> TyClDecl p -> HsDecl p
GHC.TyClD XTyClD GhcPs
x (TyClDecl GhcPs -> TyClDecl GhcPs
rmTyClD TyClDecl GhcPs
tyClDecl)
#else
    rmHSD (GHC.TyClD tyClDecl) = GHC.TyClD (rmTyClD tyClDecl)
#endif
    rmHSD hsd :: HsDecl GhcPs
hsd                  = HsDecl GhcPs
hsd

    -- rmTyClD :: GHC.DataId name => GHC.TyClDecl name -> GHC.TyClDecl name
    rmTyClD :: TyClDecl GhcPs -> TyClDecl GhcPs
rmTyClD dc :: TyClDecl GhcPs
dc@(GHC.DataDecl {}) = TyClDecl GhcPs
dc {tcdDataDefn :: HsDataDefn GhcPs
GHC.tcdDataDefn = HsDataDefn GhcPs -> HsDataDefn GhcPs
rmDataDefn (TyClDecl GhcPs -> HsDataDefn GhcPs
forall pass. TyClDecl pass -> HsDataDefn pass
GHC.tcdDataDefn TyClDecl GhcPs
dc)}
    rmTyClD tyClD :: TyClDecl GhcPs
tyClD = TyClDecl GhcPs
tyClD

    -- rmDataDefn :: GHC.DataId name => GHC.HsDataDefn name -> GHC.HsDataDefn name
    rmDataDefn :: HsDataDefn GhcPs -> HsDataDefn GhcPs
rmDataDefn hdf :: HsDataDefn GhcPs
hdf = HsDataDefn GhcPs
hdf {dd_cons :: [LConDecl GhcPs]
GHC.dd_cons = ((LConDecl GhcPs -> LConDecl GhcPs)
-> [LConDecl GhcPs] -> [LConDecl GhcPs]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LConDecl GhcPs -> LConDecl GhcPs)
 -> [LConDecl GhcPs] -> [LConDecl GhcPs])
-> ((ConDecl GhcPs -> ConDecl GhcPs)
    -> LConDecl GhcPs -> LConDecl GhcPs)
-> (ConDecl GhcPs -> ConDecl GhcPs)
-> [LConDecl GhcPs]
-> [LConDecl GhcPs]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConDecl GhcPs -> ConDecl GhcPs)
-> LConDecl GhcPs -> LConDecl GhcPs
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap) ConDecl GhcPs -> ConDecl GhcPs
rmCD (HsDataDefn GhcPs -> [LConDecl GhcPs]
forall pass. HsDataDefn pass -> [LConDecl pass]
GHC.dd_cons HsDataDefn GhcPs
hdf)}

    -- rmCD :: GHC.DataId name => GHC.ConDecl name -> GHC.ConDecl name
#if MIN_VERSION_ghc(8,6,0)
    rmCD :: ConDecl GhcPs -> ConDecl GhcPs
rmCD gadt :: ConDecl GhcPs
gadt@(GHC.ConDeclGADT {}) = ConDecl GhcPs
gadt {con_res_ty :: LHsType GhcPs
GHC.con_res_ty = LHsType GhcPs -> LHsType GhcPs
rmHsType (ConDecl GhcPs -> LHsType GhcPs
forall pass. ConDecl pass -> LHsType pass
GHC.con_res_ty ConDecl GhcPs
gadt)
                                          ,con_args :: HsConDeclDetails GhcPs
GHC.con_args   = HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs
forall (f :: Type -> Type) (f :: Type -> Type) (f :: Type -> Type).
(Functor f, Functor f, Functor f) =>
HsConDetails (LHsType GhcPs) (f (f (f (ConDeclField GhcPs))))
-> HsConDetails (LHsType GhcPs) (f (f (f (ConDeclField GhcPs))))
rmConDetails (ConDecl GhcPs -> HsConDeclDetails GhcPs
forall pass. ConDecl pass -> HsConDeclDetails pass
GHC.con_args ConDecl GhcPs
gadt)
                                          }
    rmCD h98 :: ConDecl GhcPs
h98@(GHC.ConDeclH98 {})   = ConDecl GhcPs
h98  {con_args :: HsConDeclDetails GhcPs
GHC.con_args = HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs
forall (f :: Type -> Type) (f :: Type -> Type) (f :: Type -> Type).
(Functor f, Functor f, Functor f) =>
HsConDetails (LHsType GhcPs) (f (f (f (ConDeclField GhcPs))))
-> HsConDetails (LHsType GhcPs) (f (f (f (ConDeclField GhcPs))))
rmConDetails (ConDecl GhcPs -> HsConDeclDetails GhcPs
forall pass. ConDecl pass -> HsConDeclDetails pass
GHC.con_args ConDecl GhcPs
h98)}
    rmCD xcon :: ConDecl GhcPs
xcon                      = ConDecl GhcPs
xcon
#else
    rmCD gadt@(GHC.ConDeclGADT {}) = gadt {GHC.con_type = rmSigType (GHC.con_type gadt)}
    rmCD h98@(GHC.ConDeclH98 {})   = h98  {GHC.con_details = rmConDetails (GHC.con_details h98)}
#endif

    -- type LHsSigType name = HsImplicitBndrs name (LHsType name)
    -- rmSigType :: GHC.DataId name => GHC.LHsSigType name -> GHC.LHsSigType name
#if !MIN_VERSION_ghc(8,6,0)
    rmSigType hsIB = hsIB {GHC.hsib_body = rmHsType (GHC.hsib_body hsIB)}
#endif

    -- type HsConDeclDetails name = HsConDetails (LBangType name) (Located [LConDeclField name])
    -- rmConDetails :: GHC.DataId name => GHC.HsConDeclDetails name -> GHC.HsConDeclDetails name
    rmConDetails :: HsConDetails (LHsType GhcPs) (f (f (f (ConDeclField GhcPs))))
-> HsConDetails (LHsType GhcPs) (f (f (f (ConDeclField GhcPs))))
rmConDetails (GHC.PrefixCon args :: [LHsType GhcPs]
args) = [LHsType GhcPs]
-> HsConDetails (LHsType GhcPs) (f (f (f (ConDeclField GhcPs))))
forall arg rec. [arg] -> HsConDetails arg rec
GHC.PrefixCon ((LHsType GhcPs -> LHsType GhcPs)
-> [LHsType GhcPs] -> [LHsType GhcPs]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap LHsType GhcPs -> LHsType GhcPs
rmHsType [LHsType GhcPs]
args)
    rmConDetails (GHC.RecCon rec :: f (f (f (ConDeclField GhcPs)))
rec)     = f (f (f (ConDeclField GhcPs)))
-> HsConDetails (LHsType GhcPs) (f (f (f (ConDeclField GhcPs))))
forall arg rec. rec -> HsConDetails arg rec
GHC.RecCon (((f (f (ConDeclField GhcPs)) -> f (f (ConDeclField GhcPs)))
-> f (f (f (ConDeclField GhcPs))) -> f (f (f (ConDeclField GhcPs)))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((f (f (ConDeclField GhcPs)) -> f (f (ConDeclField GhcPs)))
 -> f (f (f (ConDeclField GhcPs)))
 -> f (f (f (ConDeclField GhcPs))))
-> ((ConDeclField GhcPs -> ConDeclField GhcPs)
    -> f (f (ConDeclField GhcPs)) -> f (f (ConDeclField GhcPs)))
-> (ConDeclField GhcPs -> ConDeclField GhcPs)
-> f (f (f (ConDeclField GhcPs)))
-> f (f (f (ConDeclField GhcPs)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f (ConDeclField GhcPs) -> f (ConDeclField GhcPs))
-> f (f (ConDeclField GhcPs)) -> f (f (ConDeclField GhcPs))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((f (ConDeclField GhcPs) -> f (ConDeclField GhcPs))
 -> f (f (ConDeclField GhcPs)) -> f (f (ConDeclField GhcPs)))
-> ((ConDeclField GhcPs -> ConDeclField GhcPs)
    -> f (ConDeclField GhcPs) -> f (ConDeclField GhcPs))
-> (ConDeclField GhcPs -> ConDeclField GhcPs)
-> f (f (ConDeclField GhcPs))
-> f (f (ConDeclField GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConDeclField GhcPs -> ConDeclField GhcPs)
-> f (ConDeclField GhcPs) -> f (ConDeclField GhcPs)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap) ConDeclField GhcPs -> ConDeclField GhcPs
rmConDeclF f (f (f (ConDeclField GhcPs)))
rec)
    rmConDetails (GHC.InfixCon l :: LHsType GhcPs
l r :: LHsType GhcPs
r)   = LHsType GhcPs
-> LHsType GhcPs
-> HsConDetails (LHsType GhcPs) (f (f (f (ConDeclField GhcPs))))
forall arg rec. arg -> arg -> HsConDetails arg rec
GHC.InfixCon (LHsType GhcPs -> LHsType GhcPs
rmHsType LHsType GhcPs
l) (LHsType GhcPs -> LHsType GhcPs
rmHsType LHsType GhcPs
r)

    -- rmHsType :: GHC.DataId name => GHC.Located (GHC.HsType name) -> GHC.Located (GHC.HsType name)
    rmHsType :: LHsType GhcPs -> LHsType GhcPs
rmHsType = (LHsType GhcPs -> LHsType GhcPs) -> LHsType GhcPs -> LHsType GhcPs
forall on. Uniplate on => (on -> on) -> on -> on
transform LHsType GhcPs -> LHsType GhcPs
forall pass. LHsType pass -> LHsType pass
go
      where
#if MIN_VERSION_ghc(8,6,0)
        go :: LHsType pass -> LHsType pass
go (LHsType pass -> SrcSpanLess (LHsType pass)
forall a. HasSrcSpan a => a -> SrcSpanLess a
GHC.unLoc -> GHC.HsBangTy _ _ ty) = LHsType pass
ty
#else
        go (GHC.unLoc -> GHC.HsBangTy _ ty) = ty
#endif
        go ty :: LHsType pass
ty                               = LHsType pass
ty

    -- rmConDeclF :: GHC.DataId name => GHC.ConDeclField name -> GHC.ConDeclField name
    rmConDeclF :: ConDeclField GhcPs -> ConDeclField GhcPs
rmConDeclF cdf :: ConDeclField GhcPs
cdf = ConDeclField GhcPs
cdf {cd_fld_type :: LHsType GhcPs
GHC.cd_fld_type = LHsType GhcPs -> LHsType GhcPs
rmHsType (ConDeclField GhcPs -> LHsType GhcPs
forall pass. ConDeclField pass -> LBangType pass
GHC.cd_fld_type ConDeclField GhcPs
cdf)}

-- | The package id of the clash-prelude we were built with
preludePkgId :: String
preludePkgId :: FilePath
preludePkgId = $(lift $ pkgIdFromTypeable (undefined :: TopEntity))

-- | Check that we're using the same clash-prelude as we were built with
--
-- Because if they differ clash won't be able to recognize any ANNotations.
checkForInvalidPrelude :: Monad m => HscTypes.ModGuts -> m ()
checkForInvalidPrelude :: ModGuts -> m ()
checkForInvalidPrelude guts :: ModGuts
guts =
  case (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
isWrongPrelude [FilePath]
pkgIds of
    []    -> () -> m ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
    (x :: FilePath
x:_) -> ClashException -> m ()
forall a e. Exception e => e -> a
throw (SrcSpan -> FilePath -> Maybe FilePath -> ClashException
ClashException SrcSpan
noSrcSpan (FilePath -> FilePath
msgWrongPrelude FilePath
x) Maybe FilePath
forall a. Maybe a
Nothing)
  where
    pkgs :: [(InstalledUnitId, Bool)]
pkgs = Dependencies -> [(InstalledUnitId, Bool)]
HscTypes.dep_pkgs (Dependencies -> [(InstalledUnitId, Bool)])
-> (ModGuts -> Dependencies)
-> ModGuts
-> [(InstalledUnitId, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModGuts -> Dependencies
HscTypes.mg_deps (ModGuts -> [(InstalledUnitId, Bool)])
-> ModGuts -> [(InstalledUnitId, Bool)]
forall a b. (a -> b) -> a -> b
$ ModGuts
guts
    pkgIds :: [FilePath]
pkgIds = ((InstalledUnitId, Bool) -> FilePath)
-> [(InstalledUnitId, Bool)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (InstalledUnitId -> FilePath
GhcPlugins.installedUnitIdString (InstalledUnitId -> FilePath)
-> ((InstalledUnitId, Bool) -> InstalledUnitId)
-> (InstalledUnitId, Bool)
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InstalledUnitId, Bool) -> InstalledUnitId
forall a b. (a, b) -> a
fst) [(InstalledUnitId, Bool)]
pkgs
    prelude :: FilePath
prelude = "clash-prelude-"
    isPrelude :: FilePath -> Bool
isPrelude pkg :: FilePath
pkg = case Int -> FilePath -> (FilePath, FilePath)
forall a. Int -> [a] -> ([a], [a])
splitAt (FilePath -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length FilePath
prelude) FilePath
pkg of
      (x :: FilePath
x,y :: Char
y:_) | FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
prelude Bool -> Bool -> Bool
&& Char -> Bool
isDigit Char
y -> Bool
True     -- check for a digit so we don't match clash-prelude-extras
      _ -> Bool
False
    isWrongPrelude :: FilePath -> Bool
isWrongPrelude pkg :: FilePath
pkg = FilePath -> Bool
isPrelude FilePath
pkg Bool -> Bool -> Bool
&& FilePath
pkg FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
preludePkgId
    msgWrongPrelude :: FilePath -> FilePath
msgWrongPrelude pkg :: FilePath
pkg = [FilePath] -> FilePath
unlines ["Clash only works with the exact clash-prelude it was built with."
                                  ,"Clash was built with: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
preludePkgId
                                  ,"So can't run with:    " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
pkg
                                  ]