{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ParallelListComp  #-}
{-# LANGUAGE TupleSections     #-}
{-# LANGUAGE BangPatterns      #-}

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 Language.Haskell.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



-------------------------------------------------------------------------------
makeMethodTypes :: DEnv Ghc.Var LocSpecType -> [DataConP] -> [Ghc.CoreBind] -> [(Ghc.Var, MethodType LocSpecType)]
-------------------------------------------------------------------------------
makeMethodTypes :: DEnv Var LocSpecType
-> [DataConP] -> [CoreBind] -> [(Var, MethodType LocSpecType)]
makeMethodTypes (DEnv HashMap Var (HashMap Symbol (RISig LocSpecType))
m) [DataConP]
cls [CoreBind]
cbs 
  = [(Var
x, Maybe LocSpecType -> Maybe LocSpecType -> MethodType LocSpecType
forall t. Maybe t -> Maybe t -> MethodType t
MT (Var -> LocSpecType -> LocSpecType
addCC 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, Eq k, Hashable k) =>
k -> t -> HashMap k (HashMap Symbol a) -> Maybe a
methodType Var
d Var
x HashMap Var (HashMap Symbol (RISig LocSpecType))
m) (Var -> LocSpecType -> LocSpecType
addCC 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]
_) -> (RType RTyCon RTyVar RReft -> LocSpecType)
-> Maybe (RType RTyCon RTyVar RReft) -> Maybe LocSpecType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((DataConP -> SourcePos
dcpLoc DataConP
di SourcePos -> RType RTyCon RTyVar RReft -> LocSpecType
forall l b. Loc l => l -> b -> Located b
`F.atLoc`) (RType RTyCon RTyVar RReft -> LocSpecType)
-> (RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft)
-> RType RTyCon RTyVar RReft
-> LocSpecType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(RTyVar, Type)]
-> RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft
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)) (Maybe (RType RTyCon RTyVar RReft) -> Maybe LocSpecType)
-> Maybe (RType RTyCon RTyVar RReft) -> Maybe LocSpecType
forall a b. (a -> b) -> a -> b
$ Symbol
-> [(Symbol, RType RTyCon RTyVar RReft)]
-> Maybe (RType RTyCon RTyVar RReft)
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, RType RTyCon RTyVar RReft)]
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
subsTyVar_meet' (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 :: Ghc.Var -> LocSpecType -> LocSpecType
addCC :: Var -> LocSpecType -> LocSpecType
addCC Var
x zz :: LocSpecType
zz@(Loc SourcePos
l SourcePos
l' RType RTyCon RTyVar RReft
st0) 
  = SourcePos -> SourcePos -> RType RTyCon RTyVar RReft -> LocSpecType
forall a. SourcePos -> SourcePos -> a -> Located a
Loc SourcePos
l SourcePos
l' 
  (RType RTyCon RTyVar RReft -> LocSpecType)
-> (RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft)
-> RType RTyCon RTyVar RReft
-> LocSpecType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RType RTyCon RTyVar RReft
-> RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft
forall r.
RType RTyCon RTyVar r
-> RType RTyCon RTyVar r -> RType RTyCon RTyVar r
addForall RType RTyCon RTyVar RReft
hst  
  (RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft)
-> (RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft)
-> RType RTyCon RTyVar RReft
-> RType RTyCon RTyVar RReft
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(RTVar RTyVar (RType RTyCon RTyVar ()), RReft)]
-> [PVar (RType RTyCon RTyVar ())]
-> [(Symbol, RType RTyCon RTyVar RReft, RReft)]
-> [(Symbol, RType RTyCon RTyVar RReft, RReft)]
-> RType RTyCon RTyVar RReft
-> RType RTyCon RTyVar RReft
forall tv c r.
[(RTVar tv (RType c tv ()), r)]
-> [PVar (RType c tv ())]
-> [(Symbol, RType c tv r, r)]
-> [(Symbol, RType c tv r, r)]
-> RType c tv r
-> RType c tv r
mkArrow [] [PVar (RType RTyCon RTyVar ())]
ps' [] [] 
  (RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft)
-> (RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft)
-> RType RTyCon RTyVar RReft
-> RType RTyCon RTyVar RReft
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Symbol, RType RTyCon RTyVar RReft)]
-> RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft
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, RType RTyCon RTyVar RReft)]
cs' 
  (RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft)
-> (RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft)
-> RType RTyCon RTyVar RReft
-> RType RTyCon RTyVar RReft
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Symbol -> Expr -> Expr)
-> RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft
forall c tv.
(Symbol -> Expr -> Expr) -> RType c tv RReft -> RType c tv RReft
mapExprReft (\Symbol
_ -> CoSub -> Expr -> Expr
F.applyCoSub CoSub
coSub) 
  (RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft)
-> (RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft)
-> RType RTyCon RTyVar RReft
-> RType RTyCon RTyVar RReft
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(RTyVar, RTyVar)]
-> RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft
forall tv ty c. SubsTy tv ty c => [(tv, ty)] -> c -> c
subts [(RTyVar, RTyVar)]
su 
  (RType RTyCon RTyVar RReft -> LocSpecType)
-> RType RTyCon RTyVar RReft -> LocSpecType
forall a b. (a -> b) -> a -> b
$ RType RTyCon RTyVar RReft
st  
  where
    hst :: RType RTyCon RTyVar RReft
hst           = Type -> RType RTyCon RTyVar RReft
forall r. Monoid r => Type -> RRType r
ofType (Type -> Type
Ghc.expandTypeSynonyms Type
t0) :: SpecType
    t0 :: Type
t0            = Var -> Type
Ghc.varType Var
x 
    tyvsmap :: [(Var, RTyVar)]
tyvsmap       = case Type
-> RType RTyCon RTyVar RReft
-> (Doc -> Doc -> Error)
-> Either Error MapTyVarST
Bare.runMapTyVars Type
t0 RType RTyCon RTyVar RReft
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 (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, RType RTyCon RTyVar RReft)]
cs'           = [(Symbol
F.dummySymbol, RTyCon
-> [RType RTyCon RTyVar RReft]
-> [RTProp RTyCon RTyVar RReft]
-> RReft
-> RType RTyCon RTyVar RReft
forall c tv r.
c -> [RType c tv r] -> [RTProp c tv r] -> r -> RType c tv r
RApp RTyCon
c [RType RTyCon RTyVar RReft]
ts [] RReft
forall a. Monoid a => a
mempty) | (RTyCon
c, [RType RTyCon RTyVar RReft]
ts) <- [(RTyCon, [RType RTyCon RTyVar RReft])]
cs ] 
    ([(RTVar RTyVar (RType RTyCon RTyVar ()), RReft)]
_,[PVar (RType RTyCon RTyVar ())]
_,[(RTyCon, [RType RTyCon RTyVar RReft])]
cs,RType RTyCon RTyVar RReft
_)    = RType RTyCon RTyVar RReft
-> ([(RTVar RTyVar (RType RTyCon RTyVar ()), RReft)],
    [PVar (RType RTyCon RTyVar ())],
    [(RTyCon, [RType RTyCon RTyVar RReft])], RType RTyCon RTyVar RReft)
bkUnivClass (String -> RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft
forall a. PPrint a => String -> a -> a
F.notracepp String
"hs-spec" (RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft)
-> RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft
forall a b. (a -> b) -> a -> b
$ Type -> RType RTyCon RTyVar RReft
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, [RType RTyCon RTyVar RReft])]
_ ,RType RTyCon RTyVar RReft
st)  = RType RTyCon RTyVar RReft
-> ([(RTVar RTyVar (RType RTyCon RTyVar ()), RReft)],
    [PVar (RType RTyCon RTyVar ())],
    [(RTyCon, [RType RTyCon RTyVar RReft])], RType RTyCon RTyVar RReft)
bkUnivClass (String -> RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft
forall a. PPrint a => String -> a -> a
F.notracepp String
"lq-spec" RType RTyCon RTyVar RReft
st0)

    makeCls :: t (Symbol, RType c tv r) -> RType c tv r -> RType c tv r
makeCls t (Symbol, RType c tv r)
cs 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 (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)
cs
    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
x) 
      (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
$ RType RTyCon RTyVar RReft -> RType RTyCon RTyVar ()
forall c tv r. RType c tv r -> RType c tv ()
toRSort RType RTyCon RTyVar RReft
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
x) 

    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 (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
_ RType RTyCon RTyVar r
t1 RType RTyCon RTyVar r
t2 r
_) (RFun Symbol
x RType RTyCon RTyVar r
t1' RType RTyCon RTyVar r
t2' r
r)
      = Symbol
-> RType RTyCon RTyVar r
-> RType RTyCon RTyVar r
-> r
-> RType RTyCon RTyVar r
forall c tv r.
Symbol -> RType c tv r -> RType c tv r -> r -> RType c tv r
RFun Symbol
x (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 Tickish Var
_ 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 Tickish Var
_ 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 
            -> [(Ghc.Class, [(ModName, Ghc.Var, LocSpecType)])]
-------------------------------------------------------------------------------
makeCLaws :: Env
-> SigEnv
-> ModName
-> ModSpecs
-> [(Class, [(ModName, Var, LocSpecType)])]
makeCLaws Env
env SigEnv
sigEnv ModName
myName ModSpecs
specs = 
  [ (Class -> Maybe Class -> Class
forall a. a -> Maybe a -> a
Mb.fromMaybe (TyCon -> Class
forall a a. PPrint a => a -> a
msg TyCon
tc) (TyCon -> Maybe Class
Ghc.tyConClass_maybe TyCon
tc), (DataConP, [(ModName, Var, LocSpecType)])
-> [(ModName, Var, LocSpecType)]
forall a b. (a, b) -> b
snd (DataConP, [(ModName, Var, LocSpecType)])
cls) | (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) 
          , (DataConP, [(ModName, Var, LocSpecType)])
cls          <- Maybe (DataConP, [(ModName, Var, LocSpecType)])
-> [(DataConP, [(ModName, Var, LocSpecType)])]
forall a. Maybe a -> [a]
Mb.maybeToList (Env
-> SigEnv
-> ModName
-> ModName
-> RClass LocBareType
-> TyCon
-> Maybe (DataConP, [(ModName, Var, LocSpecType)])
mkClass Env
env SigEnv
sigEnv ModName
myName ModName
name RClass LocBareType
cls TyCon
tc)
    ]
  where
    msg :: a -> a
msg 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 



-------------------------------------------------------------------------------
makeClasses :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.ModSpecs 
            -> ([DataConP], [(ModName, Ghc.Var, LocSpecType)])
-------------------------------------------------------------------------------
makeClasses :: Env
-> SigEnv
-> ModName
-> ModSpecs
-> ([DataConP], [(ModName, Var, LocSpecType)])
makeClasses Env
env SigEnv
sigEnv ModName
myName ModSpecs
specs = 
  ([[(ModName, Var, LocSpecType)]] -> [(ModName, Var, LocSpecType)])
-> ([DataConP], [[(ModName, Var, LocSpecType)]])
-> ([DataConP], [(ModName, Var, LocSpecType)])
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)]))
-> ([(DataConP, [(ModName, Var, LocSpecType)])]
    -> ([DataConP], [[(ModName, Var, LocSpecType)]]))
-> [(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)]))
-> [(DataConP, [(ModName, Var, LocSpecType)])]
-> ([DataConP], [(ModName, Var, LocSpecType)])
forall a b. (a -> b) -> a -> b
$ [ (DataConP, [(ModName, Var, LocSpecType)])
cls | (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) 
          , (DataConP, [(ModName, Var, LocSpecType)])
cls          <- Maybe (DataConP, [(ModName, Var, LocSpecType)])
-> [(DataConP, [(ModName, Var, LocSpecType)])]
forall a. Maybe a -> [a]
Mb.maybeToList (Env
-> SigEnv
-> ModName
-> ModName
-> RClass LocBareType
-> TyCon
-> Maybe (DataConP, [(ModName, Var, LocSpecType)])
mkClass Env
env SigEnv
sigEnv ModName
myName ModName
name RClass LocBareType
cls TyCon
tc)
    ]
  where
    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 
        -> Maybe (DataConP, [(ModName, Ghc.Var, LocSpecType)])
mkClass :: Env
-> SigEnv
-> ModName
-> ModName
-> RClass LocBareType
-> TyCon
-> 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 UserError (DataConP, [(ModName, Var, LocSpecType)])
-> Maybe (DataConP, [(ModName, Var, LocSpecType)])
forall r. Env -> ModName -> Either UserError r -> Maybe r
Bare.failMaybe Env
env ModName
name 
  (Either UserError (DataConP, [(ModName, Var, LocSpecType)])
 -> Maybe (DataConP, [(ModName, Var, LocSpecType)]))
-> (TyCon
    -> Either UserError (DataConP, [(ModName, Var, LocSpecType)]))
-> TyCon
-> Maybe (DataConP, [(ModName, Var, LocSpecType)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> SigEnv
-> ModName
-> ModName
-> RClass LocBareType
-> TyCon
-> Either UserError (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 
         -> Either UserError (DataConP, [(ModName, Ghc.Var, LocSpecType)])
mkClassE :: Env
-> SigEnv
-> ModName
-> ModName
-> RClass LocBareType
-> TyCon
-> Either UserError (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 UserError LocSpecType)
-> [LocBareType] -> Either UserError [LocSpecType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Env
-> SigEnv -> ModName -> LocBareType -> Either UserError LocSpecType
mkConstr   Env
env SigEnv
sigEnv ModName
name) [LocBareType]
ss 
    [(ModName, PlugTV Var, LocSpecType)]
meths  <- ((LocSymbol, LocBareType)
 -> Either UserError (ModName, PlugTV Var, LocSpecType))
-> [(LocSymbol, LocBareType)]
-> Either UserError [(ModName, PlugTV Var, LocSpecType)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Env
-> SigEnv
-> ModName
-> (LocSymbol, LocBareType)
-> Either UserError (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, RType RTyCon RTyVar RReft)]
sts = [(LocSymbol -> Symbol
forall a. Located a -> a
val LocSymbol
s, RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft
unClass (RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft)
-> RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft
forall a b. (a -> b) -> a -> b
$ LocSpecType -> RType RTyCon RTyVar RReft
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 ())]
-> [RType RTyCon RTyVar RReft]
-> [(Symbol, RType RTyCon RTyVar RReft)]
-> RType RTyCon RTyVar RReft
-> Bool
-> Symbol
-> SourcePos
-> DataConP
DataConP SourcePos
l DataCon
dc [RTyVar]
αs [] (LocSpecType -> RType RTyCon RTyVar RReft
forall a. Located a -> a
val (LocSpecType -> RType RTyCon RTyVar RReft)
-> [LocSpecType] -> [RType RTyCon RTyVar RReft]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LocSpecType]
ss') ([(Symbol, RType RTyCon RTyVar RReft)]
-> [(Symbol, RType RTyCon RTyVar RReft)]
forall a. [a] -> [a]
reverse [(Symbol, RType RTyCon RTyVar RReft)]
sts) RType RTyCon RTyVar RReft
t Bool
False (ModName -> Symbol
forall a. Symbolic a => a -> Symbol
F.symbol ModName
name) SourcePos
l'
    (DataConP, [(ModName, Var, LocSpecType)])
-> Either UserError (DataConP, [(ModName, Var, LocSpecType)])
forall (m :: * -> *) a. Monad m => a -> m a
return  ((DataConP, [(ModName, Var, LocSpecType)])
 -> Either UserError (DataConP, [(ModName, Var, LocSpecType)]))
-> (DataConP, [(ModName, Var, LocSpecType)])
-> Either UserError (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]
    t :: RType RTyCon RTyVar RReft
t      = TyCon -> [RType RTyCon RTyVar RReft] -> RType RTyCon RTyVar RReft
forall r tv.
Monoid r =>
TyCon -> [RType RTyCon tv r] -> RType RTyCon tv r
rCls TyCon
tc [RType RTyCon RTyVar RReft]
forall c. [RType c RTyVar RReft]
as'

mkConstr :: Bare.Env -> Bare.SigEnv -> ModName -> LocBareType -> Either UserError LocSpecType     
mkConstr :: Env
-> SigEnv -> ModName -> LocBareType -> Either UserError LocSpecType
mkConstr Env
env SigEnv
sigEnv ModName
name = (LocSpecType -> LocSpecType)
-> Either UserError LocSpecType -> Either UserError LocSpecType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft)
-> LocSpecType -> LocSpecType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft
forall tv c r. RType tv c r -> RType tv c r
dropUniv) (Either UserError LocSpecType -> Either UserError LocSpecType)
-> (LocBareType -> Either UserError LocSpecType)
-> LocBareType
-> Either UserError LocSpecType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> SigEnv
-> ModName
-> PlugTV Var
-> LocBareType
-> Either UserError 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 :: RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft
unClass = ([(RTyCon, [RType RTyCon RTyVar RReft])],
 RType RTyCon RTyVar RReft)
-> RType RTyCon RTyVar RReft
forall a b. (a, b) -> b
snd (([(RTyCon, [RType RTyCon RTyVar RReft])],
  RType RTyCon RTyVar RReft)
 -> RType RTyCon RTyVar RReft)
-> (RType RTyCon RTyVar RReft
    -> ([(RTyCon, [RType RTyCon RTyVar RReft])],
        RType RTyCon RTyVar RReft))
-> RType RTyCon RTyVar RReft
-> RType RTyCon RTyVar RReft
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RType RTyCon RTyVar RReft
-> ([(RTyCon, [RType RTyCon RTyVar RReft])],
    RType RTyCon RTyVar RReft)
forall c tv r.
(PPrint c, TyConable c) =>
RType c tv r -> ([(c, [RType c tv r])], RType c tv r)
bkClass (RType RTyCon RTyVar RReft
 -> ([(RTyCon, [RType RTyCon RTyVar RReft])],
     RType RTyCon RTyVar RReft))
-> (RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft)
-> RType RTyCon RTyVar RReft
-> ([(RTyCon, [RType RTyCon RTyVar RReft])],
    RType RTyCon RTyVar RReft)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(RTVar RTyVar (RType RTyCon RTyVar ()), RReft)],
 [PVar (RType RTyCon RTyVar ())], RType RTyCon RTyVar RReft)
-> RType RTyCon RTyVar RReft
forall t1 t2 t3. (t1, t2, t3) -> t3
thrd3 (([(RTVar RTyVar (RType RTyCon RTyVar ()), RReft)],
  [PVar (RType RTyCon RTyVar ())], RType RTyCon RTyVar RReft)
 -> RType RTyCon RTyVar RReft)
-> (RType RTyCon RTyVar RReft
    -> ([(RTVar RTyVar (RType RTyCon RTyVar ()), RReft)],
        [PVar (RType RTyCon RTyVar ())], RType RTyCon RTyVar RReft))
-> RType RTyCon RTyVar RReft
-> RType RTyCon RTyVar RReft
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RType RTyCon RTyVar RReft
-> ([(RTVar RTyVar (RType RTyCon RTyVar ()), RReft)],
    [PVar (RType RTyCon RTyVar ())], RType RTyCon RTyVar RReft)
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) 
         -> Either UserError (ModName, PlugTV Ghc.Var, LocSpecType)
makeMethod :: Env
-> SigEnv
-> ModName
-> (LocSymbol, LocBareType)
-> Either UserError (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 UserError LocSpecType
-> Either UserError (ModName, PlugTV Var, LocSpecType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env
-> SigEnv
-> ModName
-> PlugTV Var
-> LocBareType
-> Either UserError LocSpecType
Bare.cookSpecTypeE Env
env SigEnv
sigEnv ModName
name PlugTV Var
mbV LocBareType
bt
  where 
    mbV :: PlugTV Var
mbV = case 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 of 
            Just Var
v  -> Var -> PlugTV Var
forall v. v -> PlugTV v
Bare.LqTV Var
v 
            Maybe Var
Nothing -> PlugTV Var
forall v. PlugTV v
Bare.GenTV 

-------------------------------------------------------------------------------
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
. [[(Var, HashMap Symbol (RISig LocSpecType))]]
-> [(Var, HashMap Symbol (RISig LocSpecType))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat 
  ([[(Var, HashMap Symbol (RISig LocSpecType))]]
 -> [(Var, HashMap Symbol (RISig LocSpecType))])
-> ([(ModName, BareSpec)]
    -> [[(Var, HashMap Symbol (RISig LocSpecType))]])
-> [(ModName, BareSpec)]
-> [(Var, HashMap Symbol (RISig 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 (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
x [LocBareType]
t [(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
x [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]
t
    as :: [RTyVar]
as      = (LocSpecType -> [RTyVar]) -> [LocSpecType] -> [RTyVar]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (RType RTyCon RTyVar RReft -> [RTyVar]
forall tv b b. RType tv b b -> [b]
univs (RType RTyCon RTyVar RReft -> [RTyVar])
-> (LocSpecType -> RType RTyCon RTyVar RReft)
-> LocSpecType
-> [RTyVar]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocSpecType -> RType RTyCon RTyVar RReft
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 = (RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft)
-> LocSpecType -> LocSpecType
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)])
-> RType RTyCon RTyVar RReft -> RType RTyCon RTyVar RReft
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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [RTyVar]
as) [(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 (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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Symbol, HashMap Symbol (RISig LocSpecType))
-> Maybe (Var, HashMap Symbol (RISig LocSpecType))
forall t t. ResolveSym t => (Symbol, t) -> Maybe (t, 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))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat 
                             ([[(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))])
-> [(Symbol, [HashMap Symbol (RISig LocSpecType)])]
-> [[(Symbol, HashMap Symbol (RISig LocSpecType))]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 (t, t)
lookupVar (Symbol
x, t
inst)      = (, t
inst) (t -> (t, t)) -> Maybe t -> Maybe (t, t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> ModName -> String -> LocSymbol -> Maybe t
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 :: (Symbol, [a]) -> [(Symbol, a)]
addInstIndex (Symbol
x, [a]
is) = Integer -> [a] -> [(Symbol, a)]
forall t b. (Show t, Num t) => t -> [b] -> [(Symbol, b)]
go Integer
0 ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
is)
  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)