-- | This module provides a GHC 'Plugin' that allows LiquidHaskell to be hooked directly into GHC's
-- compilation pipeline, facilitating its usage and adoption.

{-# LANGUAGE MultiWayIf                 #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE ViewPatterns               #-}

module Language.Haskell.Liquid.GHC.Plugin (

  plugin

  ) where

import qualified Outputable                              as O
import           GHC                               hiding ( Target
                                                          , Located
                                                          , desugarModule
                                                          )

import           Plugins                                 as GHC
import           TcRnTypes                               as GHC
import           TcRnMonad                               as GHC

import qualified Language.Haskell.Liquid.GHC.Misc        as LH
import qualified Language.Haskell.Liquid.UX.CmdLine      as LH
import qualified Language.Haskell.Liquid.GHC.Interface   as LH
import qualified Language.Haskell.Liquid.Liquid          as LH
import qualified Language.Haskell.Liquid.Types.PrettyPrint as LH (reportErrors)
import qualified Language.Haskell.Liquid.GHC.Logging     as LH   (fromPJDoc)

import           Language.Haskell.Liquid.GHC.Plugin.Types
import           Language.Haskell.Liquid.GHC.Plugin.Util as Util
import           Language.Haskell.Liquid.GHC.Plugin.SpecFinder
                                                         as SpecFinder

import           Language.Haskell.Liquid.GHC.Types       (MGIModGuts(..), miModGuts)
import qualified Language.Haskell.Liquid.GHC.GhcMonadLike
                                                         as GhcMonadLike
import           Language.Haskell.Liquid.GHC.GhcMonadLike ( GhcMonadLike
                                                          , askHscEnv
                                                          )
import           CoreMonad
import           DataCon
import           DynFlags
import           HscTypes                          hiding ( Target )
import           InstEnv
import           Module
import           FamInstEnv
import qualified TysPrim
import           GHC.LanguageExtensions

import           Control.Monad
import           Control.Exception                        (evaluate)

import           Data.Coerce
import           Data.List                               as L
                                                   hiding ( intersperse )
import           Data.IORef
import qualified Data.Set                                as S
import           Data.Set                                 ( Set )


import qualified Data.HashSet                            as HS
import qualified Data.HashMap.Strict                     as HM

import           System.IO.Unsafe                         ( unsafePerformIO )
import           Language.Fixpoint.Types           hiding ( panic
                                                          , Error
                                                          , Result
                                                          , Expr
                                                          )

import qualified Language.Haskell.Liquid.Measure         as Ms
import           Language.Haskell.Liquid.Parse
import           Language.Haskell.Liquid.Transforms.ANF
import           Language.Haskell.Liquid.Types     hiding ( getConfig )
import           Language.Haskell.Liquid.Bare
import           Language.Haskell.Liquid.UX.CmdLine

import           Optics


---------------------------------------------------------------------------------
-- | State and configuration management -----------------------------------------
---------------------------------------------------------------------------------

-- | A reference to cache the LH's 'Config' and produce it only /once/, during the dynFlags hook.
cfgRef :: IORef Config
cfgRef :: IORef Config
cfgRef = IO (IORef Config) -> IORef Config
forall a. IO a -> a
unsafePerformIO (IO (IORef Config) -> IORef Config)
-> IO (IORef Config) -> IORef Config
forall a b. (a -> b) -> a -> b
$ Config -> IO (IORef Config)
forall a. a -> IO (IORef a)
newIORef Config
defConfig
{-# NOINLINE cfgRef #-}

-- | Set to 'True' to enable debug logging.
debugLogs :: Bool
debugLogs :: Bool
debugLogs = Bool
False

---------------------------------------------------------------------------------
-- | Useful functions -----------------------------------------------------------
---------------------------------------------------------------------------------

-- | Reads the 'Config' out of a 'IORef'.
getConfig :: IO Config
getConfig :: IO Config
getConfig = IORef Config -> IO Config
forall a. IORef a -> IO a
readIORef IORef Config
cfgRef

-- | Combinator which conditionally print on the screen based on the value of 'debugLogs'.
debugLog :: MonadIO m => String -> m ()
debugLog :: String -> m ()
debugLog String
msg = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugLogs (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
putStrLn String
msg)

---------------------------------------------------------------------------------
-- | The Plugin entrypoint ------------------------------------------------------
---------------------------------------------------------------------------------

plugin :: GHC.Plugin
plugin :: Plugin
plugin = Plugin
GHC.defaultPlugin {
    typeCheckResultAction :: [String] -> ModSummary -> TcGblEnv -> TcM TcGblEnv
typeCheckResultAction = [String] -> ModSummary -> TcGblEnv -> TcM TcGblEnv
typecheckHook
  , dynflagsPlugin :: [String] -> DynFlags -> IO DynFlags
dynflagsPlugin        = [String] -> DynFlags -> IO DynFlags
customDynFlags
  , pluginRecompile :: [String] -> IO PluginRecompile
pluginRecompile       = [String] -> IO PluginRecompile
purePlugin
  }

--------------------------------------------------------------------------------
-- | GHC Configuration & Setup -------------------------------------------------
--------------------------------------------------------------------------------

-- | Overrides the default 'DynFlags' options. Specifically, we need the GHC
-- lexer not to throw away block comments, as this is where the LH spec comments
-- would live. This is why we set the 'Opt_KeepRawTokenStream' option.
customDynFlags :: [CommandLineOption] -> DynFlags -> IO DynFlags
customDynFlags :: [String] -> DynFlags -> IO DynFlags
customDynFlags [String]
opts DynFlags
dflags = do
  Config
cfg <- IO Config -> IO Config
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Config -> IO Config) -> IO Config -> IO Config
forall a b. (a -> b) -> a -> b
$ [String] -> IO Config
LH.getOpts [String]
opts
  IORef Config -> Config -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Config
cfgRef Config
cfg
  DynFlags -> IO DynFlags
configureDynFlags DynFlags
dflags

configureDynFlags :: DynFlags -> IO DynFlags
configureDynFlags :: DynFlags -> IO DynFlags
configureDynFlags DynFlags
df =
  DynFlags -> IO DynFlags
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DynFlags -> IO DynFlags) -> DynFlags -> IO DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags
df DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_ImplicitImportQualified
            DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_PIC
            DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_DeferTypedHoles
            DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_KeepRawTokenStream
            DynFlags -> Extension -> DynFlags
`xopt_set` Extension
MagicHash
            DynFlags -> Extension -> DynFlags
`xopt_set` Extension
DeriveGeneric
            DynFlags -> Extension -> DynFlags
`xopt_set` Extension
StandaloneDeriving

--------------------------------------------------------------------------------
-- | \"Unoptimising\" things ----------------------------------------------------
--------------------------------------------------------------------------------

-- | LiquidHaskell requires the unoptimised core binds in order to work correctly, but at the same time the
-- user can invoke GHC with /any/ optimisation flag turned out. This is why we grab the core binds by
-- desugaring the module during /parsing/ (before that's already too late) and we cache the core binds for
-- the rest of the program execution.
class Unoptimise a where
  type UnoptimisedTarget a :: *
  unoptimise :: a -> UnoptimisedTarget a

instance Unoptimise DynFlags where
  type UnoptimisedTarget DynFlags = DynFlags
  unoptimise :: DynFlags -> UnoptimisedTarget DynFlags
unoptimise DynFlags
df = Int -> DynFlags -> DynFlags
updOptLevel Int
0 DynFlags
df
    { debugLevel :: Int
debugLevel   = Int
1
    , ghcLink :: GhcLink
ghcLink      = GhcLink
LinkInMemory
    , hscTarget :: HscTarget
hscTarget    = HscTarget
HscInterpreted
    , ghcMode :: GhcMode
ghcMode      = GhcMode
CompManager
    }

instance Unoptimise ModSummary where
  type UnoptimisedTarget ModSummary = ModSummary
  unoptimise :: ModSummary -> UnoptimisedTarget ModSummary
unoptimise ModSummary
modSummary = ModSummary
modSummary { ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags -> UnoptimisedTarget DynFlags
forall a. Unoptimise a => a -> UnoptimisedTarget a
unoptimise (ModSummary -> DynFlags
ms_hspp_opts ModSummary
modSummary) }

instance Unoptimise (DynFlags, HscEnv) where
  type UnoptimisedTarget (DynFlags, HscEnv) = HscEnv
  unoptimise :: (DynFlags, HscEnv) -> UnoptimisedTarget (DynFlags, HscEnv)
unoptimise (DynFlags -> UnoptimisedTarget DynFlags
forall a. Unoptimise a => a -> UnoptimisedTarget a
unoptimise -> UnoptimisedTarget DynFlags
df, HscEnv
env) = HscEnv
env { hsc_dflags :: DynFlags
hsc_dflags = DynFlags
UnoptimisedTarget DynFlags
df }

--------------------------------------------------------------------------------
-- | Typechecking phase --------------------------------------------------------
--------------------------------------------------------------------------------

-- | We hook at this stage of the pipeline in order to call \"liquidhaskell\". This
-- might seems counterintuitive as LH works on a desugared module. However, there
-- are a bunch of reasons why we do this:
--
-- 1. Tools like \"ghcide\" works by running the compilation pipeline up until
--    this stage, which means that we won't be able to report errors and warnings
--    if we call /LH/ any later than here;
--
-- 2. Although /LH/ works on \"Core\", it requires the _unoptimised_ \"Core\" that we
--    grab from parsing (again) the module by using the GHC API, so we are really
--    independent from the \"normal\" compilation pipeline.
--
typecheckHook :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv
typecheckHook :: [String] -> ModSummary -> TcGblEnv -> TcM TcGblEnv
typecheckHook [String]
_ (ModSummary -> UnoptimisedTarget ModSummary
forall a. Unoptimise a => a -> UnoptimisedTarget a
unoptimise -> UnoptimisedTarget ModSummary
modSummary) TcGblEnv
tcGblEnv = do
  String -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debugLog (String -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> String -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ String
"We are in module: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> StableModule -> String
forall a. Show a => a -> String
show (Module -> StableModule
toStableModule Module
thisModule)

  ParsedModule
parsed        <- ModSummary -> IOEnv (Env TcGblEnv TcLclEnv) ParsedModule
forall (m :: * -> *).
GhcMonadLike m =>
ModSummary -> m ParsedModule
GhcMonadLike.parseModule (ModSummary -> ModSummary
LH.keepRawTokenStream ModSummary
cleanedSummary)
  let comments :: [(SourcePos, String)]
comments  = ApiAnns -> [(SourcePos, String)]
LH.extractSpecComments (ParsedModule -> ApiAnns
pm_annotations ParsedModule
parsed)
  TypecheckedModule
typechecked     <- ParsedModule -> IOEnv (Env TcGblEnv TcLclEnv) TypecheckedModule
forall (m :: * -> *).
GhcMonadLike m =>
ParsedModule -> m TypecheckedModule
GhcMonadLike.typecheckModule (ParsedModule -> ParsedModule
LH.ignoreInline ParsedModule
parsed)
  HscEnv
env             <- IOEnv (Env TcGblEnv TcLclEnv) HscEnv
forall (m :: * -> *). HasHscEnv m => m HscEnv
askHscEnv
  [(Name, Maybe TyThing)]
resolvedNames   <- HscEnv
-> ModSummary
-> TcGblEnv
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, Maybe TyThing)]
forall (m :: * -> *).
GhcMonadLike m =>
HscEnv -> ModSummary -> TcGblEnv -> m [(Name, Maybe TyThing)]
LH.lookupTyThings HscEnv
env ModSummary
UnoptimisedTarget ModSummary
modSummary TcGblEnv
tcGblEnv
  [TyCon]
availTyCons     <- HscEnv
-> ModSummary
-> TcGblEnv
-> [AvailInfo]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall (m :: * -> *).
GhcMonadLike m =>
HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> m [TyCon]
LH.availableTyCons HscEnv
env ModSummary
UnoptimisedTarget ModSummary
modSummary TcGblEnv
tcGblEnv (TcGblEnv -> [AvailInfo]
tcg_exports TcGblEnv
tcGblEnv)
  [Var]
availVars       <- HscEnv
-> ModSummary
-> TcGblEnv
-> [AvailInfo]
-> IOEnv (Env TcGblEnv TcLclEnv) [Var]
forall (m :: * -> *).
GhcMonadLike m =>
HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> m [Var]
LH.availableVars HscEnv
env ModSummary
UnoptimisedTarget ModSummary
modSummary TcGblEnv
tcGblEnv (TcGblEnv -> [AvailInfo]
tcg_exports TcGblEnv
tcGblEnv)

  ModGuts
unoptimisedGuts <- ModSummary
-> TypecheckedModule -> IOEnv (Env TcGblEnv TcLclEnv) ModGuts
forall (m :: * -> *) t.
(GhcMonadLike m, IsTypecheckedModule t) =>
ModSummary -> t -> m ModGuts
GhcMonadLike.desugarModule ModSummary
UnoptimisedTarget ModSummary
modSummary TypecheckedModule
typechecked

  let tcData :: TcData
tcData = [LImportDecl GhcRn]
-> [(Name, Maybe TyThing)] -> [TyCon] -> [Var] -> TcData
mkTcData (TcGblEnv -> [LImportDecl GhcRn]
tcg_rn_imports TcGblEnv
tcGblEnv) [(Name, Maybe TyThing)]
resolvedNames [TyCon]
availTyCons [Var]
availVars
  let pipelineData :: PipelineData
pipelineData = Unoptimised ModGuts -> TcData -> [SpecComment] -> PipelineData
PipelineData (ModGuts -> Unoptimised ModGuts
forall a. a -> Unoptimised a
toUnoptimised ModGuts
unoptimisedGuts) TcData
tcData (((SourcePos, String) -> SpecComment)
-> [(SourcePos, String)] -> [SpecComment]
forall a b. (a -> b) -> [a] -> [b]
map (SourcePos, String) -> SpecComment
SpecComment [(SourcePos, String)]
comments)

  PipelineData -> ModSummary -> TcGblEnv -> TcM TcGblEnv
liquidHaskellCheck PipelineData
pipelineData ModSummary
UnoptimisedTarget ModSummary
modSummary TcGblEnv
tcGblEnv

  where
    thisModule :: Module
    thisModule :: Module
thisModule = TcGblEnv -> Module
tcg_mod TcGblEnv
tcGblEnv

    cleanedSummary :: ModSummary
    cleanedSummary :: ModSummary
cleanedSummary =
        ModSummary
UnoptimisedTarget ModSummary
modSummary { ms_hspp_opts :: DynFlags
ms_hspp_opts = (ModSummary -> DynFlags
ms_hspp_opts ModSummary
UnoptimisedTarget ModSummary
modSummary) { cachedPlugins :: [LoadedPlugin]
cachedPlugins = []
                                                              , staticPlugins :: [StaticPlugin]
staticPlugins = []
                                                              }
                   }

-- | Partially calls into LiquidHaskell's GHC API.
liquidHaskellCheck :: PipelineData -> ModSummary -> TcGblEnv -> TcM TcGblEnv
liquidHaskellCheck :: PipelineData -> ModSummary -> TcGblEnv -> TcM TcGblEnv
liquidHaskellCheck PipelineData
pipelineData ModSummary
modSummary TcGblEnv
tcGblEnv = do
  Config
cfg <- IO Config -> IOEnv (Env TcGblEnv TcLclEnv) Config
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Config
getConfig

  -- The 'specQuotes' contain stuff we need from imported modules, extracted
  -- from the annotations in their interface files.
  let specQuotes :: [BPspec]
      specQuotes :: [BPspec]
specQuotes = (TcGblEnv -> Module)
-> (TcGblEnv -> [Annotation]) -> TcGblEnv -> [BPspec]
forall a. (a -> Module) -> (a -> [Annotation]) -> a -> [BPspec]
LH.extractSpecQuotes' TcGblEnv -> Module
tcg_mod TcGblEnv -> [Annotation]
tcg_anns TcGblEnv
tcGblEnv

  -- Here, we are calling Liquid Haskell's parser, acting on the unparsed
  -- spec comments stored in the pipeline data, supported by the specQuotes
  -- obtained from the imported modules.
  BareSpec
inputSpec :: BareSpec <- Module -> [SpecComment] -> [BPspec] -> TcM BareSpec
getLiquidSpec Module
thisModule (PipelineData -> [SpecComment]
pdSpecComments PipelineData
pipelineData) [BPspec]
specQuotes

  String -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debugLog (String -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> String -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ String
" Input spec: \n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ BareSpec -> String
forall a. Show a => a -> String
show BareSpec
inputSpec
  String -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debugLog (String -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> String -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ String
"Relevant ===> \n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ([String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Module -> String) -> [Module] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Module -> String
renderModule ([Module] -> [String]) -> [Module] -> [String]
forall a b. (a -> b) -> a -> b
$ (Set Module -> [Module]
forall a. Set a -> [a]
S.toList (Set Module -> [Module]) -> Set Module -> [Module]
forall a b. (a -> b) -> a -> b
$ ModGuts -> Set Module
relevantModules ModGuts
modGuts))

  LogicMap
logicMap :: LogicMap <- IO LogicMap -> IOEnv (Env TcGblEnv TcLclEnv) LogicMap
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LogicMap -> IOEnv (Env TcGblEnv TcLclEnv) LogicMap)
-> IO LogicMap -> IOEnv (Env TcGblEnv TcLclEnv) LogicMap
forall a b. (a -> b) -> a -> b
$ IO LogicMap
LH.makeLogicMap

  -- debugLog $ "Logic map:\n" ++ show logicMap

  let lhContext :: LiquidHaskellContext
lhContext = LiquidHaskellContext :: Config
-> BareSpec
-> LogicMap
-> ModSummary
-> TcData
-> Unoptimised ModGuts
-> Set Module
-> LiquidHaskellContext
LiquidHaskellContext {
        lhGlobalCfg :: Config
lhGlobalCfg       = Config
cfg
      , lhInputSpec :: BareSpec
lhInputSpec       = BareSpec
inputSpec
      , lhModuleLogicMap :: LogicMap
lhModuleLogicMap  = LogicMap
logicMap
      , lhModuleSummary :: ModSummary
lhModuleSummary   = ModSummary
modSummary
      , lhModuleTcData :: TcData
lhModuleTcData    = PipelineData -> TcData
pdTcData PipelineData
pipelineData
      , lhModuleGuts :: Unoptimised ModGuts
lhModuleGuts      = PipelineData -> Unoptimised ModGuts
pdUnoptimisedCore PipelineData
pipelineData
      , lhRelevantModules :: Set Module
lhRelevantModules = ModGuts -> Set Module
relevantModules ModGuts
modGuts
      }

  ProcessModuleResult{TargetInfo
LiquidLib
pmrTargetInfo :: ProcessModuleResult -> TargetInfo
pmrClientLib :: ProcessModuleResult -> LiquidLib
pmrTargetInfo :: TargetInfo
pmrClientLib :: LiquidLib
..} <- LiquidHaskellContext -> TcM ProcessModuleResult
processModule LiquidHaskellContext
lhContext

  -- Call into the existing Liquid interface
  Output Doc
out <- IO (Output Doc) -> IOEnv (Env TcGblEnv TcLclEnv) (Output Doc)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Output Doc) -> IOEnv (Env TcGblEnv TcLclEnv) (Output Doc))
-> IO (Output Doc) -> IOEnv (Env TcGblEnv TcLclEnv) (Output Doc)
forall a b. (a -> b) -> a -> b
$ TargetInfo -> IO (Output Doc)
LH.checkTargetInfo TargetInfo
pmrTargetInfo

  -- Report the outcome of the checking
  (OutputResult -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> Config
-> [String]
-> Output Doc
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *).
MonadIO m =>
(OutputResult -> m ()) -> Config -> [String] -> Output Doc -> m ()
LH.reportResult OutputResult -> IOEnv (Env TcGblEnv TcLclEnv) ()
errorLogger Config
cfg [TargetSrc -> String
giTarget (TargetInfo -> TargetSrc
giSrc TargetInfo
pmrTargetInfo)] Output Doc
out
  case Output Doc -> ErrorResult
forall a. Output a -> ErrorResult
o_result Output Doc
out of
    Safe Stats
_stats -> () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    ErrorResult
_           -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall env a. IOEnv env a
failM

  let serialisedSpec :: Annotation
serialisedSpec = LiquidLib -> Module -> Annotation
Util.serialiseLiquidLib LiquidLib
pmrClientLib Module
thisModule
  String -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debugLog (String -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> String -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ String
"Serialised annotation ==> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (SDoc -> String
O.showSDocUnsafe (SDoc -> String) -> (Annotation -> SDoc) -> Annotation -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Annotation -> SDoc
forall a. Outputable a => a -> SDoc
O.ppr (Annotation -> String) -> Annotation -> String
forall a b. (a -> b) -> a -> b
$ Annotation
serialisedSpec)

  TcGblEnv -> TcM TcGblEnv
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TcGblEnv -> TcM TcGblEnv) -> TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ TcGblEnv
tcGblEnv { tcg_anns :: [Annotation]
tcg_anns = Annotation
serialisedSpec Annotation -> [Annotation] -> [Annotation]
forall a. a -> [a] -> [a]
: TcGblEnv -> [Annotation]
tcg_anns TcGblEnv
tcGblEnv }
  where
    thisModule :: Module
    thisModule :: Module
thisModule = TcGblEnv -> Module
tcg_mod TcGblEnv
tcGblEnv

    modGuts :: ModGuts
    modGuts :: ModGuts
modGuts = Unoptimised ModGuts -> ModGuts
forall a. Unoptimised a -> a
fromUnoptimised (Unoptimised ModGuts -> ModGuts)
-> (PipelineData -> Unoptimised ModGuts) -> PipelineData -> ModGuts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PipelineData -> Unoptimised ModGuts
pdUnoptimisedCore (PipelineData -> ModGuts) -> PipelineData -> ModGuts
forall a b. (a -> b) -> a -> b
$ PipelineData
pipelineData

    errorLogger :: OutputResult -> TcM ()
    errorLogger :: OutputResult -> IOEnv (Env TcGblEnv TcLclEnv) ()
errorLogger OutputResult
outputResult = do
      [ErrMsg]
errs <- [(SrcSpan, Doc)]
-> ((SrcSpan, Doc) -> IOEnv (Env TcGblEnv TcLclEnv) ErrMsg)
-> IOEnv (Env TcGblEnv TcLclEnv) [ErrMsg]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (OutputResult -> [(SrcSpan, Doc)]
LH.orMessages OutputResult
outputResult) (((SrcSpan, Doc) -> IOEnv (Env TcGblEnv TcLclEnv) ErrMsg)
 -> IOEnv (Env TcGblEnv TcLclEnv) [ErrMsg])
-> ((SrcSpan, Doc) -> IOEnv (Env TcGblEnv TcLclEnv) ErrMsg)
-> IOEnv (Env TcGblEnv TcLclEnv) [ErrMsg]
forall a b. (a -> b) -> a -> b
$ \(SrcSpan
spn, Doc
e) -> SrcSpan -> SDoc -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ErrMsg
mkLongErrAt SrcSpan
spn (Doc -> SDoc
LH.fromPJDoc Doc
e) SDoc
O.empty
      [ErrMsg] -> IOEnv (Env TcGblEnv TcLclEnv) ()
GHC.reportErrors [ErrMsg]
errs


--------------------------------------------------------------------------------
-- | Working with bare & lifted specs ------------------------------------------
--------------------------------------------------------------------------------

loadDependencies :: forall m. GhcMonadLike m
                 => Config
                 -- ^ The 'Config' associated to the /current/ module being compiled.
                 -> ExternalPackageState
                 -> HomePackageTable
                 -> Module
                 -> [Module]
                 -> m TargetDependencies
loadDependencies :: Config
-> ExternalPackageState
-> HomePackageTable
-> Module
-> [Module]
-> m TargetDependencies
loadDependencies Config
currentModuleConfig ExternalPackageState
eps HomePackageTable
hpt Module
thisModule [Module]
mods = do
  [SpecFinderResult]
results   <- ExternalPackageState
-> HomePackageTable -> [Module] -> m [SpecFinderResult]
forall (m :: * -> *).
GhcMonadLike m =>
ExternalPackageState
-> HomePackageTable -> [Module] -> m [SpecFinderResult]
SpecFinder.findRelevantSpecs ExternalPackageState
eps HomePackageTable
hpt [Module]
mods
  TargetDependencies
deps      <- (TargetDependencies -> SpecFinderResult -> m TargetDependencies)
-> TargetDependencies -> [SpecFinderResult] -> m TargetDependencies
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM TargetDependencies -> SpecFinderResult -> m TargetDependencies
processResult TargetDependencies
forall a. Monoid a => a
mempty ([SpecFinderResult] -> [SpecFinderResult]
forall a. [a] -> [a]
reverse [SpecFinderResult]
results)
  [StableModule]
redundant <- Config -> m [StableModule]
forall (m :: * -> *). GhcMonadLike m => Config -> m [StableModule]
configToRedundantDependencies Config
currentModuleConfig

  String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debugLog (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Redundant dependencies ==> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [StableModule] -> String
forall a. Show a => a -> String
show [StableModule]
redundant

  TargetDependencies -> m TargetDependencies
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TargetDependencies -> m TargetDependencies)
-> TargetDependencies -> m TargetDependencies
forall a b. (a -> b) -> a -> b
$ (TargetDependencies -> StableModule -> TargetDependencies)
-> TargetDependencies -> [StableModule] -> TargetDependencies
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((StableModule -> TargetDependencies -> TargetDependencies)
-> TargetDependencies -> StableModule -> TargetDependencies
forall a b c. (a -> b -> c) -> b -> a -> c
flip StableModule -> TargetDependencies -> TargetDependencies
dropDependency) TargetDependencies
deps [StableModule]
redundant
  where
    processResult :: TargetDependencies -> SpecFinderResult -> m TargetDependencies
    processResult :: TargetDependencies -> SpecFinderResult -> m TargetDependencies
processResult !TargetDependencies
acc (SpecNotFound Module
mdl) = do
      String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debugLog (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"[T:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Module -> String
renderModule Module
thisModule
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"] Spec not found for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Module -> String
renderModule Module
mdl
      TargetDependencies -> m TargetDependencies
forall (f :: * -> *) a. Applicative f => a -> f a
pure TargetDependencies
acc
    processResult TargetDependencies
_ (SpecFound Module
originalModule SearchLocation
location BareSpec
_) = do
      DynFlags
dynFlags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
      String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debugLog (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"[T:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleName -> String
forall a. Show a => a -> String
show (Module -> ModuleName
moduleName Module
thisModule)
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"] Spec found for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Module -> String
renderModule Module
originalModule String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", at location " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SearchLocation -> String
forall a. Show a => a -> String
show SearchLocation
location
      String -> m TargetDependencies
forall (m :: * -> *) a. MonadIO m => String -> m a
Util.pluginAbort (DynFlags -> SDoc -> String
O.showSDoc DynFlags
dynFlags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ String -> SDoc
O.text String
"A BareSpec was returned as a dependency, this is not allowed, in " SDoc -> SDoc -> SDoc
O.<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
O.ppr Module
thisModule)
    processResult !TargetDependencies
acc (LibFound Module
originalModule SearchLocation
location LiquidLib
lib) = do
      String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debugLog (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"[T:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleName -> String
forall a. Show a => a -> String
show (Module -> ModuleName
moduleName Module
thisModule)
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"] Lib found for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Module -> String
renderModule Module
originalModule String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", at location " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SearchLocation -> String
forall a. Show a => a -> String
show SearchLocation
location
      TargetDependencies -> m TargetDependencies
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TargetDependencies -> m TargetDependencies)
-> TargetDependencies -> m TargetDependencies
forall a b. (a -> b) -> a -> b
$ TargetDependencies :: HashMap StableModule LiftedSpec -> TargetDependencies
TargetDependencies {
          getDependencies :: HashMap StableModule LiftedSpec
getDependencies = StableModule
-> LiftedSpec
-> HashMap StableModule LiftedSpec
-> HashMap StableModule LiftedSpec
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert (Module -> StableModule
toStableModule Module
originalModule) (LiquidLib -> LiftedSpec
libTarget LiquidLib
lib) (TargetDependencies -> HashMap StableModule LiftedSpec
getDependencies (TargetDependencies -> HashMap StableModule LiftedSpec)
-> TargetDependencies -> HashMap StableModule LiftedSpec
forall a b. (a -> b) -> a -> b
$ TargetDependencies
acc TargetDependencies -> TargetDependencies -> TargetDependencies
forall a. Semigroup a => a -> a -> a
<> LiquidLib -> TargetDependencies
libDeps LiquidLib
lib)
        }

-- | The collection of dependencies and usages modules which are relevant for liquidHaskell
relevantModules :: ModGuts -> Set Module
relevantModules :: ModGuts -> Set Module
relevantModules ModGuts
modGuts = Set Module
used Set Module -> Set Module -> Set Module
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Set Module
dependencies
  where
    dependencies :: Set Module
    dependencies :: Set Module
dependencies = [Module] -> Set Module
forall a. Ord a => [a] -> Set a
S.fromList ([Module] -> Set Module) -> [Module] -> Set Module
forall a b. (a -> b) -> a -> b
$ ((ModuleName, Bool) -> Module) -> [(ModuleName, Bool)] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> Module
toModule (ModuleName -> Module)
-> ((ModuleName, Bool) -> ModuleName)
-> (ModuleName, Bool)
-> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName, Bool) -> ModuleName
forall a b. (a, b) -> a
fst) ([(ModuleName, Bool)] -> [Module])
-> (Dependencies -> [(ModuleName, Bool)])
-> Dependencies
-> [Module]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ModuleName, Bool) -> Bool)
-> [(ModuleName, Bool)] -> [(ModuleName, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((ModuleName, Bool) -> Bool) -> (ModuleName, Bool) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName, Bool) -> Bool
forall a b. (a, b) -> b
snd) ([(ModuleName, Bool)] -> [(ModuleName, Bool)])
-> (Dependencies -> [(ModuleName, Bool)])
-> Dependencies
-> [(ModuleName, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependencies -> [(ModuleName, Bool)]
dep_mods (Dependencies -> [Module]) -> Dependencies -> [Module]
forall a b. (a -> b) -> a -> b
$ Dependencies
deps

    deps :: Dependencies
    deps :: Dependencies
deps = ModGuts -> Dependencies
mg_deps ModGuts
modGuts

    thisModule :: Module
    thisModule :: Module
thisModule = ModGuts -> Module
mg_module ModGuts
modGuts

    toModule :: ModuleName -> Module
    toModule :: ModuleName -> Module
toModule = UnitId -> ModuleName -> Module
Module (Module -> UnitId
moduleUnitId Module
thisModule)

    used :: Set Module
    used :: Set Module
used = [Module] -> Set Module
forall a. Ord a => [a] -> Set a
S.fromList ([Module] -> Set Module) -> [Module] -> Set Module
forall a b. (a -> b) -> a -> b
$ ([Module] -> Usage -> [Module]) -> [Module] -> [Usage] -> [Module]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [Module] -> Usage -> [Module]
collectUsage [Module]
forall a. Monoid a => a
mempty ([Usage] -> [Module])
-> (ModGuts -> [Usage]) -> ModGuts -> [Module]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModGuts -> [Usage]
mg_usages (ModGuts -> [Module]) -> ModGuts -> [Module]
forall a b. (a -> b) -> a -> b
$ ModGuts
modGuts
      where
        collectUsage :: [Module] -> Usage -> [Module]
        collectUsage :: [Module] -> Usage -> [Module]
collectUsage [Module]
acc = \case
          UsagePackageModule     { usg_mod :: Usage -> Module
usg_mod      = Module
modl    } -> Module
modl Module -> [Module] -> [Module]
forall a. a -> [a] -> [a]
: [Module]
acc
          UsageHomeModule        { usg_mod_name :: Usage -> ModuleName
usg_mod_name = ModuleName
modName } -> ModuleName -> Module
toModule ModuleName
modName Module -> [Module] -> [Module]
forall a. a -> [a] -> [a]
: [Module]
acc
          UsageMergedRequirement { usg_mod :: Usage -> Module
usg_mod      = Module
modl    } -> Module
modl Module -> [Module] -> [Module]
forall a. a -> [a] -> [a]
: [Module]
acc
          Usage
_ -> [Module]
acc


data LiquidHaskellContext = LiquidHaskellContext {
    LiquidHaskellContext -> Config
lhGlobalCfg        :: Config
  , LiquidHaskellContext -> BareSpec
lhInputSpec        :: BareSpec
  , LiquidHaskellContext -> LogicMap
lhModuleLogicMap   :: LogicMap
  , LiquidHaskellContext -> ModSummary
lhModuleSummary    :: ModSummary
  , LiquidHaskellContext -> TcData
lhModuleTcData     :: TcData
  , LiquidHaskellContext -> Unoptimised ModGuts
lhModuleGuts       :: Unoptimised ModGuts
  , LiquidHaskellContext -> Set Module
lhRelevantModules  :: Set Module
  }

--------------------------------------------------------------------------------
-- | Per-Module Pipeline -------------------------------------------------------
--------------------------------------------------------------------------------

data ProcessModuleResult = ProcessModuleResult {
    ProcessModuleResult -> LiquidLib
pmrClientLib  :: LiquidLib
  -- ^ The \"client library\" we will serialise on disk into an interface's 'Annotation'.
  , ProcessModuleResult -> TargetInfo
pmrTargetInfo :: TargetInfo
  -- ^ The 'GhcInfo' for the current 'Module' that LiquidHaskell will process.
  }

-- | Parse the spec comments from one module, supported by the
-- spec quotes from the imported module. Also looks for
-- "companion specs" for the current module and merges them in
-- if it finds one.
getLiquidSpec :: Module -> [SpecComment] -> [BPspec] -> TcM BareSpec
getLiquidSpec :: Module -> [SpecComment] -> [BPspec] -> TcM BareSpec
getLiquidSpec Module
thisModule [SpecComment]
specComments [BPspec]
specQuotes = do

  let commSpecE :: Either [Error] (ModName, Spec LocBareType LocSymbol)
      commSpecE :: Either [Error] (ModName, Spec LocBareType LocSymbol)
commSpecE = ModuleName
-> [(SourcePos, String)]
-> [BPspec]
-> Either [Error] (ModName, Spec LocBareType LocSymbol)
hsSpecificationP (Module -> ModuleName
moduleName Module
thisModule) ([SpecComment] -> [(SourcePos, String)]
coerce [SpecComment]
specComments) [BPspec]
specQuotes
  case Either [Error] (ModName, Spec LocBareType LocSymbol)
commSpecE of
    Left [Error]
errors -> do
      Tidy -> [Error] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall e.
(Show e, PPrint e) =>
Tidy -> [TError e] -> IOEnv (Env TcGblEnv TcLclEnv) ()
LH.reportErrors Tidy
Full [Error]
errors
      TcM BareSpec
forall env a. IOEnv env a
failM
    Right (Optic' An_Iso NoIx (Spec LocBareType LocSymbol) BareSpec
-> Spec LocBareType LocSymbol -> BareSpec
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' An_Iso NoIx (Spec LocBareType LocSymbol) BareSpec
bareSpecIso (Spec LocBareType LocSymbol -> BareSpec)
-> ((ModName, Spec LocBareType LocSymbol)
    -> Spec LocBareType LocSymbol)
-> (ModName, Spec LocBareType LocSymbol)
-> BareSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModName, Spec LocBareType LocSymbol) -> Spec LocBareType LocSymbol
forall a b. (a, b) -> b
snd -> BareSpec
commSpec) -> do
      SpecFinderResult
res <- Module -> IOEnv (Env TcGblEnv TcLclEnv) SpecFinderResult
forall (m :: * -> *).
GhcMonadLike m =>
Module -> m SpecFinderResult
SpecFinder.findCompanionSpec Module
thisModule
      case SpecFinderResult
res of
        SpecFound Module
_ SearchLocation
_ BareSpec
companionSpec -> do
          String -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debugLog (String -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> String -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ String
"Companion spec found for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Module -> String
renderModule Module
thisModule
          BareSpec -> TcM BareSpec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BareSpec -> TcM BareSpec) -> BareSpec -> TcM BareSpec
forall a b. (a -> b) -> a -> b
$ BareSpec
commSpec BareSpec -> BareSpec -> BareSpec
forall a. Semigroup a => a -> a -> a
<> BareSpec
companionSpec
        SpecFinderResult
_ -> BareSpec -> TcM BareSpec
forall (f :: * -> *) a. Applicative f => a -> f a
pure BareSpec
commSpec

processModule :: LiquidHaskellContext -> TcM ProcessModuleResult
processModule :: LiquidHaskellContext -> TcM ProcessModuleResult
processModule LiquidHaskellContext{Set Module
ModSummary
Config
LogicMap
BareSpec
TcData
Unoptimised ModGuts
lhRelevantModules :: Set Module
lhModuleGuts :: Unoptimised ModGuts
lhModuleTcData :: TcData
lhModuleSummary :: ModSummary
lhModuleLogicMap :: LogicMap
lhInputSpec :: BareSpec
lhGlobalCfg :: Config
lhRelevantModules :: LiquidHaskellContext -> Set Module
lhModuleGuts :: LiquidHaskellContext -> Unoptimised ModGuts
lhModuleTcData :: LiquidHaskellContext -> TcData
lhModuleSummary :: LiquidHaskellContext -> ModSummary
lhModuleLogicMap :: LiquidHaskellContext -> LogicMap
lhInputSpec :: LiquidHaskellContext -> BareSpec
lhGlobalCfg :: LiquidHaskellContext -> Config
..} = do
  String -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debugLog (String
"Module ==> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Module -> String
renderModule Module
thisModule)
  HscEnv
hscEnv              <- IOEnv (Env TcGblEnv TcLclEnv) HscEnv
forall (m :: * -> *). HasHscEnv m => m HscEnv
askHscEnv

  let bareSpec :: BareSpec
bareSpec        = BareSpec
lhInputSpec
  -- /NOTE/: For the Plugin to work correctly, we shouldn't call 'canonicalizePath', because otherwise
  -- this won't trigger the \"external name resolution\" as part of 'Language.Haskell.Liquid.Bare.Resolve'
  -- (cfr. 'allowExtResolution').
  let file :: String
file            = ModSummary -> String
LH.modSummaryHsFile ModSummary
lhModuleSummary

  ()
_                   <- [Located String] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *). GhcMonadLike m => [Located String] -> m ()
LH.checkFilePragmas ([Located String] -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [Located String] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ Spec LocBareType LocSymbol -> [Located String]
forall ty bndr. Spec ty bndr -> [Located String]
Ms.pragmas (Optic' An_Iso NoIx (Spec LocBareType LocSymbol) BareSpec
-> BareSpec -> Spec LocBareType LocSymbol
forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review Optic' An_Iso NoIx (Spec LocBareType LocSymbol) BareSpec
bareSpecIso BareSpec
bareSpec)

  Config
moduleCfg           <- IO Config -> IOEnv (Env TcGblEnv TcLclEnv) Config
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Config -> IOEnv (Env TcGblEnv TcLclEnv) Config)
-> IO Config -> IOEnv (Env TcGblEnv TcLclEnv) Config
forall a b. (a -> b) -> a -> b
$ Config -> String -> [Located String] -> IO Config
withPragmas Config
lhGlobalCfg String
file (Spec LocBareType LocSymbol -> [Located String]
forall ty bndr. Spec ty bndr -> [Located String]
Ms.pragmas (Spec LocBareType LocSymbol -> [Located String])
-> Spec LocBareType LocSymbol -> [Located String]
forall a b. (a -> b) -> a -> b
$ Optic' An_Iso NoIx (Spec LocBareType LocSymbol) BareSpec
-> BareSpec -> Spec LocBareType LocSymbol
forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review Optic' An_Iso NoIx (Spec LocBareType LocSymbol) BareSpec
bareSpecIso BareSpec
bareSpec)
  ExternalPackageState
eps                 <- IO ExternalPackageState
-> IOEnv (Env TcGblEnv TcLclEnv) ExternalPackageState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExternalPackageState
 -> IOEnv (Env TcGblEnv TcLclEnv) ExternalPackageState)
-> IO ExternalPackageState
-> IOEnv (Env TcGblEnv TcLclEnv) ExternalPackageState
forall a b. (a -> b) -> a -> b
$ IORef ExternalPackageState -> IO ExternalPackageState
forall a. IORef a -> IO a
readIORef (HscEnv -> IORef ExternalPackageState
hsc_EPS HscEnv
hscEnv)

  TargetDependencies
dependencies       <- Config
-> ExternalPackageState
-> HomePackageTable
-> Module
-> [Module]
-> IOEnv (Env TcGblEnv TcLclEnv) TargetDependencies
forall (m :: * -> *).
GhcMonadLike m =>
Config
-> ExternalPackageState
-> HomePackageTable
-> Module
-> [Module]
-> m TargetDependencies
loadDependencies Config
moduleCfg
                                         ExternalPackageState
eps
                                         (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hscEnv)
                                         Module
thisModule
                                         (Set Module -> [Module]
forall a. Set a -> [a]
S.toList Set Module
lhRelevantModules)

  String -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debugLog (String -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> String -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ String
"Found " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (HashMap StableModule LiftedSpec -> Int
forall k v. HashMap k v -> Int
HM.size (HashMap StableModule LiftedSpec -> Int)
-> HashMap StableModule LiftedSpec -> Int
forall a b. (a -> b) -> a -> b
$ TargetDependencies -> HashMap StableModule LiftedSpec
getDependencies TargetDependencies
dependencies) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" dependencies:"
  Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugLogs (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
    [StableModule]
-> (StableModule -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (HashMap StableModule LiftedSpec -> [StableModule]
forall k v. HashMap k v -> [k]
HM.keys (HashMap StableModule LiftedSpec -> [StableModule])
-> (TargetDependencies -> HashMap StableModule LiftedSpec)
-> TargetDependencies
-> [StableModule]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TargetDependencies -> HashMap StableModule LiftedSpec
getDependencies (TargetDependencies -> [StableModule])
-> TargetDependencies -> [StableModule]
forall a b. (a -> b) -> a -> b
$ TargetDependencies
dependencies) ((StableModule -> IOEnv (Env TcGblEnv TcLclEnv) ())
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> (StableModule -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ String -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debugLog (String -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> (StableModule -> String)
-> StableModule
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> String
moduleStableString (Module -> String)
-> (StableModule -> Module) -> StableModule -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StableModule -> Module
unStableModule

  String -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debugLog (String -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> String -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ String
"mg_exports => " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (SDoc -> String
O.showSDocUnsafe (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ [AvailInfo] -> SDoc
forall a. Outputable a => a -> SDoc
O.ppr ([AvailInfo] -> SDoc) -> [AvailInfo] -> SDoc
forall a b. (a -> b) -> a -> b
$ ModGuts -> [AvailInfo]
mg_exports ModGuts
modGuts)
  String -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debugLog (String -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> String -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ String
"mg_tcs => " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (SDoc -> String
O.showSDocUnsafe (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ [TyCon] -> SDoc
forall a. Outputable a => a -> SDoc
O.ppr ([TyCon] -> SDoc) -> [TyCon] -> SDoc
forall a b. (a -> b) -> a -> b
$ ModGuts -> [TyCon]
mg_tcs ModGuts
modGuts)

  TargetSrc
targetSrc  <- Config
-> String
-> TcData
-> ModGuts
-> HscEnv
-> IOEnv (Env TcGblEnv TcLclEnv) TargetSrc
forall (m :: * -> *).
GhcMonadLike m =>
Config -> String -> TcData -> ModGuts -> HscEnv -> m TargetSrc
makeTargetSrc Config
moduleCfg String
file TcData
lhModuleTcData ModGuts
modGuts HscEnv
hscEnv
  DynFlags
dynFlags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

  -- See https://github.com/ucsd-progsys/liquidhaskell/issues/1711
  -- Due to the fact the internals can throw exceptions from pure code at any point, we need to
  -- call 'evaluate' to force any exception and catch it, if we can.

  Either Diagnostics ([Warning], TargetSpec, LiftedSpec)
result <-
    (IO (Either Diagnostics ([Warning], TargetSpec, LiftedSpec))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Either Diagnostics ([Warning], TargetSpec, LiftedSpec))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Diagnostics ([Warning], TargetSpec, LiftedSpec))
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (Either Diagnostics ([Warning], TargetSpec, LiftedSpec)))
-> IO (Either Diagnostics ([Warning], TargetSpec, LiftedSpec))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Either Diagnostics ([Warning], TargetSpec, LiftedSpec))
forall a b. (a -> b) -> a -> b
$ Either Diagnostics ([Warning], TargetSpec, LiftedSpec)
-> IO (Either Diagnostics ([Warning], TargetSpec, LiftedSpec))
forall a. a -> IO a
evaluate (Config
-> LogicMap
-> TargetSrc
-> BareSpec
-> TargetDependencies
-> Either Diagnostics ([Warning], TargetSpec, LiftedSpec)
makeTargetSpec Config
moduleCfg LogicMap
lhModuleLogicMap TargetSrc
targetSrc BareSpec
bareSpec TargetDependencies
dependencies))
      IOEnv
  (Env TcGblEnv TcLclEnv)
  (Either Diagnostics ([Warning], TargetSpec, LiftedSpec))
-> (UserError
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         (Either Diagnostics ([Warning], TargetSpec, LiftedSpec)))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Either Diagnostics ([Warning], TargetSpec, LiftedSpec))
forall (m :: * -> *) e a.
(ExceptionMonad m, Exception e) =>
m a -> (e -> m a) -> m a
`gcatch` (\(UserError
e :: UserError) -> Tidy -> [UserError] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall e.
(Show e, PPrint e) =>
Tidy -> [TError e] -> IOEnv (Env TcGblEnv TcLclEnv) ()
LH.reportErrors Tidy
Full [UserError
e] IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Either Diagnostics ([Warning], TargetSpec, LiftedSpec))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Either Diagnostics ([Warning], TargetSpec, LiftedSpec))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IOEnv
  (Env TcGblEnv TcLclEnv)
  (Either Diagnostics ([Warning], TargetSpec, LiftedSpec))
forall env a. IOEnv env a
failM)
      IOEnv
  (Env TcGblEnv TcLclEnv)
  (Either Diagnostics ([Warning], TargetSpec, LiftedSpec))
-> (Error
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         (Either Diagnostics ([Warning], TargetSpec, LiftedSpec)))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Either Diagnostics ([Warning], TargetSpec, LiftedSpec))
forall (m :: * -> *) e a.
(ExceptionMonad m, Exception e) =>
m a -> (e -> m a) -> m a
`gcatch` (\(Error
e :: Error)     -> Tidy -> [Error] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall e.
(Show e, PPrint e) =>
Tidy -> [TError e] -> IOEnv (Env TcGblEnv TcLclEnv) ()
LH.reportErrors Tidy
Full [Error
e] IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Either Diagnostics ([Warning], TargetSpec, LiftedSpec))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Either Diagnostics ([Warning], TargetSpec, LiftedSpec))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IOEnv
  (Env TcGblEnv TcLclEnv)
  (Either Diagnostics ([Warning], TargetSpec, LiftedSpec))
forall env a. IOEnv env a
failM)

  case Either Diagnostics ([Warning], TargetSpec, LiftedSpec)
result of
    -- Print warnings and errors, aborting the compilation.
    Left Diagnostics
diagnostics -> do
      IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ (Warning -> IO ()) -> [Warning] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DynFlags -> Warning -> IO ()
printWarning DynFlags
dynFlags)    (Diagnostics -> [Warning]
allWarnings Diagnostics
diagnostics)
      Tidy -> [Error] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall e.
(Show e, PPrint e) =>
Tidy -> [TError e] -> IOEnv (Env TcGblEnv TcLclEnv) ()
LH.reportErrors Tidy
Full (Diagnostics -> [Error]
allErrors Diagnostics
diagnostics)
      TcM ProcessModuleResult
forall env a. IOEnv env a
failM

    Right ([Warning]
warnings, TargetSpec
targetSpec, LiftedSpec
liftedSpec) -> do
      IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ (Warning -> IO ()) -> [Warning] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DynFlags -> Warning -> IO ()
printWarning DynFlags
dynFlags) [Warning]
warnings
      let targetInfo :: TargetInfo
targetInfo = TargetSrc -> TargetSpec -> TargetInfo
TargetInfo TargetSrc
targetSrc TargetSpec
targetSpec

      String -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debugLog (String -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> String -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ String
"bareSpec ==> "   String -> String -> String
forall a. [a] -> [a] -> [a]
++ BareSpec -> String
forall a. Show a => a -> String
show BareSpec
bareSpec
      String -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *). MonadIO m => String -> m ()
debugLog (String -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> String -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ String
"liftedSpec ==> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LiftedSpec -> String
forall a. Show a => a -> String
show LiftedSpec
liftedSpec

      let clientLib :: LiquidLib
clientLib  = LiftedSpec -> LiquidLib
mkLiquidLib LiftedSpec
liftedSpec LiquidLib -> (LiquidLib -> LiquidLib) -> LiquidLib
forall a b. a -> (a -> b) -> b
& TargetDependencies -> LiquidLib -> LiquidLib
addLibDependencies TargetDependencies
dependencies

      let result :: ProcessModuleResult
result = ProcessModuleResult :: LiquidLib -> TargetInfo -> ProcessModuleResult
ProcessModuleResult {
            pmrClientLib :: LiquidLib
pmrClientLib  = LiquidLib
clientLib
          , pmrTargetInfo :: TargetInfo
pmrTargetInfo = TargetInfo
targetInfo
          }

      ProcessModuleResult -> TcM ProcessModuleResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcessModuleResult
result

  where
    modGuts :: ModGuts
modGuts    = Unoptimised ModGuts -> ModGuts
forall a. Unoptimised a -> a
fromUnoptimised Unoptimised ModGuts
lhModuleGuts
    thisModule :: Module
thisModule = ModGuts -> Module
mg_module ModGuts
modGuts

---------------------------------------------------------------------------------------
-- | @makeGhcSrc@ builds all the source-related information needed for consgen
---------------------------------------------------------------------------------------

makeTargetSrc :: GhcMonadLike m
              => Config
              -> FilePath
              -> TcData
              -> ModGuts
              -> HscEnv
              -> m TargetSrc
makeTargetSrc :: Config -> String -> TcData -> ModGuts -> HscEnv -> m TargetSrc
makeTargetSrc Config
cfg String
file TcData
tcData ModGuts
modGuts HscEnv
hscEnv = do
  [CoreBind]
coreBinds      <- IO [CoreBind] -> m [CoreBind]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [CoreBind] -> m [CoreBind]) -> IO [CoreBind] -> m [CoreBind]
forall a b. (a -> b) -> a -> b
$ Config -> HscEnv -> ModGuts -> IO [CoreBind]
anormalize Config
cfg HscEnv
hscEnv ModGuts
modGuts

  -- The type constructors for a module are the (nubbed) union of the ones defined and
  -- the ones exported. This covers the case of \"wrapper modules\" that simply re-exports
  -- everything from the imported modules.
  let availTcs :: [TyCon]
availTcs    = TcData -> [TyCon]
tcAvailableTyCons TcData
tcData
  let allTcs :: [TyCon]
allTcs      = [TyCon] -> [TyCon]
forall a. Eq a => [a] -> [a]
L.nub ([TyCon] -> [TyCon]) -> [TyCon] -> [TyCon]
forall a b. (a -> b) -> a -> b
$ (MGIModGuts -> [TyCon]
mgi_tcs MGIModGuts
mgiModGuts [TyCon] -> [TyCon] -> [TyCon]
forall a. [a] -> [a] -> [a]
++ [TyCon]
availTcs)

  let dataCons :: [Var]
dataCons       = (TyCon -> [Var]) -> [TyCon] -> [Var]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((DataCon -> Var) -> [DataCon] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Var
dataConWorkId ([DataCon] -> [Var]) -> (TyCon -> [DataCon]) -> TyCon -> [Var]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> [DataCon]
tyConDataCons) [TyCon]
allTcs
  let ([TyCon]
fiTcs, [(Symbol, DataCon)]
fiDcs) = [FamInst] -> ([TyCon], [(Symbol, DataCon)])
LH.makeFamInstEnv (ModGuts -> [FamInst]
getFamInstances ModGuts
modGuts)
  let things :: [(Name, Maybe TyThing)]
things         = TcData -> [(Name, Maybe TyThing)]
tcResolvedNames TcData
tcData
  let impVars :: [Var]
impVars        = [CoreBind] -> [Var]
LH.importVars [CoreBind]
coreBinds [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ Maybe [ClsInst] -> [Var]
LH.classCons (MGIModGuts -> Maybe [ClsInst]
mgi_cls_inst MGIModGuts
mgiModGuts)

  String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debugLog (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"_gsTcs   => " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [TyCon] -> String
forall a. Show a => a -> String
show [TyCon]
allTcs
  String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debugLog (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"_gsFiTcs => " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [TyCon] -> String
forall a. Show a => a -> String
show [TyCon]
fiTcs
  String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debugLog (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"_gsFiDcs => " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(Symbol, DataCon)] -> String
forall a. Show a => a -> String
show [(Symbol, DataCon)]
fiDcs
  String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debugLog (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"dataCons => " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Var] -> String
forall a. Show a => a -> String
show [Var]
dataCons
  String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debugLog (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"defVars  => " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Var] -> String
forall a. Show a => a -> String
show ([Var] -> [Var]
forall a. Eq a => [a] -> [a]
L.nub ([Var] -> [Var]) -> [Var] -> [Var]
forall a b. (a -> b) -> a -> b
$ [Var]
dataCons [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ ([CoreBind] -> [Var]
forall a. CBVisitable a => a -> [Var]
letVars [CoreBind]
coreBinds) [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ TcData -> [Var]
tcAvailableVars TcData
tcData)

  TargetSrc -> m TargetSrc
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetSrc -> m TargetSrc) -> TargetSrc -> m TargetSrc
forall a b. (a -> b) -> a -> b
$ TargetSrc :: String
-> String
-> ModName
-> [CoreBind]
-> [TyCon]
-> Maybe [ClsInst]
-> HashSet Var
-> [Var]
-> [Var]
-> [Var]
-> HashSet StableName
-> [TyCon]
-> [(Symbol, DataCon)]
-> [TyCon]
-> QImports
-> HashSet Symbol
-> [TyThing]
-> TargetSrc
TargetSrc
    { giIncDir :: String
giIncDir    = String
forall a. Monoid a => a
mempty
    , giTarget :: String
giTarget    = String
file
    , giTargetMod :: ModName
giTargetMod = ModType -> ModuleName -> ModName
ModName ModType
Target (Module -> ModuleName
moduleName (ModGuts -> Module
mg_module ModGuts
modGuts))
    , giCbs :: [CoreBind]
giCbs       = [CoreBind]
coreBinds
    , giImpVars :: [Var]
giImpVars   = [Var]
impVars
    , giDefVars :: [Var]
giDefVars   = [Var] -> [Var]
forall a. Eq a => [a] -> [a]
L.nub ([Var] -> [Var]) -> [Var] -> [Var]
forall a b. (a -> b) -> a -> b
$ [Var]
dataCons [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ ([CoreBind] -> [Var]
forall a. CBVisitable a => a -> [Var]
letVars [CoreBind]
coreBinds) [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ TcData -> [Var]
tcAvailableVars TcData
tcData
    , giUseVars :: [Var]
giUseVars   = [CoreBind] -> [Var]
forall a. CBVisitable a => a -> [Var]
readVars [CoreBind]
coreBinds
    , giDerVars :: HashSet Var
giDerVars   = [Var] -> HashSet Var
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList (Config -> MGIModGuts -> [Var]
LH.derivedVars Config
cfg MGIModGuts
mgiModGuts)
    , gsExports :: HashSet StableName
gsExports   = MGIModGuts -> HashSet StableName
mgi_exports  MGIModGuts
mgiModGuts
    , gsTcs :: [TyCon]
gsTcs       = [TyCon]
allTcs
    , gsCls :: Maybe [ClsInst]
gsCls       = MGIModGuts -> Maybe [ClsInst]
mgi_cls_inst MGIModGuts
mgiModGuts
    , gsFiTcs :: [TyCon]
gsFiTcs     = [TyCon]
fiTcs
    , gsFiDcs :: [(Symbol, DataCon)]
gsFiDcs     = [(Symbol, DataCon)]
fiDcs
    , gsPrimTcs :: [TyCon]
gsPrimTcs   = [TyCon]
TysPrim.primTyCons
    , gsQualImps :: QImports
gsQualImps  = TcData -> QImports
tcQualifiedImports TcData
tcData
    , gsAllImps :: HashSet Symbol
gsAllImps   = TcData -> HashSet Symbol
tcAllImports       TcData
tcData
    , gsTyThings :: [TyThing]
gsTyThings  = [ TyThing
t | (Name
_, Just TyThing
t) <- [(Name, Maybe TyThing)]
things ]
    }
  where
    mgiModGuts :: MGIModGuts
    mgiModGuts :: MGIModGuts
mgiModGuts = Maybe [ClsInst] -> ModGuts -> MGIModGuts
miModGuts Maybe [ClsInst]
deriv ModGuts
modGuts
      where
        deriv :: Maybe [ClsInst]
deriv   = [ClsInst] -> Maybe [ClsInst]
forall a. a -> Maybe a
Just ([ClsInst] -> Maybe [ClsInst]) -> [ClsInst] -> Maybe [ClsInst]
forall a b. (a -> b) -> a -> b
$ InstEnv -> [ClsInst]
instEnvElts (InstEnv -> [ClsInst]) -> InstEnv -> [ClsInst]
forall a b. (a -> b) -> a -> b
$ ModGuts -> InstEnv
mg_inst_env ModGuts
modGuts

getFamInstances :: ModGuts -> [FamInst]
getFamInstances :: ModGuts -> [FamInst]
getFamInstances ModGuts
guts = FamInstEnv -> [FamInst]
famInstEnvElts (ModGuts -> FamInstEnv
mg_fam_inst_env ModGuts
guts)