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

-}

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

import qualified Control.Monad as Ctrl
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
import qualified BNFC.Backend.Common.Makefile as Makefile

import BNFC.CF
import BNFC.Options hiding (Backend)
import BNFC.Utils (when, unless, table, getZonedTimeTruncatedToSeconds)


-- | Entrypoint for the Haskell backend.

makeHaskell :: SharedOptions -> CF -> Backend
makeHaskell :: SharedOptions -> CF -> Backend
makeHaskell SharedOptions
opts CF
cf = do
  -- Get current time in printable form.
  time <- IO [Char] -> WriterT [([Char], [Char])] IO [Char]
forall a. IO a -> WriterT [([Char], [Char])] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> WriterT [([Char], [Char])] IO [Char])
-> IO [Char] -> WriterT [([Char], [Char])] IO [Char]
forall a b. (a -> b) -> a -> b
$ ZonedTime -> [Char]
forall a. Show a => a -> [Char]
show (ZonedTime -> [Char]) -> IO ZonedTime -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ZonedTime
getZonedTimeTruncatedToSeconds

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

    -- Generate Alex lexer.  Layout is resolved after lexing.
    case alexMode opts of
      AlexVersion
Alex3 -> do
        [Char] -> [Char] -> Backend
forall c. FileContent c => [Char] -> c -> Backend
mkfile (SharedOptions -> [Char]
alexFile SharedOptions
opts) ([Char] -> Backend) -> [Char] -> Backend
forall a b. (a -> b) -> a -> b
$ [Char] -> TokenText -> CF -> [Char]
cf2alex3 [Char]
lexMod (SharedOptions -> TokenText
tokenText SharedOptions
opts) CF
cf
        IO () -> Backend
forall a. IO a -> WriterT [([Char], [Char])] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Backend) -> IO () -> Backend
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
forall r. PrintfType r => [Char] -> r
printf [Char]
"Use Alex 3 to compile %s.\n" (SharedOptions -> [Char]
alexFile SharedOptions
opts)

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

    -- Generate Happy parser and matching test program.
    do
      mkfile (happyFile opts) $
        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)        $ testfile opts cf

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

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

    -- Generate XML and DTD printers.
    case xml opts of
      Int
2 -> SharedOptions -> Bool -> CF -> Backend
makeXML SharedOptions
opts Bool
True CF
cf
      Int
1 -> SharedOptions -> Bool -> CF -> Backend
makeXML SharedOptions
opts Bool
False CF
cf
      Int
_ -> () -> Backend
forall a. a -> WriterT [([Char], [Char])] IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

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


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

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

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

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

makefileHeader :: Doc
makefileHeader :: Doc
makefileHeader = [Doc] -> Doc
vcat
  [ Doc
"# Makefile generated by BNFC."
  , Doc
""
  ]


-- | Generate the makefile.
makefile
  :: Options
  -> String    -- ^ Filename of the makefile.
  -> Doc       -- ^ Content of the makefile.
makefile :: SharedOptions -> [Char] -> Doc
makefile SharedOptions
opts [Char]
makeFile = [Doc] -> Doc
vcat
  [ Doc
makefileHeader
  , Doc
phonyRule
  , Doc
defaultRule
  , [Doc] -> Doc
vcat [ Doc
"# Rules for building the parser." , Doc
"" ]
  -- 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.
  , Bool -> Doc -> Doc
forall m. Monoid m => Bool -> m -> m
when ((SharedOptions -> [Char]) -> SharedOptions -> Bool
forall a. Eq a => (SharedOptions -> a) -> SharedOptions -> Bool
isDefault SharedOptions -> [Char]
outDir SharedOptions
opts) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
bnfcRule
  , Doc
happyRule
  , Doc
alexRule
  , Doc
testParserRule
  , Bool -> Doc -> Doc
forall m. Monoid m => Bool -> m -> m
when (SharedOptions -> Bool
agda SharedOptions
opts) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
agdaRule
  , [Doc] -> Doc
vcat [ Doc
"# Rules for cleaning generated files." , Doc
"" ]
  , SharedOptions -> Doc
cleanRule SharedOptions
opts
  , SharedOptions -> [Char] -> Doc
distCleanRule SharedOptions
opts [Char]
makeFile
  , Doc
"# EOF"
  ]
  where
  -- | List non-file targets here.
  phonyRule :: Doc
  phonyRule :: Doc
phonyRule = [Doc] -> Doc
vcat
    [ Doc
"# List of goals not corresponding to file names."
    , Doc
""
    , [Char] -> [[Char]] -> [[Char]] -> Doc
Makefile.mkRule [Char]
".PHONY" [ [Char]
"all", [Char]
"clean", [Char]
"distclean" ] []
    ]
  -- | Default: build test parser(s).
  defaultRule :: Doc
  defaultRule :: Doc
defaultRule = [Doc] -> Doc
vcat
     [ Doc
"# Default goal."
     , Doc
""
     , [Char] -> [[Char]] -> [[Char]] -> Doc
Makefile.mkRule [Char]
"all" [[Char]]
tgts []
     ]
     where
     tgts :: [[Char]]
tgts = [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[Char]]] -> [[Char]]) -> [[[Char]]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$
              [ [ SharedOptions -> [Char]
tFileExe SharedOptions
opts ]
              , [ [Char]
"Main" | SharedOptions -> Bool
agda SharedOptions
opts ]
              ]

  -- | Rule to reinvoke @bnfc@ to updated parser.
  --   Reinvokation should not recreate @Makefile@!
  bnfcRule :: Doc
  bnfcRule :: Doc
bnfcRule = [Char] -> [[Char]] -> [[Char]] -> Doc
Makefile.mkRule [Char]
tgts [ SharedOptions -> [Char]
lbnfFile SharedOptions
opts ] [ [Char]
recipe ]
    where
    recipe :: [Char]
recipe    = [[Char]] -> [Char]
unwords [ [Char]
"bnfc", SharedOptions -> [Char]
printOptions SharedOptions
opts{ make = Nothing } ]
    tgts :: [Char]
tgts      = [[Char]] -> [Char]
unwords ([[Char]] -> [Char])
-> ([[[Char]]] -> [[Char]]) -> [[[Char]]] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[Char]]] -> [Char]) -> [[[Char]]] -> [Char]
forall a b. (a -> b) -> a -> b
$
      [ [[Char]]
alexEtc
      , [ SharedOptions -> [Char]
happyFile SharedOptions
opts, SharedOptions -> [Char]
tFile SharedOptions
opts ]
      , Bool -> [[Char]] -> [[Char]]
forall m. Monoid m => Bool -> m -> m
when (SharedOptions -> Bool
agda SharedOptions
opts) [[Char]]
agdaFiles
      ]
    alexEtc :: [[Char]]
alexEtc   = ((SharedOptions -> [Char]) -> [Char])
-> [SharedOptions -> [Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ((SharedOptions -> [Char]) -> SharedOptions -> [Char]
forall a b. (a -> b) -> a -> b
$ SharedOptions
opts) [ SharedOptions -> [Char]
errFile, SharedOptions -> [Char]
alexFile, SharedOptions -> [Char]
printerFile ]
    agdaFiles :: [[Char]]
agdaFiles = ((SharedOptions -> [Char]) -> [Char])
-> [SharedOptions -> [Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ((SharedOptions -> [Char]) -> SharedOptions -> [Char]
forall a b. (a -> b) -> a -> b
$ SharedOptions
opts) [ SharedOptions -> [Char]
agdaASTFile, SharedOptions -> [Char]
agdaParserFile, SharedOptions -> [Char]
agdaLibFile, SharedOptions -> [Char]
agdaMainFile ]

  -- | Rule to invoke @happy@.
  happyRule :: Doc
  happyRule :: Doc
happyRule = [Char] -> [[Char]] -> [[Char]] -> Doc
Makefile.mkRule [Char]
"%.hs" [ [Char]
"%.y" ] [ [Char]
recipe ]
    where
    recipe :: [Char]
recipe = [[Char]] -> [Char]
unwords ([[Char]] -> [Char])
-> ([[[Char]]] -> [[Char]]) -> [[[Char]]] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[Char]]] -> [Char]) -> [[[Char]]] -> [Char]
forall a b. (a -> b) -> a -> b
$
      [ [ [Char]
"happy", [Char]
"--ghc", [Char]
"--coerce", [Char]
"--array", [Char]
"--info" ]
      , Bool -> [[Char]] -> [[Char]]
forall m. Monoid m => Bool -> m -> m
when (SharedOptions -> HappyMode
glr SharedOptions
opts HappyMode -> HappyMode -> Bool
forall a. Eq a => a -> a -> Bool
== HappyMode
GLR) ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [ [Char]
"--glr", [Char]
"--decode" ]
      , [ [Char]
"$<" ]
      ]

  -- | Rule to invoke @alex@.
  alexRule :: Doc
  alexRule :: Doc
alexRule = [Char] -> [[Char]] -> [[Char]] -> Doc
Makefile.mkRule [Char]
"%.hs" [ [Char]
"%.x" ] [ [Char]
"alex --ghc $<" ]

  -- | Rule to build Haskell test parser.
  testParserRule :: Doc
  testParserRule :: Doc
testParserRule = [Char] -> [[Char]] -> [[Char]] -> Doc
Makefile.mkRule [Char]
tgt [[Char]]
deps [ [Char]
"ghc --make $< -o $@" ]
    where
    tgt :: String
    tgt :: [Char]
tgt = SharedOptions -> [Char]
tFileExe SharedOptions
opts
    deps :: [String]
    deps :: [[Char]]
deps = ((SharedOptions -> [Char]) -> [Char])
-> [SharedOptions -> [Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ((SharedOptions -> [Char]) -> SharedOptions -> [Char]
forall a b. (a -> b) -> a -> b
$ SharedOptions
opts)
      [ SharedOptions -> [Char]
tFile {- must be first! -}
      , SharedOptions -> [Char]
errFile
      , SharedOptions -> [Char]
alexFileHs
      , SharedOptions -> [Char]
happyFileHs
      , SharedOptions -> [Char]
printerFile
      ]

  -- | Rule to build Agda parser.
  agdaRule :: Doc
  agdaRule :: Doc
agdaRule = [Char] -> [[Char]] -> [[Char]] -> Doc
Makefile.mkRule [Char]
"Main" [[Char]]
deps [ [Char]
"agda --no-libraries --ghc --ghc-flag=-Wwarn $<" ]
    where
    deps :: [[Char]]
deps = ((SharedOptions -> [Char]) -> [Char])
-> [SharedOptions -> [Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ((SharedOptions -> [Char]) -> SharedOptions -> [Char]
forall a b. (a -> b) -> a -> b
$ SharedOptions
opts)
      [ SharedOptions -> [Char]
agdaMainFile  -- must be first!
      , SharedOptions -> [Char]
agdaASTFile
      , SharedOptions -> [Char]
agdaParserFile
      , SharedOptions -> [Char]
agdaLibFile
      -- Haskell modules bound by Agda modules:
      , SharedOptions -> [Char]
errFile
      , SharedOptions -> [Char]
alexFileHs
      , SharedOptions -> [Char]
happyFileHs
      , SharedOptions -> [Char]
printerFile
      ]

testfile :: Options -> CF -> String
testfile :: SharedOptions -> CF -> [Char]
testfile SharedOptions
opts CF
cf = [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[Char]]] -> [[Char]]) -> [[[Char]]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$
  [ [ [Char]
"-- Program to test parser, automatically generated by BNF Converter."
    , [Char]
""
    , [Char]
"module Main where"
    , [Char]
""
    ]
  , case SharedOptions -> TokenText
tokenText SharedOptions
opts of
      TokenText
StringToken -> []
      TokenText
TextToken ->
        [ [Char]
"import Prelude hiding ( getContents, readFile )"
        , [Char]
"import Data.Text.IO   ( getContents, readFile )"
        , [Char]
"import qualified Data.Text"
        ]
      TokenText
ByteStringToken ->
        [ [Char]
"import Prelude hiding        ( getContents, readFile )"
        , [Char]
"import Data.ByteString.Char8 ( getContents, readFile )"
        , [Char]
"import qualified Data.ByteString.Char8 as BS"
        ]
  , [ [Char]
"import System.Environment ( getArgs, getProgName )"
    , [Char]
"import System.Exit        ( exitFailure, exitSuccess )"
    , [Char]
"import Control.Monad      ( when )"
    , [Char]
""
    ]
  , [Char] -> [[[Char]]] -> [[Char]]
table [Char]
"" ([[[Char]]] -> [[Char]]) -> [[[Char]]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [[[[Char]]]] -> [[[Char]]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ [ [Char]
"import " , SharedOptions -> [Char]
alexFileM     SharedOptions
opts , [Char]
" ( Token )"                          ]
      , [ [Char]
"import " , SharedOptions -> [Char]
happyFileM    SharedOptions
opts , [Char]
" ( " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
firstParser [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", myLexer )" ]
      , [ [Char]
"import " , SharedOptions -> [Char]
templateFileM SharedOptions
opts , [Char]
" ()"                                 ]
      , [ [Char]
"import " , SharedOptions -> [Char]
printerFileM  SharedOptions
opts , [Char]
" ( Print, printTree )"               ]
      , [ [Char]
"import " , SharedOptions -> [Char]
absFileM      SharedOptions
opts , [Char]
" ()"                                 ]
      ]
    , [ [ [Char]
"import " , SharedOptions -> [Char]
layoutFileM   SharedOptions
opts , [Char]
" ( resolveLayout )" ] | Bool
lay     ]
    , [ [ [Char]
"import " , SharedOptions -> [Char]
xmlFileM      SharedOptions
opts , [Char]
" ( XPrint, printXML )"      ] | Bool
use_xml ]
    ]
  , [ [Char]
"import qualified Data.Map ( Map, lookup, toList )" | Bool
use_glr ]
  , [ [Char]
"import Data.Maybe ( fromJust )"                    | Bool
use_glr ]
  , [ [Char]
""
    , [Char]
"type Err = Either String"
    , if Bool
use_glr
      then [Char]
"type ParseFun a = [[Token]] -> (GLRResult, GLR_Output (Err a))"
      else [Char]
"type ParseFun a = [Token] -> Err a"
    , [Char]
""
    , [Char]
"myLLexer = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ if Bool
lay then [Char]
"resolveLayout True . myLexer"
                              else [Char]
"myLexer"
    , [Char]
""
    , [Char]
"type Verbosity = Int"
    , [Char]
""
    , [Char]
"putStrV :: Verbosity -> String -> IO ()"
    , [Char]
"putStrV v s = when (v > 1) $ putStrLn s"
    , [Char]
""
    , [Char]
"runFile :: (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
xpr [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall {p}. IsString p => p -> p
if_glr [Char]
"TreeDecode a, " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()"
    , [Char]
"runFile v p f = putStrLn f >> readFile f >>= run v p"
    , [Char]
""
    , [Char]
"run :: (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
xpr [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall {p}. IsString p => p -> p
if_glr [Char]
"TreeDecode a, " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Print a, Show a) => Verbosity -> ParseFun a -> " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ TokenText -> [Char]
tokenTextType (SharedOptions -> TokenText
tokenText SharedOptions
opts) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" -> IO ()"
    , if Bool
use_glr then [Char]
runGlr else Bool -> [Char]
runStd Bool
use_xml
    , [Char]
""
    , [Char]
"showTree :: (Show a, Print a) => Int -> a -> IO ()"
    , [Char]
"showTree v tree"
    , [Char]
" = do"
    , [Char]
"      putStrV v $ \"\\n[Abstract Syntax]\\n\\n\" ++ show tree"
    , [Char]
"      putStrV v $ \"\\n[Linearized tree]\\n\\n\" ++ printTree tree"
    , [Char]
""
    , [Char]
"usage :: IO ()"
    , [Char]
"usage = do"
    , [Char]
"  putStrLn $ unlines"
    , [Char]
"    [ \"usage: Call with one of the following argument combinations:\""
    , [Char]
"    , \"  --help          Display this help message.\""
    , [Char]
"    , \"  (no arguments)  Parse stdin verbosely.\""
    , [Char]
"    , \"  (files)         Parse content of files verbosely.\""
    , [Char]
"    , \"  -s (files)      Silent mode. Parse content of files silently.\""
    , [Char]
"    ]"
    , [Char]
"  exitFailure"
    , [Char]
""
    , [Char]
"main :: IO ()"
    , [Char]
"main = do"
    , [Char]
"  args <- getArgs"
    , [Char]
"  case args of"
    , [Char]
"    [\"--help\"] -> usage"
    , [Char]
"    [] -> getContents >>= run 2 " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
firstParser
    , [Char]
"    \"-s\":fs -> mapM_ (runFile 0 " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
firstParser [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") fs"
    , [Char]
"    fs -> mapM_ (runFile 2 " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
firstParser [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") fs"
    , [Char]
""
    ]
  , if Bool
use_glr then
    [ [Char]
"the_parser :: ParseFun " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Cat -> [Char]
forall a. Show a => a -> [Char]
show Cat
topType
    , [Char]
"the_parser = lift_parser " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Doc -> [Char]
render (Cat -> Doc
parserName Cat
topType)
    , [Char]
""
    , [Char]
liftParser
    ]
    else []
  ]
  where
    lay :: Bool
lay         = CF -> Bool
hasLayout CF
cf
    use_xml :: Bool
use_xml     = SharedOptions -> Int
xml SharedOptions
opts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
    xpr :: [Char]
xpr         = if Bool
use_xml then [Char]
"XPrint a, "     else [Char]
""
    use_glr :: Bool
use_glr     = SharedOptions -> HappyMode
glr SharedOptions
opts HappyMode -> HappyMode -> Bool
forall a. Eq a => a -> a -> Bool
== HappyMode
GLR
    if_glr :: p -> p
if_glr p
s    = if Bool
use_glr then p
s else p
""
    firstParser :: [Char]
firstParser = if Bool
use_glr then [Char]
"the_parser" else Doc -> [Char]
render (Cat -> Doc
parserName Cat
topType)
    topType :: Cat
topType     = CF -> Cat
firstEntry CF
cf


runStd :: Bool -> [Char]
runStd Bool
xml
 = [[Char]] -> [Char]
unlines
   [ [Char]
"run v p s = case p ts of"
   , [Char]
"    Left s -> do"
   , [Char]
"      putStrLn \"\\nParse              Failed...\\n\""
   , [Char]
"      putStrV v \"Tokens:\""
   , [Char]
"      putStrV v $ show ts"
   , [Char]
"      putStrLn s"
   , [Char]
"      exitFailure"
   , [Char]
"    Right tree -> do"
   , [Char]
"      putStrLn \"\\nParse Successful!\""
   , [Char]
"      showTree v tree"
   , if Bool
xml then
     [Char]
"      putStrV v $ \"\\n[XML]\\n\\n\" ++ printXML tree"
     else [Char]
""
   , [Char]
"      exitSuccess"
   , [Char]
"  where"
   , [Char]
"  ts = myLLexer s"
   ]

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


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