intro_patterns.v 5.86 KB
Newer Older
Robbert Krebbers's avatar
Robbert Krebbers committed
1 2 3 4 5 6
From iris.prelude Require Export strings.

Inductive intro_pat :=
  | IName : string  intro_pat
  | IAnom : intro_pat
  | IAnomPure : intro_pat
7
  | IDrop : intro_pat
8
  | IFrame : intro_pat
Robbert Krebbers's avatar
Robbert Krebbers committed
9 10 11
  | IPersistent : intro_pat  intro_pat
  | IList : list (list intro_pat)  intro_pat
  | ISimpl : intro_pat
12
  | IAlways : intro_pat
13
  | INext : intro_pat
14 15
  | IForall : intro_pat
  | IAll : intro_pat
16
  | IClear : list (bool * string)  intro_pat. (* true = frame, false = clear *)
Robbert Krebbers's avatar
Robbert Krebbers committed
17 18 19 20 21 22

Module intro_pat.
Inductive token :=
  | TName : string  token
  | TAnom : token
  | TAnomPure : token
23
  | TDrop : token
24
  | TFrame : token
Robbert Krebbers's avatar
Robbert Krebbers committed
25 26 27 28 29 30 31 32
  | TPersistent : token
  | TBar : token
  | TBracketL : token
  | TBracketR : token
  | TAmp : token
  | TParenL : token
  | TParenR : token
  | TSimpl : token
33
  | TAlways : token
34 35
  | TNext : token
  | TClearL : token
36 37 38
  | TClearR : token
  | TForall : token
  | TAll : token.
Robbert Krebbers's avatar
Robbert Krebbers committed
39 40 41 42 43 44 45 46 47

Fixpoint cons_name (kn : string) (k : list token) : list token :=
  match kn with "" => k | _ => TName (string_rev kn) :: k end.
Fixpoint tokenize_go (s : string) (k : list token) (kn : string) : list token :=
  match s with
  | "" => rev (cons_name kn k)
  | String " " s => tokenize_go s (cons_name kn k) ""
  | String "?" s => tokenize_go s (TAnom :: cons_name kn k) ""
  | String "%" s => tokenize_go s (TAnomPure :: cons_name kn k) ""
48
  | String "_" s => tokenize_go s (TDrop :: cons_name kn k) ""
49
  | String "$" s => tokenize_go s (TFrame :: cons_name kn k) ""
Robbert Krebbers's avatar
Robbert Krebbers committed
50 51 52 53 54 55 56 57
  | String "#" s => tokenize_go s (TPersistent :: cons_name kn k) ""
  | String "[" s => tokenize_go s (TBracketL :: cons_name kn k) ""
  | String "]" s => tokenize_go s (TBracketR :: cons_name kn k) ""
  | String "|" s => tokenize_go s (TBar :: cons_name kn k) ""
  | String "(" s => tokenize_go s (TParenL :: cons_name kn k) ""
  | String ")" s => tokenize_go s (TParenR :: cons_name kn k) ""
  | String "&" s => tokenize_go s (TAmp :: cons_name kn k) ""
  | String "!" s => tokenize_go s (TAlways :: cons_name kn k) ""
58
  | String ">" s => tokenize_go s (TNext :: cons_name kn k) ""
59 60
  | String "{" s => tokenize_go s (TClearL :: cons_name kn k) ""
  | String "}" s => tokenize_go s (TClearR :: cons_name kn k) ""
Robbert Krebbers's avatar
Robbert Krebbers committed
61
  | String "/" (String "=" s) => tokenize_go s (TSimpl :: cons_name kn k) ""
62 63
  | String "*" (String "*" s) => tokenize_go s (TAll :: cons_name kn k) ""
  | String "*" s => tokenize_go s (TForall :: cons_name kn k) ""
Robbert Krebbers's avatar
Robbert Krebbers committed
64 65 66 67 68 69 70 71 72 73
  | String a s => tokenize_go s k (String a kn)
  end.
Definition tokenize (s : string) : list token := tokenize_go s [] "".

Inductive stack_item :=
  | SPat : intro_pat  stack_item
  | SPersistent : stack_item
  | SList : stack_item
  | SConjList : stack_item
  | SBar : stack_item
74
  | SAmp : stack_item.
Robbert Krebbers's avatar
Robbert Krebbers committed
75 76 77 78 79 80 81 82 83 84
Notation stack := (list stack_item).

Fixpoint close_list (k : stack)
    (ps : list intro_pat) (pss : list (list intro_pat)) : option stack :=
  match k with
  | SList :: k => Some (SPat (IList (ps :: pss)) :: k)
  | SPat pat :: k => close_list k (pat :: ps) pss
  | SPersistent :: k =>
     '(p,ps)  maybe2 (::) ps; close_list k (IPersistent p :: ps) pss
  | SBar :: k => close_list k [] (ps :: pss)
85
  | _ => None
Robbert Krebbers's avatar
Robbert Krebbers committed
86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106
  end.

Fixpoint big_conj (ps : list intro_pat) : intro_pat :=
  match ps with
  | [] => IList [[]]
  | [p] => IList [[ p ]]
  | [p1;p2] => IList [[ p1 ; p2 ]]
  | p :: ps => IList [[ p ; big_conj ps ]]
  end.

Fixpoint close_conj_list (k : stack)
    (cur : option intro_pat) (ps : list intro_pat) : option stack :=
  match k with
  | SConjList :: k =>
     ps  match cur with
          | None => guard (ps = []); Some [] | Some p => Some (p :: ps)
          end;
     Some (SPat (big_conj ps) :: k)
  | SPat pat :: k => guard (cur = None); close_conj_list k (Some pat) ps
  | SPersistent :: k => p  cur; close_conj_list k (Some (IPersistent p)) ps
  | SAmp :: k => p  cur; close_conj_list k None (p :: ps)
107 108 109
  | _ => None
  end.

Robbert Krebbers's avatar
Robbert Krebbers committed
110 111 112 113 114 115
Fixpoint parse_go (ts : list token) (k : stack) : option stack :=
  match ts with
  | [] => Some k
  | TName s :: ts => parse_go ts (SPat (IName s) :: k)
  | TAnom :: ts => parse_go ts (SPat IAnom :: k)
  | TAnomPure :: ts => parse_go ts (SPat IAnomPure :: k)
116
  | TDrop :: ts => parse_go ts (SPat IDrop :: k)
117
  | TFrame :: ts => parse_go ts (SPat IFrame :: k)
Robbert Krebbers's avatar
Robbert Krebbers committed
118 119 120 121 122 123 124 125 126
  | TPersistent :: ts => parse_go ts (SPersistent :: k)
  | TBracketL :: ts => parse_go ts (SList :: k)
  | TBar :: ts => parse_go ts (SBar :: k)
  | TBracketR :: ts => close_list k [] [] = parse_go ts
  | TParenL :: ts => parse_go ts (SConjList :: k)
  | TAmp :: ts => parse_go ts (SAmp :: k)
  | TParenR :: ts => close_conj_list k None [] = parse_go ts
  | TSimpl :: ts => parse_go ts (SPat ISimpl :: k)
  | TAlways :: ts => parse_go ts (SPat IAlways :: k)
127
  | TNext :: ts => parse_go ts (SPat INext :: k)
128 129
  | TAll :: ts => parse_go ts (SPat IAll :: k)
  | TForall :: ts => parse_go ts (SPat IForall :: k)
130 131 132 133 134 135 136 137 138 139
  | TClearL :: ts => parse_clear ts [] k
  | _ => None
  end
with parse_clear (ts : list token)
    (ss : list (bool * string)) (k : stack) : option stack :=
  match ts with
  | TFrame :: TName s :: ts => parse_clear ts ((true,s) :: ss) k
  | TName s :: ts => parse_clear ts ((false,s) :: ss) k
  | TClearR :: ts => parse_go ts (SPat (IClear (reverse ss)) :: k)
  | _ => None
Robbert Krebbers's avatar
Robbert Krebbers committed
140
  end.
141

Robbert Krebbers's avatar
Robbert Krebbers committed
142 143 144 145 146 147 148 149 150
Definition parse (s : string) : option (list intro_pat) :=
  match k  parse_go (tokenize s) [SList]; close_list k [] [] with
  | Some [SPat (IList [ps])] => Some ps
  | _ => None
  end.

Ltac parse s :=
  lazymatch type of s with
  | list intro_pat => s
151 152 153 154 155 156 157 158
  | list string =>
     lazymatch eval vm_compute in (mjoin <$> mapM parse s) with
     | Some ?pats => pats | _ => fail "invalid list intro_pat" s
     end
  | string =>
     lazymatch eval vm_compute in (parse s) with
     | Some ?pats => pats | _ => fail "invalid list intro_pat" s
     end
Robbert Krebbers's avatar
Robbert Krebbers committed
159 160 161 162
  end.
Ltac parse_one s :=
  lazymatch type of s with
  | intro_pat => s
163 164 165 166
  | string =>
     lazymatch eval vm_compute in (parse s) with
     | Some [?pat] => pat | _ => fail "invalid intro_pat" s
     end
Robbert Krebbers's avatar
Robbert Krebbers committed
167 168
  end.
End intro_pat.