{-# 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 #-}

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

module  Language.Haskell.Liquid.GHC.Misc where

import           Data.String
import qualified Data.List as L
import           Debug.Trace

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


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

import qualified Data.Text.Encoding.Error                   as TE
import qualified Data.Text.Encoding                         as T
import qualified Data.Text                                  as T
import           Control.Arrow                              (second)
import           Control.Monad                              ((>=>), foldM, 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
_ (AnonTCB FunTyFlag
_)) = 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 ((() :: Constraint) => 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 [Char]
_) = 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 -> Int -> Unique
mkUnique Char
'x' Int
24)  OccName
occ SrcSpan
noSrcSpan
    occ :: OccName
occ       = [Char] -> OccName
mkTyVarOcc [Char]
s

-- FIXME: reusing uniques like this is really dangerous
stringVar :: String -> Type -> Var
stringVar :: [Char] -> 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 -> Int -> Unique
mkUnique Char
'x' Int
25) OccName
occ SrcSpan
noSrcSpan
      occ :: OccName
occ  = [Char] -> OccName
mkVarOcc [Char]
s

-- FIXME: plugging in dummy type like this is really dangerous
maybeAuxVar :: Symbol -> Maybe Var
maybeAuxVar :: Symbol -> Maybe 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
_, Int
uid) = Symbol -> (Symbol, Int)
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 -> Int -> Unique
mkUnique Char
'x' Int
uid) OccName
occ SrcSpan
noSrcSpan
        occ :: OccName
occ = [Char] -> OccName
mkVarOcc (Text -> [Char]
T.unpack (Symbol -> Text
symbolText Symbol
sym))

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

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

hasBaseTypeVar :: Var -> Bool
hasBaseTypeVar :: 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)

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. 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 {a}. Num a => Kind -> a
go (Kind -> Int) -> (TyCon -> Kind) -> TyCon -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> Kind
tyConKind
  where
    go :: Kind -> a
go (FunTy { ft_res :: Kind -> Kind
ft_res = Kind
res}) = a
1 a -> a -> a
forall a. Num a => a -> a -> a
+ Kind -> a
go Kind
res
    go Kind
_               = a
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 -> Int -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
i (Int -> Int) -> (a -> Int) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique -> Int
getKey (Unique -> Int) -> (a -> Unique) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Unique
forall a. Uniquable a => a -> Unique
getUnique

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

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

ignoreInline :: ParsedModule -> ParsedModule
ignoreInline :: ParsedModule -> ParsedModule
ignoreInline ParsedModule
x = ParsedModule
x {pm_parsed_source = go <$> pm_parsed_source x}
  where
    go :: HsModule GhcPs -> HsModule GhcPs
go  HsModule GhcPs
y      = HsModule GhcPs
y {hsmodDecls = filter go' (hsmodDecls y) }
    go' :: LHsDecl GhcPs -> Bool
    go' :: XRec GhcPs (HsDecl GhcPs) -> Bool
go' XRec GhcPs (HsDecl GhcPs)
z
      | SigD XSigD GhcPs
_ (InlineSig {}) <-  GenLocated SrcSpanAnnA (HsDecl GhcPs) -> HsDecl GhcPs
forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsDecl GhcPs)
GenLocated SrcSpanAnnA (HsDecl GhcPs)
z = Bool
False
      | Bool
otherwise                         = Bool
True

--------------------------------------------------------------------------------
-- | 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, Int)
splitModuleUnique :: Symbol -> (Symbol, Int)
splitModuleUnique Symbol
x = (Symbol -> Symbol
dropModuleNamesAndUnique Symbol
x, Symbol -> Int
base62ToI (Symbol -> Symbol
takeModuleUnique Symbol
x))

base62ToI :: Symbol -> Int
base62ToI :: Symbol -> Int
base62ToI Symbol
s =  Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Int
forall a. HasCallStack => [Char] -> a
errorstar [Char]
"base62ToI Out Of Range") (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Int
go (Symbol -> Text
F.symbolText Symbol
s)
  where
    digitToI :: OM.Map Char Int
    digitToI :: Map Char Int
digitToI = [(Char, Int)] -> Map Char Int
forall k a. Ord k => [(k, a)] -> Map k a
OM.fromList ([(Char, Int)] -> Map Char Int) -> [(Char, Int)] -> Map Char Int
forall a b. (a -> b) -> a -> b
$ [Char] -> [Int] -> [(Char, Int)]
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']) [Int
0..]
    f :: Int -> Char -> Maybe Int
f Int
acc ((Char -> Map Char Int -> Maybe Int)
-> Map Char Int -> Char -> Maybe Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> Map Char Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
OM.lookup Map Char Int
digitToI -> Maybe Int
x) = (Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
62 Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
x
    go :: Text -> Maybe Int
go = (Int -> Char -> Maybe Int) -> Int -> [Char] -> Maybe Int
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Int -> Char -> Maybe Int
f Int
0 ([Char] -> Maybe Int) -> (Text -> [Char]) -> Text -> Maybe Int
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
s' Symbol -> Symbol -> Bool
forall a. Eq a => a -> a -> Bool
== Symbol
tupConName = Symbol
tupConName
  | 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

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)

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

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

gHC_VERSION :: String
gHC_VERSION :: [Char]
gHC_VERSION = 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)]


findVarDef :: Symbol -> [CoreBind] -> Maybe (Var, CoreExpr)
findVarDef :: Symbol -> [CoreBind] -> Maybe (Id, Expr Id)
findVarDef Symbol
sym [CoreBind]
cbs = case [CoreBind]
xCbs 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
    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 ]
    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]


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
. (() :: Constraint) => 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
. (() :: Constraint) => 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
  [DataCon]
allDs     <- TyCon -> Maybe [DataCon]
Ghc.tyConDataCons_maybe TyCon
tc
  let seenDs :: [DataCon]
seenDs = [DataCon
d | DataAlt DataCon
d <- [AltCon]
ds ]
  let defDs :: [DataCon]
defDs  = (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
  [(DataCon, [Id], [Kind])] -> Maybe [(DataCon, [Id], [Kind])]
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return [ (DataCon
d, DataCon -> [Id]
Ghc.dataConExTyCoVars DataCon
d, (Scaled Kind -> Kind) -> [Scaled Kind] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Kind -> Kind
forall a. Scaled a -> a
irrelevantMult ([Scaled Kind] -> [Kind]) -> [Scaled Kind] -> [Kind]
forall a b. (a -> b) -> a -> b
$ DataCon -> [Kind] -> [Scaled Kind]
Ghc.dataConInstArgTys DataCon
d [Kind]
argτs) | DataCon
d <- [DataCon]
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
    (GenLocated SrcSpanAnnA (HsExpr GhcRn)
rn_expr, FreeVars
_fvs) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
rdr_expr
    TcRn ()
failIfErrsM

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

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

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

    Logger
logger <- IOEnv (Env TcGblEnv TcLclEnv) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
    DiagOpts
diag_opts <- DynFlags -> DiagOpts
initDiagOpts (DynFlags -> DiagOpts)
-> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
-> IOEnv (Env TcGblEnv TcLclEnv) DiagOpts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    NoDiagnosticOpts
print_config <- DynFlags -> NoDiagnosticOpts
DynFlags -> DiagnosticOpts DsMessage
initDsMessageOpts (DynFlags -> NoDiagnosticOpts)
-> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
-> IOEnv (Env TcGblEnv TcLclEnv) NoDiagnosticOpts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    IO () -> TcRn ()
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TcRn ()) -> IO () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Logger
-> DiagnosticOpts DsMessage
-> DiagOpts
-> Messages DsMessage
-> IO ()
forall a.
Diagnostic a =>
Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
printMessages Logger
logger NoDiagnosticOpts
DiagnosticOpts DsMessage
print_config DiagOpts
diag_opts Messages DsMessage
ds_msgs

    case Maybe (Expr Id)
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) = (() :: Constraint) => 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, (() :: Constraint) => 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, (() :: Constraint) => 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
    Map k [a]
ctid' <- m (Map k [a])
forall s (m :: * -> *). MonadState s m => m s
get
    (Map k [a] -> Map k [a]) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Map k [a] -> Map k [a] -> Map k [a])
-> Map k [a] -> Map k [a] -> Map k [a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (([a] -> [a] -> [a]) -> Map k [a] -> Map k [a] -> Map k [a]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
OM.unionWith [a] -> [a] -> [a]
forall a b. a -> b -> a
const) Map k [a]
tid)
    [([a], [a])] -> m [([a], [a])]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([([a], [a])] -> m [([a], [a])])
-> (Map k ([a], [a]) -> [([a], [a])])
-> Map k ([a], [a])
-> m [([a], [a])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k ([a], [a]) -> [([a], [a])]
forall k a. Map k a -> [a]
OM.elems (Map k ([a], [a]) -> m [([a], [a])])
-> Map k ([a], [a]) -> m [([a], [a])]
forall a b. (a -> b) -> a -> b
$ ([a] -> [a] -> ([a], [a]))
-> Map k [a] -> Map k [a] -> Map k ([a], [a])
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
OM.intersectionWith (,) Map k [a]
ctid' (([a] -> [a]) -> Map k [a] -> Map k [a]
forall a b. (a -> b) -> Map k a -> Map k b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> [a]
forall a. HasCallStack => [a] -> [a]
tail Map k [a]
tid)


-- to be zipped onto the super class selectors
coherenceObligToRef :: (F.Symbolic s) => s -> [Id] -> [Id] -> F.Reft
coherenceObligToRef :: forall s. Symbolic s => s -> [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
F.Reft (Symbol
F.vv_, Brel -> Expr -> Expr -> Expr
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
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
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
  [TcWiredIn]
wiredIns <- IOEnv (Env TcGblEnv TcLclEnv) [TcWiredIn]
forall {m :: * -> *}. MonadUnique m => m [TcWiredIn]
mkWiredIns
  -- snd <$> tcValBinds Ghc.NotTopLevel (binds undef wiredIns) (sigs wiredIns) m
  ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
 a)
-> a
forall a b. (a, b) -> b
snd (([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
  a)
 -> a)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
      a)
-> TcM a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)]
-> [LSig GhcRn]
-> TcM a
-> TcM ([(RecFlag, LHsBinds GhcTc)], a)
forall thing.
TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)]
-> [LSig GhcRn]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
tcValBinds TopLevelFlag
Ghc.NotTopLevel [] ([TcWiredIn] -> [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall {t :: * -> *} {ann}.
Foldable t =>
t TcWiredIn -> [GenLocated (SrcAnn ann) (Sig GhcRn)]
sigs [TcWiredIn]
wiredIns) TcM a
m

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

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

  sigs :: t TcWiredIn -> [GenLocated (SrcAnn ann) (Sig GhcRn)]
sigs t TcWiredIn
wiredIns = (TcWiredIn -> [GenLocated (SrcAnn ann) (Sig GhcRn)])
-> t TcWiredIn -> [GenLocated (SrcAnn ann) (Sig GhcRn)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\TcWiredIn
w ->
      let inf :: [GenLocated (SrcAnn ann) (Sig GhcRn)]
inf = Maybe (GenLocated (SrcAnn ann) (Sig GhcRn))
-> [GenLocated (SrcAnn ann) (Sig GhcRn)]
forall a. Maybe a -> [a]
maybeToList (Maybe (GenLocated (SrcAnn ann) (Sig GhcRn))
 -> [GenLocated (SrcAnn ann) (Sig GhcRn)])
-> Maybe (GenLocated (SrcAnn ann) (Sig GhcRn))
-> [GenLocated (SrcAnn ann) (Sig GhcRn)]
forall a b. (a -> b) -> a -> b
$ (\(Int
fPrec, FixityDirection
fDir) -> SrcAnn ann -> Sig GhcRn -> GenLocated (SrcAnn ann) (Sig GhcRn)
forall l e. l -> e -> GenLocated l e
Ghc.L SrcAnn ann
forall {ann}. SrcAnn ann
locSpanAnn (Sig GhcRn -> GenLocated (SrcAnn ann) (Sig GhcRn))
-> Sig GhcRn -> GenLocated (SrcAnn ann) (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
EpAnn [AddEpAnn]
forall a. EpAnn 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
NoExtField
Ghc.noExtField [SrcAnn NameAnn -> Name -> GenLocated (SrcAnn NameAnn) Name
forall l e. l -> e -> GenLocated l e
Ghc.L SrcAnn NameAnn
forall {ann}. SrcAnn ann
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 (SrcAnn ann) (Sig GhcRn))
-> Maybe (Int, FixityDirection)
-> Maybe (GenLocated (SrcAnn ann) (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 (SrcAnn ann) (Sig GhcRn)]
t =
            let ext' :: [a]
ext' = [] in
            [SrcAnn ann -> Sig GhcRn -> GenLocated (SrcAnn ann) (Sig GhcRn)
forall l e. l -> e -> GenLocated l e
Ghc.L SrcAnn ann
forall {ann}. SrcAnn ann
locSpanAnn (Sig GhcRn -> GenLocated (SrcAnn ann) (Sig GhcRn))
-> Sig GhcRn -> GenLocated (SrcAnn ann) (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
EpAnn AnnSig
forall a. EpAnn a
Ghc.noAnn [SrcAnn NameAnn -> Name -> GenLocated (SrcAnn NameAnn) Name
forall l e. l -> e -> GenLocated l e
Ghc.L SrcAnn NameAnn
forall {ann}. SrcAnn ann
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 {ann}. SrcAnn ann
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 (SrcAnn ann) (Sig GhcRn)]
inf [GenLocated (SrcAnn ann) (Sig GhcRn)]
-> [GenLocated (SrcAnn ann) (Sig GhcRn)]
-> [GenLocated (SrcAnn ann) (Sig GhcRn)]
forall a. Semigroup a => a -> a -> a
<> [GenLocated (SrcAnn ann) (Sig GhcRn)]
t
    ) t TcWiredIn
wiredIns

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

  mkHsFunTy :: LHsType GhcRn -> LHsType GhcRn -> LHsType GhcRn
  mkHsFunTy :: LHsType GhcRn -> LHsType GhcRn -> LHsType GhcRn
mkHsFunTy LHsType GhcRn
a LHsType GhcRn
b = LHsType GhcRn -> LHsType GhcRn -> LHsType GhcRn
forall (p :: Pass).
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
    Unique
u <- m Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
    Name -> m Name
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> m Name) -> Name -> m Name
forall a b. (a -> b) -> a -> b
$ Unique -> OccName -> SrcSpan -> Name
Ghc.mkInternalName Unique
u ([Char] -> OccName
Ghc.mkVarOcc [Char]
s) SrcSpan
locSpan

  toLoc :: e -> GenLocated (SrcAnn ann) e
toLoc = SrcAnn ann -> e -> GenLocated (SrcAnn ann) e
forall l e. l -> e -> GenLocated l e
Ghc.L SrcAnn ann
forall {ann}. SrcAnn ann
locSpanAnn
  nameToTy :: XRec pass (IdP pass) -> GenLocated (SrcAnn ann) (HsType pass)
nameToTy = SrcAnn ann -> HsType pass -> GenLocated (SrcAnn ann) (HsType pass)
forall l e. l -> e -> GenLocated l e
Ghc.L SrcAnn ann
forall {ann}. SrcAnn ann
locSpanAnn (HsType pass -> GenLocated (SrcAnn ann) (HsType pass))
-> (XRec pass (IdP pass) -> HsType pass)
-> XRec pass (IdP pass)
-> GenLocated (SrcAnn ann) (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
EpAnn a
forall a. EpAnn a
Ghc.noAnn PromotionFlag
Ghc.NotPromoted

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

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

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

  -- infix 4 == :: forall a . a -> a -> Bool
  eq :: m TcWiredIn
eq = do
    Name
n <- [Char] -> m Name
forall {m :: * -> *}. MonadUnique m => [Char] -> m Name
toName [Char]
"=="
    GenLocated (SrcAnn NameAnn) Name
aName <- Name -> GenLocated (SrcAnn NameAnn) Name
forall {e} {ann}. e -> GenLocated (SrcAnn ann) e
toLoc (Name -> GenLocated (SrcAnn NameAnn) Name)
-> m Name -> m (GenLocated (SrcAnn NameAnn) Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> m Name
forall {m :: * -> *}. MonadUnique m => [Char] -> m Name
toName [Char]
"a"
    let aTy :: GenLocated SrcSpanAnnA (HsType GhcRn)
aTy = LIdP GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall {pass} {a} {ann}.
(XTyVar pass ~ EpAnn a) =>
XRec pass (IdP pass) -> GenLocated (SrcAnn ann) (HsType pass)
nameToTy LIdP GhcRn
GenLocated (SrcAnn NameAnn) Name
aName
    let ty :: GenLocated SrcSpanAnnA (HsType GhcRn)
ty = HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall {e} {ann}. e -> GenLocated (SrcAnn ann) 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. EpAnn a
Ghc.noAnn [HsTyVarBndr Specificity GhcRn
-> GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)
forall {e} {ann}. e -> GenLocated (SrcAnn ann) 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 XUserTyVar GhcRn
EpAnn [AddEpAnn]
forall a. EpAnn a
Ghc.noAnn Specificity
SpecifiedSpec LIdP GhcRn
GenLocated (SrcAnn NameAnn) 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')
    TcWiredIn -> m TcWiredIn
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcWiredIn -> m TcWiredIn) -> TcWiredIn -> m TcWiredIn
forall a b. (a -> b) -> a -> b
$ Name -> Maybe (Int, FixityDirection) -> LHsType GhcRn -> TcWiredIn
TcWiredIn Name
n ((Int, FixityDirection) -> Maybe (Int, FixityDirection)
forall a. a -> Maybe a
Just (Int
4, FixityDirection
Ghc.InfixN)) LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
ty

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

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

isFromGHCReal :: NamedThing a => a -> Bool
isFromGHCReal :: forall a. NamedThing a => a -> Bool
isFromGHCReal a
x = (() :: Constraint) => 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
gHC_REAL