Data/Param/TFVec.hs

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