--
-- Copyright (c) 2009-2010, ERICSSON AB All rights reserved.
-- 
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
-- 
--     * Redistributions of source code must retain the above copyright notice,
--       this list of conditions and the following disclaimer.
--     * Redistributions in binary form must reproduce the above copyright
--       notice, this list of conditions and the following disclaimer in the
--       documentation and/or other materials provided with the distribution.
--     * Neither the name of the ERICSSON AB nor the names of its contributors
--       may be used to endorse or promote products derived from this software
--       without specific prior written permission.
-- 
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-- ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS
-- BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,
-- OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
-- SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-- INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
-- CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF
-- THE POSSIBILITY OF SUCH DAMAGE.
--

{-# LANGUAGE UndecidableInstances #-}

-- | Defines types and classes for the data computed by "Feldspar" programs.

module Feldspar.Core.Types where



import Control.Applicative
import Data.Char
import Data.Foldable (Foldable)
import qualified Data.Foldable as Fold
import Data.Monoid
import Data.Traversable (Traversable, traverse)

import Data.Int
import Data.Word
import Data.Bits

import Feldspar.Utils
import Feldspar.Haskell
import Feldspar.Range



-- * Misc.

-- | Used to pass a type to a function without using 'undefined'.
data T a = T

mkT :: a -> T a
mkT _ = T



-- | Heterogeneous list
data a :> b = a :> b
    deriving (Eq, Ord, Show)

infixr 5 :>

instance (Monoid a, Monoid b) => Monoid (a :> b)
  where
    mempty = mempty :> mempty

    (a1:>b1) `mappend` (a2:>b2) = (a1 `mappend` a2) :> (b1 `mappend` b2)



class Set a
  where
    universal :: a

instance Set ()
  where
    universal     = ()

instance Ord a => Set (Range a)
  where
    universal = fullRange

instance (Set a, Set b) => Set (a :> b)
  where
    universal = universal :> universal

instance (Set a, Set b) => Set (a,b)
  where
    universal = (universal,universal)

instance (Set a, Set b, Set c) => Set (a,b,c)
  where
    universal = (universal,universal,universal)

instance (Set a, Set b, Set c, Set d) => Set (a,b,c,d)
  where
    universal = (universal,universal,universal,universal)



type Length = Int



-- * Tuples

-- | Untyped representation of nested tuples
data Tuple a
       = One a
       | Tup [Tuple a]
     deriving (Eq, Show)

instance Functor Tuple
  where
    fmap f (One a)  = One (f a)
    fmap f (Tup as) = Tup $ map (fmap f) as
  -- XXX Can be derived in GHC 6.12

instance Foldable Tuple
  where
    foldr f x (One a)  = f a x
    foldr f x (Tup as) = Fold.foldr (flip $ Fold.foldr f) x as
  -- XXX Can be derived in GHC 6.12

instance Traversable Tuple
  where
    traverse f (One a)  = pure One <*> f a
    traverse f (Tup as) = pure Tup <*> traverse (traverse f) as
  -- XXX Can be derived in GHC 6.12

instance HaskellType a => HaskellType (Tuple a)
  where
    haskellType = showTuple . fmap haskellType

instance HaskellValue a => HaskellValue (Tuple a)
  where
    haskellValue = showTuple . fmap haskellValue



-- | Shows a nested tuple in Haskell's tuple syntax (e.g @\"(a,(b,c))\"@).
showTuple :: Tuple String -> String
showTuple (One a)  = a
showTuple (Tup as) = showSeq "(" (map showTuple as) ")"

-- | Replaces each element by its path in the tuple tree. For example:
--
-- > tuplePath (Tup [One 'a',Tup [One 'b', One 'c']])
-- >   ==
-- > Tup [One [0],Tup [One [1,0],One [1,1]]]
tuplePath :: Tuple a -> Tuple [Int]
tuplePath tup = path [] tup
  where
    path pth (One _)  = One pth
    path pth (Tup as) = Tup [path (pth++[n]) a | (a,n) <- as `zip` [0..]]



-- * Data

-- | Untyped representation of primitive data
data PrimitiveData
  = UnitData  ()
  | BoolData  Bool
  | IntData   Integer
  | FloatData Float
    deriving (Eq, Show)

-- | Untyped representation of storable data (arrays of primitive data)
data StorableData
  = PrimitiveData PrimitiveData
  | StorableData [StorableData]
    deriving (Eq, Show)

instance HaskellValue PrimitiveData
  where
    haskellValue (UnitData  a) = show a
    haskellValue (BoolData  a) = map toLower (show a)
    haskellValue (IntData   a) = show a
    haskellValue (FloatData a) = show a

instance HaskellValue StorableData
  where
    haskellValue (PrimitiveData a) = haskellValue a
    haskellValue (StorableData as) = showSeq "[" (map haskellValue as) "]"



-- * Types

type Unsigned32 = Word32
type Signed32   = Int32
type Unsigned16 = Word16
type Signed16   = Int16
type Unsigned8  = Word8
type Signed8    = Int8

-- | Representation of primitive types
data PrimitiveType
  = UnitType
  | BoolType
  | IntType { signed :: Bool, bitSize :: Int, valueSet :: (Range Integer) }
  | FloatType (Range Float)
  | UserType String
    deriving (Eq, Show)

-- | Representation of storable types (arrays of primitive types). Array size is
-- given as a list of ranged lengths, starting with outermost array level.
-- Primitive types are treated as zero-dimensional arrays.
data StorableType = StorableType [Range Length] PrimitiveType
    deriving (Eq, Show)

instance HaskellType PrimitiveType
  where
    haskellType UnitType             = "()"
    haskellType BoolType             = "Bool"
    haskellType (IntType True  32 _) = "Int32"
    haskellType (IntType False 32 _) = "Word32"
    haskellType (IntType True  16 _) = "Int16"
    haskellType (IntType False 16 _) = "Word16"
    haskellType (IntType True   8 _) = "Int8"
    haskellType (IntType False  8 _) = "Word8"
    haskellType (FloatType _)        = "Float"
    haskellType (UserType t)         = t

instance HaskellType StorableType
  where
    haskellType (StorableType ls t) = arrType
      where
        d       = length ls
        arrType = replicate d '[' ++ haskellType t ++ replicate d ']'

showPrimitiveRange :: PrimitiveType -> String
showPrimitiveRange (IntType _ _ r) = showRange r
showPrimitiveRange (FloatType r)   = showRange r
showPrimitiveRange _               = ""

-- | Shows the size of a storable type.
showStorableSize :: StorableType -> String
showStorableSize (StorableType ls t) =
    showSeq "" (map (showBound . upperBound) ls) "" ++ showPrimitiveRange t



{-# DEPRECATED Primitive "The class Primitive will be removed. Use Storable instead." #-}
-- | Primitive types
class    Storable a => Primitive a
instance Storable a => Primitive a

-- | Storable types (zero- or higher-level arrays of primitive data).
class Typeable a => Storable a
  where
    -- | Converts a storable value to its untyped representation.
    storableData :: a -> StorableData

    -- | Gives the type representation of a storable value.
    storableType :: Size a -> T a -> StorableType

    -- | Gives the size of a storable value.
    storableSize :: a -> Size a

    listSize :: T a -> Size a -> [Range Length]
      -- XXX Could be put in a separate class without the (T a).

instance Storable ()
  where
    storableData    = PrimitiveData . UnitData
    storableType _ _= StorableType [] UnitType
    storableSize _  = ()
    listSize _ _    = []

instance Storable Bool
  where
    storableData     = PrimitiveData . BoolData
    storableType _ _ = StorableType [] BoolType
    storableSize _   = ()
    listSize _ _     = []

-- XXX Assumes 32 bits which is not necessarily correct
instance Storable Int
  where
    storableData     = PrimitiveData . IntData . toInteger
    storableType s _ = StorableType [] $ IntType True 32 s
    storableSize a   = singletonRange $ toInteger a
    listSize _ _     = []

instance Storable Unsigned32
  where
    storableData     = PrimitiveData . IntData . toInteger
    storableType s _ = StorableType [] $ IntType False 32 s
    storableSize a   = singletonRange $ toInteger a
    listSize _ _     = []

instance Storable Signed32
  where
    storableData     = PrimitiveData . IntData . toInteger
    storableType s _ = StorableType [] $ IntType True 32 s
    storableSize a   = singletonRange $ toInteger a
    listSize _ _     = []

instance Storable Unsigned16
  where
    storableData     = PrimitiveData . IntData . toInteger
    storableType s _ = StorableType [] $ IntType False 16 s
    storableSize a   = singletonRange $ toInteger a
    listSize _ _     = []

instance Storable Signed16
  where
    storableData     = PrimitiveData . IntData . toInteger
    storableType s _ = StorableType [] $ IntType True 16 s
    storableSize a   = singletonRange $ toInteger a
    listSize _ _     = []

instance Storable Unsigned8
  where
    storableData     = PrimitiveData . IntData . toInteger
    storableType s _ = StorableType [] $ IntType False 8 s
    storableSize a   = singletonRange $ toInteger a
    listSize _ _     = []

instance Storable Signed8
  where
    storableData     = PrimitiveData . IntData . toInteger
    storableType s _ = StorableType [] $ IntType True 8 s
    storableSize a   = singletonRange $ toInteger a
    listSize _ _     = []

instance Storable Float
  where
    storableData     = PrimitiveData . FloatData
    storableType s _ = StorableType [] $ FloatType s
    storableSize a   = singletonRange a
    listSize _ _     = []

instance Storable a => Storable [a]
  where
    storableData = StorableData . map storableData

    storableType (l:>ls) _ = StorableType (l:ls') t
      where
        StorableType ls' t = storableType ls (T::T a)

    storableSize as =
        singletonRange (length as) :> mconcat (map storableSize as)

    listSize _ (l:>ls) = l : listSize (T::T a) ls



class (Eq a, Monoid (Size a), Set (Size a)) => Typeable a
  where
    -- | This type provides the necessary extra information to compute a type
    -- representation @`Tuple` `StorableType`@ from a type @a@. This is needed
    -- because the type @a@ is missing information about sizes of arrays and
    -- primitive values.
    type Size a

    -- | Gives the type representation of a storable value.
    typeOf :: Size a -> T a -> Tuple StorableType

instance Typeable ()
  where
    type Size () = ()
    typeOf       = typeOfStorable

instance Typeable Bool
  where
    type Size Bool = ()
    typeOf         = typeOfStorable

instance Typeable Int
  where
    type Size Int = Range Integer
    typeOf        = typeOfStorable

instance Typeable Unsigned32
  where
    type Size Unsigned32 = Range Integer
    typeOf               = typeOfStorable

instance Typeable Signed32
  where
    type Size Signed32 = Range Integer
    typeOf             = typeOfStorable

instance Typeable Unsigned16
  where
    type Size Unsigned16 = Range Integer
    typeOf               = typeOfStorable

instance Typeable Signed16
  where
    type Size Signed16 = Range Integer
    typeOf             = typeOfStorable

instance Typeable Unsigned8
  where
    type Size Unsigned8 = Range Integer
    typeOf              = typeOfStorable

instance Typeable Signed8
  where
    type Size Signed8 = Range Integer
    typeOf            = typeOfStorable

instance Typeable Float
  where
    type Size Float = Range Float
    typeOf          = typeOfStorable

instance Storable a => Typeable [a]
  where
    type Size [a] = Range Length :> Size a
    typeOf        = typeOfStorable

instance (Typeable a, Typeable b) => Typeable (a,b)
  where
    type Size (a,b) = (Size a, Size b)

    typeOf (sa,sb) _ = Tup [typeOf sa (T::T a), typeOf sb (T::T b)]

instance (Typeable a, Typeable b, Typeable c) => Typeable (a,b,c)
  where
    type Size (a,b,c) = (Size a, Size b, Size c)

    typeOf (sa,sb,sc) _ = Tup
        [ typeOf sa (T::T a)
        , typeOf sb (T::T b)
        , typeOf sc (T::T c)
        ]

instance (Typeable a, Typeable b, Typeable c, Typeable d) => Typeable (a,b,c,d)
  where
    type Size (a,b,c,d) = (Size a, Size b, Size c, Size d)

    typeOf (sa,sb,sc,sd) _ = Tup
        [ typeOf sa (T::T a)
        , typeOf sb (T::T b)
        , typeOf sc (T::T c)
        , typeOf sd (T::T d)
        ]



-- | Default implementation of 'typeOf' for 'Storable' types.
typeOfStorable :: Storable a => Size a -> T a -> Tuple StorableType
typeOfStorable sz = One . storableType sz