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
data T a = T
mkT :: a -> T a
mkT _ = T
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
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
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
instance Traversable Tuple
where
traverse f (One a) = pure One <*> f a
traverse f (Tup as) = pure Tup <*> traverse (traverse f) as
instance HaskellType a => HaskellType (Tuple a)
where
haskellType = showTuple . fmap haskellType
instance HaskellValue a => HaskellValue (Tuple a)
where
haskellValue = showTuple . fmap haskellValue
showTuple :: Tuple String -> String
showTuple (One a) = a
showTuple (Tup as) = showSeq "(" (map showTuple as) ")"
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 PrimitiveData
= UnitData ()
| BoolData Bool
| IntData Integer
| FloatData Float
deriving (Eq, Show)
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) "]"
data PrimitiveType
= UnitType
| BoolType
| IntType { signed :: Bool, bitSize :: Int, valueSet :: (Range Integer) }
| FloatType (Range Float)
deriving (Eq, Show)
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
showStorableSize :: StorableType -> String
showStorableSize (StorableType ls t) =
showSeq "" (map (showBound . upperBound) ls) "" ++ showPrimitiveRange t
class Storable a => Primitive a
where
primitiveData :: a -> PrimitiveData
primitiveType :: Size a -> T a -> PrimitiveType
instance Primitive ()
where
primitiveData = UnitData
primitiveType _ _ = UnitType
instance Primitive Bool
where
primitiveData = BoolData
primitiveType _ _ = BoolType
instance Primitive Int
where
primitiveData = IntData . toInteger
primitiveType s _ = IntType True 32 s
instance Primitive Float
where
primitiveData = FloatData
primitiveType s _ = FloatType s
class Typeable a => Storable a
where
storableData :: a -> StorableData
storableType :: Size a -> T a -> StorableType
storableSize :: a -> Size a
listSize :: T a -> Size a -> [Range Length]
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
type Size a
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)
]
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