--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/interps/rhotor/Parser.hs	Sun Dec 09 19:30:08 2012 +0000
@@ -0,0 +1,220 @@
+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
+												
\ No newline at end of file