{-
    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.
  String
time <- IO String -> WriterT [GeneratedFile] IO String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> WriterT [GeneratedFile] IO String)
-> IO String -> WriterT [GeneratedFile] IO String
forall a b. (a -> b) -> a -> b
$ ZonedTime -> String
forall a. Show a => a -> String
show (ZonedTime -> String) -> IO ZonedTime -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ZonedTime
getZonedTimeTruncatedToSeconds

  let absMod :: String
absMod = SharedOptions -> String
absFileM SharedOptions
opts
      lexMod :: String
lexMod = SharedOptions -> String
alexFileM SharedOptions
opts
      parMod :: String
parMod = SharedOptions -> String
happyFileM SharedOptions
opts
      prMod :: String
prMod  = SharedOptions -> String
printerFileM SharedOptions
opts
      layMod :: String
layMod = SharedOptions -> String
layoutFileM SharedOptions
opts
      errMod :: String
errMod = SharedOptions -> String
errFileM SharedOptions
opts
  do
    -- Generate abstract syntax and pretty printer.
    String -> MakeComment -> Doc -> Backend
forall c. FileContent c => String -> MakeComment -> c -> Backend
mkfile (SharedOptions -> String
absFile SharedOptions
opts) MakeComment
comment (Doc -> Backend) -> Doc -> Backend
forall a b. (a -> b) -> a -> b
$ SharedOptions -> String -> CF -> Doc
cf2Abstract SharedOptions
opts String
absMod CF
cf
    String -> MakeComment -> Doc -> Backend
forall c. FileContent c => String -> MakeComment -> c -> Backend
mkfile (SharedOptions -> String
printerFile SharedOptions
opts) MakeComment
comment (Doc -> Backend) -> Doc -> Backend
forall a b. (a -> b) -> a -> b
$ TokenText -> Bool -> Bool -> String -> String -> CF -> Doc
cf2Printer (SharedOptions -> TokenText
tokenText SharedOptions
opts) (SharedOptions -> Bool
functor SharedOptions
opts) Bool
False String
prMod String
absMod CF
cf

    -- Generate Alex lexer.  Layout is resolved after lexing.
    case SharedOptions -> AlexVersion
alexMode SharedOptions
opts of
      AlexVersion
Alex3 -> do
        String -> MakeComment -> String -> Backend
forall c. FileContent c => String -> MakeComment -> c -> Backend
mkfile (SharedOptions -> String
alexFile SharedOptions
opts) MakeComment
commentWithEmacsModeHint (String -> Backend) -> String -> Backend
forall a b. (a -> b) -> a -> b
$ String -> TokenText -> CF -> String
cf2alex3 String
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
$ String -> String -> IO ()
forall r. PrintfType r => String -> r
printf String
"Use Alex 3 to compile %s.\n" (SharedOptions -> String
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
$ String -> MakeComment -> String -> Backend
forall c. FileContent c => String -> MakeComment -> c -> Backend
mkfile (SharedOptions -> String
layoutFile SharedOptions
opts) MakeComment
comment (String -> Backend) -> String -> Backend
forall a b. (a -> b) -> a -> b
$
      String -> String -> CF -> String
cf2Layout String
layMod String
lexMod CF
cf

    -- Generate Happy parser and matching test program.
    do
      String -> MakeComment -> String -> Backend
forall c. FileContent c => String -> MakeComment -> c -> Backend
mkfile (SharedOptions -> String
happyFile SharedOptions
opts) MakeComment
commentWithEmacsModeHint (String -> Backend) -> String -> Backend
forall a b. (a -> b) -> a -> b
$
        String
-> String
-> String
-> HappyMode
-> TokenText
-> Bool
-> CF
-> String
cf2Happy String
parMod String
absMod String
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)
      String -> MakeComment -> String -> Backend
forall c. FileContent c => String -> MakeComment -> c -> Backend
mkfile (SharedOptions -> String
tFile SharedOptions
opts) MakeComment
comment (String -> Backend) -> String -> Backend
forall a b. (a -> b) -> a -> b
$ SharedOptions -> CF -> String
testfile SharedOptions
opts CF
cf

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

    -- Generate txt2tags documentation.
    String -> MakeComment -> String -> Backend
forall c. FileContent c => String -> MakeComment -> c -> Backend
mkfile (SharedOptions -> String
txtFile SharedOptions
opts) MakeComment
t2tComment (String -> Backend) -> String -> Backend
forall a b. (a -> b) -> a -> b
$ String -> CF -> String
cfToTxt (SharedOptions -> String
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
$ String -> SharedOptions -> CF -> Backend
makeAgda String
time SharedOptions
opts CF
cf

    -- Generate Makefile.
    SharedOptions -> (String -> Doc) -> Backend
Makefile.mkMakefile SharedOptions
opts ((String -> Doc) -> Backend) -> (String -> Doc) -> Backend
forall a b. (a -> b) -> a -> b
$ SharedOptions -> CF -> String -> 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 -> String -> Doc
_oldMakefile SharedOptions
opts String
makeFile = [Doc] -> Doc
vcat
  [ String -> [String] -> [String] -> Doc
Makefile.mkRule String
"all" [] ([String] -> Doc) -> [String] -> Doc
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$
      [ [ [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [ String
"happy -gca" ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
glrParams [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ SharedOptions -> String
happyFile SharedOptions
opts ] ]
      , [ String
"alex -g " String -> MakeComment
forall a. [a] -> [a] -> [a]
++ SharedOptions -> String
alexFile SharedOptions
opts ]
      ]
  , SharedOptions -> Doc
cleanRule SharedOptions
opts
  , SharedOptions -> String -> Doc
distCleanRule SharedOptions
opts String
makeFile
  ]
  where
  glrParams :: [String]
  glrParams :: [String]
glrParams = Bool -> [String] -> [String]
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) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [ String
"--glr", String
"--decode" ]

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

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

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

makefileHeader :: Options -> Doc
makefileHeader :: SharedOptions -> Doc
makefileHeader Options{ HappyMode
glr :: HappyMode
glr :: SharedOptions -> HappyMode
glr } = [Doc] -> Doc
vcat
  [ Doc
"# Makefile for building the parser and test program."
  , Doc
""
  , 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 -> String -> Doc
makefile SharedOptions
opts CF
cf String
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 -> String) -> SharedOptions -> Bool
forall a. Eq a => (SharedOptions -> a) -> SharedOptions -> Bool
isDefault SharedOptions -> String
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 -> String -> Doc
distCleanRule SharedOptions
opts String
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
""
    , String -> [String] -> [String] -> Doc
Makefile.mkRule String
".PHONY" [ String
"all", String
"clean", String
"distclean" ] []
    ]
  -- | Default: build test parser(s).
  defaultRule :: Doc
  defaultRule :: Doc
defaultRule = [Doc] -> Doc
vcat
     [ Doc
"# Default goal."
     , Doc
""
     , String -> [String] -> [String] -> Doc
Makefile.mkRule String
"all" [String]
tgts []
     ]
     where
     tgts :: [String]
tgts = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$
              [ [ SharedOptions -> String
tFileExe SharedOptions
opts ]
              , [ String
"Main" | SharedOptions -> Bool
agda SharedOptions
opts ]
              ]

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

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

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

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

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

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

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


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

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


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