{-# 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, forall t. Maybe t -> Maybe t -> MethodType t
MT (Bool -> Var -> LocSpecType -> LocSpecType
addCC Bool
allowTC Var
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RISig a -> a
fromRISig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall a. (a -> Bool) -> [a] -> [a]
filter forall a. Symbolic a => a -> Bool
GM.isMethod forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. CBVisitable a => HashSet Var -> a -> [Var]
freeVars forall a. Monoid a => a
mempty
      ds :: [(Var, CoreExpr)]
ds = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Symbolic a => a -> Bool
GM.isDictionary forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap 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
_ = forall a. Maybe a
Nothing
      classType (Just (Var
d, [Type]
ts, c
_)) t
x =
        case forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
==Var
d) forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> Var
Ghc.dataConWorkId forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataConP -> DataCon
dcpCon) [DataConP]
cls of
          (DataConP
di:[DataConP]
_) -> (DataConP -> SourcePos
dcpLoc DataConP
di forall l b. Loc l => l -> b -> Located b
`F.atLoc`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {r}.
(Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r) =>
[(RTyVar, Type)] -> RType RTyCon RTyVar r -> RType RTyCon RTyVar r
subst (forall a b. [a] -> [b] -> [(a, b)]
zip (DataConP -> [RTyVar]
dcpFreeTyVars DataConP
di) [Type]
ts) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup (forall {t}. NamedThing t => t -> Symbol
mkSymbol t
x) (DataConP -> [(Symbol, SpecType)]
dcpTyArgs DataConP
di)
          [DataConP]
_      -> 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 = forall {t} {a}.
NamedThing t =>
Maybe (HashMap Symbol a) -> t -> Maybe a
ihastype (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
_    = forall a. Maybe a
Nothing
      ihastype (Just HashMap Symbol a
xts) t
x = forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup (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 forall a b. (a -> b) -> a -> b
$ 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 = 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,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)
  = forall a. SourcePos -> SourcePos -> a -> Located a
Loc SourcePos
l SourcePos
l'
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {r}.
RType RTyCon RTyVar r
-> RType RTyCon RTyVar r -> RType RTyCon RTyVar r
addForall SpecType
hst
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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' []
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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'
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c tv.
(Symbol -> Expr -> Expr) -> RType c tv RReft -> RType c tv RReft
mapExprReft (\Symbol
_ -> CoSub -> Expr -> Expr
F.applyCoSub CoSub
coSub)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall tv ty c. SubsTy tv ty c => [(tv, ty)] -> c -> c
subts [(RTyVar, RTyVar)]
su
  forall a b. (a -> b) -> a -> b
$ SpecType
st
  where
    hst :: SpecType
hst           = 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 forall {t}. Doc -> Doc -> TError t
err of
                          Left Error
e  -> 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, 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         = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList [(forall a. Symbolic a => a -> Symbol
F.symbol RTyVar
y, Symbol -> Sort
F.FObj (forall a. Symbolic a => a -> Symbol
F.symbol RTyVar
x)) | (RTyVar
y, RTyVar
x) <- [(RTyVar, RTyVar)]
su]
    ps' :: [PVar (RType RTyCon RTyVar ())]
ps'           = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall tv ty c. SubsTy tv ty c => [(tv, ty)] -> c -> c
subts [(RTyVar, RType RTyCon RTyVar ())]
su') forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PVar (RType RTyCon RTyVar ())]
ps
    cs' :: [(Symbol, SpecType)]
cs'           = [(Symbol
F.dummySymbol, forall c tv r.
c -> [RType c tv r] -> [RTProp c tv r] -> r -> RType c tv r
RApp RTyCon
c [SpecType]
ts [] 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 (forall a. PPrint a => String -> a -> a
F.notracepp String
"hs-spec" forall a b. (a -> b) -> a -> b
$ 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 (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  = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry 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   = forall t.
SrcSpan
-> Doc
-> Doc
-> Doc
-> Doc
-> Maybe (Doc, Doc)
-> SrcSpan
-> TError t
ErrMismatch (forall a. Loc a => a -> SrcSpan
GM.fSrcSpan LocSpecType
zz) (forall a. PPrint a => a -> Doc
pprint Var
var)
      (String -> Doc
text String
"makeMethodTypes")
      (forall a. PPrint a => a -> Doc
pprint forall a b. (a -> b) -> a -> b
$ Type -> Type
Ghc.expandTypeSynonyms Type
t0)
      (forall a. PPrint a => a -> Doc
pprint forall a b. (a -> b) -> a -> b
$ forall c tv r. RType c tv r -> RType c tv ()
toRSort SpecType
st0)
      (forall a. a -> Maybe a
Just (Doc
hsT, Doc
lqT))
      (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 forall a. Eq a => a -> a -> Bool
== RTVar RTyVar (RType RTyCon RTyVar ())
v'
      = RType RTyCon RTyVar r
tt
      | Bool
otherwise
      = forall c tv r. RTVU c tv -> RType c tv r -> r -> RType c tv r
RAllT (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'
      = forall c tv r. RTVU c tv -> RType c tv r -> r -> RType c tv r
RAllT (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')
      = forall c tv r. PVU c tv -> RType c tv r -> RType c tv r
RAllP (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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)
      = 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 = 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 (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
tforall 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
xforall 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) = forall a. a -> Maybe a
Just (Var
x, forall a. [a] -> [a]
reverse [Type]
ts, forall a. [a] -> [a]
reverse [Var]
xs)
    go [Type]
_ [Var]
_ Expr b
_ = 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(ModName, RClass LocBareType, TyCon)]
classTcs 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 ->
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
              Just (DataConP, [(ModName, Var, LocSpecType)])
cls -> do
                Class
gcls <- forall b a. b -> (a -> b) -> Maybe a -> b
Mb.maybe (forall {a} {a}. PPrint a => a -> a
err TyCon
tc) forall a b. b -> Either a b
Right (TyCon -> Maybe Class
Ghc.tyConClass_maybe TyCon
tc)
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Class
gcls, forall a b. (a, b) -> b
snd (DataConP, [(ModName, Var, LocSpecType)])
cls)
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [Maybe a] -> [a]
Mb.catMaybes [Maybe (Class, [(ModName, Var, LocSpecType)])]
zMbs)
  where
    err :: a -> a
err a
tc   = forall a. HasCallStack => String -> a
error (String
"Not a type class: " forall a. [a] -> [a] -> [a]
++ forall a. PPrint a => a -> String
F.showpp a
tc)
    classTc :: RClass ty -> Maybe TyCon
classTc  = forall a.
ResolveSym a =>
Env -> ModName -> String -> LocSymbol -> Maybe a
Bare.maybeResolveSym Env
env ModName
myName String
"makeClass" forall b c a. (b -> c) -> (a -> b) -> a -> c
. BTyCon -> LocSymbol
btc_tc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ty. RClass ty -> BTyCon
rcName
    classTcs :: [(ModName, RClass LocBareType, TyCon)]
classTcs = [ (ModName
name, RClass LocBareType
cls, TyCon
tc) | (ModName
name, BareSpec
spec) <- forall k v. HashMap k v -> [(k, v)]
M.toList ModSpecs
specs
                                 , RClass LocBareType
cls          <- forall ty bndr. Spec ty bndr -> [RClass ty]
Ms.claws BareSpec
spec
                                 , TyCon
tc           <- forall a. Maybe a -> [a]
Mb.maybeToList (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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(ModName, RClass LocBareType, TyCon)]
classTcs 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
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [(a, b)] -> ([a], [b])
unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
Mb.catMaybes 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) <- forall k v. HashMap k v -> [(k, v)]
M.toList ModSpecs
specs
                                 , RClass LocBareType
cls          <- forall ty bndr. Spec ty bndr -> [RClass ty]
Ms.classes BareSpec
spec
                                 , TyCon
tc           <- forall a. Maybe a -> [a]
Mb.maybeToList (forall {ty}. RClass ty -> Maybe TyCon
classTc RClass LocBareType
cls) ]
    classTc :: RClass ty -> Maybe TyCon
classTc = forall a.
ResolveSym a =>
Env -> ModName -> String -> LocSymbol -> Maybe a
Bare.maybeResolveSym Env
env ModName
myName String
"makeClass" forall b c a. (b -> c) -> (a -> b) -> a -> c
. BTyCon -> LocSymbol
btc_tc forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)
  = forall e r. Env -> ModName -> Either e r -> Either e (Maybe r)
Bare.failMaybe Env
env ModName
name
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> SigEnv
-> ModName
-> ModName
-> RClass LocBareType
-> TyCon
-> Lookup (DataConP, [(ModName, Var, LocSpecType)])
mkClassE Env
env SigEnv
sigEnv ModName
_myName ModName
name (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
-> Lookup (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'    <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Env -> SigEnv -> ModName -> LocBareType -> Lookup LocSpecType
mkConstr   Env
env SigEnv
sigEnv ModName
name) [LocBareType]
ss
    [(ModName, PlugTV Var, LocSpecType)]
meths  <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Env
-> SigEnv
-> ModName
-> (LocSymbol, LocBareType)
-> Lookup (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 <- forall a. Maybe a -> [a]
Mb.maybeToList (forall v. PlugTV v -> Maybe v
plugSrc PlugTV Var
kv) ]
    let sts :: [(Symbol, SpecType)]
sts = [(forall a. Located a -> a
val LocSymbol
s, SpecType -> SpecType
unClass forall a b. (a -> b) -> a -> b
$ 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 [] (forall a. Located a -> a
val forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LocSpecType]
ss') (forall a. [a] -> [a]
reverse [(Symbol, SpecType)]
sts) SpecType
rt Bool
False (forall a. Symbolic a => a -> Symbol
F.symbol ModName
name) SourcePos
l'
    forall (m :: * -> *) a. Monad m => a -> m a
return  forall a b. (a -> b) -> a -> b
$ 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      = forall a. Located a -> SourcePos
loc  LocSymbol
c
    l' :: SourcePos
l'     = forall a. Located a -> SourcePos
locE LocSymbol
c
    msg :: String
msg    = String
"MKCLASS: " forall a. [a] -> [a] -> [a]
++ 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BTyVar]
as
    as' :: [RType c RTyVar RReft]
as'    = [forall r c. Monoid r => Var -> RType c RTyVar r
rVar forall a b. (a -> b) -> a -> b
$ Symbol -> Var
GM.symbolTyVar forall a b. (a -> b) -> a -> b
$ forall a. Symbolic a => a -> Symbol
F.symbol BTyVar
a | BTyVar
a <- [BTyVar]
as ]
    ms' :: [(LocSymbol, LocBareType)]
ms'    = [ (LocSymbol
s, forall r c tv.
Monoid r =>
Symbol -> RType c tv r -> RType c tv r -> RType c tv r
rFun Symbol
"" (forall c tv r.
c -> [RType c tv r] -> [RTProp c tv r] -> r -> RType c tv r
RApp BTyCon
cc (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall c tv r. tv -> r -> RType c tv r
RVar forall a. Monoid a => a
mempty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BTyVar]
as) [] forall a. Monoid a => a
mempty) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LocBareType
t) | (LocSymbol
s, LocBareType
t) <- [(LocSymbol, LocBareType)]
ms]
    rt :: SpecType
rt     = forall r tv.
Monoid r =>
TyCon -> [RType RTyCon tv r] -> RType RTyCon tv r
rCls TyCon
tc forall {c}. [RType c RTyVar RReft]
as'

mkConstr :: Bare.Env -> Bare.SigEnv -> ModName -> LocBareType -> Bare.Lookup LocSpecType
mkConstr :: Env -> SigEnv -> ModName -> LocBareType -> Lookup LocSpecType
mkConstr Env
env SigEnv
sigEnv ModName
name = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {tv} {c} {r}. RType tv c r -> RType tv c r
dropUniv) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> SigEnv
-> ModName
-> PlugTV Var
-> LocBareType
-> Lookup LocSpecType
Bare.cookSpecTypeE Env
env SigEnv
sigEnv ModName
name 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') = 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 = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c tv r.
(PPrint c, TyConable c) =>
RType c tv r -> ([(c, [RType c tv r])], RType c tv r)
bkClass forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t1 t2 t3. (t1, t2, t3) -> t3
thrd3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)
-> Lookup (ModName, PlugTV Var, LocSpecType)
makeMethod Env
env SigEnv
sigEnv ModName
name (LocSymbol
lx, LocBareType
bt) = (ModName
name, PlugTV Var
mbV,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env
-> SigEnv
-> ModName
-> PlugTV Var
-> LocBareType
-> Lookup LocSpecType
Bare.cookSpecTypeE Env
env SigEnv
sigEnv ModName
name PlugTV Var
mbV LocBareType
bt
  where
    mbV :: PlugTV Var
mbV = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall v. PlugTV v
Bare.GenTV forall v. v -> PlugTV v
Bare.LqTV (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
  = forall t. [(Var, HashMap Symbol (RISig t))] -> DEnv Var t
dfromList
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)
  forall a b. (a -> b) -> a -> b
$ 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)
  = forall a. [Maybe a] -> [a]
Mb.catMaybes
  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
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ty bndr. Spec ty bndr -> [RInstance ty]
Ms.rinstance
  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 forall a b. (a -> b) -> a -> b
$ forall a. PPrint a => String -> a -> a
F.notracepp String
"RI" forall a b. (a -> b) -> a -> b
$ 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' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LocBareType]
lbt
    rts :: [RTyVar]
rts     = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall {tv} {b} {b}. RType tv b b -> [b]
univs forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) 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
_) = 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 forall v. PlugTV v
Bare.GenTV
    mkTy :: LocBareType -> LocSpecType
    mkTy :: LocBareType -> LocSpecType
mkTy = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 forall {s} {b}. [(RTVar RTyVar s, b)] -> [(RTVar RTyVar s, b)]
tidy) 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
               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 = 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) = 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 forall a. [a] -> [a] -> [a]
++ [(RTVar RTyVar s, b)]
r
      where ([(RTVar RTyVar s, b)]
l,[(RTVar RTyVar s, b)]
r) = forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (\(RTVar RTyVar
tv RTVInfo s
_,b
_) -> RTyVar
tv 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 = 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a} {t}. ResolveSym a => (Symbol, t) -> Maybe (a, t)
lookupVar
                             forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. (Symbol, [a]) -> [(Symbol, a)]
addInstIndex
                             forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ResolveSym a =>
Env -> ModName -> String -> LocSymbol -> Maybe a
Bare.maybeResolveSym Env
env ModName
name String
"resolveDict" (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) = forall {t} {b}. (Show t, Num t) => t -> [b] -> [(Symbol, b)]
go (Int
0::Int) (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)      = (forall a. Symbolic a => a -> Symbol
F.symbol (Symbol -> String
F.symbolString Symbol
x forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
j),b
i) forall a. a -> [a] -> [a]
: t -> [b] -> [(Symbol, b)]
go (t
jforall 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 = forall a. Maybe a -> [a]
Mb.maybeToList
                            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
ResolveSym a =>
Env -> ModName -> String -> LocSymbol -> Maybe a
Bare.maybeResolveSym Env
env ModName
name String
"default-method"
                            forall a b. (a -> b) -> a -> b
$ LocSymbol
dmSym
  where
    dmSym :: LocSymbol
dmSym                   = 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 (forall a. Symbolic a => a -> Symbol
F.symbol Var
v)