parseu.u

(import* io)
(import* str)
(import* lexpru)
; SPosition (Int,Int)
(def SPosition ^2)
(def SFail (\msg pos (\on_fail on_succ (on_fail msg pos))))
(def SSucc (\a (\on_fail on_succ (on_succ a))))
(def <-SMF (\x (x SFail)))
(def ,<-SMF (\x (. (<-SMF x) feed)))

(def showSPosition (showPair showInt showInt))
(let showPositionedChar (showPair showCharL showSPosition))
(let showListPositionedChar (showList showPositionedChar))

(def STAtom (\a f1 f2 f3 f4 f5 f6 f7 (f1 a)))
(def STInt (\a f1 f2 f3 f4 f5 f6 f7 (f2 a)))
(def STDouble (\a f1 f2 f3 f4 f5 f6 f7 (f3 a)))
(def STLeftPar (\f1 f2 f3 f4 f5 f6 f7 f4))
(def STRightPar (\f1 f2 f3 f4 f5 f6 f7 f5))
(def STLambda (\f1 f2 f3 f4 f5 f6 f7 f6))
(def STStr (\a f1 f2 f3 f4 f5 f6 f7 (f7 a)))
(def showSToken (\t (t
	(\a (. (showString "STAtom ") (showStringL a)))
	(\a (. (showString "STInt ") (showInt a)))
	(\a (. (showString "STDouble ") (showFloat a)))
	(showString "STLeftPar")
	(showString "STRightPar")
	(showString "STLambda")
	(\a (. (showString "STStr ") (showStringL a) ))
)))
(let showPositionedSTToken (showPair showSToken showSPosition))
(let showListPositionedSTToken (showList showPositionedSTToken))
(def caseSTAtom     (\s e c (s     e (K c) (K c) c c c (K c))))
(def caseSTInt      (\s e c (s (K c)     e (K c) c c c (K c))))
(def caseSTDouble   (\s e c (s (K c) (K c)     e c c c (K c))))
(def caseSTLeftPar  (\s e c (s (K c) (K c) (K c) e c c (K c))))
(def caseSTRightPar (\s e c (s (K c) (K c) (K c) c e c (K c))))
(def caseSTLambda   (\s e c (s (K c) (K c) (K c) c c e (K c))))
(def caseSTStr      (\s e c (s (K c) (K c) (K c) c c c     e)))

(def STTNode (\a f1 f2 (f1 a)))
(def STTList (\a f1 f2 (f2 a)))
(def showSTokenTree (\t (let
	(show' (recur (\self (\t indent pos (t
		(\token (do
			( (iterateN indent (cons ' ')))
			( (showSToken token))
			( (showString ";"))
			( (showSPosition pos))
			( (showString "\n"))
			return
		))
		(\trees (do
			( (iterateN indent (cons ' ')))
			( (showString "STTree;"))
			( (showSPosition pos))
			( (showString "\n"))
			( (concatShow (map (\xp (self (fst xp) (+ indent 1) (snd xp))) trees)))
			return
		))
	)))))
	(show' t 0 (SPosition 0 0))
)))
(def caseSTTNode (\s e c (s e     (K c))))
(def caseSTTList (\s e c (s (K c) e    )))

; data SSExp = SSInt Int | SSDouble Double | SSLambda [Char] (SSExp,SPosition) | SSRef [Char] | SSApply (SSExp,SPosition) (SSExp,SPosition)
(def SSInt (\a f1 f2 f3 f4 f5 (f1 a)))
(def SSDouble (\a f1 f2 f3 f4 f5 (f2 a)))
(def SSLambda (\a b f1 f2 f3 f4 f5 (f3 a b)))
(def SSRef (\a f1 f2 f3 f4 f5 (f4 a)))
(def SSApply (\a b f1 f2 f3 f4 f5 (f5 a b)))

(def showSSExpP (\showpos (recur (\self (\e indent pos (let
	(posComment (\pos (. (showString " #|") (. (showSPosition pos) (showString "|#")))))
	(e
		(\i (. (showString (itoa i)) (showpos (posComment pos) id)))
		(\d (. (showString (ftoa d)) (showpos (posComment pos) id)))
		(\name pbody (do
			(body p pbody)
			( (showString "(\\"#|)|#))
			( (showString name))
			( (showpos (do
				( (showString " ;"))
				( (showSPosition pos))
				return) id))
			( (showString "\n"))
			( (iterateN (+ indent 1) (cons ' ')))
			( (self body (+ indent 1) p ))
			( (showString #|(|#")"))
			return
		))
		(\ref (. (showString ref) (showpos (posComment pos) id)))
		(\pl1 pl2 (do
			(e1 p1 pl1)
			(e2 p2 pl2)
			( (showString "("#|)|#))
			( (self e1 (+ indent 1) p1))
			( (showString "\n"))
			( (iterateN (+ indent 1) (cons ' ')))
			( (self e2 (+ indent 1) p2))
			( (showString #|(|#")"))
			return
		))
	)
))))))
(def showSSExp (\e (showSSExpP True e 0 (SPosition 0 0))))

(def SVLocal !0_2)
(def SVGlobal !1_2)
(def showSVisibility (\s (showString (s "let" "def"))))
(def SIQualified !0_2)
(def SIUnqualified !1_2)
(def showSImportMode (\m (showString (m "import" "import*"))))
;data SSImport = SSImport [Char] SImportMode deriving Show
(def SSImport ^2)
(def showSSImport (feed (\name mode (do
	( (showString "("))
	( (showSImportMode mode))
	( (showString " "))
	( (showString name))
	( (showString ")"))
	return
))))
;data SSDef = SSDef [Char] (SSExp,SPosition) SVisibility deriving Show
(def SSDef ^3)
(def showSSDef (feed (\name ep vis (do
	(exp pos ep)
	( (showString "("))
	( (showSVisibility vis))
	( (showString " "))
	( (showString name))
	( (showString "\n "))
	( (showSSExpP True exp 1 pos))
	( (showString ")"))
	return
))))
(def showSSDefP (\showpos pos (feed (\name ep vis (do
	(exp pos ep)
	( (showString "("))
	( (showSVisibility vis))
	( (showString " "))
	( (showString name))
	( (showpos (do
		( (showString " ;"))
		( (showSPosition pos))
		return) id))
	( (showString "\n "))
	( (showSSExpP showpos exp 1 pos))
	( (showString ")"))
	return
)))))
;data SSModule = SSModule [(SSImport,SPosition)] [(SSDef,SPosition)] deriving Show
(def SSModule ^2)
(def showSSModuleP (\showpos (feed (\imports defs (do
	( (concatShow (map (\p (do
		(e pos p)
		( (showSSImport e))
		( (showpos (do
			( (showString " ;"))
			( (showSPosition pos))
			return) id))
		( (cons '\n'))
		return
	)) imports)))
	( (concatShow (intersperse (cons '\n') (map (\p (do
		(e pos p)
		( (showSSDefP showpos pos e))
		return
	)) defs))))
	return
)))))
(def showSSModule (showSSModuleP True))

(def annotatePositions (\content
	(zip content (scanl
		(\l0c0 c (l0c0 (\l0 c0
			((= c '\n') (pair (+ 1 l0) 0)
				(pair l0 (+ 1 c0)))
		))) (SPosition 0 0) content)
	)
))
(def dropWhiteSpace (recur (\self (\l (run    ; SMayFail [(Char,SPosition)]
	(aap ar (l (SSucc empty)))
	(a ap aap)
	( ((isSpace a) (self ar)))
	( ((= a ';') (self (dropWhile (. (/= '\n') fst) ar))))
	(let waitUntilClose (recur (\f (\ar ap (run
		(har arr (ar (SFail "unclosed block comment" ap)))
		(harr arrr (arr (SFail "unclosed block comment" ap)))
		( ((and (= (fst har) '|') (= (fst harr) '#')) (self arrr)))
		(f arr ap)
	)))))
	( (\c ((/= a '#') c (ar c (\har arr ((= (fst har) '|') (waitUntilClose arr ap) c))))))
	(SSucc l)
)))))

(let isValidCharInt (\a (and (>= a 0) (< a 256))))

;splitChrSpecial :: [(Char,SPosition)] -> SPosition -> SMayFail (Char,[(Char,SPosition)])
(def splitChrSpecial (\ar ap (run
	(har arr (ar (SFail "incomplete escape sequence" ap)))
	( ((= (fst har) 'a') (SSucc (pair '\a' arr))))
	( ((= (fst har) 'b') (SSucc (pair '\b' arr))))
	( ((= (fst har) 'n') (SSucc (pair '\n' arr))))
	( ((= (fst har) 'r') (SSucc (pair '\r' arr))))
	( ((= (fst har) 'v') (SSucc (pair '\v' arr))))
	( ((= (fst har) 'f') (SSucc (pair '\f' arr))))
	( ((= (fst har) 't') (SSucc (pair '\t' arr))))
	( ((= (fst har) '\\') (SSucc (pair '\\' arr))))
	( ((= (fst har) '\'') (SSucc (pair '\'' arr))))
	( ((= (fst har) '\"') (SSucc (pair '\"' arr))))
	( ((= (fst har) 'x') (run
		(npart arrr (span (. isDigit fst) arr))
		(_ _ (npart (SFail "\\x must be followed by digits" ap)))
		(let c_int (intFromDigits (map fst npart)))
		( (isValidCharInt c_int (SSucc (pair c_int arrr))))
		(SFail "\\x value not in range" ap)
	)))
	(SSucc (pair (fst har) arr))
)))
; splitStrLiteral :: [(Char,SPosition)] -> SPosition -> SMayFail ((SToken,SPosition),[(Char,SPosition)])
(def splitStrLiteral (\ar ap (run
	; splitStrLiteralS :: [(Char,SPosition)] -> SMayFail ([Char],[(Char,SPosition)])
	(let splitStrLiteralS (recur (\self (\ar ap (run
		(har arr (ar (SFail "unmatched \"" ap)))
		( ((= (fst har) '"') (SSucc (pair "" arr))))
		( ((= (fst har) '\\') (run
			(c arrr (,<-SMF (splitChrSpecial arr (snd har))))
			(sr arrrr (,<-SMF (self arrr ap)))
			(SSucc (pair (cons c sr) arrrr))
		)))
		(sr arrr (,<-SMF (self arr ap)))
		(SSucc (pair (cons (fst har) sr) arrr))
	)))))
	(ps (<-SMF (splitStrLiteralS ar ap)))
	(s r ps)
	(SSucc (pair (pair (STStr s) ap) r))
)))
; splitCharLiteral :: [(Char,SPosition)] -> SPosition -> SMayFail ((SToken,SPosition),[(Char,SPosition)])
(def splitCharLiteral (recur (\self (\ar ap (run
	(har arr (ar (SFail "unmatched \'" ap)))
	( ((= (fst har) '\'') (SFail "empty ''" ap)))
	(let on_error (SFail "unmatched \'" ap))
	( ((= (fst har) '\\') (run
		(c arrr (,<-SMF (splitChrSpecial arr ap)))
		(harrr arrrr (arrr on_error))
		( ((= (fst harrr) '\'') (SSucc (pair (pair (STInt c) ap) arrrr))))
		on_error
	)))
	(harr arrr (arr on_error))
	( ((= (fst harr) '\'') (SSucc (pair (pair (STInt (fst har)) ap) arrr))))
	on_error
)))))
(def isStopChar (\c (or (isSpace c) (any (= c) "()\\;"))))

; splitNumLiteral :: [(Char,SPosition)] -> SMayFail ((SToken,SPosition),[(Char,SPosition)]) 
(def splitNumLiteral (\a (run
	(let ap (a (SPosition 0 0) (\h _ (snd h))))
	(sign a1 (run
		(ha ar (a (pair 1 a)))
		( ((= (fst ha) '+') (pair 1 ar)))
		( ((= (fst ha) '-') (pair -1 ar)))
		(pair 1 a)
	))
	(before_dot after_dot1 (span (. isDigit fst) a1))
	(let intret (SSucc (pair (pair (STInt (* sign (intFromDigits (map fst before_dot)))) ap) after_dot1)))
	( (\c (after_dot1 intret (\h r ((isStopChar (fst h)) intret c)))))
	(let after_dot (after_dot1 after_dot1 (\h r ((= (fst h) '.') r after_dot1))))
	(before_e after_e1 (span (. isDigit fst) after_dot))
	(has_e after_e (run
		(let other (pair False after_e1))
		(h r (after_e1 other))
		( ((= (fst h) 'e') (pair True r)))
		( ((= (fst h) 'E') (pair True r)))
		other
	))
	(neg_e after_es (run
		(let other (pair False after_e))
		( ((not has_e) other))
		(h r (after_e other))
		( ((= (fst h) '+') (pair False r)))
		( ((= (fst h) '-') (pair True r)))
		other
	))
	(before_end remain (span (. isDigit fst) after_es))
	( ((and has_e (null before_end)) (SFail "invalid float literal " ap)))
	(let int_part (intFromDigits (map fst before_dot)))
	(let mentisa_part (sum (zipWith * (map (. intFromDigit fst) before_e) (iterate (* 0.1) 0.1))))
	(let expint (before_end 0 (\_ _ (intFromDigits (map fst before_end)))))
	(let expbase (neg_e 0.1 10))
	(let e_part (iterateN expint (* expbase) 1))
	(SSucc (pair (pair (STDouble (* sign (* e_part (+ int_part mentisa_part)))) ap) remain))
)))

; splitFirstString :: [(Char,SPosition)] -> SMayFail ((SToken,SPosition),[(Char,SPosition)])
(def splitFirstString (\la (run
	(aap ar (la 0))
	(a ap aap)
	( ((= a '(') (SSucc (pair (pair STLeftPar ap) ar))))
	( ((= a ')') (SSucc (pair (pair STRightPar ap) ar))))
	( ((= a '\\') (SSucc (pair (pair STLambda ap) ar))))
	( ((= a '"') (splitStrLiteral ar ap)))
	( ((= a '\'') (splitCharLiteral ar ap)))
	( (((isDigit a) True ((any (= a) "+-.") (ar False (\h r (isDigit (fst h)))) False)) (splitNumLiteral la)))
	( ((isDigit a) (SFail "invalid number literal" ap)))
	(al arr (span (. not (. isStopChar fst)) la))
	(SSucc (pair (pair (STAtom (map fst al)) ap) arr))
)))

; groupStrings :: [(Char,SPosition)] -> SMayFail [(SToken,SPosition)] 
(def groupStrings (recur (\self (\x (run
	(dropped (<-SMF (dropWhiteSpace x)))
	(let groupStrings' (\a (run
		(_ _ (a (SSucc empty)))
		(f r (,<-SMF (splitFirstString a)))
		(remain (<-SMF (self r)))
		(SSucc (cons f remain))
	)))
	(groupStrings' dropped)
)))))

;firstTokenTree :: [(SToken,SPosition)] -> SMayFail ((STokenTree,SPosition),[(SToken,SPosition)])
(def firstTokenTree (recur (\self (\a (run
	(ha ar (a 0))
	(tha pha ha)
	(let groupUntilRightPar (recur (\self2 (\a sp (run
		(ha ar (a (SFail "unmatched (" #|)|# sp)))
		(tha pha ha)
		( (caseSTRightPar tha (SSucc (pair empty ar))))
		(t rr (,<-SMF (self a)))
		(ts rrr (,<-SMF (self2 rr sp)))
		(SSucc (pair (cons t ts) rrr))
	)))))
	( (caseSTLeftPar tha (run
		(trees remain (,<-SMF (groupUntilRightPar ar pha)))
		( ((null trees) (SFail "empty ()" pha)))
		(SSucc (pair (pair (STTList trees) pha) remain))
	)))
	( (caseSTRightPar tha (SFail #|(|# "unmatched )" pha)))
	(SSucc (pair (pair (STTNode tha) pha) ar))
)))))

;groupTokenTree :: [(SToken,SPosition)] -> SMayFail [(STokenTree,SPosition)]
(def groupTokenTree (recur (\self (\a (run
	(_ _ (a (SSucc empty)))
	(tt remain (,<-SMF (firstTokenTree a)))
	(rt (<-SMF (self remain)))
	(SSucc (cons tt rt))
)))))

;parseSSExp :: (STokenTree,SPosition) -> SMayFail (SSExp,SPosition)
(def parseSSExp (recur (\self (\ptree (run
	(tree sp ptree)
	(let constructApplySugar (recur (\self2 (\trees ep (run
		(ht rt (trees (SSucc ep)))
		(e1 p1 (,<-SMF (self ht)))
		(self2 rt (pair (SSApply ep (pair e1 p1)) (snd ep)))
	)))))
	(let constructLambdaSugar (recur (\self2 (\r p (run
		(hr rr (r (SFail "incomplete lambda expression" p)))
		(thr phr hr)
		(hrr rrr (rr (SFail "incomplete lambda expression" p)))
		(_ _ (rrr (run
			( (caseSTTNode thr (\token (run
				( (caseSTAtom token (\name (run
					(ebody pb (,<-SMF (self hrr)))
					(K (SSucc (pair (SSLambda name (pair ebody pb)) phr)))
				))))
				id
			)) id))
			(SFail "lambda expression needs a variable name" p)
		)))
		( (caseSTTNode thr (\token (run
			( (caseSTAtom token (\name (run
				(ebody pb (,<-SMF (self2 rr p)))
				(K (SSucc (pair (SSLambda name (pair ebody pb)) phr)))
			))))
			id
		)) id))
		(SFail "lambda expression needs a variable name" p)
	)))))
	(let constructRunSugar (recur (\self2 (\r p (run
		(hr rr (r (SFail "empty do/run clause" p)))
		(_ _ (rr (self hr)))
		(thr phr hr)
		(let on_error (SFail "invalid syntax in do/run clause" p))
		( (caseSTTList thr (\trees (run
			( (run
				(htrees rtrees (trees id))
				(thtrees p0 htrees)
				(token (. (feed id) (caseSTTNode thtrees)))
				(letstr (. (feed id) (caseSTAtom token)))
				( (. (feed id) (eqStr letstr "let")))
				(hrtrees rrtrees (rtrees id))
				(thrtrees _ hrtrees)
				(token2 (. (feed id) (caseSTTNode thrtrees)))
				(name (. (feed id) (caseSTAtom token2)))
				(e rrrtrees (rrtrees id))
				( (. (feed id) (null rrrtrees)))
				( K)
				(e1 p1 (,<-SMF (self e)))
				(e2 p2 (,<-SMF (self2 rr p)))
				(SSucc (pair (SSApply (pair (SSLambda name (pair e2 p2)) phr) (pair e1 p1)) p0))
			))
			( (run
				(htrees listr (trees id))
				( K)
				(n0 p0 htrees)
				(let name_node (foldr1 cons (K empty) empty trees))
				(let ebody (foldr1 !1_2 id htrees listr))
				(let mnames (foldr (\pnode m_cur (run
					(cur (m_cur nothing))
					(node pos pnode)
					(token (. (feed nothing) (caseSTTNode node)))
					(name (. (feed nothing) (caseSTAtom token)))
					(just (cons (pair name pos) cur))
				)) (just empty) name_node))
				(names (mnames (SFail "invalid syntax in do/run clause" p0)))
				(e1 p1 (,<-SMF (self ebody)))
				(e2 p2 (,<-SMF (self2 rr p)))
				(let absremain (foldr (\namepos ep (pair (SSLambda (fst namepos) ep) (snd namepos))) (pair e2 p2) names))
				(SSucc (pair (SSApply (pair e1 p1) absremain) p0))
			))
			on_error
		))))
		on_error
	)))))
	(let constructDoSugar (\r p (run
		(e1 p1 (,<-SMF (constructRunSugar r p)))
		(SSucc (pair (SSLambda "return" (pair e1 p1)) p))
	)))
	(let constructLetSugar (recur (\self2 (\r p (run
		(hr rr (r (SFail "empty let clause" p)))
		(_ _ (rr (self hr)))
		(thr phr hr)
		( (run
			(trees (. (feed id) (caseSTTList thr)))
			(htrees rtrees (trees id))
			(e rrtrees (rtrees id))
			( (. (feed id) (null rrtrees)))
			(thtrees p0 htrees)
			(token (. (feed id) (caseSTTNode thtrees)))
			(name (. (feed id) (caseSTAtom token)))
			( K)
			(e1 p1 (,<-SMF (self e)))
			(e2 p2 (,<-SMF (self2 rr p)))
			(SSucc (pair (SSApply (pair (SSLambda name (pair e2 p2)) p0) (pair e1 p1)) p0))
		))
		(SFail "invalid syntax in let clause" phr)
	)))))
	(let constructListSugar (recur (\self2 (\r p (run
		(hr rr (r (SSucc (pair (SSLambda "f" (pair (SSLambda "g" (pair (SSRef "f") p)) p)) p))))
		(e1 p1 (,<-SMF (self hr)))
		(remain p2 (,<-SMF (self2 rr p)))
		(SSucc (pair (SSLambda "f" (pair (SSLambda "g" (pair (SSApply (pair (SSApply (pair (SSRef "g") p1) (pair e1 p1)) p1) (pair remain p2)) p1)) p1)) p1))
	)))))
	(let constructStrSugar (\sp (foldr
		(\a remain (pair (SSLambda "f" (pair (SSLambda "g" (pair (SSApply (pair (SSApply (pair (SSRef "g") sp) (pair (SSInt a) sp)) sp) remain) sp)) sp)) sp))
		(pair (SSLambda "f" (pair (SSLambda "g" (pair (SSRef "f") sp)) sp)) sp)
	)))

	(tree
		(\token (let ; STTNode
			(other (SFail "illegal token " sp))
			(token
				(\name (SSucc (pair (SSRef name) sp)))
				(\i (SSucc (pair (SSInt i) sp)))
				(\d (SSucc (pair (SSDouble d) sp)))
				other
				other
				other
				(\s (SSucc (constructStrSugar sp s)))
			)
		))
		(\trees (run
			(ht rt (trees (SFail "empty expression" sp)))
			(tht pht ht)
			( (caseSTTNode tht (\token (run
				( (caseSTLambda token (K (constructLambdaSugar rt pht))))
				( (caseSTAtom token (\name (run
					( ((eqStr name "lambda") (K (constructLambdaSugar rt pht))))
					( ((eqStr name "run") (K (constructRunSugar rt pht))))
					( ((eqStr name "do") (K (constructDoSugar rt pht))))
					( ((eqStr name "let") (K (constructLetSugar rt pht))))
					( ((eqStr name "list") (K (constructListSugar rt pht))))
					id
				))))
				id
			)) id))
			(_ _ (trees (SFail "extra parenthesis" sp)))
			(e1 p1 (,<-SMF (self ht)))
			(constructApplySugar rt (pair e1 p1))
		))
	)
)))))
(def extractLExpr (recur (\self (\s (s
	(\i (LInt i))
	(\d (LDouble d))
	(\name body (LAbs name (self (fst body))))
	(\ref (LRef ref))
	(\l1 l2 (LApply (self (fst l1)) (self (fst l2))))
)))))

(def parseSSModule (\trees (run
	(let getImportBlock (recur (\self2 (\blocks (run
		(hb rb (blocks (SSucc (pair empty empty))))
		( (run
			(thb p1 hb)
			(lst (. (feed id) (caseSTTList thb)))
			(hlst rlst (lst id))
			(thlst phlst hlst)
			(token (. (feed id) (caseSTTNode thlst)))
			(stmt (. (feed id) (caseSTAtom token)))
			(mode (feed id (run
				( ((eqStr stmt "import") (just SIQualified)))
				( ((eqStr stmt "import*") (just SIUnqualified)))
				nothing
			)))
			(hrlst rrlst (rlst id))
			( (. (feed id) (null rrlst)))
			(thrlst phrlst hrlst)
			(token2 (. (feed id) (caseSTTNode thrlst)))
			(name (. (feed id) (caseSTAtom token2)))
			( K)
			(sis remain (,<-SMF (self2 rb)))
			(SSucc (pair (cons (pair (SSImport name mode) p1) sis) remain))
		))
		(SSucc (pair empty blocks))
	)))))
	(let getDefBlock (recur (\self2 (\blocks (run
		(hb rb (blocks (SSucc (pair empty empty))))
		( (run
			(thb p1 hb)
			(lst (. (feed id) (caseSTTList thb)))
			(hlst rlst (lst id))
			(thlst phlst hlst)
			(token (. (feed id) (caseSTTNode thlst)))
			(stmt (. (feed id) (caseSTAtom token)))
			(vis (feed id (run
				( ((eqStr stmt "def") (just SVGlobal)))
				( ((eqStr stmt "let") (just SVLocal)))
				nothing
			)))
			(hrlst rrlst (rlst id))
			(thrlst phrlst hrlst)
			(token2 (. (feed id) (caseSTTNode thrlst)))
			(name (. (feed id) (caseSTAtom token2)))
			(body rrrlst (rrlst id))
			( (. (feed id) (null rrrlst)))
			( K)
			(firstexp p2 (,<-SMF (parseSSExp body)))
			(sds remain (,<-SMF (self2 rb)))
			(SSucc (pair (cons (pair (SSDef name (pair firstexp p2) vis) p1) sds) remain))
		))
		(SSucc (pair empty blocks))
	)))))
	(simports others1 (,<-SMF (getImportBlock trees)))
	(sdefs others2 (,<-SMF (getDefBlock others1)))
	(h2 r2 (others2 (SSucc (SSModule simports sdefs))))
	( ((not (null r2)) (SFail "illegal declaration" (snd h2))))
	(e p h2)
	(e1 p1 (,<-SMF (parseSSExp h2)))
	(SSucc (SSModule simports (++ sdefs (list (pair (SSDef "main" (pair e1 p1) SVGlobal) p)))))
)))

(def parseSSModuleStr (\a (run
	( (feed (annotatePositions a)))
	( (.(.(feed(. <-SMF groupStrings)).)feed))
	( (.(.(feed(. <-SMF groupTokenTree)).)feed))
	parseSSModule
)))

(run
	;(let inp " ;haha\n #|lala|# #| papa|# ; pia\n(def a 1)\n(+ a 2)")
	(fin (open "testcomp.u" ReadMode))
	(inp (readContentF fin))
	(_ (close fin))
	;(let inp "' '")
	;(let inp "")
	;(let inp " a\\nbc\" a")
	;(let inp "(a' bc)")
	;(let inp "")
	;(let inp "(+ (+ a b) c)")
	;(let inp "\\a a")
	;(let inp "((\\a b a) b)")
	;(let inp "a")
	;(let inp "(run (a 1) (b 2) (x x))")
	;(let annotated (annotatePositions inp))
	;(_ (putStrLn (showListPositionedChar annotated "")))
	(let onSError (\msg pos (run
		(_ (putStr (++ "parser error: " (++ msg " at "))))
		(_ (putStrLn (showSPosition pos "")))
		(exit 1)
	)))
	; (chopped (dropWhiteSpace annotated onSError))
	; (_ (putStrLn (showListPositionedChar chopped "")))
	; (_ (putStrLn (map fst chopped)))
	;(splitted (splitChrSpecial annotated (SPosition 0 0) onSError))
	;(c r splitted)
	;(_ (putStrLn (itoa c)))
	;(pst r (. (splitStrLiteral annotated (SPosition 0 0) onSError) feed))
	;(pst r (. (splitCharLiteral annotated (SPosition 0 0) onSError) feed))
	;(pst r (. (splitNumLiteral annotated onSError) feed))
	;(pst r (. (splitFirstString annotated onSError) feed))
	;(_ (putStrLn (showSToken (fst pst) "")))
	;(_ (putStrLn (showSPosition (snd pst) "")))
	;(_ (putStrLn (showListPositionedChar r "")))
	;(sts (groupStrings annotated onSError))
	;(_ (putStrLn (showListPositionedSTToken sts "")))
	;(_ (putStr (showSTokenTree 
		;(STTList (list 
			;(pair (STTNode (STAtom "ha")) (SPosition 0 1))
			;(pair (STTNode (STAtom "pia")) (SPosition 0 2))
		;))
		;"")))
	;(pt r (. (firstTokenTree sts onSError) feed))
	;(t p pt)
	;(_ (putStr (showSTokenTree t "")))
	;(_ (putStrLn (showSPosition p "")))
	;(stts (groupTokenTree sts onSError))
	;(_ (putStrLn (showList (showPair showSTokenTree showSPosition) stts "")))
	;(hstts _ (stts 0))
	;(exp pos (. (parseSSExp hstts onSError) feed))
	;(_ (putStrLn (showSSExp exp "")))
	;(_ (putStrLn (showSPosition pos "")))
	;(let lexpr (extractLExpr exp))
	;(_ (putStrLn (showLExpr lexpr "")))
	;(_ (putStrLn (showSSImport (SSImport "io" SIQualified) "")))
	;(_ (putStrLn (showSSImport (SSImport "str" SIUnqualified) "")))
	;(_ (putStrLn (showSSModule (SSModule
		;(list
			;(pair (SSImport "io" SIQualified) (SPosition 0 0))
			;(pair (SSImport "str" SIUnqualified) (SPosition 0 1))
		;)
		;(list
			;(pair (SSDef "a" (pair (SSInt 1) (SPosition 0 0)) SVGlobal) (SPosition 1 2))
			;(pair (SSDef "b" (pair (SSInt 2) (SPosition 0 1)) SVLocal) (SPosition 1 3))
		;)
	;) "")))
	(mod (parseSSModuleStr inp onSError))
	(_ (putStrLn (showSSModule mod "")))
	(exit 0)
)