Template Haskell/Marshall Data
< Template Haskell
Jump to navigation
Jump to search
Revision as of 18:35, 16 February 2011 by DuncanCoutts (talk | contribs) (Undo revision 38792 by ZacBlakman (Talk))
Redundancy that motivates this example:
toT :: [Dynamic] -> T
toT [a,b,c] = do
a' <- fromDynamic a
b' <- fromDynamic b
c' <- fromDynamic c
return (T a' b' c')
Since the type of fromDynamic is different in each case, and existential types are not first-class. Here is the workaround:
-- | get the names and arities of the constructors of a datatype
--
-- this could be extended for other ConS than NormalC
getCons :: Info -> [(Name, Int)]
getCons (TyConI (DataD _ _ _ x _)) = [ (n,length ts) | NormalC n ts <- x ]
packDyn :: Name -> ExpQ
packDyn dty = do
cons <- getCons `fmap` reify dty
[| \x -> $( caseE [| x |] [ do
xs <- replicateM n (newName "x")
match (conP d (map varP xs))
(normalB $ listE [ [| toDyn $(varE x) |] | x <- xs ])
[]
| (d,n) <- cons ]
)
|]
unpackDyn :: Name -> Name -> ExpQ
unpackDyn tagt dty = do
tags <- (map fst . getCons) `fmap` reify tagt
dats <- getCons `fmap` reify dty
[| \tag ls ->
$( caseE [| (tag,ls) |] [ do
xs <- replicateM n (newName "x")
match (tupP [recP t [],listP (map varP xs)])
(normalB $ foldl (\f x -> [| $f <*> $x |])
[| pure $(conE d) |]
(map (\x -> [| fromDynamic $(varE x) |] ) xs))
[]
| (t,(d,n)) <- tags `zip` dats ]
)
|]
-- | utility for writing a function decl
-- may trigger the monomorphism restriction.
mkDec :: String -> ExpQ -> DecQ
mkDec str f = funD (mkName str) [clause [] (normalB f) []]
mkPackUnpack :: Name -> Name -> Q [Dec]
mkPackUnpack tagt dty = sequence
[mkDec ("pack" ++ n) (packDyn dty)
,mkDec ("unpack" ++ n) (unpackDyn tagt dty)
]
where n = nameBase dty
And in a separate module:
data T = A Int String
| B String Int
-- | TTag used to pick which index to unpack, an Int parameter could
-- work just as well
data TTag = ATag | BTag
$(mkPackUnpack ''TTag ''T)
Then you have functions like:
packT :: T -> [Dynamic]
unpackT :: TTag -> [Dynamic] -> Maybe T
An unrelated approach (left as an exercise to the reader :) is the use of a continuation passing style with -XRankNPolymorphism to accomplish the same.