{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
-- Needed to check (SafeCast to from) in the instance constraints for
-- RuntimeCast.
{-# LANGUAGE UndecidableInstances #-}

{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ < 710
{-# LANGUAGE OverlappingInstances #-}
#endif

-- | Safe casting.  We assume Floats have 32 bits and Doubles have 64.

module Ivory.Language.Cast
  ( safeCast
  , ivoryCast -- do not export from "Ivory.Language"
  , castWith
  , castDefault
  , signCast
  , SafeCast(), RuntimeCast(), Default(), SignCast()
  , toMaxSize
  , toMinSize
  ) where

import Ivory.Language.Float
import Ivory.Language.IBool
import Ivory.Language.IChar
import Ivory.Language.IIntegral
import Ivory.Language.Proxy
import Ivory.Language.Sint
import Ivory.Language.Type
import Ivory.Language.Uint
import qualified Ivory.Language.Syntax as AST

import Data.Word
import Data.Int

--------------------------------------------------------------------------------
-- Interface functions and methods.

-- | Statically safe casts.
class (IvoryExpr from, IvoryExpr to) => SafeCast from to where
  safeCast :: from -> to
  safeCast = ivoryCast

-- | Cast with a default value if the casted value is too large.
castWith :: RuntimeCast from to => to -> from -> to
castWith deflt from = inBounds deflt from ? (ivoryCast from, deflt)

-- | `CastWith 0` for types for which 0 is defined.
castDefault :: (Default to, RuntimeCast from to) => from -> to
castDefault = castWith defaultVal

-- | SignCast takes a unsigned number into its signed form iff safe,
-- otherwise 0, and same with signed into unsigned
class (IvoryExpr from, IvoryExpr to) => SignCast from to where
  signCast :: from -> to

-- | upperBoundCast implements signCast from unsigned to signed integers
upperBoundCast :: forall from to
                . (IvoryOrd from, IvoryExpr from, IvoryExpr to, Num to, Bounded to)
               => from -> to
upperBoundCast f = (f <=? bound) ? (ivoryCast f, 0)
  where bound = ivoryCast (maxBound :: to)

-- | lowerBoundCast implements signCast from signed to unsigned integers
lowerBoundCast :: forall from to
                . (IvoryOrd from, IvoryExpr from, IvoryExpr to, Num to, Bounded to)
               => from -> to
lowerBoundCast f = (f >? bound) ? (ivoryCast f, 0)
  where bound = ivoryCast (minBound :: to)
--------------------------------------------------------------------------------

-- | Casts requiring runtime checks.
class (IvoryExpr from, IvoryExpr to, Default to) => RuntimeCast from to where
  -- Does the from value fit within the to type?
  inBounds :: to -> from -> IBool

--------------------------------------------------------------------------------
-- Statically safe instances.

-- Booleans.
instance SafeCast IBool IBool     where
  safeCast     = id
instance SafeCast IBool IChar
instance SafeCast IBool Uint16
instance SafeCast IBool Uint8
instance SafeCast IBool Uint32
instance SafeCast IBool Uint64
instance SafeCast IBool Sint8
instance SafeCast IBool Sint16
instance SafeCast IBool Sint32
instance SafeCast IBool Sint64
instance SafeCast IBool IFloat
instance SafeCast IBool IDouble

-- Uint8.
instance SafeCast Uint8 Uint8     where
  safeCast     = id
instance SafeCast Uint8 Uint16
instance SafeCast Uint8 Uint32
instance SafeCast Uint8 Uint64
instance SafeCast Uint8 Sint16
instance SafeCast Uint8 Sint32
instance SafeCast Uint8 Sint64
instance SafeCast Uint8 IFloat
instance SafeCast Uint8 IDouble
instance SignCast Uint8 Sint8 where
  signCast = upperBoundCast

-- Uint16.
instance SafeCast Uint16 Uint16   where
  safeCast     = id
instance SafeCast Uint16 Uint32
instance SafeCast Uint16 Uint64
instance SafeCast Uint16 Sint32
instance SafeCast Uint16 Sint64
instance SafeCast Uint16 IFloat
instance SafeCast Uint16 IDouble
instance SignCast Uint16 Sint16 where
  signCast = upperBoundCast

-- Uint32.
instance SafeCast Uint32 Uint32   where
  safeCast     = id
instance SafeCast Uint32 Uint64
instance SafeCast Uint32 Sint64
instance SafeCast Uint32 IFloat
instance SafeCast Uint32 IDouble
instance SignCast Uint32 Sint32 where
  signCast = upperBoundCast

-- Uint64.
instance SafeCast Uint64 Uint64   where
  safeCast     = id
instance SafeCast Uint64 IDouble
instance SignCast Uint64 Sint64 where
  signCast = upperBoundCast

-- Sint8.
instance SafeCast Sint8 Sint8     where
  safeCast     = id
instance SafeCast Sint8 Sint16
instance SafeCast Sint8 Sint32
instance SafeCast Sint8 Sint64
instance SafeCast Sint8 IFloat
instance SafeCast Sint8 IDouble
instance SignCast Sint8 Uint8 where
  signCast = lowerBoundCast

-- Sint16.
instance SafeCast Sint16 Sint16   where
  safeCast     = id
instance SafeCast Sint16 Sint32
instance SafeCast Sint16 Sint64
instance SafeCast Sint16 IFloat
instance SafeCast Sint16 IDouble
instance SignCast Sint16 Uint16 where
  signCast = lowerBoundCast

-- Sint32.
instance SafeCast Sint32 Sint32   where
  safeCast     = id
instance SafeCast Sint32 Sint64
instance SafeCast Sint32 IFloat
instance SafeCast Sint32 IDouble
instance SignCast Sint32 Uint32 where
  signCast = lowerBoundCast

-- Sint64.
instance SafeCast Sint64 Sint64   where
  safeCast     = id
instance SafeCast Sint64 IDouble
instance SignCast Sint64 Uint64 where
  signCast = lowerBoundCast

-- IFloat.
instance SafeCast IFloat IFloat   where
  safeCast     = id
instance SafeCast IFloat IDouble

-- IDouble.
instance SafeCast IDouble IDouble where
  safeCast     = id

-- IChar.
instance SafeCast IChar IChar     where
  safeCast     = id

-- By the C standard, we can't assume they're unsigned or how big they are (we
-- just know they're at least 8 bits).  So this is the only cast for Char.

--------------------------------------------------------------------------------
-- Runtime check instances.

-- All other casts, for going to a Num type.
instance
#if __GLASGOW_HASKELL__ >= 710
    {-# OVERLAPPABLE #-}
#endif
         ( Bounded   from, Bounded   to
         , IvoryOrd  from, IvoryOrd  to
         , IvoryExpr from, IvoryExpr to
         , Default   from, Default   to
         -- Important constraint!  This means we can compare the values in the
         -- `from` type, since it must be able to hold all the values of the
         -- `to` type.  Alas, it requires undeciable instances....
         , SafeCast  to from
         ) => RuntimeCast from to where

  -- We can assume that comparison in the `from` type is safe due to the above
  -- constraint.
  inBounds = boundPred

--------------------------------------------------------------------------------
-- | Default values for expression types.
class Default a where
  defaultVal :: a

instance Default Uint8  where defaultVal = 0
instance Default Uint16 where defaultVal = 0
instance Default Uint32 where defaultVal = 0
instance Default Uint64 where defaultVal = 0
instance Default Sint8  where defaultVal = 0
instance Default Sint16 where defaultVal = 0
instance Default Sint32 where defaultVal = 0
instance Default Sint64 where defaultVal = 0

instance Default IFloat  where defaultVal = 0
instance Default IDouble where defaultVal = 0

--------------------------------------------------------------------------------
-- Floating

-- Have to define instances for Float and Double separately or you'll get
-- overlapping instances.

-- | Casting from a floating to a `Integral` type always results in truncation.
instance ( Default to
         , Bounded to
         , IvoryIntegral to
         -- Important constraint!  This means we can compare the values in the
         -- `from` type, since it must be able to hold all the values of the
         -- `to` type.  Alas, it requires undeciable instances....
         , SafeCast to IFloat
         ) => RuntimeCast IFloat to where
  inBounds to from = iNot (isnan from) .&& boundPred to from

instance ( Default to
         , Bounded to
         , IvoryIntegral to
         -- Important constraint!  This means we can compare the values in the
         -- `from` type, since it must be able to hold all the values of the
         -- `to` type.  Alas, it requires undeciable instances....
         , SafeCast to IDouble
         ) => RuntimeCast IDouble to where
  inBounds to from = iNot (isnan from) .&& boundPred to from

--------------------------------------------------------------------------------
-- Utils.

boundPred :: forall from to .
  ( IvoryExpr from
  , IvoryExpr to
  , Bounded to
  , IvoryOrd from
  ) => to -> from -> IBool
boundPred _ from = (from <=? ivoryCast (maxBound :: to))
               .&& (from >=? ivoryCast (minBound :: to))

-- XXX Don't export.
-- Type is what we're casting from.
ivoryCast :: forall a b. (IvoryExpr a, IvoryExpr b) => a -> b
ivoryCast x = wrapExpr (AST.ExpSafeCast ty (unwrapExpr x))
  where ty = ivoryType (Proxy :: Proxy a)

toMaxSize :: AST.Type -> Maybe Integer
toMaxSize ty =
  case ty of
    AST.TyInt i  -> Just $ case i of
                    AST.Int8  -> fromIntegral (maxBound :: Int8)
                    AST.Int16 -> fromIntegral (maxBound :: Int16)
                    AST.Int32 -> fromIntegral (maxBound :: Int32)
                    AST.Int64 -> fromIntegral (maxBound :: Int64)
    AST.TyWord w -> Just $ case w of
                    AST.Word8  -> fromIntegral (maxBound :: Word8)
                    AST.Word16 -> fromIntegral (maxBound :: Word16)
                    AST.Word32 -> fromIntegral (maxBound :: Word32)
                    AST.Word64 -> fromIntegral (maxBound :: Word64)
    AST.TyIndex n -> Just n
    _          -> Nothing

toMinSize :: AST.Type -> Maybe Integer
toMinSize ty =
  case ty of
    AST.TyInt i  -> Just $ case i of
                    AST.Int8  -> fromIntegral (minBound :: Int8)
                    AST.Int16 -> fromIntegral (minBound :: Int16)
                    AST.Int32 -> fromIntegral (minBound :: Int32)
                    AST.Int64 -> fromIntegral (minBound :: Int64)
    AST.TyWord w -> Just $ case w of
                    AST.Word8  -> fromIntegral (minBound :: Word8)
                    AST.Word16 -> fromIntegral (minBound :: Word16)
                    AST.Word32 -> fromIntegral (minBound :: Word32)
                    AST.Word64 -> fromIntegral (minBound :: Word64)
    AST.TyIndex _ -> Just 0
    _          -> Nothing

--------------------------------------------------------------------------------