└── Main.hs /Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | import Control.Monad 3 | import Data.Maybe 4 | import System.IO 5 | 6 | 7 | -- An (ugly) implementation of the AIM language from: 8 | -- "An Idealized MetaML: Simpler, and More Expressive" 9 | -- by Eugenio Moggi, Walid Taha, Zine El-Abidine Benaissa and Tim Sheard 10 | -- http://www.springerlink.com/content/m6yf7wmx76bj9mmb/ 11 | 12 | 13 | instance Monad (Either String) where 14 | return = Right 15 | Left s >>= _ = Left s 16 | Right x >>= fxmy = fxmy x 17 | fail = Left 18 | 19 | instance MonadPlus (Either String) where 20 | mzero = Left "mzero" 21 | Left _ `mplus` mx = mx 22 | Right x `mplus` _ = Right x 23 | 24 | markError :: a -> Either a b -> Either a b 25 | markError x (Left _) = Left x 26 | markError _ (Right y) = Right y 27 | 28 | 29 | data Nat = Z | S Nat 30 | 31 | gtNat :: Nat -> Nat -> Bool 32 | gtNat Z _ = False 33 | gtNat (S _) Z = True 34 | gtNat (S x) (S y) = gtNat x y 35 | 36 | 37 | type Stage = Nat 38 | 39 | data BaseType = IntTy 40 | deriving (Show, Eq) 41 | data Type = BaseTy BaseType | FunTy Type Type | OpenCodeTy Type | ClosedCodeTy Type 42 | deriving (Show, Eq) 43 | 44 | intTy :: Type 45 | intTy = BaseTy IntTy 46 | 47 | type Var = String 48 | 49 | data Constant = Int Integer | Sub Term Term | Mul Term Term | IfZero Term Term Term 50 | deriving (Show) 51 | data Term = Constant Constant | Var Var | App Term Term | Lam (Var, Type) Term | Quote Term | Splice Term | RunWith Term [(Var, Term)] | BoxWith Term [(Var, Term)] | Unbox Term | Compile Term | ValRec [((Var, Type), Value)] Term 52 | deriving (Show) 53 | 54 | int :: Integer -> Term 55 | int i = Constant (Int i) 56 | 57 | sub :: Term -> Term -> Term 58 | sub e1 e2 = Constant (Sub e1 e2) 59 | 60 | mul :: Term -> Term -> Term 61 | mul e1 e2 = Constant (Mul e1 e2) 62 | 63 | ifZero :: Term -> Term -> Term -> Term 64 | ifZero e1 e2 e3 = Constant (IfZero e1 e2 e3) 65 | 66 | valRec :: (Var, Type) -> Term -> Term -> Term 67 | valRec a b e = ValRec [(a, b)] e 68 | 69 | run :: Term -> Term 70 | run = flip RunWith [] 71 | 72 | box :: Term -> Term 73 | box = flip BoxWith [] 74 | 75 | 76 | constantType :: Stage -> [(Var, (Stage, Type))] -> Constant -> Either String Type 77 | constantType stage env c = case c of 78 | Int _ -> return (BaseTy IntTy) 79 | Sub e1 e2 -> do 80 | typeCheck stage env e1 >>= assertIntTy "constantType: subtracting non-integer" 81 | typeCheck stage env e2 >>= assertIntTy "constantType: subtracting non-integer" 82 | return (BaseTy IntTy) 83 | Mul e1 e2 -> do 84 | typeCheck stage env e1 >>= assertIntTy "constantType: multiplying non-integer" 85 | typeCheck stage env e2 >>= assertIntTy "constantType: multiplying non-integer" 86 | return (BaseTy IntTy) 87 | IfZero e1 e2 e3 -> do 88 | typeCheck stage env e1 >>= assertIntTy "constantType: if on non-integer" 89 | ty2 <- typeCheck stage env e2 90 | ty3 <- typeCheck stage env e3 91 | markError "constantType: types of branches do not match" $ guard (ty2 == ty3) 92 | return ty2 93 | where 94 | assertIntTy msg ty = markError (msg ++ " (instead we got " ++ show ty ++ ")") $ do 95 | BaseTy IntTy <- return ty 96 | return () 97 | 98 | typeCheck :: Stage -> [(Var, (Stage, Type))] -> Term -> Either String Type 99 | typeCheck stage env e = case e of 100 | Constant c -> constantType stage env c 101 | Var x -> do 102 | (stage_x, ty) <- markError ("typeCheck: " ++ x ++ " not in scope") $ do 103 | Just ty <- return (lookup x env) 104 | return ty 105 | if stage_x `gtNat` stage then fail ("typeCheck: staging error for " ++ x) else return ty 106 | App e1 e2 -> do 107 | ty_fun <- typeCheck stage env e1 108 | (ty1, ty_res) <- markError ("typeCheck: application to non-arrow type") $ do 109 | ty1 `FunTy` ty2 <- return ty_fun 110 | return (ty1, ty2) 111 | ty2 <- typeCheck stage env e2 112 | if ty1 /= ty2 then fail "typeCheck: argument type does not match expected type" 113 | else return ty_res 114 | Lam (x, ty) e -> liftM (ty `FunTy`) $ typeCheck stage ((x, (stage, ty)):env) e 115 | Quote e -> liftM OpenCodeTy $ typeCheck (S stage) env e 116 | Splice e -> case stage of Z -> fail "typeCheck: spliced at level 0" 117 | S stage -> do 118 | ty_open <- typeCheck stage env e 119 | markError "typeCheck: splicing non-open code type" $ do 120 | OpenCodeTy ty <- return ty_open 121 | return ty 122 | RunWith e with -> do 123 | with_env <- forM with $ \(x, e) -> do 124 | ty_closed <- typeCheck stage env e 125 | ty <- markError ("typeCheck: ran " ++ x ++ " with non-closed code type") $ do 126 | ClosedCodeTy ty <- return ty_closed 127 | return ty 128 | return (x, (stage, ClosedCodeTy ty)) 129 | ty_open <- typeCheck stage (with_env ++ [(x, (S stage, e)) | (x, (stage, e)) <- env]) e 130 | markError "typeCheck: run resulted in non-open code type" $ do 131 | OpenCodeTy ty <- return ty_open 132 | return ty 133 | BoxWith e with -> do 134 | with_env <- forM with $ \(x, e) -> do 135 | ty_closed <- typeCheck stage env e 136 | ty <- markError ("typeCheck: boxed " ++ x ++ " with non-closed code type") $ do 137 | ClosedCodeTy ty <- return ty_closed 138 | return ty 139 | return (x, (Z, ClosedCodeTy ty)) 140 | liftM ClosedCodeTy (typeCheck Z with_env e) 141 | Unbox e -> do 142 | ty_closed <- typeCheck stage env e 143 | markError "typeCheck: unboxed non-closed code type" $ do 144 | ClosedCodeTy ty <- return ty_closed 145 | return ty 146 | Compile e -> do 147 | ty_closed_open <- typeCheck stage env e 148 | markError "typeCheck: compiled something of the wrong type" $ do 149 | ClosedCodeTy (OpenCodeTy ty) <- return ty_closed_open 150 | return (ClosedCodeTy ty) 151 | ValRec bes e -> do 152 | let env' = [(x, (stage, ty)) | ((x, ty), _) <- bes] ++ env 153 | forM_ bes $ \((x, tyb), eb) -> do 154 | tyb_inferred <- typeCheck stage env' eb 155 | markError ("Inferred type for " ++ x ++ " valrec " ++ show tyb_inferred ++ " does not match declared type " ++ show tyb) $ guard (tyb == tyb_inferred) 156 | typeCheck stage env' e 157 | 158 | 159 | demote :: Stage -> Term -> Term 160 | demote stage e = case e of 161 | Constant c -> Constant c 162 | Var x -> Var x 163 | App e1 e2 -> App (demote stage e1) (demote stage e2) 164 | Lam (x, ty) e -> Lam (x, ty) (demote stage e) 165 | Quote e -> Quote (demote (S stage) e) 166 | Splice e -> case stage of Z -> RunWith e []; S stage -> Splice (demote stage e) 167 | RunWith e with -> RunWith (demote stage e) [(x, demote stage e) | (x, e) <- with] 168 | BoxWith e with -> BoxWith e [(x, demote stage e) | (x, e) <- with] 169 | Unbox e -> Unbox (demote stage e) 170 | Compile e -> Compile (demote stage e) 171 | ValRec bes e -> ValRec [((x, ty), demote stage e) | ((x, ty), e) <- bes] (demote stage e) 172 | 173 | 174 | type Value = Term 175 | 176 | evaluateConstant :: Stage -> [(Var, Value)] -> Constant -> Value 177 | evaluateConstant Z env c = case c of 178 | Int i -> Constant (Int i) 179 | Sub e1 e2 -> Constant (Int (i1 - i2)) 180 | where Constant (Int i1) = evaluate Z env e1 181 | Constant (Int i2) = evaluate Z env e2 182 | Mul e1 e2 -> Constant (Int (i1 * i2)) 183 | where Constant (Int i1) = evaluate Z env e1 184 | Constant (Int i2) = evaluate Z env e2 185 | IfZero e1 e2 e3 -> if i1 == 0 then evaluate Z env e2 else evaluate Z env e3 186 | where Constant (Int i1) = evaluate Z env e1 187 | evaluateConstant (S stage) env c = Constant $ case c of 188 | Int i -> Int i 189 | Sub e1 e2 -> Sub (evaluate (S stage) env e1) (evaluate (S stage) env e2) 190 | Mul e1 e2 -> Mul (evaluate (S stage) env e1) (evaluate (S stage) env e2) 191 | IfZero e1 e2 e3 -> IfZero (evaluate (S stage) env e1) (evaluate (S stage) env e2) (evaluate (S stage) env e3) 192 | 193 | evaluate :: Stage -> [(Var, Value)] -> Term -> Value 194 | evaluate Z env e = case e of 195 | Constant c -> evaluateConstant Z env c 196 | Var x -> fromMaybe (error $ "evaluate: free variable " ++ x ++ " at level 0") $ lookup x env 197 | App e1 e2 -> evaluate Z ((x, evaluate Z env e2) : env) e1_body 198 | where Lam (x, _) e1_body = evaluate Z env e1 199 | Lam (x, ty) e -> Lam (x, ty) (ValRec [((y, undefined "FIXME: type goes here"), v) | (y, v) <- env, x /= y] e) -- NB: this should capture its free variables. What I'm using to do that is a bit of a hack...! 200 | Quote e -> Quote (evaluate (S Z) env e) 201 | Splice e -> error "evaluate: splice at level 0" 202 | RunWith e with -> evaluate Z (with_env ++ env) (demote Z v') 203 | where Quote v' = evaluate Z (with_env ++ env) e 204 | with_env = [(x, evaluate Z env e) | (x, e) <- with] 205 | BoxWith e with -> BoxWith e [(x, evaluate Z env e) | (x, e) <- with] 206 | Unbox e -> evaluate Z with_env e' 207 | where BoxWith e' with_env = evaluate Z env e 208 | Compile e -> BoxWith (demote Z v') [] 209 | where BoxWith e' with_env = evaluate Z env e 210 | Quote v' = evaluate Z with_env e' 211 | ValRec bes e -> evaluate Z env' e 212 | where env' = [(x, evaluate Z env' v) | ((x, _), v) <- bes] ++ env -- NB: v1 being a syntactic value is sufficient for this to be well-defined. Just don't try to 'show' the resulting Values! 213 | 214 | evaluate (S stage) env e = case e of 215 | Constant c -> evaluateConstant (S stage) env c 216 | Var x -> fromMaybe (error "evaluate: free variable at non-base level") $ lookup x env -- I think we could just say Var x here if there was no cross-stage persistence? 217 | App e1 e2 -> App (evaluate (S stage) env e1) (evaluate (S stage) env e2) 218 | Lam (x, ty) e -> Lam (x, ty) (evaluate (S stage) ((x, Var x) : env) e) 219 | Quote e -> Quote (evaluate (S (S stage)) env e) 220 | Splice e -> case stage of Z -> let Quote v = evaluate stage env e in v 221 | S stage -> Splice (evaluate (S stage) env e) 222 | RunWith e with -> RunWith (evaluate (S stage) ([(x, Var x) | (x, _) <- with] ++ env) e) [(x, evaluate (S stage) env e) | (x, e) <- with] 223 | BoxWith e with -> BoxWith e [(x, evaluate (S stage) env e) | (x, e) <- with] 224 | Unbox e -> Unbox (evaluate (S stage) env e) 225 | Compile e -> Compile (evaluate (S stage) env e) 226 | ValRec bes e -> ValRec [((x, ty), evaluate (S stage) env' v) | ((x, ty), v) <- bes] (evaluate (S stage) env' e) 227 | where env' = [(x, Var x) | ((x, _), _) <- bes] ++ env 228 | 229 | 230 | test :: Term -> IO () 231 | test e = do 232 | testType e 233 | print (evaluate Z [] e) 234 | 235 | testType :: Term -> IO () 236 | testType e = do 237 | putStrLn "---" 238 | print (typeCheck Z [] e) 239 | 240 | main :: IO () 241 | main = do 242 | -- Calls to "error" in the program can cause us to lose some output unless we do this 243 | hSetBuffering stdout NoBuffering 244 | 245 | let x = "x" :: Var 246 | n = "n" :: Var 247 | a = "a" :: Var 248 | 249 | -- unbox :: [t] -> t 250 | test $ Lam (x, ClosedCodeTy intTy) (Unbox (Var x)) 251 | -- up :: t -> 252 | test $ Lam (x, intTy) (Quote (Var x)) 253 | -- weaken :: [t] -> 254 | test $ Lam (x, ClosedCodeTy intTy) (Quote (Unbox (Var x))) 255 | -- execute :: [] -> t 256 | -- Error in the paper -- this proposed definition (p202) is not actually well typed: 257 | test $ Lam (x, ClosedCodeTy (OpenCodeTy intTy)) (RunWith (Unbox (Var x)) [(x, Var x)]) 258 | test $ Lam (x, ClosedCodeTy (OpenCodeTy intTy)) (Unbox (Compile (Var x))) 259 | -- exp :: [int -> -> ] 260 | let exp = "exp" :: Var 261 | exp_ty = ClosedCodeTy (intTy `FunTy` (OpenCodeTy intTy `FunTy` OpenCodeTy intTy)) 262 | exp_def = flip BoxWith [(exp, Var exp)] $ Lam (n, intTy) $ Lam (x, OpenCodeTy intTy) $ ifZero (Var n) (Quote (int 1)) (Quote (mul (Splice (Var x)) (Splice ((Unbox (Var exp)) `App` sub (Var n) (int 1) `App` Var x)))) 263 | mk_exp = valRec (exp, exp_ty) exp_def 264 | testType $ mk_exp (Var exp) 265 | -- exponent :: [int -> int>] 266 | let exponent = "exponent" :: Var 267 | exponent_ty = ClosedCodeTy (intTy `FunTy` OpenCodeTy (intTy `FunTy` intTy)) 268 | exponent_def = flip BoxWith [(exp, Var exp)] $ Lam (n, intTy) $ Quote (Lam (a, intTy) (Splice ((Unbox (Var exp)) `App` Var n `App` Quote (Var a)))) 269 | mk_exponent = valRec (exponent, exponent_ty) exponent_def 270 | testType $ mk_exp $ mk_exponent (Var exponent) 271 | -- cube :: [int -> int] 272 | let cube = "cube" :: Var 273 | cube_ty = ClosedCodeTy (intTy `FunTy` intTy) 274 | cube_def = Compile (flip BoxWith [(exponent, Var exponent)] (Unbox (Var exponent) `App` int 3)) 275 | mk_cube = valRec (cube, cube_ty) cube_def 276 | testType $ mk_exp $ mk_exponent $ mk_cube (Var cube) 277 | -- program :: [int] 278 | let program = "program" :: Var 279 | program_ty = ClosedCodeTy intTy 280 | program_def = Compile (flip BoxWith [(cube, Var cube)] (Quote (Unbox (Var cube) `App` int 2))) 281 | mk_program = valRec (program, program_ty) program_def 282 | testType $ mk_exp $ mk_exponent $ mk_cube $ mk_program (Var program) 283 | -- it :: Int 284 | test $ mk_exp $ mk_exponent $ mk_cube $ mk_program (Unbox (Var program)) 285 | --------------------------------------------------------------------------------