ZipperAG 0.2 → 0.3
raw patch · 10 files changed
+1493/−2 lines, 10 files
Files
- ZipperAG.cabal +4/−2
- src/Language/Grammars/ZipperAG/Examples/Algol68.hs +137/−0
- src/Language/Grammars/ZipperAG/Examples/BreadthFirst.hs +71/−0
- src/Language/Grammars/ZipperAG/Examples/DESK.hs +154/−0
- src/Language/Grammars/ZipperAG/Examples/DESK_HighOrder.hs +190/−0
- src/Language/Grammars/ZipperAG/Examples/DESK_circular.hs +294/−0
- src/Language/Grammars/ZipperAG/Examples/DESK_references.hs +158/−0
- src/Language/Grammars/ZipperAG/Examples/HTMLTableFormatter.hs +315/−0
- src/Language/Grammars/ZipperAG/Examples/RepMin.hs +62/−0
- src/Language/Grammars/ZipperAG/Examples/SmartParentesis.hs +108/−0
ZipperAG.cabal view
@@ -1,5 +1,5 @@ Name: ZipperAG-Version: 0.2+Version: 0.3 Cabal-Version: >= 1.2 License: BSD3 Author: Pedro Martins <pedromartins4@gmail.com>@@ -15,6 +15,8 @@ Library Build-Depends: base >= 2 && <= 4.6.0.1, syz- Exposed-modules: Language.Grammars.ZipperAG+ Exposed-modules: Language.Grammars.ZipperAG, Language.Grammars.ZipperAG.Examples.Algol68, Language.Grammars.ZipperAG.Examples.BreadthFirst+ Language.Grammars.ZipperAG.Examples.DESK_circular, Language.Grammars.ZipperAG.Examples.DESK_HighOrder, Language.Grammars.ZipperAG.Examples.DESK_references, Language.Grammars.ZipperAG.Examples.DESK, Language.Grammars.ZipperAG.Examples.HTMLTableFormatter, Language.Grammars.ZipperAG.Examples.RepMin, Language.Grammars.ZipperAG.Examples.SmartParentesis hs-source-dirs: src +
+ src/Language/Grammars/ZipperAG/Examples/Algol68.hs view
@@ -0,0 +1,137 @@++{-# LANGUAGE DeriveDataTypeable #-}++module BLOCK_NewAG where++import Data.Data+import Data.Generics.Zipper+import Data.Maybe++data Root = Root Its+ deriving (Typeable, Show, Data)++data Its = ConsIts It Its+ | NilIts+ deriving (Show, Typeable, Data)++data It = Decl String+ | Use String+ | Block Its+ deriving (Show, Typeable, Data)++constructor :: (Typeable a) => Zipper a -> String+constructor a = case ( getHole a :: Maybe Its ) of+ Just (ConsIts _ _) -> "ConsIts"+ Just (NilIts) -> "NilIts"+ otherwise -> case ( getHole a :: Maybe It ) of+ Just (Decl _) -> "Decl"+ Just (Use _) -> "Use"+ Just (Block _) -> "Block"+ otherwise -> case ( getHole a :: Maybe Root) of + Just (Root _) -> "Root"+ otherwise -> error "Naha, that production does not exist!"++(.$) :: Zipper a -> Int -> Zipper a+z .$ 1 = let d = down' z+ in case d of+ Just x -> x+ Nothing -> error "You are going to a child that does not exist (1)!"+z .$ n = let r = right (z.$(n-1))+ in case r of+ Just x -> x+ Nothing -> error "You are going to a child that does not exist (2)!"++value z = case (getHole z :: Maybe It) of+ Just (Use x) -> x+ Just (Decl x) -> x++-- Tests if z is the n'th sibling+(.|) :: Zipper a -> Int -> Bool+z .| 1 = case (left z) of+ Nothing -> False+ _ -> True+z .| n = case (left z) of+ Nothing -> False+ Just x -> z .| (n-1)++parent z = let a = up z+ in case a of+ Just x -> x+ Nothing -> error "You are asking for the parent of the TopMost Tree!"++---- Synthesized Attributes ----+dclo :: Zipper Root -> [(String, Int)]+dclo z = case (constructor z) of+ "ConsIts" -> dclo $ z.$2+ "NilIts" -> dcli z+ "Use" -> dcli z+ "Decl" -> (value z,lev z) : (dcli z)+ "Block" -> dcli z++errs :: Zipper Root -> [String]+errs z = case (constructor z) of+ "Root" -> errs $ z.$1 + "NilIts" -> []+ "ConsIts" -> (errs $ z.$1) ++ (errs $ z.$2)+ "Use" -> mBIn (value z) (env z)+ "Decl" -> mNBIn (value z,lev z) (dcli z)+ "Block" -> errs $ z.$1++---- Inheritted Attributes ----+dcli :: Zipper Root -> [(String, Int)] +dcli z = case (constructor z) of+ "Root" -> []+ "NilIts" -> case (constructor $ parent z) of+ "ConsIts" -> dclo $ (parent z).$1+ "Block" -> env $ parent z+ "Root" -> []+ "ConsIts" -> case (constructor $ parent z) of+ "ConsIts" -> dclo $ (parent z).$1+ "Block" -> env $ parent z+ "Root" -> []+ "Block" -> dcli $ parent z+ "Use" -> dcli $ parent z+ "Decl" -> dcli $ parent z++lev :: Zipper Root -> Int+lev z = case (constructor z) of+ "Root" -> 0+ "NilIts" -> case (constructor $ parent z) of+ "Block" -> (lev $ parent z) + 1+ "ConsIts" -> lev $ parent z+ "Root" -> 0+ "ConsIts" -> case (constructor $ parent z) of+ "Block" -> (lev $ parent z) + 1+ "ConsIts" -> lev $ parent z+ "Root" -> 0+ "Block" -> lev $ parent z+ "Use" -> lev $ parent z+ "Decl" -> lev $ parent z++env :: Zipper Root -> [(String, Int)]+env z = case (constructor z) of+ "NilIts" -> case (constructor $ parent z) of+ "Block" -> dclo z+ "ConsIts" -> env $ parent z+ "Root" -> dclo z+ "ConsIts" -> case (constructor $ parent z) of+ "Block" -> dclo z+ "ConsIts" -> env $ parent z+ "Root" -> dclo z+ "Block" -> env $ parent z+ "Use" -> env $ parent z+ "Decl" -> env $ parent z+ "Root" -> dclo z++--program = [Decl "y", Decl "x", Block [Decl "y", Use "y", Use "w"], Decl "x", Use "y"]+block = Block (ConsIts (Decl "x") (ConsIts (Use "y") (ConsIts (Use "w") (NilIts))))+program = ConsIts (Decl "y") (ConsIts (Decl "x") (ConsIts (block) (ConsIts (Decl "x") (ConsIts (Use "y") (NilIts)))))++{- Environment lookup functions -}+mBIn name [] = [name]+mBIn name ((n,l):es) = if (n==name) then [] else mBIn name es++mNBIn tuple [] = [] +mNBIn pair (pl:es) = if pair==pl then [fst pair] else mNBIn pair es++semantics t = errs $ toZipper $ Root t
+ src/Language/Grammars/ZipperAG/Examples/BreadthFirst.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE DeriveDataTypeable #-}++module BreadthFirst where++import Data.Data+import Data.Generics.Zipper+import Data.Maybe+import Debug.Trace++data Root = Root Tree+ deriving (Show, Typeable, Data)++data Tree = Fork Int Tree Tree | Empty+ deriving (Show, Typeable, Data)++constructor :: (Typeable a) => Zipper a -> String+constructor a = case ( getHole a :: Maybe Root) of+ Just (Root _) -> "Root"+ _ -> case (getHole a :: Maybe Tree) of+ Just (Fork _ _ _) -> "Fork"+ Just (Empty) -> "Empty"++(.$) :: Zipper a -> Int -> Zipper a+z .$ 1 = let d = down' z+ in case d of+ Just x -> x+ Nothing -> error "You are going to a child that does not exist (1)!"+z .$ n = let r = right (z.$(n-1))+ in case r of+ Just x -> x+ Nothing -> error "You are going to a child that does not exist (2)!"++-- Tests if z is the n'th sibling+(.|) :: Zipper a -> Int -> Bool+z .| n = n == (aux z)+ where aux z = case (left z) of+ Nothing -> 1+ Just _ -> 1 + aux (fromJust $ left z)++parent z = let a = up z+ in case a of+ Just x -> x+ Nothing -> error "You are asking for the parent of the TopMost Tree!"++-- Attributes+slist :: Zipper Root -> [Int]+slist z = case (constructor z) of+ "Fork" -> (head (ilist z) + 1) : (slist $ z.$3)+ "Empty" -> ilist z++replace :: Zipper Root -> Tree+replace z = case (constructor z) of+ "Empty" -> Empty+ "Fork" -> Fork (head $ ilist z) (replace $ z.$2) (replace $ z.$3)+ "Root" -> replace $ z.$1++ilist :: Zipper Root -> [Int]+ilist z = case (constructor $ parent z) of+ "Root" -> [1] ++ (slist z)+ _ -> case (z.|3) of -- If it is the third child, it is the rightmost one+ True -> slist (fromJust (left z))+ False -> tail (ilist $ parent z)++tree = Fork 4 (Fork 8 Empty Empty) (Fork 2 (Fork 4 Empty Empty) Empty)++semantics = replace $ toZipper (Root tree)+++++
+ src/Language/Grammars/ZipperAG/Examples/DESK.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE DeriveDataTypeable #-}++module DESK_NewAG where++import Data.Maybe+import Data.Data+import Prelude+import Data.Generics.Zipper++data Root = Root Program+ deriving (Show, Typeable, Data)++data Program = PRINT Expression ConstPart+ deriving (Show, Typeable, Data)++{- Keeping it simple by just having sums -}+data Expression = Add Expression Factor+ | Fact Factor+ deriving (Show, Typeable, Data)++data Factor = Name ConstName+ | Number String+ deriving (Show, Typeable, Data)++data ConstName = Id String+ deriving (Show, Typeable, Data)+{-----------------------------------------}+data ConstPart = EmptyConstPart+ | WHERE ConstDefList+ deriving (Show, Typeable, Data)++data ConstDefList = Comma ConstDefList ConstDef+ | Def ConstDef+ deriving (Show, Typeable, Data)++data ConstDef = Equal ConstName String+ deriving (Show, Typeable, Data)++type SymbolTable = [(String,String)]++constructor :: Zipper Root -> String+constructor a = case ( getHole a :: Maybe Program ) of+ Just (PRINT _ _) -> "PRINT"+ otherwise -> case ( getHole a :: Maybe Expression ) of+ Just (Add _ _) -> "Add"+ Just (Fact _) -> "Fact"+ otherwise -> case ( getHole a :: Maybe Factor ) of+ Just (Name _) -> "Name"+ Just (Number _) -> "Number"+ otherwise -> case ( getHole a :: Maybe ConstName ) of+ Just (Id _) -> "Id"+ otherwise -> case ( getHole a :: Maybe ConstPart ) of+ Just (EmptyConstPart) -> "EmptyConstPart"+ Just (WHERE _) -> "WHERE"+ otherwise -> case ( getHole a :: Maybe ConstDefList ) of+ Just (Comma _ _) -> "Comma"+ Just (Def _) -> "Def"+ otherwise -> case ( getHole a :: Maybe ConstDef ) of+ Just (Equal _ _) -> "Equal"+ otherwise -> case ( getHole a :: Maybe Root) of+ Just (Root _) -> "Root"+ _ -> "That production does not exist!"++-- Gives the n'th child+(.$) :: Zipper a -> Int -> Zipper a+z .$ 1 = fromJust (down' z)+z .$ n = fromJust (right ( z.$(n-1) ))++-- Tests if z is the n'th sibling+(.|) :: Zipper a -> Int -> Bool+z .| 1 = case (left z) of+ Nothing -> False+ _ -> True+z .| n = case (left z) of+ Nothing -> False+ Just x -> z .| (n-1)++parent = fromJust.up++lexeme :: Zipper Root -> String+lexeme t = case ( getHole t :: Maybe ConstName ) of+ Just (Id x) -> x+ _ -> case( getHole t :: Maybe ConstDef ) of+ Just (Equal _ x) -> x+ _ -> case ( getHole t :: Maybe Factor ) of+ Just (Number x) -> x++---- AG ----++---- Inherited -----+envi t = case (constructor t) of+ "PRINT" -> envs ( t.$2 )+ _ -> envi (parent t)++---- Synthesized ----+code :: Zipper Root -> String+code t = case (constructor t) of+ "Root" -> code ( t.$1 )+ "PRINT" -> if ok ( t.$2 )+ then code ( t.$1 ) ++ "PRINT, 0\n" ++ "HALT, 0\n"+ else "HALT, 0\n"+ "Add" -> if (ok ( t.$2 ))+ then code ( t.$1 ) ++ "ADD, " ++ value ( t.$2 ) ++ "\n"+ else "HALT, 0\n"+ "Fact" -> if (ok ( t.$1 ))+ then "LOAD, " ++ value ( t.$1 ) ++ "\n"+ else "HALT, 0\n"++value :: Zipper Root -> String+value t = case (constructor t) of+ "Name" -> getValue (name ( t.$1 )) (envi t)+ "Number" -> lexeme t+ "Equal" -> lexeme t++ok :: Zipper Root -> Bool+ok t = case (constructor t) of+ "Name" -> isInST (name ( t.$1 )) (envi t)+ "Number" -> True+ "EmptyConstPart" -> True+ "WHERE" -> ok ( t.$1 )+ "Comma" -> ok ( t.$1 ) && (not (isInST (name ( t.$2 )) (envs ( t.$1 ))) )+ "Def" -> True++name :: Zipper Root -> String+name t = case (constructor t) of+ "Id" -> lexeme t+ "Equal" -> name $ (t.$1)++envs :: Zipper Root -> SymbolTable +envs t = case (constructor t) of+ "EmptyConstPart" -> []+ "WHERE" -> envs( t.$1 )+ "Comma" -> envs( t.$1 ) ++ [(name ( t.$2 ), value ( t.$2 ))]+ "Def" -> [( name ( t.$1 ), value ( t.$1) )]++{-Semantic Functions-}+isInST :: String -> SymbolTable -> Bool+isInST _ [] = False +isInST c ((a,b):xs) = if (c==a) then True else isInST c xs++getValue :: String -> SymbolTable -> String+getValue c ((a,b):xs) = if (c==a) then b else (getValue c xs)++{---------------Tests---------------}+expr = Add (Add (Fact (Name (Id "x"))) (Name (Id "y"))) (Number "1")+deflst = WHERE (Comma (Def (Equal (Id "x") ("2"))) (Equal (Id "y") ("3")))+program = Root (PRINT expr deflst)++--PRINT x + y + 1 WHERE y = 2, x = 3++semantics t = putStrLn ("\n" ++ (code (toZipper t)))+++
+ src/Language/Grammars/ZipperAG/Examples/DESK_HighOrder.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE DeriveDataTypeable #-}++module DESK_NewAG where++import Data.Maybe+import Data.Data+import Prelude+import Data.Generics.Zipper++data Root = Root Program+ deriving (Show, Typeable, Data)++data Program = PRINT Expression ConstPart+ deriving (Show, Typeable, Data)++{- Keeping it simple by just having sums -}+data Expression = Add Expression Factor+ | Fact Factor+ deriving (Show, Typeable, Data)++data Factor = Name ConstName+ | Number String+ deriving (Show, Typeable, Data)++data ConstName = Id String+ deriving (Show, Typeable, Data)+{-----------------------------------------}+data ConstPart = EmptyConstPart+ | WHERE ConstDefList+ deriving (Show, Typeable, Data)++data ConstDefList = Comma ConstDefList ConstDef+ | Def ConstDef+ deriving (Show, Typeable, Data)++data ConstDef = Equal ConstName String+ deriving (Show, Typeable, Data)++-- HO Symbol Table+data SymbolTable = NilST+ | ConsST Tuple SymbolTable+ deriving (Show, Typeable, Data)++data Tuple = Tuple String String+ deriving (Show, Typeable, Data)++constructor :: Zipper Root -> String+constructor a = case ( getHole a :: Maybe Program ) of+ Just (PRINT _ _) -> "PRINT"+ otherwise -> case ( getHole a :: Maybe Expression ) of+ Just (Add _ _) -> "Add"+ Just (Fact _) -> "Fact"+ otherwise -> case ( getHole a :: Maybe Factor ) of+ Just (Name _) -> "Name"+ Just (Number _) -> "Number"+ otherwise -> case ( getHole a :: Maybe ConstName ) of+ Just (Id _) -> "Id"+ otherwise -> case ( getHole a :: Maybe ConstPart ) of+ Just (EmptyConstPart) -> "EmptyConstPart"+ Just (WHERE _) -> "WHERE"+ otherwise -> case ( getHole a :: Maybe ConstDefList ) of+ Just (Comma _ _) -> "Comma"+ Just (Def _) -> "Def"+ otherwise -> case ( getHole a :: Maybe ConstDef ) of+ Just (Equal _ _) -> "Equal"+ otherwise -> case ( getHole a :: Maybe Root) of+ Just (Root _) -> "Root"+ _ -> "That production does not exist!"++constructor_HO :: Zipper Root_HO -> String+constructor_HO a = case ( getHole a :: Maybe SymbolTable) of+ Just (NilST) -> "NilST"+ Just (ConsST _ _) -> "ConsST"+ otherwise -> case ( getHole a :: Maybe Tuple) of+ Just (Tuple _ _) -> "Tuple"+ otherwise -> case ( getHole a :: Maybe Root_HO ) of+ Just (Root_HO _) -> "Root_HO"+ _ -> error "Ups!!"++-- Gives the n'th child+(.$) :: Zipper a -> Int -> Zipper a+z .$ 1 = fromJust (down' z)+z .$ n = fromJust (right ( z.$(n-1) ))++-- Tests if z is the n'th sibling++parent = fromJust.up++lexeme :: Zipper Root -> String+lexeme t = case ( getHole t :: Maybe ConstName ) of+ Just (Id x) -> x+ _ -> case( getHole t :: Maybe ConstDef ) of+ Just (Equal _ x) -> x+ _ -> case ( getHole t :: Maybe Factor ) of+ Just (Number x) -> x+++---- AG ----++---- Inherited -----+envi :: Zipper Root -> SymbolTable+envi t = case (constructor t) of+ "PRINT" -> envs ( t.$2 )+ _ -> envi (parent t)++---- Synthesized ----+code :: Zipper Root -> String+code t = case (constructor t) of+ "Root" -> code ( t.$1 )+ "PRINT" -> if ok ( t.$2 )+ then code ( t.$1 ) ++ "PRINT, 0\n" ++ "HALT, 0\n"+ else "HALT, 0\n"+ "Add" -> if (ok ( t.$2 ))+ then code ( t.$1 ) ++ "ADD, " ++ value ( t.$2 ) ++ "\n"+ else "HALT, 0\n"+ "Fact" -> if (ok ( t.$1 ))+ then "LOAD, " ++ value ( t.$1 ) ++ "\n"+ else "HALT, 0\n"++value :: Zipper Root -> String+value t = case (constructor t) of+ "Name" -> getValue (name $ t.$1 ) (toZipper ( Root_HO (envi t) ))+ "Number" -> lexeme t+ "Equal" -> lexeme t++ok :: Zipper Root -> Bool+ok t = case (constructor t) of+ "Name" -> isInST (name $ t.$1) (toZipper (Root_HO (envi t) ))+ "Number" -> True+ "EmptyConstPart" -> True+ "WHERE" -> ok ( t.$1 )+ "Comma" -> ok ( t.$1 ) && (not (isInST (name $ t.$2) (toZipper ( Root_HO (envs $ t.$1) ) ) ) )+ "Def" -> True++name :: Zipper Root -> String+name t = case (constructor t) of+ "Id" -> lexeme t+ "Equal" -> name ( t.$1 )++envs :: Zipper Root -> SymbolTable+envs t = case (constructor t) of+ "EmptyConstPart" -> NilST+ "WHERE" -> envs( t.$1 )+ "Comma" -> ConsST (Tuple (name $ t.$2) (value $ t.$2) ) (envs $ t.$1)+ "Def" -> ConsST (Tuple (name $ t.$1) (value $ t.$1) ) NilST++{- High Order Symbol Table -}++data Root_HO = Root_HO SymbolTable+ deriving (Data, Show, Typeable)++lexeme_Tuple_name :: Zipper Root_HO -> String+lexeme_Tuple_name z = case ( getHole z :: Maybe Tuple ) of+ Just(Tuple a b) -> a++lexeme_Tuple_value :: Zipper Root_HO -> String+lexeme_Tuple_value z = case ( getHole z :: Maybe Tuple ) of+ Just(Tuple a b) -> b++isInST :: String -> Zipper Root_HO -> Bool+isInST name z = case (constructor_HO z) of+ "Root_HO" -> isInST name (z.$1)+ "NilST" -> False+ "ConsST" -> (isInST name (z.$1)) || (isInST name (z.$2))+ "Tuple" -> lexeme_Tuple_name z == name++-- It won't ever happen to ask for the getValue Attr when it+-- does not exist, because we have tested it before with the Attr ok+getValue :: String -> Zipper Root_HO -> String+getValue name z = case (constructor_HO z) of+ "Root_HO" -> getValue name (z.$1)+ "ConsST" -> if ((lexeme_Tuple_name (z.$1)) == (name)) + then (lexeme_Tuple_value $ z.$1) + else (getValue name (z.$2))++{---------------Tests---------------}++expr = Add (Add (Fact (Name (Id "x"))) (Name (Id "y"))) (Number "1")+deflst = WHERE (Comma (Def (Equal (Id "x") ("2"))) (Equal (Id "y") ("3")))+program = Root (PRINT expr deflst)++--PRINT x + y + 1 WHERE y = 2, x = 3++semantics t = putStrLn ("\n" ++ (code (toZipper t)))++++++
+ src/Language/Grammars/ZipperAG/Examples/DESK_circular.hs view
@@ -0,0 +1,294 @@++{-# LANGUAGE DeriveDataTypeable #-}++module DESK_NewAG where+import Data.Maybe+import Data.Data+import Prelude+import Data.Generics.Zipper++data Root = Root Program+ deriving (Show, Typeable, Data)++data Program = PRINT Expression ConstPart+ deriving (Show, Typeable, Data)++{- Keeping it simple by just having sums -}+data Expression = Add Expression Factor+ | Fact Factor+ deriving (Show, Typeable, Data)++data Factor = Name ConstName+ | Number Int+ deriving (Show, Typeable, Data)++data ConstName = Id String+ deriving (Show, Typeable, Data)+{-----------------------------------------}+data ConstPart = EmptyConstPart+ | WHERE ConstDefList+ deriving (Show, Typeable, Data)++data ConstDefList = Comma ConstDefList ConstDef+ | Def ConstDef+ deriving (Show, Typeable, Data)++data ConstDef = EqualInt ConstName Int+ | EqualString ConstName String+ deriving (Show, Typeable, Data)++---- AG ----+---- Inherited -----+-- Defined as autocopy in Silver+envi :: Zipper Root -> Zipper Root_HO+envi t = case (constructor t) of+ "PRINT" -> let h_o = toZipper (Root_HO (envs $ t.$2) )+ in solve h_o+ autocopy -> envi (parent t)++---- Synthesized ----+code :: Zipper Root -> String+code t = case (constructor t) of+ "Root" -> code ( t.$1 )+ "PRINT" -> if ok ( t.$2 )+ then code ( t.$1 ) ++ "PRINT, 0\n" ++ "HALT, 0\n"+ else "HALT, 0\n"+ "Add" -> if (ok ( t.$2 ))+ then code ( t.$1 ) ++ "ADD, " ++ show (value ( t.$2 )) ++ "\n"+ else "HALT, 0\n"+ "Fact" -> if (ok ( t.$1 ))+ then "LOAD, " ++ show (value ( t.$1 )) ++ "\n"+ else "HALT, 0\n"++value :: Zipper Root -> Int+value t = case (constructor t) of+ "Name" -> getValue (name $ t.$1) (envi t)+ "Number" -> lexeme_Number t++ok :: Zipper Root -> Bool+ok t = case (constructor t) of+ "Name" -> isInST (name $ t.$1) (envi t)+ "Number" -> True+ "EmptyConstPart" -> True+ "WHERE" -> ok ( t.$1 )+ "Comma" -> ok ( t.$1 ) && not ( isInST (name $ t.$2) (toZipper ( Root_HO (envs $ t.$1)) ) )+ "Def" -> True++name :: Zipper Root -> String+name t = case (constructor t) of+ "Id" -> lexeme_Id t+ "EqualInt" -> name ( t.$1 )+ "EqualString" -> name ( t.$1 )++envs :: Zipper Root -> SymbolTable +envs t = case (constructor t) of+ "EmptyConstPart" -> NilST+ "WHERE" -> envs( t.$1 )+ "Comma" -> ConsST (extract $ t.$2) (envs $ t.$1)+ "Def" -> ConsST (extract $ t.$1) NilST++extract :: Zipper Root -> Tuple+extract t = case (constructor t) of+ "EqualInt" -> TupleInt (name $ t.$1) (lexeme_Equal_Int t)+ "EqualString" -> TupleString (name $ t.$1) (lexeme_Equal_String t)++{- High Order Symbol Table -}+data Root_HO = Root_HO SymbolTable+ deriving (Data, Show, Typeable)++data SymbolTable = NilST+ | ConsST Tuple SymbolTable+ deriving (Show, Typeable, Data)++data Tuple = TupleInt String Int+ | TupleString String String+ deriving (Show, Typeable, Data)++-- The Attr isInST depends on the Attr solve, which means it will never+-- work with an unsolved symbol table+--isInST :: String -> Zipper a -> Bool+isInST :: String -> Zipper Root_HO -> Bool+isInST var z = case (constructor_HO z) of+ "Root_HO" -> isInST var (z.$1)+ "NilST" -> False+ "ConsST" -> (isInST var (z.$1)) || (isInST var (z.$2))+ "TupleInt" -> lexeme_Tuple_name z == var+ "TupleString" -> lexeme_Tuple_name z == var++-- The Attr isInST depends on the Attr solve, which means it will never+-- work with an unsolved symbol table +-- We'll never ask for the getValue Attr if it does not+-- exist, because we have tested it before with the Attr ok+getValue :: String -> Zipper Root_HO -> Int+getValue var z = case (constructor_HO z) of+ "Root_HO" -> getValue var (z.$1)+ "ConsST" -> if (lexeme_Tuple_name $ z.$1) == var + then (lexeme_Tuple_Int_Value $ z.$1) + else getValue (var) (z.$2)++-- circular attribute+solve :: Zipper Root_HO -> Zipper Root_HO+solve z = case (constructor_HO z) of + "Root_HO" -> if (isSolved z)+ then z+ else solve $ toZipper ( Root_HO (auxSolve $ z.$1))+ autocopy -> solve $ parent z++auxSolve :: Zipper Root_HO -> SymbolTable+auxSolve z = case (constructor_HO z) of+ "Root_HO" -> auxSolve $ z.$1+ "NilST" -> NilST+ "ConsST" -> ConsST (check $ z.$1) (auxSolve $ z.$2)++check :: Zipper Root_HO -> Tuple+check z = case (constructor_HO z) of+ "TupleInt" -> lexeme_Tuple_Int z+ "TupleString" -> apply (solvedSymbols z) (lexeme_Tuple_String z)++-- Auxiliary function apply+apply :: [(String, Int)] -> Tuple -> Tuple+apply [] t = t+apply ((a,b):xs) t@(TupleString name assign) = if (a == assign)+ then (TupleInt name b)+ else apply xs t++-- There are two attributes to get the solved symbols, because+-- this way we have the warantee the result comes from a full traverse+solvedSymbols :: Zipper Root_HO -> [(String, Int)]+solvedSymbols z = case (constructor_HO z) of+ "Root_HO" -> auxSolvedSymbols $ z.$1+ autocopy -> solvedSymbols $ parent z++auxSolvedSymbols :: Zipper Root_HO -> [(String, Int)]+auxSolvedSymbols z = case (constructor_HO z) of+ "ConsST" -> auxSolvedSymbols (z.$1) ++ auxSolvedSymbols (z.$2)+ "NilST" -> []+ "TupleInt" -> [(lexeme_Tuple_name z, lexeme_Tuple_Int_Value z)]+ "TupleString" -> []++-- There are two attributes to see if the symbol table is solved, because+-- this way we have the warantee the result comes from a full traverse +isSolved :: Zipper Root_HO -> Bool+isSolved z = case (constructor_HO z) of+ "Root_HO" -> auxIsSolved $ z.$1+ autocopy -> isSolved $ parent z++auxIsSolved :: Zipper Root_HO -> Bool+auxIsSolved z = case (constructor_HO z) of+ "Root_HO" -> auxIsSolved $ z.$1+ "ConsST" -> (auxIsSolved $ z.$1) && (auxIsSolved $ z.$2)+ "NilST" -> True+ "TupleInt" -> True+ "TupleString" -> False+{---------------Tests---------------}++expr = Add (Add (Fact (Name (Id "x"))) (Name (Id "y"))) (Number 1)+deflst = WHERE (Comma (Comma (Def ((EqualString (Id "x") "y"))) (EqualInt (Id "z") 2)) (EqualString (Id "y") "z"))+program = Root (PRINT expr deflst)+--PRINT x + y + 1 WHERE x = y, z = 2, y = z++semantics t = putStrLn ("\n" ++ (code (toZipper t)))+++++++++++++++-- -- -- Zipper-based AG supporting functions++-- Gives the n'th child+(.$) :: Zipper a -> Int -> Zipper a+z .$ 1 = fromJust (down' z)+z .$ n = fromJust (right ( z.$(n-1) ))++-- parent+parent = fromJust.up++-- Tests if z is the n'th sibling+(.|) :: Zipper a -> Int -> Bool+z .| 1 = case (left z) of+ Nothing -> False+ _ -> True+z .| n = case (left z) of+ Nothing -> False+ Just x -> z .| (n-1)+++-- -- -- Boilerplate code+constructor :: (Typeable a) => Zipper a -> String+constructor a = case ( getHole a :: Maybe Program ) of+ Just (PRINT _ _) -> "PRINT"+ otherwise -> case ( getHole a :: Maybe Expression ) of+ Just (Add _ _) -> "Add"+ Just (Fact _) -> "Fact"+ otherwise -> case ( getHole a :: Maybe Factor ) of+ Just (Name _) -> "Name"+ Just (Number _) -> "Number"+ otherwise -> case ( getHole a :: Maybe ConstName ) of+ Just (Id _) -> "Id"+ otherwise -> case ( getHole a :: Maybe ConstPart ) of+ Just (EmptyConstPart) -> "EmptyConstPart"+ Just (WHERE _) -> "WHERE"+ otherwise -> case ( getHole a :: Maybe ConstDefList ) of+ Just (Comma _ _) -> "Comma"+ Just (Def _) -> "Def"+ otherwise -> case ( getHole a :: Maybe ConstDef ) of+ Just (EqualInt _ _) -> "EqualInt"+ Just (EqualString _ _) -> "EqualString"+ otherwise -> case ( getHole a :: Maybe Root) of+ Just (Root _) -> "Root"+ _ -> "That production does not exist!"+++lexeme_Id t = case ( getHole t :: Maybe ConstName ) of+ Just (Id x) -> x++lexeme_Number t = case ( getHole t :: Maybe Factor ) of+ Just (Number x) -> x++lexeme_Equal_Int t = case ( getHole t :: Maybe ConstDef ) of+ Just (EqualInt _ x) -> x++lexeme_Equal_String t = case ( getHole t :: Maybe ConstDef ) of+ Just (EqualString _ x) -> x++-- boilerplate code for the high order attr+constructor_HO :: (Typeable a) => Zipper a -> String+constructor_HO a = case ( getHole a :: Maybe SymbolTable) of+ Just (NilST) -> "NilST"+ Just (ConsST _ _) -> "ConsST"+ otherwise -> case ( getHole a :: Maybe Tuple) of+ Just (TupleInt _ _) -> "TupleInt"+ Just (TupleString _ _) -> "TupleString"+ otherwise -> case ( getHole a :: Maybe Root_HO ) of+ Just (Root_HO _) -> "Root_HO"+ _ -> error "Ups!!"++lexeme_Root z = case ( getHole z :: Maybe Root_HO ) of+ Just(Root_HO a) -> a+ +lexeme_Tuple_name z = case ( getHole z :: Maybe Tuple ) of+ Just(TupleInt a b) -> a+ Just(TupleString a b) -> a++lexeme_Tuple_Int z = case ( getHole z :: Maybe Tuple ) of+ Just(TupleInt a b) -> TupleInt a b+ +lexeme_Tuple_String z = case ( getHole z :: Maybe Tuple ) of+ Just(TupleString a b) -> TupleString a b+ +lexeme_Tuple_Int_Value z = case ( getHole z :: Maybe Tuple ) of+ Just(TupleInt a b) -> b++lexeme_Tuple_String_Value z = case ( getHole z :: Maybe Tuple ) of+ Just(TupleString a b) -> b++
+ src/Language/Grammars/ZipperAG/Examples/DESK_references.hs view
@@ -0,0 +1,158 @@++{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}++module DESK_NewAG where+import Data.Maybe+import Data.Data+import Prelude hiding (head, tail, zip)+import Data.Generics.Zipper++data Root = Root Program+ deriving (Show, Typeable, Data)++data Program = PRINT Expression ConstPart+ deriving (Show, Typeable, Data)++{- Keeping it simple by just having sums -}+data Expression = Add Expression Factor+ | Fact Factor+ deriving (Show, Typeable, Data)++data Factor = Name ConstName+ | Number String+ deriving (Show, Typeable, Data)++data ConstName = Id String+ deriving (Show, Typeable, Data)+{-----------------------------------------}+data ConstPart = EmptyConstPart+ | WHERE ConstDefList+ deriving (Show, Typeable, Data)++data ConstDefList = Comma ConstDefList ConstDef+ | Def ConstDef+ deriving (Show, Typeable, Data)++data ConstDef = Equal ConstName String+ deriving (Show, Typeable, Data)++type SymbolTable = [(String,Zipper Root)]++constructor :: Zipper Root -> String+constructor a = case ( getHole a :: Maybe Program ) of+ Just (PRINT _ _) -> "PRINT"+ otherwise -> case ( getHole a :: Maybe Expression ) of+ Just (Add _ _) -> "Add"+ Just (Fact _) -> "Fact"+ otherwise -> case ( getHole a :: Maybe Factor ) of+ Just (Name _) -> "Name"+ Just (Number _) -> "Number"+ otherwise -> case ( getHole a :: Maybe ConstName ) of+ Just (Id _) -> "Id"+ otherwise -> case ( getHole a :: Maybe ConstPart ) of+ Just (EmptyConstPart) -> "EmptyConstPart"+ Just (WHERE _) -> "WHERE"+ otherwise -> case ( getHole a :: Maybe ConstDefList ) of+ Just (Comma _ _) -> "Comma"+ Just (Def _) -> "Def"+ otherwise -> case ( getHole a :: Maybe ConstDef ) of+ Just (Equal _ _) -> "Equal"+ otherwise -> case ( getHole a :: Maybe Root) of+ Just (Root _) -> "Root"+ _ -> "That production does not exist!"++-- Gives the n'th child+(.$) :: Zipper a -> Int -> Zipper a+z .$ 1 = fromJust (down' z)+z .$ n = fromJust (right ( z.$(n-1) ))++-- Tests if z is the n'th sibling+(.|) :: Zipper a -> Int -> Bool+z .| 1 = case (left z) of+ Nothing -> False+ _ -> True+z .| n = case (left z) of+ Nothing -> False+ Just x -> z .| (n-1)++parent = fromJust.up++lexeme :: Zipper Root -> String+lexeme t = case ( getHole t :: Maybe ConstName ) of+ Just (Id x) -> x+ _ -> case( getHole t :: Maybe ConstDef ) of+ Just (Equal _ x) -> x+ _ -> case ( getHole t :: Maybe Factor ) of+ Just (Number x) -> x+++---- AG ----++---- Inherited -----+envi :: Zipper Root -> SymbolTable+envi t = case (constructor t) of+ "PRINT" -> envs ( t.$2 )+ _ -> envi (parent t)++---- Synthesized ----+code :: Zipper Root -> String+code t = case (constructor t) of+ "Root" -> code ( t.$1 )+ "PRINT" -> if ok ( t.$2 )+ then code ( t.$1 ) ++ "PRINT, 0\n" ++ "HALT, 0\n"+ else "HALT, 0\n"+ "Add" -> if (ok ( t.$2 ))+ then code ( t.$1 ) ++ "ADD, " ++ value ( t.$2 ) ++ "\n"+ else "HALT, 0\n"+ "Fact" -> if (ok ( t.$1 ))+ then "LOAD, " ++ value ( t.$1 ) ++ "\n"+ else "HALT, 0\n"++value :: Zipper Root -> String +value t = case (constructor t) of+ "Name" -> getValue (name ( t.$1 )) (envi t)+ "Number" -> lexeme t+ "Equal" -> lexeme t++ok :: Zipper Root -> Bool +ok t = case (constructor t) of+ "Name" -> isInST (name ( t.$1 )) (envi t)+ "Number" -> True+ "EmptyConstPart" -> True+ "WHERE" -> ok ( t.$1 )+ "Comma" -> ok ( t.$1 ) && (not (isInST (name ( t.$2 )) (envs ( t.$1 ))) )+ "Def" -> True++name :: Zipper Root -> String +name t = case (constructor t) of+ "Id" -> lexeme t+ "Equal" -> name ( t.$1 )++envs :: Zipper Root -> SymbolTable +envs t = case (constructor t) of+ "EmptyConstPart" -> []+ "WHERE" -> envs( t.$1 )+ "Comma" -> envs( t.$1 ) ++ [(name ( t.$2 ), t.$2 )]+ "Def" -> [( name ( t.$1 ), t.$1 )]++{-Semantic Function-}+isInST :: String -> SymbolTable -> Bool+isInST _ [] = False +isInST c ((a,b):xs) = if (c==a) then True else isInST c xs++getValue :: String -> SymbolTable -> String+getValue c ((a,b):xs) = if (c==a) then (value b) else (getValue c xs)++{---------------Tests---------------}++expr = Add (Add (Fact (Name (Id "x"))) (Name (Id "y"))) (Number "1")+deflst = WHERE (Comma (Def (Equal (Id "x") ("2"))) (Equal (Id "y") ("3")))+program = Root (PRINT expr deflst)++--PRINT x + y + 1 WHERE y = 2, x = 3++semantics t = putStrLn ("\n" ++ (code (toZipper t)))++++
+ src/Language/Grammars/ZipperAG/Examples/HTMLTableFormatter.hs view
@@ -0,0 +1,315 @@++{-# LANGUAGE DeriveDataTypeable #-}++module HTML_Table_Formatter_newAG where++import Data.Data+import Data.Generics.Zipper+import Data.Maybe++---- ABSTRACT SYNTAX GRAMMAR ----+data R = RootR Table+ deriving (Typeable, Show, Data)++data Table = RootTable Rows+ deriving (Typeable, Show, Data)++data Rows = NoRow+ | ConsRow Row Rows+ deriving (Typeable, Show, Data)++data Row = OneRow Elems+ deriving (Typeable, Show, Data)++data Elems = NoElem+ | ConsElem Elem Elems+ deriving (Typeable, Show, Data)++data Elem = TableText String+ | NestedTable Table+ deriving (Typeable, Show, Data)++constructor :: Zipper R -> String+constructor a = case ( getHole a :: Maybe R ) of+ Just (RootR _) -> "RootR"+ otherwise -> case ( getHole a :: Maybe Table ) of+ Just (RootTable _) -> "RootTable"+ otherwise -> case ( getHole a :: Maybe Rows ) of+ Just (NoRow) -> "NoRow"+ Just (ConsRow _ _) -> "ConsRow"+ otherwise -> case ( getHole a :: Maybe Row ) of+ Just (OneRow _) -> "OneRow"+ otherwise -> case ( getHole a :: Maybe Elems ) of+ Just (NoElem) -> "NoElem"+ Just (ConsElem _ _) -> "ConsElem"+ otherwise -> case ( getHole a :: Maybe Elem ) of+ Just (TableText _) -> "TableText"+ Just (NestedTable _) -> "NestedTable"+ otherwise -> error "Naha, that production does not exist!"++-- Gives the n'th child+(.$) :: Zipper a -> Int -> Zipper a+z .$ 1 = let d = down' z+ in case d of+ Just x -> x+ Nothing -> error "You are going to a child that does not exist (1)!"+z .$ n = let r = right (z.$(n-1))+ in case r of+ Just x -> x+ Nothing -> error "You are going to a child that does not exist (2)!"++-- Tests if z is the n'th sibling+(.|) :: Zipper a -> Int -> Bool+z .| 1 = case (left z) of+ Nothing -> False+ _ -> True+z .| n = case (left z) of+ Nothing -> False+ Just x -> z .| (n-1)++parent z = let a = up z+ in case a of+ Just x -> x+ Nothing -> error "You are asking for the parent of the TopMost Tree!"+++value t = case ( getHole t :: Maybe Elem ) of+ Just (TableText x) -> x+ _ -> error "You should not be asking for that value!"++-- ata is used to implement High Order+(.#.) :: Data a => (t -> a) -> t -> Zipper a+highorder_attr .#. zipper = toZipper (highorder_attr zipper) ++---- AG ----+---- Computing the number of elems per row ----+n_Syn z = case (constructor z) of+ "RootR" -> n_Syn $ z.$1+ "RootTable" -> maxList ( ns_Syn $ z.$1 )+ "OneRow" -> n_Syn $ z.$1+ "NoElem" -> 0+ "ConsElem" -> 1 + (n_Syn $ z.$2)++ns_Syn z = case (constructor z) of+ "NoRow" -> []+ "ConsRow" -> (n_Syn $ z.$1) : (ns_Syn $ z.$2)++---- Passing down the number of elements per row ----+ane_Inh z = case (constructor z) of+ "RootTable" -> n_Syn z+ "NoRow" -> case (constructor $ parent z) of+ "RootTable" -> n_Syn $ parent z+ "NoRow" -> ane_Inh $ parent z+ "ConsRow" -> ane_Inh $ parent z+ "ConsRow" -> case (constructor $ parent z) of+ "RootTable" -> n_Syn $ parent z+ "OneRow" -> ane_Inh $ parent z+ "ConsRow" -> ane_Inh $ parent z+ "OneRow" -> ane_Inh $ parent z+ "NoElem" -> case (constructor $ parent z) of+ "OneRow" -> ane_Inh $ parent z+ "ConsElem" -> (ane_Inh $ parent z) - 1+ "NoElem" -> (ane_Inh $ parent z) - 1+ "ConsElem" -> case (constructor $ parent z) of+ "OneRow" -> ane_Inh $ parent z+ "ConsElem" -> (ane_Inh $ parent z) - 1+ "NoElem" -> (ane_Inh $ parent z) - 1++---- Constructing the new table ----+r2 z = RootR (r2_table $ z.$1)++r2_table z = RootTable (r2_rows $ z.$1)++r2_rows z = case (constructor z) of+ "NoRow" -> NoRow+ "ConsRow" -> ConsRow (r2_row $ z.$1) (r2_rows $ z.$2)++r2_row z = OneRow (r2_elems $ z.$1)++r2_elems z = case (constructor z) of+ "NoElem" -> add_elems (ane_Inh z)+ "ConsElem" -> ConsElem (r2_elem $ z.$1) (r2_elems $ z.$2)++r2_elem z = case (constructor z) of+ "TableText" -> TableText (value z)+ "NestedTable" -> NestedTable (r2_table $ z.$1)++---- Computing the minimal height of each construct ----+mh_Syn z = case (constructor z) of+ "RootR" -> mh_Syn $ z.$1+ "RootTable" -> mh_Syn $ z.$1+ "NoRow" -> 0+ "ConsRow" -> (mh_Syn $ z.$1) + 1 + (mh_Syn $ z.$2)+ "OneRow" -> mh_Syn $ z.$1+ "ConsElem" -> max (mh_Syn $ z.$1) (mh_Syn $ z.$2)+ "NoElem" -> 0+ "TableText" -> 1+ "NestedTable" -> (mh_Syn $ z.$1 ) + 1++---- Computing the minimal width of each construct ----+mw_Syn z = case (constructor z) of+ "RootR" -> mw_Syn $ z.$1+ "RootTable" -> lmw_Local z -- Local attr, as defined in LRC+ "TableText" -> length (value z)+ "NestedTable" -> (mw_Syn $ z.$1) + 2++mws_Syn z = case (constructor z) of+ "NoRow" -> []+ "ConsRow" -> eq_zipwith_max (mws_Syn $ z.$1) (mws_Syn $ z.$2)+ "OneRow" -> mws_Syn $ z.$1+ "ConsElem" -> (mw_Syn $ z.$1) : (mws_Syn $ z.$2)+ "NoElem" -> []++---- LOCAL ATTRIBUTE ----+lmw_Local z = case (constructor z) of+ "RootTable" -> (sumList (mws_Syn $ z.$1)) + (lengthList (mws_Syn $ z.$1)) - 1+ "ConsRow" -> (sumList (aws_Inh z)) + (lengthList (aws_Inh z)) - 1++---- Passing down the available heights and widths ----+ah_Inh z = case (constructor z) of+ "RootR" -> mh_Syn $ z+ "RootTable" -> case (constructor $ parent z) of+ "RootR" -> ah_Inh $ parent z+ "OneElem" -> ah_Inh $ parent z+ "ConsElem" -> ah_Inh $ parent z+ "ConsElem" ->case (constructor $ parent z) of+ "OneRow" -> mh_Syn z+ "ConsElem" -> ah_Inh $ parent z+ "NoElem" -> case (constructor $ parent z) of+ "OneRow" -> mh_Syn z+ "ConsElem" -> ah_Inh $ parent z+ "TableText" -> ah_Inh $ parent z+ "NestedTable" -> ah_Inh $ parent z++aws_Inh z = case (constructor z) of+ "ConsRow" ->case (constructor $ parent z) of+ "RootTable" -> mws_Syn z+ "ConsRow" -> aws_Inh $ parent z+ "NoRow" -> case (constructor $ parent z) of+ "RootTable" -> mws_Syn z+ "ConsRow" -> aws_Inh $ parent z+ "OneRow" -> aws_Inh $ parent z+ "ConsElem" -> case (constructor $ parent z) of+ "OneRow" -> aws_Inh $ parent z+ "ConsElem" -> tailList (aws_Inh $ parent z)+ "NoElem" -> case (constructor $ parent z) of+ "OneRow" -> aws_Inh $ parent z+ "ConsElem" -> tailList (aws_Inh $ parent z)++aw_Inh z = case (constructor z) of+ "RootR" -> mw_Syn z+ "RootTable" -> case (constructor $ parent z) of+ "RootR" -> ah_Inh $ parent z+-- "TableText" -> aw_Inh $ parent z+ "NestedTable" -> aw_Inh $ parent z+ "TableText" -> headList (aws_Inh $ parent z)+ "NestedTable" -> headList (aws_Inh $ parent z)++---- Computing Formatted Table ----+lines_Syn t = let z = t+ in case (constructor z) of+ "RootR" -> lines_Syn $ z.$1+ "RootTable" -> (add_sepline (lmw_Local z)) ++ (lines_Syn $ z.$1) ++ (add_sepline (lmw_Local z))+ "NoRow" -> []+ "ConsRow" -> add_sep_line (lmw_Local z) (lines_Syn $ z.$1) (lines_Syn $ z.$2)+ "OneRow" -> add_border_line (lines_Syn $ z.$1)+ "NoElem" -> []+ "ConsElem" -> let ag = addglue (aw_Inh $ z.$1) (mw_Syn $ z.$1) (ah_Inh $ z.$1) (mh_Syn $ z.$1) (lines_Syn $ z.$1) ("align")+ in eq_zipwith_cat ag (lines_Syn $ z.$2)+ "TableText" -> value z : []+ "NestedTable" -> lines_Syn $ z.$1++---- Semantics Functions ----+sumList = sum++lengthList = length++eq_zeros = []++eq_zipwith_max :: [Int] -> [Int] -> [Int]+eq_zipwith_max [] l2 = l2+eq_zipwith_max l1 [] = l1+eq_zipwith_max (l1:l1s) (l2:l2s) = (max l1 l2) : (eq_zipwith_max l1s l2s)++maxList :: [Int] -> Int+maxList [] = 0+maxList (x:xs) = max x (maxList xs)++headList :: [Int] -> Int+headList [] = 0+headList (x:xs) = x++tailList :: [a] -> [a]+tailList [] = []+tailList (x:xs) = xs++eq_zipwith_cat :: [String] -> [String] -> [String]+eq_zipwith_cat l1 [] = l1+eq_zipwith_cat [] l2 = l2+eq_zipwith_cat (l11:l11s) (l22:l22s) = (l11 ++ "|" ++ l22) : (eq_zipwith_cat l11s l22s)++add_border_line :: [String] -> [String]+add_border_line [] = []+add_border_line (x:xs) = ("|" ++ x ++ "|") : (add_border_line xs)++--add_noborder_line :: [String] -> [String]++addglue :: Int -> Int -> Int -> Int -> [String] -> String -> [String]+addglue aw mw ah mh lineS a = (glue_horizontal aw mw lineS a) ++ (glue_vertical_new (ah-mh) (add_vertical aw))++glue_horizontal :: Int -> Int -> [String] -> String -> [String]+glue_horizontal _ _ [] _ = []+glue_horizontal aw mw (l:ls) a = (add_hor l (aw-mw) a) : (glue_horizontal aw mw ls a)++add_hor :: String -> Int -> String -> String+add_hor l aw "left" = l ++ (hor_spaces aw)+add_hor l aw "right" = (hor_spaces aw) ++ l+add_hor l aw "center" = let y = (div aw 2)+ in (hor_spaces y) ++ l ++ (hor_spaces y)+add_hor l aw _ = l ++ (hor_spaces aw)++hor_spaces :: Int -> String+hor_spaces i = if (i <= 0) then "" else (repeatChar ' ' i)++glue_vertical_new :: Int -> [String] -> [String]+glue_vertical_new n l = if (n <= 0) then [] else l ++ (glue_vertical_new (n-1) l)++add_vertical :: Int -> [String]+add_vertical aw = if (aw <= 0) then [] else (repeatChar ' ' aw) : []++add_sepline :: Int -> [String]+add_sepline aw = if (aw <= 0)+ then []+ else ["|" ++ (repeatChar '-' aw) ++ "|"]++add_sep_line :: Int -> [String] -> [String] -> [String]+add_sep_line mw l [] = l+add_sep_line mw l rest = l ++ (add_sepline mw) ++ rest++add_elems :: Int -> Elems+add_elems 0 = NoElem+add_elems n = ConsElem (TableText " ") (add_elems (n-1))++repeatChar :: Char -> Int -> String+repeatChar _ 0 = []+repeatChar c i = c : (repeatChar c (i-1)) ++---- table2nestedtable : Table -> Table++---- Tests+nestedtable = RootTable (ConsRow (OneRow (ConsElem (TableText "Some more random text!") (NoElem))) (NoRow))+elem1 = TableText "This is some text on a table!"+elem2 = TableText "And even more random text!"+row1 = ConsRow (OneRow (ConsElem (TableText "This is a big phrase etc etc.") NoElem)) (NoRow)+elem3 = ConsElem (TableText "This is a big phrase just to make sure this HTML AG etc etc.") (NoElem)++table = RootR (RootTable (ConsRow (OneRow (ConsElem (elem1) (ConsElem (NestedTable nestedtable) (NoElem)))) (ConsRow (OneRow (ConsElem (elem2) (elem3))) (row1))))++printTable :: [String] -> String+printTable [] = ""+printTable (x:xs) = x ++ "\n" ++ (printTable xs)++ata z = toZipper (r2 z)++semantics t = putStrLn $ printTable $ lines_Syn $ ata $ (toZipper t)+
+ src/Language/Grammars/ZipperAG/Examples/RepMin.hs view
@@ -0,0 +1,62 @@++{-# LANGUAGE DeriveDataTypeable#-}++module Repmin where++import Data.Maybe+import Data.Data+import Prelude+import Data.Generics.Zipper++data Root = Root Tree+ deriving (Eq, Ord, Show, Typeable, Data)++data Tree = Leaf Int+ | Fork Tree Tree+ deriving (Eq, Ord, Show, Typeable, Data)++tree = Root $ Fork (Leaf 1) + (Fork (Leaf 4)+ (Leaf 7))++constructor :: Zipper Root -> String+constructor a = case (getHole a :: Maybe Tree) of+ Just (Fork _ _) -> "Fork"+ Just (Leaf _) -> "Leaf"+ _ -> case (getHole a :: Maybe Root ) of+ Just (Root _) -> "Root"++-- infix (.$) 7+(.$) :: Zipper a -> Int -> Zipper a+z .$ 1 = fromJust (down' z)+z .$ n = fromJust (right ( z.$(n-1) ))++parent = fromJust.up++lexeme :: Zipper Root -> Int+lexeme t = let Leaf v = fromJust (getHole t :: Maybe Tree)+ in v++---- Inherited ----+globmin :: Zipper Root -> Int+globmin t = case constructor t of+ "Root" -> locmin t+ "Leaf" -> globmin $ parent t+ "Fork" -> globmin $ parent t++---- Synthesized ----+locmin :: Zipper Root -> Int+locmin t = case constructor t of + "Root" -> locmin $ t.$1+ "Leaf" -> lexeme t+ "Fork" -> min (locmin $ t.$1 ) (locmin $ t.$2 )++replace :: Zipper Root -> Tree+replace t = case constructor t of + "Root" -> replace ( t.$1 )+ "Leaf" -> Leaf (globmin t)+ "Fork" -> Fork (replace $ t.$1 ) (replace $ t.$2 )+++semantics :: Root -> Tree+semantics t = replace (toZipper t)
+ src/Language/Grammars/ZipperAG/Examples/SmartParentesis.hs view
@@ -0,0 +1,108 @@++{-# LANGUAGE DeriveDataTypeable #-}+module PP_NewAG where++import Data.Maybe+import Data.Data+import Prelude+import Data.Generics.Zipper+import Data.Data++data Root = Root Exp+ deriving (Eq, Ord, Show, Typeable, Data)++data Exp = Add Exp Exp+ | Mul Exp Exp+ | Div Exp Exp+ | Sub Exp Exp+ | Lit Int+ deriving (Eq, Ord, Show, Typeable, Data)++constructor :: Zipper Root -> String+constructor a = case (getHole a :: Maybe Exp) of+ Just (Add _ _) -> "Add"+ Just (Mul _ _) -> "Mul"+ Just (Div _ _) -> "Div"+ Just (Sub _ _) -> "Sub"+ Just (Lit _) -> "Lit"+ _ -> case (getHole a :: Maybe Root ) of+ Just (Root _) -> "Root"++-- Gives the n'th child+(.$) :: Zipper a -> Int -> Zipper a+z .$ 1 = fromJust (down' z)+z .$ n = fromJust (right ( z.$(n-1) ))++-- Tests if z is the n'th sibling+(.|) :: Zipper a -> Int -> Bool+z .| 1 = case (left z) of+ Nothing -> False+ _ -> True+z .| n = case (left z) of+ Nothing -> False+ Just x -> z .| (n-1)++parent = fromJust.up++lexeme :: Zipper Root -> Int+lexeme t = let Lit v = fromJust (getHole t :: Maybe Exp)+ in v++---- AG ----+---- Inherited Attributes ----+enclosingOpPrecedence :: Zipper Root -> Int+enclosingOpPrecedence t = case (constructor t) of+ "Root" -> 0+ "Add" -> 1+ "Sub" -> 1+ "Mul" -> 2+ "Div" -> 2++leftOrRight :: Zipper Root -> String+leftOrRight t = case (constructor t) of+ "Root" -> "none"+ "Add" -> case t.|1 of+ True -> "left"+ False -> "right"+ "Sub" -> case t.|1 of+ True -> "left"+ False -> "right"+ "Mul" -> case t.|1 of+ True -> "left"+ False -> "right"+ "Div" -> "left"++bpp :: Zipper Root -> String+bpp t = case (constructor t) of+ "Root" -> bpp (t.$1)+ "Lit" -> show (lexeme t)+ "Add" -> if (wrapInParens (enclosingOpPrecedence t) 1 (leftOrRight t) "left") + then "(" ++ (bpp ( t.$1 )) ++ "+" ++ (bpp ( t.$2 )) ++ ")"+ else (bpp ( t.$1 )) ++ "+" ++ (bpp ( t.$2 ))+ "Sub" -> if (wrapInParens (enclosingOpPrecedence t) 1 (leftOrRight t) "left")+ then "(" ++ (bpp ( t.$1 )) ++ "-" ++ (bpp ( t.$2 )) ++ ")"+ else (bpp ( t.$1 )) ++ "-" ++ (bpp ( t.$2 ))+ "Mul" -> if (wrapInParens (enclosingOpPrecedence t) 2 (leftOrRight t) "left") + then "(" ++ (bpp ( t.$1 )) ++ "*" ++ (bpp ( t.$2 )) ++ ")"+ else (bpp ( t.$1 )) ++ "*" ++ (bpp ( t.$2 ))+ "Div" -> if (wrapInParens (enclosingOpPrecedence t) 2 (leftOrRight t) "left") + then "(" ++ (bpp ( t.$1 )) ++ "/" ++ (bpp ( t.$2 )) ++ ")"+ else (bpp ( t.$1 )) ++ "/" ++ (bpp ( t.$2 ))++-- SEMANTIC FUNCTIONS --+wrapInParens enclosingP thisP thisPos opAssoc = (enclosingP > thisP) || ((enclosingP == thisP) && (thisPos /= opAssoc))++{- Simple PrettyPrinting for Exp -}+exp2str :: Exp -> String+exp2str (Add a b) = "(" ++ exp2str(a) ++ " + " ++ exp2str(b) ++ ")"+exp2str (Mul a b) = "(" ++ exp2str(a) ++ " * " ++ exp2str(b) ++ ")"+exp2str (Div a b) = "(" ++ exp2str(a) ++ " / " ++ exp2str(b) ++ ")"+exp2str (Sub a b) = "(" ++ exp2str(a) ++ " - " ++ exp2str(b) ++ ")"+exp2str (Lit f) = show f++{- Tests -}+expr = Root $ Mul (Sub (Div (Lit 5) (Lit 5)) (Lit 10)) (Add (Lit 4) (Lit 5))++semantics z = bpp (toZipper z)++