constraints-deriving 1.0.4.0 → 1.1.0.0

raw patch · 14 files changed

+389/−12 lines, 14 filesdep ~ghcdep ~pathPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: ghc, path

API changes (from Hackage documentation)

Files

• README.md +18/−4
• constraints-deriving.cabal +10/−3
• src/Data/Constraint/Deriving.hs +4/−0
• src/Data/Constraint/Deriving/ClassDict.hs +213/−0
• src/Data/Constraint/Deriving/CorePluginM.hs +11/−0
• src/Data/Constraint/Deriving/DeriveAll.hs +1/−1
• src/Data/Constraint/Deriving/ToInstance.hs +1/−1
• test/Spec.hs +33/−3
• test/Spec/ClassDict01.hs +63/−0
• test/Spec/ClassDict02.hs +13/−0
• test/out/ClassDict01.stderr +0/−0
• test/out/ClassDict01.stdout +6/−0
• test/out/ClassDict02.stderr +15/−0
• test/out/ClassDict02.stdout +1/−0

@@ -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.

@@ -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 <https://github.com/achirkin/constraints-deriving#readme> 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

@@ -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

@@ -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

@@ -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.

@@ -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)

@@ -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)

@@ -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        = []

@@ -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 <<loop>> 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

@@ -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

@@ -0,0 +1,6 @@+[*] Compiling Spec.ClassDict01 ( test/Spec/ClassDict01.hs, * )++Output of running 'main':+LT+True+Test 3 "B"

@@ -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)

@@ -0,0 +1,1 @@+[*] Compiling Spec.ClassDict02 ( test/Spec/ClassDict02.hs, * )