{-
    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 <- Either String CF -> IO CF
forall {a}. Either String a -> IO a
runErr (Either String CF -> IO CF) -> Either String CF -> IO CF
forall a b. (a -> b) -> a -> b
$ [Token] -> Err Grammar
pGrammar (String -> [Token]
myLexer String
content)
                    -- <&> expandRules -- <&> from ghc 8.4
                    Err Grammar -> (Grammar -> Err Grammar) -> Err Grammar
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Grammar -> Err Grammar
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 -> Either String CF) -> Either String CF
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SharedOptions -> Grammar -> Either String CF
getCF SharedOptions
opts
                    Either String CF -> (CF -> Either String CF) -> Either String CF
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CF -> Either String CF
forall (m :: * -> *) a. Monad m => a -> m a
return (CF -> Either String CF) -> (CF -> CF) -> CF -> Either String CF
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CF -> CF
markTokenCategories

  -- Construct the typing information in 'define' expressions.
  CF
cf <- (String -> IO CF) -> (CF -> IO CF) -> Either String CF -> IO CF
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO CF
forall a. String -> IO a
die CF -> IO CF
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String CF -> IO CF) -> Either String CF -> IO CF
forall a b. (a -> b) -> a -> b
$ Err CF -> Either String CF
forall a. Err a -> Either String a
runTypeChecker (Err CF -> Either String CF) -> Err CF -> Either String CF
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
  Bool -> IO () -> IO ()
forall m. Monoid m => Bool -> m -> m
when (Target
target Target -> Target -> Bool
forall a. Eq a => a -> a -> Bool
== Target
TargetJava) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    case (RString -> Bool) -> [RString] -> Maybe RString
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((SharedOptions -> String
lang SharedOptions
opts String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> Bool) -> (RString -> String) -> RString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RString -> String
forall a. WithPosition a -> a
wpThing) [RString]
names of
      Maybe RString
Nothing -> () -> IO ()
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 (Maybe String
layoutTop, LayoutKeyWords
layoutKeywords, [String]
_) = CF -> (Maybe String, LayoutKeyWords, [String])
layoutPragmas CF
cf
  let lay :: Bool
lay = Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
layoutTop Bool -> Bool -> Bool
|| Bool -> Bool
not (LayoutKeyWords -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null LayoutKeyWords
layoutKeywords)
  Bool -> IO () -> IO ()
forall m. Monoid m => Bool -> m -> m
when (Bool
lay Bool -> Bool -> Bool
&& Target
target Target -> [Target] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem`
    [ Target
TargetHaskell, Target
TargetHaskellGadt, Target
TargetLatex, Target
TargetPygments, Target
TargetCheck ]) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> IO ()
dieUnlessForce (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
        [ String
"ERROR: the grammar uses layout, which is not supported by backend"
        , Target -> String
forall a. Show a => a -> String
show Target
target String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
        ]

  -- A grammar that uses layout needs to contain symbols { } ;
  let symbols :: [String]
symbols = CF -> [String]
forall function. CFG function -> [String]
cfgSymbols CF
cf
      layoutSymbols :: [String]
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 (t :: * -> *) a. Foldable t => t a -> Bool
null LayoutKeyWords
layoutKeywords) [String
"{", String
"}"] ]
      missingLayoutSymbols :: [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
  Bool -> IO () -> IO ()
forall m. Monoid m => Bool -> m -> m
when (Bool
lay Bool -> Bool -> Bool
&& Bool -> Bool
not ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
missingLayoutSymbols)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> IO ()
dieUnlessForce (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
        String
"ERROR: the grammar uses layout, but does not mention"
        String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
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
_ <- CF -> [Pragma]
forall function. CFG function -> [Pragma]
cfgPragmas CF
cf ]
  case (RString -> Bool) -> [RString] -> [RString]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe (String, Integer) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (String, Integer) -> Bool)
-> (RString -> Maybe (String, Integer)) -> RString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe (String, Integer)
hasNumericSuffix (String -> Maybe (String, Integer))
-> (RString -> String) -> RString -> Maybe (String, Integer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RString -> String
forall a. WithPosition a -> a
wpThing) [RString]
userTokenTypes of
    []  -> () -> IO ()
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 (RString -> String) -> [RString] -> [List1 RString]
forall (t :: * -> *) b a.
(Foldable t, Ord b) =>
(a -> b) -> t a -> [List1 a]
duplicatesOn RString -> String
forall a. WithPosition a -> a
wpThing [RString]
userTokenTypes of
    [] -> () -> IO ()
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 :: Map String RString
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 (RString -> Maybe (RString, RString))
-> [RString] -> [(RString, RString)]
forall a b. (a -> Maybe b) -> [a] -> [b]
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) (CF -> [RString]
allCatsIdNorm CF
cf) of
    [] -> () -> IO ()
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]
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 [RString]
nonUniqueNames of
    [] -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [RString]
ns | Target
target Target -> [Target] -> 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.
  Bool -> IO () -> IO ()
forall m. Monoid m => Bool -> m -> m
when Bool
False (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
   case [RString] -> [RString]
forall a. Eq a => [a] -> [a]
nub ([RString] -> [RString]) -> [RString] -> [RString]
forall a b. (a -> b) -> a -> b
$ (RString -> Bool) -> [RString] -> [RString]
forall a. (a -> Bool) -> [a] -> [a]
filter (RString -> [RString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [RString]
nonUniqueNames) ([RString] -> [RString]) -> [RString] -> [RString]
forall a b. (a -> b) -> a -> b
$ (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
$
       (List1 RString -> [RString]) -> [List1 RString] -> [RString]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap List1 RString -> [RString]
forall a. NonEmpty a -> [a]
List1.toList ([List1 RString] -> [RString]) -> [List1 RString] -> [RString]
forall a b. (a -> b) -> a -> b
$ (RString -> String) -> [RString] -> [List1 RString]
forall (t :: * -> *) b a.
(Foldable t, Ord b) =>
(a -> b) -> t a -> [List1 a]
duplicatesOn ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> (RString -> String) -> RString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RString -> String
forall a. WithPosition a -> a
wpThing) [RString]
names of
    [] -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [RString]
ns | Target
target Target -> [Target] -> 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@
  () <- Bool -> IO () -> IO ()
forall m. Monoid m => Bool -> m -> m
when (CF -> Bool
forall g. CFG g -> Bool
hasPositionTokens CF
cf Bool -> Bool -> Bool
&& Target
target Target -> Target -> Bool
forall a. Eq a => a -> a -> Bool
== Target
TargetCppNoStl) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
        [ String
"Warning: the backend"
        , Target -> String
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 = [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 -> Bool
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 (RString -> Bool) -> [RString] -> [RString]
forall a. (a -> Bool) -> [a] -> [a]
filter RString -> Bool
undefinedConstructor ([RString] -> [RString]) -> [RString] -> [RString]
forall a b. (a -> b) -> a -> b
$ (Rul RString -> RString) -> [Rul RString] -> [RString]
forall a b. (a -> b) -> [a] -> [b]
map Rul RString -> RString
forall function. Rul function -> function
funRule ([Rul RString] -> [RString]) -> [Rul RString] -> [RString]
forall a b. (a -> b) -> a -> b
$ CF -> [Rul RString]
forall function. CFG function -> [Rul function]
cfgRules CF
cf of
    [] -> () -> IO ()
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
  [String] -> ([String] -> IO ()) -> IO ()
forall m a. Monoid m => [a] -> ([a] -> m) -> m
unlessNull (CF -> [String]
forall function. CFG function -> [String]
checkComments CF
cf) (([String] -> IO ()) -> IO ()) -> ([String] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ [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.
  (String -> IO ()) -> Maybe String -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
Fold.mapM_ String -> IO ()
dieUnlessForce (Maybe String -> IO ()) -> Maybe String -> IO ()
forall a b. (a -> b) -> a -> b
$ CF -> Maybe String
forall f. CFG f -> Maybe String
checkTokens CF
cf

  -- Check for empty grammar.
  let nRules :: Int
nRules = [Rul RString] -> 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.
  Bool -> IO () -> IO ()
forall m. Monoid m => Bool -> m -> m
when (Int
nRules Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
dieUnlessForce (String -> IO ()) -> String -> IO ()
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]
  Bool -> IO () -> IO ()
forall m. Monoid m => Bool -> m -> m
when ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (CF -> [String]
forall function. CFG function -> [String]
usedTokenCats CF
cf) Bool -> Bool -> Bool
&& [(String, Int)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (CF -> [(String, Int)]
forall f. CFG f -> [(String, Int)]
cfTokens CF
cf)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO ()
dieUnlessForce (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
      String
"ERROR: the languages defined by this grammar are empty since it mentions no terminals."

  [RCat] -> ([RCat] -> IO ()) -> IO ()
forall m a. Monoid m => [a] -> ([a] -> m) -> m
unlessNull ([Rul RString] -> [RCat]
forall f. IsFun f => [Rul f] -> [RCat]
emptyData ([Rul RString] -> [RCat]) -> [Rul RString] -> [RCat]
forall a b. (a -> b) -> a -> b
$ CF -> [Rul RString]
forall function. CFG function -> [Rul function]
cfgRules CF
cf) (([RCat] -> IO ()) -> IO ()) -> ([RCat] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ [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 (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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
nRules String -> String -> String
+++ String
"rules accepted\n"
  CF -> IO CF
forall (m :: * -> *) a. Monad m => a -> m a
return CF
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 (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 :: SharedOptions -> Abs.Grammar -> Err CF
getCF :: SharedOptions -> Grammar -> Either String CF
getCF SharedOptions
opts (Abs.Grammar [Def]
defs) = do
    ([Pragma]
pragma, [Rul RString]
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)
mapM Def -> Trans [Either Pragma (Rul RString)]
transDef [Def]
defs Trans [[Either Pragma (Rul RString)]]
-> SharedOptions -> Either String [[Either Pragma (Rul RString)]]
forall a. Trans a -> SharedOptions -> Err a
`runTrans` SharedOptions
opts
    let reservedWords :: [String]
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 :: Set Cat
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]
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
        ([String]
symbols,[String]
keywords) = (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition String -> Bool
notIdent [String]
reservedWords
    Signature
sig <- Err Signature -> Either String Signature
forall a. Err a -> Either String a
runTypeChecker (Err Signature -> Either String Signature)
-> Err Signature -> Either String Signature
forall a b. (a -> b) -> a -> b
$ [Rul RString] -> Err Signature
buildSignature [Rul RString]
rules
    let
      cf :: CF
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 (Rul RString -> Maybe String) -> [Rul RString] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (CF -> Rul RString -> Maybe String
checkRule CF
cf) [Rul RString]
rules of
      [] -> () -> Either String ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      [String]
msgs -> String -> Either String ()
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
    CF -> Either String CF
forall (m :: * -> *) a. Monad m => a -> m a
return CF
cf
  where
    notIdent :: String -> Bool
notIdent String
s       = String -> 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. [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 :: [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 = [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
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 (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 (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]
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  = [String] -> [Pragma] -> [Pragma]
forall a. FixTokenCats a => [String] -> a -> a
fixTokenCats [String]
ns [Pragma]
cfgPragmas
    , cfgUsedCats :: Set Cat
cfgUsedCats = [String] -> Set Cat -> Set Cat
forall a. FixTokenCats a => [String] -> a -> a
fixTokenCats [String]
ns Set Cat
cfgUsedCats
    , cfgRules :: [Rul f]
cfgRules    = [String] -> [Rul f] -> [Rul f]
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 -> 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
<$ :: 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
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
<* :: 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
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
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 = Trans a -> ReaderT SharedOptions (Either String) a
forall a. Trans a -> ReaderT SharedOptions (Either String) a
unTrans Trans a
m ReaderT SharedOptions (Either String) a
-> SharedOptions -> Either String a
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 (Rul RString)]
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
      [Either Pragma (Rul RString)]
-> Trans [Either Pragma (Rul RString)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Either Pragma (Rul RString)]
 -> Trans [Either Pragma (Rul RString)])
-> [Either Pragma (Rul RString)]
-> Trans [Either Pragma (Rul RString)]
forall a b. (a -> b) -> a -> b
$ [ Rul RString -> Either Pragma (Rul RString)
forall a b. b -> Either a b
Right (Rul RString -> Either Pragma (Rul RString))
-> Rul RString -> Either Pragma (Rul RString)
forall a b. (a -> b) -> a -> b
$ RString -> RCat -> SentForm -> InternalRule -> Rul RString
forall function.
function -> RCat -> SentForm -> InternalRule -> Rul function
Rule RString
f RCat
c ((Item -> SentForm) -> [Item] -> SentForm
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
      [Either Pragma (Rul RString)]
-> Trans [Either Pragma (Rul RString)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Either Pragma (Rul RString)]
 -> Trans [Either Pragma (Rul RString)])
-> [Either Pragma (Rul RString)]
-> Trans [Either Pragma (Rul RString)]
forall a b. (a -> b) -> a -> b
$ [ Rul RString -> Either Pragma (Rul RString)
forall a b. b -> Either a b
Right (Rul RString -> Either Pragma (Rul RString))
-> Rul RString -> Either Pragma (Rul RString)
forall a b. (a -> b) -> a -> b
$ RString -> RCat -> SentForm -> InternalRule -> Rul RString
forall function.
function -> RCat -> SentForm -> InternalRule -> Rul function
Rule RString
f RCat
c ((Item -> SentForm) -> [Item] -> SentForm
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Item -> SentForm
transItem [Item]
items) InternalRule
Internal ]

    Abs.Comment String
str               -> [Either Pragma (Rul RString)]
-> Trans [Either Pragma (Rul RString)]
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 (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 RString
x <- Identifier -> Trans RString
transIdent Identifier
ident; [Either Pragma (Rul RString)]
-> Trans [Either Pragma (Rul RString)]
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
$ RString -> Bool -> Reg -> Pragma
TokenReg RString
x Bool
False (Reg -> Pragma) -> Reg -> Pragma
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; [Either Pragma (Rul RString)]
-> Trans [Either Pragma (Rul RString)]
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
$ RString -> Bool -> Reg -> Pragma
TokenReg RString
x Bool
True  (Reg -> Pragma) -> Reg -> Pragma
forall a b. (a -> b) -> a -> b
$ Reg -> Reg
simpReg Reg
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)
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 Position
pos Cat
_ <- Cat -> Trans RCat
transCat Cat
cat
      String -> Trans [Either Pragma (Rul RString)]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Trans [Either Pragma (Rul RString)])
-> String -> Trans [Either Pragma (Rul RString)]
forall a b. (a -> b) -> a -> b
$ RString -> String
blendInPosition (RString -> String) -> RString -> String
forall a b. (a -> b) -> a -> b
$ Position -> String -> RString
forall a. Position -> a -> WithPosition a
WithPosition Position
pos (String -> RString) -> String -> RString
forall a b. (a -> b) -> a -> b
$
        String
"The delimiters pragma " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
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 (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 (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 (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
      RString
f <- Identifier -> Trans RString
transIdent Identifier
ident
      let xs' :: [(String, Base)]
xs' = (Arg -> (String, Base)) -> [Arg] -> [(String, Base)]
forall a b. (a -> b) -> [a] -> [b]
map Arg -> (String, Base)
transArg [Arg]
xs
      [Either Pragma (Rul RString)]
-> Trans [Either Pragma (Rul RString)]
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
$ Define -> Pragma
FunDef (Define -> Pragma) -> Define -> Pragma
forall a b. (a -> b) -> a -> b
$ RString -> [(String, Base)] -> Exp -> Base -> Define
Define RString
f [(String, Base)]
xs' ([String] -> Exp -> Exp
transExp (((String, Base) -> String) -> [(String, Base)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Base) -> String
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 [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 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 -> Rul RString
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
      [Rul RString] -> Trans [Rul RString]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Rul RString] -> Trans [Rul RString])
-> [Rul RString] -> Trans [Rul RString]
forall a b. (a -> b) -> a -> b
$ [[Rul RString]] -> [Rul RString]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [ String -> SentForm -> Rul RString
rule String
"[]"    []                         | MinimumSize
size MinimumSize -> MinimumSize -> Bool
forall a. Eq a => a -> a -> Bool
== MinimumSize
Abs.MEmpty ]
        , [ String -> SentForm -> Rul RString
rule String
"(:[])" [Cat -> Either Cat String
forall a b. a -> Either a b
Left Cat
c]                   ]
        , [ String -> SentForm -> Rul RString
rule String
"(:)"   [Cat -> Either Cat String
forall a b. a -> Either a b
Left Cat
c, String -> Either Cat String
forall a b. b -> Either a b
Right String
s, Cat -> Either Cat String
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 [Rul RString]
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 = Position -> a -> WithPosition a
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 = 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
  [Rul RString] -> Trans [Rul RString]
forall (m :: * -> *) a. Monad m => a -> m a
return
    [ case MinimumSize
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
"[]"    []
    ,   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 [Cat -> Either Cat String
forall a b. a -> Either a b
Left Cat
cs])
    ]
  where
  term :: [Either a String] -> [Either a String]
term = if String -> 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 Position
pos String
c <- Identifier -> Trans RString
transIdent Identifier
c0
  let wp :: a -> WithPosition a
wp = Position -> a -> WithPosition a
forall a. Position -> a -> WithPosition a
WithPosition Position
pos
  let urule :: Cat -> SentForm -> Rul (WithPosition a)
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
  [Rul RString] -> Trans [Rul RString]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Rul RString] -> Trans [Rul RString])
-> [Rul RString] -> Trans [Rul RString]
forall a b. (a -> b) -> a -> b
$ [[Rul RString]] -> [Rul RString]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ Cat -> SentForm -> Rul RString
forall {a}. IsString a => Cat -> SentForm -> Rul (WithPosition a)
urule (String -> Cat
Cat String
c)            [Cat -> Either Cat String
forall a b. a -> Either a b
Left (String -> Integer -> Cat
CoercCat String
c Integer
1)]                ]
    , [ Cat -> SentForm -> Rul RString
forall {a}. IsString a => Cat -> SentForm -> Rul (WithPosition a)
urule (String -> Integer -> Cat
CoercCat String
c (Integer
iInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1)) [Cat -> Either Cat String
forall a b. a -> Either a b
Left (String -> Integer -> Cat
CoercCat String
c Integer
i)]                | Integer
i <- [Integer
2..Integer
n] ]
    , [ Cat -> SentForm -> Rul RString
forall {a}. IsString a => Cat -> SentForm -> Rul (WithPosition a)
urule (String -> Integer -> Cat
CoercCat String
c Integer
n)     [String -> Either Cat String
forall a b. b -> Either a b
Right String
"(", Cat -> Either Cat String
forall a b. a -> Either a b
Left (String -> Cat
Cat String
c), String -> Either Cat String
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 [Rul RString]
ebnfRules (Abs.Identifier ((Int
line, Int
col), String
c)) [RHS]
rhss = do
  String
file <- (SharedOptions -> String) -> Trans String
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SharedOptions -> String
lbnfFile
  let wp :: a -> WithPosition a
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 -> SentForm -> Rul (WithPosition a)
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
  [Rul RString] -> Trans [Rul RString]
forall (m :: * -> *) a. Monad m => a -> m a
return
    [ String -> SentForm -> Rul RString
forall {a}. a -> SentForm -> Rul (WithPosition a)
rule (Int -> [Item] -> String
forall {a}. Show a => a -> [Item] -> String
mkFun Int
k [Item]
its) ((Item -> SentForm) -> [Item] -> SentForm
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Item -> SentForm
transItem [Item]
its)
    | (Int
k, Abs.RHS [Item]
its) <- [Int] -> [RHS] -> [(Int, RHS)]
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' 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 (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 (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
      String
file <- (SharedOptions -> String) -> Trans String
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SharedOptions -> String
lbnfFile
      RCat -> Trans RCat
forall (m :: * -> *) a. Monad m => a -> m a
return (RCat -> Trans RCat) -> RCat -> Trans RCat
forall a b. (a -> b) -> a -> b
$ Position -> Cat -> RCat
forall a. Position -> a -> WithPosition a
WithPosition (String -> Int -> Int -> Position
Position String
file Int
line Int
col) (Cat -> RCat) -> Cat -> RCat
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      -> RString -> Trans RString
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 (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 (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 (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
  String
file <- (SharedOptions -> String) -> Trans String
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SharedOptions -> String
lbnfFile
  RString -> Trans RString
forall (m :: * -> *) a. Monad m => a -> m a
return (RString -> Trans RString) -> RString -> Trans RString
forall a b. (a -> b) -> a -> b
$ Position -> String -> RString
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    -> 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 (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 (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 (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 (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 (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 (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 (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 (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. [a] -> a
head String
s) Bool -> Bool -> Bool
|| (String -> Char
forall a. [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)
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)
mapM (Identifier -> RHS -> StateT [(String, Int)] Identity Def
mkRule Identifier
ident) [RHS]
rhss
      Def
other                -> [Def] -> StateT [(String, Int)] Identity [Def]
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
      Label
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
      Def -> StateT [(String, Int)] Identity Def
forall (m :: * -> *) a. Monad m => a -> m a
return (Def -> StateT [(String, Int)] Identity Def)
-> Def -> StateT [(String, Int)] Identity Def
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] -> 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 (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 (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
        Int
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
        ([(String, Int)] -> [(String, Int)])
-> StateT [(String, Int)] Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((String
cat, Int
i)(String, Int) -> [(String, Int)] -> [(String, Int)]
forall a. a -> [a] -> [a]
:)
        Identifier -> StateT [(String, Int)] Identity Identifier
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]
++ Int -> String
forall a. Show a => a -> String
show Int
i)