Pasted

Astyanax task
https://repl.it/@astynax/ParserCombinators
-------------
 
import Data.Char (isDigit, isSpace)
-- No more imports should be here!
 
-- ******** Types ***********
 
newtype Parser a = Parser
  { runParser
    :: String
    -- ^ parser's input
    -> Maybe -- parsing can fail
       ( a
       -- ^ parsed value
       , String
       -- ^ rest of input
       )
  }
 
instance Functor Parser where
  fmap = error "fmap: implement me!"
  
instance Applicative Parser where
  pure  = error "pure: implement me!"
  {- 
  > runParser (pure 42) "asd"
  Just (42, "asd")
  > runParser (pure 42) ""
  Just (42, "")
  -}
  
  -- Hint: (<*>) :: Parser (a -> b) -> Parser a -> Parser b
  (<*>) = error "(<*>): implement me!"
 
-- ********* Elementary parsers ************
 
{-
> runParser anyChar "ab"
Just ('a', "b")
> runParser anyChar "a"
Just ('a', "")
> runParser anyChar ""
Nothing
-}
anyChar :: Parser Char
anyChar = Parser $ \s ->
  case s of
    (x:xs) -> Just (x, xs)
    _      -> Nothing
 
{-
> runParser (satisfy (== 'a') anyChar) "abc"
Just ('a', "bc")
> runParser (satisfy isSpace anyChar) " a "
Just (' ', "a ")
> runParser (satisfy isSpace anyChar) "xyz"
Nothing
> runParser (satisfy isSpace anyChar) ""
Nothing
-}
satisfy :: (a -> Bool) -> Parser a -> Parser a
satisfy pred p = Parser $ \s ->
  case runParser p s of
    Just (x, xs) | pred x -> Just (x, xs)
    _                     -> Nothing
 
{-
> runParser (char '1') "123"
Just ('1', "23")
-}
char :: Char -> Parser Char
char c = satisfy (== c) anyChar
 
{-
> runParser eof "asd"
Nothing
> runParser eof ""
Just ((), "")
-}
eof :: Parser ()
eof = Parser $ \s ->
  case s of
    [] -> Just ((), "")
    _  -> Nothing
 
-- ********* Combinators ***********
{-
> runParser (char 'a' <|> char 'b') "a"
Just ('a', "")
> runParser (char 'a' <|> char 'b') "b"
Just ('b', "")
> runParser (char 'a' <|> char 'b') "c"
Nothing
-}
(<|>) :: Parser a -> Parser a -> Parser a
p1 <|> p2 = error "(<|>): implement me!"
 
{-
> runParser (many $ char '.') ".abc"
Just (".", "abc")
> runParser (many $ char '.') ".....abc"
Just (".....", "abc")
> runParser (many $ char '.') "abc"
Just ("", "abc")
-}
many :: Parser a -> Parser [a]
many p = many1 p <|> pure []
 
{-
> runParser (many1 $ char '.') ".abc"
Just (".", "abc")
> runParser (many1 $ char '.') ".....abc"
Just (".....", "abc")
> runParser (many1 $ char '.') "abc"
Nothing
-}
many1 :: Parser a -> Parser [a]
many1 p = (:) <$> p <*> many p
 
{-
> runParser (between (char '{') (char '}') (many anyChar)) "{}asd"
Just ("", "asd")
> runParser (between (char '{') (char '}') (many anyChar)) "{as}d"
Just ("as", "d")
> runParser (between (char '{') (char '}') (many anyChar)) "{asd"
Nothing
-}
between :: Parser a -> Parser b -> Parser c -> Parser c
between p1 p2 p = p1 *> p <* p2
 
{-
> runParser (sepBy (char ',') (satisfy isDigit anyChar)) "1,2,3,a"
Just ("123", ",a")
> runParser (sepBy (char ',') (satisfy isDigit anyChar)) "1"
Just ("1", "")
> runParser (sepBy (char ',') (satisfy isDigit anyChar)) ""
Just ("", "")
-}
sepBy :: Parser a -> Parser b -> Parser [b]
sepBy s p = error "sepBy: implement me!"
 
-- ********* Combined parsers **********
 
{-
> runParser (string "foo") "fo"
Nothing
> runParser (string "foo") "foobar"
Just ("foo", "bar")
-}
string :: String -> Parser String
string = error "string: implement me!"
 
-- *********** Simple JSON parser *****************
-- * incomplete(!), i.e. w/o any advanced stuff like special char escaping, spaces, etc
 
data JSON
  = JNull
  | JBool Bool
  | JNum Int
  | JString String
  | JArray [JSON]
  | JObject [(String, JSON)]
  deriving (Show)
 
quotedString :: Parser String
quotedString = between (char '"') (char '"') $ many (satisfy (/= '"') anyChar)
 
jnull, jbool, jnum, jstring, jarray, jobject, json :: Parser JSON
json    = jnull <|> jbool <|> jnum <|> jstring <|> jarray <|> jobject
jnull   = JNull <$ string "null"
jbool   = JBool <$> ((True <$ string "true") <|> (False <$ string "false"))
jnum    = error "jnum: implement me!"
jstring = JString <$> quotedString
jarray  = JArray <$> between (char '[') (char ']') (sepBy (char ',') json)
jobject = JObject <$> between (char '{') (char '}')
   (sepBy (char ',') $ (,) <$> quotedString <* char ':' <*> json)
 
-- ************** Some tests
 
main :: IO ()
main = do
  putStrLn "These ones should parse something"
  print $ runParser jnull "null"
  print $ runParser jbool "true"
  print $ runParser jnum "123"
  print $ runParser jstring "\"abc\""
  print $ runParser jarray "[]"
  print $ runParser jarray "[null]"
  print $ runParser jarray "[true,false]"
  print $ runParser jobject "{}"
  print $ runParser jobject "{\"a\":null}"
  print $ runParser (json <* eof) "{\"a\":[1,null,false,\"foo\",{}],\"b\":true}"
  putStrLn "This one should fail:"
  print $ runParser (json <* eof) "{\"a\":[1,null,false,\"foo\",{}],\"b\":true}blabla"