{-# LANGUAGE Trustworthy #-} module AGParser2 where import Prelude hiding ((*>)) import Text.PrettyPrint.HughesPJ as PPH hiding (empty) -- ((PPH.<+>), vcat, text, render,($$),nest,Doc) import Data.List import TypeAg2 import Control.Monad import Control.Applicative hiding ((<|>), (*>)) ---- ************************************ ----------------------- type Instance = IRec data SorI = S | I |NILL deriving (Eq,Ord,Show, Enum) -- Synthesized or inherited or NILL type IRec = (SorI, Id) -- uniquely determines synthesized or inherited attribute for an NT data Useless = OF|ISEQUALTO deriving (Show, Eq) -- for decorating the semantic rules data SRule_ = NT {iden :: Id, par :: NTType} | Rule {par' :: SeqType} | DRule {par'' :: SRule_ } type NTType = Id -> InsAttVals -> M Foo type SeqType = Id -> InsAttVals -> [SemRule] -> Result -> M Foo type AltType = NTType type SemRule = (Instance,(InsAttVals, Id) -> InsAttVals) ------------ data Tree a = Leaf (a,Instance) | Branch [Tree a] | SubNode ((NodeName, Instance), (Start1,End)) deriving (Eq) type NodeName = MemoL type Start1 = (Int, InsAttVals) type Start = ((Int,InsAttVals), [String]) type End = (Int, InsAttVals) type Atts = [AttValue] -- [(AttType, AttValue)] type InsAttVals = [(Instance, Atts)] type Mtable = [(MemoL ,[(Start1,(Context,Result))] ) ] type Result = [((Start1, End),[Tree MemoL])] type State = Mtable type Context = ([MemoL],[(Int,[(MemoL, Int)])]) type M a = Start -> Context -> StateM a type Seq a = Id -> InsAttVals -> [SemRule] -> Result -> Start -> Context -> StateM a type Foo = (Context, Result) -- ============================ newtype StateM t = State { unState :: State -> (t,State) } instance Functor StateM where fmap = liftM instance Applicative StateM where pure = return (<*>) = ap -- defined in Control.Monad instance Monad StateM where -- defines state propagation State m >>= k = State (\s -> let (a,y) = m s in unState (k a) y) return k = State (\s -> (k,s)) -- extracts the state from the monad get :: StateM State get = State (\s -> (s,s)) put :: State -> StateM () put s = State (\_ -> ((),s)) modify :: (State -> State) -> StateM () modify sf = State (\s -> ((), sf s)) -- ============================= --------------- ******************************************** --------------------------- (<|>) :: AltType -> AltType -> AltType (p <|> q) idx inhx ((i,a),inp) c = do (l1,m) <- p idx inhx ((i,[]),inp) c (l2,n) <- q idx inhx ((i,[]),inp) c return ((union (fst l1) (fst l2),[]) ,(m ++ n)) -------------------------------------------------------- (*>) :: SeqType -> SeqType -> SeqType (p *> q) idx inhx semx resx ((i,a),inp) cc = do (l,m) <- p idx inhx semx resx ((i,[]),inp) cc let passCtxt e = if e == i then cc else empty_cuts mergeCuts e prev new = if e == i then (union prev new) else prev apply_to_all q [] l cc = return ((fst l,[]),[]) apply_to_all q (r:rs) l cc = do (l1,m) <- q `add_P` (r,cc) (l2,n) <- apply_to_all q rs l cc return ((union (fst l1) (fst l2),[]),( m ++ n)) q `add_P` (rp,cc) = do let e = pickEnd rp (l1,m) <- (q idx inhx semx resx (e,inp) (passCtxt (fst e))) return ((mergeCuts (fst e) (fst l) (fst l1),[]),(addP m rp)) (apply_to_all q m l cc) -- CHANGE cc HERE pickEnd (((s,iA),(e,a)),t) = (e,[]) addP [] ((s1,e1),t1) = [] addP ((((s2,inA2),(e2,synA2)),t2):restQ) (((s1,inA1),(e1,synA1)),t1) = (((s1,[]),(e2,[])), a_P_Q_branch) : addP restQ (((s1,inA1),(e1,synA1)),t1) where a_P_Q_branch = addToBranch (((s2,inA2),(e2,synA2)),t2) (((s1,inA1),(e1,synA1)),t1) -------- ************* --------------- addToBranch (q1,((SubNode (name2,q)):ts2)) (p1,((SubNode (name1,p)):ts1)) = [Branch [(SubNode (name1,p)),(SubNode (name2,q))]] addToBranch (q1,((Branch t2):ts2)) (p1,((Branch t1):ts1)) = [Branch (t1++t2)] addToBranch (q1,((Branch t2):ts)) (p1,((SubNode (name1,p)):ts1)) = [Branch ((SubNode (name1,p)):t2)] addToBranch (q1,((SubNode (name2,q)):ts2)) (p1,((Branch t1):ts)) = [Branch (t1++[(SubNode (name2,q))])] addToBranch (q1,((SubNode (name2,q)):ts2)) (p1,[Leaf (x,i)]) = [Branch [(SubNode ((x,i) ,p1)),(SubNode (name2,q))]] addToBranch (q1,[Leaf (x,i)]) (p1,((SubNode (name1,p)):ts1)) = [Branch [(SubNode (name1,p)),(SubNode ((x,i),q1))]] addToBranch (q1,((Branch t2):ts)) (p1,[Leaf (x,i)]) = [Branch ((SubNode ((x,i),p1)):t2)] addToBranch (q1,[Leaf (x,i)]) (p1,((Branch t1):ts)) = [Branch (t1++[(SubNode ((x,i),q1))])] addToBranch (q1,[Leaf (x2,i2)]) (p1,[Leaf (x1,i1)]) = [Branch [(SubNode ((x1,i1),p1)),(SubNode ((x2,i2),q1))]] -------- ************* --------------- empty_cuts = ([],[]) empty :: [(Instance, Atts)] -> M Foo empty atts (x,inp) l = return (empty_cuts,[((x,(fst x,atts)), [Leaf (Emp, (NILL,O0))])]) term :: String -> Instance -> [(Instance, Atts)] -> [(Instance, Atts)] -> M Foo term c id atts iatts ((r,a),dInp) l |r - 1 == length dInp = return (empty_cuts,[]) |dInp!!(r - 1) == c = return (empty_cuts,[(((r,[]),(r+1,atts)),[Leaf (ALeaf c, id)])]) |otherwise = return (empty_cuts,[]) memoize name f id downAtts ((inp,dAtts),dInput) context = do s <- get case (lookupT name inp (snd context) s) of Just lRes -> do let lookUpRes = addNode name (S, id) (inp,downAtts) (snd1 lRes) return (fst1 lRes,lookUpRes) Nothing | funccount (snd context) inp name > (length dInput) - inp + 1 -> return (([name],[]),[]) | otherwise -> do let iC = ([],(incContext (snd context) name inp)) (l,newRes) <- f id downAtts ((inp,dAtts),dInput) iC -- let ((l,newRes),s1) = unState (f id downAtts (inp,dAtts) iC) s let l1 = makeContext (fst l) (findContext (snd context) inp) s1 <- get let udtTab = udt (l1,newRes) s1 name (inp,downAtts) let newFoundRes = addNode name (S, id) (inp,downAtts) newRes put udtTab return ( l1 ,newFoundRes) findContext [] inp = [] findContext ((st,rest):sr) inp| st == inp = [(st,rest)] | otherwise = findContext sr inp funccount [] inp name = 0 funccount ((key,funcp):rest) inp name | key == inp = findf funcp | otherwise = funccount rest inp name where findf [] = 0 findf ((tk,fc):rx) | tk == name = fc | otherwise = findf rx fst1 [(a,b)] = a snd1 [(a,b)] = b makeContext [] [(st,((n,c):ncs))] = ([],[]) makeContext (r:rs) [] = ((r:rs),[]) makeContext [] [] = ([],[]) makeContext (r:rs) [(st,((n,c):ncs))] = ((r:rs), [(st,makeContext_ (r:rs) ((n,c):ncs))]) makeContext_ [] ((n,c):ncs) = [] makeContext_ (r:rs) ((n,c):ncs) = makeContext__ r ((n,c):ncs) ++ makeContext_ rs ((n,c):ncs) makeContext__ r [] = [] makeContext__ r ((n,c):ncs) | r == n = (n,c): makeContext__ r ncs | otherwise = makeContext__ r ncs incContext [] name inp = [(inp,[(name,1)])] incContext ((st,((n,c):nc)):sn) name inp | st == inp = ((st, (addNT ((n,c):nc)) name inp ) :sn) | otherwise = ((st,((n,c):nc)): incContext sn name inp ) addNT [] name inp = [(name,1)] addNT ((n,c):nc) name inp | n == name = ((n,(c + 1)):nc) | otherwise = ((n,c):addNT nc name inp) addNode name id (s',dA) [] = [] addNode name id (s',dA) oldRes -- ((((s,newIh),(e,atts)),t):rs) = let res = packAmb oldRes newSh x = [ ((sOri, snd id),attVal)| ((sOri, idOld),attVal)<- x] in [(((s,newIh),(e, newSh atts)),[SubNode ((name, id),((s,nub dA),(e, newSh atts)))]) | (((s,newIh),(e,atts)),t) <- oldRes] mapName i [] = [] mapName i ((i',r):rest) = (i,r): mapName i rest packAmb [] = [] packAmb [((s1,e1),t1)] = [((s1,e1),t1)] packAmb [((s1,e1),t1),((s2,e2),t2)] | isEq (s1,e1) (s2,e2) = [((s2,(fst e2, groupAtts (snd e1 ++ snd e2))), t1++t2)] | otherwise = [((s1,e1),t1),((s2,e2),t2)] packAmb (((s1,e1),t1):((s2,e2),t2):xs) | isEq (s1,e1) (s2,e2) = packAmb (((s2,(fst e2, groupAtts (snd e1 ++ snd e2))), t1++t2):xs) | otherwise = ((s1,e1),t1):packAmb (((s2,e2),t2):xs) isEq ((s1,b1),(e1,y1)) ((s2,b2),(e2,y2)) | s1 == s2 && e1 == e2 = True | otherwise = False lookupT name inp context mTable | lookupT1 name inp context mTable == [] = Nothing | otherwise = Just (lookupT1 name inp context mTable) lookupT1 name inp context mTable | res_in_table == [] = [] | otherwise = checkUsability inp context (lookupRes (res_in_table !! 0) inp) where res_in_table = [pairs|(n,pairs) <- mTable,n == name] lookupRes [] inp = [] lookupRes (((i,dA),res):rs) inp | i == inp = [res] | otherwise = lookupRes rs inp checkUsability inp context [] = [] checkUsability inp context [((re,sc),res)] | re == [] = [((re,sc),res)] | otherwise = checkUsability_ (findInp inp context) (findInp inp sc) [((re,sc),res)] findInp inp [] = [] findInp inp ((s,c):sc) | s == inp = c | otherwise = findInp inp sc checkUsability_ [] [] [(sc,res)] = [(sc,res)] checkUsability_ ((n,cs):ccs) [] [(sc,res)] = [(sc,res)] -- if lc at j is empty then re-use checkUsability_ [] ((n1,cs1):scs) [(sc,res)] = [] -- if cc at j is empty then don't re-use checkUsability_ ((n,cs):ccs) ((n1,cs1):scs) [(sc,res)] | and $ condCheck ((n,cs):ccs) ((n1,cs1):scs) = [(sc,res)] | otherwise = [] condCheck ((n,cs):ccs) [(n1,cs1)] = [condCheck_ ((n,cs):ccs) (n1,cs1)] condCheck ((n,cs):ccs) ((n1,cs1):scs) = condCheck_ ((n,cs):ccs) (n1,cs1) : condCheck ((n,cs):ccs) scs condCheck_ [] (n1,cs1) = False condCheck_ ((n,cs):ccs) (n1,cs1) | n1 == n && cs >= cs1 = True | n1 == n && cs < cs1 = False | otherwise = condCheck_ ccs (n1,cs1) udt :: (Context, Result) -> State -> MemoL -> Start1 -> State udt res mTable name (inp,dAtts) = update mTable name (inp,dAtts) res update [] name (inp,dAtts) res = [(name,[((inp,dAtts), res)])] update ((key, pairs):rest) name (inp,dAtts) res | key == name = (key,my_merge (inp,dAtts) res pairs):rest | otherwise = ((key, pairs): update rest name (inp,dAtts) res ) my_merge (inp,dAtts) res [] = [((inp,nub dAtts), res)] my_merge (inp,dAtts) res (((i,dA), es):rest) |inp == i = ((inp,nub dAtts{-nub (dA ++ dAtts)-}), res):rest |otherwise = ((i,dA), es): my_merge (inp,dAtts) res rest pickResult ((c,r),t) = r --------------- ************************* semantics of ATTRIBUTE GRAMMAR ************************* -------------------------- terminal syn semRules id inhAtts ((i,a),inp) c = do syn (S,id) [((S,id),semRules)] inhAtts ((i,[]),inp) c nt :: NTType -> Id -> SeqType nt fx idx id inhAtts semRules altFromSibs = let groupRule'' id rules = [rule | (ud,rule) <- rules, id == ud] ownInAtts = mapInherited (groupRule'' (I, idx) semRules) altFromSibs inhAtts id in fx idx ownInAtts parser :: SeqType -> [SemRule] -> Id -> InsAttVals -> M Foo parser synRule semRules id inhAtts i c = do s <- get let ((e,altFromSibs),d) = let sRule = groupRule'' (S, LHS) semRules ((l,newRes),st) = unState ((synRule id inhAtts semRules altFromSibs) i c) s groupRule'' id rules = [rule | (ud,rule) <- rules, id == ud] in ((l, mapSynthesize sRule newRes inhAtts id),st) put d return (e,altFromSibs) mapSynthesize [] res downAtts id = res mapSynthesize sems res downAtts id = let appSems' [] vals = [] appSems' (r:rules) vals = let [((ud, id'), atts)] = r (vals, id) in [((ud, id), atts)] ++ appSems' rules vals in [(((st,inAtts), (en,appSems' sems (findAtts t))),[t]) |(((st,inAtts), (en,synAtts)),[t]) <- res] -- mapSem' [] _ _ = [] mapInherited sems res [] id = let appSems [] vals = [] appSems (r:rules) vals = r (vals, id) ++ appSems rules vals in concat [appSems sems (findAtts t) | (((st,inAtts), (en,synAtts)),[t]) <- res] mapInherited sems [] downAtts id = let appSems [] vals = [] appSems (r:rules) vals = r (vals, id) ++ appSems rules vals in appSems sems downAtts -- concat ( map (appSems id sems) (group downAtts)) mapInherited sems res downAtts id = let appSems [] vals = [] appSems (r:rules) vals = r (vals, id) ++ appSems rules vals in concat [appSems sems ((groupAtts downAtts) ++ synAtts ++ (findAtts t)) | (((st,inAtts), (en,synAtts)),[t]) <- res] -------------------------------------- gMax [] = [] gMax [(a,[b])] = [(a,[b])] gMax [(a,[b]),(a1,[b1])] | getAVAL b >= getAVAL b1 = [(a,[b])] | otherwise = [(a1,[b1])] gMax ((a,[b]):(a1,[b1]):rest) | getAVAL b >= getAVAL b1 = gMax ((a,[b]):rest) | otherwise = gMax ((a1,[b1]):rest) groupAtts [] = [] groupAtts [(a,b)] = [(a,b)] groupAtts [(a,b),(a1,b1)] = [(a,b++b1)] groupAtts ((a,b):(a1,b1):rest) = (a,b++b1): groupAtts rest -------------------------------------- findAtts (Branch (t:ts)) = findAtts t ++ findAtts (Branch ts) findAtts (SubNode ((n,i),((s,v'),(e,v)))) = v' ++ v findAtts (Leaf (a,id)) = [] findAtts (Branch []) = [] addAtts x y = x ++ y -------------------------------------------------------- rule_i = rule I rule_s = rule S rule s_or_i typ oF pID isEq userFun listOfExp = let formAtts id spec = (id, (forNode id . spec)) forNode id atts = [(id, atts)] resType = userFun listOfExp in formAtts (s_or_i,pID) (setAtt (typ undefined) . resType) ---- **** ----- synthesized = valOf S inherited = valOf I valOf :: SorI -> (a -> AttValue) -> Useless -> Id -> [(Instance, Atts)] -> Id -> [AttValue] valOf ud typ o_f x ivs x' | x == LHS = getAttVals (ud , x') ivs typ | otherwise = getAttVals (ud , x ) ivs typ getAttVals :: Instance -> [(Instance, Atts)] -> (a -> AttValue) -> [AttValue] getAttVals x ((i,v):ivs) typ = let typeCheck typ t = if (typ undefined) == t then True else False getAttVals_ typ (t:tvs) = if (typ undefined) == t then (t :getAttVals_ typ tvs) else getAttVals_ typ tvs getAttVals_ typ [] = [] -- ErrorVal {-- 100 --} "ERROR id found but no value" in if(i == x) then getAttVals_ typ v else getAttVals x ivs typ getAttVals x [] typ = [ErrorVal {-- 200 --} "ERROR no id"] -------- ************************************** ------------ ------------------------- user functions ------------------ apply :: [(Instance,Atts)] -> Id -> ([(Instance,Atts)] -> Id -> AttValue) -> Int apply y i x = getAVAL (x y i) apply_ y i x = getB_OP (x y i) apply__ :: [(Instance,Atts)] -> Id -> ([(Instance,Atts)] -> Id -> AttValue) -> DisplayTree apply__ y i x = getRVAL (x y i) applyMax y i x = getAVAL (foldr (getMax) (MaxVal 0) (x y i)) getMax x y = MaxVal (max (getAVAL x) (getAVAL y)) findMax spec = \(atts,i) -> MaxVal (foldr (max) 0 (map (applyMax atts i) spec)) convertRep spec = \(atts,i) -> RepVal (foldr (max) 0 (map (applyMax atts i) spec)) makeTree (x:xs) = \(atts,i) -> Res (B (map (apply__ atts i) (x:xs))) mt [a,b,c] = (B [a,b,c]) mt [a] = (B [a]) ----------- for arithmetic expr ----------------- applyBiOp [e1,op,e2] = \atts -> VAL ((getAtts getB_OP atts op ) (getAtts getAVAL atts e1 ) (getAtts getAVAL atts e2)) getAtts f (y,i) x = f (head (x y i)) ----------- general copy ------------------------ copy [b] = \(atts,i) -> head (b atts i) getTypVal ((a,b):abs) t | a undefined == t = b t | otherwise = getTypVal abs t ----------- for arithmetic expr ----------------- toTree [b] = \(atts,i) -> Res (N ((map (apply atts i) [b])!!0)) -- JUNK TEST ----- -------- MAIN ---------- --------------- EXAMPLE EX-SPEC FOR TREE-REPLACEMENT ---------------- start = memoize Start (parser (nt tree T0) [ rule_i RepVal OF T0 ISEQUALTO convertRep [synthesized MaxVal OF T0] ] ) tree = memoize Tree ( parser (nt tree T1 *> nt tree T2 *> nt num T3) [ rule_s MaxVal OF LHS ISEQUALTO findMax [ synthesized MaxVal OF T1, synthesized MaxVal OF T2, synthesized MaxVal OF T3 ], rule_i RepVal OF T1 ISEQUALTO convertRep [inherited RepVal OF LHS], rule_i RepVal OF T2 ISEQUALTO convertRep [inherited RepVal OF LHS], rule_i RepVal OF T3 ISEQUALTO convertRep [inherited RepVal OF LHS] ] <|> parser (nt num N1) [ rule_i RepVal OF N1 ISEQUALTO convertRep [inherited RepVal OF LHS], rule_s MaxVal OF LHS ISEQUALTO findMax [synthesized MaxVal OF N1] ] ) num = memoize Num ( terminal (term "1") [MaxVal 1] <|> terminal (term "2") [MaxVal 2] <|> terminal (term "3") [MaxVal 3] <|> terminal (term "4") [MaxVal 4] <|> terminal (term "5") [MaxVal 5] ) ------------------------------------------------ Arithmetic Expression ------------------------------------------------ eT = memoize ET ( parser (nt expr E1) [rule_s VAL OF LHS ISEQUALTO copy [synthesized VAL OF E1]] ) expr = memoize Expr ( parser (nt expr E1 *> nt op O1 *> nt expr E2) [rule_s VAL OF LHS ISEQUALTO applyBiOp [synthesized VAL OF E1, synthesized B_OP OF O1, synthesized VAL OF E2] ] <|> parser (nt num N1) [rule_s VAL OF LHS ISEQUALTO copy [synthesized MaxVal OF N1]] ) op = memoize Op ( terminal (term "+") [B_OP (+)] <|> terminal (term "-") [B_OP (-)] <|> terminal (term "*") [B_OP (*)] <|> terminal (term "/") [B_OP (div)] ) ------------------------------------------------ Arithmetic Expression ------------------------------------------------ ----------- PrettyPrint ------------------------ po :: (PP' a) => (String -> IO ()) -> a -> IO () po act x = do stuff <- pp' x act $ render80 stuff render80 = renderStyle (style{lineLength = 80}) class PP' a where pp' :: a -> IO Doc instance PP' Doc where pp' c = return c instance PP' Char where pp' c = return $ text $ show c instance PP' AttValue where pp' (VAL i) = showio (VAL i) >>= return . text pp' (B_OP i)= showio (B_OP i) >>= return .text instance PP' Int where pp' i = return $ text $ show i instance PP' Id where pp' i = return $ text $ show i instance PP' a => PP' (Maybe a) where pp' Nothing = return $ text "Nothing" pp' (Just x) = pp' x >>= (\y -> return $ parens $ text "Just" PPH.<+> y) instance (PP' a, PP' b) => PP' (a,b) where -- pp' (a,b) = parens $ pp' a PPH.<+> text "->" PPH.<+> pp' b pp' (a,b) = pp' a >>= \z -> (pp' b >>= (\y -> return $ z PPH.<+> text "->" PPH.<+> y)) instance PP' a => PP' [a] where pp' [] = return $ brackets $ text "" pp' (x:xs) = liftM sep $ (liftM2 (:)) (pp' x) (sequence [ pp' y | y <- xs ]) instance (Show t) => PP' (Tree t) where -- pp' Empty = text "{_}" pp' (Leaf x) = return $ text "Leaf" PPH.<+> text (show x) pp' (Branch ts) = liftM2 (PPH.<+>) (return $ text "Branch") (liftM brackets $ liftM sep $ liftM (punctuate comma) $ sequence $ map pp' ts) --pp' (SubNode (x,(s,e))) = return $ text "SubNode" PPH.<+> text (show x) PPH.<+> text (show (s,e)) -- PPH.<+> pp' ts {-TODO: format :: Mtable -> Doc format t = vcat [ text (show s) $$ nest 3 (pp' [text "START at:" PPH.<+> pp' i PPH.<+> text "; Inherited atts:" PPH.<+> vcat [vcat [text (showID id0) PPH.<+> vcat [text (show ty0v0) |ty0v0 <-val0]|(id0,val0)<-inAt1]] PPH.<+> text "" $$ vcat [{- text "Inherited Atts. -" $$ vcat [vcat [text (showID id1) PPH.<+> vcat [text (show ty1v1) |ty1v1<-val1]|(id1,val1)<-(nub inAtt2)]] $$-} nest 3 ( text "END at:" PPH.<+> pp' end $$ text "Synthesized Atts. -" $$ vcat [vcat [text (showID id1) PPH.<+> vcat [text (show ty1v1) |ty1v1<-val1]|(id1,val1)<-synAtts]] $$ text "Packed Tree -" $$ pp' ts) |(((st,inAtt2),(end,synAtts)), ts)<-rs] | ((i,inAt1),((cs,ct),rs)) <- sr ]) | (s,sr) <- t ] -} showID (x,y) = show y -- only the instance --- ** printing ony own atts ** --- {-TODO: formatAtts :: MemoL -> Mtable -> Doc formatAtts key t = vcat [ text (show s) $$ nest 3 (pp' [text "START at:" PPH.<+> pp' i PPH.<+> text "; Inherited atts:" PPH.<+> vcat [vcat [text (showID id0) PPH.<+> vcat [text (show ty0v0) |ty0v0 <-val0]|(id0,val0)<-inAt1]] PPH.<+> text "" $$ vcat [nest 3 ( text "END at:" PPH.<+> pp' end $$ text "Synthesized Atts. -" $$ vcat [vcat [text (showID id1) PPH.<+> vcat [text (show ty1v1) |ty1v1<-val1]|(id1,val1)<-synAtts]] -- $$ text "Packed Tree -" {- $$ pp' ts -} ) |(((st,inAtt2),(end,synAtts)), ts)<-rs] | ((i,inAt1),((cs,ct),rs)) <- sr ]) | (s,sr) <- t, s == key ] -} formatAttsFinalAlt :: MemoL -> Int -> State -> IO [Doc] formatAttsFinalAlt key e t = --return [pp' [vcat [(vcat [vcat [vcat [text (show ty1v1) |ty1v1<-val1] sequence [(sequence [liftM vcat $ sequence [(liftM vcat $ sequence [liftM vcat $ sequence [liftM vcat $ sequence [liftM text (showio ty1v1) | ty1v1<-val1] |(id1,val1)<-synAtts]] ) |(((st,inAtt2),(end,synAtts)), ts)<-rs, end == e] | ((i,inAt1),((cs,ct),rs)) <- sr ]) >>= pp' | (s,sr) <- t, s == key ] {-formatAttsFinal key t = [(pp' [vcat [(vcat [vcat [vcat [text (show ty1v1) |ty1v1<-val1]|(id1,val1)<-synAtts]] )|(((st,inAtt2),(end,synAtts)), ts)<-rs] | ((i,inAt1),((cs,ct),rs)) <- sr ]) | (s,sr) <- t, s == key ]-} -- *************** for printing the fist element of the return pair *************** {-TODO: formatForFst ::Result -> Doc formatForFst res = vcat -- [text (show ty0v0) |ty0v0 <-val0]|(id0,val0)<-inAt1]] PPH.PPH.<+> text "" $$ vcat [ text "START at:" PPH.<+> pp' st {- $$ text "Inherited Atts. -" $$ vcat [vcat [text (showID id1) PPH.<+> vcat [text (show ty1v1) |ty1v1<-val1]|(id1,val1)<-inAtt2]] -} PPH.<+> text "END at:" PPH.<+> pp' end $$ nest 3 (text "Synthesized Atts. of" PPH.<+> vcat [vcat [text (showID id1) PPH.<+> text "::" PPH.<+> vcat [text (show ty1v1) |ty1v1<-val1]|(id1,val1)<-synAtts]] $$ pp' ts) |(((st,inAtt2),(end,synAtts)), ts)<-res] -} -- *************** for printing the fist element of the return pair *************** ----------- PrettyPrint --------------------------