{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module BNFC.Backend.Txt2Tags.Txt2Tags where

import BNFC.Prelude

import Prettyprinter

import Control.Monad.State

import           Data.Foldable   (fold)
import           Data.List       (intercalate, intersperse)
import           Data.List.Split (chunksOf)
import qualified Data.Map        as Map
import           Data.String     (fromString)

import System.FilePath (takeBaseName, (<.>))

import BNFC.Backend.CommonInterface.Backend
import BNFC.Backend.Common.Utils as Utils
import BNFC.Backend.Txt2Tags.State

import BNFC.CF

import BNFC.Options.GlobalOptions

import BNFC.Types.Position
import BNFC.Types.Regex

import qualified BNFC.Utils.List2 as List2

txt2tags :: LBNF -> State Txt2TagsBackendState Result
txt2tags :: LBNF -> State Txt2TagsBackendState Result
txt2tags LBNF
lbnf = do
  Txt2TagsBackendState
st <- StateT Txt2TagsBackendState Identity Txt2TagsBackendState
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
$ Txt2TagsBackendState -> GlobalOptions
globalOpt Txt2TagsBackendState
st
  Result -> State Txt2TagsBackendState Result
forall (m :: * -> *) a. Monad m => a -> m a
return [(String
cfName String -> String -> String
<.> String
"t2t", LBNF -> String -> String
cf2string LBNF
lbnf String
cfName)]

cf2string :: LBNF -> String -> String
cf2string :: LBNF -> String -> String
cf2string LBNF
lbnf String
cfName = LayoutOptions -> Doc () -> String
docToString LayoutOptions
defaultLayoutOptions (Doc () -> String) -> Doc () -> String
forall a b. (a -> b) -> a -> b
$ LBNF -> String -> Doc ()
cf2doc LBNF
lbnf String
cfName

cf2doc :: LBNF -> String -> Doc ()
cf2doc :: LBNF -> String -> Doc ()
cf2doc LBNF
lbnf String
cfName = [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
$
  [ String -> Doc ()
introduction String
cfName
  , LBNF -> String -> Doc ()
printTerminals LBNF
lbnf String
cfName
  , LBNF -> String -> Doc ()
printGrammar LBNF
lbnf String
cfName
  ]

introduction :: String -> Doc ()
introduction :: String -> Doc ()
introduction String
cfName = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ()
"The Language" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString String
cfName
  , Doc ()
"BNF Converter"
  , Doc ()
forall ann. Doc ann
emptyDoc
  , Doc ()
forall ann. Doc ann
emptyDoc
  , Doc ()
"% File generated by the BNF Converter."
  , Doc ()
forall ann. Doc ann
emptyDoc
  , Doc ()
forall ann. Doc ann
emptyDoc
  , Doc ()
"This document was automatically generated by the //BNF-Converter//."
  ]

printTerminals :: LBNF -> String -> Doc ()
printTerminals :: LBNF -> String -> Doc ()
printTerminals LBNF
lbnf String
cfName  = [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 ()
"==The lexical structure of" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString String
cfName Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"==" ]
  [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++ Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when Bool
hasBuiltins
    [ Doc ()
"===Literals==="
    , [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
$ BuiltinCat -> Doc ()
printBuiltin (BuiltinCat -> Doc ()) -> [BuiltinCat] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BuiltinCat]
usedBuiltins
    ]
  [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++ Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when Bool
hasTokens
    [ [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
$ (CatName, WithPosition TokenDef) -> Doc ()
printToken ((CatName, WithPosition TokenDef) -> Doc ())
-> [(CatName, WithPosition TokenDef)] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(CatName, WithPosition TokenDef)]
tokens ]
  [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++ [ Doc ()
"===Reserved words and symbols==="
     , Doc ()
reservedWords
     , String -> [String] -> Doc ()
printKeywords String
cfName [String]
keywords
     , String -> [String] -> Doc ()
printSymbols String
cfName [String]
symbols ]
  [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++ [ Doc ()
"===Comments==="
     , [String] -> Result -> Doc ()
printComments [String]
lineComments Result
blockComments ]

  where

    hasBuiltins :: Bool
    hasBuiltins :: Bool
hasBuiltins = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Map BuiltinCat (List1 Position) -> Bool
forall k a. Map k a -> Bool
Map.null (Map BuiltinCat (List1 Position) -> Bool)
-> Map BuiltinCat (List1 Position) -> Bool
forall a b. (a -> b) -> a -> b
$ LBNF -> Map BuiltinCat (List1 Position)
_lbnfASTBuiltins LBNF
lbnf

    usedBuiltins :: [BuiltinCat]
    usedBuiltins :: [BuiltinCat]
usedBuiltins = Map BuiltinCat (List1 Position) -> [BuiltinCat]
forall k a. Map k a -> [k]
Map.keys (Map BuiltinCat (List1 Position) -> [BuiltinCat])
-> Map BuiltinCat (List1 Position) -> [BuiltinCat]
forall a b. (a -> b) -> a -> b
$ LBNF -> Map BuiltinCat (List1 Position)
_lbnfASTBuiltins LBNF
lbnf

    hasTokens :: Bool
    hasTokens :: Bool
hasTokens = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Map CatName (WithPosition TokenDef) -> Bool
forall k a. Map k a -> Bool
Map.null (Map CatName (WithPosition TokenDef) -> Bool)
-> Map CatName (WithPosition TokenDef) -> Bool
forall a b. (a -> b) -> a -> b
$ LBNF -> Map CatName (WithPosition TokenDef)
_lbnfTokenDefs LBNF
lbnf

    tokens :: [(CatName, WithPosition TokenDef)]
    tokens :: [(CatName, WithPosition TokenDef)]
tokens = Map CatName (WithPosition TokenDef)
-> [(CatName, WithPosition TokenDef)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map CatName (WithPosition TokenDef)
 -> [(CatName, WithPosition TokenDef)])
-> Map CatName (WithPosition TokenDef)
-> [(CatName, WithPosition TokenDef)]
forall a b. (a -> b) -> a -> b
$ LBNF -> Map CatName (WithPosition TokenDef)
_lbnfTokenDefs LBNF
lbnf

    keywords :: [String]
    keywords :: [String]
keywords = CatName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (CatName -> String) -> (Keyword -> CatName) -> Keyword -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Keyword -> CatName
theKeyword (Keyword -> String) -> [Keyword] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Keyword (List1 Position) -> [Keyword]
forall k a. Map k a -> [k]
Map.keys (LBNF -> Map Keyword (List1 Position)
_lbnfKeywords LBNF
lbnf)

    symbols :: [String]
    symbols :: [String]
symbols = CatName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (CatName -> String) -> (Symbol -> CatName) -> Symbol -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> CatName
theSymbol (Symbol -> String) -> [Symbol] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Symbol (List1 Position) -> [Symbol]
forall k a. Map k a -> [k]
Map.keys (LBNF -> Map Symbol (List1 Position)
_lbnfSymbols LBNF
lbnf)

    lineComments :: [String]
    lineComments :: [String]
lineComments =
      (\(LineComment CatName
s1) -> CatName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList CatName
s1) (LineComment -> String) -> [LineComment] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Position LineComment -> [LineComment]
forall k a. Map k a -> [a]
Map.elems (LBNF -> Map Position LineComment
_lbnfLineComments LBNF
lbnf)

    blockComments :: [(String, String)]
    blockComments :: Result
blockComments =
      (\(BlockComment CatName
s1 CatName
s2) -> (CatName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList CatName
s1, CatName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList CatName
s2))
      (BlockComment -> (String, String)) -> [BlockComment] -> Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      Map Position BlockComment -> [BlockComment]
forall k a. Map k a -> [a]
Map.elems (LBNF -> Map Position BlockComment
_lbnfBlockComments LBNF
lbnf)

printBuiltin :: BuiltinCat -> Doc ()
printBuiltin :: BuiltinCat -> Doc ()
printBuiltin = \case
 BuiltinCat
BChar -> [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ()
"Character literals //Char// have the form" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
    Doc ()
"``'``//c//``'``, where //c// is any single character."
  ]
 BuiltinCat
BDouble -> [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ()
"Double-precision float literals //Double// have the structure" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
    Doc ()
"indicated by the regular expression" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
    Doc ()
"``digit+ '.' digit+ ('e' ('-')? digit+)?``" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
    Doc ()
"i.e. two sequences of digits separated by a decimal point, optionally" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
    Doc ()
"followed by an unsigned or negative exponent."
  ]
 BuiltinCat
BInteger -> Doc ()
"Integer literals //Integer// are nonempty sequences of digits."
 BuiltinCat
BString -> [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ()
"Double-precision float literals //Double// have the structure" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
    Doc ()
"indicated by the regular expression" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
    Doc ()
"``digit+ '.' digit+ ('e' ('-')? digit+)?``" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
    Doc ()
"i.e. two sequences of digits separated by a decimal point, optionally" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
    Doc ()
"followed by an unsigned or negative exponent."
  ]

reservedWords :: Doc ()
reservedWords :: Doc ()
reservedWords = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ()
"The set of reserved words is the set of terminals "
  , Doc ()
"appearing in the grammar. Those reserved words "
  , Doc ()
"that consist of non-letter characters are called symbols, and "
  , Doc ()
"they are treated in a different way from those that "
  , Doc ()
"are similar to identifiers. The lexer "
  , Doc ()
"follows rules familiar from languages "
  , Doc ()
"like Haskell, C, and Java, including longest match "
  , Doc ()
"and spacing conventions."
  ]

printKeywords :: String -> [String] -> Doc ()
printKeywords :: String -> [String] -> Doc ()
printKeywords String
cfName [String]
keywords =
  if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
keywords
  then Doc ()
"There are no reserved words in" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString String
cfName Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
dot
  else [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
    [ Doc ()
"The reserved words used in" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString String
cfName Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"are the following:"
    , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([String] -> Doc ()
printLine ([String] -> Doc ()) -> [[String]] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [String] -> [[String]]
forall e. Int -> [e] -> [[e]]
chunksOf Int
4 [String]
keywords)
    ]
  where

    printLine :: [String] -> Doc ()
    printLine :: [String] -> Doc ()
printLine [String]
l =
      if [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4
      then Doc ()
forall ann. Doc ann
pipe Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
        ([Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ([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
pipe) ((\String
k -> Doc ()
"``" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> Doc ()
forall a. IsString a => String -> a
fromString String
k Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"``") (String -> Doc ()) -> [String] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
l)
      else Doc ()
forall ann. Doc ann
pipe Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
        ([Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ([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
pipe) ((\String
k -> Doc ()
"``" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> Doc ()
forall a. IsString a => String -> a
fromString String
k Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"``") (String -> Doc ()) -> [String] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
l) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
        [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep (Int -> Doc () -> [Doc ()]
forall a. Int -> a -> [a]
replicate (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
- [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
l) (Doc ()
forall ann. Doc ann
space Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
pipe))

printSymbols :: String -> [String] -> Doc ()
printSymbols :: String -> [String] -> Doc ()
printSymbols String
cfName [String]
symbols =
  if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
symbols
  then Doc ()
"There are no symbols in" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString String
cfName Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
dot
  else [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [Doc ()
"The symbols used in" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString String
cfName Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
" the following:"
  , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([String] -> Doc ()
printLine ([String] -> Doc ()) -> [[String]] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [String] -> [[String]]
forall e. Int -> [e] -> [[e]]
chunksOf Int
4 [String]
symbols)
  ]
  where

    printLine :: [String] -> Doc ()
    printLine :: [String] -> Doc ()
printLine [String]
l =
      if [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4
      then Doc ()
forall ann. Doc ann
pipe Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ([Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ([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
pipe) (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> [String] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
l)
      else Doc ()
forall ann. Doc ann
pipe Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ([Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ([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
pipe) (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> [String] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
l) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
        [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep (Int -> Doc () -> [Doc ()]
forall a. Int -> a -> [a]
replicate (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
- [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
l) (Doc ()
forall ann. Doc ann
space Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
pipe))

printComments :: [String] -> [(String, String)] -> Doc ()
printComments :: [String] -> Result -> Doc ()
printComments [String]
linecomments Result
blockcomments = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
linecomments
    then Doc ()
"There are no single-line comments in the grammar."
    else Doc ()
"Single-line comments begin with" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
      ([Doc ()] -> Doc ()
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Doc ()] -> Doc ())
-> ([[Doc ()]] -> [Doc ()]) -> [[Doc ()]] -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ()] -> [[Doc ()]] -> [Doc ()]
forall a. [a] -> [[a]] -> [a]
intercalate [Doc ()
forall ann. Doc ann
comma Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
space]) ((Doc () -> [Doc ()]) -> [Doc ()] -> [[Doc ()]]
forall a b. (a -> b) -> [a] -> [b]
map (Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
: []) (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> [String] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
linecomments)) Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
dot
  , if Result -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Result
blockcomments
    then Doc ()
"There are no multiple-line comments in the grammar."
    else Doc ()
"Multiple-line comments are  enclosed with" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
      ([Doc ()] -> Doc ()
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Doc ()] -> Doc ())
-> ([[Doc ()]] -> [Doc ()]) -> [[Doc ()]] -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ()] -> [[Doc ()]] -> [Doc ()]
forall a. [a] -> [[a]] -> [a]
intercalate [Doc ()
forall ann. Doc ann
comma Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
space])
      ((Doc () -> [Doc ()]) -> [Doc ()] -> [[Doc ()]]
forall a b. (a -> b) -> [a] -> [b]
map (Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
: []) ((\(String
s1,String
s2) -> String -> Doc ()
forall a. IsString a => String -> a
fromString String
s1 Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"and" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString String
s2) ((String, String) -> Doc ()) -> Result -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Result
blockcomments)) Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
dot
  ]

printToken :: (CatName, WithPosition TokenDef) -> Doc ()
printToken :: (CatName, WithPosition TokenDef) -> Doc ()
printToken (CatName
cName, WithPosition Position
_ TokenDef
tokenDef) = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ String -> Doc ()
forall a. IsString a => String -> a
fromString (CatName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList CatName
cName) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"literals are recognized by the regular expression"
  , Doc ()
"`````" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Regex -> Doc ()
printRegTxt2Tags (TokenDef -> Regex
regexToken TokenDef
tokenDef) Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"`````"
  ]

printGrammar :: LBNF -> String -> Doc ()
printGrammar :: LBNF -> String -> Doc ()
printGrammar LBNF
lbnf String
cfName = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ()
"==The syntactic structure of" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString String
cfName Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"=="
  , Doc ()
"Non-terminals are enclosed between < and >."
  , Doc ()
"The symbols **->** (production), **|** (union)"
  , Doc ()
"and **eps** (empty rule) belong to the BNF notation."
  , Doc ()
"All other symbols are terminals."
  , Doc ()
forall ann. Doc ann
emptyDoc
  , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ (Cat, [ARHS]) -> Doc ()
printRule ((Cat, [ARHS]) -> Doc ()) -> [(Cat, [ARHS])] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Cat, [ARHS])]
rules
  ]

  where

    rules :: [(Cat, [ARHS])]
    rules :: [(Cat, [ARHS])]
rules = ((Cat, Map Label (WithPosition ARuleRHS)) -> (Cat, [ARHS]))
-> [(Cat, Map Label (WithPosition ARuleRHS))] -> [(Cat, [ARHS])]
forall a b. (a -> b) -> [a] -> [b]
map
            (\(Cat
c,Map Label (WithPosition ARuleRHS)
m) -> (Cat
c,(Label, WithPosition ARuleRHS) -> ARHS
getARHS ((Label, WithPosition ARuleRHS) -> ARHS)
-> [(Label, WithPosition ARuleRHS)] -> [ARHS]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Label (WithPosition ARuleRHS)
-> [(Label, WithPosition ARuleRHS)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Label (WithPosition ARuleRHS)
m))
            (Map Cat (Map Label (WithPosition ARuleRHS))
-> [(Cat, Map Label (WithPosition ARuleRHS))]
forall k a. Map k a -> [(k, a)]
Map.toList (LBNF -> Map Cat (Map Label (WithPosition ARuleRHS))
_lbnfASTRules LBNF
lbnf))

    getARHS :: (Label, WithPosition ARuleRHS) -> ARHS
    getARHS :: (Label, WithPosition ARuleRHS) -> ARHS
getARHS (Label
_, WithPosition Position
_ (ARuleRHS RuleOrigin
_ Parseable
_ ARHS
arhs)) = ARHS
arhs

printRule :: (Cat, [ARHS]) -> Doc ()
printRule :: (Cat, [ARHS]) -> Doc ()
printRule (Cat
c, []) = Doc ()
forall ann. Doc ann
pipe Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"//" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> Doc ()
forall a. IsString a => String -> a
fromString (Cat -> String
printCat Cat
c) Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"// | -> | **eps**"
printRule (Cat
c, ARHS
a:[ARHS]
as) = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$
  Doc ()
forall ann. Doc ann
pipe Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"//" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> Doc ()
forall a. IsString a => String -> a
fromString (Cat -> String
printCat Cat
c) Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"//" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
    Doc ()
"| ->" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
forall ann. Doc ann
pipe Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ARHS -> Doc ()
printARHS ARHS
a
  Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
:
  Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when (Bool -> Bool
not ([ARHS] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ARHS]
as))
    [ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep (((Doc ()
forall ann. Doc ann
pipe Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
space Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
space Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"|  **|**  |") Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>) (Doc () -> Doc ()) -> (ARHS -> Doc ()) -> ARHS -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ARHS -> Doc ()
printARHS (ARHS -> Doc ()) -> [ARHS] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ARHS]
as)]

printARHS :: ARHS -> Doc ()
printARHS :: ARHS -> Doc ()
printARHS ARHS
arhs =
  if ARHS -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ARHS
arhs
  then Doc ()
"**eps**"
  else [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ Item' CatName -> Doc ()
printItem (Item' CatName -> Doc ()) -> ARHS -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ARHS
arhs

printItem :: Item' String1 -> Doc ()
printItem :: Item' CatName -> Doc ()
printItem (Terminal CatName
s)  = Doc ()
"``" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> Doc ()
forall a. IsString a => String -> a
fromString (CatName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList CatName
s) Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"``"
printItem (NTerminal Cat
c) = Doc ()
"//" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> Doc ()
forall a. IsString a => String -> a
fromString (Cat -> String
printCat Cat
c) Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"//"

printCat :: Cat -> String
printCat :: Cat -> String
printCat = \case
  Cat       BaseCat
b   -> BaseCat -> String
printBaseCatName BaseCat
b
  ListCat   Cat
c   -> String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
printCat Cat
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
  CoerceCat CatName
c Integer
i -> CatName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList CatName
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i

printRegTxt2Tags :: Regex -> Doc ()
printRegTxt2Tags :: Regex -> Doc ()
printRegTxt2Tags = Int -> Regex -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
0

class Print a where
  prt :: Int -> a -> Doc ()

instance {-# OVERLAPPABLE #-} Print a => Print [a] where
  prt :: Int -> [a] -> Doc ()
prt Int
i [a]
as = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ (a -> Doc ()) -> [a] -> [Doc ()]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> a -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
i) [a]
as

instance Print Char where
  prt :: Int -> Char -> Doc ()
prt Int
_ Char
c = Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
squotes (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ String -> Doc ()
forall a. IsString a => String -> a
fromString [Char
c]

instance Print Regex where
  prt :: Int -> Regex -> Doc ()
prt Int
i Regex
e = case Regex
e of

    RChar (CMinus CharClassUnion
yes CharClassUnion
no) -> Int -> Int -> Doc () -> Doc ()
prPrec Int
i Int
1 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$
      if CharClassUnion -> Bool
isEmpty CharClassUnion
no
      then Int -> CharClassUnion -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
2 CharClassUnion
yes
      else
        Int -> CharClassUnion -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
2 CharClassUnion
yes Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
        String -> Doc ()
forall a. IsString a => String -> a
fromString String
"-" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
        Int -> CharClassUnion -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
2 CharClassUnion
no

    RAlts  List2 Regex
regs -> Int -> Int -> Doc () -> Doc ()
prPrec Int
i Int
1 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
intersperse Doc ()
"|" ([Doc ()] -> [Doc ()]) -> [Doc ()] -> [Doc ()]
forall a b. (a -> b) -> a -> b
$
      (Regex -> Doc ()) -> [Regex] -> [Doc ()]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Regex -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
1) ([Regex] -> [Doc ()]) -> [Regex] -> [Doc ()]
forall a b. (a -> b) -> a -> b
$ List2 Regex -> [Item (List2 Regex)]
forall l. IsList l => l -> [Item l]
List2.toList List2 Regex
regs

    RMinus Regex
reg1 Regex
reg2 -> Int -> Int -> Doc () -> Doc ()
prPrec Int
i Int
1 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$
      Int -> Regex -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
2 Regex
reg1 Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
      String -> Doc ()
forall a. IsString a => String -> a
fromString String
"-" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
      Int -> Regex -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
2 Regex
reg2

    Regex
REps -> Doc ()
"eps"

    RSeqs  List2 Regex
regs -> Int -> Int -> Doc () -> Doc ()
prPrec Int
i Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ Int -> [Regex] -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
2 ([Regex] -> Doc ()) -> [Regex] -> Doc ()
forall a b. (a -> b) -> a -> b
$ List2 Regex -> [Item (List2 Regex)]
forall l. IsList l => l -> [Item l]
List2.toList List2 Regex
regs

    RStar  Regex
reg  -> Int -> Regex -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
3 Regex
reg Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> Doc ()
forall a. IsString a => String -> a
fromString String
"*"

    RPlus  Regex
reg  -> Int -> Regex -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
3 Regex
reg Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> Doc ()
forall a. IsString a => String -> a
fromString String
"+"

    ROpt   Regex
reg  -> Int -> Regex -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
3 Regex
reg Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> Doc ()
forall a. IsString a => String -> a
fromString String
"?"

instance Print CharClassUnion where
  prt :: Int -> CharClassUnion -> Doc ()
prt Int
i CharClassUnion
e = case CharClassUnion
e of
    CharClassUnion
CAny      -> Doc ()
"char"
    CAlt []   -> String -> Doc ()
forall a. HasCallStack => String -> a
panic String
"CharClass shouldn't be empty"
    CAlt [CharClassAtom
a]  -> Int -> CharClassAtom -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
0 CharClassAtom
a
    CAlt [CharClassAtom]
alts -> [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
intersperse Doc ()
"|" ([Doc ()] -> [Doc ()]) -> [Doc ()] -> [Doc ()]
forall a b. (a -> b) -> a -> b
$ (CharClassAtom -> Doc ()) -> [CharClassAtom] -> [Doc ()]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> CharClassAtom -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
i) [CharClassAtom]
alts

instance Print CharClassAtom where
  prt :: Int -> CharClassAtom -> Doc ()
prt Int
_ CharClassAtom
e = case CharClassAtom
e of
    CChar Char
c -> Int -> Char -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
0 Char
c
    CharClassAtom
CDigit  -> String -> Doc ()
forall a. IsString a => String -> a
fromString String
"digit"
    CharClassAtom
CLower  -> String -> Doc ()
forall a. IsString a => String -> a
fromString String
"lower"
    CharClassAtom
CUpper  -> String -> Doc ()
forall a. IsString a => String -> a
fromString String
"upper"