diff --git a/ZipperAG.cabal b/ZipperAG.cabal --- a/ZipperAG.cabal +++ b/ZipperAG.cabal @@ -1,5 +1,5 @@ Name: ZipperAG -Version: 0.4 +Version: 0.5 Cabal-Version: >= 1.2 License: BSD3 Author: Pedro Martins @@ -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 diff --git a/src/Language/Grammars/ZipperAG/Examples/DESK.hs b/src/Language/Grammars/ZipperAG/Examples/DESK.hs deleted file mode 100644 --- a/src/Language/Grammars/ZipperAG/Examples/DESK.hs +++ /dev/null @@ -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))) - - - diff --git a/src/Language/Grammars/ZipperAG/Examples/DESK/DESK.hs b/src/Language/Grammars/ZipperAG/Examples/DESK/DESK.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/ZipperAG/Examples/DESK/DESK.hs @@ -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))) + + + diff --git a/src/Language/Grammars/ZipperAG/Examples/DESK/DESK_HighOrder.hs b/src/Language/Grammars/ZipperAG/Examples/DESK/DESK_HighOrder.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/ZipperAG/Examples/DESK/DESK_HighOrder.hs @@ -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))) + + + + + + diff --git a/src/Language/Grammars/ZipperAG/Examples/DESK/DESK_circular.hs b/src/Language/Grammars/ZipperAG/Examples/DESK/DESK_circular.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/ZipperAG/Examples/DESK/DESK_circular.hs @@ -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 + + diff --git a/src/Language/Grammars/ZipperAG/Examples/DESK/DESK_references.hs b/src/Language/Grammars/ZipperAG/Examples/DESK/DESK_references.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/ZipperAG/Examples/DESK/DESK_references.hs @@ -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))) + + + + diff --git a/src/Language/Grammars/ZipperAG/Examples/DESK_HighOrder.hs b/src/Language/Grammars/ZipperAG/Examples/DESK_HighOrder.hs deleted file mode 100644 --- a/src/Language/Grammars/ZipperAG/Examples/DESK_HighOrder.hs +++ /dev/null @@ -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))) - - - - - - diff --git a/src/Language/Grammars/ZipperAG/Examples/DESK_circular.hs b/src/Language/Grammars/ZipperAG/Examples/DESK_circular.hs deleted file mode 100644 --- a/src/Language/Grammars/ZipperAG/Examples/DESK_circular.hs +++ /dev/null @@ -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 - - diff --git a/src/Language/Grammars/ZipperAG/Examples/DESK_references.hs b/src/Language/Grammars/ZipperAG/Examples/DESK_references.hs deleted file mode 100644 --- a/src/Language/Grammars/ZipperAG/Examples/DESK_references.hs +++ /dev/null @@ -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))) - - - - diff --git a/src/Language/Grammars/ZipperAG/Examples/LET/ExampleLet.hs b/src/Language/Grammars/ZipperAG/Examples/LET/ExampleLet.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/ZipperAG/Examples/LET/ExampleLet.hs @@ -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) + + + + + + + + + + + + +