Changeset 27 for sizechecking/branches


Ignore:
Timestamp:
May 5, 2014, 3:10:33 PM (11 years ago)
Author:
gobi
Message:

new files

Location:
sizechecking/branches/macs
Files:
2 added
7 edited

Legend:

Unmodified
Added
Removed

  • sizechecking/branches/macs/Exp.hs

    r24 r27  
    44import Ops 
    55import Data.Supply as S 
     6import Data.Lens.Light 
    67 
    78class LOps l => Exp l where 
    … …  
    2122    cond c tbranch fbranch = if unQ c then tbranch else fbranch 
    2223    undefined = Prelude.undefined  
    23 instance Exp S where 
    24     nil = S $ \_ _ -> showString "[]" 
    25     undefined = S $ \_ _ -> showString "undefined" 
    26     match list nbranch cbranch = S $ \s p -> 
    27         let (s1, s2, ss) = S.split3 s 
     24 
     25instance SContext s => Exp (S s) where 
     26    nil = S $ \_ -> showString "[]" 
     27    undefined = S $ \_ -> showString "undefined" 
     28    match list nbranch cbranch = S $ \ctx -> 
     29        let (s1, s2, ss) = S.split3 (getL supply ctx) 
    2830            (s3, s4, s5) = S.split3 ss 
    2931            v1           = S.supplyValue s4 
    30             showV1       = S $ \_ _ -> showVar v1 
     32            showV1       = S $ \_ -> showVar v1 
    3133            v2           = S.supplyValue s5 
    32             showV2       = S $ \_ _ -> showVar v2 
     34            showV2       = S $ \_ -> showVar v2 
     35            p = getL prec ctx 
    3336        in showParen (p>0) $  
    3437            showString "case ". 
    35             unS list s1 0 . 
     38            unS list (updateCtx s1 0 ctx) . 
    3639            showString " of [] => ". 
    37             unS nbranch s2 0 . 
     40            unS nbranch (updateCtx s2 0 ctx) . 
    3841            showString "; (" .  showVar v1 . showChar ':' . showVar v2 . showString ") => " . 
    39             unS (cbranch showV1 showV2) s3 0 
    40     cond c tbranch fbranch = S $ \s p -> 
    41         let (s1, s2, s3) = S.split3 s 
     42            unS (cbranch showV1 showV2) (updateCtx s3 0 ctx) 
     43    cond c tbranch fbranch = S $ \ctx -> 
     44        let (s1, s2, s3) = S.split3 (getL supply ctx) 
     45            p = getL prec ctx 
    4246        in showParen (p>0) $  
    4347            showString "if ". 
    44             unS c s1 0 . 
     48            unS c (updateCtx s1 0 ctx). 
    4549            showString " then " . 
    46             unS tbranch s2 0 . 
     50            unS tbranch (updateCtx s2 0 ctx). 
    4751            showString " else " . 
    48             unS fbranch s3 0 
     52            unS fbranch (updateCtx s3 0 ctx) 

  • sizechecking/branches/macs/Lambda.hs

    r26 r27  
    1 {-# LANGUAGE TypeFamilies, GADTs #-} 
     1{-# LANGUAGE TypeFamilies, GADTs, Rank2Types, TemplateHaskell #-} 
    22 
    33module Lambda where 
    … …  
    55import qualified Data.Supply as S 
    66import qualified Data.Char as C 
    7 import Control.Monad.IO.Class (MonadIO, liftIO) 
    8 import Data.IORef (newIORef, readIORef, writeIORef) 
     7import Data.Lens.Light  
    98 
    109{- 
    … …  
    2928 
    3029{- 
    31  - show interpreter 
    32  -} 
     30- show interpreter 
     31-} 
    3332showVar :: Int -> String -> String 
    3433showVar x = if x>28  
    … …  
    3635    else showChar $ C.chr $ C.ord 'a' + x 
    3736 
    38 newtype S a = S { unS :: S.Supply Int -> Int -> ShowS } 
     37class SContext a where 
     38  supply :: Lens a (S.Supply Int) 
     39  prec :: Lens a Int 
    3940 
    40 instance Lambda S where 
    41     lit a = S (\_ p -> showsPrec p a) 
    42     app (S fun) (S arg) = S (\s p ->  
    43         let (s1, s2) = S.split2 s  
    44         in showParen (p>6) $ fun s1 6 . showChar ' ' . arg s2 7) 
    45     lam fun = S (\s p ->  
    46         let (s1, s2) = S.split2 s 
     41newtype S ctx a = S { unS :: ctx -> ShowS } 
     42 
     43instance SContext ctx => Lambda (S ctx) where 
     44    lit a = S (\ctx -> showsPrec (getL prec ctx) a) 
     45    app (S fun) (S arg) = S (\ctx -> 
     46        let (s1, s2) = S.split2 (getL supply ctx) 
     47            p = getL prec ctx 
     48        in showParen (p>6) $ fun (updateCtx s1 6 ctx) . showChar ' ' . arg (updateCtx s2 7 ctx)) 
     49    lam fun = S (\ctx ->  
     50        let (s1, s2) = S.split2 (getL supply ctx) 
    4751            v        = S.supplyValue s1 
    48             showV = S $ \_ _ -> showVar v 
    49         in showParen (p>0) $ showChar 'λ' . showVar v . showChar '.' . unS (fun showV) s2 0) 
     52            p        = getL prec ctx 
     53            showV = S $ \ctx -> showVar v 
     54        in showParen (p>0) $ showChar 'λ' . showVar v . showChar '.' . unS (fun showV) (updateCtx s2 0 ctx)) 
    5055 
    51 ast :: S a -> IO ShowS 
     56updateCtx :: SContext ctx => S.Supply Int -> Int -> ctx -> ctx 
     57updateCtx s p = setL supply s . setL prec p 
     58 
     59data SData = SData { _getSDataSupply :: S.Supply Int, _getSDataPrec :: Int } 
     60$(makeLens ''SData) 
     61 
     62instance SContext SData where 
     63  supply = getSDataSupply 
     64  prec = getSDataPrec 
     65 
     66ast :: S SData a -> IO ShowS 
    5267ast a = do 
    5368    s <- S.newSupply 0 (+1) 
    54     return $ unS a s 0 
     69    return $ unS a $ SData s 0 
    5570 
    56 printAst :: S a -> IO () 
     71printAst :: S SData a -> IO () 
    5772printAst l = ast l >>= (\s -> putStrLn $ s "") 
    5873 
    59  
    60 {- 
    61  - reduction 
    62  -} 
    63 data IR h t where 
    64     Lit :: Int -> IR h Int 
    65     App :: IR h (a -> b) -> IR h a -> IR h b 
    66     Lam :: (IR h a -> IR h b) -> IR h (a -> b) 
    67  
    68 instance Lambda (IR h) where 
    69     lam = Lam 
    70     app = App 
    71     lit = Lit 
    72  
    73 toFinal :: (Lambda l) => IR h t 

  • sizechecking/branches/macs/Ops.hs

    r25 r27  
    77import qualified Prelude 
    88import Lambda 
     9import Data.Lens.Light 
    910 
    1011-- infix operatorok, ezek beagyazasa picit necces, lasd a type family kesobb 
    … …  
    3233    fun _ = Q 
    3334 
    34 instance LOps S where 
    35     fun name _ = S (\_ p -> Prelude.showsPrec p name) 
     35instance (SContext s) => LOps (S s) where 
     36    fun name _ = S (\ctx -> Prelude.showsPrec (getL prec ctx) name) 
    3637 
    37     infixopl name prec _ lhs rhs = S(\s p -> 
    38         let (s1, s2) = S.split2 s 
    39         in Prelude.showParen (p Prelude.> prec) $ 
    40             unS lhs s1 prec . 
     38    infixopl name p _ lhs rhs = S(\ctx -> 
     39        let (s1, s2) = S.split2 (getL supply ctx) 
     40        in Prelude.showParen ((getL prec ctx) Prelude.> p) $ 
     41            unS lhs (setL supply s1 $ setL prec p ctx) . 
    4142            Prelude.showString name . 
    42             unS rhs s2 (Prelude.succ prec) 
     43            unS rhs (setL supply s2 $ setL prec (Prelude.succ p) ctx) 
    4344        ) 
    44     infixop name prec _ lhs rhs = S(\s p -> 
    45         let (s1, s2) = S.split2 s 
    46         in Prelude.showParen (p Prelude.> prec) $ 
    47             unS lhs s1 (Prelude.succ prec) . 
     45 
     46    infixop  name p _ lhs rhs = S(\ctx -> 
     47        let (s1, s2) = S.split2 (getL supply ctx) 
     48        in Prelude.showParen ((getL prec ctx) Prelude.> p) $ 
     49            unS lhs (setL supply s1 $ setL prec (Prelude.succ p) ctx) . 
    4850            Prelude.showString name . 
    49             unS rhs s2 (Prelude.succ prec) 
     51            unS rhs (setL supply s2 $ setL prec (Prelude.succ p) ctx) 
    5052        ) 
    51     infixopr name prec _ lhs rhs = S(\s p -> 
    52         let (s1, s2) = S.split2 s 
    53         in Prelude.showParen (p Prelude.> prec) $ 
    54             unS lhs s1 (Prelude.succ prec) . 
     53 
     54    infixopr name p _ lhs rhs = S(\ctx -> 
     55        let (s1, s2) = S.split2 (getL supply ctx) 
     56        in Prelude.showParen ((getL prec ctx) Prelude.> p) $ 
     57            unS lhs (setL supply s1 $ setL prec (Prelude.succ p) ctx) . 
    5558            Prelude.showString name . 
    56             unS rhs s2 prec 
     59            unS rhs (setL supply s2 $ setL prec p ctx) 
    5760        ) 

  • sizechecking/branches/macs/Size.hs

    r25 r27  
    88import Ops 
    99import Data.Supply as S 
     10import Data.Lens.Light 
    1011 
    1112data Unsized 
    … …  
    1920 
    2021 
    21 instance Size S where 
    22     unsized = S $ \_ _ -> showChar 'U' 
    23     bottom = S $ \_ _ -> showChar '┮' 
    24     list size sexp = S $ \s p -> 
    25         let (s1, s2) = S.split2 s 
     22instance SContext s => Size (S s) where 
     23    unsized = S $ \_ -> showChar 'U' 
     24    bottom = S $ \_ -> showChar '┮' 
     25    list size sexp = S $ \ctx -> 
     26        let (s1, s2) = S.split2 (getL supply ctx) 
     27            p = getL prec ctx 
    2628        in showParen (p>0) $ 
    2729            showString "List " . 
    28             unS size s1 9 . 
     30            unS size (updateCtx s1 9 ctx) . 
    2931            showChar ' ' . 
    30             unS sexp s2 9 
    31     slam f = S $ \s p -> 
    32         let (s1, s2, s3) = S.split3 s 
     32            unS sexp (updateCtx s2 9 ctx) 
     33    slam f = S $ \ctx -> 
     34        let (s1, s2, s3) = S.split3 (getL supply ctx) 
    3335            v1           = S.supplyValue s1 
    34             showV1       = S $ \_ _ -> showVar v1 
     36            showV1       = S $ \_ -> showVar v1 
    3537            v2           = S.supplyValue s2 
    36             showV2       = S $ \_ _ -> showVar v2 
     38            showV2       = S $ \_ -> showVar v2 
     39            p = getL prec ctx 
    3740        in showParen (p>0) $ 
    3841            showChar 'Λ' . 
    … …  
    4144            showVar v2 . 
    4245            showChar '.' . 
    43             unS (f showV1 showV2) s3 0 
    44     shift e1 ss e2 = S $ \s p -> 
    45         let (s1, s2, s3) = S.split3 s 
     46            unS (f showV1 showV2) (updateCtx s3 0 ctx) 
     47    shift e1 ss e2 = S $ \ctx -> 
     48        let (s1, s2, s3) = S.split3 (getL supply ctx) 
     49            p = getL prec ctx 
    4650        in showParen (p>0) 
    4751        $ showString "Shift " 
    48         . unS e1 s1 2 
     52        . unS e1 (updateCtx s1 2 ctx) 
    4953        . showChar ' ' 
    50         . unS ss s2 2 
     54        . unS ss (updateCtx s2 2 ctx) 
    5155        . showChar ' ' 
    52         . unS e2 s3 2 
     56        . unS e2 (updateCtx s3 2 ctx) 
    5357 

  • sizechecking/branches/macs/Tests/ExpTest.hs

    r24 r27  
    3030testD2Cons = cons (cons (lit 1) nil) nil 
    3131 
    32 checkAST :: S a -> String -> IO Bool 
     32checkAST :: S SData a -> String -> IO Bool 
    3333checkAST exp repr = ast exp >>= (\t -> return $ t "" == repr ) 
    3434 

  • sizechecking/branches/macs/Tests/SizeTest.hs

    r24 r27  
    2121testTail = slam $ \s f -> list (s - lit 1) f 
    2222 
     23testAddOne :: (Size l) => l ([Unsized] -> [Unsized]) 
     24testAddOne = slam $ \s f -> list (s + lit 1) (lam $ const unsized) 
     25 
    2326testCons :: Size l => l (a -> [a] -> [a]) 
    2427testCons = lam $ \x -> slam $ \s f -> 
    2528    list (s + lit 1) $ shift f s (lam $ const x) 
    2629 
    27 checkAst :: S a -> String -> IO Bool 
     30testConcat :: Size l => l ([a] -> [a] -> [a]) 
     31testConcat = slam $ \s1 f1 -> slam $ \s2 f2 -> 
     32    list (s1 + s2) $ shift f1 s1 f2 
     33 
     34 
     35checkAst :: S SData a -> String -> IO Bool 
    2836checkAst exp repr = ast exp >>= (\t -> return $ t "" == repr) 
    2937 

  • sizechecking/branches/macs/sizechecking.cabal

    r25 r27  
    5555  -- Other library packages from which modules are imported. 
    5656  build-depends:       base ==4.*, containers ==0.5.*, sbv, value-supply, 
    57                        transformers 
     57                       transformers, data-lens-light 
Note: See TracChangeset for help on using the changeset viewer.