Merge pull request #2424 from ucsd-progsys/fd/instance-method-names

Use GHC names for instance methods and dictionaries

liquidhaskell-boot/src-ghc/Liquid/GHC/API.hs

@@ -305,8 +305,10 @@ import GHC.Core.FamInstEnv            as Ghc
 import GHC.Core.InstEnv               as Ghc
     ( ClsInst(is_cls, is_dfun, is_dfun_name, is_tys)
     , DFunId
+    , InstEnvs
     , instEnvElts
     , instanceSig
+    , lookupInstEnv
     )
 import GHC.Core.Make                  as Ghc
     ( mkCoreApps
@@ -514,6 +516,8 @@ import GHC.Tc.Types                   as Ghc
 import GHC.Tc.Types.Evidence          as Ghc
     ( TcEvBinds(EvBinds) )
 import GHC.Tc.Types.Origin            as Ghc (lexprCtOrigin)
+import GHC.Tc.Utils.Env               as Ghc
+    ( tcGetInstEnvs )
 import GHC.Tc.Utils.Monad             as Ghc
     ( captureConstraints
     , discardConstraints

liquidhaskell-boot/src/Language/Haskell/Liquid/Bare.hs

@@ -213,7 +213,8 @@ makeGhcSpec cfg localVars src lmap targetSpec dependencySpecs = do
   hscEnv <- Ghc.getTopEnv
   session <- Ghc.Session <$> Ghc.liftIO (newIORef hscEnv)
   tcg <- Ghc.getGblEnv
-  (dg0, sp) <- makeGhcSpec0 cfg session tcg localVars src lmap targetSpec dependencySpecs
+  instEnvs <- Ghc.tcGetInstEnvs
+  (dg0, sp) <- makeGhcSpec0 cfg session tcg instEnvs localVars src lmap targetSpec dependencySpecs
   let diagnostics = Bare.checkTargetSpec (targetSpec : map snd dependencySpecs)
                                          (toTargetSrc src)
                                          (ghcSpecEnv sp)
@@ -255,13 +256,14 @@ makeGhcSpec0
   :: Config
   -> Ghc.Session
   -> Ghc.TcGblEnv
+  -> Ghc.InstEnvs
   -> Bare.LocalVars
   -> GhcSrc
   -> LogicMap
   -> Ms.BareSpec
   -> [(ModName, Ms.BareSpec)]
   -> Ghc.TcRn (Diagnostics, GhcSpec)
-makeGhcSpec0 cfg session tcg localVars src lmap targetSpec dependencySpecs = do
+makeGhcSpec0 cfg session tcg instEnvs localVars src lmap targetSpec dependencySpecs = do
   -- build up environments
   tycEnv <- makeTycEnv1 name env (tycEnv0, datacons) coreToLg simplifier
   let tyi      = Bare.tcTyConMap   tycEnv
@@ -273,7 +275,7 @@ makeGhcSpec0 cfg session tcg localVars src lmap targetSpec dependencySpecs = do
   -- NB: we first compute a measure environment w/o the opaque reflections, so that we can bootstrap
   -- the signature `sig`. Then we'll add the opaque reflections before we compute `sData` and al.
   let (dg1, measEnv0) = withDiagnostics $ makeMeasEnv      env tycEnv sigEnv       specs
-  let (dg2, sig) = withDiagnostics $ makeSpecSig cfg name specs env sigEnv   tycEnv measEnv0 (_giCbs src)
+  let (dg2, (specInstances, sig)) = withDiagnostics $ makeSpecSig cfg name mySpec iSpecs2 env sigEnv tycEnv measEnv0 (_giCbs src)
   elaboratedSig <-
     if allowTC then Bare.makeClassAuxTypes (elaborateSpecType coreToLg simplifier) datacons instMethods
                               >>= elaborateSig sig
@@ -329,7 +331,7 @@ makeGhcSpec0 cfg session tcg localVars src lmap targetSpec dependencySpecs = do
                   -- Preserve user-defined 'imeasures'.
                 , dvariance = Ms.dvariance finalLiftedSpec ++ Ms.dvariance mySpec
                   -- Preserve user-defined 'dvariance'.
-                , rinstance = Ms.rinstance finalLiftedSpec ++ Ms.rinstance mySpec
+                , rinstance = specInstances
                   -- Preserve rinstances.
                 , asmReflectSigs = Ms.asmReflectSigs mySpec
                 }
@@ -383,7 +385,7 @@ makeGhcSpec0 cfg session tcg localVars src lmap targetSpec dependencySpecs = do
     embs     = makeEmbeds          src env (mySpec0 : map snd dependencySpecs)
     dm       = Bare.tcDataConMap tycEnv0
     (dg0, datacons, tycEnv0) = makeTycEnv0   cfg name env embs mySpec2 iSpecs2
-    env      = Bare.makeEnv cfg session tcg localVars src lmap ((name, targetSpec) : dependencySpecs)
+    env      = Bare.makeEnv cfg session tcg instEnvs localVars src lmap ((name, targetSpec) : dependencySpecs)
     -- check barespecs
     name     = F.notracepp ("ALL-SPECS" ++ zzz) $ _giTargetMod  src
     zzz      = F.showpp (fst <$> mspecs)
@@ -403,7 +405,7 @@ makeTyConEmbeds :: Bare.Env -> Ms.BareSpec -> F.TCEmb Ghc.TyCon
 makeTyConEmbeds env spec
   = F.tceFromList [ (tc, t) | (c,t) <- F.tceToList (Ms.embeds spec), tc <- symTc c ]
     where
-      symTc = Mb.maybeToList . either (const Nothing) Just . Bare.matchTyCon env
+      symTc = Mb.maybeToList . either (const Nothing) Just . Bare.lookupGhcTyConLHName env
 
 --------------------------------------------------------------------------------
 -- | [NOTE]: REFLECT-IMPORTS
@@ -798,12 +800,12 @@ makeAutoInst env name spec = S.fromList <$> kvs
 
 
 ----------------------------------------------------------------------------------------
-makeSpecSig :: Config -> ModName -> Bare.ModSpecs -> Bare.Env -> Bare.SigEnv -> Bare.TycEnv -> Bare.MeasEnv -> [Ghc.CoreBind]
-            -> Bare.Lookup GhcSpecSig
+makeSpecSig :: Config -> ModName -> Ms.BareSpec -> Bare.ModSpecs -> Bare.Env -> Bare.SigEnv -> Bare.TycEnv -> Bare.MeasEnv -> [Ghc.CoreBind]
+            -> Bare.Lookup ([RInstance LocBareType], GhcSpecSig)
 ----------------------------------------------------------------------------------------
-makeSpecSig cfg name specs env sigEnv tycEnv measEnv cbs = do
+makeSpecSig cfg name mySpec specs env sigEnv tycEnv measEnv cbs = do
   mySigs     <- makeTySigs  env sigEnv name mySpec
-  aSigs      <- F.notracepp ("makeSpecSig aSigs " ++ F.showpp name) $ makeAsmSigs env sigEnv name specs
+  aSigs      <- F.notracepp ("makeSpecSig aSigs " ++ F.showpp name) $ makeAsmSigs env sigEnv name allSpecs
   let asmSigs =  Bare.tcSelVars tycEnv
               ++ aSigs
               ++ [ (x,t) | (_, x, t) <- concatMap snd (Bare.meCLaws measEnv) ]
@@ -816,10 +818,10 @@ makeSpecSig cfg name specs env sigEnv tycEnv measEnv cbs = do
   newTys     <-  makeNewTypes env sigEnv allSpecs
   relation   <-  makeRelation env name sigEnv (Ms.relational mySpec)
   asmRel     <-  makeRelation env name sigEnv (Ms.asmRel mySpec)
-  return SpSig
+  return (instances, SpSig
     { gsTySigs   = tySigs
     , gsAsmSigs  = asmSigs
-    , gsAsmReflects = bimap getVar getVar <$> concatMap (asmReflectSigs . snd) (M.toList specs)
+    , gsAsmReflects = bimap getVar getVar <$> concatMap (asmReflectSigs . snd) allSpecs
     , gsRefSigs  = []
     , gsDicts    = dicts
     -- , gsMethods  = if noclasscheck cfg then [] else Bare.makeMethodTypes dicts (Bare.meClasses  measEnv) cbs
@@ -829,11 +831,10 @@ makeSpecSig cfg name specs env sigEnv tycEnv measEnv cbs = do
     , gsTexprs   = [ (v, t, es) | (v, t, Just es) <- mySigs ]
     , gsRelation = relation
     , gsAsmRel   = asmRel
-  }
+    })
   where
-    dicts      = Bare.makeSpecDictionaries env sigEnv specs
-    mySpec     = M.lookupDefault mempty name specs
-    allSpecs   = M.toList specs
+    (instances, dicts) = Bare.makeSpecDictionaries env sigEnv (name, mySpec) (M.toList specs)
+    allSpecs   = (name, mySpec) : M.toList specs
     rtEnv      = Bare.sigRTEnv sigEnv
     getVar sym = case Bare.lookupGhcVar env name "assume-reflection specs" sym of
       Right x -> x
@@ -906,12 +907,12 @@ checkDuplicateSigs xts = case Misc.uniqueByKey symXs  of
     symXs = [ (F.symbol x, F.loc t) | (x, t) <- xts ]
 
 
-makeAsmSigs :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.ModSpecs -> Bare.Lookup [(Ghc.Var, LocSpecType)]
+makeAsmSigs :: Bare.Env -> Bare.SigEnv -> ModName -> [(ModName, Ms.BareSpec)] -> Bare.Lookup [(Ghc.Var, LocSpecType)]
 makeAsmSigs env sigEnv myName specs = do
   raSigs <- rawAsmSigs env myName specs
   return [ (x, t) | (name, x, bt) <- raSigs, let t = Bare.cookSpecType env sigEnv name (Bare.LqTV x) bt ]
 
-rawAsmSigs :: Bare.Env -> ModName -> Bare.ModSpecs -> Bare.Lookup [(ModName, Ghc.Var, LocBareType)]
+rawAsmSigs :: Bare.Env -> ModName -> [(ModName, Ms.BareSpec)] -> Bare.Lookup [(ModName, Ghc.Var, LocBareType)]
 rawAsmSigs env myName specs = do
   aSigs <- allAsmSigs env myName specs
   return [ (m, v, t) | (v, sigs) <- aSigs, let (m, t) = myAsmSig v sigs ]
@@ -985,10 +986,10 @@ takeBiggest :: (Ord b) => (a -> b) -> [a] -> Maybe a
 takeBiggest _ []  = Nothing
 takeBiggest f xs  = Just $ L.maximumBy (compare `on` f) xs
 
-allAsmSigs :: Bare.Env -> ModName -> Bare.ModSpecs ->
+allAsmSigs :: Bare.Env -> ModName -> [(ModName, Ms.BareSpec)] ->
               Bare.Lookup [(Ghc.Var, [(Bool, ModName, LocBareType)])]
 allAsmSigs env myName specs = do
-  let aSigs = [ (name, locallyDefined, x, t) | (name, spec) <- M.toList specs
+  let aSigs = [ (name, locallyDefined, x, t) | (name, spec) <- specs
                                    , (locallyDefined, x, t) <- getAsmSigs myName name spec ]
   vSigs    <- forM aSigs $ \(name, locallyDefined, x, t) -> do
                 v <- Bare.lookupGhcIdLHName env x
@@ -1039,14 +1040,6 @@ getAsmSigs myName name spec
     qSym           = GM.qualifySymbol ns
     ns             = F.symbol name
 
--- TODO-REBARE: grepClassAssumes
-_grepClassAssumes :: [RInstance t] -> [(Located F.Symbol, t)]
-_grepClassAssumes  = concatMap go
-  where
-    go    xts              = Mb.mapMaybe goOne (risigs xts)
-    goOne (x, RIAssumed t) = Just (fmap (F.symbol . (".$c" ++ ) . F.symbolString) x, t)
-    goOne (_, RISig _)     = Nothing
-
 makeSigEnv :: F.TCEmb Ghc.TyCon -> Bare.TyConMap -> S.HashSet StableName -> BareRTEnv -> Bare.SigEnv
 makeSigEnv embs tyi exports rtEnv = Bare.SigEnv
   { sigEmbs     = embs

liquidhaskell-boot/src/Language/Haskell/Liquid/Bare/Class.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns      #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ParallelListComp  #-}
@@ -19,7 +20,6 @@ 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
 
@@ -150,7 +150,7 @@ makeCLaws env sigEnv myName specs = do
   return (Mb.catMaybes zMbs)
   where
     err tc   = error ("Not a type class: " ++ F.showpp tc)
-    classTc  = either (const Nothing) Just . Bare.matchTyCon env . btc_tc . rcName
+    classTc  = either (const Nothing) Just . Bare.lookupGhcTyConLHName env . btc_tc . rcName
     classTcs = [ (name, cls, tc) | (name, spec) <- M.toList specs
                                  , cls          <- Ms.claws spec
                                  , tc           <- Mb.maybeToList (classTc cls)
@@ -168,7 +168,7 @@ makeClasses env sigEnv myName specs = do
     classTcs = [ (name, cls, tc) | (name, spec) <- M.toList specs
                                  , cls          <- Ms.classes spec
                                  , tc           <- Mb.maybeToList (classTc cls) ]
-    classTc = either (const Nothing) Just . Bare.matchTyCon env . btc_tc . rcName
+    classTc = either (const Nothing) Just . Bare.lookupGhcTyConLHName env . btc_tc . rcName
 
 mkClass :: Bare.Env -> Bare.SigEnv -> ModName -> ModName -> RClass LocBareType -> Ghc.TyCon
         -> Bare.Lookup (Maybe (DataConP, [(ModName, Ghc.Var, LocSpecType)]))
@@ -198,8 +198,6 @@ mkClassE env sigEnv _myName name (RClass cc ss as ms) tc = do
 
 mkConstr :: Bare.Env -> Bare.SigEnv -> ModName -> LocBareType -> Bare.Lookup LocSpecType
 mkConstr env sigEnv name = fmap (fmap dropUniv) . Bare.cookSpecTypeE env sigEnv name Bare.GenTV
-  where
-    dropUniv t           = t' where (_, _, t') = bkUniv t
 
    --FIXME: cleanup this code
 unClass :: SpecType -> SpecType
@@ -212,27 +210,35 @@ makeMethod env sigEnv name (lx, bt) = (name, mbV,) <$> Bare.cookSpecTypeE env si
     mbV = either (const Bare.GenTV) Bare.LqTV (Bare.lookupGhcIdLHName env lx)
 
 -------------------------------------------------------------------------------
-makeSpecDictionaries :: Bare.Env -> Bare.SigEnv -> ModSpecs -> DEnv Ghc.Var LocSpecType
+makeSpecDictionaries
+  :: Bare.Env
+  -> Bare.SigEnv
+  -> (ModName, Ms.BareSpec)
+  -> [(ModName, Ms.BareSpec)]
+  -> ([RInstance LocBareType], DEnv Ghc.Var LocSpecType)
 -------------------------------------------------------------------------------
-makeSpecDictionaries env sigEnv specs
-  = dfromList
-  . concatMap (makeSpecDictionary env sigEnv)
-  $ M.toList specs
+makeSpecDictionaries env sigEnv spec0 specs
+  = let (instances, specDicts) = makeSpecDictionary env sigEnv spec0
+     in (instances, dfromList $ specDicts ++ concatMap (snd . makeSpecDictionary env sigEnv) specs)
 
 makeSpecDictionary :: Bare.Env -> Bare.SigEnv -> (ModName, Ms.BareSpec)
-                   -> [(Ghc.Var, M.HashMap F.Symbol (RISig LocSpecType))]
-makeSpecDictionary env sigEnv (name, spec)
-  = Mb.catMaybes
-  . resolveDictionaries env name
-  . fmap (makeSpecDictionaryOne env sigEnv name)
-  . Ms.rinstance
-  $ spec
+                   -> ([RInstance LocBareType], [(Ghc.Var, M.HashMap F.Symbol (RISig LocSpecType))])
+makeSpecDictionary env sigEnv (name, spec) =
+    let instances = Ms.rinstance spec
+        resolved =
+          resolveDictionaries env $
+          map (makeSpecDictionaryOne env sigEnv name) instances
+        updatedInstances =
+          [ ri { riDictName = Just $ makeGHCLHNameLocatedFromId v }
+          | (ri, (v, _)) <- zip instances resolved
+          ]
+     in (updatedInstances, resolved)
 
 makeSpecDictionaryOne :: Bare.Env -> Bare.SigEnv -> ModName
                       -> RInstance LocBareType
-                      -> (F.Symbol, M.HashMap F.Symbol (RISig LocSpecType))
-makeSpecDictionaryOne env sigEnv name (RI bt lbt xts)
-         = makeDictionary $ F.notracepp "RI" $ RI bt ts [(x, mkLSpecIType t) | (x, t) <- xts ]
+                      -> RInstance LocSpecType
+makeSpecDictionaryOne env sigEnv name (RI bt mDictName lbt xts)
+         = F.notracepp "RI" $ RI bt mDictName ts [(x, mkLSpecIType t) | (x, t) <- xts ]
   where
     ts      = mkTy' <$> lbt
     rts     = concatMap (univs . val) ts
@@ -251,22 +257,37 @@ makeSpecDictionaryOne env sigEnv name (RI bt lbt xts)
     mkLSpecIType :: RISig LocBareType -> RISig LocSpecType
     mkLSpecIType t = fmap mkTy t
 
-resolveDictionaries :: Bare.Env -> ModName -> [(F.Symbol, M.HashMap F.Symbol (RISig LocSpecType))]
-                    -> [Maybe (Ghc.Var, M.HashMap F.Symbol (RISig LocSpecType))]
-resolveDictionaries env name = fmap lookupVar
-                             . concatMap addInstIndex
-                             . Misc.groupList
+resolveDictionaries :: Bare.Env -> [RInstance LocSpecType]
+                    -> [(Ghc.Var, M.HashMap F.Symbol (RISig LocSpecType))]
+resolveDictionaries env = map $ \ri ->
+    let !v = lookupDFun ri
+     in (v, M.fromList $ first (getLHNameSymbol . val) <$> risigs ri)
   where
-    lookupVar (x, inst)      = (, inst) <$> Bare.maybeResolveSym env name "resolveDict" (F.dummyLoc x)
+    lookupDFun (RI c (Just ldict) _ _) = do
+       case Bare.lookupGhcIdLHName env ldict of
+         Left e ->
+           panic (Just $ GM.fSrcSpan $ btc_tc c) $
+             "cannot find dictionary from name: " ++ show e
+         Right v -> v
+    lookupDFun (RI c _ ts _) = do
+       let tys = map (toType False . dropUniv . val) ts
+       case Bare.lookupGhcTyConLHName env (btc_tc c) of
+         Left _ ->
+           panic (Just $ GM.fSrcSpan $ btc_tc c) "cannot find type class"
+         Right tc -> case Ghc.tyConClass_maybe tc of
+           Nothing ->
+             panic (Just $ GM.fSrcSpan $ btc_tc c) "type constructor does not refer to a type class"
+           Just cls ->
+             case Ghc.lookupInstEnv False (Bare.reInstEnvs env) cls tys of
+               -- Is it ok to pick the first match?
+               ((clsInst, _) : _, _, _) ->
+                 Ghc.is_dfun clsInst
+               ([], _, _) ->
+                 panic (Just $ GM.fSrcSpan $ btc_tc c) "cannot find class instance"
+
+dropUniv :: SpecType -> SpecType
+dropUniv t = t' where (_,_,t') = bkUniv t
 
--- formerly, addIndex
--- GHC internal postfixed same name dictionaries with ints
-addInstIndex            :: (F.Symbol, [a]) -> [(F.Symbol, a)]
-addInstIndex (x, ks) = go (0::Int) (reverse ks)
-  where
-    go _ []          = []
-    go _ [i]         = [(x, i)]
-    go j (i:is)      = (F.symbol (F.symbolString x ++ show j),i) : go (j+1) is
 
 ----------------------------------------------------------------------------------
 makeDefaultMethods :: Bare.Env -> [(ModName, Ghc.Var, LocSpecType)]

liquidhaskell-boot/src/Language/Haskell/Liquid/Bare/DataType.hs

@@ -610,7 +610,7 @@ ofBDataDecl env name (Just dd@(DataDecl tc as ps cts pos sfun pt _)) maybe_invar
     err            = ErrBadData (GM.fSrcSpan tc) (pprint tc) "Mismatch in number of type variables"
 
 ofBDataDecl env name Nothing (Just (tc, is)) =
-  case Bare.matchTyCon env tc of
+  case Bare.lookupGhcTyConLHName env tc of
     Left e    -> Left e
     Right tc' -> Right ((name, TyConP srcpos tc' [] [] tcov tcontr Nothing, Nothing), [])
   where

liquidhaskell-boot/src/Language/Haskell/Liquid/Bare/Laws.hs

@@ -42,7 +42,7 @@ makeInstanceLaw env sigEnv sigs name rilaw = LawInstance
     errmsg = error ("Not a type class: " ++ F.showpp tc)
 
     classTc = tyConClass_maybe <=<
-              either (const Nothing) Just . Bare.matchTyCon env . btc_tc
+              either (const Nothing) Just . Bare.lookupGhcTyConLHName env . btc_tc
 
     mkTy :: LocBareType -> LocSpecType
     mkTy = Bare.cookSpecType env sigEnv name Bare.GenTV

liquidhaskell-boot/src/Language/Haskell/Liquid/Bare/Resolve.hs

@@ -32,7 +32,7 @@ module Language.Haskell.Liquid.Bare.Resolve
   , lookupGhcIdLHName
   , lookupGhcNamedVar
   , lookupLocalVar
-  , matchTyCon
+  , lookupGhcTyConLHName
 
   -- * Checking if names exist
   , knownGhcVar
@@ -104,8 +104,8 @@ type Lookup a = Either [Error] a
 -------------------------------------------------------------------------------
 -- | Creating an environment
 -------------------------------------------------------------------------------
-makeEnv :: Config -> Ghc.Session -> Ghc.TcGblEnv -> LocalVars -> GhcSrc -> LogicMap -> [(ModName, BareSpec)] -> Env
-makeEnv cfg session tcg localVars src lmap specs = RE
+makeEnv :: Config -> Ghc.Session -> Ghc.TcGblEnv -> Ghc.InstEnvs -> LocalVars -> GhcSrc -> LogicMap -> [(ModName, BareSpec)] -> Env
+makeEnv cfg session tcg instEnv localVars src lmap specs = RE
   { reSession   = session
   , reTcGblEnv  = tcg
   , reTypeEnv   =
@@ -114,6 +114,7 @@ makeEnv cfg session tcg localVars src lmap specs = RE
       -- also include the types of local variables.
       let varsEnv = Ghc.mkTypeEnv $ map Ghc.AnId $ letVars $ _giCbs src
        in Ghc.tcg_type_env tcg `Ghc.plusTypeEnv` varsEnv
+  , reInstEnvs = instEnv
   , reUsedExternals = usedExternals
   , reLMap      = lmap
   , reSyms      = syms
@@ -943,11 +944,11 @@ ofBRType env name f l = go []
     goSyms (x, t)                 = (x,) <$> ofBSortE env name l t
     goRApp bs tc ts rs r          = bareTCApp <$> goReft bs r <*> lc' <*> mapM (goRef bs) rs <*> mapM (go bs) ts
       where
-        lc'                    = F.atLoc lc <$> matchTyCon env lc
+        lc'                    = F.atLoc lc <$> lookupGhcTyConLHName env lc
         lc                     = btc_tc tc
 
-matchTyCon :: Env -> Located LHName -> Lookup Ghc.TyCon
-matchTyCon env lc = do
+lookupGhcTyConLHName :: Env -> Located LHName -> Lookup Ghc.TyCon
+lookupGhcTyConLHName env lc = do
     case lookupTyThing env lc of
       Ghc.ATyCon tc -> Right tc
       Ghc.AConLike (Ghc.RealDataCon dc) -> Right $ Ghc.promoteDataCon dc

liquidhaskell-boot/src/Language/Haskell/Liquid/Bare/Typeclass.hs

@@ -121,7 +121,7 @@ compileClasses src env (name, spec) rest =
       ++ concatMap (Mb.mapMaybe resolveClassMaybe . dataDecls . snd) rest
   resolveClassMaybe :: DataDecl -> Maybe Ghc.Class
   resolveClassMaybe d =
-    either (const Nothing) Just (Bare.matchTyCon env $ dataNameSymbol $ tycName d)
+    either (const Nothing) Just (Bare.lookupGhcTyConLHName env $ dataNameSymbol $ tycName d)
       >>= Ghc.tyConClass_maybe
 
 

liquidhaskell-boot/src/Language/Haskell/Liquid/Bare/Types.hs

@@ -73,6 +73,7 @@ data Env = RE
   { reSession   :: Ghc.Session
   , reTcGblEnv  :: Ghc.TcGblEnv
   , reTypeEnv   :: Ghc.TypeEnv
+  , reInstEnvs  :: Ghc.InstEnvs
   , reUsedExternals :: Ghc.NameSet
   , reLMap      :: LogicMap
   , reSyms      :: [(F.Symbol, Ghc.Var)]    -- ^ see "syms" in old makeGhcSpec'