blob: bf59b643939c15e1484538483a3b9d5eadc7aaea (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
|
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
|
