{-# LANGUAGE NoMonomorphismRestriction  #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE TypeSynonymInstances       #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE PartialTypeSignatures      #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE ViewPatterns               #-}

{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -Wwarn=deprecations #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

module Language.Haskell.Liquid.GHC.Interface (

  -- * Printer
    pprintCBs

  -- * predicates
  -- , isExportedVar
  -- , exportedVars

  -- * Internal exports (provisional)
  , extractSpecComments
  , extractSpecQuotes'
  , makeLogicMap
  , classCons
  , derivedVars
  , importVars
  , allImports
  , qualifiedImports
  , modSummaryHsFile
  , makeFamInstEnv
  , parseSpecFile
  , clearSpec
  , checkFilePragmas
  , keepRawTokenStream
  , ignoreInline
  , lookupTyThings
  , availableTyCons
  , availableVars
  , updLiftedSpec
  ) where

import Prelude hiding (error)

import           Liquid.GHC.API as Ghc hiding ( text
                                                               , (<+>)
                                                               , panic
                                                               , vcat
                                                               , showPpr
                                                               , mkStableModule
                                                               , Located
                                                               )
import qualified Liquid.GHC.API as Ghc

import Control.Exception
import Control.Monad
import Control.Monad.Trans.Maybe

import Data.Data
import Data.List hiding (intersperse)
import Data.Maybe

import Data.Generics.Aliases (mkT)
import Data.Generics.Schemes (everywhere)

import qualified Data.HashSet        as S

import System.IO
import Text.Megaparsec.Error
import Text.PrettyPrint.HughesPJ        hiding (first, (<>))
import Language.Fixpoint.Types          hiding (err, panic, Error, Result, Expr)
import qualified Language.Fixpoint.Misc as Misc
import Language.Haskell.Liquid.GHC.Misc
import Language.Haskell.Liquid.GHC.Types (MGIModGuts(..))
import Language.Haskell.Liquid.GHC.Play
import Language.Haskell.Liquid.WiredIn (isDerivedInstance)
import qualified Language.Haskell.Liquid.Measure  as Ms
import qualified Language.Haskell.Liquid.Misc     as Misc
import Language.Haskell.Liquid.Parse
import Language.Haskell.Liquid.Types hiding (Spec)
-- import Language.Haskell.Liquid.Types.PrettyPrint
-- import Language.Haskell.Liquid.Types.Visitors
import Language.Haskell.Liquid.UX.QuasiQuoter
import Language.Haskell.Liquid.UX.Tidy

import qualified Debug.Trace as Debug


--------------------------------------------------------------------------------
-- | Extract Ids ---------------------------------------------------------------
--------------------------------------------------------------------------------

classCons :: Maybe [ClsInst] -> [Id]
classCons :: Maybe [ClsInst] -> [Var]
classCons Maybe [ClsInst]
Nothing   = []
classCons (Just [ClsInst]
cs) = (ClsInst -> [Var]) -> [ClsInst] -> [Var]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (DataCon -> [Var]
dataConImplicitIds (DataCon -> [Var]) -> (ClsInst -> DataCon) -> ClsInst -> [Var]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DataCon] -> DataCon
forall a. HasCallStack => [a] -> a
head ([DataCon] -> DataCon)
-> (ClsInst -> [DataCon]) -> ClsInst -> DataCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> [DataCon]
tyConDataCons (TyCon -> [DataCon]) -> (ClsInst -> TyCon) -> ClsInst -> [DataCon]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> TyCon
classTyCon (Class -> TyCon) -> (ClsInst -> Class) -> ClsInst -> TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClsInst -> Class
is_cls) [ClsInst]
cs

derivedVars :: Config -> MGIModGuts -> [Var]
derivedVars :: Config -> MGIModGuts -> [Var]
derivedVars Config
cfg MGIModGuts
mg  = (ClsInst -> [Var]) -> [ClsInst] -> [Var]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([CoreBind] -> Var -> [Var]
dFunIdVars [CoreBind]
cbs (Var -> [Var]) -> (ClsInst -> Var) -> ClsInst -> [Var]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClsInst -> Var
is_dfun) [ClsInst]
derInsts
  where
    derInsts :: [ClsInst]
derInsts
      | Bool
checkDer    = [ClsInst]
insts
      | Bool
otherwise   = (ClsInst -> Bool) -> [ClsInst] -> [ClsInst]
forall a. (a -> Bool) -> [a] -> [a]
filter ClsInst -> Bool
isDerivedInstance [ClsInst]
insts
    insts :: [ClsInst]
insts           = MGIModGuts -> [ClsInst]
mgClsInstances MGIModGuts
mg
    checkDer :: Bool
checkDer        = Config -> Bool
checkDerived Config
cfg
    cbs :: [CoreBind]
cbs             = MGIModGuts -> [CoreBind]
mgi_binds MGIModGuts
mg


mgClsInstances :: MGIModGuts -> [ClsInst]
mgClsInstances :: MGIModGuts -> [ClsInst]
mgClsInstances = [ClsInst] -> Maybe [ClsInst] -> [ClsInst]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [ClsInst] -> [ClsInst])
-> (MGIModGuts -> Maybe [ClsInst]) -> MGIModGuts -> [ClsInst]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MGIModGuts -> Maybe [ClsInst]
mgi_cls_inst

dFunIdVars :: CoreProgram -> DFunId -> [Id]
dFunIdVars :: [CoreBind] -> Var -> [Var]
dFunIdVars [CoreBind]
cbs Var
fd  = String -> [Var] -> [Var]
forall a. PPrint a => String -> a -> a
notracepp String
msg ([Var] -> [Var]) -> [Var] -> [Var]
forall a b. (a -> b) -> a -> b
$ (CoreBind -> [Var]) -> [CoreBind] -> [Var]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CoreBind -> [Var]
forall b. Bind b -> [b]
bindersOf [CoreBind]
cbs' [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ [Var]
deps
  where
    msg :: String
msg            = String
"DERIVED-VARS-OF: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Var -> String
forall a. PPrint a => a -> String
showpp Var
fd
    cbs' :: [CoreBind]
cbs'           = (CoreBind -> Bool) -> [CoreBind] -> [CoreBind]
forall a. (a -> Bool) -> [a] -> [a]
filter CoreBind -> Bool
f [CoreBind]
cbs
    f :: CoreBind -> Bool
f (NonRec Var
x CoreExpr
_) = Var -> Bool
eqFd Var
x
    f (Rec [(Var, CoreExpr)]
xes)    = (Var -> Bool) -> [Var] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Var -> Bool
eqFd ((Var, CoreExpr) -> Var
forall a b. (a, b) -> a
fst ((Var, CoreExpr) -> Var) -> [(Var, CoreExpr)] -> [Var]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Var, CoreExpr)]
xes)
    eqFd :: Var -> Bool
eqFd Var
x         = Var -> Name
varName Var
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Var -> Name
varName Var
fd
    deps :: [Var]
deps           = (Unfolding -> [Var]) -> [Unfolding] -> [Var]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Unfolding -> [Var]
unfoldDep [Unfolding]
unfolds
    unfolds :: [Unfolding]
unfolds        = IdInfo -> Unfolding
realUnfoldingInfo (IdInfo -> Unfolding) -> (Var -> IdInfo) -> Var -> Unfolding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() :: Constraint) => Var -> IdInfo
Var -> IdInfo
idInfo (Var -> Unfolding) -> [Var] -> [Unfolding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CoreBind -> [Var]) -> [CoreBind] -> [Var]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CoreBind -> [Var]
forall b. Bind b -> [b]
bindersOf [CoreBind]
cbs'

unfoldDep :: Unfolding -> [Id]
unfoldDep :: Unfolding -> [Var]
unfoldDep (DFunUnfolding [Var]
_ DataCon
_ [CoreExpr]
e)       = (CoreExpr -> [Var]) -> [CoreExpr] -> [Var]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CoreExpr -> [Var]
exprDep [CoreExpr]
e
unfoldDep CoreUnfolding {uf_tmpl :: Unfolding -> CoreExpr
uf_tmpl = CoreExpr
e} = CoreExpr -> [Var]
exprDep CoreExpr
e
unfoldDep Unfolding
_                           = []

exprDep :: CoreExpr -> [Id]
exprDep :: CoreExpr -> [Var]
exprDep = HashSet Var -> CoreExpr -> [Var]
forall a. CBVisitable a => HashSet Var -> a -> [Var]
freeVars HashSet Var
forall a. HashSet a
S.empty

importVars :: CoreProgram -> [Id]
importVars :: [CoreBind] -> [Var]
importVars = HashSet Var -> [CoreBind] -> [Var]
forall a. CBVisitable a => HashSet Var -> a -> [Var]
freeVars HashSet Var
forall a. HashSet a
S.empty

_definedVars :: CoreProgram -> [Id]
_definedVars :: [CoreBind] -> [Var]
_definedVars = (CoreBind -> [Var]) -> [CoreBind] -> [Var]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CoreBind -> [Var]
forall b. Bind b -> [b]
defs
  where
    defs :: Bind a -> [a]
defs (NonRec a
x Expr a
_) = [a
x]
    defs (Rec [(a, Expr a)]
xes)    = ((a, Expr a) -> a) -> [(a, Expr a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, Expr a) -> a
forall a b. (a, b) -> a
fst [(a, Expr a)]
xes

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

updLiftedSpec :: Ms.BareSpec -> Maybe Ms.BareSpec -> Ms.BareSpec
updLiftedSpec :: BareSpec -> Maybe BareSpec -> BareSpec
updLiftedSpec BareSpec
s1 Maybe BareSpec
Nothing   = BareSpec
s1
updLiftedSpec BareSpec
s1 (Just BareSpec
s2) = BareSpec -> BareSpec
clearSpec BareSpec
s1 BareSpec -> BareSpec -> BareSpec
forall a. Monoid a => a -> a -> a
`mappend` BareSpec
s2

clearSpec :: Ms.BareSpec -> Ms.BareSpec
clearSpec :: BareSpec -> BareSpec
clearSpec BareSpec
s = BareSpec
s { sigs = [], asmSigs = [], aliases = [], ealiases = [], qualifiers = [], dataDecls = [] }

keepRawTokenStream :: ModSummary -> ModSummary
keepRawTokenStream :: ModSummary -> ModSummary
keepRawTokenStream ModSummary
modSummary = ModSummary
modSummary
  { ms_hspp_opts = ms_hspp_opts modSummary `gopt_set` Opt_KeepRawTokenStream }

_impThings :: [Var] -> [TyThing] -> [TyThing]
_impThings :: [Var] -> [TyThing] -> [TyThing]
_impThings [Var]
vars  = (TyThing -> Bool) -> [TyThing] -> [TyThing]
forall a. (a -> Bool) -> [a] -> [a]
filter TyThing -> Bool
ok
  where
    vs :: HashSet Var
vs          = [Var] -> HashSet Var
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList [Var]
vars
    ok :: TyThing -> Bool
ok (AnId Var
x) = Var -> HashSet Var -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member Var
x HashSet Var
vs
    ok TyThing
_        = Bool
True

allImports :: [LImportDecl GhcRn] -> S.HashSet Symbol
allImports :: [LImportDecl GhcRn] -> HashSet Symbol
allImports = \case
  []-> String -> HashSet Symbol -> HashSet Symbol
forall a. String -> a -> a
Debug.trace String
"WARNING: Missing RenamedSource" HashSet Symbol
forall a. Monoid a => a
mempty
  [LImportDecl GhcRn]
imps -> [Symbol] -> HashSet Symbol
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList (ModuleName -> Symbol
forall a. Symbolic a => a -> Symbol
symbol (ModuleName -> Symbol)
-> (GenLocated SrcSpanAnnA (ImportDecl GhcRn) -> ModuleName)
-> GenLocated SrcSpanAnnA (ImportDecl GhcRn)
-> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA ModuleName -> ModuleName)
-> (GenLocated SrcSpanAnnA (ImportDecl GhcRn)
    -> GenLocated SrcSpanAnnA ModuleName)
-> GenLocated SrcSpanAnnA (ImportDecl GhcRn)
-> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcRn -> XRec GhcRn ModuleName
ImportDecl GhcRn -> GenLocated SrcSpanAnnA ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName (ImportDecl GhcRn -> GenLocated SrcSpanAnnA ModuleName)
-> (GenLocated SrcSpanAnnA (ImportDecl GhcRn) -> ImportDecl GhcRn)
-> GenLocated SrcSpanAnnA (ImportDecl GhcRn)
-> GenLocated SrcSpanAnnA ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ImportDecl GhcRn) -> ImportDecl GhcRn
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA (ImportDecl GhcRn) -> Symbol)
-> [GenLocated SrcSpanAnnA (ImportDecl GhcRn)] -> [Symbol]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LImportDecl GhcRn]
[GenLocated SrcSpanAnnA (ImportDecl GhcRn)]
imps)

qualifiedImports :: [LImportDecl GhcRn] -> QImports
qualifiedImports :: [LImportDecl GhcRn] -> QImports
qualifiedImports = \case
  []   -> String -> QImports -> QImports
forall a. String -> a -> a
Debug.trace String
"WARNING: Missing RenamedSource" ([(Symbol, Symbol)] -> QImports
qImports [(Symbol, Symbol)]
forall a. Monoid a => a
mempty)
  [LImportDecl GhcRn]
imps -> [(Symbol, Symbol)] -> QImports
qImports [ (Symbol
qn, Symbol
n) | GenLocated SrcSpanAnnA (ImportDecl GhcRn)
i         <- [LImportDecl GhcRn]
[GenLocated SrcSpanAnnA (ImportDecl GhcRn)]
imps
                                          , let decl :: ImportDecl GhcRn
decl   = GenLocated SrcSpanAnnA (ImportDecl GhcRn) -> ImportDecl GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (ImportDecl GhcRn)
i
                                          , let m :: ModuleName
m      = GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (ImportDecl GhcRn -> XRec GhcRn ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl GhcRn
decl)
                                          , ModuleName
qm        <- Maybe ModuleName -> [ModuleName]
forall a. Maybe a -> [a]
maybeToList (GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA ModuleName -> ModuleName)
-> Maybe (GenLocated SrcSpanAnnA ModuleName) -> Maybe ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImportDecl GhcRn -> Maybe (XRec GhcRn ModuleName)
forall pass. ImportDecl pass -> Maybe (XRec pass ModuleName)
ideclAs ImportDecl GhcRn
decl)
                                          , let [Symbol
n,Symbol
qn] = ModuleName -> Symbol
forall a. Symbolic a => a -> Symbol
symbol (ModuleName -> Symbol) -> [ModuleName] -> [Symbol]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName
m, ModuleName
qm]
                                          ]

qImports :: [(Symbol, Symbol)] -> QImports
qImports :: [(Symbol, Symbol)] -> QImports
qImports [(Symbol, Symbol)]
qns  = QImports
  { qiNames :: HashMap Symbol [Symbol]
qiNames   = [(Symbol, Symbol)] -> HashMap Symbol [Symbol]
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k [v]
Misc.group [(Symbol, Symbol)]
qns
  , qiModules :: HashSet Symbol
qiModules = [Symbol] -> HashSet Symbol
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList ((Symbol, Symbol) -> Symbol
forall a b. (a, b) -> b
snd ((Symbol, Symbol) -> Symbol) -> [(Symbol, Symbol)] -> [Symbol]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Symbol, Symbol)]
qns)
  }


---------------------------------------------------------------------------------------
-- | @lookupTyThings@ grabs all the @Name@s and associated @TyThing@ known to GHC
--   for this module; we will use this to create our name-resolution environment
--   (see `Bare.Resolve`)
---------------------------------------------------------------------------------------
lookupTyThings :: HscEnv -> TcGblEnv -> IO [(Name, Maybe TyThing)]
lookupTyThings :: HscEnv -> TcGblEnv -> IO [(Name, Maybe TyThing)]
lookupTyThings HscEnv
hscEnv TcGblEnv
tcGblEnv = [Name]
-> (Name -> IO (Name, Maybe TyThing)) -> IO [(Name, Maybe TyThing)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name]
names (HscEnv -> TcGblEnv -> Name -> IO (Name, Maybe TyThing)
lookupTyThing HscEnv
hscEnv TcGblEnv
tcGblEnv)
  where
    names :: [Ghc.Name]
    names :: [Name]
names  = ([Name] -> [Name] -> [Name])
-> (TcGblEnv -> [Name])
-> (TcGblEnv -> [Name])
-> TcGblEnv
-> [Name]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
(++)
             ((GlobalRdrElt -> Name) -> [GlobalRdrElt] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GlobalRdrElt -> Name
Ghc.greMangledName ([GlobalRdrElt] -> [Name])
-> (TcGblEnv -> [GlobalRdrElt]) -> TcGblEnv -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalRdrEnv -> [GlobalRdrElt]
Ghc.globalRdrEnvElts (GlobalRdrEnv -> [GlobalRdrElt])
-> (TcGblEnv -> GlobalRdrEnv) -> TcGblEnv -> [GlobalRdrElt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcGblEnv -> GlobalRdrEnv
tcg_rdr_env)
             ((ClsInst -> Name) -> [ClsInst] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ClsInst -> Name
is_dfun_name ([ClsInst] -> [Name])
-> (TcGblEnv -> [ClsInst]) -> TcGblEnv -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcGblEnv -> [ClsInst]
tcg_insts) TcGblEnv
tcGblEnv
-- | Lookup a single 'Name' in the GHC environment, yielding back the 'Name' alongside the 'TyThing',
-- if one is found.
lookupTyThing :: HscEnv -> TcGblEnv -> Name -> IO (Name, Maybe TyThing)
lookupTyThing :: HscEnv -> TcGblEnv -> Name -> IO (Name, Maybe TyThing)
lookupTyThing HscEnv
hscEnv TcGblEnv
tcGblEnv Name
n = do
  Maybe TyThing
mty <- MaybeT IO TyThing -> IO (Maybe TyThing)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO TyThing -> IO (Maybe TyThing))
-> MaybeT IO TyThing -> IO (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$
         IO (Maybe TyThing) -> MaybeT IO TyThing
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (HscEnv -> Name -> IO (Maybe TyThing)
Ghc.hscTcRcLookupName HscEnv
hscEnv Name
n)
         MaybeT IO TyThing -> MaybeT IO TyThing -> MaybeT IO TyThing
forall a. MaybeT IO a -> MaybeT IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
         IO (Maybe TyThing) -> MaybeT IO TyThing
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (
           do ModuleInfoLH
mi  <- HscEnv -> TcGblEnv -> IO ModuleInfoLH
moduleInfoTc HscEnv
hscEnv TcGblEnv
tcGblEnv
              HscEnv -> ModuleInfoLH -> Name -> IO (Maybe TyThing)
modInfoLookupNameIO HscEnv
hscEnv ModuleInfoLH
mi Name
n
           )
  (Name, Maybe TyThing) -> IO (Name, Maybe TyThing)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Maybe TyThing
mty)

availableTyThings :: HscEnv -> TcGblEnv -> [AvailInfo] -> IO [TyThing]
availableTyThings :: HscEnv -> TcGblEnv -> [AvailInfo] -> IO [TyThing]
availableTyThings HscEnv
hscEnv TcGblEnv
tcGblEnv [AvailInfo]
avails =
    ([Maybe TyThing] -> [TyThing])
-> IO [Maybe TyThing] -> IO [TyThing]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe TyThing] -> [TyThing]
forall a. [Maybe a] -> [a]
catMaybes (IO [Maybe TyThing] -> IO [TyThing])
-> IO [Maybe TyThing] -> IO [TyThing]
forall a b. (a -> b) -> a -> b
$
      (Name -> IO (Maybe TyThing)) -> [Name] -> IO [Maybe TyThing]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (((Name, Maybe TyThing) -> Maybe TyThing)
-> IO (Name, Maybe TyThing) -> IO (Maybe TyThing)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name, Maybe TyThing) -> Maybe TyThing
forall a b. (a, b) -> b
snd (IO (Name, Maybe TyThing) -> IO (Maybe TyThing))
-> (Name -> IO (Name, Maybe TyThing)) -> Name -> IO (Maybe TyThing)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> TcGblEnv -> Name -> IO (Name, Maybe TyThing)
lookupTyThing HscEnv
hscEnv TcGblEnv
tcGblEnv) ([Name] -> IO [Maybe TyThing]) -> [Name] -> IO [Maybe TyThing]
forall a b. (a -> b) -> a -> b
$
      [AvailInfo] -> [Name]
availableNames [AvailInfo]
avails

-- | Returns all the available (i.e. exported) 'TyCon's (type constructors) for the input 'Module'.
availableTyCons :: HscEnv -> TcGblEnv -> [AvailInfo] -> IO [Ghc.TyCon]
availableTyCons :: HscEnv -> TcGblEnv -> [AvailInfo] -> IO [TyCon]
availableTyCons HscEnv
hscEnv TcGblEnv
tcGblEnv [AvailInfo]
avails =
  ([TyThing] -> [TyCon]) -> IO [TyThing] -> IO [TyCon]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[TyThing]
things -> [TyCon
tyCon | (ATyCon TyCon
tyCon) <- [TyThing]
things]) (HscEnv -> TcGblEnv -> [AvailInfo] -> IO [TyThing]
availableTyThings HscEnv
hscEnv TcGblEnv
tcGblEnv [AvailInfo]
avails)

-- | Returns all the available (i.e. exported) 'Var's for the input 'Module'.
availableVars :: HscEnv -> TcGblEnv -> [AvailInfo] -> IO [Ghc.Var]
availableVars :: HscEnv -> TcGblEnv -> [AvailInfo] -> IO [Var]
availableVars HscEnv
hscEnv TcGblEnv
tcGblEnv [AvailInfo]
avails =
  ([TyThing] -> [Var]) -> IO [TyThing] -> IO [Var]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[TyThing]
things -> [Var
var | (AnId Var
var) <- [TyThing]
things]) (HscEnv -> TcGblEnv -> [AvailInfo] -> IO [TyThing]
availableTyThings HscEnv
hscEnv TcGblEnv
tcGblEnv [AvailInfo]
avails)

availableNames :: [AvailInfo] -> [Name]
availableNames :: [AvailInfo] -> [Name]
availableNames =
    (AvailInfo -> [Name]) -> [AvailInfo] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((AvailInfo -> [Name]) -> [AvailInfo] -> [Name])
-> (AvailInfo -> [Name]) -> [AvailInfo] -> [Name]
forall a b. (a -> b) -> a -> b
$ \case
      Avail GreName
n -> [GreName -> Name
Ghc.greNameMangledName GreName
n]
      AvailTC Name
n [GreName]
ns -> Name
n Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: (GreName -> Name) -> [GreName] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map GreName -> Name
Ghc.greNameMangledName [GreName]
ns

_dumpTypeEnv :: TypecheckedModule -> IO ()
_dumpTypeEnv :: TypecheckedModule -> IO ()
_dumpTypeEnv TypecheckedModule
tm = do
  String -> IO ()
forall a. Show a => a -> IO ()
print (String
"DUMP-TYPE-ENV" :: String)
  Maybe String -> IO ()
forall a. Show a => a -> IO ()
print ([Name] -> String
forall a. PPrint a => a -> String
showpp ([Name] -> String) -> Maybe [Name] -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypecheckedModule -> Maybe [Name]
tcmTyThings TypecheckedModule
tm)

tcmTyThings :: TypecheckedModule -> Maybe [Name]
tcmTyThings :: TypecheckedModule -> Maybe [Name]
tcmTyThings
  =
  -- typeEnvElts
  -- . tcg_type_env . fst
  -- . md_types . snd
  -- . tm_internals_
  ModuleInfo -> Maybe [Name]
modInfoTopLevelScope
  (ModuleInfo -> Maybe [Name])
-> (TypecheckedModule -> ModuleInfo)
-> TypecheckedModule
-> Maybe [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypecheckedModule -> ModuleInfo
tm_checked_module_info

modSummaryHsFile :: ModSummary -> FilePath
modSummaryHsFile :: ModSummary -> String
modSummaryHsFile ModSummary
modSummary =
  String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe
    (Maybe SrcSpan -> String -> String
forall a. Maybe SrcSpan -> String -> a
panic Maybe SrcSpan
forall a. Maybe a
Nothing (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
      String
"modSummaryHsFile: missing .hs file for " String -> String -> String
forall a. [a] -> [a] -> [a]
++
      Module -> String
forall a. Outputable a => a -> String
showPpr (ModSummary -> Module
ms_mod ModSummary
modSummary))
    (ModLocation -> Maybe String
ml_hs_file (ModLocation -> Maybe String) -> ModLocation -> Maybe String
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location ModSummary
modSummary)

checkFilePragmas :: [Located String] -> IO ()
checkFilePragmas :: [Located String] -> IO ()
checkFilePragmas = IO () -> ([Error] -> IO ()) -> [Error] -> IO ()
forall b a. b -> ([a] -> b) -> [a] -> b
Misc.applyNonNull (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) [Error] -> IO ()
forall a e. Exception e => e -> a
throw ([Error] -> IO ())
-> ([Located String] -> [Error]) -> [Located String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Located String -> Maybe Error) -> [Located String] -> [Error]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Located String -> Maybe Error
err
  where
    err :: Located String -> Maybe Error
err Located String
pragma
      | String -> Bool
check (Located String -> String
forall a. Located a -> a
val Located String
pragma) = Error -> Maybe Error
forall a. a -> Maybe a
Just (SrcSpan -> Error
forall t. SrcSpan -> TError t
ErrFilePragma (SrcSpan -> Error) -> SrcSpan -> Error
forall a b. (a -> b) -> a -> b
$ Located String -> SrcSpan
forall a. Loc a => a -> SrcSpan
fSrcSpan Located String
pragma :: Error)
      | Bool
otherwise          = Maybe Error
forall a. Maybe a
Nothing
    check :: String -> Bool
check String
pragma           = (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
pragma) [String]
forall {a}. IsString a => [a]
bad
    bad :: [a]
bad =
      [ a
"-i", a
"--idirs"
      , a
"-g", a
"--ghc-option"
      , a
"--c-files", a
"--cfiles"
      ]

--------------------------------------------------------------------------------
-- | Family instance information
--------------------------------------------------------------------------------
makeFamInstEnv :: [FamInst] -> ([Ghc.TyCon], [(Symbol, DataCon)])
makeFamInstEnv :: [FamInst] -> ([TyCon], [(Symbol, DataCon)])
makeFamInstEnv [FamInst]
famInsts =
  let fiTcs :: [TyCon]
fiTcs = [ TyCon
tc            | FamInst { fi_flavor :: FamInst -> FamFlavor
fi_flavor = DataFamilyInst TyCon
tc } <- [FamInst]
famInsts ]
      fiDcs :: [(Symbol, DataCon)]
fiDcs = [ (DataCon -> Symbol
forall a. Symbolic a => a -> Symbol
symbol DataCon
d, DataCon
d) | TyCon
tc <- [TyCon]
fiTcs, DataCon
d <- TyCon -> [DataCon]
tyConDataCons TyCon
tc ]
  in ([TyCon]
fiTcs, [(Symbol, DataCon)]
fiDcs)

--------------------------------------------------------------------------------
-- | Extract Specifications from GHC -------------------------------------------
--------------------------------------------------------------------------------
extractSpecComments :: ParsedModule -> [(Maybe RealSrcLoc, String)]
extractSpecComments :: ParsedModule -> [(Maybe RealSrcLoc, String)]
extractSpecComments = (Located ApiComment -> Maybe (Maybe RealSrcLoc, String))
-> [Located ApiComment] -> [(Maybe RealSrcLoc, String)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Located ApiComment -> Maybe (Maybe RealSrcLoc, String)
extractSpecComment ([Located ApiComment] -> [(Maybe RealSrcLoc, String)])
-> (ParsedModule -> [Located ApiComment])
-> ParsedModule
-> [(Maybe RealSrcLoc, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedModule -> [Located ApiComment]
apiComments

-- | 'extractSpecComment' pulls out the specification part from a full comment
--   string, i.e. if the string is of the form:
--   1. '{-@ S @-}' then it returns the substring 'S',
--   2. '{-@ ... -}' then it throws a malformed SPECIFICATION ERROR, and
--   3. Otherwise it is just treated as a plain comment so we return Nothing.

extractSpecComment :: Ghc.Located ApiComment -> Maybe (Maybe RealSrcLoc, String)
extractSpecComment :: Located ApiComment -> Maybe (Maybe RealSrcLoc, String)
extractSpecComment (Ghc.L SrcSpan
sp (ApiBlockComment String
txt))
  | String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
"{-@" String
txt Bool -> Bool -> Bool
&& String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf String
"@-}" String
txt          -- valid   specification
  = (Maybe RealSrcLoc, String) -> Maybe (Maybe RealSrcLoc, String)
forall a. a -> Maybe a
Just (Maybe RealSrcLoc
offsetPos, Int -> String -> String
forall a. Int -> [a] -> [a]
take (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
txt Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
6) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
3 String
txt)
  | String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
"{-@" String
txt                                   -- invalid specification
  = UserError -> Maybe (Maybe RealSrcLoc, String)
forall a. UserError -> a
uError (UserError -> Maybe (Maybe RealSrcLoc, String))
-> UserError -> Maybe (Maybe RealSrcLoc, String)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Doc -> UserError
forall t. SrcSpan -> Doc -> TError t
ErrParseAnn SrcSpan
sp Doc
"A valid specification must have a closing '@-}'."
  where
    offsetPos :: Maybe RealSrcLoc
offsetPos = RealSrcLoc -> RealSrcLoc
offsetRealSrcLoc (RealSrcLoc -> RealSrcLoc)
-> (RealSrcSpan -> RealSrcLoc) -> RealSrcSpan -> RealSrcLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcSpan -> RealSrcLoc
realSrcSpanStart (RealSrcSpan -> RealSrcLoc)
-> Maybe RealSrcSpan -> Maybe RealSrcLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SrcSpan -> Maybe RealSrcSpan
srcSpanToRealSrcSpan SrcSpan
sp
    offsetRealSrcLoc :: RealSrcLoc -> RealSrcLoc
offsetRealSrcLoc RealSrcLoc
s =
      FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (RealSrcLoc -> FastString
srcLocFile RealSrcLoc
s) (RealSrcLoc -> Int
srcLocLine RealSrcLoc
s) (RealSrcLoc -> Int
srcLocCol RealSrcLoc
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)

extractSpecComment Located ApiComment
_ = Maybe (Maybe RealSrcLoc, String)
forall a. Maybe a
Nothing

extractSpecQuotes' :: (a -> Module) -> (a -> [Annotation]) -> a -> [BPspec]
extractSpecQuotes' :: forall a. (a -> Module) -> (a -> [Annotation]) -> a -> [BPspec]
extractSpecQuotes' a -> Module
thisModule a -> [Annotation]
getAnns a
a = (AnnPayload -> Maybe BPspec) -> [AnnPayload] -> [BPspec]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe AnnPayload -> Maybe BPspec
extractSpecQuote [AnnPayload]
anns
  where
    anns :: [AnnPayload]
anns = (Annotation -> AnnPayload) -> [Annotation] -> [AnnPayload]
forall a b. (a -> b) -> [a] -> [b]
map Annotation -> AnnPayload
ann_value ([Annotation] -> [AnnPayload]) -> [Annotation] -> [AnnPayload]
forall a b. (a -> b) -> a -> b
$
           (Annotation -> Bool) -> [Annotation] -> [Annotation]
forall a. (a -> Bool) -> [a] -> [a]
filter (AnnTarget Name -> Bool
isOurModTarget (AnnTarget Name -> Bool)
-> (Annotation -> AnnTarget Name) -> Annotation -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Annotation -> AnnTarget Name
ann_target) ([Annotation] -> [Annotation]) -> [Annotation] -> [Annotation]
forall a b. (a -> b) -> a -> b
$
           a -> [Annotation]
getAnns a
a

    isOurModTarget :: AnnTarget Name -> Bool
isOurModTarget (ModuleTarget Module
mod1) = Module
mod1 Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== a -> Module
thisModule a
a
    isOurModTarget AnnTarget Name
_ = Bool
False

extractSpecQuote :: AnnPayload -> Maybe BPspec
extractSpecQuote :: AnnPayload -> Maybe BPspec
extractSpecQuote AnnPayload
payload =
  case ([Word8] -> LiquidQuote) -> AnnPayload -> Maybe LiquidQuote
forall a. Typeable a => ([Word8] -> a) -> AnnPayload -> Maybe a
Ghc.fromSerialized [Word8] -> LiquidQuote
forall a. Data a => [Word8] -> a
Ghc.deserializeWithData AnnPayload
payload of
    Maybe LiquidQuote
Nothing -> Maybe BPspec
forall a. Maybe a
Nothing
    Just LiquidQuote
qt -> BPspec -> Maybe BPspec
forall a. a -> Maybe a
Just (BPspec -> Maybe BPspec) -> BPspec -> Maybe BPspec
forall a b. (a -> b) -> a -> b
$ BPspec -> BPspec
forall a. Data a => a -> a
refreshSymbols (BPspec -> BPspec) -> BPspec -> BPspec
forall a b. (a -> b) -> a -> b
$ LiquidQuote -> BPspec
liquidQuoteSpec LiquidQuote
qt

refreshSymbols :: Data a => a -> a
refreshSymbols :: forall a. Data a => a -> a
refreshSymbols = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((Symbol -> Symbol) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT Symbol -> Symbol
refreshSymbol)

refreshSymbol :: Symbol -> Symbol
refreshSymbol :: Symbol -> Symbol
refreshSymbol = Text -> Symbol
forall a. Symbolic a => a -> Symbol
symbol (Text -> Symbol) -> (Symbol -> Text) -> Symbol -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Text
symbolText

--------------------------------------------------------------------------------
-- | Finding & Parsing Files ---------------------------------------------------
--------------------------------------------------------------------------------

-- | Parse a spec file by path.
--
-- On a parse error, we fail.
--
-- TODO, Andres: It would be better to fail more systematically, but currently we
-- seem to have an option between throwing an error which will be reported badly,
-- or printing the error ourselves.
--
parseSpecFile :: FilePath -> IO (ModName, Ms.BareSpec)
parseSpecFile :: String -> IO (ModName, BareSpec)
parseSpecFile String
file = do
  String
contents <- String -> IO String
Misc.sayReadFile String
file
  case String
-> String
-> Either (ParseErrorBundle String Void) (ModName, BareSpec)
specSpecificationP String
file String
contents of
    Left ParseErrorBundle String Void
peb -> do
      Handle -> String -> IO ()
hPutStrLn Handle
stderr (ParseErrorBundle String Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle String Void
peb)
      Maybe SrcSpan -> String -> IO (ModName, BareSpec)
forall a. Maybe SrcSpan -> String -> a
panic Maybe SrcSpan
forall a. Maybe a
Nothing String
"parsing spec file failed"
    Right (ModName, BareSpec)
x  -> (ModName, BareSpec) -> IO (ModName, BareSpec)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModName, BareSpec)
x

--------------------------------------------------------------------------------
-- Assemble Information for Spec Extraction ------------------------------------
--------------------------------------------------------------------------------

makeLogicMap :: IO LogicMap
makeLogicMap :: IO LogicMap
makeLogicMap = do
  String
lg    <- IO String
Misc.getCoreToLogicPath
  String
lspec <- String -> IO String
Misc.sayReadFile String
lg
  case String -> String -> Either (ParseErrorBundle String Void) LogicMap
parseSymbolToLogic String
lg String
lspec of
    Left ParseErrorBundle String Void
peb -> do
      Handle -> String -> IO ()
hPutStrLn Handle
stderr (ParseErrorBundle String Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle String Void
peb)
      Maybe SrcSpan -> String -> IO LogicMap
forall a. Maybe SrcSpan -> String -> a
panic Maybe SrcSpan
forall a. Maybe a
Nothing String
"makeLogicMap failed"
    Right LogicMap
lm -> LogicMap -> IO LogicMap
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LogicMap
lm LogicMap -> LogicMap -> LogicMap
forall a. Semigroup a => a -> a -> a
<> LogicMap
listLMap)

listLMap :: LogicMap -- TODO-REBARE: move to wiredIn
listLMap :: LogicMap
listLMap  = [(Located Symbol, [Symbol], Expr)] -> LogicMap
toLogicMap [ (Symbol -> Located Symbol
forall a. a -> Located a
dummyLoc Symbol
nilName , []     , Expr
hNil)
                       , (Symbol -> Located Symbol
forall a. a -> Located a
dummyLoc Symbol
consName, [Symbol
forall {a}. IsString a => a
x, Symbol
forall {a}. IsString a => a
xs], [Expr] -> Expr
hCons (Symbol -> Expr
EVar (Symbol -> Expr) -> [Symbol] -> [Expr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Symbol
forall {a}. IsString a => a
x, Symbol
forall {a}. IsString a => a
xs])) ]
  where
    x :: a
x     = a
"x"
    xs :: a
xs    = a
"xs"
    hNil :: Expr
hNil  = Located Symbol -> [Expr] -> Expr
mkEApp (DataCon -> Located Symbol
forall {a}. Symbolic a => a -> Located Symbol
dcSym DataCon
Ghc.nilDataCon ) []
    hCons :: [Expr] -> Expr
hCons = Located Symbol -> [Expr] -> Expr
mkEApp (DataCon -> Located Symbol
forall {a}. Symbolic a => a -> Located Symbol
dcSym DataCon
Ghc.consDataCon)
    dcSym :: a -> Located Symbol
dcSym = Symbol -> Located Symbol
forall a. a -> Located a
dummyLoc (Symbol -> Located Symbol) -> (a -> Symbol) -> a -> Located Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Symbol
dropModuleUnique (Symbol -> Symbol) -> (a -> Symbol) -> a -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Symbol
forall a. Symbolic a => a -> Symbol
symbol



--------------------------------------------------------------------------------
-- | Pretty Printing -----------------------------------------------------------
--------------------------------------------------------------------------------

instance PPrint TargetSpec where
  pprintTidy :: Tidy -> TargetSpec -> Doc
pprintTidy Tidy
k TargetSpec
spec = [Doc] -> Doc
vcat
    [ Doc
"******* Target Variables ********************"
    , Tidy -> [Var] -> Doc
forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k ([Var] -> Doc) -> [Var] -> Doc
forall a b. (a -> b) -> a -> b
$ GhcSpecVars -> [Var]
gsTgtVars (TargetSpec -> GhcSpecVars
gsVars TargetSpec
spec)
    , Doc
"******* Type Signatures *********************"
    , Tidy -> [(Var, LocSpecType)] -> Doc
forall a. PPrint a => Tidy -> [a] -> Doc
pprintLongList Tidy
k (GhcSpecSig -> [(Var, LocSpecType)]
gsTySigs (TargetSpec -> GhcSpecSig
gsSig TargetSpec
spec))
    , Doc
"******* Assumed Type Signatures *************"
    , Tidy -> [(Var, LocSpecType)] -> Doc
forall a. PPrint a => Tidy -> [a] -> Doc
pprintLongList Tidy
k (GhcSpecSig -> [(Var, LocSpecType)]
gsAsmSigs (TargetSpec -> GhcSpecSig
gsSig TargetSpec
spec))
    , Doc
"******* DataCon Specifications (Measure) ****"
    , Tidy -> [(Var, LocSpecType)] -> Doc
forall a. PPrint a => Tidy -> [a] -> Doc
pprintLongList Tidy
k (GhcSpecData -> [(Var, LocSpecType)]
gsCtors (TargetSpec -> GhcSpecData
gsData TargetSpec
spec))
    , Doc
"******* Measure Specifications **************"
    , Tidy -> [(Symbol, LocSpecType)] -> Doc
forall a. PPrint a => Tidy -> [a] -> Doc
pprintLongList Tidy
k (GhcSpecData -> [(Symbol, LocSpecType)]
gsMeas (TargetSpec -> GhcSpecData
gsData TargetSpec
spec))       ]

instance PPrint TargetInfo where
  pprintTidy :: Tidy -> TargetInfo -> Doc
pprintTidy Tidy
k TargetInfo
info = [Doc] -> Doc
vcat
    [ -- "*************** Imports *********************"
      -- , intersperse comma $ text <$> imports info
      -- , "*************** Includes ********************"
      -- , intersperse comma $ text <$> includes info
      Doc
"*************** Imported Variables **********"
    , [Var] -> Doc
forall a. Outputable a => a -> Doc
pprDoc ([Var] -> Doc) -> [Var] -> Doc
forall a b. (a -> b) -> a -> b
$ GhcSrc -> [Var]
_giImpVars (TargetSrc -> GhcSrc
fromTargetSrc (TargetSrc -> GhcSrc) -> TargetSrc -> GhcSrc
forall a b. (a -> b) -> a -> b
$ TargetInfo -> TargetSrc
giSrc TargetInfo
info)
    , Doc
"*************** Defined Variables ***********"
    , [Var] -> Doc
forall a. Outputable a => a -> Doc
pprDoc ([Var] -> Doc) -> [Var] -> Doc
forall a b. (a -> b) -> a -> b
$ GhcSrc -> [Var]
_giDefVars (TargetSrc -> GhcSrc
fromTargetSrc (TargetSrc -> GhcSrc) -> TargetSrc -> GhcSrc
forall a b. (a -> b) -> a -> b
$ TargetInfo -> TargetSrc
giSrc TargetInfo
info)
    , Doc
"*************** Specification ***************"
    , Tidy -> TargetSpec -> Doc
forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k (TargetSpec -> Doc) -> TargetSpec -> Doc
forall a b. (a -> b) -> a -> b
$ TargetInfo -> TargetSpec
giSpec TargetInfo
info
    , Doc
"*************** Core Bindings ***************"
    , [CoreBind] -> Doc
pprintCBs ([CoreBind] -> Doc) -> [CoreBind] -> Doc
forall a b. (a -> b) -> a -> b
$ GhcSrc -> [CoreBind]
_giCbs (TargetSrc -> GhcSrc
fromTargetSrc (TargetSrc -> GhcSrc) -> TargetSrc -> GhcSrc
forall a b. (a -> b) -> a -> b
$ TargetInfo -> TargetSrc
giSrc TargetInfo
info) ]

pprintCBs :: [CoreBind] -> Doc
pprintCBs :: [CoreBind] -> Doc
pprintCBs = [CoreBind] -> Doc
forall a. Outputable a => a -> Doc
pprDoc ([CoreBind] -> Doc)
-> ([CoreBind] -> [CoreBind]) -> [CoreBind] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CoreBind] -> [CoreBind]
tidyCBs
    -- To print verbosely
    --    = text . O.showSDocDebug unsafeGlobalDynFlags . O.ppr . tidyCBs

instance Show TargetInfo where
  show :: TargetInfo -> String
show = TargetInfo -> String
forall a. PPrint a => a -> String
showpp

instance PPrint TargetVars where
  pprintTidy :: Tidy -> TargetVars -> Doc
pprintTidy Tidy
_ TargetVars
AllVars   = String -> Doc
text String
"All Variables"
  pprintTidy Tidy
k (Only [Var]
vs) = String -> Doc
text String
"Only Variables: " Doc -> Doc -> Doc
<+> Tidy -> [Var] -> Doc
forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k [Var]
vs

------------------------------------------------------------------------
-- Dealing with Errors ---------------------------------------------------
------------------------------------------------------------------------

instance Result SourceError where
  result :: SourceError -> FixResult UserError
result SourceError
e = [(UserError, Maybe String)] -> String -> FixResult UserError
forall a. [(a, Maybe String)] -> String -> FixResult a
Crash ((, Maybe String
forall a. Maybe a
Nothing) (UserError -> (UserError, Maybe String))
-> [UserError] -> [(UserError, Maybe String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> SourceError -> [UserError]
forall t. String -> SourceError -> [TError t]
sourceErrors String
"" SourceError
e) String
"Invalid Source"