Implementation of FIRST
(c) 1993-2001 Andy Gill, Simon Marlow
> module Happy.Tabular.First ( mkFirst, mkClosure ) where
> import Happy.Tabular.NameSet ( NameSet )
> import qualified Happy.Tabular.NameSet as Set
> import Happy.Grammar
> import Data.IntSet (IntSet)
\subsection{Utilities}
> joinSymSets :: (a -> NameSet) -> [a] -> NameSet
> joinSymSets :: forall a. (a -> NameSet) -> [a] -> NameSet
joinSymSets a -> NameSet
f = (NameSet -> NameSet -> NameSet) -> NameSet -> [NameSet] -> NameSet
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr NameSet -> NameSet -> NameSet
go (Name -> NameSet
Set.singleton Name
epsilonTok) ([NameSet] -> NameSet) -> ([a] -> [NameSet]) -> [a] -> NameSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> NameSet) -> [a] -> [NameSet]
forall a b. (a -> b) -> [a] -> [b]
map a -> NameSet
f
> where
> go :: NameSet -> NameSet -> NameSet
go NameSet
h NameSet
b
> | Name -> NameSet -> Bool
Set.member Name
epsilonTok NameSet
h = Name -> NameSet -> NameSet
Set.delete Name
epsilonTok NameSet
h NameSet -> NameSet -> NameSet
`Set.union` NameSet
b
> | Bool
otherwise = NameSet
h
@mkClosure@ makes a closure, when given a comparison and iteration loop.
Be careful, because if the functional always makes the object different,
This will never terminate.
> mkClosure :: (a -> a -> Bool) -> (a -> a) -> a -> a
> mkClosure :: forall a. (a -> a -> Bool) -> (a -> a) -> a -> a
mkClosure a -> a -> Bool
eq a -> a
f = [a] -> a
match ([a] -> a) -> (a -> [a]) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a) -> a -> [a]
forall a. (a -> a) -> a -> [a]
iterate a -> a
f
> where
> match :: [a] -> a
match (a
a:a
b:[a]
_) | a
a a -> a -> Bool
`eq` a
b = a
a
> match (a
_:[a]
c) = [a] -> a
match [a]
c
> match [] = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Can't happen: match []"
\subsection{Implementation of FIRST}
> mkFirst :: Grammar -> [Name] -> NameSet
> mkFirst :: Grammar -> [Name] -> NameSet
mkFirst (Grammar { first_term :: Grammar -> Name
first_term = Name
fst_term
> , lookupProdNo :: Grammar -> Name -> Production
lookupProdNo = Name -> Production
prodNo
> , lookupProdsOfName :: Grammar -> Name -> [Name]
lookupProdsOfName = Name -> [Name]
prodsOfName
> , non_terminals :: Grammar -> [Name]
non_terminals = [Name]
nts
> })
> = (Name -> NameSet) -> [Name] -> NameSet
forall a. (a -> NameSet) -> [a] -> NameSet
joinSymSets (\ Name
h -> NameSet -> (NameSet -> NameSet) -> Maybe NameSet -> NameSet
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> NameSet
Set.singleton Name
h) NameSet -> NameSet
forall a. a -> a
id (Name -> [(Name, NameSet)] -> Maybe NameSet
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
h [(Name, NameSet)]
env) )
> where
> env :: [(Name, NameSet)]
env = ([(Name, NameSet)] -> [(Name, NameSet)] -> Bool)
-> ([(Name, NameSet)] -> [(Name, NameSet)])
-> [(Name, NameSet)]
-> [(Name, NameSet)]
forall a. (a -> a -> Bool) -> (a -> a) -> a -> a
mkClosure [(Name, NameSet)] -> [(Name, NameSet)] -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Name
-> (Name -> Production)
-> (Name -> [Name])
-> [(Name, NameSet)]
-> [(Name, NameSet)]
forall a.
Name
-> (a -> Production)
-> (Name -> [a])
-> [(Name, NameSet)]
-> [(Name, NameSet)]
getNext Name
fst_term Name -> Production
prodNo Name -> [Name]
prodsOfName)
> [ (Name
name,NameSet
Set.empty) | Name
name <- [Name]
nts ]
> getNext :: Name -> (a -> Production) -> (Name -> [a])
> -> [(Name, IntSet)] -> [(Name, NameSet)]
> getNext :: forall a.
Name
-> (a -> Production)
-> (Name -> [a])
-> [(Name, NameSet)]
-> [(Name, NameSet)]
getNext Name
fst_term a -> Production
prodNo Name -> [a]
prodsOfName [(Name, NameSet)]
env =
> [ (Name
nm, Name -> NameSet
next Name
nm) | (Name
nm,NameSet
_) <- [(Name, NameSet)]
env ]
> where
> fn :: Name -> NameSet
fn Name
t | Name
t Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
errorTok Bool -> Bool -> Bool
|| Name
t Name -> Name -> Bool
forall a. Ord a => a -> a -> Bool
>= Name
fst_term = Name -> NameSet
Set.singleton Name
t
> fn Name
x = NameSet -> (NameSet -> NameSet) -> Maybe NameSet -> NameSet
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> NameSet
forall a. HasCallStack => [Char] -> a
error [Char]
"attempted FIRST(e) :-(") NameSet -> NameSet
forall a. a -> a
id (Name -> [(Name, NameSet)] -> Maybe NameSet
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
x [(Name, NameSet)]
env)
> next :: Name -> NameSet
> next :: Name -> NameSet
next Name
t | Name
t Name -> Name -> Bool
forall a. Ord a => a -> a -> Bool
>= Name
fst_term = Name -> NameSet
Set.singleton Name
t
> next Name
n = [NameSet] -> NameSet
forall (f :: * -> *). Foldable f => f NameSet -> NameSet
Set.unions
> [ (Name -> NameSet) -> [Name] -> NameSet
forall a. (a -> NameSet) -> [a] -> NameSet
joinSymSets Name -> NameSet
fn [Name]
lhs
> | a
rl <- Name -> [a]
prodsOfName Name
n
> , let Production Name
_ [Name]
lhs ([Char], [Name])
_ Priority
_ = a -> Production
prodNo a
rl ]