{-# LANGUAGE OverloadedStrings #-}

module BNFC.Backend.Haskell.Test where

import BNFC.CF

import BNFC.Backend.CommonInterface.Backend

import BNFC.Backend.Common.Utils as Utils

import BNFC.Backend.Haskell.Options
import BNFC.Backend.Haskell.State
import BNFC.Backend.Haskell.Utilities.Parser
import BNFC.Backend.Haskell.Utilities.Utils

import BNFC.Options.GlobalOptions

import BNFC.Prelude

import Control.Monad.State

import qualified Data.Map     as Map
import           Data.List   (intersperse, sortBy)
import           Data.String (fromString)

import Prettyprinter

import System.FilePath (takeBaseName)

haskellParserTest :: LBNF -> State HaskellBackendState Result
haskellParserTest :: LBNF -> State HaskellBackendState Result
haskellParserTest LBNF
lbnf = do
  HaskellBackendState
st <- StateT HaskellBackendState Identity HaskellBackendState
forall s (m :: * -> *). MonadState s m => m s
get
  let
    cfName :: String
cfName      = String -> String
takeBaseName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ GlobalOptions -> String
optInput (GlobalOptions -> String) -> GlobalOptions -> String
forall a b. (a -> b) -> a -> b
$ HaskellBackendState -> GlobalOptions
globalOpt HaskellBackendState
st
    tt :: TokenText
tt          = HaskellBackendOptions -> TokenText
tokenText (HaskellBackendOptions -> TokenText)
-> HaskellBackendOptions -> TokenText
forall a b. (a -> b) -> a -> b
$ HaskellBackendState -> HaskellBackendOptions
haskellOpts HaskellBackendState
st
    inDirectory :: Bool
inDirectory = HaskellBackendOptions -> Bool
inDir (HaskellBackendOptions -> Bool) -> HaskellBackendOptions -> Bool
forall a b. (a -> b) -> a -> b
$ HaskellBackendState -> HaskellBackendOptions
haskellOpts HaskellBackendState
st
    nSpace :: Maybe String
nSpace      = HaskellBackendOptions -> Maybe String
nameSpace (HaskellBackendOptions -> Maybe String)
-> HaskellBackendOptions -> Maybe String
forall a b. (a -> b) -> a -> b
$ HaskellBackendState -> HaskellBackendOptions
haskellOpts HaskellBackendState
st
    test :: String
test        = LBNF -> String -> TokenText -> Bool -> Maybe String -> String
cf2test LBNF
lbnf String
cfName TokenText
tt Bool
inDirectory Maybe String
nSpace
  Result -> State HaskellBackendState Result
forall (m :: * -> *) a. Monad m => a -> m a
return [(Bool -> Maybe String -> String -> String -> String -> String
mkFilePath Bool
inDirectory Maybe String
nSpace String
cfName String
"Test" String
"hs", String
test)]

cf2test :: LBNF -> String -> TokenText -> Bool -> Maybe String -> String
cf2test :: LBNF -> String -> TokenText -> Bool -> Maybe String -> String
cf2test LBNF
lbnf String
cfName TokenText
tt Bool
inDir Maybe String
nameSpace =
  LayoutOptions -> Doc () -> String
docToString LayoutOptions
defaultLayoutOptions (Doc () -> String) -> Doc () -> String
forall a b. (a -> b) -> a -> b
$ LBNF -> String -> TokenText -> Bool -> Maybe String -> Doc ()
cf2doc LBNF
lbnf String
cfName TokenText
tt Bool
inDir Maybe String
nameSpace

cf2doc :: LBNF -> String -> TokenText -> Bool -> Maybe String -> Doc ()
cf2doc :: LBNF -> String -> TokenText -> Bool -> Maybe String -> Doc ()
cf2doc LBNF
lbnf String
cfName TokenText
tokenText Bool
inDir Maybe String
nameSpace = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ())
-> ([Doc ()] -> [Doc ()]) -> [Doc ()] -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
intersperse Doc ()
forall ann. Doc ann
emptyDoc  ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$
  [ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
    [ Doc ()
"-- File generated by the BNF Converter."
    , Doc ()
"-- | Program to test parser."
    ]
  , Doc ()
"module Main where"
  , Doc ()
imports
  , [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
    [ Doc ()
"type Err        = Either String"
    , Doc ()
"type ParseFun a = [Token] -> Err a"
    , Doc ()
"type Verbosity  = Int"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"putStrV :: Verbosity -> String -> IO ()"
    , Doc ()
"putStrV v s = when (v > 1) $ putStrLn s"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()"
    , Doc ()
"runFile v p f = putStrLn f >> readFile f >>= run v p"
    , Doc ()
forall ann. Doc ann
emptyDoc
    -- TODO xml
    , Doc ()
"run :: (Print a, Show a) => Verbosity -> ParseFun a ->" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TokenText -> Doc ()
tokenTextType TokenText
tokenText Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"-> IO ()"
    , Doc ()
"run v p s ="
    , Doc ()
"  case p ts of"
    , Doc ()
"    Left err -> do"
    , Doc ()
"      putStrLn \"\\nParse              Failed...\\n\""
    , Doc ()
"      putStrV v \"Tokens:\""
    , Doc ()
"      mapM_ (putStrV v . showPosToken . mkPosToken) ts"
    , Doc ()
"      putStrLn err"
    , Doc ()
"      exitFailure"
    , Doc ()
"    Right tree -> do"
    , Doc ()
"      putStrLn \"\\nParse Successful!\""
    , Doc ()
"      showTree v tree"
    , Doc ()
"  where"
    , if Bool
layouts
      then
        if Bool
topLevelLayout
        then Doc ()
"  ts = resolveLayout True $ myLexer s"
        else Doc ()
"  ts = resolveLayout False $ myLexer s"
      else Doc ()
"  ts = myLexer s"
    , Doc ()
"  showPosToken ((l,c),t) = concat [ show l, \":\", show c, \"\\t\", show t ]"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"showTree :: (Show a, Print a) => Int -> a -> IO ()"
    , Doc ()
"showTree v tree = do"
    , Doc ()
"  putStrV v $ \"\\n[Abstract Syntax]\\n\\n\" ++ show tree"
    , Doc ()
"  putStrV v $ \"\\n[Linearized tree]\\n\\n\" ++ printTree tree"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"usage :: IO ()"
    , Doc ()
"usage = do"
    , Doc ()
"  putStrLn $ unlines"
    , Doc ()
"    [ \"usage: Call with one of the following argument combinations:\""
    , Doc ()
"    , \"  --help          Display this help message.\""
    , Doc ()
"    , \"  (no arguments)  Parse stdin verbosely.\""
    , Doc ()
"    , \"  (files)         Parse content of files verbosely.\""
    , Doc ()
"    , \"  -s (files)      Silent mode. Parse content of files silently.\""
    , Doc ()
"    ]"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"main :: IO ()"
    , Doc ()
"main = do"
    , Doc ()
"  args <- getArgs"
    , Doc ()
"  case args of"
    , Doc ()
"    [\"--help\"] -> usage"
    , Doc ()
"    []         -> getContents >>= run 2" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
firstParser
    , Doc ()
"    \"-s\":fs    -> mapM_ (runFile 0" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
firstParser Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
") fs"
    , Doc ()
"    fs         -> mapM_ (runFile 2" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
firstParser Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
") fs"
    ]
  ]

  where

  layouts :: Bool
  layouts :: Bool
layouts = LBNF -> Bool
layoutsAreUsed LBNF
lbnf

  topLevelLayout :: Bool
  topLevelLayout :: Bool
topLevelLayout = Maybe Position -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Position -> Bool) -> Maybe Position -> Bool
forall a b. (a -> b) -> a -> b
$ LBNF -> Maybe Position
_lbnfLayoutTop LBNF
lbnf

  imports :: Doc ()
  imports :: Doc ()
imports = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$
    [ Doc ()
"import Prelude"
    , Doc ()
"  ( ($), (.)"
    , Doc ()
"  , Either(..)"
    ]
    [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++
    Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when Bool
layouts [ Doc ()
"  , Bool (..)" ]
    [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++
    [ Doc ()
"  , Int, (>)"
    , Doc ()
"  , String, (++), concat, unlines"
    , Doc ()
"  , Show, show"
    , Doc ()
"  , IO, (>>), (>>=), mapM_, putStrLn"
    , Doc ()
"  , FilePath"
    ]
    [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++
    Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when (TokenText
tokenText TokenText -> TokenText -> Bool
forall a. Eq a => a -> a -> Bool
== TokenText
StringToken) [ Doc ()
"  , getContents, readFile" ]
    [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++
    [ Doc ()
"  )" , Doc ()
forall ann. Doc ann
emptyDoc ]
    [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++
    case TokenText
tokenText of
      TokenText
StringToken -> []
      TokenText
TextToken ->
        [ Doc ()
forall ann. Doc ann
emptyDoc
        , Doc ()
"import Data.Text.IO   ( getContents, readFile )"
        , Doc ()
"import qualified Data.Text"
        , Doc ()
forall ann. Doc ann
emptyDoc
        ]
    [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++
    [ Doc ()
"import System.Environment ( getArgs )"
    , Doc ()
"import System.Exit        ( exitFailure )"
    , Doc ()
"import Control.Monad      ( when )"
    , Doc ()
forall ann. Doc ann
emptyDoc
    ]
    [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++
    [ Doc ()
"import" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString String
absModule Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"()" ]
    [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++
    Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when Bool
layouts [ Doc ()
"import"  Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString String
layoutModule Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"( resolveLayout )" ]
    [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++
    [ Doc ()
"import" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString String
lexModule Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"( Token, mkPosToken )"
    , Doc ()
"import" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString String
parModule Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"(" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
firstParser Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
", myLexer )"
    , Doc ()
"import" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString String
printModule Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"( Print, printTree )"
    , Doc ()
"import" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString String
templateModule Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"()"
    ]

  -- Components module names.
  absModule :: ModuleName
  absModule :: String
absModule = Bool -> Maybe String -> String -> String -> String
mkModule Bool
inDir Maybe String
nameSpace String
cfName String
"Abs"
  layoutModule :: ModuleName
  layoutModule :: String
layoutModule = Bool -> Maybe String -> String -> String -> String
mkModule Bool
inDir Maybe String
nameSpace String
cfName String
"Layout"
  lexModule :: ModuleName
  lexModule :: String
lexModule = Bool -> Maybe String -> String -> String -> String
mkModule Bool
inDir Maybe String
nameSpace String
cfName String
"Lex"
  parModule :: ModuleName
  parModule :: String
parModule = Bool -> Maybe String -> String -> String -> String
mkModule Bool
inDir Maybe String
nameSpace String
cfName String
"Par"
  printModule :: ModuleName
  printModule :: String
printModule = Bool -> Maybe String -> String -> String -> String
mkModule Bool
inDir Maybe String
nameSpace String
cfName String
"Print"
  templateModule :: ModuleName
  templateModule :: String
templateModule = Bool -> Maybe String -> String -> String -> String
mkModule Bool
inDir Maybe String
nameSpace String
cfName String
"Skel"

  firstParser :: Doc ()
firstParser = Cat -> Doc ()
parserCatName Cat
firstCat

  firstCat :: Cat
  firstCat :: Cat
firstCat = [Cat] -> Cat
forall a. [a] -> a
head [Cat]
entrypoints

  -- Entrypoints sorted according to their declaration order in the grammar file.
  entrypoints :: [Cat]
  entrypoints :: [Cat]
entrypoints = (Cat, List1 Position) -> Cat
forall a b. (a, b) -> a
fst ((Cat, List1 Position) -> Cat) -> [(Cat, List1 Position)] -> [Cat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Cat, List1 Position) -> (Cat, List1 Position) -> Ordering)
-> [(Cat, List1 Position)] -> [(Cat, List1 Position)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (List1 Position -> List1 Position -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (List1 Position -> List1 Position -> Ordering)
-> ((Cat, List1 Position) -> List1 Position)
-> (Cat, List1 Position)
-> (Cat, List1 Position)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Cat, List1 Position) -> List1 Position
forall a b. (a, b) -> b
snd) (Map Cat (List1 Position) -> [(Cat, List1 Position)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Cat (List1 Position) -> [(Cat, List1 Position)])
-> Map Cat (List1 Position) -> [(Cat, List1 Position)]
forall a b. (a -> b) -> a -> b
$ LBNF -> Map Cat (List1 Position)
_lbnfEntryPoints LBNF
lbnf)