PackCon.hs

module Data.Packed.TH.PackCon (genConstructorPackers) where

import Data.Packed.Needs
import Data.Packed.Packable
import Data.Packed.Packed
import Data.Packed.TH.Flag (PackingFlag)
import Data.Packed.TH.Utils
import Data.Packed.TH.WriteCon
import Language.Haskell.TH

-- | Generates a function that serialises an applied data constructor
--
-- The function calls the functions generated by 'Data.Packed.TH.genConWrite'
--
-- __Example:__
--
-- For the 'Tree' data type, it generates the following functions
--
-- @
-- packLeaf :: ('Packable' a) => a -> 'Data.Packed' '[Tree a]
-- packLeaf n = 'finish' ('withEmptyNeeds' (writeLeaf n))
--
-- packNode :: ('Packable' a) => Tree a -> Tree a -> 'Data.Packed' '[Tree a]
-- packNode t1 t2 = 'finish' ('withEmptyNeeds' (writeNode t1 t2))
-- @
genConstructorPackers :: [PackingFlag] -> Name -> Q [Dec]
genConstructorPackers flags tyName = do
    (TyConI (DataD _ _ _ _ cs _)) <- reify tyName
    packers <-
        mapM
            ( \con ->
                let (conName, bt) = getNameAndBangTypesFromCon con
                 in genConstructorPacker flags conName (snd <$> bt)
            )
            cs
    return $ concat packers

packConFName :: Name -> Name
packConFName conName = mkName $ "pack" ++ sanitizeConName conName

genConstructorPacker :: [PackingFlag] -> Name -> [Type] -> Q [Dec]
genConstructorPacker flags conName argTypes = do
    varNames <- mapM (\_ -> newName "t") argTypes
    writeExp <- (foldl (\rest p -> appE rest (varE p)) (varE $ conWriteFName conName) varNames)
    body <- [|finish (withEmptyNeeds $(return writeExp))|]
    signature <- genConstructorPackerSig flags conName argTypes
    return
        [ signature
        , FunD (packConFName conName) [Clause (VarP <$> varNames) (NormalB body) []]
        ]

genConstructorPackerSig :: [PackingFlag] -> Name -> [Type] -> Q Dec
genConstructorPackerSig _ conName argTypes = do
    (DataConI _ _ tyName) <- reify conName
    (ty, typeParameterNames) <- resolveAppliedType tyName
    constraints <- mapM (\tyVarName -> [t|Packable $(varT tyVarName)|]) typeParameterNames
    signature <- foldr (\p rest -> [t|$(return p) -> $rest|]) [t|Packed '[$(return ty)]|] argTypes
    return $ SigD (packConFName conName) $ ForallT [] constraints signature