{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE LambdaCase #-}
module Parser where

import Control.Applicative
import Data.Char (isSpace)
import Control.Monad.Chronicle
import Control.Monad.Reader
import Control.Monad.State.Strict
import Data.Foldable (asum)
import Data.These

import AST


-- Positions are zero-based in both dimensions
data PS = PS
    { psRefCol :: Int
    , psLine :: Int
    , psCol :: Int
    , psRest :: String }
  deriving (Show)

data Context = Context { ctxFile :: FilePath }
  deriving (Show)

type Parser = ReaderT Context (ChronicleT [ErrMsg] (State PS))

-- Positions are zero-based in both dimensions
data ErrMsg = ErrMsg { errFile :: FilePath
                     , errLine :: Int
                     , errCol :: Int
                     , errMsg :: String }
  deriving (Show)

printErrMsg :: ErrMsg -> String
printErrMsg (ErrMsg fp y x s) = fp ++ ":" ++ show (y + 1) ++ ":" ++ show (x + 1) ++ ": " ++ s

parse :: FilePath -> String -> These [ErrMsg] (Program ())
parse fp source =
    flip evalState (PS 0 0 0 source)
    . runChronicleT
    . flip runReaderT (Context fp)
    $ pProgram
                            
pProgram :: Parser (Program ())
pProgram = do
    prog <- Program <$> many pFunDef
    skipWhiteComment
    assertEOF Error
    return prog

pFunDef :: Parser (FunDef ())
pFunDef = _



data Fatality = Error | Fatal
  deriving (Show)

raise :: Fatality -> String -> Parser ()
raise fat msg = do
    fp <- asks ctxFile
    ps <- get
    let fun = case fat of
                Error -> dictate . pure
                Fatal -> confess . pure
    fun (ErrMsg fp (psLine ps) (psCol ps) msg)

assertEOF :: Fatality -> Parser ()
assertEOF fat = gets psRest >>= \case
    [] -> return ()
    _ -> raise fat "Unexpected stuff"

data ReadResult a = Token a | Truncated a
  deriving (Show, Functor)

readInline :: (s -> Char -> Maybe s) -> s -> Parser (ReadResult String)
readInline f s0 = do
    ps0 <- get
    when (psCol ps0 <= psRefCol ps0) $
        raise Fatal "Expected stuff, but found end of indented expression"
    let loop :: (s -> Char -> Maybe s) -> s -> Parser (ReadResult String)
        loop f' st = do
            ps <- get
            case psRest ps of
              c : cs | Just st' <- f' st c -> do
                         put (ps { psCol = psCol ps + 1, psRest = cs })
                         fmap (c :) <$> loop f' st'
                     | otherwise -> return (Token "")
              [] -> return (Truncated "")
    loop f s0

skipWhiteComment :: Parser ()
skipWhiteComment = do
    inlineWhite
    _ <- many (inlineComment >> inlineWhite)
    _ <- optional lineComment
    (consumeNewline >> skipWhiteComment) <|> return ()
  where
    inlineWhite :: Parser ()
    inlineWhite = readWhileInline isSpace

    inlineComment :: Parser ()
    inlineComment = do
        string "{-"
        let loop = do
                readWhileInline (`notElem` "{-")
                asum [string "-}"
                     ,inlineComment >> loop
                     ,consumeNewline >> loop]
        loop

    lineComment :: Parser ()
    lineComment = string "--" >> readWhileInline (const True)

    readWhileInline :: (Char -> Bool) -> Parser ()
    readWhileInline p = do
        (taken, rest) <- span (\c -> p c && c /= '\n') <$> gets psRest
        modify (\ps -> ps { psCol = psCol ps + length taken
                          , psRest = rest })

consumeNewline :: Parser ()
consumeNewline = gets psRest >>= \case
    '\n' : rest -> modify (\ps -> ps { psLine = psLine ps + 1
                                     , psCol = 0
                                     , psRest = rest })
    _ -> empty

string :: String -> Parser ()
string s | any (== '\n') s = error "Newline in 'string' argument"
string s = do
    ps <- get
    if take (length s) (psRest ps) == s
        then put (ps { psCol = psCol ps + length s
                     , psRest = drop (length s) (psRest ps) })
        else empty