/-----------------------------------------------------------------------------
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

>   [Rule1 e]
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
>   [String]
nonterm_strs <- [String] -> String -> [String] -> Writer [String] [String]
checkRules [String
n | Rule1 String
n [Prod1 e]
_ Maybe (String, Subst)
_ <- [Rule1 e]
rules] String
"" []

>   let

>       terminal_strs :: [String]
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 :: 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 :: Name
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 :: Name
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 :: Name
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 :: Name
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]
start_names    = [ Name
firstStartTok .. Name
last_start ]
>       nonterm_names :: [Name]
nonterm_names  = [ Name
first_nt .. Name
last_nt ]
>       terminal_names :: [Name]
terminal_names = [ Name
first_t .. Name
last_t ]

>       starts' :: [Directive String]
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 :: Bool
error_resumptive | ResumptiveErrorHandler{} <- [Directive String] -> ErrorHandlerInfo
forall t. [Directive t] -> ErrorHandlerInfo
getError [Directive String]
dirs = Bool
True
>                        | Bool
otherwise                                 = Bool
False
>
>       start_strs :: [String]
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, String)]
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 -> [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 -> WriterT [String] Identity Name
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 :: Directive a -> WriterT [String] Identity Name
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

>   [Name]
start_toks <- (Directive String -> WriterT [String] Identity Name)
-> [Directive 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 Directive String -> WriterT [String] Identity Name
forall {a}. Directive a -> WriterT [String] Identity Name
lookupStart [Directive String]
starts'

>   let
>       parser_names :: [String]
parser_names   = [ String
s | TokenName String
s Maybe String
_ Bool
_ <- [Directive String]
starts' ]
>       start_partials :: [Bool]
start_partials = [ Bool
b | TokenName String
_ Maybe String
_ Bool
b <- [Directive String]
starts' ]
>       start_prods :: [Production e]
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)]
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 :: forall a. 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, Priority)]
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, Priority)]
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 e
-> WriterT
     [String] Identity (Name, [Prod1 e], Maybe (String, Subst))
convNT (Rule1 String
nt [Prod1 e]
prods Maybe (String, Subst)
ty)
>         = do Name
nt' <- String -> WriterT [String] Identity Name
mapToName String
nt
>              (Name, [Prod1 e], Maybe (String, Subst))
-> WriterT
     [String] Identity (Name, [Prod1 e], Maybe (String, Subst))
forall a. a -> WriterT [String] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
nt', [Prod1 e]
prods, Maybe (String, Subst)
ty)
>
>       transRule :: (Name, t (Prod1 e), c)
-> WriterT [String] Identity (t (Production e))
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 -> Prod1 e -> WriterT [String] Identity (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
>           [Name]
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
>           (e, [Int])
code' <- CodeChecker e
checkCode [Name]
lhs' [Name]
nonterm_names e
code
>           case [Name] -> Prec -> Either String Priority
mkPrec [Name]
lhs' Prec
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] -> 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

>   [(Name, [Prod1 e], Maybe (String, Subst))]
rules1 <- (Rule1 e
 -> WriterT
      [String] Identity (Name, [Prod1 e], Maybe (String, Subst)))
-> [Rule1 e]
-> WriterT
     [String] Identity [(Name, [Prod1 e], Maybe (String, Subst))]
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 Rule1 e
-> WriterT
     [String] Identity (Name, [Prod1 e], Maybe (String, Subst))
forall {e}.
Rule1 e
-> WriterT
     [String] Identity (Name, [Prod1 e], Maybe (String, Subst))
convNT [Rule1 e]
rules
>   [[Production e]]
rules2 <- ((Name, [Prod1 e], Maybe (String, Subst))
 -> WriterT [String] Identity [Production e])
-> [(Name, [Prod1 e], Maybe (String, Subst))]
-> WriterT [String] Identity [[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) -> [a] -> m [b]
mapM (Name, [Prod1 e], Maybe (String, Subst))
-> WriterT [String] Identity [Production e]
forall {t :: * -> *} {c}.
Traversable t =>
(Name, t (Prod1 e), c)
-> WriterT [String] Identity (t (Production e))
transRule [(Name, [Prod1 e], Maybe (String, Subst))]
rules1

>   let
>       type_env :: Subst
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, Subst) -> WriterT [String] Identity String
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, (String, Subst)) -> WriterT [String] Identity (a, String)
convType (a
nm, (String, Subst)
t)
>         = do String
t' <- (String, Subst) -> WriterT [String] Identity String
fixType (String, Subst)
t
>              (a, String) -> WriterT [String] Identity (a, String)
forall a. a -> WriterT [String] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
nm, String
t')
>
>   -- in
>   [(Name, String)]
tys <- ((Name, (String, Subst))
 -> WriterT [String] Identity (Name, String))
-> [(Name, (String, Subst))]
-> WriterT [String] Identity [(Name, String)]
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 (Name, (String, Subst)) -> WriterT [String] Identity (Name, String)
forall {a}.
(a, (String, Subst)) -> WriterT [String] Identity (a, String)
convType [ (Name
nm, (String, Subst)
t) | (Name
nm, [Prod1 e]
_, Just (String, Subst)
t) <- [(Name, [Prod1 e], Maybe (String, Subst))]
rules1 ]
>

>   let
>       type_array :: Array Name (Maybe String)
>       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 :: 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, b) -> WriterT [String] Identity (Name, b)
fixTokenSpec (String
a,b
b) = do Name
n <- String -> WriterT [String] Identity Name
mapToName String
a; (Name, b) -> WriterT [String] Identity (Name, b)
forall a. a -> WriterT [String] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n,b
b)
>   -- in
>   [(Name, TokenSpec)]
tokspec <- ((String, TokenSpec)
 -> WriterT [String] Identity (Name, TokenSpec))
-> [(String, TokenSpec)]
-> WriterT [String] Identity [(Name, TokenSpec)]
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, TokenSpec) -> WriterT [String] Identity (Name, TokenSpec)
forall {b}. (String, b) -> WriterT [String] Identity (Name, b)
fixTokenSpec ([Directive String] -> [(String, TokenSpec)]
forall t. [Directive t] -> [(t, TokenSpec)]
getTokenSpec [Directive String]
dirs)

>   let
>      ass :: [(Name, [Int])]
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 :: Array Name [Int]
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 -> [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]
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 :: Array Int (Production e)
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'

>   (Grammar e, Directives) -> Writer [String] (Grammar e, Directives)
forall a. a -> WriterT [String] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return  (Grammar {
>               productions :: [Production e]
productions       = [Production e]
productions',
>               lookupProdNo :: Int -> Production e
lookupProdNo      = (Array Int (Production e)
prod_array Array Int (Production e) -> Int -> Production e
forall i e. Ix i => Array i e -> i -> e
!),
>               lookupProdsOfName :: Name -> [Int]
lookupProdsOfName = Name -> [Int]
lookup_prods,
>               token_specs :: [(Name, TokenSpec)]
token_specs       = [(Name, TokenSpec)]
tokspec,
>               terminals :: [Name]
terminals         = Name
errorTok Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: Name
catchTok Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
terminal_names,
>               non_terminals :: [Name]
non_terminals     = [Name]
start_names [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
nonterm_names,
>                                       -- INCLUDES the %start tokens
>               starts :: [(String, Name, Name, Bool)]
starts            = [String]
-> [Name] -> [Name] -> [Bool] -> [(String, Name, Name, Bool)]
forall a b c d. [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
zip4 [String]
parser_names [Name]
start_names [Name]
start_toks
>                                       [Bool]
start_partials,
>               types :: Array Name (Maybe String)
types             = Array Name (Maybe String)
type_array,
>               token_names :: Array Name String
token_names       = Array Name String
env_array,
>               first_nonterm :: Name
first_nonterm     = Name
first_nt,
>               first_term :: Name
first_term        = Name
first_t,
>               eof_term :: Name
eof_term          = [Name] -> Name
forall a. HasCallStack => [a] -> a
last [Name]
terminal_names,
>               priorities :: [(Name, Priority)]
priorities        = [(Name, Priority)]
prios
>       },
>       Directives {
>               imported_identity :: Bool
imported_identity                 = [Directive String] -> Bool
forall t. [Directive t] -> Bool
getImportedIdentity [Directive String]
dirs,
>               monad :: (Bool, String, String, String, String)
monad             = [Directive String] -> (Bool, String, String, String, String)
forall t. [Directive t] -> (Bool, String, String, String, String)
getMonad [Directive String]
dirs,
>               lexer :: Maybe (String, String)
lexer             = [Directive String] -> Maybe (String, String)
forall t. [Directive t] -> Maybe (String, String)
getLexer [Directive String]
dirs,
>               error_handler :: ErrorHandlerInfo
error_handler     = [Directive String] -> ErrorHandlerInfo
forall t. [Directive t] -> ErrorHandlerInfo
getError [Directive String]
dirs,
>               error_expected :: ErrorExpectedMode
error_expected    = [Directive String] -> ErrorExpectedMode
forall t. Eq t => [Directive t] -> ErrorExpectedMode
getErrorExpectedMode [Directive String]
dirs,
>               token_type :: String
token_type        = [Directive String] -> String
forall t. [Directive t] -> String
getTokenType [Directive String]
dirs,
>               expect :: Maybe Int
expect            = [Directive String] -> Maybe Int
forall t. [Directive t] -> Maybe Int
getExpect [Directive String]
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