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

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

Mangler converts AbsSyn to Grammar

> 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.Maybe ( fromMaybe )
> 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 -> Either [ErrMsg] (Grammar, Pragmas)
> mangler :: String -> AbsSyn -> Either [String] (Grammar, Pragmas)
mangler String
file AbsSyn
abssyn
>   | [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
errs = (Grammar, Pragmas) -> Either [String] (Grammar, Pragmas)
forall a b. b -> Either a b
Right (Grammar, Pragmas)
gd
>   | Bool
otherwise = [String] -> Either [String] (Grammar, Pragmas)
forall a b. a -> Either a b
Left [String]
errs
>   where ((Grammar, Pragmas)
gd, [String]
errs) = Writer [String] (Grammar, Pragmas)
-> ((Grammar, Pragmas), [String])
forall w a. Writer w a -> (a, w)
runWriter (String -> AbsSyn -> Writer [String] (Grammar, Pragmas)
manglerM String
file AbsSyn
abssyn)

> manglerM :: FilePath -> AbsSyn -> M (Grammar, Pragmas)
> manglerM :: String -> AbsSyn -> Writer [String] (Grammar, Pragmas)
manglerM String
file (AbsSyn [Directive String]
dirs [Rule]
rules') =
>   -- add filename to all error messages
>   (((Grammar, Pragmas), [String]) -> ((Grammar, Pragmas), [String]))
-> Writer [String] (Grammar, Pragmas)
-> Writer [String] (Grammar, Pragmas)
forall a w b w'. ((a, w) -> (b, w')) -> Writer w a -> Writer w' b
mapWriter (\((Grammar, Pragmas)
a,[String]
e) -> ((Grammar, Pragmas)
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, Pragmas)
 -> Writer [String] (Grammar, Pragmas))
-> Writer [String] (Grammar, Pragmas)
-> Writer [String] (Grammar, Pragmas)
forall a b. (a -> b) -> a -> b
$ do

>   [Rule1]
rules <- case [Rule] -> Either String [Rule1]
expand_rules [Rule]
rules' of
>              Left String
err -> String -> M ()
addErr String
err M ()
-> WriterT [String] Identity [Rule1]
-> WriterT [String] Identity [Rule1]
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] -> WriterT [String] Identity [Rule1]
forall a. a -> WriterT [String] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return []
>              Right [Rule1]
as -> [Rule1] -> WriterT [String] Identity [Rule1]
forall a. a -> WriterT [String] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [Rule1]
as
>   [String]
nonterm_strs <- [String] -> String -> [String] -> Writer [String] [String]
checkRules [String
n | Rule1 String
n [Prod1]
_ Maybe (String, Subst)
_ <- [Rule1]
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]

>       n_starts :: Int
n_starts   = [Directive String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Directive String]
starts'
>       n_nts :: Int
n_nts      = [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
nonterm_strs
>       n_ts :: Int
n_ts       = [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
terminal_strs
>       first_nt :: Int
first_nt   = Int
firstStartTok Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n_starts
>       first_t :: Int
first_t    = Int
first_nt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n_nts
>       last_start :: Int
last_start = Int
first_nt Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
>       last_nt :: Int
last_nt    = Int
first_t  Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
>       last_t :: Int
last_t     = Int
first_t Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n_ts Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

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

>       starts' :: [Directive 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
>
>       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 :: [(Int, String)]
name_env = (Int
errorTok, String
errorName) (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
>                  (Int
dummyTok, String
dummyName) (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
>                  [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
start_names    [String]
start_strs [(Int, String)] -> [(Int, String)] -> [(Int, String)]
forall a. [a] -> [a] -> [a]
++
>                  [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
nonterm_names  [String]
nonterm_strs [(Int, String)] -> [(Int, String)] -> [(Int, String)]
forall a. [a] -> [a] -> [a]
++
>                  [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
terminal_names [String]
terminal_strs

>       lookupName :: String -> [Name]
>       lookupName :: String -> [Int]
lookupName String
n = [ Int
t | (Int
t,String
r) <- [(Int, String)]
name_env, String
r String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
n ]

>       mapToName :: String -> WriterT [String] Identity Int
mapToName String
str' =
>             case String -> [Int]
lookupName String
str' of
>                [Int
a]   -> Int -> WriterT [String] Identity Int
forall a. a -> WriterT [String] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
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
"'")
>                            Int -> WriterT [String] Identity Int
forall a. a -> WriterT [String] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
errorTok
>                (Int
a:[Int]
_) -> 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
"'")
>                            Int -> WriterT [String] Identity Int
forall a. a -> WriterT [String] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
a

Start symbols...

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

>   [Int]
start_toks <- (Directive String -> WriterT [String] Identity Int)
-> [Directive String] -> WriterT [String] Identity [Int]
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 Int
forall {a}. Directive a -> WriterT [String] Identity Int
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]
start_prods = (Int -> Int -> Production) -> [Int] -> [Int] -> [Production]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
nm Int
tok -> Int -> [Int] -> (String, [Int]) -> Priority -> Production
Production Int
nm [Int
tok] (String
"no code",[]) Priority
No)
>                        [Int]
start_names [Int]
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 :: [(Int, Priority)]
prios = [ (Int
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
>               , Int
name <- String -> [Int]
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
-> WriterT [String] Identity (Int, [Prod1], Maybe (String, Subst))
convNT (Rule1 String
nt [Prod1]
prods Maybe (String, Subst)
ty)
>         = do Int
nt' <- String -> WriterT [String] Identity Int
mapToName String
nt
>              (Int, [Prod1], Maybe (String, Subst))
-> WriterT [String] Identity (Int, [Prod1], Maybe (String, Subst))
forall a. a -> WriterT [String] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
nt', [Prod1]
prods, Maybe (String, Subst)
ty)
>
>       attrs :: Subst
attrs = [Directive String] -> Subst
forall t. [Directive t] -> Subst
getAttributes [Directive String]
dirs
>       attrType :: String
attrType = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"HappyAttrs" ([Directive String] -> Maybe String
forall t. [Directive t] -> Maybe String
getAttributetype [Directive String]
dirs)
>
>       transRule :: (Int, t Prod1, c) -> WriterT [String] Identity (t Production)
transRule (Int
nt, t Prod1
prods, c
_ty)
>         = (Prod1 -> WriterT [String] Identity Production)
-> t Prod1 -> WriterT [String] Identity (t Production)
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 (Int -> Prod1 -> WriterT [String] Identity Production
finishRule Int
nt) t Prod1
prods
>
>       finishRule :: Name -> Prod1 -> Writer [ErrMsg] Production
>       finishRule :: Int -> Prod1 -> WriterT [String] Identity Production
finishRule Int
nt (Prod1 [String]
lhs String
code Int
line Prec
prec)
>         = ((Production, [String]) -> (Production, [String]))
-> WriterT [String] Identity Production
-> WriterT [String] Identity Production
forall a w b w'. ((a, w) -> (b, w')) -> Writer w a -> Writer w' b
mapWriter (\(Production
a,[String]
e) -> (Production
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
 -> WriterT [String] Identity Production)
-> WriterT [String] Identity Production
-> WriterT [String] Identity Production
forall a b. (a -> b) -> a -> b
$ do
>           [Int]
lhs' <- (String -> WriterT [String] Identity Int)
-> [String] -> WriterT [String] Identity [Int]
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 Int
mapToName [String]
lhs
>           (String, [Int])
code' <- [Int] -> [Int] -> String -> Subst -> M (String, [Int])
checkCode [Int]
lhs' [Int]
nonterm_names String
code Subst
attrs
>           case [Int] -> Prec -> Either String Priority
mkPrec [Int]
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 -> WriterT [String] Identity Production
forall a. a -> WriterT [String] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> [Int] -> (String, [Int]) -> Priority -> Production
Production Int
nt [Int]
lhs' (String, [Int])
code' Priority
No)
>               Right Priority
p -> Production -> WriterT [String] Identity Production
forall a. a -> WriterT [String] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> [Int] -> (String, [Int]) -> Priority -> Production
Production Int
nt [Int]
lhs' (String, [Int])
code' Priority
p)
>
>       mkPrec :: [Name] -> Prec -> Either String Priority
>       mkPrec :: [Int] -> Prec -> Either String Priority
mkPrec [Int]
lhs Prec
PrecNone =
>         case (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> [Int] -> Bool) -> [Int] -> Int -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Int]
terminal_names) [Int]
lhs of
>                            [] -> Priority -> Either String Priority
forall a b. b -> Either a b
Right Priority
No
>                            [Int]
xs -> case Int -> [(Int, Priority)] -> Maybe Priority
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ([Int] -> Int
forall a. HasCallStack => [a] -> a
last [Int]
xs) [(Int, 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 [Int]
_ (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 [Int]
_ Prec
PrecShift = Priority -> Either String Priority
forall a b. b -> Either a b
Right Priority
PrioLowest
>
>   -- in

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

>   let
>       type_env :: Subst
type_env = [(String
nt, String
t) | Rule1 String
nt [Prod1]
_ (Just (String
t,[])) <- [Rule1]
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
>   [(Int, String)]
tys <- ((Int, (String, Subst)) -> WriterT [String] Identity (Int, String))
-> [(Int, (String, Subst))]
-> WriterT [String] Identity [(Int, 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 (Int, (String, Subst)) -> WriterT [String] Identity (Int, String)
forall {a}.
(a, (String, Subst)) -> WriterT [String] Identity (a, String)
convType [ (Int
nm, (String, Subst)
t) | (Int
nm, [Prod1]
_, Just (String, Subst)
t) <- [(Int, [Prod1], Maybe (String, Subst))]
rules1 ]
>

>   let
>       type_array :: Array Int (Maybe String)
>       type_array :: Array Int (Maybe String)
type_array = (Maybe String -> Maybe String -> Maybe String)
-> Maybe String
-> (Int, Int)
-> [(Int, Maybe String)]
-> Array Int (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 (Int
first_nt, Int
last_nt)
>                    [ (Int
nm, String -> Maybe String
forall a. a -> Maybe a
Just String
t) | (Int
nm, String
t) <- [(Int, String)]
tys ]

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

Get the token specs in terms of Names.

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

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

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

>   (Grammar, Pragmas) -> Writer [String] (Grammar, Pragmas)
forall a. a -> WriterT [String] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return  (Grammar {
>               productions :: [Production]
productions       = [Production]
productions',
>               lookupProdNo :: Int -> Production
lookupProdNo      = (Array Int Production
prod_array Array Int Production -> Int -> Production
forall i e. Ix i => Array i e -> i -> e
!),
>               lookupProdsOfName :: Int -> [Int]
lookupProdsOfName = Int -> [Int]
lookup_prods,
>               token_specs :: [(Int, String)]
token_specs       = [(Int, String)]
tokspec,
>               terminals :: [Int]
terminals         = Int
errorTok Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
terminal_names,
>               non_terminals :: [Int]
non_terminals     = [Int]
start_names [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
nonterm_names,
>                                       -- INCLUDES the %start tokens
>               starts :: [(String, Int, Int, Bool)]
starts            = [String] -> [Int] -> [Int] -> [Bool] -> [(String, Int, Int, Bool)]
forall a b c d. [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
zip4 [String]
parser_names [Int]
start_names [Int]
start_toks
>                                       [Bool]
start_partials,
>               types :: Array Int (Maybe String)
types             = Array Int (Maybe String)
type_array,
>               token_names :: Array Int String
token_names       = Array Int String
env_array,
>               first_nonterm :: Int
first_nonterm     = Int
first_nt,
>               first_term :: Int
first_term        = Int
first_t,
>               eof_term :: Int
eof_term          = [Int] -> Int
forall a. HasCallStack => [a] -> a
last [Int]
terminal_names,
>               priorities :: [(Int, Priority)]
priorities        = [(Int, Priority)]
prios,
>               attributes :: Subst
attributes        = Subst
attrs,
>               attributetype :: String
attributetype     = String
attrType
>       },
>       Pragmas {
>               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 :: Maybe String
error_handler     = [Directive String] -> Maybe String
forall t. [Directive t] -> Maybe String
getError [Directive String]
dirs,
>               error_sig :: ErrorHandlerType
error_sig         = [Directive String] -> ErrorHandlerType
forall t. [Directive t] -> ErrorHandlerType
getErrorHandlerType [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, String)]
stuff) = ((a, String) -> a) -> [(a, String)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, String) -> a
forall a b. (a, b) -> a
fst [(a, String)]
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)

-----------------------------------------------------------------------------
-- 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 :: [Name] -> [Name] -> String -> [(String,String)] -> M (String,[Int])
> checkCode :: [Int] -> [Int] -> String -> Subst -> M (String, [Int])
checkCode [Int]
lhs [Int]
_             String
code []    = Int -> String -> M (String, [Int])
doCheckCode ([Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
lhs) String
code
> checkCode [Int]
lhs [Int]
nonterm_names String
code Subst
attrs = [Int] -> [Int] -> String -> Subst -> M (String, [Int])
rewriteAttributeGrammar [Int]
lhs [Int]
nonterm_names String
code Subst
attrs

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