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: 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 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 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 @@ -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 diff --git a/src/Data/Constraint/Deriving/DeriveAll.hs b/src/Data/Constraint/Deriving/DeriveAll.hs --- a/src/Data/Constraint/Deriving/DeriveAll.hs +++ b/src/Data/Constraint/Deriving/DeriveAll.hs @@ -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) diff --git a/test/Spec/ToInstance02.hs b/test/Spec/ToInstance02.hs --- a/test/Spec/ToInstance02.hs +++ b/test/Spec/ToInstance02.hs @@ -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)