{-# OPTIONS_GHC -fno-warn-orphans #-}

module Data.Word.Word24.Instances
  (
  ) where

import ClassyPrelude
import Database.Persist
import Database.Persist.Sql
import System.Random (Random(..))

import Data.Aeson (FromJSON(..), ToJSON(..))
import qualified Data.Aeson.Types as Aeson

import Web.PathPieces

import Data.Word.Word24

import Control.Lens
  
import Control.Monad.Fail

import qualified Data.Scientific as Scientific
import Data.Scientific.Instances ()

import Data.Binary
import Data.Bits


instance PersistField Word24 where
  toPersistValue p = toPersistValue (fromIntegral p :: Word32)
  fromPersistValue v = do
    w <- fromPersistValue v :: Either Text Word32
    if
      | 0 <= w
      , w <= fromIntegral (maxBound :: Word24)
        -> return $ fromIntegral w
      | otherwise
        -> Left "Word24 out of range"

instance PersistFieldSql Word24 where
  sqlType _ = SqlInt32

instance Random Word24 where
  randomR (max minBound -> lo, min maxBound -> hi) gen = over _1 (fromIntegral :: Word32 -> Word24) $ randomR (fromIntegral lo, fromIntegral hi) gen
  random = randomR (minBound, maxBound)

instance FromJSON Word24 where
  parseJSON (Aeson.Number n) = case Scientific.toBoundedInteger n of
    Just n' -> return n'
    Nothing -> fail "parsing Word24 failed, out of range or not integral"
  parseJSON _ = fail "parsing Word24 failed, expected Number"

instance ToJSON Word24 where
  toJSON = Aeson.Number . fromIntegral

instance PathPiece Word24 where
  toPathPiece p = toPathPiece (fromIntegral p :: Word32)
  fromPathPiece = Scientific.toBoundedInteger <=< fromPathPiece


-- | Big Endian
instance Binary Word24 where
  put w = forM_ [2,1..0] $ putWord8 . fromIntegral . shiftR w . (* 8)
  get = foldlM (\w i -> (.|. w) . flip shiftL (8 * i) . fromIntegral <$> getWord8) 0 [2,1..0] 
