intrinsic-superclasses 0.1.0.0 → 0.2.0.0
raw patch · 2 files changed
+102/−31 lines, 2 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
intrinsic-superclasses.cabal view
@@ -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
src/Language/Haskell/TH/Instances.hs view
@@ -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.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 @@ -- 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 @@ 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- 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"+ 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 (<$>)