{-# LANGUAGE TemplateHaskell #-}
module Data.Serialize.Versioned.Primitive.TH ( unversionedPrimitiveFor
                                             , unversionedPrimitiveFor'
                                             , unversionedPrimitivesFor
                                             , unversionedPrimitivesFor'
                                             , unversionedPrimitiveContainerFor
                                             , unversionedPrimitiveContainerFor'
                                             , unversionedPrimitiveContainersFor
                                             , unversionedPrimitiveContainersFor'
                                             , definePrimitiveTupleFor
                                             , definePrimitiveTuplesFor
                                             ) where

import Data.Foldable (foldl')
import Data.Serialize ( get
                      , put
                      )
import Language.Haskell.TH ( DecsQ
                           , ExpQ
                           , Name
                           , TypeQ
                           , appT
                           , clause
                           , conT
                           , funD
                           , instanceD
                           , newName
                           , normalB
                           , tupE
                           , tupP
                           , tupleT
                           , varE
                           , varP
                           , varT
                           )

import Data.Serialize.Versioned.Get
import Data.Serialize.Versioned.Put
import Data.Serialize.Versioned.Versioned

unversionedPrimitiveFor :: Name -> Name -> Name -> TypeQ -> DecsQ
unversionedPrimitiveFor pvs getPrimitiveVersioned putPrimitiveVersioned t = do
  d <- newName "d"
  v <- newName "v"
  (map pure <$>
    [d|
      $(varP getPrimitiveVersioned) = getUnversioned get
      $(varP putPrimitiveVersioned) = putUnversioned . put
      |]
    ) >>=
    fmap pure .
    instanceD (pure [])
    [t| $(conT pvs) $(varT d) $(varT v) $t |]

unversionedPrimitiveFor' :: Name -> Name -> Name -> Name -> DecsQ
unversionedPrimitiveFor' pvs gpv ppv = unversionedPrimitiveFor pvs gpv ppv . conT

unversionedPrimitivesFor :: Name -> Name -> Name -> [TypeQ] -> DecsQ
unversionedPrimitivesFor pvs gpv ppv =
  fmap concat . traverse (unversionedPrimitiveFor pvs gpv ppv)

unversionedPrimitivesFor' :: Name -> Name -> Name -> [Name] -> DecsQ
unversionedPrimitivesFor' pvs gpv ppv =
  fmap concat . traverse (unversionedPrimitiveFor' pvs gpv ppv)

unversionedPrimitiveContainerFor :: Name -> Name -> Name -> TypeQ -> ExpQ -> ExpQ -> DecsQ
unversionedPrimitiveContainerFor pvs gpv ppv c putContainer getContainer = do
  d <- newName "d"
  t <- newName "t"
  v <- newName "v"
  xs <- newName "xs"
  let gpvD = funD gpv [clause []
                       (normalB
                        [e|
                          getUnversionedResumable $ \resume ->
                            $getContainer $ resume getVersioned
                          |]
                       ) []
                      ]
      ppvD = funD ppv [clause [varP xs]
                       (normalB
                        [e|
                         putUnversionedResumable $ \resume ->
                            $putContainer (resume . putVersioned) $(varE xs)
                          |]
                       ) []
                      ]
  vsConstraint <- [t| VersionedSerialize $(varT d) $(varT t) |]
  vConstraint <- [t| CurrentStructureVersion $(varT d) $(varT t) ~ $(varT v) |]
  pure <$>
    instanceD
    (pure [vsConstraint, vConstraint])
    [t| $(conT pvs) $(varT d) $(varT v) ($c $(varT t)) |]
    [gpvD, ppvD]

unversionedPrimitiveContainerFor' :: Name -> Name -> Name -> Name -> ExpQ -> ExpQ -> DecsQ
unversionedPrimitiveContainerFor' pvs gpv ppv = unversionedPrimitiveContainerFor pvs gpv ppv . conT

unversionedPrimitiveContainersFor :: Name -> Name -> Name -> [(TypeQ, ExpQ, ExpQ)] -> DecsQ
unversionedPrimitiveContainersFor pvs gpv ppv =
  fmap concat . traverse (\(t, g, p) -> unversionedPrimitiveContainerFor pvs gpv ppv t g p)

unversionedPrimitiveContainersFor' :: Name -> Name -> Name -> [(Name, ExpQ, ExpQ)] -> DecsQ
unversionedPrimitiveContainersFor' pvs gpv ppv =
  unversionedPrimitiveContainersFor pvs gpv ppv . map (\(n, g, p) -> (conT n, g, p))

tupT :: [Name] -> TypeQ
tupT ts = foldl' (\acc var -> appT acc (varT var)) (tupleT $ length ts) ts

definePrimitiveTupleFor :: Name -> Name -> Name -> Int -> DecsQ
definePrimitiveTupleFor pvs gpv ppv n = do
  let newTupleNames = traverse (newName . pure) ['a' .. toEnum (fromEnum 'a' + pred n)]
  tupleTypeNames@(aTN : restTN) <- newTupleNames
  let fullT = tupT tupleTypeNames
      restT = tupT restTN
      bothT = [t| ($(varT aTN), $restT) |]
  tupleValNames@(aName : restNames) <- newTupleNames
  let bothP = [p| ($(varP aName), $(tupP $ map varP restNames)) |]
      fullE = tupE $ map varE tupleValNames
      fullP = tupP $ map varP tupleValNames
      bothE = [e| ($(varE aName), $(tupE $ map varE restNames)) |]
  d <- newName "d"
  v <- newName "v"
  let gpvD = funD gpv [ clause []
                        ( normalB
                          [e| fmap (\ $bothP -> $fullE) getVersioned |]
                        ) []
                      ]
      ppvD = funD ppv [ clause [fullP]
                        ( normalB
                          [e| putVersioned $bothE |]
                        ) []
                      ]
  vsConstraint <- [t| VersionedSerialize $(varT d) $bothT |]
  vConstraint <- [t| CurrentStructureVersion $(varT d) $bothT ~ $(varT v) |]
  pure <$>
    instanceD
    (pure [vsConstraint, vConstraint])
    [t| $(conT pvs) $(varT d) $(varT v) $fullT |]
    [gpvD, ppvD]

definePrimitiveTuplesFor :: Name -> Name -> Name -> Int -> DecsQ
definePrimitiveTuplesFor pvs gpv ppv n = concat <$> traverse (definePrimitiveTupleFor pvs gpv ppv) [3..n]