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) "]"
type Unsigned32 = Word32
type Signed32 = Int32
type Unsigned16 = Word16
type Signed16 = Int16
type Unsigned8 = Word8
type Signed8 = Int8
data PrimitiveType
= UnitType
| BoolType
| IntType { signed :: Bool, bitSize :: Int, valueSet :: (Range Integer) }
| FloatType (Range Float)
| UserType String
deriving (Eq, Show)
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 _ = ""
showStorableSize :: StorableType -> String
showStorableSize (StorableType ls t) =
showSeq "" (map (showBound . upperBound) ls) "" ++ showPrimitiveRange t
class Storable a => Primitive a
instance Storable a => Primitive a
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 . UnitData
storableType _ _= StorableType [] UnitType
storableSize _ = ()
listSize _ _ = []
instance Storable Bool
where
storableData = PrimitiveData . BoolData
storableType _ _ = StorableType [] BoolType
storableSize _ = ()
listSize _ _ = []
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
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 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)
]
typeOfStorable :: Storable a => Size a -> T a -> Tuple StorableType
typeOfStorable sz = One . storableType sz