{-# LANGUAGE DeriveDataTypeable #-}

module Language.Grammars.ZipperAG.Examples.DESK.DESK_circular 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 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)))



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