constraints-deriving 1.0.1.2 → 1.0.2.0
raw patch · 5 files changed
+67/−16 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- README.md +7/−0
- constraints-deriving.cabal +3/−3
- src/Data/Constraint/Deriving.hs +1/−1
- src/Data/Constraint/Deriving/CorePluginM.hs +47/−1
- src/Data/Constraint/Deriving/ToInstance.hs +9/−11
README.md view
@@ -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).
constraints-deriving.cabal view
@@ -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 <https://github.com/achirkin/constraints-deriving#readme> 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
src/Data/Constraint/Deriving.hs view
@@ -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
src/Data/Constraint/Deriving/CorePluginM.hs view
@@ -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+
src/Data/Constraint/Deriving/ToInstance.hs view
@@ -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]