From 92c75d44a1306f47d5097ccf11e768bab88236fd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Pawe=C5=82=20Nowak?= Date: Sat, 22 Nov 2014 21:55:11 +0100 Subject: [PATCH] Generate HFoldable instances using TH. --- Data/Tuple/Morph.hs | 32 ++++++++++-------------- Data/Tuple/Morph/Append.hs | 2 ++ Data/Tuple/Morph/TH.hs | 50 ++++++++++++++++++++++++++++++++++---- 3 files changed, 60 insertions(+), 24 deletions(-) diff --git a/Data/Tuple/Morph.hs b/Data/Tuple/Morph.hs index 0592795..813d6a6 100644 --- a/Data/Tuple/Morph.hs +++ b/Data/Tuple/Morph.hs @@ -21,12 +21,12 @@ Stability : experimental Allows you to flatten, unflatten and morph tuples of matching types. -Note: by design units are ignored. For example @(Int, (), Char)@ is - the same as @(Int, Char)@. +Note: by design units are ignored. For example @(Int, (), Char)@ is the same as @(Int, Char)@. -} module Data.Tuple.Morph ( -- * Morphing tuples. morph, + sizeLimit, -- * Converting between tuples and HLists. Rep, @@ -46,11 +46,11 @@ import Data.Tuple.Morph.Append import Data.Tuple.Morph.TH -- | Recurisvely break down a tuple type, representing it as a type list. -$(mkRep 13) +$(mkRep sizeLimit) -- | Morph a tuple to some isomorphic tuple with the same order of types. -- --- Works with arbitrary nested tuples, each tuple can have size up to 13. +-- Works with arbitrary nested tuples, each tuple can have size up to 'sizeLimit'. -- -- >>> morph ("a", ("b", "c")) :: (String, String, String) -- ("a","b","c") @@ -116,17 +116,9 @@ class HUnfoldable t where -- | Builds a structure from a heterogenous list and yields the leftovers. hListParser :: HParser (Rep t) t -instance (HFoldable a, HFoldable b, HFoldable c, HFoldable d, HFoldable e) => HFoldable (a, b, c, d, e) where - toHList (a, b, c, d, e) = toHList a ++@ toHList b ++@ toHList c ++@ toHList d ++@ toHList e +-- HFoldable instances. -instance (HFoldable a, HFoldable b, HFoldable c, HFoldable d) => HFoldable (a, b, c, d) where - toHList (a, b, c, d) = toHList a ++@ toHList b ++@ toHList c ++@ toHList d - -instance (HFoldable a, HFoldable b, HFoldable c) => HFoldable (a, b, c) where - toHList (a, b, c) = toHList a ++@ toHList b ++@ toHList c - -instance (HFoldable a, HFoldable b) => HFoldable (a, b) where - toHList (a, b) = toHList a ++@ toHList b +$(mapM (mkHFoldableInst ''HFoldable) [sizeLimit, sizeLimit-1 .. 2]) instance HFoldable () where toHList () = HNil @@ -134,18 +126,20 @@ instance HFoldable () where instance (Rep a ~ '[a]) => HFoldable a where toHList a = HCons a HNil +-- HUnfoldable instances. instance (HUnfoldable a, HUnfoldable b, HUnfoldable c, HUnfoldable d) => HUnfoldable (a, b, c, d) where - hListParser = case appendRightId (Proxy :: Proxy (Rep d)) of - Refl -> hListParser `bindMI` (\(a, b, c) -> - hListParser `bindMI` (\d -> + hListParser = case appendRightId (Proxy :: Proxy (Rep b ++ Rep c ++ Rep d)) of + Refl -> hListParser `bindMI` (\a -> + hListParser `bindMI` (\(b, c, d) -> returnMI (a, b, c, d))) instance (HUnfoldable a, HUnfoldable b, HUnfoldable c) => HUnfoldable (a, b, c) where hListParser = case appendRightId (Proxy :: Proxy (Rep c)) of - Refl -> hListParser `bindMI` (\(a, b) -> + Refl -> hListParser `bindMI` (\a -> + hListParser `bindMI` (\b -> hListParser `bindMI` (\c -> - returnMI (a, b, c))) + returnMI (a, b, c)))) instance (HUnfoldable a, HUnfoldable b) => HUnfoldable (a, b) where hListParser = case appendRightId (Proxy :: Proxy (Rep b)) of diff --git a/Data/Tuple/Morph/Append.hs b/Data/Tuple/Morph/Append.hs index 8cd1003..fe61c64 100644 --- a/Data/Tuple/Morph/Append.hs +++ b/Data/Tuple/Morph/Append.hs @@ -20,6 +20,8 @@ import Data.Proxy import Data.Type.Equality import Unsafe.Coerce +infixr 5 ++, ++@ + -- | Appends two type lists. type family (++) (a :: [k]) (b :: [k]) :: [k] where '[] ++ b = b diff --git a/Data/Tuple/Morph/TH.hs b/Data/Tuple/Morph/TH.hs index a615d4a..ad6fc52 100644 --- a/Data/Tuple/Morph/TH.hs +++ b/Data/Tuple/Morph/TH.hs @@ -10,11 +10,30 @@ License : MIT Maintainer : Paweł Nowak Stability : experimental -} -module Data.Tuple.Morph.TH where +module Data.Tuple.Morph.TH ( + sizeLimit, + mkRep, + mkHFoldableInst + ) where +import Control.Monad import Data.Tuple.Morph.Append import Language.Haskell.TH +-- | Generates names starting with letters of the alphabet, then +-- pairs of letters, triples of letters and so on. +mkNames :: Int -> [Name] +mkNames n = take n $ map mkName $ [1 ..] >>= flip replicateM ['a' .. 'z'] + +tupleFrom :: [Type] -> Type +tupleFrom vars = foldl AppT (TupleT (length vars)) vars + +-- | Size of the largest tuple that this library will work with. Equal to 13. +-- +-- Note that size of ((((((1, 1), 1), 1), 1), 1), 1) is 2, not 7. +sizeLimit :: Int +sizeLimit = 13 + -- | Creates the "Rep" type family. mkRep :: Int -> Q [Dec] mkRep n = fmap (:[]) @@ -31,13 +50,34 @@ mkRep n = fmap (:[]) repName = mkName "Rep" append = VarT ''(++) mkEqn k = do - names <- sequence $ take k $ map (newName . (:[])) ['a' .. 'z'] - let -- a, b, c, ... + let names = mkNames k + -- a, b, c, ... vars = map VarT names -- (a, b, c, ...) - tuple = foldl AppT (TupleT k) vars + tuple = tupleFrom vars -- Rep a, Rep b, Rep c, ... reps = map (AppT (ConT repName)) vars -- Rep a ++ Rep b ++ Rep c ++ ... - rep = foldl1 (\x y -> AppT (AppT append x) y) reps + rep = foldr1 (\x y -> AppT (AppT append x) y) reps return $ TySynEqn [tuple] rep + +-- | Creates a HFoldable instance for @k@ element tuples. +mkHFoldableInst :: Name -> Int -> Q Dec +mkHFoldableInst className k = do + let names = mkNames k + -- types a, b, c, ... + vars = map VarT names + -- type (a, b, c, ...) + tuple = tupleFrom vars + -- pattern (a, b, c, ...) + tupleP = TupP $ map VarP names + toHListName = mkName "toHList" + -- toHList a, toHList b, toHList c, ... + hlists = map (\n -> AppE (VarE toHListName) (VarE n)) names + -- toHList a ++@ toHList b ++@ toHList c ++@ ... + body = NormalB $ foldr1 (\x y -> AppE (AppE (VarE '(++@)) x) y) hlists + toHList = FunD toHListName [Clause [tupleP] body []] + return $ InstanceD + [ClassP className [var] | var <- vars] + (AppT (ConT className) tuple) + [toHList]