> module Grammar (
> Name, isEmpty,
>
> Production, Grammar(..), mangler,
>
> LRAction(..), ActionTable, Goto(..), GotoTable, Priority(..),
> Assoc(..),
>
> errorName, errorTok, startName, firstStartTok, dummyTok,
> eofName, epsilonTok
> ) where
> import GenUtils
> import AbsSyn
> import ParseMonad
> import AttrGrammar
> import AttrGrammarParser
> import ParamRules
> import Data.Array
> import Data.Char
> import Data.List
> import Data.Maybe (fromMaybe)
> import Control.Monad (when)
> import Control.Monad.Writer
#ifdef DEBUG
> import System.IOExts
#endif
> type Name = Int
> type Production = (Name,[Name],(String,[Int]),Priority)
> data Grammar
> = Grammar {
> Grammar -> [Production]
productions :: [Production],
> Grammar -> Int -> Production
lookupProdNo :: Int -> Production,
> Grammar -> Int -> [Int]
lookupProdsOfName :: Name -> [Int],
> Grammar -> [(Int, ErrMsg)]
token_specs :: [(Name,String)],
> Grammar -> [Int]
terminals :: [Name],
> Grammar -> [Int]
non_terminals :: [Name],
> Grammar -> [(ErrMsg, Int, Int, Bool)]
starts :: [(String,Name,Name,Bool)],
> Grammar -> Array Int (Maybe ErrMsg)
types :: Array Int (Maybe String),
> Grammar -> Array Int ErrMsg
token_names :: Array Int String,
> Grammar -> Int
first_nonterm :: Name,
> Grammar -> Int
first_term :: Name,
> Grammar -> Int
eof_term :: Name,
> Grammar -> [(Int, Priority)]
priorities :: [(Name,Priority)],
> Grammar -> ErrMsg
token_type :: String,
> Grammar -> Bool
imported_identity :: Bool,
> Grammar -> (Bool, ErrMsg, ErrMsg, ErrMsg, ErrMsg)
monad :: (Bool,String,String,String,String),
> Grammar -> Maybe Int
expect :: Maybe Int,
> Grammar -> [(ErrMsg, ErrMsg)]
attributes :: [(String,String)],
> Grammar -> ErrMsg
attributetype :: String,
> Grammar -> Maybe (ErrMsg, ErrMsg)
lexer :: Maybe (String,String),
> Grammar -> Maybe ErrMsg
error_handler :: Maybe String
> }
#ifdef DEBUG
> instance Show Grammar where
> showsPrec _ (Grammar
> { productions = p
> , token_specs = t
> , terminals = ts
> , non_terminals = nts
> , starts = starts
> , types = tys
> , token_names = e
> , first_nonterm = fnt
> , first_term = ft
> , eof_term = eof
> })
> = showString "productions = " . shows p
> . showString "\ntoken_specs = " . shows t
> . showString "\nterminals = " . shows ts
> . showString "\nnonterminals = " . shows nts
> . showString "\nstarts = " . shows starts
> . showString "\ntypes = " . shows tys
> . showString "\ntoken_names = " . shows e
> . showString "\nfirst_nonterm = " . shows fnt
> . showString "\nfirst_term = " . shows ft
> . showString "\neof = " . shows eof
> . showString "\n"
#endif
> data Assoc = LeftAssoc | RightAssoc | None
#ifdef DEBUG
> deriving Show
#endif
> data Priority = No | Prio Assoc Int
#ifdef DEBUG
> deriving Show
#endif
> instance Eq Priority where
> Priority
No == :: Priority -> Priority -> Bool
== Priority
No = Bool
True
> Prio Assoc
_ Int
i == Prio Assoc
_ Int
j = Int
i forall a. Eq a => a -> a -> Bool
== Int
j
> Priority
_ == Priority
_ = Bool
False
> mkPrio :: Int -> Directive a -> Priority
> mkPrio :: forall a. Int -> Directive a -> Priority
mkPrio Int
i (TokenNonassoc [ErrMsg]
_) = Assoc -> Int -> Priority
Prio Assoc
None Int
i
> mkPrio Int
i (TokenRight [ErrMsg]
_) = Assoc -> Int -> Priority
Prio Assoc
RightAssoc Int
i
> mkPrio Int
i (TokenLeft [ErrMsg]
_) = Assoc -> Int -> Priority
Prio Assoc
LeftAssoc Int
i
> mkPrio Int
_ Directive a
_ = forall a. HasCallStack => ErrMsg -> a
error ErrMsg
"Panic: impossible case in mkPrio"
> startName, eofName, errorName, dummyName :: String
> startName :: ErrMsg
startName = ErrMsg
"%start"
> eofName :: ErrMsg
eofName = ErrMsg
"%eof"
> errorName :: ErrMsg
errorName = ErrMsg
"error"
> dummyName :: ErrMsg
dummyName = ErrMsg
"%dummy"
> firstStartTok, dummyTok, errorTok, epsilonTok :: Name
> firstStartTok :: Int
firstStartTok = Int
3
> dummyTok :: Int
dummyTok = Int
2
> errorTok :: Int
errorTok = Int
1
> epsilonTok :: Int
epsilonTok = Int
0
> isEmpty :: Name -> Bool
> isEmpty :: Int -> Bool
isEmpty Int
n | Int
n forall a. Eq a => a -> a -> Bool
== Int
epsilonTok = Bool
True
> | Bool
otherwise = Bool
False
> type ErrMsg = String
> type M a = Writer [ErrMsg] a
> addErr :: ErrMsg -> M ()
> addErr :: ErrMsg -> M ()
addErr ErrMsg
e = forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ErrMsg
e]
> mangler :: FilePath -> AbsSyn -> MaybeErr Grammar [ErrMsg]
> mangler :: ErrMsg -> AbsSyn -> MaybeErr Grammar [ErrMsg]
mangler ErrMsg
file AbsSyn
abssyn
> | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ErrMsg]
errs = forall a err. a -> MaybeErr a err
Succeeded Grammar
g
> | Bool
otherwise = forall a err. err -> MaybeErr a err
Failed [ErrMsg]
errs
> where (Grammar
g, [ErrMsg]
errs) = forall w a. Writer w a -> (a, w)
runWriter (ErrMsg -> AbsSyn -> M Grammar
manglerM ErrMsg
file AbsSyn
abssyn)
> manglerM :: FilePath -> AbsSyn -> M Grammar
> manglerM :: ErrMsg -> AbsSyn -> M Grammar
manglerM ErrMsg
file (AbsSyn Maybe ErrMsg
_hd [Directive ErrMsg]
dirs [Rule]
rules' Maybe ErrMsg
_tl) =
>
> forall a w b w'. ((a, w) -> (b, w')) -> Writer w a -> Writer w' b
mapWriter (\(Grammar
a,[ErrMsg]
e) -> (Grammar
a, forall a b. (a -> b) -> [a] -> [b]
map (\ErrMsg
s -> ErrMsg
file forall a. [a] -> [a] -> [a]
++ ErrMsg
": " forall a. [a] -> [a] -> [a]
++ ErrMsg
s) [ErrMsg]
e)) forall a b. (a -> b) -> a -> b
$ do
> [Rule1]
rules <- case [Rule] -> Either ErrMsg [Rule1]
expand_rules [Rule]
rules' of
> Left ErrMsg
err -> ErrMsg -> M ()
addErr ErrMsg
err forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return []
> Right [Rule1]
as -> forall (m :: * -> *) a. Monad m => a -> m a
return [Rule1]
as
> [ErrMsg]
nonterm_strs <- [ErrMsg] -> ErrMsg -> [ErrMsg] -> Writer [ErrMsg] [ErrMsg]
checkRules ([ErrMsg
n | (ErrMsg
n,[Prod1]
_,Maybe ErrMsg
_) <- [Rule1]
rules]) ErrMsg
"" []
> let
> terminal_strs :: [ErrMsg]
terminal_strs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b. (a -> b) -> [a] -> [b]
map forall a. Directive a -> [a]
getTerm [Directive ErrMsg]
dirs) forall a. [a] -> [a] -> [a]
++ [ErrMsg
eofName]
> n_starts :: Int
n_starts = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Directive ErrMsg]
starts'
> n_nts :: Int
n_nts = forall (t :: * -> *) a. Foldable t => t a -> Int
length [ErrMsg]
nonterm_strs
> n_ts :: Int
n_ts = forall (t :: * -> *) a. Foldable t => t a -> Int
length [ErrMsg]
terminal_strs
> first_nt :: Int
first_nt = Int
firstStartTok forall a. Num a => a -> a -> a
+ Int
n_starts
> first_t :: Int
first_t = Int
first_nt forall a. Num a => a -> a -> a
+ Int
n_nts
> last_start :: Int
last_start = Int
first_nt forall a. Num a => a -> a -> a
- Int
1
> last_nt :: Int
last_nt = Int
first_t forall a. Num a => a -> a -> a
- Int
1
> last_t :: Int
last_t = Int
first_t forall a. Num a => a -> a -> a
+ Int
n_ts forall a. Num a => a -> a -> a
- Int
1
> start_names :: [Int]
start_names = [ Int
firstStartTok .. Int
last_start ]
> nonterm_names :: [Int]
nonterm_names = [ Int
first_nt .. Int
last_nt ]
> terminal_names :: [Int]
terminal_names = [ Int
first_t .. Int
last_t ]
> starts' :: [Directive ErrMsg]
starts' = case forall t. [Directive t] -> [Directive t]
getParserNames [Directive ErrMsg]
dirs of
> [] -> [forall a. ErrMsg -> Maybe ErrMsg -> Bool -> Directive a
TokenName ErrMsg
"happyParse" forall a. Maybe a
Nothing Bool
False]
> [Directive ErrMsg]
ns -> [Directive ErrMsg]
ns
>
> start_strs :: [ErrMsg]
start_strs = [ ErrMsg
startNameforall a. [a] -> [a] -> [a]
++Char
'_'forall a. a -> [a] -> [a]
:ErrMsg
p | (TokenName ErrMsg
p Maybe ErrMsg
_ Bool
_) <- [Directive ErrMsg]
starts' ]
> name_env :: [(Int, ErrMsg)]
name_env = (Int
errorTok, ErrMsg
errorName) forall a. a -> [a] -> [a]
:
> (Int
dummyTok, ErrMsg
dummyName) forall a. a -> [a] -> [a]
:
> forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
start_names [ErrMsg]
start_strs forall a. [a] -> [a] -> [a]
++
> forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
nonterm_names [ErrMsg]
nonterm_strs forall a. [a] -> [a] -> [a]
++
> forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
terminal_names [ErrMsg]
terminal_strs
> lookupName :: String -> [Name]
> lookupName :: ErrMsg -> [Int]
lookupName ErrMsg
n = [ Int
t | (Int
t,ErrMsg
r) <- [(Int, ErrMsg)]
name_env, ErrMsg
r forall a. Eq a => a -> a -> Bool
== ErrMsg
n ]
> mapToName :: ErrMsg -> WriterT [ErrMsg] Identity Int
mapToName ErrMsg
str' =
> case ErrMsg -> [Int]
lookupName ErrMsg
str' of
> [Int
a] -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
a
> [] -> do ErrMsg -> M ()
addErr (ErrMsg
"unknown identifier '" forall a. [a] -> [a] -> [a]
++ ErrMsg
str' forall a. [a] -> [a] -> [a]
++ ErrMsg
"'")
> forall (m :: * -> *) a. Monad m => a -> m a
return Int
errorTok
> (Int
a:[Int]
_) -> do ErrMsg -> M ()
addErr (ErrMsg
"multiple use of '" forall a. [a] -> [a] -> [a]
++ ErrMsg
str' forall a. [a] -> [a] -> [a]
++ ErrMsg
"'")
> forall (m :: * -> *) a. Monad m => a -> m a
return Int
a
>
> lookupStart :: Directive a -> WriterT [ErrMsg] Identity Int
lookupStart (TokenName ErrMsg
_ Maybe ErrMsg
Nothing Bool
_) = forall (m :: * -> *) a. Monad m => a -> m a
return Int
first_nt
> lookupStart (TokenName ErrMsg
_ (Just ErrMsg
n) Bool
_) = ErrMsg -> WriterT [ErrMsg] Identity Int
mapToName ErrMsg
n
> lookupStart Directive a
_ = forall a. HasCallStack => ErrMsg -> a
error ErrMsg
"lookupStart: Not a TokenName"
>
> [Int]
start_toks <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {a}. Directive a -> WriterT [ErrMsg] Identity Int
lookupStart [Directive ErrMsg]
starts'
> let
> parser_names :: [ErrMsg]
parser_names = [ ErrMsg
s | TokenName ErrMsg
s Maybe ErrMsg
_ Bool
_ <- [Directive ErrMsg]
starts' ]
> start_partials :: [Bool]
start_partials = [ Bool
b | TokenName ErrMsg
_ Maybe ErrMsg
_ Bool
b <- [Directive ErrMsg]
starts' ]
> start_prods :: [(Int, [Int], (ErrMsg, [a]), Priority)]
start_prods = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
nm Int
tok -> (Int
nm, [Int
tok], (ErrMsg
"no code",[]), Priority
No))
> [Int]
start_names [Int]
start_toks
> priodir :: [(Int, Directive ErrMsg)]
priodir = forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] (forall t. [Directive t] -> [Directive t]
getPrios [Directive ErrMsg]
dirs)
>
> prios :: [(Int, Priority)]
prios = [ (Int
name,forall a. Int -> Directive a -> Priority
mkPrio Int
i Directive ErrMsg
dir)
> | (Int
i,Directive ErrMsg
dir) <- [(Int, Directive ErrMsg)]
priodir
> , ErrMsg
nm <- forall t. Directive t -> [ErrMsg]
AbsSyn.getPrioNames Directive ErrMsg
dir
> , Int
name <- ErrMsg -> [Int]
lookupName ErrMsg
nm
> ]
> prioByString :: [(ErrMsg, Priority)]
prioByString = [ (ErrMsg
name, forall a. Int -> Directive a -> Priority
mkPrio Int
i Directive ErrMsg
dir)
> | (Int
i,Directive ErrMsg
dir) <- [(Int, Directive ErrMsg)]
priodir
> , ErrMsg
name <- forall t. Directive t -> [ErrMsg]
AbsSyn.getPrioNames Directive ErrMsg
dir
> ]
> convNT :: (ErrMsg, b, c) -> WriterT [ErrMsg] Identity (Int, b, c)
convNT (ErrMsg
nt, b
prods, c
ty)
> = do Int
nt' <- ErrMsg -> WriterT [ErrMsg] Identity Int
mapToName ErrMsg
nt
> forall (m :: * -> *) a. Monad m => a -> m a
return (Int
nt', b
prods, c
ty)
>
> attrs :: [(ErrMsg, ErrMsg)]
attrs = forall t. [Directive t] -> [(ErrMsg, ErrMsg)]
getAttributes [Directive ErrMsg]
dirs
> attrType :: ErrMsg
attrType = forall a. a -> Maybe a -> a
fromMaybe ErrMsg
"HappyAttrs" (forall t. [Directive t] -> Maybe ErrMsg
getAttributetype [Directive ErrMsg]
dirs)
>
> transRule :: (a, t Prod1, c)
-> WriterT
[ErrMsg] Identity (t (a, [Int], (ErrMsg, [Int]), Priority))
transRule (a
nt, t Prod1
prods, c
_ty)
> = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {a}.
a -> Prod1 -> Writer [ErrMsg] (a, [Int], (ErrMsg, [Int]), Priority)
finishRule a
nt) t Prod1
prods
>
> finishRule :: a -> Prod1 -> Writer [ErrMsg] (a, [Int], (ErrMsg, [Int]), Priority)
finishRule a
nt ([ErrMsg]
lhs,ErrMsg
code,Int
line,Maybe ErrMsg
prec)
> = forall a w b w'. ((a, w) -> (b, w')) -> Writer w a -> Writer w' b
mapWriter (\((a, [Int], (ErrMsg, [Int]), Priority)
a,[ErrMsg]
e) -> ((a, [Int], (ErrMsg, [Int]), Priority)
a, forall a b. (a -> b) -> [a] -> [b]
map (Int -> ErrMsg -> ErrMsg
addLine Int
line) [ErrMsg]
e)) forall a b. (a -> b) -> a -> b
$ do
> [Int]
lhs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ErrMsg -> WriterT [ErrMsg] Identity Int
mapToName [ErrMsg]
lhs
> (ErrMsg, [Int])
code' <- Int
-> [Int]
-> [Int]
-> ErrMsg
-> [(ErrMsg, ErrMsg)]
-> M (ErrMsg, [Int])
checkCode (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ErrMsg]
lhs) [Int]
lhs' [Int]
nonterm_names ErrMsg
code [(ErrMsg, ErrMsg)]
attrs
> case [Int] -> Maybe ErrMsg -> Either ErrMsg Priority
mkPrec [Int]
lhs' Maybe ErrMsg
prec of
> Left ErrMsg
s -> do ErrMsg -> M ()
addErr (ErrMsg
"Undeclared precedence token: " forall a. [a] -> [a] -> [a]
++ ErrMsg
s)
> forall (m :: * -> *) a. Monad m => a -> m a
return (a
nt, [Int]
lhs', (ErrMsg, [Int])
code', Priority
No)
> Right Priority
p -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
nt, [Int]
lhs', (ErrMsg, [Int])
code', Priority
p)
>
> mkPrec :: [Name] -> Maybe String -> Either String Priority
> mkPrec :: [Int] -> Maybe ErrMsg -> Either ErrMsg Priority
mkPrec [Int]
lhs Maybe ErrMsg
prio =
> case Maybe ErrMsg
prio of
> Maybe ErrMsg
Nothing -> case forall a. (a -> Bool) -> [a] -> [a]
filter (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Int]
terminal_names) [Int]
lhs of
> [] -> forall a b. b -> Either a b
Right Priority
No
> [Int]
xs -> case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (forall a. [a] -> a
last [Int]
xs) [(Int, Priority)]
prios of
> Maybe Priority
Nothing -> forall a b. b -> Either a b
Right Priority
No
> Just Priority
p -> forall a b. b -> Either a b
Right Priority
p
> Just ErrMsg
s -> case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ErrMsg
s [(ErrMsg, Priority)]
prioByString of
> Maybe Priority
Nothing -> forall a b. a -> Either a b
Left ErrMsg
s
> Just Priority
p -> forall a b. b -> Either a b
Right Priority
p
>
> [(Int, [Prod1], Maybe ErrMsg)]
rules1 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {b} {c}.
(ErrMsg, b, c) -> WriterT [ErrMsg] Identity (Int, b, c)
convNT [Rule1]
rules
> [[Production]]
rules2 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {t :: * -> *} {a} {c}.
Traversable t =>
(a, t Prod1, c)
-> WriterT
[ErrMsg] Identity (t (a, [Int], (ErrMsg, [Int]), Priority))
transRule [(Int, [Prod1], Maybe ErrMsg)]
rules1
> let
> tys :: Array Int (Maybe ErrMsg)
tys = forall i e a.
Ix i =>
(e -> a -> e) -> e -> (i, i) -> [(i, a)] -> Array i e
accumArray (\Maybe ErrMsg
_ Maybe ErrMsg
x -> Maybe ErrMsg
x) forall a. Maybe a
Nothing (Int
first_nt, Int
last_nt)
> [ (Int
nm, forall a. a -> Maybe a
Just ErrMsg
ty) | (Int
nm, [Prod1]
_, Just ErrMsg
ty) <- [(Int, [Prod1], Maybe ErrMsg)]
rules1 ]
> env_array :: Array Int String
> env_array :: Array Int ErrMsg
env_array = forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Int
errorTok, Int
last_t) [(Int, ErrMsg)]
name_env
>
> let
> fixTokenSpec :: (ErrMsg, b) -> WriterT [ErrMsg] Identity (Int, b)
fixTokenSpec (ErrMsg
a,b
b) = do Int
n <- ErrMsg -> WriterT [ErrMsg] Identity Int
mapToName ErrMsg
a; forall (m :: * -> *) a. Monad m => a -> m a
return (Int
n,b
b)
>
> [(Int, ErrMsg)]
tokspec <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {b}. (ErrMsg, b) -> WriterT [ErrMsg] Identity (Int, b)
fixTokenSpec (forall t. [Directive t] -> [(t, ErrMsg)]
getTokenSpec [Directive ErrMsg]
dirs)
> let
> ass :: [(Int, [Int])]
ass = forall a b. Ord a => [(a, b)] -> [(a, [b])]
combinePairs [ (Int
a,Int
no)
> | ((Int
a,[Int]
_,(ErrMsg, [Int])
_,Priority
_),Int
no) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Production]
productions' [Int
0..] ]
> arr :: Array Int [Int]
arr = forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Int
firstStartTok, forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, [Int])]
ass forall a. Num a => a -> a -> a
- Int
1 forall a. Num a => a -> a -> a
+ Int
firstStartTok) [(Int, [Int])]
ass
> lookup_prods :: Name -> [Int]
> lookup_prods :: Int -> [Int]
lookup_prods Int
x | Int
x forall a. Ord a => a -> a -> Bool
>= Int
firstStartTok Bool -> Bool -> Bool
&& Int
x forall a. Ord a => a -> a -> Bool
< Int
first_t = Array Int [Int]
arr forall i e. Ix i => Array i e -> i -> e
! Int
x
> lookup_prods Int
_ = forall a. HasCallStack => ErrMsg -> a
error ErrMsg
"lookup_prods"
>
> productions' :: [Production]
productions' = forall {a}. [(Int, [Int], (ErrMsg, [a]), Priority)]
start_prods forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Production]]
rules2
> prod_array :: Array Int Production
prod_array = forall a. (Int, Int) -> [a] -> Array Int a
listArray' (Int
0,forall (t :: * -> *) a. Foldable t => t a -> Int
length [Production]
productions' forall a. Num a => a -> a -> a
- Int
1) [Production]
productions'
>
> forall (m :: * -> *) a. Monad m => a -> m a
return (Grammar {
> productions :: [Production]
productions = [Production]
productions',
> lookupProdNo :: Int -> Production
lookupProdNo = (Array Int Production
prod_array forall i e. Ix i => Array i e -> i -> e
!),
> lookupProdsOfName :: Int -> [Int]
lookupProdsOfName = Int -> [Int]
lookup_prods,
> token_specs :: [(Int, ErrMsg)]
token_specs = [(Int, ErrMsg)]
tokspec,
> terminals :: [Int]
terminals = Int
errorTok forall a. a -> [a] -> [a]
: [Int]
terminal_names,
> non_terminals :: [Int]
non_terminals = [Int]
start_names forall a. [a] -> [a] -> [a]
++ [Int]
nonterm_names,
>
> starts :: [(ErrMsg, Int, Int, Bool)]
starts = forall a b c d. [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
zip4 [ErrMsg]
parser_names [Int]
start_names [Int]
start_toks
> [Bool]
start_partials,
> types :: Array Int (Maybe ErrMsg)
types = Array Int (Maybe ErrMsg)
tys,
> token_names :: Array Int ErrMsg
token_names = Array Int ErrMsg
env_array,
> first_nonterm :: Int
first_nonterm = Int
first_nt,
> first_term :: Int
first_term = Int
first_t,
> eof_term :: Int
eof_term = forall a. [a] -> a
last [Int]
terminal_names,
> priorities :: [(Int, Priority)]
priorities = [(Int, Priority)]
prios,
> imported_identity :: Bool
imported_identity = forall t. [Directive t] -> Bool
getImportedIdentity [Directive ErrMsg]
dirs,
> monad :: (Bool, ErrMsg, ErrMsg, ErrMsg, ErrMsg)
monad = forall t. [Directive t] -> (Bool, ErrMsg, ErrMsg, ErrMsg, ErrMsg)
getMonad [Directive ErrMsg]
dirs,
> lexer :: Maybe (ErrMsg, ErrMsg)
lexer = forall t. [Directive t] -> Maybe (ErrMsg, ErrMsg)
getLexer [Directive ErrMsg]
dirs,
> error_handler :: Maybe ErrMsg
error_handler = forall t. [Directive t] -> Maybe ErrMsg
getError [Directive ErrMsg]
dirs,
> token_type :: ErrMsg
token_type = forall t. [Directive t] -> ErrMsg
getTokenType [Directive ErrMsg]
dirs,
> expect :: Maybe Int
expect = forall t. [Directive t] -> Maybe Int
getExpect [Directive ErrMsg]
dirs,
> attributes :: [(ErrMsg, ErrMsg)]
attributes = [(ErrMsg, ErrMsg)]
attrs,
> attributetype :: ErrMsg
attributetype = ErrMsg
attrType
> })
> addLine :: Int -> String -> String
> addLine :: Int -> ErrMsg -> ErrMsg
addLine Int
l ErrMsg
s = forall a. Show a => a -> ErrMsg
show Int
l forall a. [a] -> [a] -> [a]
++ ErrMsg
": " forall a. [a] -> [a] -> [a]
++ ErrMsg
s
> getTerm :: Directive a -> [a]
> getTerm :: forall a. Directive a -> [a]
getTerm (TokenSpec [(a, ErrMsg)]
stuff) = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(a, ErrMsg)]
stuff
> getTerm Directive a
_ = []
> checkRules :: [String] -> String -> [String] -> Writer [ErrMsg] [String]
> checkRules :: [ErrMsg] -> ErrMsg -> [ErrMsg] -> Writer [ErrMsg] [ErrMsg]
checkRules (ErrMsg
name:[ErrMsg]
rest) ErrMsg
above [ErrMsg]
nonterms
> | ErrMsg
name forall a. Eq a => a -> a -> Bool
== ErrMsg
above = [ErrMsg] -> ErrMsg -> [ErrMsg] -> Writer [ErrMsg] [ErrMsg]
checkRules [ErrMsg]
rest ErrMsg
name [ErrMsg]
nonterms
> | ErrMsg
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ErrMsg]
nonterms
> = do ErrMsg -> M ()
addErr (ErrMsg
"Multiple rules for '" forall a. [a] -> [a] -> [a]
++ ErrMsg
name forall a. [a] -> [a] -> [a]
++ ErrMsg
"'")
> [ErrMsg] -> ErrMsg -> [ErrMsg] -> Writer [ErrMsg] [ErrMsg]
checkRules [ErrMsg]
rest ErrMsg
name [ErrMsg]
nonterms
> | Bool
otherwise = [ErrMsg] -> ErrMsg -> [ErrMsg] -> Writer [ErrMsg] [ErrMsg]
checkRules [ErrMsg]
rest ErrMsg
name (ErrMsg
name forall a. a -> [a] -> [a]
: [ErrMsg]
nonterms)
> checkRules [] ErrMsg
_ [ErrMsg]
nonterms = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
reverse [ErrMsg]
nonterms)
> checkCode :: Int -> [Name] -> [Name] -> String -> [(String,String)] -> M (String,[Int])
> checkCode :: Int
-> [Int]
-> [Int]
-> ErrMsg
-> [(ErrMsg, ErrMsg)]
-> M (ErrMsg, [Int])
checkCode Int
arity [Int]
_ [Int]
_ ErrMsg
code [] = Int -> ErrMsg -> M (ErrMsg, [Int])
doCheckCode Int
arity ErrMsg
code
> checkCode Int
arity [Int]
lhs [Int]
nonterm_names ErrMsg
code [(ErrMsg, ErrMsg)]
attrs = Int
-> [Int]
-> [Int]
-> ErrMsg
-> [(ErrMsg, ErrMsg)]
-> M (ErrMsg, [Int])
rewriteAttributeGrammar Int
arity [Int]
lhs [Int]
nonterm_names ErrMsg
code [(ErrMsg, ErrMsg)]
attrs
> rewriteAttributeGrammar :: Int -> [Name] -> [Name] -> String -> [(String,String)] -> M (String,[Int])
> rewriteAttributeGrammar :: Int
-> [Int]
-> [Int]
-> ErrMsg
-> [(ErrMsg, ErrMsg)]
-> M (ErrMsg, [Int])
rewriteAttributeGrammar Int
arity [Int]
lhs [Int]
nonterm_names ErrMsg
code [(ErrMsg, ErrMsg)]
attrs =
> case forall a. P a -> ErrMsg -> Int -> ParseResult a
runP P [AgRule]
agParser ErrMsg
code Int
0 of
> FailP ErrMsg
msg -> do ErrMsg -> M ()
addErr (ErrMsg
"error in attribute grammar rules: "forall a. [a] -> [a] -> [a]
++ErrMsg
msg)
> forall (m :: * -> *) a. Monad m => a -> m a
return (ErrMsg
"",[])
> OkP [AgRule]
rules ->
> let ([AgRule]
selfRules,[AgRule]
subRules,[AgRule]
conditions) = [AgRule]
-> [AgRule]
-> [AgRule]
-> [AgRule]
-> ([AgRule], [AgRule], [AgRule])
partitionRules [] [] [] [AgRule]
rules
> attrNames :: [ErrMsg]
attrNames = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(ErrMsg, ErrMsg)]
attrs
> defaultAttr :: ErrMsg
defaultAttr = forall a. [a] -> a
head [ErrMsg]
attrNames
> in do let prods :: [Int]
prods = [AgRule] -> [Int]
mentionedProductions [AgRule]
rules
> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Int -> M ()
checkArity [Int]
prods
> ErrMsg
rulesStr <- Int
-> [ErrMsg]
-> ErrMsg
-> [Int]
-> [AgRule]
-> [AgRule]
-> [AgRule]
-> M ErrMsg
formatRules Int
arity [ErrMsg]
attrNames ErrMsg
defaultAttr
> [Int]
allSubProductions [AgRule]
selfRules
> [AgRule]
subRules [AgRule]
conditions
> forall (m :: * -> *) a. Monad m => a -> m a
return (ErrMsg
rulesStr,forall a. Eq a => [a] -> [a]
nub ([Int]
allSubProductionsforall a. [a] -> [a] -> [a]
++[Int]
prods))
> where partitionRules :: [AgRule]
-> [AgRule]
-> [AgRule]
-> [AgRule]
-> ([AgRule], [AgRule], [AgRule])
partitionRules [AgRule]
a [AgRule]
b [AgRule]
c [] = ([AgRule]
a,[AgRule]
b,[AgRule]
c)
> partitionRules [AgRule]
a [AgRule]
b [AgRule]
c (RightmostAssign ErrMsg
attr [AgToken]
toks : [AgRule]
xs) = [AgRule]
-> [AgRule]
-> [AgRule]
-> [AgRule]
-> ([AgRule], [AgRule], [AgRule])
partitionRules [AgRule]
a ((Int, ErrMsg) -> [AgToken] -> AgRule
SubAssign (Int
arity,ErrMsg
attr) [AgToken]
toks forall a. a -> [a] -> [a]
: [AgRule]
b) [AgRule]
c [AgRule]
xs
> partitionRules [AgRule]
a [AgRule]
b [AgRule]
c (x :: AgRule
x@(SelfAssign ErrMsg
_ [AgToken]
_ ) : [AgRule]
xs) = [AgRule]
-> [AgRule]
-> [AgRule]
-> [AgRule]
-> ([AgRule], [AgRule], [AgRule])
partitionRules (AgRule
xforall a. a -> [a] -> [a]
:[AgRule]
a) [AgRule]
b [AgRule]
c [AgRule]
xs
> partitionRules [AgRule]
a [AgRule]
b [AgRule]
c (x :: AgRule
x@(SubAssign (Int, ErrMsg)
_ [AgToken]
_) : [AgRule]
xs) = [AgRule]
-> [AgRule]
-> [AgRule]
-> [AgRule]
-> ([AgRule], [AgRule], [AgRule])
partitionRules [AgRule]
a (AgRule
xforall a. a -> [a] -> [a]
:[AgRule]
b) [AgRule]
c [AgRule]
xs
> partitionRules [AgRule]
a [AgRule]
b [AgRule]
c (x :: AgRule
x@(Conditional [AgToken]
_) : [AgRule]
xs) = [AgRule]
-> [AgRule]
-> [AgRule]
-> [AgRule]
-> ([AgRule], [AgRule], [AgRule])
partitionRules [AgRule]
a [AgRule]
b (AgRule
xforall a. a -> [a] -> [a]
:[AgRule]
c) [AgRule]
xs
> allSubProductions :: [Int]
allSubProductions = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Num a => a -> a -> a
+Int
1) (forall a. (a -> Bool) -> [a] -> [Int]
findIndices (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
nonterm_names) [Int]
lhs)
> mentionedProductions :: [AgRule] -> [Int]
mentionedProductions [AgRule]
rules = [ Int
i | (AgTok_SubRef (Int
i,ErrMsg
_)) <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b. (a -> b) -> [a] -> [b]
map AgRule -> [AgToken]
getTokens [AgRule]
rules) ]
> getTokens :: AgRule -> [AgToken]
getTokens (SelfAssign ErrMsg
_ [AgToken]
toks) = [AgToken]
toks
> getTokens (SubAssign (Int, ErrMsg)
_ [AgToken]
toks) = [AgToken]
toks
> getTokens (Conditional [AgToken]
toks) = [AgToken]
toks
> getTokens (RightmostAssign ErrMsg
_ [AgToken]
toks) = [AgToken]
toks
>
> checkArity :: Int -> M ()
checkArity Int
x = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
x forall a. Ord a => a -> a -> Bool
> Int
arity) forall a b. (a -> b) -> a -> b
$ ErrMsg -> M ()
addErr (forall a. Show a => a -> ErrMsg
show Int
xforall a. [a] -> [a] -> [a]
++ErrMsg
" out of range")
> formatRules :: Int -> [String] -> String -> [Name]
> -> [AgRule] -> [AgRule] -> [AgRule]
> -> M String
> formatRules :: Int
-> [ErrMsg]
-> ErrMsg
-> [Int]
-> [AgRule]
-> [AgRule]
-> [AgRule]
-> M ErrMsg
formatRules Int
arity [ErrMsg]
_attrNames ErrMsg
defaultAttr [Int]
prods [AgRule]
selfRules [AgRule]
subRules [AgRule]
conditions = 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 [ ErrMsg
"\\happyInhAttrs -> let { "
> , ErrMsg
"happySelfAttrs = happyInhAttrs",ErrMsg
formattedSelfRules
> , ErrMsg
subProductionRules
> , ErrMsg
"; happyConditions = ", ErrMsg
formattedConditions
> , ErrMsg
" } in (happyConditions,happySelfAttrs)"
> ]
>
> where formattedSelfRules :: ErrMsg
formattedSelfRules = case [AgRule]
selfRules of [] -> []; [AgRule]
_ -> ErrMsg
"{ "forall a. [a] -> [a] -> [a]
++ErrMsg
formattedSelfRules'forall a. [a] -> [a] -> [a]
++ErrMsg
" }"
> formattedSelfRules' :: ErrMsg
formattedSelfRules' = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse ErrMsg
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map AgRule -> ErrMsg
formatSelfRule [AgRule]
selfRules
> formatSelfRule :: AgRule -> ErrMsg
formatSelfRule (SelfAssign [] [AgToken]
toks) = ErrMsg
defaultAttrforall a. [a] -> [a] -> [a]
++ErrMsg
" = "forall a. [a] -> [a] -> [a]
++([AgToken] -> ErrMsg
formatTokens [AgToken]
toks)
> formatSelfRule (SelfAssign ErrMsg
attr [AgToken]
toks) = ErrMsg
attrforall a. [a] -> [a] -> [a]
++ErrMsg
" = "forall a. [a] -> [a] -> [a]
++([AgToken] -> ErrMsg
formatTokens [AgToken]
toks)
> formatSelfRule AgRule
_ = forall a. HasCallStack => ErrMsg -> a
error ErrMsg
"formatSelfRule: Not a self rule"
> subRulesMap :: [(Int,[(String,[AgToken])])]
> subRulesMap :: [(Int, [(ErrMsg, [AgToken])])]
subRulesMap = forall a b. (a -> b) -> [a] -> [b]
map (\[(Int, (ErrMsg, [AgToken]))]
l -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ (Int
_,(ErrMsg, [AgToken])
x) (Int
i,[(ErrMsg, [AgToken])]
xs) -> (Int
i,(ErrMsg, [AgToken])
xforall a. a -> [a] -> [a]
:[(ErrMsg, [AgToken])]
xs))
> (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [(Int, (ErrMsg, [AgToken]))]
l,[forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [(Int, (ErrMsg, [AgToken]))]
l])
> (forall a. [a] -> [a]
tail [(Int, (ErrMsg, [AgToken]))]
l) ) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
> forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\(Int, (ErrMsg, [AgToken]))
x (Int, (ErrMsg, [AgToken]))
y -> (forall a b. (a, b) -> a
fst (Int, (ErrMsg, [AgToken]))
x) forall a. Eq a => a -> a -> Bool
== (forall a b. (a, b) -> a
fst (Int, (ErrMsg, [AgToken]))
y)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
> forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(Int, (ErrMsg, [AgToken]))
x (Int, (ErrMsg, [AgToken]))
y -> forall a. Ord a => a -> a -> Ordering
compare (forall a b. (a, b) -> a
fst (Int, (ErrMsg, [AgToken]))
x) (forall a b. (a, b) -> a
fst (Int, (ErrMsg, [AgToken]))
y)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
> forall a b. (a -> b) -> [a] -> [b]
map (\(SubAssign (Int
i,ErrMsg
ident) [AgToken]
toks) -> (Int
i,(ErrMsg
ident,[AgToken]
toks))) forall a b. (a -> b) -> a -> b
$ [AgRule]
subRules
> subProductionRules :: ErrMsg
subProductionRules = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Int -> ErrMsg
formatSubRules [Int]
prods
> formatSubRules :: Int -> ErrMsg
formatSubRules Int
i =
> let attrs :: [(ErrMsg, [AgToken])]
attrs = forall a. a -> Maybe a -> a
fromMaybe [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
i forall a b. (a -> b) -> a -> b
$ [(Int, [(ErrMsg, [AgToken])])]
subRulesMap
> attrUpdates' :: ErrMsg
attrUpdates' = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse ErrMsg
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall {p}. p -> (ErrMsg, [AgToken]) -> ErrMsg
formatSubRule Int
i) [(ErrMsg, [AgToken])]
attrs
> attrUpdates :: ErrMsg
attrUpdates = case ErrMsg
attrUpdates' of [] -> []; ErrMsg
x -> ErrMsg
"{ "forall a. [a] -> [a] -> [a]
++ErrMsg
xforall a. [a] -> [a] -> [a]
++ErrMsg
" }"
> in forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrMsg
"; (happyConditions_",forall a. Show a => a -> ErrMsg
show Int
i,ErrMsg
",happySubAttrs_",forall a. Show a => a -> ErrMsg
show Int
i,ErrMsg
") = ",Int -> ErrMsg
mkHappyVar Int
i
> ,ErrMsg
" happyEmptyAttrs"
> , ErrMsg
attrUpdates
> ]
>
> formattedConditions :: ErrMsg
formattedConditions = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse ErrMsg
"++" forall a b. (a -> b) -> a -> b
$ ErrMsg
localConditions forall a. a -> [a] -> [a]
: (forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> ErrMsg
"happyConditions_"forall a. [a] -> [a] -> [a]
++(forall a. Show a => a -> ErrMsg
show Int
i)) [Int]
prods)
> localConditions :: ErrMsg
localConditions = ErrMsg
"["forall a. [a] -> [a] -> [a]
++(forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse ErrMsg
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map AgRule -> ErrMsg
formatCondition [AgRule]
conditions)forall a. [a] -> [a] -> [a]
++ErrMsg
"]"
> formatCondition :: AgRule -> ErrMsg
formatCondition (Conditional [AgToken]
toks) = [AgToken] -> ErrMsg
formatTokens [AgToken]
toks
> formatCondition AgRule
_ = forall a. HasCallStack => ErrMsg -> a
error ErrMsg
"formatCondition: Not a condition"
> formatSubRule :: p -> (ErrMsg, [AgToken]) -> ErrMsg
formatSubRule p
_ ([],[AgToken]
toks) = ErrMsg
defaultAttrforall a. [a] -> [a] -> [a]
++ErrMsg
" = "forall a. [a] -> [a] -> [a]
++([AgToken] -> ErrMsg
formatTokens [AgToken]
toks)
> formatSubRule p
_ (ErrMsg
attr,[AgToken]
toks) = ErrMsg
attrforall a. [a] -> [a] -> [a]
++ErrMsg
" = "forall a. [a] -> [a] -> [a]
++([AgToken] -> ErrMsg
formatTokens [AgToken]
toks)
> formatTokens :: [AgToken] -> ErrMsg
formatTokens [AgToken]
tokens = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b. (a -> b) -> [a] -> [b]
map AgToken -> ErrMsg
formatToken [AgToken]
tokens)
> formatToken :: AgToken -> ErrMsg
formatToken AgToken
AgTok_LBrace = ErrMsg
"{ "
> formatToken AgToken
AgTok_RBrace = ErrMsg
"} "
> formatToken AgToken
AgTok_Where = ErrMsg
"where "
> formatToken AgToken
AgTok_Semicolon = ErrMsg
"; "
> formatToken AgToken
AgTok_Eq = ErrMsg
"="
> formatToken (AgTok_SelfRef []) = ErrMsg
"("forall a. [a] -> [a] -> [a]
++ErrMsg
defaultAttrforall a. [a] -> [a] -> [a]
++ErrMsg
" happySelfAttrs) "
> formatToken (AgTok_SelfRef ErrMsg
x) = ErrMsg
"("forall a. [a] -> [a] -> [a]
++ErrMsg
xforall a. [a] -> [a] -> [a]
++ErrMsg
" happySelfAttrs) "
> formatToken (AgTok_RightmostRef ErrMsg
x) = AgToken -> ErrMsg
formatToken ((Int, ErrMsg) -> AgToken
AgTok_SubRef (Int
arity,ErrMsg
x))
> formatToken (AgTok_SubRef (Int
i,[]))
> | Int
i forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
prods = ErrMsg
"("forall a. [a] -> [a] -> [a]
++ErrMsg
defaultAttrforall a. [a] -> [a] -> [a]
++ErrMsg
" happySubAttrs_"forall a. [a] -> [a] -> [a]
++(forall a. Show a => a -> ErrMsg
show Int
i)forall a. [a] -> [a] -> [a]
++ErrMsg
") "
> | Bool
otherwise = Int -> ErrMsg
mkHappyVar Int
i forall a. [a] -> [a] -> [a]
++ ErrMsg
" "
> formatToken (AgTok_SubRef (Int
i,ErrMsg
x))
> | Int
i forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
prods = ErrMsg
"("forall a. [a] -> [a] -> [a]
++ErrMsg
xforall a. [a] -> [a] -> [a]
++ErrMsg
" happySubAttrs_"forall a. [a] -> [a] -> [a]
++(forall a. Show a => a -> ErrMsg
show Int
i)forall a. [a] -> [a] -> [a]
++ErrMsg
") "
> | Bool
otherwise = forall a. HasCallStack => ErrMsg -> a
error (ErrMsg
"lhs "forall a. [a] -> [a] -> [a]
++(forall a. Show a => a -> ErrMsg
show Int
i)forall a. [a] -> [a] -> [a]
++ErrMsg
" is not a non-terminal")
> formatToken (AgTok_Unknown ErrMsg
x) = ErrMsg
xforall a. [a] -> [a] -> [a]
++ErrMsg
" "
> formatToken AgToken
AgTok_EOF = forall a. HasCallStack => ErrMsg -> a
error ErrMsg
"formatToken AgTok_EOF"
> doCheckCode :: Int -> String -> M (String, [Int])
> doCheckCode :: Int -> ErrMsg -> M (ErrMsg, [Int])
doCheckCode Int
arity ErrMsg
code0 = ErrMsg -> ErrMsg -> [Int] -> M (ErrMsg, [Int])
go ErrMsg
code0 ErrMsg
"" []
> where go :: ErrMsg -> ErrMsg -> [Int] -> M (ErrMsg, [Int])
go ErrMsg
code ErrMsg
acc [Int]
used =
> case ErrMsg
code of
> [] -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
reverse ErrMsg
acc, [Int]
used)
>
> Char
'"' :ErrMsg
r -> case forall a. Read a => ReadS a
reads ErrMsg
code :: [(String,String)] of
> [] -> ErrMsg -> ErrMsg -> [Int] -> M (ErrMsg, [Int])
go ErrMsg
r (Char
'"'forall a. a -> [a] -> [a]
:ErrMsg
acc) [Int]
used
> (ErrMsg
s,ErrMsg
r'):[(ErrMsg, ErrMsg)]
_ -> ErrMsg -> ErrMsg -> [Int] -> M (ErrMsg, [Int])
go ErrMsg
r' (forall a. [a] -> [a]
reverse (forall a. Show a => a -> ErrMsg
show ErrMsg
s) forall a. [a] -> [a] -> [a]
++ ErrMsg
acc) [Int]
used
> Char
a:Char
'\'' :ErrMsg
r | Char -> Bool
isAlphaNum Char
a -> ErrMsg -> ErrMsg -> [Int] -> M (ErrMsg, [Int])
go ErrMsg
r (Char
'\''forall a. a -> [a] -> [a]
:Char
aforall a. a -> [a] -> [a]
:ErrMsg
acc) [Int]
used
> Char
'\'' :ErrMsg
r -> case forall a. Read a => ReadS a
reads ErrMsg
code :: [(Char,String)] of
> [] -> ErrMsg -> ErrMsg -> [Int] -> M (ErrMsg, [Int])
go ErrMsg
r (Char
'\''forall a. a -> [a] -> [a]
:ErrMsg
acc) [Int]
used
> (Char
c,ErrMsg
r'):[(Char, ErrMsg)]
_ -> ErrMsg -> ErrMsg -> [Int] -> M (ErrMsg, [Int])
go ErrMsg
r' (forall a. [a] -> [a]
reverse (forall a. Show a => a -> ErrMsg
show Char
c) forall a. [a] -> [a] -> [a]
++ ErrMsg
acc) [Int]
used
> Char
'\\':Char
'$':ErrMsg
r -> ErrMsg -> ErrMsg -> [Int] -> M (ErrMsg, [Int])
go ErrMsg
r (Char
'$'forall a. a -> [a] -> [a]
:ErrMsg
acc) [Int]
used
>
> Char
'$':Char
'>':ErrMsg
r
> | Int
arity forall a. Eq a => a -> a -> Bool
== Int
0 -> do ErrMsg -> M ()
addErr ErrMsg
"$> in empty rule"
> ErrMsg -> ErrMsg -> [Int] -> M (ErrMsg, [Int])
go ErrMsg
r ErrMsg
acc [Int]
used
> | Bool
otherwise -> ErrMsg -> ErrMsg -> [Int] -> M (ErrMsg, [Int])
go ErrMsg
r (forall a. [a] -> [a]
reverse (Int -> ErrMsg
mkHappyVar Int
arity) forall a. [a] -> [a] -> [a]
++ ErrMsg
acc)
> (Int
arity forall a. a -> [a] -> [a]
: [Int]
used)
>
> Char
'$':r :: ErrMsg
r@(Char
i:ErrMsg
_) | Char -> Bool
isDigit Char
i ->
> case forall a. Read a => ReadS a
reads ErrMsg
r :: [(Int,String)] of
> (Int
j,ErrMsg
r'):[(Int, ErrMsg)]
_ ->
> if Int
j forall a. Ord a => a -> a -> Bool
> Int
arity
> then do ErrMsg -> M ()
addErr (Char
'$'forall a. a -> [a] -> [a]
: forall a. Show a => a -> ErrMsg
show Int
j forall a. [a] -> [a] -> [a]
++ ErrMsg
" out of range")
> ErrMsg -> ErrMsg -> [Int] -> M (ErrMsg, [Int])
go ErrMsg
r' ErrMsg
acc [Int]
used
> else ErrMsg -> ErrMsg -> [Int] -> M (ErrMsg, [Int])
go ErrMsg
r' (forall a. [a] -> [a]
reverse (Int -> ErrMsg
mkHappyVar Int
j) forall a. [a] -> [a] -> [a]
++ ErrMsg
acc)
> (Int
j forall a. a -> [a] -> [a]
: [Int]
used)
> [] -> forall a. HasCallStack => ErrMsg -> a
error ErrMsg
"doCheckCode []"
> Char
c:ErrMsg
r -> ErrMsg -> ErrMsg -> [Int] -> M (ErrMsg, [Int])
go ErrMsg
r (Char
cforall a. a -> [a] -> [a]
:ErrMsg
acc) [Int]
used
> mkHappyVar :: Int -> String
> mkHappyVar :: Int -> ErrMsg
mkHappyVar Int
n = ErrMsg
"happy_var_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> ErrMsg
show Int
n
> data LRAction = LR'Shift Int Priority
> | LR'Reduce Int Priority
> | LR'Accept
> | LR'Fail
> | LR'MustFail
> | LR'Multiple [LRAction] LRAction
> deriving(LRAction -> LRAction -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LRAction -> LRAction -> Bool
$c/= :: LRAction -> LRAction -> Bool
== :: LRAction -> LRAction -> Bool
$c== :: LRAction -> LRAction -> Bool
Eq
#ifdef DEBUG
> ,Show
#endif
> )
> type ActionTable = Array Int (Array Int LRAction)
> data Goto = Goto Int | NoGoto
> deriving(Goto -> Goto -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Goto -> Goto -> Bool
$c/= :: Goto -> Goto -> Bool
== :: Goto -> Goto -> Bool
$c== :: Goto -> Goto -> Bool
Eq
#ifdef DEBUG
> ,Show
#endif
> )
> type GotoTable = Array Int (Array Int Goto)