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: 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 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 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 @@ -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 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 @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 diff --git a/test/Spec/DeriveAll02.hs b/test/Spec/DeriveAll02.hs --- a/test/Spec/DeriveAll02.hs +++ b/test/Spec/DeriveAll02.hs @@ -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 #-} diff --git a/test/Spec/DeriveAll03.hs b/test/Spec/DeriveAll03.hs --- a/test/Spec/DeriveAll03.hs +++ b/test/Spec/DeriveAll03.hs @@ -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 #-} diff --git a/test/Spec/ToInstance01.hs b/test/Spec/ToInstance01.hs --- a/test/Spec/ToInstance01.hs +++ b/test/Spec/ToInstance01.hs @@ -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 diff --git a/test/Spec/ToInstance02.hs b/test/Spec/ToInstance02.hs new file mode 100644 --- /dev/null +++ b/test/Spec/ToInstance02.hs @@ -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 diff --git a/test/out/ToInstance02.stderr b/test/out/ToInstance02.stderr new file mode 100644 --- /dev/null +++ b/test/out/ToInstance02.stderr @@ -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:* diff --git a/test/out/ToInstance02.stdout b/test/out/ToInstance02.stdout new file mode 100644 --- /dev/null +++ b/test/out/ToInstance02.stdout @@ -0,0 +1,1 @@ +[*] Compiling Spec.ToInstance02 ( test/Spec/ToInstance02.hs, * )