module Feldspar.Core.Types where
import Control.Applicative
import Control.Monad
import Data.Char
import Data.Foldable (Foldable)
import qualified Data.Foldable as Fold
import Data.Maybe
import Data.Traversable (Traversable, traverse)
import Types.Data.Num
import Feldspar.Utils
data T a = T
numberT :: forall n . IntegerT n => T n -> Int
numberT _ = fromIntegerT (undefined :: n)
class HaskellType a
where
haskellType :: a -> String
instance HaskellType a => HaskellType (Tuple a)
where
haskellType = showTuple . fmap haskellType
class HaskellValue a
where
haskellValue :: a -> String
instance HaskellValue String
where
haskellValue = id
instance HaskellValue Int
where
haskellValue = show
instance HaskellValue a => HaskellValue (Tuple a)
where
haskellValue = showTuple . fmap haskellValue
class NaturalT n => GetTuple n a
where
type Part n a
getTup :: T n -> a -> Part n a
instance GetTuple D0 (a,b)
where
type Part D0 (a,b) = a
getTup _ (a,b) = a
instance GetTuple D1 (a,b)
where
type Part D1 (a,b) = b
getTup _ (a,b) = b
instance GetTuple D0 (a,b,c)
where
type Part D0 (a,b,c) = a
getTup _ (a,b,c) = a
instance GetTuple D1 (a,b,c)
where
type Part D1 (a,b,c) = b
getTup _ (a,b,c) = b
instance GetTuple D2 (a,b,c)
where
type Part D2 (a,b,c) = c
getTup _ (a,b,c) = c
instance GetTuple D0 (a,b,c,d)
where
type Part D0 (a,b,c,d) = a
getTup _ (a,b,c,d) = a
instance GetTuple D1 (a,b,c,d)
where
type Part D1 (a,b,c,d) = b
getTup _ (a,b,c,d) = b
instance GetTuple D2 (a,b,c,d)
where
type Part D2 (a,b,c,d) = c
getTup _ (a,b,c,d) = c
instance GetTuple D3 (a,b,c,d)
where
type Part D3 (a,b,c,d) = d
getTup _ (a,b,c,d) = d
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
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 PrimitiveType
= UnitType
| BoolType
| IntType
| FloatType
deriving (Eq, Show)
data PrimitiveData
= UnitData
| BoolData Bool
| IntData Int
| FloatData Float
deriving (Eq, Show)
data StorableType = StorableType [Int] PrimitiveType
deriving (Eq, Show)
data StorableData
= PrimitiveData PrimitiveData
| StorableData Int [StorableData]
deriving (Eq, Show)
instance HaskellType PrimitiveType
where
haskellType UnitType = "()"
haskellType BoolType = "Bool"
haskellType IntType = "Int"
haskellType FloatType = "Float"
instance HaskellValue PrimitiveData
where
haskellValue UnitData = "()"
haskellValue (BoolData a) = map toLower (show a)
haskellValue (IntData a) = show a
haskellValue (FloatData a) = show a
instance HaskellType StorableType
where
haskellType (StorableType dim t) = arrType ++ dimComment
where
l = length dim
arrType = replicate l '[' ++ haskellType t ++ replicate l ']'
dimComment
| [] <- dim = ""
| otherwise = showSeq "{-" (map haskellValue dim) "-}"
instance HaskellValue StorableData
where
haskellValue (PrimitiveData a) = haskellValue a
haskellValue (StorableData _ as) = showSeq "[" (map haskellValue as) "]"
class Storable a => Primitive a
instance Primitive ()
instance Primitive Bool
instance Primitive Int
instance Primitive Float
data n :> a = (NaturalT n, Storable a) => ArrayList [a]
infixr 5 :>
instance (NaturalT n, Storable a, Eq a) => Eq (n :> a)
where
ArrayList a == ArrayList b = a == b
instance (NaturalT n, Storable a, Show (ListBased a)) => Show (n :> a)
where
show = show . toList
instance (NaturalT n, Storable a, Ord a) => Ord (n :> a)
where
ArrayList a `compare` ArrayList b = a `compare` b
mapArray ::
(NaturalT n, Storable a, Storable b) => (a -> b) -> (n :> a) -> (n :> b)
mapArray f (ArrayList as) = ArrayList $ map f as
class Typeable a => Storable a
where
type ListBased a :: *
type Element a :: *
replicateArray :: Element a -> a
toList :: a -> ListBased a
fromList :: ListBased a -> a
toData :: a -> StorableData
instance Storable ()
where
type ListBased () = ()
type Element () = ()
replicateArray = id
toList = id
fromList = id
toData a = PrimitiveData $ case a of
() -> UnitData
instance Storable Bool
where
type ListBased Bool = Bool
type Element Bool = Bool
replicateArray = id
toList = id
fromList = id
toData = PrimitiveData . BoolData
instance Storable Int
where
type ListBased Int = Int
type Element Int = Int
replicateArray = id
toList = id
fromList = id
toData = PrimitiveData . IntData
instance Storable Float
where
type ListBased Float = Float
type Element Float = Float
replicateArray = id
toList = id
fromList = id
toData = PrimitiveData . FloatData
instance (NaturalT n, Storable a) => Storable (n :> a)
where
type ListBased (n :> a) = [ListBased a]
type Element (n :> a) = Element a
replicateArray = ArrayList . replicate n . replicateArray
where
n = fromIntegerT (undefined :: n)
toList (ArrayList as) = map toList as
fromList as = ArrayList $ take n $ map fromList as
where
n = fromIntegerT (undefined :: n)
toData (ArrayList a) = StorableData n $ map toData a
where
n = fromIntegerT (undefined :: n)
isRectangular :: Storable a => a -> Bool
isRectangular = isJust . checkRect . toData
where
checkRect (PrimitiveData _) = return []
checkRect (StorableData _ []) = return []
checkRect (StorableData _ as) = do
dims <- mapM checkRect as
guard $ allEqual dims
return (length as : head dims)
class (Eq a, Ord a) => Typeable a
where
typeOf :: T a -> Tuple StorableType
instance Typeable ()
where
typeOf = const $ One $ StorableType [] UnitType
instance Typeable Bool
where
typeOf = const $ One $ StorableType [] BoolType
instance Typeable Int
where
typeOf = const $ One $ StorableType [] IntType
instance Typeable Float
where
typeOf = const $ One $ StorableType [] FloatType
instance (NaturalT n, Storable a) => Typeable (n :> a)
where
typeOf = const $ One $ StorableType (n:dim) t
where
n = fromIntegerT (undefined :: n)
One (StorableType dim t) = typeOf (T::T a)
instance (Typeable a, Typeable b) => Typeable (a,b)
where
typeOf = const $ Tup [typeOf (T::T a), typeOf (T::T b)]
instance (Typeable a, Typeable b, Typeable c) => Typeable (a,b,c)
where
typeOf = const $ Tup [typeOf (T::T a), typeOf (T::T b), typeOf (T::T c)]
instance (Typeable a, Typeable b, Typeable c, Typeable d) => Typeable (a,b,c,d)
where
typeOf = const $ Tup
[ typeOf (T::T a)
, typeOf (T::T b)
, typeOf (T::T c)
, typeOf (T::T d)
]
isPrimitive :: Typeable a => T a -> Bool
isPrimitive a = case typeOf a of
One (StorableType [] _) -> True
_ -> False