├── README.md ├── compiler ├── .gitignore ├── annotate.sml ├── ast.sml ├── attempt-monad.sml ├── attempt.sml ├── class.sml ├── collect.sml ├── compile.sml ├── eval.sml ├── instance.sml ├── letreduce.sml ├── luca.bnf ├── monad-util.sml ├── monad.sig ├── optattempt-monad.sml ├── optattempt.sml ├── parse-monad.sml ├── parse-util.sml ├── parse.sml ├── polish.sml ├── scan.sml ├── sources.cm ├── surfaceprogram.sml ├── tests.sml ├── tests │ ├── concat.luca │ ├── curried_add.luca │ ├── even_odd.luca │ ├── exists.luca │ ├── flatten.luca │ ├── foldl.luca │ ├── foldr.luca │ ├── identity.luca │ ├── left_case.luca │ ├── length.luca │ └── map.luca ├── ty.sml ├── tyenv.sml ├── tyexpr.sml ├── tyscheme.sml ├── unify.sml └── utils.sml ├── paper.pdf └── presentation.pdf /README.md: -------------------------------------------------------------------------------- 1 | # ForML: Iterative Programming with Type Classes and Associated Types 2 | 3 | This repository represents the culmination of my bachelor's thesis, completed 4 | June 6, 2019, advised by Adam Shaw. 5 | 6 | The paper can be read 7 | [here](paper.pdf). 8 | 9 | A recording of the presentation, given June 5, 2019, can be found 10 | [here](https://www.youtube.com/watch?v=n8rnVjCZ570), and the slides can be found 11 | [here](presentation.pdf). 12 | 13 | The compiler for `LUCA`, broken though it is, can be found [here](compiler/). 14 | -------------------------------------------------------------------------------- /compiler/.gitignore: -------------------------------------------------------------------------------- 1 | .cm/ 2 | -------------------------------------------------------------------------------- /compiler/annotate.sml: -------------------------------------------------------------------------------- 1 | structure Annotate: sig 2 | 3 | datatype aterm 4 | = AUnit of Ty.ty 5 | | AVar of string * Ty.ty 6 | 7 | | ATrue of Ty.ty 8 | | AFalse of Ty.ty 9 | | AIf of aterm * aterm * aterm * Ty.ty 10 | 11 | | AZero of Ty.ty 12 | | ASucc of aterm * Ty.ty 13 | | APred of aterm * Ty.ty 14 | 15 | | ANil of Ty.ty 16 | | ACons of aterm * aterm * Ty.ty 17 | 18 | | APair of aterm * aterm * Ty.ty 19 | 20 | | ANone of Ty.ty 21 | | ASome of aterm * Ty.ty 22 | | ACase of aterm * string * Ty.ty * aterm * aterm * Ty.ty 23 | 24 | | AAbs of string * aterm * Ty.ty 25 | | AApp of aterm * aterm * Ty.ty 26 | 27 | val getTy: aterm -> Ty.ty Attempt.attempt 28 | val annotate: AST.term -> aterm Attempt.attempt 29 | 30 | end = struct 31 | 32 | open Attempt 33 | 34 | open AttemptMonad 35 | structure AttemptMonadUtil = MonadUtil(AttemptMonad) 36 | open AttemptMonadUtil 37 | infixr 0 $ 38 | infix 1 >>= >> 39 | infixr 1 =<< >=> <=< 40 | infix 4 <$> <*> 41 | 42 | val <+> = TyEnv.<+> 43 | infix <+> 44 | 45 | datatype aterm 46 | = AUnit of Ty.ty 47 | | AVar of string * Ty.ty 48 | 49 | | ATrue of Ty.ty 50 | | AFalse of Ty.ty 51 | | AIf of aterm * aterm * aterm * Ty.ty 52 | 53 | | AZero of Ty.ty 54 | | ASucc of aterm * Ty.ty 55 | | APred of aterm * Ty.ty 56 | 57 | | ANil of Ty.ty 58 | | ACons of aterm * aterm * Ty.ty 59 | 60 | | APair of aterm * aterm * Ty.ty 61 | 62 | | ANone of Ty.ty 63 | | ASome of aterm * Ty.ty 64 | | ACase of aterm * string * Ty.ty * aterm * aterm * Ty.ty 65 | 66 | | AAbs of string * aterm * Ty.ty 67 | | AApp of aterm * aterm * Ty.ty 68 | 69 | fun getTy (AUnit ty) = pure ty 70 | | getTy (AVar (_, ty)) = pure ty 71 | 72 | | getTy (ATrue ty) = pure ty 73 | | getTy (AFalse ty) = pure ty 74 | | getTy (AIf (_, _, _, ty)) = pure ty 75 | 76 | | getTy (AZero ty) = pure ty 77 | | getTy (ASucc (_, ty)) = pure ty 78 | | getTy (APred (_, ty)) = pure ty 79 | 80 | | getTy (ANil ty) = pure ty 81 | | getTy (ACons (_, _, ty)) = pure ty 82 | 83 | | getTy (APair (_, _, ty)) = pure ty 84 | 85 | | getTy (ANone ty) = pure ty 86 | | getTy (ASome (_, ty)) = pure ty 87 | | getTy (ACase (_, _, _, _, _, ty)) = pure ty 88 | 89 | | getTy (AAbs (_, _, ty)) = pure ty 90 | | getTy (AApp (_, _, ty)) = pure ty 91 | 92 | fun annotate' g AST.Unit = pure (AUnit Ty.Unit) 93 | | annotate' g (AST.Var x) = 94 | TyEnv.lookup g x >>= (fn ty => 95 | pure (AVar (x, ty))) 96 | 97 | | annotate' g AST.True = pure (ATrue Ty.Bool) 98 | | annotate' g AST.False = pure (AFalse Ty.Bool) 99 | | annotate' g (AST.If (e1, e2, e3)) = 100 | annotate' g e1 >>= (fn ae1 => 101 | annotate' g e2 >>= (fn ae2 => 102 | annotate' g e3 >>= (fn ae3 => 103 | pure (AIf (ae1, ae2, ae3, Ty.freshTyVar ()))))) 104 | 105 | | annotate' g AST.Zero = pure (AZero Ty.Int) 106 | | annotate' g (AST.Succ e) = 107 | annotate' g e >>= (fn ae => 108 | pure (ASucc (ae, Ty.Int))) 109 | | annotate' g (AST.Pred e) = 110 | annotate' g e >>= (fn ae => 111 | pure (APred (ae, Ty.Int))) 112 | 113 | | annotate' g AST.Nil = pure (ANil (Ty.List (Ty.freshTyVar ()))) 114 | | annotate' g (AST.Cons (e1, e2)) = 115 | annotate' g e1 >>= (fn ae1 => 116 | annotate' g e2 >>= (fn ae2 => 117 | pure (ACons (ae1, ae2, Ty.List (Ty.freshTyVar ()))))) 118 | 119 | | annotate' g (AST.Pair (e1, e2)) = 120 | annotate' g e1 >>= (fn ae1 => 121 | annotate' g e2 >>= (fn ae2 => 122 | pure (APair (ae1, ae2, Ty.Pair (Ty.freshTyVar (), Ty.freshTyVar ()))))) 123 | 124 | | annotate' g AST.None = pure (ANone (Ty.Option (Ty.freshTyVar ()))) 125 | | annotate' g (AST.Some e) = 126 | annotate' g e >>= (fn ae => 127 | pure (ASome (ae, Ty.Option (Ty.freshTyVar ())))) 128 | | annotate' g (AST.Case (e1, x, e2, e3)) = 129 | let 130 | val xTy = Ty.freshTyVar () 131 | in 132 | annotate' g e1 >>= (fn ae1 => 133 | annotate' (g <+> (x, xTy)) e2 >>= (fn ae2 => 134 | annotate' g e3 >>= (fn ae3 => 135 | pure (ACase (ae1, x, xTy, ae2, ae3, Ty.freshTyVar ()))))) 136 | end 137 | 138 | | annotate' g (AST.Abs (arg, e)) = 139 | let 140 | val argTy = Ty.freshTyVar () 141 | in 142 | annotate' (g <+> (arg, argTy)) e >>= (fn ae => 143 | getTy ae >>= (fn retTy => 144 | pure (AAbs (arg, ae, Ty.Fun (argTy, retTy))))) 145 | end 146 | | annotate' g (AST.App (f, arg)) = 147 | annotate' g f >>= (fn af => 148 | annotate' g arg >>= (fn aarg => 149 | pure (AApp (af, aarg, Ty.freshTyVar ())))) 150 | 151 | (* | annotate' g (AST.Let (x, NONE, e', e)) = *) 152 | (* annotate' g (AST.Let (x, SOME (Ty.freshTyVar ()), e', e)) *) 153 | (* | annotate' g (AST.Let (x, SOME ty, e', e)) = *) 154 | (* annotate' (g <+> (x, ty)) e' >>= (fn ae' => *) 155 | (* annotate' (g <+> (x, ty)) e >>= (fn ae => *) 156 | (* pure (ALet (x, ty, ae', ae, Ty.freshTyVar ())))) *) 157 | 158 | (* TODO: what do we do with type annotations? *) 159 | | annotate' g (AST.Let (_, _, _, _)) = 160 | Failure "annotate: unexpected let (should've been reduced away)" 161 | 162 | val annotate = annotate' [] 163 | 164 | end 165 | -------------------------------------------------------------------------------- /compiler/ast.sml: -------------------------------------------------------------------------------- 1 | structure AST: sig 2 | 3 | datatype term 4 | = Unit 5 | | Var of string 6 | 7 | | True 8 | | False 9 | | If of term * term * term 10 | 11 | | Zero 12 | | Succ of term 13 | | Pred of term 14 | 15 | | Nil 16 | | Cons of term * term 17 | 18 | | Pair of term * term 19 | 20 | | None 21 | | Some of term 22 | | Case of term * string * term * term 23 | 24 | | Abs of string * term 25 | | App of term * term 26 | 27 | | Let of string * Ty.ty option * term * term 28 | 29 | val subst: term -> string -> term -> term 30 | 31 | val isValue: term -> bool 32 | 33 | val unparse: term -> string 34 | 35 | end = struct 36 | 37 | open Attempt 38 | 39 | open AttemptMonad 40 | structure AttemptMonadUtil = MonadUtil(AttemptMonad) 41 | open AttemptMonadUtil 42 | infixr 0 $ 43 | infix 1 >>= >> 44 | infixr 1 =<< >=> <=< 45 | infix 4 <$> <*> 46 | 47 | 48 | datatype term 49 | = Unit 50 | | Var of string 51 | 52 | | True 53 | | False 54 | | If of term * term * term 55 | 56 | | Zero 57 | | Succ of term 58 | | Pred of term 59 | 60 | | Nil 61 | | Cons of term * term 62 | 63 | | Pair of term * term 64 | 65 | | None 66 | | Some of term 67 | | Case of term * string * term * term 68 | 69 | | Abs of string * term 70 | | App of term * term 71 | 72 | | Let of string * Ty.ty option * term * term 73 | 74 | 75 | (* substitute s for x in e *) 76 | fun subst _ _ Unit = Unit 77 | | subst s x (Var y) = 78 | if x = y 79 | then s 80 | else Var y 81 | | subst _ _ True = True 82 | | subst _ _ False = False 83 | | subst s x (If (e1, e2, e3)) = crank3 s x e1 e2 e3 If 84 | | subst _ _ Zero = Zero 85 | | subst s x (Succ e) = crank1 s x e Succ 86 | | subst s x (Pred e) = crank1 s x e Pred 87 | | subst _ _ Nil = Nil 88 | | subst s x (Cons (e1, e2)) = crank2 s x e1 e2 Cons 89 | | subst s x (Pair (e1, e2)) = crank2 s x e1 e2 Pair 90 | | subst _ _ None = None 91 | | subst s x (Some e) = crank1 s x e Some 92 | | subst s x (Case (e1, x2, e2, e3)) = 93 | let 94 | val (x2', e2Pre) = freshen x x2 e2 95 | in 96 | crank3 s x e1 e2Pre e3 (fn (e1', e2', e3') => (Case (e1', x2', e2', e3'))) 97 | end 98 | | subst s x (Abs (y, e)) = 99 | let 100 | val (y', ePre) = freshen x y e 101 | in 102 | crank1 s x ePre (fn e' => Abs (y', e')) 103 | end 104 | | subst s x (App (e1, e2)) = crank2 s x e1 e2 App 105 | | subst s x (Let (y, ty, e1, e2)) = 106 | let 107 | val (y', e1Pre) = freshen x y e1 108 | val (y', e2Pre) = freshen x y e2 109 | in 110 | crank2 s x e1Pre e2Pre (fn (e1', e2') => Let (y', ty, e1', e2')) 111 | end 112 | 113 | and freshen x1 x2 e = 114 | if x1 = x2 115 | then ("@" ^ x2, subst (Var ("@" ^ x2)) x2 e) 116 | else (x2, e) 117 | 118 | and crank1 s x e con = con (subst s x e) 119 | and crank2 s x e1 e2 con = 120 | let 121 | val e1' = subst s x e1 122 | val e2' = subst s x e2 123 | in 124 | con (e1', e2') 125 | end 126 | and crank3 s x e1 e2 e3 con = 127 | let 128 | val e1' = subst s x e1 129 | val e2' = subst s x e2 130 | val e3' = subst s x e3 131 | in 132 | con (e1', e2', e3') 133 | end 134 | 135 | 136 | fun isValue Unit = true 137 | 138 | | isValue (True | False) = true 139 | 140 | | isValue Zero = true 141 | | isValue (Succ e) = isValue e 142 | | isValue (Pred _) = false 143 | 144 | | isValue Nil = true 145 | | isValue (Cons (e1, e2)) = isValue e1 andalso isValue e2 146 | 147 | | isValue (Pair (e1, e2)) = isValue e1 andalso isValue e2 148 | 149 | | isValue None = true 150 | | isValue (Some e) = isValue e 151 | 152 | | isValue (Abs (_, _)) = true 153 | 154 | | isValue _ = false 155 | 156 | 157 | fun fromPeano Zero = 0 158 | | fromPeano (Succ e) = (fromPeano e) + 1 159 | | fromPeano (Pred e) = (fromPeano e) - 1 160 | | fromPeano _ = raise Fail "cannot convert non-numeric term" 161 | 162 | local open Utils in 163 | fun unparse Unit = "()" 164 | | unparse (Var x) = x 165 | 166 | | unparse True = "true" 167 | | unparse False = "false" 168 | | unparse (If (e1, e2, e3)) = 169 | spc ["if", (unparse e1), "then", (unparse e2), "else", (unparse e3)] 170 | 171 | | unparse (e as (Zero | (Succ _) | (Pred _))) = (Int.toString o fromPeano) e 172 | 173 | | unparse Nil = "[]" 174 | | unparse (Cons (e1, e2)) = spc [unparse e1, "::", unparse e2] 175 | 176 | | unparse (Pair (e1, e2)) = paren ((cat o between [unparse e1, unparse e2]) ", ") 177 | 178 | | unparse None = "None" 179 | | unparse (Some e) = spc ["Some", unparse e] 180 | | unparse (Case (e1, x, e2, e3)) = spc [ 181 | "case", unparse e1, 182 | "of", spc ["Some", x], "=>", unparse e2, 183 | "|", "None", "=>", unparse e3 184 | ] 185 | 186 | | unparse (Abs (x, e)) = 187 | spc ["fn", x, "=>", unparse e] 188 | | unparse (App ((Var f), arg)) = spc [f, unparse arg] 189 | | unparse (App (e, arg)) = spc [(paren o unparse) e, unparse arg] 190 | 191 | | unparse (Let (x, (SOME ty), e', e)) = 192 | spc ["let", x, ":", Ty.unty ty, "=", unparse e', "in", unparse e] 193 | | unparse (Let (x, NONE, e', e)) = 194 | spc ["let", x, "=", unparse e', "in", unparse e] 195 | end 196 | 197 | end 198 | -------------------------------------------------------------------------------- /compiler/attempt-monad.sml: -------------------------------------------------------------------------------- 1 | structure AttemptMonad: Monad = struct 2 | 3 | open Attempt 4 | infix >>= 5 | 6 | type 'a monad = 'a attempt 7 | 8 | val pure = Success 9 | 10 | fun (Failure m) >>= f = Failure m 11 | | (Success x) >>= f = f x 12 | 13 | end 14 | -------------------------------------------------------------------------------- /compiler/attempt.sml: -------------------------------------------------------------------------------- 1 | structure Attempt = struct 2 | 3 | datatype 'a attempt 4 | = Success of 'a 5 | | Failure of string 6 | 7 | end 8 | -------------------------------------------------------------------------------- /compiler/class.sml: -------------------------------------------------------------------------------- 1 | structure Class: sig 2 | 3 | type class = { 4 | name: string, 5 | self: TyScheme.tyScheme, 6 | binds: (string * TyScheme.tyScheme) list 7 | } 8 | 9 | val classExpr: Scan.token list -> (class * Scan.token list) Attempt.attempt 10 | 11 | end = struct 12 | 13 | open Attempt 14 | 15 | open ParseMonad 16 | structure ParseMonadUtil = MonadUtil(ParseMonad) 17 | open ParseMonadUtil 18 | infixr 0 $ 19 | infix 1 >>= >> 20 | infixr 1 =<< >=> <=< 21 | infix 4 <$> <*> 22 | 23 | open ParseUtil 24 | infix 1 \/ 25 | 26 | 27 | type class = { 28 | name: string, 29 | self: TyScheme.tyScheme, 30 | binds: (string * TyScheme.tyScheme) list 31 | } 32 | 33 | fun bindingExpr ts = ( 34 | litKey "val" >> 35 | identifier >>= (fn name => 36 | lit Scan.Colon >> 37 | TyExpr.tyExpr (Scan.Keyword "val") >>= 38 | pure o TyScheme.generalize >>= (fn tyScheme => 39 | pure (name, tyScheme)))) ts 40 | 41 | fun classExpr ts = ( 42 | litKey "class" >> 43 | identifier >>= (fn name => 44 | TyExpr.tyExpr (Scan.Keyword "where") >>= 45 | pure o TyScheme.generalize >>= (fn self => 46 | litKey "where" >> 47 | many1 bindingExpr >>= (fn binds => 48 | pure {name = name, self = self, binds = binds})))) ts 49 | 50 | end 51 | -------------------------------------------------------------------------------- /compiler/collect.sml: -------------------------------------------------------------------------------- 1 | structure Collect: sig 2 | 3 | val collect: Annotate.aterm -> (Ty.ty * Ty.ty) list Attempt.attempt 4 | 5 | end = struct 6 | 7 | open Attempt 8 | 9 | open AttemptMonad 10 | structure AttemptMonadUtil = MonadUtil(AttemptMonad) 11 | open AttemptMonadUtil 12 | infixr 0 $ 13 | infix 1 >>= >> 14 | infixr 1 =<< >=> <=< 15 | infix 4 <$> <*> 16 | 17 | val <+> = TyEnv.<+> 18 | infix <+> 19 | 20 | local open Ty in local open Annotate in 21 | fun collect' [] cs = pure cs 22 | | collect' (AIf (ae1, ae2, ae3, ty) :: aes) cs = 23 | getTy ae1 >>= (fn ae1Ty => 24 | getTy ae2 >>= (fn ae2Ty => 25 | getTy ae3 >>= (fn ae3Ty => 26 | collect' (ae1 :: ae2 :: ae3 :: aes) 27 | ((ae1Ty, Bool) :: (ae2Ty, ae3Ty) :: (ae2Ty, ty) :: cs)))) 28 | 29 | | collect' (ACons (hd, tl, List ty) :: aes) cs = 30 | getTy hd >>= (fn hdTy => 31 | getTy tl >>= (fn tlTy => 32 | collect' (hd :: tl :: aes) ((hdTy, ty) :: (tlTy, List ty) :: cs))) 33 | | collect' (ACons (_, _, _) :: _) _ = 34 | Failure "received an annotated cons that didn't have a list type" 35 | 36 | | collect' (APair (ae1, ae2, ty) :: aes) cs = 37 | getTy ae1 >>= (fn ae1Ty => 38 | getTy ae2 >>= (fn ae2Ty => 39 | collect' (ae1 :: ae2 :: aes) ((ty, Pair (ae1Ty, ae2Ty)) :: cs))) 40 | 41 | | collect' (ASome (ae, ty) :: aes) cs = 42 | getTy ae >>= (fn aeTy => 43 | collect' (ae :: aes) ((ty, Option aeTy) :: cs)) 44 | 45 | | collect' (ACase (ae1, _, ty2, ae2, ae3, ty) :: aes) cs = 46 | getTy ae1 >>= (fn ae1Ty => 47 | getTy ae2 >>= (fn ae2Ty => 48 | getTy ae3 >>= (fn ae3Ty => 49 | collect' (ae1 :: ae2 :: ae3 :: aes) 50 | ((ae1Ty, Option ty2) :: (ae2Ty, ae3Ty) :: (ae2Ty, ty) :: cs)))) 51 | 52 | | collect' (AAbs (_, ae, _) :: aes) cs = collect' (ae :: aes) cs 53 | | collect' (AApp (f, arg, ty) :: aes) cs = 54 | getTy f >>= (fn fTy => 55 | getTy arg >>= (fn argTy => 56 | collect' (f :: arg :: aes) ((fTy, Fun (argTy, ty)) :: cs))) 57 | 58 | (* | collect' (ALet (x, ty', ae', ae, ty) :: aes) cs = *) 59 | (* getTy ae' >>= (fn ae'Ty => *) 60 | (* getTy ae >>= (fn aeTy => *) 61 | (* collect' (ae' :: ae :: aes) ((ae'Ty, ty') :: (aeTy, ty) :: cs))) *) 62 | 63 | | collect' (_ :: aes) cs = collect' aes cs 64 | end end 65 | 66 | fun collect ae = collect' [ae] [] 67 | 68 | end 69 | -------------------------------------------------------------------------------- /compiler/compile.sml: -------------------------------------------------------------------------------- 1 | structure Compile : sig 2 | 3 | type 'a compileFn = string -> 'a Attempt.attempt 4 | 5 | val scan: string -> Scan.token list Attempt.attempt 6 | val unscan: string -> string Attempt.attempt 7 | val parse: string -> AST.term Attempt.attempt 8 | val unparse: string -> string Attempt.attempt 9 | val letReduce: string -> AST.term Attempt.attempt 10 | val annotate: string -> Annotate.aterm Attempt.attempt 11 | val collect: string -> (Ty.ty * Ty.ty) list Attempt.attempt 12 | val unify: string -> Unify.substitution Attempt.attempt 13 | val typeof: string -> Ty.ty Attempt.attempt 14 | val polish: string -> Ty.ty Attempt.attempt 15 | val unty: string -> string Attempt.attempt 16 | (* val eval: string -> AST.term Attempt.attempt *) 17 | (* val unval: string -> string Attempt.attempt *) 18 | 19 | val read: string -> string 20 | 21 | end = struct 22 | 23 | open Attempt 24 | 25 | open AttemptMonad 26 | structure AttemptMonadUtil = MonadUtil(AttemptMonad) 27 | open AttemptMonadUtil 28 | infixr 0 $ 29 | infix 1 >>= >> 30 | infixr 1 =<< >=> <=< 31 | infix 4 <$> <*> 32 | 33 | type 'a compileFn = string -> 'a Attempt.attempt 34 | 35 | fun compile pre f = fn prog => 36 | pure prog >>= pre >>= f 37 | 38 | val scan = Scan.scan 39 | val unscan = compile scan (pure o Scan.unscan) 40 | 41 | val parse = compile scan Parse.parse 42 | val unparse = compile parse (pure o AST.unparse) 43 | 44 | val letReduce = compile parse (pure o LetReduce.reduce) 45 | 46 | val annotate = compile letReduce Annotate.annotate 47 | val collect = compile annotate Collect.collect 48 | val unify = compile collect Unify.unify 49 | fun typeof prog = 50 | let 51 | val ae = annotate prog 52 | val ty = Annotate.getTy =<< ae 53 | val sub = Unify.unify =<< Collect.collect =<< ae 54 | in 55 | liftM2 Unify.apply sub ty 56 | end 57 | fun polish prog = ( 58 | Ty.resetTyVars (); 59 | compile typeof (pure o Polish.polish) prog) 60 | val unty = compile polish (pure o Ty.unty) 61 | (* fun eval prog = *) 62 | (* let *) 63 | (* val e = parse prog *) 64 | (* in *) 65 | (* typeof prog >> *) 66 | (* e >>= *) 67 | (* Eval.eval *) 68 | (* end *) 69 | (* val unval = compile eval (pure o AST.unparse) *) 70 | 71 | fun read filename = 72 | let 73 | val instrm = TextIO.openIn filename 74 | fun lp _ = 75 | (case TextIO.inputLine instrm 76 | of NONE => "" 77 | | SOME line => line ^ lp ()) 78 | val fileContentsAsString = lp () 79 | val _ = TextIO.closeIn instrm 80 | in 81 | fileContentsAsString 82 | end 83 | 84 | end 85 | -------------------------------------------------------------------------------- /compiler/eval.sml: -------------------------------------------------------------------------------- 1 | (* structure Eval: sig *) 2 | 3 | (* val eval: AST.term -> AST.term Attempt.attempt *) 4 | 5 | (* end = struct *) 6 | structure Eval = struct 7 | 8 | open OptAttempt 9 | 10 | open OptAttemptMonad 11 | structure OptAttemptMonadUtil = MonadUtil(OptAttemptMonad) 12 | open OptAttemptMonadUtil 13 | infixr 0 $ 14 | infix 1 >>= >> 15 | infixr 1 =<< >=> <=< 16 | infix 4 <$> <*> 17 | 18 | 19 | local open AST in 20 | fun subst _ _ (t as ((Int _) | True | False | (String _) | Unit | (List []))) = 21 | Success t 22 | 23 | | subst x v (List (t :: ts)) = 24 | subst x v t >>= (fn t' => 25 | forM ts (subst x v) >>= (fn ts' => 26 | Success (List (t' :: ts')))) 27 | | subst x v (Pair (t1, t2)) = 28 | subst x v t1 >>= (fn t1' => 29 | subst x v t2 >>= (fn t2' => 30 | Success (Pair (t1', t2')))) 31 | | subst x v (Left t) = 32 | subst x v t >>= (fn t' => 33 | Success (Left t')) 34 | | subst x v (Right t) = 35 | subst x v t >>= (fn t' => 36 | Success (Right t')) 37 | 38 | | subst x v (If (t1, t2, t3)) = 39 | subst x v t1 >>= (fn t1' => 40 | subst x v t2 >>= (fn t2' => 41 | subst x v t3 >>= (fn t3' => 42 | Success (If (t1', t2', t3'))))) 43 | | subst x v (Case (t1, x2, t2, x3, t3)) = 44 | subst x v t1 >>= (fn t1' => 45 | if x = x2 andalso x = x3 46 | then Success (Case (t1', x2, t2, x3, t3)) 47 | else if x = x2 48 | then 49 | subst x v t3 >>= (fn t3' => 50 | Success (Case (t1', x2, t2, x3, t3'))) 51 | else if x = x3 52 | then 53 | subst x v t2 >>= (fn t2' => 54 | Success (Case (t1', x2, t2', x3, t3))) 55 | else 56 | subst x v t2 >>= (fn t2' => 57 | subst x v t3 >>= (fn t3' => 58 | Success (Case (t1', x2, t2', x3, t3'))))) 59 | | subst x v (t as Fun (x', t')) = 60 | if x = x' 61 | then Success t 62 | else 63 | subst x v t' >>= (fn t'' => 64 | Success (Fun (x', t''))) 65 | | subst x v (App (t1, t2)) = 66 | subst x v t1 >>= (fn t1' => 67 | subst x v t2 >>= (fn t2' => 68 | Success (App (t1', t2')))) 69 | | subst x v (t as Var x') = 70 | if x = x' 71 | then Success v 72 | else Success t 73 | end 74 | 75 | 76 | local open AST in 77 | fun basis "succ" [Int n] = pure (Int (n + 1)) 78 | | basis "pred" [Int n] = pure (Int (n - 1)) 79 | | basis "zero?" [Int 0] = pure True 80 | | basis "zero?" [Int _] = pure False 81 | | basis "cons" [x, List xs] = pure (List (x :: xs)) 82 | | basis "hd" [List []] = Failure "cannot take head of empty list!" 83 | | basis "hd" [List (x :: _)] = pure x 84 | | basis "tl" [List []] = Failure "cannot take tail of empty list!" 85 | | basis "tl" [List (_ :: xs)] = pure (List xs) 86 | | basis "nil?" [List []] = pure True 87 | | basis "nil?" [List _] = pure False 88 | | basis "fst" [Pair (x, _)] = pure x 89 | | basis "snd" [Pair (_, x)] = pure x 90 | | basis "plus" [Int x, Int y] = pure (Int (x + y)) 91 | | basis "minus" [Int x, Int y] = pure (Int (x - y)) 92 | | basis "times" [Int x, Int y] = pure (Int (x * y)) 93 | | basis "and" [False, _] = pure False 94 | | basis "and" [True, t] = pure t 95 | | basis "or" [True, _] = pure True 96 | | basis "or" [False, t] = pure t 97 | | basis "not" [True] = pure False 98 | | basis "not" [False] = pure True 99 | | basis f xs = 100 | if Utils.andmap isValue xs 101 | then 102 | Failure ( 103 | "either no such basis function " ^ f ^ 104 | ", or cannot apply " ^ f ^ " to args " ^ (Utils.spc (map unparse xs))) 105 | else 106 | forM xs step >>= (fn xs' => 107 | basis f xs') 108 | 109 | and step (t as ((Int _) | True | False | (String _) | Unit | (List []))) = 110 | Terminal t 111 | 112 | | step (List (t :: ts)) = 113 | if Utils.andmap isValue (t :: ts) 114 | then Terminal (List (t :: ts)) 115 | else 116 | step t >>= (fn t' => 117 | forM ts step >>= (fn ts' => 118 | pure (List (t' :: ts')))) 119 | | step (Pair (t1, t2)) = 120 | if isValue t1 andalso isValue t2 121 | then Terminal (Pair (t1, t2)) 122 | else 123 | step t1 >>= (fn t1' => 124 | step t2 >>= (fn t2' => 125 | pure (Pair (t1', t2')))) 126 | | step (Left t) = 127 | if isValue t 128 | then Terminal (Left t) 129 | else 130 | step t >>= (fn t' => 131 | pure (Left t')) 132 | | step (Right t) = 133 | if isValue t 134 | then Terminal (Right t) 135 | else 136 | step t >>= (fn t' => 137 | pure (Right t')) 138 | 139 | | step (If (t1, t2, t3)) = 140 | if isValue t1 141 | then 142 | if t1 = True 143 | then pure t2 144 | else pure t3 145 | else 146 | step t1 >>= (fn t1' => 147 | pure (If (t1', t2, t3))) 148 | | step (Case (Left t1, x2, t2, _, _)) = 149 | subst x2 t1 t2 150 | | step (Case (Right t1, _, _, x3, t3)) = 151 | subst x3 t1 t3 152 | | step (Case (t1, x2, t2, x3, t3)) = 153 | step t1 >>= (fn t1' => 154 | pure (Case (t1', x2, t2, x3, t3))) 155 | 156 | | step (t as Fun (_, _)) = 157 | Terminal t 158 | | step (App ((Fun (x, t1)), t2)) = 159 | subst x t2 t1 160 | | step (App ((App (Var f, t1)), t2)) = 161 | basis f [t1, t2] 162 | | step (App (Var f, t2)) = 163 | basis f [t2] 164 | | step (App (t1, t2)) = 165 | step t1 >>= (fn t1' => 166 | pure (App (t1', t2))) 167 | | step (Var x) = 168 | Failure ("eval error: " ^ x ^ " is a free variable") 169 | 170 | | step (Let ([(x1, ty1, t1)], t)) = 171 | if isValue t 172 | then pure t 173 | else 174 | subst x1 t1 t >>= (fn t' => 175 | step t' >>= (fn t'' => 176 | subst x1 t1 t'' >>= (fn t''' => 177 | pure (Let ([(x1, ty1, t1)], t'''))))) 178 | end 179 | 180 | fun eval t = 181 | case step t 182 | of Success t' => eval t' 183 | | Terminal t' => Attempt.Success t' 184 | | Failure m => Attempt.Failure m 185 | 186 | end 187 | -------------------------------------------------------------------------------- /compiler/instance.sml: -------------------------------------------------------------------------------- 1 | structure Instance: sig 2 | 3 | type instance = { 4 | name: string, 5 | self: TyScheme.tyScheme, 6 | binds: (string * AST.term) list 7 | } 8 | 9 | val instanceExpr: Scan.token list -> (instance * Scan.token list) Attempt.attempt 10 | 11 | end = struct 12 | 13 | open Attempt 14 | 15 | open ParseMonad 16 | structure ParseMonadUtil = MonadUtil(ParseMonad) 17 | open ParseMonadUtil 18 | infixr 0 $ 19 | infix 1 >>= >> 20 | infixr 1 =<< >=> <=< 21 | infix 4 <$> <*> 22 | 23 | open ParseUtil 24 | infix 1 \/ 25 | 26 | 27 | type instance = { 28 | name: string, 29 | self: TyScheme.tyScheme, 30 | binds: (string * AST.term) list 31 | } 32 | 33 | fun bindingExpr ts = ( 34 | litKey "val" >> 35 | identifier >>= (fn name => 36 | lit Scan.Equals >> 37 | Parse.expr >>= (fn e => 38 | pure (name, e)))) ts 39 | 40 | fun instanceExpr ts = ( 41 | litKey "instance" >> 42 | identifier >>= (fn name => 43 | TyExpr.tyExpr (Scan.Keyword "where") >>= 44 | pure o TyScheme.generalize >>= (fn self => 45 | litKey "where" >> 46 | many1 bindingExpr >>= (fn binds => 47 | pure {name = name, self = self, binds = binds})))) ts 48 | 49 | end 50 | -------------------------------------------------------------------------------- /compiler/letreduce.sml: -------------------------------------------------------------------------------- 1 | structure LetReduce: sig 2 | 3 | val reduce: AST.term -> AST.term 4 | 5 | end = struct 6 | 7 | local open AST in 8 | fun reduce Unit = Unit 9 | | reduce (Var x) = Var x 10 | | reduce True = True 11 | | reduce False = False 12 | | reduce (If (e1, e2, e3)) = crank3 e1 e2 e3 If 13 | | reduce Zero = Zero 14 | | reduce (Succ e) = crank1 e Succ 15 | | reduce (Pred e) = crank1 e Pred 16 | | reduce Nil = Nil 17 | | reduce (Cons (e1, e2)) = crank2 e1 e2 Cons 18 | | reduce (Pair (e1, e2)) = crank2 e1 e2 Pair 19 | | reduce None = None 20 | | reduce (Some e) = crank1 e Some 21 | | reduce (Case (e1, x2, e2, e3)) = crank3 e1 e2 e3 (fn (e1', e2', e3') => Case (e1', x2, e2', e3')) 22 | | reduce (Abs (x, e)) = crank1 e (fn e' => Abs (x, e')) 23 | | reduce (App (e1, e2)) = crank2 e1 e2 App 24 | | reduce (Let (x, ty, e1, e2)) = reduce (subst e1 x e2) 25 | 26 | and crank1 e con = con (reduce e) 27 | and crank2 e1 e2 con = 28 | let 29 | val e1' = reduce e1 30 | val e2' = reduce e2 31 | in 32 | con (e1, e2) 33 | end 34 | and crank3 e1 e2 e3 con = 35 | let 36 | val e1' = reduce e1 37 | val e2' = reduce e2 38 | val e3' = reduce e3 39 | in 40 | con (e1, e2, e3) 41 | end 42 | end 43 | 44 | end 45 | -------------------------------------------------------------------------------- /compiler/luca.bnf: -------------------------------------------------------------------------------- 1 | t ::= 2 | true 3 | false 4 | nv 5 | () 6 | str 7 | 8 | [t, t, ...] 9 | (t, t) 10 | Left t 11 | Right t 12 | 13 | if t then t else t 14 | case t of Some x => t | None => t 15 | case t of Left x => t | Right x => t 16 | 17 | fn x x ... => t 18 | x(t)(t)(...) 19 | (t)(t)(t)(...) 20 | x 21 | 22 | let dec ... in t 23 | 24 | dec ::= 25 | x = t 26 | x: ty = t 27 | 28 | nv ::= 29 | 0 30 | 1 31 | ... 32 | 33 | str ::= 34 | "x" 35 | 36 | ty ::= 37 | int 38 | bool 39 | string 40 | unit 41 | tyvar 42 | 43 | ty list 44 | ty option 45 | 46 | ty -> ty 47 | ty * ty 48 | ty | ty 49 | 50 | (ty) 51 | -------------------------------------------------------------------------------- /compiler/monad-util.sml: -------------------------------------------------------------------------------- 1 | signature MonadUtil = sig 2 | 3 | include Monad 4 | 5 | (* A synonym for >>= *) 6 | val bind : 'a monad -> ('a -> 'b monad) -> 'b monad 7 | 8 | (* A handful of sequencing related operators. *) 9 | val =<< : ('a -> 'b monad) * 'a monad -> 'b monad 10 | val >> : 'a monad * 'b monad -> 'b monad 11 | val >=> : ('a -> 'b monad) * ('b -> 'c monad) -> 'a -> 'c monad 12 | val <=< : ('a -> 'b monad) * ('c -> 'a monad) -> 'c -> 'b monad 13 | 14 | (* Functions for sequencing lists. *) 15 | val sequence : 'a monad list -> 'a list monad 16 | val sequence_ : 'a monad list -> unit monad 17 | val mapM : ('a -> 'b monad) -> 'a list -> 'b list monad 18 | val mapM_ : ('a -> 'b monad) -> 'a list -> unit monad 19 | val forM : 'a list -> ('a -> 'b monad) -> 'b list monad 20 | val forM_ : 'a list -> ('a -> 'b monad) -> unit monad 21 | 22 | (* Functions for lifting other functions into monads. *) 23 | val liftM : ('a -> 'b) -> 'a monad -> 'b monad 24 | val liftM2 : ('a -> 'b -> 'c) -> 'a monad -> 'b monad -> 'c monad 25 | val liftM3 : ('a -> 'b -> 'c -> 'd) -> 'a monad -> 'b monad -> 'c monad -> 'd monad 26 | val liftM2' : ('a * 'b -> 'c) -> 'a monad * 'b monad -> 'c monad 27 | 28 | (* Things that properly belong in a functor or applicative. *) 29 | val fmap : ('a -> 'b) -> 'a monad -> 'b monad 30 | val <$> : ('a -> 'b) * 'a monad -> 'b monad 31 | val ap : ('a -> 'b) monad -> 'a monad -> 'b monad 32 | val <*> : ('a -> 'b) monad * 'a monad -> 'b monad 33 | 34 | val forever : 'a monad -> 'b monad 35 | val join : 'a monad monad -> 'a monad 36 | 37 | end 38 | 39 | functor MonadUtil (M: Monad): MonadUtil = struct 40 | 41 | open M 42 | infixr 0 $ 43 | infix 1 >>= >> 44 | infixr 1 =<< >=> <=< 45 | infix 4 <$> <*> 46 | 47 | fun f $ x = f x 48 | fun id x = x 49 | 50 | fun bind m f = m >>= f 51 | fun f =<< mx = mx >>= f 52 | fun x >> y = x >>= (fn _ => y) 53 | 54 | (* fish. *) 55 | fun f >=> g = fn x => f x >>= g 56 | fun g <=< f = fn x => f x >>= g 57 | 58 | (* Some of these are names stolen from haskell functions 59 | * over Functor and Applicative instances. *) 60 | fun fmap f mx = mx >>= (fn x => pure $ f x) 61 | fun f <$> x = fmap f x 62 | val liftM = fmap 63 | fun liftM2 f m1 m2 = 64 | m1 >>= (fn x1 => m2 >>= (fn x2 => pure $ f x1 x2)) 65 | fun liftM3 f m1 m2 m3 = 66 | m1 >>= (fn x1 => m2 >>= (fn x2 => m3 >>= (fn x3 => pure $ f x1 x2 x3))) 67 | (* Sigh, SML. Why don't you curry more? *) 68 | fun liftM2' f (m1, m2) = 69 | m1 >>= (fn x1 => m2 >>= (fn x2 => pure $ f (x1, x2))) 70 | 71 | fun ap f x = liftM2 id f x 72 | fun f <*> x = ap f x 73 | 74 | fun sequence ms = 75 | foldr (liftM2' (op ::)) (pure []) ms 76 | 77 | fun sequence_ ms = foldr (op >>) (pure ()) ms 78 | 79 | fun mapM f x = sequence $ map f x 80 | fun mapM_ f x = sequence_ $ map f x 81 | fun forM x f = mapM f x 82 | fun forM_ x f = mapM_ f x 83 | 84 | (* Haskell defines forever as "forever a = a >> forever a". 85 | * We can't do that because we are strict *) 86 | fun forever a = a >>= (fn _ => forever a) 87 | 88 | fun join m = m >>= id 89 | 90 | end 91 | -------------------------------------------------------------------------------- /compiler/monad.sig: -------------------------------------------------------------------------------- 1 | signature Monad = sig 2 | 3 | type 'a monad 4 | val pure: 'a -> 'a monad 5 | val >>= : 'a monad * ('a -> 'b monad) -> 'b monad 6 | 7 | end 8 | -------------------------------------------------------------------------------- /compiler/optattempt-monad.sml: -------------------------------------------------------------------------------- 1 | structure OptAttemptMonad: Monad = struct 2 | 3 | open OptAttempt 4 | infix >>= 5 | 6 | type 'a monad = 'a optattempt 7 | 8 | val pure = Success 9 | 10 | fun (Failure m) >>= f = Failure m 11 | | (Terminal x) >>= f = f x 12 | | (Success x) >>= f = f x 13 | 14 | end 15 | -------------------------------------------------------------------------------- /compiler/optattempt.sml: -------------------------------------------------------------------------------- 1 | structure OptAttempt = struct 2 | 3 | datatype 'a optattempt 4 | = Success of 'a 5 | | Terminal of 'a 6 | | Failure of string 7 | 8 | end 9 | -------------------------------------------------------------------------------- /compiler/parse-monad.sml: -------------------------------------------------------------------------------- 1 | structure ParseMonad: Monad = struct 2 | 3 | open Attempt 4 | infix >>= 5 | 6 | type 'a parser = Scan.token list -> ('a * Scan.token list) attempt 7 | type 'a monad = 'a parser 8 | 9 | fun pure v = fn ts => 10 | Success (v, ts) 11 | 12 | fun p >>= f = fn ts => 13 | case (p ts) 14 | of Success (e, ts') => f e ts' 15 | | Failure m => Failure m 16 | 17 | end 18 | -------------------------------------------------------------------------------- /compiler/parse-util.sml: -------------------------------------------------------------------------------- 1 | structure ParseUtil = struct 2 | 3 | open Attempt 4 | 5 | open ParseMonad 6 | structure ParseMonadUtil = MonadUtil(ParseMonad) 7 | open ParseMonadUtil 8 | infixr 0 $ 9 | infix 1 >>= >> 10 | infixr 1 =<< >=> <=< 11 | infix 4 <$> <*> 12 | 13 | (* misc utilities *) 14 | infix \/ 15 | fun p1 \/ p2 = fn ts => 16 | case (p1 ts) 17 | of Success e => Success e 18 | | Failure _ => (p2 ts) 19 | 20 | fun many p = (fn ts => (( 21 | p >>= (fn x => 22 | (many p \/ pure []) >>= (fn xs => 23 | pure (x :: xs)))) \/ pure []) ts) 24 | 25 | fun many1 p = (fn ts => ( 26 | p >>= (fn x => 27 | (many1 p \/ pure []) >>= (fn xs => 28 | pure (x :: xs)))) ts) 29 | 30 | fun lit t [] = Failure ("parse error: expected " ^ (Scan.unscan [t]) ^ ", got none") 31 | | lit t (t' :: ts') = 32 | if t = t' 33 | then Success ((), ts') 34 | else Failure 35 | ("expected: [" ^ (Scan.unscan [t]) ^ "]" 36 | ^ ", got: [" ^ (Scan.unscan [t']) ^ "]" 37 | ^ ", remaining program: [" ^ (Scan.unscan ts') ^ "]") 38 | 39 | fun litId id = lit (Scan.Identifier id) 40 | fun litKey key = lit (Scan.Keyword key) 41 | 42 | val identifier = fn ts => 43 | case ts 44 | of Scan.Identifier x :: ts' => Success (x, ts') 45 | | _ => Failure ("expected identifier, got: " ^ (Scan.unscan ts)) 46 | 47 | end 48 | -------------------------------------------------------------------------------- /compiler/parse.sml: -------------------------------------------------------------------------------- 1 | structure Parse: sig 2 | 3 | val expr: Scan.token list -> (AST.term * Scan.token list) Attempt.attempt 4 | 5 | val parse: Scan.token list -> AST.term Attempt.attempt 6 | 7 | end = struct 8 | 9 | open Attempt 10 | 11 | open ParseMonad 12 | structure ParseMonadUtil = MonadUtil(ParseMonad) 13 | open ParseMonadUtil 14 | infixr 0 $ 15 | infix 1 >>= >> 16 | infixr 1 =<< >=> <=< 17 | infix 4 <$> <*> 18 | 19 | open ParseUtil 20 | infix 1 \/ 21 | 22 | 23 | (* literal expressions *) 24 | val unitExpr = 25 | lit Scan.LParen >> 26 | lit Scan.RParen >> 27 | pure AST.Unit 28 | 29 | val varExpr = AST.Var <$> identifier 30 | 31 | val boolExpr = 32 | (litKey "true" >> pure AST.True) \/ 33 | (litKey "false" >> pure AST.False) 34 | 35 | fun toPeano 0 = AST.Zero 36 | | toPeano n = AST.Succ (toPeano (n - 1)) 37 | val intExpr = fn ts => 38 | case ts 39 | of Scan.Numeric n :: ts' => Success (toPeano n, ts') 40 | | _ => Failure ("expected numeric, got: " ^ (Scan.unscan ts)) 41 | 42 | val nilExpr = 43 | lit Scan.LBracket >> 44 | lit Scan.RBracket >> 45 | pure AST.Nil 46 | 47 | val noneExpr = 48 | litKey "None" >> 49 | pure AST.None 50 | 51 | 52 | (* recursive expressions *) 53 | fun nestedExpr ts = ( 54 | lit Scan.LParen >> 55 | expr >>= (fn e1 => 56 | lit Scan.RParen >> 57 | pure e1)) ts 58 | 59 | and absExpr ts = ( 60 | litKey "fn" >> 61 | (many1 identifier) >>= (fn xs => 62 | lit Scan.FatArrow >> 63 | expr >>= (fn e => 64 | pure (foldr AST.Abs e xs)))) ts 65 | 66 | and appExpr ts = ( 67 | (varExpr \/ nestedExpr) >>= (fn f => 68 | many1 (litExpr \/ nestedExpr) >>= (fn xs => 69 | pure (foldl (fn (x, f') => AST.App (f', x)) f xs)))) ts 70 | 71 | and letExpr ts = 72 | let 73 | fun annotated ts = ( 74 | identifier >>= (fn x => 75 | lit Scan.Colon >> 76 | TyExpr.tyExpr Scan.Equals >>= (fn ty => 77 | pure (x, SOME ty)))) ts 78 | fun unannotated ts = ( 79 | identifier >>= (fn x => 80 | pure (x, NONE))) ts 81 | val bindingExpr = annotated \/ unannotated 82 | in ( 83 | litKey "let" >> 84 | bindingExpr >>= (fn (x, mTy) => 85 | lit Scan.Equals >> 86 | expr >>= (fn e' => 87 | litKey "in" >> 88 | expr >>= (fn e => 89 | pure (AST.Let (x, mTy, e', e)))))) ts 90 | end 91 | 92 | and listExpr ts = 93 | let 94 | fun commaExpr ts = ( 95 | lit Scan.Comma >> 96 | expr >>= (fn e => 97 | pure e)) ts 98 | in ( 99 | lit Scan.LBracket >> 100 | expr >>= (fn hd => 101 | (many commaExpr) >>= (fn tl => 102 | lit Scan.RBracket >> 103 | pure (foldr (fn (x, inner) => AST.Cons (x, inner)) AST.Nil (hd :: tl))))) ts 104 | end 105 | 106 | and pairExpr ts = 107 | let 108 | fun commaExpr ts = ( 109 | expr >>= (fn e => 110 | lit Scan.Comma >> 111 | pure e)) ts 112 | in ( 113 | lit Scan.LParen >> 114 | (many1 commaExpr) >>= (fn fsts => 115 | expr >>= (fn snd => 116 | lit Scan.RParen >> 117 | pure (foldr (fn (x, inner) => AST.Pair (x, inner)) snd fsts)))) ts 118 | end 119 | 120 | and ifExpr ts = ( 121 | litKey "if" >> 122 | expr >>= (fn e1 => 123 | litKey "then" >> 124 | expr >>= (fn e2 => 125 | litKey "else" >> 126 | expr >>= (fn e3 => 127 | pure (AST.If (e1, e2, e3)))))) ts 128 | 129 | and someExpr ts = ( 130 | litId "Some" >> 131 | expr >>= (fn e => 132 | pure (AST.Some e))) ts 133 | 134 | and noneExpr ts = ( 135 | litId "None" >> 136 | pure (AST.None)) ts 137 | 138 | and caseExpr ts = ( 139 | (* case e *) 140 | litKey "case" >> 141 | (litExpr \/ nestedExpr) >>= (fn e1 => 142 | 143 | (* of Some x => e *) 144 | litKey "of" >> 145 | litId "Some" >> 146 | identifier >>= (fn x => 147 | lit Scan.FatArrow >> 148 | expr >>= (fn e2 => 149 | 150 | (* | None => e *) 151 | lit Scan.Pipe >> 152 | litId "None" >> 153 | lit Scan.FatArrow >> 154 | expr >>= (fn e3 => 155 | 156 | pure (AST.Case (e1, x, e2, e3))))))) ts 157 | 158 | and litExpr ts = ( 159 | boolExpr \/ 160 | intExpr \/ 161 | listExpr \/ 162 | pairExpr \/ 163 | unitExpr \/ 164 | noneExpr \/ 165 | varExpr) ts 166 | 167 | and expr ts = ( 168 | boolExpr \/ 169 | intExpr \/ 170 | listExpr \/ 171 | pairExpr \/ 172 | unitExpr \/ 173 | someExpr \/ 174 | noneExpr \/ 175 | 176 | ifExpr \/ 177 | caseExpr \/ 178 | 179 | absExpr \/ 180 | appExpr \/ 181 | letExpr \/ 182 | 183 | varExpr) ts 184 | 185 | fun parse tokens = 186 | case expr tokens 187 | of Success (term, []) => Success term 188 | | Success (term, ts) => Failure ( 189 | "parse error: extra tokens:\n got\n " 190 | ^ (AST.unparse term) 191 | ^ "\n remaining\n " 192 | ^ (Scan.unscan ts)) 193 | | Failure msg => Failure msg 194 | 195 | end 196 | -------------------------------------------------------------------------------- /compiler/polish.sml: -------------------------------------------------------------------------------- 1 | structure Polish: sig 2 | 3 | val polish: Ty.ty -> Ty.ty 4 | 5 | end = struct 6 | 7 | open Ty 8 | 9 | fun lookupOrPolish [] x = (x, freshPolishedTyVar ()) 10 | | lookupOrPolish ((x': string, tv': ty) :: ps) x = 11 | if x = x' 12 | then (x, tv') 13 | else lookupOrPolish ps x 14 | 15 | fun polish' ps (Unit | Bool | Int) = ps 16 | | polish' ps (List ty) = polish' ps ty 17 | | polish' ps (Option ty) = polish' ps ty 18 | | polish' ps (Pair (ty1, ty2)) = 19 | foldl (fn (ty', ps') => polish' ps' ty') ps [ty1, ty2] 20 | | polish' ps (Fun (arg, ret)) = 21 | foldl (fn (ty', ps') => polish' ps' ty') ps [arg, ret] 22 | | polish' ps (TyVar x) = 23 | ps @ [lookupOrPolish ps x] 24 | 25 | fun polish ty = Unify.apply (polish' [] ty) ty 26 | 27 | end 28 | -------------------------------------------------------------------------------- /compiler/scan.sml: -------------------------------------------------------------------------------- 1 | structure Scan: sig 2 | 3 | datatype token 4 | = Identifier of string 5 | | Keyword of string 6 | | LParen 7 | | RParen 8 | | Equals 9 | 10 | | Numeric of int 11 | | LBracket 12 | | RBracket 13 | | Comma 14 | | Quote 15 | | Pipe 16 | | Asterisk 17 | | Colon 18 | | ThinArrow 19 | | FatArrow 20 | 21 | val scan: string -> token list Attempt.attempt 22 | 23 | val unscan: token list -> string 24 | 25 | end = struct 26 | 27 | datatype token 28 | = Identifier of string 29 | | Keyword of string 30 | | LParen 31 | | RParen 32 | | Equals 33 | 34 | | Numeric of int 35 | | LBracket 36 | | RBracket 37 | | Comma 38 | | Quote 39 | | Pipe 40 | | Asterisk 41 | | Colon 42 | | ThinArrow 43 | | FatArrow 44 | 45 | open Attempt 46 | 47 | open AttemptMonad 48 | structure AttemptMonadUtil = MonadUtil(AttemptMonad) 49 | open AttemptMonadUtil 50 | infixr 0 $ 51 | infix 1 >>= >> 52 | infixr 1 =<< >=> <=< 53 | infix 4 <$> <*> 54 | 55 | fun err msg = Utils.err "scan" msg 56 | 57 | fun nextID cs = 58 | let 59 | fun existsIn xs x = List.exists (fn x' => x = x') xs 60 | 61 | val keychars = [ 62 | #"(", 63 | #")", 64 | #"=", 65 | #"[", 66 | #"]", 67 | #",", 68 | #"+", 69 | #"-", 70 | #"\"", 71 | #"|", 72 | #">", 73 | #"*", 74 | #":" 75 | ] 76 | val isKeychar = existsIn keychars 77 | 78 | val keywords = [ 79 | "fn", 80 | 81 | "let", 82 | "val", 83 | "in", 84 | 85 | "true", 86 | "false", 87 | 88 | "if", 89 | "then", 90 | "else", 91 | 92 | "case", 93 | "of", 94 | 95 | "class", 96 | "instance", 97 | "where" 98 | ] 99 | val isKeyword = existsIn keywords 100 | 101 | infix \/ 102 | fun p \/ q = fn x => (p x orelse q x) 103 | fun fnot f = fn x => not (f x) 104 | 105 | val (cs1, cs2) = Utils.takeWhile (fnot (Char.isSpace \/ isKeychar)) cs 106 | val id = implode cs1 107 | in 108 | if 109 | id = "" 110 | then 111 | Failure ("scan error: encountered empty identifier at " ^ (implode cs)) 112 | else if 113 | List.all Char.isDigit cs1 114 | then 115 | Success (Numeric (valOf (Int.fromString id)), cs2) 116 | else if 117 | isKeyword id 118 | then 119 | Success (Keyword id, cs2) 120 | else 121 | Success (Identifier id, cs2) 122 | end 123 | 124 | fun nextToken [] = Failure "scan error: ground case" 125 | | nextToken ((#" " | #"\t" | #"\n") :: cs) = nextToken cs 126 | 127 | | nextToken (#"-" :: #">" :: cs) = Success (ThinArrow, cs) 128 | | nextToken (#"=" :: #">" :: cs) = Success (FatArrow, cs) 129 | 130 | | nextToken (#"(" :: cs) = Success (LParen, cs) 131 | | nextToken (#")" :: cs) = Success (RParen, cs) 132 | | nextToken (#"=" :: cs) = Success (Equals, cs) 133 | | nextToken (#"[" :: cs) = Success (LBracket, cs) 134 | | nextToken (#"]" :: cs) = Success (RBracket, cs) 135 | | nextToken (#"," :: cs) = Success (Comma, cs) 136 | | nextToken (#"\"" :: cs) = Success (Quote, cs) 137 | | nextToken (#"|" :: cs) = Success (Pipe, cs) 138 | | nextToken (#"*" :: cs) = Success (Asterisk, cs) 139 | | nextToken (#":" :: cs) = Success (Colon, cs) 140 | 141 | | nextToken cs = nextID cs 142 | 143 | fun scan program = 144 | let 145 | fun lp [] = Success [] 146 | | lp cs = 147 | case nextToken cs 148 | of Failure "scan error: ground case" => Success [] 149 | | Failure m => Failure m 150 | | Success (tok, cs') => 151 | pure cs' >>= 152 | lp >>= (fn cs'' => 153 | pure (tok :: cs'')) 154 | in 155 | lp (explode program) 156 | end 157 | 158 | fun unscanT (Identifier s) = s 159 | | unscanT (Keyword s) = s 160 | | unscanT LParen = "(" 161 | | unscanT RParen = ")" 162 | | unscanT Equals = "=" 163 | 164 | | unscanT (Numeric n) = Int.toString n 165 | | unscanT LBracket = "[" 166 | | unscanT RBracket = "]" 167 | | unscanT Comma = "," 168 | | unscanT Quote = "\"" 169 | | unscanT Pipe = "|" 170 | | unscanT Asterisk = "*" 171 | | unscanT Colon = ":" 172 | | unscanT ThinArrow = "->" 173 | | unscanT FatArrow = "=>" 174 | 175 | fun unscan ts = 176 | Utils.cat (Utils.between (map unscanT ts) ", ") 177 | 178 | end 179 | -------------------------------------------------------------------------------- /compiler/sources.cm: -------------------------------------------------------------------------------- 1 | Group 2 | structure Utils 3 | structure Attempt 4 | structure OptAttempt 5 | signature Monad 6 | signature MonadUtil 7 | functor MonadUtil 8 | 9 | structure AttemptMonad 10 | structure ParseMonad 11 | structure OptAttemptMonad 12 | 13 | structure AST 14 | structure Ty 15 | structure TyScheme 16 | structure Class 17 | structure Instance 18 | structure SurfaceProgram 19 | 20 | structure Scan 21 | 22 | structure ParseUtil 23 | structure TyExpr 24 | structure Parse 25 | 26 | structure LetReduce 27 | 28 | structure TyEnv 29 | structure Annotate 30 | structure Collect 31 | structure Unify 32 | structure Polish 33 | 34 | structure Compile 35 | structure Tests 36 | 37 | is 38 | $/basis.cm 39 | utils.sml 40 | attempt.sml 41 | optattempt.sml 42 | monad.sig 43 | monad-util.sml 44 | 45 | attempt-monad.sml 46 | optattempt-monad.sml 47 | parse-monad.sml 48 | 49 | ast.sml 50 | ty.sml 51 | class.sml 52 | instance.sml 53 | tyscheme.sml 54 | surfaceprogram.sml 55 | 56 | scan.sml 57 | 58 | parse-util.sml 59 | tyexpr.sml 60 | parse.sml 61 | 62 | letreduce.sml 63 | 64 | tyenv.sml 65 | annotate.sml 66 | collect.sml 67 | unify.sml 68 | polish.sml 69 | 70 | compile.sml 71 | tests.sml 72 | -------------------------------------------------------------------------------- /compiler/surfaceprogram.sml: -------------------------------------------------------------------------------- 1 | structure SurfaceProgram: sig 2 | 3 | type program = { 4 | classes: Class.class list, 5 | instances: Instance.instance list, 6 | body: AST.term 7 | } 8 | 9 | end = struct 10 | 11 | type program = { 12 | classes: Class.class list, 13 | instances: Instance.instance list, 14 | body: AST.term 15 | } 16 | 17 | (* fun verifyInstances *) 18 | 19 | end 20 | -------------------------------------------------------------------------------- /compiler/tests.sml: -------------------------------------------------------------------------------- 1 | structure Tests: sig 2 | 3 | val run: 'a Compile.compileFn -> (string * 'a Attempt.attempt) list 4 | val run1: string -> 'a Compile.compileFn -> 'a Attempt.attempt 5 | 6 | end = struct 7 | 8 | open Attempt 9 | 10 | open AttemptMonad 11 | structure AttemptMonadUtil = MonadUtil(AttemptMonad) 12 | open AttemptMonadUtil 13 | infixr 0 $ 14 | infix 1 >>= >> 15 | infixr 1 =<< >=> <=< 16 | infix 4 <$> <*> 17 | 18 | fun ls dir = 19 | let 20 | val strm = OS.FileSys.openDir dir; 21 | 22 | fun readAll strm = 23 | case OS.FileSys.readDir strm 24 | of SOME f => (Utils.cat [dir, "/", f]) :: (readAll strm) 25 | | NONE => [] 26 | in 27 | readAll strm 28 | end 29 | 30 | fun run f = 31 | let 32 | val files = ls "tests" 33 | val ress = map (f o Compile.read) files 34 | in 35 | Utils.zipEq files ress 36 | end 37 | 38 | fun run1 file f = (f o Compile.read) (Utils.cat ["tests/", file, ".luca"]) 39 | 40 | end 41 | -------------------------------------------------------------------------------- /compiler/tests/concat.luca: -------------------------------------------------------------------------------- 1 | let 2 | val rev' = fn xs acc => 3 | if nil? xs 4 | then acc 5 | else rev' (tl xs) (cons (hd xs) acc) 6 | 7 | val rev = fn xs => 8 | rev' xs [] 9 | 10 | val concat = fn xs ys => 11 | if nil? ys 12 | then xs 13 | else concat (rev (cons (hd ys) (rev xs))) (tl ys) 14 | in 15 | concat 16 | -------------------------------------------------------------------------------- /compiler/tests/curried_add.luca: -------------------------------------------------------------------------------- 1 | let 2 | val plus = fn x y => 3 | if zero? y 4 | then x 5 | else plus (succ x) (pred y) 6 | 7 | val curried_add = fn x => 8 | fn y => plus x y 9 | in 10 | curried_add 11 | -------------------------------------------------------------------------------- /compiler/tests/even_odd.luca: -------------------------------------------------------------------------------- 1 | let 2 | val even = fn n => 3 | if zero? n 4 | then true 5 | else odd (pred n) 6 | 7 | val odd = fn n => 8 | if zero? n 9 | then false 10 | else even (pred n) 11 | in 12 | (even, odd) 13 | -------------------------------------------------------------------------------- /compiler/tests/exists.luca: -------------------------------------------------------------------------------- 1 | let 2 | val exists? = fn f xs => 3 | if nil? xs 4 | then false 5 | else if f (hd xs) 6 | then true 7 | else exists? f (tl xs) 8 | in 9 | exists? 10 | -------------------------------------------------------------------------------- /compiler/tests/flatten.luca: -------------------------------------------------------------------------------- 1 | let 2 | val rev' = fn xs acc => 3 | if nil? xs 4 | then acc 5 | else rev' (tl xs) (cons (hd xs) acc) 6 | 7 | val rev = fn xs => 8 | rev' xs [] 9 | 10 | val concat = fn xs ys => 11 | if nil? ys 12 | then xs 13 | else concat (rev (cons (hd ys) (rev xs))) (tl ys) 14 | 15 | val flatten = fn xss => 16 | if nil? xss 17 | then [] 18 | else concat (hd xss) (flatten (tl xss)) 19 | in 20 | flatten 21 | -------------------------------------------------------------------------------- /compiler/tests/foldl.luca: -------------------------------------------------------------------------------- 1 | let 2 | val foldl = fn f init xs => 3 | if nil? xs 4 | then init 5 | else foldl f (f (hd xs) init) (tl xs) 6 | in 7 | foldl 8 | -------------------------------------------------------------------------------- /compiler/tests/foldr.luca: -------------------------------------------------------------------------------- 1 | let 2 | val foldr = fn f init xs => 3 | if nil? xs 4 | then init 5 | else f (hd xs) (foldr f init (tl xs)) 6 | in 7 | foldr 8 | -------------------------------------------------------------------------------- /compiler/tests/identity.luca: -------------------------------------------------------------------------------- 1 | let 2 | val id = fn x => x 3 | in 4 | id 5 | -------------------------------------------------------------------------------- /compiler/tests/left_case.luca: -------------------------------------------------------------------------------- 1 | case (Left 5) 2 | of Left x => fn _ => 6 3 | | Right _ => fn _ => 4 4 | -------------------------------------------------------------------------------- /compiler/tests/length.luca: -------------------------------------------------------------------------------- 1 | let 2 | val length = fn xs => 3 | if nil? xs 4 | then 0 5 | else succ (length (tl xs)) 6 | in 7 | length 8 | -------------------------------------------------------------------------------- /compiler/tests/map.luca: -------------------------------------------------------------------------------- 1 | let 2 | val map: ('a -> 'b) -> 'a list -> 'b list = fn f xs => 3 | if nil? xs 4 | then [] 5 | else cons (f (hd xs)) (map f (tl xs)) 6 | in 7 | map 8 | -------------------------------------------------------------------------------- /compiler/ty.sml: -------------------------------------------------------------------------------- 1 | structure Ty: sig 2 | 3 | datatype ty 4 | = Unit 5 | | Bool 6 | | Int 7 | | List of ty 8 | | Pair of ty * ty 9 | | Option of ty 10 | | Fun of ty * ty 11 | | TyVar of string 12 | 13 | val unty: ty -> string 14 | 15 | val resetTyVars: unit -> unit 16 | val freshTyVar: unit -> ty 17 | val freshPolishedTyVar: unit -> ty 18 | 19 | end = struct 20 | 21 | (* type declarations *) 22 | datatype ty 23 | = Unit 24 | | Bool 25 | | Int 26 | | List of ty 27 | | Pair of ty * ty 28 | | Option of ty 29 | | Fun of ty * ty 30 | | TyVar of string 31 | 32 | local open Utils in 33 | fun nest (ty as (Pair (ty1, ty2) | Fun (ty1, ty2))) = 34 | paren (unty ty) 35 | | nest ty = unty ty 36 | 37 | and unty Unit = "unit" 38 | | unty Bool = "bool" 39 | | unty Int = "int" 40 | | unty (List ty) = spc [(nest ty), "list"] 41 | | unty (Pair (ty1, ty2)) = (spc o between (map nest [ty1, ty2])) "*" 42 | | unty (Option ty) = spc [(nest ty), "option"] 43 | | unty (Fun (arg, res)) = (spc o between (map nest [arg, res])) "->" 44 | | unty (TyVar v) = v 45 | end 46 | 47 | 48 | (* type variable utilities *) 49 | val counter = ref 1 50 | val polishedCounter = ref [0] 51 | 52 | fun incrementPolished ns = 53 | if List.all (fn n => n = 25) ns 54 | then List.tabulate ((length ns) + 1, (fn _ => 0)) 55 | else let 56 | val (rsuffix, rprefix) = Utils.takeWhile (fn n => n = 25) (rev ns) 57 | val newPrefix = rev (((hd rprefix) + 1) :: (tl rprefix)) 58 | in 59 | newPrefix @ (rev rsuffix) 60 | end 61 | 62 | fun resetTyVars () = 63 | (counter := 0; polishedCounter := [0]) 64 | 65 | fun freshTyVar () = 66 | let 67 | val v = "@" ^ (Int.toString (!counter)) 68 | val _ = counter := (!counter) + 1 69 | in 70 | TyVar v 71 | end 72 | 73 | fun freshPolishedTyVar () = 74 | let 75 | val v = implode (#"'" :: (map (fn n => Char.chr (n + (Char.ord #"a"))) (!polishedCounter))) 76 | val _ = polishedCounter := incrementPolished (!polishedCounter) 77 | in 78 | TyVar v 79 | end 80 | 81 | end 82 | -------------------------------------------------------------------------------- /compiler/tyenv.sml: -------------------------------------------------------------------------------- 1 | structure TyEnv: sig 2 | 3 | type tyenv = (string * Ty.ty) list 4 | 5 | val empty: tyenv 6 | val lookup: tyenv -> string -> Ty.ty Attempt.attempt 7 | val <+> : tyenv * (string * Ty.ty) -> tyenv 8 | 9 | end = struct 10 | 11 | open Attempt 12 | 13 | open AttemptMonad 14 | structure AttemptMonadUtil = MonadUtil(AttemptMonad) 15 | open AttemptMonadUtil 16 | infixr 0 $ 17 | infix 1 >>= >> 18 | infixr 1 =<< >=> <=< 19 | infix 4 <$> <*> 20 | 21 | open Ty 22 | 23 | infix \/ 24 | fun f1 \/ f2 = fn x => 25 | case (f1 x) 26 | of Success x' => Success x' 27 | | Failure _ => (f2 x) 28 | 29 | type tyenv = (string * Ty.ty) list 30 | 31 | val empty = [] 32 | 33 | fun basis "succ" = Success (Fun (Int, Int)) 34 | | basis "pred" = Success (Fun (Int, Int)) 35 | | basis "zero?" = Success (Fun (Int, Bool)) 36 | | basis "cons" = let val alpha = freshTyVar () in 37 | Success (Fun (alpha, Fun (List alpha, List alpha))) 38 | end 39 | | basis "hd" = let val alpha = freshTyVar () in 40 | Success (Fun (List alpha, alpha)) 41 | end 42 | | basis "tl" = let val alpha = freshTyVar () in 43 | Success (Fun (List alpha, List alpha)) 44 | end 45 | | basis "nil?" = let val alpha = freshTyVar () in 46 | Success (Fun (List alpha, Bool)) 47 | end 48 | | basis "fst" = let val alpha = freshTyVar () val beta = freshTyVar () in 49 | Success (Fun (Pair (alpha, beta), alpha)) 50 | end 51 | | basis "snd" = let val alpha = freshTyVar () val beta = freshTyVar () in 52 | Success (Fun (Pair (alpha, beta), beta)) 53 | end 54 | | basis "plus" = Success (Fun (Int, Fun (Int, Int))) 55 | | basis "minus" = Success (Fun (Int, Fun (Int, Int))) 56 | | basis "times" = Success (Fun (Int, Fun (Int, Int))) 57 | | basis "and" = Success (Fun (Bool, Fun (Bool, Bool))) 58 | | basis "or" = Success (Fun (Bool, Fun (Bool, Bool))) 59 | | basis "not" = Success (Fun (Bool, Bool)) 60 | | basis f = Failure ("no such basis function: " ^ f) 61 | 62 | fun binding [] x = Failure ("identifier " ^ x ^ " not bound") 63 | | binding ((y, ty) :: gs) x = 64 | if x = y 65 | then Success ty 66 | else binding gs x 67 | 68 | fun lookup env x = (basis \/ (binding env)) x 69 | 70 | infix <+> 71 | fun g <+> (x, ty) = (x, ty) :: g 72 | 73 | end 74 | -------------------------------------------------------------------------------- /compiler/tyexpr.sml: -------------------------------------------------------------------------------- 1 | structure TyExpr: sig 2 | 3 | val tyExpr: Scan.token -> Scan.token list -> (Ty.ty * Scan.token list) Attempt.attempt 4 | 5 | end = struct 6 | 7 | open Attempt 8 | 9 | open ParseMonad 10 | structure ParseMonadUtil = MonadUtil(ParseMonad) 11 | open ParseMonadUtil 12 | infixr 0 $ 13 | infix 1 >>= >> 14 | infixr 1 =<< >=> <=< 15 | infix 4 <$> <*> 16 | 17 | datatype opers 18 | = Fun 19 | | Pair 20 | | List 21 | | Option 22 | | LParen 23 | 24 | datatype associativity = Left | Right 25 | 26 | fun isUnary List = true 27 | | isUnary Option = true 28 | | isUnary _ = false 29 | 30 | fun precedence Fun = 2 31 | | precedence Pair = 1 32 | | precedence _ = raise Fail "tried to take precedence of non-binary operator" 33 | 34 | fun associativity Fun = Right 35 | | associativity Pair = Right 36 | | associativity _ = raise Fail "tried to take associativity of non-binary operator" 37 | 38 | (* type expressions *) 39 | fun popFromOpers input (Fun :: ops) (x2 :: x1 :: out) = 40 | shunt input ops ((Ty.Fun (x1, x2)) :: out) 41 | | popFromOpers input (Pair :: ops) (x2 :: x1 :: out) = 42 | shunt input ops ((Ty.Pair (x1, x2)) :: out) 43 | | popFromOpers input (List :: ops) (x :: out) = 44 | shunt input ops ((Ty.List x) :: out) 45 | | popFromOpers input (Option :: ops) (x :: out) = 46 | shunt input ops ((Ty.Option x) :: out) 47 | 48 | | popFromOpers _ _ _ = 49 | Failure "something wasn't right with the operator stack" 50 | 51 | (* "number"s *) 52 | and shunt ((Scan.Identifier "unit") :: ts) ops out = 53 | shunt ts ops (Ty.Unit :: out) 54 | | shunt ((Scan.Identifier "bool") :: ts) ops out = 55 | shunt ts ops (Ty.Bool :: out) 56 | | shunt ((Scan.Identifier "int") :: ts) ops out = 57 | shunt ts ops (Ty.Int :: out) 58 | 59 | (* "function"s *) 60 | | shunt ((Scan.Identifier "list") :: ts) ops out = 61 | shunt ts (List :: ops) out 62 | | shunt ((Scan.Identifier "option") :: ts) ops out = 63 | shunt ts (Option :: ops) out 64 | 65 | (* operators *) 66 | | shunt ((operToken as (Scan.ThinArrow | Scan.Asterisk | Scan.Pipe)) :: ts) [] out = 67 | let 68 | val oper = case operToken 69 | of Scan.ThinArrow => Fun 70 | | Scan.Asterisk => Pair 71 | | _ => raise Fail "something really horrible must have happened here" 72 | in 73 | shunt ts [oper] out 74 | end 75 | | shunt ((operToken as (Scan.ThinArrow | Scan.Asterisk | Scan.Pipe)) :: ts) (top :: ops) out = 76 | let 77 | val oper = case operToken 78 | of Scan.ThinArrow => Fun 79 | | Scan.Asterisk => Pair 80 | | _ => raise Fail "something really horrible must have happened here" 81 | in 82 | if ( 83 | (top <> LParen) 84 | andalso 85 | ((isUnary top) 86 | orelse ((precedence top) > (precedence oper)) 87 | orelse (((precedence top) = (precedence oper)) andalso ((associativity top) = Left)))) 88 | then 89 | popFromOpers (operToken :: ts) (top :: ops) out 90 | else 91 | shunt ts (oper :: top :: ops) out 92 | end 93 | 94 | (* parens *) 95 | | shunt (Scan.LParen :: ts) ops out = 96 | shunt ts (LParen :: ops) out 97 | 98 | | shunt (Scan.RParen :: ts) (LParen :: ops) out = 99 | shunt ts ops out 100 | | shunt (Scan.RParen :: ts) ops out = 101 | popFromOpers (Scan.RParen :: ts) ops out 102 | 103 | (* need to match tyvars last *) 104 | | shunt ((Scan.Identifier x) :: ts) ops out = 105 | shunt ts ops ((Ty.TyVar x) :: out) 106 | 107 | | shunt _ [] [] = Failure ( 108 | "parse error: nothing on output queue at end of shunt") 109 | | shunt _ [] (ast :: []) = Success ast 110 | | shunt _ [] (_ :: _) = Failure ( 111 | "parse error: more than one term on output stack at end of shunt\n") 112 | | shunt _ ops out = popFromOpers [] ops out 113 | 114 | fun tyExpr terminator ts = 115 | let 116 | val (ts', rest) = Utils.takeWhile (fn t => t <> terminator) ts 117 | in 118 | case (shunt ts' [] []) 119 | of Success ast => Success (ast, rest) 120 | | Failure m => Failure m 121 | end 122 | 123 | end 124 | -------------------------------------------------------------------------------- /compiler/tyscheme.sml: -------------------------------------------------------------------------------- 1 | structure TyScheme: sig 2 | 3 | type tyScheme = {sigmas: string list, tau: Ty.ty} 4 | 5 | val generalize: Ty.ty -> tyScheme 6 | 7 | val instantiate: tyScheme -> Ty.ty 8 | 9 | val untyScheme: tyScheme -> string 10 | 11 | end = struct 12 | 13 | type tyScheme = {sigmas: string list, tau: Ty.ty} 14 | 15 | local open Ty in 16 | fun freeVars' (Unit | Bool | Int) = [] 17 | | freeVars' (List ty) = freeVars' ty 18 | | freeVars' (Pair (ty1, ty2)) = (freeVars' ty1) @ (freeVars' ty2) 19 | | freeVars' (Option ty) = freeVars' ty 20 | | freeVars' (Fun (ty1, ty2)) = (freeVars' ty1) @ (freeVars' ty2) 21 | | freeVars' (TyVar a) = [a] 22 | end 23 | fun dedup [] = [] 24 | | dedup (x :: xs) = 25 | if List.exists (fn x' => x = x') xs 26 | then dedup xs 27 | else x :: dedup xs 28 | val freeVars = dedup o freeVars' 29 | 30 | fun generalize ty = 31 | {sigmas = freeVars ty, tau = ty} 32 | 33 | fun instantiate {sigmas = sigmas, tau = ty} = 34 | foldl (fn (a, inner) => Unify.subst (Ty.freshTyVar ()) a inner) ty sigmas 35 | 36 | local open Utils in 37 | fun untyScheme {sigmas = sigmas, tau = ty} = 38 | cat ( 39 | (map (fn a => cat ["\\/", a, "."]) sigmas) @ 40 | [Ty.unty ty] 41 | ) 42 | end 43 | 44 | end 45 | -------------------------------------------------------------------------------- /compiler/unify.sml: -------------------------------------------------------------------------------- 1 | structure Unify: sig 2 | 3 | type substitution = (string * Ty.ty) list 4 | 5 | val occurs: string -> Ty.ty -> bool 6 | val subst: Ty.ty -> string -> Ty.ty -> Ty.ty 7 | val unify: (Ty.ty * Ty.ty) list -> substitution Attempt.attempt 8 | val apply: substitution -> Ty.ty -> Ty.ty 9 | 10 | end = struct 11 | 12 | open Attempt 13 | 14 | open AttemptMonad 15 | structure AttemptMonadUtil = MonadUtil(AttemptMonad) 16 | open AttemptMonadUtil 17 | infixr 0 $ 18 | infix 1 >>= >> 19 | infixr 1 =<< >=> <=< 20 | infix 4 <$> <*> 21 | 22 | type substitution = (string * Ty.ty) list 23 | 24 | open Ty 25 | 26 | fun occurs _ (Unit | Bool | Int) = false 27 | | occurs x (List ty) = occurs x ty 28 | | occurs x (Pair (ty1, ty2)) = occurs x ty1 orelse occurs x ty2 29 | | occurs x (Option ty) = occurs x ty 30 | | occurs x (Fun (arg, ret)) = occurs x arg orelse occurs x ret 31 | | occurs x (TyVar y) = x = y 32 | 33 | (* subst s for x in t *) 34 | fun subst _ _ (x as (Unit | Bool | Int)) = x 35 | | subst s x (List ty) = List (subst s x ty) 36 | | subst s x (Pair (ty1, ty2)) = Pair (subst s x ty1, subst s x ty2) 37 | | subst s x (Option ty) = Option (subst s x ty) 38 | | subst s x (Fun (arg, ret)) = Fun (subst s x arg, subst s x ret) 39 | | subst s x (TyVar y) = 40 | if x = y 41 | then s 42 | else TyVar y 43 | 44 | fun apply s t = foldr (fn ((x, t'), e) => subst t' x e) t s 45 | 46 | fun unifyIfNotOccurs x ty = 47 | if occurs x ty 48 | then Failure ("Cannot unify " ^ x ^ " with " ^ (unty ty)) 49 | else Success [(x, ty)] 50 | 51 | fun unify' Unit Unit = pure [] 52 | | unify' Unit (TyVar x) = pure [(x, Unit)] 53 | | unify' (TyVar x) Unit = pure [(x, Unit)] 54 | 55 | | unify' Bool Bool = pure [] 56 | | unify' Bool (TyVar x) = pure [(x, Bool)] 57 | | unify' (TyVar x) Bool = pure [(x, Bool)] 58 | 59 | | unify' Int Int = pure [] 60 | | unify' Int (TyVar x) = pure [(x, Int)] 61 | | unify' (TyVar x) Int = pure [(x, Int)] 62 | 63 | | unify' (List ty1) (List ty2) = unify' ty1 ty2 64 | 65 | | unify' (Pair (ty1, ty2)) (Pair (ty1', ty2')) = 66 | unify [(ty1, ty1'), (ty2, ty2')] 67 | 68 | | unify' (Option ty1) (Option ty2) = unify' ty1 ty2 69 | 70 | | unify' (Fun (arg1, ret1)) (Fun (arg2, ret2)) = 71 | unify [(arg1, arg2), (ret1, ret2)] 72 | 73 | | unify' (TyVar x) (TyVar y) = 74 | if x = y 75 | then pure [] 76 | else pure [(y, TyVar x)] 77 | | unify' ty (TyVar x) = unifyIfNotOccurs x ty 78 | | unify' (TyVar x) ty = unifyIfNotOccurs x ty 79 | 80 | | unify' x y = Failure ("cannot unify " ^ (unty x) ^ " with " ^ (unty y)) 81 | 82 | and unify [] = pure [] 83 | | unify ((x, y) :: t) = 84 | unify t >>= (fn t2 => 85 | unify' (apply t2 x) (apply t2 y) >>= (fn t1 => 86 | pure (t1 @ t2))) 87 | 88 | end 89 | -------------------------------------------------------------------------------- /compiler/utils.sml: -------------------------------------------------------------------------------- 1 | structure Utils: sig 2 | 3 | (* print the string, then a newline *) 4 | val println: string -> unit 5 | 6 | (* take items from list as long as items pass the test *) 7 | val takeWhile: ('a -> bool) -> 'a list -> 'a list * 'a list 8 | 9 | (* split a list at a given length, returning both sides of the split *) 10 | val splitAt: 'a list -> int -> ('a list * 'a list) 11 | 12 | (* take as many as n items from the list *) 13 | val upto: int -> 'a list -> 'a list 14 | 15 | val err: string -> string -> 'a 16 | 17 | val andmap: ('a -> bool) -> 'a list -> bool 18 | val ormap: ('a -> bool) -> 'a list -> bool 19 | val zipEq: 'a list -> 'b list -> ('a * 'b) list 20 | 21 | (* un-X helpers *) 22 | val spc: string list -> string 23 | val cat: string list -> string 24 | val paren: string -> string 25 | val brc: string -> string 26 | val between: string list -> string -> string list 27 | 28 | end = struct 29 | 30 | fun println s = (TextIO.print s; TextIO.print "\n") 31 | 32 | fun takeWhile f xs = 33 | let 34 | fun lp ([], acc) = (rev acc, []) 35 | | lp (list as x::xs, acc) = 36 | if f x 37 | then lp (xs, x::acc) 38 | else (rev acc, list) 39 | in 40 | lp (xs, []) 41 | end 42 | 43 | fun upto _ [] = [] 44 | | upto n (x::xs) = 45 | if n <= 0 46 | then [] 47 | else x::(upto (n - 1) xs) 48 | 49 | fun splitAt [] _ = ([], []) 50 | | splitAt xs 0 = ([], xs) 51 | | splitAt (x :: xs) n = 52 | let 53 | val (l, r) = splitAt xs (n - 1) 54 | in 55 | (x :: l, r) 56 | end 57 | 58 | fun err kind msg = 59 | raise Fail (kind ^ " error: " ^ msg) 60 | 61 | fun spc [] = "" 62 | | spc [t] = t 63 | | spc (t :: ts) = t ^ " " ^ (spc ts) 64 | 65 | fun cat [] = "" 66 | | cat (t :: ts) = t ^ (cat ts) 67 | 68 | fun paren x = "(" ^ x ^ ")" 69 | 70 | fun brc x = "[" ^ x ^ "]" 71 | 72 | fun between [] _ = [] 73 | | between [x] _ = [x] 74 | | between (x :: xs) b = [x, b] @ (between xs b) 75 | 76 | fun andmap _ [] = true 77 | | andmap f (x :: xs) = (f x) andalso (andmap f xs) 78 | 79 | fun ormap _ [] = false 80 | | ormap f (x :: xs) = (f x) orelse (ormap f xs) 81 | 82 | fun zipEq [] [] = [] 83 | | zipEq _ [] = raise Fail "cannot zipEq lists of different lengths" 84 | | zipEq [] _ = raise Fail "cannot zipEq lists of different lengths" 85 | | zipEq (x :: xs) (y :: ys) = (x, y) :: zipEq xs ys 86 | 87 | end 88 | -------------------------------------------------------------------------------- /paper.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mpcsh/ForML/f4b65d5410e827c19694196ee18ae5636d8dba7a/paper.pdf -------------------------------------------------------------------------------- /presentation.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mpcsh/ForML/f4b65d5410e827c19694196ee18ae5636d8dba7a/presentation.pdf --------------------------------------------------------------------------------