{-
    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, parseRawCF
  , checkRule, transItem
  ) where

import Control.Arrow (left)
import Control.Monad.Reader (ReaderT, runReaderT, MonadReader(..), ask)
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

-- | Parse raw CF from LBNF file without checking backend requirements

parseRawCF :: FilePath -> String -> Err CF
parseRawCF :: String -> String -> Err CF
parseRawCF String
fileName String
content = [Token] -> Err Grammar
pGrammar (String -> [Token]
myLexer String
content)
                    -- <&> expandRules -- <&> from ghc 8.4
                    Err Grammar -> (Grammar -> Err Grammar) -> Err Grammar
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Grammar -> Err Grammar
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Grammar -> Err Grammar)
-> (Grammar -> Grammar) -> Grammar -> Err Grammar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Grammar -> Grammar
expandRules
                    Err Grammar -> (Grammar -> Err CF) -> Err CF
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Grammar -> Err CF
getCF String
fileName
                    Err CF -> (CF -> Err CF) -> Err CF
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CF -> Err CF
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (CF -> Err CF) -> (CF -> CF) -> CF -> Err CF
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CF -> CF
markTokenCategories
                    -- Construct the typing information in 'define' expressions.
                    Err CF -> (CF -> Err CF) -> Err CF
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Err CF -> Err CF
forall a. Err a -> Either String a
runTypeChecker (Err CF -> Err CF) -> (CF -> Err CF) -> CF -> Err CF
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CF -> Err CF
checkDefinitions

-- | Entrypoint. Parses full CF from LBNF file and checks against
--   all backend requirements

parseCF :: SharedOptions -> Target -> String -> IO CF
parseCF :: SharedOptions -> Target -> String -> IO CF
parseCF SharedOptions
opts Target
target String
content = do
  cf <- Err CF -> IO CF
forall {a}. Either String a -> IO a
runErr (Err CF -> IO CF) -> Err CF -> IO CF
forall a b. (a -> b) -> a -> b
$ String -> String -> Err CF
parseRawCF (SharedOptions -> String
lbnfFile SharedOptions
opts) String
content

  -- Some backends do not allow the grammar name to coincide with
  -- one of the category or constructor names.
  let names    = CF -> [RString]
allNames CF
cf
  when (target == TargetJava) $
    case List.find ((lang opts ==) . wpThing) names of
      Maybe RString
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just RString
px ->
        String -> IO ()
dieUnlessForce (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
          [ [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
            [ String
"ERROR of backend", Target -> String
forall a. Show a => a -> String
show Target
target String -> String -> String
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 (layoutTop, layoutKeywords, _) = layoutPragmas cf
  let lay = Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
layoutTop Bool -> Bool -> Bool
|| Bool -> Bool
not (LayoutKeyWords -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null LayoutKeyWords
layoutKeywords)
  when (lay && target `notElem`
    [ TargetHaskell, TargetHaskellGadt, TargetLatex, TargetPygments, TargetCheck ]) $
      dieUnlessForce $ unwords
        [ "ERROR: the grammar uses layout, which is not supported by backend"
        , show target ++ "."
        ]

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

  -- Token types that end in a numeral confuse BNFC, because of CoerceCat.
  let userTokenTypes = [ RString
rx | TokenReg RString
rx Bool
_ Reg
_ <- CF -> [Pragma]
forall function. CFG function -> [Pragma]
cfgPragmas CF
cf ]
  case filter (isJust . hasNumericSuffix . wpThing) userTokenTypes of
    []  -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [RString]
rxs -> String -> IO ()
dieUnlessForce (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
             [ [ String
"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 duplicatesOn wpThing userTokenTypes of
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [List1 RString]
gs -> String -> IO ()
dieUnlessForce (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
             [ [ String
"ERROR: duplicate token definitions:" ]
             , (List1 RString -> String) -> [List1 RString] -> [String]
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) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
         [ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"  ", RString -> String
forall a. WithPosition a -> a
wpThing RString
rx, String
" at " ]
         , [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (RString -> String) -> [RString] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Position -> String
prettyPosition (Position -> String) -> (RString -> Position) -> RString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RString -> Position
forall a. WithPosition a -> Position
wpPosition) (RString
rx RString -> [RString] -> [RString]
forall a. a -> [a] -> [a]
: [RString]
rxs)
         ]

  -- Fail if token name conflicts with category name.
  let userTokenNames = [(String, RString)] -> Map String RString
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(String, RString)] -> Map String RString)
-> [(String, RString)] -> Map String RString
forall a b. (a -> b) -> a -> b
$ (RString -> (String, RString)) -> [RString] -> [(String, RString)]
forall a b. (a -> b) -> [a] -> [b]
map (\ RString
rx -> (RString -> String
forall a. WithPosition a -> a
wpThing RString
rx, RString
rx)) [RString]
userTokenTypes
  case mapMaybe (\ RString
rx -> (RString
rx,) (RString -> (RString, RString))
-> Maybe RString -> Maybe (RString, RString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Map String RString -> Maybe RString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (RString -> String
forall a. WithPosition a -> a
wpThing RString
rx) Map String RString
userTokenNames) (allCatsIdNorm cf) of
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [(RString, RString)]
ns -> String -> IO ()
dieUnlessForce (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
             [ [ String
"ERROR: these token definitions conflict with non-terminals:" ]
             , ((RString, RString) -> String) -> [(RString, RString)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ (RString
rx, RString
rp) -> String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RString -> String
blendInPosition RString
rp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" conflicts with " String -> String -> String
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 -> Bool) -> [RString] -> [RString]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (RString -> Bool) -> RString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RString -> Bool
forall a. IsFun a => a -> Bool
isDefinedRule) ([RString] -> [RString]) -> [RString] -> [RString]
forall a b. (a -> b) -> a -> b
$ [RString] -> [RString]
forall a. Ord a => [a] -> [a]
filterNonUnique [RString]
names
  case nonUniqueNames of
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [RString]
ns | Target
target Target -> [Target] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Target
TargetC, Target
TargetCpp , Target
TargetCppNoStl , Target
TargetJava ]
       -> String -> IO ()
dieUnlessForce (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [ String
"ERROR: names not unique:" ]
            , [RString] -> [String]
printNames [RString]
ns
            , [ String
"This is an error in the backend " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Target -> String
forall a. Show a => a -> String
show Target
target String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." ]
            ]
       | Bool
otherwise
       -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [ String
"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.
  case nub
    . filter (`notElem` nonUniqueNames)
    . concatMap List1.toList
    . duplicatesOn (map toLower . wpThing)
    . filter (not . isDefinedRule)
    $ names
    of
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [RString]
ns | Target
target Target -> [Target] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Target
TargetJava ]
       -> String -> IO ()
dieUnlessForce (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [ String
"ERROR: names not unique ignoring case:" ]
            , [RString] -> [String]
printNames [RString]
ns
            , [ String
"This is an error in the backend " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Target -> String
forall a. Show a => a -> String
show Target
target String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."]
            ]
       | Bool
otherwise
       -> String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [ String
"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@
  () <- when (hasPositionTokens cf && target == TargetCppNoStl) $
      putStrLn $ unwords
        [ "Warning: the backend"
        , show target
        , "ignores the qualifier `position` in token definitions."
        ]

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

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

  -- Print warnings if user defined nullable tokens.
  Fold.mapM_ dieUnlessForce $ checkTokens cf

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

  -- Check whether one of the parsers could consume at least one token. [#213]
  when (null (usedTokenCats cf) && null (cfTokens cf)) $
    dieUnlessForce $
      "ERROR: the languages defined by this grammar are empty since it mentions no terminals."

  unlessNull (emptyData $ cfgRules cf) $ \ [RCat]
pcs -> do
    String -> IO ()
dieUnlessForce (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ String
"ERROR: the following categories have empty abstract syntax:" ]
      , [RString] -> [String]
printNames ([RString] -> [String]) -> [RString] -> [String]
forall a b. (a -> b) -> a -> b
$ (RCat -> RString) -> [RCat] -> [RString]
forall a b. (a -> b) -> [a] -> [b]
map ((Cat -> String) -> RCat -> RString
forall a b. (a -> b) -> WithPosition a -> WithPosition b
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.
  putStrLn $ show nRules +++ "rules accepted\n"
  return cf

  where
  runErr :: Either String a -> IO a
runErr = (String -> IO a) -> (a -> IO a) -> Either String a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO a
forall a. String -> IO a
die a -> IO a
forall a. a -> IO a
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.)"
      IO ()
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
_ <- CFG f -> [Rul f]
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 = (RString -> String) -> [RString] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (RString -> String) -> RString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RString -> String
blendInPosition) ([RString] -> [String])
-> ([RString] -> [RString]) -> [RString] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RString -> (Position, String)) -> [RString] -> [RString]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn RString -> (Position, String)
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
  IO a
forall a. IO a
exitFailure

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

getCF :: FilePath -> Abs.Grammar -> Err CF
getCF :: String -> Grammar -> Err CF
getCF String
inputFile (Abs.Grammar [Def]
defs) = do
    (pragma, rules) <- [Either Pragma (Rul RString)] -> ([Pragma], [Rul RString])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either Pragma (Rul RString)] -> ([Pragma], [Rul RString]))
-> ([[Either Pragma (Rul RString)]]
    -> [Either Pragma (Rul RString)])
-> [[Either Pragma (Rul RString)]]
-> ([Pragma], [Rul RString])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Either Pragma (Rul RString)]] -> [Either Pragma (Rul RString)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Either Pragma (Rul RString)]] -> ([Pragma], [Rul RString]))
-> Either String [[Either Pragma (Rul RString)]]
-> Either String ([Pragma], [Rul RString])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Def -> Trans [Either Pragma (Rul RString)])
-> [Def] -> Trans [[Either Pragma (Rul RString)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Def -> Trans [Either Pragma (Rul RString)]
transDef [Def]
defs Trans [[Either Pragma (Rul RString)]]
-> String -> Either String [[Either Pragma (Rul RString)]]
forall a. Trans a -> String -> Err a
`runTrans` String
inputFile
    let reservedWords      = [String] -> [String]
forall a. Eq a => [a] -> [a]
nub [ String
t | Rul RString
r <- [Rul RString]
rules, Rul RString -> Bool
forall f. Rul f -> Bool
isParsable Rul RString
r, Right String
t <- Rul RString -> SentForm
forall function. Rul function -> SentForm
rhsRule Rul RString
r, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> Bool
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           = [Cat] -> Set Cat
forall a. Ord a => [a] -> Set a
Set.fromList [ Cat
c | Rule RString
_ RCat
_ SentForm
rhs InternalRule
_ <- [Rul RString]
rules, Left Cat
c <- SentForm
rhs ]
        -- literals = used builtin token cats (Integer, String, ...)
        literals           = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ String
s -> String -> Cat
TokenCat String
s Cat -> Set Cat -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Cat
usedCats) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String]
specialCatsP
        (symbols,keywords) = partition notIdent reservedWords
    sig <- runTypeChecker $ buildSignature rules
    let
      cf = CF -> CF
revs (CF -> CF) -> CF -> CF
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 :: [Rul RString]
cfgRules          = [Rul RString]
rules
        , cfgSignature :: Signature
cfgSignature      = Signature
sig
        }
    case mapMaybe (checkRule cf) rules of
      [] -> () -> Either String ()
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      [String]
msgs -> String -> Either String ()
forall a. String -> Either String a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
msgs
    return cf
  where
    notIdent :: String -> Bool
notIdent String
s       = String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s Bool -> Bool -> Bool
|| Bool -> Bool
not (Char -> Bool
isAlpha (String -> Char
forall a. HasCallStack => [a] -> a
head String
s)) Bool -> Bool -> Bool
|| (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
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 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\''
    revs :: CF -> CF
revs CF
cf =
        CF
cf{ cfgReversibleCats = findAllReversibleCats 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 = [String] -> CF -> CF
forall a. FixTokenCats a => [String] -> a -> a
fixTokenCats [String]
tokenCatNames CF
cf
  where
  tokenCatNames :: [String]
tokenCatNames = [ RString -> String
forall a. WithPosition a -> a
wpThing RString
n | TokenReg RString
n Bool
_ Reg
_ <- CF -> [Pragma]
forall function. CFG function -> [Pragma]
cfgPragmas CF
cf ] [String] -> [String] -> [String]
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 = (b -> b) -> a -> a
(b -> b) -> t b -> t b
forall a b. (a -> b) -> t a -> t b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b -> b) -> a -> a) -> ([String] -> b -> b) -> [String] -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> b -> b
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 = (a -> a) -> Set a -> Set a
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map ((a -> a) -> Set a -> Set a)
-> ([String] -> a -> a) -> [String] -> Set a -> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> a -> a
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 String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
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 (Cat -> Cat) -> Cat -> Cat
forall a b. (a -> b) -> a -> b
$ [String] -> Cat -> Cat
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 = (Cat -> Cat) -> Either Cat String -> Either Cat String
forall b c d. (b -> c) -> Either b d -> Either c d
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ((Cat -> Cat) -> Either Cat String -> Either Cat String)
-> ([String] -> Cat -> Cat)
-> [String]
-> Either Cat String
-> Either Cat String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Cat -> Cat
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) =
    f -> RCat -> SentForm -> InternalRule -> Rul f
forall function.
function -> RCat -> SentForm -> InternalRule -> Rul function
Rule f
f ([String] -> RCat -> RCat
forall a. FixTokenCats a => [String] -> a -> a
fixTokenCats [String]
ns RCat
c) ([String] -> SentForm -> SentForm
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 ([RCat] -> Pragma) -> [RCat] -> Pragma
forall a b. (a -> b) -> a -> b
$ [String] -> [RCat] -> [RCat]
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]
Set Cat
Signature
cfgSymbols :: forall function. CFG function -> [String]
cfgPragmas :: forall function. CFG function -> [Pragma]
cfgRules :: forall function. CFG function -> [Rul function]
cfgUsedCats :: forall function. CFG function -> Set Cat
cfgLiterals :: forall function. CFG function -> [String]
cfgKeywords :: forall function. CFG function -> [String]
cfgReversibleCats :: forall function. CFG function -> [Cat]
cfgSignature :: forall function. CFG function -> Signature
cfgPragmas :: [Pragma]
cfgUsedCats :: Set Cat
cfgLiterals :: [String]
cfgSymbols :: [String]
cfgKeywords :: [String]
cfgReversibleCats :: [Cat]
cfgRules :: [Rul f]
cfgSignature :: Signature
..} = CFG f
cf
    { cfgPragmas  = fixTokenCats ns cfgPragmas
    , cfgUsedCats = fixTokenCats ns cfgUsedCats
    , cfgRules    = fixTokenCats ns cfgRules
    }

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

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

transDef :: Abs.Def -> Trans [Either Pragma Rule]
transDef :: Def -> Trans [Either Pragma (Rul RString)]
transDef = \case
    Abs.Rule Label
label Cat
cat [Item]
items  -> do
      f <- Label -> Trans RString
transLabel Label
label
      c <- transCat cat
      return $ [ Right $ Rule f c (concatMap transItem items) Parsable ]
    Abs.Internal Label
label Cat
cat [Item]
items  -> do
      f <- Label -> Trans RString
transLabel Label
label
      c <- transCat cat
      return $ [ Right $ Rule f c (concatMap transItem items) Internal ]

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

    Abs.Token Identifier
ident Reg
reg           -> do x <- Identifier -> Trans RString
transIdent Identifier
ident; return [Left $ TokenReg x False $ simpReg reg]
    Abs.PosToken Identifier
ident Reg
reg        -> do x <- Identifier -> Trans RString
transIdent Identifier
ident; return [Left $ TokenReg x True  $ simpReg reg]
    Abs.Entryp [Cat]
cats               -> Either Pragma (Rul RString) -> [Either Pragma (Rul RString)]
forall a. a -> [a]
singleton (Either Pragma (Rul RString) -> [Either Pragma (Rul RString)])
-> ([RCat] -> Either Pragma (Rul RString))
-> [RCat]
-> [Either Pragma (Rul RString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pragma -> Either Pragma (Rul RString)
forall a b. a -> Either a b
Left (Pragma -> Either Pragma (Rul RString))
-> ([RCat] -> Pragma) -> [RCat] -> Either Pragma (Rul RString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RCat] -> Pragma
EntryPoints ([RCat] -> [Either Pragma (Rul RString)])
-> Trans [RCat] -> Trans [Either Pragma (Rul RString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Cat -> Trans RCat) -> [Cat] -> Trans [RCat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Cat -> Trans RCat
transCat [Cat]
cats
    Abs.Separator MinimumSize
size Cat
ident String
str  -> (Rul RString -> Either Pragma (Rul RString))
-> [Rul RString] -> [Either Pragma (Rul RString)]
forall a b. (a -> b) -> [a] -> [b]
map Rul RString -> Either Pragma (Rul RString)
forall a b. b -> Either a b
Right ([Rul RString] -> [Either Pragma (Rul RString)])
-> Trans [Rul RString] -> Trans [Either Pragma (Rul RString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MinimumSize -> Cat -> String -> Trans [Rul RString]
separatorRules MinimumSize
size Cat
ident String
str
    Abs.Terminator MinimumSize
size Cat
ident String
str -> (Rul RString -> Either Pragma (Rul RString))
-> [Rul RString] -> [Either Pragma (Rul RString)]
forall a b. (a -> b) -> [a] -> [b]
map Rul RString -> Either Pragma (Rul RString)
forall a b. b -> Either a b
Right ([Rul RString] -> [Either Pragma (Rul RString)])
-> Trans [Rul RString] -> Trans [Either Pragma (Rul RString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MinimumSize -> Cat -> String -> Trans [Rul RString]
terminatorRules MinimumSize
size Cat
ident String
str
    Abs.Delimiters Cat
cat String
_ String
_ Separation
_ MinimumSize
_    -> do
      WithPosition pos _ <- Cat -> Trans RCat
transCat Cat
cat
      throwError $ blendInPosition $ WithPosition pos $
        "The delimiters pragma " ++ removedIn290
    Abs.Coercions Identifier
ident Integer
int       -> (Rul RString -> Either Pragma (Rul RString))
-> [Rul RString] -> [Either Pragma (Rul RString)]
forall a b. (a -> b) -> [a] -> [b]
map Rul RString -> Either Pragma (Rul RString)
forall a b. b -> Either a b
Right ([Rul RString] -> [Either Pragma (Rul RString)])
-> Trans [Rul RString] -> Trans [Either Pragma (Rul RString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Identifier -> Integer -> Trans [Rul RString]
coercionRules Identifier
ident Integer
int
    Abs.Rules Identifier
ident [RHS]
strs          -> (Rul RString -> Either Pragma (Rul RString))
-> [Rul RString] -> [Either Pragma (Rul RString)]
forall a b. (a -> b) -> [a] -> [b]
map Rul RString -> Either Pragma (Rul RString)
forall a b. b -> Either a b
Right ([Rul RString] -> [Either Pragma (Rul RString)])
-> Trans [Rul RString] -> Trans [Either Pragma (Rul RString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Identifier -> [RHS] -> Trans [Rul RString]
ebnfRules Identifier
ident [RHS]
strs
    Abs.Layout [String]
ss                 -> [Either Pragma (Rul RString)]
-> Trans [Either Pragma (Rul RString)]
forall a. a -> Trans a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Pragma -> Either Pragma (Rul RString)
forall a b. a -> Either a b
Left (Pragma -> Either Pragma (Rul RString))
-> Pragma -> Either Pragma (Rul RString)
forall a b. (a -> b) -> a -> b
$ LayoutKeyWords -> Pragma
Layout (LayoutKeyWords -> Pragma) -> LayoutKeyWords -> Pragma
forall a b. (a -> b) -> a -> b
$ (String -> (String, Delimiters)) -> [String] -> LayoutKeyWords
forall a b. (a -> b) -> [a] -> [b]
map (,String -> String -> String -> Delimiters
Delimiters String
";" String
"{" String
"}") [String]
ss ]
    Abs.LayoutStop [String]
ss             -> [Either Pragma (Rul RString)]
-> Trans [Either Pragma (Rul RString)]
forall a. a -> Trans a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Pragma -> Either Pragma (Rul RString)
forall a b. a -> Either a b
Left (Pragma -> Either Pragma (Rul RString))
-> Pragma -> Either Pragma (Rul RString)
forall a b. (a -> b) -> a -> b
$ [String] -> Pragma
LayoutStop [String]
ss]
    Def
Abs.LayoutTop                 -> [Either Pragma (Rul RString)]
-> Trans [Either Pragma (Rul RString)]
forall a. a -> Trans a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Pragma -> Either Pragma (Rul RString)
forall a b. a -> Either a b
Left (Pragma -> Either Pragma (Rul RString))
-> Pragma -> Either Pragma (Rul RString)
forall a b. (a -> b) -> a -> b
$ String -> Pragma
LayoutTop String
";" ]
    Abs.Function Identifier
ident [Arg]
xs Exp
e       -> do
      f <- Identifier -> Trans RString
transIdent Identifier
ident
      let xs' = (Arg -> (String, Base)) -> [Arg] -> [(String, Base)]
forall a b. (a -> b) -> [a] -> [b]
map Arg -> (String, Base)
transArg [Arg]
xs
      return [ Left $ FunDef $ Define f xs' (transExp (map fst xs') e) 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 [Rul RString]
separatorRules MinimumSize
size Cat
c0 String
s
  | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
s = MinimumSize -> Cat -> String -> Trans [Rul RString]
terminatorRules MinimumSize
size Cat
c0 String
s
  | Bool
otherwise     = do
      WithPosition pos c <- Cat -> Trans RCat
transCat Cat
c0
      let cs = Cat -> Cat
ListCat Cat
c
      let rule :: String -> SentForm -> Rule
          rule String
x SentForm
rhs = RString -> RCat -> SentForm -> InternalRule -> Rul RString
forall function.
function -> RCat -> SentForm -> InternalRule -> Rul function
Rule (Position -> String -> RString
forall a. Position -> a -> WithPosition a
WithPosition Position
pos String
x) (Position -> Cat -> RCat
forall a. Position -> a -> WithPosition a
WithPosition Position
pos Cat
cs) SentForm
rhs InternalRule
Parsable
      return $ concat
        [ [ rule "[]"    []                         | size == Abs.MEmpty ]
        , [ rule "(:[])" [Left c]                   ]
        , [ rule "(:)"   [Left c, Right s, Left 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 [Rul RString]
terminatorRules MinimumSize
size Cat
c0 String
s = do
  WithPosition pos c <- Cat -> Trans RCat
transCat Cat
c0
  let wp = Position -> a -> WithPosition a
forall a. Position -> a -> WithPosition a
WithPosition Position
pos
  let cs = Cat -> Cat
ListCat Cat
c
  let rule a
x SentForm
rhs = WithPosition a
-> RCat -> SentForm -> InternalRule -> Rul (WithPosition a)
forall function.
function -> RCat -> SentForm -> InternalRule -> Rul function
Rule (a -> WithPosition a
forall {a}. a -> WithPosition a
wp a
x) (Cat -> RCat
forall {a}. a -> WithPosition a
wp Cat
cs) SentForm
rhs InternalRule
Parsable
  return
    [ case size of
      MinimumSize
Abs.MNonempty ->
        String -> SentForm -> Rul RString
forall {a}. a -> SentForm -> Rul (WithPosition a)
rule String
"(:[])" (Cat -> Either Cat String
forall a b. a -> Either a b
Left Cat
c Either Cat String -> SentForm -> SentForm
forall a. a -> [a] -> [a]
: SentForm -> SentForm
forall {a}. [Either a String] -> [Either a String]
term [])
      MinimumSize
Abs.MEmpty ->
        String -> SentForm -> Rul RString
forall {a}. a -> SentForm -> Rul (WithPosition a)
rule String
"[]"    []
    ,   rule "(:)"   (Left c : term [Left cs])
    ]
  where
  term :: [Either a String] -> [Either a String]
term = if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s then [Either a String] -> [Either a String]
forall a. a -> a
id else (String -> Either a String
forall a b. b -> Either a b
Right String
s Either a String -> [Either a String] -> [Either a String]
forall a. a -> [a] -> [a]
:)

-- | Expansion of the @coercion@ pragma.

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

-- | Expansion of the @rules@ pragma.

ebnfRules :: Abs.Identifier -> [Abs.RHS] -> Trans [Rule]
ebnfRules :: Identifier -> [RHS] -> Trans [Rul RString]
ebnfRules (Abs.Identifier ((Int
line, Int
col), String
c)) [RHS]
rhss = do
  file <- Trans String
forall r (m :: * -> *). MonadReader r m => m r
ask
  let wp = Position -> a -> WithPosition a
forall a. Position -> a -> WithPosition a
WithPosition (Position -> a -> WithPosition a)
-> Position -> a -> WithPosition a
forall a b. (a -> b) -> a -> b
$ String -> Int -> Int -> Position
Position String
file Int
line Int
col
  let rule a
x SentForm
rhs = WithPosition a
-> RCat -> SentForm -> InternalRule -> Rul (WithPosition a)
forall function.
function -> RCat -> SentForm -> InternalRule -> Rul function
Rule (a -> WithPosition a
forall {a}. a -> WithPosition a
wp a
x) (Cat -> RCat
forall {a}. a -> WithPosition a
wp (Cat -> RCat) -> Cat -> RCat
forall a b. (a -> b) -> a -> b
$ String -> Cat
strToCat String
c) SentForm
rhs InternalRule
Parsable
  return
    [ rule (mkFun k its) (concatMap transItem its)
    | (k, Abs.RHS its) <- zip [1 :: Int ..] rhss
    ]
 where
   mkFun :: a -> [Item] -> String
mkFun a
k = \case
     [Abs.Terminal String
s]  -> String
c' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String -> String
forall {a}. Show a => a -> String -> String
mkName a
k String
s
     [Abs.NTerminal Cat
n] -> String
c' String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
identCat (Cat -> Cat
transCat' Cat
n)
     [Item]
_ -> String
c' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
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 (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
c (String
"_'" :: String)) String
s
                   then String
s else a -> String
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)  = [ String -> Either Cat String
forall a b. b -> Either a b
Right String
w | String
w <- String -> [String]
words String
str ]
transItem (Abs.NTerminal Cat
cat) = [ Cat -> Either Cat String
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 (Cat -> Cat) -> Cat -> Cat
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                             -> (Cat -> Cat) -> RCat -> RCat
forall a b. (a -> b) -> WithPosition a -> WithPosition b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cat -> Cat
ListCat (RCat -> RCat) -> Trans RCat -> Trans RCat
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
      file <- Trans String
forall r (m :: * -> *). MonadReader r m => m r
ask
      return $ WithPosition (Position file line col) $ strToCat 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      -> RString -> Trans RString
forall a. a -> Trans a
forall (m :: * -> *) a. Monad m => a -> m a
return (RString -> Trans RString) -> RString -> Trans RString
forall a b. (a -> b) -> a -> b
$ String -> RString
forall {a}. a -> WithPosition a
noPosition (String -> RString) -> String -> RString
forall a b. (a -> b) -> a -> b
$ String
"_"
    Label
Abs.ListE     -> RString -> Trans RString
forall a. a -> Trans a
forall (m :: * -> *) a. Monad m => a -> m a
return (RString -> Trans RString) -> RString -> Trans RString
forall a b. (a -> b) -> a -> b
$ String -> RString
forall {a}. a -> WithPosition a
noPosition (String -> RString) -> String -> RString
forall a b. (a -> b) -> a -> b
$ String
"[]"
    Label
Abs.ListCons  -> RString -> Trans RString
forall a. a -> Trans a
forall (m :: * -> *) a. Monad m => a -> m a
return (RString -> Trans RString) -> RString -> Trans RString
forall a b. (a -> b) -> a -> b
$ String -> RString
forall {a}. a -> WithPosition a
noPosition (String -> RString) -> String -> RString
forall a b. (a -> b) -> a -> b
$ String
"(:)"
    Label
Abs.ListOne   -> RString -> Trans RString
forall a. a -> Trans a
forall (m :: * -> *) a. Monad m => a -> m a
return (RString -> Trans RString) -> RString -> Trans RString
forall a b. (a -> b) -> a -> b
$ String -> RString
forall {a}. a -> WithPosition a
noPosition (String -> RString) -> String -> RString
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
  file <- Trans String
forall r (m :: * -> *). MonadReader r m => m r
ask
  return $ WithPosition (Position file line col) 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    -> String -> Type -> [Exp] -> Exp
forall f. f -> Type -> [Exp' f] -> Exp' f
App (Identifier -> String
transIdent' Identifier
x) Type
dummyType ((Exp -> Exp) -> [Exp] -> [Exp]
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' String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
xs then String -> Exp
forall f. String -> Exp' f
Var String
x' else String -> Type -> [Exp] -> Exp
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     -> (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall a b. (a -> b -> b) -> b -> [a] -> b
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    -> Integer -> Exp
forall f. Integer -> Exp' f
LitInt Integer
x
    Abs.LitDouble Double
x -> Double -> Exp
forall f. Double -> Exp' f
LitDouble Double
x
    Abs.LitChar Char
x   -> Char -> Exp
forall f. Char -> Exp' f
LitChar Char
x
    Abs.LitString String
x -> String -> Exp
forall f. String -> Exp' f
LitString String
x
  cons :: Exp -> Exp -> Exp
cons Exp
e1 Exp
e2 = String -> Type -> [Exp] -> Exp
forall f. f -> Type -> [Exp' f] -> Exp' f
App String
"(:)" Type
dummyType [Exp -> Exp
loop Exp
e1, Exp
e2]
  nil :: Exp
nil        = String -> Type -> [Exp] -> Exp
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 = [[String]] -> [String]
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 = CFG f -> [Pragma]
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 [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [ CFG f -> Maybe String
forall f. CFG f -> Maybe String
checkTokensEmpty CFG f
cf, CFG f -> Maybe String
forall f. CFG f -> Maybe String
checkTokensNullable CFG f
cf ] of
    [] -> Maybe String
forall a. Maybe a
Nothing
    [String]
ss -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> String
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
  | [RString] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RString]
pxs  = Maybe String
forall a. Maybe a
Nothing
  | Bool
otherwise = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ String
"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 <- CFG f -> [Pragma]
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
  | [RString] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RString]
pxs  = Maybe String
forall a. Maybe a
Nothing
  | Bool
otherwise = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ String
"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
"") <- CFG f -> [Pragma]
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 -> Rul RString -> Maybe String
checkRule CF
cf r :: Rul RString
r@(Rule RString
f (WithPosition Position
_ Cat
cat) SentForm
rhs InternalRule
_)
  | Cat (Char
'@':String
_) <- Cat
cat = Maybe String
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 (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"Bad special category rule" String -> String -> String
+++ String
s
  | Bool
badTypeName = String -> Maybe String
failure (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"Bad type name" String -> String -> String
+++ [String] -> String
unwords ((Cat -> String) -> [Cat] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> String
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 (String -> Maybe String) -> String -> Maybe String
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 (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"no production for" String -> String -> String
+++ [String] -> String
unwords [String]
missing String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", appearing in rule\n    " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
  | Bool
otherwise   = Maybe String
forall a. Maybe a
Nothing
 where
   failure :: String -> Maybe String
failure = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> (String -> String) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RString -> String
blendInPosition (RString -> String) -> (String -> RString) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RString
f RString -> String -> RString
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 (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [ String
err String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":", String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s, String
txt ]

   fun :: String
fun = RString -> String
forall a. WithPosition a -> a
wpThing RString
f
   s :: String
s  = Rul RString -> String
forall a. Pretty a => a -> String
prettyShow Rul RString
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 = RString -> Bool
forall a. IsFun a => a -> Bool
isCoercion RString
f Bool -> Bool -> Bool
&& [Cat]
cs [Cat] -> [Cat] -> Bool
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 = RString -> Bool
forall a. IsFun a => a -> Bool
isNilFun RString
f   Bool -> Bool -> Bool
&& Bool -> Bool
not (Cat -> Bool
isList Cat
c Bool -> Bool -> Bool
&& [Cat] -> Bool
forall a. [a] -> 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 = RString -> Bool
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 [Cat] -> [Cat] -> Bool
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 = RString -> Bool
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 [Cat] -> [Cat] -> Bool
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 (RString -> Bool
forall a. IsFun a => a -> Bool
isCoercion RString
f Bool -> Bool -> Bool
|| RString -> 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  = Cat -> [Cat] -> Bool
forall a. Eq a => a -> [a] -> Bool
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 (RString -> Bool
forall a. IsFun a => a -> Bool
isCoercion RString
f)

   badMissing :: Bool
badMissing  = Bool -> Bool
not ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
missing)
   missing :: [String]
missing     = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> [String] -> Bool
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 = CF -> [String]
forall function. CFG function -> [String]
tokenNames CF
cf [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
specialCatsP [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Rul RString -> String) -> [Rul RString] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Cat -> String
catToStr (Cat -> String) -> (Rul RString -> Cat) -> Rul RString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rul RString -> Cat
forall fun. Rul fun -> Cat
valCat) (CF -> [Rul RString]
forall function. CFG function -> [Rul function]
cfgRules CF
cf)

   badTypeName :: Bool
badTypeName = Bool -> Bool
not ([Cat] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Cat]
badTypes)
   badTypes :: [Cat]
badTypes = (Cat -> Bool) -> [Cat] -> [Cat]
forall a. (a -> Bool) -> [a] -> [a]
filter Cat -> Bool
isBadType ([Cat] -> [Cat]) -> [Cat] -> [Cat]
forall a b. (a -> b) -> a -> b
$ Cat
cat Cat -> [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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char -> Bool
isUpper (String -> Char
forall a. HasCallStack => [a] -> a
head String
s) Bool -> Bool -> Bool
|| (String -> Char
forall a. HasCallStack => [a] -> a
head String
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'@')

   badFunName :: Bool
badFunName = Bool -> Bool
not ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_') (RString -> String
forall a. WithPosition a -> a
wpThing RString
f) {-isUpper (head f)-}
                       Bool -> Bool -> Bool
|| RString -> Bool
forall a. IsFun a => a -> Bool
isCoercion RString
f Bool -> Bool -> Bool
|| RString -> 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 ([Def] -> Grammar) -> ([[Def]] -> [Def]) -> [[Def]] -> Grammar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Def]] -> [Def]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Def]] -> Grammar) -> [[Def]] -> Grammar
forall a b. (a -> b) -> a -> b
$ (Def -> StateT [(String, Int)] Identity [Def])
-> [Def] -> StateT [(String, Int)] Identity [[Def]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Def -> StateT [(String, Int)] Identity [Def]
expand [Def]
defs StateT [(String, Int)] Identity [[Def]]
-> [(String, Int)] -> [[Def]]
forall s a. State s a -> s -> a
`evalState` []
  where
    expand :: Abs.Def -> State [(String, Int)] [Abs.Def]
    expand :: Def -> StateT [(String, Int)] Identity [Def]
expand = \case
      Abs.Rules Identifier
ident [RHS]
rhss -> (RHS -> StateT [(String, Int)] Identity Def)
-> [RHS] -> StateT [(String, Int)] Identity [Def]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Identifier -> RHS -> StateT [(String, Int)] Identity Def
mkRule Identifier
ident) [RHS]
rhss
      Def
other                -> [Def] -> StateT [(String, Int)] Identity [Def]
forall a. a -> StateT [(String, Int)] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Def
other ]

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

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

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

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

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