{-# LANGUAGE
DeriveFunctor,
TemplateHaskell
  #-}


module Part
(
  XY(..),
  Error(..),
  Result,
  Parser,
  parse,
  try,
  char,
  string,
)
where


-- General
import Control.Applicative
import Control.Monad
import Data.Monoid
-- Lists
import Data.List (intercalate)
-- Lenses
import Lens.Micro
import Lens.Micro.TH
-- Text
import Text.Printf
-- Lists
import Data.List (stripPrefix)


data XY = XY {
  x, y :: Int }
  deriving (Show)  

instance Monoid XY where
  mempty = XY 0 0
  mappend p1 p2 = XY {
    x = x p1 + x p2,
    y = y p1 + y p2 }

xy0 :: XY
xy0 = mempty

data Error
  = Expected {
      errorExpected :: [String],
      errorBut      :: Maybe String }
  | Message {
      errorMessage  :: String }
  deriving (Show)

makeLensesFor [("errorExpected", "_errorExpected"),
               ("errorBut",      "_errorBut"),
               ("errorMessage",  "_errorMessage")] ''Error

showError :: Error -> String
showError (Expected xs but) =
  "expected " ++ or'ed ++ maybe "" (", but " ++) but
  where
    or'ed = case xs of
      []  -> error "Path.showError: empty list of expected things"
      [x] -> x
      xs  -> intercalate ", " (init xs) ++ " or " ++ last xs
showError (Message msg) = msg

type Result a = Either (XY, Error) (a, String)

data Parser a = Parser {runParser :: String -> (XY, Result a)}
  deriving (Functor)

makeLensesFor [("runParser", "_Parser")] ''Parser

_parserResult :: ASetter (Parser a) (Parser b) (XY, Result a) (XY, Result b)
_parserResult = _Parser.mapped

_shift :: Lens' (XY, Result a) XY
_shift = _1

_error :: Traversal' (XY, Result a) Error
_error = _2._Left._2

_errorPosition :: Traversal' (XY, Result a) XY
_errorPosition = _2._Left._1

instance Applicative Parser where
  pure = return
  (<*>) = ap

instance Monad Parser where
  fail s = Parser $ \_ -> (xy0, Left (xy0, Message s))
  return x = Parser $ \s -> (xy0, Right (x, s))
  Parser sa >>= fb = Parser $ \s -> case sa s of
    (pa, Left err)      -> (pa, Left err)
    (pa, Right (a, s')) -> let Parser sb = fb a
                           in  sb s'
                                 -- have to update position
                                 & _shift %~ (<> pa)
                                 -- as well as error position (if exists)
                                 & _errorPosition %~ (<> pa)

instance Alternative Parser where
  empty = fail "empty"
  Parser sa <|> Parser sb = Parser $ \s -> case sa s of
    (pa, Right x) -> (pa, Right x)
    -- If the parser hasn't consumed any input, we try the other parser.
    (XY 0 0, Left _) -> sb s
    -- Otherwise, we report the error – we don't do backtracking.
    (pa, Left err) -> (pa, Left err)

instance MonadPlus Parser where
  mzero = fail "mzero"
  mplus = (<|>)

parse :: Parser a -> String -> Either (XY, Error) a
parse (Parser sa) s = case sa s of
  (pa, Left err)     -> Left err
  (_,  Right (a, _)) -> Right a

try :: Parser a -> Parser a
try = set (_parserResult._shift) xy0

-- parsers

char :: Char -> Parser Char
char c = Parser $ \inp -> case inp of
  []                 -> (xy0, Left (xy0, errEOF))
  (x:xs) | x /= c    -> (xy0, Left (xy0, errUnexpected x))
         | otherwise -> (XY 1 0, Right (c, xs))
  where
    errEOF = Expected [show c] (Just "string has ended")
    errUnexpected x = Expected [show c] (Just ("got " ++ show x))

string :: String -> Parser String
string s = Parser $ \inp -> case stripPrefix s inp of
  Nothing | null inp  -> (xy0, Left (xy0, errEOF))
          | otherwise -> (xy0, Left (xy0, errUnexpected))
  Just xs             -> (XY (length s) 0, Right (s, xs))
  where
    errEOF = Expected [show s] (Just "string has ended")
    errUnexpected = Expected [show s] Nothing
