Library iris.proofmode.intro_patterns

From stdpp Require Export strings.
From iris.proofmode Require Import base tokens sel_patterns.
From iris.prelude Require Import options.

Inductive gallina_ident :=
  | IGallinaNamed : string gallina_ident
  | IGallinaAnon : gallina_ident.

Inductive intro_pat :=
  | IIdent : ident intro_pat
  | IFresh : intro_pat
  | IDrop : intro_pat
  | IFrame : intro_pat
  | IList : list (list intro_pat) intro_pat
  | IPure : gallina_ident intro_pat
  | IIntuitionistic : intro_pat intro_pat
  | ISpatial : intro_pat intro_pat
  | IModalElim : intro_pat intro_pat
  | IRewrite : direction intro_pat
  | IPureIntro : intro_pat
  | IModalIntro : intro_pat
  | ISimpl : intro_pat
  | IDone : intro_pat
  | IForall : intro_pat
  | IAll : intro_pat
  | IClear : sel_pat intro_pat
  | IClearFrame : sel_pat intro_pat.

Module intro_pat.
Inductive stack_item :=
  | StPat : intro_pat stack_item
  | StList : stack_item
  | StConjList : stack_item
  | StBar : stack_item
  | StAmp : stack_item
  | StIntuitionistic : stack_item
  | StSpatial : stack_item
  | StModalElim : stack_item.
Notation stack := (list stack_item).

Fixpoint close_list (k : stack)
    (ps : list intro_pat) (pss : list (list intro_pat)) : option stack :=
  match k with
  | StList :: kSome (StPat (IList (ps :: pss)) :: k)
  | StPat pat :: kclose_list k (pat :: ps) pss
  | StIntuitionistic :: k
     '(p,ps) maybe2 (::) ps; close_list k (IIntuitionistic p :: ps) pss
  | StModalElim :: k
     '(p,ps) maybe2 (::) ps; close_list k (IModalElim p :: ps) pss
  | StBar :: kclose_list k [] (ps :: pss)
  | _None
  end.

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

Fixpoint close_conj_list (k : stack)
    (cur : option intro_pat) (ps : list intro_pat) : option stack :=
  match k with
  | StConjList :: k
     ps match cur with
          | Noneguard (ps = []);; Some [] | Some pSome (p :: ps)
          end;
     Some (StPat (big_conj ps) :: k)
  | StPat pat :: kguard (cur = None);; close_conj_list k (Some pat) ps
  | StIntuitionistic :: kp cur; close_conj_list k (Some (IIntuitionistic p)) ps
  | StSpatial :: kp cur; close_conj_list k (Some (ISpatial p)) ps
  | StModalElim :: kp cur; close_conj_list k (Some (IModalElim p)) ps
  | StAmp :: kp cur; close_conj_list k None (p :: ps)
  | _None
  end.

Fixpoint parse_go (ts : list token) (k : stack) : option stack :=
  match ts with
  | []Some k
  | TName "_" :: tsparse_go ts (StPat IDrop :: k)
  | TName s :: tsparse_go ts (StPat (IIdent s) :: k)
  | TAnon :: tsparse_go ts (StPat IFresh :: k)
  | TFrame :: tsparse_go ts (StPat IFrame :: k)
  | TBracketL :: tsparse_go ts (StList :: k)
  | TBar :: tsparse_go ts (StBar :: k)
  | TBracketR :: tsclose_list k [] [] ≫= parse_go ts
  | TParenL :: tsparse_go ts (StConjList :: k)
  | TAmp :: tsparse_go ts (StAmp :: k)
  | TParenR :: tsclose_conj_list k None [] ≫= parse_go ts
  | TPure (Some s) :: tsparse_go ts (StPat (IPure (IGallinaNamed s)) :: k)
  | TPure None :: tsparse_go ts (StPat (IPure IGallinaAnon) :: k)
  | TIntuitionistic :: tsparse_go ts (StIntuitionistic :: k)
  | TMinus :: TIntuitionistic :: tsparse_go ts (StSpatial :: k)
  | TModal :: tsparse_go ts (StModalElim :: k)
  | TArrow d :: tsparse_go ts (StPat (IRewrite d) :: k)
  | TPureIntro :: tsparse_go ts (StPat IPureIntro :: k)
  | (TModalIntro | TIntuitionisticIntro) :: tsparse_go ts (StPat IModalIntro :: k)
  | TSimpl :: tsparse_go ts (StPat ISimpl :: k)
  | TDone :: tsparse_go ts (StPat IDone :: k)
  | TAll :: tsparse_go ts (StPat IAll :: k)
  | TForall :: tsparse_go ts (StPat IForall :: k)
  | TBraceL :: tsparse_clear ts k
  | _None
  end
with parse_clear (ts : list token) (k : stack) : option stack :=
  match ts with
  | TFrame :: TName s :: tsparse_clear ts (StPat (IClearFrame (SelIdent s)) :: k)
  | TFrame :: TPure None :: tsparse_clear ts (StPat (IClearFrame SelPure) :: k)
  | TFrame :: TIntuitionistic :: tsparse_clear ts (StPat (IClearFrame SelIntuitionistic) :: k)
  | TFrame :: TSep :: tsparse_clear ts (StPat (IClearFrame SelSpatial) :: k)
  | TName s :: tsparse_clear ts (StPat (IClear (SelIdent s)) :: k)
  | TPure None :: tsparse_clear ts (StPat (IClear SelPure) :: k)
  | TIntuitionistic :: tsparse_clear ts (StPat (IClear SelIntuitionistic) :: k)
  | TSep :: tsparse_clear ts (StPat (IClear SelSpatial) :: k)
  | TBraceR :: tsparse_go ts k
  | _None
  end.

Fixpoint close (k : stack) (ps : list intro_pat) : option (list intro_pat) :=
  match k with
  | []Some ps
  | StPat pat :: kclose k (pat :: ps)
  | StIntuitionistic :: k'(p,ps) maybe2 (::) ps; close k (IIntuitionistic p :: ps)
  | StSpatial :: k'(p,ps) maybe2 (::) ps; close k (ISpatial p :: ps)
  | StModalElim :: k'(p,ps) maybe2 (::) ps; close k (IModalElim p :: ps)
  | _None
  end.

Definition parse (s : string) : option (list intro_pat) :=
  k parse_go (tokenize s) []; close k [].

Ltac parse s :=
  lazymatch type of s with
  | list intro_pats
  | intro_patconstr:([s])
  | list string
     lazymatch eval vm_compute in (mjoin <$> mapM parse s) with
     | Some ?patspats
     | _fail "intro_pat.parse: cannot parse" s "as an introduction pattern"
     end
  | string
     lazymatch eval vm_compute in (parse s) with
     | Some ?patspats
     | _fail "intro_pat.parse: cannot parse" s "as an introduction pattern"
     end
  | identconstr:([IIdent s])
  | ?Xfail "intro_pat.parse: the term" s
     "is expected to be an introduction pattern"
     "(usually a string),"
     "but has unexpected type" X
  end.
Ltac parse_one s :=
  lazymatch type of s with
  | intro_pats
  | string
     lazymatch eval vm_compute in (parse s) with
     | Some [?pat]pat
     | _fail "intro_pat.parse_one: cannot parse" s "as an introduction pattern"
     end
  | ?Xfail "intro_pat.parse_one: the term" s
     "is expected to be an introduction pattern"
     "(usually a string),"
     "but has unexpected type" X
  end.
End intro_pat.

Fixpoint intro_pat_intuitionistic (p : intro_pat) :=
  match p with
  | IPure _true
  | IRewrite _true
  | IIntuitionistic _true
  | IList ppsforallb (forallb intro_pat_intuitionistic) pps
  | ISimpltrue
  | IClear _true
  | IClearFrame _true
  | _false
  end.

Ltac intro_pat_intuitionistic p :=
  lazymatch type of p with
  | intro_pateval cbv in (intro_pat_intuitionistic p)
  | list intro_pateval cbv in (forallb intro_pat_intuitionistic p)
  | string
     let pat := intro_pat.parse p in
     eval cbv in (forallb intro_pat_intuitionistic pat)
  | identfalse
  | boolp
  | ?Xfail "intro_pat_intuitionistic: the term" p
     "is expected to be an introduction pattern"
     "(usually a string),"
     "but has unexpected type" X
  end.