expression.hs

{-# LANGUAGE ScopedTypeVariables #-}
module Main where

import           Control.Applicative (Alternative, empty, (<|>), liftA2)
import           Control.Monad
import           Data.Char

main :: IO ()
main =
  print $ runParser ( sepBy ( many expressionParser ) endOfLine ) rawInput

rawInput :: String
rawInput = "1x - 1y - z = 4\n2x - 1y - 1z = 2\n2x + 1y - 4z = 16"

data Expression
  = Digit Int
  | Variable Char
  | Symbol Char
  deriving (Eq, Show)

expressionParser :: Parser Expression
expressionParser = do
  val <- digitParser <|> variableParser <|> symbolParser
  void $ many space
  pure val

symbolParser :: Parser Expression
symbolParser = do
  s <- oneOf "+-="
  pure $ Symbol s

variableParser :: Parser Expression
variableParser = do
  variable <- letter
  pure $ Variable variable

digitParser :: Parser Expression
digitParser = do
  dig <- some digit
  pure $ Digit $ read dig

newtype Parser a
  = Parser { parse :: String -> [(a, String)] }

runParser :: Parser a -> String -> Either String a
runParser parser input =
  case parse parser input of
    [(res, [])] -> Right res
    [(_, rs)]   -> Left $ "Unconsumed input: " <> rs
    _           -> Left "Parser error"

sepBy :: Alternative f => f a -> f s -> f [a]
sepBy p separator = liftA2 (:) p ((separator *> sepBy1 p separator) <|> pure [])
  <|> pure []

sepBy1 :: Alternative f => f a -> f s -> f [a]
sepBy1 p s = scan
    where scan = liftA2 (:) p ((s *> scan) <|> pure [])

digit :: Parser Char
digit = satisfy isDigit

endOfLine :: Parser ()
endOfLine = void $ char '\n'

letter :: Parser Char
letter = satisfy isAlpha

space :: Parser Char
space = char ' '

symbols :: Parser String
symbols = many $ oneOf "+-="

oneOf :: String -> Parser Char
oneOf str = satisfy (\c -> c `elem` str)

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

satisfy :: ( Char -> Bool ) -> Parser Char
satisfy predFn =  item `bind` \c ->
  if predFn c
  then unit c
  else Parser $ const []

bind :: Parser a -> ( a -> Parser b ) -> Parser b
bind p fn = Parser $ \s -> concatMap (\(a, s') -> parse ( fn a ) s') $ parse p s

unit :: a -> Parser a
unit a = Parser (\s -> [(a, s)])

item :: Parser Char
item = Parser $ \s ->
  case s of
    []     -> []
    (c:cs) -> [(c, cs)]

some :: ( Monad f, Alternative f ) => f a -> f [ a ]
some v = someV
  where
    manyV = someV <|> pure []
    someV = do
      a <- v
      m <- manyV
      pure $ a : m

many :: ( Monad f, Alternative f ) => f a -> f [ a ]
many v = manyV
  where
    manyV = someV <|> pure []
    someV = do
      a <- v
      m <- manyV
      pure $ a : m

instance Functor Parser where
  fmap fn ( Parser strToPair ) = Parser $ \s -> do
    (a, b) <- strToPair s
    pure $ (fn a, b)

instance Applicative Parser where
  pure = unit
  ( Parser strToPair1 ) <*> ( Parser strToPair2 ) = Parser $ \s -> do
    ( fn, s1 ) <- strToPair1 s
    ( a, s2 ) <- strToPair2 s1
    pure $ ( fn a, s2 )

instance Monad Parser where
  return = pure
  ( >>= ) = bind

instance Alternative Parser where
  empty = mzero
  ( <|> ) = option

instance MonadPlus Parser where
  mzero = failure
  mplus = combine

combine :: Parser a -> Parser a -> Parser a
combine p1 p2 = Parser $ \s -> parse p1 s ++ parse p2 s

failure :: Parser a
failure = Parser $ \_ -> []

option :: Parser a -> Parser a -> Parser a
option p1 p2 = Parser $ \s ->
  case parse p1 s of
    []          -> parse p2 s
    restOfInput -> restOfInput