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

   --FIXME: cleanup this code
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 -- (Bare.HsTV (Bare.lookupGhcVar env name "rawDictionaries" x))
    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)

-- formerly, addIndex
-- GHC internal postfixed same name dictionaries with ints
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)