merry / src / lib / ast.ml

(* Our AST is essentially Morbig's CST without linebreaks, newlines
   etc. *)
open Morbig
open Import
include Sast

type t = complete_commands

let rec program : CST.program -> complete_commands =
 fun x ->
  match x with
  | Program_LineBreak_CompleteCommands_LineBreak (_, b, _) ->
      complete_commands b.value
  | Program_LineBreak _ -> []

and complete_commands : CST.complete_commands -> complete_commands =
 fun x ->
  match x with
  | CompleteCommands_CompleteCommands_NewlineList_CompleteCommand (a, _, c) ->
      let a = complete_commands a.value in
      let c = complete_command c.value in
      a @ [ c ]
  | CompleteCommands_CompleteCommand a ->
      let a = complete_command a.value in
      [ a ]

and complete_command : CST.complete_command -> complete_command =
 fun x ->
  match x with
  | CompleteCommand_CList_SeparatorOp (a, b) ->
      (clist a.value, Some (separator_op b.value))
  | CompleteCommand_CList a ->
      let a = clist a.value in
      (a, None)

and separator_op : CST.separator_op -> separator = function
  | CST.SeparatorOp_Uppersand -> Ampersand
  | CST.SeparatorOp_Semicolon -> Semicolon

and clist : ?sep:separator -> CST.clist -> clist =
 fun ?(sep = Semicolon) x ->
  match x with
  | CList_CList_SeparatorOp_AndOr (a, b, c) ->
      let next_sep = separator_op b.value in
      let rest = clist ~sep:next_sep a.value in
      let command = and_or c.value in
      Nslist.append rest (Nlist.Singleton (command, sep))
  | CList_AndOr a ->
      let a = and_or a.value in
      Nslist.singleton sep a

and and_or : ?sep:and_or -> CST.and_or -> pipeline and_or_list =
 fun ?(sep = Noand_or) x ->
  match x with
  | AndOr_Pipeline a ->
      let a = pipeline a.value in
      Nslist.singleton sep a
  | AndOr_AndOr_AndIf_LineBreak_Pipeline (a, _, c) ->
      let rest = and_or ~sep:And a.value in
      let c = pipeline c.value in
      Nslist.append rest (Nlist.Singleton (c, sep))
  | AndOr_AndOr_OrIf_LineBreak_Pipeline (a, _, c) ->
      let rest = and_or ~sep:Or a.value in
      let c = pipeline c.value in
      Nslist.append rest (Nlist.Singleton (c, sep))

and pipeline : CST.pipeline -> pipeline =
 fun x ->
  match x with
  | Pipeline_PipeSequence a ->
      let a = pipe_sequence a.value in
      Pipeline a
  | Pipeline_Bang_PipeSequence a ->
      let a = pipe_sequence a.value in
      Pipeline_Bang a

and pipe_sequence : CST.pipe_sequence -> pipe_sequence =
 fun x ->
  match x with
  | PipeSequence_Command a ->
      let a = command a.value in
      [ a ]
  | PipeSequence_PipeSequence_Pipe_LineBreak_Command (a, _, c) ->
      let rest = pipe_sequence a.value in
      let c = command c.value in
      rest @ [ c ]

and command : CST.command -> command =
 fun x ->
  match x with
  | Command_SimpleCommand a ->
      let a = simple_command a.value in
      SimpleCommand a
  | Command_CompoundCommand a ->
      let a = compound_command a.value in
      CompoundCommand (a, [])
  | Command_CompoundCommand_RedirectList (a, rdrs) ->
      let a = compound_command a.value in
      let b = redirect_list rdrs.value in
      CompoundCommand (a, b)
  | Command_FunctionDefinition a ->
      let a = function_definition a.value in
      FunctionDefinition a

and compound_command : CST.compound_command -> compound_command =
 fun x ->
  match x with
  | CompoundCommand_BraceGroup a ->
      let a = brace_group a.value in
      BraceGroup a
  | CompoundCommand_Subshell a ->
      let a = subshell a.value in
      Subshell a
  | CompoundCommand_ForClause a ->
      let a = for_clause a.value in
      ForClause a
  | CompoundCommand_CaseClause a ->
      let a = case_clause a.value in
      CaseClause a
  | CompoundCommand_IfClause a ->
      let a = if_clause a.value in
      IfClause a
  | CompoundCommand_WhileClause a ->
      let a = while_clause a.value in
      WhileClause a
  | CompoundCommand_UntilClause a ->
      let a = until_clause a.value in
      UntilClause a

and subshell : CST.subshell -> subshell =
 fun x ->
  match x with Subshell_Lparen_CompoundList_Rparen a -> compound_list a.value

and compound_list : CST.compound_list -> compound_list =
 fun x ->
  match x with
  | CompoundList_LineBreak_Term (_, b) ->
      let b = term b.value in
      (b, Semicolon)
  | CompoundList_LineBreak_Term_Separator (_, b, c) ->
      let b = term b.value in
      let c = separator c.value in
      (b, c)

and term : CST.term -> term =
 fun x ->
  match x with
  | Term_Term_Separator_AndOr (a, b, c) ->
      let rest = term a.value in
      let b = separator b.value in
      let c = and_or c.value in
      Nslist.append rest (Nslist.singleton b c)
  | Term_AndOr a ->
      let a = and_or a.value in
      Nslist.singleton Semicolon a

and for_clause : CST.for_clause -> for_clause =
 fun x ->
  match x with
  | ForClause_For_Name_DoGroup (a, b) ->
      let a = name a.value in
      let b = do_group b.value in
      For_Name_DoGroup (a, b)
  | ForClause_For_Name_SequentialSep_DoGroup (a, _, c) ->
      let a = name a.value in
      let c = do_group c.value in
      For_Name_DoGroup (a, c)
  | ForClause_For_Name_LineBreak_In_SequentialSep_DoGroup (a, _, _, d) ->
      let a = name a.value in
      let d = do_group d.value in
      For_Name_DoGroup (a, d)
  | ForClause_For_Name_LineBreak_In_WordList_SequentialSep_DoGroup
      (a, _, c, _, e) ->
      let a = name a.value in
      let c = wordlist c.value in
      let e = do_group e.value in
      For_Name_In_WordList_DoGroup (a, c, e)

and wordlist : CST.wordlist -> wordlist =
 fun x ->
  match x with
  | WordList_WordList_Word (a, b) ->
      let a = wordlist a.value in
      let b = word b.value in
      Nlist.append a (Nlist.Singleton b)
  | WordList_Word a ->
      let a = word a.value in
      Nlist.Singleton a

and case_clause : CST.case_clause -> case_clause =
 fun x ->
  match x with
  | CaseClause_Case_Word_LineBreak_In_LineBreak_CaseList_Esac (a, _, _, d) ->
      let a = word a.value in
      let d = case_list d.value in
      Cases (a, d)
  | CaseClause_Case_Word_LineBreak_In_LineBreak_CaseListNS_Esac (a, _, _, d) ->
      let a = word a.value in
      let d = case_list_ns d.value in
      Cases (a, d)
  | CaseClause_Case_Word_LineBreak_In_LineBreak_Esac (a, _, _) ->
      let a = word a.value in
      Case a

and case_list_ns : CST.case_list_ns -> case_list =
 fun x ->
  match x with
  | CaseListNS_CaseList_CaseItemNS (a, b) ->
      let a = case_list a.value in
      let b = case_item_ns b.value in
      Nlist.(a @ Singleton b)
  | CaseListNS_CaseItemNS a ->
      let a = case_item_ns a.value in
      Nlist.Singleton a

and case_list : CST.case_list -> case_list =
 fun x ->
  match x with
  | CaseList_CaseList_CaseItem (a, b) ->
      let a = case_list a.value in
      let b = case_item b.value in
      Nlist.(a @ Singleton b)
  | CaseList_CaseItem a ->
      let a = case_item a.value in
      Nlist.Singleton a

and case_item_ns : CST.case_item_ns -> case_item =
 fun x ->
  match x with
  | CaseItemNS_Pattern_Rparen_LineBreak (a, _) ->
      let a = pattern a.value in
      Case_pattern (a, None)
  | CaseItemNS_Pattern_Rparen_CompoundList (a, b) ->
      let a = pattern a.value in
      let b = compound_list b.value in
      Case_pattern (a, Some b)
  | CaseItemNS_Lparen_Pattern_Rparen_LineBreak (a, _) ->
      let a = pattern a.value in
      Case_pattern (a, None)
  | CaseItemNS_Lparen_Pattern_Rparen_CompoundList (a, b) ->
      let a = pattern a.value in
      let b = compound_list b.value in
      Case_pattern (a, Some b)

and case_item : CST.case_item -> case_item =
 fun x ->
  match x with
  | CaseItem_Pattern_Rparen_LineBreak_Dsemi_LineBreak (a, _, _) ->
      let a = pattern a.value in
      Case_pattern (a, None)
  | CaseItem_Pattern_Rparen_CompoundList_Dsemi_LineBreak (a, b, _) ->
      let a = pattern a.value in
      let b = compound_list b.value in
      Case_pattern (a, Some b)
  | CaseItem_Lparen_Pattern_Rparen_LineBreak_Dsemi_LineBreak (a, _, _) ->
      let a = pattern a.value in
      Case_pattern (a, None)
  | CaseItem_Lparen_Pattern_Rparen_CompoundList_Dsemi_LineBreak (a, b, _) ->
      let a = pattern a.value in
      let b = compound_list b.value in
      Case_pattern (a, Some b)

and pattern : CST.pattern -> pattern =
 fun x ->
  match x with
  | Pattern_Word a ->
      let a = word a.value in
      Nlist.Singleton a
  | Pattern_Pattern_Pipe_Word (a, b) ->
      let a = pattern a.value in
      let b = word b.value in
      Nlist.(a @ Singleton b)

and if_clause : CST.if_clause -> if_clause =
 fun x ->
  match x with
  | IfClause_If_CompoundList_Then_CompoundList_ElsePart_Fi (a, b, c) ->
      let a = compound_list a.value in
      let b = compound_list b.value in
      let c = else_part c.value in
      If_then_else (a, b, c)
  | IfClause_If_CompoundList_Then_CompoundList_Fi (a, b) ->
      let a = compound_list a.value in
      let b = compound_list b.value in
      If_then (a, b)

and else_part : CST.else_part -> else_part =
 fun x ->
  match x with
  | ElsePart_Elif_CompoundList_Then_CompoundList (a, b) ->
      let a = compound_list a.value in
      let b = compound_list b.value in
      Elif_then (a, b)
  | ElsePart_Elif_CompoundList_Then_CompoundList_ElsePart (a, b, c) ->
      let a = compound_list a.value in
      let b = compound_list b.value in
      let c = else_part c.value in
      Elif_then_else (a, b, c)
  | ElsePart_Else_CompoundList a ->
      let a = compound_list a.value in
      Else a

and while_clause : CST.while_clause -> while_clause =
 fun x ->
  match x with
  | WhileClause_While_CompoundList_DoGroup (a, b) ->
      let a = compound_list a.value in
      let b = do_group b.value in
      While (a, b)

and until_clause : CST.until_clause -> until_clause =
 fun x ->
  match x with
  | UntilClause_Until_CompoundList_DoGroup (a, b) ->
      let a = compound_list a.value in
      let b = do_group b.value in
      Until (a, b)

and function_definition : CST.function_definition -> function_definition =
 fun x ->
  match x with
  | FunctionDefinition_Fname_Lparen_Rparen_LineBreak_FunctionBody (a, _, c) ->
      let CST.(Fname_Name (Name a)) = a.value in
      let c = function_body c.value in
      (a, c)

and function_body : CST.function_body -> function_body =
 fun x ->
  match x with
  | FunctionBody_CompoundCommand a ->
      let a = compound_command a.value in
      (a, [])
  | FunctionBody_CompoundCommand_RedirectList (a, b) ->
      let a = compound_command a.value in
      let b = redirect_list b.value in
      (a, b)

and brace_group : CST.brace_group -> brace_group =
 fun x ->
  match x with
  | BraceGroup_LBrace_CompoundList_RBrace a ->
      let a = compound_list a.value in
      a

and do_group : CST.do_group -> do_group =
 fun x ->
  match x with
  | DoGroup_Do_CompoundList_Done a ->
      let a = compound_list a.value in
      a

and simple_command : CST.simple_command -> simple_command =
 fun x ->
  match x with
  | SimpleCommand_CmdPrefix_CmdWord_CmdSuffix (a, b, c) ->
      let a = cmd_prefix a.value in
      let b = cmd_word b.value in
      let c = cmd_suffix c.value in
      Prefixed (a, Some b, Some c)
  | SimpleCommand_CmdPrefix_CmdWord (a, b) ->
      let a = cmd_prefix a.value in
      let b = cmd_word b.value in
      Prefixed (a, Some b, None)
  | SimpleCommand_CmdPrefix a ->
      let a = cmd_prefix a.value in
      Prefixed (a, None, None)
  | SimpleCommand_CmdName_CmdSuffix (a, b) ->
      let a = cmd_name a.value in
      let b = cmd_suffix b.value in
      Named (a, Some b)
  | SimpleCommand_CmdName a ->
      let a = cmd_name a.value in
      Named (a, None)

and cmd_name : CST.cmd_name -> cmd_name =
 fun x ->
  match x with
  | CmdName_Word a ->
      let a = word a.value in
      a

and cmd_word : CST.cmd_word -> cmd_word =
 fun x ->
  match x with
  | CmdWord_Word a ->
      let a = word a.value in
      a

and cmd_prefix : CST.cmd_prefix -> cmd_prefix =
 fun x ->
  match x with
  | CmdPrefix_IoRedirect a ->
      let a = io_redirect a.value in
      [ Prefix_redirect a ]
  | CmdPrefix_CmdPrefix_IoRedirect (a, b) ->
      let a = cmd_prefix a.value in
      let b = io_redirect b.value in
      a @ [ Prefix_redirect b ]
  | CmdPrefix_AssignmentWord a ->
      let a = assignment_word a.value in
      [ Prefix_assignment a ]
  | CmdPrefix_CmdPrefix_AssignmentWord (a, b) ->
      let a = cmd_prefix a.value in
      let b = assignment_word b.value in
      a @ [ Prefix_assignment b ]

and cmd_suffix : CST.cmd_suffix -> cmd_suffix =
 fun x ->
  match x with
  | CmdSuffix_IoRedirect a ->
      let a = io_redirect a.value in
      [ Suffix_redirect a ]
  | CmdSuffix_CmdSuffix_IoRedirect (a, b) ->
      let a = cmd_suffix a.value in
      let b = io_redirect b.value in
      a @ [ Suffix_redirect b ]
  | CmdSuffix_Word a ->
      let a = word a.value in
      [ Suffix_word a ]
  | CmdSuffix_CmdSuffix_Word (a, b) ->
      let a = cmd_suffix a.value in
      let b = word b.value in
      a @ [ Suffix_word b ]

and redirect_list : CST.redirect_list -> redirects =
 fun x ->
  match x with
  | RedirectList_IoRedirect a ->
      let a = io_redirect a.value in
      [ a ]
  | RedirectList_RedirectList_IoRedirect (a, b) ->
      let a = redirect_list a.value in
      let b = io_redirect b.value in
      a @ [ b ]

and io_op_default_fd : io_op -> io_number = function
  | Io_op_less -> 0
  | Io_op_lessand -> 0
  | _ -> 1

and io_redirect : CST.io_redirect -> io_redirect =
 fun x ->
  match x with
  | IoRedirect_IoFile a ->
      let a = io_file a.value in
      IoRedirect_IoFile (io_op_default_fd (fst a), a)
  | IoRedirect_IoNumber_IoFile (a, b) ->
      let a = io_number a in
      let b = io_file b.value in
      IoRedirect_IoFile (a, b)
  | IoRedirect_IoHere a ->
      let a = io_here a.value in
      IoRedirect_IoHere (0, a)
  | IoRedirect_IoNumber_IoHere (a, b) ->
      let a = io_number a in
      let b = io_here b.value in
      IoRedirect_IoHere (a, b)

and io_file : CST.io_file -> io_file =
 fun x ->
  match x with
  | IoFile_Less_FileName a ->
      let a = filename a.value in
      (Io_op_less, a)
  | IoFile_LessAnd_FileName a ->
      let a = filename a.value in
      (Io_op_lessand, a)
  | IoFile_Great_FileName a ->
      let a = filename a.value in
      (Io_op_great, a)
  | IoFile_GreatAnd_FileName a ->
      let a = filename a.value in
      (Io_op_greatand, a)
  | IoFile_DGreat_FileName a ->
      let a = filename a.value in
      (Io_op_dgreat, a)
  | IoFile_LessGreat_FileName a ->
      let a = filename a.value in
      (Io_op_lessgreat, a)
  | IoFile_AndGreat_FileName a ->
      let a = filename a.value in
      (Io_op_andgreat, a)
  | IoFile_Clobber_FileName a ->
      let a = filename a.value in
      (Io_op_clobber, a)

and filename : CST.filename -> filename =
 fun x ->
  match x with
  | Filename_Word a ->
      let a = word a.value in
      a

and io_here : CST.io_here -> io_here =
 fun x ->
  match x with
  | IoHere_DLess_HereEnd (a, b) ->
      let a = here_end a.value in
      IoHere (a, word !b.value)
  | IoHere_DLessDash_HereEnd (a, b) ->
      let a = here_end a.value in
      IoHere_Dash (a, word !b.value)

and here_end : CST.here_end -> here_end =
 fun x ->
  match x with
  | HereEnd_Word a ->
      let a = word a.value in
      a

and separator : CST.separator -> separator =
 fun x ->
  match x with
  | Separator_SeparatorOp_LineBreak (a, _) -> separator_op a.value
  | Separator_NewLineList _ -> Semicolon

and word : CST.word -> word = fun x -> match x with Word (_, b) -> word_cst b
and word_cst : CST.word_cst -> word_cst = fun v -> List.map word_component v

and need_escaped = function
  | '(' | '`' | '$' | ')' | '0' .. '9' -> true
  | _ -> false

and remove_double_escape s =
  let len = String.length s in
  let i = ref 0 in
  let r = ref "" in
  while !i <= len - 1 do
    if
      Char.equal (String.unsafe_get s !i) '\\'
      && need_escaped (String.unsafe_get s (!i + 1))
    then begin
      r := !r ^ String.make 1 @@ String.unsafe_get s (!i + 1);
      i := !i + 2
    end
    else begin
      r := !r ^ String.make 1 @@ String.unsafe_get s !i;
      incr i
    end
  done;
  !r

and word_component : CST.word_component -> word_component =
 fun x ->
  match x with
  | WordSubshell (_a, b) ->
      let b = program b.value in
      WordSubshell b
  | WordName a -> WordName (remove_double_escape a)
  | WordAssignmentWord a ->
      let a = assignment_word a in
      WordAssignmentWord a
  | WordDoubleQuoted a ->
      let a = word a in
      WordDoubleQuoted a
  | WordSingleQuoted a ->
      let a = word a in
      WordSingleQuoted a
  | WordTildePrefix a -> WordTildePrefix a
  | WordLiteral a -> WordLiteral (remove_double_escape a)
  | WordVariable a ->
      let a = variable a in
      WordVariable a
  | WordGlobAll -> WordGlobAll
  | WordGlobAny -> WordGlobAny
  | WordArithmeticExpression s -> WordArithmeticExpression (word s)
  | WordReBracketExpression a ->
      let a = bracket_expression a in
      WordReBracketExpression a
  | WordEmpty -> WordEmpty

and bracket_expression : CST.bracket_expression -> bracket_expression =
 fun x ->
  match x with
  | BracketExpression_LBRACKET_MatchingList_RBRACKET a ->
      let a = matching_list a in
      BracketExpression_LBRACKET_MatchingList_RBRACKET a
  | BracketExpression_LBRACKET_NonMatchingList_RBRACKET a ->
      let a = nonmatching_list a in
      BracketExpression_LBRACKET_NonMatchingList_RBRACKET a

and matching_list : CST.matching_list -> matching_list =
 fun x ->
  match x with
  | MatchingList_BracketList a ->
      let a = bracket_list a in
      MatchingList_BracketList a

and nonmatching_list : CST.nonmatching_list -> nonmatching_list =
 fun x ->
  match x with
  | NonMatchingList_BracketList a ->
      let a = bracket_list a in
      NonMatchingList_BracketList a

and bracket_list : CST.bracket_list -> bracket_list =
 fun x ->
  match x with
  | BracketList_FollowList a ->
      let a = follow_list a in
      BracketList_FollowList a
  | BracketList_FollowList_MINUS a ->
      let a = follow_list a in
      BracketList_FollowList_MINUS a

and follow_list : CST.follow_list -> follow_list =
 fun x ->
  match x with
  | FollowList_ExpressionTerm a ->
      let a = expression_term a in
      FollowList_ExpressionTerm a
  | FollowList_FollowList_ExpressionTerm (a, b) ->
      let a = follow_list a in
      let b = expression_term b in
      FollowList_FollowList_ExpressionTerm (a, b)

and expression_term : CST.expression_term -> expression_term =
 fun x ->
  match x with
  | ExpressionTerm_SingleExpression a ->
      let a = single_expression a in
      ExpressionTerm_SingleExpression a
  | ExpressionTerm_RangeExpression a ->
      let a = range_expression a in
      ExpressionTerm_RangeExpression a

and single_expression : CST.single_expression -> single_expression =
 fun x ->
  match x with
  | SingleExpression_EndRange a ->
      let a = end_range a in
      SingleExpression_EndRange a
  | SingleExpression_CharacterClass a ->
      let a = character_class a in
      SingleExpression_CharacterClass a
  | SingleExpression_EquivalenceClass a ->
      let a = equivalence_class a in
      SingleExpression_EquivalenceClass a

and range_expression : CST.range_expression -> range_expression =
 fun x ->
  match x with
  | RangeExpression_StartRange_EndRange (a, b) ->
      let a = start_range a in
      let b = end_range b in
      RangeExpression_StartRange_EndRange (a, b)
  | RangeExpression_StartRange_MINUS a ->
      let a = start_range a in
      RangeExpression_StartRange_MINUS a

and start_range : CST.start_range -> start_range =
 fun x ->
  match x with
  | StartRange_EndRange_MINUS a ->
      let a = end_range a in
      StartRange_EndRange_MINUS a

and end_range : CST.end_range -> end_range =
 fun x ->
  match x with
  | EndRange_COLLELEMSINGLE a -> EndRange_COLLELEMSINGLE a
  | EndRangeCollatingSymbol a ->
      let a = collating_symbol a in
      EndRangeCollatingSymbol a

and collating_symbol : CST.collating_symbol -> collating_symbol =
 fun x ->
  match x with
  | CollatingSymbol_OpenDot_COLLELEMSINGLE_DotClose a ->
      CollatingSymbol_OpenDot_COLLELEMSINGLE_DotClose a
  | CollatingSymbol_OpenDot_COLLELEMMULTI_DotClose a ->
      CollatingSymbol_OpenDot_COLLELEMMULTI_DotClose a
  | CollatingSymbol_OpenDot_METACHAR_DotClose a ->
      CollatingSymbol_OpenDot_METACHAR_DotClose a

and equivalence_class : CST.equivalence_class -> equivalence_class =
 fun x ->
  match x with
  | EquivalenceClass_OpenEqual_COLLELEMSINGLE_EqualClose a ->
      EquivalenceClass_OpenEqual_COLLELEMSINGLE_EqualClose a
  | EquivalenceClass_OpenEqual_COLLELEMMULTI_EqualClose a ->
      EquivalenceClass_OpenEqual_COLLELEMMULTI_EqualClose a

and character_class : CST.character_class -> character_class =
 fun x ->
  match x with
  | CharacterClass_OpenColon_CLASSNAME_ColonClose a ->
      let a = class_name a in
      CharacterClass_OpenColon_CLASSNAME_ColonClose a

and class_name : CST.class_name -> class_name =
 fun x -> match x with ClassName a -> ClassName a

and variable : CST.variable -> variable =
 fun x ->
  match x with
  | VariableAtom (a, b) ->
      let b = variable_attribute b in
      VariableAtom (a, b)

and variable_attribute : CST.variable_attribute -> variable_attribute =
 fun x ->
  match x with
  | NoAttribute -> NoAttribute
  | ParameterLength -> ParameterLength
  | UseDefaultValues (a, b) ->
      let b = word b in
      UseDefaultValues (a, b)
  | AssignDefaultValues (a, b) ->
      let b = word b in
      AssignDefaultValues (a, b)
  | IndicateErrorifNullorUnset (a, b) ->
      let b = word b in
      IndicateErrorifNullorUnset (a, b)
  | UseAlternativeValue (a, b) ->
      let b = word b in
      UseAlternativeValue (a, b)
  | RemoveSmallestSuffixPattern a ->
      let a = word a in
      RemoveSmallestSuffixPattern a
  | RemoveLargestSuffixPattern a ->
      let a = word a in
      RemoveLargestSuffixPattern a
  | RemoveSmallestPrefixPattern a ->
      let a = word a in
      RemoveSmallestPrefixPattern a
  | RemoveLargestPrefixPattern a ->
      let a = word a in
      RemoveLargestPrefixPattern a

and name : CST.name -> name = fun x -> match x with Name a -> Name a

and assignment_word : CST.assignment_word -> assignment_word =
 fun (a, b) ->
  let a = name a in
  let b = word b in
  (a, b)

and io_number : CST.io_number -> io_number =
 fun x -> match x with IONumber a -> int_of_string a

let of_program = program

module Dump = struct
  let pp ppf v =
    let yjs = complete_commands_to_yojson v in
    Yojson.Safe.pretty_print ppf yjs
end

let () =
  Printexc.register_printer (function
    | Morbig.Errors.DuringParsing pos ->
        Some
          (Fmt.str "Error during parsing (potentially non-POSIX): %s"
             (Morbig.string_of_lexing_position pos))
    | Morbig.Errors.DuringLexing (pos, s) ->
        Some
          (Fmt.str "Error during lexing of \"%s\": %s" s
             (Morbig.string_of_lexing_position pos))
    | Morbig.Errors.DuringAliasing (pos, s) ->
        Some
          (Fmt.str "Error during aliasing of \"%s\": %s" s
             (Morbig.string_of_lexing_position pos))
    | _ -> None)

let of_string ?(filename = "-") s =
  let f = Morbig.parse_string filename s in
  of_program f

let of_file path =
  let fname = Eio.Path.native_exn path in
  Eio.Path.load path |> of_string ~filename:fname

let rec word_component_to_string :
    ?field_splitting:bool -> word_component -> string list =
 fun ?(field_splitting = true) -> function
  | WordName s -> [ s ]
  | WordLiteral s -> [ s ]
  | WordDoubleQuoted s -> word_components_to_strings ~field_splitting:false s
  | WordSingleQuoted s -> word_components_to_strings ~field_splitting:false s
  | WordGlobAll -> [ "*" ]
  | WordGlobAny -> [ "?" ]
  | WordEmpty -> [ "" ]
  | WordAssignmentWord (Name p, v) ->
      p :: "=" :: word_components_to_strings ~field_splitting v
  | WordSubshell _ ->
      Fmt.failwith
        "This is an error in Merry, subshells should already have been \
         expanded by now!"
  | v ->
      Fmt.failwith "conversion of %a" Yojson.Safe.pp
        (word_component_to_yojson v)

and word_components_to_strings ?(field_splitting = true) ws =
  if field_splitting then
    List.concat_map (word_component_to_string ~field_splitting) ws
  else
    [
      String.concat ""
        (List.concat_map (word_component_to_string ~field_splitting) ws);
    ]

class check_ast =
  object (_)
    inherit [bool] Sast.fold
    method int _ ctx = ctx
    method bool _ ctx = ctx
    method string _ ctx = ctx
    method char _ ctx = ctx
    method option f v ctx = Option.fold ~none:ctx ~some:(fun i -> f i ctx) v
    method nlist__t f v ctx = Nlist.fold_left (fun acc i -> f i acc) ctx v

    method nslist__t f g v ctx =
      Nslist.fold_left (fun acc a b -> f a acc |> g b) ctx v

    method list f v ctx = List.fold_left (fun acc i -> f i acc) ctx v
  end

let has_async ast =
  let o =
    object
      inherit check_ast as super

      method! complete_command v ctx =
        match v with
        | _, Some Ampersand -> true
        | _ -> super#complete_command v ctx

      method! clist l ctx =
        let v =
          Nlist.to_list l
          |> List.exists (function _, Ampersand -> true | _ -> false)
        in
        if v then v else super#clist l ctx

      method! term t ctx =
        let v =
          Nlist.to_list t
          |> List.exists (function _, Ampersand -> true | _ -> false)
        in
        if v then v else super#term t ctx
    end
  in
  o#complete_command ast false

let has_glob ast =
  let o =
    object
      inherit check_ast as super

      method! word_component v ctx =
        match v with
        | WordGlobAll | WordGlobAny -> true
        | _ -> super#word_component v ctx
    end
  in
  o#word_cst ast false

module Fragment = struct
  let make ?(splittable = false) ?(globbable = false) ?(tilde_expansion = false)
      ?(join = `No) txt =
    { txt; splittable; join; globbable; tilde_expansion }

  let empty = make ""
  let to_string { txt; _ } = txt

  let join ~sep f1 f2 =
    {
      f1 with
      txt = f1.txt ^ sep ^ f2.txt;
      globbable = f1.globbable || f2.globbable;
    }

  let join_list ~sep fs = List.fold_left (join ~sep) empty fs |> to_string

  let pp_join ppf = function
    | `No -> Fmt.pf ppf "no"
    | `With_previous -> Fmt.pf ppf "with-previous"
    | `With_next -> Fmt.pf ppf "with-next"

  let pp ppf { txt; join; splittable; globbable; tilde_expansion } =
    Fmt.pf ppf
      "{ txt = %s; join = %a; splittable = %b; globbable = %b; tilde_expansion \
       = %b }"
      txt pp_join join splittable globbable tilde_expansion

  let handle_joins cst =
    let rec loop = function
      | [] -> []
      | [ x ] -> [ { x with join = `No } ]
      | x :: { txt; join = `With_previous; globbable; _ } :: rest ->
          loop
            ({
               x with
               join = `No;
               txt = x.txt ^ txt;
               globbable = x.globbable || globbable;
             }
            :: rest)
      | { txt; join = `With_next; globbable; _ } :: y :: rest ->
          { y with txt = txt ^ y.txt; globbable = globbable || y.globbable }
          :: loop rest
      | x :: xs -> x :: loop xs
    in
    let v = loop cst in
    let has_a_tilde = List.exists (fun f -> f.tilde_expansion) v in
    let v =
      if has_a_tilde then [ List.fold_left (join ~sep:"") empty v ] else v
    in
    (* TODO: Blergh, this is horrible, surely there is a better way? Maybe morbig
       should not parse these separately... *)
    let rec recombine_equals = function
      | [] -> []
      | [ x ] -> [ x ]
      | ({ txt; _ } as x) :: y :: rest -> (
          let s = String.length txt in
          match String.get txt (s - 1) with
          | '=' -> { y with txt = txt ^ y.txt } :: recombine_equals rest
          | (exception Invalid_argument _) | _ ->
              x :: recombine_equals (y :: rest))
    in
    recombine_equals v
end