module Parser (parse)
where

import Data.List
import Uniqs
import Node

data Token =	Variable String 			|
				NewVariable String 			|
				TFunction 					|
				Fail						|
				TCons						|
				TLT		| TGT				|
				String String				|
				Number Integer  			|
				SubExp [Token]  			|
				NCons Token Token			|
				NFunction Token Token Token	|
				NApplication Token Token	|
				TNil						


parse		:: String -> Node
parse x		= tokenToNode (parseIntern (tokenize x)) [] Root
			
{- Tokenizer -}			

tokenize									:: String -> [Token]
tokenize []									= []
tokenize ( '/' :t)							= (TFunction : tokenize t)
tokenize ( '\\':t)							= (Fail		: tokenize t)
tokenize ( ',' :t)							= (TCons		: tokenize t)
tokenize ( '<' :t)							= (TLT		: tokenize t)
tokenize ( '>' :t)							= (TGT		: tokenize t)
tokenize ( '%' :( '"' :t )) 				= (String text : tokenize q) 
											where (text,q) = (textTokenize t)
tokenize ( '%' :( '\'' :(c:t))) 			= (Number (toInteger (fromEnum c)) : tokenize t) 
tokenize ( '%' :t)							= (Number (read text) : tokenize q)
											where (text,q) = (numberTokenize t)
tokenize ( ':' :t)							= (NewVariable text : tokenize q)	
											where (text,q) = (varTokenize t)
tokenize y@( x  :t)             			
	| (x >= 'a' && x <= 'z') 				= (Variable text : tokenize q)								
	| elem x ". \n\t\r"						= tokenize t
	| (x >= 'A' && x <= 'Z') 				= tokenize t
	where (text,q) = (varTokenize y)
						

textTokenize						:: String -> (String,String)
textTokenize ( '\\' : ( 'n' :t) )	= (( '\n' :text), q)
									where (text,q) = (textTokenize t)
textTokenize ( '\\' : (  x  :t) )	= ((x:text), q)
									where (text,q) = (textTokenize t)
textTokenize ( '"' : t)				= ("",t)
textTokenize ( x   : t)				= ((x:text), q)
									where (text,q) = (textTokenize t)


numberTokenize						:: String -> (String,String)
numberTokenize	[]					= ("",[])
numberTokenize y@( x   : t)		
	| x >= '0' && x <= '9' 			= ((x:text), q)  									
	| otherwise				 		= ("",y)
	where (text,q) = (numberTokenize t)

	
varTokenize							:: String -> (String,String)
varTokenize	[]						= ("",[])
varTokenize y@( x   : t)		
	| x >= 'a' && x <= 'z' 			= ((x:text), q)								
	| otherwise				 		= ("",y)
	where (text,q) = (varTokenize t) 

									
instance Show Token where
	show (Variable x)		= "Variable " ++ (show x)
	show (NewVariable x)	= "NewVariable " ++ (show x)
	show (TFunction)		= "TFunction"
	show (Fail)				= "Fail"
	show (TCons)			= "TCons"
	show (TLT)				= "TLT"
	show (TGT)				= "TGT"
	show (String x)			= "String " ++ (show x)
	show (Number x)			= "Number " ++ (show x)
	show (SubExp x)			= "SubExp " ++ (show x)
	show (NCons x y)		= "NCons (" ++ (show x) ++ ") (" ++ (show y) ++ ")"
	show (NFunction x y z)	= "NFunction (" ++ (show x) ++ ") (" ++ (show y) ++ ") (" ++ (show z) ++ ")"
	show (NApplication x y)	= "NApplication (" ++ (show x) ++ ") (" ++ (show y) ++ ")"
	show (TNil)			= "TNil"

instance Eq Token where
	(==) TFunction TFunction		= True
	(==) Fail Fail					= True
	(==) _ _						= False
	
{- Parser -}

parseIntern		:: [Token] -> Token
parseIntern	x	= stripSubExp (head (parseApplication (parseCons (fst (parseFunctions (fst (parseTT (expandNumbers (expandStrings x)))))))))

onReverse		:: ([a] -> [a]) -> [a] -> [a]
onReverse x y	= (reverse (x (reverse y)))

expandStrings					:: [Token] -> [Token]
expandStrings []				= []
expandStrings ((String x):rest)	= (xtail (concatMap toNums x)) ++ (expandStrings rest)
								where
									toNums x	= [TCons,TLT,Number (toInteger (fromEnum x)),TGT]
									xtail []	= []
									xtail (h:t)	= t
expandStrings (h:rest)			= h:(expandStrings rest)

expandNumbers					:: [Token] -> [Token]
expandNumbers []				= []
expandNumbers ((Number x):rest)	= (toNils x) ++ (expandNumbers rest)
								where
									toNils 0   	= [TNil]
									toNils (n+1)	= TNil:(TCons:(toNils n))
expandNumbers (h:rest)			= h:(expandNumbers rest)

parseTT			:: [Token] -> ([Token],[Token])
parseTT []		= ([],[])
parseTT (TGT:y)	= ([],y)
parseTT (TLT:y)	= ((SubExp frst:snd),thrd)
				where
					(frst,lst) = parseTT y
					(snd,thrd) = parseTT lst
						
parseTT (x:y)	= ((x:frst),lst)
				where (frst,lst) = parseTT y

partitionWhen 			:: (a -> Bool) -> [a] -> Maybe ([a],[a])
partitionWhen f x@(h:t)	= 	if f h then
								Just ([],x)
							else case (partitionWhen f t) of
								Nothing		-> Nothing
								Just (q,r)	-> Just ((h:q),r)
partitionWhen f []		= Nothing

partitionWhen2			:: (a -> Bool) -> [a] -> Maybe ([a],a,[a])
partitionWhen2 f x		= case (partitionWhen f x) of
							Nothing		-> Nothing
							Just (q,h:t)-> Just (q,h,t)



parseFunctions		:: [Token] -> ([Token],[Token])
parseFunctions x	= case (partitionWhen2 (\y -> y == TFunction || y == Fail) x) of
						Nothing					-> ((parseSubFunctions x),[])
						Just (fl,Fail,frst)		-> (fl,frst)
						Just (a,TFunction,c) 	-> let
													(def,rst) = parseFunctions c
													(frst,lrst) = parseFunctions rst
													in ([NFunction (SubExp (fst (parseFunctions a))) (SubExp (fst (parseFunctions def))) (SubExp (fst (parseFunctions frst)))],lrst)
											
parseSubFunctions					:: [Token] -> [Token]
parseSubFunctions []				= []
parseSubFunctions ((SubExp x):t)	= (SubExp (fst (parseFunctions x))):(parseSubFunctions t)
parseSubFunctions (x:t)				= x:(parseSubFunctions t)

parseApplication					:: [Token] -> [Token]
parseApplication x					= foldr iteration [] (reverse x)
										where
											iteration itema (itemb:rest)	= (NApplication itemb (parseSubApplication itema)):rest
											iteration item []				= [parseSubApplication item]
											
parseSubApplication						:: Token -> Token
parseSubApplication (SubExp x)			= SubExp (parseApplication x)
parseSubApplication (NFunction x y z)	= NFunction (parseSubApplication x) (parseSubApplication y) (parseSubApplication z)
parseSubApplication (NCons x y)			= NCons (parseSubApplication x) (parseSubApplication y) 
parseSubApplication	x					= x

parseCons							:: [Token] -> [Token]
parseCons x							= foldr iteration [] x
										where
											iteration itema (TCons:(itemb:rest))	= (NCons (parseSubCons itema) itemb):rest
											iteration item list						= (parseSubCons item):list
											
parseSubCons					:: Token -> Token
parseSubCons (SubExp x)			= SubExp (parseCons x)
parseSubCons (NFunction x y z)	= NFunction (parseSubCons x) (parseSubCons y) (parseSubCons z)
parseSubCons x					= x


stripSubExp						:: Token -> Token
stripSubExp (SubExp [a])		= stripSubExp a
stripSubExp (SubExp [])			= TNil
stripSubExp (NCons a b)			= NCons (stripSubExp a) (stripSubExp b)
stripSubExp (NFunction a b c)	= NFunction (stripSubExp a) (stripSubExp b) (stripSubExp c)
stripSubExp (NApplication a b)	= NApplication (stripSubExp a) (stripSubExp b)
stripSubExp a					= a

tokenToNode								:: Token -> [(String,Uniqs)] -> Uniqs -> Node
tokenToNode TNil _ _					= Nil
tokenToNode (NCons a b) tab cn			= Cons (tokenToNode a tab (A cn)) (tokenToNode b tab (B cn))
tokenToNode (NApplication a b) tab cn	= Application (tokenToNode a tab (A cn)) (tokenToNode b tab (B cn))
tokenToNode (NFunction a b c) tab cn	= let (ac,ntab) = functionPtrnToNode a tab (C cn)
											in (Function ac (tokenToNode b ntab (A cn)) (tokenToNode c tab (B cn)))
tokenToNode (Variable n) tab _			= let Just a = (lookup n tab)
											in (Symbol a)

functionPtrnToNode								:: Token -> [(String,Uniqs)] -> Uniqs -> (Node,[(String,Uniqs)])
functionPtrnToNode TNil tab	_					= (Nil,tab)
functionPtrnToNode (NCons a b) tab cn 			= 	let
														(newa,tab2) = functionPtrnToNode a tab (A cn)
														(newb,tab3) = functionPtrnToNode b tab2 (B cn)
													in ((Cons newa newb),tab3)
functionPtrnToNode (NApplication a b) tab cn	= 	let
										   	 			(newa,tab2) = functionPtrnToNode a tab (A cn)
										   	 			(newb,tab3) = functionPtrnToNode b tab2 (B cn)
										   	 		in ((Application newa newb),tab3)
functionPtrnToNode a@(NFunction _ _ _) tab cn	= ((tokenToNode a tab cn),tab)

functionPtrnToNode (Variable n)	tab cn			= case (lookup n tab) of
													Just a -> (Symbol a,tab)
													Nothing -> (Symbol cn,((n,cn):tab))
																
functionPtrnToNode (NewVariable n) tab cn  		= (Symbol cn,((n,cn):(deleteBy filter (n,cn) tab)))
												where filter (a,_) (b,_) = a == b