{-# LANGUAGE CPP                       #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE TupleSections             #-}
{-# LANGUAGE TypeSynonymInstances      #-}
{-# LANGUAGE UndecidableInstances      #-}
{-# LANGUAGE ViewPatterns              #-}
{-# LANGUAGE PatternSynonyms           #-}

-- | This module contains a wrappers and utility functions for
-- accessing GHC module information. It should NEVER depend on
-- ANY module inside the Language.Haskell.Liquid.* tree.

module Language.Haskell.Liquid.GHC.Misc where

import           Data.String
import qualified Data.List as L
import           PrelNames                                  (fractionalClassKeys)
import           Debug.Trace

import qualified CoreUtils
import qualified DataCon                                    -- (dataConInstArgTys, isTupleDataCon)
import           Prelude                                    hiding (error)
import           CoreSyn                                    hiding (Expr, sourceName)
import qualified CoreSyn                                    as Core
import           CostCentre
import           Language.Haskell.Liquid.GHC.API            as Ghc hiding (L, sourceName)
import           Bag
import           CoreLint
import           CoreMonad

import           Text.Parsec.Pos                            (incSourceColumn, sourceName, sourceLine, sourceColumn, newPos)

import           Finder                                     (findImportedModule, cannotFindModule)
import           Panic                                      (throwGhcException)
import           TcRnDriver
-- import           TcRnTypes


import           IdInfo
import qualified TyCon                                      as TC
import           Data.Char                                  (isLower, isSpace, isUpper)
import           Data.Maybe                                 (isJust, fromMaybe, fromJust)
import           Data.Hashable
import qualified Data.HashSet                               as S

import qualified Data.Text.Encoding.Error                   as TE
import qualified Data.Text.Encoding                         as T
import qualified Data.Text                                  as T
import           Control.Arrow                              (second)
import           Control.Monad                              ((>=>))
import           Outputable                                 (Outputable (..), text, ppr)
import qualified Outputable                                 as Out
import qualified Text.PrettyPrint.HughesPJ                  as PJ
import           Language.Fixpoint.Types                    hiding (L, panic, Loc (..), SrcSpan, Constant, SESearch (..))
import qualified Language.Fixpoint.Types                    as F
import           Language.Fixpoint.Misc                     (safeHead) -- , safeLast, safeInit)
import           Language.Haskell.Liquid.Misc               (keyDiff) 
import           Control.DeepSeq
import           Language.Haskell.Liquid.Types.Errors


isAnonBinder :: TC.TyConBinder -> Bool
isAnonBinder :: TyConBinder -> Bool
isAnonBinder (Bndr TyVar
_ (AnonTCB AnonArgFlag
_)) = Bool
True
isAnonBinder (Bndr TyVar
_ TyConBndrVis
_)           = Bool
False

mkAlive :: Var -> Id
mkAlive :: TyVar -> TyVar
mkAlive TyVar
x
  | TyVar -> Bool
isId TyVar
x Bool -> Bool -> Bool
&& OccInfo -> Bool
isDeadOcc (TyVar -> OccInfo
idOccInfo TyVar
x)
  = TyVar -> IdInfo -> TyVar
setIdInfo TyVar
x (IdInfo -> OccInfo -> IdInfo
setOccInfo (HasDebugCallStack => TyVar -> IdInfo
TyVar -> IdInfo
idInfo TyVar
x) OccInfo
noOccInfo)
  | Bool
otherwise
  = TyVar
x


--------------------------------------------------------------------------------
-- | Encoding and Decoding Location --------------------------------------------
--------------------------------------------------------------------------------
srcSpanTick :: Module -> SrcSpan -> Tickish a
srcSpanTick :: Module -> SrcSpan -> Tickish a
srcSpanTick Module
m SrcSpan
sp = CostCentre -> Bool -> Bool -> Tickish a
forall id. CostCentre -> Bool -> Bool -> Tickish id
ProfNote (Module -> SrcSpan -> CostCentre
AllCafsCC Module
m SrcSpan
sp) Bool
False Bool
True

tickSrcSpan ::  Outputable a => Tickish a -> SrcSpan
tickSrcSpan :: Tickish a -> SrcSpan
tickSrcSpan (ProfNote CostCentre
cc Bool
_ Bool
_) = CostCentre -> SrcSpan
cc_loc CostCentre
cc
tickSrcSpan (SourceNote RealSrcSpan
ss String
_) = RealSrcSpan -> SrcSpan
RealSrcSpan RealSrcSpan
ss
tickSrcSpan Tickish a
_                 = SrcSpan
noSrcSpan

--------------------------------------------------------------------------------
-- | Generic Helpers for Accessing GHC Innards ---------------------------------
--------------------------------------------------------------------------------

-- FIXME: reusing uniques like this is really dangerous
stringTyVar :: String -> TyVar
stringTyVar :: String -> TyVar
stringTyVar String
s = Name -> Kind -> TyVar
mkTyVar Name
name Kind
liftedTypeKind
  where 
    name :: Name
name      = Unique -> OccName -> SrcSpan -> Name
mkInternalName (Char -> Int -> Unique
mkUnique Char
'x' Int
24)  OccName
occ SrcSpan
noSrcSpan
    occ :: OccName
occ       = String -> OccName
mkTyVarOcc String
s

-- FIXME: reusing uniques like this is really dangerous
stringVar :: String -> Type -> Var
stringVar :: String -> Kind -> TyVar
stringVar String
s Kind
t = IdDetails -> Name -> Kind -> IdInfo -> TyVar
mkLocalVar IdDetails
VanillaId Name
name Kind
t IdInfo
vanillaIdInfo
   where
      name :: Name
name = Unique -> OccName -> SrcSpan -> Name
mkInternalName (Char -> Int -> Unique
mkUnique Char
'x' Int
25) OccName
occ SrcSpan
noSrcSpan
      occ :: OccName
occ  = String -> OccName
mkVarOcc String
s

stringTyCon :: Char -> Int -> String -> TyCon
stringTyCon :: Char -> Int -> String -> TyCon
stringTyCon = Kind -> Char -> Int -> String -> TyCon
stringTyConWithKind Kind
anyTy

-- FIXME: reusing uniques like this is really dangerous
stringTyConWithKind :: Kind -> Char -> Int -> String -> TyCon
stringTyConWithKind :: Kind -> Char -> Int -> String -> TyCon
stringTyConWithKind Kind
k Char
c Int
n String
s = Name -> [TyConBinder] -> Kind -> [Role] -> Name -> TyCon
TC.mkKindTyCon Name
name [] Kind
k [] Name
name
  where
    name :: Name
name          = Unique -> OccName -> SrcSpan -> Name
mkInternalName (Char -> Int -> Unique
mkUnique Char
c Int
n) OccName
occ SrcSpan
noSrcSpan
    occ :: OccName
occ           = String -> OccName
mkTcOcc String
s

hasBaseTypeVar :: Var -> Bool
hasBaseTypeVar :: TyVar -> Bool
hasBaseTypeVar = Kind -> Bool
isBaseType (Kind -> Bool) -> (TyVar -> Kind) -> TyVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Kind
varType

-- same as Constraint isBase
isBaseType :: Type -> Bool
isBaseType :: Kind -> Bool
isBaseType (ForAllTy TyCoVarBinder
_ Kind
_)  = Bool
False
isBaseType (FunTy { ft_arg :: Kind -> Kind
ft_arg = Kind
t1, ft_res :: Kind -> Kind
ft_res = Kind
t2}) = Kind -> Bool
isBaseType Kind
t1 Bool -> Bool -> Bool
&& Kind -> Bool
isBaseType Kind
t2
isBaseType (TyVarTy TyVar
_)     = Bool
True
isBaseType (TyConApp TyCon
_ [Kind]
ts) = (Kind -> Bool) -> [Kind] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Kind -> Bool
isBaseType [Kind]
ts
isBaseType (AppTy Kind
t1 Kind
t2)   = Kind -> Bool
isBaseType Kind
t1 Bool -> Bool -> Bool
&& Kind -> Bool
isBaseType Kind
t2
isBaseType Kind
_               = Bool
False

isTmpVar :: Var -> Bool 
isTmpVar :: TyVar -> Bool
isTmpVar = Symbol -> Bool
isTmpSymbol (Symbol -> Bool) -> (TyVar -> Symbol) -> TyVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Symbol
dropModuleNamesAndUnique (Symbol -> Symbol) -> (TyVar -> Symbol) -> TyVar -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Symbol
forall a. Symbolic a => a -> Symbol
symbol 

isTmpSymbol    :: Symbol -> Bool
isTmpSymbol :: Symbol -> Bool
isTmpSymbol Symbol
x  = (Symbol -> Bool) -> [Symbol] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Symbol -> Symbol -> Bool
`isPrefixOfSym` Symbol
x) [Symbol
anfPrefix, Symbol
tempPrefix, Symbol
"ds_"]

validTyVar :: String -> Bool
validTyVar :: String -> Bool
validTyVar s :: String
s@(Char
c:String
_) = Char -> Bool
isLower Char
c Bool -> Bool -> Bool
&& (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) String
s
validTyVar String
_       = Bool
False

tvId :: TyVar -> String
tvId :: TyVar -> String
tvId TyVar
α = {- traceShow ("tvId: α = " ++ show α) $ -} TyVar -> String
forall a. Outputable a => a -> String
showPpr TyVar
α String -> String -> String
forall a. [a] -> [a] -> [a]
++ Unique -> String
forall a. Show a => a -> String
show (TyVar -> Unique
varUnique TyVar
α)

tidyCBs :: [CoreBind] -> [CoreBind]
tidyCBs :: [CoreBind] -> [CoreBind]
tidyCBs = (CoreBind -> CoreBind) -> [CoreBind] -> [CoreBind]
forall a b. (a -> b) -> [a] -> [b]
map CoreBind -> CoreBind
unTick

unTick :: CoreBind -> CoreBind
unTick :: CoreBind -> CoreBind
unTick (NonRec TyVar
b Expr TyVar
e) = TyVar -> Expr TyVar -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec TyVar
b (Expr TyVar -> Expr TyVar
unTickExpr Expr TyVar
e)
unTick (Rec [(TyVar, Expr TyVar)]
bs)     = [(TyVar, Expr TyVar)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ([(TyVar, Expr TyVar)] -> CoreBind)
-> [(TyVar, Expr TyVar)] -> CoreBind
forall a b. (a -> b) -> a -> b
$ ((TyVar, Expr TyVar) -> (TyVar, Expr TyVar))
-> [(TyVar, Expr TyVar)] -> [(TyVar, Expr TyVar)]
forall a b. (a -> b) -> [a] -> [b]
map ((Expr TyVar -> Expr TyVar)
-> (TyVar, Expr TyVar) -> (TyVar, Expr TyVar)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Expr TyVar -> Expr TyVar
unTickExpr) [(TyVar, Expr TyVar)]
bs

unTickExpr :: CoreExpr -> CoreExpr
unTickExpr :: Expr TyVar -> Expr TyVar
unTickExpr (App Expr TyVar
e Expr TyVar
a)          = Expr TyVar -> Expr TyVar -> Expr TyVar
forall b. Expr b -> Expr b -> Expr b
App (Expr TyVar -> Expr TyVar
unTickExpr Expr TyVar
e) (Expr TyVar -> Expr TyVar
unTickExpr Expr TyVar
a)
unTickExpr (Lam TyVar
b Expr TyVar
e)          = TyVar -> Expr TyVar -> Expr TyVar
forall b. b -> Expr b -> Expr b
Lam TyVar
b (Expr TyVar -> Expr TyVar
unTickExpr Expr TyVar
e)
unTickExpr (Let CoreBind
b Expr TyVar
e)          = CoreBind -> Expr TyVar -> Expr TyVar
forall b. Bind b -> Expr b -> Expr b
Let (CoreBind -> CoreBind
unTick CoreBind
b) (Expr TyVar -> Expr TyVar
unTickExpr Expr TyVar
e)
unTickExpr (Case Expr TyVar
e TyVar
b Kind
t [Alt TyVar]
as)    = Expr TyVar -> TyVar -> Kind -> [Alt TyVar] -> Expr TyVar
forall b. Expr b -> b -> Kind -> [Alt b] -> Expr b
Case (Expr TyVar -> Expr TyVar
unTickExpr Expr TyVar
e) TyVar
b Kind
t ((Alt TyVar -> Alt TyVar) -> [Alt TyVar] -> [Alt TyVar]
forall a b. (a -> b) -> [a] -> [b]
map Alt TyVar -> Alt TyVar
forall a b. (a, b, Expr TyVar) -> (a, b, Expr TyVar)
unTickAlt [Alt TyVar]
as)
    where unTickAlt :: (a, b, Expr TyVar) -> (a, b, Expr TyVar)
unTickAlt (a
a, b
b, Expr TyVar
e) = (a
a, b
b, Expr TyVar -> Expr TyVar
unTickExpr Expr TyVar
e)
unTickExpr (Cast Expr TyVar
e Coercion
c)         = Expr TyVar -> Coercion -> Expr TyVar
forall b. Expr b -> Coercion -> Expr b
Cast (Expr TyVar -> Expr TyVar
unTickExpr Expr TyVar
e) Coercion
c
unTickExpr (Tick Tickish TyVar
_ Expr TyVar
e)         = Expr TyVar -> Expr TyVar
unTickExpr Expr TyVar
e
unTickExpr Expr TyVar
x                  = Expr TyVar
x

isFractionalClass :: Class -> Bool
isFractionalClass :: Class -> Bool
isFractionalClass Class
clas = Class -> Unique
classKey Class
clas Unique -> [Unique] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Unique]
fractionalClassKeys

--------------------------------------------------------------------------------
-- | Pretty Printers -----------------------------------------------------------
--------------------------------------------------------------------------------
notracePpr :: Outputable a => String -> a -> a
notracePpr :: String -> a -> a
notracePpr String
_ a
x = a
x

tracePpr :: Outputable a => String -> a -> a
tracePpr :: String -> a -> a
tracePpr String
s a
x = String -> a -> a
forall a. String -> a -> a
trace (String
"\nTrace: [" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"] : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Outputable a => a -> String
showPpr a
x) a
x

pprShow :: Show a => a -> Out.SDoc
pprShow :: a -> SDoc
pprShow = String -> SDoc
text (String -> SDoc) -> (a -> String) -> a -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show


toFixSDoc :: Fixpoint a => a -> PJ.Doc
toFixSDoc :: a -> Doc
toFixSDoc = String -> Doc
PJ.text (String -> Doc) -> (a -> String) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
PJ.render (Doc -> String) -> (a -> Doc) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc
forall a. Fixpoint a => a -> Doc
toFix

sDocDoc :: Out.SDoc -> PJ.Doc
sDocDoc :: SDoc -> Doc
sDocDoc   = String -> Doc
PJ.text (String -> Doc) -> (SDoc -> String) -> SDoc -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> String
showSDoc

pprDoc :: Outputable a => a -> PJ.Doc
pprDoc :: a -> Doc
pprDoc    = SDoc -> Doc
sDocDoc (SDoc -> Doc) -> (a -> SDoc) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SDoc
forall a. Outputable a => a -> SDoc
ppr

-- Overriding Outputable functions because they now require DynFlags!
showPpr :: Outputable a => a -> String
showPpr :: a -> String
showPpr       = SDoc -> String
showSDoc (SDoc -> String) -> (a -> SDoc) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SDoc
forall a. Outputable a => a -> SDoc
ppr

-- FIXME: somewhere we depend on this printing out all GHC entities with
-- fully-qualified names...
showSDoc :: Out.SDoc -> String
showSDoc :: SDoc -> String
showSDoc SDoc
sdoc = DynFlags -> SDoc -> PprStyle -> String
Out.renderWithStyle DynFlags
unsafeGlobalDynFlags SDoc
sdoc (DynFlags -> PrintUnqualified -> Depth -> PprStyle
Out.mkUserStyle DynFlags
unsafeGlobalDynFlags PrintUnqualified
myQualify {- Out.alwaysQualify -} Depth
Out.AllTheWay)

myQualify :: Out.PrintUnqualified
myQualify :: PrintUnqualified
myQualify = PrintUnqualified
Out.neverQualify { queryQualifyName :: QueryQualifyName
Out.queryQualifyName = QueryQualifyName
Out.alwaysQualifyNames }
-- { Out.queryQualifyName = \_ _ -> Out.NameNotInScope1 }

showSDocDump :: Out.SDoc -> String
showSDocDump :: SDoc -> String
showSDocDump  = DynFlags -> SDoc -> String
Out.showSDocDump DynFlags
unsafeGlobalDynFlags

instance Outputable a => Outputable (S.HashSet a) where
  ppr :: HashSet a -> SDoc
ppr = [a] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([a] -> SDoc) -> (HashSet a -> [a]) -> HashSet a -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashSet a -> [a]
forall a. HashSet a -> [a]
S.toList

typeUniqueString :: Outputable a => a -> String
typeUniqueString :: a -> String
typeUniqueString = {- ("sort_" ++) . -} SDoc -> String
showSDocDump (SDoc -> String) -> (a -> SDoc) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SDoc
forall a. Outputable a => a -> SDoc
ppr


--------------------------------------------------------------------------------
-- | Manipulating Source Spans -------------------------------------------------
--------------------------------------------------------------------------------

newtype Loc    = L (Int, Int) deriving (Loc -> Loc -> Bool
(Loc -> Loc -> Bool) -> (Loc -> Loc -> Bool) -> Eq Loc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Loc -> Loc -> Bool
$c/= :: Loc -> Loc -> Bool
== :: Loc -> Loc -> Bool
$c== :: Loc -> Loc -> Bool
Eq, Eq Loc
Eq Loc
-> (Loc -> Loc -> Ordering)
-> (Loc -> Loc -> Bool)
-> (Loc -> Loc -> Bool)
-> (Loc -> Loc -> Bool)
-> (Loc -> Loc -> Bool)
-> (Loc -> Loc -> Loc)
-> (Loc -> Loc -> Loc)
-> Ord Loc
Loc -> Loc -> Bool
Loc -> Loc -> Ordering
Loc -> Loc -> Loc
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Loc -> Loc -> Loc
$cmin :: Loc -> Loc -> Loc
max :: Loc -> Loc -> Loc
$cmax :: Loc -> Loc -> Loc
>= :: Loc -> Loc -> Bool
$c>= :: Loc -> Loc -> Bool
> :: Loc -> Loc -> Bool
$c> :: Loc -> Loc -> Bool
<= :: Loc -> Loc -> Bool
$c<= :: Loc -> Loc -> Bool
< :: Loc -> Loc -> Bool
$c< :: Loc -> Loc -> Bool
compare :: Loc -> Loc -> Ordering
$ccompare :: Loc -> Loc -> Ordering
$cp1Ord :: Eq Loc
Ord, Int -> Loc -> String -> String
[Loc] -> String -> String
Loc -> String
(Int -> Loc -> String -> String)
-> (Loc -> String) -> ([Loc] -> String -> String) -> Show Loc
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Loc] -> String -> String
$cshowList :: [Loc] -> String -> String
show :: Loc -> String
$cshow :: Loc -> String
showsPrec :: Int -> Loc -> String -> String
$cshowsPrec :: Int -> Loc -> String -> String
Show)

instance Hashable Loc where
  hashWithSalt :: Int -> Loc -> Int
hashWithSalt Int
i (L (Int, Int)
z) = Int -> (Int, Int) -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
i (Int, Int)
z

--instance (Uniquable a) => Hashable a where

instance Hashable SrcSpan where
  hashWithSalt :: Int -> SrcSpan -> Int
hashWithSalt Int
i (UnhelpfulSpan FastString
s) = Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
i (FastString -> Int
uniq FastString
s)
  hashWithSalt Int
i (RealSrcSpan RealSrcSpan
s)   = Int -> (Int, Int, Int) -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
i (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
s, RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
s, RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
s)

fSrcSpan :: (F.Loc a) => a -> SrcSpan
fSrcSpan :: a -> SrcSpan
fSrcSpan = SrcSpan -> SrcSpan
fSrcSpanSrcSpan (SrcSpan -> SrcSpan) -> (a -> SrcSpan) -> a -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SrcSpan
forall a. Loc a => a -> SrcSpan
F.srcSpan

fSourcePos :: (F.Loc a) => a -> F.SourcePos 
fSourcePos :: a -> SourcePos
fSourcePos = SrcSpan -> SourcePos
F.sp_start (SrcSpan -> SourcePos) -> (a -> SrcSpan) -> a -> SourcePos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SrcSpan
forall a. Loc a => a -> SrcSpan
F.srcSpan 

fSrcSpanSrcSpan :: F.SrcSpan -> SrcSpan
fSrcSpanSrcSpan :: SrcSpan -> SrcSpan
fSrcSpanSrcSpan (F.SS SourcePos
p SourcePos
p') = SourcePos -> SourcePos -> SrcSpan
sourcePos2SrcSpan SourcePos
p SourcePos
p'

srcSpanFSrcSpan :: SrcSpan -> F.SrcSpan
srcSpanFSrcSpan :: SrcSpan -> SrcSpan
srcSpanFSrcSpan SrcSpan
sp = SourcePos -> SourcePos -> SrcSpan
F.SS SourcePos
p SourcePos
p'
  where
    p :: SourcePos
p              = SrcSpan -> SourcePos
srcSpanSourcePos SrcSpan
sp
    p' :: SourcePos
p'             = SrcSpan -> SourcePos
srcSpanSourcePosE SrcSpan
sp

sourcePos2SrcSpan :: SourcePos -> SourcePos -> SrcSpan
sourcePos2SrcSpan :: SourcePos -> SourcePos -> SrcSpan
sourcePos2SrcSpan SourcePos
p SourcePos
p' = RealSrcSpan -> SrcSpan
RealSrcSpan (RealSrcSpan -> SrcSpan) -> RealSrcSpan -> SrcSpan
forall a b. (a -> b) -> a -> b
$ String -> Int -> Int -> Int -> Int -> RealSrcSpan
realSrcSpan String
f Int
l Int
c Int
l' Int
c'
  where
    (String
f, Int
l,  Int
c)         = SourcePos -> (String, Int, Int)
F.sourcePosElts SourcePos
p
    (String
_, Int
l', Int
c')        = SourcePos -> (String, Int, Int)
F.sourcePosElts SourcePos
p'

sourcePosSrcSpan   :: SourcePos -> SrcSpan
sourcePosSrcSpan :: SourcePos -> SrcSpan
sourcePosSrcSpan SourcePos
p = SourcePos -> SourcePos -> SrcSpan
sourcePos2SrcSpan SourcePos
p (SourcePos -> Int -> SourcePos
incSourceColumn SourcePos
p Int
1)

sourcePosSrcLoc    :: SourcePos -> SrcLoc
sourcePosSrcLoc :: SourcePos -> SrcLoc
sourcePosSrcLoc SourcePos
p = FastString -> Int -> Int -> SrcLoc
mkSrcLoc (String -> FastString
fsLit String
file) Int
line Int
col
  where
    file :: String
file          = SourcePos -> String
sourceName SourcePos
p
    line :: Int
line          = SourcePos -> Int
sourceLine SourcePos
p
    col :: Int
col           = SourcePos -> Int
sourceColumn SourcePos
p

srcSpanSourcePos :: SrcSpan -> SourcePos
srcSpanSourcePos :: SrcSpan -> SourcePos
srcSpanSourcePos (UnhelpfulSpan FastString
_) = String -> SourcePos
dummyPos String
"<no source information>"
srcSpanSourcePos (RealSrcSpan RealSrcSpan
s)   = RealSrcSpan -> SourcePos
realSrcSpanSourcePos RealSrcSpan
s

srcSpanSourcePosE :: SrcSpan -> SourcePos
srcSpanSourcePosE :: SrcSpan -> SourcePos
srcSpanSourcePosE (UnhelpfulSpan FastString
_) = String -> SourcePos
dummyPos String
"<no source information>"
srcSpanSourcePosE (RealSrcSpan RealSrcSpan
s)   = RealSrcSpan -> SourcePos
realSrcSpanSourcePosE RealSrcSpan
s

srcSpanFilename :: SrcSpan -> String
srcSpanFilename :: SrcSpan -> String
srcSpanFilename    = String -> (FastString -> String) -> Maybe FastString -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" FastString -> String
unpackFS (Maybe FastString -> String)
-> (SrcSpan -> Maybe FastString) -> SrcSpan -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Maybe FastString
srcSpanFileName_maybe

srcSpanStartLoc :: RealSrcSpan -> Loc
srcSpanStartLoc :: RealSrcSpan -> Loc
srcSpanStartLoc RealSrcSpan
l  = (Int, Int) -> Loc
L (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
l, RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
l)

srcSpanEndLoc :: RealSrcSpan -> Loc
srcSpanEndLoc :: RealSrcSpan -> Loc
srcSpanEndLoc RealSrcSpan
l    = (Int, Int) -> Loc
L (RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
l, RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
l)


oneLine :: RealSrcSpan -> Bool
oneLine :: RealSrcSpan -> Bool
oneLine RealSrcSpan
l          = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
l

lineCol :: RealSrcSpan -> (Int, Int)
lineCol :: RealSrcSpan -> (Int, Int)
lineCol RealSrcSpan
l          = (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
l, RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
l)

realSrcSpanSourcePos :: RealSrcSpan -> SourcePos
realSrcSpanSourcePos :: RealSrcSpan -> SourcePos
realSrcSpanSourcePos RealSrcSpan
s = String -> Int -> Int -> SourcePos
newPos String
file Int
line Int
col
  where
    file :: String
file               = FastString -> String
unpackFS (FastString -> String) -> FastString -> String
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
s
    line :: Int
line               = RealSrcSpan -> Int
srcSpanStartLine       RealSrcSpan
s
    col :: Int
col                = RealSrcSpan -> Int
srcSpanStartCol        RealSrcSpan
s


realSrcSpanSourcePosE :: RealSrcSpan -> SourcePos
realSrcSpanSourcePosE :: RealSrcSpan -> SourcePos
realSrcSpanSourcePosE RealSrcSpan
s = String -> Int -> Int -> SourcePos
newPos String
file Int
line Int
col
  where
    file :: String
file                = FastString -> String
unpackFS (FastString -> String) -> FastString -> String
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
s
    line :: Int
line                = RealSrcSpan -> Int
srcSpanEndLine       RealSrcSpan
s
    col :: Int
col                 = RealSrcSpan -> Int
srcSpanEndCol        RealSrcSpan
s

getSourcePos :: NamedThing a => a -> SourcePos
getSourcePos :: a -> SourcePos
getSourcePos = SrcSpan -> SourcePos
srcSpanSourcePos  (SrcSpan -> SourcePos) -> (a -> SrcSpan) -> a -> SourcePos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan

getSourcePosE :: NamedThing a => a -> SourcePos
getSourcePosE :: a -> SourcePos
getSourcePosE = SrcSpan -> SourcePos
srcSpanSourcePosE (SrcSpan -> SourcePos) -> (a -> SrcSpan) -> a -> SourcePos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan

locNamedThing :: NamedThing a => a -> F.Located a
locNamedThing :: a -> Located a
locNamedThing a
x = SourcePos -> SourcePos -> a -> Located a
forall a. SourcePos -> SourcePos -> a -> Located a
F.Loc SourcePos
l SourcePos
lE a
x
  where
    l :: SourcePos
l          = a -> SourcePos
forall a. NamedThing a => a -> SourcePos
getSourcePos  a
x
    lE :: SourcePos
lE         = a -> SourcePos
forall a. NamedThing a => a -> SourcePos
getSourcePosE a
x

instance F.Loc Var where 
  srcSpan :: TyVar -> SrcSpan
srcSpan TyVar
v = SourcePos -> SourcePos -> SrcSpan
SS (TyVar -> SourcePos
forall a. NamedThing a => a -> SourcePos
getSourcePos TyVar
v) (TyVar -> SourcePos
forall a. NamedThing a => a -> SourcePos
getSourcePosE TyVar
v) 

namedLocSymbol :: (F.Symbolic a, NamedThing a) => a -> F.Located F.Symbol
namedLocSymbol :: a -> Located Symbol
namedLocSymbol a
d = a -> Symbol
forall a. Symbolic a => a -> Symbol
F.symbol (a -> Symbol) -> Located a -> Located Symbol
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Located a
forall a. NamedThing a => a -> Located a
locNamedThing a
d

varLocInfo :: (Type -> a) -> Var -> F.Located a
varLocInfo :: (Kind -> a) -> TyVar -> Located a
varLocInfo Kind -> a
f TyVar
x = Kind -> a
f (Kind -> a) -> (TyVar -> Kind) -> TyVar -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Kind
varType (TyVar -> a) -> Located TyVar -> Located a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVar -> Located TyVar
forall a. NamedThing a => a -> Located a
locNamedThing TyVar
x

namedPanic :: (NamedThing a) => a -> String -> b
namedPanic :: a -> String -> b
namedPanic a
x String
msg = Maybe SrcSpan -> String -> b
forall a. Maybe SrcSpan -> String -> a
panic (SrcSpan -> Maybe SrcSpan
forall a. a -> Maybe a
Just (a -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan a
x)) String
msg

--------------------------------------------------------------------------------
-- | Manipulating CoreExpr -----------------------------------------------------
--------------------------------------------------------------------------------

collectArguments :: Int -> CoreExpr -> [Var]
collectArguments :: Int -> Expr TyVar -> [TyVar]
collectArguments Int
n Expr TyVar
e = if [TyVar] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyVar]
xs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n then Int -> [TyVar] -> [TyVar]
forall a. Int -> [a] -> [a]
take Int
n [TyVar]
xs else [TyVar]
xs
  where
    ([TyVar]
vs', Expr TyVar
e')        = Expr TyVar -> ([TyVar], Expr TyVar)
collectValBinders' (Expr TyVar -> ([TyVar], Expr TyVar))
-> Expr TyVar -> ([TyVar], Expr TyVar)
forall a b. (a -> b) -> a -> b
$ ([TyVar], Expr TyVar) -> Expr TyVar
forall a b. (a, b) -> b
snd (([TyVar], Expr TyVar) -> Expr TyVar)
-> ([TyVar], Expr TyVar) -> Expr TyVar
forall a b. (a -> b) -> a -> b
$ Expr TyVar -> ([TyVar], Expr TyVar)
collectTyBinders Expr TyVar
e
    vs :: [TyVar]
vs               = ([TyVar], Expr TyVar) -> [TyVar]
forall a b. (a, b) -> a
fst (([TyVar], Expr TyVar) -> [TyVar])
-> ([TyVar], Expr TyVar) -> [TyVar]
forall a b. (a -> b) -> a -> b
$ Expr TyVar -> ([TyVar], Expr TyVar)
forall b. Expr b -> ([b], Expr b)
collectBinders (Expr TyVar -> ([TyVar], Expr TyVar))
-> Expr TyVar -> ([TyVar], Expr TyVar)
forall a b. (a -> b) -> a -> b
$ Expr TyVar -> Expr TyVar
forall t. Expr t -> Expr t
ignoreLetBinds Expr TyVar
e'
    xs :: [TyVar]
xs               = [TyVar]
vs' [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
vs

{-
collectTyBinders :: CoreExpr -> ([Var], CoreExpr)
collectTyBinders expr
  = go [] expr
  where
    go tvs (Lam b e) | isTyVar b = go (b:tvs) e
    go tvs e                     = (reverse tvs, e)
-}

collectValBinders' :: Core.Expr Var -> ([Var], Core.Expr Var)
collectValBinders' :: Expr TyVar -> ([TyVar], Expr TyVar)
collectValBinders' = [TyVar] -> Expr TyVar -> ([TyVar], Expr TyVar)
go []
  where
    go :: [TyVar] -> Expr TyVar -> ([TyVar], Expr TyVar)
go [TyVar]
tvs (Lam TyVar
b Expr TyVar
e) | TyVar -> Bool
isTyVar TyVar
b = [TyVar] -> Expr TyVar -> ([TyVar], Expr TyVar)
go [TyVar]
tvs     Expr TyVar
e
    go [TyVar]
tvs (Lam TyVar
b Expr TyVar
e) | TyVar -> Bool
isId    TyVar
b = [TyVar] -> Expr TyVar -> ([TyVar], Expr TyVar)
go (TyVar
bTyVar -> [TyVar] -> [TyVar]
forall a. a -> [a] -> [a]
:[TyVar]
tvs) Expr TyVar
e
    go [TyVar]
tvs (Tick Tickish TyVar
_ Expr TyVar
e)            = [TyVar] -> Expr TyVar -> ([TyVar], Expr TyVar)
go [TyVar]
tvs Expr TyVar
e
    go [TyVar]
tvs Expr TyVar
e                     = ([TyVar] -> [TyVar]
forall a. [a] -> [a]
reverse [TyVar]
tvs, Expr TyVar
e)

ignoreLetBinds :: Core.Expr t -> Core.Expr t
ignoreLetBinds :: Expr t -> Expr t
ignoreLetBinds (Let (NonRec t
_ Expr t
_) Expr t
e')
  = Expr t -> Expr t
forall t. Expr t -> Expr t
ignoreLetBinds Expr t
e'
ignoreLetBinds Expr t
e
  = Expr t
e

--------------------------------------------------------------------------------
-- | Predicates on CoreExpr and DataCons ---------------------------------------
--------------------------------------------------------------------------------

isTupleId :: Id -> Bool
isTupleId :: TyVar -> Bool
isTupleId = Bool -> (DataCon -> Bool) -> Maybe DataCon -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False DataCon -> Bool
DataCon.isTupleDataCon (Maybe DataCon -> Bool)
-> (TyVar -> Maybe DataCon) -> TyVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Maybe DataCon
idDataConM

idDataConM :: Id -> Maybe DataCon
idDataConM :: TyVar -> Maybe DataCon
idDataConM TyVar
x = case TyVar -> IdDetails
idDetails TyVar
x of
  DataConWorkId DataCon
d -> DataCon -> Maybe DataCon
forall a. a -> Maybe a
Just DataCon
d
  DataConWrapId DataCon
d -> DataCon -> Maybe DataCon
forall a. a -> Maybe a
Just DataCon
d
  IdDetails
_               -> Maybe DataCon
forall a. Maybe a
Nothing 

isDataConId :: Id -> Bool
isDataConId :: TyVar -> Bool
isDataConId = Maybe DataCon -> Bool
forall a. Maybe a -> Bool
isJust (Maybe DataCon -> Bool)
-> (TyVar -> Maybe DataCon) -> TyVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Maybe DataCon
idDataConM

getDataConVarUnique :: Var -> Unique
getDataConVarUnique :: TyVar -> Unique
getDataConVarUnique TyVar
v
  | TyVar -> Bool
isId TyVar
v Bool -> Bool -> Bool
&& TyVar -> Bool
isDataConId TyVar
v = DataCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique (TyVar -> DataCon
idDataCon TyVar
v)
  | Bool
otherwise               = TyVar -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyVar
v

isDictionaryExpression :: Core.Expr Id -> Maybe Id
isDictionaryExpression :: Expr TyVar -> Maybe TyVar
isDictionaryExpression (Tick Tickish TyVar
_ Expr TyVar
e) = Expr TyVar -> Maybe TyVar
isDictionaryExpression Expr TyVar
e
isDictionaryExpression (Var TyVar
x)    | TyVar -> Bool
forall a. Symbolic a => a -> Bool
isDictionary TyVar
x = TyVar -> Maybe TyVar
forall a. a -> Maybe a
Just TyVar
x
isDictionaryExpression Expr TyVar
_          = Maybe TyVar
forall a. Maybe a
Nothing

realTcArity :: TyCon -> Arity
realTcArity :: TyCon -> Int
realTcArity = TyCon -> Int
tyConArity

{-
  tracePpr ("realTcArity of " ++ showPpr c
     ++ "\n tyConKind = " ++ showPpr (tyConKind c)
     ++ "\n kindArity = " ++ show (kindArity (tyConKind c))
     ++ "\n kindArity' = " ++ show (kindArity' (tyConKind c)) -- this works for TypeAlias
     ) $ kindArity' (tyConKind c)
-}

kindTCArity :: TyCon -> Arity
kindTCArity :: TyCon -> Int
kindTCArity = Kind -> Int
forall p. Num p => Kind -> p
go (Kind -> Int) -> (TyCon -> Kind) -> TyCon -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> Kind
tyConKind
  where
    go :: Kind -> p
go (FunTy { ft_res :: Kind -> Kind
ft_res = Kind
res}) = p
1 p -> p -> p
forall a. Num a => a -> a -> a
+ Kind -> p
go Kind
res
    go Kind
_               = p
0


kindArity :: Kind -> Arity
kindArity :: Kind -> Int
kindArity (ForAllTy TyCoVarBinder
_ Kind
res)
  = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Kind -> Int
kindArity Kind
res
kindArity Kind
_
  = Int
0

uniqueHash :: Uniquable a => Int -> a -> Int
uniqueHash :: Int -> a -> Int
uniqueHash Int
i = Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
i (Int -> Int) -> (a -> Int) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique -> Int
getKey (Unique -> Int) -> (a -> Unique) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Unique
forall a. Uniquable a => a -> Unique
getUnique

-- slightly modified version of DynamicLoading.lookupRdrNameInModule
lookupRdrName :: HscEnv -> ModuleName -> RdrName -> IO (Maybe Name)
lookupRdrName :: HscEnv -> ModuleName -> RdrName -> IO (Maybe Name)
lookupRdrName HscEnv
hsc_env ModuleName
mod_name RdrName
rdr_name = do
    -- First find the package the module resides in by searching exposed packages and home modules
    FindResult
found_module <- HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
mod_name Maybe FastString
forall a. Maybe a
Nothing
    case FindResult
found_module of
        Found ModLocation
_ Module
mod -> do
            -- Find the exports of the module
            (Messages
_, Maybe ModIface
mb_iface) <- HscEnv -> Module -> IO (Messages, Maybe ModIface)
getModuleInterface HscEnv
hsc_env Module
mod
            case Maybe ModIface
mb_iface of
                Just ModIface
iface -> do
                    -- Try and find the required name in the exports
                    let decl_spec :: ImpDeclSpec
decl_spec = ImpDeclSpec :: ModuleName -> ModuleName -> Bool -> SrcSpan -> ImpDeclSpec
ImpDeclSpec { is_mod :: ModuleName
is_mod = ModuleName
mod_name, is_as :: ModuleName
is_as = ModuleName
mod_name
                                                , is_qual :: Bool
is_qual = Bool
False, is_dloc :: SrcSpan
is_dloc = SrcSpan
noSrcSpan }
                        provenance :: Maybe ImportSpec
provenance = ImportSpec -> Maybe ImportSpec
forall a. a -> Maybe a
Just (ImportSpec -> Maybe ImportSpec) -> ImportSpec -> Maybe ImportSpec
forall a b. (a -> b) -> a -> b
$ ImpDeclSpec -> ImpItemSpec -> ImportSpec
ImpSpec ImpDeclSpec
decl_spec ImpItemSpec
ImpAll
                        env :: GlobalRdrEnv
env = case ModIface -> Maybe GlobalRdrEnv
forall (phase :: ModIfacePhase).
ModIface_ phase -> Maybe GlobalRdrEnv
mi_globals ModIface
iface of
                                Maybe GlobalRdrEnv
Nothing -> [GlobalRdrElt] -> GlobalRdrEnv
mkGlobalRdrEnv (Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt]
gresFromAvails Maybe ImportSpec
provenance (ModIface -> [AvailInfo]
forall (phase :: ModIfacePhase). ModIface_ phase -> [AvailInfo]
mi_exports ModIface
iface))
                                Just GlobalRdrEnv
e -> GlobalRdrEnv
e
                    case RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
lookupGRE_RdrName RdrName
rdr_name GlobalRdrEnv
env of
                        [GlobalRdrElt
gre] -> Maybe Name -> IO (Maybe Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Maybe Name
forall a. a -> Maybe a
Just (GlobalRdrElt -> Name
gre_name GlobalRdrElt
gre))
                        []    -> Maybe Name -> IO (Maybe Name)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Name
forall a. Maybe a
Nothing
                        [GlobalRdrElt]
_     -> String -> IO (Maybe Name)
forall a. String -> a
Out.panic String
"lookupRdrNameInModule"
                Maybe ModIface
Nothing -> DynFlags -> SDoc -> IO (Maybe Name)
forall c. DynFlags -> SDoc -> c
throwCmdLineErrorS DynFlags
dflags (SDoc -> IO (Maybe Name)) -> SDoc -> IO (Maybe Name)
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
Out.hsep [PtrString -> SDoc
Out.ptext (String -> PtrString
sLit String
"Could not determine the exports of the module"), ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
mod_name]
        FindResult
err -> DynFlags -> SDoc -> IO (Maybe Name)
forall c. DynFlags -> SDoc -> c
throwCmdLineErrorS DynFlags
dflags (SDoc -> IO (Maybe Name)) -> SDoc -> IO (Maybe Name)
forall a b. (a -> b) -> a -> b
$ DynFlags -> ModuleName -> FindResult -> SDoc
cannotFindModule DynFlags
dflags ModuleName
mod_name FindResult
err
  where dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        throwCmdLineErrorS :: DynFlags -> SDoc -> c
throwCmdLineErrorS DynFlags
dflags = String -> c
forall a. String -> a
throwCmdLineError (String -> c) -> (SDoc -> String) -> SDoc -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> SDoc -> String
Out.showSDoc DynFlags
dflags
        throwCmdLineError :: String -> c
throwCmdLineError = GhcException -> c
forall a. GhcException -> a
throwGhcException (GhcException -> c) -> (String -> GhcException) -> String -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GhcException
CmdLineError

-- qualImportDecl :: ModuleName -> ImportDecl name
-- qualImportDecl mn = (simpleImportDecl mn) { ideclQualified = True }

ignoreInline :: ParsedModule -> ParsedModule
ignoreInline :: ParsedModule -> ParsedModule
ignoreInline ParsedModule
x = ParsedModule
x {pm_parsed_source :: ParsedSource
pm_parsed_source = HsModule GhcPs -> HsModule GhcPs
go (HsModule GhcPs -> HsModule GhcPs) -> ParsedSource -> ParsedSource
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsedModule -> ParsedSource
pm_parsed_source ParsedModule
x}
  where 
    go :: HsModule GhcPs -> HsModule GhcPs
    go :: HsModule GhcPs -> HsModule GhcPs
go  HsModule GhcPs
x      = HsModule GhcPs
x {hsmodDecls :: [LHsDecl GhcPs]
hsmodDecls = (LHsDecl GhcPs -> Bool) -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. (a -> Bool) -> [a] -> [a]
filter LHsDecl GhcPs -> Bool
go' (HsModule GhcPs -> [LHsDecl GhcPs]
forall pass. HsModule pass -> [LHsDecl pass]
hsmodDecls HsModule GhcPs
x) }
    go' :: LHsDecl GhcPs -> Bool
    go' :: LHsDecl GhcPs -> Bool
go' LHsDecl GhcPs
x 
      | SigD _ (InlineSig {}) <-  LHsDecl GhcPs -> SrcSpanLess (LHsDecl GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsDecl GhcPs
x = Bool
False
      | Bool
otherwise                         = Bool
True

--------------------------------------------------------------------------------
-- | Symbol Conversions --------------------------------------------------------
--------------------------------------------------------------------------------

symbolTyConWithKind :: Kind -> Char -> Int -> Symbol -> TyCon
symbolTyConWithKind :: Kind -> Char -> Int -> Symbol -> TyCon
symbolTyConWithKind Kind
k Char
x Int
i Symbol
n = Kind -> Char -> Int -> String -> TyCon
stringTyConWithKind Kind
k Char
x Int
i (Symbol -> String
symbolString Symbol
n)

symbolTyCon :: Char -> Int -> Symbol -> TyCon
symbolTyCon :: Char -> Int -> Symbol -> TyCon
symbolTyCon Char
x Int
i Symbol
n = Char -> Int -> String -> TyCon
stringTyCon Char
x Int
i (Symbol -> String
symbolString Symbol
n)

symbolTyVar :: Symbol -> TyVar
symbolTyVar :: Symbol -> TyVar
symbolTyVar = String -> TyVar
stringTyVar (String -> TyVar) -> (Symbol -> String) -> Symbol -> TyVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> String
symbolString

localVarSymbol ::  Var -> Symbol
localVarSymbol :: TyVar -> Symbol
localVarSymbol TyVar
v
  | Symbol
us Symbol -> Symbol -> Bool
`isSuffixOfSym` Symbol
vs = Symbol
vs
  | Bool
otherwise             = Symbol -> Symbol -> Symbol
suffixSymbol Symbol
vs Symbol
us
  where
    us :: Symbol
us                    = String -> Symbol
forall a. Symbolic a => a -> Symbol
symbol (String -> Symbol) -> String -> Symbol
forall a b. (a -> b) -> a -> b
$ Unique -> String
forall a. Outputable a => a -> String
showPpr (Unique -> String) -> Unique -> String
forall a b. (a -> b) -> a -> b
$ TyVar -> Unique
getDataConVarUnique TyVar
v
    vs :: Symbol
vs                    = TyVar -> Symbol
exportedVarSymbol TyVar
v 

exportedVarSymbol :: Var -> Symbol
exportedVarSymbol :: TyVar -> Symbol
exportedVarSymbol TyVar
x = String -> Symbol -> Symbol
forall a. PPrint a => String -> a -> a
notracepp String
msg (Symbol -> Symbol) -> (TyVar -> Symbol) -> TyVar -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Symbol
forall a. Symbolic a => a -> Symbol
symbol (Name -> Symbol) -> (TyVar -> Name) -> TyVar -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Name
forall a. NamedThing a => a -> Name
getName (TyVar -> Symbol) -> TyVar -> Symbol
forall a b. (a -> b) -> a -> b
$ TyVar
x            
  where 
    msg :: String
msg = String
"exportedVarSymbol: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TyVar -> String
forall a. Outputable a => a -> String
showPpr TyVar
x 

qualifiedNameSymbol :: Name -> Symbol
qualifiedNameSymbol :: Name -> Symbol
qualifiedNameSymbol Name
n = FastString -> Symbol
forall a. Symbolic a => a -> Symbol
symbol (FastString -> Symbol) -> FastString -> Symbol
forall a b. (a -> b) -> a -> b
$ [FastString] -> FastString
concatFS [FastString
modFS, FastString
occFS, FastString
uniqFS]
  where
  _msg :: String
_msg   = SDoc -> String
showSDoc (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n) -- getOccString n
  modFS :: FastString
modFS = case Name -> Maybe Module
nameModule_maybe Name
n of
            Maybe Module
Nothing -> String -> FastString
fsLit String
""
            Just Module
m  -> [FastString] -> FastString
concatFS [ModuleName -> FastString
moduleNameFS (Module -> ModuleName
moduleName Module
m), String -> FastString
fsLit String
"."]

  occFS :: FastString
occFS = OccName -> FastString
occNameFS (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
n)
  uniqFS :: FastString
uniqFS
    | Name -> Bool
isSystemName Name
n
    = [FastString] -> FastString
concatFS [String -> FastString
fsLit String
"_",  String -> FastString
fsLit (Unique -> String
forall a. Outputable a => a -> String
showPpr (Name -> Unique
forall a. Uniquable a => a -> Unique
getUnique Name
n))]
    | Bool
otherwise
    = String -> FastString
fsLit String
""

instance Symbolic FastString where
  symbol :: FastString -> Symbol
symbol = Text -> Symbol
forall a. Symbolic a => a -> Symbol
symbol (Text -> Symbol) -> (FastString -> Text) -> FastString -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> Text
fastStringText

fastStringText :: FastString -> T.Text
fastStringText :: FastString -> Text
fastStringText = OnDecodeError -> ByteString -> Text
T.decodeUtf8With OnDecodeError
TE.lenientDecode (ByteString -> Text)
-> (FastString -> ByteString) -> FastString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> ByteString
bytesFS

tyConTyVarsDef :: TyCon -> [TyVar]
tyConTyVarsDef :: TyCon -> [TyVar]
tyConTyVarsDef TyCon
c
  | TyCon -> Bool
noTyVars TyCon
c = []
  | Bool
otherwise  = TyCon -> [TyVar]
TC.tyConTyVars TyCon
c
  --where
  --  none         = tracepp ("tyConTyVarsDef: " ++ show c) (noTyVars c)

noTyVars :: TyCon -> Bool
noTyVars :: TyCon -> Bool
noTyVars TyCon
c =  (TyCon -> Bool
TC.isPrimTyCon TyCon
c Bool -> Bool -> Bool
|| TyCon -> Bool
isFunTyCon TyCon
c Bool -> Bool -> Bool
|| TyCon -> Bool
TC.isPromotedDataCon TyCon
c)

--------------------------------------------------------------------------------
-- | Symbol Instances
--------------------------------------------------------------------------------

instance Symbolic TyCon where
  symbol :: TyCon -> Symbol
symbol = Name -> Symbol
forall a. Symbolic a => a -> Symbol
symbol (Name -> Symbol) -> (TyCon -> Name) -> TyCon -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> Name
forall a. NamedThing a => a -> Name
getName

instance Symbolic Class where
  symbol :: Class -> Symbol
symbol = Name -> Symbol
forall a. Symbolic a => a -> Symbol
symbol (Name -> Symbol) -> (Class -> Name) -> Class -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> Name
forall a. NamedThing a => a -> Name
getName

instance Symbolic Name where
  symbol :: Name -> Symbol
symbol = Symbol -> Symbol
forall a. Symbolic a => a -> Symbol
symbol (Symbol -> Symbol) -> (Name -> Symbol) -> Name -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Symbol
qualifiedNameSymbol

-- | [NOTE:REFLECT-IMPORTS] we **eschew** the `unique` suffix for exported vars,
-- to make it possible to lookup names from symbols _across_ modules;
-- anyways exported names are top-level and you shouldn't have local binders
-- that shadow them. However, we **keep** the `unique` suffix for local variables,
-- as otherwise there are spurious, but extremely problematic, name collisions
-- in the fixpoint environment.

instance Symbolic Var where   -- TODO:reflect-datacons varSymbol
  symbol :: TyVar -> Symbol
symbol TyVar
v
    | TyVar -> Bool
isExportedId TyVar
v = TyVar -> Symbol
exportedVarSymbol TyVar
v
    | Bool
otherwise      = TyVar -> Symbol
localVarSymbol    TyVar
v


instance Hashable Var where
  hashWithSalt :: Int -> TyVar -> Int
hashWithSalt = Int -> TyVar -> Int
forall a. Uniquable a => Int -> a -> Int
uniqueHash

instance Hashable TyCon where
  hashWithSalt :: Int -> TyCon -> Int
hashWithSalt = Int -> TyCon -> Int
forall a. Uniquable a => Int -> a -> Int
uniqueHash

instance Hashable DataCon where
  hashWithSalt :: Int -> DataCon -> Int
hashWithSalt = Int -> DataCon -> Int
forall a. Uniquable a => Int -> a -> Int
uniqueHash

instance Fixpoint Var where
  toFix :: TyVar -> Doc
toFix = TyVar -> Doc
forall a. Outputable a => a -> Doc
pprDoc

instance Fixpoint Name where
  toFix :: Name -> Doc
toFix = Name -> Doc
forall a. Outputable a => a -> Doc
pprDoc

instance Fixpoint Type where
  toFix :: Kind -> Doc
toFix = Kind -> Doc
forall a. Outputable a => a -> Doc
pprDoc

instance Show Name where
  show :: Name -> String
show = Symbol -> String
symbolString (Symbol -> String) -> (Name -> Symbol) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Symbol
forall a. Symbolic a => a -> Symbol
symbol

instance Show Var where
  show :: TyVar -> String
show = Name -> String
forall a. Show a => a -> String
show (Name -> String) -> (TyVar -> Name) -> TyVar -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Name
forall a. NamedThing a => a -> Name
getName

instance Show Class where
  show :: Class -> String
show = Name -> String
forall a. Show a => a -> String
show (Name -> String) -> (Class -> Name) -> Class -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> Name
forall a. NamedThing a => a -> Name
getName

instance Show TyCon where
  show :: TyCon -> String
show = Name -> String
forall a. Show a => a -> String
show (Name -> String) -> (TyCon -> Name) -> TyCon -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> Name
forall a. NamedThing a => a -> Name
getName

instance NFData Class where
  rnf :: Class -> ()
rnf Class
t = Class -> () -> ()
seq Class
t ()

instance NFData TyCon where
  rnf :: TyCon -> ()
rnf TyCon
t = TyCon -> () -> ()
seq TyCon
t ()

instance NFData Type where
  rnf :: Kind -> ()
rnf Kind
t = Kind -> () -> ()
seq Kind
t ()

instance NFData Var where
  rnf :: TyVar -> ()
rnf TyVar
t = TyVar -> () -> ()
seq TyVar
t ()

--------------------------------------------------------------------------------
-- | Manipulating Symbols ------------------------------------------------------
--------------------------------------------------------------------------------

splitModuleName :: Symbol -> (Symbol, Symbol)
splitModuleName :: Symbol -> (Symbol, Symbol)
splitModuleName Symbol
x = (Symbol -> Symbol
takeModuleNames Symbol
x, Symbol -> Symbol
dropModuleNamesAndUnique Symbol
x)

dropModuleNamesAndUnique :: Symbol -> Symbol
dropModuleNamesAndUnique :: Symbol -> Symbol
dropModuleNamesAndUnique = Symbol -> Symbol
dropModuleUnique (Symbol -> Symbol) -> (Symbol -> Symbol) -> Symbol -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Symbol
dropModuleNames

dropModuleNames  :: Symbol -> Symbol
dropModuleNames :: Symbol -> Symbol
dropModuleNames = Symbol -> Symbol
dropModuleNamesCorrect 
{- 
dropModuleNames = mungeNames lastName sepModNames "dropModuleNames: "
 where
   lastName msg = symbol . safeLast msg
-}

dropModuleNamesCorrect  :: Symbol -> Symbol
dropModuleNamesCorrect :: Symbol -> Symbol
dropModuleNamesCorrect = Text -> Symbol
forall a. Symbolic a => a -> Symbol
F.symbol (Text -> Symbol) -> (Symbol -> Text) -> Symbol -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
go (Text -> Text) -> (Symbol -> Text) -> Symbol -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Text
F.symbolText
  where
    go :: Text -> Text
go Text
s = case Text -> Maybe (Char, Text)
T.uncons Text
s of
             Just (Char
c,Text
tl) -> if Char -> Bool
isUpper Char
c  Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') Text
tl
                              then Text -> Text
go (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ (Char, Text) -> Text
forall a b. (a, b) -> b
snd ((Char, Text) -> Text) -> (Char, Text) -> Text
forall a b. (a -> b) -> a -> b
$ Maybe (Char, Text) -> (Char, Text)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Char, Text) -> (Char, Text))
-> Maybe (Char, Text) -> (Char, Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe (Char, Text)
T.uncons (Text -> Maybe (Char, Text)) -> Text -> Maybe (Char, Text)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') Text
s
                              else Text
s
             Maybe (Char, Text)
Nothing -> Text
s

takeModuleNames  :: Symbol -> Symbol
takeModuleNames :: Symbol -> Symbol
takeModuleNames  = Text -> Symbol
forall a. Symbolic a => a -> Symbol
F.symbol (Text -> Symbol) -> (Symbol -> Text) -> Symbol -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text -> Text
go [] (Text -> Text) -> (Symbol -> Text) -> Symbol -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Text
F.symbolText
  where
    go :: [Text] -> Text -> Text
go [Text]
acc Text
s = case Text -> Maybe (Char, Text)
T.uncons Text
s of
                Just (Char
c,Text
tl) -> if Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') Text
tl
                                 then [Text] -> Text -> Text
go (Text -> Text
getModule Text
sText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
acc) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ (Char, Text) -> Text
forall a b. (a, b) -> b
snd ((Char, Text) -> Text) -> (Char, Text) -> Text
forall a b. (a -> b) -> a -> b
$ Maybe (Char, Text) -> (Char, Text)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Char, Text) -> (Char, Text))
-> Maybe (Char, Text) -> (Char, Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe (Char, Text)
T.uncons (Text -> Maybe (Char, Text)) -> Text -> Maybe (Char, Text)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') Text
s
                                 else Text -> [Text] -> Text
T.intercalate Text
"." ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
acc) 
                Maybe (Char, Text)
Nothing -> Text -> [Text] -> Text
T.intercalate Text
"." ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
acc) 
    getModule :: Text -> Text
getModule Text
s = (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') Text
s

{- 
takeModuleNamesOld  = mungeNames initName sepModNames "takeModuleNames: "
  where
    initName msg = symbol . T.intercalate "." . safeInit msg
-}
dropModuleUnique :: Symbol -> Symbol
dropModuleUnique :: Symbol -> Symbol
dropModuleUnique = (String -> [Text] -> Symbol) -> Text -> String -> Symbol -> Symbol
mungeNames String -> [Text] -> Symbol
forall a. Symbolic a => String -> ListNE a -> Symbol
headName Text
sepUnique   String
"dropModuleUnique: "
  where
    headName :: String -> ListNE a -> Symbol
headName String
msg = a -> Symbol
forall a. Symbolic a => a -> Symbol
symbol (a -> Symbol) -> (ListNE a -> a) -> ListNE a -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ListNE a -> a
forall a. HasCallStack => String -> ListNE a -> a
safeHead String
msg

cmpSymbol :: Symbol -> Symbol -> Bool
cmpSymbol :: Symbol -> Symbol -> Bool
cmpSymbol Symbol
coreSym Symbol
logicSym
  =  (Symbol -> Symbol
dropModuleUnique Symbol
coreSym Symbol -> Symbol -> Bool
forall a. Eq a => a -> a -> Bool
== Symbol -> Symbol
dropModuleNamesAndUnique Symbol
logicSym)
  Bool -> Bool -> Bool
|| (Symbol -> Symbol
dropModuleUnique Symbol
coreSym Symbol -> Symbol -> Bool
forall a. Eq a => a -> a -> Bool
== Symbol -> Symbol
dropModuleUnique         Symbol
logicSym)

sepModNames :: T.Text
sepModNames :: Text
sepModNames = Text
"."

sepUnique :: T.Text
sepUnique :: Text
sepUnique = Text
"#"

mungeNames :: (String -> [T.Text] -> Symbol) -> T.Text -> String -> Symbol -> Symbol
mungeNames :: (String -> [Text] -> Symbol) -> Text -> String -> Symbol -> Symbol
mungeNames String -> [Text] -> Symbol
_ Text
_ String
_ Symbol
""  = Symbol
""
mungeNames String -> [Text] -> Symbol
f Text
d String
msg s' :: Symbol
s'@(Symbol -> Text
symbolText -> Text
s)
  | Symbol
s' Symbol -> Symbol -> Bool
forall a. Eq a => a -> a -> Bool
== Symbol
tupConName = Symbol
tupConName
  | Bool
otherwise        = String -> [Text] -> Symbol
f (String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
s) ([Text] -> Symbol) -> [Text] -> Symbol
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn Text
d (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text
stripParens Text
s

qualifySymbol :: Symbol -> Symbol -> Symbol
qualifySymbol :: Symbol -> Symbol -> Symbol
qualifySymbol (Symbol -> Text
symbolText -> Text
m) x' :: Symbol
x'@(Symbol -> Text
symbolText -> Text
x)
  | Text -> Bool
isQualified Text
x  = Symbol
x'
  | Text -> Bool
isParened Text
x    = Text -> Symbol
forall a. Symbolic a => a -> Symbol
symbol (Text -> Text
forall a. (IsString a, Monoid a) => a -> a
wrapParens (Text
m Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
"." Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text -> Text
stripParens Text
x))
  | Bool
otherwise      = Text -> Symbol
forall a. Symbolic a => a -> Symbol
symbol (Text
m Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
"." Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
x)

isQualifiedSym :: Symbol -> Bool
isQualifiedSym :: Symbol -> Bool
isQualifiedSym (Symbol -> Text
symbolText -> Text
x) = Text -> Bool
isQualified Text
x 

isQualified :: T.Text -> Bool
isQualified :: Text -> Bool
isQualified Text
y = Text
"." Text -> Text -> Bool
`T.isInfixOf` Text
y

wrapParens :: (IsString a, Monoid a) => a -> a
wrapParens :: a -> a
wrapParens a
x  = a
"(" a -> a -> a
forall a. Monoid a => a -> a -> a
`mappend` a
x a -> a -> a
forall a. Monoid a => a -> a -> a
`mappend` a
")"

isParened :: T.Text -> Bool
isParened :: Text -> Bool
isParened Text
xs  = Text
xs Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> Text
stripParens Text
xs

isDictionary :: Symbolic a => a -> Bool
isDictionary :: a -> Bool
isDictionary = Symbol -> Symbol -> Bool
isPrefixOfSym Symbol
"$f" (Symbol -> Bool) -> (a -> Symbol) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Symbol
dropModuleNames (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

isMethod :: Symbolic a => a -> Bool
isMethod :: a -> Bool
isMethod = Symbol -> Symbol -> Bool
isPrefixOfSym Symbol
"$c" (Symbol -> Bool) -> (a -> Symbol) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Symbol
dropModuleNames (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

isInternal :: Symbolic a => a -> Bool
isInternal :: a -> Bool
isInternal   = Symbol -> Symbol -> Bool
isPrefixOfSym Symbol
"$"  (Symbol -> Bool) -> (a -> Symbol) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Symbol
dropModuleNames (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

isWorker :: Symbolic a => a -> Bool 
isWorker :: a -> Bool
isWorker a
s = String -> Bool -> Bool
forall a. PPrint a => String -> a -> a
notracepp (String
"isWorkerSym: s = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ss) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String
"$W" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isInfixOf` String
ss 
  where 
    ss :: String
ss     = Symbol -> String
symbolString (a -> Symbol
forall a. Symbolic a => a -> Symbol
symbol a
s)



stripParens :: T.Text -> T.Text
stripParens :: Text -> Text
stripParens Text
t = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
t (Text -> Maybe Text
strip Text
t)
  where
    strip :: Text -> Maybe Text
strip = Text -> Text -> Maybe Text
T.stripPrefix Text
"(" (Text -> Maybe Text) -> (Text -> Maybe Text) -> Text -> Maybe Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Text -> Text -> Maybe Text
T.stripSuffix Text
")"

stripParensSym :: Symbol -> Symbol
stripParensSym :: Symbol -> Symbol
stripParensSym (Symbol -> Text
symbolText -> Text
t) = Text -> Symbol
forall a. Symbolic a => a -> Symbol
symbol (Text -> Text
stripParens Text
t)

desugarModule :: TypecheckedModule -> Ghc DesugaredModule
desugarModule :: TypecheckedModule -> Ghc DesugaredModule
desugarModule TypecheckedModule
tcm = do
  let ms :: ModSummary
ms = ParsedModule -> ModSummary
pm_mod_summary (ParsedModule -> ModSummary) -> ParsedModule -> ModSummary
forall a b. (a -> b) -> a -> b
$ TypecheckedModule -> ParsedModule
tm_parsed_module TypecheckedModule
tcm
  -- let ms = modSummary tcm
  let (TcGblEnv
tcg, ModDetails
_) = TypecheckedModule -> (TcGblEnv, ModDetails)
tm_internals_ TypecheckedModule
tcm
  HscEnv
hsc_env <- Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  let hsc_env_tmp :: HscEnv
hsc_env_tmp = HscEnv
hsc_env { hsc_dflags :: DynFlags
hsc_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms }
  ModGuts
guts <- IO ModGuts -> Ghc ModGuts
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModGuts -> Ghc ModGuts) -> IO ModGuts -> Ghc ModGuts
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
hscDesugar{- WithLoc -} HscEnv
hsc_env_tmp ModSummary
ms TcGblEnv
tcg
  DesugaredModule -> Ghc DesugaredModule
forall (m :: * -> *) a. Monad m => a -> m a
return DesugaredModule :: TypecheckedModule -> ModGuts -> DesugaredModule
DesugaredModule { dm_typechecked_module :: TypecheckedModule
dm_typechecked_module = TypecheckedModule
tcm, dm_core_module :: ModGuts
dm_core_module = ModGuts
guts }

--------------------------------------------------------------------------------
-- | GHC Compatibility Layer ---------------------------------------------------
--------------------------------------------------------------------------------

gHC_VERSION :: String
gHC_VERSION :: String
gHC_VERSION = Integer -> String
forall a. Show a => a -> String
show __GLASGOW_HASKELL__

symbolFastString :: Symbol -> FastString
symbolFastString :: Symbol -> FastString
symbolFastString = ByteString -> FastString
mkFastStringByteString (ByteString -> FastString)
-> (Symbol -> ByteString) -> Symbol -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> (Symbol -> Text) -> Symbol -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Text
symbolText

lintCoreBindings :: [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc)
lintCoreBindings :: [TyVar] -> [CoreBind] -> (Bag SDoc, Bag SDoc)
lintCoreBindings = DynFlags
-> CoreToDo -> [TyVar] -> [CoreBind] -> (Bag SDoc, Bag SDoc)
CoreLint.lintCoreBindings (Settings -> LlvmConfig -> DynFlags
defaultDynFlags Settings
forall a. HasCallStack => a
undefined (String -> LlvmConfig
forall a. HasCallStack => a
undefined String
"LlvmTargets")) CoreToDo
CoreDoNothing

synTyConRhs_maybe :: TyCon -> Maybe Type
synTyConRhs_maybe :: TyCon -> Maybe Kind
synTyConRhs_maybe = TyCon -> Maybe Kind
TC.synTyConRhs_maybe

tcRnLookupRdrName :: HscEnv -> Ghc.Located RdrName -> IO (Messages, Maybe [Name])
tcRnLookupRdrName :: HscEnv -> Located RdrName -> IO (Messages, Maybe [Name])
tcRnLookupRdrName = HscEnv -> Located RdrName -> IO (Messages, Maybe [Name])
TcRnDriver.tcRnLookupRdrName

showCBs :: Bool -> [CoreBind] -> String
showCBs :: Bool -> [CoreBind] -> String
showCBs Bool
untidy
  | Bool
untidy    = DynFlags -> SDoc -> String
Out.showSDocDebug DynFlags
unsafeGlobalDynFlags (SDoc -> String) -> ([CoreBind] -> SDoc) -> [CoreBind] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CoreBind] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([CoreBind] -> SDoc)
-> ([CoreBind] -> [CoreBind]) -> [CoreBind] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CoreBind] -> [CoreBind]
tidyCBs
  | Bool
otherwise = [CoreBind] -> String
forall a. Outputable a => a -> String
showPpr


ignoreCoreBinds :: S.HashSet Var -> [CoreBind] -> [CoreBind]
ignoreCoreBinds :: HashSet TyVar -> [CoreBind] -> [CoreBind]
ignoreCoreBinds HashSet TyVar
vs [CoreBind]
cbs 
  | HashSet TyVar -> Bool
forall a. HashSet a -> Bool
S.null HashSet TyVar
vs         = [CoreBind]
cbs 
  | Bool
otherwise         = (CoreBind -> [CoreBind]) -> [CoreBind] -> [CoreBind]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CoreBind -> [CoreBind]
go [CoreBind]
cbs
  where
    go :: CoreBind -> [CoreBind]
    go :: CoreBind -> [CoreBind]
go b :: CoreBind
b@(NonRec TyVar
x Expr TyVar
_) 
      | TyVar -> HashSet TyVar -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member TyVar
x HashSet TyVar
vs = [] 
      | Bool
otherwise     = [CoreBind
b] 
    go (Rec [(TyVar, Expr TyVar)]
xes)      = [[(TyVar, Expr TyVar)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec (((TyVar, Expr TyVar) -> Bool)
-> [(TyVar, Expr TyVar)] -> [(TyVar, Expr TyVar)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((TyVar -> HashSet TyVar -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` HashSet TyVar
vs) (TyVar -> Bool)
-> ((TyVar, Expr TyVar) -> TyVar) -> (TyVar, Expr TyVar) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TyVar, Expr TyVar) -> TyVar
forall a b. (a, b) -> a
fst) [(TyVar, Expr TyVar)]
xes)]


findVarDef :: Symbol -> [CoreBind] -> Maybe (Var, CoreExpr)
findVarDef :: Symbol -> [CoreBind] -> Maybe (TyVar, Expr TyVar)
findVarDef Symbol
x [CoreBind]
cbs = case [CoreBind]
xCbs of
                     (NonRec TyVar
v Expr TyVar
def   : [CoreBind]
_ ) -> (TyVar, Expr TyVar) -> Maybe (TyVar, Expr TyVar)
forall a. a -> Maybe a
Just (TyVar
v, Expr TyVar
def)
                     (Rec [(TyVar
v, Expr TyVar
def)] : [CoreBind]
_ ) -> (TyVar, Expr TyVar) -> Maybe (TyVar, Expr TyVar)
forall a. a -> Maybe a
Just (TyVar
v, Expr TyVar
def)
                     [CoreBind]
_                     -> Maybe (TyVar, Expr TyVar)
forall a. Maybe a
Nothing
  where
    xCbs :: [CoreBind]
xCbs            = [ CoreBind
cb | CoreBind
cb <- (CoreBind -> [CoreBind]) -> [CoreBind] -> [CoreBind]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CoreBind -> [CoreBind]
forall b. Bind b -> [Bind b]
unRec [CoreBind]
cbs, Symbol
x Symbol -> [Symbol] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` CoreBind -> [Symbol]
coreBindSymbols CoreBind
cb ]
    unRec :: Bind b -> [Bind b]
unRec (Rec [(b, Expr b)]
xes) = [b -> Expr b -> Bind b
forall b. b -> Expr b -> Bind b
NonRec b
x Expr b
es | (b
x,Expr b
es) <- [(b, Expr b)]
xes]
    unRec Bind b
nonRec    = [Bind b
nonRec]


coreBindSymbols :: CoreBind -> [Symbol]
coreBindSymbols :: CoreBind -> [Symbol]
coreBindSymbols = (TyVar -> Symbol) -> [TyVar] -> [Symbol]
forall a b. (a -> b) -> [a] -> [b]
map (Symbol -> Symbol
dropModuleNames (Symbol -> Symbol) -> (TyVar -> Symbol) -> TyVar -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Symbol
forall t. NamedThing t => t -> Symbol
simplesymbol) ([TyVar] -> [Symbol])
-> (CoreBind -> [TyVar]) -> CoreBind -> [Symbol]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBind -> [TyVar]
forall a. Bind a -> [a]
binders

simplesymbol :: (NamedThing t) => t -> Symbol
simplesymbol :: t -> Symbol
simplesymbol = Name -> Symbol
forall a. Symbolic a => a -> Symbol
symbol (Name -> Symbol) -> (t -> Name) -> t -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Name
forall a. NamedThing a => a -> Name
getName

binders :: Bind a -> [a]
binders :: Bind a -> [a]
binders (NonRec a
z Expr a
_) = [a
z]
binders (Rec [(a, Expr a)]
xes)    = (a, Expr a) -> a
forall a b. (a, b) -> a
fst ((a, Expr a) -> a) -> [(a, Expr a)] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, Expr a)]
xes

expandVarType :: Var -> Type
expandVarType :: TyVar -> Kind
expandVarType = Kind -> Kind
expandTypeSynonyms (Kind -> Kind) -> (TyVar -> Kind) -> TyVar -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Kind
varType
--------------------------------------------------------------------------------
-- | The following functions test if a `CoreExpr` or `CoreVar` are just types
--   in disguise, e.g. have `PredType` (in the GHC sense of the word), and so
--   shouldn't appear in refinements.
--------------------------------------------------------------------------------
isPredExpr :: CoreExpr -> Bool
isPredExpr :: Expr TyVar -> Bool
isPredExpr = Kind -> Bool
isPredType (Kind -> Bool) -> (Expr TyVar -> Kind) -> Expr TyVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr TyVar -> Kind
CoreUtils.exprType

isPredVar :: Var -> Bool
isPredVar :: TyVar -> Bool
isPredVar TyVar
v = String -> Bool -> Bool
forall a. PPrint a => String -> a -> a
F.notracepp String
msg (Bool -> Bool) -> (TyVar -> Bool) -> TyVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> Bool
isPredType (Kind -> Bool) -> (TyVar -> Kind) -> TyVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Kind
varType (TyVar -> Bool) -> TyVar -> Bool
forall a b. (a -> b) -> a -> b
$ TyVar
v
  where
    msg :: String
msg     =  String
"isGoodCaseBind v = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TyVar -> String
forall a. Show a => a -> String
show TyVar
v

isPredType :: Type -> Bool
isPredType :: Kind -> Bool
isPredType = [Kind -> Bool] -> Kind -> Bool
forall a. [a -> Bool] -> a -> Bool
anyF [ Kind -> Bool
isClassPred, Kind -> Bool
isEqPred, Kind -> Bool
isEqPrimPred ]

anyF :: [a -> Bool] -> a -> Bool
anyF :: [a -> Bool] -> a -> Bool
anyF [a -> Bool]
ps a
x = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ a -> Bool
p a
x | a -> Bool
p <- [a -> Bool]
ps ]


-- | 'defaultDataCons t ds' returns the list of '(dc, types)' pairs,
--   corresponding to the _missing_ cases, i.e. _other_ than those in 'ds',
--   that are being handled by DEFAULT.
defaultDataCons :: Type -> [AltCon] -> Maybe [(DataCon, [TyVar], [Type])]
defaultDataCons :: Kind -> [AltCon] -> Maybe [(DataCon, [TyVar], [Kind])]
defaultDataCons (TyConApp TyCon
tc [Kind]
argτs) [AltCon]
ds = do 
  [DataCon]
allDs     <- TyCon -> Maybe [DataCon]
TC.tyConDataCons_maybe TyCon
tc
  let seenDs :: [DataCon]
seenDs = [DataCon
d | DataAlt DataCon
d <- [AltCon]
ds ]
  let defDs :: [DataCon]
defDs  = (DataCon -> String) -> [DataCon] -> [DataCon] -> [DataCon]
forall k a. (Eq k, Hashable k) => (a -> k) -> [a] -> [a] -> [a]
keyDiff DataCon -> String
forall a. Outputable a => a -> String
showPpr [DataCon]
allDs [DataCon]
seenDs 
  [(DataCon, [TyVar], [Kind])] -> Maybe [(DataCon, [TyVar], [Kind])]
forall (m :: * -> *) a. Monad m => a -> m a
return [ (DataCon
d, DataCon -> [TyVar]
Ghc.dataConExTyVars DataCon
d, DataCon -> [Kind] -> [Kind]
DataCon.dataConInstArgTys DataCon
d [Kind]
argτs) | DataCon
d <- [DataCon]
defDs ] 

defaultDataCons Kind
_ [AltCon]
_ = 
  Maybe [(DataCon, [TyVar], [Kind])]
forall a. Maybe a
Nothing



isEvVar :: Id -> Bool 
isEvVar :: TyVar -> Bool
isEvVar TyVar
x = TyVar -> Bool
isPredVar TyVar
x Bool -> Bool -> Bool
|| TyVar -> Bool
isTyVar TyVar
x Bool -> Bool -> Bool
|| TyVar -> Bool
isCoVar TyVar
x