(* ==================================================================
   Cours 3 (suite) : La monade Parsec
   ================================================================== *)

(* Un analyseur (parser) prend une liste de caractères et retourne
   la liste de toutes les réussites, chacune étant un couple
   (valeur analysée, reste de la liste).  La liste vide = échec.
   Le lien avec la monade Liste est direct. *)

type 'a parser = char list -> ('a * char list) list

(* --- Opérations monadiques --- *)

(* return x : réussit avec x sans rien consommer *)
let return x = fun input -> [x, input]

(* bind p f : analyse avec p, puis applique f au résultat *)
let (>>=) (p : 'a parser) (f : 'a -> 'b parser) : 'b parser =
  fun input ->
    List.concat_map (fun (x, reste) -> f x reste) (p input)

(* fail : échoue toujours *)
let fail = fun _ -> []

(* --- Combinateurs de base --- *)

(* any : consume et réussit avec le premier caractère (s'il existe) *)
let any : char parser = function
  | [] -> []
  | c :: cs -> [c, cs]

(* satisfy p : réussit si le premier car. vérifie le prédicat p *)
let satisfy p =
  any >>= fun c ->
  if p c then return c else fail

(* char c : analyse un caractère précis *)
let char c =
  satisfy (fun x -> x = c)

(* string s : analyse une chaîne précise *)
let string s =
  let chars = List.of_seq (String.to_seq s) in
  let rec aux = function
    | [] -> return ()
    | c :: cs ->
      char c >>= fun _ ->
      aux cs
  in
  aux chars >>= fun _ -> return s

(* --- Combinateurs de composition --- *)

(* seq p1 p2 : applique p1 puis p2, retourne la paire *)
let seq p1 p2 =
  p1 >>= fun x1 ->
  p2 >>= fun x2 ->
  return (x1, x2)

(* alt p1 p2 : essaie p1, si échec essaie p2 *)
let alt p1 p2 =
  fun input ->
    match p1 input with
    | [] -> p2 input
    | res -> res

(* option p : zéro ou une occurrence de p *)
let option p =
  alt (p >>= fun x -> return (Some x)) (return None)

(* rep p : répétition de p (zéro ou plus) — liste des résultats *)
let rec rep p =
  alt (p >>= fun x ->
       rep p >>= fun xs ->
       return (x :: xs))
      (return [])

(* rep1 p : répétition (une ou plus) *)
let rep1 p =
  p >>= fun x ->
  rep p >>= fun xs ->
  return (x :: xs)

(* map f p : applique f au résultat de p *)
let map f p =
  p >>= fun x -> return (f x)

(* --- Simplifications pour l'écriture — versions infixes --- *)

(* ( *> ) : enchaîne mais ne garde que le résultat de droite *)
let ( *> ) p1 p2 =
  p1 >>= fun _ -> p2

(* ( <* ) : enchaîne mais ne garde que le résultat de gauche *)
let ( <* ) p1 p2 =
  p1 >>= fun x -> p2 >>= fun _ -> return x

(* ( <|> ) : alternative infixe *)
let ( <|> ) = alt

(* between p1 p2 p3 : p1 puis p3 puis p2, retourne le résultat de p3 *)
let between p1 p2 p3 =
  p1 *> p3 <* p2


(* ==================================================================
   Exemples : on retrouve les expressions régulières
   ================================================================== *)

(* --- Exemple 1 : un chiffre décimal --- *)
let digit : char parser =
  satisfy (fun c -> c >= '0' && c <= '9')

let decimal : string parser =
  rep1 digit >>= fun cs ->
  return (String.of_seq (List.to_seq cs))
(* decimal "123abc" = [("123", ['a';'b';'c'])] *)

(* --- Exemple 2 : un entier signé --- *)
let signe : char option parser =
  option (char '-')

let entier : string parser =
  signe >>= fun sgn ->
  decimal >>= fun d ->
  return (match sgn with None -> d | Some _ -> "-" ^ d)
(* entier "-42abc" = [("-42", ['a';'b';'c'])] *)

(* --- Exemple 3 : un nombre flottant --- *)
let flottant : string parser =
  entier >>= fun partie_entiere ->
  option (char '.' *> decimal) >>= fun partie_decimale ->
  option (char 'e' *> entier <|> char 'E' *> entier) >>= fun exposant ->
  return (partie_entiere ^
          (match partie_decimale with None -> "" | Some d -> "." ^ d) ^
          (match exposant with None -> "" | Some e -> "e" ^ e))
(* flottant "3.14e-10" = [("3.14e-10", [])] *)

(* --- Exemple 4 : un identifiant [a-z][a-z0-9]* --- *)
let lettre : char parser =
  satisfy (fun c -> (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'))

let alphanum : char parser =
  lettre <|> digit

let identifiant : string parser =
  lettre >>= fun premiere ->
  rep alphanum >>= fun suivantes ->
  return (String.make 1 premiere ^ String.of_seq (List.to_seq suivantes))
(* identifiant "abc123 def" = [("abc123", [' ';'d';'e';'f'])] *)

(* --- Exemple 5 : séquence d'identifiants séparés par des virgules --- *)
let ws : unit parser =           (* white space optionnel *)
  rep (satisfy (fun c -> c = ' ' || c = '\t' || c = '\n')) *> return ()

let token p =                    (* ignore les espaces autour *)
  ws *> p <* ws

let ident_token = token identifiant

let rec sep_by p sep =
  alt (p >>= fun x ->
       sep *> sep_by p sep >>= fun xs ->
       return (x :: xs))
      (p >>= fun x -> return [x])

let liste_identifiants : string list parser =
  sep_by ident_token (char ',')
(* liste_identifiants "abc, def, ghi" = [(["abc"; "def"; "ghi"], [])] *)

(* --- Exemple 6 : parentheses équilibrées --- *)
let rec parentheses input =
  (char '(' *>
   rep parentheses >>= fun _ ->
   char ')' *>
   return "()") input
(* parentheses "(()())" =
   [("()", "()"); ("()", "()")]
   Il y a deux analyses possibles ! *)

(* --- Exemple 7 : un petit langage arithmétique --- *)
(* Expression : somme de produits *)
(*   expr    = terme (('+'|'-') terme)*
     terme   = facteur (('*'|'/') facteur)*
     facteur = entier | '(' expr ')' *)

let addop = char '+' <|> char '-'
let mulop = char '*' <|> char '/'

let rec expr input =
  (terme >>= fun x ->
   rep (addop >>= fun op ->
        terme >>= fun y ->
        return (fun gauche -> (String.make 1 op) ^ "(" ^ gauche ^ "," ^ y ^ ")")) >>= fun ops ->
   return (List.fold_left (fun acc f -> f acc) x ops)) input

and terme input =
  (facteur >>= fun x ->
   rep (mulop >>= fun op ->
        facteur >>= fun y ->
        return (fun gauche -> (String.make 1 op) ^ "(" ^ gauche ^ "," ^ y ^ ")")) >>= fun ops ->
   return (List.fold_left (fun acc f -> f acc) x ops)) input

and facteur input =
  ((entier >>= fun n -> return ("Num(" ^ n ^ ")")) <|>
   (char '(' *> expr <* char ')')) input
(* expr "1+2*3" =
   [("+(Num(1),*(Num(2),Num(3)))", [])]  *)

(* --- Exemple 8 : analyseur déterministe (alt choisit la première réussite) --- *)
(* Avec alt déterministe, une seule analyse est retournée. *)
let rec un_plus_plus input =
  (alt (char 'a' >>= fun _ ->
        un_plus_plus >>= fun s ->
        return ("a+" ^ s))
       (char 'a' >>= fun _ -> return "a")) input
(* un_plus_plus "aaa" = "a+a+a" (alt court-circuite) *)

(* --- Exemple 9 : expression régulière classique --- *)
(* a(b|c)*d *)
let regex_abcd : string parser =
  char 'a' *>
  rep (char 'b' <|> char 'c') >>= fun mid ->
  char 'd' *>
  return ("a" ^ String.of_seq (List.to_seq mid) ^ "d")
(* regex_abcd "abcd" = [("abcd", [])]
   regex_abcd "accbd" = [("accbd", [])]
   regex_abcd "abd" = [("abd", [])]
   regex_abcd "ad" = [("ad", [])]
   regex_abcd "axd" = [] *)

(* --- Exemple 10 : parser un CSV simple --- *)
let cellule : string parser =
  rep (satisfy (fun c -> c != ',' && c != '\n')) >>= fun cs ->
  return (String.of_seq (List.to_seq cs))

let ligne : string list parser =
  sep_by cellule (char ',')

let csv : string list list parser =
  sep_by ligne (char '\n')

(* csv "a,b,c\nd,e,f" = [([["a";"b";"c"]; ["d";"e";"f"]], [])] *)


(* ==================================================================
   Tests
   ================================================================== *)

let affiche_res titre affiche = function
  | [] -> Printf.printf "%s  =  [] (échec)\n" titre
  | res ->
    List.iteri (fun i (x, reste) ->
      let r = String.of_seq (List.to_seq reste) in
      Printf.printf "%s#%d  =  (%s, %S)\n" titre i (affiche x) r
    ) res

let () =
  Printf.printf "\n=== La monade Parsec ===\n\n";
  Printf.printf "  type 'a parser = char list -> ('a * char list) list\n\n";

  Printf.printf "--- 1. any ---\n";
  affiche_res "any \"hello\"" (String.make 1) (any (List.of_seq (String.to_seq "hello")));

  Printf.printf "\n--- 2. char 'a' ---\n";
  affiche_res "char 'a' \"abc\"" (String.make 1) (char 'a' (List.of_seq (String.to_seq "abc")));
  affiche_res "char 'a' \"xyz\"" (String.make 1) (char 'a' (List.of_seq (String.to_seq "xyz")));

  Printf.printf "\n--- 3. string \"abc\" ---\n";
  affiche_res "string \"abc\" \"abcdef\"" Fun.id (string "abc" (List.of_seq (String.to_seq "abcdef")));
  affiche_res "string \"abc\" \"abx\"" Fun.id (string "abc" (List.of_seq (String.to_seq "abx")));

  Printf.printf "\n--- 4. digit / decimal ---\n";
  affiche_res "decimal \"123abc\"" Fun.id (decimal (List.of_seq (String.to_seq "123abc")));
  affiche_res "decimal \"abc\"" Fun.id (decimal (List.of_seq (String.to_seq "abc")));

  Printf.printf "\n--- 5. entier signé ---\n";
  affiche_res "entier \"-42abc\"" Fun.id (entier (List.of_seq (String.to_seq "-42abc")));
  affiche_res "entier \"42abc\"" Fun.id (entier (List.of_seq (String.to_seq "42abc")));

  Printf.printf "\n--- 6. identifiant ---\n";
  affiche_res "identifiant \"abc123 def\"" Fun.id (identifiant (List.of_seq (String.to_seq "abc123 def")));

  Printf.printf "\n--- 7. liste d'identifiants ---\n";
  affiche_res "liste_identifiants ..." Fun.id
    (map (String.concat ";") liste_identifiants
       (List.of_seq (String.to_seq "abc, def, ghi")));

  Printf.printf "\n--- 9. regex a(b|c)*d ---\n";
  affiche_res "a(b|c)*d \"abcd\"" Fun.id (regex_abcd (List.of_seq (String.to_seq "abcd")));
  affiche_res "a(b|c)*d \"accbd\"" Fun.id (regex_abcd (List.of_seq (String.to_seq "accbd")));
  affiche_res "a(b|c)*d \"ad\"" Fun.id (regex_abcd (List.of_seq (String.to_seq "ad")));
  affiche_res "a(b|c)*d \"axd\"" Fun.id (regex_abcd (List.of_seq (String.to_seq "axd")));

  Printf.printf "\n--- 10. CSV ---\n";
  affiche_res "csv \"a,b,c\\nd,e,f\"" Fun.id
    (map (String.concat " ; ") (map (List.map (String.concat "|")) csv)
       (List.of_seq (String.to_seq "a,b,c\nd,e,f")));

  Printf.printf "\n--- 11. Expressions arithmétiques ---\n";
  affiche_res "expr \"1+2*3\"" Fun.id (expr (List.of_seq (String.to_seq "1+2*3")));
  affiche_res "expr \"(1+2)*3\"" Fun.id (expr (List.of_seq (String.to_seq "(1+2)*3")));

  Printf.printf "\n--- 12. Ambiguité de un_plus_plus \"aaa\" ---\n";
  List.iteri (fun i (s, _) ->
    Printf.printf "  analyse #%d : %s\n" i s
  ) (un_plus_plus (List.of_seq (String.to_seq "aaa")))