diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,7 +3,8 @@ # constraints-deriving This project is based on the [constraints](http://hackage.haskell.org/package/constraints) library. -Module `Data.Constraint.Deriving` provides a GHC Core compiler plugin that generates class instances. +Module `Data.Constraint.Deriving` is a GHC Core compiler plugin that +provides new flexible programmable ways to generate class instances. The main goal of this project is to make possible a sort of ad-hoc polymorphism that I wanted to implement in [easytensor](http://hackage.haskell.org/package/easytensor) for performance reasons: @@ -25,8 +26,8 @@ Check out `example` folder for a motivating use case (enabled with flag `examples`). -The plugin is controlled via GHC annotations; there are two types of annotations corresponding to two plugin passes. -Both passes are core-to-core, which means the plugin runs after typechecker, +The plugin is controlled via GHC annotations; there are three types of annotations corresponding to plugin passes. +All passes are core-to-core, which means the plugin runs after the typechecker, which in turn means **the generated class instances are available only outside of the module**. A sort of inconvenience you may have experienced with template haskell 😉. @@ -107,6 +108,19 @@ (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.* + +### ClassDict + +`ClassDict` plugin pass lets you construct a new class dictionary without +actually creating a class instance: +```Haskell +{-# ANN defineEq ClassDict #-} +defineEq :: (a -> a -> Bool) -> (a -> a -> Bool) -> Dict (Eq a) +defineEq = defineEq +-- the plugin replaces the above line with an actual class data constructor application +``` +Check out [`test/Spec/ClassDict01.hs`](https://github.com/achirkin/constraints-deriving/blob/master/test/Spec/ClassDict01.hs) for a more elaborate example. + ## Further work -`DeriveAll` derivation mechanics currently may break functional dependencies (untested). +`DeriveAll` derivation mechanics currently ignores and may break functional dependencies. 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: 1dd28a5dcf2104b86a3f1997734e55e702ac467521acc6e594ec01af5d11bc02 +-- hash: 8479ce57401f6861d28b9788c4d6722bb49be9d6bdbcede970e729f8d9887a37 name: constraints-deriving -version: 1.0.4.0 +version: 1.1.0.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 category: Constraints @@ -21,6 +21,8 @@ build-type: Custom extra-source-files: README.md + test/Spec/ClassDict01.hs + test/Spec/ClassDict02.hs test/Spec/DeriveAll01.hs test/Spec/DeriveAll02.hs test/Spec/DeriveAll03.hs @@ -29,6 +31,8 @@ test/Spec/DeriveAll06.hs test/Spec/ToInstance01.hs test/Spec/ToInstance02.hs + test/out/ClassDict01.stderr + test/out/ClassDict02.stderr test/out/DeriveAll01.stderr test/out/DeriveAll02.stderr test/out/DeriveAll03.stderr @@ -37,6 +41,8 @@ test/out/DeriveAll06.stderr test/out/ToInstance01.stderr test/out/ToInstance02.stderr + test/out/ClassDict01.stdout + test/out/ClassDict02.stdout test/out/DeriveAll01.stdout test/out/DeriveAll02.stdout test/out/DeriveAll03.stdout @@ -74,6 +80,7 @@ exposed-modules: Data.Constraint.Bare Data.Constraint.Deriving + Data.Constraint.Deriving.ClassDict Data.Constraint.Deriving.DeriveAll Data.Constraint.Deriving.ToInstance other-modules: @@ -128,6 +135,6 @@ , filepath , ghc , ghc-paths - , path + , path >=0.5.13 , path-io default-language: Haskell2010 diff --git a/src/Data/Constraint/Deriving.hs b/src/Data/Constraint/Deriving.hs --- a/src/Data/Constraint/Deriving.hs +++ b/src/Data/Constraint/Deriving.hs @@ -7,6 +7,8 @@ -- * ToInstance pass , ToInstance (..) , OverlapMode (..) + -- * ClassDict pass + , ClassDict (..) ) where @@ -16,6 +18,7 @@ import InstEnv (is_cls, is_tys) import Type (tyConAppTyCon_maybe) +import Data.Constraint.Deriving.ClassDict import Data.Constraint.Deriving.DeriveAll import Data.Constraint.Deriving.ToInstance @@ -50,6 +53,7 @@ install cmdopts todo = do eref <- initCorePluginEnv return ( deriveAllPass eref + : classDictPass eref : toInstancePass eref : if elem "dump-instances" cmdopts then dumpInstances:todo diff --git a/src/Data/Constraint/Deriving/ClassDict.hs b/src/Data/Constraint/Deriving/ClassDict.hs new file mode 100644 --- /dev/null +++ b/src/Data/Constraint/Deriving/ClassDict.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module Data.Constraint.Deriving.ClassDict + ( ClassDict (..) + , classDictPass + , CorePluginEnvRef, initCorePluginEnv + ) where + +import Control.Monad (join, unless, when) +import Data.Data (Data) +import Data.Maybe (fromMaybe, isJust) +import GhcPlugins hiding (OverlapMode (..), overlapMode) +import qualified Unify + +import Data.Constraint.Deriving.CorePluginM + + +{- | A marker to tell the core plugin to replace the implementation of a + top-level function by a corresponding class data constructor + (wrapped into `Data.Constraint.Dict`). + + Example: + +@ + +class BarClass a => FooClass a where + fooFun1 :: a -> a -> Int + fooFun2 :: a -> Bool + +{\-\# ANN deriveFooClass ClassDict \#-\} +deriveFooClass :: forall a . BarClass a + => (a -> a -> Int) + -> (a -> Bool) + -> Dict (FooClass a) +deriveFooClass = deriveFooClass +@ + + That is, the plugin replaces the RHS of @deriveFooClass@ function with + `DataCon.classDataCon` wrapped by `bareToDict`. + + Note: + + * The plugin requires you to create a dummy function `deriveFooClass` and + annotate it with `ClassDict` instead of automatically creating this function + for you; this way, the function is visible during type checking: + you can use it in the same module (avoiding orphans) and you see its type signature. + * You have to provide a correct signature for `deriveFooClass` function; + the plugin compares this signature against visible classes and their constructors. + An incorrect signature will result in a compile-time error. + * The dummy implementation @deriveFooClass = deriveFooClass@ is used here to + prevent GHC from inlining the function before the plugin can replace it. + But you can implement in any way you like at your own risk. + -} +data ClassDict = ClassDict + deriving (Eq, Show, Read, Data) + +-- | Run `ClassDict` plugin pass +classDictPass :: CorePluginEnvRef -> CoreToDo +classDictPass eref = CoreDoPluginPass "Data.Constraint.Deriving.ClassDict" + -- 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 (classDictPass' x) eref) + +classDictPass' :: ModGuts -> CorePluginM ModGuts +classDictPass' guts = do + (remAnns, processedBinds) <- runWithAnns (traverse go (mg_binds guts)) annotateds + unless (isNullUFM remAnns) $ + pluginWarning $ "One or more ClassDict annotations are ignored:" + $+$ vcat + (map pprBulletNameLoc . join $ eltsUFM remAnns) + $$ "Note possible issues:" + $$ pprNotes + [ "ClassDict is meant to be used only on bindings of type Ctx => Dict (Class t1 .. tn)." + , "GHC may remove the annotated definition if it is not reachable from module exports." + ] + return guts { mg_binds = processedBinds} + where + annotateds :: UniqFM [Name] + annotateds = map fst <$> (getModuleAnns guts :: UniqFM [(Name, ClassDict)]) + + go :: CoreBind -> WithAnns CoreBind + go (NonRec b e) = NonRec b <$> classDict' b e + go (Rec bes) = Rec <$> traverse (\(b, e) -> (,) b <$> classDict' b e) bes + + pprBulletNameLoc n = hsep + [" " , bullet, ppr $ occName n, ppr $ nameSrcSpan n] + pprNotes = vcat . map (\x -> hsep [" ", bullet, x]) + + classDict' x origBind = WithAnns $ \anns -> case lookupUFM anns x of + Just (xn:xns) -> do + unless (null xns) $ + pluginLocatedWarning (nameSrcSpan xn) $ + "Ignoring redundant ClassDict annotations" $$ + hcat + [ "(the plugin needs only one annotation per binding, but got " + , speakN (length xns + 1) + , ")" + ] + -- add new definitions and continue + (,) (delFromUFM anns x) . fromMaybe origBind <$> try (classDict x) + _ -> return (anns, origBind) + +-- a small state transformer for tracking remaining annotations +newtype WithAnns a = WithAnns + { runWithAnns :: UniqFM [Name] -> CorePluginM (UniqFM [Name], a) } + +instance Functor WithAnns where + fmap f m = WithAnns $ \anns -> fmap f <$> runWithAnns m anns + +instance Applicative WithAnns where + pure x = WithAnns $ \anns -> pure (anns, x) + mf <*> mx = WithAnns $ \anns0 -> do + (anns1, f) <- runWithAnns mf anns0 + (anns2, x) <- runWithAnns mx anns1 + pure (anns2, f x) + + +-- | Replace a given CoreBind with a corresponding class DataCon fun implementation. +-- +-- The core bind must have type `Ctx => Dict (Class t1 .. tn)`; +-- it does not change. +classDict :: CoreBndr -> CorePluginM CoreExpr + +classDict bindVar = do + + -- get necessary definitions + tcDict <- ask tyConDict + let conDict = tyConSingleDataCon tcDict + + -- check that the outermost constructor of the result type is Dict + -- and unwrap it. + dictContentTy <- case splitTyConApp_maybe dictTy of + Just (tcDict', [resTy]) + | tcDict' == tcDict -> pure resTy + err -> pluginLocatedError loc $ vcat + [ hsep + [ "Expected `Dict (Cls t1..tn)', but found", ppr dictTy] + , if isJust err + then "(constructor or number of arguments do not match)." + else "(I could not split apart a constructor application)." + , notGoodMsg + ] + + -- check if the content of the result Dict is indeed a class constraint + -- and get the class and its arguments. + (klass, instanceArgs) <- case splitTyConApp_maybe dictContentTy of + Just (klassTyCon, iArgs) + | Just klas <- tyConClass_maybe klassTyCon + -> pure (klas, iArgs) + | otherwise + -> pluginLocatedError loc $ vcat + [ hsep + [ "Expected a class constructor, but found", ppr klassTyCon] + , "(not a class data constructor)." + , notGoodMsg + ] + Nothing -> pluginLocatedError loc $ vcat + [ hsep + [ "Expected a class constructor, but found", ppr dictContentTy] + , "(I could not split apart a constructor application)." + , notGoodMsg + ] + + -- the core of the plugin: use a class data constructor + let klassDataCon = classDataCon klass + + -- check if the types agree + let expectedType = mapResultType (mkTyConApp tcDict . (:[])) + . idType $ dataConWorkId klassDataCon + + when (Unify.typesCantMatch [(origBindTy, expectedType)]) $ + pluginLocatedError loc $ vcat + [ hsep + [ "Cannot match the expected type (the type of the data constructor of the given class)" + , "and the found type (the user-supplied binding)."] + , hsep ["Expected type:", ppr expectedType] + , hsep ["Found type: ", ppr origBindTy] + ] + + argVars <- traverse (flip newLocalVar "t") argTys + return + . mkCoreLams (bndrs ++ argVars) + $ mkCoreConApps conDict + [ mkTyArg dictContentTy + , klassDataCon `mkCoreConApps` + (map mkTyArg instanceArgs ++ varsToCoreExprs argVars) + ] + + where + origBindTy = idType bindVar + (bndrs, bindTy) = splitForAllTys origBindTy + (argTys, dictTy) = splitFunTys bindTy + loc = nameSrcSpan $ getName bindVar + notGoodMsg = + "ClassDict plugin pass failed to process a Dict declaraion." + $$ "The declaration must have form `forall a1..an . Ctx => Dict (Cls t1..tn)'" + $$ "Declaration:" + $$ hcat + [ " " + , ppr bindVar, " :: " + , ppr origBindTy + ] + +-- | Transform the result type in a more complex fun type. +mapResultType :: (Type -> Type) -> Type -> Type +mapResultType f t + | (bndrs@(_:_), t') <- splitForAllTys t + = mkSpecForAllTys bndrs $ mapResultType f t' + | Just (at, rt) <- splitFunTy_maybe t + = mkFunTy at (mapResultType f rt) + | otherwise + = f t 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 @@ -26,6 +26,7 @@ , recMatchTyKi, replaceTypeOccurrences , OverlapMode (..), toOverlapFlag, instanceOverlapMode , lookupClsInsts, getInstEnvs, replaceInstance + , mkTyArg -- * Debugging , pluginDebug, pluginTrace , HasCallStack @@ -280,6 +281,9 @@ Right x <$ liftIO (modifyIORef' eref $ f (pure x)) maybeFound (Found _ m) = Just m maybeFound _ = Nothing + lookupDep :: HscEnv + -> (Maybe FastString, GenLocated SrcSpan ModuleName) + -> CorePluginM (Maybe Module) lookupDep hsce (mpn, mn) = maybeFound <$> liftIO (Finder.findImportedModule hsce (unLoc mn) mpn) @@ -496,6 +500,13 @@ isConstraintKind = Kind.isConstraintKind #else isConstraintKind = tcIsConstraintKind +#endif + +#if __GLASGOW_HASKELL__ < 802 +mkTyArg :: Type -> Expr b +mkTyArg ty + | Just co <- isCoercionTy_maybe ty = Coercion co + | otherwise = Type ty #endif -- | Similar to `getAnnotations`, but keeps the annotation target. 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 @@ -112,7 +112,7 @@ | Just ((xn, da):ds) <- lookupUFM anns x = do unless (null ds) $ pluginLocatedWarning (nameSrcSpan xn) $ - "Ignoring redundant DeriveAll annotions" $$ + "Ignoring redundant DeriveAll annotations" $$ hcat [ "(the plugin needs only one annotation per type declaration, but got " , speakN (length ds + 1) 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 @@ -96,7 +96,7 @@ | Just ((xn, ti):ds) <- lookupUFM anns x = do unless (null ds) $ pluginLocatedWarning (nameSrcSpan xn) $ - "Ignoring redundant ToInstance annotions" $$ + "Ignoring redundant ToInstance annotations" $$ hcat [ "(the plugin needs only one annotation per binding, but got " , speakN (length ds + 1) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -16,8 +16,10 @@ import DynFlags import ErrUtils (mkLocMessageAnn) import GHC +import GHC.IO.Handle import GHC.Paths (libdir) import MonadUtils (liftIO) +import Name (getOccString) import Outputable import Path import Path.IO @@ -58,6 +60,9 @@ main :: IO () main = do + stdout' <- hDuplicate stdout + stderr' <- hDuplicate stderr + targetPaths <- sort . mapMaybe lookupTargetPaths <$> (listDir specDir >>= traverse makeRelativeToCurrentDir . snd) withSystemTempFile "constraints-deriving-stdout" $ \_ outH -> @@ -67,7 +72,7 @@ runGhc (Just libdir) $ do dflags' <- makeSimpleAndFast <$> getSessionDynFlags (dflags, _, _) <- parseDynamicFlags dflags' - { log_action = manualLogAction outH errH} + { log_action = manualLogAction outH errH } [ noLoc "-Wall" , noLoc "-hide-all-packages" , noLoc "-package ghc" @@ -85,6 +90,30 @@ outPos <- liftIO $ hGetPosn outH errPos <- liftIO $ hGetPosn errH resCompile <- isSucceeded <$> load LoadAllTargets + -- try to exec main function if it exists + when (getAll resCompile) $ do + modSystemIO <- parseImportDecl "import System.IO (hFlush, stderr, stdout)" + modSumTarget <- getModSummary $ mkModuleName $ "Spec." ++ targetName + setContext [IIDecl modSystemIO, IIModule $ moduleName $ ms_mod modSumTarget] + mainIsInScope + <- not . null . filter (("main" ==) . getOccString) + <$> getNamesInScope + when (mainIsInScope) $ do + liftIO $ do + hDuplicateTo outH stdout + hDuplicateTo errH stderr + _ <- execStmt "putStrLn \"\"" execOptions + _ <- execStmt "putStrLn \"Output of running 'main':\"" execOptions + r <- execStmt "main" execOptions + _ <- execStmt "hFlush stdout" execOptions + _ <- execStmt "hFlush stderr" execOptions + liftIO $ do + case r of + ExecComplete { execResult = Left e } -> print e + _ -> return () + hDuplicateTo stdout' stdout + hDuplicateTo stderr' stderr + liftIO $ do -- flush logging handles to make sure logs are written hFlush outH @@ -179,8 +208,9 @@ makeSimpleAndFast :: DynFlags -> DynFlags makeSimpleAndFast flags = flags - { ghcMode = OneShot - , ghcLink = NoLink + { ghcMode = CompManager + , ghcLink = LinkInMemory + , hscTarget = HscInterpreted , verbosity = 1 , optLevel = 0 , ways = [] diff --git a/test/Spec/ClassDict01.hs b/test/Spec/ClassDict01.hs new file mode 100644 --- /dev/null +++ b/test/Spec/ClassDict01.hs @@ -0,0 +1,63 @@ +{-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-} +module Spec.ClassDict01 where + +import Data.Constraint +import Data.Constraint.Deriving +import qualified Data.Monoid as M + +main :: IO () +main = case testOrd of + Dict -> do + -- pattern-matching against Dict type makes `Ord Test` instance available + -- within the scope of the case expression. + print $ compare (Test 1 "hello") (Test 1 "world") + print $ Test 2 "hello" > Test 1 "world" + print $ max (Test 3 "A") (Test 3 "B") + + +-- Note, Test derives `Eq`, but not `Ord` +data Test = Test Int String + deriving (Eq, Show, Read) + +{- +Here I just use the function `defineOrd`. +In the source code, `defineOrd` is a dummy <> function, +but the GHC Core plugin replaces it with a proper implementation. + -} +testOrd :: Dict (Ord Test) +testOrd = defineOrd + cmp + (\a b -> cmp a b == LT) + (\a b -> cmp a b /= GT) + (\a b -> cmp a b == GT) + (\a b -> cmp a b /= LT) + (\a b -> if cmp a b == LT then b else a) + (\a b -> if cmp a b == GT then b else a) + where + cmp (Test i s) (Test j t) = compare i j M.<> compare s t + +{- +This is where all the magic happens: + +1. The ClassDict plugin pass picks up the `defineOrd` declaration +2. Checks the result type: `Dict (Ord a)`; infers the class of interest: `Ord` +3. Finds out the data constructor of the class `Ord` and compares it against the + given function signature +4. If the types agree, the plugin replaces the generated GHC Core code with + actual constructor (wrapped by `Dict`). + +Note, the arguments of this function should be carefully translated from the +class declaration: +all superclasses go first, followed by all class methods (order matters!). + -} +{-# ANN defineOrd ClassDict #-} +defineOrd :: Eq a -- Superclass + => (a -> a -> Ordering) -- compare + -> (a -> a -> Bool) -- (<) + -> (a -> a -> Bool) -- (<=) + -> (a -> a -> Bool) -- (>) + -> (a -> a -> Bool) -- (>=) + -> (a -> a -> a) -- max + -> (a -> a -> a) -- min + -> Dict (Ord a) +defineOrd = defineOrd diff --git a/test/Spec/ClassDict02.hs b/test/Spec/ClassDict02.hs new file mode 100644 --- /dev/null +++ b/test/Spec/ClassDict02.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-} +module Spec.ClassDict02 where + +import Data.Constraint +import Data.Constraint.Deriving + +-- Here check test/out/ClassDict02.stderr to see what happens if the type of this +-- function does not correspond to the class declaration +{-# ANN defineOrd ClassDict #-} +defineOrd :: Eq a + => (a -> a -> Ordering) + -> Dict (Ord a) +defineOrd = defineOrd diff --git a/test/out/ClassDict01.stderr b/test/out/ClassDict01.stderr new file mode 100644 --- /dev/null +++ b/test/out/ClassDict01.stderr diff --git a/test/out/ClassDict01.stdout b/test/out/ClassDict01.stdout new file mode 100644 --- /dev/null +++ b/test/out/ClassDict01.stdout @@ -0,0 +1,6 @@ +[*] Compiling Spec.ClassDict01 ( test/Spec/ClassDict01.hs, * ) + +Output of running 'main': +LT +True +Test 3 "B" diff --git a/test/out/ClassDict02.stderr b/test/out/ClassDict02.stderr new file mode 100644 --- /dev/null +++ b/test/out/ClassDict02.stderr @@ -0,0 +1,15 @@ +test/Spec/ClassDict02.hs:* error: + Cannot match the expected type (the type of the data constructor of the given class) and the found type (the user-supplied binding). + Expected type: forall a. + Eq a => + (a -> a -> Ordering) + -> (a -> a -> Bool) + -> (a -> a -> Bool) + -> (a -> a -> Bool) + -> (a -> a -> Bool) + -> (a -> a -> a) + -> (a -> a -> a) + -> Dict (Ord a) + Found type: forall a. + Eq a => + (a -> a -> Ordering) -> Dict (Ord a) diff --git a/test/out/ClassDict02.stdout b/test/out/ClassDict02.stdout new file mode 100644 --- /dev/null +++ b/test/out/ClassDict02.stdout @@ -0,0 +1,1 @@ +[*] Compiling Spec.ClassDict02 ( test/Spec/ClassDict02.hs, * )