summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authordailectic <>2017-12-07 02:31:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-12-07 02:31:00 (GMT)
commitbef7aa85bfa9f9f12ced74cb4aea9b4b9d03cd33 (patch)
treefb497f11943283ce64c0406d4c7365c16a45ad01
parent938c6d0f16c0118930db65ed92737797490e7a98 (diff)
version 0.2.0.0HEAD0.2.0.0master
-rw-r--r--intrinsic-superclasses.cabal4
-rw-r--r--src/Language/Haskell/TH/Instances.hs129
2 files changed, 102 insertions, 31 deletions
diff --git a/intrinsic-superclasses.cabal b/intrinsic-superclasses.cabal
index 7660608..1e2421e 100644
--- a/intrinsic-superclasses.cabal
+++ b/intrinsic-superclasses.cabal
@@ -1,11 +1,11 @@
name: intrinsic-superclasses
-version: 0.1.0.0
+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, rathar than
+ of the class heirarchy in one declaration, rather than
an instance declaration per class
homepage: https://github.com/daig/intrinsic-superclasses#readme
license: MIT
diff --git a/src/Language/Haskell/TH/Instances.hs b/src/Language/Haskell/TH/Instances.hs
index d93b4eb..3c1717a 100644
--- a/src/Language/Haskell/TH/Instances.hs
+++ b/src/Language/Haskell/TH/Instances.hs
@@ -1,3 +1,11 @@
+{-# 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
@@ -6,17 +14,22 @@ import Language.Haskell.Meta.Parse (parseDecs)
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Data.Set (Set)
import qualified Data.Set as S
-import Data.List (partition)
-import Control.Monad.Writer (when,lift,execWriterT,Endo(..),MonadWriter(..))
+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
--- > [instances| Num a => Group where
+-- > 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
@@ -25,8 +38,10 @@ import Control.Monad.Writer (when,lift,execWriterT,Endo(..),MonadWriter(..))
-- 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"
@@ -36,31 +51,87 @@ instances = QuasiQuoter
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 d = case d of
- InstanceD _overlaps ctx ty@(AppT _ instanceFor) instanceMethods ->
- let
- go methods t = case t of
- AppT (ConT className) _ -> do
- (superclasses,classMethods) <- lift $ reifyClass className
- let (theseMethods,methods') = partition (\x -> defOccName x `S.member` classMethods) methods
- when (length theseMethods > 0) $ tellCons $ InstanceD Nothing ctx (AppT (ConT className) instanceFor) theseMethods
- mapM_ (go methods') superclasses
- _ -> error $ "splitInstances: malformed instance head (" ++ show t ++ ")"
- {-_ -> pure ()-}
- in (`appEndo` []) <$> execWriterT (go instanceMethods ty)
- _ -> error $ "splitInstances: not an instance declaration " ++ show d
+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
- tellCons = tell . Endo . (:)
- defOccName x = case x of
- FunD (Name occ _) _ -> occ
- ValD (VarP (Name occ _)) _ _ -> occ
- _ -> error $ "defOccName: not a function or value definition " ++ show x
- reifyClass :: Name -> Q (Cxt,Set OccName)
- reifyClass n = do
- info <- reify n
- pure $ case info of
- ClassI (ClassD ctx _name _tyvarbndr _fundeps methods) _instances -> (ctx,S.fromList [occ | SigD (Name occ _) _ <- methods])
- _ -> error "reifyClass: not a class 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
+
+
+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 (<$>)