Haskell.hs

{-
    BNF Converter: Haskell main file
    Copyright (C) 2004  Author:  Markus Forsberg, Peter Gammie, Aarne Ranta

-}

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

module BNFC.Backend.Haskell (makeHaskell, AlexVersion(..), makefile, testfile) where

import qualified Control.Monad as Ctrl
import Data.Maybe      (isJust)
import System.FilePath ((<.>), (</>), pathSeparator)
import Text.Printf     (printf)
import Text.PrettyPrint

import BNFC.Backend.Agda
import BNFC.Backend.Base
import BNFC.Backend.Haskell.CFtoHappy
import BNFC.Backend.Haskell.CFtoAlex3
import BNFC.Backend.Haskell.CFtoAbstract
import BNFC.Backend.Haskell.CFtoTemplate
import BNFC.Backend.Haskell.CFtoPrinter
import BNFC.Backend.Haskell.CFtoLayout
import BNFC.Backend.Haskell.HsOpts
import BNFC.Backend.Haskell.MkErrM
import BNFC.Backend.Haskell.Utils
import BNFC.Backend.Txt2Tag
import BNFC.Backend.XML (makeXML)
import qualified BNFC.Backend.Common.Makefile as Makefile

import BNFC.CF
import BNFC.Options
  ( SharedOptions(..), TokenText(..), AlexVersion(..), HappyMode(..)
  , isDefault, printOptions
  )
import BNFC.Utils (when, table, getZonedTimeTruncatedToSeconds)


-- | Entrypoint for the Haskell backend.

makeHaskell :: SharedOptions -> CF -> Backend
makeHaskell opts cf = do
  -- Get current time in printable form.
  time <- liftIO $ show <$> getZonedTimeTruncatedToSeconds

  let absMod = absFileM opts
      lexMod = alexFileM opts
      parMod = happyFileM opts
      prMod  = printerFileM opts
      layMod = layoutFileM opts
      errMod = errFileM opts
  do
    -- Generate abstract syntax and pretty printer.
    mkfile (absFile opts) comment $ cf2Abstract opts absMod cf
    mkfile (printerFile opts) comment $ cf2Printer (tokenText opts) (functor opts) False prMod absMod cf

    -- Generate Alex lexer.  Layout is resolved after lexing.
    case alexMode opts of
      Alex3 -> do
        mkfile (alexFile opts) commentWithEmacsModeHint $ cf2alex3 lexMod (tokenText opts) cf
        liftIO $ printf "Use Alex 3 to compile %s.\n" (alexFile opts)

    Ctrl.when (hasLayout cf) $ mkfile (layoutFile opts) comment $
      cf2Layout layMod lexMod cf

    -- Generate Happy parser and matching test program.
    do
      mkfile (happyFile opts) commentWithEmacsModeHint $
        cf2Happy parMod absMod lexMod (glr opts) (tokenText opts) (functor opts) cf
      -- liftIO $ printf "%s Tested with Happy 1.15\n" (happyFile opts)
      mkfile (tFile opts) comment $ testfile opts cf

    -- Both Happy parser and skeleton (template) rely on Err.
    mkfile (errFile opts) comment $ mkErrM errMod
    mkfile (templateFile opts) comment $ cf2Template (templateFileM opts) absMod (functor opts) cf

    -- Generate txt2tags documentation.
    mkfile (txtFile opts) t2tComment $ cfToTxt (lang opts) cf

    -- Generate XML and DTD printers.
    case xml opts of
      2 -> makeXML opts True cf
      1 -> makeXML opts False cf
      _ -> return ()

    -- Generate Agda bindings for AST, Printer and Parser.
    Ctrl.when (agda opts) $ makeAgda time opts cf

    -- Generate Makefile.
    Makefile.mkMakefile opts $ makefile opts cf


-- | Generate the makefile (old version, with just one "all" target).
_oldMakefile
  :: Options
  -> String    -- ^ Filename of the makefile.
  -> Doc       -- ^ Content of the makefile.
_oldMakefile opts makeFile = vcat
  [ Makefile.mkRule "all" [] $ concat $
      [ [ unwords $ [ "happy -gca" ] ++ glrParams ++ [ happyFile opts ] ]
      , [ "alex -g " ++ alexFile opts ]
      ]
  , cleanRule opts
  , distCleanRule opts makeFile
  ]
  where
  glrParams :: [String]
  glrParams = when (glr opts == GLR) $ [ "--glr", "--decode" ]

-- | Rule to clean GHC and Latex generated files.
cleanRule :: Options -> Doc
cleanRule opts = Makefile.mkRule "clean" [] $ concat $
  [ [ rmGen ]
  , when (agda opts) rmAgda
  ]
  where
  rmGen  = unwords $ [ "-rm", "-f" ] ++ map prefix gen
  gen    = concat [ genHs, genLtx, genAg ]
  genHs  = [ "*.hi", "*.o" ]
  genLtx = [ "*.log", "*.aux", "*.dvi" ]
  genAg  = when (agda opts) $ [ "*.agdai" ]
  rmAgda = [ "-rm -rf MAlonzo" ]
  prefix = if null dir then id else (dir </>)
  dir    = codeDir opts

-- | Rule to clean all files generated by BNFC and the subsequent tools.
distCleanRule :: Options -> String -> Doc
distCleanRule opts makeFile = Makefile.mkRule "distclean" ["clean"] $
  [ unwords . concat $
    [ [ "-rm -f" ]
      -- Generated files that have a .bak variant
    , concatMap (\ f -> alsoBak (f opts))
      [ absFile        -- Abs.hs
      , composOpFile   -- ComposOp.hs
      , txtFile        -- Doc.txt
      , errFile        -- ErrM.hs
      , layoutFile     -- Layout.hs
      , alexFile       -- Lex.x
      , happyFile      -- Par.y
      , printerFile    -- Print.hs
      , templateFile   -- Skel.hs
      , tFile          -- Test.hs
      , xmlFile        -- XML.hs
      , agdaASTFile    -- AST.agda
      , agdaParserFile -- Parser.agda
      , agdaLibFile    -- IOLib.agda
      , agdaMainFile   -- Main.agda
      , (\ opts -> dir ++ lang opts ++ ".dtd")
      ]
      -- Files that have no .bak variant
    , map (\ (file, ext) -> mkFile withLang file ext opts)
      [ ("Test"    , "")
      , ("Lex"     , "hs")
      , ("Par"     , "hs")
      , ("Par"     , "info")
      , ("ParData" , "hs")  -- only if --glr
      ]
    , [ "Main" | agda opts ]
    , [ makeFile ]
    ]
  , if null dir then "" else "-rmdir -p " ++ dir
  ]
  where
  dir = let d = codeDir opts in if null d then "" else d ++ [pathSeparator]

  alsoBak :: FilePath -> [FilePath]
  alsoBak s = [ s, s <.> "bak" ]

makefileHeader :: Options -> Doc
makefileHeader Options{ agda, glr } = vcat
  [ "# Makefile for building the parser and test program."
  , ""
  , when agda $
    "AGDA       = agda"
  , "GHC        = ghc"
  , "HAPPY      = happy"
  , hsep $ concat
    [ [ "HAPPY_OPTS = --array --info" ]
    , if glr == GLR
      then [ "--glr --decode" ]
      else [ "--ghc --coerce" ]
        -- These options currently (2021-02-14) do not work with GLR mode
        -- see https://github.com/simonmar/happy/issues/173
    ]
  , "ALEX       = alex"
  , "ALEX_OPTS  = --ghc"
  , ""
  ]


-- | Generate the makefile.
makefile
  :: Options
  -> CF
  -> String    -- ^ Filename of the makefile.
  -> Doc       -- ^ Content of the makefile.
makefile opts cf makeFile = vcat
  [ makefileHeader opts
  , phonyRule
  , defaultRule
  , vcat [ "# Rules for building the parser." , "" ]
  -- If option -o was given, we have no access to the grammar file
  -- from the Makefile.  Thus, we have to drop the rule for
  -- reinvokation of bnfc.
  , when (isDefault outDir opts) $ bnfcRule
  , happyRule
  , alexRule
  , testParserRule
  , when (agda opts) $ agdaRule
  , vcat [ "# Rules for cleaning generated files." , "" ]
  , cleanRule opts
  , distCleanRule opts makeFile
  , "# EOF"
  ]
  where
  -- | List non-file targets here.
  phonyRule :: Doc
  phonyRule = vcat
    [ "# List of goals not corresponding to file names."
    , ""
    , Makefile.mkRule ".PHONY" [ "all", "clean", "distclean" ] []
    ]
  -- | Default: build test parser(s).
  defaultRule :: Doc
  defaultRule = vcat
     [ "# Default goal."
     , ""
     , Makefile.mkRule "all" tgts []
     ]
     where
     tgts = concat $
              [ [ tFileExe opts ]
              , [ "Main" | agda opts ]
              ]

  -- | Rule to reinvoke @bnfc@ to updated parser.
  --   Reinvokation should not recreate @Makefile@!
  bnfcRule :: Doc
  bnfcRule = Makefile.mkRule tgts [ lbnfFile opts ] [ recipe ]
    where
    recipe    = unwords [ "bnfc", printOptions opts{ make = Nothing } ]
    tgts      = unwords . map ($ opts) . concat $
      [ [ absFile ]
      , [ layoutFile | lay ]
      , [ alexFile, happyFile, printerFile, tFile ]
      , when (agda opts)
        [ agdaASTFile, agdaParserFile, agdaLibFile, agdaMainFile ]
      ]

  lay :: Bool
  lay = hasLayout cf

  -- | Rule to invoke @happy@.
  happyRule :: Doc
  happyRule = Makefile.mkRule "%.hs" [ "%.y" ] [ "${HAPPY} ${HAPPY_OPTS} $<" ]

  -- | Rule to invoke @alex@.
  alexRule :: Doc
  alexRule = Makefile.mkRule "%.hs" [ "%.x" ] [ "${ALEX} ${ALEX_OPTS} $<" ]

  -- | Rule to build Haskell test parser.
  testParserRule :: Doc
  testParserRule = Makefile.mkRule tgt deps [ "${GHC} ${GHC_OPTS} $@" ]
    where
    tgt :: String
    tgt = tFileExe opts
    deps :: [String]
    deps = map ($ opts) $ concat
      [ [ absFile ]
      , [ layoutFile | lay ]
      , [ alexFileHs
        , happyFileHs
        , printerFile
        , tFile
        ]
      ]

  -- | Rule to build Agda parser.
  agdaRule :: Doc
  agdaRule = Makefile.mkRule "Main" deps [ "${AGDA} --no-libraries --ghc --ghc-flag=-Wwarn $<" ]
    where
    deps = map ($ opts) $ concat
      [ [ agdaMainFile  -- must be first!
        , agdaASTFile
        , agdaParserFile
        , agdaLibFile
        -- Haskell modules bound by Agda modules:
        , errFile
        ]
      , [ layoutFile | lay ]
      , [ alexFileHs
        , happyFileHs
        , printerFile
        ]
      ]

testfile :: Options -> CF -> String
testfile opts cf = unlines $ concat $
  [ [ "-- | Program to test parser."
    , ""
    , "module Main where"
    , ""
    , "import Prelude"
    , "  ( ($), (.)"
    ]
  , [ "  , Bool(..)" | lay ]
  , [ "  , Either(..)"
    , "  , Int, (>)"
    , "  , String, (++), concat, unlines"
    , "  , Show, show"
    , "  , IO, (>>), (>>=), mapM_, putStrLn"
    , "  , FilePath"
    ]
  , [ "  , getContents, readFile" | tokenText opts == StringToken ]
  , [ "  , error, flip, map, replicate, sequence_, zip" | use_glr ]
  , [ "  )" ]
  , case tokenText opts of
      StringToken -> []
      TextToken ->
        [ "import Data.Text.IO   ( getContents, readFile )"
        , "import qualified Data.Text"
        ]
      ByteStringToken ->
        [ "import Data.ByteString.Char8 ( getContents, readFile )"
        , "import qualified Data.ByteString.Char8 as BS"
        ]
  , [ "import System.Environment ( getArgs )"
    , "import System.Exit        ( exitFailure )"
    , "import Control.Monad      ( when )"
    , ""
    ]
  , table "" $ concat
    [ [ [ "import " , absFileM      opts , " (" ++ if_glr impTopCat ++ ")" ] ]
    , [ [ "import " , layoutFileM   opts , " ( resolveLayout )"      ] | lay     ]
    , [ [ "import " , alexFileM     opts , " ( Token, mkPosToken )"              ]
      , [ "import " , happyFileM    opts , " ( " ++ impParser ++ ", myLexer" ++ impParGLR ++ " )" ]
      , [ "import " , printerFileM  opts , " ( Print, printTree )"               ]
      , [ "import " , templateFileM opts , " ()"                                 ]
      ]
    , [ [ "import " , xmlFileM      opts , " ( XPrint, printXML )"   ] | use_xml ]
    ]
  , [ "import qualified Data.Map ( Map, lookup, toList )" | use_glr ]
  , [ "import Data.Maybe ( fromJust )"                    | use_glr ]
  , [ ""
    , "type Err        = Either String"
    , if use_glr
      then "type ParseFun a = [[Token]] -> (GLRResult, GLR_Output (Err a))"
      else "type ParseFun a = [Token] -> Err a"
    , "type Verbosity  = Int"
    , ""
    , "putStrV :: Verbosity -> String -> IO ()"
    , "putStrV v s = when (v > 1) $ putStrLn s"
    , ""
    , "runFile :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()"
    , "runFile v p f = putStrLn f >> readFile f >>= run v p"
    , ""
    , "run :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> " ++ tokenTextType (tokenText opts) ++ " -> IO ()"
    , (if use_glr then runGlr else runStd use_xml) myLLexer
    , "showTree :: (Show a, Print a) => Int -> a -> IO ()"
    , "showTree v tree = do"
    , "  putStrV v $ \"\\n[Abstract Syntax]\\n\\n\" ++ show tree"
    , "  putStrV v $ \"\\n[Linearized tree]\\n\\n\" ++ printTree tree"
    , ""
    , "usage :: IO ()"
    , "usage = do"
    , "  putStrLn $ unlines"
    , "    [ \"usage: Call with one of the following argument combinations:\""
    , "    , \"  --help          Display this help message.\""
    , "    , \"  (no arguments)  Parse stdin verbosely.\""
    , "    , \"  (files)         Parse content of files verbosely.\""
    , "    , \"  -s (files)      Silent mode. Parse content of files silently.\""
    , "    ]"
    , ""
    , "main :: IO ()"
    , "main = do"
    , "  args <- getArgs"
    , "  case args of"
    , "    [\"--help\"] -> usage"
    , "    []         -> getContents >>= run 2 " ++ firstParser
    , "    \"-s\":fs    -> mapM_ (runFile 0 " ++ firstParser ++ ") fs"
    , "    fs         -> mapM_ (runFile 2 " ++ firstParser ++ ") fs"
    , ""
    ]
  , if_glr $
    [ "the_parser :: ParseFun " ++ catToStr topType
    , "the_parser = lift_parser " ++ render (parserName topType)
    , ""
    , liftParser
    ]
  ]
  where
    lay         = isJust hasTopLevelLayout || not (null layoutKeywords)
    use_xml     = xml opts > 0
    xpr         = if use_xml then "XPrint a, "     else ""
    use_glr     = glr opts == GLR
    if_glr      :: Monoid a => a -> a
    if_glr      = when use_glr
    firstParser = if use_glr then "the_parser" else impParser
    impParser   = render (parserName topType)
    topType     = firstEntry cf
    impTopCat   = unwords [ "", identCat topType, "" ]
    impParGLR   = if_glr ", GLRResult(..), Branch, ForestId, TreeDecode(..), decode"
    myLLexer atom
      | lay     = unwords [ "resolveLayout", show useTopLevelLayout, "$ myLexer", atom]
      | True    = unwords [ "myLexer", atom]
    (hasTopLevelLayout, layoutKeywords, _) = layoutPragmas cf
    useTopLevelLayout = isJust hasTopLevelLayout

runStd :: Bool -> (String -> String) -> String
runStd xml myLLexer = unlines $ concat
 [ [ "run v p s ="
   , "  case p ts of"
   , "    Left err -> do"
   , "      putStrLn \"\\nParse              Failed...\\n\""
   , "      putStrV v \"Tokens:\""
   , "      mapM_ (putStrV v . showPosToken . mkPosToken) ts"
   -- , "      putStrV v $ show ts"
   , "      putStrLn err"
   , "      exitFailure"
   , "    Right tree -> do"
   , "      putStrLn \"\\nParse Successful!\""
   , "      showTree v tree"
   ]
 , [ "      putStrV v $ \"\\n[XML]\\n\\n\" ++ printXML tree" | xml ]
 , [ "  where"
   , "  ts = " ++ myLLexer "s"
   , "  showPosToken ((l,c),t) = concat [ show l, \":\", show c, \"\\t\", show t ]"
   ]
 ]

runGlr :: (String -> String) -> String
runGlr myLLexer
 = unlines
   [ "run v p s"
   , " = let ts = map (:[]) $ " ++ myLLexer "s"
   , "       (raw_output, simple_output) = p ts in"
   , "   case simple_output of"
   , "     GLR_Fail major minor -> do"
   , "                               putStrLn major"
   , "                               putStrV v minor"
   , "     GLR_Result df trees  -> do"
   , "                               putStrLn \"\\nParse Successful!\""
   , "                               case trees of"
   , "                                 []        -> error \"No results but parse succeeded?\""
   , "                                 [Right x] -> showTree v x"
   , "                                 xs@(_:_)  -> showSeveralTrees v xs"
   , "   where"
   , "  showSeveralTrees :: (Print b, Show b) => Int -> [Err b] -> IO ()"
   , "  showSeveralTrees v trees"
   , "   = sequence_ "
   , "     [ do putStrV v (replicate 40 '-')"
   , "          putStrV v $ \"Parse number: \" ++ show n"
   , "          showTree v t"
   , "     | (Right t,n) <- zip trees [1..]"
   , "     ]"
   ]

liftParser :: String
liftParser
 = unlines
   [ "type Forest = Data.Map.Map ForestId [Branch]      -- omitted in ParX export."
   , "data GLR_Output a"
   , " = GLR_Result { pruned_decode     :: (Forest -> Forest) -> [a]"
   , "              , semantic_result   :: [a]"
   , "              }"
   , " | GLR_Fail   { main_message :: String"
   , "              , extra_info   :: String"
   , "              }"
   , ""
   , "lift_parser"
   , " :: (TreeDecode a, Show a, Print a)"
   , " => ([[Token]] -> GLRResult) -> ParseFun a"
   , "lift_parser parser ts"
   , " = let result = parser ts in"
   , "   (\\o -> (result, o)) $"
   , "   case result of"
   , "     ParseError ts f -> GLR_Fail \"Parse failed, unexpected token(s)\\n\""
   , "                                 (\"Tokens: \" ++ show ts)"
   , "     ParseEOF   f    -> GLR_Fail \"Parse failed, unexpected EOF\\n\""
   , "                                 (\"Partial forest:\\n\""
   , "                                    ++ unlines (map show $ Data.Map.toList f))"
   , "     ParseOK r f     -> let find   f = fromJust . ((flip Data.Map.lookup) f)"
   , "                            dec_fn f = decode (find f) r"
   , "                        in GLR_Result (\\ff -> dec_fn $ ff f) (dec_fn f)"
   ]