clash/Data/Param/Vector.hs

   1 {-# LANGUAGE StandaloneDeriving, ExistentialQuantification, ScopedTypeVariables, TemplateHaskell, TypeOperators, TypeFamilies #-}
   2 module Data.Param.Vector
   3   ( Vector
   4   , empty
   5   , (+>)
   6   , singleton
   7   , vectorTH
   8   , unsafeVector
   9   , readVector
  10   , length
  11   , lengthT
  12   , fromVector
  13   , null
  14   , (!)
  15   , replace
  16   , head
  17   , last
  18   , init
  19   , tail
  20   , take
  21   , drop
  22   , select
  23   , (<+)
  24   , (++)
  25   , map
  26   , zipWith
  27   , foldl
  28   , foldr
  29   , zip
  30   , unzip
  31   , shiftIntoL
  32   , shiftIntoR
  33   , rotl
  34   , rotr
  35   , concat
  36   , reverse
  37   , iterate
  38   , iteraten
  39   , generate
  40   , generaten
  41   , copy
  42   , copyn
  43   , split
  44   ) where
  45
  46 import Types
  47 import Types.Data.Num
  48 import Types.Data.Num.Decimal.Literals.TH
  49 import Data.Param.Index
  50
  51 import Data.Typeable
  52 import qualified Prelude as P
  53 import Prelude hiding (
  54   null, length, head, tail, last, init, take, drop, (++), map, foldl, foldr,
  55   zipWith, zip, unzip, concat, reverse, iterate )
  56 import qualified Data.Foldable as DF (Foldable, foldr)
  57 import qualified Data.Traversable as DT (Traversable(traverse))
  58 import Language.Haskell.TH hiding (Pred)
  59 import Language.Haskell.TH.Syntax (Lift(..))
  60
  61 newtype (NaturalT s) => Vector s a = Vector {unVec :: [a]}
  62   deriving Eq
  63
  64 -- deriving instance (NaturalT s, Typeable s, Data s, Typeable a, Data a) => Data (TFVec s a)
  65
  66 -- ==========================
  67 -- = Constructing functions =
  68 -- ==========================
  69
  70 empty :: Vector D0 a
  71 empty = Vector []
  72
  73 (+>) :: a -> Vector s a -> Vector (Succ s) a
  74 x +> (Vector xs) = Vector (x:xs)
  75
  76 infix 5 +>
  77
  78 singleton :: a -> Vector D1 a
  79 singleton x = x +> empty
  80
  81 -- FIXME: Not the most elegant solution... but it works for now in clash
  82 vectorTH :: (Lift a) => [a] -> ExpQ
  83 -- vectorTH xs = sigE [| (TFVec xs) |] (decTFVecT (toInteger (P.length xs)) xs)
  84 vectorTH [] = [| empty |]
  85 vectorTH [x] = [| singleton x |]
  86 vectorTH (x:xs) = [| x +> $(vectorTH xs) |]
  87
  88 unsafeVector :: NaturalT s => s -> [a] -> Vector s a
  89 unsafeVector l xs
  90   | fromIntegerT l /= P.length xs =
  91     error (show 'unsafeVector P.++ ": dynamic/static lenght mismatch")
  92   | otherwise = Vector xs
  93
  94 readVector :: (Read a, NaturalT s) => String -> Vector s a
  95 readVector = read
  96
  97 -- =======================
  98 -- = Observing functions =
  99 -- =======================
 100 length :: forall s a . NaturalT s => Vector s a -> Int
 101 length _ = fromIntegerT (undefined :: s)
 102
 103 lengthT :: NaturalT s => Vector s a -> s
 104 lengthT = undefined
 105
 106 fromVector :: NaturalT s => Vector s a -> [a]
 107 fromVector (Vector xs) = xs
 108
 109 null :: Vector D0 a -> Bool
 110 null _ = True
 111
 112 (!) :: PositiveT s => Vector s a -> Index s -> a
 113 (Vector xs) ! i = xs !! (fromInteger (toInteger i))
 114
 115 -- ==========================
 116 -- = Transforming functions =
 117 -- ==========================
 118 replace :: PositiveT s =>
 119   Vector s a -> Index s -> a -> Vector s a
 120 replace (Vector xs) i y = Vector $ replace' xs (toInteger i) y
 121   where replace' []     _ _ = []
 122         replace' (_:xs) 0 y = (y:xs)
 123         replace' (x:xs) n y = x : (replace' xs (n-1) y)
 124
 125 head :: PositiveT s => Vector s a -> a
 126 head = P.head . unVec
 127
 128 tail :: PositiveT s => Vector s a -> Vector (Pred s) a
 129 tail = liftV P.tail
 130
 131 last :: PositiveT s => Vector s a -> a
 132 last = P.last . unVec
 133
 134 init :: PositiveT s => Vector s a -> Vector (Pred s) a
 135 init = liftV P.init
 136
 137 take :: NaturalT i => i -> Vector s a -> Vector (Min s i) a
 138 take i = liftV $ P.take (fromIntegerT i)
 139
 140 drop :: NaturalT i => i -> Vector s a -> Vector (s :-: (Min s i)) a
 141 drop i = liftV $ P.drop (fromIntegerT i)
 142
 143 select :: (NaturalT f, NaturalT s, NaturalT n, (f :<: i) ~ True,
 144           (((s :*: n) :+: f) :<=: i) ~ True) =>
 145           f -> s -> n -> Vector i a -> Vector n a
 146 select f s n = liftV (select' f' s' n')
 147   where (f', s', n') = (fromIntegerT f, fromIntegerT s, fromIntegerT n)
 148         select' f s n = ((selectFirst0 s n).(P.drop f))
 149         selectFirst0 :: Int -> Int -> [a] -> [a]
 150         selectFirst0 s n l@(x:_)
 151           | n > 0 = x : selectFirst0 s (n-1) (P.drop s l)
 152           | otherwise = []
 153         selectFirst0 _ 0 [] = []
 154
 155 (<+) :: Vector s a -> a -> Vector (Succ s) a
 156 (<+) (Vector xs) x = Vector (xs P.++ [x])
 157
 158 (++) :: Vector s a -> Vector s2 a -> Vector (s :+: s2) a
 159 (++) = liftV2 (P.++)
 160
 161 infixl 5 <+
 162 infixr 5 ++
 163
 164 map :: (a -> b) -> Vector s a -> Vector s b
 165 map f = liftV (P.map f)
 166
 167 zipWith :: (a -> b -> c) -> Vector s a -> Vector s b -> Vector s c
 168 zipWith f = liftV2 (P.zipWith f)
 169
 170 foldl :: (a -> b -> a) -> a -> Vector s b -> a
 171 foldl f e = (P.foldl f e) . unVec
 172
 173 foldr :: (b -> a -> a) -> a -> Vector s b -> a
 174 foldr f e = (P.foldr f e) . unVec
 175
 176 zip :: Vector s a -> Vector s b -> Vector s (a, b)
 177 zip = liftV2 P.zip
 178
 179 unzip :: Vector s (a, b) -> (Vector s a, Vector s b)
 180 unzip (Vector xs) = let (a,b) = P.unzip xs in (Vector a, Vector b)
 181
 182 shiftIntoL :: (PositiveT s, NaturalT n, n ~ Pred s, s ~ Succ n) =>
 183               Vector s a -> a -> Vector s a
 184 shiftIntoL xs x = x +> init xs
 185
 186 shiftIntoR :: (PositiveT s, NaturalT n, n ~ Pred s, s ~ Succ n) =>
 187               Vector s a -> a -> Vector s a
 188 shiftIntoR xs x = tail xs <+ x
 189
 190 rotl :: forall s a . NaturalT s => Vector s a -> Vector s a
 191 rotl = liftV rotl'
 192   where vlen = fromIntegerT (undefined :: s)
 193         rotl' [] = []
 194         rotl' xs = let (i,[l]) = splitAt (vlen - 1) xs
 195                    in l : i
 196
 197 rotr :: NaturalT s => Vector s a -> Vector s a
 198 rotr = liftV rotr'
 199   where
 200     rotr' [] = []
 201     rotr' (x:xs) = xs P.++ [x]
 202
 203 concat :: Vector s1 (Vector s2 a) -> Vector (s1 :*: s2) a
 204 concat = liftV (P.foldr ((P.++).unVec) [])
 205
 206 reverse :: Vector s a -> Vector s a
 207 reverse = liftV P.reverse
 208
 209 iterate :: NaturalT s => (a -> a) -> a -> Vector s a
 210 iterate = iteraten (undefined :: s)
 211
 212 iteraten :: NaturalT s => s -> (a -> a) -> a -> Vector s a
 213 iteraten s f x = let s' = fromIntegerT s in Vector (P.take s' $ P.iterate f x)
 214
 215 generate :: NaturalT s => (a -> a) -> a -> Vector s a
 216 generate = generaten (undefined :: s)
 217
 218 generaten :: NaturalT s => s -> (a -> a) -> a -> Vector s a
 219 generaten s f x = let s' = fromIntegerT s in Vector (P.take s' $ P.tail $ P.iterate f x)
 220
 221 copy :: NaturalT s => a -> Vector s a
 222 copy x = copyn (undefined :: s) x
 223
 224 copyn :: NaturalT s => s -> a -> Vector s a
 225 copyn s x = iteraten s id x
 226
 227 split :: ( NaturalT s
 228          -- , IsEven s ~ True
 229          ) => Vector s a -> (Vector (Div2 s) a, Vector (Div2 s) a)
 230 split (Vector xs) = (Vector (P.take vlen xs), Vector (P.drop vlen xs))
 231   where
 232     vlen = round ((fromIntegral (P.length xs)) / 2)
 233
 234 -- =============
 235 -- = Instances =
 236 -- =============
 237 instance Show a => Show (Vector s a) where
 238   showsPrec _ = showV.unVec
 239     where showV []      = showString "<>"
 240           showV (x:xs)  = showChar '<' . shows x . showl xs
 241                             where showl []      = showChar '>'
 242                                   showl (x:xs)  = showChar ',' . shows x .
 243                                                   showl xs
 244
 245 instance (Read a, NaturalT nT) => Read (Vector nT a) where
 246   readsPrec _ str
 247     | all fitsLength possibilities = P.map toReadS possibilities
 248     | otherwise = error (fName P.++ ": string/dynamic length mismatch")
 249     where
 250       fName = "Data.Param.TFVec.read"
 251       expectedL = fromIntegerT (undefined :: nT)
 252       possibilities = readVectorList str
 253       fitsLength (_, l, _) = l == expectedL
 254       toReadS (xs, _, rest) = (Vector xs, rest)
 255
 256 instance NaturalT s => DF.Foldable (Vector s) where
 257  foldr = foldr
 258
 259 instance NaturalT s => Functor (Vector s) where
 260  fmap = map
 261
 262 instance NaturalT s => DT.Traversable (Vector s) where
 263   traverse f = (fmap Vector).(DT.traverse f).unVec
 264
 265 instance (Lift a, NaturalT nT) => Lift (Vector nT a) where
 266   lift (Vector xs) = [|  unsafeVectorCoerse
 267                          $(decLiteralV (fromIntegerT (undefined :: nT)))
 268                           (Vector xs) |]
 269
 270 -- ======================
 271 -- = Internal Functions =
 272 -- ======================
 273 liftV :: ([a] -> [b]) -> Vector nT a -> Vector nT' b
 274 liftV f = Vector . f . unVec
 275
 276 liftV2 :: ([a] -> [b] -> [c]) -> Vector s a -> Vector s2 b -> Vector s3 c
 277 liftV2 f a b = Vector (f (unVec a) (unVec b))
 278
 279 splitAtM :: Int -> [a] -> Maybe ([a],[a])
 280 splitAtM n xs = splitAtM' n [] xs
 281   where splitAtM' 0 xs ys = Just (xs, ys)
 282         splitAtM' n xs (y:ys) | n > 0 = do
 283           (ls, rs) <- splitAtM' (n-1) xs ys
 284           return (y:ls,rs)
 285         splitAtM' _ _ _ = Nothing
 286
 287 unsafeVectorCoerse :: nT' -> Vector nT a -> Vector nT' a
 288 unsafeVectorCoerse _ (Vector v) = (Vector v)
 289
 290 readVectorList :: Read a => String -> [([a], Int, String)]
 291 readVectorList = readParen' False (\r -> [pr | ("<",s) <- lexVector r,
 292                                               pr <- readl s])
 293   where
 294     readl   s = [([],0,t) | (">",t) <- lexVector s] P.++
 295                             [(x:xs,1+n,u) | (x,t)       <- reads s,
 296                                             (xs, n, u)  <- readl' t]
 297     readl'  s = [([],0,t) | (">",t) <- lexVector s] P.++
 298                             [(x:xs,1+n,v) | (",",t)   <- lex s,
 299                                             (x,u)     <- reads t,
 300                                             (xs,n,v)  <- readl' u]
 301     readParen' b g  = if b then mandatory else optional
 302       where optional r  = g r P.++ mandatory r
 303             mandatory r = [(x,n,u) | ("(",s)  <- lexVector r,
 304                                       (x,n,t) <- optional s,
 305                                       (")",u) <- lexVector t]
 306
 307 -- Custom lexer for FSVecs, we cannot use lex directly because it considers
 308 -- sequences of < and > as unique lexemes, and that breaks nested FSVecs, e.g.
 309 -- <<1,2><3,4>>
 310 lexVector :: ReadS String
 311 lexVector ('>':rest) = [(">",rest)]
 312 lexVector ('<':rest) = [("<",rest)]
 313 lexVector str = lex str
 314