{-# LANGUAGE NoImplicitPrelude #-}

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

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1335, USA
-}

module BNFC.Backend.OCaml.CFtoOCamlTest where

import Prelude'

import Text.PrettyPrint

import BNFC.CF
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 d = "(*" <+> d <+> "*)"

-- | OCaml String concatenation
-- >>> "print a" <^> doubleQuotes "abc"
-- print a ^ "abc"
a <^> b = a <+> "^" <+> b

-- | Generate a test program in OCaml
ocamlTestfile :: String -> String -> String -> String -> String -> CF -> Doc
ocamlTestfile absM lexM parM printM showM cf =
    let
        cat         = firstEntry cf
        qualify q x = concat [ q, ".", x ]
        lexerName   = text $ qualify lexM "token"
        parserName  = text $ qualify parM $ epName cat
        printerName = hsep $ map (text . qualify printM) [ "printTree", prtFun cat ]
        showFun     = parens . hsep $
          [ "fun x ->"
          , text $ qualify showM "show"
          , parens $ text (showsFunQual (qualify showM) cat) <+> "x"
          ]
        topType     = text absM <> "." <> text (fixType $ normCat cat)
    in vcat
        [ comment "automatically generated by the BNF Converter"
        , ""
        , "open Lexing"
        , ""
        , "let parse (c : in_channel) :" <+> topType <+> "="
        , nest 4 (parserName <+> lexerName <+> "(Lexing.from_channel c)")
        , ";;"
        , ""
        , "let showTree (t : " <> topType <> ") : string ="
        , nest 4 (fsep ( punctuate "^"
            [ doubleQuotes "[Abstract syntax]\\n\\n"
            , showFun <+> "t"
            , doubleQuotes "\\n\\n"
            , doubleQuotes "[Linearized tree]\\n\\n"
            , printerName <+> "t"
            , doubleQuotes "\\n" ] ) )
        , ";;"
        , ""
        , "let main () ="
        , nest 4 $ vcat
            [ "let channel ="
            , nest 4 $ vcat
                [ "if Array.length Sys.argv > 1 then open_in Sys.argv.(1)"
                , "else stdin" ]
            , "in"
            , "try"
            , nest 4 $ vcat
                [ "print_string (showTree (parse channel));"
                , "flush stdout;"
                , "exit 0"]
            , "with BNFC_Util.Parse_error (start_pos, end_pos) ->"
            , nest 4 $ vcat
                [ "Printf.printf \"Parse error at %d.%d-%d.%d\\n\""
                , nest 4 $ vcat
                    [ "start_pos.pos_lnum (start_pos.pos_cnum - start_pos.pos_bol)"
                    , "end_pos.pos_lnum (end_pos.pos_cnum - end_pos.pos_bol);" ]
                , "exit 1" ]]
        , ";;"
        , ""
        , "main ();;" ]
