-- 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

-- | Representation of primitive types
data PrimitiveType
  = UnitType
  | BoolType
  | IntType { signed :: Bool, bitSize :: Int, valueSet :: (Range Integer) }
  | FloatType (Range Float)
    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 _ _ _) = "Int"
    haskellType (FloatType _)   = "Float"

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

showPrimitiveRange UnitType        = ""
showPrimitiveRange BoolType        = ""
showPrimitiveRange (IntType _ _ r) = showRange r
showPrimitiveRange (FloatType r)   = showRange r

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



-- | Primitive types
class Storable a => Primitive a
  where
    -- | Converts a primitive value to its untyped representation.
    primitiveData :: a -> PrimitiveData

    -- | Gives the type representation of a primitive value.
    primitiveType :: Size a -> T a -> PrimitiveType

instance Primitive ()
  where
    primitiveData     = UnitData
    primitiveType _ _ = UnitType

instance Primitive Bool
  where
    primitiveData     = BoolData
    primitiveType _ _ = BoolType

-- Assumes 32 bits which is not necessarily correct
instance Primitive Int
  where
    primitiveData     = IntData . toInteger
    primitiveType s _ = IntType True 32 s

instance Primitive Float
  where
    primitiveData     = FloatData
    primitiveType s _ = FloatType s



-- | 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 . primitiveData
    storableType s  = StorableType [] . primitiveType s
    storableSize _  = ()
    listSize _ _    = []

instance Storable Bool
  where
    storableData   = PrimitiveData . primitiveData
    storableType s = StorableType [] . primitiveType s
    storableSize _ = ()
    listSize _ _   = []

instance Storable Int
  where
    storableData   = PrimitiveData . primitiveData
    storableType s = StorableType [] . primitiveType s
    storableSize a = singletonRange $ toInteger a
    listSize _ _   = []

instance Storable Float
  where
    storableData   = PrimitiveData . primitiveData
    storableType s = StorableType [] . primitiveType 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, Ord 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 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

class (Num a, Primitive a, Num (Size a)) => Numeric a

instance Numeric Int

instance Numeric Float