{-# LANGUAGE DeriveDataTypeable #-}

module Language.Grammars.ZipperAG.Examples.HTMLTableFormatter where

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

---- ABSTRACT SYNTAX GRAMMAR ----
data R = RootR Table
	deriving (Typeable, Show, Data)

data Table = RootTable Rows
	deriving (Typeable, Show, Data)

data Rows = NoRow
		  | ConsRow Row Rows
	deriving (Typeable, Show, Data)

data Row = OneRow Elems
	deriving (Typeable, Show, Data)

data Elems = NoElem
		   | ConsElem Elem Elems
	deriving (Typeable, Show, Data)

data Elem = TableText String
		  | NestedTable Table
	deriving (Typeable, Show, Data)

constructor :: Zipper R -> String
constructor a = case ( getHole a :: Maybe R ) of
				 Just (RootR _) -> "RootR"
				 otherwise -> case ( getHole a :: Maybe Table ) of
								Just (RootTable _) -> "RootTable"
				   				otherwise -> case ( getHole a :: Maybe Rows ) of
				   							 Just (NoRow) -> "NoRow"
				   							 Just (ConsRow _ _) -> "ConsRow"
				   							 otherwise -> case ( getHole a :: Maybe Row ) of
				   										  Just (OneRow _) -> "OneRow"
				   										  otherwise -> case ( getHole a :: Maybe Elems ) of
				   													   Just (NoElem) -> "NoElem"
				   													   Just (ConsElem _ _) -> "ConsElem"
				   													   otherwise -> case ( getHole a :: Maybe Elem ) of
				   													   				Just (TableText _) -> "TableText"
				   													   				Just (NestedTable _) -> "NestedTable"
				   													   				otherwise -> error "Naha, that production does not exist!"

-- Gives the n'th child
(.$) :: 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)!"

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


value t = case ( getHole t :: Maybe Elem ) of
				Just (TableText x) -> x
				_ -> error "You should not be asking for that value!"

-- ata is used to implement High Order
(.#.) :: Data a => (t -> a) -> t -> Zipper a
highorder_attr .#. zipper = toZipper (highorder_attr zipper) 

---- AG ----
---- Computing the number of elems per row ----
n_Syn z = case (constructor z) of
			"RootR" -> n_Syn $ z.$1
			"RootTable" -> maxList ( ns_Syn $ z.$1 )
			"OneRow" -> n_Syn $ z.$1
			"NoElem" -> 0
			"ConsElem" -> 1 + (n_Syn $ z.$2)

ns_Syn z = case (constructor z) of
			"NoRow" -> []
			"ConsRow" -> (n_Syn $ z.$1) : (ns_Syn $ z.$2)

---- Passing down the number of elements per row ----
ane_Inh z = case (constructor z) of
			"RootTable" -> n_Syn z
			"NoRow" -> case (constructor $ parent z) of
						"RootTable" -> n_Syn $ parent z
						"NoRow" -> ane_Inh $ parent z
						"ConsRow" -> ane_Inh $ parent z
			"ConsRow" -> case (constructor $ parent z) of
							"RootTable" -> n_Syn $ parent z
							"OneRow" -> ane_Inh $ parent z
							"ConsRow" -> ane_Inh $ parent z
			"OneRow" -> ane_Inh $ parent z
			"NoElem" -> case (constructor $ parent z) of
							"OneRow" -> ane_Inh $ parent z
							"ConsElem" -> (ane_Inh $ parent z) - 1
							"NoElem" -> (ane_Inh $ parent z) - 1
			"ConsElem" -> case (constructor $ parent z) of
							"OneRow" -> ane_Inh $ parent z
							"ConsElem" -> (ane_Inh $ parent z) - 1
							"NoElem" -> (ane_Inh $ parent z) - 1

---- Constructing the new table ----
r2 z = RootR (r2_table $ z.$1)

r2_table z = RootTable (r2_rows $ z.$1)

r2_rows z = case (constructor z) of
				"NoRow" -> NoRow
				"ConsRow" -> ConsRow (r2_row $ z.$1) (r2_rows $ z.$2)

r2_row z = OneRow (r2_elems $ z.$1)

r2_elems z = case (constructor z) of
				"NoElem" -> add_elems (ane_Inh z)
				"ConsElem" -> ConsElem (r2_elem $ z.$1) (r2_elems $ z.$2)

r2_elem z = case (constructor z) of
				"TableText" -> TableText (value z)
				"NestedTable" -> NestedTable (r2_table $ z.$1)

---- Computing the minimal height of each construct ----
mh_Syn z = case (constructor z) of
			"RootR" -> mh_Syn $ z.$1
			"RootTable" -> mh_Syn $ z.$1
			"NoRow" -> 0
			"ConsRow" -> (mh_Syn $ z.$1) + 1 + (mh_Syn $ z.$2)
			"OneRow" -> mh_Syn $ z.$1
			"ConsElem" -> max (mh_Syn $ z.$1) (mh_Syn $ z.$2)
			"NoElem" -> 0
			"TableText" -> 1
			"NestedTable" -> (mh_Syn $ z.$1 ) + 1

---- Computing the minimal width of each construct ----
mw_Syn z = case (constructor z) of
			"RootR" -> mw_Syn $ z.$1
			"RootTable" -> lmw_Local z -- Local attr, as defined in LRC
			"TableText" -> length (value z)
			"NestedTable" -> (mw_Syn $ z.$1) + 2

mws_Syn z = case (constructor z) of
				"NoRow" -> []
				"ConsRow" -> eq_zipwith_max (mws_Syn $ z.$1) (mws_Syn $ z.$2)
				"OneRow" -> mws_Syn $ z.$1
				"ConsElem" -> (mw_Syn $ z.$1) : (mws_Syn $ z.$2)
				"NoElem" -> []

---- LOCAL ATTRIBUTE ----
lmw_Local z = case (constructor z) of
					"RootTable" -> (sumList (mws_Syn $ z.$1)) + (lengthList (mws_Syn $ z.$1)) - 1
					"ConsRow" -> (sumList (aws_Inh z)) + (lengthList (aws_Inh z)) - 1

---- Passing down the available heights and widths ----
ah_Inh z = case (constructor z) of
			"RootR" -> mh_Syn $ z
			"RootTable" -> case (constructor $ parent z) of
							"RootR" -> ah_Inh $ parent z
							"OneElem" -> ah_Inh $ parent z
							"ConsElem" -> ah_Inh $ parent z
			"ConsElem" ->case (constructor $ parent z) of
							"OneRow" -> mh_Syn z
							"ConsElem" -> ah_Inh $ parent z
			"NoElem" -> case (constructor $ parent z) of
							"OneRow" -> mh_Syn z
							"ConsElem" -> ah_Inh $ parent z
			"TableText" -> ah_Inh $ parent z
			"NestedTable" -> ah_Inh $ parent z

aws_Inh z = case (constructor z) of
				"ConsRow" ->case (constructor $ parent z) of
								"RootTable" -> mws_Syn z
								"ConsRow" -> aws_Inh $ parent z
				"NoRow" -> case (constructor $ parent z) of
								"RootTable" -> mws_Syn z
								"ConsRow" -> aws_Inh $ parent z
				"OneRow" -> aws_Inh $ parent z
				"ConsElem" -> case (constructor $ parent z) of
								"OneRow" -> aws_Inh $ parent z
								"ConsElem" -> tailList (aws_Inh $ parent z)
				"NoElem" -> case (constructor $ parent z) of
								"OneRow" -> aws_Inh $ parent z
								"ConsElem" -> tailList (aws_Inh $ parent z)

aw_Inh z = case (constructor z) of
			"RootR" -> mw_Syn z
			"RootTable" -> case (constructor $ parent z) of
							"RootR" -> ah_Inh $ parent z
--							"TableText" -> aw_Inh $ parent z
							"NestedTable" -> aw_Inh $ parent z
			"TableText" -> headList (aws_Inh $ parent z)
			"NestedTable" -> headList (aws_Inh $ parent z)

---- Computing Formatted Table ----
lines_Syn t = let z = t
			  in case (constructor z) of
					"RootR" -> lines_Syn $ z.$1
					"RootTable" -> (add_sepline (lmw_Local z)) ++ (lines_Syn $ z.$1) ++ (add_sepline (lmw_Local z))
					"NoRow" -> []
					"ConsRow" -> add_sep_line (lmw_Local z) (lines_Syn $ z.$1) (lines_Syn $ z.$2)
					"OneRow" -> add_border_line (lines_Syn $ z.$1)
					"NoElem" -> []
					"ConsElem" -> let ag = addglue (aw_Inh $ z.$1) (mw_Syn $ z.$1) (ah_Inh $ z.$1) (mh_Syn $ z.$1) (lines_Syn $ z.$1) ("align")
								  in eq_zipwith_cat ag (lines_Syn $ z.$2)
					"TableText" -> value z : []
					"NestedTable" -> lines_Syn $ z.$1

---- Semantics Functions ----
sumList = sum

lengthList = length

eq_zeros = []

eq_zipwith_max :: [Int] -> [Int] -> [Int]
eq_zipwith_max [] l2 = l2
eq_zipwith_max l1 [] = l1
eq_zipwith_max (l1:l1s) (l2:l2s) = (max l1 l2) : (eq_zipwith_max l1s l2s)

maxList :: [Int] -> Int
maxList [] = 0
maxList (x:xs) = max x (maxList xs)

headList :: [Int] -> Int
headList [] = 0
headList (x:xs) = x

tailList :: [a] -> [a]
tailList [] = []
tailList (x:xs) = xs

eq_zipwith_cat :: [String] -> [String] -> [String]
eq_zipwith_cat l1 [] = l1
eq_zipwith_cat [] l2 = l2
eq_zipwith_cat (l11:l11s) (l22:l22s) = (l11 ++ "|" ++ l22) : (eq_zipwith_cat l11s l22s)

add_border_line :: [String] -> [String]
add_border_line [] = []
add_border_line (x:xs) = ("|" ++ x ++ "|") : (add_border_line xs)

--add_noborder_line :: [String] -> [String]

addglue :: Int -> Int -> Int -> Int -> [String] -> String -> [String]
addglue aw mw ah mh lineS a = (glue_horizontal aw mw lineS a) ++ (glue_vertical_new (ah-mh) (add_vertical aw))

glue_horizontal :: Int -> Int -> [String] -> String -> [String]
glue_horizontal _ _ [] _ = []
glue_horizontal aw mw (l:ls) a = (add_hor l (aw-mw) a) : (glue_horizontal aw mw ls a)

add_hor :: String -> Int -> String -> String
add_hor l aw "left" = l ++ (hor_spaces aw)
add_hor l aw "right" = (hor_spaces aw) ++ l
add_hor l aw "center" = let y = (div aw 2)
						in (hor_spaces y) ++ l ++ (hor_spaces y)
add_hor l aw _ = l ++ (hor_spaces aw)

hor_spaces :: Int -> String
hor_spaces i = if (i <= 0) then "" else (repeatChar ' ' i)

glue_vertical_new :: Int -> [String] -> [String]
glue_vertical_new n l = if (n <= 0) then [] else l ++ (glue_vertical_new (n-1) l)

add_vertical :: Int -> [String]
add_vertical aw = if (aw <= 0) then [] else (repeatChar ' ' aw) : []

add_sepline :: Int -> [String]
add_sepline aw = if (aw <= 0)
				then []
				else ["|" ++ (repeatChar '-' aw) ++ "|"]

add_sep_line :: Int -> [String] -> [String] -> [String]
add_sep_line mw l [] = l
add_sep_line mw l rest = l ++ (add_sepline mw) ++ rest

add_elems :: Int -> Elems
add_elems 0 = NoElem
add_elems n = ConsElem (TableText " ") (add_elems (n-1))

repeatChar :: Char -> Int -> String
repeatChar _ 0 = []
repeatChar c i = c : (repeatChar c (i-1)) 

---- table2nestedtable : Table -> Table

---- Tests
nestedtable = RootTable (ConsRow (OneRow (ConsElem (TableText "Some more random text!") (NoElem))) (NoRow))
elem1 = TableText "This is some text on a table!"
elem2 = TableText "And even more random text!"
row1 = ConsRow (OneRow (ConsElem (TableText "This is a big phrase etc etc.") NoElem)) (NoRow)
elem3 = ConsElem (TableText "This is a big phrase just to make sure this HTML AG etc etc.") (NoElem)

table = RootR (RootTable (ConsRow (OneRow (ConsElem (elem1) (ConsElem (NestedTable nestedtable) (NoElem)))) (ConsRow (OneRow (ConsElem (elem2) (elem3))) (row1))))

printTable :: [String] -> String
printTable [] = ""
printTable (x:xs) = x ++ "\n" ++ (printTable xs)

ata z = toZipper (r2 z)

semantics t = putStrLn $ printTable $ lines_Syn $ ata $ (toZipper t)