/-----------------------------------------------------------------------------
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 )
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') =
>
> (((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...
>
> 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"
>
> [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
>
>
> [(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]
>
> 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 =
> 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)
> 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')
>
>
> [(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
>
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)
>
> [(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'
>
> (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,
>
> 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)
> 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
> 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
> | 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