{-# LANGUAGE CPP                       #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE MagicHash                 #-}
{-# 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 #-}
{-# OPTIONS_GHC -Wno-x-partial #-}

-- | 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           Data.Word (Word64)
import           Debug.Trace

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


import           Data.Char                                  (isDigit, 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, when)
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 Id
_ TyConBndrVis
AnonTCB) = Bool
True
isAnonBinder (Bndr Id
_ TyConBndrVis
_)           = Bool
False

mkAlive :: Var -> Id
mkAlive :: Id -> Id
mkAlive Id
x
  | Id -> Bool
isId Id
x Bool -> Bool -> Bool
&& OccInfo -> Bool
isDeadOcc (Id -> OccInfo
idOccInfo Id
x)
  = Id -> IdInfo -> Id
setIdInfo Id
x (IdInfo -> OccInfo -> IdInfo
setOccInfo (HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
x) OccInfo
noOccInfo)
  | Bool
otherwise
  = Id
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 LexicalFastString
_) = RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
ss Maybe BufSpan
forall a. Maybe a
strictNothing
tickSrcSpan CoreTickish
_                 = SrcSpan
noSrcSpan

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

-- FIXME: reusing uniques like this is really dangerous
stringTyVar :: String -> TyVar
stringTyVar :: [Char] -> Id
stringTyVar [Char]
s = Name -> Kind -> Id
mkTyVar Name
name Kind
liftedTypeKind
  where
    name :: Name
name      = Unique -> OccName -> SrcSpan -> Name
mkInternalName (Char -> Word64 -> Unique
mkUnique Char
'x' Word64
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] -> Kind -> Id
stringVar [Char]
s Kind
t = IdDetails -> Name -> Kind -> Kind -> IdInfo -> Id
mkLocalVar IdDetails
VanillaId Name
name Kind
ManyTy Kind
t IdInfo
vanillaIdInfo
   where
      name :: Name
name = Unique -> OccName -> SrcSpan -> Name
mkInternalName (Char -> Word64 -> Unique
mkUnique Char
'x' Word64
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 Id
maybeAuxVar Symbol
s
  | Symbol -> Bool
forall a. Symbolic a => a -> Bool
isMethod Symbol
sym = Id -> Maybe Id
forall a. a -> Maybe a
Just Id
sv
  | Bool
otherwise = Maybe Id
forall a. Maybe a
Nothing
  where (Symbol
_, Word64
uid) = Symbol -> (Symbol, Word64)
splitModuleUnique Symbol
s
        sym :: Symbol
sym = Symbol -> Symbol
dropModuleNames Symbol
s
        sv :: Id
sv = IdDetails -> Name -> Kind -> Id
mkExportedLocalId IdDetails
VanillaId Name
name Kind
anyTy
        -- 'x' is chosen for no particular reason..
        name :: Name
name = Unique -> OccName -> SrcSpan -> Name
mkInternalName (Char -> Word64 -> Unique
mkUnique Char
'x' Word64
uid) OccName
occ SrcSpan
noSrcSpan
        occ :: OccName
occ = [Char] -> OccName
mkVarOcc (Text -> [Char]
T.unpack (Symbol -> Text
symbolText Symbol
sym))

stringTyCon :: Char -> UniqueId -> String -> TyCon
stringTyCon :: Char -> Word64 -> [Char] -> TyCon
stringTyCon = Kind -> Char -> Word64 -> [Char] -> TyCon
stringTyConWithKind Kind
anyTy

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

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

-- same as Constraint isBase
isBaseType :: Type -> Bool
isBaseType :: Kind -> Bool
isBaseType (ForAllTy ForAllTyBinder
_ 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 Id
_)     = 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 :: Id -> Bool
isTmpVar = Symbol -> Bool
isTmpSymbol (Symbol -> Bool) -> (Id -> Symbol) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Symbol
dropModuleNamesAndUnique (Symbol -> Symbol) -> (Id -> Symbol) -> Id -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> 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 :: [Char] -> Bool
validTyVar s :: [Char]
s@(Char
c:[Char]
_) = Char -> Bool
isLower Char
c Bool -> Bool -> Bool
&& Bool -> Bool
not ((Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
isSpace [Char]
s)
validTyVar [Char]
_       = Bool
False

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

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 Id
b Expr Id
e) = Id -> Expr Id -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
b (Expr Id -> Expr Id
unTickExpr Expr Id
e)
unTick (Rec [(Id, Expr Id)]
bs)     = [(Id, Expr Id)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ([(Id, Expr Id)] -> CoreBind) -> [(Id, Expr Id)] -> CoreBind
forall a b. (a -> b) -> a -> b
$ ((Id, Expr Id) -> (Id, Expr Id))
-> [(Id, Expr Id)] -> [(Id, Expr Id)]
forall a b. (a -> b) -> [a] -> [b]
map ((Expr Id -> Expr Id) -> (Id, Expr Id) -> (Id, Expr Id)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Expr Id -> Expr Id
unTickExpr) [(Id, Expr Id)]
bs

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

isFractionalClass :: Class -> Bool
isFractionalClass :: Class -> Bool
isFractionalClass Class
clas = Class -> Unique
classKey Class
clas Unique -> [Unique] -> Bool
forall a. Eq a => a -> [a] -> Bool
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 Unique -> Unique -> Bool
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 = [Char] -> a -> a
forall a. [Char] -> a -> a
trace ([Char]
"\nTrace: [" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"] : " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
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
forall doc. IsLine doc => [Char] -> doc
text ([Char] -> SDoc) -> (a -> [Char]) -> a -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Char]
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 ([Char] -> Doc) -> (a -> [Char]) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Char]
PJ.render (Doc -> [Char]) -> (a -> Doc) -> a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc
forall a. Fixpoint a => a -> Doc
toFix

sDocDoc :: Ghc.SDoc -> PJ.Doc
sDocDoc :: SDoc -> Doc
sDocDoc   = [Char] -> Doc
PJ.text ([Char] -> Doc) -> (SDoc -> [Char]) -> SDoc -> Doc
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 (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 :: forall a. Outputable a => a -> [Char]
showPpr = a -> [Char]
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.NamePprCtx
myQualify :: NamePprCtx
myQualify = NamePprCtx
Ghc.neverQualify { Ghc.queryQualifyName = Ghc.alwaysQualifyNames }
-- { Ghc.queryQualifyName = \_ _ -> Ghc.NameNotInScope1 }

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

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 :: forall a. Outputable a => a -> [Char]
typeUniqueString = {- ("sort_" ++) . -} SDoc -> [Char]
showSDocDump (SDoc -> [Char]) -> (a -> SDoc) -> a -> [Char]
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
$c== :: Loc -> Loc -> Bool
== :: Loc -> Loc -> Bool
$c/= :: Loc -> Loc -> Bool
/= :: 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
$ccompare :: Loc -> Loc -> Ordering
compare :: Loc -> Loc -> Ordering
$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
>= :: Loc -> Loc -> Bool
$cmax :: Loc -> Loc -> Loc
max :: Loc -> Loc -> Loc
$cmin :: Loc -> Loc -> Loc
min :: Loc -> Loc -> Loc
Ord, Int -> Loc -> [Char] -> [Char]
[Loc] -> [Char] -> [Char]
Loc -> [Char]
(Int -> Loc -> [Char] -> [Char])
-> (Loc -> [Char]) -> ([Loc] -> [Char] -> [Char]) -> Show Loc
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Loc -> [Char] -> [Char]
showsPrec :: Int -> Loc -> [Char] -> [Char]
$cshow :: Loc -> [Char]
show :: Loc -> [Char]
$cshowList :: [Loc] -> [Char] -> [Char]
showList :: [Loc] -> [Char] -> [Char]
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 UnhelpfulSpanReason
reason) = case UnhelpfulSpanReason
reason of
    UnhelpfulSpanReason
UnhelpfulNoLocationInfo -> Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
i (FastString -> Int
uniq (FastString -> Int) -> FastString -> Int
forall a b. (a -> b) -> a -> b
$ [Char] -> FastString
fsLit [Char]
"UnhelpfulNoLocationInfo")
    UnhelpfulSpanReason
UnhelpfulWiredIn        -> Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
i (FastString -> Int
uniq (FastString -> Int) -> FastString -> Int
forall a b. (a -> b) -> a -> b
$ [Char] -> FastString
fsLit [Char]
"UnhelpfulWiredIn")
    UnhelpfulSpanReason
UnhelpfulInteractive    -> Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
i (FastString -> Int
uniq (FastString -> Int) -> FastString -> Int
forall a b. (a -> b) -> a -> b
$ [Char] -> FastString
fsLit [Char]
"UnhelpfulInteractive")
    UnhelpfulSpanReason
UnhelpfulGenerated      -> Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
i (FastString -> Int
uniq (FastString -> Int) -> FastString -> Int
forall a b. (a -> b) -> a -> b
$ [Char] -> FastString
fsLit [Char]
"UnhelpfulGenerated")
    UnhelpfulOther FastString
fs       -> Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
i (FastString -> Int
uniq FastString
fs)
  hashWithSalt Int
i (RealSrcSpan RealSrcSpan
s Maybe BufSpan
_)      = 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 :: forall a. Loc a => 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 :: forall a. Loc a => 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 -> 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')) Maybe BufSpan
forall a. Maybe a
strictNothing
  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    = [Char] -> (FastString -> [Char]) -> Maybe FastString -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" FastString -> [Char]
unpackFS (Maybe FastString -> [Char])
-> (SrcSpan -> Maybe FastString) -> SrcSpan -> [Char]
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 = [Char] -> Int -> Int -> SourcePos
safeSourcePos [Char]
file Int
line Int
col
  where
    file :: [Char]
file               = FastString -> [Char]
unpackFS (FastString -> [Char]) -> FastString -> [Char]
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 (FastString -> [Char]) -> FastString -> [Char]
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 (FastString -> [Char]) -> FastString -> [Char]
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  (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 :: forall a. NamedThing a => 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 :: forall a. NamedThing a => 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 :: Id -> SrcSpan
srcSpan Id
v = SourcePos -> SourcePos -> SrcSpan
SS (Id -> SourcePos
forall a. NamedThing a => a -> SourcePos
getSourcePos Id
v) (Id -> SourcePos
forall a. NamedThing a => a -> SourcePos
getSourcePosE Id
v)

instance F.Loc Name where
  srcSpan :: Name -> SrcSpan
srcSpan Name
v = SourcePos -> SourcePos -> SrcSpan
SS (Name -> SourcePos
forall a. NamedThing a => a -> SourcePos
getSourcePos Name
v) (Name -> SourcePos
forall a. NamedThing a => a -> SourcePos
getSourcePosE Name
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 = 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 :: forall a. (Kind -> a) -> Id -> Located a
varLocInfo Kind -> a
f Id
x = Kind -> a
f (Kind -> a) -> (Id -> Kind) -> Id -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Kind
varType (Id -> a) -> Located Id -> Located a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> Located Id
forall a. NamedThing a => a -> Located a
locNamedThing Id
x

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

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

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

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

idDataConM :: Id -> Maybe DataCon
idDataConM :: Id -> Maybe DataCon
idDataConM Id
x = case Id -> IdDetails
idDetails Id
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 :: Id -> Bool
isDataConId = Maybe DataCon -> Bool
forall a. Maybe a -> Bool
isJust (Maybe DataCon -> Bool) -> (Id -> Maybe DataCon) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Maybe DataCon
idDataConM

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

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


kindArity :: Kind -> Arity
kindArity :: Kind -> Int
kindArity (ForAllTy ForAllTyBinder
_ 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 :: forall a. Uniquable a => Int -> a -> Int
uniqueHash Int
i = Int -> Word64 -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
i (Word64 -> Int) -> (a -> Word64) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique -> Word64
getKey (Unique -> Word64) -> (a -> Unique) -> a -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Unique
forall a. Uniquable a => a -> Unique
getUnique

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

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

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

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

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

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 -> [Id]
tyConTyVarsDef TyCon
c
  | TyCon -> Bool
noTyVars TyCon
c = []
  | Bool
otherwise  = TyCon -> [Id]
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
Ghc.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 :: Id -> Symbol
symbol Id
v
    | Id -> Bool
isExternalId Id
v = Id -> Symbol
exportedVarSymbol Id
v
    | Bool
otherwise      = Id -> Symbol
localVarSymbol    Id
v


instance Hashable Var where
  hashWithSalt :: Int -> Id -> Int
hashWithSalt = Int -> Id -> 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 Class where
  hashWithSalt :: Int -> Class -> Int
hashWithSalt = Int -> Class -> 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 :: Id -> Doc
toFix = Id -> 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 -> [Char]
show = Symbol -> [Char]
symbolString (Symbol -> [Char]) -> (Name -> Symbol) -> Name -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Symbol
forall a. Symbolic a => a -> Symbol
symbol

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

instance Show Class where
  show :: Class -> [Char]
show = Name -> [Char]
forall a. Show a => a -> [Char]
show (Name -> [Char]) -> (Class -> Name) -> Class -> [Char]
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 -> [Char]
show = Name -> [Char]
forall a. Show a => a -> [Char]
show (Name -> [Char]) -> (TyCon -> Name) -> TyCon -> [Char]
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 -> () -> ()
forall a b. a -> b -> b
seq Class
t ()

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

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

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

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

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

splitModuleUnique :: Symbol -> (Symbol, UniqueId)
splitModuleUnique :: Symbol -> (Symbol, Word64)
splitModuleUnique Symbol
x = (Symbol -> Symbol
dropModuleNamesAndUnique Symbol
x, Word64 -> Word64
toUniqueId (Word64 -> Word64) -> Word64 -> Word64
forall a b. (a -> b) -> a -> b
$ Symbol -> Word64
base62ToW (Symbol -> Symbol
takeModuleUnique Symbol
x))

base62ToW :: Symbol -> Word64
base62ToW :: Symbol -> Word64
base62ToW Symbol
s =  Word64 -> Maybe Word64 -> Word64
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Word64
forall a. HasCallStack => [Char] -> a
errorstar [Char]
"base62ToW Out Of Range") (Maybe Word64 -> Word64) -> Maybe Word64 -> Word64
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Word64
go (Symbol -> Text
F.symbolText Symbol
s)
  where
    digitToW :: OM.Map Char Word64
    digitToW :: Map Char Word64
digitToW = [(Char, Word64)] -> Map Char Word64
forall k a. Ord k => [(k, a)] -> Map k a
OM.fromList ([(Char, Word64)] -> Map Char Word64)
-> [(Char, Word64)] -> Map Char Word64
forall a b. (a -> b) -> a -> b
$ [Char] -> [Word64] -> [(Char, Word64)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Char
'0'..Char
'9'] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char
'a'..Char
'z'] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char
'A'..Char
'Z']) [Word64
0..]
    f :: Word64 -> Char -> Maybe Word64
f Word64
acc ((Char -> Map Char Word64 -> Maybe Word64)
-> Map Char Word64 -> Char -> Maybe Word64
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> Map Char Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
OM.lookup Map Char Word64
digitToW -> Maybe Word64
x) = (Word64
acc Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
62 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+) (Word64 -> Word64) -> Maybe Word64 -> Maybe Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Word64
x
    go :: Text -> Maybe Word64
go = (Word64 -> Char -> Maybe Word64)
-> Word64 -> [Char] -> Maybe Word64
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Word64 -> Char -> Maybe Word64
f Word64
0 ([Char] -> Maybe Word64)
-> (Text -> [Char]) -> Text -> Maybe Word64
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 (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' = (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
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 [Char] -> [Text] -> Symbol
forall {b}. Symbolic b => [Char] -> ListNE b -> Symbol
headName Text
sepUnique   [Char]
"dropModuleUnique: "
  where
    headName :: [Char] -> ListNE b -> Symbol
headName [Char]
msg = b -> Symbol
forall a. Symbolic a => a -> Symbol
symbol (b -> Symbol) -> (ListNE b -> b) -> ListNE b -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ListNE b -> b
forall a. HasCallStack => [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 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 :: ([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 -> Bool
isTupleSymbol Symbol
s' = Symbol
s'
  | Bool
otherwise        = [Char] -> [Text] -> Symbol
f ([Char]
msg [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
s) ([Text] -> Symbol) -> [Text] -> Symbol
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
d (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text
stripParens Text
s

isTupleSymbol :: Symbol -> Bool
isTupleSymbol :: Symbol -> Bool
isTupleSymbol Symbol
s =
    let t :: Text
t = Symbol -> Text
F.symbolText Symbol
s
     in Text -> Text -> Bool
T.isPrefixOf Text
"Tuple" Text
t Bool -> Bool -> Bool
&&
        (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isDigit (Int -> Text -> Text
T.drop Int
5 Text
t) Bool -> Bool -> Bool
&&
        Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
5

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 :: forall a. (IsString a, Monoid a) => 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 :: forall a. Symbolic a => 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 :: forall a. Symbolic a => 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 :: forall a. Symbolic a => 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 :: forall a. Symbolic a => a -> Bool
isWorker a
s = [Char] -> Bool -> Bool
forall a. PPrint a => [Char] -> a -> a
notracepp ([Char]
"isWorkerSym: s = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ss) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Char]
"$W" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isInfixOf` [Char]
ss
  where
    ss :: [Char]
ss     = Symbol -> [Char]
symbolString (a -> Symbol
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" (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

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)

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

gHC_VERSION :: String
gHC_VERSION :: [Char]
gHC_VERSION = Int -> [Char]
forall a. Show a => a -> [Char]
show (__GLASGOW_HASKELL__ :: Int)

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

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

showCBs :: Bool -> [CoreBind] -> String
showCBs :: Bool -> [CoreBind] -> [Char]
showCBs Bool
untidy
  | Bool
untidy    =
    SDocContext -> SDoc -> [Char]
Ghc.renderWithContext SDocContext
ctx (SDoc -> [Char]) -> ([CoreBind] -> SDoc) -> [CoreBind] -> [Char]
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] -> [Char]
forall a. Outputable a => a -> [Char]
showPpr
  where
    ctx :: SDocContext
ctx = SDocContext
Ghc.defaultSDocContext { sdocPprDebug = True }

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


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

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


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



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

simplesymbol :: (NamedThing t) => t -> Symbol
simplesymbol :: forall t. NamedThing t => 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 :: forall a. 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 :: Id -> Kind
expandVarType = Kind -> Kind
expandTypeSynonyms (Kind -> Kind) -> (Id -> Kind) -> Id -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Kind
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 Id -> Bool
isEmbeddedDictExpr = Kind -> Bool
isEmbeddedDictType (Kind -> Bool) -> (Expr Id -> Kind) -> Expr Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Expr Id -> Kind
Expr Id -> Kind
exprType

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

isEmbeddedDictType :: Type -> Bool
isEmbeddedDictType :: Kind -> Bool
isEmbeddedDictType = [Kind -> Bool] -> Kind -> Bool
forall a. [a -> Bool] -> a -> Bool
anyF [Kind -> Bool
isOrdPred, Kind -> Bool
isNumericPred, Kind -> Bool
isEqPred, Kind -> 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 :: Kind -> Bool
isPrelEqPred Kind
ty = case Kind -> Maybe TyCon
tyConAppTyCon_maybe Kind
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 TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqClassKey

isOrdPred :: Type -> Bool
isOrdPred :: Kind -> Bool
isOrdPred Kind
ty = case Kind -> Maybe TyCon
tyConAppTyCon_maybe Kind
ty of
  Just TyCon
tyCon -> TyCon
tyCon TyCon -> Unique -> Bool
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 :: Kind -> Bool
isNumericPred Kind
ty = case Kind -> Maybe TyCon
tyConAppTyCon_maybe Kind
ty of
  Just TyCon
tyCon -> TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyCon
tyCon Unique -> [Unique] -> Bool
forall a. Eq a => a -> [a] -> Bool
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 Id -> Bool
isPredExpr = Kind -> Bool
isPredType (Kind -> Bool) -> (Expr Id -> Kind) -> Expr Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Expr Id -> Kind
Expr Id -> Kind
Ghc.exprType

isPredVar :: Var -> Bool
isPredVar :: Id -> Bool
isPredVar Id
v = [Char] -> Bool -> Bool
forall a. PPrint a => [Char] -> a -> a
F.notracepp [Char]
msg (Bool -> Bool) -> (Id -> Bool) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> Bool
isPredType (Kind -> Bool) -> (Id -> Kind) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Kind
varType (Id -> Bool) -> Id -> Bool
forall a b. (a -> b) -> a -> b
$ Id
v
  where
    msg :: [Char]
msg     =  [Char]
"isGoodCaseBind v = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Id -> [Char]
forall a. Show a => a -> [Char]
show Id
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 :: forall a. [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, [Id], [Kind])]
defaultDataCons (TyConApp TyCon
tc [Kind]
argτs) [AltCon]
ds = do
  allDs     <- TyCon -> Maybe [DataCon]
Ghc.tyConDataCons_maybe TyCon
tc
  let seenDs = [DataCon
d | DataAlt DataCon
d <- [AltCon]
ds ]
  let defDs  = (DataCon -> [Char]) -> [DataCon] -> [DataCon] -> [DataCon]
forall k a. (Eq k, Hashable k) => (a -> k) -> [a] -> [a] -> [a]
keyDiff DataCon -> [Char]
forall a. Outputable a => a -> [Char]
showPpr [DataCon]
allDs [DataCon]
seenDs
  return [ (d, Ghc.dataConExTyCoVars d, map irrelevantMult $ Ghc.dataConInstArgTys d argτs) | d <- defDs ]

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



isEvVar :: Id -> Bool
isEvVar :: Id -> Bool
isEvVar Id
x = Id -> Bool
isPredVar Id
x Bool -> Bool -> Bool
|| Id -> Bool
isTyVar Id
x Bool -> Bool -> Bool
|| Id -> Bool
isCoVar Id
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 Id)
elabRnExpr LHsExpr GhcPs
rdr_expr = do
    (rn_expr, _fvs) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
rdr_expr
    failIfErrsM

    -- Typecheck the expression
    ((tclvl, (tc_expr, res_ty)), lie)
          <- captureTopConstraints $
             pushTcLevelM          $
             tcInferRho rn_expr

    -- Generalise
    uniq <- newUnique
    let { fresh_it = Unique -> SrcSpan -> Name
itName Unique
uniq (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
rdr_expr) }
    ((_qtvs, _dicts, evbs, _), residual)
         <- captureConstraints $
            simplifyInfer tclvl NoRestrictions
                          []    {- No sig vars -}
                          [(fresh_it, res_ty)]
                          lie

    -- Ignore the dictionary bindings
    evbs' <- simplifyInteractive residual
    full_expr <- zonkTopLExpr (mkHsDictLet (EvBinds evbs') (mkHsDictLet evbs tc_expr))
    (ds_msgs, me) <- initDsTc $ dsLExpr full_expr

    logger <- getLogger
    diag_opts <- initDiagOpts <$> getDynFlags
    print_config <- initDsMessageOpts <$> getDynFlags
    liftIO $ printMessages logger print_config diag_opts ds_msgs

    case me of
      Maybe (Expr Id)
Nothing -> TcRn (Expr Id)
forall env a. IOEnv env a
failM
      Just Expr Id
e -> do
        Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Messages DsMessage -> Bool
forall e. Messages e -> Bool
errorsOrFatalWarningsFound Messages DsMessage
ds_msgs)
          TcRn ()
forall env a. IOEnv env a
failM
        Expr Id -> TcRn (Expr Id)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Id
e

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

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

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

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


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

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

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


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

coherenceObligToRefE :: F.Expr -> [Id] -> [Id] -> F.Reft
coherenceObligToRefE :: Expr -> [Id] -> [Id] -> Reft
coherenceObligToRefE Expr
e [Id]
rps0 [Id]
rps1 = (Symbol, Expr) -> Reft
forall v. (Symbol, ExprV v) -> ReftV v
F.Reft (Symbol
F.vv_, Brel -> Expr -> Expr -> Expr
forall v. Brel -> ExprV v -> ExprV v -> ExprV v
F.PAtom Brel
F.Eq Expr
lhs Expr
rhs)
  where lhs :: Expr
lhs = (Expr -> Expr -> Expr) -> Expr -> [Expr] -> Expr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
L.foldr Expr -> Expr -> Expr
forall v. ExprV v -> ExprV v -> ExprV v
EApp Expr
e [Expr]
ps0
        rhs :: Expr
rhs = (Expr -> Expr -> Expr) -> Expr -> [Expr] -> Expr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
L.foldr Expr -> Expr -> Expr
forall v. ExprV v -> ExprV v -> ExprV v
EApp (Symbol -> Expr
forall a. Symbolic a => a -> Expr
F.eVar Symbol
F.vv_) [Expr]
ps1
        ps0 :: [Expr]
ps0 = Symbol -> Expr
forall a. Symbolic a => a -> Expr
F.eVar (Symbol -> Expr) -> (Id -> Symbol) -> Id -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Symbol
forall a. Symbolic a => a -> Symbol
F.symbol (Id -> Expr) -> [Id] -> [Expr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Id] -> [Id]
forall a. [a] -> [a]
L.reverse [Id]
rps0
        ps1 :: [Expr]
ps1 = Symbol -> Expr
forall a. Symbolic a => a -> Expr
F.eVar (Symbol -> Expr) -> (Id -> Symbol) -> Id -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Symbol
forall a. Symbolic a => a -> Symbol
F.symbol (Id -> Expr) -> [Id] -> [Expr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Id] -> [Id]
forall a. [a] -> [a]
L.reverse [Id]
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 = TcM a -> TcM a
forall a. TcM a -> TcM a
discardConstraints (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$ do
  -- undef <- lookupUndef
  wiredIns <- IOEnv (Env TcGblEnv TcLclEnv) [TcWiredIn]
forall {m :: * -> *}. MonadUnique m => m [TcWiredIn]
mkWiredIns
  -- snd <$> tcValBinds Ghc.NotTopLevel (binds undef wiredIns) (sigs wiredIns) m
  (_, _, a) <- tcValBinds Ghc.NotTopLevel [] (sigs wiredIns) m
  return a

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

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

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

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

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

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

  boolTy' :: LHsType GhcRn
  boolTy' :: LHsType GhcRn
boolTy' = LIdP GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall {l} {pass}.
(HasAnnotation l, NoAnn (XTyVar pass)) =>
XRec pass (IdP pass) -> GenLocated l (HsType pass)
nameToTy (LIdP GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> LIdP GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$ Name -> GenLocated SrcSpanAnnN Name
forall {l} {e}. HasAnnotation l => e -> GenLocated l 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 l (HsType pass)
intTy' = XRec pass (IdP pass) -> GenLocated l (HsType pass)
forall {l} {pass}.
(HasAnnotation l, NoAnn (XTyVar pass)) =>
XRec pass (IdP pass) -> GenLocated l (HsType pass)
nameToTy (XRec pass (IdP pass) -> GenLocated l (HsType pass))
-> XRec pass (IdP pass) -> GenLocated l (HsType pass)
forall a b. (a -> b) -> a -> b
$ Name -> GenLocated l Name
forall {l} {e}. HasAnnotation l => e -> GenLocated l e
toLoc Name
intTyConName
  listTy :: GenLocated l (HsType pass) -> GenLocated l (HsType pass)
listTy GenLocated l (HsType pass)
lt = HsType pass -> GenLocated l (HsType pass)
forall {l} {e}. HasAnnotation l => e -> GenLocated l e
toLoc (HsType pass -> GenLocated l (HsType pass))
-> HsType pass -> GenLocated l (HsType pass)
forall a b. (a -> b) -> a -> b
$ XAppTy pass
-> XRec pass (HsType pass)
-> XRec pass (HsType pass)
-> HsType pass
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy XAppTy pass
NoExtField
Ghc.noExtField (XRec pass (IdP pass) -> GenLocated l (HsType pass)
forall {l} {pass}.
(HasAnnotation l, NoAnn (XTyVar pass)) =>
XRec pass (IdP pass) -> GenLocated l (HsType pass)
nameToTy (XRec pass (IdP pass) -> GenLocated l (HsType pass))
-> XRec pass (IdP pass) -> GenLocated l (HsType pass)
forall a b. (a -> b) -> a -> b
$ Name -> GenLocated l Name
forall {l} {e}. HasAnnotation l => e -> GenLocated l e
toLoc Name
listTyConName) XRec pass (HsType pass)
GenLocated l (HsType pass)
lt

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

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

  -- infix 4 == :: forall a . a -> a -> Bool
  eq :: m TcWiredIn
eq = do
    n <- [Char] -> m Name
forall {m :: * -> *}. MonadUnique m => [Char] -> m Name
toName [Char]
"=="
    aName <- toLoc <$> toName "a"
    let aTy = LIdP GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall {l} {pass}.
(HasAnnotation l, NoAnn (XTyVar pass)) =>
XRec pass (IdP pass) -> GenLocated l (HsType pass)
nameToTy LIdP GhcRn
GenLocated (Anno (IdGhcP 'Renamed)) Name
aName
    let ty = HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall {l} {e}. HasAnnotation l => e -> GenLocated l e
toLoc (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$ XForAllTy GhcRn
-> HsForAllTelescope GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XForAllTy pass
-> HsForAllTelescope pass -> LHsType pass -> HsType pass
HsForAllTy XForAllTy GhcRn
NoExtField
Ghc.noExtField
             (EpAnnForallTy
-> [LHsTyVarBndr Specificity GhcRn] -> HsForAllTelescope GhcRn
forall (p :: Pass).
EpAnnForallTy
-> [LHsTyVarBndr Specificity (GhcPass p)]
-> HsForAllTelescope (GhcPass p)
mkHsForAllInvisTele EpAnnForallTy
forall a. NoAnn a => a
Ghc.noAnn [HsTyVarBndr Specificity GhcRn
-> GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)
forall {l} {e}. HasAnnotation l => e -> GenLocated l e
toLoc (HsTyVarBndr Specificity GhcRn
 -> GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn))
-> HsTyVarBndr Specificity GhcRn
-> GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)
forall a b. (a -> b) -> a -> b
$ XUserTyVar GhcRn
-> Specificity -> LIdP GhcRn -> HsTyVarBndr Specificity GhcRn
forall flag pass.
XUserTyVar pass -> flag -> LIdP pass -> HsTyVarBndr flag pass
UserTyVar [AddEpAnn]
XUserTyVar GhcRn
forall a. NoAnn a => a
Ghc.noAnn Specificity
SpecifiedSpec LIdP GhcRn
GenLocated (Anno (IdGhcP 'Renamed)) Name
aName]) (LHsType GhcRn -> HsType GhcRn) -> LHsType GhcRn -> HsType GhcRn
forall a b. (a -> b) -> a -> b
$ LHsType GhcRn -> LHsType GhcRn -> LHsType GhcRn
mkHsFunTy LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
aTy (LHsType GhcRn -> LHsType GhcRn -> LHsType GhcRn
mkHsFunTy LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
aTy LHsType GhcRn
boolTy')
    return $ TcWiredIn n (Just (4, Ghc.InfixN)) 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
    n <- [Char] -> m Name
forall {m :: * -> *}. MonadUnique m => [Char] -> m Name
toName [Char]
"len"
    aName <- toLoc <$> toName "a"
    let aTy = LIdP GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall {l} {pass}.
(HasAnnotation l, NoAnn (XTyVar pass)) =>
XRec pass (IdP pass) -> GenLocated l (HsType pass)
nameToTy LIdP GhcRn
GenLocated (Anno (IdGhcP 'Renamed)) Name
aName
    let ty = HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall {l} {e}. HasAnnotation l => e -> GenLocated l e
toLoc (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$ XForAllTy GhcRn
-> HsForAllTelescope GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XForAllTy pass
-> HsForAllTelescope pass -> LHsType pass -> HsType pass
HsForAllTy XForAllTy GhcRn
NoExtField
Ghc.noExtField
               (EpAnnForallTy
-> [LHsTyVarBndr Specificity GhcRn] -> HsForAllTelescope GhcRn
forall (p :: Pass).
EpAnnForallTy
-> [LHsTyVarBndr Specificity (GhcPass p)]
-> HsForAllTelescope (GhcPass p)
mkHsForAllInvisTele EpAnnForallTy
forall a. NoAnn a => a
Ghc.noAnn [HsTyVarBndr Specificity GhcRn
-> GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)
forall {l} {e}. HasAnnotation l => e -> GenLocated l e
toLoc (HsTyVarBndr Specificity GhcRn
 -> GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn))
-> HsTyVarBndr Specificity GhcRn
-> GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)
forall a b. (a -> b) -> a -> b
$ XUserTyVar GhcRn
-> Specificity -> LIdP GhcRn -> HsTyVarBndr Specificity GhcRn
forall flag pass.
XUserTyVar pass -> flag -> LIdP pass -> HsTyVarBndr flag pass
UserTyVar [AddEpAnn]
XUserTyVar GhcRn
forall a. NoAnn a => a
Ghc.noAnn Specificity
SpecifiedSpec LIdP GhcRn
GenLocated (Anno (IdGhcP 'Renamed)) Name
aName]) (LHsType GhcRn -> HsType GhcRn) -> LHsType GhcRn -> HsType GhcRn
forall a b. (a -> b) -> a -> b
$ LHsType GhcRn -> LHsType GhcRn -> LHsType GhcRn
mkHsFunTy (GenLocated SrcSpanAnnA (HsType GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn)
forall {pass} {l} {l} {l}.
(IdP pass ~ Name, XAppTy pass ~ NoExtField,
 XRec pass (HsType pass) ~ GenLocated l (HsType pass),
 XRec pass Name ~ GenLocated l Name, NoAnn (XTyVar pass),
 HasAnnotation l, HasAnnotation l, HasAnnotation l) =>
GenLocated l (HsType pass) -> GenLocated l (HsType pass)
listTy GenLocated SrcSpanAnnA (HsType GhcRn)
aTy) LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
forall {pass} {l} {l}.
(IdP pass ~ Name, XRec pass Name ~ GenLocated l Name,
 NoAnn (XTyVar pass), HasAnnotation l, HasAnnotation l) =>
GenLocated l (HsType pass)
intTy'
    return $ TcWiredIn n Nothing ty

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

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