hmx-multi.opp.exp 7.63 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114
File "hmx-multi.mly", line 115, characters 7-12:
Warning: the token MATCH is unused.
%{

open Multi.Hm
open Multi.Primitives

let app e1 e2 =
  App(e1, e2)

let prim p =
  PrimApp (p, [])

let primapp p e =
  PrimApp (p, [e])

let primapp2 p e1 e2 =
  PrimApp (p, [e1; e2])

let sequence e1 e2 =
  Let ("-", primapp PrimEnsureUnit e1, e2)

(* A pattern is either a variable or the unit constant. A wildcard pattern is viewed as a variable "-", which cannot
   be named inside expressions, because the lexer will not view it as an identifier. *)

type pattern =
  | PVariable of string
  | PUnit

let rec make_fun patterns expr =
  match patterns with
  | [] ->
      expr
  | (PVariable x) :: patterns ->
      Lambda (x, make_fun patterns expr)
  | PUnit :: patterns ->
      Lambda ("-", sequence (Var "-") (make_fun patterns expr))

let rec make_let (pattern, body) =
  match pattern with
  | PVariable x ->
      x, body
  | PUnit ->
      "-", primapp PrimEnsureUnit body

let rec make_extension base = function
  | [] ->
      base
  | (mutflag, label, expr) :: rest ->
      primapp2
	(if mutflag then PrimExtendMutable label else PrimExtend label)
	(make_extension base rest) expr

let rec make_restriction base = function
  | [] ->
      base
  | label :: rest ->
      primapp (PrimRestrict label) (make_restriction base rest)

type case_pattern =
  | CaseOne of string
  | CaseAll

let rec make_case subject = function
  | [] ->
      prim PrimCaseNone
  | (CaseOne tag, e) :: rest ->
      
      (* For convenience, we have made PrimCaseOne a binary primitive operation. This allows avoiding unnecessary
	 $\eta$-expansions.

	 Note that our current encoding of ``case'' constructs into $\lambda$-abstractions and applications of
	 primitives is not satisfactory, because it forces all such constructs to have monomorphic type. *)

      primapp2 (PrimCaseOne tag) (make_fun [subject] e) (make_case subject rest)
  | (CaseAll, e) :: rest ->
      if rest <> [] then
	Printf.eprintf "Warning: unused `case' clauses.\n";
      make_fun [subject] e

%}
%start phrase
%token UNIT
%token UNDERSCORE
%token <string> UIDENT
%token SETMINUS
%token SEMISEMI
%token SEMI
%token RPAREN
%token REC
%token RBRACE
%token OF
%token MUTABLE
%token MATCH
%token LPAREN
%token <string> LIDENT
%token LET
%token LEFTARROW
%token LBRACE
%token <int> INT
%token IN
%token FUN
%token EQUAL
%token END
%token DOT
%token CHOOSE
%token CASE
%token BAR
%token ARROW

%type <Multi.Hm.phrase> phrase
%%

phrase:
115 116 117 118 119 120 121
| _1 = expression _2 = SEMISEMI
    {                                                                ( "-", _1 )}
| _1 = LET _2 = pattern _3 = pattern_list _4 = EQUAL _5 = expression _6 = SEMISEMI
    {                                                                ( make_let (_2, make_fun _3 _5) )}
| _1 = LET _2 = REC _3 = LIDENT _4 = pattern_list _5 = EQUAL _6 = expression _7 = SEMISEMI
    {                                                                ( let ff = Lambda (_3, make_fun _4 _6) in
                                                                  _3, primapp PrimFix ff )}
122 123

expression:
124 125 126 127 128 129 130 131 132 133
| _1 = expression2
    {                            ( _1 )}
| _1 = FUN _2 = pattern_list _3 = ARROW _4 = expression
    {                                         ( make_fun _2 _4 )}
| _1 = LET _2 = pattern _3 = pattern_list _4 = EQUAL _5 = expression _6 = IN _7 = expression
    {                                                                ( let name, body = make_let (_2, make_fun _3 _5) in
                                                                  Let (name, body, _7) )}
| _1 = LET _2 = REC _3 = LIDENT _4 = pattern_list _5 = EQUAL _6 = expression _7 = IN _8 = expression
    {                                                                ( let ff = Lambda (_3, make_fun _4 _6) in
                                                                  Let (_3, primapp PrimFix ff, _8) )}
134 135

expression2:
136 137 138 139
| _1 = expression1
    {                      ( _1 )}
| _1 = expression1 _2 = SEMI _3 = expression
    {                                    ( sequence _1 _3 )}
140 141

expression1:
142 143 144 145 146 147
| _1 = expression0
    {                             ( _1 )}
| _1 = expression1 _2 = expression0
    {                                                ( app _1 _2 )}
| _1 = CHOOSE _2 = expression0 _3 = expression0
    {                                                                ( primapp2 PrimChoice _2 _3 )}
148 149

expression0:
150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173
| _1 = LIDENT
    {                         ( Var _1 )}
| _1 = UIDENT
    {                         ( prim (PrimConstructor _1) )}
| _1 = UNIT
    {                      ( prim PrimUnit )}
| _1 = INT
    {                                                                ( prim (PrimInt _1) )}
| _1 = LPAREN _2 = expression _3 = RPAREN
    {                                              ( _2 )}
| _1 = expression0 _2 = LBRACE _3 = field_expr_list _4 = RBRACE
    {                                                              ( make_extension _1 _3 )}
| _1 = expression0 _2 = DOT _3 = LIDENT
    {                                              ( primapp (PrimAccess _3) _1 )}
| _1 = expression0 _2 = SETMINUS _3 = LIDENT
    {                                                                ( primapp (PrimRestrict _3) _1 )}
| _1 = expression0 _2 = SETMINUS _3 = LBRACE _4 = field_list _5 = RBRACE
    {                                                                ( make_restriction _1 _4 )}
| _1 = expression0 _2 = DOT _3 = LIDENT _4 = LEFTARROW _5 = expression1
    {                                                                ( primapp2 (PrimMutate _3) _1 _5 )}
| _1 = CASE _2 = LIDENT _3 = OF _4 = case_list _5 = END
    {                                                                ( app (make_case (PVariable _2) _4) (Var _2) )}
| _1 = CASE _2 = pattern _3 = EQUAL _4 = expression _5 = OF _6 = case_list _7 = END
    {                                                                ( app (make_case _2 _6) _4 )}
174 175 176

field_expr_list:
| 
177 178 179 180 181
    {                              ( [] )}
| _1 = field_expr
    {                                                                ( [_1] )}
| _1 = field_expr _2 = SEMI _3 = field_expr_list
    {                                                          ( _1 :: _3 )}
182 183

field_expr:
184 185 186 187
| _1 = LIDENT _2 = EQUAL _3 = expression1
    {                                                                ( false, _1, _3 )}
| _1 = MUTABLE _2 = LIDENT _3 = EQUAL _4 = expression1
    {                                                                ( true, _2, _4 )}
188 189 190

field_list:
| 
191 192 193 194 195
    {                              ( [] )}
| _1 = LIDENT
    {                                      ( [_1] )}
| _1 = LIDENT _2 = SEMI _3 = field_list
    {                                                          ( _1 :: _3 )}
196 197 198

pattern_list:
| 
199 200 201
    {                              ( [] )}
| _1 = pattern _2 = pattern_list
    {                                                     ( _1 :: _2 )}
202 203

pattern:
204 205 206 207 208 209
| _1 = LIDENT
    {                                                                ( PVariable _1 )}
| _1 = UNDERSCORE
    {                                                                ( PVariable "-" )}
| _1 = UNIT
    {                                                                ( PUnit )}
210 211 212

case_list:
| 
213 214 215
    {                                                                ( [] )}
| _1 = case_entry _2 = case_list
    {                                                                ( _1 :: _2 )}
216 217

case_entry:
218 219
| _1 = BAR _2 = case_pattern _3 = ARROW _4 = expression
    {                                                                ( _2, _4 )}
220 221

case_pattern:
222 223 224 225
| _1 = UIDENT
    {                                                                ( CaseOne _1 )}
| _1 = UNDERSCORE
    {                                                                ( CaseAll )}
226 227 228 229 230

%%