{-
    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 :: SharedOptions -> CF -> Backend
makeHaskell SharedOptions
opts CF
cf = do
  -- Get current time in printable form.
  [Char]
time <- IO [Char] -> WriterT [GeneratedFile] IO [Char]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> WriterT [GeneratedFile] IO [Char])
-> IO [Char] -> WriterT [GeneratedFile] 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 :: [Char]
absMod = SharedOptions -> [Char]
absFileM SharedOptions
opts
      lexMod :: [Char]
lexMod = SharedOptions -> [Char]
alexFileM SharedOptions
opts
      parMod :: [Char]
parMod = SharedOptions -> [Char]
happyFileM SharedOptions
opts
      prMod :: [Char]
prMod  = SharedOptions -> [Char]
printerFileM SharedOptions
opts
      layMod :: [Char]
layMod = SharedOptions -> [Char]
layoutFileM SharedOptions
opts
      errMod :: [Char]
errMod = SharedOptions -> [Char]
errFileM SharedOptions
opts
  do
    -- Generate abstract syntax and pretty printer.
    [Char] -> MakeComment -> Doc -> Backend
forall c. FileContent c => [Char] -> MakeComment -> c -> Backend
mkfile (SharedOptions -> [Char]
absFile SharedOptions
opts) MakeComment
comment (Doc -> Backend) -> Doc -> Backend
forall a b. (a -> b) -> a -> b
$ SharedOptions -> [Char] -> CF -> Doc
cf2Abstract SharedOptions
opts [Char]
absMod CF
cf
    [Char] -> MakeComment -> Doc -> Backend
forall c. FileContent c => [Char] -> MakeComment -> c -> Backend
mkfile (SharedOptions -> [Char]
printerFile SharedOptions
opts) MakeComment
comment (Doc -> Backend) -> Doc -> Backend
forall a b. (a -> b) -> a -> b
$ TokenText -> Bool -> Bool -> [Char] -> [Char] -> CF -> Doc
cf2Printer (SharedOptions -> TokenText
tokenText SharedOptions
opts) (SharedOptions -> Bool
functor SharedOptions
opts) Bool
False [Char]
prMod [Char]
absMod CF
cf

    -- Generate Alex lexer.  Layout is resolved after lexing.
    case SharedOptions -> AlexVersion
alexMode SharedOptions
opts of
      AlexVersion
Alex3 -> do
        [Char] -> MakeComment -> [Char] -> Backend
forall c. FileContent c => [Char] -> MakeComment -> c -> Backend
mkfile (SharedOptions -> [Char]
alexFile SharedOptions
opts) MakeComment
commentWithEmacsModeHint ([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 (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)

    Bool -> Backend -> Backend
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Ctrl.when (CF -> Bool
hasLayout CF
cf) (Backend -> Backend) -> Backend -> Backend
forall a b. (a -> b) -> a -> b
$ [Char] -> MakeComment -> [Char] -> Backend
forall c. FileContent c => [Char] -> MakeComment -> c -> Backend
mkfile (SharedOptions -> [Char]
layoutFile SharedOptions
opts) MakeComment
comment ([Char] -> Backend) -> [Char] -> Backend
forall a b. (a -> b) -> a -> b
$
      [Char] -> [Char] -> CF -> [Char]
cf2Layout [Char]
layMod [Char]
lexMod CF
cf

    -- Generate Happy parser and matching test program.
    do
      [Char] -> MakeComment -> [Char] -> Backend
forall c. FileContent c => [Char] -> MakeComment -> c -> Backend
mkfile (SharedOptions -> [Char]
happyFile SharedOptions
opts) MakeComment
commentWithEmacsModeHint ([Char] -> Backend) -> [Char] -> Backend
forall a b. (a -> b) -> a -> b
$
        [Char]
-> [Char]
-> [Char]
-> HappyMode
-> TokenText
-> Bool
-> CF
-> [Char]
cf2Happy [Char]
parMod [Char]
absMod [Char]
lexMod (SharedOptions -> HappyMode
glr SharedOptions
opts) (SharedOptions -> TokenText
tokenText SharedOptions
opts) (SharedOptions -> Bool
functor SharedOptions
opts) CF
cf
      -- liftIO $ printf "%s Tested with Happy 1.15\n" (happyFile opts)
      [Char] -> MakeComment -> [Char] -> Backend
forall c. FileContent c => [Char] -> MakeComment -> c -> Backend
mkfile (SharedOptions -> [Char]
tFile SharedOptions
opts) MakeComment
comment ([Char] -> Backend) -> [Char] -> Backend
forall a b. (a -> b) -> a -> b
$ SharedOptions -> CF -> [Char]
testfile SharedOptions
opts CF
cf

    -- Both Happy parser and skeleton (template) rely on Err.
    [Char] -> MakeComment -> Doc -> Backend
forall c. FileContent c => [Char] -> MakeComment -> c -> Backend
mkfile (SharedOptions -> [Char]
errFile SharedOptions
opts) MakeComment
comment (Doc -> Backend) -> Doc -> Backend
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
mkErrM [Char]
errMod
    [Char] -> MakeComment -> [Char] -> Backend
forall c. FileContent c => [Char] -> MakeComment -> c -> Backend
mkfile (SharedOptions -> [Char]
templateFile SharedOptions
opts) MakeComment
comment ([Char] -> Backend) -> [Char] -> Backend
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> Bool -> CF -> [Char]
cf2Template (SharedOptions -> [Char]
templateFileM SharedOptions
opts) [Char]
absMod (SharedOptions -> Bool
functor SharedOptions
opts) CF
cf

    -- Generate txt2tags documentation.
    [Char] -> MakeComment -> [Char] -> Backend
forall c. FileContent c => [Char] -> MakeComment -> c -> Backend
mkfile (SharedOptions -> [Char]
txtFile SharedOptions
opts) MakeComment
t2tComment ([Char] -> Backend) -> [Char] -> Backend
forall a b. (a -> b) -> a -> b
$ [Char] -> CF -> [Char]
cfToTxt (SharedOptions -> [Char]
lang SharedOptions
opts) CF
cf

    -- Generate XML and DTD printers.
    case SharedOptions -> Int
xml SharedOptions
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 (m :: * -> *) a. Monad m => a -> m a
return ()

    -- Generate Agda bindings for AST, Printer and Parser.
    Bool -> Backend -> Backend
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Ctrl.when (SharedOptions -> Bool
agda SharedOptions
opts) (Backend -> Backend) -> Backend -> Backend
forall a b. (a -> b) -> a -> b
$ [Char] -> SharedOptions -> CF -> Backend
makeAgda [Char]
time SharedOptions
opts CF
cf

    -- Generate Makefile.
    SharedOptions -> ([Char] -> Doc) -> Backend
Makefile.mkMakefile SharedOptions
opts (([Char] -> Doc) -> Backend) -> ([Char] -> Doc) -> Backend
forall a b. (a -> b) -> a -> b
$ SharedOptions -> CF -> [Char] -> Doc
makefile SharedOptions
opts CF
cf


-- | 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] -> MakeComment
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]
++ MakeComment -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map MakeComment
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 :: MakeComment
prefix = if [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
dir then MakeComment
forall a. a -> a
id else ([Char]
dir [Char] -> MakeComment
</>)
  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] -> MakeComment
forall a. [a] -> [a] -> [a]
++ SharedOptions -> [Char]
lang SharedOptions
opts [Char] -> MakeComment
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 -> MakeComment)
-> [Char] -> [Char] -> SharedOptions -> [Char]
mkFile SharedOptions -> MakeComment
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 (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
dir then [Char]
"" else [Char]
"-rmdir -p " [Char] -> MakeComment
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 (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
d then [Char]
"" else [Char]
d [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char
pathSeparator]

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

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


-- | Generate the makefile.
makefile
  :: Options
  -> CF
  -> String    -- ^ Filename of the makefile.
  -> Doc       -- ^ Content of the makefile.
makefile :: SharedOptions -> CF -> [Char] -> Doc
makefile SharedOptions
opts CF
cf [Char]
makeFile = [Doc] -> Doc
vcat
  [ SharedOptions -> Doc
makefileHeader SharedOptions
opts
  , 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 :: Maybe [Char]
make = Maybe [Char]
forall a. Maybe a
Nothing } ]
    tgts :: [Char]
tgts      = [[Char]] -> [Char]
unwords ([[Char]] -> [Char])
-> ([[SharedOptions -> [Char]]] -> [[Char]])
-> [[SharedOptions -> [Char]]]
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((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]] -> [[Char]])
-> ([[SharedOptions -> [Char]]] -> [SharedOptions -> [Char]])
-> [[SharedOptions -> [Char]]]
-> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[SharedOptions -> [Char]]] -> [SharedOptions -> [Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[SharedOptions -> [Char]]] -> [Char])
-> [[SharedOptions -> [Char]]] -> [Char]
forall a b. (a -> b) -> a -> b
$
      [ [ SharedOptions -> [Char]
absFile ]
      , [ SharedOptions -> [Char]
layoutFile | Bool
lay ]
      , [ SharedOptions -> [Char]
alexFile, SharedOptions -> [Char]
happyFile, SharedOptions -> [Char]
printerFile, SharedOptions -> [Char]
tFile ]
      , Bool -> [SharedOptions -> [Char]] -> [SharedOptions -> [Char]]
forall m. Monoid m => Bool -> m -> m
when (SharedOptions -> Bool
agda SharedOptions
opts)
        [ SharedOptions -> [Char]
agdaASTFile, SharedOptions -> [Char]
agdaParserFile, SharedOptions -> [Char]
agdaLibFile, SharedOptions -> [Char]
agdaMainFile ]
      ]

  lay :: Bool
  lay :: Bool
lay = CF -> Bool
hasLayout CF
cf

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

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

  -- | Rule to build Haskell test parser.
  testParserRule :: Doc
  testParserRule :: Doc
testParserRule = [Char] -> [[Char]] -> [[Char]] -> Doc
Makefile.mkRule [Char]
tgt [[Char]]
deps [ [Char]
"${GHC} ${GHC_OPTS} $@" ]
    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]] -> [[Char]])
-> [SharedOptions -> [Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [[SharedOptions -> [Char]]] -> [SharedOptions -> [Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ SharedOptions -> [Char]
absFile ]
      , [ SharedOptions -> [Char]
layoutFile | Bool
lay ]
      , [ SharedOptions -> [Char]
alexFileHs
        , SharedOptions -> [Char]
happyFileHs
        , SharedOptions -> [Char]
printerFile
        , SharedOptions -> [Char]
tFile
        ]
      ]

  -- | 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]] -> [[Char]])
-> [SharedOptions -> [Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [[SharedOptions -> [Char]]] -> [SharedOptions -> [Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ 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]
layoutFile | Bool
lay ]
      , [ 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."
    , [Char]
""
    , [Char]
"module Main where"
    , [Char]
""
    , [Char]
"import Prelude"
    , [Char]
"  ( ($), (.)"
    ]
  , [ [Char]
"  , Bool(..)" | Bool
lay ]
  , [ [Char]
"  , Either(..)"
    , [Char]
"  , Int, (>)"
    , [Char]
"  , String, (++), concat, unlines"
    , [Char]
"  , Show, show"
    , [Char]
"  , IO, (>>), (>>=), mapM_, putStrLn"
    , [Char]
"  , FilePath"
    ]
  , [ [Char]
"  , getContents, readFile" | SharedOptions -> TokenText
tokenText SharedOptions
opts TokenText -> TokenText -> Bool
forall a. Eq a => a -> a -> Bool
== TokenText
StringToken ]
  , [ [Char]
"  , error, flip, map, replicate, sequence_, zip" | Bool
use_glr ]
  , [ [Char]
"  )" ]
  , case SharedOptions -> TokenText
tokenText SharedOptions
opts of
      TokenText
StringToken -> []
      TokenText
TextToken ->
        [ [Char]
"import Data.Text.IO   ( getContents, readFile )"
        , [Char]
"import qualified Data.Text"
        ]
      TokenText
ByteStringToken ->
        [ [Char]
"import Data.ByteString.Char8 ( getContents, readFile )"
        , [Char]
"import qualified Data.ByteString.Char8 as BS"
        ]
  , [ [Char]
"import System.Environment ( getArgs )"
    , [Char]
"import System.Exit        ( exitFailure )"
    , [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]
absFileM      SharedOptions
opts , [Char]
" (" [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ MakeComment
forall a. Monoid a => a -> a
if_glr [Char]
impTopCat [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
")" ] ]
    , [ [ [Char]
"import " , SharedOptions -> [Char]
layoutFileM   SharedOptions
opts , [Char]
" ( resolveLayout )"      ] | Bool
lay     ]
    , [ [ [Char]
"import " , SharedOptions -> [Char]
alexFileM     SharedOptions
opts , [Char]
" ( Token, mkPosToken )"              ]
      , [ [Char]
"import " , SharedOptions -> [Char]
happyFileM    SharedOptions
opts , [Char]
" ( " [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
impParser [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
", myLexer" [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
impParGLR [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
" )" ]
      , [ [Char]
"import " , SharedOptions -> [Char]
printerFileM  SharedOptions
opts , [Char]
" ( Print, printTree )"               ]
      , [ [Char]
"import " , SharedOptions -> [Char]
templateFileM SharedOptions
opts , [Char]
" ()"                                 ]
      ]
    , [ [ [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]
"type Verbosity  = Int"
    , [Char]
""
    , [Char]
"putStrV :: Verbosity -> String -> IO ()"
    , [Char]
"putStrV v s = when (v > 1) $ putStrLn s"
    , [Char]
""
    , [Char]
"runFile :: (" [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
xpr [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ MakeComment
forall a. Monoid a => a -> a
if_glr [Char]
"TreeDecode a, " [Char] -> MakeComment
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] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
xpr [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ MakeComment
forall a. Monoid a => a -> a
if_glr [Char]
"TreeDecode a, " [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
"Print a, Show a) => Verbosity -> ParseFun a -> " [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ TokenText -> [Char]
tokenTextType (SharedOptions -> TokenText
tokenText SharedOptions
opts) [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
" -> IO ()"
    , (if Bool
use_glr then MakeComment -> [Char]
runGlr else Bool -> MakeComment -> [Char]
runStd Bool
use_xml) MakeComment
myLLexer
    , [Char]
"showTree :: (Show a, Print a) => Int -> a -> IO ()"
    , [Char]
"showTree v tree = 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]
""
    , [Char]
"main :: IO ()"
    , [Char]
"main = do"
    , [Char]
"  args <- getArgs"
    , [Char]
"  case args of"
    , [Char]
"    [\"--help\"] -> usage"
    , [Char]
"    []         -> getContents >>= run 2 " [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
firstParser
    , [Char]
"    \"-s\":fs    -> mapM_ (runFile 0 " [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
firstParser [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
") fs"
    , [Char]
"    fs         -> mapM_ (runFile 2 " [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
firstParser [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
") fs"
    , [Char]
""
    ]
  , [[Char]] -> [[Char]]
forall a. Monoid a => a -> a
if_glr ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$
    [ [Char]
"the_parser :: ParseFun " [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ Cat -> [Char]
catToStr Cat
topType
    , [Char]
"the_parser = lift_parser " [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ Doc -> [Char]
render (Cat -> Doc
parserName Cat
topType)
    , [Char]
""
    , [Char]
liftParser
    ]
  ]
  where
    lay :: Bool
lay         = Maybe [Char] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [Char]
hasTopLevelLayout Bool -> Bool -> Bool
|| Bool -> Bool
not ([([Char], Delimiters)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([Char], Delimiters)]
layoutKeywords)
    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      :: Monoid a => a -> a
    if_glr :: forall a. Monoid a => a -> a
if_glr      = Bool -> a -> a
forall m. Monoid m => Bool -> m -> m
when Bool
use_glr
    firstParser :: [Char]
firstParser = if Bool
use_glr then [Char]
"the_parser" else [Char]
impParser
    impParser :: [Char]
impParser   = Doc -> [Char]
render (Cat -> Doc
parserName Cat
topType)
    topType :: Cat
topType     = CF -> Cat
firstEntry CF
cf
    impTopCat :: [Char]
impTopCat   = [[Char]] -> [Char]
unwords [ [Char]
"", Cat -> [Char]
identCat Cat
topType, [Char]
"" ]
    impParGLR :: [Char]
impParGLR   = MakeComment
forall a. Monoid a => a -> a
if_glr [Char]
", GLRResult(..), Branch, ForestId, TreeDecode(..), decode"
    myLLexer :: MakeComment
myLLexer [Char]
atom
      | Bool
lay     = [[Char]] -> [Char]
unwords [ [Char]
"resolveLayout", Bool -> [Char]
forall a. Show a => a -> [Char]
show Bool
useTopLevelLayout, [Char]
"$ myLexer", [Char]
atom]
      | Bool
True    = [[Char]] -> [Char]
unwords [ [Char]
"myLexer", [Char]
atom]
    (Maybe [Char]
hasTopLevelLayout, [([Char], Delimiters)]
layoutKeywords, [[Char]]
_) = CF -> (Maybe [Char], [([Char], Delimiters)], [[Char]])
layoutPragmas CF
cf
    useTopLevelLayout :: Bool
useTopLevelLayout = Maybe [Char] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [Char]
hasTopLevelLayout

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

runGlr :: (String -> String) -> String
runGlr :: MakeComment -> [Char]
runGlr MakeComment
myLLexer
 = [[Char]] -> [Char]
unlines
   [ [Char]
"run v p s"
   , [Char]
" = let ts = map (:[]) $ " [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ MakeComment
myLLexer [Char]
"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 :: String
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)"
   ]