Ebnf2ps-1.0.8: src/GrammarTransform.hs
-- -*- Mode: Haskell -*-
-- Copyright 1994 by Peter Thiemann
-- GrammarTransform.hs --- some transformations on parse trees
-- Author : Peter Thiemann
-- Created On : Thu Oct 21 16:44:17 1993
-- simplifying transformations on grammars
module GrammarTransform
(simplify,
happysimplify, happysimplifyExt,
yaccsimplify, yaccsimplifyExt,
freents, simp0)
where
import AbstractSyntax
import Data.List
data RInfo
= ROk [Production] [Production] Production
| RKo
simplify :: [Production] -> [Production]
simplify = map (simplify2' . simplify') . simp3
happysimplify = simp0
yaccsimplify = simp0
happysimplifyExt = (\ p -> (fst p, map (simplify2' . simplify') (snd p))) . (simp0 . simp3o)
yaccsimplifyExt = (\ p -> (fst p, map (simplify2' . simplify') (snd p))) . (simp0 . simp3o)
-- simp1 gets the body of a ProdFactor as an argument
-- and provides the transformations
-- beta { X } X gamma ---> beta (X)+ gamma
-- beta X { X } gamma ---> beta (X)+ gamma
-- beta { X Y } X gamma ---> beta (X)/ (Y) gamma
-- beta X { Y X } gamma ---> beta (X)/ (Y) gamma
simp1 [] = []
simp1 [p] = [p]
simp1 (ProdRepeat p:p':prods)
| p `eqProduction` p' = ProdRepeat1 p: simp1 prods
simp1 (p:ProdRepeat p':prods)
| p `eqProduction` p' = ProdRepeat1 p: simp1 prods
simp1 (ProdRepeat (ProdFactor [p1, p2]):p:prods)
| p1 `eqProduction` p = ProdRepeatWithAtom p p2: simp1 prods
simp1 (p:ProdRepeat (ProdFactor [p1, p2]):prods)
| p `eqProduction` p2 = ProdRepeatWithAtom p p1: simp1 prods
simp1 (p:prods) = p: simp1 prods
-- simp2'r gets the body of a ProdTerm as an argument
-- and provides the transformations (slow)
-- gamma X | delta X ---> (gamma | delta) X
-- gamma X | X ---> [gamma] X
-- X | gamma X ---> [gamma| X
rightpart2'r [p] x = (x `eqProduction` p, [])
rightpart2'r ps x =
let l = last ps
n = length ps
in (x `eqProduction` l, init ps)
rightParts rest rest' =
let l' = last rest'
in case (rightpart2'r rest l') of
(True, front) -> ROk front (init rest') l'
(False, _) -> RKo
simp2'r' term@(ProdTerm prods) =
let res = simplifier term
in case res of
(ProdFactor _) -> res
(ProdTerm ps) -> ProdTerm (simp2'r ps)
_ -> term
simp2'r (first@(ProdFactor (p:rest)): next@(ProdFactor (p':rest')): more) =
case (rest, rest') of
([], [])
| p `eqProduction` p' -> simp2'r (ProdFactor [p]: more)
| otherwise -> first: simp2'r (next:more)
([], _) -> case (rightpart2'r rest' p) of
(True,front) -> simp2'r (ProdFactor [ProdOption (ProdFactor (p':front)), p] : more)
(False,_) -> first: simp2'r (next:more)
(_, []) -> case (rightpart2'r rest p') of
(True, front) -> simp2'r (ProdFactor [ProdOption (ProdFactor (p:front)),p']: more)
(False,_) -> first: simp2'r (next:more)
(_, _) -> case (rightParts rest rest') of
RKo -> first: simp2'r (next: more)
(ROk front1 front2 l) -> let t = simp2'r' (ProdTerm [ProdFactor (p:front1), ProdFactor (p':front2)])
in simp2'r (ProdFactor [t,l] : more)
simp2'r [p] = [p]
simp2'r [] = []
-- simp2 gets the body of a ProdTerm as an argument
-- and provides the transformations
-- X gamma | X delta ---> X (gamma | delta)
-- X gamma | X ---> X [ gamma ]
-- X | X gamma ---> X [ gamma ]
getPrefixes ps1@(p1:_:_) ps2@(p2:_:_) firsts
| p1 `eqProduction` p2 = getPrefixes (tail ps1) (tail ps2) (firsts++[p1])
getPrefixes ps1 ps2 firsts = (firsts, ps1, ps2)
lookahead x more = partition (la x) more
where la x (ProdFactor (p:_)) = x `eqProduction` p
la x _ = False
simplifier term@(ProdTerm [a,b]) =
case (a,b) of
(ProdFactor [ProdTerm psa@(x:y:_)], ProdFactor [ProdTerm psb@(x':y':_)]) -> ProdTerm (psa++psb)
(ProdFactor [ProdTerm psa@(x:y:_)], _) -> ProdTerm (psa++[b])
(_, ProdFactor [ProdTerm psb@(x':y':_)]) -> ProdTerm (a:psb)
(_,_) -> term
simplifier term = term
simp2' term@(ProdTerm prods) =
let res = simplifier term
in case res of
(ProdFactor _) -> res
(ProdTerm ps) -> ProdTerm (simp2 ps)
_ -> term
simp2 (ProdFactor (p:rest): next@(ProdFactor (p':rest')): more)
| p `eqProduction` p' = case (rest, rest') of
([], []) -> simp2 (ProdFactor [p]: more)
([], _) -> case (lookahead p more) of
([],_) -> simp2 (ProdFactor [p, ProdOption (ProdFactor rest')]: more)
(others,more') -> simp2 ((next:others)++(ProdFactor [p]:more'))
(_, []) -> simp2 (ProdFactor [p, ProdOption (ProdFactor rest)]: more)
(_, _) -> let (firsts,rs,rs') = getPrefixes rest rest' []
pfirsts = p:firsts
next = simp2' (ProdTerm [ProdFactor rs, ProdFactor rs'])
in simp2 ((ProdFactor (pfirsts++[next])):more)
| otherwise = ProdFactor (p:rest): simp2 (ProdFactor (p':rest'):more)
simp2 [p] = [p]
simp2 [] = []
-- simp3 gets a list of ProdProductions and looks for left and right recursive productions
-- it executes the transformations
-- A -> A gamma_1 | ... | A gamma_k | delta
-- --->
-- A -> delta { gamma_1 | ... | gamma_k }
-- and
-- A -> gamma_1 A | ... | gamma_k A | delta
-- --->
-- A -> { gamma_1 | ... | gamma_k } delta
leftParty nt (ProdTerm ps) = foldr f ([], []) ps
where f (ProdFactor (ProdNonterminal nt':rest)) (yes, no)
| nt == nt' = (ProdFactor rest:yes, no)
f p (yes, no) = (yes, p:no)
simp3'l prod@(ProdProduction nt nts p@(ProdTerm _))
= case leftParty nt p of
(lefties@(_:_), others@(_:_)) ->
ProdProduction nt nts
(ProdFactor [ProdTerm others, ProdRepeat (ProdTerm lefties)])
_ -> prod
simp3'l prod = prod
rightParty nt (ProdTerm ps) = foldr f ([], []) ps
where f (ProdFactor ps) (yes, no)
| length ps > 1 && rightmost nt ps = (ProdFactor (init ps):yes, no)
f p (yes, no) = (yes, p:no)
rightmost nt [ProdNonterminal nt'] = nt == nt'
rightmost nt [p] = False
rightmost nt (p:ps) = rightmost nt ps
simp3'r prod@(ProdProduction nt nts p@(ProdTerm _))
= case rightParty nt p of
(righties@(_:_), others@(_:_)) ->
ProdProduction nt nts
(ProdFactor [ProdRepeat (ProdTerm righties), ProdTerm others])
_ -> prod
simp3'r prod = prod
simp3 :: [Production] -> [Production]
simp3 = map (simp3'r . simp3'l)
-- [happyInput && yaccInput]
-- simp0 gets a list of productions and looks for empty productions on the right
-- side of happy rule and provides the transformations
-- N -> X | . ---> N -> [X].
-- and N -> X1 | X2 | ... | Xk | . ---> N -> [X1| X2 | ... | Xk].
simp0' prod@(ProdProduction nt nts p@(ProdTerm prods)) =
case (partition (\p -> not (p `eqProduction` emptyProd)) prods) of
([], _) -> ([nt], ProdProduction nt nts ProdEmpty)
(prods', []) -> ([],prod)
(prods', (x:_)) -> ([], ProdProduction nt nts (ProdOption (ProdTerm prods')))
where emptyProd = ProdFactor []
simp0' prod = ([],prod)
simp0 prods = foldr f ([],[]) (map simp0' prods)
where f ([],p) (nts,ps) = (nts,p:ps)
f ([n],p) (nts,ps) = (n:nts,p:ps)
-- [happyInput && yaccInput]
-- simp3o gets a list of ProdProductions and looks for left and right recursive productions
-- it executes the transformations
simp3o :: [Production] -> [Production]
simp3o = map (simp3o'r . simp3o'l)
-- [simp3o'l]
-- A -> A gamma_1 | ... | A gamma_k | delta --> A -> delta { gamma_1 | ... | gamma_k }
-- A -> A gamma_1 | ... | A gamma_k | 'empty' --> A -> { gamma_1 | ... | gamma_k }
--
-- A -> A gamma_1 | ... | A gamma_k | delta_1 | ... | delta_k | 'empty'
-- -->
-- A -> [delta_1 | ... | delta_k] { gamma_1 | ... | gamma_k }
leftParty' nt (ProdTerm ps) = foldr f ([], [], False) ps
where f (ProdFactor []) (yes,no,_) = (yes,no,True)
f (ProdFactor (ProdNonterminal nt':rest)) (yes, no,emptyProds)
| nt == nt' = (ProdFactor rest:yes, no,emptyProds)
f p (yes, no,emptyProds) = (yes, p:no,emptyProds)
-- repeatWithAtom'l: X {delta X} --> X / delta
repeatWithAtom'l prod@(ProdFactor [p1,p2]) =
case (p1,p2) of
(front@(ProdTerm [ProdFactor [x]]), ProdRepeat (ProdTerm [ProdFactor p2s@(a:b:_)])) ->
if (last p2s) `eqProduction` x
then ProdRepeatWithAtom front (ProdFactor (init p2s))
else prod
_ -> prod
repeatWithAtom'l p = p
simp3o'l prod@(ProdProduction nt nts p@(ProdTerm _))
= case leftParty' nt p of
(lefties@(_:_), [], _) ->
ProdProduction nt nts
(ProdRepeat (ProdTerm lefties))
(lefties@(_:_), others@(_:_), True) ->
ProdProduction nt nts
(ProdFactor [ProdOption (ProdTerm others), ProdRepeat (ProdTerm lefties)])
(lefties@(_:_), others@(_:_), False) ->
ProdProduction nt nts
(repeatWithAtom'l (ProdFactor [ProdTerm others, ProdRepeat (ProdTerm lefties)]))
_ -> prod
simp3o'l prod = prod
-- [simp3o'r]
-- A -> gamma_1 A | ... | gamma_k A | delta --> A -> { gamma_1 | ... | gamma_k } delta
-- A -> gamma_1 A | ... | gamma_k A | 'empty' --> A -> { gamma_1 | ... | gamma_k }
-- A -> gamma_1 A | ... | gamma_k A | delta_1 | ... | delta_k | 'empty'
-- -->
-- A -> { gamma_1 | ... | gamma_k } [delta_1 | ... | delta_k]
-- repeatWithAtom'r: {X delta} X --> X / delta
repeatWithAtom'r prod@(ProdFactor [p1,p2]) =
case (p1,p2) of
(ProdRepeat (ProdTerm [ProdFactor p2s@(a:b:_)]), front@(ProdTerm [ProdFactor [x]])) ->
if a `eqProduction` x
then ProdRepeatWithAtom front (ProdFactor (tail p2s))
else prod
_ -> prod
repeatWithAtom'r p = p
rightParty' nt (ProdTerm ps) = foldr f ([], [], False) ps
where f (ProdFactor ps) (yes, no, emptyProds)
| length ps == 0 = (yes,no,True)
| length ps > 1 && rightmost nt ps = (ProdFactor (init ps):yes, no, emptyProds)
f p (yes, no,emptyProds) = (yes, p:no,emptyProds)
simp3o'r prod@(ProdProduction nt nts p@(ProdTerm _))
= case rightParty' nt p of
(righties@(_:_), [], _) ->
ProdProduction nt nts
(ProdRepeat (ProdTerm righties))
(righties@(_:_), others@(_:_), True) ->
ProdProduction nt nts
(ProdFactor [ProdRepeat (ProdTerm righties), ProdOption (ProdTerm others)])
(righties@(_:_), others@(_:_), False) ->
ProdProduction nt nts
(repeatWithAtom'r (ProdFactor [ProdRepeat (ProdTerm righties), ProdTerm others]))
_ -> prod
simp3o'r prod = prod
-- compute the set of all nonterminals in a Production
freents :: Production -> [String]
freents (ProdTerm prods) = concat (map freents prods)
freents (ProdFactor prods) = concat (map freents prods)
freents (ProdNonterminal s) = [s]
freents (ProdTerminal s) = []
freents (ProdOption p) = freents p
freents (ProdRepeat p) = freents p
freents (ProdRepeat1 p) = freents p
freents (ProdRepeatWithAtom p1 p2) = freents p1 ++ freents p2
freents (ProdPlus) = []
freents (ProdEmpty) = []
freents (ProdSlash p) = freents p
simplify' (ProdProduction s1 s2 prod) = ProdProduction s1 s2 (simplify' prod)
simplify' (ProdFactor prods) = ProdFactor (simp1 (map simplify' prods))
simplify' (ProdNonterminal s) = ProdNonterminal s
simplify' (ProdTerminal s) = ProdTerminal s
simplify' (ProdOption prod) = ProdOption (simplify' prod)
simplify' (ProdRepeat prod) = ProdRepeat (simplify' prod)
simplify' (ProdRepeat1 prod) = ProdRepeat1 (simplify' prod)
simplify' (ProdRepeatWithAtom p1 p2) = ProdRepeatWithAtom (simplify' p1) (simplify' p2)
simplify' (ProdPlus) = ProdPlus
simplify' (ProdEmpty) = ProdEmpty
simplify' (ProdSlash prod) = ProdSlash (simplify' prod)
simplify' (ProdTerm prods) = ProdTerm ((simp2 . map simplify') prods)
simplify2' (ProdProduction s1 s2 prod) = ProdProduction s1 s2 (simplify2' prod)
simplify2' (ProdFactor prods) = ProdFactor (simp1 (map simplify2' prods))
simplify2' (ProdNonterminal s) = ProdNonterminal s
simplify2' (ProdTerminal s) = ProdTerminal s
simplify2' (ProdOption prod) = ProdOption (simplify2' prod)
simplify2' (ProdRepeat prod) = ProdRepeat (simplify2' prod)
simplify2' (ProdRepeat1 prod) = ProdRepeat1 (simplify2' prod)
simplify2' (ProdRepeatWithAtom p1 p2) = ProdRepeatWithAtom (simplify2' p1) (simplify2' p2)
simplify2' (ProdPlus) = ProdPlus
simplify2' (ProdEmpty) = ProdEmpty
simplify2' (ProdSlash prod) = ProdSlash (simplify2' prod)
simplify2' (ProdTerm prods) = ProdTerm ((simp2'r . map simplify2') prods)
-- Goferisms:
eqList [] [] = True
eqList (x:xs) (y:ys) = eqProduction x y && eqList xs ys
eqList _ _ = False
eqProduction (ProdFile ps) (ProdFile ps') = eqList ps ps'
eqProduction (ProdProduction str ostr p) (ProdProduction str' ostr' p') = str == str' && ostr == ostr' && eqProduction p p'
eqProduction (ProdTerm ps) (ProdTerm ps') = eqList ps ps'
eqProduction (ProdFactor ps) (ProdFactor ps') = eqList ps ps'
eqProduction (ProdNonterminal str) (ProdNonterminal str') = str == str'
eqProduction (ProdTerminal str) (ProdTerminal str') = str == str'
eqProduction (ProdOption p) (ProdOption p') = eqProduction p p'
eqProduction (ProdRepeat p) (ProdRepeat p') = eqProduction p p'
eqProduction (ProdRepeatWithAtom p1 p2) (ProdRepeatWithAtom p1' p2') = eqProduction p1 p1' && eqProduction p2 p2'
eqProduction (ProdRepeat1 p) (ProdRepeat1 p') = eqProduction p p'
eqProduction (ProdPlus) (ProdPlus) = True
eqProduction (ProdEmpty) (ProdEmpty) = True
eqProduction (ProdSlash p) (ProdSlash p') = eqProduction p p'
eqProduction _ _ = False