haskell/Reader.hs

   1 module Reader
   2 ( read_str )
   3 where
   4
   5 import Text.ParserCombinators.Parsec (
   6     Parser, parse, char, digit, letter, try,
   7     (<|>), oneOf, noneOf, many, many1, skipMany, skipMany1, sepEndBy, string)
   8 import qualified Data.Map as Map
   9
  10 import Types
  11
  12 spaces :: Parser ()
  13 spaces = skipMany1 (oneOf ", \n")
  14
  15 comment :: Parser ()
  16 comment = char ';' *> skipMany (noneOf "\r\n")
  17
  18 ignored :: Parser ()
  19 ignored = skipMany (spaces <|> comment)
  20
  21 symbol :: Parser Char
  22 symbol = oneOf "!#$%&|*+-/:<=>?@^_~"
  23
  24 escaped :: Parser Char
  25 escaped = f <$> (char '\\' *> oneOf "\\\"n")
  26     where f 'n' = '\n'
  27           f x   = x
  28
  29 read_number :: Parser MalVal
  30 read_number = MalNumber . read <$> many1 digit
  31
  32 read_negative_number :: Parser MalVal
  33 read_negative_number = f <$> char '-' <*> many1 digit
  34     where f sign rest = MalNumber $ read $ sign : rest
  35
  36 read_string :: Parser MalVal
  37 read_string = MalString <$> (char '"' *> many (escaped <|> noneOf "\\\"") <* char '"')
  38
  39 read_symbol :: Parser MalVal
  40 read_symbol = f <$> (letter <|> symbol) <*> many (letter <|> digit <|> symbol)
  41     where f first rest = g (first : rest)
  42           g "true"     = MalBoolean True
  43           g "false"    = MalBoolean False
  44           g "nil"      = Nil
  45           g s          = MalSymbol s
  46
  47 read_keyword :: Parser MalVal
  48 read_keyword = MalString . (:) keywordMagic <$> (char ':' *> many (letter <|> digit <|> symbol))
  49
  50 read_atom :: Parser MalVal
  51 read_atom =  read_number
  52          <|> try read_negative_number
  53          <|> read_string
  54          <|> read_keyword
  55          <|> read_symbol
  56
  57 read_list :: Parser MalVal
  58 read_list = toList <$> (char '(' *> ignored *> sepEndBy read_form ignored <* char ')')
  59
  60 read_vector :: Parser MalVal
  61 read_vector = MalSeq (MetaData Nil) (Vect True) <$> (char '[' *> ignored *> sepEndBy read_form ignored <* char ']')
  62
  63 read_hash_map :: Parser MalVal
  64 read_hash_map = g . keyValuePairs =<< (char '{' *> ignored *> sepEndBy read_form ignored <* char '}')
  65     where g (Just pairs) = return $ MalHashMap (MetaData Nil) (Map.fromList pairs)
  66           g Nothing      = fail "invalid contents inside map braces"
  67
  68 -- reader macros
  69 addPrefix :: String -> MalVal -> MalVal
  70 addPrefix s x = toList [MalSymbol s, x]
  71
  72 read_quote :: Parser MalVal
  73 read_quote = addPrefix "quote" <$> (char '\'' *> read_form)
  74
  75 read_quasiquote :: Parser MalVal
  76 read_quasiquote = addPrefix "quasiquote" <$> (char '`' *> read_form)
  77
  78 read_splice_unquote :: Parser MalVal
  79 read_splice_unquote = addPrefix "splice-unquote" <$> (string "~@" *> read_form)
  80
  81 read_unquote :: Parser MalVal
  82 read_unquote = addPrefix "unquote" <$> (char '~' *> read_form)
  83
  84 read_deref :: Parser MalVal
  85 read_deref = addPrefix "deref" <$> (char '@' *> read_form)
  86
  87 read_with_meta :: Parser MalVal
  88 read_with_meta = f <$> (char '^' *> read_form) <*> read_form
  89     where f m x = toList [MalSymbol "with-meta", x, m]
  90
  91 read_macro :: Parser MalVal
  92 read_macro = read_quote
  93          <|> read_quasiquote
  94          <|> try read_splice_unquote <|> read_unquote
  95          <|> read_deref
  96          <|> read_with_meta
  97
  98 --
  99
 100 read_form :: Parser MalVal
 101 read_form = ignored *> (
 102          read_macro
 103      <|> read_list
 104      <|> read_vector
 105      <|> read_hash_map
 106      <|> read_atom)
 107
 108 read_str :: String -> IOThrows MalVal
 109 read_str str = case parse read_form "Mal" str of
 110     Left err -> throwStr $ show err
 111     Right val -> return val