Changeset 23 for sizechecking

Timestamp:

May 3, 2014, 5:01:55 PM (11 years ago)

Author:

gobi

Message:

expression

Location:

sizechecking/branches/macs

Files:

• Exp.hs (modified) (1 diff)
• Lambda.hs (modified) (1 diff)
• Ops.hs (modified) (3 diffs)
• SizedExp.hs (modified) (1 diff)
• tests/ExpTest.hs (modified) (1 diff)

sizechecking/branches/macs/Exp.hs

@@ -1 +1 @@
 module Exp where
 
-import Size
+import Lambda
+import Ops
+import Data.Supply as S
 
-class Exp l where
+class LOps l => Exp l where
     nil :: l [a]
     cons :: l a -> l [a] -> l [a]
-    match :: l [a] -> l b -> l (a -> [a] -> b) -> [b]
+    cons = infixopr ":" 5 (:)
+    match :: l [a] -> l b -> (l a -> l [a] -> l b) -> l b
+    cond :: l Bool -> l a -> l a -> l a
+    undefined :: l a
+
+instance Exp Q where
+    nil = Q []
+    cons x xs = Q ( unQ x : unQ xs )
+    match l nbranch cbranch = case unQ l of
+        [] -> nbranch
+        (x:xs) -> cbranch (Q x) (Q xs)
+    cond c tbranch fbranch = if unQ c then tbranch else fbranch
+    undefined = Prelude.undefined 
+instance Exp S where
+    nil = S $ \_ _ -> showString "[]"
+    undefined = S $ \_ _ -> showString "undefined"
+    match list nbranch cbranch = S $ \s p ->
+        let (s1, s2, ss) = S.split3 s
+            (s3, s4, s5) = S.split3 ss
+            v1           = S.supplyValue s4
+            showV1       = S $ \_ _ -> showVar v1
+            v2           = S.supplyValue s5
+            showV2       = S $ \_ _ -> showVar v2
+        in showParen (p>0) $ 
+            showString "case ".
+            unS list s1 0 .
+            showString " of [] => ".
+            unS nbranch s2 0 .
+            showString "; (" .  showVar v1 . showChar ':' . showVar v2 . showString ") => " .
+            unS (cbranch showV1 showV2) s3 0

sizechecking/branches/macs/Lambda.hs

@@ -12 +12 @@
     app   :: l (a -> b) -> l a -> l b
     const :: Int -> l Int
-
 
 {-

sizechecking/branches/macs/Ops.hs

@@ -10 +10 @@
 class (Lambda l) => LOps l where
     infixop :: String -> Int -> (a -> b -> c) -> l a -> l b -> l c
+    infixopr :: String -> Int -> (a -> b -> c) -> l a -> l b -> l c
+    infixopl :: String -> Int -> (a -> b -> c) -> l a -> l b -> l c
     fun :: String -> a -> l a
 
     (+) :: l Int -> l Int -> l Int
-    (+) = infixop "+" 4 (Prelude.+)
+    (+) = infixopl "+" 6 (Prelude.+)
 
     (-) :: l Int -> l Int -> l Int
-    (-) = infixop "-" 4 (Prelude.-)
+    (-) = infixopl "-" 6 (Prelude.-)
 
     (*) :: l Int -> l Int -> l Int
-    (*) = infixop "*" 5 (Prelude.*)
+    (*) = infixopl "*" 7 (Prelude.*)
 
 
 instance LOps Q where
-    infixop _ _ f lhs rhs = Q (eval lhs `f` eval rhs)
+    infixopl _ _ f lhs rhs = Q (eval lhs `f` eval rhs)
+    infixop  _ _ f lhs rhs = Q (eval lhs `f` eval rhs)
+    infixopr _ _ f lhs rhs = Q (eval lhs `f` eval rhs)
     fun _ = Q
 
@@ -29 +33 @@
     fun name _ = S (\_ p -> Prelude.showsPrec p name)
 
-    infixop name prec _ lhs rhs = S(\s p ->
+    infixopl name prec _ lhs rhs = S(\s p ->
         let (s1, s2) = S.split2 s
         in Prelude.showParen (p Prelude.> prec) $
@@ -36 +40 @@
             unS rhs s2 (Prelude.succ prec)
         )
+    infixop name prec _ lhs rhs = S(\s p ->
+        let (s1, s2) = S.split2 s
+        in Prelude.showParen (p Prelude.> prec) $
+            unS lhs s1 (Prelude.succ prec) .
+            Prelude.showString name .
+            unS rhs s2 (Prelude.succ prec)
+        )
+    infixopr name prec _ lhs rhs = S(\s p ->
+        let (s1, s2) = S.split2 s
+        in Prelude.showParen (p Prelude.> prec) $
+            unS lhs s1 (Prelude.succ prec) .
+            Prelude.showString name .
+            unS rhs s2 prec
+        )

sizechecking/branches/macs/SizedExp.hs

@@ -1 +1 @@
 import Ops
 
-:e

sizechecking/branches/macs/tests/ExpTest.hs

@@ -5 +5 @@
 import Lambda
 import Exp
-import Ops
 import Prelude ( ($), Int, (==), return, sequence, (>>=), and, (.), IO, Bool )
+import qualified Control.Monad
 
 testNil :: Exp e => e [a]
 testNil = nil
 
-addOne :: Exp e => e [Int]
+testAddOne :: Exp e => e ([Int] -> [Int])
+testAddOne = lam $ \l -> cons (const 1) l
+
+testHead :: Exp e => e ([a] -> a)
+testHead = lam $ \l -> match l undefined $ \x _ -> x
+
+testTail :: Exp e => e ([a] -> [a])
+testTail = lam $ \l -> match l undefined $ \_ xs -> xs
+
+testConcat :: Exp e => e ([a] -> [a] -> [a])
+testConcat = lam $ \l1 -> lam $ \l2 -> match l1 l2
+    $ \x xs -> cons x (testConcat `app` xs `app` l2)
+
+testEvalNil :: IO Bool
+testEvalNil = return $ ([]::[Int]) == eval testNil
+
+testEvalAddOne :: IO Bool
+testEvalAddOne = return $ [1::Int] == (eval $ testAddOne `app` nil)
+
+testEvalTail :: IO Bool
+testEvalTail = return $ [2..6::Int] == eval testTail [1..6]
+
+testEvalConcat :: IO Bool
+testEvalConcat = return $ [1..6::Int] == eval testConcat [1,2,3] [4,5,6] 
+
+tests :: [IO Bool]
+
+tests = [ testEvalNil
+        , testEvalAddOne
+        , testEvalTail
+        , testEvalConcat
+        ]
+
+runTests :: IO Bool
+runTests = Control.Monad.liftM and $ sequence tests