intrinsic-superclasses 0.2.0.0 → 0.3.0.0

raw patch · 6 files changed

+275/−167 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• intrinsic-superclasses.cabal +49/−30
• src/Language/Haskell/TH/Instances.hs +3/−137
• src/Language/Haskell/TH/Instances/Defaults.hs +33/−0
• src/Language/Haskell/TH/Instances/Internal.hs +152/−0
• src/Language/Haskell/TH/Instances/Internal/Defaults.hs +18/−0
• src/Language/Haskell/TH/Instances/Internal/Utils.hs +20/−0

@@ -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-  <https://ghc.haskell.org/trac/ghc/wiki/IntrinsicSuperclasses Intrinsic Superclasses Proposal>,-  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+                <https://ghc.haskell.org/trac/ghc/wiki/IntrinsicSuperclasses Intrinsic Superclasses Proposal>,+                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

@@ -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 <https://ghc.haskell.org/trac/ghc/wiki/IntrinsicSuperclasses intrinsic-superclasses>.------ 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

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

@@ -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 <https://ghc.haskell.org/trac/ghc/wiki/IntrinsicSuperclasses intrinsic-superclasses>.+--+-- 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

@@ -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) []+

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