~jojo/Carth: src/Parse.hs - sourcehut git


                                                                                
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
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
{-# LANGUAGE FlexibleContexts #-}

module Parse (parse, Expr (..)) where

import Control.Monad
import Data.Char (isMark, isPunctuation, isSymbol)
import Data.Functor
import qualified Text.Parsec as Parsec
import Text.Parsec hiding (parse)

import Ast

type Parser = Parsec String ()

-- Use Parsec LanguageDef for easy handling of comments and reserved keywords
-- http://hackage.haskell.org/package/parsec-3.1.13.0/docs/Text-Parsec-Token.html

parse :: SourceName -> String -> Either ParseError Expr
parse = Parsec.parse expr

expr :: Parser Expr
expr = choice [nil, double, int, str, bool, var, pexpr]

nil :: Parser Expr
nil = try (string "nil" <* notFollowedBy identRest) $> Nil

double, int :: Parser Expr
double = do
  l <- try (option "" (string "-") <++> uintS <++> string ".")
  r <- uintS
  e <- option "" (char 'e' <:> intS)
  pure ((Double . read . concat) [l, r, e])
int = fmap (Int . read) intS
intS = try (option "" (string "-") <++> uintS)
uintS = many1 digit

str :: Parser Expr
str = do
  char '"'
  s <- many (escaped <|> fmap pure (noneOf ['"']))
  char '"'
  pure (Str (concat s))
  where
    escaped :: Parser String
    escaped = do
      char '\\'
      c <- anyChar
      return ['\\', c]

bool :: Parser Expr
bool = try ((<*) ((<|>) (string "true" $> Bool True)
                        (string "false" $> Bool False))
                 (notFollowedBy identRest))

var :: Parser Expr
var = fmap Var ident

pexpr :: Parser Expr
pexpr = parens (choice [if', lam, let', app])

app :: Parser Expr
app = do
  rator <- expr
  rands <- many1 (spaces1 >> expr)
  pure (foldl App rator rands)

if' :: Parser Expr
if' = do
  try (string "if" *> spaces1)
  pred <- expr
  spaces1
  conseq <- expr
  spaces1
  alt <- expr
  pure (If pred conseq alt)

lam :: Parser Expr
lam = do
  try (string "lambda" *> spaces1)
  params <- parens (sepEndBy1 ident spaces1)
  spaces1
  body <- expr
  pure (foldr Lam body params)

let' :: Parser Expr
let' = do
  try (string "let" >> spaces1)
  bindings <- parens (sepEndBy binding spaces)
  spaces1
  body <- expr
  pure (Let bindings body)
  where
    binding = parens (liftM2 (,) ident (spaces1 *> expr))

ident :: Parser Ident
ident = identFirst <:> many identRest

identFirst = letter <|> symbol
identRest = identFirst <|> digit
symbol = satisfy (\c -> and [ any ($ c) [isMark, isPunctuation, isSymbol]
                            , not (elem c "()[]{}")
                            , not (c == '"') ])

(<:>) :: Parser a -> Parser [a] -> Parser [a]
(<:>) = liftM2 (:)

(<++>) :: Parser [a] -> Parser [a] -> Parser [a]
(<++>) = liftM2 (++)

spaces1 :: Parser ()
spaces1 = skipMany1 space

-- Note that () and [] can be used interchangeably, as long as the
-- opening and closing bracket matches.
parens :: Parser a -> Parser a
parens p = choice (map (\(l, r) -> between (char l >> spaces) (spaces >> char r) p)
                       [('(', ')'), ('[', ']')])