{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeSynonymInstances #-}

-- | LR-parser.

module LR where

import Data.Version                 ( showVersion )

import System.Environment (getArgs)
import System.Exit (exitFailure, exitSuccess)

import qualified LBNF.Abs as A
import LBNF.Par (pGrammar, myLexer)
import LBNF.Print (printTree)

import DebugPrint
import Util

import CFG
import CharacterTokenGrammar
import ParseTable
import ParseTable.Pretty

import License
import qualified Paths_LR_demo as Self ( version )

-- | Main: read file passed by only command line argument and call 'run'.

main :: IO ()
main :: IO ()
main = do
  IO [String]
getArgs IO [String] -> ([String] -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [String
"-h"]                -> IO ()
forall {b}. IO b
usage
    [String
"--help"]            -> IO ()
forall {b}. IO b
usage
    [String
"-V"]                -> IO ()
version
    [String
"--version"]         -> IO ()
version
    [String
"--numeric-version"] -> IO ()
forall {b}. IO b
numericVersion
    [String
"--license"]         -> IO ()
forall {b}. IO b
printLicense
    [String
"--licence"]         -> IO ()
forall {b}. IO b
printLicense
    [Term
'-':String
_]               -> IO ()
forall {b}. IO b
usage
    [String
file]                -> String -> IO ()
run (String -> IO ()) -> IO String -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO String
readFile String
file
    [String]
_                     -> IO ()
forall {b}. IO b
usage
  where
    ver :: String
ver = Version -> String
showVersion Version
Self.version
    versionLine :: String
versionLine = [String] -> String
unwords [ String
"lr-demo version", String
ver, String
"(C) 2019-25 Andreas Abel" ]
    usage :: IO b
usage = do
      String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
        [ String
versionLine
        , String
"Call patterns:"
        , String
"  -h | --help        Print this help text."
        , String
"  -V | --version     Print version info."
        , String
"  --numeric-version  Print just the version number."
        , String
"  --license          Print the license text."
        , String
"  FILE               Parses stdin with the LBNF grammar given in FILE."
        ]
      IO b
forall {b}. IO b
exitFailure
    version :: IO ()
version = do
      String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
        [ String
versionLine
        , String
"Developed for the course Programming Language Technology;"
        , String
"Chalmers DAT151 / University of Gothenburg DIT231."
        , String
"License: BSD 3-clause."
        ]
    numericVersion :: IO b
numericVersion = do
      String -> IO ()
putStrLn String
ver
      IO b
forall {b}. IO b
exitSuccess
    printLicense :: IO b
printLicense = do
      String -> IO ()
putStr String
license
      IO b
forall {b}. IO b
exitSuccess

-- | Parse grammar and then use it to parse stdin.

run :: String -> IO ()
run :: String -> IO ()
run String
s = do

  -- Parse CFG grammar from file in LBNF syntax
  tree <- IO () -> Err Grammar -> IO Grammar
forall a. IO () -> Err a -> IO a
runErr (String -> IO ()
putStrLn String
"Syntax error in grammar file") (Err Grammar -> IO Grammar) -> Err Grammar -> IO Grammar
forall a b. (a -> b) -> a -> b
$
    [Token] -> Err Grammar
pGrammar (String -> [Token]
myLexer String
s)

  -- Scope-check grammar and convert into internal format.
  (mstart, grm)  <- runM $ checkGrammar tree

  start <- runM $ case mstart of
    Just NT
start -> NT -> Err NT
forall a b. b -> Either a b
Right NT
start
    Maybe NT
Nothing    -> String -> Err NT
forall a b. a -> Either a b
Left String
"grammar is empty!"

  putStrLn $ unlines
    [ "Using the following grammar:"
    , ""
    , printTree $ reifyGrammar grm
    ]

  let newstart = String -> Ident
A.Ident String
"%start"
  let egrm = Ident
-> Ident
-> EGrammar' Ident Ident Term
-> EGrammar' Ident Ident Term
forall x r t. x -> r -> EGrammar' x r t -> EGrammar' x r t
addNewStart Ident
newstart Ident
newstart (EGrammar' Ident Ident Term -> EGrammar' Ident Ident Term)
-> EGrammar' Ident Ident Term -> EGrammar' Ident Ident Term
forall a b. (a -> b) -> a -> b
$ Grammar -> NT -> EGrammar' Ident Ident Term
forall t x r. Ord t => Grammar' x r t -> NT' x -> EGrammar' x r t
makeEGrammar Grammar
grm NT
start
  let ipt  = EGrammar' Ident Ident Term -> IPT' Ident Ident Term
forall x r t. (Ord r, Ord t) => EGrammar' x r t -> IPT' x r t
ptGen EGrammar' Ident Ident Term
egrm

  putStrLn $ unlines
    [ "Generated parse table:"
    , ""
    , debugPrint $ WithNTNames @A.Ident (getNTNames egrm) ipt
    ]

  let pt   = IPT' Ident Ident Term -> ParseTable' Ident Ident Term PState
forall x r t.
(Ord r, Ord t) =>
IPT' x r t -> ParseTable' x r t PState
constructParseTable' IPT' Ident Ident Term
ipt

  -- Run the parser.
  putStrLn "Parsing stdin..."
  stdin <- trim <$> getContents
  -- runM $ parseWith pt stdin
  -- putStrLn "Parse successful!"
  putStrLn $ debugPrint $ runLR1Parser pt stdin

type Err = Either String

runM :: Err a -> IO a
runM :: forall a. Err a -> IO a
runM = IO () -> Err a -> IO a
forall a. IO () -> Err a -> IO a
runErr (IO () -> Err a -> IO a) -> IO () -> Err a -> IO a
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

runErr :: IO () -> Err a -> IO a
runErr :: forall a. IO () -> Err a -> IO a
runErr IO ()
preErr = \case
  Right a
a -> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
  Left String
err -> do
    IO ()
preErr
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
    IO a
forall {b}. IO b
exitFailure