intrinsic-superclasses 0.3.0.0 → 0.4.0.0

raw patch · 6 files changed

+60/−46 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• intrinsic-superclasses.cabal +2/−3
• src/Language/Haskell/TH/Instances.hs +1/−2
• src/Language/Haskell/TH/Instances/Defaults.hs +24/−20
• src/Language/Haskell/TH/Instances/Internal.hs +32/−3
• src/Language/Haskell/TH/Instances/Internal/Defaults.hs +0/−18
• src/Language/Haskell/TH/Instances/Internal/Utils.hs +1/−0

@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 32460428f2e391d6d2ae71ef71c376c5316fc2eff4c82315199e39cb10e902e5+-- hash: 8943068b544ca8d720e42dbdc781092d3cb7df39118c00c6e64d2f4979fcd8f9  name:           intrinsic-superclasses-version:        0.3.0.0+version:        0.4.0.0 synopsis:       A quasiquoter for better instance deriving and default methods description:    A template haskell utility inspired by the                 <https://ghc.haskell.org/trac/ghc/wiki/IntrinsicSuperclasses Intrinsic Superclasses Proposal>,@@ -46,7 +46,6 @@       Language.Haskell.TH.Instances       Language.Haskell.TH.Instances.Defaults       Language.Haskell.TH.Instances.Internal-      Language.Haskell.TH.Instances.Internal.Defaults       Language.Haskell.TH.Instances.Internal.Utils   other-modules:       Paths_intrinsic_superclasses

@@ -1,3 +1,2 @@-module Language.Haskell.TH.Instances (instances, defaulting) where+module Language.Haskell.TH.Instances (instances, Defaults(..)) where import Language.Haskell.TH.Instances.Internal-import Language.Haskell.TH.Instances.Defaults

@@ -1,33 +1,37 @@-{-# language MagicHash #-}+{-# language DeriveDataTypeable #-} module Language.Haskell.TH.Instances.Defaults where-import Language.Haskell.TH.Instances.Internal.Defaults-import Control.Concurrent.MVar (modifyMVar)+import Data.Data+import Language.Haskell.TH --- | Give a default for a typeclass method that will be utilized by the @instances@ quasiquoter.--- The default will be implicitly brought into scope when the module is imported, like typeclass instances.+-- | Give a default for a typeclass method that will be utilized by the 'instances' quasiquoter.+-- Defaults are declared by giving an [annotation](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/extending_ghc.html#annotating-types) like: ----- Example:+-- > {-# ann type MySubClass (Defaults 'mySuperclassMethod 'myDefaultDefinition) #-} ----- > module Data.Traversable.Defaults (module X) where--- > import Data.Traversable as X--- > import Data.Functor.Identity as X--- > import Data.Functor.Const as X--- > defaultMethod 'fmap [|\f -> runIdentity . traverse (Identity . f)|]--- > defaultMethod 'foldmap [|\f -> getConst . traverse (Const . f)|]+-- For example, we could modify "Data.Traversable" to work with 'instances' like so: --+-- > {-# language TemplateHaskell #-}+-- > module Data.Traversable where+-- > {- ... normal imports ... -}+-- > import Language.Haskell.TH.Instances.Defaults+-- >+-- > class (Functor t, Foldable t) => Traversable t where ...  -- Same as normal+-- > {-# ANN type Traversable (Defaults 'fmap 'fmapDefault) #-}+-- > {-# ANN type Traversable (Defaults 'foldMap 'foldMapDefault) #-}+-- -- > module MyData where--- > import Data.Traversable.Defaults+-- > import Data.Traversable -- > -- > data Foo a = Foo a a -- > [instances| Travesable Foo where traverse f (Foo a a') = Foo <$> f a <*> f a'|] -- -- will generate ----- > instance Functor Foo where fmap = \f -> runIdentity . traverse (Identity . f)--- > instance Foldable Foo where foldMap = \f -> getConst . traverse (Const . f)+-- > instance Functor Foo where fmap = fmapDefault+-- > instance Foldable Foo where foldMap = foldMapDefault -- > instance Travesable Foo where traverse f (Foo a a') = Foo <$> f a <*> f a'-defaulting :: Name -> Q Exp -> Q [Dec]-defaulting n qe = do-  e <- qe-  runIO $ modifyMVar defaults# (\m -> return (insert n e m,()))-  return []+data Defaults = Defaults+  {defining :: Name -- ^ The name of the superclass method being provided+  ,definition :: Name -- ^ The name of a function implementing the superclass method+  }+  deriving (Data,Typeable,Show)

@@ -1,4 +1,5 @@ {-# language ScopedTypeVariables #-}+{-# language RecordWildCards #-} {-# language TupleSections #-} {-# language FlexibleInstances #-} {-# language MultiParamTypeClasses #-}@@ -12,7 +13,7 @@  import Language.Haskell.TH as X import Language.Haskell.TH.Instances.Internal.Utils as X-import Language.Haskell.TH.Instances.Internal.Defaults as X+import Language.Haskell.TH.Instances.Defaults as X import Language.Haskell.TH.Syntax as X hiding (lift) import Language.Haskell.Meta.Parse as X (parseDecs) import Language.Haskell.TH.Quote as X (QuasiQuoter(..))@@ -26,11 +27,16 @@ -- -- Example: --+-- >  {-# language TemplateHaskell,QuasiQuotes,FlexibleInstances,UndecidableInstances #-}+-- >  import Prelude hiding (Monoid(..))+-- >  import Language.Haskell.TH.Instances+-- > -- >  class Semigroup a where mappend :: a -> a -> a -- >  class Semigroup a => Commutative a -- >  class Semigroup a => Monoid a where mempty :: a -- >  class Monoid a => Group a where inverse :: a -> a -- >  class (Commutative a, Group a) => CommutativeGroup a+-- >  $(return []) -- Only needed if classes are defined in the same module, to make sure they're in scope below -- >  [instances| Num a => CommutativeGroup a where -- >      mempty = fromInteger 0 -- >      mappend a b = a + b@@ -61,13 +67,14 @@     declaredMethods' <- M.fromList <$> traverse globalizeDef declaredMethods     superclasses <- getTransitiveSuperclassNames className -    requiredMethods <- fold <$> M.traverseWithKey (\k _ -> getClassMethods k) superclasses+    requiredMethods <- fold <$> M.traverseWithKey (\k _ -> getClassMethods k) superclasses -- Methods that will eventually need to be filled in     let badMethods = filter (\x -> not $ M.member x requiredMethods) $ M.keys declaredMethods'     unless (null badMethods) $       error $ "splitInstances: Trying to declare methods not in the superclass heirarchy\n"            ++ unlines (map show badMethods) -    defaultMethods <- M.traverseMaybeWithKey (\k _ -> getDefault k)  requiredMethods+    defaultMethods <- (`M.intersection` requiredMethods) <$> transitiveProvidedDefaults className+    {-defaultMethods <- M.traverseMaybeWithKey (\k _ -> getDefault k)  requiredMethods-}     let declaredMethods'' = declaredMethods' `M.union` defaultMethods      superclassHasInstance <- M.traverseWithKey (\k _ -> isInstance k [instancesFor]) superclasses@@ -150,3 +157,25 @@ -- > occName ''Show === "Show" occName :: Name -> String occName (Name (OccName s) _) = s++-- | reify the names of all transitive superclasses for a class name, including itself+getTransitiveSuperclassNames' :: Name -> Q (Map Name Int)+getTransitiveSuperclassNames' = execWriterT . go 0 where+  go i n = do+    tell $ M.singleton n i+    traverse_ (go (i+1)) =<< lift (getSuperclassNames n)++transitiveProvidedDefaults :: Name -> Q (Map Name Dec)+transitiveProvidedDefaults n = do+  sc <- M.toList <$> getTransitiveSuperclassNames' n+  defaultsMap <- M.map fst . M.unionsWith lowest -- Defaults from deeper subclasses take precidence+             <$> mapM (\(n',i) -> M.map (,i) <$> providedDefaults n') sc+  return $ M.mapWithKey name_dec defaultsMap+  where name_dec n' def = ValD (VarP n') (NormalB (VarE def)) []+        lowest a@(_,i) b@(_,i') = if i <= i' then a else b++-- | Get the default superclass method implementations provided by a subclass+providedDefaults :: Name -> Q (Map Name Name)+providedDefaults (AnnLookupName -> n) = do+  defaults <- reifyAnnotations n+  return $ M.fromList [(defining,definition) | Defaults{..} <- defaults]

@@ -1,18 +0,0 @@-{-# language MagicHash #-}-module Language.Haskell.TH.Instances.Internal.Defaults (defaults#,getDefault, module X) where-import Language.Haskell.TH.Instances.Internal.Utils as X-import Control.Concurrent.MVar (MVar,newMVar,readMVar)-import GHC.Conc (pseq)-import System.IO.Unsafe---- | Global map from method names to definitions.--- Do not use directly, preferring 'defaulting' and 'getDefault'-defaults# :: MVar (Map Name Exp)-{-# noinline defaults# #-}-defaults# = m `pseq` unsafePerformIO (newMVar m) where m = mempty---- | Generate a method definition for provided 'Name' if a default exists in scope-getDefault :: Name -> Q (Maybe Dec)-getDefault n = runIO $ fmap exp_dec . mapLookup n <$> readMVar defaults#-  where exp_dec e = ValD (VarP n) (NormalB e) []-

@@ -1,3 +1,4 @@+{-# language DeriveDataTypeable #-} module Language.Haskell.TH.Instances.Internal.Utils   (module Language.Haskell.TH.Instances.Internal.Utils   ,module X) where