From: Christiaan Baaij <christiaan.baaij@gmail.com>
Date: Fri, 19 Jun 2009 12:57:14 +0000 (+0200)
Subject: Initial commit
X-Git-Url: https://git.stderr.nl/gitweb?p=matthijs%2Fmaster-project%2Fsupport%2Ftfvec.git;a=commitdiff_plain;h=a0076ff5e9593b4ccfb3fff7637d6338307e09ef

Initial commit
---

a0076ff5e9593b4ccfb3fff7637d6338307e09ef
diff --git a/Data/Param/TFVec.hs b/Data/Param/TFVec.hs
new file mode 100644
index 0000000..673d69b
--- /dev/null
+++ b/Data/Param/TFVec.hs
@@ -0,0 +1,327 @@
+------------------------------------------------------------------------------
+-- |
+-- Module       : Data.Param.TFVec
+-- Copyright    : (c) 2009 Christiaan Baaij
+-- Licence      : BSD-style (see the file LICENCE)
+--
+-- Maintainer   : christiaan.baaij@gmail.com
+-- Stability    : experimental
+-- Portability  : non-portable
+--
+-- 'TFVec': Fixed sized vectors. Vectors with numerically parameterized size,
+--          using type-level numerals from 'tfp' library
+--
+------------------------------------------------------------------------------
+
+module Data.Param.TFVec
+  ( TFVec
+  , empty
+  , (+>)
+  , singleton
+  , vectorCPS
+  , vectorTH
+  , unsafeVector
+  , readTFVec
+  , length
+  , lengthT
+  , fromVector
+  , null
+  , (!)
+  , replace
+  , head
+  , last
+  , init
+  , tail
+  , take
+  , drop
+  , select
+  , group
+  , (<+)
+  , (++)
+  , map
+  , zipWith
+  , foldl
+  , foldr
+  , zip
+  , unzip
+  , shiftl
+  , shiftr
+  , rotl
+  , rotr
+  , concat
+  , reverse
+  , iterate
+  , generate
+  , copy
+  ) where
+    
+
+import Types
+import Types.Data.Num.Decimal.Literals.TH
+import Data.RangedWord
+
+import Data.Generics (Data, Typeable)
+import qualified Prelude as P
+import Prelude hiding (
+  null, length, head, tail, last, init, take, drop, (++), map, foldl, foldr,
+  zipWith, zip, unzip, concat, reverse, iterate )
+import qualified Data.Foldable as DF (Foldable, foldr)
+import qualified Data.Traversable as DT (Traversable(traverse))
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax (Lift(..))
+
+newtype (NaturalT s) => TFVec s a = TFVec {unTFVec :: [a]}
+  deriving (Eq, Typeable)
+
+deriving instance (NaturalT s, Typeable s, Data s, Typeable a, Data a) => Data (TFVec s a)
+
+-- ==========================
+-- = Constructing functions =
+-- ==========================
+                                                  
+empty :: TFVec D0 a
+empty = TFVec []
+
+{-# NOINLINE (+>) #-}
+(+>) :: a -> TFVec s a -> TFVec (Succ s) a
+x +> (TFVec xs) = TFVec (x:xs)
+
+infix 5 +>
+
+singleton :: a -> TFVec D1 a
+singleton x = x +> empty
+
+vectorCPS :: [a] -> (forall s . NaturalT s => TFVec s a -> w) -> w
+vectorCPS xs = unsafeVectorCPS (toInteger (P.length xs)) xs
+
+vectorTH :: Lift a => [a] -> ExpQ
+vectorTH xs = (vectorCPS xs) lift
+
+unsafeVector :: NaturalT s => s -> [a] -> TFVec s a
+unsafeVector l xs
+  | fromIntegerT l /= P.length xs =
+    error (show 'unsafeVector P.++ ": dynamic/static lenght mismatch")
+  | otherwise = TFVec xs
+
+readTFVec :: (Read a, NaturalT s) => String -> TFVec s a
+readTFVec = read
+
+readTFVecCPS :: Read a => String -> (forall s . NaturalT s => TFVec s a -> w) -> w
+readTFVecCPS str = unsafeVectorCPS (toInteger l) xs
+ where fName = show 'readTFVecCPS
+       (xs,l) = case [(xs,l) | (xs,l,rest) <- readTFVecList str,  
+                           ("","") <- lexTFVec rest] of
+                       [(xs,l)] -> (xs,l)
+                       []   -> error (fName P.++ ": no parse")
+                       _    -> error (fName P.++ ": ambiguous parse")
+        
+-- =======================
+-- = Observing functions =
+-- =======================
+length :: forall s a . NaturalT s => TFVec s a -> Int
+length _ = fromIntegerT (undefined :: s)
+
+lengthT :: NaturalT s => TFVec s a -> s
+lengthT = undefined
+
+fromVector :: NaturalT s => TFVec s a -> [a]
+fromVector (TFVec xs) = xs
+
+null :: TFVec D0 a -> Bool
+null _ = True
+
+(!) ::  ( PositiveT s
+        , NaturalT u
+        , (s :>: u) ~ True) => TFVec s a -> RangedWord u -> a
+(TFVec xs) ! i = xs !! (fromInteger (toInteger i))
+
+-- ==========================
+-- = Transforming functions =
+-- ==========================
+replace :: (PositiveT s, NaturalT u, (s :>: u) ~ True) =>
+  TFVec s a -> RangedWord u -> a -> TFVec s a
+replace (TFVec xs) i y = TFVec $ replace' xs (toInteger i) y
+  where replace' []     _ _ = []
+        replace' (_:xs) 0 y = (y:xs)
+        replace' (x:xs) n y = x : (replace' xs (n-1) y)
+  
+head :: PositiveT s => TFVec s a -> a
+head = P.head . unTFVec
+
+tail :: PositiveT s => TFVec s a -> TFVec (Pred s) a
+tail = liftV P.tail
+
+last :: PositiveT s => TFVec s a -> a
+last = P.last . unTFVec
+
+init :: PositiveT s => TFVec s a -> TFVec (Pred s) a
+init = liftV P.init
+
+take :: NaturalT i => i -> TFVec s a -> TFVec (Min s i) a
+take i = liftV $ P.take (fromIntegerT i)
+
+drop :: NaturalT i => i -> TFVec s a -> TFVec (s :-: (Min s i)) a
+drop i = liftV $ P.drop (fromIntegerT i)
+
+select :: (NaturalT f, NaturalT s, NaturalT n, (f :<: i) ~ True, 
+          (((s :*: n) :+: f) :<=: i) ~ True) => 
+          f -> s -> n -> TFVec i a -> TFVec n a
+select f s n = liftV (select' f' s' n')
+  where (f', s', n') = (fromIntegerT f, fromIntegerT s, fromIntegerT n)
+        select' f s n = ((selectFirst0 s n).(P.drop f))
+        selectFirst0 :: Int -> Int -> [a] -> [a]
+        selectFirst0 s n l@(x:_)
+          | n > 0 = x : selectFirst0 s (n-1) (P.drop s l)
+          | otherwise = []
+        selectFirst0 _ 0 [] = []
+
+group :: PositiveT n => n -> TFVec s a -> TFVec (Div s n) (TFVec n a)
+group n = liftV (group' (fromIntegerT n))
+  where group' :: Int -> [a] -> [TFVec s a]
+        group' n xs = case splitAtM n xs of
+                        Nothing -> []
+                        Just (ls, rs) -> TFVec ls : group' n rs
+
+(<+) :: TFVec s a -> a -> TFVec (Succ s) a
+(<+) (TFVec xs) x = TFVec (xs P.++ [x])
+
+(++) :: TFVec s a -> TFVec s2 a -> TFVec (s :+: s2) a
+(++) = liftV2 (P.++)
+
+infixl 5 <+
+infixr 5 ++
+
+map :: (a -> b) -> TFVec s a -> TFVec s b
+map f = liftV (P.map f)
+
+zipWith :: (a -> b -> c) -> TFVec s a -> TFVec s b -> TFVec s c
+zipWith f = liftV2 (P.zipWith f)
+
+foldl :: (a -> b -> a) -> a -> TFVec s b -> a
+foldl f e = (P.foldl f e) . unTFVec
+
+foldr :: (b -> a -> a) -> a -> TFVec s b -> a
+foldr f e = (P.foldr f e) . unTFVec
+
+zip :: TFVec s a -> TFVec s b -> TFVec s (a, b)
+zip = liftV2 P.zip
+
+unzip :: TFVec s (a, b) -> (TFVec s a, TFVec s b)
+unzip (TFVec xs) = let (a,b) = P.unzip xs in (TFVec a, TFVec b)
+
+shiftl :: (PositiveT s, NaturalT n, n ~ Pred s, s ~ Succ n) => 
+          TFVec s a -> a -> TFVec s a
+shiftl xs x = x +> init xs
+
+shiftr :: (PositiveT s, NaturalT n, n ~ Pred s, s ~ Succ n) => 
+          TFVec s a -> a -> TFVec s a
+shiftr xs x = tail xs <+ x
+  
+rotl :: (PositiveT s, s ~ Succ (Pred s)) => TFVec s a -> TFVec s a
+rotl xs = last xs +> init xs
+
+class Rotr a where rotr :: a -> a
+instance Rotr (TFVec D0 a) where rotr xs = xs
+instance (PositiveT s, s ~ Succ (Pred s)) => Rotr (TFVec s a) where rotr xs = tail xs <+ head xs
+
+concat :: TFVec s1 (TFVec s2 a) -> TFVec (s1 :*: s2) a
+concat = liftV (P.foldr ((P.++).unTFVec) [])
+
+reverse :: TFVec s a -> TFVec s a
+reverse = liftV P.reverse
+
+iterate :: NaturalT s => s -> (a -> a) -> a -> TFVec s a
+iterate s f x = let s' = fromIntegerT s in TFVec (P.take s' $ P.iterate f x)
+
+generate :: NaturalT s => s -> (a -> a) -> a -> TFVec s a
+generate s f x = let s' = fromIntegerT s in TFVec (P.take s' $ P.tail $ P.iterate f x)
+
+copy :: NaturalT s => s -> a -> TFVec s a
+copy s x = iterate s id x
+
+-- =============
+-- = Instances =
+-- =============
+instance Show a => Show (TFVec s a) where
+  showsPrec _ = showV.unTFVec
+    where showV []      = showString "<>"
+          showV (x:xs)  = showChar '<' . shows x . showl xs
+                            where showl []      = showChar '>'
+                                  showl (x:xs)  = showChar ',' . shows x .
+                                                  showl xs
+
+instance (Read a, NaturalT nT) => Read (TFVec nT a) where
+  readsPrec _ str
+    | all fitsLength possibilities = P.map toReadS possibilities
+    | otherwise = error (fName P.++ ": string/dynamic length mismatch")
+    where 
+      fName = "Data.Param.TFVec.read"
+      expectedL = fromIntegerT (undefined :: nT)
+      possibilities = readTFVecList str
+      fitsLength (_, l, _) = l == expectedL
+      toReadS (xs, _, rest) = (TFVec xs, rest)
+      
+instance NaturalT s => DF.Foldable (TFVec s) where
+ foldr = foldr
+ 
+instance NaturalT s => Functor (TFVec s) where
+ fmap = map
+
+instance NaturalT s => DT.Traversable (TFVec s) where 
+  traverse f = (fmap TFVec).(DT.traverse f).unTFVec
+
+instance (Lift a, NaturalT nT) => Lift (TFVec nT a) where
+  lift (TFVec xs) = [|  unsafeTFVecCoerse 
+                        $(decLiteralV (fromIntegerT (undefined :: nT))) 
+                        (TFVec xs) |]
+
+-- ======================
+-- = Internal Functions =
+-- ======================
+liftV :: ([a] -> [b]) -> TFVec nT a -> TFVec nT' b
+liftV f = TFVec . f . unTFVec
+
+liftV2 :: ([a] -> [b] -> [c]) -> TFVec s a -> TFVec s2 b -> TFVec s3 c
+liftV2 f a b = TFVec (f (unTFVec a) (unTFVec b))
+
+splitAtM :: Int -> [a] -> Maybe ([a],[a])
+splitAtM n xs = splitAtM' n [] xs
+  where splitAtM' 0 xs ys = Just (xs, ys)
+        splitAtM' n xs (y:ys) | n > 0 = do
+          (ls, rs) <- splitAtM' (n-1) xs ys
+          return (y:ls,rs)
+        splitAtM' _ _ _ = Nothing
+
+unsafeTFVecCoerse :: nT' -> TFVec nT a -> TFVec nT' a
+unsafeTFVecCoerse _ (TFVec v) = (TFVec v)
+
+unsafeVectorCPS :: forall a w . Integer -> [a] ->
+                        (forall s . NaturalT s => TFVec s a -> w) -> w
+unsafeVectorCPS l xs f = reifyNaturalD l 
+                        (\(_ :: lt) -> f ((TFVec xs) :: (TFVec lt a)))
+
+readTFVecList :: Read a => String -> [([a], Int, String)]
+readTFVecList = readParen' False (\r -> [pr | ("<",s) <- lexTFVec r,
+                                              pr <- readl s])
+  where
+    readl   s = [([],0,t) | (">",t) <- lexTFVec s] P.++
+                            [(x:xs,1+n,u) | (x,t)       <- reads s,
+                                            (xs, n, u)  <- readl' t]
+    readl'  s = [([],0,t) | (">",t) <- lexTFVec s] P.++
+                            [(x:xs,1+n,v) | (",",t)   <- lex s,
+                                            (x,u)     <- reads t,
+                                            (xs,n,v)  <- readl' u]
+    readParen' b g  = if b then mandatory else optional
+      where optional r  = g r P.++ mandatory r
+            mandatory r = [(x,n,u) | ("(",s)  <- lexTFVec r,
+                                      (x,n,t) <- optional s,
+                                      (")",u) <- lexTFVec t]
+
+-- Custom lexer for FSVecs, we cannot use lex directly because it considers
+-- sequences of < and > as unique lexemes, and that breaks nested FSVecs, e.g.
+-- <<1,2><3,4>>
+lexTFVec :: ReadS String
+lexTFVec ('>':rest) = [(">",rest)]
+lexTFVec ('<':rest) = [("<",rest)]
+lexTFVec str = lex str
+                                           
\ No newline at end of file
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..23ebcfd
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,25 @@
+Copyright (c) 2009 Christiaan Baaij & Matthijs Kooijman
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+    * Redistributions in binary form must reproduce the above copyright
+      notice, this list of conditions and the following disclaimer in the
+      documentation and/or other materials provided with the distribution.
+    * Neither the name of the copyright holder nor the
+      names of its contributors may be used to endorse or promote products
+      derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER ``AS IS'' AND ANY
+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE
+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
+IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
\ No newline at end of file
diff --git a/README b/README
new file mode 100644
index 0000000..8b13789
--- /dev/null
+++ b/README
@@ -0,0 +1 @@
+
diff --git a/Setup.lhs b/Setup.lhs
new file mode 100644
index 0000000..5bde0de
--- /dev/null
+++ b/Setup.lhs
@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain
diff --git a/tfvec.cabal b/tfvec.cabal
new file mode 100644
index 0000000..488e90e
--- /dev/null
+++ b/tfvec.cabal
@@ -0,0 +1,20 @@
+name:                tfvec
+version:             0.1.1
+synopsis:            Fixed sized vectors.
+description:         Vectors with numerically parameterized size, using 
+                     type-level numerals from 'tfp' library
+category:            Data
+license:             BSD3
+license-file:        LICENSE
+author:              Christiaan Baaij
+maintainer:          christiaan.baaij@gmail.com
+build-type:          Simple
+cabal-version:       >=1.2  
+
+Library
+  extensions:        StandaloneDeriving, ExistentialQuantification, 
+                     ScopedTypeVariables, TemplateHaskell, TypeOperators, 
+                     FlexibleInstances, TypeFamilies, UndecidableInstances,
+                     DeriveDataTypeable, RankNTypes
+  build-depends:     base >= 3.0, template-haskell >= 2.0, tfp >= 0.3.1
+  exposed-modules:   Data.Param.TFVec
\ No newline at end of file