1 {-# LANGUAGE StandaloneDeriving, ExistentialQuantification, ScopedTypeVariables, TemplateHaskell, TypeOperators, TypeFamilies #-}
2 module Data.Param.Vector
48 import Types.Data.Num.Decimal.Literals.TH
49 import Data.Param.Index
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(..))
61 newtype (NaturalT s) => Vector s a = Vector {unVec :: [a]}
64 -- deriving instance (NaturalT s, Typeable s, Data s, Typeable a, Data a) => Data (TFVec s a)
66 -- ==========================
67 -- = Constructing functions =
68 -- ==========================
73 (+>) :: a -> Vector s a -> Vector (Succ s) a
74 x +> (Vector xs) = Vector (x:xs)
78 singleton :: a -> Vector D1 a
79 singleton x = x +> empty
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) |]
88 unsafeVector :: NaturalT s => s -> [a] -> Vector s a
90 | fromIntegerT l /= P.length xs =
91 error (show 'unsafeVector P.++ ": dynamic/static lenght mismatch")
92 | otherwise = Vector xs
94 readVector :: (Read a, NaturalT s) => String -> Vector s a
97 -- =======================
98 -- = Observing functions =
99 -- =======================
100 length :: forall s a . NaturalT s => Vector s a -> Int
101 length _ = fromIntegerT (undefined :: s)
103 lengthT :: NaturalT s => Vector s a -> s
106 fromVector :: NaturalT s => Vector s a -> [a]
107 fromVector (Vector xs) = xs
109 null :: Vector D0 a -> Bool
112 (!) :: PositiveT s => Vector s a -> Index s -> a
113 (Vector xs) ! i = xs !! (fromInteger (toInteger i))
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)
125 head :: PositiveT s => Vector s a -> a
126 head = P.head . unVec
128 tail :: PositiveT s => Vector s a -> Vector (Pred s) a
131 last :: PositiveT s => Vector s a -> a
132 last = P.last . unVec
134 init :: PositiveT s => Vector s a -> Vector (Pred s) a
137 take :: NaturalT i => i -> Vector s a -> Vector (Min s i) a
138 take i = liftV $ P.take (fromIntegerT i)
140 drop :: NaturalT i => i -> Vector s a -> Vector (s :-: (Min s i)) a
141 drop i = liftV $ P.drop (fromIntegerT i)
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)
153 selectFirst0 _ 0 [] = []
155 (<+) :: Vector s a -> a -> Vector (Succ s) a
156 (<+) (Vector xs) x = Vector (xs P.++ [x])
158 (++) :: Vector s a -> Vector s2 a -> Vector (s :+: s2) a
164 map :: (a -> b) -> Vector s a -> Vector s b
165 map f = liftV (P.map f)
167 zipWith :: (a -> b -> c) -> Vector s a -> Vector s b -> Vector s c
168 zipWith f = liftV2 (P.zipWith f)
170 foldl :: (a -> b -> a) -> a -> Vector s b -> a
171 foldl f e = (P.foldl f e) . unVec
173 foldr :: (b -> a -> a) -> a -> Vector s b -> a
174 foldr f e = (P.foldr f e) . unVec
176 zip :: Vector s a -> Vector s b -> Vector s (a, b)
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)
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
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
190 rotl :: forall s a . NaturalT s => Vector s a -> Vector s a
192 where vlen = fromIntegerT (undefined :: s)
194 rotl' xs = let (i,[l]) = splitAt (vlen - 1) xs
197 rotr :: NaturalT s => Vector s a -> Vector s a
201 rotr' (x:xs) = xs P.++ [x]
203 concat :: Vector s1 (Vector s2 a) -> Vector (s1 :*: s2) a
204 concat = liftV (P.foldr ((P.++).unVec) [])
206 reverse :: Vector s a -> Vector s a
207 reverse = liftV P.reverse
209 iterate :: NaturalT s => (a -> a) -> a -> Vector s a
210 iterate = iteraten (undefined :: s)
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)
215 generate :: NaturalT s => (a -> a) -> a -> Vector s a
216 generate = generaten (undefined :: s)
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)
221 copy :: NaturalT s => a -> Vector s a
222 copy x = copyn (undefined :: s) x
224 copyn :: NaturalT s => s -> a -> Vector s a
225 copyn s x = iteraten s id x
227 split :: ( NaturalT s
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))
232 vlen = round ((fromIntegral (P.length xs)) / 2)
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 .
245 instance (Read a, NaturalT nT) => Read (Vector nT a) where
247 | all fitsLength possibilities = P.map toReadS possibilities
248 | otherwise = error (fName P.++ ": string/dynamic length mismatch")
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)
256 instance NaturalT s => DF.Foldable (Vector s) where
259 instance NaturalT s => Functor (Vector s) where
262 instance NaturalT s => DT.Traversable (Vector s) where
263 traverse f = (fmap Vector).(DT.traverse f).unVec
265 instance (Lift a, NaturalT nT) => Lift (Vector nT a) where
266 lift (Vector xs) = [| unsafeVectorCoerse
267 $(decLiteralV (fromIntegerT (undefined :: nT)))
270 -- ======================
271 -- = Internal Functions =
272 -- ======================
273 liftV :: ([a] -> [b]) -> Vector nT a -> Vector nT' b
274 liftV f = Vector . f . unVec
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))
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
285 splitAtM' _ _ _ = Nothing
287 unsafeVectorCoerse :: nT' -> Vector nT a -> Vector nT' a
288 unsafeVectorCoerse _ (Vector v) = (Vector v)
290 readVectorList :: Read a => String -> [([a], Int, String)]
291 readVectorList = readParen' False (\r -> [pr | ("<",s) <- lexVector r,
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,
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]
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.
310 lexVector :: ReadS String
311 lexVector ('>':rest) = [(">",rest)]
312 lexVector ('<':rest) = [("<",rest)]
313 lexVector str = lex str