{-# LANGUAGE TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables, InstanceSigs, PolyKinds, DataKinds, GADTs, FlexibleContexts #-}
{-# LANGUAGE DefaultSignatures, AllowAmbiguousTypes #-}
{-|
Description  : Serialization of primitive types
Copyright    : 2020 Sven Bartscher
License      : MPL-2.0
Maintainer   : sven.bartscher@weltraumschlangen.de
Stability    : experimental
Portability  : GHC

This module provides serialization and deserialization operations for
primitive types.
-}
module Data.Serialize.Versioned.Primitive ( -- * Primitive serialization class
                                            PrimitiveVersionedSerialize(..)
                                            -- * Template Haskell helpers
                                            --
                                            -- | These macros are useful
                                            -- when defining primitive
                                            -- serialization instances
                                            -- based on existing
                                            -- 'Data.Serialize.Serialize'
                                            -- instances.
                                          , unversionedPrimitive
                                          , unversionedPrimitive'
                                          , unversionedPrimitives
                                          , unversionedPrimitives'
                                          , unversionedPrimitiveContainer
                                          , unversionedPrimitiveContainer'
                                          , unversionedPrimitiveContainers
                                          , unversionedPrimitiveContainers'
                                          ) where

import Control.Applicative (liftA2)
import Data.Array (Array)
import Data.Array.IArray (IArray)
import Data.Array.Unboxed (UArray)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as B.L
import Data.ByteString.Short (ShortByteString)
import Data.Int ( Int8
                , Int16
                , Int32
                , Int64
                )
import Data.IntMap (IntMap)
import Data.IntSet (IntSet)
import Data.Ix (Ix)
import Data.Map (Map)
import Data.Monoid ( All
                   , Any
                   , Dual
                   , First
                   , Last
                   , Product
                   , Sum
                   )
import Data.Ratio ( Ratio
                  , (%)
                  , denominator
                  , numerator
                  )
import Data.Sequence (Seq)
import Data.Serialize ( getEitherOf
                      , getIArrayOf
                      , getIntMapOf
                      , getListOf
                      , getMapOf
                      , getMaybeOf
                      , getSeqOf
                      , getSetOf
                      , getTreeOf
                      , getTwoOf
                      , putEitherOf
                      , putIArrayOf
                      , putIntMapOf
                      , putListOf
                      , putMapOf
                      , putMaybeOf
                      , putSeqOf
                      , putSetOf
                      , putTreeOf
                      , putTwoOf
                      )
import Data.Set (Set)
import Data.Tree (Tree)
import Data.Word ( Word8
                 , Word16
                 , Word32
                 , Word64
                 )
import GHC.Generics ( Generic
                    , Rep
                    , from
                    , to
                    )
import GHC.Natural (Natural)
import GHC.TypeNats (Nat)
import Language.Haskell.TH ( DecsQ
                           , ExpQ
                           , Name
                           , TypeQ
                           )

import Data.Serialize.Versioned.Get
import Data.Serialize.Versioned.Primitive.TH
import Data.Serialize.Versioned.Put
import Data.Serialize.Versioned.Versioned

-- | This class provides primitive implementations for serialization
-- and deserialization. They differ from the operations provided by
-- 'VersionedGettable' and 'VersionedSerialize' by not taking
-- migration or versioning into account for themselves. However, they
-- differ from simple @'getUnversioned' 'Data.Serialize.get'@ or
-- @'putUnversioned' . 'Data.Serialize.put'@ by taking migration and
-- version into account for sub structures,
-- e.g. 'getPrimitiveVersioned' will alwas deserialize lists exactly
-- the same way, so no migration is necessary, but the elements of the
-- list will be deserialized and migrated as needed.
class PrimitiveVersionedSerialize d (v :: Nat) t where
  -- | Reads the structure itself and migrates sub-structures if
  -- necessary.
  getPrimitiveVersioned :: VersionedGet d t
  default getPrimitiveVersioned :: ( Generic t
                                   , GVersionedGet d (Rep t)
                                   )
                                => VersionedGet d t
  getPrimitiveVersioned = fmap to gVersionedGet
  -- | Puts the structure and all sub-structures.
  putPrimitiveVersioned :: VersionedPutter d v t
  default putPrimitiveVersioned :: ( Generic t
                                   , GVersionedPut d v (Rep t)
                                   )
                                => VersionedPutter d v t
  putPrimitiveVersioned = gVersionedPut . from

supplyNames :: (Name -> Name -> Name -> a) -> a
supplyNames f = f ''PrimitiveVersionedSerialize 'getPrimitiveVersioned 'putPrimitiveVersioned

-- | @unversionedPrimitive t@ generates an instance of
-- @'PrimitiveVersionedSerialize' d v $t@ based on
-- 'Data.Serialize.get' and 'Data.Serialize.put'. Serialization
-- and deserialization will be entirely based on the
-- 'Data.Serialize.Serialize'  instance of the type, so no
-- substructures will be migrated.
unversionedPrimitive :: TypeQ -> DecsQ
unversionedPrimitive = supplyNames unversionedPrimitiveFor

-- | A version of 'unversionedPrimitive', but takes the name of a
-- type constructor without arguments instead of a type.
unversionedPrimitive' :: Name -> DecsQ
unversionedPrimitive' = supplyNames unversionedPrimitiveFor'

-- | A shorthand for applying 'unversionedPrimitive' to multiple
-- types.
unversionedPrimitives :: [TypeQ] -> DecsQ
unversionedPrimitives = supplyNames unversionedPrimitivesFor

-- | A shorthand for applying 'unversionedPrimitive'' to multiple
-- types.
unversionedPrimitives' :: [Name] -> DecsQ
unversionedPrimitives' = supplyNames unversionedPrimitivesFor'

-- | @unversionedPrimitiveContainer t putContainer getContainer@
-- generates an instance @'PrimitiveVersionedSerialize' d v ($t
-- e)'@, where the “structure” of a container is primitive, but the
-- elements of the container are migratable and migrated with the
-- appropriate instance for the current domain and version.
--
-- The expression getContainer (the second argument) has to have a
-- type of @'Data.Serialize.Get' e -> 'Data.Serialize.Get' (t
-- e)@. Likewise the expression in putContainer (the third argument)
-- has to have a type of @'Data.Serialize.Putter' e ->
-- 'Data.Serialize.Putter' (t e)@
unversionedPrimitiveContainer :: TypeQ -> ExpQ -> ExpQ -> DecsQ
unversionedPrimitiveContainer = supplyNames unversionedPrimitiveContainerFor

-- | A version of 'unversionedPrimitiveContainer' that takes a name of
-- a type constructor that takes a single argument.
unversionedPrimitiveContainer' :: Name -> ExpQ -> ExpQ -> DecsQ
unversionedPrimitiveContainer' = supplyNames unversionedPrimitiveContainerFor'

-- | A shorthand for applying 'unversionedPrimitiveContainer' to
-- multiple types.
unversionedPrimitiveContainers :: [(TypeQ, ExpQ, ExpQ)] -> DecsQ
unversionedPrimitiveContainers = supplyNames unversionedPrimitiveContainersFor

-- | A shorthand for applying 'unversionedPrimitiveContainer'' to
-- multiple types.
unversionedPrimitiveContainers' :: [(Name, ExpQ, ExpQ)] -> DecsQ
unversionedPrimitiveContainers' = supplyNames unversionedPrimitiveContainersFor'

unversionedPrimitivesFor' ''PrimitiveVersionedSerialize 'getPrimitiveVersioned 'putPrimitiveVersioned
  [ ''Bool
  , ''Char
  , ''Double
  , ''Float
  , ''Int
  , ''Int8
  , ''Int16
  , ''Int32
  , ''Int64
  , ''Integer
  , ''Natural
  , ''Ordering
  , ''Word
  , ''Word8
  , ''Word16
  , ''Word32
  , ''Word64
  , ''()
  , ''All
  , ''Any
  , ''B.ByteString
  , ''ShortByteString
  , ''B.L.ByteString
  , ''IntSet
  ]

unversionedPrimitiveContainersFor'
  ''PrimitiveVersionedSerialize 'getPrimitiveVersioned 'putPrimitiveVersioned
  [ (''[], [e| putListOf |], [e| getListOf |])
  , (''Maybe, [e| putMaybeOf |], [e| getMaybeOf |])
  , (''Tree, [e| putTreeOf |], [e| getTreeOf |])
  , (''Seq, [e| putSeqOf |], [e| getSeqOf |])
  ]

instance ( VersionedSerialize d a
         , CurrentStructureVersion d a ~ v
         , Integral a
         ) => PrimitiveVersionedSerialize d v (Ratio a) where
  getPrimitiveVersioned = liftA2 (%) getVersioned getVersioned
  putPrimitiveVersioned x = putVersioned (numerator x) <> putVersioned (denominator x)

instance ( VersionedSerialize d (Maybe a)
         , CurrentStructureVersion d (Maybe a) ~ v
         ) => PrimitiveVersionedSerialize d v (First a)

instance ( VersionedSerialize d (Maybe a)
         , CurrentStructureVersion d (Maybe a) ~ v
         ) => PrimitiveVersionedSerialize d v (Last a)

instance ( VersionedSerialize d a
         , CurrentStructureVersion d a ~ v
         ) => PrimitiveVersionedSerialize d v (Dual a)

instance ( VersionedSerialize d a
         , CurrentStructureVersion d a ~ v
         ) => PrimitiveVersionedSerialize d v (Sum a)

instance ( VersionedSerialize d a
         , CurrentStructureVersion d a ~ v
         ) => PrimitiveVersionedSerialize d v (Product a)

instance ( VersionedSerialize d a
         , CurrentStructureVersion d a ~ v
         , VersionedSerialize d Int
         , CurrentStructureVersion d Int ~ v
         ) => PrimitiveVersionedSerialize d v (IntMap a) where
  getPrimitiveVersioned =
    getUnversionedResumable $ \resume ->
    getIntMapOf (resume getVersioned) (resume getVersioned)
  putPrimitiveVersioned m =
    putUnversionedResumable $ \resume ->
    putIntMapOf (resume . putVersioned) (resume . putVersioned) m

instance ( VersionedSerialize d a
         , CurrentStructureVersion d a ~ v
         , Ord a
         ) => PrimitiveVersionedSerialize d v (Set a) where
  getPrimitiveVersioned =
    getUnversionedResumable $ \resume ->
    getSetOf $ resume getVersioned
  putPrimitiveVersioned s =
    putUnversionedResumable $ \resume ->
    putSetOf (resume . putVersioned) s

instance ( VersionedSerialize d a
         , VersionedSerialize d b
         , CurrentStructureVersion d a ~ v
         , CurrentStructureVersion d b ~ v
         ) => PrimitiveVersionedSerialize d v (Either a b) where
  getPrimitiveVersioned =
    getUnversionedResumable $ \resume ->
    getEitherOf (resume getVersioned) (resume getVersioned)
  putPrimitiveVersioned e =
    putUnversionedResumable $ \resume ->
    putEitherOf (resume . putVersioned) (resume . putVersioned) e

instance ( VersionedSerialize d a
         , VersionedSerialize d b
         , CurrentStructureVersion d a ~ v
         , CurrentStructureVersion d b ~ v
         ) => PrimitiveVersionedSerialize d v (a, b) where
  getPrimitiveVersioned =
    getUnversionedResumable $ \resume ->
    getTwoOf (resume getVersioned) (resume getVersioned)
  putPrimitiveVersioned p =
    putUnversionedResumable $ \resume ->
    putTwoOf (resume . putVersioned) (resume . putVersioned) p

instance ( VersionedSerialize d e
         , VersionedSerialize d i
         , CurrentStructureVersion d e ~ v
         , CurrentStructureVersion d i ~ v
         , Ix i
         , IArray UArray e
         ) => PrimitiveVersionedSerialize d v (UArray i e) where
  getPrimitiveVersioned =
    getUnversionedResumable $ \resume ->
    getIArrayOf (resume getVersioned) (resume getVersioned)
  putPrimitiveVersioned arr =
    putUnversionedResumable $ \resume ->
    putIArrayOf (resume . putVersioned) (resume . putVersioned) arr

instance ( VersionedSerialize d e
         , VersionedSerialize d i
         , CurrentStructureVersion d e ~ v
         , CurrentStructureVersion d i ~ v
         , Ix i
         , IArray Array e
         ) => PrimitiveVersionedSerialize d v (Array i e) where
  getPrimitiveVersioned =
    getUnversionedResumable $ \resume ->
    getIArrayOf (resume getVersioned) (resume getVersioned)
  putPrimitiveVersioned arr =
    putUnversionedResumable $ \resume ->
    putIArrayOf (resume . putVersioned) (resume . putVersioned) arr

instance ( VersionedSerialize d k
         , VersionedSerialize d e
         , CurrentStructureVersion d k ~ v
         , CurrentStructureVersion d e ~ v
         , Ord k
         ) => PrimitiveVersionedSerialize d v (Map k e) where
  getPrimitiveVersioned =
    getUnversionedResumable $ \resume ->
    getMapOf (resume getVersioned) (resume getVersioned)
  putPrimitiveVersioned m =
    putUnversionedResumable $ \resume ->
    putMapOf (resume . putVersioned) (resume . putVersioned) m

definePrimitiveTuplesFor ''PrimitiveVersionedSerialize 'getPrimitiveVersioned 'putPrimitiveVersioned 16