tup-functor 0.2 → 0.2.0.1

raw patch · 4 files changed

+70/−24 lines, 4 files

Files

• Data/Tup/Tup/Concat.hs +1/−1
• Data/Tup/Vec.hs +30/−4
• preprocessor/tpp.hs +38/−18
• tup-functor.cabal +1/−1

@@ -1,7 +1,7 @@ 
 -- | Concatenation of tuples. Requires MPTCs and FunDeps. 
 
-{-# OPTIONS_GHC -pgmPcpphs -optP--cpp -optP-ansi -optP--hashes #-}
+{-# OPTIONS_GHC -cpp -pgmPcpphs -optP--cpp -optP-ansi -optP--hashes #-}
 {-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies #-}
 module Data.Tup.Tup.Concat where
 

@@ -5,7 +5,9 @@ -- (one which also scales for vectors/tuples longer than 9 elements)
 --
 
-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable, FlexibleContexts #-}
+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable, FlexibleContexts, 
+             MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances 
+  #-}
 module Data.Tup.Vec where
 
 --------------------------------------------------------------------------------
@@ -34,20 +36,28 @@   vecUndef    :: v a -> a
   vecUndef _ = undefined
 
+  undefinedVec :: v a
+
 instance Vec Empty where
-  vecSize     Empty  = 0
+  --vecSize     Empty  = 0
+  vecSize _ = 0
+
   vecToList   Empty  = []
   vecFromList []     = Empty
   vecFromList (x:xs) = error "vecFromList: list length does not match"
+  undefinedVec = Empty
 
 instance Vec v => Vec (Cons v) where
-  vecSize (Cons _ p) = 1 + vecSize p
+  --vecSize (Cons _ p) = 1 + vecSize p
+  vecSize v = 1 + vecSize (consUndefTail v)
+
   vecToList (Cons x p) = x : vecToList p
   vecFromList xxs = this where
     this = case xxs of
       (x:xs) -> Cons x (vecFromList xs)
       []     -> err
     err = error "vecFromList: list length odes not match"
+  undefinedVec = Cons undefined undefinedVec
 
 --------------------------------------------------------------------------------
 -- * Type abbreviations for short vectors
@@ -69,6 +79,9 @@ data Empty  a = Empty        deriving (Eq,Ord,Functor,Foldable,Traversable)
 data Cons v a = Cons a (v a) deriving (Eq,Ord,Functor,Foldable,Traversable)
 
+consUndefTail :: Vec v => Cons v a -> v a
+consUndefTail _ = undefinedVec
+
 --------------------------------------------------------------------------------
 -- * Misc 
 
@@ -86,8 +99,9 @@ transposeVec = vecFromList . (map vecFromList) . transpose . (map vecToList) . vecToList
 
 --------------------------------------------------------------------------------
+-- * Concatenation
 
--- | Concatenation
+-- | safe concatenation
 maybeVecConcat :: (Vec f, Vec g, Vec h) => f a -> g a -> Maybe (h a)
 maybeVecConcat x y = 
   if vecSize x + vecSize y == vecSize z 
@@ -96,10 +110,22 @@   where
     z = vecFromList (vecToList x ++ vecToList y)
 
+-- | unsafe concatenation
 unsafeVecConcat :: (Vec f, Vec g, Vec h) => f a -> g a -> h a
 unsafeVecConcat x y = z
   where
     z = vecFromList (vecToList x ++ vecToList y)
+
+-- | concatenation with type class
+class (Vec u, Vec v, Vec w) => VecConcat u v w | u v -> w where
+  vecConcat :: u a -> v a -> w a
+
+instance Vec v => VecConcat Empty v v where
+  vecConcat Empty v = v
+
+-- This seems to need UndecidableInstances?
+instance (Vec u, Vec v, VecConcat u v w) => VecConcat (Cons u) v (Cons w) where
+  vecConcat (Cons x u) v = Cons x (vecConcat u v)
 
 --------------------------------------------------------------------------------
 -- * Zipping 

@@ -12,7 +12,7 @@ -- and it will be translated to one of these:
 --
 -- > x = Tup3 a b c 
--- > x = vec3 a b c 
+-- > x = (Cons a (Cons b (Cons c Empty)))
 -- 
 {-# LANGUAGE PackageImports #-}
 module Main where
@@ -32,21 +32,39 @@ 
 --------------------------------------------------------------------------------
 
-tupleCon :: Cfg -> Int -> Exp
-tupleCon (Cfg con) k = Var $ UnQual $ Ident (con {- "Tup"-} ++ show k)
+constructor :: String -> Exp
+constructor con = Var $ UnQual $ Ident (con)
 
-toTupleE :: Cfg -> Exp -> Exp
-toTupleE cfg e = case e of
-  Tuple es -> foldl App (tupleCon cfg (length es)) es
-  _        -> App (tupleCon cfg 1) e
+toVecListE ::  Exp -> Exp
+toVecListE e = 
+  case e of
+    Con (Special UnitCon) -> go []
+    Tuple es -> go es 
+    _        -> go [e]
+  where
+    go [] = constructor "Empty"
+    go (x:xs) = App (App (constructor "Cons") x) (go xs)
 
+--------------------------------------------------------------------------------
+
+tupleCon :: Int -> Exp
+tupleCon k = Var $ UnQual $ Ident ("Tup" ++ show k)
+
+toTupleE :: Exp -> Exp
+toTupleE e = case e of
+  Con (Special UnitCon) -> tupleCon 0
+  Tuple es -> foldl App (tupleCon (length es)) es
+  _        -> App (tupleCon 1) e
+
 inparens :: String -> String
 inparens s = "(" ++ s ++ ")"
 
 toTupleS :: Cfg -> String -> String
 toTupleS cfg s = {- trace ("|"++s++"|") $ -} case parseExp (inparens s) of
-  ParseOk e -> pp (toTupleE cfg e)
-  err       -> error ("parse error in idiom bracket:\n" ++ show err)
+  ParseOk e -> case cfg of
+    TupPP -> pp (toTupleE   e)
+    VecPP -> pp (toVecListE e)
+  err -> error ("tuplepp: parse error in tuple bracket:\n" ++ show err)
 
 pp :: Pretty a => a -> String
 pp = prettyPrintStyleMode style mode where
@@ -105,7 +123,7 @@ parseLine :: SourceName -> String -> TupleLine
 parseLine src s = case runParser lineP () "" s of
   Right xx -> xx
-  Left err -> error ("preprocessor parse error in file \"" ++ src ++ "\":\n" ++ show err)
+  Left err -> error ("tuplepp: preprocessor parse error in file \"" ++ src ++ "\":\n" ++ show err)
 
 convertTupleLine :: Cfg -> TupleLine -> String
 convertTupleLine cfg (S ln) = ln
@@ -122,13 +140,15 @@     
 --------------------------------------------------------------------------------  
 
-data Cfg = Cfg { _constructor :: String }
+data Cfg = TupPP | VecPP deriving (Eq,Show)
 
-tupCfg = Cfg "Tup"
-vecCfg = Cfg "vec"
+tupCfg, vecCfg :: Cfg
+tupCfg = TupPP
+vecCfg = VecPP
 
-vecOpts = [ "-v" , "--vec" ]
+tupOpts, vecOpts, possibleOpts :: [String]
 tupOpts = [ "-t" , "--tup" ] 
+vecOpts = [ "-v" , "--vec" ]
 possibleOpts = vecOpts ++ tupOpts
 
 main :: IO ()
@@ -161,10 +181,10 @@         print args
         putStrLn $ unlines
           [ "usage:"
-          , "  tpp [options] <input.hs >output.hs"
-          , "  tpp [options] input.hs >output.hs"
-          , "  tpp [options] input.hs output.hs"
-          , "  tpp [options] dummy.hs input.hs output.hs     -- this is for GHC"
+          , "  tuplepp [options] <input.hs >output.hs"
+          , "  tuplepp [options] input.hs >output.hs"
+          , "  tuplepp [options] input.hs output.hs"
+          , "  tuplepp [options] dummy.hs input.hs output.hs     -- this is for GHC"
           , "options:"
           , "  -t, --tup : generates (Tup3 105 106 106) expressions"
           , "  -v, --vec : generates (vec3 105 106 106) expressions"

@@ -1,6 +1,6 @@ 
 Name:                tup-functor
-Version:             0.2
+Version:             0.2.0.1
 Synopsis:            Homogeneous tuples
 Description:         Homogeneous tuples (also known as vectors), with various instances, most notably 'Functor' and 'Applicative'.
                      The primary goal of the library is to help functor-oriented programming