{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoMonoLocalBinds #-}
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 (($>))
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)
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
parseCF :: SharedOptions -> Target -> String -> IO CF
parseCF :: SharedOptions -> Target -> String -> IO CF
parseCF SharedOptions
opts Target
target String
content = do
CF
cf <- forall {a}. Either String a -> IO a
runErr forall a b. (a -> b) -> a -> b
$ [Token] -> Either String Grammar
pGrammar (String -> [Token]
myLexer String
content)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Grammar -> Grammar
expandRules
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SharedOptions -> Grammar -> Either String CF
getCF SharedOptions
opts
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. CF -> CF
markTokenCategories
CF
cf <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. String -> IO a
die forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Err a -> Either String a
runTypeChecker forall a b. (a -> b) -> a -> b
$ CF -> Err CF
checkDefinitions CF
cf
let names :: [RString]
names = CF -> [RString]
allNames CF
cf
forall m. Monoid m => Bool -> m -> m
when (Target
target forall a. Eq a => a -> a -> Bool
== Target
TargetJava) forall a b. (a -> b) -> a -> b
$
case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((SharedOptions -> String
lang SharedOptions
opts forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. WithPosition a -> a
wpThing) [RString]
names of
Maybe RString
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just RString
px ->
String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
[ [String] -> String
unwords forall a b. (a -> b) -> a -> b
$
[ String
"ERROR of backend", forall a. Show a => a -> String
show Target
target forall a. [a] -> [a] -> [a]
++ String
":"
, String
"the language name"
, SharedOptions -> String
lang SharedOptions
opts
, String
"conflicts with a name defined in the grammar:"
]
, RString -> String
blendInPosition RString
px
]
let (Maybe String
layoutTop, LayoutKeyWords
layoutKeywords, [String]
_) = CF -> (Maybe String, LayoutKeyWords, [String])
layoutPragmas CF
cf
let lay :: Bool
lay = forall a. Maybe a -> Bool
isJust Maybe String
layoutTop Bool -> Bool -> Bool
|| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null LayoutKeyWords
layoutKeywords)
forall m. Monoid m => Bool -> m -> m
when (Bool
lay Bool -> Bool -> Bool
&& Target
target forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem`
[ Target
TargetHaskell, Target
TargetHaskellGadt, Target
TargetLatex, Target
TargetPygments, Target
TargetCheck ]) forall a b. (a -> b) -> a -> b
$
String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
[ String
"ERROR: the grammar uses layout, which is not supported by backend"
, forall a. Show a => a -> String
show Target
target forall a. [a] -> [a] -> [a]
++ String
"."
]
let symbols :: [String]
symbols = forall function. CFG function -> [String]
cfgSymbols CF
cf
layoutSymbols :: [String]
layoutSymbols = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [String
";"], forall m. Monoid m => Bool -> m -> m
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null LayoutKeyWords
layoutKeywords) [String
"{", String
"}"] ]
missingLayoutSymbols :: [String]
missingLayoutSymbols = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
symbols) [String]
layoutSymbols
forall m. Monoid m => Bool -> m -> m
when (Bool
lay Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
missingLayoutSymbols)) forall a b. (a -> b) -> a -> b
$
String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords forall a b. (a -> b) -> a -> b
$
String
"ERROR: the grammar uses layout, but does not mention"
forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [String]
missingLayoutSymbols
let userTokenTypes :: [RString]
userTokenTypes = [ RString
rx | TokenReg RString
rx Bool
_ Reg
_ <- forall function. CFG function -> [Pragma]
cfgPragmas CF
cf ]
case forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe (String, Integer)
hasNumericSuffix forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. WithPosition a -> a
wpThing) [RString]
userTokenTypes of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
[RString]
rxs -> String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ String
"ERROR: illegal token names:" ]
, [RString] -> [String]
printNames [RString]
rxs
, [ String
"Token names may not end with a number---to avoid confusion with coercion categories." ]
]
case forall (t :: * -> *) b a.
(Foldable t, Ord b) =>
(a -> b) -> t a -> [List1 a]
duplicatesOn forall a. WithPosition a -> a
wpThing [RString]
userTokenTypes of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
[List1 RString]
gs -> String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ String
"ERROR: duplicate token definitions:" ]
, forall a b. (a -> b) -> [a] -> [b]
map List1 RString -> String
printDuplicateTokenDefs [List1 RString]
gs
]
where
printDuplicateTokenDefs :: List1 RString -> String
printDuplicateTokenDefs (RString
rx :| [RString]
rxs) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
[ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
" ", forall a. WithPosition a -> a
wpThing RString
rx, String
" at " ]
, [String] -> String
unwords forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Position -> String
prettyPosition forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. WithPosition a -> Position
wpPosition) (RString
rx forall a. a -> [a] -> [a]
: [RString]
rxs)
]
let userTokenNames :: Map String RString
userTokenNames = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\ RString
rx -> (forall a. WithPosition a -> a
wpThing RString
rx, RString
rx)) [RString]
userTokenTypes
case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\ RString
rx -> (RString
rx,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall a. WithPosition a -> a
wpThing RString
rx) Map String RString
userTokenNames) (CF -> [RString]
allCatsIdNorm CF
cf) of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
[(RString, RString)]
ns -> String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ String
"ERROR: these token definitions conflict with non-terminals:" ]
, forall a b. (a -> b) -> [a] -> [b]
map (\ (RString
rx, RString
rp) -> String
" " forall a. [a] -> [a] -> [a]
++ RString -> String
blendInPosition RString
rp forall a. [a] -> [a] -> [a]
++ String
" conflicts with " forall a. [a] -> [a] -> [a]
++ RString -> String
blendInPosition RString
rx) [(RString, RString)]
ns
]
let nonUniqueNames :: [RString]
nonUniqueNames = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsFun a => a -> Bool
isDefinedRule) forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
filterNonUnique [RString]
names
case [RString]
nonUniqueNames of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
[RString]
ns | Target
target forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Target
TargetC, Target
TargetCpp , Target
TargetCppNoStl , Target
TargetJava ]
-> String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ String
"ERROR: names not unique:" ]
, [RString] -> [String]
printNames [RString]
ns
, [ String
"This is an error in the backend " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Target
target forall a. [a] -> [a] -> [a]
++ String
"." ]
]
| Bool
otherwise
-> String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ String
"Warning: names not unique:" ]
, [RString] -> [String]
printNames [RString]
ns
, [ String
"This can be an error in some backends." ]
]
forall m. Monoid m => Bool -> m -> m
when Bool
False forall a b. (a -> b) -> a -> b
$
case forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [RString]
nonUniqueNames) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsFun a => a -> Bool
isDefinedRule) forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. NonEmpty a -> [a]
List1.toList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
(Foldable t, Ord b) =>
(a -> b) -> t a -> [List1 a]
duplicatesOn (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. WithPosition a -> a
wpThing) [RString]
names of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
[RString]
ns | Target
target forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Target
TargetJava ]
-> String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ String
"ERROR: names not unique ignoring case:" ]
, [RString] -> [String]
printNames [RString]
ns
, [ String
"This is an error in the backend " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Target
target forall a. [a] -> [a] -> [a]
++ String
"."]
]
| Bool
otherwise
-> String -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ String
"Warning: names not unique ignoring case:" ]
, [RString] -> [String]
printNames [RString]
ns
, [ String
"This can be an error in some backends." ]
]
() <- forall m. Monoid m => Bool -> m -> m
when (forall g. CFG g -> Bool
hasPositionTokens CF
cf Bool -> Bool -> Bool
&& Target
target forall a. Eq a => a -> a -> Bool
== Target
TargetCppNoStl) forall a b. (a -> b) -> a -> b
$
String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
[ String
"Warning: the backend"
, forall a. Show a => a -> String
show Target
target
, String
"ignores the qualifier `position` in token definitions."
]
let definedConstructors :: Set RString
definedConstructors = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Define -> RString
defName forall a b. (a -> b) -> a -> b
$ forall f. CFG f -> [Define]
definitions CF
cf
let undefinedConstructor :: RString -> Bool
undefinedConstructor RString
x = forall a. IsFun a => a -> Bool
isDefinedRule RString
x Bool -> Bool -> Bool
&& RString
x forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set RString
definedConstructors
case forall a. (a -> Bool) -> [a] -> [a]
filter RString -> Bool
undefinedConstructor forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall function. Rul function -> function
funRule forall a b. (a -> b) -> a -> b
$ forall function. CFG function -> [Rul function]
cfgRules CF
cf of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
[RString]
xs -> String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ String
"Lower case rule labels need a definition."
, String
"ERROR: undefined rule label(s):"
]
, [RString] -> [String]
printNames [RString]
xs
]
forall m a. Monoid m => [a] -> ([a] -> m) -> m
unlessNull (forall function. CFG function -> [String]
checkComments CF
cf) forall a b. (a -> b) -> a -> b
$ \ [String]
errs -> do
String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
errs
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
Fold.mapM_ String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$ forall f. CFG f -> Maybe String
checkTokens CF
cf
let nRules :: Int
nRules = forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall function. CFG function -> [Rul function]
cfgRules CF
cf)
forall m. Monoid m => Bool -> m -> m
when (Int
nRules forall a. Eq a => a -> a -> Bool
== Int
0) forall a b. (a -> b) -> a -> b
$ String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$ String
"ERROR: the grammar contains no rules."
forall m. Monoid m => Bool -> m -> m
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall function. CFG function -> [String]
usedTokenCats CF
cf) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall f. CFG f -> [(String, Int)]
cfTokens CF
cf)) forall a b. (a -> b) -> a -> b
$
String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$
String
"ERROR: the languages defined by this grammar are empty since it mentions no terminals."
forall m a. Monoid m => [a] -> ([a] -> m) -> m
unlessNull (forall f. IsFun f => [Rul f] -> [RCat]
emptyData forall a b. (a -> b) -> a -> b
$ forall function. CFG function -> [Rul function]
cfgRules CF
cf) forall a b. (a -> b) -> a -> b
$ \ [RCat]
pcs -> do
String -> IO ()
dieUnlessForce forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ String
"ERROR: the following categories have empty abstract syntax:" ]
, [RString] -> [String]
printNames forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cat -> String
catToStr) [RCat]
pcs
]
String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
nRules String -> String -> String
+++ String
"rules accepted\n"
forall (m :: * -> *) a. Monad m => a -> m a
return CF
cf
where
runErr :: Either String a -> IO a
runErr = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. String -> IO a
die forall (m :: * -> *) a. Monad m => a -> m a
return
dieUnlessForce :: String -> IO ()
dieUnlessForce :: String -> IO ()
dieUnlessForce String
msg = do
Handle -> String -> IO ()
hPutStrLn Handle
stderr String
msg
if SharedOptions -> Bool
force SharedOptions
opts then do
Handle -> String -> IO ()
hPutStrLn Handle
stderr
String
"Ignoring error... (thanks to --force)"
else do
Handle -> String -> IO ()
hPutStrLn Handle
stderr
String
"Aborting. (Use option --force to continue despite errors.)"
forall a. IO a
exitFailure
usedTokenCats :: CFG f -> [TokenCat]
usedTokenCats :: forall function. CFG function -> [String]
usedTokenCats CFG f
cf = [ String
c | Rule f
_ RCat
_ SentForm
rhs InternalRule
_ <- forall function. CFG function -> [Rul function]
cfgRules CFG f
cf, Left (TokenCat String
c) <- SentForm
rhs ]
printNames :: [RString] -> [String]
printNames :: [RString] -> [String]
printNames = forall a b. (a -> b) -> [a] -> [b]
map ((String
" " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. RString -> String
blendInPosition) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn forall {b}. WithPosition b -> (Position, b)
lexicoGraphic
where
lexicoGraphic :: WithPosition b -> (Position, b)
lexicoGraphic (WithPosition Position
pos b
x) = (Position
pos,b
x)
die :: String -> IO a
die :: forall a. String -> IO a
die String
msg = do
Handle -> String -> IO ()
hPutStrLn Handle
stderr String
msg
forall a. IO a
exitFailure
getCF :: SharedOptions -> Abs.Grammar -> Err CF
getCF :: SharedOptions -> Grammar -> Either String CF
getCF SharedOptions
opts (Abs.Grammar [Def]
defs) = do
([Pragma]
pragma, [Rule]
rules) <- forall a b. [Either a b] -> ([a], [b])
partitionEithers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Def -> Trans [Either Pragma Rule]
transDef [Def]
defs forall a. Trans a -> SharedOptions -> Err a
`runTrans` SharedOptions
opts
let reservedWords :: [String]
reservedWords = forall a. Eq a => [a] -> [a]
nub [ String
t | Rule
r <- [Rule]
rules, forall f. Rul f -> Bool
isParsable Rule
r, Right String
t <- forall function. Rul function -> SentForm
rhsRule Rule
r, Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
t ]
usedCats :: Set Cat
usedCats = forall a. Ord a => [a] -> Set a
Set.fromList [ Cat
c | Rule RString
_ RCat
_ SentForm
rhs InternalRule
_ <- [Rule]
rules, Left Cat
c <- SentForm
rhs ]
literals :: [String]
literals = forall a. (a -> Bool) -> [a] -> [a]
filter (\ String
s -> String -> Cat
TokenCat String
s forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Cat
usedCats) forall a b. (a -> b) -> a -> b
$ [String]
specialCatsP
([String]
symbols,[String]
keywords) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition String -> Bool
notIdent [String]
reservedWords
Signature
sig <- forall a. Err a -> Either String a
runTypeChecker forall a b. (a -> b) -> a -> b
$ [Rule] -> Err Signature
buildSignature [Rule]
rules
let
cf :: CF
cf = CF -> CF
revs forall a b. (a -> b) -> a -> b
$ CFG
{ cfgPragmas :: [Pragma]
cfgPragmas = [Pragma]
pragma
, cfgUsedCats :: Set Cat
cfgUsedCats = Set Cat
usedCats
, cfgLiterals :: [String]
cfgLiterals = [String]
literals
, cfgSymbols :: [String]
cfgSymbols = [String]
symbols
, cfgKeywords :: [String]
cfgKeywords = [String]
keywords
, cfgReversibleCats :: [Cat]
cfgReversibleCats = []
, cfgRules :: [Rule]
cfgRules = [Rule]
rules
, cfgSignature :: Signature
cfgSignature = Signature
sig
}
case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (CF -> Rule -> Maybe String
checkRule CF
cf) [Rule]
rules of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
[String]
msgs -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
msgs
forall (m :: * -> *) a. Monad m => a -> m a
return CF
cf
where
notIdent :: String -> Bool
notIdent String
s = forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s Bool -> Bool -> Bool
|| Bool -> Bool
not (Char -> Bool
isAlpha (forall a. [a] -> a
head String
s)) Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isIdentRest) String
s
isIdentRest :: Char -> Bool
isIdentRest Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\''
revs :: CF -> CF
revs CF
cf =
CF
cf{ cfgReversibleCats :: [Cat]
cfgReversibleCats = CF -> [Cat]
findAllReversibleCats CF
cf }
markTokenCategories :: CF -> CF
markTokenCategories :: CF -> CF
markTokenCategories CF
cf = forall a. FixTokenCats a => [String] -> a -> a
fixTokenCats [String]
tokenCatNames CF
cf
where
tokenCatNames :: [String]
tokenCatNames = [ forall a. WithPosition a -> a
wpThing RString
n | TokenReg RString
n Bool
_ Reg
_ <- forall function. CFG function -> [Pragma]
cfgPragmas CF
cf ] forall a. [a] -> [a] -> [a]
++ [String]
specialCatsP
class FixTokenCats a where
fixTokenCats :: [TokenCat] -> a -> a
default fixTokenCats :: (Functor t, FixTokenCats b, t b ~ a) => [TokenCat] -> a -> a
fixTokenCats = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FixTokenCats a => [String] -> a -> a
fixTokenCats
instance FixTokenCats a => FixTokenCats [a]
instance FixTokenCats a => FixTokenCats (WithPosition a)
instance (FixTokenCats a, Ord a) => FixTokenCats (Set a) where
fixTokenCats :: [String] -> Set a -> Set a
fixTokenCats = forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FixTokenCats a => [String] -> a -> a
fixTokenCats
instance FixTokenCats Cat where
fixTokenCats :: [String] -> Cat -> Cat
fixTokenCats [String]
ns = \case
Cat String
a | String
a forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
ns -> String -> Cat
TokenCat String
a
ListCat Cat
c -> Cat -> Cat
ListCat forall a b. (a -> b) -> a -> b
$ forall a. FixTokenCats a => [String] -> a -> a
fixTokenCats [String]
ns Cat
c
Cat
c -> Cat
c
instance FixTokenCats (Either Cat String) where
fixTokenCats :: [String] -> Either Cat String -> Either Cat String
fixTokenCats = forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FixTokenCats a => [String] -> a -> a
fixTokenCats
instance FixTokenCats (Rul f) where
fixTokenCats :: [String] -> Rul f -> Rul f
fixTokenCats [String]
ns (Rule f
f RCat
c SentForm
rhs InternalRule
internal) =
forall function.
function -> RCat -> SentForm -> InternalRule -> Rul function
Rule f
f (forall a. FixTokenCats a => [String] -> a -> a
fixTokenCats [String]
ns RCat
c) (forall a. FixTokenCats a => [String] -> a -> a
fixTokenCats [String]
ns SentForm
rhs) InternalRule
internal
instance FixTokenCats Pragma where
fixTokenCats :: [String] -> Pragma -> Pragma
fixTokenCats [String]
ns = \case
EntryPoints [RCat]
eps -> [RCat] -> Pragma
EntryPoints forall a b. (a -> b) -> a -> b
$ forall a. FixTokenCats a => [String] -> a -> a
fixTokenCats [String]
ns [RCat]
eps
Pragma
p -> Pragma
p
instance FixTokenCats (CFG f) where
fixTokenCats :: [String] -> CFG f -> CFG f
fixTokenCats [String]
ns cf :: CFG f
cf@CFG{[String]
[Cat]
[Pragma]
[Rul f]
Signature
Set Cat
cfgSignature :: Signature
cfgRules :: [Rul f]
cfgReversibleCats :: [Cat]
cfgKeywords :: [String]
cfgSymbols :: [String]
cfgLiterals :: [String]
cfgUsedCats :: Set Cat
cfgPragmas :: [Pragma]
cfgSignature :: forall function. CFG function -> Signature
cfgReversibleCats :: forall function. CFG function -> [Cat]
cfgKeywords :: forall function. CFG function -> [String]
cfgLiterals :: forall function. CFG function -> [String]
cfgUsedCats :: forall function. CFG function -> Set Cat
cfgRules :: forall function. CFG function -> [Rul function]
cfgPragmas :: forall function. CFG function -> [Pragma]
cfgSymbols :: forall function. CFG function -> [String]
..} = CFG f
cf
{ cfgPragmas :: [Pragma]
cfgPragmas = forall a. FixTokenCats a => [String] -> a -> a
fixTokenCats [String]
ns [Pragma]
cfgPragmas
, cfgUsedCats :: Set Cat
cfgUsedCats = forall a. FixTokenCats a => [String] -> a -> a
fixTokenCats [String]
ns Set Cat
cfgUsedCats
, cfgRules :: [Rul f]
cfgRules = forall a. FixTokenCats a => [String] -> a -> a
fixTokenCats [String]
ns [Rul f]
cfgRules
}
newtype Trans a = Trans { forall a. Trans a -> ReaderT SharedOptions (Either String) a
unTrans :: ReaderT SharedOptions Err a }
deriving (forall a b. a -> Trans b -> Trans a
forall a b. (a -> b) -> Trans a -> Trans b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Trans b -> Trans a
$c<$ :: forall a b. a -> Trans b -> Trans a
fmap :: forall a b. (a -> b) -> Trans a -> Trans b
$cfmap :: forall a b. (a -> b) -> Trans a -> Trans b
Functor, Functor Trans
forall a. a -> Trans a
forall a b. Trans a -> Trans b -> Trans a
forall a b. Trans a -> Trans b -> Trans b
forall a b. Trans (a -> b) -> Trans a -> Trans b
forall a b c. (a -> b -> c) -> Trans a -> Trans b -> Trans c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. Trans a -> Trans b -> Trans a
$c<* :: forall a b. Trans a -> Trans b -> Trans a
*> :: forall a b. Trans a -> Trans b -> Trans b
$c*> :: forall a b. Trans a -> Trans b -> Trans b
liftA2 :: forall a b c. (a -> b -> c) -> Trans a -> Trans b -> Trans c
$cliftA2 :: forall a b c. (a -> b -> c) -> Trans a -> Trans b -> Trans c
<*> :: forall a b. Trans (a -> b) -> Trans a -> Trans b
$c<*> :: forall a b. Trans (a -> b) -> Trans a -> Trans b
pure :: forall a. a -> Trans a
$cpure :: forall a. a -> Trans a
Applicative, Applicative Trans
forall a. a -> Trans a
forall a b. Trans a -> Trans b -> Trans b
forall a b. Trans a -> (a -> Trans b) -> Trans b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> Trans a
$creturn :: forall a. a -> Trans a
>> :: forall a b. Trans a -> Trans b -> Trans b
$c>> :: forall a b. Trans a -> Trans b -> Trans b
>>= :: forall a b. Trans a -> (a -> Trans b) -> Trans b
$c>>= :: forall a b. Trans a -> (a -> Trans b) -> Trans b
Monad, MonadReader SharedOptions, MonadError String)
runTrans :: Trans a -> SharedOptions -> Err a
runTrans :: forall a. Trans a -> SharedOptions -> Err a
runTrans Trans a
m SharedOptions
opts = forall a. Trans a -> ReaderT SharedOptions (Either String) a
unTrans Trans a
m forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` SharedOptions
opts
transDef :: Abs.Def -> Trans [Either Pragma Rule]
transDef :: Def -> Trans [Either Pragma Rule]
transDef = \case
Abs.Rule Label
label Cat
cat [Item]
items -> do
RString
f <- Label -> Trans RString
transLabel Label
label
RCat
c <- Cat -> Trans RCat
transCat Cat
cat
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall function.
function -> RCat -> SentForm -> InternalRule -> Rul function
Rule RString
f RCat
c (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Item -> SentForm
transItem [Item]
items) InternalRule
Parsable ]
Abs.Internal Label
label Cat
cat [Item]
items -> do
RString
f <- Label -> Trans RString
transLabel Label
label
RCat
c <- Cat -> Trans RCat
transCat Cat
cat
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall function.
function -> RCat -> SentForm -> InternalRule -> Rul function
Rule RString
f RCat
c (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Item -> SentForm
transItem [Item]
items) InternalRule
Internal ]
Abs.Comment String
str -> forall (m :: * -> *) a. Monad m => a -> m a
return [ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Pragma
CommentS String
str ]
Abs.Comments String
str1 String
str2 -> forall (m :: * -> *) a. Monad m => a -> m a
return [ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ (String, String) -> Pragma
CommentM (String
str1, String
str2) ]
Abs.Token Identifier
ident Reg
reg -> do RString
x <- Identifier -> Trans RString
transIdent Identifier
ident; forall (m :: * -> *) a. Monad m => a -> m a
return [forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ RString -> Bool -> Reg -> Pragma
TokenReg RString
x Bool
False forall a b. (a -> b) -> a -> b
$ Reg -> Reg
simpReg Reg
reg]
Abs.PosToken Identifier
ident Reg
reg -> do RString
x <- Identifier -> Trans RString
transIdent Identifier
ident; forall (m :: * -> *) a. Monad m => a -> m a
return [forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ RString -> Bool -> Reg -> Pragma
TokenReg RString
x Bool
True forall a b. (a -> b) -> a -> b
$ Reg -> Reg
simpReg Reg
reg]
Abs.Entryp [Cat]
cats -> forall a. a -> [a]
singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RCat] -> Pragma
EntryPoints forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Cat -> Trans RCat
transCat [Cat]
cats
Abs.Separator MinimumSize
size Cat
ident String
str -> forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MinimumSize -> Cat -> String -> Trans [Rule]
separatorRules MinimumSize
size Cat
ident String
str
Abs.Terminator MinimumSize
size Cat
ident String
str -> forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MinimumSize -> Cat -> String -> Trans [Rule]
terminatorRules MinimumSize
size Cat
ident String
str
Abs.Delimiters Cat
cat String
_ String
_ Separation
_ MinimumSize
_ -> do
WithPosition Position
pos Cat
_ <- Cat -> Trans RCat
transCat Cat
cat
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ RString -> String
blendInPosition forall a b. (a -> b) -> a -> b
$ forall a. Position -> a -> WithPosition a
WithPosition Position
pos forall a b. (a -> b) -> a -> b
$
String
"The delimiters pragma " forall a. [a] -> [a] -> [a]
++ String
removedIn290
Abs.Coercions Identifier
ident Integer
int -> forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Identifier -> Integer -> Trans [Rule]
coercionRules Identifier
ident Integer
int
Abs.Rules Identifier
ident [RHS]
strs -> forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Identifier -> [RHS] -> Trans [Rule]
ebnfRules Identifier
ident [RHS]
strs
Abs.Layout [String]
ss -> forall (m :: * -> *) a. Monad m => a -> m a
return [ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ LayoutKeyWords -> Pragma
Layout forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (,String -> String -> String -> Delimiters
Delimiters String
";" String
"{" String
"}") [String]
ss ]
Abs.LayoutStop [String]
ss -> forall (m :: * -> *) a. Monad m => a -> m a
return [ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [String] -> Pragma
LayoutStop [String]
ss]
Def
Abs.LayoutTop -> forall (m :: * -> *) a. Monad m => a -> m a
return [ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Pragma
LayoutTop String
";" ]
Abs.Function Identifier
ident [Arg]
xs Exp
e -> do
RString
f <- Identifier -> Trans RString
transIdent Identifier
ident
let xs' :: [(String, Base)]
xs' = forall a b. (a -> b) -> [a] -> [b]
map Arg -> (String, Base)
transArg [Arg]
xs
forall (m :: * -> *) a. Monad m => a -> m a
return [ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Define -> Pragma
FunDef forall a b. (a -> b) -> a -> b
$ RString -> [(String, Base)] -> Exp -> Base -> Define
Define RString
f [(String, Base)]
xs' ([String] -> Exp -> Exp
transExp (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(String, Base)]
xs') Exp
e) Base
dummyBase ]
separatorRules :: Abs.MinimumSize -> Abs.Cat -> String -> Trans [Rule]
separatorRules :: MinimumSize -> Cat -> String -> Trans [Rule]
separatorRules MinimumSize
size Cat
c0 String
s
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
s = MinimumSize -> Cat -> String -> Trans [Rule]
terminatorRules MinimumSize
size Cat
c0 String
s
| Bool
otherwise = do
WithPosition Position
pos Cat
c <- Cat -> Trans RCat
transCat Cat
c0
let cs :: Cat
cs = Cat -> Cat
ListCat Cat
c
let rule :: String -> SentForm -> Rule
rule :: String -> SentForm -> Rule
rule String
x SentForm
rhs = forall function.
function -> RCat -> SentForm -> InternalRule -> Rul function
Rule (forall a. Position -> a -> WithPosition a
WithPosition Position
pos String
x) (forall a. Position -> a -> WithPosition a
WithPosition Position
pos Cat
cs) SentForm
rhs InternalRule
Parsable
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ String -> SentForm -> Rule
rule String
"[]" [] | MinimumSize
size forall a. Eq a => a -> a -> Bool
== MinimumSize
Abs.MEmpty ]
, [ String -> SentForm -> Rule
rule String
"(:[])" [forall a b. a -> Either a b
Left Cat
c] ]
, [ String -> SentForm -> Rule
rule String
"(:)" [forall a b. a -> Either a b
Left Cat
c, forall a b. b -> Either a b
Right String
s, forall a b. a -> Either a b
Left Cat
cs] ]
]
terminatorRules :: Abs.MinimumSize -> Abs.Cat -> String -> Trans [Rule]
terminatorRules :: MinimumSize -> Cat -> String -> Trans [Rule]
terminatorRules MinimumSize
size Cat
c0 String
s = do
WithPosition Position
pos Cat
c <- Cat -> Trans RCat
transCat Cat
c0
let wp :: a -> WithPosition a
wp = forall a. Position -> a -> WithPosition a
WithPosition Position
pos
let cs :: Cat
cs = Cat -> Cat
ListCat Cat
c
let rule :: a -> SentForm -> Rul (WithPosition a)
rule a
x SentForm
rhs = forall function.
function -> RCat -> SentForm -> InternalRule -> Rul function
Rule (forall {a}. a -> WithPosition a
wp a
x) (forall {a}. a -> WithPosition a
wp Cat
cs) SentForm
rhs InternalRule
Parsable
forall (m :: * -> *) a. Monad m => a -> m a
return
[ case MinimumSize
size of
MinimumSize
Abs.MNonempty ->
forall {a}. a -> SentForm -> Rul (WithPosition a)
rule String
"(:[])" (forall a b. a -> Either a b
Left Cat
c forall a. a -> [a] -> [a]
: forall {a}. [Either a String] -> [Either a String]
term [])
MinimumSize
Abs.MEmpty ->
forall {a}. a -> SentForm -> Rul (WithPosition a)
rule String
"[]" []
, forall {a}. a -> SentForm -> Rul (WithPosition a)
rule String
"(:)" (forall a b. a -> Either a b
Left Cat
c forall a. a -> [a] -> [a]
: forall {a}. [Either a String] -> [Either a String]
term [forall a b. a -> Either a b
Left Cat
cs])
]
where
term :: [Either a String] -> [Either a String]
term = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s then forall a. a -> a
id else (forall a b. b -> Either a b
Right String
s forall a. a -> [a] -> [a]
:)
coercionRules :: Abs.Identifier -> Integer -> Trans [Rule]
coercionRules :: Identifier -> Integer -> Trans [Rule]
coercionRules Identifier
c0 Integer
n = do
WithPosition Position
pos String
c <- Identifier -> Trans RString
transIdent Identifier
c0
let wp :: a -> WithPosition a
wp = forall a. Position -> a -> WithPosition a
WithPosition Position
pos
let urule :: Cat -> SentForm -> Rul (WithPosition a)
urule Cat
x SentForm
rhs = forall function.
function -> RCat -> SentForm -> InternalRule -> Rul function
Rule (forall {a}. a -> WithPosition a
wp a
"_") (forall {a}. a -> WithPosition a
wp Cat
x) SentForm
rhs InternalRule
Parsable
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ forall {a}. IsString a => Cat -> SentForm -> Rul (WithPosition a)
urule (String -> Cat
Cat String
c) [forall a b. a -> Either a b
Left (String -> Integer -> Cat
CoercCat String
c Integer
1)] ]
, [ forall {a}. IsString a => Cat -> SentForm -> Rul (WithPosition a)
urule (String -> Integer -> Cat
CoercCat String
c (Integer
iforall a. Num a => a -> a -> a
-Integer
1)) [forall a b. a -> Either a b
Left (String -> Integer -> Cat
CoercCat String
c Integer
i)] | Integer
i <- [Integer
2..Integer
n] ]
, [ forall {a}. IsString a => Cat -> SentForm -> Rul (WithPosition a)
urule (String -> Integer -> Cat
CoercCat String
c Integer
n) [forall a b. b -> Either a b
Right String
"(", forall a b. a -> Either a b
Left (String -> Cat
Cat String
c), forall a b. b -> Either a b
Right String
")"] ]
]
ebnfRules :: Abs.Identifier -> [Abs.RHS] -> Trans [Rule]
ebnfRules :: Identifier -> [RHS] -> Trans [Rule]
ebnfRules (Abs.Identifier ((Int
line, Int
col), String
c)) [RHS]
rhss = do
String
file <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SharedOptions -> String
lbnfFile
let wp :: a -> WithPosition a
wp = forall a. Position -> a -> WithPosition a
WithPosition forall a b. (a -> b) -> a -> b
$ String -> Int -> Int -> Position
Position String
file Int
line Int
col
let rule :: a -> SentForm -> Rul (WithPosition a)
rule a
x SentForm
rhs = forall function.
function -> RCat -> SentForm -> InternalRule -> Rul function
Rule (forall {a}. a -> WithPosition a
wp a
x) (forall {a}. a -> WithPosition a
wp forall a b. (a -> b) -> a -> b
$ String -> Cat
strToCat String
c) SentForm
rhs InternalRule
Parsable
forall (m :: * -> *) a. Monad m => a -> m a
return
[ forall {a}. a -> SentForm -> Rul (WithPosition a)
rule (forall {a}. Show a => a -> [Item] -> String
mkFun Int
k [Item]
its) (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Item -> SentForm
transItem [Item]
its)
| (Int
k, Abs.RHS [Item]
its) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] [RHS]
rhss
]
where
mkFun :: a -> [Item] -> String
mkFun a
k = \case
[Abs.Terminal String
s] -> String
c' forall a. [a] -> [a] -> [a]
++ String
"_" forall a. [a] -> [a] -> [a]
++ forall {a}. Show a => a -> String -> String
mkName a
k String
s
[Abs.NTerminal Cat
n] -> String
c' forall a. [a] -> [a] -> [a]
++ Cat -> String
identCat (Cat -> Cat
transCat' Cat
n)
[Item]
_ -> String
c' forall a. [a] -> [a] -> [a]
++ String
"_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
k
c' :: String
c' = String
c
mkName :: a -> String -> String
mkName a
k String
s = if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
c (String
"_'" :: String)) String
s
then String
s else forall a. Show a => a -> String
show a
k
transItem :: Abs.Item -> [Either Cat String]
transItem :: Item -> SentForm
transItem (Abs.Terminal String
str) = [ forall a b. b -> Either a b
Right String
w | String
w <- String -> [String]
words String
str ]
transItem (Abs.NTerminal Cat
cat) = [ forall a b. a -> Either a b
Left (Cat -> Cat
transCat' Cat
cat) ]
transCat' :: Abs.Cat -> Cat
transCat' :: Cat -> Cat
transCat' = \case
Abs.ListCat Cat
cat -> Cat -> Cat
ListCat forall a b. (a -> b) -> a -> b
$ Cat -> Cat
transCat' Cat
cat
Abs.IdCat (Abs.Identifier ((Int, Int)
_pos, String
c)) -> String -> Cat
strToCat String
c
transCat :: Abs.Cat -> Trans (WithPosition Cat)
transCat :: Cat -> Trans RCat
transCat = \case
Abs.ListCat Cat
cat -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cat -> Cat
ListCat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cat -> Trans RCat
transCat Cat
cat
Abs.IdCat (Abs.Identifier ((Int
line, Int
col), String
c)) -> do
String
file <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SharedOptions -> String
lbnfFile
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Position -> a -> WithPosition a
WithPosition (String -> Int -> Int -> Position
Position String
file Int
line Int
col) forall a b. (a -> b) -> a -> b
$ String -> Cat
strToCat String
c
transLabel :: Abs.Label -> Trans RFun
transLabel :: Label -> Trans RString
transLabel = \case
Abs.Id Identifier
id -> Identifier -> Trans RString
transIdent Identifier
id
Label
Abs.Wild -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {a}. a -> WithPosition a
noPosition forall a b. (a -> b) -> a -> b
$ String
"_"
Label
Abs.ListE -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {a}. a -> WithPosition a
noPosition forall a b. (a -> b) -> a -> b
$ String
"[]"
Label
Abs.ListCons -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {a}. a -> WithPosition a
noPosition forall a b. (a -> b) -> a -> b
$ String
"(:)"
Label
Abs.ListOne -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {a}. a -> WithPosition a
noPosition forall a b. (a -> b) -> a -> b
$ String
"(:[])"
transIdent :: Abs.Identifier -> Trans RString
transIdent :: Identifier -> Trans RString
transIdent (Abs.Identifier ((Int
line, Int
col), String
str)) = do
String
file <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SharedOptions -> String
lbnfFile
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Position -> a -> WithPosition a
WithPosition (String -> Int -> Int -> Position
Position String
file Int
line Int
col) String
str
transArg :: Abs.Arg -> (String, Base)
transArg :: Arg -> (String, Base)
transArg (Abs.Arg (Abs.Identifier ((Int, Int)
_pos, String
x))) = (String
x, Base
dummyBase)
transExp
:: [String]
-> Abs.Exp
-> Exp
transExp :: [String] -> Exp -> Exp
transExp [String]
xs = Exp -> Exp
loop
where
loop :: Exp -> Exp
loop = \case
Abs.App Identifier
x [Exp]
es -> forall f. f -> Type -> [Exp' f] -> Exp' f
App (Identifier -> String
transIdent' Identifier
x) Type
dummyType (forall a b. (a -> b) -> [a] -> [b]
map Exp -> Exp
loop [Exp]
es)
Abs.Var Identifier
x -> let x' :: String
x' = Identifier -> String
transIdent' Identifier
x in
if String
x' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
xs then forall f. String -> Exp' f
Var String
x' else forall f. f -> Type -> [Exp' f] -> Exp' f
App String
x' Type
dummyType []
Abs.Cons Exp
e1 Exp
e2 -> Exp -> Exp -> Exp
cons Exp
e1 (Exp -> Exp
loop Exp
e2)
Abs.List [Exp]
es -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp -> Exp -> Exp
cons Exp
nil [Exp]
es
Abs.LitInt Integer
x -> forall f. Integer -> Exp' f
LitInt Integer
x
Abs.LitDouble Double
x -> forall f. Double -> Exp' f
LitDouble Double
x
Abs.LitChar Char
x -> forall f. Char -> Exp' f
LitChar Char
x
Abs.LitString String
x -> forall f. String -> Exp' f
LitString String
x
cons :: Exp -> Exp -> Exp
cons Exp
e1 Exp
e2 = forall f. f -> Type -> [Exp' f] -> Exp' f
App String
"(:)" Type
dummyType [Exp -> Exp
loop Exp
e1, Exp
e2]
nil :: Exp
nil = forall f. f -> Type -> [Exp' f] -> Exp' f
App String
"[]" Type
dummyType []
transIdent' :: Identifier -> String
transIdent' (Abs.Identifier ((Int, Int)
_pos, String
x)) = String
x
checkComments :: CFG f -> [String]
CFG f
cf = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ String
"Empty line comment delimiter." | CommentS String
"" <- [Pragma]
prags ]
, [ String
"Empty block comment start delimiter." | CommentM (String
"", String
_) <- [Pragma]
prags ]
, [ String
"Empty block comment end delimiter." | CommentM (String
_, String
"") <- [Pragma]
prags ]
]
where
prags :: [Pragma]
prags = forall function. CFG function -> [Pragma]
cfgPragmas CFG f
cf
checkTokens :: CFG f -> Maybe String
checkTokens :: forall f. CFG f -> Maybe String
checkTokens CFG f
cf =
case forall a. [Maybe a] -> [a]
catMaybes [ forall f. CFG f -> Maybe String
checkTokensEmpty CFG f
cf, forall f. CFG f -> Maybe String
checkTokensNullable CFG f
cf ] of
[] -> forall a. Maybe a
Nothing
[String]
ss -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
ss
checkTokensNullable :: CFG f -> Maybe String
checkTokensNullable :: forall f. CFG f -> Maybe String
checkTokensNullable CFG f
cf
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RString]
pxs = forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ String
"ERROR: The following tokens accept the empty string:" ]
, [RString] -> [String]
printNames [RString]
pxs
]
where
pxs :: [RString]
pxs = [ RString
px | TokenReg RString
px Bool
_ Reg
regex <- forall function. CFG function -> [Pragma]
cfgPragmas CFG f
cf, Reg -> Bool
nullable Reg
regex ]
checkTokensEmpty :: CFG f -> Maybe String
checkTokensEmpty :: forall f. CFG f -> Maybe String
checkTokensEmpty CFG f
cf
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RString]
pxs = forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ String
"ERROR: The following tokens accept nothing:" ]
, [RString] -> [String]
printNames [RString]
pxs
]
where
pxs :: [RString]
pxs = [ RString
px | TokenReg RString
px Bool
_ (RAlts String
"") <- forall function. CFG function -> [Pragma]
cfgPragmas CFG f
cf ]
checkRule :: CF -> Rule -> Maybe String
checkRule :: CF -> Rule -> Maybe String
checkRule CF
cf r :: Rule
r@(Rule RString
f (WithPosition Position
_ Cat
cat) SentForm
rhs InternalRule
_)
| Cat (Char
'@':String
_) <- Cat
cat = forall a. Maybe a
Nothing
| Bool
badCoercion = String -> String -> Maybe String
stdFail String
txtCoercion String
"Bad coercion in rule"
| Bool
badNil = String -> String -> Maybe String
stdFail String
txtNil String
"Bad empty list rule"
| Bool
badOne = String -> String -> Maybe String
stdFail String
txtOne String
"Bad one-element list rule"
| Bool
badCons = String -> String -> Maybe String
stdFail String
txtCons String
"Bad list construction rule"
| Bool
badList = String -> String -> Maybe String
stdFail String
txtList String
"Bad list formation rule"
| Bool
badSpecial = String -> Maybe String
failure forall a b. (a -> b) -> a -> b
$ String
"Bad special category rule" String -> String -> String
+++ String
s
| Bool
badTypeName = String -> Maybe String
failure forall a b. (a -> b) -> a -> b
$ String
"Bad type name" String -> String -> String
+++ [String] -> String
unwords (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> String
prettyShow [Cat]
badTypes) String -> String -> String
+++ String
"in" String -> String -> String
+++ String
s
| Bool
badFunName = String -> Maybe String
failure forall a b. (a -> b) -> a -> b
$ String
"Bad constructor name" String -> String -> String
+++ String
fun String -> String -> String
+++ String
"in" String -> String -> String
+++ String
s
| Bool
badMissing = String -> Maybe String
failure forall a b. (a -> b) -> a -> b
$ String
"no production for" String -> String -> String
+++ [String] -> String
unwords [String]
missing forall a. [a] -> [a] -> [a]
++ String
", appearing in rule\n " forall a. [a] -> [a] -> [a]
++ String
s
| Bool
otherwise = forall a. Maybe a
Nothing
where
failure :: String -> Maybe String
failure = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. RString -> String
blendInPosition forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RString
f forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>)
stdFail :: String -> String -> Maybe String
stdFail String
txt String
err = String -> Maybe String
failure forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [ String
err forall a. [a] -> [a] -> [a]
++ String
":", String
" " forall a. [a] -> [a] -> [a]
++ String
s, String
txt ]
fun :: String
fun = forall a. WithPosition a -> a
wpThing RString
f
s :: String
s = forall a. Pretty a => a -> String
prettyShow Rule
r
c :: Cat
c = Cat -> Cat
normCat Cat
cat
cs :: [Cat]
cs = [Cat -> Cat
normCat Cat
c | Left Cat
c <- SentForm
rhs]
badCoercion :: Bool
badCoercion = forall a. IsFun a => a -> Bool
isCoercion RString
f Bool -> Bool -> Bool
&& [Cat]
cs forall a. Eq a => a -> a -> Bool
/= [Cat
c]
txtCoercion :: String
txtCoercion = String
"In a coercion (label _), category on the left of ::= needs to be the single category on the right."
badNil :: Bool
badNil = forall a. IsFun a => a -> Bool
isNilFun RString
f Bool -> Bool -> Bool
&& Bool -> Bool
not (Cat -> Bool
isList Cat
c Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Cat]
cs)
txtNil :: String
txtNil = String
"In a nil rule (label []), the category on the left of ::= needs to be a list category [C] and no categories are allowed on the right."
badOne :: Bool
badOne = forall a. IsFun a => a -> Bool
isOneFun RString
f Bool -> Bool -> Bool
&& Bool -> Bool
not (Cat -> Bool
isList Cat
c Bool -> Bool -> Bool
&& [Cat]
cs forall a. Eq a => a -> a -> Bool
== [Cat -> Cat
catOfList Cat
c])
txtOne :: String
txtOne = String
"In a singleton rule (label (:[])), the category on the left of ::= needs to be a list category [C], and C must be the sole categories on the right."
badCons :: Bool
badCons = forall a. IsFun a => a -> Bool
isConsFun RString
f Bool -> Bool -> Bool
&& Bool -> Bool
not (Cat -> Bool
isList Cat
c Bool -> Bool -> Bool
&& [Cat]
cs forall a. Eq a => a -> a -> Bool
== [Cat -> Cat
catOfList Cat
c, Cat
c])
txtCons :: String
txtCons = String
"In a cons rule (label (:)), the category on the left of ::= needs to be a list category [C], and C and [C] (in this order) must be the sole categories on the right."
badList :: Bool
badList = Cat -> Bool
isList Cat
c Bool -> Bool -> Bool
&& Bool -> Bool
not (forall a. IsFun a => a -> Bool
isCoercion RString
f Bool -> Bool -> Bool
|| forall a. IsFun a => a -> Bool
isNilCons RString
f)
txtList :: String
txtList = String
"List categories [C] can only be formed by rules labeled _, [], (:), or (:[])."
badSpecial :: Bool
badSpecial = forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Cat
c [ String -> Cat
Cat String
x | String
x <- [String]
specialCatsP] Bool -> Bool -> Bool
&& Bool -> Bool
not (forall a. IsFun a => a -> Bool
isCoercion RString
f)
badMissing :: Bool
badMissing = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
missing)
missing :: [String]
missing = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
defineds) [Cat -> String
catToStr Cat
c | Left Cat
c <- SentForm
rhs]
where
defineds :: [String]
defineds = forall function. CFG function -> [String]
tokenNames CF
cf forall a. [a] -> [a] -> [a]
++ [String]
specialCatsP forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (Cat -> String
catToStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall fun. Rul fun -> Cat
valCat) (forall function. CFG function -> [Rul function]
cfgRules CF
cf)
badTypeName :: Bool
badTypeName = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Cat]
badTypes)
badTypes :: [Cat]
badTypes = forall a. (a -> Bool) -> [a] -> [a]
filter Cat -> Bool
isBadType forall a b. (a -> b) -> a -> b
$ Cat
cat forall a. a -> [a] -> [a]
: [Cat
c | Left Cat
c <- SentForm
rhs]
where
isBadType :: Cat -> Bool
isBadType (ListCat Cat
c) = Cat -> Bool
isBadType Cat
c
isBadType (CoercCat String
c Integer
_) = String -> Bool
isBadCatName String
c
isBadType (Cat String
s) = String -> Bool
isBadCatName String
s
isBadType (TokenCat String
s) = String -> Bool
isBadCatName String
s
isBadCatName :: String -> Bool
isBadCatName String
s = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Char -> Bool
isUpper (forall a. [a] -> a
head String
s) Bool -> Bool -> Bool
|| (forall a. [a] -> a
head String
s forall a. Eq a => a -> a -> Bool
== Char
'@')
badFunName :: Bool
badFunName = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_') (forall a. WithPosition a -> a
wpThing RString
f)
Bool -> Bool -> Bool
|| forall a. IsFun a => a -> Bool
isCoercion RString
f Bool -> Bool -> Bool
|| forall a. IsFun a => a -> Bool
isNilCons RString
f)
expandRules :: Abs.Grammar -> Abs.Grammar
expandRules :: Grammar -> Grammar
expandRules (Abs.Grammar [Def]
defs) =
[Def] -> Grammar
Abs.Grammar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Def -> State [(String, Int)] [Def]
expand [Def]
defs forall s a. State s a -> s -> a
`evalState` []
where
expand :: Abs.Def -> State [(String, Int)] [Abs.Def]
expand :: Def -> State [(String, Int)] [Def]
expand = \case
Abs.Rules Identifier
ident [RHS]
rhss -> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Identifier -> RHS -> State [(String, Int)] Def
mkRule Identifier
ident) [RHS]
rhss
Def
other -> forall (m :: * -> *) a. Monad m => a -> m a
return [ Def
other ]
mkRule :: Abs.Identifier -> Abs.RHS -> State [(String, Int)] Abs.Def
mkRule :: Identifier -> RHS -> State [(String, Int)] Def
mkRule Identifier
ident (Abs.RHS [Item]
rhs) = do
Label
fun <- Identifier -> Label
Abs.Id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Identifier -> [Item] -> State [(String, Int)] Identifier
mkName Identifier
ident [Item]
rhs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Label -> Cat -> [Item] -> Def
Abs.Rule Label
fun (Identifier -> Cat
Abs.IdCat Identifier
ident) [Item]
rhs
mkName :: Abs.Identifier -> [Abs.Item] -> State [(String, Int)] Abs.Identifier
mkName :: Identifier -> [Item] -> State [(String, Int)] Identifier
mkName (Abs.Identifier ((Int, Int)
pos, String
cat)) = \case
[ Abs.Terminal String
s ] | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\ Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_') String
s ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ((Int, Int), String) -> Identifier
Abs.Identifier ((Int, Int)
pos, String
cat forall a. [a] -> [a] -> [a]
++ String
"_" forall a. [a] -> [a] -> [a]
++ String
s)
[ Abs.NTerminal (Abs.IdCat (Abs.Identifier ((Int, Int)
pos', String
s))) ] ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ((Int, Int), String) -> Identifier
Abs.Identifier ((Int, Int)
pos', String
cat forall a. [a] -> [a] -> [a]
++ String
s)
[Item]
_ -> do
Int
i <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
1 (forall a. Num a => a -> a -> a
+Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
cat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((String
cat, Int
i)forall a. a -> [a] -> [a]
:)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ((Int, Int), String) -> Identifier
Abs.Identifier ((Int, Int)
pos, String
cat forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i)