implementation module SmurfParse

from StdFunc import o, flip
import StdArray
import StdChar
import StdList
import StdMisc
import StdFile
import StdTuple
import StdString

from Data.Func import $
import Data.Maybe
import Control.Applicative
import Control.Monad

import Smurf

eToVarChars :: Expr -> [VarChar]
eToVarChars (Lit s)         = map Char $ fromString s
eToVarChars (Var v)         = [VarString v]
eToVarChars (ECat a b)      = eToVarChars a ++ eToVarChars b
eToVarChars (EHead (Var v)) = abort "head of var\n"
eToVarChars (EHead a)       = [hd $ eToVarChars a]
eToVarChars (ETail (Var v)) = abort "tail of var\n"
eToVarChars (ETail a)       = tl $ eToVarChars a
eToVarChars (EQuotify a)    = [Quoted a]

parse :: ![Char] -> Maybe Program
parse cs = parsev $ map Char cs

parsev :: ![VarChar] -> Maybe Program
parsev []            = pure []
parsev [Char '"':cs] = parseString cs >>= \(s,cs`) -> append (Push s) $ parsev cs`
parsev [Char 'i':cs] = apparse Input cs
parsev [Char 'o':cs] = apparse Output cs
parsev [Char '+':cs] = apparse Cat cs
parsev [Char 'h':cs] = apparse Head cs
parsev [Char 't':cs] = apparse Tail cs
parsev [Char 'q':cs] = apparse Quotify cs
parsev [Char 'p':cs] = apparse Put cs
parsev [Char 'g':cs] = apparse Get cs
parsev [Char 'x':cs] = apparse Exec cs
parsev [Char c:cs]   = if (isSpace c) (parsev cs) empty
parsev [Quoted e:cs] = apparse (Push e) cs
parsev _             = empty

apparse :: Stm -> [VarChar] -> Maybe Program
apparse stm = append stm o parsev

append :: a (m [a]) -> m [a] | Monad m
append x mx = mx >>= \xs -> pure [x:xs]

parseString :: ![VarChar] -> Maybe (Expr, [VarChar])
parseString cs = pS [] cs
where
	pS :: ![VarChar] ![VarChar] -> Maybe (Expr, [VarChar])
	pS _ []             = empty
	pS s [Char '"':cs]
		= pure (toExpr $ reverse s, cs)
	pS s [Char '\\':Char 'n':cs]  = pS [Char '\n':s] cs
	pS s [Char '\\':Char 'r':cs]  = pS [Char '\r':s] cs
	pS s [Char '\\':Char 't':cs]  = pS [Char '\t':s] cs
	pS s [Char '\\':Char '\\':cs] = pS [Char '\\':s] cs
	pS s [Char '\\':Char '"':cs]  = pS [Char '"':s] cs
	pS s [c:cs]                   = pS [c:s] cs

	toExpr :: [VarChar] -> Expr
	toExpr cs = simplify $ te cs
	where
		te :: [VarChar] -> Expr
		te []               = Lit ""
		te [VarString v:cs] = ECat (Var v) (te cs)
		te [Char c:cs]      = ECat (Lit {c}) (te cs)
		te [Quoted e:cs2]   = ECat e (te cs2)
		
		simplify :: Expr -> Expr
		simplify (ECat a b) = case (simplify a, simplify b) of
			(Lit x, Lit y) = Lit $ x +++ y
			(x, y)         = ECat x y
		simplify e = e