{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}

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