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
114 , (s :>: u) ~ True) => Vector s a -> Index u -> a
115 (Vector xs) ! i = xs !! (fromInteger (toInteger i))
117 -- ==========================
118 -- = Transforming functions =
119 -- ==========================
120 replace :: (PositiveT s, NaturalT u, (s :>: u) ~ True) =>
121 Vector s a -> Index u -> a -> Vector s a
122 replace (Vector xs) i y = Vector $ replace' xs (toInteger i) y
123 where replace' [] _ _ = []
124 replace' (_:xs) 0 y = (y:xs)
125 replace' (x:xs) n y = x : (replace' xs (n-1) y)
127 head :: PositiveT s => Vector s a -> a
128 head = P.head . unVec
130 tail :: PositiveT s => Vector s a -> Vector (Pred s) a
133 last :: PositiveT s => Vector s a -> a
134 last = P.last . unVec
136 init :: PositiveT s => Vector s a -> Vector (Pred s) a
139 take :: NaturalT i => i -> Vector s a -> Vector (Min s i) a
140 take i = liftV $ P.take (fromIntegerT i)
142 drop :: NaturalT i => i -> Vector s a -> Vector (s :-: (Min s i)) a
143 drop i = liftV $ P.drop (fromIntegerT i)
145 select :: (NaturalT f, NaturalT s, NaturalT n, (f :<: i) ~ True,
146 (((s :*: n) :+: f) :<=: i) ~ True) =>
147 f -> s -> n -> Vector i a -> Vector n a
148 select f s n = liftV (select' f' s' n')
149 where (f', s', n') = (fromIntegerT f, fromIntegerT s, fromIntegerT n)
150 select' f s n = ((selectFirst0 s n).(P.drop f))
151 selectFirst0 :: Int -> Int -> [a] -> [a]
152 selectFirst0 s n l@(x:_)
153 | n > 0 = x : selectFirst0 s (n-1) (P.drop s l)
155 selectFirst0 _ 0 [] = []
157 (<+) :: Vector s a -> a -> Vector (Succ s) a
158 (<+) (Vector xs) x = Vector (xs P.++ [x])
160 (++) :: Vector s a -> Vector s2 a -> Vector (s :+: s2) a
166 map :: (a -> b) -> Vector s a -> Vector s b
167 map f = liftV (P.map f)
169 zipWith :: (a -> b -> c) -> Vector s a -> Vector s b -> Vector s c
170 zipWith f = liftV2 (P.zipWith f)
172 foldl :: (a -> b -> a) -> a -> Vector s b -> a
173 foldl f e = (P.foldl f e) . unVec
175 foldr :: (b -> a -> a) -> a -> Vector s b -> a
176 foldr f e = (P.foldr f e) . unVec
178 zip :: Vector s a -> Vector s b -> Vector s (a, b)
181 unzip :: Vector s (a, b) -> (Vector s a, Vector s b)
182 unzip (Vector xs) = let (a,b) = P.unzip xs in (Vector a, Vector b)
184 shiftl :: (PositiveT s, NaturalT n, n ~ Pred s, s ~ Succ n) =>
185 Vector s a -> a -> Vector s a
186 shiftl xs x = x +> init xs
188 shiftr :: (PositiveT s, NaturalT n, n ~ Pred s, s ~ Succ n) =>
189 Vector s a -> a -> Vector s a
190 shiftr xs x = tail xs <+ x
192 rotl :: forall s a . NaturalT s => Vector s a -> Vector s a
194 where vlen = fromIntegerT (undefined :: s)
196 rotl' xs = let (i,[l]) = splitAt (vlen - 1) xs
199 rotr :: NaturalT s => Vector s a -> Vector s a
203 rotr' (x:xs) = xs P.++ [x]
205 concat :: Vector s1 (Vector s2 a) -> Vector (s1 :*: s2) a
206 concat = liftV (P.foldr ((P.++).unVec) [])
208 reverse :: Vector s a -> Vector s a
209 reverse = liftV P.reverse
211 iterate :: NaturalT s => (a -> a) -> a -> Vector s a
212 iterate = iteraten (undefined :: s)
214 iteraten :: NaturalT s => s -> (a -> a) -> a -> Vector s a
215 iteraten s f x = let s' = fromIntegerT s in Vector (P.take s' $ P.iterate f x)
217 generate :: NaturalT s => (a -> a) -> a -> Vector s a
218 generate = generaten (undefined :: s)
220 generaten :: NaturalT s => s -> (a -> a) -> a -> Vector s a
221 generaten s f x = let s' = fromIntegerT s in Vector (P.take s' $ P.tail $ P.iterate f x)
223 copy :: NaturalT s => a -> Vector s a
224 copy x = copyn (undefined :: s) x
226 copyn :: NaturalT s => s -> a -> Vector s a
227 copyn s x = iteraten s id x
229 split :: ( NaturalT s
231 ) => Vector s a -> (Vector (Div2 s) a, Vector (Div2 s) a)
232 split (Vector xs) = (Vector (P.take vlen xs), Vector (P.drop vlen xs))
234 vlen = round ((fromIntegral (P.length xs)) / 2)
239 instance Show a => Show (Vector s a) where
240 showsPrec _ = showV.unVec
241 where showV [] = showString "<>"
242 showV (x:xs) = showChar '<' . shows x . showl xs
243 where showl [] = showChar '>'
244 showl (x:xs) = showChar ',' . shows x .
247 instance (Read a, NaturalT nT) => Read (Vector nT a) where
249 | all fitsLength possibilities = P.map toReadS possibilities
250 | otherwise = error (fName P.++ ": string/dynamic length mismatch")
252 fName = "Data.Param.TFVec.read"
253 expectedL = fromIntegerT (undefined :: nT)
254 possibilities = readVectorList str
255 fitsLength (_, l, _) = l == expectedL
256 toReadS (xs, _, rest) = (Vector xs, rest)
258 instance NaturalT s => DF.Foldable (Vector s) where
261 instance NaturalT s => Functor (Vector s) where
264 instance NaturalT s => DT.Traversable (Vector s) where
265 traverse f = (fmap Vector).(DT.traverse f).unVec
267 instance (Lift a, NaturalT nT) => Lift (Vector nT a) where
268 lift (Vector xs) = [| unsafeVectorCoerse
269 $(decLiteralV (fromIntegerT (undefined :: nT)))
272 -- ======================
273 -- = Internal Functions =
274 -- ======================
275 liftV :: ([a] -> [b]) -> Vector nT a -> Vector nT' b
276 liftV f = Vector . f . unVec
278 liftV2 :: ([a] -> [b] -> [c]) -> Vector s a -> Vector s2 b -> Vector s3 c
279 liftV2 f a b = Vector (f (unVec a) (unVec b))
281 splitAtM :: Int -> [a] -> Maybe ([a],[a])
282 splitAtM n xs = splitAtM' n [] xs
283 where splitAtM' 0 xs ys = Just (xs, ys)
284 splitAtM' n xs (y:ys) | n > 0 = do
285 (ls, rs) <- splitAtM' (n-1) xs ys
287 splitAtM' _ _ _ = Nothing
289 unsafeVectorCoerse :: nT' -> Vector nT a -> Vector nT' a
290 unsafeVectorCoerse _ (Vector v) = (Vector v)
292 readVectorList :: Read a => String -> [([a], Int, String)]
293 readVectorList = readParen' False (\r -> [pr | ("<",s) <- lexVector r,
296 readl s = [([],0,t) | (">",t) <- lexVector s] P.++
297 [(x:xs,1+n,u) | (x,t) <- reads s,
298 (xs, n, u) <- readl' t]
299 readl' s = [([],0,t) | (">",t) <- lexVector s] P.++
300 [(x:xs,1+n,v) | (",",t) <- lex s,
302 (xs,n,v) <- readl' u]
303 readParen' b g = if b then mandatory else optional
304 where optional r = g r P.++ mandatory r
305 mandatory r = [(x,n,u) | ("(",s) <- lexVector r,
306 (x,n,t) <- optional s,
307 (")",u) <- lexVector t]
309 -- Custom lexer for FSVecs, we cannot use lex directly because it considers
310 -- sequences of < and > as unique lexemes, and that breaks nested FSVecs, e.g.
312 lexVector :: ReadS String
313 lexVector ('>':rest) = [(">",rest)]
314 lexVector ('<':rest) = [("<",rest)]
315 lexVector str = lex str