newtype-th 0.2 → 0.3
raw patch · 3 files changed
+84/−12 lines, 3 filesdep +syb
Dependencies added: syb
Files
- Control/Newtype/TH.hs +62/−8
- Tests.hs +16/−2
- newtype-th.cabal +6/−2
Control/Newtype/TH.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE TemplateHaskell #-}-+{-# LANGUAGE TemplateHaskell, TupleSections #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Newtype.TH@@ -9,7 +8,8 @@ -- Portability : unportable -- -- This module provides a template Haskell based mechanism for deriving--- instances of the Newtype class, defined in Control.Newtype. Example usage:+-- instances of the @Newtype@ class, defined in @ Control.Newtype @ in the+-- newtype package. Example usage: -- -- > newtype CartesianList a = CartesianList [a] -- > $(mkNewTypes [''CartesianList])@@ -20,19 +20,31 @@ -- -- > *Main> print $ underF CartesianList (\xs -> [fold xs]) ([[[4],[5],[6]], [[1],[2]], [[0]]]) -- > [[[4,1,0],[4,2,0],[5,1,0],[5,2,0],[6,1,0],[6,2,0]]]+--+----------------------------------------------------------------------------- -module Control.Newtype.TH (mkNewTypes) where+module Control.Newtype.TH ( mkNewTypes ) where +import Control.Newtype ( Newtype(pack, unpack) )++import Control.Applicative ((<$>))+import Control.Arrow ((&&&), (***))+import Data.Function ( on )+import Data.List ( groupBy, sortBy, find, nub )+import Data.Maybe ( catMaybes )+import Data.Ord ( comparing )+import Data.Generics ( Data(gmapQ) )+import Data.Generics.Schemes ( everywhere' )+import Data.Generics.Aliases ( extT, extQ )+ import Language.Haskell.TH import Language.Haskell.Meta.Utils (conName, conTypes) -import Control.Newtype (Newtype(pack, unpack))---- | Derive instances of Newtype, specified as a list of references to newtypes.+-- | Derive instances of @Newtype@, specified as a list of references to newtypes. mkNewTypes :: [Name] -> Q [Dec] mkNewTypes = mapM mkInst where- mkInst name = fmap (mkInstH name) $ reify name+ mkInst name = rewriteFamilies =<< mkInstH name <$> reify name mkInstH name (TyConI (NewtypeD context _ vs con _)) = -- Construct the instance declaration -- "instance Newtype (<newtype> a ...) (<field type> a ...) where"@@ -56,3 +68,45 @@ bndrToType :: TyVarBndr -> Type bndrToType (PlainTV x) = VarT x bndrToType (KindedTV x k) = SigT (VarT x) k++-- This rewrites type family instances to equality constraints.+rewriteFamilies :: Dec -> Q Dec+rewriteFamilies (InstanceD preds ity ds) = do+ -- Infos of every type constructor that's applied to something else.+ infos <- mapM (\(n, t) -> (n, t, ) <$> reify n) $ apps ity+ -- Each one that's determined to be a family constraint.+ fams <- mapM (\(ns, t) -> (ns, t, ) . VarT <$> newName "f")+ -- Merge all of the identical applications of the family constructor.+ . map (nub . map snd &&& (snd . fst . head))+ . groupBy ((==) `on` fst)+ . sortBy (comparing ((id *** show) . fst)) + . catMaybes $ map process infos+ -- Build resulting instance+ -- TODO: consider substituting into other predicates too?+ return $ InstanceD (preds' fams) (ity' fams) ds+ where+ process (n, t, TyConI (FamilyD _ n' _ _)) = Just ((n', t), n)+ process _ = Nothing++ preds' fams = map (\((n:_), t, v) -> EqualP v (AppT (ConT n) t)) fams ++ preds++ ity' :: [([Name], Type, Type)] -> Type+ ity' fams = everywhere' (id `extT` handleType) ity+ where+ handleType :: Type -> Type+ handleType app@(AppT (ConT n) r)+ = case find (\(ns, t, _) -> n `elem` ns && t == r) fams of+ Just (_, _, v) -> v+ Nothing -> app+ handleType t = t++ apps :: Type -> [(Name, Type)]+ apps = handleType+ where+ handleType :: Type -> [(Name, Type)]+ handleType (AppT (ConT v) r) = (v, r) : handleType r+ handleType t = generic t+ generic :: Data a => a -> [(Name, Type)]+ generic = concat . gmapQ (const [] `extQ` handleType)++rewriteFamilies d = return d
Tests.hs view
@@ -1,5 +1,11 @@-{-# LANGUAGE DatatypeContexts, FlexibleInstances, MultiParamTypeClasses,- KindSignatures, TemplateHaskell #-}+{-# LANGUAGE DatatypeContexts+ , FlexibleInstances+ , KindSignatures+ , MultiParamTypeClasses+ , TemplateHaskell+ , TypeFamilies+ , UndecidableInstances+ #-} import Control.Newtype import Control.Newtype.TH@@ -23,6 +29,14 @@ a `mappend` b = pack [x ++ y | x <- unpack a, y <- unpack b] $(mkNewTypes [''Yarn, ''Occasionally, ''ShowNum , ''Kinda, ''CartesianList])++type family V a :: *+type instance V [a] = V a+newtype Familial1 a = Familial1 (V a)+newtype Familial2 a = Familial2 (V a, V a)+newtype Familial3 a = Familial3 (V a, V (V a))++$(mkNewTypes [''Familial1, ''Familial2, ''Familial3]) pun :: (Newtype a b, Show b) => a -> IO () pun = print . unpack
newtype-th.cabal view
@@ -1,5 +1,5 @@ Name: newtype-th-Version: 0.2+Version: 0.3 Synopsis: A template haskell deriver to create Control.Newtype instances. Description: Provides a template haskell based mechanism for deriving instances of djahandarie's Control.Newtype class.@@ -22,5 +22,9 @@ Library Extensions: TemplateHaskell Exposed-modules: Control.Newtype.TH- Build-depends: base >= 3.0 && < 6, newtype, haskell-src-meta, template-haskell+ Build-depends: base >= 3.0 && < 6, + haskell-src-meta, + newtype, + syb,+ template-haskell Ghc-options: -Wall