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