, take
, drop
, select
- , group
, (<+)
, (++)
, map
, concat
, reverse
, iterate
+ , iteraten
, generate
+ , generaten
, copy
+ , copyn
) where
-
import Types
+import Types.Data.Num
import Types.Data.Num.Decimal.Literals.TH
import Data.RangedWord
-import Data.Generics (Data, Typeable)
+import Data.Generics (Data)
+import Data.Typeable
import qualified Prelude as P
import Prelude hiding (
null, length, head, tail, last, init, take, drop, (++), map, foldl, foldr,
zipWith, zip, unzip, concat, reverse, iterate )
import qualified Data.Foldable as DF (Foldable, foldr)
import qualified Data.Traversable as DT (Traversable(traverse))
-import Language.Haskell.TH
+import Language.Haskell.TH hiding (Pred)
import Language.Haskell.TH.Syntax (Lift(..))
+import Language.Haskell.TH.TypeLib
+
newtype (NaturalT s) => TFVec s a = TFVec {unTFVec :: [a]}
deriving (Eq, Typeable)
empty :: TFVec D0 a
empty = TFVec []
-{-# NOINLINE (+>) #-}
(+>) :: a -> TFVec s a -> TFVec (Succ s) a
x +> (TFVec xs) = TFVec (x:xs)
vectorCPS :: [a] -> (forall s . NaturalT s => TFVec s a -> w) -> w
vectorCPS xs = unsafeVectorCPS (toInteger (P.length xs)) xs
-vectorTH :: Lift a => [a] -> ExpQ
-vectorTH xs = (vectorCPS xs) lift
+-- FIXME: Not the most elegant solution... but it works for now in clash
+vectorTH :: (Lift a, Typeable a) => [a] -> ExpQ
+-- vectorTH xs = sigE [| (TFVec xs) |] (decTFVecT (toInteger (P.length xs)) xs)
+vectorTH [] = [| empty |]
+vectorTH [x] = [| singleton x |]
+vectorTH (x:xs) = [| x +> $(vectorTH xs) |]
unsafeVector :: NaturalT s => s -> [a] -> TFVec s a
unsafeVector l xs
| otherwise = []
selectFirst0 _ 0 [] = []
-group :: PositiveT n => n -> TFVec s a -> TFVec (Div s n) (TFVec n a)
-group n = liftV (group' (fromIntegerT n))
- where group' :: Int -> [a] -> [TFVec s a]
- group' n xs = case splitAtM n xs of
- Nothing -> []
- Just (ls, rs) -> TFVec ls : group' n rs
-
(<+) :: TFVec s a -> a -> TFVec (Succ s) a
(<+) (TFVec xs) x = TFVec (xs P.++ [x])
TFVec s a -> a -> TFVec s a
shiftr xs x = tail xs <+ x
-rotl :: (PositiveT s, s ~ Succ (Pred s)) => TFVec s a -> TFVec s a
-rotl xs = last xs +> init xs
-
-class Rotr a where rotr :: a -> a
-instance Rotr (TFVec D0 a) where rotr xs = xs
-instance (PositiveT s, s ~ Succ (Pred s)) => Rotr (TFVec s a) where rotr xs = tail xs <+ head xs
+rotl :: forall s a . NaturalT s => TFVec s a -> TFVec s a
+rotl = liftV rotl'
+ where vlen = fromIntegerT (undefined :: s)
+ rotl' [] = []
+ rotl' xs = let (i,[l]) = splitAt (vlen - 1) xs
+ in l : i
+
+rotr :: NaturalT s => TFVec s a -> TFVec s a
+rotr = liftV rotr'
+ where
+ rotr' [] = []
+ rotr' (x:xs) = xs P.++ [x]
concat :: TFVec s1 (TFVec s2 a) -> TFVec (s1 :*: s2) a
concat = liftV (P.foldr ((P.++).unTFVec) [])
reverse :: TFVec s a -> TFVec s a
reverse = liftV P.reverse
-iterate :: NaturalT s => s -> (a -> a) -> a -> TFVec s a
-iterate s f x = let s' = fromIntegerT s in TFVec (P.take s' $ P.iterate f x)
+iterate :: NaturalT s => (a -> a) -> a -> TFVec s a
+iterate = iteraten (undefined :: s)
+
+iteraten :: NaturalT s => s -> (a -> a) -> a -> TFVec s a
+iteraten s f x = let s' = fromIntegerT s in TFVec (P.take s' $ P.iterate f x)
-generate :: NaturalT s => s -> (a -> a) -> a -> TFVec s a
-generate s f x = let s' = fromIntegerT s in TFVec (P.take s' $ P.tail $ P.iterate f x)
+generate :: NaturalT s => (a -> a) -> a -> TFVec s a
+generate = generaten (undefined :: s)
-copy :: NaturalT s => s -> a -> TFVec s a
-copy s x = iterate s id x
+generaten :: NaturalT s => s -> (a -> a) -> a -> TFVec s a
+generaten s f x = let s' = fromIntegerT s in TFVec (P.take s' $ P.tail $ P.iterate f x)
+
+copy :: NaturalT s => a -> TFVec s a
+copy x = copyn (undefined :: s) x
+
+copyn :: NaturalT s => s -> a -> TFVec s a
+copyn s x = iteraten s id x
-- =============
-- = Instances =
instance NaturalT s => DT.Traversable (TFVec s) where
traverse f = (fmap TFVec).(DT.traverse f).unTFVec
-instance (Lift a, NaturalT nT) => Lift (TFVec nT a) where
- lift (TFVec xs) = [| unsafeTFVecCoerse
- $(decLiteralV (fromIntegerT (undefined :: nT)))
- (TFVec xs) |]
+-- instance (Lift a, NaturalT nT) => Lift (TFVec nT a) where
+-- lift (TFVec xs) = [| unsafeTFVecCoerse
+-- $(decLiteralV (fromIntegerT (undefined :: nT)))
+-- (TFVec xs) |]
+
+instance (Lift a, Typeable a, NaturalT nT) => Lift (TFVec nT a) where
+ lift (TFVec xs) = sigE [| (TFVec xs) |] (decTFVecT (fromIntegerT (undefined :: nT)) xs)
+
+decTFVecT :: Typeable x => Integer -> x -> Q Type
+decTFVecT n a = appT (appT (conT (''TFVec)) (decLiteralT n)) elemT
+ where
+ (con,reps) = splitTyConApp (typeOf a)
+ elemT = typeRep2Type (P.head reps)
+
-- ======================
-- = Internal Functions =
lexTFVec ('>':rest) = [(">",rest)]
lexTFVec ('<':rest) = [("<",rest)]
lexTFVec str = lex str
-
\ No newline at end of file
+