mirror of
https://github.com/ilyakooo0/tuple-morph.git
synced 2024-09-11 06:25:44 +03:00
Generate HFoldable instances using TH.
This commit is contained in:
parent
2c2b177958
commit
92c75d44a1
@ -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
|
||||
|
@ -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
|
||||
|
@ -10,11 +10,30 @@ License : MIT
|
||||
Maintainer : Paweł Nowak <pawel834@gmail.com>
|
||||
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]
|
||||
|
Loading…
Reference in New Issue
Block a user