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