{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}

{-
    BNF Converter: Generate main/test module for OCaml
    Copyright (C) 2005  Author:  Kristofer Johannisson

-}

module BNFC.Backend.OCaml.CFtoOCamlTest where

import Prelude hiding ((<>))

import Text.PrettyPrint

import BNFC.CF
import BNFC.Options                        (OCamlParser(..))
import BNFC.Backend.OCaml.OCamlUtil
import BNFC.Backend.OCaml.CFtoOCamlYacc    (epName)
import BNFC.Backend.OCaml.CFtoOCamlPrinter (prtFun)
import BNFC.Backend.OCaml.CFtoOCamlShow    (showsFunQual)

-- | OCaml comment
-- >>> comment "I'm a comment"
-- (* I'm a comment *)
comment :: Doc -> Doc
comment :: Doc -> Doc
comment Doc
d = Doc
"(*" Doc -> Doc -> Doc
<+> Doc
d Doc -> Doc -> Doc
<+> Doc
"*)"

-- | Generate a test program in OCaml
ocamlTestfile :: OCamlParser -> String -> String -> String -> String -> String -> CF -> Doc
ocamlTestfile :: OCamlParser
-> String -> String -> String -> String -> String -> CF -> Doc
ocamlTestfile OCamlParser
ocamlParser String
absM String
lexM String
parM String
printM String
showM CF
cf =
    let
        cat :: Cat
cat         = CF -> Cat
firstEntry CF
cf
        qualify :: String -> String -> String
qualify String
q String
x = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
q, String
".", String
x ]
        lexerName :: Doc
lexerName   = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String -> String -> String
qualify String
lexM String
"token"
        parserName :: Doc
parserName  = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String -> String -> String
qualify String
parM (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Cat -> String
epName Cat
cat
        printerName :: Doc
printerName = [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Doc
text (String -> Doc) -> (String -> String) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
qualify String
printM) [ String
"printTree", Cat -> String
prtFun Cat
cat ]
        showFun :: Doc
showFun     = Doc -> Doc
parens (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
          [ Doc
"fun x ->"
          , String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String -> String -> String
qualify String
showM String
"show"
          , Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text ((String -> String) -> Cat -> String
showsFunQual (String -> String -> String
qualify String
showM) Cat
cat) Doc -> Doc -> Doc
<+> Doc
"x"
          ]
        topType :: Doc
topType     = String -> Doc
text (String -> Cat -> String
fixTypeQual String
absM (Cat -> String) -> Cat -> String
forall a b. (a -> b) -> a -> b
$ Cat -> Cat
normCat Cat
cat)
        exc :: Doc
exc         = case OCamlParser
ocamlParser of
          OCamlParser
OCamlYacc -> Doc
"Parsing.Parse_error"
          OCamlParser
Menhir    -> String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String -> String -> String
qualify String
parM String
"Error"
    in [Doc] -> Doc
vcat
        [ Doc
"open Lexing"
        , Doc
""
        , Doc
"let parse (c : in_channel) :" Doc -> Doc -> Doc
<+> Doc
topType Doc -> Doc -> Doc
<+> Doc
"="
        , Int -> Doc -> Doc
nest Int
4 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat
            [ Doc
"let lexbuf = Lexing.from_channel c"
            , Doc
"in"
            , Doc
"try"
            , Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep [ Doc
parserName, Doc
lexerName, Doc
"lexbuf" ]
            , Doc
"with"
            , Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep [ Doc
exc, Doc
"->" ]
            , Int -> Doc -> Doc
nest Int
4 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat
                [ Doc
"let start_pos = Lexing.lexeme_start_p lexbuf"
                , Doc
"and end_pos   = Lexing.lexeme_end_p   lexbuf"
                , Doc
"in  raise (BNFC_Util.Parse_error (start_pos, end_pos))"
                ]
            ]
        , Doc
";;"
        , Doc
""
        , Doc
"let showTree (t : " Doc -> Doc -> Doc
<> Doc
topType Doc -> Doc -> Doc
<> Doc
") : string ="
        , Int -> Doc -> Doc
nest Int
4 ([Doc] -> Doc
fsep ( Doc -> [Doc] -> [Doc]
punctuate Doc
"^"
            [ Doc -> Doc
doubleQuotes Doc
"[Abstract syntax]\\n\\n"
            , Doc
showFun Doc -> Doc -> Doc
<+> Doc
"t"
            , Doc -> Doc
doubleQuotes Doc
"\\n\\n"
            , Doc -> Doc
doubleQuotes Doc
"[Linearized tree]\\n\\n"
            , Doc
printerName Doc -> Doc -> Doc
<+> Doc
"t"
            , Doc -> Doc
doubleQuotes Doc
"\\n" ] ) )
        , Doc
";;"
        , Doc
""
        , Doc
"let main () ="
        , Int -> Doc -> Doc
nest Int
4 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat
            [ Doc
"let channel ="
            , Int -> Doc -> Doc
nest Int
4 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat
                [ Doc
"if Array.length Sys.argv > 1 then open_in Sys.argv.(1)"
                , Doc
"else stdin" ]
            , Doc
"in"
            , Doc
"try"
            , Int -> Doc -> Doc
nest Int
4 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat
                [ Doc
"print_string (showTree (parse channel));"
                , Doc
"flush stdout;"
                , Doc
"exit 0"]
            , Doc
"with BNFC_Util.Parse_error (start_pos, end_pos) ->"
            , Int -> Doc -> Doc
nest Int
4 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat
                [ Doc
"Printf.printf \"Parse error at %d.%d-%d.%d\\n\""
                , Int -> Doc -> Doc
nest Int
4 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat
                    -- Andreas, 2021-09-16, issue #380:
                    -- To have column counting start with 1 (and not with 0), we have to
                    -- add 1 to the difference between current offset and the offset of the
                    -- beginning of the line.
                    -- See e.g. https://github.com/let-def/ocamllex/blob/e5c8421f8fe56017e9b4e58c3496356631843802/lexer.mll#L54
                    [ Doc
"start_pos.pos_lnum (start_pos.pos_cnum - start_pos.pos_bol + 1)"
                    , Doc
"end_pos.pos_lnum (end_pos.pos_cnum - end_pos.pos_bol + 1);" ]
                , Doc
"exit 1" ]]
        , Doc
";;"
        , Doc
""
        , Doc
"main ();;" ]