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

{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -- TODO(#1918): Only needed for GHC <9.0.1.
{-# OPTIONS_GHC -Wno-orphans #-}

-- | 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           Debug.Trace

import           Prelude                                    hiding (error)
import           Liquid.GHC.API            as Ghc hiding ( L
                                                                          , sourceName
                                                                          , showPpr
                                                                          , showSDocDump
                                                                          , panic
                                                                          , showSDoc
                                                                          )
import qualified Liquid.GHC.API            as Ghc (GenLocated (L), showSDoc, panic, showSDocDump)


import           Data.Char                                  (isLower, isSpace, isUpper)
import           Data.Maybe                                 (isJust, fromMaybe, fromJust, maybeToList)
import           Data.Hashable
import qualified Data.HashSet                               as S
import qualified Data.Map.Strict                            as OM
import           Control.Monad.State                        (evalState, get, modify)

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                              ((>=>), foldM)
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, errorstar) -- , safeLast, safeInit)
import           Language.Haskell.Liquid.Misc               (keyDiff)
import           Control.DeepSeq
import           Language.Haskell.Liquid.Types.Errors


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

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


--------------------------------------------------------------------------------
-- | Encoding and Decoding Location --------------------------------------------
--------------------------------------------------------------------------------

tickSrcSpan :: CoreTickish -> SrcSpan
tickSrcSpan :: CoreTickish -> SrcSpan
tickSrcSpan (ProfNote CostCentre
cc Bool
_ Bool
_) = CostCentre -> SrcSpan
cc_loc CostCentre
cc
tickSrcSpan (SourceNote RealSrcSpan
ss [Char]
_) = RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
ss forall a. Maybe a
Nothing
tickSrcSpan CoreTickish
_                 = SrcSpan
noSrcSpan

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

-- FIXME: reusing uniques like this is really dangerous
stringTyVar :: String -> TyVar
stringTyVar :: [Char] -> Var
stringTyVar [Char]
s = Name -> Type -> Var
mkTyVar Name
name Type
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       = [Char] -> OccName
mkTyVarOcc [Char]
s

-- FIXME: reusing uniques like this is really dangerous
stringVar :: String -> Type -> Var
stringVar :: [Char] -> Type -> Var
stringVar [Char]
s Type
t = IdDetails -> Name -> Type -> Type -> IdInfo -> Var
mkLocalVar IdDetails
VanillaId Name
name Type
Many Type
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  = [Char] -> OccName
mkVarOcc [Char]
s

-- FIXME: plugging in dummy type like this is really dangerous
maybeAuxVar :: Symbol -> Maybe Var
maybeAuxVar :: Symbol -> Maybe Var
maybeAuxVar Symbol
s
  | forall a. Symbolic a => a -> Bool
isMethod Symbol
sym = forall a. a -> Maybe a
Just Var
sv
  | Bool
otherwise = forall a. Maybe a
Nothing
  where (Symbol
_, Int
uid) = Symbol -> (Symbol, Int)
splitModuleUnique Symbol
s
        sym :: Symbol
sym = Symbol -> Symbol
dropModuleNames Symbol
s
        sv :: Var
sv = IdDetails -> Name -> Type -> Var
mkExportedLocalId IdDetails
VanillaId Name
name Type
anyTy
        -- 'x' is chosen for no particular reason..
        name :: Name
name = Unique -> OccName -> SrcSpan -> Name
mkInternalName (Char -> Int -> Unique
mkUnique Char
'x' Int
uid) OccName
occ SrcSpan
noSrcSpan
        occ :: OccName
occ = [Char] -> OccName
mkVarOcc (Text -> [Char]
T.unpack (Symbol -> Text
symbolText Symbol
sym))

stringTyCon :: Char -> Int -> String -> TyCon
stringTyCon :: Char -> Int -> [Char] -> TyCon
stringTyCon = Type -> Char -> Int -> [Char] -> TyCon
stringTyConWithKind Type
anyTy

-- FIXME: reusing uniques like this is really dangerous
stringTyConWithKind :: Kind -> Char -> Int -> String -> TyCon
stringTyConWithKind :: Type -> Char -> Int -> [Char] -> TyCon
stringTyConWithKind Type
k Char
c Int
n [Char]
s = Name -> [TyConBinder] -> Type -> [Role] -> Name -> TyCon
Ghc.mkKindTyCon Name
name [] Type
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           = [Char] -> OccName
mkTcOcc [Char]
s

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

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

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

isTmpSymbol    :: Symbol -> Bool
isTmpSymbol :: Symbol -> Bool
isTmpSymbol Symbol
x  = 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 :: [Char] -> Bool
validTyVar s :: [Char]
s@(Char
c:[Char]
_) = Char -> Bool
isLower Char
c Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
isSpace [Char]
s)
validTyVar [Char]
_       = Bool
False

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

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

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

unTickExpr :: CoreExpr -> CoreExpr
unTickExpr :: Expr Var -> Expr Var
unTickExpr (App Expr Var
e Expr Var
a)          = forall b. Expr b -> Expr b -> Expr b
App (Expr Var -> Expr Var
unTickExpr Expr Var
e) (Expr Var -> Expr Var
unTickExpr Expr Var
a)
unTickExpr (Lam Var
b Expr Var
e)          = forall b. b -> Expr b -> Expr b
Lam Var
b (Expr Var -> Expr Var
unTickExpr Expr Var
e)
unTickExpr (Let CoreBind
b Expr Var
e)          = forall b. Bind b -> Expr b -> Expr b
Let (CoreBind -> CoreBind
unTick CoreBind
b) (Expr Var -> Expr Var
unTickExpr Expr Var
e)
unTickExpr (Case Expr Var
e Var
b Type
t [Alt Var]
as)    = forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Expr Var -> Expr Var
unTickExpr Expr Var
e) Var
b Type
t (forall a b. (a -> b) -> [a] -> [b]
map Alt Var -> Alt Var
unTickAlt [Alt Var]
as)
  where unTickAlt :: Alt Var -> Alt Var
unTickAlt (Alt AltCon
a [Var]
b' Expr Var
e') = forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
a [Var]
b' (Expr Var -> Expr Var
unTickExpr Expr Var
e')
unTickExpr (Cast Expr Var
e CoercionR
c)         = forall b. Expr b -> CoercionR -> Expr b
Cast (Expr Var -> Expr Var
unTickExpr Expr Var
e) CoercionR
c
unTickExpr (Tick CoreTickish
_ Expr Var
e)         = Expr Var -> Expr Var
unTickExpr Expr Var
e
unTickExpr Expr Var
x                  = Expr Var
x

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

isOrdClass :: Class -> Bool
isOrdClass :: Class -> Bool
isOrdClass Class
clas = Class -> Unique
classKey Class
clas forall a. Eq a => a -> a -> Bool
== Unique
ordClassKey

--------------------------------------------------------------------------------
-- | Pretty Printers -----------------------------------------------------------
--------------------------------------------------------------------------------
notracePpr :: Outputable a => String -> a -> a
notracePpr :: forall a. Outputable a => [Char] -> a -> a
notracePpr [Char]
_ a
x = a
x

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

pprShow :: Show a => a -> Ghc.SDoc
pprShow :: forall a. Show a => a -> SDoc
pprShow = [Char] -> SDoc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show


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

sDocDoc :: Ghc.SDoc -> PJ.Doc
sDocDoc :: SDoc -> Doc
sDocDoc   = [Char] -> Doc
PJ.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [Char]
showSDoc

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

-- Overriding Outputable functions because they now require DynFlags!
showPpr :: Outputable a => a -> String
showPpr :: forall a. Outputable a => a -> [Char]
showPpr = forall a. Outputable a => a -> [Char]
Ghc.showPprQualified

-- FIXME: somewhere we depend on this printing out all GHC entities with
-- fully-qualified names...
showSDoc :: Ghc.SDoc -> String
showSDoc :: SDoc -> [Char]
showSDoc = SDoc -> [Char]
Ghc.showSDocQualified

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

showSDocDump :: Ghc.SDoc -> String
showSDocDump :: SDoc -> [Char]
showSDocDump  = SDocContext -> SDoc -> [Char]
Ghc.showSDocDump SDocContext
Ghc.defaultSDocContext

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

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


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

newtype Loc    = L (Int, Int) deriving (Loc -> Loc -> Bool
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
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
Ord, Int -> Loc -> ShowS
[Loc] -> ShowS
Loc -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Loc] -> ShowS
$cshowList :: [Loc] -> ShowS
show :: Loc -> [Char]
$cshow :: Loc -> [Char]
showsPrec :: Int -> Loc -> ShowS
$cshowsPrec :: Int -> Loc -> ShowS
Show)

instance Hashable Loc where
  hashWithSalt :: Int -> Loc -> Int
hashWithSalt Int
i (L (Int, Int)
z) = 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 UnhelpfulSpanReason
reason) = case UnhelpfulSpanReason
reason of
    UnhelpfulSpanReason
UnhelpfulNoLocationInfo -> forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
i (FastString -> Int
uniq forall a b. (a -> b) -> a -> b
$ [Char] -> FastString
fsLit [Char]
"UnhelpfulNoLocationInfo")
    UnhelpfulSpanReason
UnhelpfulWiredIn        -> forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
i (FastString -> Int
uniq forall a b. (a -> b) -> a -> b
$ [Char] -> FastString
fsLit [Char]
"UnhelpfulWiredIn")
    UnhelpfulSpanReason
UnhelpfulInteractive    -> forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
i (FastString -> Int
uniq forall a b. (a -> b) -> a -> b
$ [Char] -> FastString
fsLit [Char]
"UnhelpfulInteractive")
    UnhelpfulSpanReason
UnhelpfulGenerated      -> forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
i (FastString -> Int
uniq forall a b. (a -> b) -> a -> b
$ [Char] -> FastString
fsLit [Char]
"UnhelpfulGenerated")
    UnhelpfulOther FastString
fs       -> forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
i (FastString -> Int
uniq FastString
fs)
  hashWithSalt Int
i (RealSrcSpan RealSrcSpan
s Maybe BufSpan
_)      = 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 :: forall a. Loc a => a -> SrcSpan
fSrcSpan = SrcSpan -> SrcSpan
fSrcSpanSrcSpan forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Loc a => a -> SrcSpan
F.srcSpan

fSourcePos :: (F.Loc a) => a -> F.SourcePos
fSourcePos :: forall a. Loc a => a -> SourcePos
fSourcePos = SrcSpan -> SourcePos
F.sp_start forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> Maybe BufSpan -> SrcSpan
RealSrcSpan ([Char] -> Int -> Int -> Int -> Int -> RealSrcSpan
packRealSrcSpan [Char]
f (Pos -> Int
unPos Pos
l) (Pos -> Int
unPos Pos
c) (Pos -> Int
unPos Pos
l') (Pos -> Int
unPos Pos
c')) forall a. Maybe a
Nothing
  where
    ([Char]
f, Pos
l,  Pos
c)         = SourcePos -> ([Char], Pos, Pos)
F.sourcePosElts SourcePos
p
    ([Char]
_, Pos
l', Pos
c')        = SourcePos -> ([Char], Pos, Pos)
F.sourcePosElts SourcePos
p'

sourcePosSrcSpan   :: SourcePos -> SrcSpan
sourcePosSrcSpan :: SourcePos -> SrcSpan
sourcePosSrcSpan p :: SourcePos
p@(SourcePos [Char]
file Pos
line Pos
col) = SourcePos -> SourcePos -> SrcSpan
sourcePos2SrcSpan SourcePos
p ([Char] -> Pos -> Pos -> SourcePos
SourcePos [Char]
file Pos
line (Pos -> Pos
succPos Pos
col))

sourcePosSrcLoc    :: SourcePos -> SrcLoc
sourcePosSrcLoc :: SourcePos -> SrcLoc
sourcePosSrcLoc (SourcePos [Char]
file Pos
line Pos
col) = FastString -> Int -> Int -> SrcLoc
mkSrcLoc ([Char] -> FastString
fsLit [Char]
file) (Pos -> Int
unPos Pos
line) (Pos -> Int
unPos Pos
col)

srcSpanSourcePos :: SrcSpan -> SourcePos
srcSpanSourcePos :: SrcSpan -> SourcePos
srcSpanSourcePos (UnhelpfulSpan UnhelpfulSpanReason
_) = [Char] -> SourcePos
dummyPos [Char]
"<no source information>"
srcSpanSourcePos (RealSrcSpan RealSrcSpan
s Maybe BufSpan
_) = RealSrcSpan -> SourcePos
realSrcSpanSourcePos RealSrcSpan
s

srcSpanSourcePosE :: SrcSpan -> SourcePos
srcSpanSourcePosE :: SrcSpan -> SourcePos
srcSpanSourcePosE (UnhelpfulSpan UnhelpfulSpanReason
_) = [Char] -> SourcePos
dummyPos [Char]
"<no source information>"
srcSpanSourcePosE (RealSrcSpan RealSrcSpan
s Maybe BufSpan
_) = RealSrcSpan -> SourcePos
realSrcSpanSourcePosE RealSrcSpan
s

srcSpanFilename :: SrcSpan -> String
srcSpanFilename :: SrcSpan -> [Char]
srcSpanFilename    = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" FastString -> [Char]
unpackFS 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 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 = [Char] -> Int -> Int -> SourcePos
safeSourcePos [Char]
file Int
line Int
col
  where
    file :: [Char]
file               = FastString -> [Char]
unpackFS 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

realSrcLocSourcePos :: RealSrcLoc -> SourcePos
realSrcLocSourcePos :: RealSrcLoc -> SourcePos
realSrcLocSourcePos RealSrcLoc
s = [Char] -> Int -> Int -> SourcePos
safeSourcePos [Char]
file Int
line Int
col
  where
    file :: [Char]
file               = FastString -> [Char]
unpackFS forall a b. (a -> b) -> a -> b
$ RealSrcLoc -> FastString
srcLocFile RealSrcLoc
s
    line :: Int
line               = RealSrcLoc -> Int
srcLocLine       RealSrcLoc
s
    col :: Int
col                = RealSrcLoc -> Int
srcLocCol        RealSrcLoc
s

realSrcSpanSourcePosE :: RealSrcSpan -> SourcePos
realSrcSpanSourcePosE :: RealSrcSpan -> SourcePos
realSrcSpanSourcePosE RealSrcSpan
s = [Char] -> Int -> Int -> SourcePos
safeSourcePos [Char]
file Int
line Int
col
  where
    file :: [Char]
file                = FastString -> [Char]
unpackFS 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 :: forall a. NamedThing a => a -> SourcePos
getSourcePos = SrcSpan -> SourcePos
srcSpanSourcePos  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NamedThing a => a -> SrcSpan
getSrcSpan

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

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

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

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

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

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

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

collectArguments :: Int -> CoreExpr -> [Var]
collectArguments :: Int -> Expr Var -> [Var]
collectArguments Int
n Expr Var
e = if forall (t :: * -> *) a. Foldable t => t a -> Int
length [Var]
xs forall a. Ord a => a -> a -> Bool
> Int
n then forall a. Int -> [a] -> [a]
take Int
n [Var]
xs else [Var]
xs
  where
    ([Var]
vs', Expr Var
e')        = Expr Var -> ([Var], Expr Var)
collectValBinders' forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Expr Var -> ([Var], Expr Var)
collectTyBinders Expr Var
e
    vs :: [Var]
vs               = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall b. Expr b -> ([b], Expr b)
collectBinders forall a b. (a -> b) -> a -> b
$ forall t. Expr t -> Expr t
ignoreLetBinds Expr Var
e'
    xs :: [Var]
xs               = [Var]
vs' forall a. [a] -> [a] -> [a]
++ [Var]
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' :: Ghc.Expr Var -> ([Var], Ghc.Expr Var)
collectValBinders' :: Expr Var -> ([Var], Expr Var)
collectValBinders' = [Var] -> Expr Var -> ([Var], Expr Var)
go []
  where
    go :: [Var] -> Expr Var -> ([Var], Expr Var)
go [Var]
tvs (Lam Var
b Expr Var
e) | Var -> Bool
isTyVar Var
b = [Var] -> Expr Var -> ([Var], Expr Var)
go [Var]
tvs     Expr Var
e
    go [Var]
tvs (Lam Var
b Expr Var
e) | Var -> Bool
isId    Var
b = [Var] -> Expr Var -> ([Var], Expr Var)
go (Var
bforall a. a -> [a] -> [a]
:[Var]
tvs) Expr Var
e
    go [Var]
tvs (Tick CoreTickish
_ Expr Var
e)            = [Var] -> Expr Var -> ([Var], Expr Var)
go [Var]
tvs Expr Var
e
    go [Var]
tvs Expr Var
e                     = (forall a. [a] -> [a]
reverse [Var]
tvs, Expr Var
e)

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

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

isExternalId :: Id -> Bool
isExternalId :: Var -> Bool
isExternalId = Name -> Bool
isExternalName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NamedThing a => a -> Name
getName

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

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

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

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

isDictionaryExpression :: Ghc.Expr Id -> Maybe Id
isDictionaryExpression :: Expr Var -> Maybe Var
isDictionaryExpression (Tick CoreTickish
_ Expr Var
e) = Expr Var -> Maybe Var
isDictionaryExpression Expr Var
e
isDictionaryExpression (Var Var
x)    | forall a. Symbolic a => a -> Bool
isDictionary Var
x = forall a. a -> Maybe a
Just Var
x
isDictionaryExpression Expr Var
_          = 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 = forall {a}. Num a => Type -> a
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> Type
tyConKind
  where
    go :: Type -> a
go (FunTy { ft_res :: Type -> Type
ft_res = Type
res}) = a
1 forall a. Num a => a -> a -> a
+ Type -> a
go Type
res
    go Type
_               = a
0


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

uniqueHash :: Uniquable a => Int -> a -> Int
uniqueHash :: forall a. Uniquable a => Int -> a -> Int
uniqueHash Int
i = forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
i forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique -> Int
getKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Maybe a
Nothing
    case FindResult
found_module of
        Found ModLocation
_ Module
mod' -> do
            -- Find the exports of the module
            (Messages DecoratedSDoc
_, Maybe ModIface
mb_iface) <- HscEnv -> Module -> IO (Messages DecoratedSDoc, 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 { 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 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ImpDeclSpec -> ImpItemSpec -> ImportSpec
ImpSpec ImpDeclSpec
decl_spec ImpItemSpec
ImpAll
                        env :: GlobalRdrEnv
env = case 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 (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
-- XXX                        [gre] -> return (Just (gre_name gre))
                        []    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                        [GlobalRdrElt]
_     -> forall a. [Char] -> a
Ghc.panic [Char]
"lookupRdrNameInModule"
                Maybe ModIface
Nothing -> forall {c}. DynFlags -> SDoc -> c
throwCmdLineErrorS DynFlags
dflags forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
Ghc.hsep [PtrString -> SDoc
Ghc.ptext ([Char] -> PtrString
sLit [Char]
"Could not determine the exports of the module"), forall a. Outputable a => a -> SDoc
ppr ModuleName
mod_name]
        FindResult
err' -> forall {c}. DynFlags -> SDoc -> c
throwCmdLineErrorS DynFlags
dflags forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> FindResult -> SDoc
cannotFindModule HscEnv
hsc_env ModuleName
mod_name FindResult
err'
  where dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        throwCmdLineErrorS :: DynFlags -> SDoc -> c
throwCmdLineErrorS DynFlags
dflags' = forall a. [Char] -> a
throwCmdLineError forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> SDoc -> [Char]
Ghc.showSDoc DynFlags
dflags'
        throwCmdLineError :: [Char] -> c
throwCmdLineError = forall a. GhcException -> a
throwGhcException forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> 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 -> HsModule
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsedModule -> ParsedSource
pm_parsed_source ParsedModule
x}
  where
    go :: HsModule -> HsModule
go  HsModule
y      = HsModule
y {hsmodDecls :: [LHsDecl GhcPs]
hsmodDecls = forall a. (a -> Bool) -> [a] -> [a]
filter LHsDecl GhcPs -> Bool
go' (HsModule -> [LHsDecl GhcPs]
hsmodDecls HsModule
y) }
    go' :: LHsDecl GhcPs -> Bool
    go' :: LHsDecl GhcPs -> Bool
go' LHsDecl GhcPs
z
      | SigD XSigD GhcPs
_ (InlineSig {}) <-  forall l e. GenLocated l e -> e
unLoc LHsDecl GhcPs
z = Bool
False
      | Bool
otherwise                         = Bool
True

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

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

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

symbolTyVar :: Symbol -> TyVar
symbolTyVar :: Symbol -> Var
symbolTyVar = [Char] -> Var
stringTyVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> [Char]
symbolString

localVarSymbol ::  Var -> Symbol
localVarSymbol :: Var -> Symbol
localVarSymbol Var
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                    = forall a. Symbolic a => a -> Symbol
symbol forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> [Char]
showPpr forall a b. (a -> b) -> a -> b
$ Var -> Unique
getDataConVarUnique Var
v
    vs :: Symbol
vs                    = Var -> Symbol
exportedVarSymbol Var
v

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

qualifiedNameSymbol :: Name -> Symbol
qualifiedNameSymbol :: Name -> Symbol
qualifiedNameSymbol = forall a. Symbolic a => a -> Symbol
symbol forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> FastString
Ghc.qualifiedNameFS

instance Symbolic FastString where
  symbol :: FastString -> Symbol
symbol = forall a. Symbolic a => a -> Symbol
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> ByteString
bytesFS

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

noTyVars :: TyCon -> Bool
noTyVars :: TyCon -> Bool
noTyVars TyCon
c =  TyCon -> Bool
Ghc.isPrimTyCon TyCon
c Bool -> Bool -> Bool
|| TyCon -> Bool
isFunTyCon TyCon
c Bool -> Bool -> Bool
|| TyCon -> Bool
Ghc.isPromotedDataCon TyCon
c

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

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

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

instance Symbolic Name where
  symbol :: Name -> Symbol
symbol = forall a. Symbolic a => a -> Symbol
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 :: Var -> Symbol
symbol Var
v
    | Var -> Bool
isExternalId Var
v = Var -> Symbol
exportedVarSymbol Var
v
    | Bool
otherwise      = Var -> Symbol
localVarSymbol    Var
v


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

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

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

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

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

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

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

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

instance Show Var where
  show :: Var -> [Char]
show = forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NamedThing a => a -> Name
getName

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

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

instance NFData Class where
  rnf :: Class -> ()
rnf Class
t = seq :: forall a b. a -> b -> b
seq Class
t ()

instance NFData TyCon where
  rnf :: TyCon -> ()
rnf TyCon
t = seq :: forall a b. a -> b -> b
seq TyCon
t ()

instance NFData Type where
  rnf :: Type -> ()
rnf Type
t = seq :: forall a b. a -> b -> b
seq Type
t ()

instance NFData Var where
  rnf :: Var -> ()
rnf Var
t = seq :: forall a b. a -> b -> b
seq Var
t ()

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

takeModuleUnique :: Symbol -> Symbol
takeModuleUnique :: Symbol -> Symbol
takeModuleUnique = ([Char] -> [Text] -> Symbol) -> Text -> [Char] -> Symbol -> Symbol
mungeNames forall {b}. Symbolic b => [Char] -> ListNE b -> Symbol
tailName Text
sepUnique   [Char]
"takeModuleUnique: "
  where
    tailName :: [Char] -> ListNE b -> Symbol
tailName [Char]
msg = forall a. Symbolic a => a -> Symbol
symbol forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (?callStack::CallStack) => [Char] -> ListNE a -> a
safeLast [Char]
msg

splitModuleUnique :: Symbol -> (Symbol, Int)
splitModuleUnique :: Symbol -> (Symbol, Int)
splitModuleUnique Symbol
x = (Symbol -> Symbol
dropModuleNamesAndUnique Symbol
x, Symbol -> Int
base62ToI (Symbol -> Symbol
takeModuleUnique Symbol
x))

base62ToI :: Symbol -> Int
base62ToI :: Symbol -> Int
base62ToI Symbol
s =  forall a. a -> Maybe a -> a
fromMaybe (forall a. (?callStack::CallStack) => [Char] -> a
errorstar [Char]
"base62ToI Out Of Range") forall a b. (a -> b) -> a -> b
$ Text -> Maybe Int
go (Symbol -> Text
F.symbolText Symbol
s)
  where
    digitToI :: OM.Map Char Int
    digitToI :: Map Char Int
digitToI = forall k a. Ord k => [(k, a)] -> Map k a
OM.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip ([Char
'0'..Char
'9'] forall a. [a] -> [a] -> [a]
++ [Char
'a'..Char
'z'] forall a. [a] -> [a] -> [a]
++ [Char
'A'..Char
'Z']) [Int
0..]
    f :: Int -> Char -> Maybe Int
f Int
acc (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
OM.lookup Map Char Int
digitToI -> Maybe Int
x) = (Int
acc forall a. Num a => a -> a -> a
* Int
62 forall a. Num a => a -> a -> a
+) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
x
    go :: Text -> Maybe Int
go = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Int -> Char -> Maybe Int
f Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack


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 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 = forall a. Symbolic a => a -> Symbol
F.symbol forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
go 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 (forall a. Eq a => a -> a -> Bool
== Char
'.') Text
tl
                              then Text -> Text
go forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. (?callStack::CallStack) => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ Text -> Maybe (Char, Text)
T.uncons forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhile (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  = forall a. Symbolic a => a -> Symbol
F.symbol forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text -> Text
go [] 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 (forall a. Eq a => a -> a -> Bool
== Char
'.') Text
tl
                                 then [Text] -> Text -> Text
go (Text -> Text
getModule' Text
sforall a. a -> [a] -> [a]
:[Text]
acc) forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. (?callStack::CallStack) => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ Text -> Maybe (Char, Text)
T.uncons forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhile (forall a. Eq a => a -> a -> Bool
/= Char
'.') Text
s
                                 else Text -> [Text] -> Text
T.intercalate Text
"." (forall a. [a] -> [a]
reverse [Text]
acc)
                Maybe (Char, Text)
Nothing -> Text -> [Text] -> Text
T.intercalate Text
"." (forall a. [a] -> [a]
reverse [Text]
acc)
    getModule' :: Text -> Text
getModule' = (Char -> Bool) -> Text -> Text
T.takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'.')

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

cmpSymbol :: Symbol -> Symbol -> Bool
cmpSymbol :: Symbol -> Symbol -> Bool
cmpSymbol Symbol
coreSym Symbol
logicSym
  =  (Symbol -> Symbol
dropModuleUnique Symbol
coreSym forall a. Eq a => a -> a -> Bool
== Symbol -> Symbol
dropModuleNamesAndUnique Symbol
logicSym)
  Bool -> Bool -> Bool
|| (Symbol -> Symbol
dropModuleUnique Symbol
coreSym 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 :: ([Char] -> [Text] -> Symbol) -> Text -> [Char] -> Symbol -> Symbol
mungeNames [Char] -> [Text] -> Symbol
_ Text
_ [Char]
_ Symbol
""  = Symbol
""
mungeNames [Char] -> [Text] -> Symbol
f Text
d [Char]
msg s' :: Symbol
s'@(Symbol -> Text
symbolText -> Text
s)
  | Symbol
s' forall a. Eq a => a -> a -> Bool
== Symbol
tupConName = Symbol
tupConName
  | Bool
otherwise        = [Char] -> [Text] -> Symbol
f ([Char]
msg forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
s) forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn Text
d 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    = forall a. Symbolic a => a -> Symbol
symbol (forall a. (IsString a, Monoid a) => a -> a
wrapParens (Text
m forall a. Monoid a => a -> a -> a
`mappend` Text
"." forall a. Monoid a => a -> a -> a
`mappend` Text -> Text
stripParens Text
x))
  | Bool
otherwise      = forall a. Symbolic a => a -> Symbol
symbol (Text
m forall a. Monoid a => a -> a -> a
`mappend` 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 :: forall a. (IsString a, Monoid a) => a -> a
wrapParens a
x  = a
"(" forall a. Monoid a => a -> a -> a
`mappend` a
x forall a. Monoid a => a -> a -> a
`mappend` a
")"

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

isDictionary :: Symbolic a => a -> Bool
isDictionary :: forall a. Symbolic a => a -> Bool
isDictionary = Symbol -> Symbol -> Bool
isPrefixOfSym Symbol
"$f" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Symbol
dropModuleNames forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Symbolic a => a -> Symbol
symbol

isMethod :: Symbolic a => a -> Bool
isMethod :: forall a. Symbolic a => a -> Bool
isMethod = Symbol -> Symbol -> Bool
isPrefixOfSym Symbol
"$c" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Symbol
dropModuleNames forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Symbolic a => a -> Symbol
symbol

isInternal :: Symbolic a => a -> Bool
isInternal :: forall a. Symbolic a => a -> Bool
isInternal   = Symbol -> Symbol -> Bool
isPrefixOfSym Symbol
"$"  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Symbol
dropModuleNames forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Symbolic a => a -> Symbol
symbol

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

isSCSel :: Symbolic a => a -> Bool
isSCSel :: forall a. Symbolic a => a -> Bool
isSCSel  = Symbol -> Symbol -> Bool
isPrefixOfSym Symbol
"$p" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Symbol
dropModuleNames forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Symbolic a => a -> Symbol
symbol

stripParens :: T.Text -> T.Text
stripParens :: Text -> Text
stripParens Text
t = 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
"(" 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) = 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 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 <- 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
hscDesugar{- WithLoc -} HscEnv
hsc_env_tmp ModSummary
ms TcGblEnv
tcg
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: [Char]
gHC_VERSION = forall a. Show a => a -> [Char]
show (__GLASGOW_HASKELL__ :: Int)

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

synTyConRhs_maybe :: TyCon -> Maybe Type
synTyConRhs_maybe :: TyCon -> Maybe Type
synTyConRhs_maybe = TyCon -> Maybe Type
Ghc.synTyConRhs_maybe

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

showCBs :: Bool -> [CoreBind] -> String
showCBs :: Bool -> [CoreBind] -> [Char]
showCBs Bool
untidy
  | Bool
untidy    =
    SDocContext -> SDoc -> [Char]
Ghc.renderWithContext SDocContext
ctx forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> SDoc
ppr forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CoreBind] -> [CoreBind]
tidyCBs
  | Bool
otherwise = forall a. Outputable a => a -> [Char]
showPpr
  where
    ctx :: SDocContext
ctx = SDocContext
Ghc.defaultSDocContext { sdocPprDebug :: Bool
sdocPprDebug = Bool
True }

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


findVarDef :: Symbol -> [CoreBind] -> Maybe (Var, CoreExpr)
findVarDef :: Symbol -> [CoreBind] -> Maybe (Var, Expr Var)
findVarDef Symbol
sym [CoreBind]
cbs = case [CoreBind]
xCbs of
                     (NonRec Var
v Expr Var
def   : [CoreBind]
_ ) -> forall a. a -> Maybe a
Just (Var
v, Expr Var
def)
                     (Rec [(Var
v, Expr Var
def)] : [CoreBind]
_ ) -> forall a. a -> Maybe a
Just (Var
v, Expr Var
def)
                     [CoreBind]
_                     -> forall a. Maybe a
Nothing
  where
    xCbs :: [CoreBind]
xCbs            = [ CoreBind
cb | CoreBind
cb <- forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {b}. Bind b -> [Bind b]
unRec [CoreBind]
cbs, Symbol
sym 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) = [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]


findVarDefMethod :: Symbol -> [CoreBind] -> Maybe (Var, CoreExpr)
findVarDefMethod :: Symbol -> [CoreBind] -> Maybe (Var, Expr Var)
findVarDefMethod Symbol
sym [CoreBind]
cbs =
  case [CoreBind]
rcbs  of
                     (NonRec Var
v Expr Var
def   : [CoreBind]
_ ) -> forall a. a -> Maybe a
Just (Var
v, Expr Var
def)
                     (Rec [(Var
v, Expr Var
def)] : [CoreBind]
_ ) -> forall a. a -> Maybe a
Just (Var
v, Expr Var
def)
                     [CoreBind]
_                     -> forall a. Maybe a
Nothing
  where
    rcbs :: [CoreBind]
rcbs | forall a. Symbolic a => a -> Bool
isMethod Symbol
sym = [CoreBind]
mCbs
         | forall a. Symbolic a => a -> Bool
isDictionary (Symbol -> Symbol
dropModuleNames Symbol
sym) = [CoreBind]
dCbs
         | Bool
otherwise  = [CoreBind]
xCbs
    xCbs :: [CoreBind]
xCbs            = [ CoreBind
cb | CoreBind
cb <- forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {b}. Bind b -> [Bind b]
unRec [CoreBind]
cbs, Symbol
sym forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` CoreBind -> [Symbol]
coreBindSymbols CoreBind
cb
                           ]
    mCbs :: [CoreBind]
mCbs            = [ CoreBind
cb | CoreBind
cb <- forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {b}. Bind b -> [Bind b]
unRec [CoreBind]
cbs, Symbol
sym forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` CoreBind -> [Symbol]
methodSymbols CoreBind
cb]
    dCbs :: [CoreBind]
dCbs            = [ CoreBind
cb | CoreBind
cb <- forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {b}. Bind b -> [Bind b]
unRec [CoreBind]
cbs, Symbol
sym forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` CoreBind -> [Symbol]
dictionarySymbols CoreBind
cb]
    unRec :: Bind b -> [Bind b]
unRec (Rec [(b, Expr b)]
xes) = [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]

dictionarySymbols :: CoreBind -> [Symbol]
dictionarySymbols :: CoreBind -> [Symbol]
dictionarySymbols = forall a. (a -> Bool) -> [a] -> [a]
filter forall a. Symbolic a => a -> Bool
isDictionary forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Symbol -> Symbol
dropModuleNames forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Symbolic a => a -> Symbol
symbol) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Bind a -> [a]
binders


methodSymbols :: CoreBind -> [Symbol]
methodSymbols :: CoreBind -> [Symbol]
methodSymbols = forall a. (a -> Bool) -> [a] -> [a]
filter forall a. Symbolic a => a -> Bool
isMethod forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Symbol -> Symbol
dropModuleNames forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Symbolic a => a -> Symbol
symbol) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Bind a -> [a]
binders



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

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

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

expandVarType :: Var -> Type
expandVarType :: Var -> Type
expandVarType = Type -> Type
expandTypeSynonyms forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> Type
varType

--------------------------------------------------------------------------------
-- | The following functions test if a `CoreExpr` or `CoreVar` can be
--   embedded in logic. With type-class support, we can no longer erase
--   such expressions arbitrarily.
--------------------------------------------------------------------------------
isEmbeddedDictExpr :: CoreExpr -> Bool
isEmbeddedDictExpr :: Expr Var -> Bool
isEmbeddedDictExpr = Type -> Bool
isEmbeddedDictType forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr Var -> Type
exprType

isEmbeddedDictVar :: Var -> Bool
isEmbeddedDictVar :: Var -> Bool
isEmbeddedDictVar Var
v = forall a. PPrint a => [Char] -> a -> a
F.notracepp [Char]
msg forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Bool
isEmbeddedDictType forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> Type
varType forall a b. (a -> b) -> a -> b
$ Var
v
  where
    msg :: [Char]
msg     =  [Char]
"isGoodCaseBind v = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Var
v

isEmbeddedDictType :: Type -> Bool
isEmbeddedDictType :: Type -> Bool
isEmbeddedDictType = forall a. [a -> Bool] -> a -> Bool
anyF [Type -> Bool
isOrdPred, Type -> Bool
isNumericPred, Type -> Bool
isEqPred, Type -> Bool
isPrelEqPred]

-- unlike isNumCls, isFracCls, these two don't check if the argument's
-- superclass is Ord or Num. I believe this is the more predictable behavior

isPrelEqPred :: Type -> Bool
isPrelEqPred :: Type -> Bool
isPrelEqPred Type
ty = case Type -> Maybe TyCon
tyConAppTyCon_maybe Type
ty of
  Just TyCon
tyCon -> TyCon -> Bool
isPrelEqTyCon TyCon
tyCon
  Maybe TyCon
_          -> Bool
False


isPrelEqTyCon :: TyCon -> Bool
isPrelEqTyCon :: TyCon -> Bool
isPrelEqTyCon TyCon
tc = TyCon
tc forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqClassKey

isOrdPred :: Type -> Bool
isOrdPred :: Type -> Bool
isOrdPred Type
ty = case Type -> Maybe TyCon
tyConAppTyCon_maybe Type
ty of
  Just TyCon
tyCon -> TyCon
tyCon forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
ordClassKey
  Maybe TyCon
_          -> Bool
False

-- Not just Num, but Fractional, Integral as well
isNumericPred :: Type -> Bool
isNumericPred :: Type -> Bool
isNumericPred Type
ty = case Type -> Maybe TyCon
tyConAppTyCon_maybe Type
ty of
  Just TyCon
tyCon -> forall a. Uniquable a => a -> Unique
getUnique TyCon
tyCon forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Unique]
numericClassKeys
  Maybe TyCon
_          -> Bool
False



--------------------------------------------------------------------------------
-- | 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 Var -> Bool
isPredExpr = Type -> Bool
isPredType forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr Var -> Type
Ghc.exprType

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

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

anyF :: [a -> Bool] -> a -> Bool
anyF :: forall a. [a -> Bool] -> a -> Bool
anyF [a -> Bool]
ps a
x = 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 :: Type -> [AltCon] -> Maybe [(DataCon, [Var], [Type])]
defaultDataCons (TyConApp TyCon
tc [Type]
argτs) [AltCon]
ds = do
  [DataCon]
allDs     <- TyCon -> Maybe [DataCon]
Ghc.tyConDataCons_maybe TyCon
tc
  let seenDs :: [DataCon]
seenDs = [DataCon
d | DataAlt DataCon
d <- [AltCon]
ds ]
  let defDs :: [DataCon]
defDs  = forall k a. (Eq k, Hashable k) => (a -> k) -> [a] -> [a] -> [a]
keyDiff forall a. Outputable a => a -> [Char]
showPpr [DataCon]
allDs [DataCon]
seenDs
  forall (m :: * -> *) a. Monad m => a -> m a
return [ (DataCon
d, DataCon -> [Var]
Ghc.dataConExTyCoVars DataCon
d, forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
irrelevantMult forall a b. (a -> b) -> a -> b
$ DataCon -> [Type] -> [Scaled Type]
Ghc.dataConInstArgTys DataCon
d [Type]
argτs) | DataCon
d <- [DataCon]
defDs ]

defaultDataCons Type
_ [AltCon]
_ =
  forall a. Maybe a
Nothing



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


--------------------------------------------------------------------------------
-- | Elaboration
--------------------------------------------------------------------------------

-- FIXME: the handling of exceptions seems to be broken

-- partially stolen from GHC'sa exprType

-- elaborateHsExprInst
--   :: GhcMonad m => LHsExpr GhcPs -> m (Messages, Maybe CoreExpr)
-- elaborateHsExprInst expr = elaborateHsExpr TM_Inst expr


-- elaborateHsExpr
--   :: GhcMonad m => TcRnExprMode -> LHsExpr GhcPs -> m (Messages, Maybe CoreExpr)
-- elaborateHsExpr mode expr =
--   withSession $ \hsc_env -> liftIO $ hscElabHsExpr hsc_env mode expr

-- hscElabHsExpr :: HscEnv -> TcRnExprMode -> LHsExpr GhcPs -> IO (Messages, Maybe CoreExpr)
-- hscElabHsExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do
--   hsc_env <- Ghc.getHscEnv
--   liftIO $ elabRnExpr hsc_env mode expr

elabRnExpr :: LHsExpr GhcPs -> TcRn CoreExpr
elabRnExpr :: LHsExpr GhcPs -> TcRn (Expr Var)
elabRnExpr LHsExpr GhcPs
rdr_expr = do
    (GenLocated SrcSpanAnnA (HsExpr GhcRn)
rn_expr, FreeVars
_fvs) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
rdr_expr
    TcRn ()
failIfErrsM

    -- Typecheck the expression
    ((TcLevel
tclvl, (GenLocated SrcSpanAnnA (HsExpr GhcTc)
tc_expr, Type
res_ty)), WantedConstraints
lie)
          <- forall a. TcM a -> TcM (a, WantedConstraints)
captureTopConstraints forall a b. (a -> b) -> a -> b
$
             forall a. TcM a -> TcM (TcLevel, a)
pushTcLevelM          forall a b. (a -> b) -> a -> b
$
             LHsExpr GhcRn -> TcM (LHsExpr GhcTc, Type)
tcInferRho GenLocated SrcSpanAnnA (HsExpr GhcRn)
rn_expr

    -- Generalise
    Unique
uniq <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
    let { fresh_it :: Name
fresh_it = Unique -> SrcSpan -> Name
itName Unique
uniq (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsExpr GhcPs
rdr_expr) }
    (([Var]
_qtvs, [Var]
_dicts, TcEvBinds
evbs, Bool
_), WantedConstraints
residual)
         <- forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints forall a b. (a -> b) -> a -> b
$
            TcLevel
-> InferMode
-> [TcIdSigInst]
-> [(Name, Type)]
-> WantedConstraints
-> TcM ([Var], [Var], TcEvBinds, Bool)
simplifyInfer TcLevel
tclvl InferMode
NoRestrictions
                          []    {- No sig vars -}
                          [(Name
fresh_it, Type
res_ty)]
                          WantedConstraints
lie

    -- Ignore the dictionary bindings
    Bag EvBind
evbs' <- WantedConstraints -> TcM (Bag EvBind)
simplifyInteractive WantedConstraints
residual
    GenLocated SrcSpanAnnA (HsExpr GhcTc)
full_expr <- LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkTopLExpr (TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc
mkHsDictLet (Bag EvBind -> TcEvBinds
EvBinds Bag EvBind
evbs') (TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc
mkHsDictLet TcEvBinds
evbs GenLocated SrcSpanAnnA (HsExpr GhcTc)
tc_expr))
    forall a. DsM a -> TcM a
initDsTc forall a b. (a -> b) -> a -> b
$ LHsExpr GhcTc -> DsM (Expr Var)
dsLExpr GenLocated SrcSpanAnnA (HsExpr GhcTc)
full_expr

newtype HashableType = HashableType {HashableType -> Type
getHType :: Type}

instance Eq HashableType where
  HashableType
x == :: HashableType -> HashableType -> Bool
== HashableType
y = Type -> Type -> Bool
eqType (HashableType -> Type
getHType HashableType
x) (HashableType -> Type
getHType HashableType
y)

instance Ord HashableType where
  compare :: HashableType -> HashableType -> Ordering
compare HashableType
x HashableType
y = Type -> Type -> Ordering
nonDetCmpType (HashableType -> Type
getHType HashableType
x) (HashableType -> Type
getHType HashableType
y)

instance Outputable HashableType where
  ppr :: HashableType -> SDoc
ppr = forall a. Outputable a => a -> SDoc
ppr forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashableType -> Type
getHType


--------------------------------------------------------------------------------
-- | Superclass coherence
--------------------------------------------------------------------------------

canonSelectorChains :: PredType -> OM.Map HashableType [Id]
canonSelectorChains :: Type -> Map HashableType [Var]
canonSelectorChains Type
t = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
OM.unionWith forall a b. a -> b -> a
const) forall a. Monoid a => a
mempty (Map HashableType [Var]
zs forall a. a -> [a] -> [a]
: [Map HashableType [Var]]
xs)
 where
  (Class
cls, [Type]
ts) = HasDebugCallStack => Type -> (Class, [Type])
Ghc.getClassPredTys Type
t
  scIdTys :: [Var]
scIdTys   = Class -> [Var]
classSCSelIds Class
cls
  ys :: [(Var, Type)]
ys        = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Var
d -> (Var
d, HasDebugCallStack => Type -> [Type] -> Type
piResultTys (Var -> Type
idType Var
d) ([Type]
ts forall a. [a] -> [a] -> [a]
++ [Type
t]))) [Var]
scIdTys
  zs :: Map HashableType [Var]
zs        = forall k a. Ord k => [(k, a)] -> Map k a
OM.fromList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Var
x, Type
y) -> (Type -> HashableType
HashableType Type
y, [Var
x])) [(Var, Type)]
ys
  xs :: [Map HashableType [Var]]
xs        = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Var
d, Type
t') -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Var
d forall a. a -> [a] -> [a]
:) (Type -> Map HashableType [Var]
canonSelectorChains Type
t')) [(Var, Type)]
ys

buildCoherenceOblig :: Class -> [[([Id], [Id])]]
buildCoherenceOblig :: Class -> [[([Var], [Var])]]
buildCoherenceOblig Class
cls = forall s a. State s a -> s -> a
evalState (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {k} {a} {m :: * -> *}.
(MonadState (Map k [a]) m, Ord k) =>
Map k [a] -> m [([a], [a])]
f [Map HashableType [Var]]
xs) forall k a. Map k a
OM.empty
 where
  ([Var]
ts, [Type]
_, [Var]
selIds, [ClassOpItem]
_) = Class -> ([Var], [Type], [Var], [ClassOpItem])
classBigSig Class
cls
  tts :: [Type]
tts                = Var -> Type
mkTyVarTy forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Var]
ts
  t :: Type
t                  = Class -> [Type] -> Type
mkClassPred Class
cls [Type]
tts
  ys :: [(Var, Type)]
ys = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Var
d -> (Var
d, HasDebugCallStack => Type -> [Type] -> Type
piResultTys (Var -> Type
idType Var
d) ([Type]
tts forall a. [a] -> [a] -> [a]
++ [Type
t]))) [Var]
selIds
  xs :: [Map HashableType [Var]]
xs                 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Var
d, Type
t') -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Var
dforall a. a -> [a] -> [a]
:) (Type -> Map HashableType [Var]
canonSelectorChains Type
t')) [(Var, Type)]
ys
  f :: Map k [a] -> m [([a], [a])]
f Map k [a]
tid = do
    Map k [a]
ctid' <- forall s (m :: * -> *). MonadState s m => m s
get
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
OM.unionWith forall a b. a -> b -> a
const) Map k [a]
tid)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
OM.elems forall a b. (a -> b) -> a -> b
$ forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
OM.intersectionWith (,) Map k [a]
ctid' (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> [a]
tail Map k [a]
tid)


-- to be zipped onto the super class selectors
coherenceObligToRef :: (F.Symbolic s) => s -> [Id] -> [Id] -> F.Reft
coherenceObligToRef :: forall s. Symbolic s => s -> [Var] -> [Var] -> Reft
coherenceObligToRef s
d = Expr -> [Var] -> [Var] -> Reft
coherenceObligToRefE (forall a. Symbolic a => a -> Expr
F.eVar forall a b. (a -> b) -> a -> b
$ forall a. Symbolic a => a -> Symbol
F.symbol s
d)

coherenceObligToRefE :: F.Expr -> [Id] -> [Id] -> F.Reft
coherenceObligToRefE :: Expr -> [Var] -> [Var] -> Reft
coherenceObligToRefE Expr
e [Var]
rps0 [Var]
rps1 = (Symbol, Expr) -> Reft
F.Reft (Symbol
F.vv_, Brel -> Expr -> Expr -> Expr
F.PAtom Brel
F.Eq Expr
lhs Expr
rhs)
  where lhs :: Expr
lhs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
L.foldr Expr -> Expr -> Expr
EApp Expr
e [Expr]
ps0
        rhs :: Expr
rhs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
L.foldr Expr -> Expr -> Expr
EApp (forall a. Symbolic a => a -> Expr
F.eVar Symbol
F.vv_) [Expr]
ps1
        ps0 :: [Expr]
ps0 = forall a. Symbolic a => a -> Expr
F.eVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Symbolic a => a -> Symbol
F.symbol forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> [a]
L.reverse [Var]
rps0
        ps1 :: [Expr]
ps1 = forall a. Symbolic a => a -> Expr
F.eVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Symbolic a => a -> Symbol
F.symbol forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> [a]
L.reverse [Var]
rps1

data TcWiredIn = TcWiredIn {
    TcWiredIn -> Name
tcWiredInName :: Name
  , TcWiredIn -> Maybe (Int, FixityDirection)
tcWiredInFixity :: Maybe (Int, FixityDirection)
  , TcWiredIn -> LHsType GhcRn
tcWiredInType :: LHsType GhcRn
  }

-- | Run a computation in GHC's typechecking monad with wired in values locally bound in the typechecking environment.
withWiredIn :: TcM a -> TcM a
withWiredIn :: forall a. TcM a -> TcM a
withWiredIn TcM a
m = forall a. TcM a -> TcM a
discardConstraints forall a b. (a -> b) -> a -> b
$ do
  -- undef <- lookupUndef
  [TcWiredIn]
wiredIns <- forall {m :: * -> *}. MonadUnique m => m [TcWiredIn]
mkWiredIns
  -- snd <$> tcValBinds Ghc.NotTopLevel (binds undef wiredIns) (sigs wiredIns) m
  forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall thing.
TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)]
-> [LSig GhcRn]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
tcValBinds TopLevelFlag
Ghc.NotTopLevel [] (forall {t :: * -> *} {ann}.
Foldable t =>
t TcWiredIn -> [GenLocated (SrcAnn ann) (Sig GhcRn)]
sigs [TcWiredIn]
wiredIns) TcM a
m

 where
  -- lookupUndef = do
  --   lookupOrig gHC_ERR (Ghc.mkVarOcc "undefined")
  --   -- tcLookupGlobal undefName

  -- binds :: Name -> [TcWiredIn] -> [(Ghc.RecFlag, LHsBinds GhcRn)]
  -- binds undef wiredIns = map (\w -> 
  --     let ext = Ghc.unitNameSet undef in -- $ varName $ tyThingId undef in
  --     let co_fn = idHsWrapper in
  --     let matches = 
  --           let ctxt = LambdaExpr in
  --           let grhss = GRHSs Ghc.noExtField [Ghc.L locSpan (GRHS Ghc.noExtField [] (Ghc.L locSpan (HsVar Ghc.noExtField (Ghc.L locSpan undef))))] (Ghc.L locSpan emptyLocalBinds) in
  --           MG Ghc.noExtField (Ghc.L locSpan [Ghc.L locSpan (Match Ghc.noExtField ctxt [] grhss)]) Ghc.Generated 
  --     in
  --     let b = FunBind ext (Ghc.L locSpan $ tcWiredInName w) matches co_fn [] in
  --     (Ghc.NonRecursive, unitBag (Ghc.L locSpan b))
  --   ) wiredIns

  sigs :: t TcWiredIn -> [GenLocated (SrcAnn ann) (Sig GhcRn)]
sigs t TcWiredIn
wiredIns = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\TcWiredIn
w ->
      let inf :: [GenLocated (SrcAnn ann) (Sig GhcRn)]
inf = forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ (\(Int
fPrec, FixityDirection
fDir) -> forall l e. l -> e -> GenLocated l e
Ghc.L forall {ann}. SrcAnn ann
locSpanAnn forall a b. (a -> b) -> a -> b
$ forall pass. XFixSig pass -> FixitySig pass -> Sig pass
Ghc.FixSig forall a. EpAnn a
Ghc.noAnn forall a b. (a -> b) -> a -> b
$ forall pass.
XFixitySig pass -> [LIdP pass] -> Fixity -> FixitySig pass
Ghc.FixitySig NoExtField
Ghc.noExtField [forall l e. l -> e -> GenLocated l e
Ghc.L forall {ann}. SrcAnn ann
locSpanAnn (TcWiredIn -> Name
tcWiredInName TcWiredIn
w)] forall a b. (a -> b) -> a -> b
$ SourceText -> Int -> FixityDirection -> Fixity
Ghc.Fixity SourceText
Ghc.NoSourceText Int
fPrec FixityDirection
fDir) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TcWiredIn -> Maybe (Int, FixityDirection)
tcWiredInFixity TcWiredIn
w in
      let t :: [GenLocated (SrcAnn ann) (Sig GhcRn)]
t =
            let ext' :: [a]
ext' = [] in
            [forall l e. l -> e -> GenLocated l e
Ghc.L forall {ann}. SrcAnn ann
locSpanAnn forall a b. (a -> b) -> a -> b
$ forall pass.
XTypeSig pass -> [LIdP pass] -> LHsSigWcType pass -> Sig pass
TypeSig forall a. EpAnn a
Ghc.noAnn [forall l e. l -> e -> GenLocated l e
Ghc.L forall {ann}. SrcAnn ann
locSpanAnn (TcWiredIn -> Name
tcWiredInName TcWiredIn
w)] forall a b. (a -> b) -> a -> b
$ forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
HsWC forall a. [a]
ext' forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
Ghc.L forall {ann}. SrcAnn ann
locSpanAnn forall a b. (a -> b) -> a -> b
$ forall pass.
XHsSig pass
-> HsOuterSigTyVarBndrs pass -> LHsType pass -> HsSigType pass
HsSig NoExtField
Ghc.noExtField (forall flag pass.
XHsOuterImplicit pass -> HsOuterTyVarBndrs flag pass
HsOuterImplicit forall a. [a]
ext') forall a b. (a -> b) -> a -> b
$ TcWiredIn -> LHsType GhcRn
tcWiredInType TcWiredIn
w]
      in
      [GenLocated (SrcAnn ann) (Sig GhcRn)]
inf forall a. Semigroup a => a -> a -> a
<> [GenLocated (SrcAnn ann) (Sig GhcRn)]
t
    ) t TcWiredIn
wiredIns

  locSpan :: SrcSpan
locSpan = UnhelpfulSpanReason -> SrcSpan
UnhelpfulSpan (FastString -> UnhelpfulSpanReason
UnhelpfulOther FastString
"Liquid.GHC.Misc: WiredIn")
  locSpanAnn :: SrcAnn ann
locSpanAnn = forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
locSpan

  mkHsFunTy :: LHsType GhcRn -> LHsType GhcRn -> LHsType GhcRn
  mkHsFunTy :: LHsType GhcRn -> LHsType GhcRn -> LHsType GhcRn
mkHsFunTy LHsType GhcRn
a LHsType GhcRn
b = forall (p :: Pass).
LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsFunTy LHsType GhcRn
a LHsType GhcRn
b

  mkWiredIns :: m [TcWiredIn]
mkWiredIns = forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [forall {m :: * -> *}. MonadUnique m => m TcWiredIn
impl, forall {m :: * -> *}. MonadUnique m => m TcWiredIn
dimpl, forall {m :: * -> *}. MonadUnique m => m TcWiredIn
eq, forall {m :: * -> *}. MonadUnique m => m TcWiredIn
len]

  toName :: [Char] -> m Name
toName [Char]
s = do
    Unique
u <- forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Unique -> OccName -> SrcSpan -> Name
Ghc.mkInternalName Unique
u ([Char] -> OccName
Ghc.mkVarOcc [Char]
s) SrcSpan
locSpan

  toLoc :: e -> GenLocated (SrcAnn ann) e
toLoc = forall l e. l -> e -> GenLocated l e
Ghc.L forall {ann}. SrcAnn ann
locSpanAnn
  nameToTy :: XRec pass (IdP pass) -> GenLocated (SrcAnn ann) (HsType pass)
nameToTy = forall l e. l -> e -> GenLocated l e
Ghc.L forall {ann}. SrcAnn ann
locSpanAnn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
Ghc.noAnn PromotionFlag
Ghc.NotPromoted

  boolTy' :: LHsType GhcRn
  boolTy' :: LHsType GhcRn
boolTy' = forall {pass} {a} {ann}.
(XTyVar pass ~ EpAnn a) =>
XRec pass (IdP pass) -> GenLocated (SrcAnn ann) (HsType pass)
nameToTy forall a b. (a -> b) -> a -> b
$ forall {e} {ann}. e -> GenLocated (SrcAnn ann) e
toLoc Name
boolTyConName
    -- boolName <- lookupOrig (Module (stringToUnitId "Data.Bool") (mkModuleName "Data.Bool")) (Ghc.mkVarOcc "Bool")
    -- return $ Ghc.L locSpan $ HsTyVar Ghc.noExtField Ghc.NotPromoted $ Ghc.L locSpan boolName
  intTy' :: GenLocated (SrcAnn ann) (HsType pass)
intTy' = forall {pass} {a} {ann}.
(XTyVar pass ~ EpAnn a) =>
XRec pass (IdP pass) -> GenLocated (SrcAnn ann) (HsType pass)
nameToTy forall a b. (a -> b) -> a -> b
$ forall {e} {ann}. e -> GenLocated (SrcAnn ann) e
toLoc Name
intTyConName
  listTy :: GenLocated (SrcAnn ann) (HsType pass)
-> GenLocated (SrcAnn ann) (HsType pass)
listTy GenLocated (SrcAnn ann) (HsType pass)
lt = forall {e} {ann}. e -> GenLocated (SrcAnn ann) e
toLoc forall a b. (a -> b) -> a -> b
$ forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy NoExtField
Ghc.noExtField (forall {pass} {a} {ann}.
(XTyVar pass ~ EpAnn a) =>
XRec pass (IdP pass) -> GenLocated (SrcAnn ann) (HsType pass)
nameToTy forall a b. (a -> b) -> a -> b
$ forall {e} {ann}. e -> GenLocated (SrcAnn ann) e
toLoc Name
listTyConName) GenLocated (SrcAnn ann) (HsType pass)
lt

  -- infixr 1 ==> :: Bool -> Bool -> Bool
  impl :: m TcWiredIn
impl = do
    Name
n <- forall {m :: * -> *}. MonadUnique m => [Char] -> m Name
toName [Char]
"==>"
    let ty :: LHsType GhcRn
ty = LHsType GhcRn -> LHsType GhcRn -> LHsType GhcRn
mkHsFunTy LHsType GhcRn
boolTy' (LHsType GhcRn -> LHsType GhcRn -> LHsType GhcRn
mkHsFunTy LHsType GhcRn
boolTy' LHsType GhcRn
boolTy')
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Maybe (Int, FixityDirection) -> LHsType GhcRn -> TcWiredIn
TcWiredIn Name
n (forall a. a -> Maybe a
Just (Int
1, FixityDirection
Ghc.InfixR)) GenLocated SrcSpanAnnA (HsType GhcRn)
ty

  -- infixr 1 <=> :: Bool -> Bool -> Bool
  dimpl :: m TcWiredIn
dimpl = do
    Name
n <- forall {m :: * -> *}. MonadUnique m => [Char] -> m Name
toName [Char]
"<=>"
    let ty :: LHsType GhcRn
ty = LHsType GhcRn -> LHsType GhcRn -> LHsType GhcRn
mkHsFunTy LHsType GhcRn
boolTy' (LHsType GhcRn -> LHsType GhcRn -> LHsType GhcRn
mkHsFunTy LHsType GhcRn
boolTy' LHsType GhcRn
boolTy')
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Maybe (Int, FixityDirection) -> LHsType GhcRn -> TcWiredIn
TcWiredIn Name
n (forall a. a -> Maybe a
Just (Int
1, FixityDirection
Ghc.InfixR)) GenLocated SrcSpanAnnA (HsType GhcRn)
ty

  -- infix 4 == :: forall a . a -> a -> Bool
  eq :: m TcWiredIn
eq = do
    Name
n <- forall {m :: * -> *}. MonadUnique m => [Char] -> m Name
toName [Char]
"=="
    GenLocated (SrcAnn NameAnn) Name
aName <- forall {e} {ann}. e -> GenLocated (SrcAnn ann) e
toLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {m :: * -> *}. MonadUnique m => [Char] -> m Name
toName [Char]
"a"
    let aTy :: GenLocated SrcSpanAnnA (HsType GhcRn)
aTy = forall {pass} {a} {ann}.
(XTyVar pass ~ EpAnn a) =>
XRec pass (IdP pass) -> GenLocated (SrcAnn ann) (HsType pass)
nameToTy GenLocated (SrcAnn NameAnn) Name
aName
    let ty :: GenLocated SrcSpanAnnA (HsType GhcRn)
ty = forall {e} {ann}. e -> GenLocated (SrcAnn ann) e
toLoc forall a b. (a -> b) -> a -> b
$ forall pass.
XForAllTy pass
-> HsForAllTelescope pass -> LHsType pass -> HsType pass
HsForAllTy NoExtField
Ghc.noExtField
             (forall (p :: Pass).
EpAnnForallTy
-> [LHsTyVarBndr Specificity (GhcPass p)]
-> HsForAllTelescope (GhcPass p)
mkHsForAllInvisTele forall a. EpAnn a
Ghc.noAnn [forall {e} {ann}. e -> GenLocated (SrcAnn ann) e
toLoc forall a b. (a -> b) -> a -> b
$ forall flag pass.
XUserTyVar pass -> flag -> LIdP pass -> HsTyVarBndr flag pass
UserTyVar forall a. EpAnn a
Ghc.noAnn Specificity
SpecifiedSpec GenLocated (SrcAnn NameAnn) Name
aName]) forall a b. (a -> b) -> a -> b
$ LHsType GhcRn -> LHsType GhcRn -> LHsType GhcRn
mkHsFunTy GenLocated SrcSpanAnnA (HsType GhcRn)
aTy (LHsType GhcRn -> LHsType GhcRn -> LHsType GhcRn
mkHsFunTy GenLocated SrcSpanAnnA (HsType GhcRn)
aTy LHsType GhcRn
boolTy')
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Maybe (Int, FixityDirection) -> LHsType GhcRn -> TcWiredIn
TcWiredIn Name
n (forall a. a -> Maybe a
Just (Int
4, FixityDirection
Ghc.InfixN)) GenLocated SrcSpanAnnA (HsType GhcRn)
ty

  -- TODO: This is defined as a measure in liquidhaskell GHC.Base_LHAssumptions. We probably want to insert all measures to the environment.
  -- len :: forall a. [a] -> Int
  len :: m TcWiredIn
len = do
    Name
n <- forall {m :: * -> *}. MonadUnique m => [Char] -> m Name
toName [Char]
"len"
    GenLocated (SrcAnn NameAnn) Name
aName <- forall {e} {ann}. e -> GenLocated (SrcAnn ann) e
toLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {m :: * -> *}. MonadUnique m => [Char] -> m Name
toName [Char]
"a"
    let aTy :: GenLocated SrcSpanAnnA (HsType GhcRn)
aTy = forall {pass} {a} {ann}.
(XTyVar pass ~ EpAnn a) =>
XRec pass (IdP pass) -> GenLocated (SrcAnn ann) (HsType pass)
nameToTy GenLocated (SrcAnn NameAnn) Name
aName
    let ty :: GenLocated SrcSpanAnnA (HsType GhcRn)
ty = forall {e} {ann}. e -> GenLocated (SrcAnn ann) e
toLoc forall a b. (a -> b) -> a -> b
$ forall pass.
XForAllTy pass
-> HsForAllTelescope pass -> LHsType pass -> HsType pass
HsForAllTy NoExtField
Ghc.noExtField
               (forall (p :: Pass).
EpAnnForallTy
-> [LHsTyVarBndr Specificity (GhcPass p)]
-> HsForAllTelescope (GhcPass p)
mkHsForAllInvisTele forall a. EpAnn a
Ghc.noAnn [forall {e} {ann}. e -> GenLocated (SrcAnn ann) e
toLoc forall a b. (a -> b) -> a -> b
$ forall flag pass.
XUserTyVar pass -> flag -> LIdP pass -> HsTyVarBndr flag pass
UserTyVar forall a. EpAnn a
Ghc.noAnn Specificity
SpecifiedSpec GenLocated (SrcAnn NameAnn) Name
aName]) forall a b. (a -> b) -> a -> b
$ LHsType GhcRn -> LHsType GhcRn -> LHsType GhcRn
mkHsFunTy (forall {pass} {a} {ann} {ann} {ann}.
(XAppTy pass ~ NoExtField, XTyVar pass ~ EpAnn a,
 XRec pass (IdP pass) ~ GenLocated (SrcAnn ann) Name,
 XRec pass (HsType pass) ~ GenLocated (SrcAnn ann) (HsType pass)) =>
GenLocated (SrcAnn ann) (HsType pass)
-> GenLocated (SrcAnn ann) (HsType pass)
listTy GenLocated SrcSpanAnnA (HsType GhcRn)
aTy) forall {pass} {a} {ann} {ann}.
(XTyVar pass ~ EpAnn a,
 XRec pass (IdP pass) ~ GenLocated (SrcAnn ann) Name) =>
GenLocated (SrcAnn ann) (HsType pass)
intTy'
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Maybe (Int, FixityDirection) -> LHsType GhcRn -> TcWiredIn
TcWiredIn Name
n forall a. Maybe a
Nothing GenLocated SrcSpanAnnA (HsType GhcRn)
ty

prependGHCRealQual :: FastString -> RdrName
prependGHCRealQual :: FastString -> RdrName
prependGHCRealQual = Module -> FastString -> RdrName
varQual_RDR Module
gHC_REAL

isFromGHCReal :: NamedThing a => a -> Bool
isFromGHCReal :: forall a. NamedThing a => a -> Bool
isFromGHCReal a
x = HasDebugCallStack => Name -> Module
Ghc.nameModule (forall a. NamedThing a => a -> Name
Ghc.getName a
x) forall a. Eq a => a -> a -> Bool
== Module
gHC_REAL