constraints-deriving 1.0.1.1 → 1.0.1.2
raw patch · 4 files changed
+79/−40 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- constraints-deriving.cabal +3/−3
- src/Data/Constraint/Deriving/CorePluginM.hs +35/−7
- src/Data/Constraint/Deriving/DeriveAll.hs +38/−27
- test/Spec/ToInstance02.hs +3/−3
constraints-deriving.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 0f67a2b1a43466e740a84b0fde7084941d45d3945d82810684880fcb86c15139+-- hash: 30a4b9fddcbefe3a1c3195cfe57101f769caf42b02a24fd4b87b429fd4e68c71 name: constraints-deriving-version: 1.0.1.1+version: 1.0.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@@ -61,7 +61,7 @@ default: False flag debug- description: Show debug trace info (used only for library develpoment)+ description: Show debug trace info (used only for library development) manual: True default: False
src/Data/Constraint/Deriving/CorePluginM.hs view
@@ -24,7 +24,7 @@ , bullet, isConstraintKind, getModuleAnns , filterAvails , recMatchTyKi, replaceTypeOccurrences- , OverlapMode (..), toOverlapFlag+ , OverlapMode (..), toOverlapFlag, instanceOverlapMode , lookupClsInsts, getInstEnvs -- * Debugging , pluginDebug, pluginTrace@@ -38,8 +38,9 @@ import Data.Data (Data, typeRep) import Data.IORef (IORef, modifyIORef', newIORef, readIORef) import Data.Maybe (catMaybes)-import Data.Monoid (First (..))+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,@@ -518,11 +519,12 @@ --- | Similar to Unify.tcMatchTyKis, but looks if there is non-trivial subtype+-- | 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 :: Type -> Type -> Maybe TCvSubst-recMatchTyKi tsearched ttemp = go tsearched+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@@ -530,7 +532,9 @@ | isTyVarTy t = Nothing -- found a good substitution- | Just sub <- matchIt t ttemp+ | Just sub <- if inverse+ then matchIt ttemp t+ else matchIt t ttemp = Just sub -- split type constructors | Just (_, tys) <- splitTyConApp_maybe t@@ -595,7 +599,25 @@ -- 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@@ -611,7 +633,13 @@ 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
src/Data/Constraint/Deriving/DeriveAll.hs view
@@ -24,9 +24,9 @@ import Data.Data (Data) import Data.Either (partitionEithers) import qualified Data.Kind (Constraint, Type)-import Data.List (groupBy, isPrefixOf, sortOn)+import Data.List (groupBy, isPrefixOf, nubBy, sortOn) import Data.Maybe (catMaybes, fromMaybe)-import Data.Monoid (First (..))+import Data.Monoid (First (..), Monoid (..)) import qualified FamInstEnv import GhcPlugins hiding (OverlapMode (..), overlapMode, (<>))@@ -63,7 +63,7 @@ -- | Run `DeriveAll` plugin pass deriveAllPass :: CorePluginEnvRef -> CoreToDo deriveAllPass eref = CoreDoPluginPass "Data.Constraint.Deriving.DeriveAll"- -- if a plugin pass totally fails to do anything useful,+ -- if a plugin pass totally fails to do anything useful, -- copy original ModGuts as its output, so that next passes can do their jobs. (\x -> fromMaybe x <$> runCorePluginM (deriveAllPass' x) eref) @@ -173,7 +173,7 @@ pluginDebug . hang "DeriveAll (3): matching class instances:" 2 . vcat $ map (ppr . fst) r- return r+ return $ filterDupInsts r -- not a good newtype declaration | otherwise@@ -182,6 +182,8 @@ "DeriveAll works only on plain newtype declarations" where+ -- O(n^2) search for duplicates. Slow, but what else can I do?..+ filterDupInsts = nubBy $ \(x,_) (y, _) -> InstEnv.identicalClsInstHead x y mockInstance tc = do let tvs = tyConTyVars tc tys = mkTyVarTys tvs@@ -684,7 +686,7 @@ -> Maybe MatchingInstance findInstance ie t i | -- Most important: some part of the instance parameters must unify to arg- Just sub <- getFirst $ foldMap (First . flip recMatchTyKi t) iTyPams+ Just sub <- getFirst $ foldMap (First . flip (recMatchTyKi False) t) iTyPams -- substituted type parameters of the class , newTyPams <- map (substTyAddInScope sub) iTyPams -- This tells us how instance tyvars change after matching the type@@ -762,7 +764,7 @@ -- | Construct a core expression and a corresponding type. -- It does not bind arguments;--- uses only types and vars present in MatchinInstance;+-- uses only types and vars present in MatchingInstance; -- may create a few vars for PredTypes, they are returned in fst. miToExpression' :: [TyExp] -- ^ types and expressions of the PredTypes that are in scope@@ -857,29 +859,38 @@ lookupMatchingInstance da ie mt@MatchingType {..} baseInst | not . unwantedName da $ getName iClass , all (noneTy (unwantedName DeriveAll)) iTyPams- , Just mi <- findInstance ie mtBaseType baseInst- = do- (t, e) <- mtmiToExpression mt mi- newN <- newName (occNameSpace baseDFunName)- $ occNameString baseDFunName- ++ show (getUnique baseDFunId) -- unique per baseDFunId- ++ newtypeNameS -- unique per newType- let (newTyVars, _, _, newTyPams) = tcSplitDFunTy t- newDFunId = mkExportedLocalId- (DFunId isNewType) newN t- return $ Just- ( InstEnv.mkLocalInstance- newDFunId- (toOverlapFlag mtOverlapMode)- newTyVars iClass newTyPams- , NonRec newDFunId e- )+ = case findInstance ie mtBaseType baseInst of+ Just mi -> do+ (t, e) <- mtmiToExpression mt mi+ newN <- newName (occNameSpace baseDFunName)+ $ occNameString baseDFunName+ ++ show (getUnique baseDFunId) -- unique per baseDFunId+ ++ newtypeNameS -- unique per newType+ let (newTyVars, _, _, newTyPams) = tcSplitDFunTy t+ newDFunId = mkExportedLocalId+ (DFunId isNewType) newN t+ return $ Just+ ( InstEnv.mkLocalInstance+ newDFunId+ ( toOverlapFlag $ mappend mtOverlapMode baseOM )+ newTyVars iClass newTyPams+ , NonRec newDFunId e+ )+ Nothing+ -- in case if the instance is more specific than the MatchingType,+ -- substitute types and try again+ | Just sub <- getFirst+ $ foldMap (First . flip (recMatchTyKi True) mtBaseType) iTyPams+ -> lookupMatchingInstance da ie (substMatchingType sub mt) baseInst+ | otherwise+ -> do+ pluginDebug $ hang "Ignored instance" 2+ $ ppr mtBaseType <+> ppr baseInst+ pure Nothing | otherwise- = do- pluginDebug $ hang "Ignored instance" 2- $ ppr mtBaseType <+> ppr baseInst- pure Nothing+ = pure Nothing where+ baseOM = instanceOverlapMode baseInst baseDFunId = InstEnv.instanceDFunId baseInst (_, _, iClass, iTyPams) = InstEnv.instanceSig baseInst isNewType = isNewTyCon (classTyCon iClass)
test/Spec/ToInstance02.hs view
@@ -12,9 +12,9 @@ ToInstance pass should be able to go through the vars and theta types and match the RHS of the arrow (deriveEqOrig signature). -}-import Data.Constraint-import Data.Constraint.Deriving-import Data.Constraint.Unsafe+import Data.Constraint+import Data.Constraint.Deriving+import Data.Constraint.Unsafe newtype Number t = Number (NumberFam t)