{-# 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
  , listLMap
  , classCons
  , derivedVars
  , importVars
  , modSummaryHsFile
  , makeFamInstEnv
  , clearSpec
  , lookupTyThing
  , 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.Monad
import Control.Monad.Trans.Maybe

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

import qualified Data.HashSet        as S

import Text.PrettyPrint.HughesPJ        hiding (first, (<>))
import Language.Fixpoint.Types          hiding (err, panic, Error, Result, Expr)
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 Language.Haskell.Liquid.Types.Errors
import Language.Haskell.Liquid.Types.PrettyPrint
import Language.Haskell.Liquid.Types.Specs
import Language.Haskell.Liquid.Types.Types
import Language.Haskell.Liquid.Types.Visitors
import Language.Haskell.Liquid.UX.Config
import Language.Haskell.Liquid.UX.Tidy


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

classCons :: Maybe [ClsInst] -> [Id]
classCons :: Maybe [ClsInst] -> [CoreBndr]
classCons Maybe [ClsInst]
Nothing   = []
classCons (Just [ClsInst]
cs) = (ClsInst -> [CoreBndr]) -> [ClsInst] -> [CoreBndr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (DataCon -> [CoreBndr]
dataConImplicitIds (DataCon -> [CoreBndr])
-> (ClsInst -> DataCon) -> ClsInst -> [CoreBndr]
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 -> [CoreBndr]
derivedVars Config
cfg MGIModGuts
mg  = (ClsInst -> [CoreBndr]) -> [ClsInst] -> [CoreBndr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([CoreBind] -> CoreBndr -> [CoreBndr]
dFunIdVars [CoreBind]
cbs (CoreBndr -> [CoreBndr])
-> (ClsInst -> CoreBndr) -> ClsInst -> [CoreBndr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClsInst -> CoreBndr
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] -> CoreBndr -> [CoreBndr]
dFunIdVars [CoreBind]
cbs CoreBndr
fd  = [Char] -> [CoreBndr] -> [CoreBndr]
forall a. PPrint a => [Char] -> a -> a
notracepp [Char]
msg ([CoreBndr] -> [CoreBndr]) -> [CoreBndr] -> [CoreBndr]
forall a b. (a -> b) -> a -> b
$ (CoreBind -> [CoreBndr]) -> [CoreBind] -> [CoreBndr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CoreBind -> [CoreBndr]
forall b. Bind b -> [b]
bindersOf [CoreBind]
cbs' [CoreBndr] -> [CoreBndr] -> [CoreBndr]
forall a. [a] -> [a] -> [a]
++ [CoreBndr]
deps
  where
    msg :: [Char]
msg            = [Char]
"DERIVED-VARS-OF: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CoreBndr -> [Char]
forall a. PPrint a => a -> [Char]
showpp CoreBndr
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 CoreBndr
x Expr CoreBndr
_) = CoreBndr -> Bool
eqFd CoreBndr
x
    f (Rec [(CoreBndr, Expr CoreBndr)]
xes)    = (CoreBndr -> Bool) -> [CoreBndr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any CoreBndr -> Bool
eqFd ((CoreBndr, Expr CoreBndr) -> CoreBndr
forall a b. (a, b) -> a
fst ((CoreBndr, Expr CoreBndr) -> CoreBndr)
-> [(CoreBndr, Expr CoreBndr)] -> [CoreBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(CoreBndr, Expr CoreBndr)]
xes)
    eqFd :: CoreBndr -> Bool
eqFd CoreBndr
x         = CoreBndr -> Name
varName CoreBndr
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== CoreBndr -> Name
varName CoreBndr
fd
    deps :: [CoreBndr]
deps           = (Unfolding -> [CoreBndr]) -> [Unfolding] -> [CoreBndr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Unfolding -> [CoreBndr]
unfoldDep [Unfolding]
unfolds
    unfolds :: [Unfolding]
unfolds        = IdInfo -> Unfolding
realUnfoldingInfo (IdInfo -> Unfolding)
-> (CoreBndr -> IdInfo) -> CoreBndr -> Unfolding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => CoreBndr -> IdInfo
CoreBndr -> IdInfo
idInfo (CoreBndr -> Unfolding) -> [CoreBndr] -> [Unfolding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CoreBind -> [CoreBndr]) -> [CoreBind] -> [CoreBndr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CoreBind -> [CoreBndr]
forall b. Bind b -> [b]
bindersOf [CoreBind]
cbs'

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

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

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

_definedVars :: CoreProgram -> [Id]
_definedVars :: [CoreBind] -> [CoreBndr]
_definedVars = (CoreBind -> [CoreBndr]) -> [CoreBind] -> [CoreBndr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CoreBind -> [CoreBndr]
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 :: Spec Symbol BareType
-> Maybe (Spec Symbol BareType) -> Spec Symbol BareType
updLiftedSpec Spec Symbol BareType
s1 Maybe (Spec Symbol BareType)
Nothing   = Spec Symbol BareType
s1
updLiftedSpec Spec Symbol BareType
s1 (Just Spec Symbol BareType
s2) = Spec Symbol BareType -> Spec Symbol BareType
clearSpec Spec Symbol BareType
s1 Spec Symbol BareType
-> Spec Symbol BareType -> Spec Symbol BareType
forall a. Monoid a => a -> a -> a
`mappend` Spec Symbol BareType
s2

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

lookupTyThing :: (GhcMonad m) => Ghc.TypeEnv -> Name -> m (Maybe TyThing)
lookupTyThing :: forall (m :: * -> *).
GhcMonad m =>
TypeEnv -> Name -> m (Maybe TyThing)
lookupTyThing TypeEnv
tyEnv Name
name = do
    MaybeT m TyThing -> m (Maybe TyThing)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m TyThing -> m (Maybe TyThing))
-> ([m (Maybe TyThing)] -> MaybeT m TyThing)
-> [m (Maybe TyThing)]
-> m (Maybe TyThing)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MaybeT m TyThing] -> MaybeT m TyThing
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([MaybeT m TyThing] -> MaybeT m TyThing)
-> ([m (Maybe TyThing)] -> [MaybeT m TyThing])
-> [m (Maybe TyThing)]
-> MaybeT m TyThing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m (Maybe TyThing) -> MaybeT m TyThing)
-> [m (Maybe TyThing)] -> [MaybeT m TyThing]
forall a b. (a -> b) -> [a] -> [b]
map m (Maybe TyThing) -> MaybeT m TyThing
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT ([m (Maybe TyThing)] -> m (Maybe TyThing))
-> [m (Maybe TyThing)] -> m (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$
        [ Maybe TyThing -> m (Maybe TyThing)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeEnv -> Name -> Maybe TyThing
lookupTypeEnv TypeEnv
tyEnv Name
name)
        , Name -> m (Maybe TyThing)
forall (m :: * -> *). GhcMonad m => Name -> m (Maybe TyThing)
lookupName Name
name
        ]

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

--------------------------------------------------------------------------------
-- | 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 :: HsParsedModule -> [(Maybe RealSrcLoc, String)]
extractSpecComments :: HsParsedModule -> [(Maybe RealSrcLoc, [Char])]
extractSpecComments = (GenLocated SrcSpan ApiComment -> Maybe (Maybe RealSrcLoc, [Char]))
-> [GenLocated SrcSpan ApiComment] -> [(Maybe RealSrcLoc, [Char])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe GenLocated SrcSpan ApiComment -> Maybe (Maybe RealSrcLoc, [Char])
extractSpecComment ([GenLocated SrcSpan ApiComment] -> [(Maybe RealSrcLoc, [Char])])
-> (HsParsedModule -> [GenLocated SrcSpan ApiComment])
-> HsParsedModule
-> [(Maybe RealSrcLoc, [Char])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsParsedModule -> [GenLocated SrcSpan 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 :: GenLocated SrcSpan ApiComment -> Maybe (Maybe RealSrcLoc, [Char])
extractSpecComment (Ghc.L SrcSpan
sp (ApiBlockComment [Char]
txt))
  | [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Char]
"{-@" [Char]
txt Bool -> Bool -> Bool
&& [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf [Char]
"@-}" [Char]
txt          -- valid   specification
  = (Maybe RealSrcLoc, [Char]) -> Maybe (Maybe RealSrcLoc, [Char])
forall a. a -> Maybe a
Just (Maybe RealSrcLoc
offsetPos, Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
txt Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
6) ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
3 [Char]
txt)
  | [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Char]
"{-@" [Char]
txt                                   -- invalid specification
  = UserError -> Maybe (Maybe RealSrcLoc, [Char])
forall a. UserError -> a
uError (UserError -> Maybe (Maybe RealSrcLoc, [Char]))
-> UserError -> Maybe (Maybe RealSrcLoc, [Char])
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 GenLocated SrcSpan ApiComment
_ = Maybe (Maybe RealSrcLoc, [Char])
forall a. Maybe a
Nothing

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

listLMap :: LogicMap -- TODO-REBARE: move to wiredIn
listLMap :: LogicMap
listLMap  = [(LocSymbol, ([Symbol], ExprV Symbol))] -> LogicMap
toLogicMap [ (Symbol -> LocSymbol
forall a. a -> Located a
dummyLoc Symbol
nilName , ([]     , ExprV Symbol
forall {b}. ExprBV b Symbol
hNil))
                       , (Symbol -> LocSymbol
forall a. a -> Located a
dummyLoc Symbol
consName, ([Symbol
forall {a}. IsString a => a
x, Symbol
forall {a}. IsString a => a
xs], [ExprV Symbol] -> ExprV Symbol
forall {b}. [ExprBV b Symbol] -> ExprBV b Symbol
hCons (Symbol -> ExprV Symbol
forall b v. v -> ExprBV b v
EVar (Symbol -> ExprV Symbol) -> [Symbol] -> [ExprV Symbol]
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 :: ExprBV b Symbol
hNil  = LocSymbol -> [ExprBV b Symbol] -> ExprBV b Symbol
forall v b. Located v -> [ExprBV b v] -> ExprBV b v
mkEApp (DataCon -> LocSymbol
forall {a}. Symbolic a => a -> LocSymbol
dcSym DataCon
Ghc.nilDataCon ) []
    hCons :: [ExprBV b Symbol] -> ExprBV b Symbol
hCons = LocSymbol -> [ExprBV b Symbol] -> ExprBV b Symbol
forall v b. Located v -> [ExprBV b v] -> ExprBV b v
mkEApp (DataCon -> LocSymbol
forall {a}. Symbolic a => a -> LocSymbol
dcSym DataCon
Ghc.consDataCon)
    dcSym :: a -> LocSymbol
dcSym = Symbol -> LocSymbol
forall a. a -> Located a
dummyLoc (Symbol -> LocSymbol) -> (a -> Symbol) -> a -> LocSymbol
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 -> [CoreBndr] -> Doc
forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k ([CoreBndr] -> Doc) -> [CoreBndr] -> Doc
forall a b. (a -> b) -> a -> b
$ GhcSpecVars -> [CoreBndr]
gsTgtVars (TargetSpec -> GhcSpecVars
gsVars TargetSpec
spec)
    , Doc
"******* Type Signatures *********************"
    , Tidy -> [(CoreBndr, LocSpecType)] -> Doc
forall a. PPrint a => Tidy -> [a] -> Doc
pprintLongList Tidy
k (GhcSpecSig -> [(CoreBndr, LocSpecType)]
gsTySigs (TargetSpec -> GhcSpecSig
gsSig TargetSpec
spec))
    , Doc
"******* Assumed Type Signatures *************"
    , Tidy -> [(CoreBndr, LocSpecType)] -> Doc
forall a. PPrint a => Tidy -> [a] -> Doc
pprintLongList Tidy
k (GhcSpecSig -> [(CoreBndr, LocSpecType)]
gsAsmSigs (TargetSpec -> GhcSpecSig
gsSig TargetSpec
spec))
    , Doc
"******* DataCon Specifications (Measure) ****"
    , Tidy -> [(CoreBndr, LocSpecType)] -> Doc
forall a. PPrint a => Tidy -> [a] -> Doc
pprintLongList Tidy
k (GhcSpecData -> [(CoreBndr, 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 **********"
    , [CoreBndr] -> Doc
forall a. Outputable a => a -> Doc
pprDoc ([CoreBndr] -> Doc) -> [CoreBndr] -> Doc
forall a b. (a -> b) -> a -> b
$ GhcSrc -> [CoreBndr]
_giImpVars (TargetSrc -> GhcSrc
fromTargetSrc (TargetSrc -> GhcSrc) -> TargetSrc -> GhcSrc
forall a b. (a -> b) -> a -> b
$ TargetInfo -> TargetSrc
giSrc TargetInfo
info)
    , Doc
"*************** Defined Variables ***********"
    , [CoreBndr] -> Doc
forall a. Outputable a => a -> Doc
pprDoc ([CoreBndr] -> Doc) -> [CoreBndr] -> Doc
forall a b. (a -> b) -> a -> b
$ GhcSrc -> [CoreBndr]
_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 -> [Char]
show = TargetInfo -> [Char]
forall a. PPrint a => a -> [Char]
showpp

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

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