applicative_parser.hs

import Control.Applicative hiding (many)
import Data.Char (toLower, isAlphaNum)
import Data.Either (isRight)
import Data.List (isPrefixOf)

data Parser a = Parser { parse :: String -> Either String (String, a) }

satisfy :: (Char -> Bool) -> Parser Char
satisfy pr = Parser f where
  f "" = Left "unexpected end of input"
  f (c:cs) = if pr c then Right (cs, c) else Left ("unexpected " ++ [c])

anyChar :: Parser Char
anyChar = satisfy (const True)

char :: Char -> Parser Char
char p = satisfy (== p)

instance Functor Parser where
  fmap f (Parser p) = Parser $ fmap (fmap f) . p

instance Applicative Parser where
  pure a = Parser $ \s -> Right (s, a)

  pf <*> pv = Parser $ \s ->
    case parse pf s of
      Right (s', g) ->
        case parse pv s' of
          Right (s'', a) -> Right (s'', g a)
          Left e -> Left e
      Left e -> Left e

string :: String -> Parser String
string str = Parser f where
  f s | str `isPrefixOf` s = Right (drop (length str) s, str)
      | otherwise = Left $ "unexpected " ++ s ++ ", expected " ++ str

instance Alternative Parser where
  empty = Parser $ \s -> Left $ "unexpected " ++ s

  p <|> q = Parser f where
      f s = let ps = parse p s
        in if isRight ps then ps else parse q s

many :: Parser a -> Parser [a]
many p = (:) <$> p <*> many p <|> pure []

many1 :: Parser a -> Parser [a]
many1 p = (:) <$> p <*> many p

runParser :: Parser a -> String -> a
runParser p s | Right ("", a) <- parse p s = a
              | otherwise = error "failed to run parser"

-- SQL

data Join = Join String String String deriving (Show)

data Query = Query { selection :: [String], from :: String, joins :: Maybe [Join] } deriving (Show)

whitespace :: Parser String
whitespace = many (char ' ')

sepBy :: Parser a -> Parser sep -> Parser [a]
sepBy p sep = flip (:) <$> many (p <* sep) <*> p

alphaNum :: Parser Char
alphaNum = satisfy isAlphaNum

tableNameP :: Parser String
tableNameP = many1 (alphaNum <|> char '.')

selectP :: Parser [String]
selectP = string "select" *> whitespace *> (tableNameP `sepBy` (char ',' <* whitespace))

fromP :: Parser String
fromP = whitespace *> string "from" *> whitespace *> many1 alphaNum

optionMaybe :: Parser a -> Parser (Maybe a)
optionMaybe p =
  Parser $ \s ->
    let ps = parse p s
      in case ps of
        Right (s', a) -> if s' /= s then Right (s', Just a) else Right (s', Nothing)
        Left _ -> Right (s, Nothing)

joinP :: Parser Join
joinP =
  Join
    <$> (whitespace *> string "join" *> whitespace *> many1 alphaNum <* whitespace)
    <*> (string "on" *> whitespace *> tableNameP <* whitespace)
    <*> (char '=' *> whitespace *> tableNameP)

joinsP :: Parser (Maybe [Join])
joinsP = whitespace *> optionMaybe (many joinP)

sqlP :: Parser Query
sqlP = Query <$> selectP <*> fromP <*> joinsP

main = do
  print $ parse anyChar "ABC"

  print $ parse (char 'A') "ABC"
  print $ parse (char 'B') "ABC"

  -- functor example
  print $ parse (toLower <$> char 'A') "ABC"

  -- applicative example
  print $ parse ((:) <$> char 'A' <*> string "BC") "ABC"
  print $ parse (char 'A' *> string "BC") "ABC"
  print $ parse (char 'A' <* string "BC") "ABC"

  -- alternative example
  print $ parse (many (char 'A')) "AAABC"
  print $ parse (many (char 'A')) "BC"

  print $ parse (many1 (char 'A')) "AAABC"
  print $ parse (many1 (char 'A')) "BC"

  -- sql
  print $ parse (many alphaNum `sepBy` char ',') "qwe,dfg"
  print $ runParser sqlP "select movies.title, movies.createdAt from movies"
  print $ runParser sqlP "select movies.title, movies.createdAt from movies join directors on directors.id = movies.directorId"