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)
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)
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!!"
(.$) :: Zipper a -> Int -> Zipper a
z .$ 1 = fromJust (down' z)
z .$ n = fromJust (right ( z.$(n1) ))
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
envi :: Zipper Root -> SymbolTable
envi t = case (constructor t) of
"PRINT" -> envs ( t.$2 )
_ -> envi (parent t)
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
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
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))
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)
semantics t = putStrLn ("\n" ++ (code (toZipper t)))