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)
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!"
(.$) :: Zipper a -> Int -> Zipper a
z .$ 1 = fromJust (down' z)
z .$ n = fromJust (right ( z.$(n1) ))
(.|) :: Zipper a -> Int -> Bool
z .| 1 = case (left z) of
Nothing -> False
_ -> True
z .| n = case (left z) of
Nothing -> False
Just x -> 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 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 )) (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) )]
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)
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)))