Template Haskell/Marshall Data

toT :: [Dynamic] -> T
toT [a,b,c] = do
    a' <- fromDynamic a
    b' <- fromDynamic b
    c' <- fromDynamic c
    return (T a' b' c')

-- | 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

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)

packT :: T -> [Dynamic]
unpackT :: TTag -> [Dynamic] -> Maybe T