constraints-deriving 1.0.1.0 → 1.0.1.1
raw patch · 10 files changed
+159/−61 lines, 10 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- constraints-deriving.cabal +5/−2
- src/Data/Constraint/Deriving/CorePluginM.hs +58/−33
- src/Data/Constraint/Deriving/ToInstance.hs +33/−15
- test/Spec.hs +2/−2
- test/Spec/DeriveAll02.hs +2/−2
- test/Spec/DeriveAll03.hs +2/−2
- test/Spec/ToInstance01.hs +6/−5
- test/Spec/ToInstance02.hs +43/−0
- test/out/ToInstance02.stderr +7/−0
- test/out/ToInstance02.stdout +1/−0
constraints-deriving.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 6c8f5cef290d153bdcf309c40e67aad5a37963821df9a06e92c4a260a1c79adf+-- hash: 0f67a2b1a43466e740a84b0fde7084941d45d3945d82810684880fcb86c15139 name: constraints-deriving-version: 1.0.1.0+version: 1.0.1.1 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@@ -28,6 +28,7 @@ test/Spec/DeriveAll05.hs test/Spec/DeriveAll06.hs test/Spec/ToInstance01.hs+ test/Spec/ToInstance02.hs test/out/DeriveAll01.stderr test/out/DeriveAll02.stderr test/out/DeriveAll03.stderr@@ -35,6 +36,7 @@ test/out/DeriveAll05.stderr test/out/DeriveAll06.stderr test/out/ToInstance01.stderr+ test/out/ToInstance02.stderr test/out/DeriveAll01.stdout test/out/DeriveAll02.stdout test/out/DeriveAll03.stdout@@ -42,6 +44,7 @@ test/out/DeriveAll05.stdout test/out/DeriveAll06.stdout test/out/ToInstance01.stdout+ test/out/ToInstance02.stdout source-repository head type: git
src/Data/Constraint/Deriving/CorePluginM.hs view
@@ -20,7 +20,7 @@ , pluginWarning, pluginLocatedWarning , pluginError, pluginLocatedError -- * Tools- , newName, newTyVar, freshenTyVar+ , newName, newTyVar, freshenTyVar, newLocalVar , bullet, isConstraintKind, getModuleAnns , filterAvails , recMatchTyKi, replaceTypeOccurrences@@ -33,8 +33,8 @@ import qualified Avail import Class (Class)-import Control.Applicative ((<|>))-import Control.Monad (join)+import Control.Applicative (Alternative (..))+import Control.Monad (join, (>=>)) import Data.Data (Data, typeRep) import Data.IORef (IORef, modifyIORef', newIORef, readIORef) import Data.Maybe (catMaybes)@@ -42,14 +42,15 @@ import Data.Proxy (Proxy (..)) import qualified ErrUtils import qualified Finder-import GhcPlugins hiding (OverlapMode (..), overlapMode,- (<>))+import GhcPlugins hiding (OverlapMode (..), empty,+ overlapMode, (<>)) 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@@ -69,26 +70,38 @@ -- -- It provides two pieces of functionality: ----- * Possibility to fail a computation+-- * Possibility to fail a computation with IO error action -- (to show a nice error to a user and continue the work if possible); -- -- * An environment with things that computed on demand, once at most. -- newtype CorePluginM a = CorePluginM- { runCorePluginM :: IORef CorePluginEnv -> CoreM (Maybe a) }+ { _runCorePluginM :: IORef CorePluginEnv -> CoreM (Either (IO ()) a) } +runCorePluginM :: CorePluginM a -> IORef CorePluginEnv -> CoreM (Maybe a)+runCorePluginM m e = _runCorePluginM m e >>= \case+ Left er -> Nothing <$ liftIO er+ Right a -> pure $ Just a+ instance Functor CorePluginM where- fmap f m = CorePluginM $ fmap (fmap f) . runCorePluginM m+ fmap f m = CorePluginM $ fmap (fmap f) . _runCorePluginM m instance Applicative CorePluginM where- pure = CorePluginM . const . pure . Just- mf <*> ma = CorePluginM $ \e -> (<*>) <$> runCorePluginM mf e <*> runCorePluginM ma e+ pure = CorePluginM . const . pure . Right+ mf <*> ma = CorePluginM $ \e -> (<*>) <$> _runCorePluginM mf e <*> _runCorePluginM ma e +instance Alternative CorePluginM where+ empty = CorePluginM . const $ pure $ Left $ pure ()+ ma <|> mb = CorePluginM $ \e -> f <$> _runCorePluginM ma e <*> _runCorePluginM mb e+ where+ f (Left _) = id+ f rx = const rx+ instance Monad CorePluginM where return = pure- ma >>= k = CorePluginM $ \e -> runCorePluginM ma e >>= \case- Nothing -> pure Nothing- Just a -> runCorePluginM (k a) e+ ma >>= k = CorePluginM $ \e -> _runCorePluginM ma e >>= \case+ Left a -> pure (Left a)+ Right a -> _runCorePluginM (k a) e instance MonadIO CorePluginM where liftIO = liftCoreM . liftIO@@ -97,21 +110,28 @@ lookupThing = liftCoreM . lookupThing instance MonadUnique CorePluginM where- getUniqueSupplyM = CorePluginM $ const $ Just <$> getUniqueSupplyM+ getUniqueSupplyM = CorePluginM $ const $ Right <$> getUniqueSupplyM -- | Wrap CoreM action liftCoreM :: CoreM a -> CorePluginM a-liftCoreM = CorePluginM . const . fmap Just+liftCoreM = CorePluginM . const . fmap Right -- | Synonym for `fail` exception :: CorePluginM a-exception = CorePluginM $ const $ pure Nothing+exception = empty -- | Return `Nothing` if the computation fails try :: CorePluginM a -> CorePluginM (Maybe a)-try m = CorePluginM $ fmap Just . runCorePluginM m+try m = CorePluginM $ _runCorePluginM m >=> f+ where+ f (Left e) = Right Nothing <$ liftIO e+ f (Right a) = pure . Right $ Just a +-- | Try and ignore the result+try' :: CorePluginM a -> CorePluginM ()+try' m = () <$ try m+ -- | Reference to the plugin environment variables. type CorePluginEnvRef = IORef CorePluginEnv @@ -135,7 +155,7 @@ -- | Ask a field of the CorePluginEnv environment. ask :: (CorePluginEnv -> CorePluginM a) -> CorePluginM a-ask f = join $ CorePluginM $ liftIO . fmap (Just . f) . readIORef+ask f = join $ CorePluginM $ liftIO . fmap (Right . f) . readIORef -- | Init the `CorePluginM` environment and save it to IORef. initCorePluginEnv :: CoreM (IORef CorePluginEnv)@@ -144,7 +164,7 @@ -- need to force globalInstEnv as early as possible to make sure -- that ExternalPackageState var is not yet contaminated with -- many unrelated modules.- gie <- runCorePluginM (ask globalInstEnv) env+ gie <- _runCorePluginM (ask globalInstEnv) env seq gie $ return env @@ -254,9 +274,9 @@ } where saveAndReturn Nothing f = CorePluginM $ \eref ->- Nothing <$ liftIO (modifyIORef' eref $ f exception)+ Left (pure ()) <$ liftIO (modifyIORef' eref $ f exception) saveAndReturn (Just x) f = CorePluginM $ \eref ->- Just x <$ liftIO (modifyIORef' eref $ f (pure x))+ Right x <$ liftIO (modifyIORef' eref $ f (pure x)) maybeFound (Found _ m) = Just m maybeFound _ = Nothing lookupDep hsce (mpn, mn)@@ -374,7 +394,13 @@ "_" -> mkOccName (occNameSpace oc) ("fresh_" ++ s) _ -> on -+-- | Generate a new unique local var (not be exported!)+newLocalVar :: Type -> String -> CorePluginM Var+newLocalVar ty nameStr = do+ loc <- liftCoreM getSrcSpanM+ u <- getUniqueM+ return $+ mkLocalId (mkInternalName u (mkOccName OccName.varName nameStr) loc) ty -- | Generate new unique name newName :: NameSpace -> String -> CorePluginM Name@@ -388,27 +414,27 @@ pluginError :: SDoc -> CorePluginM a-pluginError msg- = pluginProblemMsg Nothing ErrUtils.SevError msg >> exception+pluginError = pluginProblemMsg Nothing ErrUtils.SevError pluginLocatedError :: SrcSpan -> SDoc -> CorePluginM a-pluginLocatedError loc msg- = pluginProblemMsg (Just loc) ErrUtils.SevError msg >> exception+pluginLocatedError loc = pluginProblemMsg (Just loc) ErrUtils.SevError pluginWarning :: SDoc -> CorePluginM ()-pluginWarning = pluginProblemMsg Nothing ErrUtils.SevWarning+pluginWarning = try' . pluginProblemMsg Nothing ErrUtils.SevWarning pluginLocatedWarning :: SrcSpan -> SDoc -> CorePluginM ()-pluginLocatedWarning loc = pluginProblemMsg (Just loc) ErrUtils.SevWarning+pluginLocatedWarning loc = try' . pluginProblemMsg (Just loc) ErrUtils.SevWarning pluginDebug :: SDoc -> CorePluginM () #if PLUGIN_DEBUG-pluginDebug = pluginProblemMsg Nothing ErrUtils.SevDump+pluginDebug = try' . pluginProblemMsg Nothing ErrUtils.SevDump #else pluginDebug = const (pure ()) #endif {-# INLINE pluginDebug #-} ++ pluginTrace :: HasCallStack => SDoc -> a -> a #if PLUGIN_DEBUG pluginTrace = withFrozenCallStack pprSTrace@@ -417,19 +443,18 @@ #endif {-# INLINE pluginTrace #-} - pluginProblemMsg :: Maybe SrcSpan -> ErrUtils.Severity -> SDoc- -> CorePluginM ()+ -> CorePluginM a pluginProblemMsg mspan sev msg = do dflags <- liftCoreM getDynFlags loc <- case mspan of Just sp -> pure sp Nothing -> liftCoreM getSrcSpanM unqual <- liftCoreM getPrintUnqualified- liftIO $ putLogMsg- dflags NoReason sev loc (mkErrStyle dflags unqual) msg+ CorePluginM $ const $ pure $ Left $+ putLogMsg dflags NoReason sev loc (mkErrStyle dflags unqual) msg #if __GLASGOW_HASKELL__ < 802 putLogMsg :: DynFlags -> WarnReason -> ErrUtils.Severity
src/Data/Constraint/Deriving/ToInstance.hs view
@@ -163,7 +163,8 @@ Just cl -> pure cl -- try to apply dictToBare to the expression of the found binding- newExpr <- case unwrapDictExpr dictTy fDictToBare bindExpr of+ mnewExpr <- try $ unwrapDictExpr dictTy fDictToBare bindExpr+ newExpr <- case mnewExpr of Nothing -> pluginLocatedError loc notGoodMsg Just ex -> pure $ mkCast ex $ mkUnsafeCo Representational bindBareTy instSig@@ -236,21 +237,25 @@ -- ^ dictToBare :: forall (c :: Constraint) . Dict c -> BareConstraint c -> CoreExpr -- ^ forall a1..an . (Ctx1,.. Ctxn) => Dict c- -> Maybe CoreExpr+ -> CorePluginM CoreExpr -- ^ forall a1..an . (Ctx1,.. Ctxn) => BareConstraint c unwrapDictExpr dictT unwrapFun ex = case ex of- Var _ -> testNWrap Nothing- Lit _ -> testNWrap Nothing- App e a -> testNWrap $ (App e <$> proceed a)- <|> (flip App a <$> proceed e)- Lam b e -> testNWrap $ Lam b <$> proceed e- Let b e -> testNWrap $ Let b <$> proceed e- Case {} -> testNWrap Nothing- Cast {} -> testNWrap Nothing- Tick t e -> testNWrap $ Tick t <$> proceed e- Type {} -> Nothing- Coercion {} -> Nothing+ Var _ -> testNWrap unwrapFail <|> (mkLamApp >>= proceed)+ Lit _ -> testNWrap unwrapFail+ App e a -> testNWrap $ (App e <$> proceed a) <|> (flip App a <$> proceed e)+ Lam b e -> testNWrap $ Lam b <$> proceed e+ Let b e -> testNWrap $ Let b <$> proceed e+ Case{} -> testNWrap unwrapFail+ Cast{} -> testNWrap unwrapFail+ Tick t e -> testNWrap $ Tick t <$> proceed e+ Type{} -> unwrapFail+ Coercion{} -> unwrapFail where+ unwrapFail = pluginError+ $ "Failed to match a definition signature."+ $$ hang "Looking for a dictionary:" 2 (ppr dictT)+ $$ hang "Inspecting an expression:" 2+ (hsep [ppr ex, "::", ppr $ exprType ex]) proceed = unwrapDictExpr dictT unwrapFun testNWrap go = if testType ex then wrap ex else go wrap e = flip fmap (getClsT e) $ \t -> Var unwrapFun `App` t `App` e@@ -258,5 +263,18 @@ -- I do not check if resulting substition is not trivial. Shall I? testType = isJust . Unify.tcMatchTy dictT . exprType getClsT e = case tyConAppArgs_maybe $ exprType e of- Just [t] -> Just $ Type t- _ -> Nothing+ Just [t] -> pure $ Type t+ _ -> unwrapFail+ mkThetaVar (i, ty) = newLocalVar ty ("theta" ++ show (i :: Int))+ mkLamApp =+ let et0 = exprType ex+ (bndrs, et1) = splitForAllTys et0+ (theta, _ ) = splitFunTys et1+ in if null bndrs && null theta+ then unwrapFail+ else do+ thetaVars <- traverse mkThetaVar $ zip [1 ..] theta+ let allVars = bndrs ++ thetaVars+ allApps = map (Type . mkTyVarTy) bndrs ++ map Var thetaVars+ fullyApplied = foldl App ex allApps+ return $ foldr Lam fullyApplied allVars
test/Spec.hs view
@@ -4,7 +4,7 @@ {-# LANGUAGE RecordWildCards #-} module Main (main) where -import Control.Monad (when)+import Control.Monad (when) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Data.Char (isSpace)@@ -22,8 +22,8 @@ import Path import Path.IO import System.Exit-import System.IO import System.FilePath (isPathSeparator)+import System.IO -- | Folder with test modules to be compiled specDir :: Path Rel Dir
test/Spec/DeriveAll02.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-} {-# OPTIONS_GHC -fplugin-opt Data.Constraint.Deriving:dump-instances #-}
test/Spec/DeriveAll03.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-} {-# OPTIONS_GHC -fplugin-opt Data.Constraint.Deriving:dump-instances #-}
test/Spec/ToInstance01.hs view
@@ -1,6 +1,7 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-} {-# OPTIONS_GHC -fplugin-opt Data.Constraint.Deriving:dump-instances #-} module Spec.ToInstance01 where@@ -17,8 +18,8 @@ rather than once for every fuction usage. -} import Data.Constraint-import Data.Constraint.Unsafe import Data.Constraint.Deriving+import Data.Constraint.Unsafe newtype Number t = Number (NumberFam t) @@ -46,6 +47,6 @@ deriveNum :: KnownNumber t => Dict (Num (Number t)) deriveNum = deriveIt numberSing -deriveIt :: (c Double, c Int) => NumberSing t -> Dict (c (Number t)) +deriveIt :: (c Double, c Int) => NumberSing t -> Dict (c (Number t)) deriveIt NumInt = mapDict (unsafeDerive Number) Dict deriveIt NumDouble = mapDict (unsafeDerive Number) Dict
+ test/Spec/ToInstance02.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-}+{-# OPTIONS_GHC -fplugin-opt Data.Constraint.Deriving:dump-instances #-}+module Spec.ToInstance02 where++{-+Testing that variables, such as deriveEqOrig, may have TyVars (forall t);+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++newtype Number t = Number (NumberFam t)++type family NumberFam t where+ NumberFam Int = Int+ NumberFam Double = Double++data NumberSing t where+ NumInt :: NumberSing Int+ NumDouble :: NumberSing Double++class KnownNumber t where numberSing :: NumberSing t+instance KnownNumber Int where numberSing = NumInt+instance KnownNumber Double where numberSing = NumDouble++{-# ANN deriveEq (ToInstance NoOverlap) #-}+deriveEq :: forall t . KnownNumber t => Dict (Eq (Number t))+deriveEq = deriveEqOrig++deriveEqOrig :: forall t . KnownNumber t => Dict (Eq (Number t))+deriveEqOrig = deriveIt numberSing+{-# NOINLINE deriveEqOrig #-}++deriveIt :: (c Double, c Int) => NumberSing t -> Dict (c (Number t))+deriveIt NumInt = mapDict (unsafeDerive Number) Dict+deriveIt NumDouble = mapDict (unsafeDerive Number) Dict
+ test/out/ToInstance02.stderr view
@@ -0,0 +1,7 @@+============ Class instances declared in this module ============+ instance KnownNumber t => Eq (Number t)+ -- Defined in `Spec.ToInstance02'+ instance KnownNumber Double+ -- Defined at test/Spec/ToInstance02.hs:*+ instance KnownNumber Int+ -- Defined at test/Spec/ToInstance02.hs:*
+ test/out/ToInstance02.stdout view
@@ -0,0 +1,1 @@+[*] Compiling Spec.ToInstance02 ( test/Spec/ToInstance02.hs, * )