{-
    BNF Converter: Abstract syntax
    Copyright (C) 2004  Author: Markus Forsberg, Aarne Ranta

-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}  -- for type equality ~
{-# LANGUAGE NoMonoLocalBinds #-} -- counteract TypeFamilies

-- | Check LBNF input file and turn it into the 'CF' internal representation.

module BNFC.GetCF
  ( parseCF
  , checkRule, transItem
  ) where

import Control.Arrow (left)
import Control.Monad.Reader (ReaderT, runReaderT, MonadReader(..), asks)
import Control.Monad.State (State, evalState, get, modify)
import Control.Monad.Except (MonadError(..))

import Data.Char
import Data.Either  (partitionEithers)
import Data.Functor (($>)) -- ((<&>)) -- only from ghc 8.4
import Data.List    (nub, partition)
import Data.List.NonEmpty (pattern (:|))
import qualified Data.List as List
import qualified Data.List.NonEmpty as List1
import Data.Maybe

import Data.Set (Set)
import qualified Data.Foldable as Fold
import qualified Data.Set      as Set
import qualified Data.Map      as Map

import System.Exit (exitFailure)
import System.IO   (hPutStrLn, stderr)

-- Local imports:

import qualified BNFC.Abs as Abs
import BNFC.Abs (Reg(RAlts))
import BNFC.Par

import BNFC.CF
import BNFC.Check.EmptyTypes
import BNFC.Options
import BNFC.PrettyPrint
import BNFC.Regex       (nullable, simpReg)
import BNFC.TypeChecker
import BNFC.Utils

type Err = Either String

-- $setup
-- >>> import BNFC.Print

-- | Entrypoint.

parseCF :: SharedOptions -> Target -> String -> IO CF
parseCF :: SharedOptions -> Target -> String -> IO CF
parseCF SharedOptions
opts Target
target String
content = do
  CF
cf <- forall {a}. Either String a -> IO a
runErr forall a b. (a -> b) -> a -> b
$ [Token] -> Either String Grammar
pGrammar (String -> [Token]
myLexer String
content)
                    -- <&> expandRules -- <&> from ghc 8.4
                    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Grammar -> Grammar
expandRules
                    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SharedOptions -> Grammar -> Either String CF
getCF SharedOptions
opts
                    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. CF -> CF
markTokenCategories

  -- Construct the typing information in 'define' expressions.
  CF
cf <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. String -> IO a
die forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Err a -> Either String a
runTypeChecker forall a b. (a -> b) -> a -> b
$ CF -> Err CF
checkDefinitions CF
cf

  -- Some backends do not allow the grammar name to coincide with
  -- one of the category or constructor names.
  let names :: [RString]
names    = CF -> [RString]
allNames CF
cf
  forall m. Monoid m => Bool -> m -> m
when (Target
target forall a. Eq a => a -> a -> Bool
== Target
TargetJava) forall a b. (a -> b) -> a -> b
$
    case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((SharedOptions -> String
lang SharedOptions
opts forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. WithPosition a -> a
wpThing) [RString]
names of
      Maybe RString
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just RString
px ->
        String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
          [ [String] -> String
unwords forall a b. (a -> b) -> a -> b
$
            [ String
"ERROR of backend", forall a. Show a => a -> String
show Target
target forall a. [a] -> [a] -> [a]
++ String
":"
            , String
"the language name"
            , SharedOptions -> String
lang SharedOptions
opts
            , String
"conflicts with a name defined in the grammar:"
            ]
          , RString -> String
blendInPosition RString
px
          ]

  -- Some (most) backends do not support layout.
  let (Maybe String
layoutTop, LayoutKeyWords
layoutKeywords, [String]
_) = CF -> (Maybe String, LayoutKeyWords, [String])
layoutPragmas CF
cf
  let lay :: Bool
lay = forall a. Maybe a -> Bool
isJust Maybe String
layoutTop Bool -> Bool -> Bool
|| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null LayoutKeyWords
layoutKeywords)
  forall m. Monoid m => Bool -> m -> m
when (Bool
lay Bool -> Bool -> Bool
&& Target
target forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem`
    [ Target
TargetHaskell, Target
TargetHaskellGadt, Target
TargetLatex, Target
TargetPygments, Target
TargetCheck ]) forall a b. (a -> b) -> a -> b
$
      String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
        [ String
"ERROR: the grammar uses layout, which is not supported by backend"
        , forall a. Show a => a -> String
show Target
target forall a. [a] -> [a] -> [a]
++ String
"."
        ]

  -- A grammar that uses layout needs to contain symbols { } ;
  let symbols :: [String]
symbols = forall function. CFG function -> [String]
cfgSymbols CF
cf
      layoutSymbols :: [String]
layoutSymbols = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [String
";"], forall m. Monoid m => Bool -> m -> m
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null LayoutKeyWords
layoutKeywords) [String
"{", String
"}"] ]
      missingLayoutSymbols :: [String]
missingLayoutSymbols = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
symbols) [String]
layoutSymbols
  forall m. Monoid m => Bool -> m -> m
when (Bool
lay Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
missingLayoutSymbols)) forall a b. (a -> b) -> a -> b
$
      String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords forall a b. (a -> b) -> a -> b
$
        String
"ERROR: the grammar uses layout, but does not mention"
        forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [String]
missingLayoutSymbols

  -- Token types that end in a numeral confuse BNFC, because of CoerceCat.
  let userTokenTypes :: [RString]
userTokenTypes = [ RString
rx | TokenReg RString
rx Bool
_ Reg
_ <- forall function. CFG function -> [Pragma]
cfgPragmas CF
cf ]
  case forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe (String, Integer)
hasNumericSuffix forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. WithPosition a -> a
wpThing) [RString]
userTokenTypes of
    []  -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [RString]
rxs -> String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
             [ [ String
"ERROR: illegal token names:" ]
             , [RString] -> [String]
printNames [RString]
rxs
             , [ String
"Token names may not end with a number---to avoid confusion with coercion categories." ]
             ]

  -- Fail if grammar defines a @token@ twice.
  case forall (t :: * -> *) b a.
(Foldable t, Ord b) =>
(a -> b) -> t a -> [List1 a]
duplicatesOn forall a. WithPosition a -> a
wpThing [RString]
userTokenTypes of
    [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [List1 RString]
gs -> String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
             [ [ String
"ERROR: duplicate token definitions:" ]
             , forall a b. (a -> b) -> [a] -> [b]
map List1 RString -> String
printDuplicateTokenDefs [List1 RString]
gs
             ]
      where
      printDuplicateTokenDefs :: List1 RString -> String
printDuplicateTokenDefs (RString
rx :| [RString]
rxs) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
         [ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"  ", forall a. WithPosition a -> a
wpThing RString
rx, String
" at " ]
         , [String] -> String
unwords forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Position -> String
prettyPosition forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. WithPosition a -> Position
wpPosition) (RString
rx forall a. a -> [a] -> [a]
: [RString]
rxs)
         ]

  -- Fail if token name conflicts with category name.
  let userTokenNames :: Map String RString
userTokenNames = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\ RString
rx -> (forall a. WithPosition a -> a
wpThing RString
rx, RString
rx)) [RString]
userTokenTypes
  case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\ RString
rx -> (RString
rx,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall a. WithPosition a -> a
wpThing RString
rx) Map String RString
userTokenNames) (CF -> [RString]
allCatsIdNorm CF
cf) of
    [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [(RString, RString)]
ns -> String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
             [ [ String
"ERROR: these token definitions conflict with non-terminals:" ]
             , forall a b. (a -> b) -> [a] -> [b]
map (\ (RString
rx, RString
rp) -> String
"  " forall a. [a] -> [a] -> [a]
++ RString -> String
blendInPosition RString
rp forall a. [a] -> [a] -> [a]
++ String
" conflicts with " forall a. [a] -> [a] -> [a]
++ RString -> String
blendInPosition RString
rx) [(RString, RString)]
ns
             ]

  -- Warn or fail if the grammar uses non unique names.
  let nonUniqueNames :: [RString]
nonUniqueNames = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsFun a => a -> Bool
isDefinedRule) forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
filterNonUnique [RString]
names
  case [RString]
nonUniqueNames of
    [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [RString]
ns | Target
target forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Target
TargetC, Target
TargetCpp , Target
TargetCppNoStl , Target
TargetJava ]
       -> String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [ String
"ERROR: names not unique:" ]
            , [RString] -> [String]
printNames [RString]
ns
            , [ String
"This is an error in the backend " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Target
target forall a. [a] -> [a] -> [a]
++ String
"." ]
            ]
       | Bool
otherwise
       -> String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [ String
"Warning: names not unique:" ]
            , [RString] -> [String]
printNames [RString]
ns
            , [ String
"This can be an error in some backends." ]
            ]

  -- Warn or fail if the grammar uses names not unique modulo upper/lowercase.
  forall m. Monoid m => Bool -> m -> m
when Bool
False forall a b. (a -> b) -> a -> b
$
   case forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [RString]
nonUniqueNames) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsFun a => a -> Bool
isDefinedRule) forall a b. (a -> b) -> a -> b
$
       forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. NonEmpty a -> [a]
List1.toList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
(Foldable t, Ord b) =>
(a -> b) -> t a -> [List1 a]
duplicatesOn (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. WithPosition a -> a
wpThing) [RString]
names of
    [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [RString]
ns | Target
target forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Target
TargetJava ]
       -> String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [ String
"ERROR: names not unique ignoring case:" ]
            , [RString] -> [String]
printNames [RString]
ns
            , [ String
"This is an error in the backend " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Target
target forall a. [a] -> [a] -> [a]
++ String
"."]
            ]
       | Bool
otherwise
       -> String -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [ String
"Warning: names not unique ignoring case:" ]
            , [RString] -> [String]
printNames [RString]
ns
            , [ String
"This can be an error in some backends." ]
            ]

  -- Note: the following @() <-@ works around an @Ambiguous type variable@
  () <- forall m. Monoid m => Bool -> m -> m
when (forall g. CFG g -> Bool
hasPositionTokens CF
cf Bool -> Bool -> Bool
&& Target
target forall a. Eq a => a -> a -> Bool
== Target
TargetCppNoStl) forall a b. (a -> b) -> a -> b
$
      String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
        [ String
"Warning: the backend"
        , forall a. Show a => a -> String
show Target
target
        , String
"ignores the qualifier `position` in token definitions."
        ]

  -- Fail if the grammar uses defined constructors which are not actually defined.
  let definedConstructors :: Set RString
definedConstructors = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Define -> RString
defName forall a b. (a -> b) -> a -> b
$ forall f. CFG f -> [Define]
definitions CF
cf
  let undefinedConstructor :: RString -> Bool
undefinedConstructor RString
x = forall a. IsFun a => a -> Bool
isDefinedRule RString
x Bool -> Bool -> Bool
&& RString
x forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set RString
definedConstructors
  case forall a. (a -> Bool) -> [a] -> [a]
filter RString -> Bool
undefinedConstructor forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall function. Rul function -> function
funRule forall a b. (a -> b) -> a -> b
$ forall function. CFG function -> [Rul function]
cfgRules CF
cf of
    [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [RString]
xs -> String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [ String
"Lower case rule labels need a definition."
              , String
"ERROR: undefined rule label(s):"
              ]
            , [RString] -> [String]
printNames [RString]
xs
            ]

  -- Print errors for empty comment deliminters
  forall m a. Monoid m => [a] -> ([a] -> m) -> m
unlessNull (forall function. CFG function -> [String]
checkComments CF
cf) forall a b. (a -> b) -> a -> b
$ \ [String]
errs -> do
    String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
errs

  -- Print warnings if user defined nullable tokens.
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
Fold.mapM_ String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$ forall f. CFG f -> Maybe String
checkTokens CF
cf

  -- Check for empty grammar.
  let nRules :: Int
nRules = forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall function. CFG function -> [Rul function]
cfgRules CF
cf)
  -- Note: the match against () is necessary for type class instance resolution.
  forall m. Monoid m => Bool -> m -> m
when (Int
nRules forall a. Eq a => a -> a -> Bool
== Int
0) forall a b. (a -> b) -> a -> b
$ String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$ String
"ERROR: the grammar contains no rules."

  -- Check whether one of the parsers could consume at least one token. [#213]
  forall m. Monoid m => Bool -> m -> m
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall function. CFG function -> [String]
usedTokenCats CF
cf) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall f. CFG f -> [(String, Int)]
cfTokens CF
cf)) forall a b. (a -> b) -> a -> b
$
    String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$
      String
"ERROR: the languages defined by this grammar are empty since it mentions no terminals."

  forall m a. Monoid m => [a] -> ([a] -> m) -> m
unlessNull (forall f. IsFun f => [Rul f] -> [RCat]
emptyData forall a b. (a -> b) -> a -> b
$ forall function. CFG function -> [Rul function]
cfgRules CF
cf) forall a b. (a -> b) -> a -> b
$ \ [RCat]
pcs -> do
    String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ String
"ERROR: the following categories have empty abstract syntax:" ]
      , [RString] -> [String]
printNames forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cat -> String
catToStr) [RCat]
pcs
      ]

  -- Passed the tests: Print the number of rules.
  String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
nRules String -> String -> String
+++ String
"rules accepted\n"
  forall (m :: * -> *) a. Monad m => a -> m a
return CF
cf

  where
  runErr :: Either String a -> IO a
runErr = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. String -> IO a
die forall (m :: * -> *) a. Monad m => a -> m a
return

  dieUnlessForce :: String -> IO ()
  dieUnlessForce :: String -> IO ()
dieUnlessForce String
msg = do
    Handle -> String -> IO ()
hPutStrLn Handle
stderr String
msg
    if SharedOptions -> Bool
force SharedOptions
opts then do
      Handle -> String -> IO ()
hPutStrLn Handle
stderr
        String
"Ignoring error... (thanks to --force)"
    else do
      Handle -> String -> IO ()
hPutStrLn Handle
stderr
        String
"Aborting.  (Use option --force to continue despite errors.)"
      forall a. IO a
exitFailure

  -- | All token categories used in the grammar.
  --   Includes internal rules.
  usedTokenCats :: CFG f -> [TokenCat]
  usedTokenCats :: forall function. CFG function -> [String]
usedTokenCats CFG f
cf = [ String
c | Rule f
_ RCat
_ SentForm
rhs InternalRule
_ <- forall function. CFG function -> [Rul function]
cfgRules CFG f
cf, Left (TokenCat String
c) <- SentForm
rhs ]

-- | Print vertical list of names with position sorted by position.
printNames :: [RString] -> [String]
printNames :: [RString] -> [String]
printNames = forall a b. (a -> b) -> [a] -> [b]
map ((String
"  " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. RString -> String
blendInPosition) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn forall {b}. WithPosition b -> (Position, b)
lexicoGraphic
  where
  lexicoGraphic :: WithPosition b -> (Position, b)
lexicoGraphic (WithPosition Position
pos b
x) = (Position
pos,b
x)

die :: String -> IO a
die :: forall a. String -> IO a
die String
msg = do
  Handle -> String -> IO ()
hPutStrLn Handle
stderr String
msg
  forall a. IO a
exitFailure

-- | Translate the parsed grammar file into a context-free grammar 'CF'.
--   Desugars and type-checks.

getCF :: SharedOptions -> Abs.Grammar -> Err CF
getCF :: SharedOptions -> Grammar -> Either String CF
getCF SharedOptions
opts (Abs.Grammar [Def]
defs) = do
    ([Pragma]
pragma, [Rule]
rules) <- forall a b. [Either a b] -> ([a], [b])
partitionEithers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Def -> Trans [Either Pragma Rule]
transDef [Def]
defs forall a. Trans a -> SharedOptions -> Err a
`runTrans` SharedOptions
opts
    let reservedWords :: [String]
reservedWords      = forall a. Eq a => [a] -> [a]
nub [ String
t | Rule
r <- [Rule]
rules, forall f. Rul f -> Bool
isParsable Rule
r, Right String
t <- forall function. Rul function -> SentForm
rhsRule Rule
r, Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
t ]
          -- Issue #204: exclude keywords from internal rules
          -- Issue #70: whitespace separators should be treated like "", at least in the parser
        usedCats :: Set Cat
usedCats           = forall a. Ord a => [a] -> Set a
Set.fromList [ Cat
c | Rule RString
_ RCat
_ SentForm
rhs InternalRule
_ <- [Rule]
rules, Left Cat
c <- SentForm
rhs ]
        -- literals = used builtin token cats (Integer, String, ...)
        literals :: [String]
literals           = forall a. (a -> Bool) -> [a] -> [a]
filter (\ String
s -> String -> Cat
TokenCat String
s forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Cat
usedCats) forall a b. (a -> b) -> a -> b
$ [String]
specialCatsP
        ([String]
symbols,[String]
keywords) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition String -> Bool
notIdent [String]
reservedWords
    Signature
sig <- forall a. Err a -> Either String a
runTypeChecker forall a b. (a -> b) -> a -> b
$ [Rule] -> Err Signature
buildSignature [Rule]
rules
    let
      cf :: CF
cf = CF -> CF
revs forall a b. (a -> b) -> a -> b
$ CFG
        { cfgPragmas :: [Pragma]
cfgPragmas        = [Pragma]
pragma
        , cfgUsedCats :: Set Cat
cfgUsedCats       = Set Cat
usedCats
        , cfgLiterals :: [String]
cfgLiterals       = [String]
literals
        , cfgSymbols :: [String]
cfgSymbols        = [String]
symbols
        , cfgKeywords :: [String]
cfgKeywords       = [String]
keywords
        , cfgReversibleCats :: [Cat]
cfgReversibleCats = []
        , cfgRules :: [Rule]
cfgRules          = [Rule]
rules
        , cfgSignature :: Signature
cfgSignature      = Signature
sig
        }
    case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (CF -> Rule -> Maybe String
checkRule CF
cf) [Rule]
rules of
      [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      [String]
msgs -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
msgs
    forall (m :: * -> *) a. Monad m => a -> m a
return CF
cf
  where
    notIdent :: String -> Bool
notIdent String
s       = forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s Bool -> Bool -> Bool
|| Bool -> Bool
not (Char -> Bool
isAlpha (forall a. [a] -> a
head String
s)) Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isIdentRest) String
s
    isIdentRest :: Char -> Bool
isIdentRest Char
c    = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\''
    revs :: CF -> CF
revs CF
cf =
        CF
cf{ cfgReversibleCats :: [Cat]
cfgReversibleCats = CF -> [Cat]
findAllReversibleCats CF
cf }

-- | This function goes through each rule of a grammar and replace Cat "X" with
-- TokenCat "X" when "X" is a token type.
markTokenCategories :: CF -> CF
markTokenCategories :: CF -> CF
markTokenCategories CF
cf = forall a. FixTokenCats a => [String] -> a -> a
fixTokenCats [String]
tokenCatNames CF
cf
  where
  tokenCatNames :: [String]
tokenCatNames = [ forall a. WithPosition a -> a
wpThing RString
n | TokenReg RString
n Bool
_ Reg
_ <- forall function. CFG function -> [Pragma]
cfgPragmas CF
cf ] forall a. [a] -> [a] -> [a]
++ [String]
specialCatsP

class FixTokenCats a where
  fixTokenCats :: [TokenCat] -> a -> a

  default fixTokenCats :: (Functor t, FixTokenCats b, t b ~ a) => [TokenCat] -> a -> a
  fixTokenCats = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FixTokenCats a => [String] -> a -> a
fixTokenCats

instance FixTokenCats a => FixTokenCats [a]
instance FixTokenCats a => FixTokenCats (WithPosition a)

instance (FixTokenCats a, Ord a) => FixTokenCats (Set a) where
  fixTokenCats :: [String] -> Set a -> Set a
fixTokenCats = forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FixTokenCats a => [String] -> a -> a
fixTokenCats

-- | Change the constructor of categories with the given names from Cat to
-- TokenCat
-- >>> fixTokenCats ["A"] (Cat "A") == TokenCat "A"
-- True
-- >>> fixTokenCats ["A"] (ListCat (Cat "A")) == ListCat (TokenCat "A")
-- True
-- >>> fixTokenCats ["A"] (Cat "B") == Cat "B"
-- True

instance FixTokenCats Cat where
  fixTokenCats :: [String] -> Cat -> Cat
fixTokenCats [String]
ns = \case
    Cat String
a | String
a forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
ns -> String -> Cat
TokenCat String
a
    ListCat Cat
c           -> Cat -> Cat
ListCat forall a b. (a -> b) -> a -> b
$ forall a. FixTokenCats a => [String] -> a -> a
fixTokenCats [String]
ns Cat
c
    Cat
c -> Cat
c

instance FixTokenCats (Either Cat String) where
  fixTokenCats :: [String] -> Either Cat String -> Either Cat String
fixTokenCats = forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FixTokenCats a => [String] -> a -> a
fixTokenCats

instance FixTokenCats (Rul f) where
  fixTokenCats :: [String] -> Rul f -> Rul f
fixTokenCats [String]
ns (Rule f
f RCat
c SentForm
rhs InternalRule
internal) =
    forall function.
function -> RCat -> SentForm -> InternalRule -> Rul function
Rule f
f (forall a. FixTokenCats a => [String] -> a -> a
fixTokenCats [String]
ns RCat
c) (forall a. FixTokenCats a => [String] -> a -> a
fixTokenCats [String]
ns SentForm
rhs) InternalRule
internal

instance FixTokenCats Pragma where
  fixTokenCats :: [String] -> Pragma -> Pragma
fixTokenCats [String]
ns = \case
    EntryPoints [RCat]
eps -> [RCat] -> Pragma
EntryPoints forall a b. (a -> b) -> a -> b
$ forall a. FixTokenCats a => [String] -> a -> a
fixTokenCats [String]
ns [RCat]
eps
    Pragma
p -> Pragma
p

instance FixTokenCats (CFG f) where
  fixTokenCats :: [String] -> CFG f -> CFG f
fixTokenCats [String]
ns cf :: CFG f
cf@CFG{[String]
[Cat]
[Pragma]
[Rul f]
Signature
Set Cat
cfgSignature :: Signature
cfgRules :: [Rul f]
cfgReversibleCats :: [Cat]
cfgKeywords :: [String]
cfgSymbols :: [String]
cfgLiterals :: [String]
cfgUsedCats :: Set Cat
cfgPragmas :: [Pragma]
cfgSignature :: forall function. CFG function -> Signature
cfgReversibleCats :: forall function. CFG function -> [Cat]
cfgKeywords :: forall function. CFG function -> [String]
cfgLiterals :: forall function. CFG function -> [String]
cfgUsedCats :: forall function. CFG function -> Set Cat
cfgRules :: forall function. CFG function -> [Rul function]
cfgPragmas :: forall function. CFG function -> [Pragma]
cfgSymbols :: forall function. CFG function -> [String]
..} = CFG f
cf
    { cfgPragmas :: [Pragma]
cfgPragmas  = forall a. FixTokenCats a => [String] -> a -> a
fixTokenCats [String]
ns [Pragma]
cfgPragmas
    , cfgUsedCats :: Set Cat
cfgUsedCats = forall a. FixTokenCats a => [String] -> a -> a
fixTokenCats [String]
ns Set Cat
cfgUsedCats
    , cfgRules :: [Rul f]
cfgRules    = forall a. FixTokenCats a => [String] -> a -> a
fixTokenCats [String]
ns [Rul f]
cfgRules
    }

-- | Translation monad.
newtype Trans a = Trans { forall a. Trans a -> ReaderT SharedOptions (Either String) a
unTrans :: ReaderT SharedOptions Err a }
  deriving (forall a b. a -> Trans b -> Trans a
forall a b. (a -> b) -> Trans a -> Trans b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Trans b -> Trans a
$c<$ :: forall a b. a -> Trans b -> Trans a
fmap :: forall a b. (a -> b) -> Trans a -> Trans b
$cfmap :: forall a b. (a -> b) -> Trans a -> Trans b
Functor, Functor Trans
forall a. a -> Trans a
forall a b. Trans a -> Trans b -> Trans a
forall a b. Trans a -> Trans b -> Trans b
forall a b. Trans (a -> b) -> Trans a -> Trans b
forall a b c. (a -> b -> c) -> Trans a -> Trans b -> Trans c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. Trans a -> Trans b -> Trans a
$c<* :: forall a b. Trans a -> Trans b -> Trans a
*> :: forall a b. Trans a -> Trans b -> Trans b
$c*> :: forall a b. Trans a -> Trans b -> Trans b
liftA2 :: forall a b c. (a -> b -> c) -> Trans a -> Trans b -> Trans c
$cliftA2 :: forall a b c. (a -> b -> c) -> Trans a -> Trans b -> Trans c
<*> :: forall a b. Trans (a -> b) -> Trans a -> Trans b
$c<*> :: forall a b. Trans (a -> b) -> Trans a -> Trans b
pure :: forall a. a -> Trans a
$cpure :: forall a. a -> Trans a
Applicative, Applicative Trans
forall a. a -> Trans a
forall a b. Trans a -> Trans b -> Trans b
forall a b. Trans a -> (a -> Trans b) -> Trans b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> Trans a
$creturn :: forall a. a -> Trans a
>> :: forall a b. Trans a -> Trans b -> Trans b
$c>> :: forall a b. Trans a -> Trans b -> Trans b
>>= :: forall a b. Trans a -> (a -> Trans b) -> Trans b
$c>>= :: forall a b. Trans a -> (a -> Trans b) -> Trans b
Monad, MonadReader SharedOptions, MonadError String)

runTrans :: Trans a -> SharedOptions -> Err a
runTrans :: forall a. Trans a -> SharedOptions -> Err a
runTrans Trans a
m SharedOptions
opts = forall a. Trans a -> ReaderT SharedOptions (Either String) a
unTrans Trans a
m forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` SharedOptions
opts

transDef :: Abs.Def -> Trans [Either Pragma Rule]
transDef :: Def -> Trans [Either Pragma Rule]
transDef = \case
    Abs.Rule Label
label Cat
cat [Item]
items  -> do
      RString
f <- Label -> Trans RString
transLabel Label
label
      RCat
c <- Cat -> Trans RCat
transCat Cat
cat
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall function.
function -> RCat -> SentForm -> InternalRule -> Rul function
Rule RString
f RCat
c (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Item -> SentForm
transItem [Item]
items) InternalRule
Parsable ]
    Abs.Internal Label
label Cat
cat [Item]
items  -> do
      RString
f <- Label -> Trans RString
transLabel Label
label
      RCat
c <- Cat -> Trans RCat
transCat Cat
cat
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall function.
function -> RCat -> SentForm -> InternalRule -> Rul function
Rule RString
f RCat
c (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Item -> SentForm
transItem [Item]
items) InternalRule
Internal ]

    Abs.Comment String
str               -> forall (m :: * -> *) a. Monad m => a -> m a
return [ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Pragma
CommentS String
str ]
    Abs.Comments String
str1 String
str2        -> forall (m :: * -> *) a. Monad m => a -> m a
return [ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ (String, String) -> Pragma
CommentM (String
str1, String
str2) ]

    Abs.Token Identifier
ident Reg
reg           -> do RString
x <- Identifier -> Trans RString
transIdent Identifier
ident; forall (m :: * -> *) a. Monad m => a -> m a
return [forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ RString -> Bool -> Reg -> Pragma
TokenReg RString
x Bool
False forall a b. (a -> b) -> a -> b
$ Reg -> Reg
simpReg Reg
reg]
    Abs.PosToken Identifier
ident Reg
reg        -> do RString
x <- Identifier -> Trans RString
transIdent Identifier
ident; forall (m :: * -> *) a. Monad m => a -> m a
return [forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ RString -> Bool -> Reg -> Pragma
TokenReg RString
x Bool
True  forall a b. (a -> b) -> a -> b
$ Reg -> Reg
simpReg Reg
reg]
    Abs.Entryp [Cat]
cats               -> forall a. a -> [a]
singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RCat] -> Pragma
EntryPoints forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Cat -> Trans RCat
transCat [Cat]
cats
    Abs.Separator MinimumSize
size Cat
ident String
str  -> forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MinimumSize -> Cat -> String -> Trans [Rule]
separatorRules MinimumSize
size Cat
ident String
str
    Abs.Terminator MinimumSize
size Cat
ident String
str -> forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MinimumSize -> Cat -> String -> Trans [Rule]
terminatorRules MinimumSize
size Cat
ident String
str
    Abs.Delimiters Cat
cat String
_ String
_ Separation
_ MinimumSize
_    -> do
      WithPosition Position
pos Cat
_ <- Cat -> Trans RCat
transCat Cat
cat
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ RString -> String
blendInPosition forall a b. (a -> b) -> a -> b
$ forall a. Position -> a -> WithPosition a
WithPosition Position
pos forall a b. (a -> b) -> a -> b
$
        String
"The delimiters pragma " forall a. [a] -> [a] -> [a]
++ String
removedIn290
    Abs.Coercions Identifier
ident Integer
int       -> forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Identifier -> Integer -> Trans [Rule]
coercionRules Identifier
ident Integer
int
    Abs.Rules Identifier
ident [RHS]
strs          -> forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Identifier -> [RHS] -> Trans [Rule]
ebnfRules Identifier
ident [RHS]
strs
    Abs.Layout [String]
ss                 -> forall (m :: * -> *) a. Monad m => a -> m a
return [ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ LayoutKeyWords -> Pragma
Layout forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (,String -> String -> String -> Delimiters
Delimiters String
";" String
"{" String
"}") [String]
ss ]
    Abs.LayoutStop [String]
ss             -> forall (m :: * -> *) a. Monad m => a -> m a
return [ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [String] -> Pragma
LayoutStop [String]
ss]
    Def
Abs.LayoutTop                 -> forall (m :: * -> *) a. Monad m => a -> m a
return [ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Pragma
LayoutTop String
";" ]
    Abs.Function Identifier
ident [Arg]
xs Exp
e       -> do
      RString
f <- Identifier -> Trans RString
transIdent Identifier
ident
      let xs' :: [(String, Base)]
xs' = forall a b. (a -> b) -> [a] -> [b]
map Arg -> (String, Base)
transArg [Arg]
xs
      forall (m :: * -> *) a. Monad m => a -> m a
return [ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Define -> Pragma
FunDef forall a b. (a -> b) -> a -> b
$ RString -> [(String, Base)] -> Exp -> Base -> Define
Define RString
f [(String, Base)]
xs' ([String] -> Exp -> Exp
transExp (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(String, Base)]
xs') Exp
e) Base
dummyBase ]

-- | Translate @separator [nonempty] C "s"@.
--   The position attached to the generated rules is taken from @C@.
--
--   (Ideally, we would take them from the @separator@ keyword.
--   But BNFC does not deliver position information there.)
--
--   If the user-provided separator consists of white space only,
--   we turn it into a terminator rule to prevent reduce/reduce conflicts.

separatorRules :: Abs.MinimumSize -> Abs.Cat -> String -> Trans [Rule]
separatorRules :: MinimumSize -> Cat -> String -> Trans [Rule]
separatorRules MinimumSize
size Cat
c0 String
s
  | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
s = MinimumSize -> Cat -> String -> Trans [Rule]
terminatorRules MinimumSize
size Cat
c0 String
s
  | Bool
otherwise     = do
      WithPosition Position
pos Cat
c <- Cat -> Trans RCat
transCat Cat
c0
      let cs :: Cat
cs = Cat -> Cat
ListCat Cat
c
      let rule :: String -> SentForm -> Rule
          rule :: String -> SentForm -> Rule
rule String
x SentForm
rhs = forall function.
function -> RCat -> SentForm -> InternalRule -> Rul function
Rule (forall a. Position -> a -> WithPosition a
WithPosition Position
pos String
x) (forall a. Position -> a -> WithPosition a
WithPosition Position
pos Cat
cs) SentForm
rhs InternalRule
Parsable
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [ String -> SentForm -> Rule
rule String
"[]"    []                         | MinimumSize
size forall a. Eq a => a -> a -> Bool
== MinimumSize
Abs.MEmpty ]
        , [ String -> SentForm -> Rule
rule String
"(:[])" [forall a b. a -> Either a b
Left Cat
c]                   ]
        , [ String -> SentForm -> Rule
rule String
"(:)"   [forall a b. a -> Either a b
Left Cat
c, forall a b. b -> Either a b
Right String
s, forall a b. a -> Either a b
Left Cat
cs] ]
        ]

-- | Translate @terminator [nonempty] C "s"@.
--   The position attached to the generated rules is taken from @C@.
--
--   (Ideally, we would take them from the @terminator@ keyword.
--   But BNFC does not deliver position information there.)

terminatorRules :: Abs.MinimumSize -> Abs.Cat -> String -> Trans [Rule]
terminatorRules :: MinimumSize -> Cat -> String -> Trans [Rule]
terminatorRules MinimumSize
size Cat
c0 String
s = do
  WithPosition Position
pos Cat
c <- Cat -> Trans RCat
transCat Cat
c0
  let wp :: a -> WithPosition a
wp = forall a. Position -> a -> WithPosition a
WithPosition Position
pos
  let cs :: Cat
cs = Cat -> Cat
ListCat Cat
c
  let rule :: a -> SentForm -> Rul (WithPosition a)
rule a
x SentForm
rhs = forall function.
function -> RCat -> SentForm -> InternalRule -> Rul function
Rule (forall {a}. a -> WithPosition a
wp a
x) (forall {a}. a -> WithPosition a
wp Cat
cs) SentForm
rhs InternalRule
Parsable
  forall (m :: * -> *) a. Monad m => a -> m a
return
    [ case MinimumSize
size of
      MinimumSize
Abs.MNonempty ->
        forall {a}. a -> SentForm -> Rul (WithPosition a)
rule String
"(:[])" (forall a b. a -> Either a b
Left Cat
c forall a. a -> [a] -> [a]
: forall {a}. [Either a String] -> [Either a String]
term [])
      MinimumSize
Abs.MEmpty ->
        forall {a}. a -> SentForm -> Rul (WithPosition a)
rule String
"[]"    []
    ,   forall {a}. a -> SentForm -> Rul (WithPosition a)
rule String
"(:)"   (forall a b. a -> Either a b
Left Cat
c forall a. a -> [a] -> [a]
: forall {a}. [Either a String] -> [Either a String]
term [forall a b. a -> Either a b
Left Cat
cs])
    ]
  where
  term :: [Either a String] -> [Either a String]
term = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s then forall a. a -> a
id else (forall a b. b -> Either a b
Right String
s forall a. a -> [a] -> [a]
:)

-- | Expansion of the @coercion@ pragma.

coercionRules :: Abs.Identifier -> Integer -> Trans [Rule]
coercionRules :: Identifier -> Integer -> Trans [Rule]
coercionRules Identifier
c0 Integer
n = do
  WithPosition Position
pos String
c <- Identifier -> Trans RString
transIdent Identifier
c0
  let wp :: a -> WithPosition a
wp = forall a. Position -> a -> WithPosition a
WithPosition Position
pos
  let urule :: Cat -> SentForm -> Rul (WithPosition a)
urule Cat
x SentForm
rhs = forall function.
function -> RCat -> SentForm -> InternalRule -> Rul function
Rule (forall {a}. a -> WithPosition a
wp a
"_") (forall {a}. a -> WithPosition a
wp Cat
x) SentForm
rhs InternalRule
Parsable
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ forall {a}. IsString a => Cat -> SentForm -> Rul (WithPosition a)
urule (String -> Cat
Cat String
c)            [forall a b. a -> Either a b
Left (String -> Integer -> Cat
CoercCat String
c Integer
1)]                ]
    , [ forall {a}. IsString a => Cat -> SentForm -> Rul (WithPosition a)
urule (String -> Integer -> Cat
CoercCat String
c (Integer
iforall a. Num a => a -> a -> a
-Integer
1)) [forall a b. a -> Either a b
Left (String -> Integer -> Cat
CoercCat String
c Integer
i)]                | Integer
i <- [Integer
2..Integer
n] ]
    , [ forall {a}. IsString a => Cat -> SentForm -> Rul (WithPosition a)
urule (String -> Integer -> Cat
CoercCat String
c Integer
n)     [forall a b. b -> Either a b
Right String
"(", forall a b. a -> Either a b
Left (String -> Cat
Cat String
c), forall a b. b -> Either a b
Right String
")"] ]
    ]

-- | Expansion of the @rules@ pragma.

ebnfRules :: Abs.Identifier -> [Abs.RHS] -> Trans [Rule]
ebnfRules :: Identifier -> [RHS] -> Trans [Rule]
ebnfRules (Abs.Identifier ((Int
line, Int
col), String
c)) [RHS]
rhss = do
  String
file <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SharedOptions -> String
lbnfFile
  let wp :: a -> WithPosition a
wp = forall a. Position -> a -> WithPosition a
WithPosition forall a b. (a -> b) -> a -> b
$ String -> Int -> Int -> Position
Position String
file Int
line Int
col
  let rule :: a -> SentForm -> Rul (WithPosition a)
rule a
x SentForm
rhs = forall function.
function -> RCat -> SentForm -> InternalRule -> Rul function
Rule (forall {a}. a -> WithPosition a
wp a
x) (forall {a}. a -> WithPosition a
wp forall a b. (a -> b) -> a -> b
$ String -> Cat
strToCat String
c) SentForm
rhs InternalRule
Parsable
  forall (m :: * -> *) a. Monad m => a -> m a
return
    [ forall {a}. a -> SentForm -> Rul (WithPosition a)
rule (forall {a}. Show a => a -> [Item] -> String
mkFun Int
k [Item]
its) (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Item -> SentForm
transItem [Item]
its)
    | (Int
k, Abs.RHS [Item]
its) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] [RHS]
rhss
    ]
 where
   mkFun :: a -> [Item] -> String
mkFun a
k = \case
     [Abs.Terminal String
s]  -> String
c' forall a. [a] -> [a] -> [a]
++ String
"_" forall a. [a] -> [a] -> [a]
++ forall {a}. Show a => a -> String -> String
mkName a
k String
s
     [Abs.NTerminal Cat
n] -> String
c' forall a. [a] -> [a] -> [a]
++ Cat -> String
identCat (Cat -> Cat
transCat' Cat
n)
     [Item]
_ -> String
c' forall a. [a] -> [a] -> [a]
++ String
"_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
k
   c' :: String
c' = String
c --- normCat c
   mkName :: a -> String -> String
mkName a
k String
s = if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
c (String
"_'" :: String)) String
s
                   then String
s else forall a. Show a => a -> String
show a
k

-- | Translate a rule item (terminal or non terminal)
-- It also sanitizes the terminals a bit by skipping empty terminals
-- or splitting multiwords terminals.
-- This means that the following rule
--
-- >  Foo. S ::= "foo bar" ""
--
-- is equivalent to
--
-- >  Foo. S ::= "foo" "bar"

transItem :: Abs.Item -> [Either Cat String]
transItem :: Item -> SentForm
transItem (Abs.Terminal String
str)  = [ forall a b. b -> Either a b
Right String
w | String
w <- String -> [String]
words String
str ]
transItem (Abs.NTerminal Cat
cat) = [ forall a b. a -> Either a b
Left (Cat -> Cat
transCat' Cat
cat) ]

transCat' :: Abs.Cat -> Cat
transCat' :: Cat -> Cat
transCat' = \case
    Abs.ListCat Cat
cat                      -> Cat -> Cat
ListCat forall a b. (a -> b) -> a -> b
$ Cat -> Cat
transCat' Cat
cat
    Abs.IdCat (Abs.Identifier ((Int, Int)
_pos, String
c)) -> String -> Cat
strToCat String
c

transCat :: Abs.Cat -> Trans (WithPosition Cat)
transCat :: Cat -> Trans RCat
transCat = \case
    Abs.ListCat Cat
cat                             -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cat -> Cat
ListCat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cat -> Trans RCat
transCat Cat
cat
    Abs.IdCat (Abs.Identifier ((Int
line, Int
col), String
c)) -> do
      String
file <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SharedOptions -> String
lbnfFile
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Position -> a -> WithPosition a
WithPosition (String -> Int -> Int -> Position
Position String
file Int
line Int
col) forall a b. (a -> b) -> a -> b
$ String -> Cat
strToCat String
c

transLabel :: Abs.Label -> Trans RFun
transLabel :: Label -> Trans RString
transLabel = \case
    Abs.Id Identifier
id     -> Identifier -> Trans RString
transIdent Identifier
id
    Label
Abs.Wild      -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {a}. a -> WithPosition a
noPosition forall a b. (a -> b) -> a -> b
$ String
"_"
    Label
Abs.ListE     -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {a}. a -> WithPosition a
noPosition forall a b. (a -> b) -> a -> b
$ String
"[]"
    Label
Abs.ListCons  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {a}. a -> WithPosition a
noPosition forall a b. (a -> b) -> a -> b
$ String
"(:)"
    Label
Abs.ListOne   -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {a}. a -> WithPosition a
noPosition forall a b. (a -> b) -> a -> b
$ String
"(:[])"

transIdent :: Abs.Identifier -> Trans RString
transIdent :: Identifier -> Trans RString
transIdent (Abs.Identifier ((Int
line, Int
col), String
str)) = do
  String
file <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SharedOptions -> String
lbnfFile
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Position -> a -> WithPosition a
WithPosition (String -> Int -> Int -> Position
Position String
file Int
line Int
col) String
str

transArg :: Abs.Arg -> (String, Base)
transArg :: Arg -> (String, Base)
transArg (Abs.Arg (Abs.Identifier ((Int, Int)
_pos, String
x))) = (String
x, Base
dummyBase)

transExp
  :: [String] -- ^ Arguments of definition (in scope in expression).
  -> Abs.Exp  -- ^ Expression.
  -> Exp      -- ^ Translated expression.
transExp :: [String] -> Exp -> Exp
transExp [String]
xs = Exp -> Exp
loop
  where
  loop :: Exp -> Exp
loop = \case
    Abs.App Identifier
x [Exp]
es    -> forall f. f -> Type -> [Exp' f] -> Exp' f
App (Identifier -> String
transIdent' Identifier
x) Type
dummyType (forall a b. (a -> b) -> [a] -> [b]
map Exp -> Exp
loop [Exp]
es)
    Abs.Var Identifier
x       -> let x' :: String
x' = Identifier -> String
transIdent' Identifier
x in
                       if String
x' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
xs then forall f. String -> Exp' f
Var String
x' else forall f. f -> Type -> [Exp' f] -> Exp' f
App String
x' Type
dummyType []
    Abs.Cons Exp
e1 Exp
e2  -> Exp -> Exp -> Exp
cons Exp
e1 (Exp -> Exp
loop Exp
e2)
    Abs.List [Exp]
es     -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp -> Exp -> Exp
cons Exp
nil [Exp]
es
    Abs.LitInt Integer
x    -> forall f. Integer -> Exp' f
LitInt Integer
x
    Abs.LitDouble Double
x -> forall f. Double -> Exp' f
LitDouble Double
x
    Abs.LitChar Char
x   -> forall f. Char -> Exp' f
LitChar Char
x
    Abs.LitString String
x -> forall f. String -> Exp' f
LitString String
x
  cons :: Exp -> Exp -> Exp
cons Exp
e1 Exp
e2 = forall f. f -> Type -> [Exp' f] -> Exp' f
App String
"(:)" Type
dummyType [Exp -> Exp
loop Exp
e1, Exp
e2]
  nil :: Exp
nil        = forall f. f -> Type -> [Exp' f] -> Exp' f
App String
"[]"  Type
dummyType []
  transIdent' :: Identifier -> String
transIdent' (Abs.Identifier ((Int, Int)
_pos, String
x)) = String
x

--------------------------------------------------------------------------------

-- | Check if any comment delimiter is null.
checkComments :: CFG f -> [String]  -- ^ List of errors.
checkComments :: forall function. CFG function -> [String]
checkComments CFG f
cf = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ String
"Empty line comment delimiter."        | CommentS String
""      <- [Pragma]
prags ]
  , [ String
"Empty block comment start delimiter." | CommentM (String
"", String
_) <- [Pragma]
prags ]
  , [ String
"Empty block comment end delimiter."   | CommentM (String
_, String
"") <- [Pragma]
prags ]
  ]
  where
  prags :: [Pragma]
prags = forall function. CFG function -> [Pragma]
cfgPragmas CFG f
cf

-- | Check if any of the user-defined terminal categories is nullable or empty.
checkTokens :: CFG f -> Maybe String
checkTokens :: forall f. CFG f -> Maybe String
checkTokens CFG f
cf =
  case forall a. [Maybe a] -> [a]
catMaybes [ forall f. CFG f -> Maybe String
checkTokensEmpty CFG f
cf, forall f. CFG f -> Maybe String
checkTokensNullable CFG f
cf ] of
    [] -> forall a. Maybe a
Nothing
    [String]
ss -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
ss

-- | Check if any of the user-defined terminal categories is nullable.
checkTokensNullable :: CFG f -> Maybe String
checkTokensNullable :: forall f. CFG f -> Maybe String
checkTokensNullable CFG f
cf
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RString]
pxs  = forall a. Maybe a
Nothing
  | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ String
"ERROR: The following tokens accept the empty string:" ]
      , [RString] -> [String]
printNames [RString]
pxs
      ]
  where
    pxs :: [RString]
pxs = [ RString
px | TokenReg RString
px Bool
_ Reg
regex <- forall function. CFG function -> [Pragma]
cfgPragmas CFG f
cf, Reg -> Bool
nullable Reg
regex ]

-- | Check if any of the user-defined terminal categories is nullable.
checkTokensEmpty :: CFG f -> Maybe String
checkTokensEmpty :: forall f. CFG f -> Maybe String
checkTokensEmpty CFG f
cf
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RString]
pxs  = forall a. Maybe a
Nothing
  | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ String
"ERROR: The following tokens accept nothing:" ]
      , [RString] -> [String]
printNames [RString]
pxs
      ]
  where
    -- The regular expression is already simplified, so we match against 0 directly.
    pxs :: [RString]
pxs = [ RString
px | TokenReg RString
px Bool
_ (RAlts String
"") <- forall function. CFG function -> [Pragma]
cfgPragmas CFG f
cf ]


-- we should actually check that
-- (1) coercions are always between variants
-- (2) no other digits are used

checkRule :: CF -> Rule -> Maybe String
checkRule :: CF -> Rule -> Maybe String
checkRule CF
cf r :: Rule
r@(Rule RString
f (WithPosition Position
_ Cat
cat) SentForm
rhs InternalRule
_)
  | Cat (Char
'@':String
_) <- Cat
cat = forall a. Maybe a
Nothing -- Generated by a pragma; it's a trusted category
  | Bool
badCoercion = String -> String -> Maybe String
stdFail String
txtCoercion String
"Bad coercion in rule"
  | Bool
badNil      = String -> String -> Maybe String
stdFail String
txtNil      String
"Bad empty list rule"
  | Bool
badOne      = String -> String -> Maybe String
stdFail String
txtOne      String
"Bad one-element list rule"
  | Bool
badCons     = String -> String -> Maybe String
stdFail String
txtCons     String
"Bad list construction rule"
  | Bool
badList     = String -> String -> Maybe String
stdFail String
txtList     String
"Bad list formation rule"
  | Bool
badSpecial  = String -> Maybe String
failure forall a b. (a -> b) -> a -> b
$ String
"Bad special category rule" String -> String -> String
+++ String
s
  | Bool
badTypeName = String -> Maybe String
failure forall a b. (a -> b) -> a -> b
$ String
"Bad type name" String -> String -> String
+++ [String] -> String
unwords (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> String
prettyShow [Cat]
badTypes) String -> String -> String
+++ String
"in" String -> String -> String
+++ String
s
  | Bool
badFunName  = String -> Maybe String
failure forall a b. (a -> b) -> a -> b
$ String
"Bad constructor name" String -> String -> String
+++ String
fun String -> String -> String
+++ String
"in" String -> String -> String
+++ String
s
  | Bool
badMissing  = String -> Maybe String
failure forall a b. (a -> b) -> a -> b
$ String
"no production for" String -> String -> String
+++ [String] -> String
unwords [String]
missing forall a. [a] -> [a] -> [a]
++ String
", appearing in rule\n    " forall a. [a] -> [a] -> [a]
++ String
s
  | Bool
otherwise   = forall a. Maybe a
Nothing
 where
   failure :: String -> Maybe String
failure = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. RString -> String
blendInPosition forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RString
f forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>)
   stdFail :: String -> String -> Maybe String
stdFail String
txt String
err = String -> Maybe String
failure forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [ String
err forall a. [a] -> [a] -> [a]
++ String
":", String
"  " forall a. [a] -> [a] -> [a]
++ String
s, String
txt ]

   fun :: String
fun = forall a. WithPosition a -> a
wpThing RString
f
   s :: String
s  = forall a. Pretty a => a -> String
prettyShow Rule
r
   c :: Cat
c  = Cat -> Cat
normCat Cat
cat                  -- lhs cat without the coercion number
   cs :: [Cat]
cs = [Cat -> Cat
normCat Cat
c | Left Cat
c <- SentForm
rhs]  -- rhs cats without the coercion numbers

   badCoercion :: Bool
badCoercion = forall a. IsFun a => a -> Bool
isCoercion RString
f Bool -> Bool -> Bool
&& [Cat]
cs forall a. Eq a => a -> a -> Bool
/= [Cat
c]   -- the single rhs cat needs to match the lhs cat
   txtCoercion :: String
txtCoercion = String
"In a coercion (label _), category on the left of ::= needs to be the single category on the right."

   badNil :: Bool
badNil = forall a. IsFun a => a -> Bool
isNilFun RString
f   Bool -> Bool -> Bool
&& Bool -> Bool
not (Cat -> Bool
isList Cat
c Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Cat]
cs)
   txtNil :: String
txtNil = String
"In a nil rule (label []), the category on the left of ::= needs to be a list category [C] and no categories are allowed on the right."

   badOne :: Bool
badOne = forall a. IsFun a => a -> Bool
isOneFun RString
f   Bool -> Bool -> Bool
&& Bool -> Bool
not (Cat -> Bool
isList Cat
c Bool -> Bool -> Bool
&& [Cat]
cs forall a. Eq a => a -> a -> Bool
== [Cat -> Cat
catOfList Cat
c])
   txtOne :: String
txtOne = String
"In a singleton rule (label (:[])), the category on the left of ::= needs to be a list category [C], and C must be the sole categories on the right."

   badCons :: Bool
badCons = forall a. IsFun a => a -> Bool
isConsFun RString
f  Bool -> Bool -> Bool
&& Bool -> Bool
not (Cat -> Bool
isList Cat
c Bool -> Bool -> Bool
&& [Cat]
cs forall a. Eq a => a -> a -> Bool
== [Cat -> Cat
catOfList Cat
c, Cat
c])
   txtCons :: String
txtCons = String
"In a cons rule (label (:)), the category on the left of ::= needs to be a list category [C], and C and [C] (in this order) must be the sole categories on the right."

   badList :: Bool
badList = Cat -> Bool
isList Cat
c     Bool -> Bool -> Bool
&& Bool -> Bool
not (forall a. IsFun a => a -> Bool
isCoercion RString
f Bool -> Bool -> Bool
|| forall a. IsFun a => a -> Bool
isNilCons RString
f)
   txtList :: String
txtList = String
"List categories [C] can only be formed by rules labeled _, [], (:), or (:[])."

   badSpecial :: Bool
badSpecial  = forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Cat
c [ String -> Cat
Cat String
x | String
x <- [String]
specialCatsP] Bool -> Bool -> Bool
&& Bool -> Bool
not (forall a. IsFun a => a -> Bool
isCoercion RString
f)

   badMissing :: Bool
badMissing  = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
missing)
   missing :: [String]
missing     = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
defineds) [Cat -> String
catToStr Cat
c | Left Cat
c <- SentForm
rhs]
     where
     defineds :: [String]
defineds = forall function. CFG function -> [String]
tokenNames CF
cf forall a. [a] -> [a] -> [a]
++ [String]
specialCatsP forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (Cat -> String
catToStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall fun. Rul fun -> Cat
valCat) (forall function. CFG function -> [Rul function]
cfgRules CF
cf)

   badTypeName :: Bool
badTypeName = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Cat]
badTypes)
   badTypes :: [Cat]
badTypes = forall a. (a -> Bool) -> [a] -> [a]
filter Cat -> Bool
isBadType forall a b. (a -> b) -> a -> b
$ Cat
cat forall a. a -> [a] -> [a]
: [Cat
c | Left Cat
c <- SentForm
rhs]
     where
     isBadType :: Cat -> Bool
isBadType (ListCat Cat
c)    = Cat -> Bool
isBadType Cat
c
     isBadType (CoercCat String
c Integer
_) = String -> Bool
isBadCatName String
c
     isBadType (Cat String
s)        = String -> Bool
isBadCatName String
s
     isBadType (TokenCat String
s)   = String -> Bool
isBadCatName String
s
     isBadCatName :: String -> Bool
isBadCatName String
s = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Char -> Bool
isUpper (forall a. [a] -> a
head String
s) Bool -> Bool -> Bool
|| (forall a. [a] -> a
head String
s forall a. Eq a => a -> a -> Bool
== Char
'@')

   badFunName :: Bool
badFunName = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_') (forall a. WithPosition a -> a
wpThing RString
f) {-isUpper (head f)-}
                       Bool -> Bool -> Bool
|| forall a. IsFun a => a -> Bool
isCoercion RString
f Bool -> Bool -> Bool
|| forall a. IsFun a => a -> Bool
isNilCons RString
f)


-- | Pre-processor that converts the `rules` macros to regular rules
-- by creating unique function names for them.
-- >>> :{
-- let rules1 = Abs.Rules (Abs.Identifier ((0, 0), "Foo"))
--         [ Abs.RHS [Abs.Terminal "abc"]
--         , Abs.RHS [Abs.NTerminal (Abs.IdCat (Abs.Identifier ((0, 0), "A")))]
--         , Abs.RHS [Abs.Terminal "foo", Abs.Terminal "bar"]
--         , Abs.RHS [Abs.Terminal "++"]
--         ]
-- in
-- let tree = expandRules (Abs.Grammar [rules1])
-- in putStrLn (printTree tree)
-- :}
-- Foo_abc . Foo ::= "abc";
-- FooA . Foo ::= A;
-- Foo1 . Foo ::= "foo" "bar";
-- Foo2 . Foo ::= "++"
--
-- Note that if there are two `rules` macro with the same category, the
-- generated names should be uniques:
-- >>> :{
-- let rules1 = Abs.Rules (Abs.Identifier ((0, 0), "Foo"))
--         [ Abs.RHS [Abs.Terminal "foo", Abs.Terminal "bar"] ]
-- in
-- let rules2 = Abs.Rules (Abs.Identifier ((0, 0), "Foo"))
--         [ Abs.RHS [Abs.Terminal "foo", Abs.Terminal "foo"] ]
-- in
-- let tree = expandRules (Abs.Grammar [rules1, rules2])
-- in putStrLn (printTree tree)
-- :}
-- Foo1 . Foo ::= "foo" "bar";
-- Foo2 . Foo ::= "foo" "foo"
--
-- This is using a State monad to remember the last used index for a category.
expandRules :: Abs.Grammar -> Abs.Grammar
expandRules :: Grammar -> Grammar
expandRules (Abs.Grammar [Def]
defs) =
    [Def] -> Grammar
Abs.Grammar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Def -> State [(String, Int)] [Def]
expand [Def]
defs forall s a. State s a -> s -> a
`evalState` []
  where
    expand :: Abs.Def -> State [(String, Int)] [Abs.Def]
    expand :: Def -> State [(String, Int)] [Def]
expand = \case
      Abs.Rules Identifier
ident [RHS]
rhss -> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Identifier -> RHS -> State [(String, Int)] Def
mkRule Identifier
ident) [RHS]
rhss
      Def
other                -> forall (m :: * -> *) a. Monad m => a -> m a
return [ Def
other ]

    mkRule :: Abs.Identifier -> Abs.RHS -> State [(String, Int)] Abs.Def
    mkRule :: Identifier -> RHS -> State [(String, Int)] Def
mkRule Identifier
ident (Abs.RHS [Item]
rhs) = do
      Label
fun <- Identifier -> Label
Abs.Id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Identifier -> [Item] -> State [(String, Int)] Identifier
mkName Identifier
ident [Item]
rhs
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Label -> Cat -> [Item] -> Def
Abs.Rule Label
fun (Identifier -> Cat
Abs.IdCat Identifier
ident) [Item]
rhs

    mkName :: Abs.Identifier -> [Abs.Item] -> State [(String, Int)] Abs.Identifier
    mkName :: Identifier -> [Item] -> State [(String, Int)] Identifier
mkName (Abs.Identifier ((Int, Int)
pos, String
cat)) = \case

      -- A string that is a valid identifier.
      [ Abs.Terminal String
s ] | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\ Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_') String
s ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ((Int, Int), String) -> Identifier
Abs.Identifier ((Int, Int)
pos, String
cat forall a. [a] -> [a] -> [a]
++ String
"_" forall a. [a] -> [a] -> [a]
++ String
s)

      -- Same but without double quotes.
      [ Abs.NTerminal (Abs.IdCat (Abs.Identifier ((Int, Int)
pos', String
s))) ] ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ((Int, Int), String) -> Identifier
Abs.Identifier ((Int, Int)
pos', String
cat forall a. [a] -> [a] -> [a]
++ String
s)

      -- Something else that does not immediately give a valid rule name.
      -- Just number!
      [Item]
_ -> do
        Int
i <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
1 (forall a. Num a => a -> a -> a
+Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
cat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get
        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((String
cat, Int
i)forall a. a -> [a] -> [a]
:)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ((Int, Int), String) -> Identifier
Abs.Identifier ((Int, Int)
pos, String
cat forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i)