diff --git a/intrinsic-superclasses.cabal b/intrinsic-superclasses.cabal --- a/intrinsic-superclasses.cabal +++ b/intrinsic-superclasses.cabal @@ -1,34 +1,53 @@ -name: intrinsic-superclasses -version: 0.2.0.0 -synopsis: A quasiquoter implementation of the Intrinsic Superclasses Proposal -description: - A template haskell implementation of the - , - which allows defining all superclass methods at the "root" - of the class heirarchy in one declaration, rather than - an instance declaration per class -homepage: https://github.com/daig/intrinsic-superclasses#readme -license: MIT -license-file: LICENSE -author: Dai -maintainer: dailectic@gmail.com -copyright: Sodality -category: Language -build-type: Simple -extra-source-files: README.md -cabal-version: >=1.10 +-- This file has been generated from package.yaml by hpack version 0.20.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 32460428f2e391d6d2ae71ef71c376c5316fc2eff4c82315199e39cb10e902e5 -library - hs-source-dirs: src - ghc-options: -Wall - exposed-modules: Language.Haskell.TH.Instances - build-depends: base >= 4.7 && < 5 - ,template-haskell - ,haskell-src-meta - ,containers - ,mtl - default-language: Haskell2010 +name: intrinsic-superclasses +version: 0.3.0.0 +synopsis: A quasiquoter for better instance deriving and default methods +description: A template haskell utility inspired by the + , + which allows defining all superclass methods at the "root" subclass + of the heirarchy in one declaration, rather than + an instance declaration per class. + Also permits defining superclass method defaults with the subclass + for greater flexibility than the DefaultSignatures extension +category: Language +homepage: https://github.com/daig/intrinsic-superclasses#readme +bug-reports: https://github.com/daig/intrinsic-superclasses/issues +author: Dai +maintainer: dailectic@gmail.com +copyright: Sodality +license: MIT +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + README.md + source-repository head - type: git + type: git location: https://github.com/daig/intrinsic-superclasses + +library + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + base >=4.7 && <5 + , containers + , haskell-src-meta + , mtl + , template-haskell + exposed-modules: + 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 + default-language: Haskell2010 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,137 +1,3 @@ -{-# language ScopedTypeVariables #-} -{-# language TupleSections #-} -{-# language FlexibleInstances #-} -{-# language MultiParamTypeClasses #-} -{-# language FlexibleContexts #-} -{-# language GADTs #-} -{-# language LambdaCase #-} -{-# language ViewPatterns #-} -module Language.Haskell.TH.Instances (instances) where - -import Language.Haskell.TH -import Language.Haskell.TH.Syntax hiding (lift) -import Language.Haskell.Meta.Parse (parseDecs) -import Language.Haskell.TH.Quote (QuasiQuoter(..)) -import Data.Set (Set) -import qualified Data.Set as S -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (mapMaybe) -import Control.Monad.Writer -import Data.Foldable - --- | @QuasiQuoter@ for providing . --- --- Example: --- --- > 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 --- > [instances| Num a => CommutativeGroup a where --- > mempty = fromInteger 0 --- > mappend a b = a + b --- > inverse = negate --- > |] --- --- will generate the appropriate instances for @Semigroup@, @Monoid@, and @Group@: --- --- > instance Num a => Semigroup a where mappend a b = a + b --- > instance Num a => Commutative a --- > instance Num a => Monoid a where mempty = fromInteger 0 --- > instance Num a => Group a where inverse = negate --- > instance Num a => CommutativeGroup a -instances :: QuasiQuoter -instances = QuasiQuoter - {quoteExp = err "Exp" - ,quotePat = err "Pat" - ,quoteType = err "Type" - ,quoteDec = \s -> case parseDecs ("instance " ++ s) of - Left e -> error e - Right d -> fmap concat $ mapM splitInstances d} - where err s = const $ error $ "quasiquoter `instances` expected Dec, instead used as " ++ s - --- | Implements the @instances@ quasiquoter ast transform -splitInstances :: Dec -> DecsQ -splitInstances = \case - InstanceD Nothing ctx (AppT (ConT className) instancesFor) instanceMethods -> do - instanceMethods' <- M.fromList <$> traverse globalizeDef instanceMethods - superclasses <- getTransitiveSuperclassNames className - - superclassMethods <- fold <$> M.traverseWithKey (\k _ -> getClassMethods k) superclasses - let badMethods = filter (\x -> not $ S.member x superclassMethods) $ M.keys instanceMethods' - unless (null badMethods) $ - error $ "splitInstances: Trying to declare methods not in the superclass heirarchy\n" - ++ unlines (map show badMethods) - - superclassHasInstance <- M.traverseWithKey (\k _ -> isInstance k [instancesFor]) superclasses - let superclasses' = M.filterWithKey (\k _ -> not $ superclassHasInstance M.! k) superclasses - classOps <- getClassOps instanceMethods superclasses' - let classDefs = M.map (\names -> (instanceMethods' M.!) `S.map` names) classOps - let instanceDecls = M.foldrWithKey (\c ms -> (declInstance ctx c instancesFor ms :)) [] classDefs - pure instanceDecls - d -> error $ "splitInstances: Not an instance declaration\n" ++ pprint d - where - occName (Name (OccName s) _) = s - declInstance ctx className targetType ms = InstanceD Nothing ctx (AppT (ConT className) targetType) (S.toList ms) - -- Associate a definition with its toplevel qualified identifier - globalizeDef d = (lookupValueName . occName . defName) d >>= \case - Nothing -> error $ "globalizeDef: instance method " ++ show (occName (defName d)) ++ " not in scope" - Just n -> pure (n,d) - --- | Create a Map of className to method declaration from a list of instance method definitions -getClassOps :: Traversable t => t Dec -> Map ParentName (Set Name) -> Q (Map ParentName (Set Name)) -getClassOps decs superclasses = collectFromList S.insert superclasses <$> mapM (\d -> opClass <$> reify (defName d)) decs - where - opClass (ClassOpI n _t p) = (p,n) - opClass x = error $ "opClass: not a class operation\n" ++ pprint x - --- | Get the name of a function or value declaration -defName :: Dec -> Name -defName x = case x of - FunD n _ -> n - ValD (VarP n) _ _ -> n - d -> error $ "defName: Declaration is not a Function or Value definition\n" ++ pprint d -sigName :: Dec -> Name -sigName = \case - SigD n _ -> n - d -> error $ "sigName: Declaration is not a type signature\n" ++ pprint d - - -collectFromList :: (Ord k, Foldable t) => (a -> as -> as) -> Map k as -> t (k,a) -> Map k as -collectFromList f m0 x = foldr (\(k,a) -> M.adjust (f a) k) m0 x - --- | reify the names of the direct superclasses for a class name -getSuperclassNames :: Name -> Q [Name] -getSuperclassNames className = do - ClassI (ClassD ctx _ (S.fromList . map _TyVarBndr_name -> classVars) _ _) _ <- reify className - let - -- if t represents a supeclass of n then `superclass t` is Just the superclass name, and Nothing otherwise - superclass :: Type -> Maybe Name - superclass = \case - AppT t (VarT v) | S.member v classVars -> Just $ headAppT t - AppT ConT{} _ -> Nothing - AppT t _ -> superclass t - x -> error $ show x - pure $ mapMaybe superclass ctx - where - _TyVarBndr_name = \case {PlainTV n -> n; KindedTV n _ -> n} - headAppT :: Type -> Name -- project the innermost @ConT@ in a chain of @AppT@ - headAppT = \case - ConT n -> n - AppT t _ -> headAppT t - x -> error $ "headAppT: Malformed type\n" ++ show x - -getClassMethods :: Name -> Q (Set Name) -getClassMethods className = reify className <&> (\(ClassI (ClassD _ _ _ _ (map sigName -> methods)) _) -> S.fromList methods) - --- | reify the names of all transitive superclasses for a class name, including itself -getTransitiveSuperclassNames :: Name -> Q (Map Name (Set a)) -getTransitiveSuperclassNames = execWriterT . go where - go n = do - tell $ M.singleton n S.empty - traverse_ go =<< lift (getSuperclassNames n) - -(<&>) :: Functor f => f a -> (a -> b) -> f b -(<&>) = flip (<$>) +module Language.Haskell.TH.Instances (instances, defaulting) 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 new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TH/Instances/Defaults.hs @@ -0,0 +1,33 @@ +{-# language MagicHash #-} +module Language.Haskell.TH.Instances.Defaults where +import Language.Haskell.TH.Instances.Internal.Defaults +import Control.Concurrent.MVar (modifyMVar) + +-- | 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. +-- +-- Example: +-- +-- > 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)|] +-- +-- > module MyData where +-- > import Data.Traversable.Defaults +-- > +-- > 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 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 [] diff --git a/src/Language/Haskell/TH/Instances/Internal.hs b/src/Language/Haskell/TH/Instances/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TH/Instances/Internal.hs @@ -0,0 +1,152 @@ +{-# language ScopedTypeVariables #-} +{-# language TupleSections #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language FlexibleContexts #-} +{-# language GADTs #-} +{-# language LambdaCase #-} +{-# language ViewPatterns #-} +module Language.Haskell.TH.Instances.Internal + (module Language.Haskell.TH.Instances.Internal + ,module X) where + +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.Syntax as X hiding (lift) +import Language.Haskell.Meta.Parse as X (parseDecs) +import Language.Haskell.TH.Quote as X (QuasiQuoter(..)) +import Data.Map as X (Map) +import qualified Data.Map as M +import Data.Maybe as X (mapMaybe) +import Control.Monad.Writer as X +import Data.Foldable as X + +-- | @QuasiQuoter@ for providing . +-- +-- Example: +-- +-- > 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 +-- > [instances| Num a => CommutativeGroup a where +-- > mempty = fromInteger 0 +-- > mappend a b = a + b +-- > inverse = negate +-- > |] +-- +-- will generate the appropriate instances for @Semigroup@, @Monoid@, and @Group@: +-- +-- > instance Num a => Semigroup a where mappend a b = a + b +-- > instance Num a => Commutative a +-- > instance Num a => Monoid a where mempty = fromInteger 0 +-- > instance Num a => Group a where inverse = negate +-- > instance Num a => CommutativeGroup a +instances :: QuasiQuoter +instances = QuasiQuoter + {quoteExp = err "Exp" + ,quotePat = err "Pat" + ,quoteType = err "Type" + ,quoteDec = \s -> case parseDecs ("instance " ++ s) of + Left e -> error e + Right d -> fmap concat $ mapM splitInstances d} + where err s = const $ error $ "quasiquoter `instances` expected Dec, instead used as " ++ s + +-- | Implements the @instances@ quasiquoter ast transform +splitInstances :: Dec -> DecsQ +splitInstances = \case + InstanceD Nothing ctx (AppT (ConT className) instancesFor) declaredMethods -> do + declaredMethods' <- M.fromList <$> traverse globalizeDef declaredMethods + superclasses <- getTransitiveSuperclassNames className + + requiredMethods <- fold <$> M.traverseWithKey (\k _ -> getClassMethods k) superclasses + 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 + let declaredMethods'' = declaredMethods' `M.union` defaultMethods + + superclassHasInstance <- M.traverseWithKey (\k _ -> isInstance k [instancesFor]) superclasses + superclasses' <- fmap (fromKeys M.empty) $ traverse globalizeClass $ filter (\k -> not $ superclassHasInstance M.! k) $ M.keys superclasses + + classOps <- getClassOps (M.elems declaredMethods'') superclasses' + + let classDefs = M.map (\names -> (declaredMethods'' M.!) `M.mapKeys` names) classOps + let instanceDecls = M.foldrWithKey (\c ms -> (declInstance ctx c instancesFor ms :)) [] classDefs + pure instanceDecls + d -> error $ "splitInstances: Not an instance declaration\n" ++ pprint d + where + declInstance ctx className targetType ms = InstanceD Nothing ctx (AppT (ConT className) targetType) (M.keys ms) + -- Associate a definition with its toplevel qualified identifier + globalizeDef d = (lookupValueName . occName . defName) d >>= \case + Nothing -> error $ "globalizeDef: instance method " ++ show (occName (defName d)) ++ " not in scope" + Just n -> pure (n,d) + +-- | Get the fully qualified name of a class +globalizeClass :: Name -> Q Name +globalizeClass c = (lookupTypeName . occName) c >>= \case + Nothing -> error $ "globalizeClass: class " ++ show (occName c) ++ " not in scope" + Just n -> pure n + +-- | Create a Map of className to method declaration from a list of instance method definitions +getClassOps :: Traversable t => t Dec -> Map ParentName (Set Name) -> Q (Map ParentName (Set Name)) +getClassOps decs superclasses = adjustMany (`M.insert` ()) superclasses <$> mapM (\d -> opClass <$> reify (defName d)) decs + where + opClass :: Info -> (ParentName, Name) + opClass (ClassOpI n _t p) = (p,n) + opClass x = error $ "opClass: not a class operation\n" ++ pprint x + + +-- | Get the name of a function or value declaration +defName :: Dec -> Name +defName x = case x of + FunD n _ -> n + ValD (VarP n) _ _ -> n + d -> error $ "defName: Declaration is not a Function or Value definition\n" ++ pprint d +sigName :: Dec -> Name +sigName = \case + SigD n _ -> n + d -> error $ "sigName: Declaration is not a type signature\n" ++ pprint d + + +-- | reify the names of the direct superclasses for a class name +getSuperclassNames :: Name -> Q [Name] +getSuperclassNames className = do + ClassI (ClassD ctx _ (fromKeys () . map _TyVarBndr_name -> classVars) _ _) _ <- reify className + let + -- if t represents a supeclass of n then `superclass t` is Just the superclass name, and Nothing otherwise + superclass :: Type -> Maybe Name + superclass = \case + AppT t (VarT v) | M.member v classVars -> Just $ headAppT t + AppT ConT{} _ -> Nothing + AppT t _ -> superclass t + x -> error $ show x + pure $ mapMaybe superclass ctx + where + _TyVarBndr_name = \case {PlainTV n -> n; KindedTV n _ -> n} + headAppT :: Type -> Name -- project the innermost @ConT@ in a chain of @AppT@ + headAppT = \case + ConT n -> n + AppT t _ -> headAppT t + x -> error $ "headAppT: Malformed type\n" ++ show x + +getClassMethods :: Name -> Q (Set Name) +getClassMethods className = reify className <&> (\(ClassI (ClassD _ _ _ _ (map sigName -> methods)) _) -> fromKeys () methods) + +-- | reify the names of all transitive superclasses for a class name, including itself +getTransitiveSuperclassNames :: Name -> Q (Map Name (Set a)) +getTransitiveSuperclassNames = execWriterT . go where + go n = do + tell $ M.singleton n M.empty + traverse_ go =<< lift (getSuperclassNames n) + +-- | Extract the unqualified part from a @Name@. For example: +-- +-- > show ''Show === "GHC.Show.Show" +-- > occName ''Show === "Show" +occName :: Name -> String +occName (Name (OccName s) _) = s diff --git a/src/Language/Haskell/TH/Instances/Internal/Defaults.hs b/src/Language/Haskell/TH/Instances/Internal/Defaults.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TH/Instances/Internal/Defaults.hs @@ -0,0 +1,18 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TH/Instances/Internal/Utils.hs @@ -0,0 +1,20 @@ +module Language.Haskell.TH.Instances.Internal.Utils + (module Language.Haskell.TH.Instances.Internal.Utils + ,module X) where +import Language.Haskell.TH as X +import Data.Map as X (Map, lookup,adjust,fromList,insert,traverseWithKey) + +mapLookup :: Ord k => k -> Map k v -> Maybe v +mapLookup = X.lookup + +type Set k = Map k () + +-- | Initialize a Map from a default value and a list of keys +fromKeys :: Ord k => v -> [k] -> Map k v +fromKeys z xs = let zs = z:zs in fromList $ zip xs zs + +(<&>) :: Functor f => f a -> (a -> b) -> f b +(<&>) = flip (<$>) + +adjustMany :: (Ord k, Foldable t) => (a -> as -> as) -> Map k as -> t (k,a) -> Map k as +adjustMany ins m0 x = foldr (\(k,a) -> adjust (ins a) k) m0 x