diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -94,6 +94,13 @@ You can find a more meaningful example in [`test/Spec/ToInstance01.hs`](https://github.com/achirkin/constraints-deriving/blob/master/test/Spec/ToInstance01.hs#L45-L47) or [`example/Lib/VecBackend.hs`](https://github.com/achirkin/constraints-deriving/blob/master/example/Lib/VecBackend.hs). +**Danger**: `ToInstance` removes duplicate instances; +if you have defined an instance with the same head using vanilla Haskell and the plugin, +the latter will try to replace the former in place. +Behavior of the instance in the same module is undefined in this case +(the other modules should be fine seeing the plugin version). +*I used this trick to convince `.hs-boot` to see the instances generated by the plugin.* + ## Further work `DeriveAll` derivation mechanics currently may break functional dependencies (untested). diff --git a/constraints-deriving.cabal b/constraints-deriving.cabal --- a/constraints-deriving.cabal +++ b/constraints-deriving.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 30a4b9fddcbefe3a1c3195cfe57101f769caf42b02a24fd4b87b429fd4e68c71 +-- hash: 48cc1543c057350d23f16b7333dcd83d11d54ae3dfb991b5f6809165c5f33613 name: constraints-deriving -version: 1.0.1.2 +version: 1.0.2.0 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 category: Constraints @@ -61,7 +61,7 @@ default: False flag debug - description: Show debug trace info (used only for library development) + description: Show debug trace info (used only for library development). Note, if you want to see the debug output of the plugin in another project, you may need to manually define a CPP option -DPLUGIN_DEBUG in that project. manual: True default: False diff --git a/src/Data/Constraint/Deriving.hs b/src/Data/Constraint/Deriving.hs --- a/src/Data/Constraint/Deriving.hs +++ b/src/Data/Constraint/Deriving.hs @@ -13,7 +13,7 @@ import Data.List (sortOn) import GhcPlugins hiding (OverlapMode (..), overlapMode) -import InstEnv (is_tys, is_cls) +import InstEnv (is_cls, is_tys) import Type (tyConAppTyCon_maybe) import Data.Constraint.Deriving.DeriveAll diff --git a/src/Data/Constraint/Deriving/CorePluginM.hs b/src/Data/Constraint/Deriving/CorePluginM.hs --- a/src/Data/Constraint/Deriving/CorePluginM.hs +++ b/src/Data/Constraint/Deriving/CorePluginM.hs @@ -25,7 +25,7 @@ , filterAvails , recMatchTyKi, replaceTypeOccurrences , OverlapMode (..), toOverlapFlag, instanceOverlapMode - , lookupClsInsts, getInstEnvs + , lookupClsInsts, getInstEnvs, replaceInstance -- * Debugging , pluginDebug, pluginTrace , HasCallStack @@ -574,6 +574,52 @@ -- 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 + diff --git a/src/Data/Constraint/Deriving/ToInstance.hs b/src/Data/Constraint/Deriving/ToInstance.hs --- a/src/Data/Constraint/Deriving/ToInstance.hs +++ b/src/Data/Constraint/Deriving/ToInstance.hs @@ -68,7 +68,7 @@ (\x -> fromMaybe x <$> runCorePluginM (toInstancePass' x) eref) toInstancePass' :: ModGuts -> CorePluginM ModGuts -toInstancePass' gs = go (reverse $ mg_binds gs) annotateds gs { mg_binds = []} +toInstancePass' gs = go (reverse $ mg_binds gs) annotateds gs where annotateds :: UniqFM [(Name, ToInstance)] annotateds = getModuleAnns gs @@ -105,19 +105,17 @@ -- add new definitions and continue try (toInstance ti cbx) >>= \case Nothing - -> go xs (delFromUFM anns x) guts { mg_binds = cbx : mg_binds guts} - Just (newInstance, newBind) -> go xs (delFromUFM anns x) guts - { mg_insts = newInstance : mg_insts guts - , mg_inst_env = InstEnv.extendInstEnv (mg_inst_env guts) newInstance - , mg_binds = cbx : newBind : mg_binds guts - -- Remove original binding from the export list - -- if it was there. - , mg_exports = filterAvails (xn /=) $ mg_exports guts - } + Just (newInstance, newBind) + -> go xs (delFromUFM anns x) + (replaceInstance newInstance newBind guts) + { -- Remove original binding from the export list + -- if it was there. + mg_exports = filterAvails (xn /=) $ mg_exports guts + } -- ignore the rest of bindings - go (x:xs) anns guts = go xs anns guts { mg_binds = x : mg_binds guts} + go (_:xs) anns guts = go xs anns guts pprBulletNameLoc n = hsep [" " , bullet, ppr $ occName n, ppr $ nameSrcSpan n]