{-# LANGUAGE DeriveDataTypeable #-}

module Language.Grammars.ZipperAG.Examples.Algol68 where

import Data.Data
import Data.Generics.Zipper
import Data.Maybe

data Root = Root Its
          deriving (Typeable, Show, Data)

data Its = ConsIts It Its
         | NilIts
       deriving (Show, Typeable, Data)

data It = Decl String
        | Use String
        | Block Its
        deriving (Show, Typeable, Data)

constructor :: (Typeable a) => Zipper a -> String
constructor a = case ( getHole a :: Maybe Its ) of
				 Just (ConsIts _ _) -> "ConsIts"
				 Just (NilIts) -> "NilIts"
				 otherwise -> case ( getHole a :: Maybe It ) of
								Just (Decl _) -> "Decl"
								Just (Use _) -> "Use"
								Just (Block _) -> "Block"
								otherwise -> case ( getHole a :: Maybe Root) of 
															Just (Root _) -> "Root"
															otherwise -> error "Naha, that production does not exist!"

(.$) :: Zipper a -> Int -> Zipper a
z .$ 1 = let d = down' z
		 in case d of
			Just x -> x
			Nothing -> error "You are going to a child that does not exist (1)!"
z .$ n = let r = right (z.$(n-1))
		 in case r of
			Just x -> x
			Nothing -> error "You are going to a child that does not exist (2)!"

value z = case (getHole z :: Maybe It) of
							Just (Use x) -> x
							Just (Decl x) -> x

-- 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 z = let a = up z
		   in case a of
		   		Just x -> x
		   		Nothing -> error "You are asking for the parent of the TopMost Tree!"

---- Synthesized Attributes ----
dclo :: Zipper Root -> [(String, Int)]
dclo z = case (constructor z) of
					"ConsIts" -> dclo $ z.$2
					"NilIts" -> dcli z
					"Use" -> dcli z
					"Decl" -> (value z,lev z) : (dcli z)
					"Block" -> dcli z

errs :: Zipper Root -> [String]
errs z = case (constructor z) of
					"Root" -> errs $ z.$1	
					"NilIts" -> []
					"ConsIts" -> (errs $ z.$1) ++ (errs $ z.$2)
					"Use" -> mBIn (value z) (env z)
					"Decl" -> mNBIn (value z,lev z) (dcli z)
					"Block" -> errs $ z.$1

---- Inheritted Attributes ----
dcli :: Zipper Root -> [(String, Int)] 
dcli z = case (constructor z) of
					"Root" -> []
					"NilIts" -> case (constructor $ parent z) of
									"ConsIts" -> dclo $ (parent z).$1
									"Block" -> env $ parent z
									"Root" -> []
					"ConsIts" -> case (constructor $ parent z) of
									"ConsIts" -> dclo $ (parent z).$1
									"Block" -> env $ parent z
									"Root" -> []
					"Block" -> dcli $ parent z
					"Use" -> dcli $ parent z
					"Decl" -> dcli $ parent z

lev :: Zipper Root -> Int
lev z = case (constructor z) of
				"Root" -> 0
				"NilIts" -> case (constructor $ parent z) of
								"Block" -> (lev $ parent z) + 1
								"ConsIts" -> lev $ parent z
								"Root" -> 0
				"ConsIts" -> case (constructor $ parent z) of
								"Block" -> (lev $ parent z) + 1
								"ConsIts" -> lev $ parent z
								"Root" -> 0
				"Block" -> lev $ parent z
				"Use" -> lev $ parent z
				"Decl" -> lev $ parent z

env :: Zipper Root -> [(String, Int)]
env z = case (constructor z) of
					"NilIts" -> case (constructor $ parent z) of
												"Block" -> dclo z
												"ConsIts" -> env $ parent z
												"Root" -> dclo z
					"ConsIts" -> case (constructor $ parent z) of
												"Block" -> dclo z
												"ConsIts" -> env $ parent z
												"Root" -> dclo z
					"Block" -> env $ parent z
					"Use" -> env $ parent z
					"Decl" -> env $ parent z
					"Root" -> dclo z

--program = [Decl "y", Decl "x", Block [Decl "y", Use "y", Use "w"], Decl "x", Use "y"]
block = Block (ConsIts (Decl "x") (ConsIts (Use "y") (ConsIts (Use "w") (NilIts))))
program = ConsIts (Decl "y") (ConsIts (Decl "x") (ConsIts (block) (ConsIts (Decl "x") (ConsIts (Use "y") (NilIts)))))

{- Environment lookup functions -}
mBIn name [] = [name]
mBIn name ((n,l):es) = if (n==name) then [] else mBIn name es

mNBIn tuple [] = [] 
mNBIn pair (pl:es) = if pair==pl then [fst pair] else mNBIn pair es

semantics t = errs $ toZipper $ Root t