newtype-th 0.3 → 0.3.1
raw patch · 3 files changed
+91/−28 lines, 3 files
Files
- Control/Newtype/TH.hs +42/−27
- Tests.hs +48/−0
- newtype-th.cabal +1/−1
Control/Newtype/TH.hs view
@@ -28,7 +28,7 @@ import Control.Newtype ( Newtype(pack, unpack) ) import Control.Applicative ((<$>))-import Control.Arrow ((&&&), (***))+import Control.Arrow ((&&&)) import Data.Function ( on ) import Data.List ( groupBy, sortBy, find, nub ) import Data.Maybe ( catMaybes )@@ -40,23 +40,28 @@ import Language.Haskell.TH import Language.Haskell.Meta.Utils (conName, conTypes) --- | 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 = rewriteFamilies =<< mkInstH name <$> reify name- mkInstH name (TyConI (NewtypeD context _ vs con _)) =- -- Construct the instance declaration- -- "instance Newtype (<newtype> a ...) (<field type> a ...) where"- InstanceD context- (foldl1 AppT [ConT ''Newtype, bndrsToType (ConT name) vs, head $ conTypes con])- (defs (conName con))- mkInstH name _ = error $ show name ++ " is not a Newtype"- defs cname =- [ FunD 'unpack [Clause [ConP cname [VarP xname]] (NormalB $ VarE xname) []]- , FunD 'pack [Clause [] (NormalB (ConE cname)) []]- ]+mkNewTypes = mapM (\n -> rewriteFamilies =<< mkInstH n <$> reify n)+ where+--Construct the instance declaration+-- "instance Newtype (<newtype> a ...) (<field type> a ...) where"+ mkInstH name (TyConI (NewtypeD context _ vs con _))+ = InstanceD context+ ( foldl1 AppT [ ConT ''Newtype+ , bndrsToType (ConT name) vs+ , head $ conTypes con+ ] )+ [ FunD 'pack [ Clause [] + (NormalB $ ConE cname) [] ]+ , FunD 'unpack [ Clause [ConP cname [VarP xname]] + (NormalB $ VarE xname) [] ]+ ]+ where+ cname = conName con xname = mkName "x"+ mkInstH name _ = error $ show name ++ " is not a Newtype" -- Given a root type and a list of type variables, converts for use as -- parameters to the newtype's type in the instance head.@@ -74,22 +79,27 @@ 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.+ -- Every unique family constraint found, each with a new name. 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?+ . mergeApps . catMaybes $ map justFamily infos+ -- Build resulting instance. return $ InstanceD (preds' fams) (ity' fams) ds where- process (n, t, TyConI (FamilyD _ n' _ _)) = Just ((n', t), n)- process _ = Nothing+-- Selects for just family declarations, and yields the name used to+-- refer to it, along with the cannonical reified name and the passed+-- type.+ justFamily :: (Name, Type, Info) -> Maybe (Name, (Name, Type))+ justFamily (n, t, TyConI (FamilyD _ n' _ _)) = Just (n, (n', t))+ justFamily _ = Nothing - preds' fams = map (\((n:_), t, v) -> EqualP v (AppT (ConT n) t)) fams ++ preds+-- Merges all of the identical applications of the family constructor.+ mergeApps :: [(Name, (Name, Type))] -> [([Name], Type)]+ mergeApps = map (nub . map fst &&& (snd . snd . head))+ . groupBy ((==) `on` snd) . sortBy (comparing snd) + preds' = (preds ++)+ . map (\((n:_), t, v) -> EqualP v (AppT (ConT n) t))+ ity' :: [([Name], Type, Type)] -> Type ity' fams = everywhere' (id `extT` handleType) ity where@@ -100,11 +110,16 @@ Nothing -> app handleType t = t + -- Enumerates all of the found instances of an application of a+ -- type constructor. apps :: Type -> [(Name, Type)] apps = handleType where handleType :: Type -> [(Name, Type)] handleType (AppT (ConT v) r) = (v, r) : handleType r+ handleType (AppT (SigT t _) r) = handleType (AppT t r)+--TODO: any conceivable reason to special-case (AppT (ForallT ...)) ?+-- handleType (AppT (SigT t) r) = handleType t = generic t generic :: Data a => a -> [(Name, Type)] generic = concat . gmapQ (const [] `extQ` handleType)
Tests.hs view
@@ -7,6 +7,54 @@ , UndecidableInstances #-} +{- output of "runhaskell -ddump-splices Tests.hs"++Tests.hs:1:14:+ Warning: -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language.+Tests.hs:1:1: Splicing declarations+ mkNewTypes ['Yarn, 'Occasionally, 'ShowNum, 'Kinda, 'CartesianList]+ ======>+ Tests.hs:31:3-75+ instance Newtype Yarn String where+ { unpack (Yarn x) = x+ pack = Yarn }+ instance Newtype (Occasionally a_a2fx) (Maybe a_a2fx) where+ { unpack (Occasionally x) = x+ pack = Occasionally }+ instance (Num a_a2fv, Show b_a2fw) =>+ Newtype (ShowNum a_a2fv b_a2fw) (a_a2fv -> b_a2fw) where+ { unpack (ShowNum x) = x+ pack = ShowNum }+ instance Newtype (Kinda (a_a2ft :: * -> *) b_a2fu) b_a2fu where+ { unpack (Kinda x) = x+ pack = Kinda }+ instance Newtype (CartesianList a_a2fs) [[a_a2fs]] where+ { unpack (CartesianList x) = x+ pack = CartesianList }+Tests.hs:1:1: Splicing declarations+ mkNewTypes ['Familial1, 'Familial2, 'Familial3]+ ======>+ Tests.hs:39:3-52+ instance f_a2w8 ~ (V a_a2un) =>+ Newtype (Familial1 a_a2un) f_a2w8 where+ { unpack (Familial1 x) = x+ pack = Familial1 }+ instance f_a2w9 ~ (V a_a2um) =>+ Newtype (Familial2 a_a2um) (f_a2w9, f_a2w9) where+ { unpack (Familial2 x) = x+ pack = Familial2 }+ instance (f_a2wa ~ (V a_a2ul), f_a2wb ~ (V (V a_a2ul))) =>+ Newtype (Familial3 a_a2ul) (f_a2wa, f_a2wb) where+ { unpack (Familial3 x) = x+ pack = Familial3 }++"ball"+Just "ice"+"42"+5+[[[4,1,0],[4,2,0],[5,1,0],[5,2,0],[6,1,0],[6,2,0]]]+-}+ import Control.Newtype import Control.Newtype.TH import Data.Monoid
newtype-th.cabal view
@@ -1,5 +1,5 @@ Name: newtype-th-Version: 0.3+Version: 0.3.1 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.