content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE UndecidableInstances #-}
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  
  module Data.SafeCopy.Instances where
  
  import Data.SafeCopy.SafeCopy
  
  import           Control.Monad
  import qualified Data.Array as Array
  import qualified Data.Array.Unboxed as UArray
  import qualified Data.Array.IArray as IArray
  import qualified Data.ByteString.Lazy.Char8 as L
  import qualified Data.ByteString.Char8 as B
  import qualified Data.Foldable as Foldable
  import           Data.Fixed (HasResolution, Fixed)
  import           Data.Int
  import qualified Data.IntMap as IntMap
  import qualified Data.IntSet as IntSet
  import           Data.Ix
  import qualified Data.List.NonEmpty as NonEmpty
  import qualified Data.Map as Map
  import           Data.Ratio (Ratio, (%), numerator, denominator)
  import qualified Data.Sequence as Sequence
  import           Data.Serialize
  import qualified Data.Set as Set
  import qualified Data.Text as T
  import qualified Data.Text.Encoding as T
  import qualified Data.Text.Lazy as TL
  import qualified Data.Text.Lazy.Encoding as TL
  import           Data.Time.Calendar (Day(..))
  import           Data.Time.Clock (DiffTime, NominalDiffTime, UniversalTime(..), UTCTime(..))
  import           Data.Time.Clock.TAI (AbsoluteTime, taiEpoch, addAbsoluteTime, diffAbsoluteTime)
  import           Data.Time.LocalTime (LocalTime(..), TimeOfDay(..), TimeZone(..), ZonedTime(..))
  import qualified Data.Tree as Tree
  import           Data.Typeable hiding (Proxy)
  import           Data.Word
  import           Numeric.Natural (Natural)
  import           System.Time (ClockTime(..), TimeDiff(..), CalendarTime(..), Month(..))
  import qualified System.Time as OT
  import qualified Data.Vector as V
  import qualified Data.Vector.Generic as VG
  import qualified Data.Vector.Primitive as VP
  import qualified Data.Vector.Storable as VS
  import qualified Data.Vector.Unboxed as VU
  
  instance SafeCopy a => SafeCopy (Prim a) where
    kind = primitive
    getCopy = contain $
              do e <- unsafeUnPack getCopy
                 return $ Prim e
    putCopy (Prim e)
      = contain $ unsafeUnPack (putCopy e)
  
  instance SafeCopy a => SafeCopy [a] where
    getCopy = contain $ do
      n <- get
      g <- getSafeGet
      go g [] n
        where
          go :: Get a -> [a] -> Int -> Get [a]
          go _ as 0 = return (reverse as)
          go g as i = do x <- g
                         x `seq` go g (x:as) (i - 1)
    putCopy lst = contain $ do put (length lst)
                               getSafePut >>= forM_ lst
    errorTypeName = typeName1
  
  instance SafeCopy a => SafeCopy (NonEmpty.NonEmpty a) where
      getCopy = contain $ fmap NonEmpty.fromList safeGet
      putCopy = contain . safePut . NonEmpty.toList
      errorTypeName = typeName1
  
  instance SafeCopy a => SafeCopy (Maybe a) where
      getCopy = contain $ do n <- get
                             if n then liftM Just safeGet
                                  else return Nothing
      putCopy (Just a) = contain $ put True >> safePut a
      putCopy Nothing = contain $ put False
      errorTypeName = typeName1
  
  instance (SafeCopy a, Ord a) => SafeCopy (Set.Set a) where
      getCopy = contain $ fmap Set.fromDistinctAscList safeGet
      putCopy = contain . safePut . Set.toAscList
      errorTypeName = typeName1
  
  instance (SafeCopy a, SafeCopy b, Ord a) => SafeCopy (Map.Map a b) where
      getCopy = contain $ fmap Map.fromDistinctAscList safeGet
      putCopy = contain . safePut . Map.toAscList
      errorTypeName = typeName2
  
  instance (SafeCopy a) => SafeCopy (IntMap.IntMap a) where
      getCopy = contain $ fmap IntMap.fromDistinctAscList safeGet
      putCopy = contain . safePut . IntMap.toAscList
      errorTypeName = typeName1
  
  instance SafeCopy IntSet.IntSet where
      getCopy = contain $ fmap IntSet.fromDistinctAscList safeGet
      putCopy = contain . safePut . IntSet.toAscList
      errorTypeName = typeName
  
  instance (SafeCopy a) => SafeCopy (Sequence.Seq a) where
      getCopy = contain $ fmap Sequence.fromList safeGet
      putCopy = contain . safePut . Foldable.toList
      errorTypeName = typeName1
  
  instance (SafeCopy a) => SafeCopy (Tree.Tree a) where
      getCopy = contain $ liftM2 Tree.Node safeGet safeGet
      putCopy (Tree.Node root sub) = contain $ safePut root >> safePut sub
      errorTypeName = typeName1
  
  iarray_getCopy :: (Ix i, SafeCopy e, SafeCopy i, IArray.IArray a e) => Contained (Get (a i e))
  iarray_getCopy = contain $ do getIx <- getSafeGet
                                liftM3 mkArray getIx getIx safeGet
      where
        mkArray l h xs = IArray.listArray (l, h) xs
  {-# INLINE iarray_getCopy #-}
  
  iarray_putCopy :: (Ix i, SafeCopy e, SafeCopy i, IArray.IArray a e) => a i e -> Contained Put
  iarray_putCopy arr = contain $ do putIx <- getSafePut
                                    let (l,h) = IArray.bounds arr
                                    putIx l >> putIx h
                                    safePut (IArray.elems arr)
  {-# INLINE iarray_putCopy #-}
  
  instance (Ix i, SafeCopy e, SafeCopy i) => SafeCopy (Array.Array i e) where
      getCopy = iarray_getCopy
      putCopy = iarray_putCopy
      errorTypeName = typeName2
  
  instance (IArray.IArray UArray.UArray e, Ix i, SafeCopy e, SafeCopy i) => SafeCopy (UArray.UArray i e) where
      getCopy = iarray_getCopy
      putCopy = iarray_putCopy
      errorTypeName = typeName2
  
  instance (SafeCopy a, SafeCopy b) => SafeCopy (a,b) where
      getCopy = contain $ liftM2 (,) safeGet safeGet
      putCopy (a,b) = contain $ safePut a >> safePut b
      errorTypeName = typeName2
  instance (SafeCopy a, SafeCopy b, SafeCopy c) => SafeCopy (a,b,c) where
      getCopy = contain $ liftM3 (,,) safeGet safeGet safeGet
      putCopy (a,b,c) = contain $ safePut a >> safePut b >> safePut c
  instance (SafeCopy a, SafeCopy b, SafeCopy c, SafeCopy d) => SafeCopy (a,b,c,d) where
      getCopy = contain $ liftM4 (,,,) safeGet safeGet safeGet safeGet
      putCopy (a,b,c,d) = contain $ safePut a >> safePut b >> safePut c >> safePut d
  instance (SafeCopy a, SafeCopy b, SafeCopy c, SafeCopy d, SafeCopy e) =>
           SafeCopy (a,b,c,d,e) where
      getCopy = contain $ liftM5 (,,,,) safeGet safeGet safeGet safeGet safeGet
      putCopy (a,b,c,d,e) = contain $ safePut a >> safePut b >> safePut c >> safePut d >> safePut e
  instance (SafeCopy a, SafeCopy b, SafeCopy c, SafeCopy d, SafeCopy e, SafeCopy f) =>
           SafeCopy (a,b,c,d,e,f) where
      getCopy = contain $ (,,,,,) <$> safeGet <*> safeGet <*> safeGet <*> safeGet <*> safeGet <*> safeGet
      putCopy (a,b,c,d,e,f) = contain $ safePut a >> safePut b >> safePut c >> safePut d >>
                                        safePut e >> safePut f
  instance (SafeCopy a, SafeCopy b, SafeCopy c, SafeCopy d, SafeCopy e, SafeCopy f, SafeCopy g) =>
           SafeCopy (a,b,c,d,e,f,g) where
      getCopy = contain $ (,,,,,,) <$> safeGet <*> safeGet <*> safeGet <*> safeGet <*>
                                       safeGet <*> safeGet <*> safeGet
      putCopy (a,b,c,d,e,f,g) = contain $ safePut a >> safePut b >> safePut c >> safePut d >>
                                          safePut e >> safePut f >> safePut g
  
  
  instance SafeCopy Int where
      getCopy = contain get; putCopy = contain . put; errorTypeName = typeName
  instance SafeCopy Integer where
      getCopy = contain get; putCopy = contain . put; errorTypeName = typeName
  instance SafeCopy Natural where
      getCopy = contain get; putCopy = contain . put; errorTypeName = typeName
  
  -- | cereal changed the formats for Float/Double in 0.5.*
  --
  -- https://github.com/GaloisInc/cereal/commit/47d839609413e3e9d1147b99c34ae421ae36bced
  -- https://github.com/GaloisInc/cereal/issues/35
  newtype CerealFloat040 = CerealFloat040 { unCerealFloat040 :: Float} deriving (Show)
  instance SafeCopy CerealFloat040 where
      getCopy = contain (CerealFloat040 <$> liftM2 encodeFloat get get)
      putCopy (CerealFloat040 float) = contain (put (decodeFloat float))
      errorTypeName = typeName
  
  instance Migrate Float where
    type MigrateFrom Float = CerealFloat040
    migrate (CerealFloat040 d) = d
  
  instance SafeCopy Float where
    version = Version 1
    kind = extension
    getCopy = contain get
    putCopy = contain . put
    errorTypeName = typeName
  
  -- | cereal changed the formats for Float/Double in 0.5.*
  --
  -- https://github.com/GaloisInc/cereal/commit/47d839609413e3e9d1147b99c34ae421ae36bced
  -- https://github.com/GaloisInc/cereal/issues/35
  newtype CerealDouble040 = CerealDouble040 { unCerealDouble040 :: Double} deriving (Show)
  instance SafeCopy CerealDouble040 where
      getCopy = contain (CerealDouble040 <$> liftM2 encodeFloat get get)
      putCopy (CerealDouble040 double) = contain (put (decodeFloat double))
      errorTypeName = typeName
  
  instance Migrate Double where
    type MigrateFrom Double = CerealDouble040
    migrate (CerealDouble040 d) = d
  
  instance SafeCopy Double where
    version = Version 1
    kind = extension
    getCopy = contain get
    putCopy = contain . put
    errorTypeName = typeName
  
  
  instance SafeCopy L.ByteString where
      getCopy = contain get; putCopy = contain . put; errorTypeName = typeName
  instance SafeCopy B.ByteString where
      getCopy = contain get; putCopy = contain . put; errorTypeName = typeName
  instance SafeCopy Char where
      getCopy = contain get; putCopy = contain . put; errorTypeName = typeName
  instance SafeCopy Word where
      getCopy = contain get; putCopy = contain . put; errorTypeName = typeName
  instance SafeCopy Word8 where
      getCopy = contain get; putCopy = contain . put; errorTypeName = typeName
  instance SafeCopy Word16 where
      getCopy = contain get; putCopy = contain . put; errorTypeName = typeName
  instance SafeCopy Word32 where
      getCopy = contain get; putCopy = contain . put; errorTypeName = typeName
  instance SafeCopy Word64 where
      getCopy = contain get; putCopy = contain . put; errorTypeName = typeName
  instance SafeCopy Ordering where
      getCopy = contain get; putCopy = contain . put; errorTypeName = typeName
  instance SafeCopy Int8 where
      getCopy = contain get; putCopy = contain . put; errorTypeName = typeName
  instance SafeCopy Int16 where
      getCopy = contain get; putCopy = contain . put; errorTypeName = typeName
  instance SafeCopy Int32 where
      getCopy = contain get; putCopy = contain . put; errorTypeName = typeName
  instance SafeCopy Int64 where
      getCopy = contain get; putCopy = contain . put; errorTypeName = typeName
  instance (Integral a, SafeCopy a) => SafeCopy (Ratio a) where
      getCopy   = contain $ do n <- safeGet
                               d <- safeGet
                               return (n % d)
      putCopy r = contain $ do safePut (numerator   r)
                               safePut (denominator r)
      errorTypeName = typeName1
  instance (HasResolution a, Fractional (Fixed a), Typeable a) => SafeCopy (Fixed a) where
      getCopy   = contain $ fromRational <$> safeGet
      putCopy   = contain . safePut . toRational
      errorTypeName = typeName1
  
  instance SafeCopy () where
      getCopy = contain get; putCopy = contain . put; errorTypeName = typeName
  instance SafeCopy Bool where
      getCopy = contain get; putCopy = contain . put; errorTypeName = typeName
  instance (SafeCopy a, SafeCopy b) => SafeCopy (Either a b) where
      getCopy = contain $ do n <- get
                             if n then liftM Right safeGet
                                  else liftM Left safeGet
      putCopy (Right a) = contain $ put True >> safePut a
      putCopy (Left a) = contain $ put False >> safePut a
  
      errorTypeName = typeName2
  
  --  instances for 'text' library
  
  instance SafeCopy T.Text where
      kind = base
      getCopy = contain $ T.decodeUtf8 <$> safeGet
      putCopy = contain . safePut . T.encodeUtf8
      errorTypeName = typeName
  
  instance SafeCopy TL.Text where
      kind = base
      getCopy = contain $ TL.decodeUtf8 <$> safeGet
      putCopy = contain . safePut . TL.encodeUtf8
      errorTypeName = typeName
  
  -- instances for 'time' library
  
  instance SafeCopy Day where
      kind = base
      getCopy = contain $ ModifiedJulianDay <$> safeGet
      putCopy = contain . safePut . toModifiedJulianDay
      errorTypeName = typeName
  
  instance SafeCopy DiffTime where
      kind = base
      getCopy = contain $ fromRational <$> safeGet
      putCopy = contain . safePut . toRational
      errorTypeName = typeName
  
  instance SafeCopy UniversalTime where
      kind = base
      getCopy = contain $ ModJulianDate <$> safeGet
      putCopy = contain . safePut . getModJulianDate
      errorTypeName = typeName
  
  instance SafeCopy UTCTime where
      kind = base
      getCopy   = contain $ do day      <- safeGet
                               diffTime <- safeGet
                               return (UTCTime day diffTime)
      putCopy u = contain $ do safePut (utctDay u)
                               safePut (utctDayTime u)
      errorTypeName = typeName
  
  instance SafeCopy NominalDiffTime where
      kind = base
      getCopy = contain $ fromRational <$> safeGet
      putCopy = contain . safePut . toRational
      errorTypeName = typeName
  
  instance SafeCopy TimeOfDay where
      kind = base
      getCopy   = contain $ do hour <- safeGet
                               mins <- safeGet
                               sec  <- safeGet
                               return (TimeOfDay hour mins sec)
      putCopy t = contain $ do safePut (todHour t)
                               safePut (todMin t)
                               safePut (todSec t)
      errorTypeName = typeName
  
  instance SafeCopy TimeZone where
      kind = base
      getCopy   = contain $ do mins       <- safeGet
                               summerOnly <- safeGet
                               zoneName   <- safeGet
                               return (TimeZone mins summerOnly zoneName)
      putCopy t = contain $ do safePut (timeZoneMinutes t)
                               safePut (timeZoneSummerOnly t)
                               safePut (timeZoneName t)
      errorTypeName = typeName
  
  instance SafeCopy LocalTime where
      kind = base
      getCopy   = contain $ do day <- safeGet
                               tod <- safeGet
                               return (LocalTime day tod)
      putCopy t = contain $ do safePut (localDay t)
                               safePut (localTimeOfDay t)
      errorTypeName = typeName
  
  instance SafeCopy ZonedTime where
      kind = base
      getCopy   = contain $ do localTime <- safeGet
                               timeZone  <- safeGet
                               return (ZonedTime localTime timeZone)
      putCopy t = contain $ do safePut (zonedTimeToLocalTime t)
                               safePut (zonedTimeZone t)
      errorTypeName = typeName
  
  instance SafeCopy AbsoluteTime where
    getCopy = contain $ liftM toAbsoluteTime safeGet
      where
        toAbsoluteTime :: DiffTime -> AbsoluteTime
        toAbsoluteTime dt = addAbsoluteTime dt taiEpoch
    putCopy = contain . safePut . fromAbsoluteTime
      where
        fromAbsoluteTime :: AbsoluteTime -> DiffTime
        fromAbsoluteTime at = diffAbsoluteTime at taiEpoch
    errorTypeName = typeName
  
  -- instances for old-time
  
  instance SafeCopy ClockTime where
      kind = base
      getCopy = contain $ do secs <- safeGet
                             pico <- safeGet
                             return (TOD secs pico)
      putCopy (TOD secs pico) =
                contain $ do safePut secs
                             safePut pico
  
  instance SafeCopy TimeDiff where
      kind = base
      getCopy   = contain $ do year    <- get
                               month   <- get
                               day     <- get
                               hour    <- get
                               mins    <- get
                               sec     <- get
                               pico    <- get
                               return (TimeDiff year month day hour mins sec pico)
      putCopy t = contain $ do put (tdYear t)
                               put (tdMonth t)
                               put (tdDay t)
                               put (tdHour t)
                               put (tdMin t)
                               put (tdSec t)
                               put (tdPicosec t)
  
  instance SafeCopy OT.Day where
      kind = base ; getCopy = contain $ toEnum <$> get ; putCopy = contain . put . fromEnum
  
  instance SafeCopy Month where
      kind = base ; getCopy = contain $ toEnum <$> get ; putCopy = contain . put . fromEnum
  
  
  instance SafeCopy CalendarTime where
      kind = base
      getCopy   = contain $ do year   <- get
                               month  <- safeGet
                               day    <- get
                               hour   <- get
                               mins   <- get
                               sec    <- get
                               pico   <- get
                               wday   <- safeGet
                               yday   <- get
                               tzname <- safeGet
                               tz     <- get
                               dst    <- get
                               return (CalendarTime year month day hour mins sec pico wday yday tzname tz dst)
      putCopy t = contain $ do put     (ctYear t)
                               safePut (ctMonth t)
                               put     (ctDay t)
                               put     (ctHour t)
                               put     (ctMin t)
                               put     (ctSec t)
                               put     (ctPicosec t)
                               safePut (ctWDay t)
                               put     (ctYDay t)
                               safePut (ctTZName t)
                               put     (ctTZ t)
                               put     (ctIsDST t)
  
  typeName :: Typeable a => Proxy a -> String
  typeName proxy = show (typeOf (undefined `asProxyType` proxy))
  
  #if MIN_VERSION_base(4,10,0)
  typeName1 :: (Typeable c) => Proxy (c a) -> String
  typeName2 :: (Typeable c) => Proxy (c a b) -> String
  #else
  typeName1 :: (Typeable1 c) => Proxy (c a) -> String
  typeName2 :: (Typeable2 c) => Proxy (c a b) -> String
  #endif
  
  typeName1 proxy = show (typeOf1 (undefined `asProxyType` proxy))
  typeName2 proxy = show (typeOf2 (undefined `asProxyType` proxy))
  
  getGenericVector :: (SafeCopy a, VG.Vector v a) => Contained (Get (v a))
  getGenericVector = contain $ do n <- get
                                  getSafeGet >>= VG.replicateM n
  
  putGenericVector :: (SafeCopy a, VG.Vector v a) => v a -> Contained Put
  putGenericVector v = contain $ do put (VG.length v)
                                    getSafePut >>= VG.forM_ v
  
  instance SafeCopy a => SafeCopy (V.Vector a) where
      getCopy = getGenericVector
      putCopy = putGenericVector
  
  instance (SafeCopy a, VP.Prim a) => SafeCopy (VP.Vector a) where
      getCopy = getGenericVector
      putCopy = putGenericVector
  
  instance (SafeCopy a, VS.Storable a) => SafeCopy (VS.Vector a) where
      getCopy = getGenericVector
      putCopy = putGenericVector
  
  instance (SafeCopy a, VU.Unbox a) => SafeCopy (VU.Vector a) where
      getCopy = getGenericVector
      putCopy = putGenericVector
  