diff --git a/Control/Newtype/TH.hs b/Control/Newtype/TH.hs --- a/Control/Newtype/TH.hs +++ b/Control/Newtype/TH.hs @@ -1,43 +1,50 @@ {-# LANGUAGE TemplateHaskell #-} -{- | -This module provides a template Haskell based mechanism for deriving -instances of the Newtype class, defined in Control.Newtype. Example usage: -> newtype CartesianList a = CartesianList [a] -> $(mkNewTypes [''CartesianList]) -> -> instance Monoid (CartesianList a) where -> mempty = pack [[]] -> a `mappend` b = pack [x ++ y | x <- unpack a, y <- unpack b] +----------------------------------------------------------------------------- +-- | +-- Module : Control.Newtype.TH +-- Copyright : Michael Sloan 2011 +-- +-- Maintainer : Michael Sloan (mgsloan@gmail.com) +-- Portability : unportable +-- +-- This module provides a template Haskell based mechanism for deriving +-- instances of the Newtype class, defined in Control.Newtype. Example usage: +-- +-- > newtype CartesianList a = CartesianList [a] +-- > $(mkNewTypes [''CartesianList]) +-- > +-- > instance Monoid (CartesianList a) where +-- > mempty = pack [[]] +-- > a `mappend` b = pack [x ++ y | x <- unpack a, y <- unpack b] +-- +-- > *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]]] -> *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 -import Control.Monad (liftM) - 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. mkNewTypes :: [Name] -> Q [Dec] -mkNewTypes = liftM concat . mapM (\n -> reify n >>= return . mkInst) - where mkInst (TyConI (NewtypeD context name vs con _)) = - [InstanceD context - -- Construct the class declaration - -- "class Newtype ( a ...) ( a ...) where" - (AppT (AppT (ConT $ mkName "Control.Newtype.Newtype") - $ bndrsToType (ConT name) vs) - . head $ conTypes con) - (defs (mkName "x") (conName con))] - mkInst _ = [] - defs xnam cnam = - [ FunD (mkName "unpack") - [Clause [ConP cnam [VarP xnam]] (NormalB $ VarE xnam) []] - , FunD (mkName "pack") - [Clause [] (NormalB $ (ConE cnam)) []] - ] +mkNewTypes = mapM mkInst + where + mkInst name = fmap (mkInstH name) $ reify name + mkInstH name (TyConI (NewtypeD context _ vs con _)) = + -- Construct the instance declaration + -- "instance Newtype ( a ...) ( 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)) []] + ] + xname = mkName "x" -- Given a root type and a list of type variables, converts for use as -- parameters to the newtype's type in the instance head. @@ -45,7 +52,7 @@ bndrsToType = foldl (\x y -> AppT x $ bndrToType y) -- This converts a type variable binding to a type. Preserving kind --- signatures is probably unecessary, but we might as well. +-- signatures is probably unnecessary, but we might as well. bndrToType :: TyVarBndr -> Type bndrToType (PlainTV x) = VarT x bndrToType (KindedTV x k) = SigT (VarT x) k diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,13 @@ +http://hackage.haskell.org/package/newtype-th + +Provides a template haskell based mechanism for +deriving instances of djahandarie's Control.Newtype class. + +To build / install: + +chmod ugo+x Setup.hs +./Setup.hs configure --user +./Setup.hs build +./Setup.hs install + +See the haddock or Control/Newtype/TH.hs for documentation. diff --git a/Tests.hs b/Tests.hs new file mode 100644 --- /dev/null +++ b/Tests.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DatatypeContexts, FlexibleInstances, MultiParamTypeClasses, + KindSignatures, TemplateHaskell #-} + +import Control.Newtype +import Control.Newtype.TH +import Data.Monoid +import Data.Foldable (fold) + +newtype Yarn = Yarn String + +newtype Occasionally a = Occasionally (Maybe a) + +-- Test that 'DatatypeContexts' are used as class constraints, despite this +-- extension being deprecated. +newtype (Num a, Show b) => ShowNum a b = ShowNum { pump :: a -> b } + +newtype Kinda (a :: * -> *) (b :: *) = Kinda b + +newtype CartesianList a = CartesianList [[a]] deriving Show + +instance Monoid (CartesianList a) where + mempty = pack [[]] + a `mappend` b = pack [x ++ y | x <- unpack a, y <- unpack b] + +$(mkNewTypes [''Yarn, ''Occasionally, ''ShowNum , ''Kinda, ''CartesianList]) + +pun :: (Newtype a b, Show b) => a -> IO () +pun = print . unpack + +klift :: Int -> Kinda Maybe Int +klift = Kinda + +single x = [x] + +main :: IO () +main = do + -- Let's see if we can use them. Going to assume that pack works.. + pun $ Yarn "ball" + pun . Occasionally $ Just "ice" + print $ unpack (ShowNum show) 42 + pun . klift $ 5 + print $ underF CartesianList (\xs -> [fold xs]) + [[[4],[5],[6]], [[1],[2]], [[0]]] diff --git a/newtype-th.cabal b/newtype-th.cabal --- a/newtype-th.cabal +++ b/newtype-th.cabal @@ -1,6 +1,6 @@ Name: newtype-th -Version: 0.1 -Synopsis: Provides a template haskell deriver for use with Control.Newtype. +Version: 0.2 +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. License: BSD3 @@ -8,10 +8,11 @@ Author: Michael Sloan Maintainer: Michael Sloan Homepage: http://github.com/mgsloan/newtype-th --- Copyright: +Copyright: Michael Sloan 2011 Category: Control Build-type: Simple --- Extra-source-files: +Extra-source-files: Tests.hs +Data-files: README Cabal-version: >=1.6 Bug-Reports: http://github.com/mgsloan/newtype-th/issues Source-Repository head