{-# LANGUAGE DeriveDataTypeable #-}

module Language.Grammars.ZipperAG.Examples.DESK.DESK_HighOrder where

import Data.Maybe
import Data.Data
import Prelude
import Data.Generics.Zipper
import Language.Grammars.ZipperAG

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!!"

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)))