{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Language.Haskell.Liquid.Bare.Class
( makeClasses
, makeCLaws
, makeSpecDictionaries
, makeDefaultMethods
, makeMethodTypes
)
where
import Data.Bifunctor
import qualified Data.Maybe as Mb
import qualified Data.List as L
import qualified Data.HashMap.Strict as M
import qualified Language.Fixpoint.Misc as Misc
import qualified Language.Fixpoint.Types as F
import qualified Language.Fixpoint.Types.Visitor as F
import Language.Haskell.Liquid.Types.Dictionaries
import qualified Language.Haskell.Liquid.GHC.Misc as GM
import qualified Liquid.GHC.API as Ghc
import Language.Haskell.Liquid.Misc
import Language.Haskell.Liquid.Types.RefType
import Language.Haskell.Liquid.Types hiding (freeTyVars)
import qualified Language.Haskell.Liquid.Measure as Ms
import Language.Haskell.Liquid.Bare.Types as Bare
import Language.Haskell.Liquid.Bare.Resolve as Bare
import Language.Haskell.Liquid.Bare.Expand as Bare
import Language.Haskell.Liquid.Bare.Misc as Bare
import Text.PrettyPrint.HughesPJ (text)
import qualified Control.Exception as Ex
import Control.Monad (forM)
makeMethodTypes :: Bool -> DEnv Ghc.Var LocSpecType -> [DataConP] -> [Ghc.CoreBind] -> [(Ghc.Var, MethodType LocSpecType)]
makeMethodTypes :: Bool
-> DEnv Var LocSpecType
-> [DataConP]
-> [CoreBind]
-> [(Var, MethodType LocSpecType)]
makeMethodTypes Bool
allowTC (DEnv HashMap Var (HashMap Symbol (RISig LocSpecType))
hm) [DataConP]
cls [CoreBind]
cbs
= [(Var
x, Maybe LocSpecType -> Maybe LocSpecType -> MethodType LocSpecType
forall t. Maybe t -> Maybe t -> MethodType t
MT (Bool -> Var -> LocSpecType -> LocSpecType
addCC Bool
allowTC Var
x (LocSpecType -> LocSpecType)
-> (RISig LocSpecType -> LocSpecType)
-> RISig LocSpecType
-> LocSpecType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RISig LocSpecType -> LocSpecType
forall a. RISig a -> a
fromRISig (RISig LocSpecType -> LocSpecType)
-> Maybe (RISig LocSpecType) -> Maybe LocSpecType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Var
-> Var
-> HashMap Var (HashMap Symbol (RISig LocSpecType))
-> Maybe (RISig LocSpecType)
forall {t} {k} {a}.
(NamedThing t, Hashable k) =>
k -> t -> HashMap k (HashMap Symbol a) -> Maybe a
methodType Var
d Var
x HashMap Var (HashMap Symbol (RISig LocSpecType))
hm) (Bool -> Var -> LocSpecType -> LocSpecType
addCC Bool
allowTC Var
x (LocSpecType -> LocSpecType)
-> Maybe LocSpecType -> Maybe LocSpecType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Var, [Type], [Var]) -> Var -> Maybe LocSpecType
forall {t} {c}.
NamedThing t =>
Maybe (Var, [Type], c) -> t -> Maybe LocSpecType
classType (CoreExpr -> Maybe (Var, [Type], [Var])
splitDictionary CoreExpr
e) Var
x)) | (Var
d,CoreExpr
e) <- [(Var, CoreExpr)]
ds, Var
x <- CoreExpr -> [Var]
grepMethods CoreExpr
e]
where
grepMethods :: CoreExpr -> [Var]
grepMethods = (Var -> Bool) -> [Var] -> [Var]
forall a. (a -> Bool) -> [a] -> [a]
filter Var -> Bool
forall a. Symbolic a => a -> Bool
GM.isMethod ([Var] -> [Var]) -> (CoreExpr -> [Var]) -> CoreExpr -> [Var]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashSet Var -> CoreExpr -> [Var]
forall a. CBVisitable a => HashSet Var -> a -> [Var]
freeVars HashSet Var
forall a. Monoid a => a
mempty
ds :: [(Var, CoreExpr)]
ds = ((Var, CoreExpr) -> Bool) -> [(Var, CoreExpr)] -> [(Var, CoreExpr)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Var -> Bool
forall a. Symbolic a => a -> Bool
GM.isDictionary (Var -> Bool)
-> ((Var, CoreExpr) -> Var) -> (Var, CoreExpr) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var, CoreExpr) -> Var
forall a b. (a, b) -> a
fst) ((CoreBind -> [(Var, CoreExpr)]) -> [CoreBind] -> [(Var, CoreExpr)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CoreBind -> [(Var, CoreExpr)]
forall {b}. Bind b -> [(b, Expr b)]
unRec [CoreBind]
cbs)
unRec :: Bind b -> [(b, Expr b)]
unRec (Ghc.Rec [(b, Expr b)]
xes) = [(b, Expr b)]
xes
unRec (Ghc.NonRec b
x Expr b
e) = [(b
x,Expr b
e)]
classType :: Maybe (Var, [Type], c) -> t -> Maybe LocSpecType
classType Maybe (Var, [Type], c)
Nothing t
_ = Maybe LocSpecType
forall a. Maybe a
Nothing
classType (Just (Var
d, [Type]
ts, c
_)) t
x =
case (DataConP -> Bool) -> [DataConP] -> [DataConP]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
==Var
d) (Var -> Bool) -> (DataConP -> Var) -> DataConP -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> Var
Ghc.dataConWorkId (DataCon -> Var) -> (DataConP -> DataCon) -> DataConP -> Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataConP -> DataCon
dcpCon) [DataConP]
cls of
(DataConP
di:[DataConP]
_) -> (DataConP -> SourcePos
dcpLoc DataConP
di SourcePos -> SpecType -> LocSpecType
forall l b. Loc l => l -> b -> Located b
`F.atLoc`) (SpecType -> LocSpecType)
-> (SpecType -> SpecType) -> SpecType -> LocSpecType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(RTyVar, Type)] -> SpecType -> SpecType
forall {r}.
(Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r) =>
[(RTyVar, Type)] -> RType RTyCon RTyVar r -> RType RTyCon RTyVar r
subst ([RTyVar] -> [Type] -> [(RTyVar, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip (DataConP -> [RTyVar]
dcpFreeTyVars DataConP
di) [Type]
ts) (SpecType -> LocSpecType) -> Maybe SpecType -> Maybe LocSpecType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Symbol -> [(Symbol, SpecType)] -> Maybe SpecType
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup (t -> Symbol
forall {t}. NamedThing t => t -> Symbol
mkSymbol t
x) (DataConP -> [(Symbol, SpecType)]
dcpTyArgs DataConP
di)
[DataConP]
_ -> Maybe LocSpecType
forall a. Maybe a
Nothing
methodType :: k -> t -> HashMap k (HashMap Symbol a) -> Maybe a
methodType k
d t
x HashMap k (HashMap Symbol a)
m = Maybe (HashMap Symbol a) -> t -> Maybe a
forall {t} {a}.
NamedThing t =>
Maybe (HashMap Symbol a) -> t -> Maybe a
ihastype (k -> HashMap k (HashMap Symbol a) -> Maybe (HashMap Symbol a)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup k
d HashMap k (HashMap Symbol a)
m) t
x
ihastype :: Maybe (HashMap Symbol a) -> t -> Maybe a
ihastype Maybe (HashMap Symbol a)
Nothing t
_ = Maybe a
forall a. Maybe a
Nothing
ihastype (Just HashMap Symbol a
xts) t
x = Symbol -> HashMap Symbol a -> Maybe a
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup (t -> Symbol
forall {t}. NamedThing t => t -> Symbol
mkSymbol t
x) HashMap Symbol a
xts
mkSymbol :: t -> Symbol
mkSymbol t
x = Int -> Symbol -> Symbol
F.dropSym Int
2 (Symbol -> Symbol) -> Symbol -> Symbol
forall a b. (a -> b) -> a -> b
$ t -> Symbol
forall {t}. NamedThing t => t -> Symbol
GM.simplesymbol t
x
subst :: [(RTyVar, Type)] -> RType RTyCon RTyVar r -> RType RTyCon RTyVar r
subst [] RType RTyCon RTyVar r
t = RType RTyCon RTyVar r
t
subst ((RTyVar
a,Type
ta):[(RTyVar, Type)]
su) RType RTyCon RTyVar r
t = (RTyVar, RType RTyCon RTyVar r)
-> RType RTyCon RTyVar r -> RType RTyCon RTyVar r
forall tv r c.
(Eq tv, Hashable tv, Reftable r, TyConable c,
SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,
SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,
SubsTy tv (RType c tv ()) tv,
SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ()))) =>
(tv, RType c tv r) -> RType c tv r -> RType c tv r
subsTyVarMeet' (RTyVar
a,Type -> RType RTyCon RTyVar r
forall r. Monoid r => Type -> RRType r
ofType Type
ta) ([(RTyVar, Type)] -> RType RTyCon RTyVar r -> RType RTyCon RTyVar r
subst [(RTyVar, Type)]
su RType RTyCon RTyVar r
t)
addCC :: Bool -> Ghc.Var -> LocSpecType -> LocSpecType
addCC :: Bool -> Var -> LocSpecType -> LocSpecType
addCC Bool
allowTC Var
var zz :: LocSpecType
zz@(Loc SourcePos
l SourcePos
l' SpecType
st0)
= SourcePos -> SourcePos -> SpecType -> LocSpecType
forall a. SourcePos -> SourcePos -> a -> Located a
Loc SourcePos
l SourcePos
l'
(SpecType -> LocSpecType)
-> (SpecType -> SpecType) -> SpecType -> LocSpecType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpecType -> SpecType -> SpecType
forall {r}.
RType RTyCon RTyVar r
-> RType RTyCon RTyVar r -> RType RTyCon RTyVar r
addForall SpecType
hst
(SpecType -> SpecType)
-> (SpecType -> SpecType) -> SpecType -> SpecType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(RTVar RTyVar (RType RTyCon RTyVar ()), RReft)]
-> [PVar (RType RTyCon RTyVar ())]
-> [(Symbol, RFInfo, SpecType, RReft)]
-> SpecType
-> SpecType
forall tv c r.
[(RTVar tv (RType c tv ()), r)]
-> [PVar (RType c tv ())]
-> [(Symbol, RFInfo, RType c tv r, r)]
-> RType c tv r
-> RType c tv r
mkArrow [] [PVar (RType RTyCon RTyVar ())]
ps' []
(SpecType -> SpecType)
-> (SpecType -> SpecType) -> SpecType -> SpecType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Symbol, SpecType)] -> SpecType -> SpecType
forall {t :: * -> *} {r} {c} {tv}.
(Foldable t, Monoid r) =>
t (Symbol, RType c tv r) -> RType c tv r -> RType c tv r
makeCls [(Symbol, SpecType)]
cs'
(SpecType -> SpecType)
-> (SpecType -> SpecType) -> SpecType -> SpecType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Symbol -> Expr -> Expr) -> SpecType -> SpecType
forall c tv.
(Symbol -> Expr -> Expr) -> RType c tv RReft -> RType c tv RReft
mapExprReft (\Symbol
_ -> CoSub -> Expr -> Expr
F.applyCoSub CoSub
coSub)
(SpecType -> SpecType)
-> (SpecType -> SpecType) -> SpecType -> SpecType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(RTyVar, RTyVar)] -> SpecType -> SpecType
forall tv ty c. SubsTy tv ty c => [(tv, ty)] -> c -> c
subts [(RTyVar, RTyVar)]
su
(SpecType -> LocSpecType) -> SpecType -> LocSpecType
forall a b. (a -> b) -> a -> b
$ SpecType
st
where
hst :: SpecType
hst = Type -> SpecType
forall r. Monoid r => Type -> RRType r
ofType (Type -> Type
Ghc.expandTypeSynonyms Type
t0) :: SpecType
t0 :: Type
t0 = Var -> Type
Ghc.varType Var
var
tyvsmap :: [(Var, RTyVar)]
tyvsmap = case Bool
-> Type
-> SpecType
-> (Doc -> Doc -> Error)
-> Either Error MapTyVarST
Bare.runMapTyVars Bool
allowTC Type
t0 SpecType
st Doc -> Doc -> Error
forall {t}. Doc -> Doc -> TError t
err of
Left Error
e -> Error -> [(Var, RTyVar)]
forall a e. Exception e => e -> a
Ex.throw Error
e
Right MapTyVarST
s -> MapTyVarST -> [(Var, RTyVar)]
Bare.vmap MapTyVarST
s
su :: [(RTyVar, RTyVar)]
su = [(RTyVar
y, Var -> RTyVar
rTyVar Var
x) | (Var
x, RTyVar
y) <- [(Var, RTyVar)]
tyvsmap]
su' :: [(RTyVar, RType RTyCon RTyVar ())]
su' = [(RTyVar
y, RTyVar -> () -> RType RTyCon RTyVar ()
forall c tv r. tv -> r -> RType c tv r
RVar (Var -> RTyVar
rTyVar Var
x) ()) | (Var
x, RTyVar
y) <- [(Var, RTyVar)]
tyvsmap] :: [(RTyVar, RSort)]
coSub :: CoSub
coSub = [(Symbol, Sort)] -> CoSub
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList [(RTyVar -> Symbol
forall a. Symbolic a => a -> Symbol
F.symbol RTyVar
y, Symbol -> Sort
F.FObj (RTyVar -> Symbol
forall a. Symbolic a => a -> Symbol
F.symbol RTyVar
x)) | (RTyVar
y, RTyVar
x) <- [(RTyVar, RTyVar)]
su]
ps' :: [PVar (RType RTyCon RTyVar ())]
ps' = (RType RTyCon RTyVar () -> RType RTyCon RTyVar ())
-> PVar (RType RTyCon RTyVar ()) -> PVar (RType RTyCon RTyVar ())
forall a b. (a -> b) -> PVar a -> PVar b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(RTyVar, RType RTyCon RTyVar ())]
-> RType RTyCon RTyVar () -> RType RTyCon RTyVar ()
forall tv ty c. SubsTy tv ty c => [(tv, ty)] -> c -> c
subts [(RTyVar, RType RTyCon RTyVar ())]
su') (PVar (RType RTyCon RTyVar ()) -> PVar (RType RTyCon RTyVar ()))
-> [PVar (RType RTyCon RTyVar ())]
-> [PVar (RType RTyCon RTyVar ())]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PVar (RType RTyCon RTyVar ())]
ps
cs' :: [(Symbol, SpecType)]
cs' = [(Symbol
F.dummySymbol, RTyCon
-> [SpecType] -> [RTProp RTyCon RTyVar RReft] -> RReft -> SpecType
forall c tv r.
c -> [RType c tv r] -> [RTProp c tv r] -> r -> RType c tv r
RApp RTyCon
c [SpecType]
ts [] RReft
forall a. Monoid a => a
mempty) | (RTyCon
c, [SpecType]
ts) <- [(RTyCon, [SpecType])]
cs ]
([(RTVar RTyVar (RType RTyCon RTyVar ()), RReft)]
_,[PVar (RType RTyCon RTyVar ())]
_,[(RTyCon, [SpecType])]
cs,SpecType
_) = SpecType
-> ([(RTVar RTyVar (RType RTyCon RTyVar ()), RReft)],
[PVar (RType RTyCon RTyVar ())], [(RTyCon, [SpecType])], SpecType)
bkUnivClass (String -> SpecType -> SpecType
forall a. PPrint a => String -> a -> a
F.notracepp String
"hs-spec" (SpecType -> SpecType) -> SpecType -> SpecType
forall a b. (a -> b) -> a -> b
$ Type -> SpecType
forall r. Monoid r => Type -> RRType r
ofType (Type -> Type
Ghc.expandTypeSynonyms Type
t0) :: SpecType)
([(RTVar RTyVar (RType RTyCon RTyVar ()), RReft)]
_,[PVar (RType RTyCon RTyVar ())]
ps,[(RTyCon, [SpecType])]
_ ,SpecType
st) = SpecType
-> ([(RTVar RTyVar (RType RTyCon RTyVar ()), RReft)],
[PVar (RType RTyCon RTyVar ())], [(RTyCon, [SpecType])], SpecType)
bkUnivClass (String -> SpecType -> SpecType
forall a. PPrint a => String -> a -> a
F.notracepp String
"lq-spec" SpecType
st0)
makeCls :: t (Symbol, RType c tv r) -> RType c tv r -> RType c tv r
makeCls t (Symbol, RType c tv r)
c RType c tv r
t = ((Symbol, RType c tv r) -> RType c tv r -> RType c tv r)
-> RType c tv r -> t (Symbol, RType c tv r) -> RType c tv r
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Symbol -> RType c tv r -> RType c tv r -> RType c tv r)
-> (Symbol, RType c tv r) -> RType c tv r -> RType c tv r
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Symbol -> RType c tv r -> RType c tv r -> RType c tv r
forall r c tv.
Monoid r =>
Symbol -> RType c tv r -> RType c tv r -> RType c tv r
rFun) RType c tv r
t t (Symbol, RType c tv r)
c
err :: Doc -> Doc -> TError t
err Doc
hsT Doc
lqT = SrcSpan
-> Doc
-> Doc
-> Doc
-> Doc
-> Maybe (Doc, Doc)
-> SrcSpan
-> TError t
forall t.
SrcSpan
-> Doc
-> Doc
-> Doc
-> Doc
-> Maybe (Doc, Doc)
-> SrcSpan
-> TError t
ErrMismatch (LocSpecType -> SrcSpan
forall a. Loc a => a -> SrcSpan
GM.fSrcSpan LocSpecType
zz) (Var -> Doc
forall a. PPrint a => a -> Doc
pprint Var
var)
(String -> Doc
text String
"makeMethodTypes")
(Type -> Doc
forall a. PPrint a => a -> Doc
pprint (Type -> Doc) -> Type -> Doc
forall a b. (a -> b) -> a -> b
$ Type -> Type
Ghc.expandTypeSynonyms Type
t0)
(RType RTyCon RTyVar () -> Doc
forall a. PPrint a => a -> Doc
pprint (RType RTyCon RTyVar () -> Doc) -> RType RTyCon RTyVar () -> Doc
forall a b. (a -> b) -> a -> b
$ SpecType -> RType RTyCon RTyVar ()
forall c tv r. RType c tv r -> RType c tv ()
toRSort SpecType
st0)
((Doc, Doc) -> Maybe (Doc, Doc)
forall a. a -> Maybe a
Just (Doc
hsT, Doc
lqT))
(Var -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
Ghc.getSrcSpan Var
var)
addForall :: RType RTyCon RTyVar r
-> RType RTyCon RTyVar r -> RType RTyCon RTyVar r
addForall (RAllT RTVar RTyVar (RType RTyCon RTyVar ())
v RType RTyCon RTyVar r
t r
r) tt :: RType RTyCon RTyVar r
tt@(RAllT RTVar RTyVar (RType RTyCon RTyVar ())
v' RType RTyCon RTyVar r
_ r
_)
| RTVar RTyVar (RType RTyCon RTyVar ())
v RTVar RTyVar (RType RTyCon RTyVar ())
-> RTVar RTyVar (RType RTyCon RTyVar ()) -> Bool
forall a. Eq a => a -> a -> Bool
== RTVar RTyVar (RType RTyCon RTyVar ())
v'
= RType RTyCon RTyVar r
tt
| Bool
otherwise
= RTVar RTyVar (RType RTyCon RTyVar ())
-> RType RTyCon RTyVar r -> r -> RType RTyCon RTyVar r
forall c tv r. RTVU c tv -> RType c tv r -> r -> RType c tv r
RAllT (RTVar RTyVar (RType RTyCon RTyVar ())
-> RTVar RTyVar (RType RTyCon RTyVar ())
forall r i.
Monoid r =>
RTVar RTyVar i -> RTVar RTyVar (RType RTyCon RTyVar r)
updateRTVar RTVar RTyVar (RType RTyCon RTyVar ())
v) (RType RTyCon RTyVar r
-> RType RTyCon RTyVar r -> RType RTyCon RTyVar r
addForall RType RTyCon RTyVar r
t RType RTyCon RTyVar r
tt) r
r
addForall (RAllT RTVar RTyVar (RType RTyCon RTyVar ())
v RType RTyCon RTyVar r
t r
r) RType RTyCon RTyVar r
t'
= RTVar RTyVar (RType RTyCon RTyVar ())
-> RType RTyCon RTyVar r -> r -> RType RTyCon RTyVar r
forall c tv r. RTVU c tv -> RType c tv r -> r -> RType c tv r
RAllT (RTVar RTyVar (RType RTyCon RTyVar ())
-> RTVar RTyVar (RType RTyCon RTyVar ())
forall r i.
Monoid r =>
RTVar RTyVar i -> RTVar RTyVar (RType RTyCon RTyVar r)
updateRTVar RTVar RTyVar (RType RTyCon RTyVar ())
v) (RType RTyCon RTyVar r
-> RType RTyCon RTyVar r -> RType RTyCon RTyVar r
addForall RType RTyCon RTyVar r
t RType RTyCon RTyVar r
t') r
r
addForall (RAllP PVar (RType RTyCon RTyVar ())
_ RType RTyCon RTyVar r
t) RType RTyCon RTyVar r
t'
= RType RTyCon RTyVar r
-> RType RTyCon RTyVar r -> RType RTyCon RTyVar r
addForall RType RTyCon RTyVar r
t RType RTyCon RTyVar r
t'
addForall RType RTyCon RTyVar r
_ (RAllP PVar (RType RTyCon RTyVar ())
p RType RTyCon RTyVar r
t')
= PVar (RType RTyCon RTyVar ())
-> RType RTyCon RTyVar r -> RType RTyCon RTyVar r
forall c tv r. PVU c tv -> RType c tv r -> RType c tv r
RAllP ((RType RTyCon RTyVar () -> RType RTyCon RTyVar ())
-> PVar (RType RTyCon RTyVar ()) -> PVar (RType RTyCon RTyVar ())
forall a b. (a -> b) -> PVar a -> PVar b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(RTyVar, RType RTyCon RTyVar ())]
-> RType RTyCon RTyVar () -> RType RTyCon RTyVar ()
forall tv ty c. SubsTy tv ty c => [(tv, ty)] -> c -> c
subts [(RTyVar, RType RTyCon RTyVar ())]
su') PVar (RType RTyCon RTyVar ())
p) RType RTyCon RTyVar r
t'
addForall (RFun Symbol
_ RFInfo
_ RType RTyCon RTyVar r
t1 RType RTyCon RTyVar r
t2 r
_) (RFun Symbol
x RFInfo
i RType RTyCon RTyVar r
t1' RType RTyCon RTyVar r
t2' r
r)
= Symbol
-> RFInfo
-> RType RTyCon RTyVar r
-> RType RTyCon RTyVar r
-> r
-> RType RTyCon RTyVar r
forall c tv r.
Symbol
-> RFInfo -> RType c tv r -> RType c tv r -> r -> RType c tv r
RFun Symbol
x RFInfo
i (RType RTyCon RTyVar r
-> RType RTyCon RTyVar r -> RType RTyCon RTyVar r
addForall RType RTyCon RTyVar r
t1 RType RTyCon RTyVar r
t1') (RType RTyCon RTyVar r
-> RType RTyCon RTyVar r -> RType RTyCon RTyVar r
addForall RType RTyCon RTyVar r
t2 RType RTyCon RTyVar r
t2') r
r
addForall RType RTyCon RTyVar r
_ RType RTyCon RTyVar r
t
= RType RTyCon RTyVar r
t
splitDictionary :: Ghc.CoreExpr -> Maybe (Ghc.Var, [Ghc.Type], [Ghc.Var])
splitDictionary :: CoreExpr -> Maybe (Var, [Type], [Var])
splitDictionary = [Type] -> [Var] -> CoreExpr -> Maybe (Var, [Type], [Var])
forall {b}. [Type] -> [Var] -> Expr b -> Maybe (Var, [Type], [Var])
go [] []
where
go :: [Type] -> [Var] -> Expr b -> Maybe (Var, [Type], [Var])
go [Type]
ts [Var]
xs (Ghc.App Expr b
e (Ghc.Tick CoreTickish
_ Expr b
a)) = [Type] -> [Var] -> Expr b -> Maybe (Var, [Type], [Var])
go [Type]
ts [Var]
xs (Expr b -> Expr b -> Expr b
forall b. Expr b -> Expr b -> Expr b
Ghc.App Expr b
e Expr b
a)
go [Type]
ts [Var]
xs (Ghc.App Expr b
e (Ghc.Type Type
t)) = [Type] -> [Var] -> Expr b -> Maybe (Var, [Type], [Var])
go (Type
tType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
ts) [Var]
xs Expr b
e
go [Type]
ts [Var]
xs (Ghc.App Expr b
e (Ghc.Var Var
x)) = [Type] -> [Var] -> Expr b -> Maybe (Var, [Type], [Var])
go [Type]
ts (Var
xVar -> [Var] -> [Var]
forall a. a -> [a] -> [a]
:[Var]
xs) Expr b
e
go [Type]
ts [Var]
xs (Ghc.Tick CoreTickish
_ Expr b
t) = [Type] -> [Var] -> Expr b -> Maybe (Var, [Type], [Var])
go [Type]
ts [Var]
xs Expr b
t
go [Type]
ts [Var]
xs (Ghc.Var Var
x) = (Var, [Type], [Var]) -> Maybe (Var, [Type], [Var])
forall a. a -> Maybe a
Just (Var
x, [Type] -> [Type]
forall a. [a] -> [a]
reverse [Type]
ts, [Var] -> [Var]
forall a. [a] -> [a]
reverse [Var]
xs)
go [Type]
_ [Var]
_ Expr b
_ = Maybe (Var, [Type], [Var])
forall a. Maybe a
Nothing
makeCLaws :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.ModSpecs
-> Bare.Lookup [(Ghc.Class, [(ModName, Ghc.Var, LocSpecType)])]
makeCLaws :: Env
-> SigEnv
-> ModName
-> ModSpecs
-> Lookup [(Class, [(ModName, Var, LocSpecType)])]
makeCLaws Env
env SigEnv
sigEnv ModName
myName ModSpecs
specs = do
[Maybe (Class, [(ModName, Var, LocSpecType)])]
zMbs <- [(ModName, RClass LocBareType, TyCon)]
-> ((ModName, RClass LocBareType, TyCon)
-> Either [Error] (Maybe (Class, [(ModName, Var, LocSpecType)])))
-> Either [Error] [Maybe (Class, [(ModName, Var, LocSpecType)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(ModName, RClass LocBareType, TyCon)]
classTcs (((ModName, RClass LocBareType, TyCon)
-> Either [Error] (Maybe (Class, [(ModName, Var, LocSpecType)])))
-> Either [Error] [Maybe (Class, [(ModName, Var, LocSpecType)])])
-> ((ModName, RClass LocBareType, TyCon)
-> Either [Error] (Maybe (Class, [(ModName, Var, LocSpecType)])))
-> Either [Error] [Maybe (Class, [(ModName, Var, LocSpecType)])]
forall a b. (a -> b) -> a -> b
$ \(ModName
name, RClass LocBareType
clss, TyCon
tc) -> do
Maybe (DataConP, [(ModName, Var, LocSpecType)])
clsMb <- Env
-> SigEnv
-> ModName
-> ModName
-> RClass LocBareType
-> TyCon
-> Lookup (Maybe (DataConP, [(ModName, Var, LocSpecType)]))
mkClass Env
env SigEnv
sigEnv ModName
myName ModName
name RClass LocBareType
clss TyCon
tc
case Maybe (DataConP, [(ModName, Var, LocSpecType)])
clsMb of
Maybe (DataConP, [(ModName, Var, LocSpecType)])
Nothing ->
Maybe (Class, [(ModName, Var, LocSpecType)])
-> Either [Error] (Maybe (Class, [(ModName, Var, LocSpecType)]))
forall a. a -> Either [Error] a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Class, [(ModName, Var, LocSpecType)])
forall a. Maybe a
Nothing
Just (DataConP, [(ModName, Var, LocSpecType)])
cls -> do
Class
gcls <- Either [Error] Class
-> (Class -> Either [Error] Class)
-> Maybe Class
-> Either [Error] Class
forall b a. b -> (a -> b) -> Maybe a -> b
Mb.maybe (TyCon -> Either [Error] Class
forall {a} {a}. PPrint a => a -> a
err TyCon
tc) Class -> Either [Error] Class
forall a b. b -> Either a b
Right (TyCon -> Maybe Class
Ghc.tyConClass_maybe TyCon
tc)
Maybe (Class, [(ModName, Var, LocSpecType)])
-> Either [Error] (Maybe (Class, [(ModName, Var, LocSpecType)]))
forall a. a -> Either [Error] a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Class, [(ModName, Var, LocSpecType)])
-> Either [Error] (Maybe (Class, [(ModName, Var, LocSpecType)])))
-> Maybe (Class, [(ModName, Var, LocSpecType)])
-> Either [Error] (Maybe (Class, [(ModName, Var, LocSpecType)]))
forall a b. (a -> b) -> a -> b
$ (Class, [(ModName, Var, LocSpecType)])
-> Maybe (Class, [(ModName, Var, LocSpecType)])
forall a. a -> Maybe a
Just (Class
gcls, (DataConP, [(ModName, Var, LocSpecType)])
-> [(ModName, Var, LocSpecType)]
forall a b. (a, b) -> b
snd (DataConP, [(ModName, Var, LocSpecType)])
cls)
[(Class, [(ModName, Var, LocSpecType)])]
-> Lookup [(Class, [(ModName, Var, LocSpecType)])]
forall a. a -> Either [Error] a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Maybe (Class, [(ModName, Var, LocSpecType)])]
-> [(Class, [(ModName, Var, LocSpecType)])]
forall a. [Maybe a] -> [a]
Mb.catMaybes [Maybe (Class, [(ModName, Var, LocSpecType)])]
zMbs)
where
err :: a -> a
err a
tc = String -> a
forall a. HasCallStack => String -> a
error (String
"Not a type class: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. PPrint a => a -> String
F.showpp a
tc)
classTc :: RClass ty -> Maybe TyCon
classTc = Env -> ModName -> String -> LocSymbol -> Maybe TyCon
forall a.
ResolveSym a =>
Env -> ModName -> String -> LocSymbol -> Maybe a
Bare.maybeResolveSym Env
env ModName
myName String
"makeClass" (LocSymbol -> Maybe TyCon)
-> (RClass ty -> LocSymbol) -> RClass ty -> Maybe TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BTyCon -> LocSymbol
btc_tc (BTyCon -> LocSymbol)
-> (RClass ty -> BTyCon) -> RClass ty -> LocSymbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RClass ty -> BTyCon
forall ty. RClass ty -> BTyCon
rcName
classTcs :: [(ModName, RClass LocBareType, TyCon)]
classTcs = [ (ModName
name, RClass LocBareType
cls, TyCon
tc) | (ModName
name, BareSpec
spec) <- ModSpecs -> [(ModName, BareSpec)]
forall k v. HashMap k v -> [(k, v)]
M.toList ModSpecs
specs
, RClass LocBareType
cls <- BareSpec -> [RClass LocBareType]
forall ty bndr. Spec ty bndr -> [RClass ty]
Ms.claws BareSpec
spec
, TyCon
tc <- Maybe TyCon -> [TyCon]
forall a. Maybe a -> [a]
Mb.maybeToList (RClass LocBareType -> Maybe TyCon
forall {ty}. RClass ty -> Maybe TyCon
classTc RClass LocBareType
cls)
]
makeClasses :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.ModSpecs
-> Bare.Lookup ([DataConP], [(ModName, Ghc.Var, LocSpecType)])
makeClasses :: Env
-> SigEnv
-> ModName
-> ModSpecs
-> Lookup ([DataConP], [(ModName, Var, LocSpecType)])
makeClasses Env
env SigEnv
sigEnv ModName
myName ModSpecs
specs = do
[Maybe (DataConP, [(ModName, Var, LocSpecType)])]
mbZs <- [(ModName, RClass LocBareType, TyCon)]
-> ((ModName, RClass LocBareType, TyCon)
-> Lookup (Maybe (DataConP, [(ModName, Var, LocSpecType)])))
-> Either [Error] [Maybe (DataConP, [(ModName, Var, LocSpecType)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(ModName, RClass LocBareType, TyCon)]
classTcs (((ModName, RClass LocBareType, TyCon)
-> Lookup (Maybe (DataConP, [(ModName, Var, LocSpecType)])))
-> Either
[Error] [Maybe (DataConP, [(ModName, Var, LocSpecType)])])
-> ((ModName, RClass LocBareType, TyCon)
-> Lookup (Maybe (DataConP, [(ModName, Var, LocSpecType)])))
-> Either [Error] [Maybe (DataConP, [(ModName, Var, LocSpecType)])]
forall a b. (a -> b) -> a -> b
$ \(ModName
name, RClass LocBareType
cls, TyCon
tc) ->
Env
-> SigEnv
-> ModName
-> ModName
-> RClass LocBareType
-> TyCon
-> Lookup (Maybe (DataConP, [(ModName, Var, LocSpecType)]))
mkClass Env
env SigEnv
sigEnv ModName
myName ModName
name RClass LocBareType
cls TyCon
tc
([DataConP], [(ModName, Var, LocSpecType)])
-> Lookup ([DataConP], [(ModName, Var, LocSpecType)])
forall a. a -> Either [Error] a
forall (m :: * -> *) a. Monad m => a -> m a
return (([DataConP], [(ModName, Var, LocSpecType)])
-> Lookup ([DataConP], [(ModName, Var, LocSpecType)]))
-> ([Maybe (DataConP, [(ModName, Var, LocSpecType)])]
-> ([DataConP], [(ModName, Var, LocSpecType)]))
-> [Maybe (DataConP, [(ModName, Var, LocSpecType)])]
-> Lookup ([DataConP], [(ModName, Var, LocSpecType)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([[(ModName, Var, LocSpecType)]] -> [(ModName, Var, LocSpecType)])
-> ([DataConP], [[(ModName, Var, LocSpecType)]])
-> ([DataConP], [(ModName, Var, LocSpecType)])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [[(ModName, Var, LocSpecType)]] -> [(ModName, Var, LocSpecType)]
forall a. Monoid a => [a] -> a
mconcat (([DataConP], [[(ModName, Var, LocSpecType)]])
-> ([DataConP], [(ModName, Var, LocSpecType)]))
-> ([Maybe (DataConP, [(ModName, Var, LocSpecType)])]
-> ([DataConP], [[(ModName, Var, LocSpecType)]]))
-> [Maybe (DataConP, [(ModName, Var, LocSpecType)])]
-> ([DataConP], [(ModName, Var, LocSpecType)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(DataConP, [(ModName, Var, LocSpecType)])]
-> ([DataConP], [[(ModName, Var, LocSpecType)]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(DataConP, [(ModName, Var, LocSpecType)])]
-> ([DataConP], [[(ModName, Var, LocSpecType)]]))
-> ([Maybe (DataConP, [(ModName, Var, LocSpecType)])]
-> [(DataConP, [(ModName, Var, LocSpecType)])])
-> [Maybe (DataConP, [(ModName, Var, LocSpecType)])]
-> ([DataConP], [[(ModName, Var, LocSpecType)]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (DataConP, [(ModName, Var, LocSpecType)])]
-> [(DataConP, [(ModName, Var, LocSpecType)])]
forall a. [Maybe a] -> [a]
Mb.catMaybes ([Maybe (DataConP, [(ModName, Var, LocSpecType)])]
-> Lookup ([DataConP], [(ModName, Var, LocSpecType)]))
-> [Maybe (DataConP, [(ModName, Var, LocSpecType)])]
-> Lookup ([DataConP], [(ModName, Var, LocSpecType)])
forall a b. (a -> b) -> a -> b
$ [Maybe (DataConP, [(ModName, Var, LocSpecType)])]
mbZs
where
classTcs :: [(ModName, RClass LocBareType, TyCon)]
classTcs = [ (ModName
name, RClass LocBareType
cls, TyCon
tc) | (ModName
name, BareSpec
spec) <- ModSpecs -> [(ModName, BareSpec)]
forall k v. HashMap k v -> [(k, v)]
M.toList ModSpecs
specs
, RClass LocBareType
cls <- BareSpec -> [RClass LocBareType]
forall ty bndr. Spec ty bndr -> [RClass ty]
Ms.classes BareSpec
spec
, TyCon
tc <- Maybe TyCon -> [TyCon]
forall a. Maybe a -> [a]
Mb.maybeToList (RClass LocBareType -> Maybe TyCon
forall {ty}. RClass ty -> Maybe TyCon
classTc RClass LocBareType
cls) ]
classTc :: RClass ty -> Maybe TyCon
classTc = Env -> ModName -> String -> LocSymbol -> Maybe TyCon
forall a.
ResolveSym a =>
Env -> ModName -> String -> LocSymbol -> Maybe a
Bare.maybeResolveSym Env
env ModName
myName String
"makeClass" (LocSymbol -> Maybe TyCon)
-> (RClass ty -> LocSymbol) -> RClass ty -> Maybe TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BTyCon -> LocSymbol
btc_tc (BTyCon -> LocSymbol)
-> (RClass ty -> BTyCon) -> RClass ty -> LocSymbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RClass ty -> BTyCon
forall ty. RClass ty -> BTyCon
rcName
mkClass :: Bare.Env -> Bare.SigEnv -> ModName -> ModName -> RClass LocBareType -> Ghc.TyCon
-> Bare.Lookup (Maybe (DataConP, [(ModName, Ghc.Var, LocSpecType)]))
mkClass :: Env
-> SigEnv
-> ModName
-> ModName
-> RClass LocBareType
-> TyCon
-> Lookup (Maybe (DataConP, [(ModName, Var, LocSpecType)]))
mkClass Env
env SigEnv
sigEnv ModName
_myName ModName
name (RClass BTyCon
cc [LocBareType]
ss [BTyVar]
as [(LocSymbol, LocBareType)]
ms)
= Env
-> ModName
-> Either [Error] (DataConP, [(ModName, Var, LocSpecType)])
-> Lookup (Maybe (DataConP, [(ModName, Var, LocSpecType)]))
forall e r. Env -> ModName -> Either e r -> Either e (Maybe r)
Bare.failMaybe Env
env ModName
name
(Either [Error] (DataConP, [(ModName, Var, LocSpecType)])
-> Lookup (Maybe (DataConP, [(ModName, Var, LocSpecType)])))
-> (TyCon
-> Either [Error] (DataConP, [(ModName, Var, LocSpecType)]))
-> TyCon
-> Lookup (Maybe (DataConP, [(ModName, Var, LocSpecType)]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> SigEnv
-> ModName
-> ModName
-> RClass LocBareType
-> TyCon
-> Either [Error] (DataConP, [(ModName, Var, LocSpecType)])
mkClassE Env
env SigEnv
sigEnv ModName
_myName ModName
name (BTyCon
-> [LocBareType]
-> [BTyVar]
-> [(LocSymbol, LocBareType)]
-> RClass LocBareType
forall ty.
BTyCon -> [ty] -> [BTyVar] -> [(LocSymbol, ty)] -> RClass ty
RClass BTyCon
cc [LocBareType]
ss [BTyVar]
as [(LocSymbol, LocBareType)]
ms)
mkClassE :: Bare.Env -> Bare.SigEnv -> ModName -> ModName -> RClass LocBareType -> Ghc.TyCon
-> Bare.Lookup (DataConP, [(ModName, Ghc.Var, LocSpecType)])
mkClassE :: Env
-> SigEnv
-> ModName
-> ModName
-> RClass LocBareType
-> TyCon
-> Either [Error] (DataConP, [(ModName, Var, LocSpecType)])
mkClassE Env
env SigEnv
sigEnv ModName
_myName ModName
name (RClass BTyCon
cc [LocBareType]
ss [BTyVar]
as [(LocSymbol, LocBareType)]
ms) TyCon
tc = do
[LocSpecType]
ss' <- (LocBareType -> Either [Error] LocSpecType)
-> [LocBareType] -> Either [Error] [LocSpecType]
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 (Env
-> SigEnv -> ModName -> LocBareType -> Either [Error] LocSpecType
mkConstr Env
env SigEnv
sigEnv ModName
name) [LocBareType]
ss
[(ModName, PlugTV Var, LocSpecType)]
meths <- ((LocSymbol, LocBareType)
-> Either [Error] (ModName, PlugTV Var, LocSpecType))
-> [(LocSymbol, LocBareType)]
-> Either [Error] [(ModName, PlugTV Var, LocSpecType)]
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 (Env
-> SigEnv
-> ModName
-> (LocSymbol, LocBareType)
-> Either [Error] (ModName, PlugTV Var, LocSpecType)
makeMethod Env
env SigEnv
sigEnv ModName
name) [(LocSymbol, LocBareType)]
ms'
let vts :: [(ModName, Var, LocSpecType)]
vts = [ (ModName
m, Var
v, LocSpecType
t) | (ModName
m, PlugTV Var
kv, LocSpecType
t) <- [(ModName, PlugTV Var, LocSpecType)]
meths, Var
v <- Maybe Var -> [Var]
forall a. Maybe a -> [a]
Mb.maybeToList (PlugTV Var -> Maybe Var
forall v. PlugTV v -> Maybe v
plugSrc PlugTV Var
kv) ]
let sts :: [(Symbol, SpecType)]
sts = [(LocSymbol -> Symbol
forall a. Located a -> a
val LocSymbol
s, SpecType -> SpecType
unClass (SpecType -> SpecType) -> SpecType -> SpecType
forall a b. (a -> b) -> a -> b
$ LocSpecType -> SpecType
forall a. Located a -> a
val LocSpecType
t) | (LocSymbol
s, LocBareType
_) <- [(LocSymbol, LocBareType)]
ms | (ModName
_, PlugTV Var
_, LocSpecType
t) <- [(ModName, PlugTV Var, LocSpecType)]
meths]
let dcp :: DataConP
dcp = SourcePos
-> DataCon
-> [RTyVar]
-> [PVar (RType RTyCon RTyVar ())]
-> [SpecType]
-> [(Symbol, SpecType)]
-> SpecType
-> Bool
-> Symbol
-> SourcePos
-> DataConP
DataConP SourcePos
l DataCon
dc [RTyVar]
αs [] (LocSpecType -> SpecType
forall a. Located a -> a
val (LocSpecType -> SpecType) -> [LocSpecType] -> [SpecType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LocSpecType]
ss') ([(Symbol, SpecType)] -> [(Symbol, SpecType)]
forall a. [a] -> [a]
reverse [(Symbol, SpecType)]
sts) SpecType
rt Bool
False (ModName -> Symbol
forall a. Symbolic a => a -> Symbol
F.symbol ModName
name) SourcePos
l'
(DataConP, [(ModName, Var, LocSpecType)])
-> Either [Error] (DataConP, [(ModName, Var, LocSpecType)])
forall a. a -> Either [Error] a
forall (m :: * -> *) a. Monad m => a -> m a
return ((DataConP, [(ModName, Var, LocSpecType)])
-> Either [Error] (DataConP, [(ModName, Var, LocSpecType)]))
-> (DataConP, [(ModName, Var, LocSpecType)])
-> Either [Error] (DataConP, [(ModName, Var, LocSpecType)])
forall a b. (a -> b) -> a -> b
$ String
-> (DataConP, [(ModName, Var, LocSpecType)])
-> (DataConP, [(ModName, Var, LocSpecType)])
forall a. PPrint a => String -> a -> a
F.notracepp String
msg (DataConP
dcp, [(ModName, Var, LocSpecType)]
vts)
where
c :: LocSymbol
c = BTyCon -> LocSymbol
btc_tc BTyCon
cc
l :: SourcePos
l = LocSymbol -> SourcePos
forall a. Located a -> SourcePos
loc LocSymbol
c
l' :: SourcePos
l' = LocSymbol -> SourcePos
forall a. Located a -> SourcePos
locE LocSymbol
c
msg :: String
msg = String
"MKCLASS: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (BTyCon, [BTyVar], [RTyVar]) -> String
forall a. PPrint a => a -> String
F.showpp (BTyCon
cc, [BTyVar]
as, [RTyVar]
αs)
(DataCon
dc:[DataCon]
_) = TyCon -> [DataCon]
Ghc.tyConDataCons TyCon
tc
αs :: [RTyVar]
αs = BTyVar -> RTyVar
bareRTyVar (BTyVar -> RTyVar) -> [BTyVar] -> [RTyVar]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BTyVar]
as
as' :: [RType c RTyVar RReft]
as' = [Var -> RType c RTyVar RReft
forall r c. Monoid r => Var -> RType c RTyVar r
rVar (Var -> RType c RTyVar RReft) -> Var -> RType c RTyVar RReft
forall a b. (a -> b) -> a -> b
$ Symbol -> Var
GM.symbolTyVar (Symbol -> Var) -> Symbol -> Var
forall a b. (a -> b) -> a -> b
$ BTyVar -> Symbol
forall a. Symbolic a => a -> Symbol
F.symbol BTyVar
a | BTyVar
a <- [BTyVar]
as ]
ms' :: [(LocSymbol, LocBareType)]
ms' = [ (LocSymbol
s, Symbol
-> RType BTyCon BTyVar RReft
-> RType BTyCon BTyVar RReft
-> RType BTyCon BTyVar RReft
forall r c tv.
Monoid r =>
Symbol -> RType c tv r -> RType c tv r -> RType c tv r
rFun Symbol
"" (BTyCon
-> [RType BTyCon BTyVar RReft]
-> [RTProp BTyCon BTyVar RReft]
-> RReft
-> RType BTyCon BTyVar RReft
forall c tv r.
c -> [RType c tv r] -> [RTProp c tv r] -> r -> RType c tv r
RApp BTyCon
cc ((BTyVar -> RReft -> RType BTyCon BTyVar RReft)
-> RReft -> BTyVar -> RType BTyCon BTyVar RReft
forall a b c. (a -> b -> c) -> b -> a -> c
flip BTyVar -> RReft -> RType BTyCon BTyVar RReft
forall c tv r. tv -> r -> RType c tv r
RVar RReft
forall a. Monoid a => a
mempty (BTyVar -> RType BTyCon BTyVar RReft)
-> [BTyVar] -> [RType BTyCon BTyVar RReft]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BTyVar]
as) [] RReft
forall a. Monoid a => a
mempty) (RType BTyCon BTyVar RReft -> RType BTyCon BTyVar RReft)
-> LocBareType -> LocBareType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LocBareType
t) | (LocSymbol
s, LocBareType
t) <- [(LocSymbol, LocBareType)]
ms]
rt :: SpecType
rt = TyCon -> [SpecType] -> SpecType
forall r tv.
Monoid r =>
TyCon -> [RType RTyCon tv r] -> RType RTyCon tv r
rCls TyCon
tc [SpecType]
forall {c}. [RType c RTyVar RReft]
as'
mkConstr :: Bare.Env -> Bare.SigEnv -> ModName -> LocBareType -> Bare.Lookup LocSpecType
mkConstr :: Env
-> SigEnv -> ModName -> LocBareType -> Either [Error] LocSpecType
mkConstr Env
env SigEnv
sigEnv ModName
name = (LocSpecType -> LocSpecType)
-> Either [Error] LocSpecType -> Either [Error] LocSpecType
forall a b. (a -> b) -> Either [Error] a -> Either [Error] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SpecType -> SpecType) -> LocSpecType -> LocSpecType
forall a b. (a -> b) -> Located a -> Located b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SpecType -> SpecType
forall {tv} {c} {r}. RType tv c r -> RType tv c r
dropUniv) (Either [Error] LocSpecType -> Either [Error] LocSpecType)
-> (LocBareType -> Either [Error] LocSpecType)
-> LocBareType
-> Either [Error] LocSpecType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> SigEnv
-> ModName
-> PlugTV Var
-> LocBareType
-> Either [Error] LocSpecType
Bare.cookSpecTypeE Env
env SigEnv
sigEnv ModName
name PlugTV Var
forall v. PlugTV v
Bare.GenTV
where
dropUniv :: RType tv c r -> RType tv c r
dropUniv RType tv c r
t = RType tv c r
t' where ([(RTVar c (RType tv c ()), r)]
_, [PVar (RType tv c ())]
_, RType tv c r
t') = RType tv c r
-> ([(RTVar c (RType tv c ()), r)], [PVar (RType tv c ())],
RType tv c r)
forall tv c r.
RType tv c r
-> ([(RTVar c (RType tv c ()), r)], [PVar (RType tv c ())],
RType tv c r)
bkUniv RType tv c r
t
unClass :: SpecType -> SpecType
unClass :: SpecType -> SpecType
unClass = ([(RTyCon, [SpecType])], SpecType) -> SpecType
forall a b. (a, b) -> b
snd (([(RTyCon, [SpecType])], SpecType) -> SpecType)
-> (SpecType -> ([(RTyCon, [SpecType])], SpecType))
-> SpecType
-> SpecType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpecType -> ([(RTyCon, [SpecType])], SpecType)
forall c tv r.
(PPrint c, TyConable c) =>
RType c tv r -> ([(c, [RType c tv r])], RType c tv r)
bkClass (SpecType -> ([(RTyCon, [SpecType])], SpecType))
-> (SpecType -> SpecType)
-> SpecType
-> ([(RTyCon, [SpecType])], SpecType)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(RTVar RTyVar (RType RTyCon RTyVar ()), RReft)],
[PVar (RType RTyCon RTyVar ())], SpecType)
-> SpecType
forall t1 t2 t3. (t1, t2, t3) -> t3
thrd3 (([(RTVar RTyVar (RType RTyCon RTyVar ()), RReft)],
[PVar (RType RTyCon RTyVar ())], SpecType)
-> SpecType)
-> (SpecType
-> ([(RTVar RTyVar (RType RTyCon RTyVar ()), RReft)],
[PVar (RType RTyCon RTyVar ())], SpecType))
-> SpecType
-> SpecType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpecType
-> ([(RTVar RTyVar (RType RTyCon RTyVar ()), RReft)],
[PVar (RType RTyCon RTyVar ())], SpecType)
forall tv c r.
RType tv c r
-> ([(RTVar c (RType tv c ()), r)], [PVar (RType tv c ())],
RType tv c r)
bkUniv
makeMethod :: Bare.Env -> Bare.SigEnv -> ModName -> (LocSymbol, LocBareType)
-> Bare.Lookup (ModName, PlugTV Ghc.Var, LocSpecType)
makeMethod :: Env
-> SigEnv
-> ModName
-> (LocSymbol, LocBareType)
-> Either [Error] (ModName, PlugTV Var, LocSpecType)
makeMethod Env
env SigEnv
sigEnv ModName
name (LocSymbol
lx, LocBareType
bt) = (ModName
name, PlugTV Var
mbV,) (LocSpecType -> (ModName, PlugTV Var, LocSpecType))
-> Either [Error] LocSpecType
-> Either [Error] (ModName, PlugTV Var, LocSpecType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env
-> SigEnv
-> ModName
-> PlugTV Var
-> LocBareType
-> Either [Error] LocSpecType
Bare.cookSpecTypeE Env
env SigEnv
sigEnv ModName
name PlugTV Var
mbV LocBareType
bt
where
mbV :: PlugTV Var
mbV = PlugTV Var -> (Var -> PlugTV Var) -> Maybe Var -> PlugTV Var
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PlugTV Var
forall v. PlugTV v
Bare.GenTV Var -> PlugTV Var
forall v. v -> PlugTV v
Bare.LqTV (Env -> ModName -> String -> LocSymbol -> Maybe Var
forall a.
ResolveSym a =>
Env -> ModName -> String -> LocSymbol -> Maybe a
Bare.maybeResolveSym Env
env ModName
name String
"makeMethod" LocSymbol
lx)
makeSpecDictionaries :: Bare.Env -> Bare.SigEnv -> ModSpecs -> DEnv Ghc.Var LocSpecType
makeSpecDictionaries :: Env -> SigEnv -> ModSpecs -> DEnv Var LocSpecType
makeSpecDictionaries Env
env SigEnv
sigEnv ModSpecs
specs
= [(Var, HashMap Symbol (RISig LocSpecType))] -> DEnv Var LocSpecType
forall t. [(Var, HashMap Symbol (RISig t))] -> DEnv Var t
dfromList
([(Var, HashMap Symbol (RISig LocSpecType))]
-> DEnv Var LocSpecType)
-> ([(ModName, BareSpec)]
-> [(Var, HashMap Symbol (RISig LocSpecType))])
-> [(ModName, BareSpec)]
-> DEnv Var LocSpecType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ModName, BareSpec)
-> [(Var, HashMap Symbol (RISig LocSpecType))])
-> [(ModName, BareSpec)]
-> [(Var, HashMap Symbol (RISig LocSpecType))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Env
-> SigEnv
-> (ModName, BareSpec)
-> [(Var, HashMap Symbol (RISig LocSpecType))]
makeSpecDictionary Env
env SigEnv
sigEnv)
([(ModName, BareSpec)] -> DEnv Var LocSpecType)
-> [(ModName, BareSpec)] -> DEnv Var LocSpecType
forall a b. (a -> b) -> a -> b
$ ModSpecs -> [(ModName, BareSpec)]
forall k v. HashMap k v -> [(k, v)]
M.toList ModSpecs
specs
makeSpecDictionary :: Bare.Env -> Bare.SigEnv -> (ModName, Ms.BareSpec)
-> [(Ghc.Var, M.HashMap F.Symbol (RISig LocSpecType))]
makeSpecDictionary :: Env
-> SigEnv
-> (ModName, BareSpec)
-> [(Var, HashMap Symbol (RISig LocSpecType))]
makeSpecDictionary Env
env SigEnv
sigEnv (ModName
name, BareSpec
spec)
= [Maybe (Var, HashMap Symbol (RISig LocSpecType))]
-> [(Var, HashMap Symbol (RISig LocSpecType))]
forall a. [Maybe a] -> [a]
Mb.catMaybes
([Maybe (Var, HashMap Symbol (RISig LocSpecType))]
-> [(Var, HashMap Symbol (RISig LocSpecType))])
-> (BareSpec -> [Maybe (Var, HashMap Symbol (RISig LocSpecType))])
-> BareSpec
-> [(Var, HashMap Symbol (RISig LocSpecType))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> ModName
-> [(Symbol, HashMap Symbol (RISig LocSpecType))]
-> [Maybe (Var, HashMap Symbol (RISig LocSpecType))]
resolveDictionaries Env
env ModName
name
([(Symbol, HashMap Symbol (RISig LocSpecType))]
-> [Maybe (Var, HashMap Symbol (RISig LocSpecType))])
-> (BareSpec -> [(Symbol, HashMap Symbol (RISig LocSpecType))])
-> BareSpec
-> [Maybe (Var, HashMap Symbol (RISig LocSpecType))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RInstance LocBareType
-> (Symbol, HashMap Symbol (RISig LocSpecType)))
-> [RInstance LocBareType]
-> [(Symbol, HashMap Symbol (RISig LocSpecType))]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Env
-> SigEnv
-> ModName
-> RInstance LocBareType
-> (Symbol, HashMap Symbol (RISig LocSpecType))
makeSpecDictionaryOne Env
env SigEnv
sigEnv ModName
name)
([RInstance LocBareType]
-> [(Symbol, HashMap Symbol (RISig LocSpecType))])
-> (BareSpec -> [RInstance LocBareType])
-> BareSpec
-> [(Symbol, HashMap Symbol (RISig LocSpecType))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BareSpec -> [RInstance LocBareType]
forall ty bndr. Spec ty bndr -> [RInstance ty]
Ms.rinstance
(BareSpec -> [(Var, HashMap Symbol (RISig LocSpecType))])
-> BareSpec -> [(Var, HashMap Symbol (RISig LocSpecType))]
forall a b. (a -> b) -> a -> b
$ BareSpec
spec
makeSpecDictionaryOne :: Bare.Env -> Bare.SigEnv -> ModName
-> RInstance LocBareType
-> (F.Symbol, M.HashMap F.Symbol (RISig LocSpecType))
makeSpecDictionaryOne :: Env
-> SigEnv
-> ModName
-> RInstance LocBareType
-> (Symbol, HashMap Symbol (RISig LocSpecType))
makeSpecDictionaryOne Env
env SigEnv
sigEnv ModName
name (RI BTyCon
bt [LocBareType]
lbt [(LocSymbol, RISig LocBareType)]
xts)
= RInstance LocSpecType
-> (Symbol, HashMap Symbol (RISig LocSpecType))
makeDictionary (RInstance LocSpecType
-> (Symbol, HashMap Symbol (RISig LocSpecType)))
-> RInstance LocSpecType
-> (Symbol, HashMap Symbol (RISig LocSpecType))
forall a b. (a -> b) -> a -> b
$ String -> RInstance LocSpecType -> RInstance LocSpecType
forall a. PPrint a => String -> a -> a
F.notracepp String
"RI" (RInstance LocSpecType -> RInstance LocSpecType)
-> RInstance LocSpecType -> RInstance LocSpecType
forall a b. (a -> b) -> a -> b
$ BTyCon
-> [LocSpecType]
-> [(LocSymbol, RISig LocSpecType)]
-> RInstance LocSpecType
forall t. BTyCon -> [t] -> [(LocSymbol, RISig t)] -> RInstance t
RI BTyCon
bt [LocSpecType]
ts [(LocSymbol
x, RISig LocBareType -> RISig LocSpecType
mkLSpecIType RISig LocBareType
t) | (LocSymbol
x, RISig LocBareType
t) <- [(LocSymbol, RISig LocBareType)]
xts ]
where
ts :: [LocSpecType]
ts = LocBareType -> LocSpecType
mkTy' (LocBareType -> LocSpecType) -> [LocBareType] -> [LocSpecType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LocBareType]
lbt
rts :: [RTyVar]
rts = (LocSpecType -> [RTyVar]) -> [LocSpecType] -> [RTyVar]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (SpecType -> [RTyVar]
forall {tv} {b} {b}. RType tv b b -> [b]
univs (SpecType -> [RTyVar])
-> (LocSpecType -> SpecType) -> LocSpecType -> [RTyVar]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocSpecType -> SpecType
forall a. Located a -> a
val) [LocSpecType]
ts
univs :: RType tv b b -> [b]
univs RType tv b b
t = (\(RTVar b
tv RTVInfo (RType tv b ())
_, b
_) -> b
tv) ((RTVar b (RType tv b ()), b) -> b)
-> [(RTVar b (RType tv b ()), b)] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(RTVar b (RType tv b ()), b)]
as where ([(RTVar b (RType tv b ()), b)]
as, [PVar (RType tv b ())]
_, RType tv b b
_) = RType tv b b
-> ([(RTVar b (RType tv b ()), b)], [PVar (RType tv b ())],
RType tv b b)
forall tv c r.
RType tv c r
-> ([(RTVar c (RType tv c ()), r)], [PVar (RType tv c ())],
RType tv c r)
bkUniv RType tv b b
t
mkTy' :: LocBareType -> LocSpecType
mkTy' :: LocBareType -> LocSpecType
mkTy' = Env
-> SigEnv -> ModName -> PlugTV Var -> LocBareType -> LocSpecType
Bare.cookSpecType Env
env SigEnv
sigEnv ModName
name PlugTV Var
forall v. PlugTV v
Bare.GenTV
mkTy :: LocBareType -> LocSpecType
mkTy :: LocBareType -> LocSpecType
mkTy = (SpecType -> SpecType) -> LocSpecType -> LocSpecType
forall a b. (a -> b) -> Located a -> Located b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([(RTVar RTyVar (RType RTyCon RTyVar ()), RReft)]
-> [(RTVar RTyVar (RType RTyCon RTyVar ()), RReft)])
-> SpecType -> SpecType
forall {t :: * -> *} {tv} {c} {r}.
Foldable t =>
([(RTVar tv (RType c tv ()), r)]
-> t (RTVar tv (RType c tv ()), r))
-> RType c tv r -> RType c tv r
mapUnis [(RTVar RTyVar (RType RTyCon RTyVar ()), RReft)]
-> [(RTVar RTyVar (RType RTyCon RTyVar ()), RReft)]
forall {s} {b}. [(RTVar RTyVar s, b)] -> [(RTVar RTyVar s, b)]
tidy) (LocSpecType -> LocSpecType)
-> (LocBareType -> LocSpecType) -> LocBareType -> LocSpecType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> SigEnv -> ModName -> PlugTV Var -> LocBareType -> LocSpecType
Bare.cookSpecType Env
env SigEnv
sigEnv ModName
name
PlugTV Var
forall v. PlugTV v
Bare.GenTV
mapUnis :: ([(RTVar tv (RType c tv ()), r)]
-> t (RTVar tv (RType c tv ()), r))
-> RType c tv r -> RType c tv r
mapUnis [(RTVar tv (RType c tv ()), r)] -> t (RTVar tv (RType c tv ()), r)
f RType c tv r
t = t (RTVar tv (RType c tv ()), r)
-> [PVar (RType c tv ())] -> RType c tv r -> RType c tv r
forall (t :: * -> *) (t1 :: * -> *) tv c r.
(Foldable t, Foldable t1) =>
t (RTVar tv (RType c tv ()), r)
-> t1 (PVar (RType c tv ())) -> RType c tv r -> RType c tv r
mkUnivs ([(RTVar tv (RType c tv ()), r)] -> t (RTVar tv (RType c tv ()), r)
f [(RTVar tv (RType c tv ()), r)]
as) [PVar (RType c tv ())]
ps RType c tv r
t0 where ([(RTVar tv (RType c tv ()), r)]
as, [PVar (RType c tv ())]
ps, RType c tv r
t0) = RType c tv r
-> ([(RTVar tv (RType c tv ()), r)], [PVar (RType c tv ())],
RType c tv r)
forall tv c r.
RType tv c r
-> ([(RTVar c (RType tv c ()), r)], [PVar (RType tv c ())],
RType tv c r)
bkUniv RType c tv r
t
tidy :: [(RTVar RTyVar s, b)] -> [(RTVar RTyVar s, b)]
tidy [(RTVar RTyVar s, b)]
vs = [(RTVar RTyVar s, b)]
l [(RTVar RTyVar s, b)]
-> [(RTVar RTyVar s, b)] -> [(RTVar RTyVar s, b)]
forall a. [a] -> [a] -> [a]
++ [(RTVar RTyVar s, b)]
r
where ([(RTVar RTyVar s, b)]
l,[(RTVar RTyVar s, b)]
r) = ((RTVar RTyVar s, b) -> Bool)
-> [(RTVar RTyVar s, b)]
-> ([(RTVar RTyVar s, b)], [(RTVar RTyVar s, b)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (\(RTVar RTyVar
tv RTVInfo s
_,b
_) -> RTyVar
tv RTyVar -> [RTyVar] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [RTyVar]
rts) [(RTVar RTyVar s, b)]
vs
mkLSpecIType :: RISig LocBareType -> RISig LocSpecType
mkLSpecIType :: RISig LocBareType -> RISig LocSpecType
mkLSpecIType RISig LocBareType
t = (LocBareType -> LocSpecType)
-> RISig LocBareType -> RISig LocSpecType
forall a b. (a -> b) -> RISig a -> RISig b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LocBareType -> LocSpecType
mkTy RISig LocBareType
t
resolveDictionaries :: Bare.Env -> ModName -> [(F.Symbol, M.HashMap F.Symbol (RISig LocSpecType))]
-> [Maybe (Ghc.Var, M.HashMap F.Symbol (RISig LocSpecType))]
resolveDictionaries :: Env
-> ModName
-> [(Symbol, HashMap Symbol (RISig LocSpecType))]
-> [Maybe (Var, HashMap Symbol (RISig LocSpecType))]
resolveDictionaries Env
env ModName
name = ((Symbol, HashMap Symbol (RISig LocSpecType))
-> Maybe (Var, HashMap Symbol (RISig LocSpecType)))
-> [(Symbol, HashMap Symbol (RISig LocSpecType))]
-> [Maybe (Var, HashMap Symbol (RISig LocSpecType))]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Symbol, HashMap Symbol (RISig LocSpecType))
-> Maybe (Var, HashMap Symbol (RISig LocSpecType))
forall {a} {t}. ResolveSym a => (Symbol, t) -> Maybe (a, t)
lookupVar
([(Symbol, HashMap Symbol (RISig LocSpecType))]
-> [Maybe (Var, HashMap Symbol (RISig LocSpecType))])
-> ([(Symbol, HashMap Symbol (RISig LocSpecType))]
-> [(Symbol, HashMap Symbol (RISig LocSpecType))])
-> [(Symbol, HashMap Symbol (RISig LocSpecType))]
-> [Maybe (Var, HashMap Symbol (RISig LocSpecType))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Symbol, [HashMap Symbol (RISig LocSpecType)])
-> [(Symbol, HashMap Symbol (RISig LocSpecType))])
-> [(Symbol, [HashMap Symbol (RISig LocSpecType)])]
-> [(Symbol, HashMap Symbol (RISig LocSpecType))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Symbol, [HashMap Symbol (RISig LocSpecType)])
-> [(Symbol, HashMap Symbol (RISig LocSpecType))]
forall a. (Symbol, [a]) -> [(Symbol, a)]
addInstIndex
([(Symbol, [HashMap Symbol (RISig LocSpecType)])]
-> [(Symbol, HashMap Symbol (RISig LocSpecType))])
-> ([(Symbol, HashMap Symbol (RISig LocSpecType))]
-> [(Symbol, [HashMap Symbol (RISig LocSpecType)])])
-> [(Symbol, HashMap Symbol (RISig LocSpecType))]
-> [(Symbol, HashMap Symbol (RISig LocSpecType))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Symbol, HashMap Symbol (RISig LocSpecType))]
-> [(Symbol, [HashMap Symbol (RISig LocSpecType)])]
forall k v. (Eq k, Hashable k) => [(k, v)] -> [(k, [v])]
Misc.groupList
where
lookupVar :: (Symbol, t) -> Maybe (a, t)
lookupVar (Symbol
x, t
inst) = (, t
inst) (a -> (a, t)) -> Maybe a -> Maybe (a, t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> ModName -> String -> LocSymbol -> Maybe a
forall a.
ResolveSym a =>
Env -> ModName -> String -> LocSymbol -> Maybe a
Bare.maybeResolveSym Env
env ModName
name String
"resolveDict" (Symbol -> LocSymbol
forall a. a -> Located a
F.dummyLoc Symbol
x)
addInstIndex :: (F.Symbol, [a]) -> [(F.Symbol, a)]
addInstIndex :: forall a. (Symbol, [a]) -> [(Symbol, a)]
addInstIndex (Symbol
x, [a]
ks) = Int -> [a] -> [(Symbol, a)]
forall {t} {b}. (Show t, Num t) => t -> [b] -> [(Symbol, b)]
go (Int
0::Int) ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
ks)
where
go :: t -> [b] -> [(Symbol, b)]
go t
_ [] = []
go t
_ [b
i] = [(Symbol
x, b
i)]
go t
j (b
i:[b]
is) = (String -> Symbol
forall a. Symbolic a => a -> Symbol
F.symbol (Symbol -> String
F.symbolString Symbol
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
j),b
i) (Symbol, b) -> [(Symbol, b)] -> [(Symbol, b)]
forall a. a -> [a] -> [a]
: t -> [b] -> [(Symbol, b)]
go (t
jt -> t -> t
forall a. Num a => a -> a -> a
+t
1) [b]
is
makeDefaultMethods :: Bare.Env -> [(ModName, Ghc.Var, LocSpecType)]
-> [(ModName, Ghc.Var, LocSpecType)]
makeDefaultMethods :: Env
-> [(ModName, Var, LocSpecType)] -> [(ModName, Var, LocSpecType)]
makeDefaultMethods Env
env [(ModName, Var, LocSpecType)]
mts = [ (ModName
mname, Var
dm, LocSpecType
t)
| (ModName
mname, Var
m, LocSpecType
t) <- [(ModName, Var, LocSpecType)]
mts
, Var
dm <- Env -> ModName -> Var -> [Var]
lookupDefaultVar Env
env ModName
mname Var
m ]
lookupDefaultVar :: Bare.Env -> ModName -> Ghc.Var -> [Ghc.Var]
lookupDefaultVar :: Env -> ModName -> Var -> [Var]
lookupDefaultVar Env
env ModName
name Var
v = Maybe Var -> [Var]
forall a. Maybe a -> [a]
Mb.maybeToList
(Maybe Var -> [Var])
-> (LocSymbol -> Maybe Var) -> LocSymbol -> [Var]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> ModName -> String -> LocSymbol -> Maybe Var
forall a.
ResolveSym a =>
Env -> ModName -> String -> LocSymbol -> Maybe a
Bare.maybeResolveSym Env
env ModName
name String
"default-method"
(LocSymbol -> [Var]) -> LocSymbol -> [Var]
forall a b. (a -> b) -> a -> b
$ LocSymbol
dmSym
where
dmSym :: LocSymbol
dmSym = Var -> Symbol -> LocSymbol
forall l b. Loc l => l -> b -> Located b
F.atLoc Var
v (Symbol -> Symbol -> Symbol
GM.qualifySymbol Symbol
mSym Symbol
dnSym)
dnSym :: Symbol
dnSym = Symbol -> Symbol -> Symbol
F.mappendSym Symbol
"$dm" Symbol
nSym
(Symbol
mSym, Symbol
nSym) = Symbol -> (Symbol, Symbol)
GM.splitModuleName (Var -> Symbol
forall a. Symbolic a => a -> Symbol
F.symbol Var
v)