fpc-8-11-2017.hs

import Control.Applicative
import Data.Map (Map)
import qualified Data.Map as Map

data Result a = Ok a | Error String
  deriving (Show, Eq)

instance Functor Result where
  fmap f (Ok x) = Ok (f x)
  fmap f (Error str) = Error str

instance Applicative Result where
  pure x = Ok x
  -- (<*>) :: Result (a -> b) -> Result a -> Result b
  Ok f <*> Ok x = Ok (f x)
  Error str <*> Ok _ = Error str
  Ok _ <*> Error str = Error str
  Error err1 <*> Error err2 = Error (err1 ++ err2)

instance Foldable Result where
  -- foldMap :: Monoid m => (a -> m) -> Result a -> m
  foldMap f (Error _) = mempty
  foldMap f (Ok x) = f x

instance Traversable Result where
  -- traverse :: Applicative f => (a -> f b)
  --          -> Result a
  --          -> f (Result b)
  -- traverse f (Error err) = pure (Error err)
  -- traverse f (Ok x) = Ok `fmap` f x
  --
  -- sequenceA :: Applicative f => Result (f a) -> f (Result a)
  sequenceA (Error err) = pure (Error err)
  sequenceA (Ok x) = Ok <$> x

data JSON
  = JSONString String
  | JSONList [JSON]
  | JSONMap (Map String JSON)
  deriving Eq

showsSurrounded :: String -> String -> ShowS -> ShowS
showsSurrounded leading trailing s = (leading ++) . s . (trailing ++)

showsSequence :: (a -> ShowS) -> [a] -> ShowS
showsSequence f = foldr (.) id . map f

showsList :: String -> String -> String -> (a -> ShowS) -> [a] -> ShowS
showsList leading trailing separating f = showsSurrounded leading trailing . showsSequence (\x -> f x . (separating ++))

instance Show JSON where
  showsPrec _ (JSONString str) = shows str
  showsPrec _ (JSONList lst) = showsList "[" "]" "," shows lst
  showsPrec _ (JSONMap jmap) = showsList "{" "}" "," (\(k,v) -> shows k . ("=" ++) . shows v) (Map.toList jmap)

parseJSON :: String -> Maybe JSON
parseJSON = runParser jsonParser

newtype Parser a = ParserImpl (String -> Maybe (a, String))

runParser :: Parser a -> String -> Maybe a
runParser (ParserImpl f) str = fst <$> f str

instance Functor Parser where
  fmap f (ParserImpl pv) = ParserImpl $ \str ->
    case pv str of
      Just (v, rest) -> Just (f v, rest)
      Nothing -> Nothing

instance Applicative Parser where
  pure v = ParserImpl $ \str -> Just (v, str)
  ParserImpl pf <*> ParserImpl pv = ParserImpl $ \str ->
    case pf str of
      Just (f, rest) ->
        case pv rest of
          Just (v, rest') -> Just (f v, rest')
          Nothing -> Nothing
      Nothing -> Nothing

instance Alternative Parser where
  empty = ParserImpl $ \_ -> Nothing
  ParserImpl px <|> ParserImpl py = ParserImpl $ \str ->
    case px str of
      Just res -> Just res
      Nothing -> py str

satisfiesParser :: (Char -> Bool) -> Parser Char
satisfiesParser f = ParserImpl go
 where go "" = Nothing
       go (c:cs)
        | f c = Just (c, cs)
        | otherwise = Nothing

charParser :: Char -> Parser Char
charParser c = satisfiesParser (==c)

surroundedParser :: Parser a -> Parser b -> Parser c -> Parser c
surroundedParser leading trailing p = leading *> p <* trailing

{-
data JSON
  = JSONString String
  | JSONList [JSON]
  | JSONMap (Map String JSON)
-}
jsonParser :: Parser JSON
jsonParser =  (JSONString <$> jsonString)
          <|> (JSONList <$> jsonList)
          <|> (JSONMap <$> jsonMap)

jsonString :: Parser String
jsonString = surroundedParser
              (charParser '"')
              (charParser '"') $
                many (satisfiesParser (/= '"'))

jsonList :: Parser [JSON]
jsonList = surroundedParser
            (charParser '[')
            (charParser ']') $
              many (jsonParser <* charParser ',')

jsonMap :: Parser (Map String JSON)
jsonMap = surroundedParser
           (charParser '{')
           (charParser '}') $
             Map.fromList <$> many (jsonMapElem <* charParser ',')

jsonMapElem :: Parser (String, JSON)
jsonMapElem = (\n _ v -> (n,v))
           <$> jsonString
           <*> charParser '='
           <*> jsonParser

-- parseExpr = (parseExpr *> parsePlus *> parseExpr) <|> parseInt
-- parseExpr "1+2"
-- (*>) x y = (\_ a -> a) <$> x <*> y
-- (<*) x y = (\a _ -> a) <$> x <*> y