/-----------------------------------------------------------------------------
The Grammar data type.

(c) 1993-2001 Andy Gill, Simon Marlow
-----------------------------------------------------------------------------

Mangler converts AbsSyn to Grammar

> {-# LANGUAGE ScopedTypeVariables #-}

> module Happy.Frontend.Mangler (mangler) where

> import Happy.Grammar
> import Happy.Frontend.AbsSyn
> import Happy.Frontend.Mangler.Monad
> import Happy.Frontend.AttrGrammar.Mangler

> import Happy.Frontend.ParamRules

> import Data.Array ( Array, (!), accumArray, array, listArray )
> import Data.Char  ( isAlphaNum, isDigit, isLower )
> import Data.List  ( zip4, sortBy )
> import Data.Ord

> import Control.Monad.Writer ( Writer, mapWriter, runWriter )

-----------------------------------------------------------------------------
-- The Mangler

This bit is a real mess, mainly because of the error message support.

> mangler :: FilePath -> AbsSyn String -> Either [ErrMsg] (Grammar String, Maybe AttributeGrammarExtras, Directives)
> mangler :: String
-> AbsSyn String
-> Either
     [String] (Grammar String, Maybe AttributeGrammarExtras, Directives)
mangler String
file abssyn :: AbsSyn String
abssyn@(AbsSyn [Directive String]
dirs [Rule String]
_)
>   | [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
errs = (Grammar String, Maybe AttributeGrammarExtras, Directives)
-> Either
     [String] (Grammar String, Maybe AttributeGrammarExtras, Directives)
forall a b. b -> Either a b
Right (Grammar String
gd, Maybe AttributeGrammarExtras
mAg, Directives
ps)
>   | Bool
otherwise = [String]
-> Either
     [String] (Grammar String, Maybe AttributeGrammarExtras, Directives)
forall a b. a -> Either a b
Left [String]
errs
>   where mAg :: Maybe AttributeGrammarExtras
mAg = [Directive String] -> Maybe AttributeGrammarExtras
forall t. [Directive t] -> Maybe AttributeGrammarExtras
getAttributeGrammarExtras [Directive String]
dirs
>         ((Grammar String
gd, Directives
ps), [String]
errs) = Writer [String] (Grammar String, Directives)
-> ((Grammar String, Directives), [String])
forall w a. Writer w a -> (a, w)
runWriter (String
-> CodeChecker String
-> String
-> AbsSyn String
-> Writer [String] (Grammar String, Directives)
forall e.
e
-> CodeChecker e -> String -> AbsSyn e -> M (Grammar e, Directives)
manglerM String
"no code" CodeChecker String
checkCode String
file AbsSyn String
abssyn)

If any attribute directives were used, we are in an attribute grammar, so
go do special processing.  If not, pass on to the regular processing routine

>         checkCode :: CodeChecker String
>         checkCode :: CodeChecker String
checkCode = case Maybe AttributeGrammarExtras
mAg of
>             Maybe AttributeGrammarExtras
Nothing -> \[Name]
lhs [Name]
_             String
code ->
>                 Int -> String -> M (String, [Int])
doCheckCode ([Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
lhs) String
code
>             Just AttributeGrammarExtras
a  -> \[Name]
lhs [Name]
nonterm_names String
code ->
>                 [Name]
-> [Name] -> String -> AttributeGrammarExtras -> M (String, [Int])
rewriteAttributeGrammar [Name]
lhs [Name]
nonterm_names String
code AttributeGrammarExtras
a

> -- | Function to check elimination rules
> type CodeChecker e = [Name] -> [Name] -> e -> M (e, [Int])

> manglerM
>   :: forall e
>   .  e
>   -- ^ Empty elimination rule, used for starting productions. Will never be run.
>   -> CodeChecker e
>   -> FilePath
>   -> AbsSyn e
>   -> M (Grammar e, Directives)
> manglerM :: forall e.
e
-> CodeChecker e -> String -> AbsSyn e -> M (Grammar e, Directives)
manglerM e
noCode CodeChecker e
checkCode String
file (AbsSyn [Directive String]
dirs [Rule e]
rules') =
>   -- add filename to all error messages
>   (((Grammar e, Directives), [String])
 -> ((Grammar e, Directives), [String]))
-> Writer [String] (Grammar e, Directives)
-> Writer [String] (Grammar e, Directives)
forall a w b w'. ((a, w) -> (b, w')) -> Writer w a -> Writer w' b
mapWriter (\((Grammar e, Directives)
a,[String]
e) -> ((Grammar e, Directives)
a, (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\String
s -> String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s) [String]
e)) (Writer [String] (Grammar e, Directives)
 -> Writer [String] (Grammar e, Directives))
-> Writer [String] (Grammar e, Directives)
-> Writer [String] (Grammar e, Directives)
forall a b. (a -> b) -> a -> b
$ do

>   rules <- case [Rule e] -> Either String [Rule1 e]
forall e. [Rule e] -> Either String [Rule1 e]
expand_rules [Rule e]
rules' of
>              Left String
err -> String -> M ()
addErr String
err M ()
-> WriterT [String] Identity [Rule1 e]
-> WriterT [String] Identity [Rule1 e]
forall a b.
WriterT [String] Identity a
-> WriterT [String] Identity b -> WriterT [String] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Rule1 e] -> WriterT [String] Identity [Rule1 e]
forall a. a -> WriterT [String] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return []
>              Right [Rule1 e]
as -> [Rule1 e] -> WriterT [String] Identity [Rule1 e]
forall a. a -> WriterT [String] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [Rule1 e]
as
>   nonterm_strs <- checkRules [n | Rule1 n _ _ <- rules] "" []

>   let

>       terminal_strs  = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Directive String -> [String]) -> [Directive String] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map Directive String -> [String]
forall a. Directive a -> [a]
getTerm [Directive String]
dirs) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
eofName]

>       first_nt, first_t, last_start, last_nt, last_t :: Name

>       first_nt   = Int -> Name
MkName (Int -> Name) -> Int -> Name
forall a b. (a -> b) -> a -> b
$ Name -> Int
getName Name
firstStartTok Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Directive String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Directive String]
starts'
>       first_t    = Int -> Name
MkName (Int -> Name) -> Int -> Name
forall a b. (a -> b) -> a -> b
$ Name -> Int
getName Name
first_nt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
nonterm_strs
>       last_start = Int -> Name
MkName (Int -> Name) -> Int -> Name
forall a b. (a -> b) -> a -> b
$ Name -> Int
getName Name
first_nt Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
>       last_nt    = Int -> Name
MkName (Int -> Name) -> Int -> Name
forall a b. (a -> b) -> a -> b
$ Name -> Int
getName Name
first_t  Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
>       last_t     = Int -> Name
MkName (Int -> Name) -> Int -> Name
forall a b. (a -> b) -> a -> b
$ Name -> Int
getName Name
first_t Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
terminal_strs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

>       start_names    = [ Name
firstStartTok .. Name
last_start ]
>       nonterm_names  = [ Name
first_nt .. Name
last_nt ]
>       terminal_names = [ Name
first_t .. Name
last_t ]

>       starts'     = case [Directive String] -> [Directive String]
forall t. [Directive t] -> [Directive t]
getParserNames [Directive String]
dirs of
>                       [] -> [String -> Maybe String -> Bool -> Directive String
forall a. String -> Maybe String -> Bool -> Directive a
TokenName String
"happyParse" Maybe String
forall a. Maybe a
Nothing Bool
False]
>                       [Directive String]
ns -> [Directive String]
ns
>       error_resumptive | ResumptiveErrorHandler{} <- [Directive String] -> ErrorHandlerInfo
forall t. [Directive t] -> ErrorHandlerInfo
getError [Directive String]
dirs = Bool
True
>                        | Bool
otherwise                                 = Bool
False
>
>       start_strs  = [ String
startNameString -> String -> String
forall a. [a] -> [a] -> [a]
++Char
'_'Char -> String -> String
forall a. a -> [a] -> [a]
:String
p  | (TokenName String
p Maybe String
_ Bool
_) <- [Directive String]
starts' ]

Build up a mapping from name values to strings.

>       name_env = (Name
errorTok, String
errorName) (Name, String) -> [(Name, String)] -> [(Name, String)]
forall a. a -> [a] -> [a]
:
>                  (Name
catchTok, String
catchName) (Name, String) -> [(Name, String)] -> [(Name, String)]
forall a. a -> [a] -> [a]
:
>                  (Name
dummyTok, String
dummyName) (Name, String) -> [(Name, String)] -> [(Name, String)]
forall a. a -> [a] -> [a]
:
>                  [Name] -> [String] -> [(Name, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
start_names    [String]
start_strs [(Name, String)] -> [(Name, String)] -> [(Name, String)]
forall a. [a] -> [a] -> [a]
++
>                  [Name] -> [String] -> [(Name, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
nonterm_names  [String]
nonterm_strs [(Name, String)] -> [(Name, String)] -> [(Name, String)]
forall a. [a] -> [a] -> [a]
++
>                  [Name] -> [String] -> [(Name, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
terminal_names [String]
terminal_strs

>       lookupName :: String -> [Name]
>       lookupName String
n = [ Name
t | (Name
t,String
r) <- [(Name, String)]
name_env, String
r String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
n
>                          , Name
t Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
catchTok Bool -> Bool -> Bool
|| Bool
error_resumptive ]
>                            -- hide catchName unless %errorresumptive is active
>                            -- issue93.y uses catch as a nonterminal, we should not steal it

>       mapToName String
str' =
>             case String -> [Name]
lookupName String
str' of
>                [Name
a]   -> Name -> WriterT [String] Identity Name
forall a. a -> WriterT [String] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
a
>                []    -> do String -> M ()
addErr (String
"unknown identifier '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'")
>                            Name -> WriterT [String] Identity Name
forall a. a -> WriterT [String] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
errorTok -- SG: What a confusing use of errorTok.. Use dummyTok?
>                (Name
a:[Name]
_) -> do String -> M ()
addErr (String
"multiple use of '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'")
>                            Name -> WriterT [String] Identity Name
forall a. a -> WriterT [String] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
a

Start symbols...

>               -- default start token is the first non-terminal in the grammar
>       lookupStart (TokenName String
_ Maybe String
Nothing  Bool
_) = Name -> WriterT [String] Identity Name
forall a. a -> WriterT [String] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
first_nt
>       lookupStart (TokenName String
_ (Just String
n) Bool
_) = String -> WriterT [String] Identity Name
mapToName String
n
>       lookupStart Directive a
_ = String -> WriterT [String] Identity Name
forall a. HasCallStack => String -> a
error String
"lookupStart: Not a TokenName"
>   -- in

>   start_toks <- mapM lookupStart starts'

>   let
>       parser_names   = [ String
s | TokenName String
s Maybe String
_ Bool
_ <- [Directive String]
starts' ]
>       start_partials = [ Bool
b | TokenName String
_ Maybe String
_ Bool
b <- [Directive String]
starts' ]
>       start_prods = (Name -> Name -> Production e)
-> [Name] -> [Name] -> [Production e]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Name
nm Name
tok -> Name -> [Name] -> (e, [Int]) -> Priority -> Production e
forall eliminator.
Name
-> [Name]
-> (eliminator, [Int])
-> Priority
-> Production eliminator
Production Name
nm [Name
tok] (e
noCode,[]) Priority
No)
>                        [Name]
start_names [Name]
start_toks

Deal with priorities...

>       priodir = [Int] -> [Directive String] -> [(Int, Directive String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] ([Directive String] -> [Directive String]
forall t. [Directive t] -> [Directive t]
getPrios [Directive String]
dirs)
>
>       mkPrio :: Int -> Directive a -> Priority
>       mkPrio Int
i (TokenNonassoc [String]
_) = Assoc -> Int -> Priority
Prio Assoc
None Int
i
>       mkPrio Int
i (TokenRight [String]
_) = Assoc -> Int -> Priority
Prio Assoc
RightAssoc Int
i
>       mkPrio Int
i (TokenLeft [String]
_) = Assoc -> Int -> Priority
Prio Assoc
LeftAssoc Int
i
>       mkPrio Int
_ Directive a
_ = String -> Priority
forall a. HasCallStack => String -> a
error String
"Panic: impossible case in mkPrio"

>       prios = [ (Name
name,Int -> Directive String -> Priority
forall a. Int -> Directive a -> Priority
mkPrio Int
i Directive String
dir)
>               | (Int
i,Directive String
dir) <- [(Int, Directive String)]
priodir
>               , String
nm <- Directive String -> [String]
forall t. Directive t -> [String]
getPrioNames Directive String
dir
>               , Name
name <- String -> [Name]
lookupName String
nm
>               ]

>       prioByString = [ (String
name, Int -> Directive String -> Priority
forall a. Int -> Directive a -> Priority
mkPrio Int
i Directive String
dir)
>                      | (Int
i,Directive String
dir) <- [(Int, Directive String)]
priodir
>                      , String
name <- Directive String -> [String]
forall t. Directive t -> [String]
getPrioNames Directive String
dir
>                      ]

Translate the rules from string to name-based.

>       convNT (Rule1 String
nt [Prod1 e]
prods Maybe (String, Subst)
ty)
>         = do nt' <- String -> WriterT [String] Identity Name
mapToName String
nt
>              return (nt', prods, ty)
>
>       transRule (Name
nt, t (Prod1 e)
prods, c
_ty)
>         = (Prod1 e -> WriterT [String] Identity (Production e))
-> t (Prod1 e) -> WriterT [String] Identity (t (Production e))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)
mapM (Name -> Prod1 e -> WriterT [String] Identity (Production e)
finishRule Name
nt) t (Prod1 e)
prods
>
>       finishRule :: Name -> Prod1 e -> Writer [ErrMsg] (Production e)
>       finishRule Name
nt (Prod1 [String]
lhs e
code Int
line Prec
prec)
>         = ((Production e, [String]) -> (Production e, [String]))
-> WriterT [String] Identity (Production e)
-> WriterT [String] Identity (Production e)
forall a w b w'. ((a, w) -> (b, w')) -> Writer w a -> Writer w' b
mapWriter (\(Production e
a,[String]
e) -> (Production e
a, (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> String -> String
addLine Int
line) [String]
e)) (WriterT [String] Identity (Production e)
 -> WriterT [String] Identity (Production e))
-> WriterT [String] Identity (Production e)
-> WriterT [String] Identity (Production e)
forall a b. (a -> b) -> a -> b
$ do
>           lhs' <- (String -> WriterT [String] Identity Name)
-> [String] -> WriterT [String] Identity [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> WriterT [String] Identity Name
mapToName [String]
lhs
>           code' <- checkCode lhs' nonterm_names code
>           case mkPrec lhs' prec of
>               Left String
s  -> do String -> M ()
addErr (String
"Undeclared precedence token: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
>                             Production e -> WriterT [String] Identity (Production e)
forall a. a -> WriterT [String] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [Name] -> (e, [Int]) -> Priority -> Production e
forall eliminator.
Name
-> [Name]
-> (eliminator, [Int])
-> Priority
-> Production eliminator
Production Name
nt [Name]
lhs' (e, [Int])
code' Priority
No)
>               Right Priority
p -> Production e -> WriterT [String] Identity (Production e)
forall a. a -> WriterT [String] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [Name] -> (e, [Int]) -> Priority -> Production e
forall eliminator.
Name
-> [Name]
-> (eliminator, [Int])
-> Priority
-> Production eliminator
Production Name
nt [Name]
lhs' (e, [Int])
code' Priority
p)
>
>       mkPrec :: [Name] -> Prec -> Either String Priority
>       mkPrec [Name]
lhs Prec
PrecNone =
>         case (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Name -> [Name] -> Bool) -> [Name] -> Name -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Name]
terminal_names) [Name]
lhs of
>                            [] -> Priority -> Either String Priority
forall a b. b -> Either a b
Right Priority
No
>                            [Name]
xs -> case Name -> [(Name, Priority)] -> Maybe Priority
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ([Name] -> Name
forall a. HasCallStack => [a] -> a
last [Name]
xs) [(Name, Priority)]
prios of
>                                    Maybe Priority
Nothing -> Priority -> Either String Priority
forall a b. b -> Either a b
Right Priority
No
>                                    Just Priority
p  -> Priority -> Either String Priority
forall a b. b -> Either a b
Right Priority
p
>       mkPrec [Name]
_ (PrecId String
s) =
>         case String -> [(String, Priority)] -> Maybe Priority
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
s [(String, Priority)]
prioByString of
>                           Maybe Priority
Nothing -> String -> Either String Priority
forall a b. a -> Either a b
Left String
s
>                           Just Priority
p -> Priority -> Either String Priority
forall a b. b -> Either a b
Right Priority
p
>
>       mkPrec [Name]
_ Prec
PrecShift = Priority -> Either String Priority
forall a b. b -> Either a b
Right Priority
PrioLowest
>
>   -- in

>   rules1 <- mapM convNT rules
>   rules2 <- mapM transRule rules1

>   let
>       type_env = [(String
nt, String
t) | Rule1 String
nt [Prod1 e]
_ (Just (String
t,[])) <- [Rule1 e]
rules] Subst -> Subst -> Subst
forall a. [a] -> [a] -> [a]
++
>                  [(String
nt, [Directive String] -> String
forall t. [Directive t] -> String
getTokenType [Directive String]
dirs) | String
nt <- [String]
terminal_strs] -- XXX: Doesn't handle $$ type!
>
>       fixType (String
ty,Subst
s) = String -> String -> WriterT [String] Identity String
go String
"" String
ty
>         where go :: String -> String -> WriterT [String] Identity String
go String
acc [] = String -> WriterT [String] Identity String
forall a. a -> WriterT [String] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String
forall a. [a] -> [a]
reverse String
acc)
>               go String
acc (Char
c:String
r) | Char -> Bool
isLower Char
c = -- look for a run of alphanumerics starting with a lower case letter
>                                let (String
cs,String
r1) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isAlphaNum String
r
>                                    go1 :: String -> WriterT [String] Identity String
go1 String
x = String -> String -> WriterT [String] Identity String
go (String -> String
forall a. [a] -> [a]
reverse String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
acc) String
r1
>                                in case String -> Subst -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
cs) Subst
s of
>                                        Maybe String
Nothing -> String -> WriterT [String] Identity String
go1 (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
cs) -- no binding found
>                                        Just String
a -> case String -> Subst -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
a Subst
type_env of
>                                          Maybe String
Nothing -> do
>                                            String -> M ()
addErr (String
"Parameterized rule argument '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' does not have type")
>                                            String -> WriterT [String] Identity String
go1 (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
cs)
>                                          Just String
t -> String -> WriterT [String] Identity String
go1 (String -> WriterT [String] Identity String)
-> String -> WriterT [String] Identity String
forall a b. (a -> b) -> a -> b
$ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
>                            | Bool
otherwise = String -> String -> WriterT [String] Identity String
go (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
acc) String
r
>
>       convType (a
nm, (String, Subst)
t)
>         = do t' <- (String, Subst) -> WriterT [String] Identity String
fixType (String, Subst)
t
>              return (nm, t')
>
>   -- in
>   tys <- mapM convType [ (nm, t) | (nm, _, Just t) <- rules1 ]
>

>   let
>       type_array :: Array Name (Maybe String)
>       type_array = (Maybe String -> Maybe String -> Maybe String)
-> Maybe String
-> (Name, Name)
-> [(Name, Maybe String)]
-> Array Name (Maybe String)
forall i e a.
Ix i =>
(e -> a -> e) -> e -> (i, i) -> [(i, a)] -> Array i e
accumArray (\Maybe String
_ Maybe String
x -> Maybe String
x) Maybe String
forall a. Maybe a
Nothing (Name
first_nt, Name
last_nt)
>                    [ (Name
nm, String -> Maybe String
forall a. a -> Maybe a
Just String
t) | (Name
nm, String
t) <- [(Name, String)]
tys ]

>       env_array :: Array Name String
>       env_array = (Name, Name) -> [(Name, String)] -> Array Name String
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Name
errorTok, Name
last_t) [(Name, String)]
name_env
>   -- in

Get the token specs in terms of Names.

>   let
>       fixTokenSpec (String
a,b
b) = do n <- String -> WriterT [String] Identity Name
mapToName String
a; return (n,b)
>   -- in
>   tokspec <- mapM fixTokenSpec (getTokenSpec dirs)

>   let
>      ass = [(Name, Int)] -> [(Name, [Int])]
forall a b. Ord a => [(a, b)] -> [(a, [b])]
combinePairs [ (Name
a,Int
no)
>                         | (Production Name
a [Name]
_ (e, [Int])
_ Priority
_,Int
no) <- [Production e] -> [Int] -> [(Production e, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Production e]
productions' [Int
0..] ]
>      arr = (Name, Name) -> [(Name, [Int])] -> Array Name [Int]
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Name
firstStartTok, Int -> Name
MkName (Int -> Name) -> Int -> Name
forall a b. (a -> b) -> a -> b
$ [(Name, [Int])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, [Int])]
ass Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Name -> Int
getName Name
firstStartTok) [(Name, [Int])]
ass

>      lookup_prods :: Name -> [Int]
>      lookup_prods Name
x | Name
x Name -> Name -> Bool
forall a. Ord a => a -> a -> Bool
>= Name
firstStartTok Bool -> Bool -> Bool
&& Name
x Name -> Name -> Bool
forall a. Ord a => a -> a -> Bool
< Name
first_t = Array Name [Int]
arr Array Name [Int] -> Name -> [Int]
forall i e. Ix i => Array i e -> i -> e
! Name
x
>      lookup_prods Name
_ = String -> [Int]
forall a. HasCallStack => String -> a
error String
"lookup_prods"
>
>      productions' = [Production e]
start_prods [Production e] -> [Production e] -> [Production e]
forall a. [a] -> [a] -> [a]
++ [[Production e]] -> [Production e]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Production e]]
rules2
>      prod_array  = (Int, Int) -> [Production e] -> Array Int (Production e)
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,[Production e] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Production e]
productions' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Production e]
productions'

>   return  (Grammar {
>               productions       = productions',
>               lookupProdNo      = (prod_array !),
>               lookupProdsOfName = lookup_prods,
>               token_specs       = tokspec,
>               terminals         = errorTok : catchTok : terminal_names,
>               non_terminals     = start_names ++ nonterm_names,
>                                       -- INCLUDES the %start tokens
>               starts            = zip4 parser_names start_names start_toks
>                                       start_partials,
>               types             = type_array,
>               token_names       = env_array,
>               first_nonterm     = first_nt,
>               first_term        = first_t,
>               eof_term          = last terminal_names,
>               priorities        = prios
>       },
>       Directives {
>               imported_identity                 = getImportedIdentity dirs,
>               monad             = getMonad dirs,
>               lexer             = getLexer dirs,
>               error_handler     = getError dirs,
>               error_expected    = getErrorExpectedMode dirs,
>               token_type        = getTokenType dirs,
>               expect            = getExpect dirs
>       })

Gofer-like stuff:

> combinePairs :: (Ord a) => [(a,b)] -> [(a,[b])]
> combinePairs :: forall a b. Ord a => [(a, b)] -> [(a, [b])]
combinePairs [(a, b)]
xs =
>       [(a, [b])] -> [(a, [b])]
forall {a} {a}. Eq a => [(a, [a])] -> [(a, [a])]
combine [ (a
a,[b
b]) | (a
a,b
b) <- ((a, b) -> (a, b) -> Ordering) -> [(a, b)] -> [(a, b)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((a, b) -> a) -> (a, b) -> (a, b) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (a, b) -> a
forall a b. (a, b) -> a
fst) [(a, b)]
xs]
>  where
>       combine :: [(a, [a])] -> [(a, [a])]
combine [] = []
>       combine ((a
a,[a]
b):(a
c,[a]
d):[(a, [a])]
r) | a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
c = [(a, [a])] -> [(a, [a])]
combine ((a
a,[a]
b[a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++[a]
d) (a, [a]) -> [(a, [a])] -> [(a, [a])]
forall a. a -> [a] -> [a]
: [(a, [a])]
r)
>       combine ((a, [a])
a:[(a, [a])]
r) = (a, [a])
a (a, [a]) -> [(a, [a])] -> [(a, [a])]
forall a. a -> [a] -> [a]
: [(a, [a])] -> [(a, [a])]
combine [(a, [a])]
r
>

For combining actions with possible error messages.

> addLine :: Int -> String -> String
> addLine :: Int -> String -> String
addLine Int
l String
s = Int -> String
forall a. Show a => a -> String
show Int
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s

> getTerm :: Directive a -> [a]
> getTerm :: forall a. Directive a -> [a]
getTerm (TokenSpec [(a, TokenSpec)]
stuff) = ((a, TokenSpec) -> a) -> [(a, TokenSpec)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, TokenSpec) -> a
forall a b. (a, b) -> a
fst [(a, TokenSpec)]
stuff
> getTerm Directive a
_                 = []

So is this.

> checkRules :: [String] -> String -> [String] -> Writer [ErrMsg] [String]
> checkRules :: [String] -> String -> [String] -> Writer [String] [String]
checkRules (String
name:[String]
rest) String
above [String]
nonterms
>       | String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
above = [String] -> String -> [String] -> Writer [String] [String]
checkRules [String]
rest String
name [String]
nonterms
>       | String
name String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
nonterms
>               = do String -> M ()
addErr (String
"Multiple rules for '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'")
>                    [String] -> String -> [String] -> Writer [String] [String]
checkRules [String]
rest String
name [String]
nonterms
>       | Bool
otherwise = [String] -> String -> [String] -> Writer [String] [String]
checkRules [String]
rest String
name (String
name String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
nonterms)

> checkRules [] String
_ [String]
nonterms = [String] -> Writer [String] [String]
forall a. a -> WriterT [String] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
nonterms)

-----------------------------------------------------------------------------
-- Check for every $i that i is <= the arity of the rule.

-- At the same time, we collect a list of the variables actually used in this
-- code, which is used by the backend.

> doCheckCode :: Int -> String -> M (String, [Int])
> doCheckCode :: Int -> String -> M (String, [Int])
doCheckCode Int
arity String
code0 = String -> String -> [Int] -> M (String, [Int])
go String
code0 String
"" []
>   where go :: String -> String -> [Int] -> M (String, [Int])
go String
code String
acc [Int]
used =
>           case String
code of
>               [] -> (String, [Int]) -> M (String, [Int])
forall a. a -> WriterT [String] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String
forall a. [a] -> [a]
reverse String
acc, [Int]
used)
>
>               Char
'"'  :String
r    -> case ReadS String
forall a. Read a => ReadS a
reads String
code :: [(String,String)] of
>                                []       -> String -> String -> [Int] -> M (String, [Int])
go String
r (Char
'"'Char -> String -> String
forall a. a -> [a] -> [a]
:String
acc) [Int]
used
>                                (String
s,String
r'):Subst
_ -> String -> String -> [Int] -> M (String, [Int])
go String
r' (String -> String
forall a. [a] -> [a]
reverse (String -> String
forall a. Show a => a -> String
show String
s) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
acc) [Int]
used
>               Char
a:Char
'\'' :String
r | Char -> Bool
isAlphaNum Char
a -> String -> String -> [Int] -> M (String, [Int])
go String
r (Char
'\''Char -> String -> String
forall a. a -> [a] -> [a]
:Char
aChar -> String -> String
forall a. a -> [a] -> [a]
:String
acc) [Int]
used
>               Char
'\'' :String
r    -> case ReadS Char
forall a. Read a => ReadS a
reads String
code :: [(Char,String)] of
>                                []       -> String -> String -> [Int] -> M (String, [Int])
go String
r  (Char
'\''Char -> String -> String
forall a. a -> [a] -> [a]
:String
acc) [Int]
used
>                                (Char
c,String
r'):[(Char, String)]
_ -> String -> String -> [Int] -> M (String, [Int])
go String
r' (String -> String
forall a. [a] -> [a]
reverse (Char -> String
forall a. Show a => a -> String
show Char
c) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
acc) [Int]
used
>               Char
'\\':Char
'$':String
r -> String -> String -> [Int] -> M (String, [Int])
go String
r (Char
'$'Char -> String -> String
forall a. a -> [a] -> [a]
:String
acc) [Int]
used
>
>               Char
'$':Char
'>':String
r -- the "rightmost token"
>                       | Int
arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> do String -> M ()
addErr String
"$> in empty rule"
>                                          String -> String -> [Int] -> M (String, [Int])
go String
r String
acc [Int]
used
>                       | Bool
otherwise  -> String -> String -> [Int] -> M (String, [Int])
go String
r (String -> String
forall a. [a] -> [a]
reverse (Int -> String
mkHappyVar Int
arity) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
acc)
>                                        (Int
arity Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
used)
>
>               Char
'$':r :: String
r@(Char
i:String
_) | Char -> Bool
isDigit Char
i ->
>                       case ReadS Int
forall a. Read a => ReadS a
reads String
r :: [(Int,String)] of
>                         (Int
j,String
r'):[(Int, String)]
_ ->
>                            if Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
arity
>                                 then do String -> M ()
addErr (Char
'$'Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
j String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" out of range")
>                                         String -> String -> [Int] -> M (String, [Int])
go String
r' String
acc [Int]
used
>                                 else String -> String -> [Int] -> M (String, [Int])
go String
r' (String -> String
forall a. [a] -> [a]
reverse (Int -> String
mkHappyVar Int
j) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
acc)
>                                        (Int
j Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
used)
>                         [] -> String -> M (String, [Int])
forall a. HasCallStack => String -> a
error String
"doCheckCode []"
>               Char
c:String
r  -> String -> String -> [Int] -> M (String, [Int])
go String
r (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
acc) [Int]
used

> mkHappyVar :: Int -> String
> mkHappyVar :: Int -> String
mkHappyVar Int
n  = String
"happy_var_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n