constraints-deriving 1.1.1.1 → 1.1.1.2

raw patch · 16 files changed

+681/−569 lines, 16 filesdep ~ghcsetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: ghc

API changes (from Hackage documentation)

Files

• Setup.hs +2/−2
• constraints-deriving.cabal +7/−4
• example/Lib/BackendFamily.hs +6/−8
• example/Lib/VecBackend.hs +1/−1
• example/Lib/Vector.hs +6/−7
• example/Main.hs +3/−4
• src/Data/Constraint/Bare.hs +0/−4
• src/Data/Constraint/Deriving.hs +4/−11
• src/Data/Constraint/Deriving/ClassDict.hs +22/−18
• src/Data/Constraint/Deriving/Compat.hs +219/−0
• src/Data/Constraint/Deriving/CorePluginM.hs +42/−353
• src/Data/Constraint/Deriving/DeriveAll.hs +121/−104
• src/Data/Constraint/Deriving/Import.hs +48/−0
• src/Data/Constraint/Deriving/OverlapMode.hs +82/−0
• src/Data/Constraint/Deriving/ToInstance.hs +64/−29
• test/Spec.hs +54/−24

@@ -26,7 +26,7 @@ import Distribution.PackageDescription import Distribution.Simple import qualified Distribution.ModuleName as ModuleName-#if MIN_VERSION_Cabal(3,5,0)+#if MIN_VERSION_Cabal(3,4,0) import Distribution.Types.ModuleReexport #elif MIN_VERSION_Cabal(2,0,0) import Distribution.Types.CondTree (CondBranch(CondBranch))@@ -46,7 +46,7 @@     { condTreeComponents = reexportBranch : condTreeComponents ct }   where     constraintsCondition = Var (-#if MIN_VERSION_Cabal(3,5,0)+#if MIN_VERSION_Cabal(3,4,0)                               PackageFlag #else                               Flag

@@ -1,13 +1,13 @@ cabal-version: 1.24 --- This file has been generated from package.yaml by hpack version 0.31.2.+-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack ----- hash: 1f381c6f9903b2c370468e91d9aac18c3c22484c77c40d714597171d0403c0da+-- hash: 9a339ace4bfdaf6624b72728b2cd767885828fcd2cad2769afd3443c2f4e58f0  name:           constraints-deriving-version:        1.1.1.1+version:        1.1.1.2 synopsis:       Manipulating constraints and deriving class instances programmatically. description:    The library provides a plugin to derive class instances programmatically. Please see the README on GitHub at <https://github.com/achirkin/constraints-deriving#readme> category:       Constraints@@ -84,13 +84,16 @@       Data.Constraint.Deriving.DeriveAll       Data.Constraint.Deriving.ToInstance   other-modules:+      Data.Constraint.Deriving.Compat       Data.Constraint.Deriving.CorePluginM+      Data.Constraint.Deriving.Import+      Data.Constraint.Deriving.OverlapMode   hs-source-dirs:       src   ghc-options: -Wall   build-depends:       base >=4.9 && <5-    , ghc >=8.0.1+    , ghc >=8.0.1 && <9.1   if flag(debug)     cpp-options: -DPLUGIN_DEBUG   if flag(constraints)

@@ -2,18 +2,15 @@ {-# LANGUAGE ConstraintKinds        #-} {-# LANGUAGE DataKinds              #-} {-# LANGUAGE DefaultSignatures      #-}-{-# LANGUAGE ExplicitNamespaces     #-} {-# LANGUAGE FlexibleContexts       #-} {-# LANGUAGE FlexibleInstances      #-} {-# LANGUAGE GADTs                  #-}-{-# LANGUAGE MagicHash              #-} {-# LANGUAGE MultiParamTypeClasses  #-} {-# LANGUAGE PolyKinds              #-} {-# LANGUAGE RankNTypes             #-} {-# LANGUAGE ScopedTypeVariables    #-} {-# LANGUAGE StandaloneDeriving     #-} {-# LANGUAGE TypeApplications       #-}-{-# LANGUAGE TypeFamilies           #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators          #-} {-# LANGUAGE UndecidableInstances   #-}@@ -41,6 +38,7 @@ import Debug.Trace import GHC.Base import GHC.TypeLits+import Unsafe.Coerce #if __GLASGOW_HASKELL__ < 804 import Data.Semigroup #endif@@ -102,7 +100,7 @@                      , KnownBackend (Backend (DataElemType t) (DataDims t))                      )                   => BackendSing t-    bSing = unsafeCoerce# (bSing @(Backend (DataElemType t) (DataDims t)))+    bSing = unsafeCoerce (bSing @(Backend (DataElemType t) (DataDims t)))   @@ -144,7 +142,7 @@ instance KnownBackend (Vec2Base t) where     bSing = BS2 instance CmpNat n 2 ~ 'GT => KnownBackend (ListBase t n) where-    bSing = case ( unsafeCoerce#+    bSing = case ( unsafeCoerce                      (Dict :: Dict (ListBase t n ~ ListBase t n) )                            :: Dict (ListBase t n ~ Backend  t n)                  ) of@@ -204,10 +202,10 @@       ListBase _      -> error "Unexpected-length vector"  unsafeDict :: forall a b . a => Dict a -> Dict b-unsafeDict _ = unsafeCoerce# (Dict @a)+unsafeDict _ = unsafeCoerce (Dict @a)  dataTypeDims :: forall t n . Backend t n -> Dict (t ~ DataElemType (Backend t n), n ~ DataDims (Backend t n))-dataTypeDims _ = unsafeCoerce# (Dict @(t ~ t, n ~ n))+dataTypeDims _ = unsafeCoerce (Dict @(t ~ t, n ~ n))  --  Hmm, would be interesting to "provide" KnownBackend (Backend t (n+1)) bCons :: forall t n@@ -218,7 +216,7 @@     BS0 -> ScalarBase a     BS1 -> case as of ScalarBase b -> Vec2Base a b     BS2 -> case as of Vec2Base b c -> ListBase [a,b,c]-    BSn -> case as of ListBase as' -> unsafeCoerce# (ListBase (a : as'))+    BSn -> case as of ListBase as' -> unsafeCoerce (ListBase (a : as'))  bNil :: Backend t 0 bNil = UnitBase

@@ -30,7 +30,7 @@ import Data.Constraint.Deriving import Data.Constraint.Unsafe import GHC.Base-import GHC.TypeLits             (KnownNat, Nat)+import GHC.TypeLits import Unsafe.Coerce #if __GLASGOW_HASKELL__ < 804 import Data.Semigroup

@@ -1,11 +1,9 @@ {-# LANGUAGE CPP                        #-} {-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE ExplicitNamespaces         #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MagicHash                  #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE PatternSynonyms            #-} {-# LANGUAGE RoleAnnotations            #-}@@ -27,7 +25,7 @@   than the `Vector t 1` type is a newtype wrapper over `t`,   and GHC statically uses all type class instances for `t`, sidestepping dynamic instance elaboration.   But, if GHC does not know the dimensionality of the vector statically,-  it selects class instances dynamically at runtime.  +  it selects class instances dynamically at runtime.  -} module Lib.Vector   ( -- * Data types@@ -41,8 +39,9 @@ import Data.Semigroup #endif import Data.Constraint-import GHC.Base        (Type, unsafeCoerce#)+import GHC.Base        (Type) import GHC.TypeLits    (type (+), type (-), KnownNat, Nat)+import Unsafe.Coerce   (unsafeCoerce)  import Lib.BackendFamily import Lib.VecBackend@@ -87,12 +86,12 @@                          , t ~ DataElemType (Vector t m)                          )                   , t, Vector t m )-vUncons = case underiveKB @t @n of Dict -> unsafeCoerce# (bUncons @t @n @m)+vUncons = case underiveKB @t @n of Dict -> unsafeCoerce (bUncons @t @n @m)  vCons :: forall t n        . KnownBackend (Vector t n)       => t -> Vector t n -> Vector t (n + 1)-vCons = case underiveKB @t @n of Dict -> unsafeCoerce# (bCons @t @n)+vCons = case underiveKB @t @n of Dict -> unsafeCoerce (bCons @t @n)   data SomeVector (t :: Type) where@@ -114,4 +113,4 @@ deriving instance Monoid (VecBackend t n (Backend t n)) => Monoid (Vector t n)  underiveKB :: forall t n . KnownBackend (Vector t n) => Dict (KnownBackend (Backend t n))-underiveKB = unsafeCoerce# (Dict @(KnownBackend (Vector t n)))+underiveKB = unsafeCoerce (Dict @(KnownBackend (Vector t n)))

@@ -3,16 +3,16 @@ module Main (main) where  #if __GLASGOW_HASKELL__ < 804-import           Data.Semigroup+import Data.Semigroup #endif-import           Lib.Vector+import Lib.Vector   main :: IO () main = do     print $ Z <> (mempty :: Vector Double 0)     print $ (7 :: Double) :* Z <> 15 :* Z-    print $ (7 :: Double) :* Z <> mempty +    print $ (7 :: Double) :* Z <> mempty     print $ mempty <> 2 :* 6 :* Z <> v2     () <- case v2 of       a :* as -> print $ a :* Z <> as@@ -32,4 +32,3 @@     sdf2 = SomeVector $ (2::Int) :* 6 :* Z     sdf7 = SomeVector $ (1::Float)       :* 2 :* 3 :* 4 :* 5 :* 16 :* 92 :* Z-

@@ -29,11 +29,7 @@  import Data.Constraint (Dict (..)) import GHC.Base        (Constraint, Type)-#if __GLASGOW_HASKELL__ >= 900 import GHC.Exts        (unsafeCoerce#)-#else-import GHC.Base        (unsafeCoerce#)-#endif  -- | An unsafeCoerced pointer to a Constraint, such as a class function dictionary. data BareConstraint :: Constraint -> Type

@@ -11,21 +11,14 @@   , ClassDict (..)   ) where ---import Data.List  (sortOn)-import GhcPlugins hiding (OverlapMode (..), overlapMode)-import InstEnv    (is_cls, is_tys)-#if __GLASGOW_HASKELL__ < 808-import Type (tyConAppTyCon_maybe)-#endif+import Data.List (sortOn)  import Data.Constraint.Deriving.ClassDict import Data.Constraint.Deriving.DeriveAll+import Data.Constraint.Deriving.Import import Data.Constraint.Deriving.ToInstance  - -- | To use the plugin, add -- -- @@@ -46,7 +39,7 @@ plugin :: Plugin plugin = defaultPlugin   { installCoreToDos = install-#if MIN_VERSION_ghc(8,6,0)+#if __GLASGOW_HASKELL__ >= 860   , pluginRecompile = purePlugin #endif   }@@ -57,7 +50,7 @@     return ( deriveAllPass eref            : classDictPass eref            : toInstancePass eref-           : if elem "dump-instances" cmdopts+           : if "dump-instances" `elem` cmdopts              then dumpInstances:todo              else todo            )

@@ -1,5 +1,4 @@ {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE LambdaCase         #-} {-# LANGUAGE OverloadedStrings  #-} module Data.Constraint.Deriving.ClassDict   ( ClassDict (..)@@ -7,13 +6,13 @@   , CorePluginEnvRef, initCorePluginEnv   ) where -import           Control.Monad (join, unless, when)-import           Data.Data     (Data)-import           Data.Maybe    (fromMaybe, isJust)-import           GhcPlugins    hiding (OverlapMode (..), overlapMode, mkFunTy)-import qualified Unify+import Control.Monad (join, unless, when)+import Data.Data     (Data)+import Data.Maybe    (fromMaybe, isJust) + import Data.Constraint.Deriving.CorePluginM+import Data.Constraint.Deriving.Import   {- | A marker to tell the core plugin to replace the implementation of a@@ -50,7 +49,7 @@        An incorrect signature will result in a compile-time error.      * The dummy implementation @deriveFooClass = deriveFooClass@ is used here to        prevent GHC from inlining the function before the plugin can replace it.-       But you can implement in any way you like at your own risk.+       But you can implement it in any way you like at your own risk.  -} data ClassDict = ClassDict   deriving (Eq, Show, Read, Data)@@ -76,8 +75,8 @@          ]     return guts { mg_binds = processedBinds}   where-    annotateds :: UniqFM [Name]-    annotateds = map fst <$> (getModuleAnns guts :: UniqFM [(Name, ClassDict)])+    annotateds :: UniqMap [Name]+    annotateds = map fst <$> (getModuleAnns guts :: UniqMap [(Name, ClassDict)])      go :: CoreBind -> WithAnns CoreBind     go (NonRec b e) = NonRec b <$> classDict' b e@@ -87,7 +86,7 @@       [" " , bullet, ppr $ occName n, ppr $ nameSrcSpan n]     pprNotes = vcat . map (\x -> hsep [" ", bullet, x]) -    classDict' x origBind = WithAnns $ \anns -> case lookupUFM anns x of+    classDict' x origBind = WithAnns $ \anns -> case lookupUFM anns (getUnique x) of       Just (xn:xns) -> do         unless (null xns) $           pluginLocatedWarning (nameSrcSpan xn) $@@ -98,15 +97,15 @@             , ")"             ]         -- add new definitions and continue-        (,) (delFromUFM anns x)  . fromMaybe origBind <$> try (classDict x)+        (,) (delFromUFM anns (getUnique x))  . fromMaybe origBind <$> try (classDict x)       _ -> return (anns, origBind)  -- a small state transformer for tracking remaining annotations newtype WithAnns a = WithAnns-  { runWithAnns :: UniqFM [Name] -> CorePluginM (UniqFM [Name], a) }+  { runWithAnns :: UniqMap [Name] -> CorePluginM (UniqMap [Name], a) }  instance Functor WithAnns where-  fmap f m = WithAnns $ \anns -> fmap f <$> runWithAnns m anns+  fmap f m = WithAnns $ fmap (fmap f) . runWithAnns m  instance Applicative WithAnns where   pure x = WithAnns $ \anns -> pure (anns, x)@@ -169,7 +168,7 @@     let expectedType = mapResultType (mkTyConApp tcDict . (:[]))                        . idType $ dataConWorkId klassDataCon -    when (Unify.typesCantMatch [(origBindTy, expectedType)]) $+    when (typesCantMatch [(origBindTy, expectedType)]) $       pluginLocatedError loc $ vcat             [ hsep               [ "Cannot match the expected type (the type of the data constructor of the given class)"@@ -178,7 +177,7 @@             , hsep ["Found type:   ", ppr origBindTy]             ] -    argVars <- traverse (flip newLocalVar "t") argTys+    argVars <- traverse (`newLocalVar` "t") argTys     return       . mkCoreLams (bndrs ++ argVars)       $ mkCoreConApps conDict@@ -190,7 +189,7 @@   where     origBindTy = idType bindVar     (bndrs, bindTy) = splitForAllTys origBindTy-    (argTys, dictTy) = splitFunTys bindTy+    (argTys, dictTy) = splitFunTysCompat bindTy     loc = nameSrcSpan $ getName bindVar     notGoodMsg =          "ClassDict plugin pass failed to process a Dict declaraion."@@ -207,7 +206,12 @@ mapResultType f t   | (bndrs@(_:_), t') <- splitForAllTys t     = mkSpecForAllTys bndrs $ mapResultType f t'-  | Just (vis, at, rt) <- splitFunTyArg_maybe t-    = mkFunTy vis at (mapResultType f rt)+  | Just (vis, m, at, rt) <- splitFunTyCompat t+  -- Looks like `idType (dataConWorkId klassDataCon)` has constraints as visible arguments.+  -- I guess usually that does not change anything for the user, because they don't ever observe+  -- type signatures of class data constructors.+  -- This only pops up since 8.10 with the introduction of visibility arguments.+  -- The check below workarounds this.+    = mkFunTyCompat (mkConstraintInvis at vis) m at (mapResultType f rt)   | otherwise     = f t

@@ -0,0 +1,219 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 900+{-# LANGUAGE PatternSynonyms #-}+#define CPP_GhcPlugins GHC.Plugins+#define CPP_InstEnv    GHC.Core.InstEnv+#define CPP_TyCoRep    GHC.Core.TyCo.Rep+#define CPP_ErrUtils   GHC.Utils.Error+#else+#define CPP_GhcPlugins GhcPlugins+#define CPP_InstEnv    InstEnv+#define CPP_TyCoRep    TyCoRep+#define CPP_ErrUtils   ErrUtils+#endif+module Data.Constraint.Deriving.Compat where++import CPP_GhcPlugins+    ( Id,DFunId, Type, Coercion, SrcSpan, SDoc+    , PrintUnqualified, Name, ModSummary, WarnReason+    , DynFlags, Role, UniqFM+    , splitFunTys, coreView, mkWildValBinder+    , mkLocalIdOrCoVar, mkLocalId, isBootSummary+    , mkUnivCo, typeKind+#if __GLASGOW_HASKELL__ >= 900+    , Mult, Unique, IsBootInterface(NotBoot)+    , pattern Many, irrelevantMult+#else+    , mkErrStyle+#if __GLASGOW_HASKELL__ >= 810+    , mkInvisFunTys+#endif+#endif+#if __GLASGOW_HASKELL__ >= 810+    , AnonArgFlag(..)+#else+    , splitFunTy_maybe, mkFunTys+#endif+#if __GLASGOW_HASKELL__ >= 806+    , tcIsConstraintKind+#else+    , Kind, HscEnv, Module, OccName+#endif+#if __GLASGOW_HASKELL__ >= 802+    , idName, putLogMsg+#else+    , Expr(..), TCvSubst, UniqSet+    , isCoercionTy_maybe, unicodeSyntax, char, flSelector, log_action+#endif+    )+import CPP_InstEnv (ClsInst(..))+import CPP_TyCoRep+    ( UnivCoProvenance(PluginProv)+#if __GLASGOW_HASKELL__ >= 810+    , Type (FunTy)+#endif+    , mkFunTy+    )+import CPP_ErrUtils (Severity)+#if __GLASGOW_HASKELL__ < 806+import Kind (isConstraintKind)+import IfaceEnv (lookupOrig)+import TcRnMonad (initTcForLookup)+#endif+#if __GLASGOW_HASKELL__ < 802+import Avail (AvailInfo(..))+import Unify (tcMatchTy)+#endif+++#if __GLASGOW_HASKELL__ >= 900+type UniqMap = UniqFM Unique+#else+type UniqMap = UniqFM+#endif++#if __GLASGOW_HASKELL__ < 900+-- | A substitute for GHC.Core.Multiplicity that comes in GHC 9.0+data Mult = One | Many++mkInvisFunTysMany :: [Type] -> Type -> Type+#if __GLASGOW_HASKELL__ < 810+mkInvisFunTysMany = mkFunTys+#else+mkInvisFunTysMany = mkInvisFunTys+#endif+#endif++#if __GLASGOW_HASKELL__ < 810+data AnonArgFlag = VisArg | InvisArg+#endif++#if __GLASGOW_HASKELL__ < 802+uniqSetAny :: (a -> Bool) -> UniqSet a -> Bool+uniqSetAny g = foldl (\a -> (||) a . g) False++mkTyArg :: Type -> Expr b+mkTyArg ty+  | Just co <- isCoercionTy_maybe ty = Coercion co+  | otherwise                        = Type ty++bullet :: SDoc+bullet = unicodeSyntax (char '•') (char '*')++filterAvails :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo]+filterAvails _    [] = []+filterAvails keep (a:as) = case go a of+    Nothing -> filterAvails keep as+    Just fa -> fa : filterAvails keep as+  where+    go x@(Avail _ n)+      | keep n    = Just x+      | otherwise = Nothing+    go (AvailTC n ns fs) =+      let ns' = filter keep ns+          fs' = filter (keep . flSelector) fs+      in if null ns' && null fs'+         then Nothing+         else Just $ AvailTC n ns' fs'++tcMatchTyKi :: Type -> Type -> Maybe TCvSubst+tcMatchTyKi = tcMatchTy+#endif++#if __GLASGOW_HASKELL__ < 806+lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name+lookupOrigIO hscEnv m = initTcForLookup hscEnv . lookupOrig m++tcIsConstraintKind :: Kind -> Bool+tcIsConstraintKind = isConstraintKind+#endif++mkLocalIdCompat :: Name -> Mult -> Type -> Id+#if __GLASGOW_HASKELL__ >= 900+mkLocalIdCompat = mkLocalId+#else+mkLocalIdCompat name _ = mkLocalId name+#endif++mkLocalIdOrCoVarCompat :: Name -> Mult -> Type -> Id+#if __GLASGOW_HASKELL__ >= 900+mkLocalIdOrCoVarCompat = mkLocalIdOrCoVar+#else+mkLocalIdOrCoVarCompat name _ = mkLocalIdOrCoVar name+#endif+++setClsInstDfunId :: DFunId -> ClsInst -> ClsInst+setClsInstDfunId dFunId i = i+  { is_dfun = dFunId+#if __GLASGOW_HASKELL__ >= 802+  , is_dfun_name = idName dFunId+#endif+  }++-- | Coercion with provenance given by the plugin+mkPluginCo :: String -> Role -> Type -> Type -> Coercion+mkPluginCo reason = mkUnivCo (PluginProv $ "constraints-deriving: " ++ reason)++mkFunTyCompat :: AnonArgFlag -> Mult -> Type -> Type -> Type+#if __GLASGOW_HASKELL__ >= 900+mkFunTyCompat = mkFunTy+#elif __GLASGOW_HASKELL__ >= 810+mkFunTyCompat f _ = mkFunTy f+#else+mkFunTyCompat _ _ = mkFunTy+#endif++splitFunTyCompat :: Type -> Maybe (AnonArgFlag, Mult, Type, Type)+#if __GLASGOW_HASKELL__ >= 900+splitFunTyCompat (FunTy vis mult arg res)+    = Just (vis, mult, arg, res)+#elif __GLASGOW_HASKELL__ >= 810+splitFunTyCompat (FunTy vis arg res)+    = Just (vis, Many, arg, res)+#else+splitFunTyCompat ty | Just (arg, res) <- splitFunTy_maybe ty+    = Just (mkConstraintInvis arg VisArg, Many, arg, res)+#endif+splitFunTyCompat ty | Just ty' <- coreView ty = splitFunTyCompat ty'+splitFunTyCompat _                            = Nothing+++splitFunTysCompat :: Type -> ([Type], Type)+#if __GLASGOW_HASKELL__ >= 900+splitFunTysCompat t = (map irrelevantMult ts, r)+  where+    (ts, r) = splitFunTys t+#else+splitFunTysCompat = splitFunTys+#endif++-- | When you cannot decide if LHS of an arrow should be visible,+--   you can take this as a reasonable heuristic.+--   The second argument is the default visibility.+mkConstraintInvis :: Type -> AnonArgFlag -> AnonArgFlag+mkConstraintInvis arg vis = if tcIsConstraintKind (typeKind arg) then InvisArg else vis++mkWildValBinderCompat :: Type -> Id+#if __GLASGOW_HASKELL__ >= 900+mkWildValBinderCompat = mkWildValBinder Many+#else+mkWildValBinderCompat = mkWildValBinder+#endif++isNotBootFile :: ModSummary -> Bool+#if __GLASGOW_HASKELL__ >= 900+isNotBootFile = (NotBoot ==) . isBootSummary+#else+isNotBootFile = not . isBootSummary+#endif++putLogMsgCompat :: DynFlags -> WarnReason -> Severity+                -> SrcSpan -> PrintUnqualified -> SDoc -> IO ()+#if __GLASGOW_HASKELL__ >= 900+putLogMsgCompat df wr se ss _ = putLogMsg df wr se ss+#elif __GLASGOW_HASKELL__ >= 802+putLogMsgCompat df wr se ss pu = putLogMsg df wr se ss (mkErrStyle df pu)+#else+putLogMsgCompat df wr se ss pu = log_action df df wr se ss (mkErrStyle df pu)+#endif

@@ -1,5 +1,4 @@ {-# LANGUAGE CPP                 #-}-{-# LANGUAGE DeriveDataTypeable  #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE LambdaCase          #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -19,65 +18,25 @@     -- * Reporting   , pluginWarning, pluginLocatedWarning   , pluginError, pluginLocatedError-    -- * Tools-  , newName, newTyVar, freshenTyVar, newLocalVar-  , bullet, isConstraintKind, getModuleAnns-  , filterAvails-  , recMatchTyKi, replaceTypeOccurrences-  , OverlapMode (..), toOverlapFlag, instanceOverlapMode-  , lookupClsInsts, getInstEnvs, replaceInstance-  , mkTyArg     -- * Debugging   , pluginDebug, pluginTrace-  , HasCallStack-  , splitFunTyArg_maybe-  , mkFunTy-#if __GLASGOW_HASKELL__ < 810-  , mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkInvisFunTys-#endif+    -- * Tools+  , newName, newTyVar, freshenTyVar, newLocalVar, getInstEnvs, getModuleAnns   ) where -import qualified Avail-import           Class               (Class)-import           Control.Applicative (Alternative (..))-import           Control.Monad       (join, (>=>))-import           Data.Data           (Data, typeRep)-import           Data.IORef          (IORef, modifyIORef', newIORef, readIORef)-import           Data.Maybe          (catMaybes)-import           Data.Monoid         as Mon (First (..), Monoid (..))-import           Data.Proxy          (Proxy (..))-import           Data.Semigroup      as Sem (Semigroup (..))-import qualified ErrUtils-import qualified Finder-import           GhcPlugins          hiding (OverlapMode (..), empty,-                                      overlapMode, (<>), mkFunTy)-import qualified GhcPlugins-import qualified IfaceEnv-import           InstEnv             (InstEnv, InstEnvs)-import qualified InstEnv-import qualified LoadIface-import           MonadUtils          (MonadIO (..))-import qualified OccName             (varName)-import           TcRnMonad           (getEps, initTc)-import           TcRnTypes           (TcM)-import qualified Unify-#if __GLASGOW_HASKELL__ >= 810-import qualified TyCoRep-#endif-#if __GLASGOW_HASKELL__ >= 808-import qualified TysWiredIn-#endif-#if __GLASGOW_HASKELL__ < 806-import qualified Kind      (isConstraintKind)-import qualified TcRnMonad (initTcForLookup)-#endif-#if __GLASGOW_HASKELL__ < 802-import GHC.Stack (HasCallStack)-#endif #if PLUGIN_DEBUG import GHC.Stack (withFrozenCallStack) #endif +import Control.Applicative (Alternative (..))+import Control.Monad       (join, (>=>))+import Data.Data           (Data, typeRep)+import Data.IORef          (IORef, modifyIORef', newIORef, readIORef)+import Data.Maybe          (catMaybes)+import Data.Proxy          (Proxy (..))++import Data.Constraint.Deriving.Import+ -- | Since I do not have access to the guts of CoreM monad, --   I implement a wrapper on top of it here. --@@ -229,11 +188,11 @@         saveAndReturn (Just ec) $ \a e -> e { tyEmptyConstraint = a }  #if __GLASGOW_HASKELL__ >= 808-    , classTypeEq = pure TysWiredIn.eqClass+    , classTypeEq = pure eqClass #else     , classTypeEq = do         m <- ask modDataTypeEquality-        mc <- try $ lookupName m cnTypeEq >>= lookupThing >>= \case+        mc <- try $ lookupName m (mkTcOcc "~") >>= lookupThing >>= \case           ATyCon tc | Just cls <- tyConClass_maybe tc             -> return cls           _ -> exception@@ -247,7 +206,7 @@         mdesc           <- case [ m | m <- mgModSummaries $ hsc_mod_graph hscEnv                       , ms_mod_name m == mn-                      , not (isBootSummary m) ] of+                      , isNotBootFile m ] of           []   -> pluginError $ hsep                   [ text "Could not find"                   , ppr mn@@ -268,15 +227,15 @@             -- Modules that we definitely need to look through,             -- even if they are from other, hidden packages             reexportedDeps i = mkUniqSet $ do-              a@Avail.AvailTC{} <- mi_exports i-              let m = nameModule $ Avail.availName a+              a@AvailTC{} <- mi_exports i+              let m = nameModule $ availName a               [ m | m /= mi_module i, notMyOwn m]             -- Load reexportedDeps recursively.             -- This enumerate all modules that export some type constructors             -- visible from the current module;             -- this includes our base types and also all classes in scope.             loadRec ms = do-              ifs <- traverse (LoadIface.loadModuleInterface reason)+              ifs <- traverse (loadModuleInterface reason)                       $ backToList ms               let ms' = foldr (unionUniqSets . reexportedDeps) ms ifs               if isEmptyUniqSet $ ms' `minusUniqSet` ms@@ -284,7 +243,7 @@               else loadRec ms'         gie <- runTcM $ do           mods <- backToList <$> loadRec mSetDirect-          LoadIface.loadModuleInterfaces reason mods+          loadModuleInterfaces reason mods           eps_inst_env <$> getEps         saveAndReturn (Just gie) $ \a e -> e { globalInstEnv = a } @@ -301,15 +260,16 @@               -> CorePluginM (Maybe Module)     lookupDep hsce (mpn, mn)       = maybeFound <$>-        liftIO (Finder.findImportedModule hsce (unLoc mn) mpn)+        liftIO (findImportedModule hsce (unLoc mn) mpn)     reason = text $ "Constraints.Deriving.CorePluginM "                                ++ "itinialization of global InstEnv"     -- Ignore my own modules: they do not contain any classes.     notMyOwn m = moduleNameString (moduleName m) `notElem`       [ "Data.Constraint.Deriving"+      , "Data.Constraint.Deriving.Import"+      , "Data.Constraint.Deriving.Compat"       , "Data.Constraint.Deriving.DeriveAll"       , "Data.Constraint.Deriving.ToInstance"-      , "Data.Constraint.Deriving.ToInstance"       , "Data.Constraint.Deriving.CorePluginM"       ] #if __GLASGOW_HASKELL__ < 804@@ -325,13 +285,7 @@ lookupName :: Module -> OccName -> CorePluginM Name lookupName m occn = do     hscEnv <- liftCoreM getHscEnv-    liftIO-#if __GLASGOW_HASKELL__ < 806-        $ TcRnMonad.initTcForLookup hscEnv-        $ IfaceEnv.lookupOrig m occn-#else-        $ IfaceEnv.lookupOrigIO hscEnv m occn-#endif+    liftIO $ lookupOrigIO hscEnv m occn  runTcM :: TcM a -> CorePluginM a runTcM mx = do@@ -339,36 +293,25 @@   modu <- liftCoreM getModule   let sp = realSrcLocSpan $ mkRealSrcLoc (fsLit "<CorePluginM.runTcM>") 1 1   ((warns, errs), my) <- liftIO $ initTc hsce HsSrcFile False modu sp mx-  mapM_ pluginWarning $ ErrUtils.pprErrMsgBagWithLoc warns+  mapM_ pluginWarning $ pprErrMsgBagWithLoc warns   case my of     Nothing ->       let f []     = pluginError $ text "runTcM failed"           f [x]    = pluginError x           f (x:xs) = pluginWarning x >> f xs-      in f $ ErrUtils.pprErrMsgBagWithLoc errs+      in f $ pprErrMsgBagWithLoc errs     Just y  -> do-      mapM_ pluginWarning $ ErrUtils.pprErrMsgBagWithLoc errs+      mapM_ pluginWarning $ pprErrMsgBagWithLoc errs       return y --- Made this similar to tcRnGetInfo---   and a hidden function lookupInsts used there-lookupClsInsts :: InstEnvs -> TyCon -> [InstEnv.ClsInst]-lookupClsInsts ie tc =-  [ ispec        -- Search all-  | ispec <- InstEnv.instEnvElts (InstEnv.ie_local  ie)-          ++ InstEnv.instEnvElts (InstEnv.ie_global ie)-  , InstEnv.instIsVisible (InstEnv.ie_visible ie) ispec-  , tyConName tc `elemNameSet` InstEnv.orphNamesOfClsInst ispec-  ]- getInstEnvs :: ModGuts-            -> CorePluginM InstEnv.InstEnvs+            -> CorePluginM InstEnvs getInstEnvs guts = do   globalInsts <- ask globalInstEnv-  return $ InstEnv.InstEnvs-    { InstEnv.ie_global  = globalInsts-    , InstEnv.ie_local   = mg_inst_env guts-    , InstEnv.ie_visible = mkModuleSet . dep_orphs $ mg_deps guts+  return $ InstEnvs+    { ie_global  = globalInsts+    , ie_local   = mg_inst_env guts+    , ie_visible = mkModuleSet . dep_orphs $ mg_deps guts     }  lookupModule :: ModuleName@@ -383,7 +326,7 @@       Nothing -> go he xs       Just md -> return md -    findIt he = fmap getIt . liftIO . Finder.findImportedModule he mdName+    findIt he = fmap getIt . liftIO . findImportedModule he mdName     getIt (Found _ md)                = Just md     getIt (FoundMultiple ((md, _):_)) = Just md     getIt _                           = Nothing@@ -420,7 +363,7 @@     loc <- liftCoreM getSrcSpanM     u <- getUniqueM     return $-      mkLocalId (mkInternalName u (mkOccName OccName.varName nameStr) loc) ty+      mkLocalIdCompat (mkInternalName u (mkOccName varName nameStr) loc) Many ty  -- | Generate new unique name newName :: NameSpace -> String -> CorePluginM Name@@ -434,20 +377,20 @@   pluginError :: SDoc -> CorePluginM a-pluginError = pluginProblemMsg Nothing ErrUtils.SevError+pluginError = pluginProblemMsg Nothing SevError  pluginLocatedError :: SrcSpan -> SDoc -> CorePluginM a-pluginLocatedError loc = pluginProblemMsg (Just loc) ErrUtils.SevError+pluginLocatedError loc = pluginProblemMsg (Just loc) SevError  pluginWarning :: SDoc -> CorePluginM ()-pluginWarning = try' . pluginProblemMsg Nothing ErrUtils.SevWarning+pluginWarning = try' . pluginProblemMsg Nothing SevWarning  pluginLocatedWarning :: SrcSpan -> SDoc -> CorePluginM ()-pluginLocatedWarning loc = try' . pluginProblemMsg (Just loc) ErrUtils.SevWarning+pluginLocatedWarning loc = try' . pluginProblemMsg (Just loc) SevWarning  pluginDebug :: SDoc -> CorePluginM () #if PLUGIN_DEBUG-pluginDebug = try' . pluginProblemMsg Nothing ErrUtils.SevDump+pluginDebug = try' . pluginProblemMsg Nothing SevDump #else pluginDebug = const (pure ()) #endif@@ -464,7 +407,7 @@ {-# INLINE pluginTrace #-}  pluginProblemMsg :: Maybe SrcSpan-                 -> ErrUtils.Severity+                 -> Severity                  -> SDoc                  -> CorePluginM a pluginProblemMsg mspan sev msg = do@@ -474,247 +417,29 @@     Nothing -> liftCoreM getSrcSpanM   unqual <- liftCoreM getPrintUnqualified   CorePluginM $ const $ pure $ Left $-    putLogMsg dflags NoReason sev loc (mkErrStyle dflags unqual) msg--#if __GLASGOW_HASKELL__ < 802-putLogMsg :: DynFlags -> WarnReason -> ErrUtils.Severity-          -> SrcSpan -> PprStyle -> SDoc -> IO ()-putLogMsg dflags = log_action dflags dflags-#endif--filterAvails :: (Name -> Bool) -> [Avail.AvailInfo] -> [Avail.AvailInfo]-#if __GLASGOW_HASKELL__ < 802-filterAvails _    [] = []-filterAvails keep (a:as) = case go a of-    Nothing -> filterAvails keep as-    Just fa -> fa : filterAvails keep as-  where-    go x@(Avail.Avail _ n)-      | keep n    = Just x-      | otherwise = Nothing-    go (Avail.AvailTC n ns fs) =-      let ns' = filter keep ns-          fs' = filter (keep . flSelector) fs-      in if null ns' && null fs'-         then Nothing-         else Just $ Avail.AvailTC n ns' fs'-#else-filterAvails = Avail.filterAvails-#endif--#if __GLASGOW_HASKELL__ < 802-bullet :: SDoc-bullet = unicodeSyntax (char '•') (char '*')-#endif+    putLogMsgCompat dflags NoReason sev loc unqual msg  --- This function was moved and renamed in GHC 8.6--- | Check if this kind is Constraint, as seen to the typechecker.-isConstraintKind :: Kind -> Bool-#if __GLASGOW_HASKELL__ < 806-isConstraintKind = Kind.isConstraintKind-#else-isConstraintKind = tcIsConstraintKind-#endif--#if __GLASGOW_HASKELL__ < 802-mkTyArg :: Type -> Expr b-mkTyArg ty-  | Just co <- isCoercionTy_maybe ty = Coercion co-  | otherwise                        = Type ty-#endif- -- | Similar to `getAnnotations`, but keeps the annotation target. --   Also, it is hardcoded to `deserializeWithData`. --   Looks only for annotations defined in this module. --   Ignores module annotations.-getModuleAnns :: forall a . Data a => ModGuts -> UniqFM [(Name, a)]+getModuleAnns :: forall a . Data a => ModGuts -> UniqMap [(Name, a)] getModuleAnns = go . mg_anns   where     valTRep = typeRep (Proxy :: Proxy a)-    go :: [Annotation] -> UniqFM [(Name, a)]+    go :: [Annotation] -> UniqMap [(Name, a)]     go [] = emptyUFM     go (Annotation          (NamedTarget n) -- ignore module targets          (Serialized trep bytes)         : as)       | trep == valTRep -- match type representations-      = addToUFM_Acc (:) (:[]) (go as) n (n, deserializeWithData bytes)+      = addToUFM_Acc (:) (:[]) (go as) (getUnique n) (n, deserializeWithData bytes)     -- ignore non-matching annotations     go (_:as) = go as  ---- | Similar to Unify.tcMatchTyKis, but looks if there is a non-trivial subtype---   in the first type that matches the second.---   Non-trivial means not a TyVar.-recMatchTyKi :: Bool -- ^ Whether to do inverse match (instance is more conrete)-             -> Type -> Type -> Maybe TCvSubst-recMatchTyKi inverse tsearched ttemp = go tsearched-  where-    go :: Type -> Maybe TCvSubst-    go t-        -- ignore plain TyVars-      | isTyVarTy t-        = Nothing-        -- found a good substitution-      | Just sub <- if inverse-                    then matchIt ttemp t-                    else matchIt t ttemp-        = Just sub-        -- split type constructors-      | Just (_, tys) <- splitTyConApp_maybe t-        = getFirst $ foldMap (First . go) tys-        -- split foralls-      | (_:_, t') <- splitForAllTys t-        = go t'-        -- split arrow types-      | Just (at, rt) <- splitFunTy_maybe t-        = go at <|> go rt-      | otherwise-        = Nothing-#if __GLASGOW_HASKELL__ >= 802-    matchIt = Unify.tcMatchTyKi-#else-    matchIt = Unify.tcMatchTy-#endif---- | Replace all occurrences of one type in another.-replaceTypeOccurrences :: Type -> Type -> Type -> Type-replaceTypeOccurrences told tnew = replace-  where-    replace :: Type -> Type-    replace t-        -- found occurrence-      | eqType t told-        = tnew-        -- split type constructors-      | Just (tyCon, tys) <- splitTyConApp_maybe t-        = mkTyConApp tyCon $ map replace tys-        -- split foralls-      | (bndrs@(_:_), t') <- splitForAllTys t-        = mkSpecForAllTys bndrs $ replace t'-        -- split arrow types-      | Just (vis, at, rt) <- splitFunTyArg_maybe t-        = mkFunTy vis (replace at) (replace rt)-        -- could not find anything-      | otherwise-        = t----- | Replace instance in ModGuts if its duplicate already exists there;---   otherwise just add this instance.-replaceInstance :: InstEnv.ClsInst -> CoreBind -> ModGuts -> ModGuts-replaceInstance newI newB guts-  | NonRec _ newE <- newB-  , First (Just oldI) <- foldMap sameInst $ mg_insts guts-  , newDFunId <- InstEnv.instanceDFunId newI-  , origDFunId <- InstEnv.instanceDFunId oldI-  , dFunId <- newDFunId `setVarName`   idName origDFunId-                        `setVarUnique` varUnique origDFunId-  , bind   <- NonRec dFunId newE-  , inst   <- newI { InstEnv.is_dfun = dFunId-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(8,0,2,0)-                   , InstEnv.is_dfun_name = idName dFunId-#endif-#endif-                   }-    = guts-      { mg_insts    = replInst origDFunId inst $ mg_insts guts-      , mg_inst_env = mg_inst_env guts-           `InstEnv.deleteFromInstEnv` oldI-           `InstEnv.extendInstEnv` inst-      , mg_binds    = bind : remBind origDFunId (mg_binds guts)-      }-  | otherwise-    = guts-      { mg_insts    = newI : mg_insts guts-      , mg_inst_env = InstEnv.extendInstEnv (mg_inst_env guts) newI-      , mg_binds    = newB : mg_binds guts-      }-  where-    remBind _ [] = []-    remBind i' (b@(NonRec i _):bs)-      | i == i'   = remBind i' bs-      | otherwise = b  : remBind i' bs-    remBind i' (Rec rb :bs) = Rec (filter ((i' /=) . fst) rb) : remBind i' bs-    replInst _ _ [] = []-    replInst d' i' (i:is)-      | InstEnv.instanceDFunId i == d'   = i' : is-      | otherwise = i : replInst d' i' is-    sameInst i-      = First $ if InstEnv.identicalClsInstHead newI i then Just i else Nothing------- | Define the behavior for the instance selection.---   Mirrors `BasicTypes.OverlapMode`, but does not have a `SourceText` field.-data OverlapMode-  = NoOverlap-    -- ^ This instance must not overlap another `NoOverlap` instance.-    --   However, it may be overlapped by `Overlapping` instances,-    --   and it may overlap `Overlappable` instances.-  | Overlappable-    -- ^ Silently ignore this instance if you find a-    --   more specific one that matches the constraint-    --   you are trying to resolve-  | Overlapping-    -- ^ Silently ignore any more general instances that may be-    --   used to solve the constraint.-  | Overlaps-    -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags.-  | Incoherent-    -- ^ Behave like Overlappable and Overlapping, and in addition pick-    --   an an arbitrary one if there are multiple matching candidates, and-    --   don't worry about later instantiation-  deriving (Eq, Show, Read, Data)--instance Sem.Semigroup OverlapMode where-    NoOverlap <> m = m-    m <> NoOverlap = m-    Incoherent <> _ = Incoherent-    _ <> Incoherent = Incoherent-    Overlaps <> _   = Overlaps-    _ <> Overlaps   = Overlaps-    Overlappable <> Overlappable = Overlappable-    Overlapping  <> Overlapping  = Overlapping-    Overlappable <> Overlapping  = Overlaps-    Overlapping  <> Overlappable = Overlaps--instance Mon.Monoid OverlapMode where-    mempty = NoOverlap-#if !(MIN_VERSION_base(4,11,0))-    mappend = (<>)-#endif---toOverlapFlag :: OverlapMode -> OverlapFlag-toOverlapFlag m = OverlapFlag (getOMode m) False-  where-    getOMode NoOverlap    = GhcPlugins.NoOverlap noSourceText-    getOMode Overlapping  = GhcPlugins.Overlapping noSourceText-    getOMode Overlappable = GhcPlugins.Overlappable noSourceText-    getOMode Overlaps     = GhcPlugins.Overlaps noSourceText-    getOMode Incoherent   = GhcPlugins.Incoherent noSourceText--#if __GLASGOW_HASKELL__ >= 802-    noSourceText = GhcPlugins.NoSourceText-#else-    noSourceText = "[plugin-generated code]"-#endif--instanceOverlapMode :: InstEnv.ClsInst -> OverlapMode-instanceOverlapMode i = case InstEnv.overlapMode (InstEnv.is_flag i) of-    GhcPlugins.NoOverlap {}    -> NoOverlap-    GhcPlugins.Overlapping {}  -> Overlapping-    GhcPlugins.Overlappable {} -> Overlappable-    GhcPlugins.Overlaps {}     -> Overlaps-    GhcPlugins.Incoherent {}   -> Incoherent--- pnConstraintsDeriving :: FastString pnConstraintsDeriving = mkFastString "constraints-deriving" @@ -750,39 +475,3 @@  vnDictToBare :: OccName vnDictToBare = mkVarOcc "dictToBare"--#if __GLASGOW_HASKELL__ < 808-cnTypeEq :: OccName-cnTypeEq = mkTcOcc "~"-#endif--#if __GLASGOW_HASKELL__ < 810-type AnonArgFlag = ()--mkVisFunTy, mkInvisFunTy :: Type -> Type -> Type-mkVisFunTy = GhcPlugins.mkFunTy-mkInvisFunTy = GhcPlugins.mkFunTy--mkVisFunTys, mkInvisFunTys :: [Type] -> Type -> Type-mkVisFunTys = GhcPlugins.mkFunTys-mkInvisFunTys = GhcPlugins.mkFunTys-#endif--mkFunTy :: AnonArgFlag -> Type -> Type -> Type-#if __GLASGOW_HASKELL__ < 810-mkFunTy _ = GhcPlugins.mkFunTy-#else-mkFunTy = TyCoRep.mkFunTy-#endif--splitFunTyArg_maybe :: Type -> Maybe (AnonArgFlag, Type, Type)-#if __GLASGOW_HASKELL__ < 810-splitFunTyArg_maybe ty =-    case splitFunTy_maybe ty of-        Just (arg, res) -> Just ((), arg, res)-        _               -> Nothing-#else-splitFunTyArg_maybe ty | Just ty' <- coreView ty = splitFunTyArg_maybe ty'-splitFunTyArg_maybe (TyCoRep.FunTy vis arg res)  = Just (vis, arg, res)-splitFunTyArg_maybe _                            = Nothing-#endif

@@ -1,7 +1,5 @@-{-# LANGUAGE CPP                #-} {-# LANGUAGE DataKinds          #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE KindSignatures     #-} {-# LANGUAGE LambdaCase         #-} {-# LANGUAGE OverloadedStrings  #-} {-# LANGUAGE RecordWildCards    #-}@@ -12,12 +10,6 @@   , CorePluginEnvRef, initCorePluginEnv   ) where --import           Class               (Class, classTyCon)-import           CoAxiom             (CoAxBranch, coAxBranchIncomps,-                                      coAxBranchLHS, coAxBranchRHS,-                                      coAxiomBranches, coAxiomSingleBranch,-                                      fromBranches) import           Control.Applicative (Alternative (..)) import           Control.Arrow       (second) import           Control.Monad       (join, unless)@@ -26,22 +18,11 @@ import qualified Data.Kind           (Constraint, Type) import           Data.List           (groupBy, isPrefixOf, nubBy, sortOn) import           Data.Maybe          (catMaybes, fromMaybe)-import           Data.Monoid-import qualified FamInstEnv-import           GhcPlugins          hiding (OverlapMode (..), overlapMode,-                                      (<>))-import qualified GhcPlugins-import           InstEnv             (ClsInst, DFunInstType)-import qualified InstEnv-import qualified OccName-import           Panic               (panicDoc)-import           TcType              (tcSplitDFunTy)-import qualified Unify-#if __GLASGOW_HASKELL__ >= 810-import           Predicate-#endif+import           Data.Monoid         (First (..))  import Data.Constraint.Deriving.CorePluginM+import Data.Constraint.Deriving.Import+import Data.Constraint.Deriving.OverlapMode  -- | A marker to tell the core plugin to derive all visible class instances --      for a given newtype.@@ -97,10 +78,10 @@ deriveAllPass' :: ModGuts -> CorePluginM ModGuts deriveAllPass' gs = go (mg_tcs gs) annotateds gs   where-    annotateds :: UniqFM [(Name, DeriveAll)]+    annotateds :: UniqMap [(Name, DeriveAll)]     annotateds = getModuleAnns gs -    go :: [TyCon] -> UniqFM [(Name, DeriveAll)] -> ModGuts -> CorePluginM ModGuts+    go :: [TyCon] -> UniqMap [(Name, DeriveAll)] -> ModGuts -> CorePluginM ModGuts     -- All exports are processed, just return ModGuts     go [] anns guts = do       unless (isNullUFM anns) $@@ -112,7 +93,7 @@      -- process type definitions present in the set of annotations     go (x:xs) anns guts-      | Just ((xn, da):ds) <- lookupUFM anns x = do+      | Just ((xn, da):ds) <- lookupUFM anns (getUnique x) = do       unless (null ds) $         pluginLocatedWarning (nameSrcSpan xn) $           "Ignoring redundant DeriveAll annotations" $$@@ -124,7 +105,7 @@       pluginDebug $ "DeriveAll invoked on TyCon" <+> ppr x       (newInstances, newBinds) <- unzip . fromMaybe [] <$> try (deriveAll da x guts)       -- add new definitions and continue-      go xs (delFromUFM anns x) guts+      go xs (delFromUFM anns (getUnique x)) guts         { mg_insts    = newInstances ++ mg_insts guts         --   I decided to not modify mg_inst_env so that DeriveAll-derived instances         --   do not refer to each other.@@ -151,7 +132,7 @@     and type families in the newtype def.)   Then, lookup all class instances for the found type instances.  -}-deriveAll :: DeriveAll -> TyCon -> ModGuts -> CorePluginM [(InstEnv.ClsInst, CoreBind)]+deriveAll :: DeriveAll -> TyCon -> ModGuts -> CorePluginM [(ClsInst, CoreBind)] deriveAll da tyCon guts -- match good newtypes only   | True <- isNewTyCon tyCon@@ -188,14 +169,14 @@    where     -- O(n^2) search for duplicates. Slow, but what else can I do?..-    filterDupInsts = nubBy $ \(x,_) (y, _) -> InstEnv.identicalClsInstHead x y+    filterDupInsts = nubBy $ \(x,_) (y, _) -> identicalClsInstHead x y     mockInstance tc = do       let tvs = tyConTyVars tc           tys = mkTyVarTys tvs       rhs <- ask tyEmptyConstraint       return (tys, rhs)     unpackInstance i-      = let tys  = case tyConAppArgs_maybe <$> FamInstEnv.fi_tys i of+      = let tys  = case tyConAppArgs_maybe <$> fi_tys i of               [Just ts] -> ts               _ -> panicDoc "DeriveAll" $                 hsep@@ -203,24 +184,24 @@                       <+> "matching an instance of type family DeriveContext:"                   , ppr i, "at"                   , ppr $ nameSrcSpan $ getName i]-            rhs = FamInstEnv.fi_rhs i+            rhs = fi_rhs i         in (tys, rhs)   -- | Find all instance of a type family in scope by its TyCon.-lookupTyFamInstances :: ModGuts -> TyCon -> CorePluginM [FamInstEnv.FamInst]+lookupTyFamInstances :: ModGuts -> TyCon -> CorePluginM [FamInst] lookupTyFamInstances guts fTyCon = do     pkgFamInstEnv <- liftCoreM getPackageFamInstEnv-    return $ FamInstEnv.lookupFamInstEnvByTyCon+    return $ lookupFamInstEnvByTyCon                (pkgFamInstEnv, mg_fam_inst_env guts) fTyCon  -- | Find all possible instances of DeriveContext type family for a given TyCon-lookupDeriveContextInstances :: ModGuts -> TyCon -> CorePluginM [FamInstEnv.FamInst]+lookupDeriveContextInstances :: ModGuts -> TyCon -> CorePluginM [FamInst] lookupDeriveContextInstances guts tyCon = do     allInsts <- ask tyConDeriveContext >>= lookupTyFamInstances guts     return $ filter check allInsts   where-    check fi = case tyConAppTyCon_maybe <$> FamInstEnv.fi_tys fi of+    check fi = case tyConAppTyCon_maybe <$> fi_tys fi of       Just tc : _ -> tc == tyCon       _           -> False @@ -249,12 +230,12 @@ instance Outputable MatchingType where   ppr MatchingType {..} = vcat     [ "MatchingType"-    , "{ mtCtxEqs      = " GhcPlugins.<> ppr mtCtxEqs-    , ", mtTheta       = " GhcPlugins.<> ppr mtTheta-    , ", mtOverlapMode = " GhcPlugins.<> text (show mtOverlapMode)-    , ", mtBaseType    = " GhcPlugins.<> ppr mtBaseType-    , ", mtNewType     = " GhcPlugins.<> ppr mtNewType-    , ", mtIgnorelist  = " GhcPlugins.<> ppr mtIgnoreList+    , "{ mtCtxEqs      =" <+> ppr mtCtxEqs+    , ", mtTheta       =" <+> ppr mtTheta+    , ", mtOverlapMode =" <+> text (show mtOverlapMode)+    , ", mtBaseType    =" <+> ppr mtBaseType+    , ", mtNewType     =" <+> ppr mtNewType+    , ", mtIgnorelist  =" <+> ppr mtIgnoreList     , "}"     ] @@ -328,7 +309,7 @@   , Just ntv <- getTyVar_maybe nt   , btv == ntv     -- No constraints or anything else involving our TyVar-  , not . elem btv+  , notElem btv         . (map fst mtCtxEqs ++)         . tyCoVarsOfTypesWellScoped       $ [mtBaseType', mtNewType']@@ -485,29 +466,6 @@       ]  --- -- TODO: Not sure if I need it at all;---                   most of the API functions look through synonyms--- -- | Try to remove all occurrences of type synonyms.--- clearSynonyms :: Type -> Type--- clearSynonyms t'---       -- split type constructors---     | Just (tyCon, tys) <- splitTyConApp_maybe t---       = mkTyConApp tyCon $ map clearSynonyms tys---       -- split foralls---     | (bndrs@(_:_), t1) <- splitForAllTys t---       = mkSpecForAllTys bndrs $ clearSynonyms t1---       -- split arrow types---     | Just (at, rt) <- splitFunTy_maybe t---       = mkFunTy (clearSynonyms at) (clearSynonyms rt)---     | otherwise---       = t---   where---     stripOuter x = case tcView x of---       Nothing -> x---       Just y  -> stripOuter y---     t = stripOuter t'-- -- | Depth-first lookup of the first occurrence of any type family. --   First argument is a list of types to ignore. lookupFamily :: [Type] -> Type -> Maybe (FamTyConFlav, Type)@@ -524,7 +482,7 @@     | (_:_, t') <- splitForAllTys t       = lookupFamily ignoreLst t'       -- split arrow types-    | Just (at, rt) <- splitFunTy_maybe t+    | Just (_, _, at, rt) <- splitFunTyCompat t       = lookupFamily ignoreLst at <|> lookupFamily ignoreLst rt     | otherwise       = Nothing@@ -556,8 +514,8 @@     = withFamily ft (pure Nothing) $ const $ expandClosedFamily os bcs   where     bcs = fromBranches $ coAxiomBranches coax-    os  = if any (not . null . coAxBranchIncomps) bcs-          then map overlap bcs else repeat NoOverlap+    os  = if all (null . coAxBranchIncomps) bcs+          then repeat NoOverlap else map overlap bcs     overlap cb = if null $ coAxBranchIncomps cb           then Overlapping           else Incoherent@@ -591,7 +549,7 @@           flhs = substTys freshenSub flhs'           frhs = substTyAddInScope freshenSub $ coAxBranchRHS cb           t = foldl mkAppTy frhs $ drop n fTyArgs-          msub = Unify.tcMatchTys (take n fTyArgs) flhs+          msub = tcMatchTys (take n fTyArgs) flhs       return $ (,,) om t <$> msub  @@ -607,7 +565,7 @@     then pure $ Just [] -- No mercy     else expandClosedFamily            (repeat NoOverlap)-           (coAxiomSingleBranch . FamInstEnv.famInstAxiom <$> tfInsts)+           (coAxiomSingleBranch . famInstAxiom <$> tfInsts)            fTyArgs  @@ -623,14 +581,14 @@     else sequence <$> traverse expandDInstance tfInsts   where     expandDInstance inst-      | fitvs <- FamInstEnv.fi_tvs inst+      | fitvs <- fi_tvs inst       = do-      tvs <- traverse freshenTyVar $ fitvs+      tvs <- traverse freshenTyVar fitvs       let freshenSub = zipTvSubst fitvs $ map mkTyVarTy tvs-          fitys = substTys freshenSub $ FamInstEnv.fi_tys inst+          fitys = substTys freshenSub $ fi_tys inst           instTyArgs = align fTyArgs fitys       return $ (,,) NoOverlap (mkTyConApp fTyCon instTyArgs)-        <$> Unify.tcMatchTys fTyArgs instTyArgs+        <$> tcMatchTys fTyArgs instTyArgs     align [] _          = []     align xs []         = xs     align (_:xs) (y:ys) = y : align xs ys@@ -685,7 +643,7 @@   ppr (MptReflexive x)   = "MptReflexive" <+> ppr x   ppr (MptPropagateAs x) = "MptPropagateAs" <+> ppr x -findInstance :: InstEnv.InstEnvs+findInstance :: InstEnvs              -> Type              -> ClsInst              -> Maybe MatchingInstance@@ -699,17 +657,17 @@   | otherwise     = Nothing   where-    (_, _, iClass, iTyPams) = InstEnv.instanceSig i+    (_, _, iClass, iTyPams) = instanceSig i  -matchInstance :: InstEnv.InstEnvs+matchInstance :: InstEnvs               -> Class               -> [Type]               -> Maybe MatchingInstance matchInstance ie cls ts   | ([(i, tyVarSubs)], _notMatchButUnify, _safeHaskellStuff)-      <- InstEnv.lookupInstEnv False ie cls ts-  , (iTyVars, iTheta, _, _) <- InstEnv.instanceSig i+      <- lookupInstEnv False ie cls ts+  , (iTyVars, iTheta, _, _) <- instanceSig i   , sub <- mkTvSubstPrs          . catMaybes $ zipWith (fmap . (,)) iTyVars tyVarSubs     = do@@ -723,7 +681,7 @@   | otherwise     = Nothing -matchPredType :: InstEnv.InstEnvs+matchPredType :: InstEnvs               -> PredType               -> Maybe MatchingPredType matchPredType ie pt = go $ classifyPredType pt@@ -739,7 +697,7 @@       | eqType t1 t2   = Just . MptReflexive $ case rel of                                           NomEq  -> mkReflCo Nominal t1                                           ReprEq -> mkReflCo Representational t1-      | Unify.typesCantMatch [(t1,t2)]+      | typesCantMatch [(t1,t2)]                        = Nothing       | otherwise      = Just $ MptPropagateAs pt     go _               = Just $ MptPropagateAs pt@@ -757,13 +715,13 @@   let extraTheta             = filter (\t -> not $ any (eqType t . fst) bndrs) mtTheta       tRepl = replaceTypeOccurrences mtBaseType mtNewType tOrig-      tFun  = mkInvisFunTys (extraTheta ++ map fst bndrs) tRepl+      tFun  = mkInvisFunTysMany (extraTheta ++ map fst bndrs) tRepl       tvs   =  tyCoVarsOfTypeWellScoped tFun   return     ( mkSpecForAllTys tvs tFun-    , mkCoreLams (tvs ++ map mkWildValBinder extraTheta ++ map snd bndrs)+    , mkCoreLams (tvs ++ map mkWildValBinderCompat extraTheta ++ map snd bndrs)       $ mkCast e-      $ mkUnsafeCo Representational tOrig tRepl+      $ mkPluginCo "ignore newtype" Representational tOrig tRepl     )  @@ -785,14 +743,14 @@         )       )   where-    (iTyVars, _, iClass, iTyPams) = InstEnv.instanceSig miInst+    (iTyVars, _, iClass, iTyPams) = instanceSig miInst     -- this is the same length as iTyVars, needs to be applied on dFunId     tyVarVals = zipWith (fromMaybe . mkTyVarTy) iTyVars miInstTyVars     sub = mkTvSubstPrs . catMaybes           $ zipWith (fmap . (,)) iTyVars miInstTyVars     newTyPams = map (substTyAddInScope sub) iTyPams     newIHead = mkTyConApp (classTyCon iClass) newTyPams-    eDFun = Var $ InstEnv.instanceDFunId miInst+    eDFun = Var $ instanceDFunId miInst     eDFunWithTyPams = mkTyApps eDFun tyVarVals     addArgs :: [TyExp]             -> [MatchingPredType]@@ -824,8 +782,8 @@       loc <- liftCoreM getSrcSpanM       u <- getUniqueM       let n = mkInternalName u-                (mkOccName OccName.varName $ "dFunArg_" ++ show u) loc-          v = mkLocalIdOrCoVar n pt+                (mkOccName varName $ "dFunArg_" ++ show u) loc+          v = mkLocalIdOrCoVarCompat n Many pt       return ([(pt,v)], Var v)   where       mte = getFirst $ foldMap getSamePT ps@@ -857,7 +815,7 @@   lookupMatchingInstance :: DeriveAll-                       -> InstEnv.InstEnvs+                       -> InstEnvs                        -> MatchingType                        -> ClsInst                        -> CorePluginM (Maybe (ClsInst, CoreBind))@@ -875,7 +833,7 @@               newDFunId = mkExportedLocalId                 (DFunId isNewType) newN t           return $ Just-            ( InstEnv.mkLocalInstance+            ( mkLocalInstance                           newDFunId                           ( deriveAllMode da $ mappend mtOverlapMode baseOM )                           newTyVars iClass newTyPams@@ -888,18 +846,18 @@               $ foldMap (First . flip (recMatchTyKi True) mtBaseType) iTyPams           , not $ isEmptyTCvSubst sub             -> do-            pluginDebug $ hang "Could not find an instance, trying again:" 2 $-              vcat $ [ text "Base type:" <+> ppr mtBaseType-                     , text "Instance:" <+> ppr baseInst-                     , text "Substitution:" <+> ppr sub-                    ]+            pluginDebug $ hang "Could not find an instance, trying again:" 2 $ vcat+              [ text "Base type:" <+> ppr mtBaseType+              , text "Instance:" <+> ppr baseInst+              , text "Substitution:" <+> ppr sub+              ]             lookupMatchingInstance da ie (substMatchingType sub mt) baseInst           | otherwise             -> do-            pluginDebug $ hang "Ignored instance" 2 $-              vcat $ [ text "Base type:" <+> ppr mtBaseType-                     , text "Instance:" <+> ppr baseInst-                     ]+            pluginDebug $ hang "Ignored instance" 2 $ vcat+              [ text "Base type:" <+> ppr mtBaseType+              , text "Instance:" <+> ppr baseInst+              ]             pure Nothing   | otherwise     = pure Nothing@@ -907,8 +865,8 @@     deriveAllMode (DeriveAll' m _) _ = toOverlapFlag m     deriveAllMode  _               m = toOverlapFlag m     baseOM = instanceOverlapMode baseInst-    baseDFunId = InstEnv.instanceDFunId baseInst-    (_, _, iClass, iTyPams) = InstEnv.instanceSig baseInst+    baseDFunId = instanceDFunId baseInst+    (_, _, iClass, iTyPams) = instanceSig baseInst     isNewType = isNewTyCon (classTyCon iClass)     baseDFunName = occName . idName $ baseDFunId     newtypeNameS = case tyConAppTyCon_maybe mtNewType of@@ -919,10 +877,6 @@ -- checks if none of the names in the type satisfy the predicate noneTy :: (Name -> Bool) -> Type -> Bool noneTy f = not . uniqSetAny f . orphNamesOfType-#if __GLASGOW_HASKELL__ < 802-  where-    uniqSetAny g = foldl (\a -> (||) a . g) False-#endif  unwantedName :: DeriveAll -> Name -> Bool unwantedName da n@@ -940,3 +894,66 @@   where     modName = moduleNameString . moduleName $ nameModule n     valName = occNameString $ getOccName n++-- | Replace all occurrences of one type in another.+replaceTypeOccurrences :: Type -> Type -> Type -> Type+replaceTypeOccurrences told tnew = replace+  where+    replace :: Type -> Type+    replace t+        -- found occurrence+      | eqType t told+        = tnew+        -- split arrow types+      | Just (vis, mu, at, rt) <- splitFunTyCompat t+        = mkFunTyCompat vis mu (replace at) (replace rt)+        -- split type constructors+      | Just (tyCon, tys) <- splitTyConApp_maybe t+        = mkTyConApp tyCon $ map replace tys+        -- split foralls+      | (bndrs@(_:_), t') <- splitForAllTys t+        = mkSpecForAllTys bndrs $ replace t'+        -- could not find anything+      | otherwise+        = t+++-- Made this similar to tcRnGetInfo+--   and a hidden function lookupInsts used there+lookupClsInsts :: InstEnvs -> TyCon -> [ClsInst]+lookupClsInsts ie tc =+  [ ispec        -- Search all+  | ispec <- instEnvElts (ie_local  ie)+          ++ instEnvElts (ie_global ie)+  , instIsVisible (ie_visible ie) ispec+  , tyConName tc `elemNameSet` orphNamesOfClsInst ispec+  ]++-- | Similar to Unify.tcMatchTyKis, but looks if there is a non-trivial subtype+--   in the first type that matches the second.+--   Non-trivial means not a TyVar.+recMatchTyKi :: Bool -- ^ Whether to do inverse match (instance is more conrete)+             -> Type -> Type -> Maybe TCvSubst+recMatchTyKi inverse tsearched ttemp = go tsearched+  where+    go :: Type -> Maybe TCvSubst+    go t+        -- ignore plain TyVars+      | isTyVarTy t+        = Nothing+        -- found a good substitution+      | Just sub <- if inverse+                    then tcMatchTyKi ttemp t+                    else tcMatchTyKi t ttemp+        = Just sub+        -- split type constructors+      | Just (_, tys) <- splitTyConApp_maybe t+        = getFirst $ foldMap (First . go) tys+        -- split foralls+      | (_:_, t') <- splitForAllTys t+        = go t'+        -- split arrow types+      | Just (_, _, at, rt) <- splitFunTyCompat t+        = go at <|> go rt+      | otherwise+        = Nothing

@@ -0,0 +1,48 @@+{-# LANGUAGE CPP #-}+module Data.Constraint.Deriving.Import (module Reexport) where++#if __GLASGOW_HASKELL__ >= 900+import GHC.Core.Class            as Reexport (Class, classTyCon)+import GHC.Core.Coercion.Axiom   as Reexport+import GHC.Core.FamInstEnv       as Reexport+import GHC.Core.InstEnv          as Reexport hiding (OverlapMode (..))+import GHC.Core.Predicate        as Reexport+import GHC.Core.Unify            as Reexport+import GHC.Driver.Finder         as Reexport+import GHC.Iface.Env             as Reexport+import GHC.Iface.Load            as Reexport+import GHC.Plugins               as Reexport hiding (OverlapMode (..), UniqFM, empty, varName)+import GHC.Tc.Utils.Monad        as Reexport (TcM, getEps, initTc)+import GHC.Tc.Utils.TcType       as Reexport (tcSplitDFunTy)+import GHC.Types.Avail           as Reexport (AvailInfo (..), availName, filterAvails)+import GHC.Types.Name.Occurrence as Reexport (varName)+import GHC.Utils.Error           as Reexport (Severity (..), pprErrMsgBagWithLoc)+import GHC.Utils.Monad           as Reexport (MonadIO (..))+import GHC.Utils.Panic           as Reexport (panicDoc)+#else+import Avail      as Reexport+import Class      as Reexport (Class, classTyCon)+import CoAxiom    as Reexport+import ErrUtils   as Reexport (Severity (..), pprErrMsgBagWithLoc)+import FamInstEnv as Reexport+import Finder     as Reexport (findImportedModule)+import GhcPlugins as Reexport hiding (OverlapMode (..), empty, varName)+import IfaceEnv   as Reexport+import InstEnv    as Reexport hiding (OverlapMode (..))+import LoadIface  as Reexport (loadModuleInterface, loadModuleInterfaces)+import MonadUtils as Reexport (MonadIO (..))+import Name       as Reexport (varName)+import Panic      as Reexport (panicDoc)+import TcRnMonad  as Reexport (getEps, initTc)+import TcRnTypes  as Reexport (TcM)+import TcType     as Reexport (tcSplitDFunTy)+import Unify      as Reexport+#if __GLASGOW_HASKELL__ >= 810+import Predicate as Reexport+#endif+#if __GLASGOW_HASKELL__ < 802+import GHC.Stack as Reexport (HasCallStack)+#endif+#endif++import Data.Constraint.Deriving.Compat as Reexport

@@ -0,0 +1,82 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DeriveDataTypeable  #-}+module Data.Constraint.Deriving.OverlapMode+  ( OverlapMode (..)+  , toOverlapFlag, instanceOverlapMode+  ) where++import           Data.Data           (Data)+import           Data.Semigroup      as Sem (Semigroup (..))+import           Data.Monoid         as Mon (Monoid (..))++#if __GLASGOW_HASKELL__ >= 900+import qualified GHC.Types.Basic as BasicTypes+import qualified GHC.Core.InstEnv as InstEnv+#else+import qualified BasicTypes+import qualified InstEnv+#endif++-- | Define the behavior for the instance selection.+--   Mirrors `BasicTypes.OverlapMode`, but does not have a `SourceText` field.+data OverlapMode+  = NoOverlap+    -- ^ This instance must not overlap another `NoOverlap` instance.+    --   However, it may be overlapped by `Overlapping` instances,+    --   and it may overlap `Overlappable` instances.+  | Overlappable+    -- ^ Silently ignore this instance if you find a+    --   more specific one that matches the constraint+    --   you are trying to resolve+  | Overlapping+    -- ^ Silently ignore any more general instances that may be+    --   used to solve the constraint.+  | Overlaps+    -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags.+  | Incoherent+    -- ^ Behave like Overlappable and Overlapping, and in addition pick+    --   an an arbitrary one if there are multiple matching candidates, and+    --   don't worry about later instantiation+  deriving (Eq, Show, Read, Data)++instance Sem.Semigroup OverlapMode where+    NoOverlap <> m = m+    m <> NoOverlap = m+    Incoherent <> _ = Incoherent+    _ <> Incoherent = Incoherent+    Overlaps <> _   = Overlaps+    _ <> Overlaps   = Overlaps+    Overlappable <> Overlappable = Overlappable+    Overlapping  <> Overlapping  = Overlapping+    Overlappable <> Overlapping  = Overlaps+    Overlapping  <> Overlappable = Overlaps++instance Mon.Monoid OverlapMode where+    mempty = NoOverlap+#if !(MIN_VERSION_base(4,11,0))+    mappend = (<>)+#endif+++toOverlapFlag :: OverlapMode -> BasicTypes.OverlapFlag+toOverlapFlag m = BasicTypes.OverlapFlag (getOMode m) False+  where+    getOMode NoOverlap    = BasicTypes.NoOverlap noSourceText+    getOMode Overlapping  = BasicTypes.Overlapping noSourceText+    getOMode Overlappable = BasicTypes.Overlappable noSourceText+    getOMode Overlaps     = BasicTypes.Overlaps noSourceText+    getOMode Incoherent   = BasicTypes.Incoherent noSourceText++#if __GLASGOW_HASKELL__ >= 802+    noSourceText = BasicTypes.NoSourceText+#else+    noSourceText = "[plugin-generated code]"+#endif++instanceOverlapMode :: InstEnv.ClsInst -> OverlapMode+instanceOverlapMode i = case BasicTypes.overlapMode (InstEnv.is_flag i) of+    BasicTypes.NoOverlap {}    -> NoOverlap+    BasicTypes.Overlapping {}  -> Overlapping+    BasicTypes.Overlappable {} -> Overlappable+    BasicTypes.Overlaps {}     -> Overlaps+    BasicTypes.Incoherent {}   -> Incoherent

@@ -8,19 +8,15 @@   , CorePluginEnvRef, initCorePluginEnv   ) where -import           Class               (Class, classTyCon)-import           Control.Applicative (Alternative (..))-import           Control.Monad       (join, unless)-import           Data.Data           (Data)-import           Data.Maybe          (fromMaybe, isJust)-import           Data.Monoid         (First (..))-import           GhcPlugins          hiding (OverlapMode (..), overlapMode)-import qualified InstEnv-import qualified OccName-import           Panic               (panicDoc)-import qualified Unify+import Control.Applicative (Alternative (..))+import Control.Monad       (join, unless)+import Data.Data           (Data)+import Data.Maybe          (fromMaybe, isJust)+import Data.Monoid         (First (..))  import Data.Constraint.Deriving.CorePluginM+import Data.Constraint.Deriving.Import+import Data.Constraint.Deriving.OverlapMode   {- | A marker to tell the core plugin to convert a top-level `Data.Constraint.Dict` binding into@@ -70,10 +66,10 @@ toInstancePass' :: ModGuts -> CorePluginM ModGuts toInstancePass' gs = go (reverse $ mg_binds gs) annotateds gs   where-    annotateds :: UniqFM [(Name, ToInstance)]+    annotateds :: UniqMap [(Name, ToInstance)]     annotateds = getModuleAnns gs -    go :: [CoreBind] -> UniqFM [(Name, ToInstance)] -> ModGuts -> CorePluginM ModGuts+    go :: [CoreBind] -> UniqMap [(Name, ToInstance)] -> ModGuts -> CorePluginM ModGuts     -- All exports are processed, just return ModGuts     go [] anns guts = do       unless (isNullUFM anns) $@@ -93,7 +89,7 @@      -- process type definitions present in the set of annotations     go (cbx@(NonRec x _):xs) anns guts-      | Just ((xn, ti):ds) <- lookupUFM anns x = do+      | Just ((xn, ti):ds) <- lookupUFM anns (getUnique x) = do       unless (null ds) $         pluginLocatedWarning (nameSrcSpan xn) $           "Ignoring redundant ToInstance annotations" $$@@ -105,9 +101,9 @@       -- add new definitions and continue       try (toInstance ti cbx) >>= \case         Nothing-          -> go xs (delFromUFM anns x) guts+          -> go xs (delFromUFM anns (getUnique x)) guts         Just (newInstance, newBind)-          -> go xs (delFromUFM anns x)+          -> go xs (delFromUFM anns (getUnique x))               (replaceInstance newInstance newBind guts)                 { -- Remove original binding from the export list                   --                                if it was there.@@ -126,7 +122,7 @@ --   The input core bind must have type `Ctx => Dict (Class t1 .. tn)` -- --   The output is `instance {-# overlapMode #-} Ctx => Class t1 ... tn`-toInstance :: ToInstance -> CoreBind -> CorePluginM (InstEnv.ClsInst, CoreBind)+toInstance :: ToInstance -> CoreBind -> CorePluginM (ClsInst, CoreBind)  toInstance _ (Rec xs) = do     loc <- liftCoreM getSrcSpanM@@ -137,7 +133,7 @@  toInstance (ToInstance omode) (NonRec bindVar bindExpr) = do     -- check if all type arguments are constraint arguments-    unless (all (isConstraintKind . typeKind) theta) $+    unless (all (tcIsConstraintKind . typeKind) theta) $       pluginLocatedError loc notGoodMsg      -- get necessary definitions@@ -148,12 +144,12 @@     let tyMatcher = mkTyConApp tcDict [mkTyVarTy varCls]      -- Get instance definition-    match <- case Unify.tcMatchTy tyMatcher dictTy of+    match <- case tcMatchTy tyMatcher dictTy of       Nothing -> pluginLocatedError loc notGoodMsg       Just ma -> pure ma     let matchedTy = substTyVar match varCls-        instSig = mkSpecForAllTys bndrs $ mkInvisFunTys theta matchedTy-        bindBareTy = mkSpecForAllTys bndrs $ mkInvisFunTys theta $ mkTyConApp tcBareConstraint [matchedTy]+        instSig = mkSpecForAllTys bndrs $ mkInvisFunTysMany theta matchedTy+        bindBareTy = mkSpecForAllTys bndrs $ mkInvisFunTysMany theta $ mkTyConApp tcBareConstraint [matchedTy]      -- check if constraint is indeed a class and get it     matchedClass <- case tyConAppTyCon_maybe matchedTy >>= tyConClass_maybe of@@ -165,7 +161,7 @@     newExpr  <- case mnewExpr of       Nothing -> pluginLocatedError loc notGoodMsg       Just ex -> pure $ mkCast ex-                      $ mkUnsafeCo Representational bindBareTy instSig+                      $ mkPluginCo "(BareConstraint c ~ c)" Representational bindBareTy instSig       mkNewInstance omode matchedClass bindVar newExpr@@ -173,7 +169,7 @@   where     origBindTy = idType bindVar     (bndrs, bindTy) = splitForAllTys origBindTy-    (theta, dictTy) = splitFunTys bindTy+    (theta, dictTy) = splitFunTysCompat bindTy     loc = nameSrcSpan $ getName bindVar     notGoodMsg =          "ToInstance plugin pass failed to process a Dict declaraion."@@ -200,15 +196,15 @@               -> Class               -> Id -- ^ Original core binding (with old type)               -> CoreExpr -- ^ implementation, with a proper new type (instance signature)-              -> CorePluginM (InstEnv.ClsInst, CoreBind)+              -> CorePluginM (ClsInst, CoreBind) mkNewInstance omode cls bindVar bindExpr = do-    n <- newName OccName.varName+    n <- newName varName        $ getOccString bindVar ++ "_ToInstance"     let iDFunId = mkExportedLocalId           (DFunId $ isNewTyCon (classTyCon cls))           n itype     return-      ( InstEnv.mkLocalInstance iDFunId ioflag tvs cls tys+      ( mkLocalInstance iDFunId ioflag tvs cls tys       , NonRec iDFunId bindExpr       )   where@@ -216,7 +212,7 @@     itype   = exprType bindExpr      (tvs, itype') = splitForAllTys itype-    (_, typeBody) = splitFunTys itype'+    (_, typeBody) = splitFunTysCompat itype'     tys = fromMaybe aAaaOmg $ tyConAppArgs_maybe typeBody     aAaaOmg = panicDoc "ToInstance" $ hsep       [ "Impossible happened:"@@ -259,7 +255,7 @@     wrap e = flip fmap (getClsT e) $ \t -> Var unwrapFun `App` t `App` e     -- type variables may differ, so I need to use tcMatchTy.     -- I do not check if resulting substition is not trivial. Shall I?-    testType = isJust . Unify.tcMatchTy dictT . exprType+    testType = isJust . tcMatchTy dictT . exprType     getClsT e = case tyConAppArgs_maybe $ exprType e of       Just [t] -> pure $ Type t       _        -> unwrapFail@@ -267,7 +263,7 @@     mkLamApp =       let et0          = exprType ex           (bndrs, et1) = splitForAllTys et0-          (theta, _  ) = splitFunTys et1+          (theta, _  ) = splitFunTysCompat et1       in  if null bndrs && null theta             then unwrapFail             else do@@ -276,3 +272,42 @@                   allApps      = map (Type . mkTyVarTy) bndrs ++ map Var thetaVars                   fullyApplied = foldl App ex allApps               return $ foldr Lam fullyApplied allVars+++-- | Replace instance in ModGuts if its duplicate already exists there;+--   otherwise just add this instance.+replaceInstance :: ClsInst -> CoreBind -> ModGuts -> ModGuts+replaceInstance newI newB guts+  | NonRec _ newE <- newB+  , First (Just oldI) <- foldMap sameInst $ mg_insts guts+  , newDFunId <- instanceDFunId newI+  , origDFunId <- instanceDFunId oldI+  , dFunId <- newDFunId `setVarName`   idName origDFunId+                        `setVarUnique` varUnique origDFunId+  , bind   <- NonRec dFunId newE+  , inst   <- setClsInstDfunId dFunId newI+    = guts+      { mg_insts    = replInst origDFunId inst $ mg_insts guts+      , mg_inst_env = mg_inst_env guts+           `deleteFromInstEnv` oldI+           `extendInstEnv` inst+      , mg_binds    = bind : remBind origDFunId (mg_binds guts)+      }+  | otherwise+    = guts+      { mg_insts    = newI : mg_insts guts+      , mg_inst_env = extendInstEnv (mg_inst_env guts) newI+      , mg_binds    = newB : mg_binds guts+      }+  where+    remBind _ [] = []+    remBind i' (b@(NonRec i _):bs)+      | i == i'   = remBind i' bs+      | otherwise = b  : remBind i' bs+    remBind i' (Rec rb :bs) = Rec (filter ((i' /=) . fst) rb) : remBind i' bs+    replInst _ _ [] = []+    replInst d' i' (i:is)+      | instanceDFunId i == d'   = i' : is+      | otherwise = i : replInst d' i' is+    sameInst i+      = First $ if identicalClsInstHead newI i then Just i else Nothing

@@ -13,25 +13,46 @@ import           Data.Maybe            (mapMaybe) import           Data.Monoid import           Data.Traversable      (for)-import           DynFlags-import           ErrUtils              (mkLocMessageAnn) import           GHC import           GHC.IO.Handle import           GHC.Paths             (libdir)-import           MonadUtils            (liftIO)-import           Name                  (getOccString)-import           Outputable import           Path import           Path.IO import           System.Exit import           System.FilePath       (isPathSeparator) import           System.IO+#if __GLASGOW_HASKELL__ >= 900+import           GHC.Driver.Session    ( LogAction, gopt_set, gopt_unset, defaultFatalMessager+                                       , defaultFlushOut, defaultLogActionHPrintDoc+                                       , defaultLogActionHPutStrDoc)+import           GHC.Utils.Error       (mkLocMessageAnn)+import           GHC.Utils.Monad       (liftIO)+import           GHC.Types.Name        (getOccString)+import           GHC.Utils.Outputable+#else+import           DynFlags              ( LogAction, gopt_set, gopt_unset, defaultFatalMessager+                                       , defaultFlushOut, defaultLogActionHPrintDoc+                                       , defaultLogActionHPutStrDoc)+import           ErrUtils              (mkLocMessageAnn)+import           MonadUtils            (liftIO)+import           Name                  (getOccString)+import           Outputable+#endif -#if !MIN_VERSION_path(0,7,0)-replaceExtension :: String -> Path b File -> Maybe (Path b File)-replaceExtension = setFileExtension+replaceExt :: String -> Path b File -> Maybe (Path b File)+#if MIN_VERSION_path(0,7,0)+replaceExt = replaceExtension+#else+replaceExt = setFileExtension #endif +removeExt :: Path b File -> Maybe (Path b File)+#if MIN_VERSION_path(0,7,0)+removeExt = fmap fst . splitExtension+#else+removeExt = setFileExtension ""+#endif+ -- | Folder with test modules to be compiled specDir :: Path Rel Dir specDir = [reldir|test/Spec/|]@@ -41,10 +62,10 @@ outDir = [reldir|test/out/|]  correspondingStdOut :: Path a File -> Maybe (Path Rel File)-correspondingStdOut f = replaceExtension "stdout" $ outDir </> filename f+correspondingStdOut f = replaceExt ".stdout" $ outDir </> filename f  correspondingStdErr :: Path a File -> Maybe (Path Rel File)-correspondingStdErr f = replaceExtension "stderr" $ outDir </> filename f+correspondingStdErr f = replaceExt ".stderr" $ outDir </> filename f  data TargetPaths = TargetPaths   { targetName :: String@@ -62,7 +83,7 @@ #endif   guard $ ext == ".hs"   targetPath <- Just $ toFilePath p-  targetName <- toFilePath <$> replaceExtension "" (filename p)+  targetName <- toFilePath <$> removeExt (filename p)   stdoutPath <- toFilePath <$> correspondingStdOut p   stderrPath <- toFilePath <$> correspondingStdErr p   return TargetPaths {..}@@ -105,10 +126,8 @@               modSystemIO <- parseImportDecl "import System.IO (hFlush, stderr, stdout)"               modSumTarget <- getModSummary $ mkModuleName $ "Spec." ++ targetName               setContext [IIDecl modSystemIO, IIModule $ moduleName  $ ms_mod modSumTarget]-              mainIsInScope-                <- not . null . filter (("main" ==) . getOccString)-                   <$> getNamesInScope-              when (mainIsInScope) $ do+              mainIsInScope <- any (("main" ==) . getOccString) <$> getNamesInScope+              when mainIsInScope $ do                 liftIO $ do                   hDuplicateTo outH stdout                   hDuplicateTo errH stderr@@ -223,7 +242,7 @@   , hscTarget   = HscInterpreted   , verbosity   = 1   , optLevel    = 0-  , ways        = []+  , ways        = mempty   , useUnicode  = False   } `gopt_set` Opt_DoCoreLinting     `gopt_set` Opt_ForceRecomp@@ -248,25 +267,36 @@ -- --   These all is to make testing output easy across different GHC versions. manualLogAction :: Handle -> Handle -> LogAction-manualLogAction outH errH dflags _reason severity srcSpan style msg+manualLogAction outH errH dflags _reason severity srcSpan+#if __GLASGOW_HASKELL__ < 900+  style+#endif+  msg     = case severity of-      SevOutput      -> printOut msg style-      SevDump        -> printOut (msg $$ blankLine) style-      SevInteractive -> putStrSDoc msg style-      SevInfo        -> printErrs msg style-      SevFatal       -> printErrs msg style+      SevOutput      -> printOut msg+      SevDump        -> printOut (msg $$ blankLine)+      SevInteractive -> putStrSDoc msg+      SevInfo        -> printErrs msg+      SevFatal       -> printErrs msg       SevWarning     -> printWarns       SevError       -> printWarns   where+    message = mkLocMessageAnn Nothing severity srcSpan msg+#if __GLASGOW_HASKELL__ >= 900     printOut   = defaultLogActionHPrintDoc  dflags outH     printErrs  = defaultLogActionHPrintDoc  dflags errH     putStrSDoc = defaultLogActionHPutStrDoc dflags outH-    message = mkLocMessageAnn Nothing severity srcSpan msg+    printWarns = hPutChar errH '\n' >> printErrs message+#else+    printOut   m = defaultLogActionHPrintDoc  dflags outH m style+    printErrs  m = defaultLogActionHPrintDoc  dflags errH m style+    putStrSDoc m = defaultLogActionHPutStrDoc dflags outH m style     printWarns = do       hPutChar errH '\n'-      printErrs message+      defaultLogActionHPrintDoc dflags errH message #if __GLASGOW_HASKELL__ >= 802         (setStyleColoured False style) #else         style+#endif #endif