Use new TH.TypeLib for vectorTH

[matthijs/master-project/support/tfvec.git] / Data / Param / TFVec.hs

diff --git a/Data/Param/TFVec.hs b/Data/Param/TFVec.hs
index 50b2fda258b44de6c285aeacae5889aeeddd5ab9..529c52c12a163dfb3b31397ddfbd987189e78ca4 100644 (file)
--- a/Data/Param/TFVec.hs
+++ b/Data/Param/TFVec.hs
@@ -35,7 +35,6 @@ module Data.Param.TFVec
   , take
   , drop
   , select
---  , group
   , (<+)
   , (++)
   , map
@@ -51,26 +50,31 @@ module Data.Param.TFVec
   , 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)
 
@@ -94,8 +98,11 @@ singleton x = x +> empty
 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:xs) = [| x +> $(vectorTH xs) |]
 
 unsafeVector :: NaturalT s => s -> [a] -> TFVec s a
 unsafeVector l xs
@@ -175,13 +182,6 @@ select f s n = liftV (select' f' s' n')
           | 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])
 
@@ -217,11 +217,18 @@ shiftr :: (PositiveT s, NaturalT n, n ~ Pred s, s ~ Succ n) =>
           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
-
-rotr :: (PositiveT s, s ~ Succ (Pred s)) => TFVec s a -> TFVec s a
-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) [])
@@ -229,17 +236,23 @@ 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)
+
+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 = iterate s id x
+copyn s x = iteraten s id x
 
 -- =============
 -- = Instances =
@@ -272,10 +285,20 @@ instance NaturalT s => Functor (TFVec s) where
 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 =