ZipperAG 0.4 → 0.5
raw patch · 10 files changed
+957/−800 lines, 10 files
Files
- ZipperAG.cabal +2/−2
- src/Language/Grammars/ZipperAG/Examples/DESK.hs +0/−154
- src/Language/Grammars/ZipperAG/Examples/DESK/DESK.hs +154/−0
- src/Language/Grammars/ZipperAG/Examples/DESK/DESK_HighOrder.hs +190/−0
- src/Language/Grammars/ZipperAG/Examples/DESK/DESK_circular.hs +294/−0
- src/Language/Grammars/ZipperAG/Examples/DESK/DESK_references.hs +158/−0
- src/Language/Grammars/ZipperAG/Examples/DESK_HighOrder.hs +0/−190
- src/Language/Grammars/ZipperAG/Examples/DESK_circular.hs +0/−295
- src/Language/Grammars/ZipperAG/Examples/DESK_references.hs +0/−159
- src/Language/Grammars/ZipperAG/Examples/LET/ExampleLet.hs +159/−0
ZipperAG.cabal view
@@ -1,5 +1,5 @@ Name: ZipperAG-Version: 0.4+Version: 0.5 Cabal-Version: >= 1.2 License: BSD3 Author: Pedro Martins <pedromartins4@gmail.com>@@ -15,7 +15,7 @@ Library Build-Depends: base >= 2 && <= 4.6.0.1, syz- 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+ Exposed-modules: Language.Grammars.ZipperAG, Language.Grammars.ZipperAG.Examples.Algol68, Language.Grammars.ZipperAG.Examples.BreadthFirst, Language.Grammars.ZipperAG.Examples.DESK.DESK_circular, Language.Grammars.ZipperAG.Examples.DESK.DESK_HighOrder, Language.Grammars.ZipperAG.Examples.DESK.DESK_references, Language.Grammars.ZipperAG.Examples.DESK.DESK, Language.Grammars.ZipperAG.Examples.HTMLTableFormatter, Language.Grammars.ZipperAG.Examples.RepMin, Language.Grammars.ZipperAG.Examples.SmartParentesis, Language.Grammars.ZipperAG.Examples.LET.ExampleLet hs-source-dirs: src
− src/Language/Grammars/ZipperAG/Examples/DESK.hs
@@ -1,154 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--module Language.Grammars.ZipperAG.Examples.DESK 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/DESK.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Language.Grammars.ZipperAG.Examples.DESK.DESK 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/DESK_HighOrder.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Language.Grammars.ZipperAG.Examples.DESK.DESK_HighOrder 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/DESK_circular.hs view
@@ -0,0 +1,294 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Language.Grammars.ZipperAG.Examples.DESK.DESK_circular 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/DESK_references.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}++module Language.Grammars.ZipperAG.Examples.DESK.DESK_references 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/DESK_HighOrder.hs
@@ -1,190 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--module Language.Grammars.ZipperAG.Examples.DESK_HighOrder 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
@@ -1,295 +0,0 @@--{-# LANGUAGE DeriveDataTypeable #-}--module Language.Grammars.ZipperAG.Examples.DESK_circular 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
@@ -1,159 +0,0 @@--{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}--module Language.Grammars.ZipperAG.Examples.DESK_references 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/LET/ExampleLet.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Language.Grammars.ZipperAG.Examples.LET.ExampleLet where++import Data.Generics+import Data.Generics.Zipper+import Language.Grammars.ZipperAG++import Let_DataTypes_Boilerplate+import Let_Bidi+import Let_Scope+import Let_Meaning_HO_NestedST_Circ++-- This Module is where all the example are presented+-- All examples are presented as the LET language, in their+-- Haskell form (a1..f1) and in their CST form (a..f)+-- The functions test_bidi, test_scope_rules and test_meaning+-- are presented+------ test_bidi - Test bidirectionality. Converts from CST to AST and back to CST+------ test_scope_rules - Applies the AG that performs name/scope analysis with references+------ test_meaning - Applies the AG that calculates the meaning of the program, through+------ an higher-order AG and then through circularity++---- Examples ----+a1 = let a = b + 3+ c = 8+ w = let z = a * b+ in z * b + b = (c * 3) - c+ in c * w - a+a = RootC $+ -- let a = b + 3+ LetC ( ConsAssignC "a" (Add (Et $ Tf $ Var "b") (Tf $ Const 3))+ -- c = 8+ $ ConsAssignC "c" (Et $ Tf $ Const 8)+ -- w = let z = a * b+ $ ConsLetC "w" ( LetC ( ConsAssignC "z" (Et $ Mul (Tf $ Var "a") (Var "b")) EmptyListC)+ -- in z * b+ $ InC (Et $ Mul (Tf $ Var "z") (Var "b"))+ )+ -- b = (c * 3) - c+ $ ConsAssignC "b" (Sub (Et $ (Mul (Tf $ Var "c") (Const 3))) (Tf $ Var "c"))+ EmptyListC+ )+ -- in c * w - a+ $ InC (Sub (Et $ Mul (Tf $ Var "c") (Var "w")) (Tf $ Var "a"))++b1 = let c = 1+ a = let b = c+ in b+ in a + c+b = RootC $+ -- c = 1+ LetC ( ConsAssignC "c" (Et $ Tf $ Const 1)+ -- a = let b = 7+ $ ConsLetC "a" ( LetC ( ConsAssignC "b" (Et $ Tf $ Var "c") EmptyListC)+ -- in b+ $ InC (Et $ Tf $ Var "b")+ )+ EmptyListC+ )+ -- in a + c+ $ InC (Add (Et $ Tf $ Var "a") (Tf $ Var "c"))++c1 = let a = 5+ b = a+ in b+c = RootC $+ -- let a = 5+ LetC ( ConsAssignC "a" (Et $ Tf $ Const 5)+ -- b = a+ $ ConsAssignC "b" (Et $ Tf $ Var "a")+ EmptyListC+ )+ -- in b+ $ InC (Et $ Tf $ Var "b")++d1 = let a = b+3+ c = 8+ b = c*3 - c+ in c*5 - a+d = RootC $+ -- let a = b + 3 (19)+ LetC ( ConsAssignC "a" (Add (Et $ Tf $ Var "b") (Tf $ Const 3))+ -- c = 8+ $ ConsAssignC "c" (Et $ Tf $ Const 8)+ -- b = c * 3 - c (16)+ $ ConsAssignC "b" (Sub (Et $ (Mul (Tf $ Var "c") (Const 3))) (Tf $ Var "c"))+ EmptyListC+ )+ -- in c * 5 - a (21)+ $ InC (Sub (Et $ Mul (Tf $ Var "c") (Const 5)) (Tf $ Var "a"))++-- Exemplo de circularidade do Paakki+e1 = let x = y+ y = z+ z = 2+ in x+e = RootC $+ -- let x = y+ LetC ( ConsAssignC "x" (Et $ Tf $ Var "y")+ -- y = z+ $ ConsAssignC "y" (Et $ Tf $ Var "z")+ -- z = 2+ $ ConsAssignC "z" (Et $ Tf $ Const 2)+ EmptyListC+ )+ -- in x+ $ InC (Et $ Tf $ Var "x")++f1 = let a = b + 3+ c = 8+ w = let z = a * b+ in z * b + b = let c = 1+ in c + 4+ in c * w - a+f = RootC $+ -- let a = b + 3+ LetC ( ConsAssignC "a" (Add (Et $ Tf $ Var "b") (Tf $ Const 3))+ -- c = 8+ $ ConsAssignC "c" (Et $ Tf $ Const 8)+ -- w = let z = a * b+ $ ConsLetC "w" ( LetC ( ConsAssignC "z" (Et $ Mul (Tf $ Var "a") (Var "b")) EmptyListC)+ -- in z * b+ $ InC (Et $ Mul (Tf $ Var "z") (Var "b"))+ )+ -- b = let c = 1+ $ ConsLetC "b" ( LetC ( ConsAssignC "c" (Et $ Tf $ Const 1) EmptyListC)+ -- in c + 4+ $ InC (Add (Et $ Tf $ Var "c") (Tf $ Const 4))+ )+ EmptyListC+ )+ -- in c * w - a+ $ InC (Sub (Et $ Mul (Tf $ Var "c") (Var "w")) (Tf $ Var "a"))++test_bidi p = do putStrLn ("**** CONCRETE -> " ++ show p)+ let t1 = getRootC_RootA $ toZipper p+ putStrLn ("**** ABSTRACT -> " ++ show t1)+ let t2 = putRootA_RootC $ toZipper t1+ putStrLn ("**** CONCRETE -> " ++ show t2)++test_scope_rules p = errs $ toZipper (getRootC_RootA $ toZipper p)++test_meaning p = solve $ toZipper (getRootC_RootA $ toZipper p)+++++++++++++