module Data.Packed.TH.Start (startFName, genStart) where

import Data.Packed.Needs
import Data.Packed.Packable (write)
import Data.Packed.TH.Flag (PackingFlag (..))
import Data.Packed.TH.Utils
import Data.Word (Word8)
import Language.Haskell.TH

-- | For a constructor 'Leaf', will generate the function name 'startLeaf'
startFName :: Name -> Name
startFName :: Name -> Name
startFName Name
conName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"start" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
sanitizeConName Name
conName

-- | Generates a function that prepares a 'Data.Packed.Needs' to receive values from a data constructor.
--
-- __Example:__
--
-- For the 'Tree' data type, it generates the following functions
--
-- @
-- startLeaf :: NeedsBuilder (Tree a ': r) t (a ': r) t
-- startLeaf = 'mkNeedsBuilder' (\n -> runBuilder (write (0 :: Word8) ('unsafeCastNeeds' n)))
--
-- startNode :: NeedsBuilder (Tree a ': r) t (Tree a ': Tree a ': r) t
-- startNode = 'mkNeedsBuilder' (\n -> runBuilder (write (1 :: Word8) ('unsafeCastNeeds' n)))
-- @
genStart ::
    [PackingFlag] ->
    -- | Constructor to generate the function for
    Con ->
    -- | The 'Tag' (byte) to write for this constructor
    Tag ->
    Q [Dec]
genStart :: [PackingFlag] -> Con -> Tag -> Q [Dec]
genStart [PackingFlag]
flags Con
con Tag
tag = do
    branchType <- Con -> [PackingFlag] -> Q [Type]
getBranchTyList Con
con [PackingFlag]
flags
    let (conName, _) = getNameAndBangTypesFromCon con
        fName = Name -> Name
startFName Name
conName
    (DataConI _ conType _) <- reify conName
    sig <-
        let r = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"r"
            t = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"t"
            destNeedsTypeParams = (Type -> Q Type -> Q Type) -> Q Type -> [Type] -> Q Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Type
field Q Type
rest -> [t|$(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
field) ': $Q Type
rest|]) Q Type
r [Type]
branchType
            parentType = Type -> Type
getParentTypeFromConstructorType Type
conType
         in [t|NeedsBuilder ($(return parentType) ': $r) $t $destNeedsTypeParams $t|]
    expr <- [|mkNeedsBuilder (\n -> runBuilder (write (tag :: Word8)) (unsafeCastNeeds n))|]
    return
        [ SigD fName sig
        , FunD fName [Clause [] (NormalB expr) []]
        ]