5.27. Pattern matching utilities

Start ocaml section to src/flx_pat.mli[1 /1 ]
     1: # 4 "./lpsrc/flx_pat.ipk"
     2: open Flx_ast
     3: 
     4: val validate_patterns:
     5:   pattern_t list -> unit
     6: 
     7: val is_universal:
     8:   pattern_t -> bool
     9: 
End ocaml section to src/flx_pat.mli[1]
Start ocaml section to src/flx_pat.ml[1 /1 ]
     1: # 14 "./lpsrc/flx_pat.ipk"
     2: open Flx_util
     3: open Flx_ast
     4: open Flx_print
     5: open Flx_typing
     6: open List
     7: open Flx_srcref
     8: open Flx_exceptions
     9: 
    10: (* These routine just check that the shape of a list
    11:   of patterns match the pattern class indicated by their names.
    12: 
    13:   These routines are used for class based desugaring.
    14:   Note that type correctness isn't checked, since
    15:   type binding isn't done yet.
    16: *)
    17: 
    18: let rec check_match_int pats =
    19:   let rec check pat = match pat with
    20:   | `PAT_any _
    21:   | `PAT_int _
    22:   | `PAT_int_range _
    23:   | `PAT_name _ -> ()
    24: 
    25:   | `PAT_coercion (_,pat,_)
    26:   | `PAT_as (_,pat,_)
    27:   | `PAT_when (_,pat,_) -> check pat
    28:   | _ ->
    29:     let sr = src_of_pat pat in clierr sr
    30:     (
    31:       "Integer pattern expected"
    32:     )
    33:   in
    34:   List.iter check pats
    35: 
    36: and check_match_string pats =
    37:   let rec check pat = match pat with
    38:   | `PAT_any _
    39:   | `PAT_string _
    40:   | `PAT_string_range _
    41:   | `PAT_regexp _
    42:   | `PAT_name _ -> ()
    43: 
    44:   | `PAT_coercion (_,pat,_)
    45:   | `PAT_as (_,pat,_)
    46:   | `PAT_when (_,pat,_) -> check pat
    47:   | _ ->
    48:     let sr = src_of_pat pat in clierr sr
    49:     (
    50:       "String pattern expected"
    51:     )
    52:   in
    53:   List.iter check pats
    54: 
    55: and check_match_float pats =
    56:   let rec check pat = match pat with
    57:   | `PAT_none _ -> assert false
    58:   | `PAT_nan _
    59:   | `PAT_any _
    60:   | `PAT_float_range _
    61:   | `PAT_name _ -> ()
    62:   | `PAT_coercion (_,pat,_)
    63:   | `PAT_as (_,pat,_)
    64:   | `PAT_when (_,pat,_) -> check pat
    65:   | _ ->
    66:     let sr = src_of_pat pat in clierr sr
    67:     (
    68:      "Float pattern expected"
    69:     )
    70:   in
    71:   List.iter check pats
    72: 
    73: and check_match_record pats =
    74:   let rec check pat = match pat with
    75:   | `PAT_record _
    76:   | `PAT_any _
    77:   | `PAT_name _ -> ()
    78: 
    79:   | `PAT_as (_,pat,_)
    80:   | `PAT_coercion (_,pat,_)
    81:   | `PAT_when (_,pat,_) -> check pat
    82:   | _ ->
    83:     let sr = src_of_pat pat in clierr sr
    84:     "Record pattern expected"
    85:   in
    86:   List.iter check pats
    87: 
    88: and check_match_tuple n pats =
    89:   let rec check n pat = match pat with
    90:   | `PAT_any _
    91:   | `PAT_name _ -> ()
    92:   | `PAT_tuple (sr,pats) ->
    93:     if List.length pats <> n
    94:     then let sr = src_of_pat pat in clierr sr
    95:       (
    96:         "Tuple pattern wrong length"
    97:       )
    98:   | `PAT_coercion (_,pat,_)
    99:   | `PAT_as (_,pat,_)
   100:   | `PAT_when (_,pat,_) -> check n pat
   101:   | _ ->
   102:     let sr = src_of_pat pat in clierr sr
   103:     (
   104:       "Tuple pattern expected"
   105:     )
   106:   in
   107:   List.iter (check n) pats
   108:   ;
   109:   let rec match_split pat = match pat with
   110:   | `PAT_any _ -> []
   111:   | `PAT_name _ -> []
   112: 
   113:   | `PAT_coercion (_,pat,_)
   114:   | `PAT_as (_,pat,_)
   115:   | `PAT_when (_,pat,_) -> match_split pat
   116: 
   117:   | `PAT_tuple (_,ps) -> ps
   118:   | _ ->
   119:     let sr = src_of_pat pat in clierr sr
   120:     (
   121:       "Tuple pattern expected"
   122:     )
   123:   in let tpats =
   124:     try
   125:       Flx_util.transpose
   126:       (
   127:         List.filter
   128:         (function | [] -> false | _ -> true)
   129:         (List.map match_split pats)
   130:       )
   131:     with _ -> failwith "Transpose failed"
   132:   in
   133:   List.iter
   134:   (fun pats ->
   135:     if List.length pats = 0
   136:     then failwith "Null list?"
   137:     else find_match_type (List.hd pats) pats
   138:   )
   139:   tpats
   140: 
   141: and check_match_union pats =
   142:   let rec check pat = match pat with
   143:   | `PAT_any  _
   144:   | `PAT_nonconst_ctor _
   145:   | `PAT_const_ctor _
   146:   | `PAT_name _ -> ()
   147: 
   148:   | `PAT_coercion (_,pat,_)
   149:   | `PAT_as (_,pat,_)
   150:   | `PAT_when (_,pat,_) -> check pat
   151:   | _ ->
   152:     let sr = src_of_pat pat in clierr sr
   153:     (
   154:       short_string_of_src (src_of_pat pat) ^
   155:       ": union pattern expected"
   156:     )
   157:   in
   158:   List.iter check pats
   159: 
   160: and renaming pats = ()
   161: 
   162: (* This routine finds the checker routine for given
   163:    pattern. Note that 'renaming' checks nothing:
   164:    if this kind is the head of a match list,
   165:    the following matches will never be executed.
   166:    [They should be checked for correctness anyhow ..
   167:     but instead, we consider this an error temporarily
   168:    ]
   169: *)
   170: and find_match_type pat = match pat with
   171:   | `PAT_none _ -> assert false
   172:   | `PAT_nan _ -> check_match_float
   173:   | `PAT_int _ -> check_match_int
   174:   | `PAT_string _ -> check_match_string
   175: 
   176:   (* ranges *)
   177:   | `PAT_int_range _ -> check_match_int
   178:   | `PAT_string_range _ -> check_match_string
   179:   | `PAT_float_range _ -> check_match_float
   180: 
   181:   (* other *)
   182:   | `PAT_name _ -> renaming
   183:   | `PAT_tuple (_,pats) -> check_match_tuple (List.length pats)
   184:   | `PAT_any _ -> renaming
   185:   | `PAT_regexp _ -> check_match_string
   186:   | `PAT_const_ctor _ -> check_match_union
   187:   | `PAT_nonconst_ctor _ -> check_match_union
   188:   | `PAT_record (_,_) -> check_match_record
   189: 
   190:   | `PAT_as (_,pat,_)
   191:   | `PAT_when (_,pat,_)
   192:   | `PAT_coercion (_,pat,_) -> find_match_type pat
   193: 
   194: (* This routine is used to check all but the last
   195:    pattern match isn't a match all
   196: *)
   197: 
   198: let rec is_universal pat = match pat with
   199:   | `PAT_any _
   200:   | `PAT_name (_,_)
   201:   | `PAT_float_range (_, Float_minus_inf, Float_inf)
   202:     -> true
   203: 
   204:   | `PAT_as (_,pat,_) -> is_universal pat
   205:   | `PAT_coercion (_,pat,_) -> is_universal pat
   206:   | `PAT_tuple (_,ps) -> fold_left (fun a p -> a && is_universal p) true ps
   207: 
   208:   | _ -> false
   209: 
   210: let rec check_terminal pat = match pat with
   211:   | `PAT_any sr ->
   212:     failwith
   213:     (
   214:       "'Any' pattern '_' must be last in match in " ^
   215:       short_string_of_src sr
   216:     )
   217:   | `PAT_name (sr,x) ->
   218:     failwith
   219:     (
   220:       "'Name' pattern '"^x^"' must be last in match in " ^
   221:       short_string_of_src sr
   222:     )
   223:   | `PAT_float_range (sr, Float_minus_inf, Float_inf) ->
   224:     failwith
   225:     (
   226:       "Whole floating range must be last in match in " ^
   227:       short_string_of_src sr
   228:     )
   229: 
   230:   | `PAT_as (_,pat,_) -> check_terminal pat
   231:   | `PAT_coercion (_,pat,_) -> check_terminal pat
   232:   | _ -> ()
   233: 
   234: let validate_patterns pats =
   235:   if List.length pats = 0
   236:   then failwith "Empty pattern list";
   237:   let hpat = List.hd pats in
   238:   let checker = find_match_type hpat in
   239:   checker pats;
   240:   List.iter check_terminal (List.tl (List.rev pats));
   241:   List.iter
   242:   (fun x -> match x with
   243:     | `PAT_none sr -> assert false
   244:     | `PAT_nan sr ->
   245:       failwith
   246:       (
   247:         "NaN test must be first in match in " ^
   248:         short_string_of_src sr
   249:       )
   250:     | _ -> ()
   251:   )
   252:   (List.tl pats)
   253: 
End ocaml section to src/flx_pat.ml[1]