/-----------------------------------------------------------------------------
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 :: [Char]
-> AbsSyn [Char]
-> Either
     [[Char]] (Grammar [Char], Maybe AttributeGrammarExtras, Directives)
mangler [Char]
file abssyn :: AbsSyn [Char]
abssyn@(AbsSyn [Directive [Char]]
dirs [Rule [Char]]
_)
>   | [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
errs = (Grammar [Char], Maybe AttributeGrammarExtras, Directives)
-> Either
     [[Char]] (Grammar [Char], Maybe AttributeGrammarExtras, Directives)
forall a b. b -> Either a b
Right (Grammar [Char]
gd, Maybe AttributeGrammarExtras
mAg, Directives
ps)
>   | Bool
otherwise = [[Char]]
-> Either
     [[Char]] (Grammar [Char], Maybe AttributeGrammarExtras, Directives)
forall a b. a -> Either a b
Left [[Char]]
errs
>   where mAg :: Maybe AttributeGrammarExtras
mAg = [Directive [Char]] -> Maybe AttributeGrammarExtras
forall t. [Directive t] -> Maybe AttributeGrammarExtras
getAttributeGrammarExtras [Directive [Char]]
dirs
>         ((Grammar [Char]
gd, Directives
ps), [[Char]]
errs) = Writer [[Char]] (Grammar [Char], Directives)
-> ((Grammar [Char], Directives), [[Char]])
forall w a. Writer w a -> (a, w)
runWriter ([Char]
-> CodeChecker [Char]
-> [Char]
-> AbsSyn [Char]
-> Writer [[Char]] (Grammar [Char], Directives)
forall e.
e
-> CodeChecker e -> [Char] -> AbsSyn e -> M (Grammar e, Directives)
manglerM [Char]
"no code" CodeChecker [Char]
checkCode [Char]
file AbsSyn [Char]
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 [Char]
checkCode = case Maybe AttributeGrammarExtras
mAg of
>             Maybe AttributeGrammarExtras
Nothing -> \[Name]
lhs [Name]
_             [Char]
code ->
>                 Int -> [Char] -> M ([Char], [Int])
doCheckCode ([Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
lhs) [Char]
code
>             Just AttributeGrammarExtras
a  -> \[Name]
lhs [Name]
nonterm_names [Char]
code ->
>                 [Name]
-> [Name] -> [Char] -> AttributeGrammarExtras -> M ([Char], [Int])
rewriteAttributeGrammar [Name]
lhs [Name]
nonterm_names [Char]
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 -> [Char] -> AbsSyn e -> M (Grammar e, Directives)
manglerM e
noCode CodeChecker e
checkCode [Char]
file (AbsSyn [Directive [Char]]
dirs [Rule e]
rules') =
>   -- add filename to all error messages
>   (((Grammar e, Directives), [[Char]])
 -> ((Grammar e, Directives), [[Char]]))
-> Writer [[Char]] (Grammar e, Directives)
-> Writer [[Char]] (Grammar e, Directives)
forall a w b w'. ((a, w) -> (b, w')) -> Writer w a -> Writer w' b
mapWriter (\((Grammar e, Directives)
a,[[Char]]
e) -> ((Grammar e, Directives)
a, ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\[Char]
s -> [Char]
file [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s) [[Char]]
e)) (Writer [[Char]] (Grammar e, Directives)
 -> Writer [[Char]] (Grammar e, Directives))
-> Writer [[Char]] (Grammar e, Directives)
-> Writer [[Char]] (Grammar e, Directives)
forall a b. (a -> b) -> a -> b
$ do

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

>   let

>       terminal_strs  = [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Directive [Char] -> [[Char]]) -> [Directive [Char]] -> [[[Char]]]
forall a b. (a -> b) -> [a] -> [b]
map Directive [Char] -> [[Char]]
forall a. Directive a -> [a]
getTerm [Directive [Char]]
dirs) [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
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 [Char]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Directive [Char]]
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
+ [[Char]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
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
+ [[Char]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
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 [Char]] -> [Directive [Char]]
forall t. [Directive t] -> [Directive t]
getParserNames [Directive [Char]]
dirs of
>                       [] -> [[Char] -> Maybe [Char] -> Bool -> Directive [Char]
forall a. [Char] -> Maybe [Char] -> Bool -> Directive a
TokenName [Char]
"happyParse" Maybe [Char]
forall a. Maybe a
Nothing Bool
False]
>                       [Directive [Char]]
ns -> [Directive [Char]]
ns
>       error_resumptive | ResumptiveErrorHandler{} <- [Directive [Char]] -> ErrorHandlerInfo
forall t. [Directive t] -> ErrorHandlerInfo
getError [Directive [Char]]
dirs = Bool
True
>                        | Bool
otherwise                                 = Bool
False
>
>       start_strs  = [ [Char]
startName[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Char
'_'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
p  | (TokenName [Char]
p Maybe [Char]
_ Bool
_) <- [Directive [Char]]
starts' ]

Build up a mapping from name values to strings.

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

>       lookupName :: String -> [Name]
>       lookupName [Char]
n = [ Name
t | (Name
t,[Char]
r) <- [(Name, [Char])]
name_env, [Char]
r [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
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 [Char]
str' =
>             case [Char] -> [Name]
lookupName [Char]
str' of
>                [Name
a]   -> Name -> WriterT [[Char]] Identity Name
forall a. a -> WriterT [[Char]] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
a
>                []    -> do [Char] -> M ()
addErr ([Char]
"unknown identifier '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
str' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'")
>                            Name -> WriterT [[Char]] Identity Name
forall a. a -> WriterT [[Char]] 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 [Char] -> M ()
addErr ([Char]
"multiple use of '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
str' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'")
>                            Name -> WriterT [[Char]] Identity Name
forall a. a -> WriterT [[Char]] 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 [Char]
_ Maybe [Char]
Nothing  Bool
_) = Name -> WriterT [[Char]] Identity Name
forall a. a -> WriterT [[Char]] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
first_nt
>       lookupStart (TokenName [Char]
_ (Just [Char]
n) Bool
_) = [Char] -> WriterT [[Char]] Identity Name
mapToName [Char]
n
>       lookupStart Directive a
_ = [Char] -> WriterT [[Char]] Identity Name
forall a. HasCallStack => [Char] -> a
error [Char]
"lookupStart: Not a TokenName"
>   -- in

>   start_toks <- mapM lookupStart starts'

>   let
>       parser_names   = [ [Char]
s | TokenName [Char]
s Maybe [Char]
_ Bool
_ <- [Directive [Char]]
starts' ]
>       start_partials = [ Bool
b | TokenName [Char]
_ Maybe [Char]
_ Bool
b <- [Directive [Char]]
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 [Char]] -> [(Int, Directive [Char])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] ([Directive [Char]] -> [Directive [Char]]
forall t. [Directive t] -> [Directive t]
getPrios [Directive [Char]]
dirs)
>
>       mkPrio :: Int -> Directive a -> Priority
>       mkPrio Int
i (TokenNonassoc [[Char]]
_) = Assoc -> Int -> Priority
Prio Assoc
None Int
i
>       mkPrio Int
i (TokenRight [[Char]]
_) = Assoc -> Int -> Priority
Prio Assoc
RightAssoc Int
i
>       mkPrio Int
i (TokenLeft [[Char]]
_) = Assoc -> Int -> Priority
Prio Assoc
LeftAssoc Int
i
>       mkPrio Int
_ Directive a
_ = [Char] -> Priority
forall a. HasCallStack => [Char] -> a
error [Char]
"Panic: impossible case in mkPrio"

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

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

Translate the rules from string to name-based.

>       convNT (Rule1 [Char]
nt [Prod1 e]
prods Maybe ([Char], Subst)
ty)
>         = do nt' <- [Char] -> WriterT [[Char]] Identity Name
mapToName [Char]
nt
>              return (nt', prods, ty)
>
>       transRule (Name
nt, t (Prod1 e)
prods, c
_ty)
>         = (Prod1 e -> WriterT [[Char]] Identity (Production e))
-> t (Prod1 e) -> WriterT [[Char]] 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 [[Char]] Identity (Production e)
finishRule Name
nt) t (Prod1 e)
prods
>
>       finishRule :: Name -> Prod1 e -> Writer [ErrMsg] (Production e)
>       finishRule Name
nt (Prod1 [[Char]]
lhs e
code Int
line Prec
prec)
>         = ((Production e, [[Char]]) -> (Production e, [[Char]]))
-> WriterT [[Char]] Identity (Production e)
-> WriterT [[Char]] Identity (Production e)
forall a w b w'. ((a, w) -> (b, w')) -> Writer w a -> Writer w' b
mapWriter (\(Production e
a,[[Char]]
e) -> (Production e
a, ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> [Char] -> [Char]
addLine Int
line) [[Char]]
e)) (WriterT [[Char]] Identity (Production e)
 -> WriterT [[Char]] Identity (Production e))
-> WriterT [[Char]] Identity (Production e)
-> WriterT [[Char]] Identity (Production e)
forall a b. (a -> b) -> a -> b
$ do
>           lhs' <- ([Char] -> WriterT [[Char]] Identity Name)
-> [[Char]] -> WriterT [[Char]] 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 [Char] -> WriterT [[Char]] Identity Name
mapToName [[Char]]
lhs
>           code' <- checkCode lhs' nonterm_names code
>           case mkPrec lhs' prec of
>               Left [Char]
s  -> do [Char] -> M ()
addErr ([Char]
"Undeclared precedence token: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s)
>                             Production e -> WriterT [[Char]] Identity (Production e)
forall a. a -> WriterT [[Char]] 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 [[Char]] Identity (Production e)
forall a. a -> WriterT [[Char]] 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 [Char] 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 [Char] Priority
forall a b. b -> Either a b
Right Priority
No
>                                    Just Priority
p  -> Priority -> Either [Char] Priority
forall a b. b -> Either a b
Right Priority
p
>       mkPrec [Name]
_ (PrecId [Char]
s) =
>         case [Char] -> [([Char], Priority)] -> Maybe Priority
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
s [([Char], Priority)]
prioByString of
>                           Maybe Priority
Nothing -> [Char] -> Either [Char] Priority
forall a b. a -> Either a b
Left [Char]
s
>                           Just Priority
p -> Priority -> Either [Char] Priority
forall a b. b -> Either a b
Right Priority
p
>
>       mkPrec [Name]
_ Prec
PrecShift = Priority -> Either [Char] Priority
forall a b. b -> Either a b
Right Priority
PrioLowest
>
>   -- in

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

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

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

Get the token specs in terms of Names.

>   let
>       fixTokenSpec ([Char]
a,b
b) = do n <- [Char] -> WriterT [[Char]] Identity Name
mapToName [Char]
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
_ = [Char] -> [Int]
forall a. HasCallStack => [Char] -> a
error [Char]
"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 -> [Char] -> [Char]
addLine Int
l [Char]
s = Int -> [Char]
forall a. Show a => a -> [Char]
show Int
l [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
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 :: [[Char]] -> [Char] -> [[Char]] -> Writer [[Char]] [[Char]]
checkRules ([Char]
name:[[Char]]
rest) [Char]
above [[Char]]
nonterms
>       | [Char]
name [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
above = [[Char]] -> [Char] -> [[Char]] -> Writer [[Char]] [[Char]]
checkRules [[Char]]
rest [Char]
name [[Char]]
nonterms
>       | [Char]
name [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
nonterms
>               = do [Char] -> M ()
addErr ([Char]
"Multiple rules for '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'")
>                    [[Char]] -> [Char] -> [[Char]] -> Writer [[Char]] [[Char]]
checkRules [[Char]]
rest [Char]
name [[Char]]
nonterms
>       | Bool
otherwise = [[Char]] -> [Char] -> [[Char]] -> Writer [[Char]] [[Char]]
checkRules [[Char]]
rest [Char]
name ([Char]
name [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
nonterms)

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

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