diff --git a/intrinsic-superclasses.cabal b/intrinsic-superclasses.cabal --- a/intrinsic-superclasses.cabal +++ b/intrinsic-superclasses.cabal @@ -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 , @@ -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 diff --git a/src/Language/Haskell/TH/Instances.hs b/src/Language/Haskell/TH/Instances.hs --- a/src/Language/Haskell/TH/Instances.hs +++ b/src/Language/Haskell/TH/Instances.hs @@ -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 diff --git a/src/Language/Haskell/TH/Instances/Defaults.hs b/src/Language/Haskell/TH/Instances/Defaults.hs --- a/src/Language/Haskell/TH/Instances/Defaults.hs +++ b/src/Language/Haskell/TH/Instances/Defaults.hs @@ -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) diff --git a/src/Language/Haskell/TH/Instances/Internal.hs b/src/Language/Haskell/TH/Instances/Internal.hs --- a/src/Language/Haskell/TH/Instances/Internal.hs +++ b/src/Language/Haskell/TH/Instances/Internal.hs @@ -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] diff --git a/src/Language/Haskell/TH/Instances/Internal/Defaults.hs b/src/Language/Haskell/TH/Instances/Internal/Defaults.hs deleted file mode 100644 --- a/src/Language/Haskell/TH/Instances/Internal/Defaults.hs +++ /dev/null @@ -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) [] - diff --git a/src/Language/Haskell/TH/Instances/Internal/Utils.hs b/src/Language/Haskell/TH/Instances/Internal/Utils.hs --- a/src/Language/Haskell/TH/Instances/Internal/Utils.hs +++ b/src/Language/Haskell/TH/Instances/Internal/Utils.hs @@ -1,3 +1,4 @@ +{-# language DeriveDataTypeable #-} module Language.Haskell.TH.Instances.Internal.Utils (module Language.Haskell.TH.Instances.Internal.Utils ,module X) where