UScheme.hs

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
82
83
module UScheme
where

import Control.Applicative hiding ((<|>), many)
import Data.Char (isDigit, isSpace)
import Data.Map
import Prelude hiding (exp)
import Text.Parsec

type Parser a = Parsec String () a

data Def = Val Name Exp
         | Exp Exp
         | Define Name Lambda
         deriving Show

data Exp = Literal Value
         | Var Name
         | If Exp Exp Exp
         | Apply Exp [Exp]
         | Let LetStyle [(Name, Exp)] Exp
         | Lambda Lambda
         deriving Show

data Value = Nil
           | Bool Bool
           | Num Integer
           | Pair Value Value
           | Closure Lambda (Env Value)
           deriving Show
           -- | Primitive ([Value] -> Value) 

type Name = String

type Lambda = ([Name], Exp)

data LetStyle = Plain | Star | Rec deriving Show

type Env a = Map Name a

program :: Parser [Def]
program = many def

def :: Parser Def
def = val <|> Exp <$> exp

-- define = parserFail 

val :: Parser Def
val = bracketed "val" $ Val <$> name <*> exp

bracketed :: String -> Parser a -> Parser a
bracketed s p = parens $ delimited (string s) >> spaces >> p

exp :: Parser Exp
exp = spaced $ (Literal . Num . read) <$> many1 (satisfy isDigit)

name :: Parser String
name = spaced $ filterpNot (all isDigit) $ delimited $ many1 $ satisfy (not . isDelimiter)

filterpNot :: (a -> Bool) -> Parser a -> Parser a
filterpNot bad p = try $ do
  a <- p
  if bad a then parserZero else return a

delimited :: Parser a -> Parser a
delimited p = spaces *> p <* (eof <|> const () <$> lookAhead delimiter)

delimiter :: Parser Char
delimiter = satisfy isDelimiter

isDelimiter :: Char -> Bool
isDelimiter c = (c `elem` ";()\"'") || isSpace c

parens :: Parser a -> Parser a
parens = between (char '(' >> spaces) (spaces >> char ')')

spaced :: Parser a -> Parser a
spaced = between spaces spaces

spaces1 :: Parser ()
spaces1 = skipMany1 space