module Data.Packed.TH.Skip (genSkip, skipFName) where

import Data.Packed.FieldSize (skipWithFieldSize)
import Data.Packed.Reader (PackedReader)
import qualified Data.Packed.Reader as R
import Data.Packed.Skippable (Skippable (skip))
import Data.Packed.TH.Case (caseFName)
import Data.Packed.TH.Flag (PackingFlag (..))
import Data.Packed.TH.Utils
import Language.Haskell.TH

-- For a data type 'Tree', will generate the function name 'skipTree'
skipFName :: Name -> Name
skipFName :: Name -> Name
skipFName Name
tyName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"skip" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
sanitizeConName Name
tyName

-- | Generates an function to skip a value of the given type in a 'Data.Packed.Packed'
--
--  __Example:__
--
-- For the 'Tree' data type, it generates the following function:
--
-- @
-- skipTree :: ('Data.Packed.Skippable' a) => 'Data.Packed.PackedReader' '[Tree a] r ()
-- skipTree = caseTree
--      'Data.Packed.Skip.skip'
--      ('skipTree' >> 'skipTree')
-- @
genSkip :: [PackingFlag] -> Name -> Q [Dec]
genSkip :: [PackingFlag] -> Name -> Q [Dec]
genSkip [PackingFlag]
flags Name
tyName = do
    let fName :: Name
fName = Name -> Name
skipFName Name
tyName
    lambdas <- [PackingFlag] -> Name -> Q [Exp]
genSkipLambdas [PackingFlag]
flags Name
tyName
    funExpr <-
        foldl
            (\Q Exp
rest Exp
arg -> [|$Q Exp
rest $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
arg)|])
            (varE $ caseFName tyName)
            lambdas
    let fun = Name -> [Clause] -> Dec
FunD Name
fName [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
funExpr) []]
    signature <- genSkipSignature tyName
    return [signature, fun]

-- Generates all the lambda functions we will need, to skip using caseTree
genSkipLambdas :: [PackingFlag] -> Name -> Q [Exp]
genSkipLambdas :: [PackingFlag] -> Name -> Q [Exp]
genSkipLambdas [PackingFlag]
flags Name
tyName = do
    branchTypes <- Name -> [PackingFlag] -> Q [[Type]]
getBranchesTyList Name
tyName [PackingFlag]
flags
    genSkipLambda `mapM` branchTypes

-- generates a single lambda to use with caseTree for our skip method
genSkipLambda :: [Type] -> Q Exp
genSkipLambda :: [Type] -> Q Exp
genSkipLambda [Type]
types = [Type] -> Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => [Type] -> m Exp -> m Exp
go [Type]
types [|R.return ()|]
  where
    go :: [Type] -> m Exp -> m Exp
go [] m Exp
end = m Exp
end
    go [Type
_] m Exp
end = [|skip R.>> $m Exp
end|]
    go (Type
t1 : Type
t2 : [Type]
ts) m Exp
end =
        if Type -> Bool
typeIsFieldSize Type
t1
            then [|skipWithFieldSize R.>> $([Type] -> m Exp -> m Exp
go [Type]
ts m Exp
end)|]
            else [|skip R.>> $([Type] -> m Exp -> m Exp
go (Type
t2 Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
ts) m Exp
end)|]

-- Generates the following function signature for a data type 'Tree'
-- skipTree :: ('Data.Packed.Skippable' a) => 'Data.Packed.PackedReader' '[Tree a] r ()
genSkipSignature :: Name -> Q Dec
genSkipSignature :: Name -> Q Dec
genSkipSignature Name
tyName = do
    (sourceType, typeParameterNames) <- Name -> Q (Type, [Name])
resolveAppliedType Name
tyName
    let fName = Name -> Name
skipFName Name
tyName
        -- Type variables for Needs
        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"
        -- Define Skippable constraints on each of the type parameters
        constraints = (Name -> Q Type) -> [Name] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\Name
tyVarName -> [t|Skippable $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
tyVarName)|]) [Name]
typeParameterNames
        signature = [t|PackedReader '[$(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
sourceType)] $Q Type
r ()|]
    sigD fName (forallT [] constraints signature)