Changeset 27 for sizechecking/branches/macs/Lambda.hs

Timestamp:

May 5, 2014, 3:10:33 PM (12 years ago)

Author:

gobi

Message:

new files

File:

• sizechecking/branches/macs/Lambda.hs (modified) (4 diffs)

sizechecking/branches/macs/Lambda.hs

@@ -1 @@
-{-# LANGUAGE TypeFamilies, GADTs #-}
+{-# LANGUAGE TypeFamilies, GADTs, Rank2Types, TemplateHaskell #-}
 
 module Lambda where
@@ -5 +5 @@
 import qualified Data.Supply as S
 import qualified Data.Char as C
-import Control.Monad.IO.Class (MonadIO, liftIO)
-import Data.IORef (newIORef, readIORef, writeIORef)
+import Data.Lens.Light 
 
 {-
@@ -29 +28 @@
 
 {-
- - show interpreter
- -}
+- show interpreter
+-}
 showVar :: Int -> String -> String
 showVar x = if x>28 
@@ -36 +35 @@
     else showChar $ C.chr $ C.ord 'a' + x
 
-newtype S a = S { unS :: S.Supply Int -> Int -> ShowS }
+class SContext a where
+  supply :: Lens a (S.Supply Int)
+  prec :: Lens a Int
 
-instance Lambda S where
-    lit a = S (\_ p -> showsPrec p a)
-    app (S fun) (S arg) = S (\s p -> 
-        let (s1, s2) = S.split2 s 
-        in showParen (p>6) $ fun s1 6 . showChar ' ' . arg s2 7)
-    lam fun = S (\s p -> 
-        let (s1, s2) = S.split2 s
+newtype S ctx a = S { unS :: ctx -> ShowS }
+
+instance SContext ctx => Lambda (S ctx) where
+    lit a = S (\ctx -> showsPrec (getL prec ctx) a)
+    app (S fun) (S arg) = S (\ctx ->
+        let (s1, s2) = S.split2 (getL supply ctx)
+            p = getL prec ctx
+        in showParen (p>6) $ fun (updateCtx s1 6 ctx) . showChar ' ' . arg (updateCtx s2 7 ctx))
+    lam fun = S (\ctx -> 
+        let (s1, s2) = S.split2 (getL supply ctx)
             v        = S.supplyValue s1
-            showV = S $ \_ _ -> showVar v
-        in showParen (p>0) $ showChar 'λ' . showVar v . showChar '.' . unS (fun showV) s2 0)
+            p        = getL prec ctx
+            showV = S $ \ctx -> showVar v
+        in showParen (p>0) $ showChar 'λ' . showVar v . showChar '.' . unS (fun showV) (updateCtx s2 0 ctx))
 
-ast :: S a -> IO ShowS
+updateCtx :: SContext ctx => S.Supply Int -> Int -> ctx -> ctx
+updateCtx s p = setL supply s . setL prec p
+
+data SData = SData { _getSDataSupply :: S.Supply Int, _getSDataPrec :: Int }
+$(makeLens ''SData)
+
+instance SContext SData where
+  supply = getSDataSupply
+  prec = getSDataPrec
+
+ast :: S SData a -> IO ShowS
 ast a = do
     s <- S.newSupply 0 (+1)
-    return $ unS a s 0
+    return $ unS a $ SData s 0
 
-printAst :: S a -> IO ()
+printAst :: S SData a -> IO ()
 printAst l = ast l >>= (\s -> putStrLn $ s "")
 
-
-{-
- - reduction
- -}
-data IR h t where
-    Lit :: Int -> IR h Int
-    App :: IR h (a -> b) -> IR h a -> IR h b
-    Lam :: (IR h a -> IR h b) -> IR h (a -> b)
-
-instance Lambda (IR h) where
-    lam = Lam
-    app = App
-    lit = Lit
-
-toFinal :: (Lambda l) => IR h t