-----------------------------------------------------------------------------
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.Maybe (fromMaybe)

\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.
It's a fixed point computation, we keep applying the function over the
input until it does not change.
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 -> Bool) -> (a -> a) -> a -> a
forall a. (a -> Bool) -> (a -> a) -> a -> a
until (\a
x -> a -> a -> Bool
eq a
x (a -> a
f a
x)) a -> a
f

\subsection{Implementation of FIRST}

> mkFirst :: Grammar e -> [Name] -> NameSet
> mkFirst :: forall e. Grammar e -> [Name] -> NameSet
mkFirst (Grammar { first_term :: forall eliminator. Grammar eliminator -> Name
first_term = Name
fst_term
>                  , lookupProdNo :: forall eliminator.
Grammar eliminator -> Int -> Production eliminator
lookupProdNo = Int -> Production e
prodNo
>                  , lookupProdsOfName :: forall eliminator. Grammar eliminator -> Name -> [Int]
lookupProdsOfName = Name -> [Int]
prodsOfName
>                  , non_terminals :: forall eliminator. Grammar eliminator -> [Name]
non_terminals = [Name]
nts
>                  })
>       = (Name -> NameSet) -> [Name] -> NameSet
forall a. (a -> NameSet) -> [a] -> NameSet
joinSymSets (\Name
h -> NameSet -> Maybe NameSet -> NameSet
forall a. a -> Maybe a -> a
fromMaybe (Name -> NameSet
Set.singleton Name
h) (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
-> (Int -> Production e)
-> (Name -> [Int])
-> [(Name, NameSet)]
-> [(Name, NameSet)]
forall a e.
Name
-> (a -> Production e)
-> (Name -> [a])
-> [(Name, NameSet)]
-> [(Name, NameSet)]
updateFirstSets Name
fst_term Int -> Production e
prodNo Name -> [Int]
prodsOfName) [(Name
name,NameSet
Set.empty) | Name
name <- [Name]
nts]

> updateFirstSets :: Name -> (a -> Production e) -> (Name -> [a]) -> [(Name, NameSet)]
>                 -> [(Name, NameSet)]
> updateFirstSets :: forall a e.
Name
-> (a -> Production e)
-> (Name -> [a])
-> [(Name, NameSet)]
-> [(Name, NameSet)]
updateFirstSets Name
fst_term a -> Production e
prodNo Name -> [a]
prodsOfName [(Name, NameSet)]
env = [ (Name
nm, Name -> NameSet
nextFstSet Name
nm)
>                                                   | (Name
nm,NameSet
_) <- [(Name, NameSet)]
env ]
>    where
>       terminalP :: Name -> Bool
>       terminalP :: Name -> Bool
terminalP Name
s = Name
s Name -> Name -> Bool
forall a. Ord a => a -> a -> Bool
>= Name
fst_term

>       currFstSet :: Name -> NameSet
>       currFstSet :: Name -> NameSet
currFstSet Name
s | Name
s Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
errorTok Bool -> Bool -> Bool
|| Name
s Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
catchTok Bool -> Bool -> Bool
|| Name -> Bool
terminalP Name
s = Name -> NameSet
Set.singleton Name
s
>                    | Bool
otherwise = 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
s [(Name, NameSet)]
env)

>       nextFstSet :: Name -> NameSet
>       nextFstSet :: Name -> NameSet
nextFstSet Name
s | Name -> Bool
terminalP Name
s = Name -> NameSet
Set.singleton Name
s
>                    | Bool
otherwise   = [NameSet] -> NameSet
Set.unions [ (Name -> NameSet) -> [Name] -> NameSet
forall a. (a -> NameSet) -> [a] -> NameSet
joinSymSets Name -> NameSet
currFstSet [Name]
rhs
>                                               | a
rl <- Name -> [a]
prodsOfName Name
s
>                                               , let Production Name
_ [Name]
rhs (e, [Int])
_ Priority
_ = a -> Production e
prodNo a
rl ]