Parser.hs 10 KB
Newer Older
1
{-# OPTIONS_GHC -Wno-warnings-deprecations #-}
Tomislav Pree's avatar
Tomislav Pree committed
2
module Parser(loadSchemeFile,loadSchemeFile',loadSourceCode, loadSchemeFileWithCode) where
3
4
5
6

import           Prelude hiding (fail)

import           Control.Monad.State hiding (fail)
Sven Keidel's avatar
Sven Keidel committed
7
import           Control.Monad.Except
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

import           Data.Label
import           Data.Text (Text, pack)
import           Data.IORef
import qualified Data.Map.Lazy as Map

import           Language.Scheme.Types as LT hiding (body)
import           Language.Scheme.Parser
import           Language.Scheme.Core
import qualified Language.Scheme.Macro as Macro

import           Paths_sturdy_scheme

import           Syntax as S

import           Text.Printf

loadSchemeFile :: String -> IO LExpr
loadSchemeFile file = do
  contents <- readFile =<< getDataFileName (printf "scheme_files/%s" file)
  case readExprList contents of
    Left err -> throwLispError err
    Right val -> do
     expanded <- macroExpand (List val)
     let expr = parseTopLevelSExpr expanded
     return expr

Sven Keidel's avatar
Sven Keidel committed
35
36
37
38
39
loadSchemeFile' :: String -> IO Expr
loadSchemeFile' file = do
  lexpr <- loadSchemeFile file
  return $ generate lexpr

Tomislav Pree's avatar
Tomislav Pree committed
40
41
42
43
44
45
46
47
48
49
50
51
52
loadSourceCode :: String -> IO FilePath
loadSourceCode file = readFile =<< getDataFileName (printf "scheme_files/%s" file)

loadSchemeFileWithCode :: String -> IO LExpr
loadSchemeFileWithCode code = do
  case readExprList code of
    Left err -> throwLispError err
    Right val -> do
      expanded <- macroExpand (List val)
      let expr = parseTopLevelSExpr expanded
      return expr


53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
macroExpand :: LispVal -> IO LispVal
macroExpand program = do
  env <- r7rsEnv
  removeMacros env
  addMacros env
  runErrorIO (Macro.expand env True program apply)
  where
    removeMacros :: Env -> IO ()
    removeMacros env = do
      bnds <- readIORef (bindings env)
      writeIORef (bindings env) (foldr Map.delete bnds ["m_begin","m_or","m_let","m_letrec","m_letrec*"])

    addMacros :: Env -> IO ()
    addMacros env = do
      macrosFile <- getDataFileName "scheme_files/macros.scm"
      _ <- evalString env (printf "(load \"%s\")" macrosFile)
      return ()

runErrorIO :: IOThrowsError a -> IO a
runErrorIO m = do
Sven Keidel's avatar
Sven Keidel committed
73
  e <- runExceptT m
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
  case e of
    Right val -> return val
    Left err  -> throwLispError err

throwLispError :: LispError -> IO a
throwLispError err = do
  str <- showLispError err
  fail str

parseTopLevelSExpr :: LispVal -> LExpr
parseTopLevelSExpr (LT.List prog) =
  let (defs,body) = parseDefinitions prog
  in let_rec defs body
parseTopLevelSExpr expr = error $ "cannot parse s-expression: " ++ show expr

parseDefinitions :: [LispVal] -> ([(Text,LExpr)],[LExpr])
parseDefinitions (LT.List [Atom "define", Atom var, body] : defs) =
  (pack var, parseSExpr body) <+ parseDefinitions defs
92
93
94
95
parseDefinitions (LT.List (Atom "define": Atom var: body) : defs) =
  (pack var, begin (map parseSExpr body)) <+ parseDefinitions defs
parseDefinitions (LT.List (Atom "define": LT.List (Atom var: args): body) : defs) =
  (pack var, lam [ pack x | Atom x <- args ] (map parseSExpr body)) <+ parseDefinitions defs
96
97
98
99
100
101
parseDefinitions (sexpr : defs) =
  parseSExpr sexpr +> parseDefinitions defs
parseDefinitions [] = ([],[])

parseSExpr :: LispVal -> LExpr
parseSExpr val = case val of
102
  LT.Number x -> lit $ S.Int $ fromIntegral x
103
  LT.Float x -> lit $ S.Float x
104
  LT.Rational x -> lit $ S.Rational x
105
106
107
108
109
110
111
112
113
  LT.Bool x -> lit $ S.Bool x
  LT.Char x -> lit $ S.Char x
  LT.String x -> lit $ S.String (pack x)
  LT.Atom "#t" -> lit $ S.Bool True
  LT.Atom "#f" -> lit $ S.Bool False
  LT.Atom "null" -> list []
  LT.Atom x -> var_ (pack x)
  LT.List [Atom "define", Atom var, body] ->
    define (pack var) (parseSExpr body)
114
115
116
117
  LT.List (Atom "define": Atom var: body) ->
    define (pack var) (begin (map parseSExpr body))
  LT.List (Atom "define": LT.List (Atom var: args): body) ->
    define (pack var) (lam [ pack x | Atom x <- args ] (map parseSExpr body))
118
119
120
121
122
123
124
125
  -- TODO : add lambdas with variable amount of arguments if only one arguement is given
  LT.List (Atom "lambda": Atom var: body_) ->
    lam [ pack var ] (map parseSExpr body_)
  LT.List (Atom "lambda": LT.List args: body_) ->
    lam [ pack x | Atom x <- args ] (map parseSExpr body_)
  -- case lambda
  LT.List [Atom "if", cond, then_branch, else_branch] ->
    if_ (parseSExpr cond) (parseSExpr then_branch) (parseSExpr else_branch)
126
127
  LT.List [Atom "if", cond, then_branch] ->
    if_ (parseSExpr cond) (parseSExpr then_branch) (list [])
128
129
130
131
132
133
134
135
136
137
138
139
  -- begin
  LT.List (Atom "begin": body_) ->
    begin (map parseSExpr body_)
  -- begin0
  LT.List (Atom "let": LT.List params_: body_) ->
    let bnds = map extractBinding params_
    in let_ bnds (map parseSExpr body_)
  LT.List (Atom "letrec": LT.List params_: body_) ->
    let bnds = map extractBinding params_
    in let_rec bnds (map parseSExpr body_)
  LT.List [Atom "set!", Atom var, body_] ->
    set (pack var) (parseSExpr body_)
140
  LT.List (Atom "set!": _) -> error $ "cannot parse set!: " ++ show val
141
142
143
144
145
146
  LT.List [Atom "quote", LT.List xs] -> list (map quoteListHelp xs)
  LT.List [Atom "quote", val_] -> lit $ parseLits val_
  LT.List (LT.List(Atom "lambda": rest): args) ->
    app (parseSExpr (LT.List(Atom "lambda" : rest))) (map parseSExpr args)
  -- LT.List [Atom "call-with-values", generator, _] ->
  --   app (parseSExpr generator) []
147
148
149
150
151
152
153
154
155
156
157
158
159
  LT.List [Atom "number?", e] -> op1_ IsNumber (parseSExpr e)
  LT.List [Atom "integer?", e] -> op1_ IsInteger (parseSExpr e)
  LT.List [Atom "float?", e] -> op1_ IsFloat (parseSExpr e)
  LT.List [Atom "rational?", e] -> op1_ IsRational (parseSExpr e)
  LT.List [Atom "zero?", e] -> op1_ IsZero (parseSExpr e)
  LT.List [Atom "positive?", e] -> op1_ IsPositive (parseSExpr e)
  LT.List [Atom "negative?", e] -> op1_ IsNegative (parseSExpr e)
  LT.List [Atom "even?", e] -> op1_ IsEven (parseSExpr e)
  LT.List [Atom "odd?", e] -> op1_ IsOdd (parseSExpr e)
  LT.List [Atom "boolean?", e] -> op1_ IsBoolean (parseSExpr e)
  LT.List [Atom "null?", e] -> op1_ IsNull (parseSExpr e)
  LT.List [Atom "pair?", e] -> op1_ IsCons (parseSExpr e)
  LT.List [Atom "cons?", e] -> op1_ IsCons (parseSExpr e)
160
161
162
163
164
165
166
167
168
169
170
  LT.List [Atom "abs", e] -> op1_ Abs (parseSExpr e)
  LT.List [Atom "floor", e] -> op1_ Floor (parseSExpr e)
  LT.List [Atom "ceiling", e] -> op1_ Ceiling (parseSExpr e)
  LT.List [Atom "log", e] -> op1_ Log (parseSExpr e)
  LT.List [Atom "not", e] -> op1_ Not (parseSExpr e)
  LT.List [Atom "car", e] -> op1_ Car (parseSExpr e)
  LT.List [Atom "cdr", e] -> op1_ Cdr (parseSExpr e)
  LT.List [Atom "caar", e] -> op1_ Caar (parseSExpr e)
  LT.List [Atom "cadr", e] -> op1_ Cadr (parseSExpr e)
  LT.List [Atom "cddr", e] -> op1_ Cddr (parseSExpr e)
  LT.List [Atom "caddr", e] -> op1_ Caddr (parseSExpr e)
171
  LT.List [Atom "cadddr", e] -> op1_ Cadddr (parseSExpr e)
172
  LT.List [Atom "random", e] -> op1_ Random (parseSExpr e)
173
174
175
  LT.List [Atom "string->symbol", e] -> op1_ StringToSymbol (parseSExpr e)
  LT.List [Atom "symbol->string", e] -> op1_ SymbolToString (parseSExpr e)
  LT.List [Atom "number->string", e] -> op1_ NumberToString (parseSExpr e)
176
177
178
179
180
  -- op2
  LT.List [Atom "eq?", e1, e2] -> op2_ Eqv (parseSExpr e1) (parseSExpr e2)
  LT.List [Atom "quotient", e1, e2] -> op2_ Quotient (parseSExpr e1) (parseSExpr e2)
  LT.List [Atom "remainder", e1, e2] -> op2_ Remainder (parseSExpr e1) (parseSExpr e2)
  LT.List [Atom "modulo", e1, e2] -> op2_ Modulo (parseSExpr e1) (parseSExpr e2)
181
  LT.List [Atom "string-ref", e1, e2] -> op2_ StringRef (parseSExpr e1) (parseSExpr e2)
182
183
  LT.List [Atom "cons", e1, e2] -> cons (parseSExpr e1) (parseSExpr e2)
  -- opvar
184
185
186
187
188
  LT.List (Atom "=": args) -> opvar_ Equal (map parseSExpr args)
  LT.List (Atom "<": args) -> opvar_ Smaller (map parseSExpr args)
  LT.List (Atom ">": args) -> opvar_ Greater (map parseSExpr args)
  LT.List (Atom "<=": args) -> opvar_ SmallerEqual (map parseSExpr args)
  LT.List (Atom ">=": args) -> opvar_ GreaterEqual (map parseSExpr args)
189
190
191
192
193
194
195
196
  LT.List (Atom "max": args) -> opvar_ Max (map parseSExpr args)
  LT.List (Atom "min": args) -> opvar_ Min (map parseSExpr args)
  LT.List (Atom "+": args) -> opvar_ Add (map parseSExpr args)
  LT.List (Atom "*": args) -> opvar_ Mul (map parseSExpr args)
  LT.List (Atom "-": args) -> opvar_ Sub (map parseSExpr args)
  LT.List (Atom "/": args) -> opvar_ Div (map parseSExpr args)
  LT.List (Atom "gcd": args) -> opvar_ Gcd (map parseSExpr args)
  LT.List (Atom "lcm": args) -> opvar_ Lcm (map parseSExpr args)
Sven Keidel's avatar
Sven Keidel committed
197
  LT.List (Atom "string-append": args) -> opvar_ StringAppend (map parseSExpr args)
198
  LT.List (Atom "list": args) -> list (map parseSExpr args)
199
  LT.List [Atom "error", LT.String err] -> error_ err
Sven Keidel's avatar
Sven Keidel committed
200
  LT.List [Atom "breakpoint", e] -> breakpoint (parseSExpr e)
Sven Keidel's avatar
Sven Keidel committed
201

202
203
204
205
206
207
208
209
210
211
212
  LT.List (Atom x: args) -> app (var_ (pack x)) (map parseSExpr args)
  LT.List (fun: args) -> app (parseSExpr fun) (map parseSExpr args)
  _ -> error $ "cannot parse s-expression: " ++ show val

extractBinding :: LispVal -> (Text, State Label Expr)
extractBinding (LT.List [Atom var, val]) = (pack var, parseSExpr val)
extractBinding _ = error "Error when extracting tuple"

--TODO: resolve remaining lispvals
parseLits :: LispVal -> Literal
parseLits val = case val of
213
  LT.Number x -> S.Int $ fromIntegral x
214
  LT.Float x -> S.Float x
215
  LT.Rational x -> S.Rational x
216
217
218
219
220
221
222
223
224
225
226
227
  LT.Bool x -> S.Bool x
  LT.Char x -> S.Char x
  LT.String x -> S.String (pack x)
  LT.Atom "#t" -> S.Bool True
  LT.Atom "#f" -> S.Bool False
  LT.Atom x -> S.Quote $ S.Symbol (pack x)
  -- LT.List xs -> list (map parseSExpr xs)
  -- LT.DottedList xs x -> S.DottedList (map parseLits xs) (parseLits x)
  _ -> error "type not supported"

quoteListHelp :: LispVal -> LExpr
quoteListHelp val = case val of
228
  LT.Number x -> lit $ S.Int $ fromIntegral x
229
  LT.Float x -> lit $ S.Float x
230
  LT.Rational x -> lit $ S.Rational x
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
  LT.Bool x -> lit $ S.Bool x
  LT.Char x -> lit $ S.Char x
  LT.String x -> lit $ S.String (pack x)
  LT.Atom "#t" -> lit $ S.Bool True
  LT.Atom "#f" -> lit $ S.Bool False
  LT.Atom x -> lit $ S.Quote $ S.Symbol (pack x)
  LT.List xs -> list (map quoteListHelp xs)
  -- LT.DottedList xs x -> S.DottedList (map parseLits xs) (parseLits x)
  _ -> error "type not supported"

(<+) :: a -> ([a],[b]) -> ([a],[b])
a1 <+ (a2,b2) = (a1 : a2, b2)

(+>) :: b -> ([a],[b]) -> ([a],[b])
b1 +> (a2,b2) = (a2, b1 : b2)