ZipperAG 0.6 → 0.7

raw patch · 8 files changed

+195/−48 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ZipperAG.cabal +2/−1
• src/Language/Grammars/ZipperAG/Examples/LET/ExampleLet.hs +15/−18
• src/Language/Grammars/ZipperAG/Examples/LET/Let_Bidi.hs +3/−3
• src/Language/Grammars/ZipperAG/Examples/LET/Let_Circular_Flatening.hs +132/−0
• src/Language/Grammars/ZipperAG/Examples/LET/Let_DataTypes_Boilerplate.hs +22/−11
• src/Language/Grammars/ZipperAG/Examples/LET/Let_Meaning_HO_NestedST_Circ.hs +11/−9
• src/Language/Grammars/ZipperAG/Examples/LET/Let_No_Blocks.hs +2/−2
• src/Language/Grammars/ZipperAG/Examples/LET/Let_Scope.hs +8/−4

@@ -1,5 +1,5 @@ Name:		   ZipperAG-Version:	   0.6+Version:	   0.7 Cabal-Version: >= 1.2 License:	   BSD3 Author:		   Pedro Martins <pedromartins4@gmail.com>@@ -31,6 +31,7 @@                     Language.Grammars.ZipperAG.Examples.LET.Let_Meaning_HO_NestedST_Circ,                     Language.Grammars.ZipperAG.Examples.LET.Let_No_Blocks,                     Language.Grammars.ZipperAG.Examples.LET.Let_Scope+                    Language.Grammars.ZipperAG.Examples.LET.Let_Circular_Flatening   hs-source-dirs:   src   

@@ -1,3 +1,4 @@+ {-# LANGUAGE DeriveDataTypeable #-}  module Language.Grammars.ZipperAG.Examples.LET.ExampleLet where@@ -6,19 +7,17 @@ import Language.Grammars.ZipperAG  import Language.Grammars.ZipperAG.Examples.LET.Let_DataTypes_Boilerplate-import Language.Grammars.ZipperAG.Examples.LET.Let_Bidi+import Language.Grammars.ZipperAG.Examples.LET.Let_No_Blocks import Language.Grammars.ZipperAG.Examples.LET.Let_Scope-import Language.Grammars.ZipperAG.Examples.LET.Let_Meaning_HO_NestedST_Circ+import Language.Grammars.ZipperAG.Examples.LET.Let_Circular_Flatening+import Language.Grammars.ZipperAG.Examples.LET.Let_Meaning_HO_NestedST_Circ hiding (calculate)  -- 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+-- To run the examples, just choose one of the functions+-- in the end and use as argument a CST. For example:+-- -> "scope_with_blocks a"  ---- Examples ---- a1 = let a = b + 3@@ -35,8 +34,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"))-           	              )+                            $ 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@@ -134,18 +133,16 @@       -- 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)+scope_no_blocks ag = Language.Grammars.ZipperAG.Examples.LET.Let_No_Blocks.test_scope_no_block_rules ag -test_meaning p    = solve $ toZipper (getRootC_RootA $ toZipper p)+scope_with_blocks ag = Language.Grammars.ZipperAG.Examples.LET.Let_Scope.test_scope_block_rules ag +flatten ag = getHole (Language.Grammars.ZipperAG.Examples.LET.Let_Circular_Flatening.flatten_Let ag) :: Maybe RootA +solve_after_flattening ag = let ata = Language.Grammars.ZipperAG.Examples.LET.Let_Circular_Flatening.flatten_Let ag+                            in  calculate ata  +solve_circ_plus_ho ag = Language.Grammars.ZipperAG.Examples.LET.Let_Meaning_HO_NestedST_Circ.solve_ho_plus_circularity ag   

@@ -3,8 +3,8 @@ module Language.Grammars.ZipperAG.Examples.LET.Let_Bidi where  import Data.Generics.Zipper-import Language.Grammars.ZipperAG.Examples.LET.Let_DataTypes_Boilerplate import Language.Grammars.ZipperAG+import Language.Grammars.ZipperAG.Examples.LET.Let_DataTypes_Boilerplate  -- Forward Transformation (GET) getRootC_RootA :: Zipper a -> RootA@@ -59,8 +59,8 @@  putListA_ListC :: Zipper a -> ListC putListA_ListC ag = case (constructor ag) of-                      "ConsLetA"    -> ConsLetC (lexeme_ConsLetA ag) (putLetA_LetC $ ag.$2) (putListA_ListC $ ag.$3)-                      "ConsAssignA" -> ConsAssignC (lexeme_ConsAssignA ag) (putA_E $ ag.$2) (putListA_ListC $ ag.$3)+                      "ConsLetA"    -> ConsLetC (lexeme_ConsLetA_1 ag) (putLetA_LetC $ ag.$2) (putListA_ListC $ ag.$3)+                      "ConsAssignA" -> ConsAssignC (lexeme_ConsAssignA_1 ag) (putA_E $ ag.$2) (putListA_ListC $ ag.$3)                       "EmptyListA"  -> EmptyListC  putA_E :: Zipper a -> E

@@ -0,0 +1,132 @@+{-# LANGUAGE DeriveDataTypeable#-}++module Language.Grammars.ZipperAG.Examples.LET.Let_Circular_Flatening where++import Data.Generics.Zipper+import Language.Grammars.ZipperAG+import Data.Data++import Language.Grammars.ZipperAG.Examples.LET.Let_DataTypes_Boilerplate+import Language.Grammars.ZipperAG.Examples.LET.Let_Scope+import Language.Grammars.ZipperAG.Examples.LET.Let_Bidi++data VarList = VarList String VarList+             | NoVar++pointFree :: Zipper a -> (Zipper a -> Bool) -> (Zipper a -> b) -> (Zipper a -> Zipper a) -> b+pointFree ag cond calc incre = if   cond ag+                               then calc ag+                               else pointFree (incre ag) cond calc incre++solve :: Zipper RootA -> Zipper RootA+solve ag = pointFree ag isSolved id (toZipper . flatAG)++isSolved :: Zipper RootA -> Bool+isSolved ag = case (constructor ag) of+                "RootA"       -> isSolved $ ag.$1+                "LetA"        -> (isSolved $ ag.$1) || (isSolved $ ag.$2)+                "InA"         -> isConstant $ ag.$1+                "ConsAssignA" -> (isConstant $ ag.$2) && (isSolved $ ag.$3)+                "ConsLetA"    -> False+                "EmptyListA"  -> True++isSolvable :: Zipper RootA -> Bool+isSolvable ag = case (constructor ag) of+                 "Plus"        -> (isSolvable $ ag.$1) && (isSolvable $ ag.$2)+                 "Divide"      -> (isSolvable $ ag.$1) && (isSolvable $ ag.$2)+                 "Minus"       -> (isSolvable $ ag.$1) && (isSolvable $ ag.$2)+                 "Time"        -> (isSolvable $ ag.$1) && (isSolvable $ ag.$2)+                 "Variable"    -> isVarSolved (lexeme_Variable ag) ag+                 "Constant"    -> True++flatAG :: Zipper RootA -> RootA+flatAG ag = case (constructor ag) of+              "RootA" -> RootA (flatLetAG $ ag.$1) Empty++flatLetAG :: Zipper RootA -> LetA+flatLetAG ag = case (constructor ag) of+                 "LetA" -> LetA (flatListAG $ ag.$1) (lexme_LetA_2 ag) Empty++flatListAG :: Zipper RootA -> ListA+flatListAG ag = case (constructor ag) of+                  "ConsLetA"    -> if (isSolved $ ag.$2)+                                   then ConsAssignA (lexeme_ConsLetA_1 ag) (Constant (calculate $ ag.$2) Empty) (flatListAG $ ag.$3) Empty+                                   else ConsLetA    (lexeme_ConsLetA_1 ag) (flatLetAG $ ag.$2)                  (flatListAG $ ag.$3) Empty+                  "ConsAssignA" -> if ((not . isConstant $ ag.$2) && (isSolvable $ ag.$2))+                                   then ConsAssignA (lexeme_ConsAssignA_1 ag) (Constant (calculate $ ag.$2) Empty) (flatListAG $ ag.$3) Empty+                                   else ConsAssignA (lexeme_ConsAssignA_1 ag) (lexeme_ConsAssignA_2 ag)            (flatListAG $ ag.$3) Empty+                  "EmptyListA"  -> EmptyListA Empty++isConstant :: Zipper RootA -> Bool+isConstant ag = case (constructor ag) of+                  "Constant" -> True+                  _          -> False++calculate :: Zipper RootA -> Int+calculate ag = case (constructor ag) of+                 "RootA"       -> calculate $ ag.$1+                 "LetA"        -> calculate $ ag.$2+                 "InA"         -> calculate $ ag.$1+                 "Plus"        -> (calculate $ ag.$1) + (calculate $ ag.$2)+                 "Divide"      -> (calculate $ ag.$1) `div` (calculate $ ag.$2)+                 "Minus"       -> (calculate $ ag.$1) - (calculate $ ag.$2)+                 "Time"        -> (calculate $ ag.$1) * (calculate $ ag.$2)+                 "Variable"    -> getVarValue (lexeme_Variable ag) ag+                 "Constant"    -> lexeme_Constant ag++------- AUX's -------++getVarValue :: String -> Zipper RootA -> Int+getVarValue name ag = case (constructor ag) of+                       "RootA"    -> auxGetVarValue name ag+                       "ConsLetA" -> auxGetVarValue name (ag.$2)+                       _ -> getVarValue name (parent ag)++auxGetVarValue :: String -> Zipper RootA -> Int+auxGetVarValue name ag = case (constructor ag) of+                          "RootA"       -> auxGetVarValue name (ag.$1)+                          "LetA"        -> auxGetVarValue name (ag.$1)+                          "ConsAssignA" -> if (lexeme_ConsAssignA_1 ag == name) then (lexeme_Constant $ ag.$2)+                                           else (auxGetVarValue name (ag.$3))+                          "ConsLetA"    -> auxGetVarValue name (ag.$3)+                          "EmptyListA"  -> oneUpGetVarValue name ag++oneUpGetVarValue :: String -> Zipper RootA -> Int+oneUpGetVarValue name ag = case (constructor ag) of+                       "ConsLetA" -> getVarValue name (parent ag)+                       _          -> oneUpGetVarValue name (parent ag)++isVarSolved :: String -> Zipper RootA -> Bool+isVarSolved name ag = case (constructor ag) of+                       "RootA"    -> auxIsVarSolved name ag+                       "ConsLetA" -> auxIsVarSolved name ag+                       _ -> isVarSolved name (parent ag)++auxIsVarSolved :: String -> Zipper RootA -> Bool+auxIsVarSolved name ag = case (constructor ag) of+                          "RootA"       -> auxIsVarSolved name (ag.$1)+                          "LetA"        -> auxIsVarSolved name (ag.$1)+                          "ConsAssignA" -> if (lexeme_ConsAssignA_1 ag == name) then (isConstant $ ag.$2)+                                           else (auxIsVarSolved name (ag.$3))+                          "ConsLetA"    -> if (lexeme_ConsLetA_1 ag == name)    then False+                                           else (auxIsVarSolved name (ag.$3))+                          "EmptyListA"  -> oneUpIsVarSolved name ag++oneUpIsVarSolved :: String -> Zipper RootA -> Bool+oneUpIsVarSolved name ag = case (constructor ag) of+                       "ConsLetA" -> isVarSolved name (parent ag)+                       _          -> oneUpIsVarSolved name (parent ag)++flatten_Let p = solve $ toZipper (getRootC_RootA $ toZipper p)++++++++++++

@@ -1,3 +1,4 @@+ {-# LANGUAGE DeriveDataTypeable #-}  module Language.Grammars.ZipperAG.Examples.LET.Let_DataTypes_Boilerplate where@@ -109,6 +110,11 @@                           Just(ConsAssignC v _ _) -> v                           _ -> error "Error in lexeme_ConsAssignC!" +lexme_LetA_2 :: Zipper a -> InA+lexme_LetA_2 ag = case (getHole ag :: Maybe LetA) of+                    Just(LetA _ i _) -> i+                    _ -> error "Error in lexme_LetA_2!"+ lexeme_InA :: Zipper a -> A lexeme_InA ag = case (getHole ag :: Maybe InA) of                   Just (InA a _) -> a@@ -128,20 +134,25 @@                   Just (Const s) -> s                   _ -> error "Error in lexeme_Const!" -lexeme_ConsAssignA :: Zipper a -> String-lexeme_ConsAssignA ag = case (getHole ag :: Maybe ListA) of-                          Just(ConsAssignA v _ _ _) -> v-                          _ -> error "Error in lexeme_ConsAssignA!"+lexeme_ConsAssignA_1 :: Zipper a -> String+lexeme_ConsAssignA_1 ag = case (getHole ag :: Maybe ListA) of+                            Just(ConsAssignA v _ _ _) -> v+                            _ -> error "Error in lexeme_ConsAssignA_1!" -lexeme_ConsAssignA_Expr :: Zipper a -> A-lexeme_ConsAssignA_Expr ag = case (getHole ag :: Maybe ListA) of+lexeme_ConsAssignA_2 :: Zipper a -> A+lexeme_ConsAssignA_2 ag = case (getHole ag :: Maybe ListA) of                               Just(ConsAssignA _ a _ _) -> a-                              _ -> error "Error in lexeme_ConsAssignA_Expr!"+                              _ -> error "Error in lexeme_ConsAssignA_2!" -lexeme_ConsLetA :: Zipper a -> String-lexeme_ConsLetA ag = case (getHole ag :: Maybe ListA) of-                       Just(ConsLetA v _ _ _) -> v-                       _ -> error "Error in lexeme_ConsLetA!"+lexeme_ConsLetA_1 :: Zipper a -> String+lexeme_ConsLetA_1 ag = case (getHole ag :: Maybe ListA) of+                         Just(ConsLetA v _ _ _) -> v+                         _ -> error "Error in lexeme_ConsLetA!"++lexeme_ConsLetA_2 :: Zipper a -> LetA+lexeme_ConsLetA_2 ag = case (getHole ag :: Maybe ListA) of+                         Just(ConsLetA _ leta _ _) -> leta+                         _ -> error "Error in lexeme_ConsLetA!"  lexeme_Variable :: Zipper a -> String lexeme_Variable ag = case (getHole ag :: Maybe A) of

@@ -1,3 +1,4 @@+ {-# LANGUAGE DeriveDataTypeable #-}  module Language.Grammars.ZipperAG.Examples.LET.Let_Meaning_HO_NestedST_Circ where@@ -8,6 +9,7 @@  import Language.Grammars.ZipperAG.Examples.LET.Let_DataTypes_Boilerplate import Language.Grammars.ZipperAG.Examples.LET.Let_Scope+import Language.Grammars.ZipperAG.Examples.LET.Let_Bidi  ---- Approach 1: multiple, nested symbol tables -- Always start searching on the nested symbol table@@ -29,13 +31,13 @@ solveST :: Zipper RootHO -> ListHO solveST ag = case (constructorHO ag) of               "ConsVarHO" -> if ((not $ isSolved $ ag.$2) && (isSolved $ ag.$3))-              	             then ConsVarHO (lexeme_ConsVarHO_Var ag) (IsSolved $ calculate $ ag.$3) (lexeme_ConsVarHO_A ag) (solveST $ ag.$4)-              	             else ConsVarHO (lexeme_ConsVarHO_Var ag) (lexeme_ConsVarHO_isSolved ag) (lexeme_ConsVarHO_A ag) (solveST $ ag.$4)+                             then ConsVarHO (lexeme_ConsVarHO_Var ag) (IsSolved $ calculate $ ag.$3) (lexeme_ConsVarHO_A ag) (solveST $ ag.$4)+                             else ConsVarHO (lexeme_ConsVarHO_Var ag) (lexeme_ConsVarHO_isSolved ag) (lexeme_ConsVarHO_A ag) (solveST $ ag.$4)               "ConsLetHO" -> if ((not $ isSolved $ ag.$2) && (isSolved $ ag.$3))-              	             then ConsLetHO (lexeme_ConsLetHO_Var ag) (IsSolved $ calculate $ ag.$3) (lexeme_ConsLetHO_NestedST ag) (solveST $ ag.$4)-              	             else let nested_ST = ag.$3-              	                      new_ST    = NestedListHO (solveST $ nested_ST.$1) (lexeme_NestedListHO $ nested_ST)-              	                  in ConsLetHO (lexeme_ConsLetHO_Var ag) (lexeme_ConsLetHO_isSolved ag) (new_ST) (solveST $ ag.$4)+                             then ConsLetHO (lexeme_ConsLetHO_Var ag) (IsSolved $ calculate $ ag.$3) (lexeme_ConsLetHO_NestedST ag) (solveST $ ag.$4)+                             else let nested_ST = ag.$3+                                      new_ST    = NestedListHO (solveST $ nested_ST.$1) (lexeme_NestedListHO $ nested_ST)+                                  in ConsLetHO (lexeme_ConsLetHO_Var ag) (lexeme_ConsLetHO_isSolved ag) (new_ST) (solveST $ ag.$4)               "EmptyListHO"  -> EmptyListHO               "NestedListHO" -> solveST $ ag.$1 @@ -121,8 +123,8 @@ createST ag = case (constructorHO ag) of                 "RootA"       -> createST $ ag.$1                 "LetA"        -> createST $ ag.$1-                "ConsAssignA" -> ConsVarHO (lexeme_ConsAssignA ag) (NotSolved) (lexeme_ConsAssignA_Expr ag) (createST $ ag.$3)-                "ConsLetA"    -> ConsLetHO (lexeme_ConsLetA ag)    (NotSolved) (NestedListHO (createST $ ag.$2) (lexeme_InA $ (ag.$2).$2)) (createST $ ag.$3)+                "ConsAssignA" -> ConsVarHO (lexeme_ConsAssignA_1 ag) (NotSolved) (lexeme_ConsAssignA_2 ag) (createST $ ag.$3)+                "ConsLetA"    -> ConsLetHO (lexeme_ConsLetA_1 ag)    (NotSolved) (NestedListHO (createST $ ag.$2) (lexeme_InA $ (ag.$2).$2)) (createST $ ag.$3)                 "EmptyListA"  -> EmptyListHO  --- Higher-Order Symbol Table@@ -196,7 +198,7 @@                                   Just(NotSolved)  -> "NotSolved"                                   _ -> constructor ag -+solve_ho_plus_circularity p = solve $ toZipper (getRootC_RootA $ toZipper p)   

@@ -20,7 +20,7 @@            "RootA"       -> errs $ ag.$1            "LetA"        -> (errs $ ag.$1) ++ (errs $ ag.$2)            "InA"         -> (errs $ ag.$1)-           "ConsAssignA" -> mNBIn (lexeme_ConsAssignA ag) (dcli ag) ++ (errs $ ag.$2) ++ (errs $ ag.$3)+           "ConsAssignA" -> mNBIn (lexeme_ConsAssignA_1 ag) (dcli ag) ++ (errs $ ag.$2) ++ (errs $ ag.$3)            "EmptyListA"  -> []            "Plus"        -> (errs $ ag.$1) ++ (errs $ ag.$2)            "Divide"      -> (errs $ ag.$1) ++ (errs $ ag.$2)@@ -34,7 +34,7 @@ dcli ag = case (constructor ag) of            "RootA" -> []            _       -> case (constructor $ parent ag) of-                             "ConsAssignA" -> (dcli $ parent ag) ++ [lexeme_ConsAssignA $ parent ag]+                             "ConsAssignA" -> (dcli $ parent ag) ++ [lexeme_ConsAssignA_1 $ parent ag]                              _             -> dcli $ parent ag  env :: Zipper RootA -> [String]

@@ -1,3 +1,4 @@+ {-# LANGUAGE DeriveDataTypeable #-}  module Language.Grammars.ZipperAG.Examples.LET.Let_Scope where@@ -5,6 +6,7 @@ import Data.Generics.Zipper import Language.Grammars.ZipperAG import Language.Grammars.ZipperAG.Examples.LET.Let_DataTypes_Boilerplate+import Language.Grammars.ZipperAG.Examples.LET.Let_Bidi  ---- Synthesized Attributes ---- dclo :: Zipper RootA -> [(String, Zipper RootA)]@@ -20,8 +22,8 @@            "RootA"       -> errs $ ag.$1            "LetA"        -> (errs $ ag.$1) ++ (errs $ ag.$2)            "InA"         -> (errs $ ag.$1)-           "ConsAssignA" -> mNBIn (lexeme_ConsAssignA ag, ag) (dcli ag) ++ (errs $ ag.$2) ++ (errs $ ag.$3)-           "ConsLetA"    -> mNBIn (lexeme_ConsLetA    ag, ag) (dcli ag) ++ (errs $ ag.$2) ++ (errs $ ag.$3)+           "ConsAssignA" -> mNBIn (lexeme_ConsAssignA_1 ag, ag) (dcli ag) ++ (errs $ ag.$2) ++ (errs $ ag.$3)+           "ConsLetA"    -> mNBIn (lexeme_ConsLetA_1    ag, ag) (dcli ag) ++ (errs $ ag.$2) ++ (errs $ ag.$3)            "EmptyListA"  -> []            "Plus"        -> (errs $ ag.$1) ++ (errs $ ag.$2)            "Divide"      -> (errs $ ag.$1) ++ (errs $ ag.$2)@@ -38,8 +40,8 @@                              "RootA"    -> dcli $ parent ag                              "ConsLetA" -> env $ parent ag            _       -> case (constructor $ parent ag) of-                             "ConsAssignA" -> (dcli $ parent ag) ++ [(lexeme_ConsAssignA $ parent ag, parent ag)]-                             "ConsLetA"    -> (dcli $ parent ag) ++ [(lexeme_ConsLetA $ parent ag, parent ag)]+                             "ConsAssignA" -> (dcli $ parent ag) ++ [(lexeme_ConsAssignA_1 $ parent ag, parent ag)]+                             "ConsLetA"    -> (dcli $ parent ag) ++ [(lexeme_ConsLetA_1 $ parent ag, parent ag)]                              _             -> dcli $ parent ag  env :: Zipper RootA -> [(String, Zipper RootA)]@@ -67,4 +69,6 @@ mNBIn :: (String, Zipper RootA) -> [(String, Zipper RootA)] -> [String] mNBIn tuple [] = []  mNBIn (a1,r1) ((a2,r2):es) = if (a1==a2) && (lev r1 == lev r2) then [a1] else mNBIn (a1,r1) es++test_scope_block_rules p = errs $ toZipper (getRootC_RootA $ toZipper p)