path: root/src/Parser.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE InstanceSigs #-}
-- I don't want a warning for 'head' and 'tail' in this file. But I also don't
-- want GHCs before 9.8 to complain that they don't know the x-partial warning.
{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-}
module Parser (
  parse,
  printErrMsg,
  -- * Re-exports
  These(..),
) where

-- import Control.Applicative
import Control.Monad
import Control.Monad.Chronicle
import Control.Monad.Reader
import Control.Monad.State.Lazy
import Data.Char
import Data.Either (partitionEithers)
import Data.Foldable
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty(..))
import Data.These

-- import Debug.Trace

import AST
import Control.FAlternative
import Pretty


data Pos = Pos
  { posLine :: Int  -- ^ zero-based
  , posCol :: Int   -- ^ zero-based
  }
  deriving (Show)

-- Positions are zero-based in both dimensions.
-- See 'isInsideBlock' and 'isAtBlockLeft' for the two relevant "inside the
-- block" conditions.
data PS = PS
  { psBlk :: Pos  -- ^ Start of current layout block
  , psCur :: Pos  -- ^ Current parsing position
  , psRest :: String  -- ^ Rest of the input
  }
  deriving (Show)

data Context = Context
  { ctxFile :: FilePath
  , ctxLines :: [String]  -- ^ The file contents, split up in lines
  , ctxStack :: [String]  -- ^ Stack of syntax scopes, for error reporting
  }
  deriving (Show)

type family BacktrackPath fail r where
  BacktrackPath 'Fallible r = r
  BacktrackPath 'Infallible r = ()

newtype Parser fail a = Parser
  { runParser
      :: forall r.
         Context
      -> PS
      -> (PS -> [ErrMsg] -> a -> r)  -- ^ OK: some diagnostics, but parsing succeeded
      -> ([ErrMsg] -> r)  -- ^ Fatal: error that prevented parsing from proceeding
      -> BacktrackPath fail r  -- ^ Backtrack: alternative was exhausted without success
      -> r }

type IParser = Parser 'Infallible
type FParser = Parser 'Fallible

instance Functor (Parser fail) where
  fmap f (Parser g) = Parser (\ctx ps kok kfat kbt ->
    g ctx ps (\ps' errs x -> kok ps' errs (f x)) kfat kbt)

instance Applicative (Parser fail) where
  pure x = Parser (\_ ps kok _ _ -> kok ps [] x)
  (<*>) = ap

instance Monad (Parser fail) where
  Parser g >>= f = Parser $ \ctx ps kok kfat kbt ->
    g ctx ps
      (\ps1 errs x ->
          x `seq`
          runParser (f x) ctx ps1
            (\ps2 errs' y -> kok ps2 (errs <> errs') y)
            (\errs' -> kfat (errs <> errs'))
            kbt)
      (\errs -> kfat errs)
      kbt

instance FAlternative Parser where
  faempty = Parser (\_ _ _ _ kbt -> kbt)
  Parser f <|>> Parser g = Parser $ \ctx ps kok kfat kbt ->
    f ctx ps kok kfat (g ctx ps kok kfat kbt)

  noFail (Parser f) = Parser $ \ctx ps kok kfat _ -> f ctx ps kok kfat ()

  toFallible :: forall fail a. KnownFallible fail => Parser fail a -> Parser 'Fallible a
  toFallible (Parser f) = Parser $ \ctx ps kok kfat kbt ->
    f ctx ps kok kfat (case knownFallible @fail of
                         SFallible -> kbt
                         SInfallible -> ())

instance MonadState PS (Parser fail) where
  state f = Parser $ \_ ps kok _ _ ->
    let (x, ps') = f ps
    in kok ps' [] x

instance MonadReader Context (Parser fail) where
  reader f = Parser $ \ctx ps kok _ _ -> kok ps [] (f ctx)
  local f (Parser g) = Parser (\ctx -> g (f ctx))

instance KnownFallible fail => MonadChronicle [ErrMsg] (Parser fail) where
  dictate errs = Parser $ \_ ps kok _ _ -> kok ps errs ()
  confess errs = Parser $ \_ _ _ kfat _ -> kfat errs
  memento (Parser f) = Parser $ \ctx ps kok _ kbt ->
    f ctx ps
      (\ps' errs x -> kok ps' errs (Right x))
      (\errs -> kok ps [] (Left errs))
      kbt
  absolve def (toFallible -> Parser f) = Parser $ \ctx ps kok _ _ ->
    f ctx ps
      kok
      (\_ -> kok ps [] def)
      (kok ps [] def)
  condemn (Parser f) = Parser $ \ctx ps kok kfat kbt ->
    f ctx ps
      (\ps' errs x -> case errs of
                        [] -> kok ps' [] x
                        _ -> kfat errs)
      kfat
      kbt
  retcon g (Parser f) = Parser $ \ctx ps kok kfat kbt ->
    f ctx ps
      (\ps' errs x -> kok ps' (g errs) x)
      (\errs -> kfat (g errs))
      kbt
  chronicle th = case th of
    This errs -> Parser (\_ _ _ kfat _ -> kfat errs)
    That res -> Parser (\_ ps kok _ _ -> kok ps [] res)
    These errs res -> Parser (\_ ps kok _ _ -> kok ps errs res)

-- Positions are zero-based in both dimensions
data ErrMsg = ErrMsg
  { errFile :: FilePath
  , errStk :: [String]
  , errPos :: Pos
  , errMsg :: String
  , errSourceLine :: String }
  deriving (Show)

printErrMsg :: ErrMsg -> String
printErrMsg (ErrMsg fp stk (Pos y x) s srcline) =
  let linenum = show (y + 1)
  in intercalate "\n" $
      map (\descr -> "In " ++ descr ++ ":") (reverse stk)
      ++ [fp ++ ":" ++ show (y + 1) ++ ":" ++ show (x + 1) ++ ": " ++ s
         ,map (\_ -> ' ') linenum ++ " |"
         ,linenum ++ " | " ++ srcline
         ,map (\_ -> ' ') linenum ++ " | " ++ replicate x ' ' ++ "^"]

parse :: FilePath -> String -> These [ErrMsg] (Program ())
parse fp source =
  runParser pProgram (Context fp (lines source) []) (PS (Pos 0 0) (Pos 0 0) source)
    (\_ errs res -> case errs of
                      [] -> That res
                      _ -> These errs res)
    (\errs -> This errs)
    () --  (This [ErrMsg fp [] (Pos 0 0) "Parse error, no grammar alternatives match your source"])

pProgram :: IParser (Program ())
pProgram = do
  defs <- pTopDefs
  let (datadefs, fundefs) = partitionEithers defs
  skipWhiteComment
  assertEOF Error
  return (Program datadefs fundefs)

pTopDefs :: IParser [Either DataDef (FunDef ())]
pTopDefs = do
  faoptional pTopDef >>= \case
    Nothing -> do
      skipWhiteComment
      faoptional eof >>= \case
        Nothing -> do
          raise Error "Unparseable content"
          readWhileInline (const True)
          pTopDefs  -- will skip the possible newline
        Just () -> return []
    Just defs -> do
      defs2 <- pTopDefs
      return (defs ++ defs2)

pTopDef :: FParser [Either DataDef (FunDef ())]
pTopDef = do
  noFail skipWhiteComment
  noFail isAtBlockLeft >>= \case
    True -> map Left <$> pDataDef0 <|>> map Right <$> pFunDef0
    False -> do
      raise Error "Skipping unparseable content"
      noFail $ readWhileInline (const True)
      pTopDef

pDataDef0 :: FParser [DataDef]
pDataDef0 = do
  pKeyword "data"
  noFail $ do
    inlineWhite
    faoptional (pIdentifier0 InBlock Uppercase WCAssume) >>= \case
      Nothing -> do
        raise Error "Expected data declaration after 'data'"
        return []
      Just name -> do
        params <- famany (inlineWhite >> pIdentifier0 InBlock Lowercase WCBacktrack)
        cons <- pDatacons "="
        return [DataDef name params cons]
  where
    pDatacons :: String -> IParser [(Name, [Type])]
    pDatacons leader = do
      inlineWhite
      facatch (return []) $ do
        pKeySym leader
        inlineWhite
        name <- pIdentifier0 InBlock Uppercase WCAssume
        fields <- noFail $ famany pTypeAtom
        rest <- noFail $ pDatacons "|"
        return ((name, fields) : rest)

data FunEqContext
  = FirstLine
  | TypeSig Name
  | Continue Name
  deriving (Show)

pFunDef0 :: FParser [FunDef ()]
pFunDef0 =
  faasum'
    [do (name, typ) <- pStandaloneTypesig0
        noFail $ do
          faoptional (pFunEq (TypeSig name)) >>= \case
            Nothing -> do
              raise Error $ "Expected function equation for " ++ pretty name ++
                            " after type signature"
              return []
            Just [] -> return [FunDef name (Just typ) (FunEq name [] (Plain (ETup () [])) :| [])]
            Just (clause1 : clauses1) -> do
              clauses <- concat <$> famany (pFunEq (Continue name))
              return [FunDef name (Just typ) (clause1 :| clauses1 ++ clauses)]
    ,do pFunEq FirstLine >>= \case
          clause1@(FunEq name _ _) : clauses1 -> noFail $ do
            clauses <- concat <$> famany (pFunEq (Continue name))
            return [FunDef name Nothing (clause1 :| clauses1 ++ clauses)]
          [] -> faempty]

-- | Given the name from the type signature or a previous clause, if any.
pFunEq :: FunEqContext -> FParser [FunEq ()]
pFunEq fectx = do
  noFail skipWhiteComment
  faguardM isAtBlockLeft

  pushLocatedContext "function equation" $ do
    name <- pIdentifier0 AtLeft Lowercase WCAssume

    -- We want to do various checks with what came before, and there are
    -- multiple branches where we decide to continue parsing this equation. To
    -- avoid code duplication or an early exit monad, we use a boolean here.
    success <- case fectx of
      FirstLine -> return True
      TypeSig checkName
        | name == checkName -> return True
        | otherwise -> noFail $ do
            raise Error $ "Name of function clause does not correspond with type signature: " ++
                          pretty checkName
            return False
      Continue checkName -> do
        faguard (name == checkName)  -- this can still backtrack out of pFunEq
        return True

    noFail $ if success
      then do
        pats <- famany (pPattern 11)
        rhs <- pRHS "="
        return [FunEq name pats rhs]
      else return []

-- | Pass "=" for function definitions and "->" for case clauses.
pRHS :: String -> IParser (RHS ())
pRHS sepsym = do
  -- TODO: parse guards
  inlineWhite
  pKeySym sepsym <|>> raise Error ("Expected " ++ show sepsym)
  expr <- pExpr <|>> (raise Error "Expected expression" >> return (ETup () []))
  return (Plain expr)

pPattern :: Int -> FParser (Pattern ())
pPattern d = inlineWhite >> pPattern0 d

pPattern0 :: Int -> FParser (Pattern ())
pPattern0 d = do
  p0 <- pPatExprAtom0 (max 10 d)
  climbRight pPattern (pInfixOp Uppercase) (POp ()) d p0 Nothing

pExpr :: FParser (Expr ())
pExpr = do
  inlineWhite
  -- basics: lit, list, var, con, tup
  -- expression atom: application of basics
  -- expression parser: op
  -- around: let, case, if
  pushLocatedContext "expression" $ do
    faasum' [pELet0
            ,pECase0
            ,pEIf0
            ,pExprOpExpr0 0]

pPatExprAtom0 :: Int -> FParser (Pattern ())
pPatExprAtom0 d =
  faasum' [pPatWildcard0
          ,pPatVarOrAs0
          ,pPatCon0
          ,pPatList0
          ,pPatParens0]
  where
    pPatWildcard0 = pKeySym "_" >> return (PWildcard ())
    pPatVarOrAs0 = do
      var <- pIdentifier0 InBlock Lowercase WCBacktrack
      facatch (return (PVar () var)) $ do
        inlineWhite
        pKeySym "@"
        noFail $ do
          p <- pPattern 11 <|>> (raise Error "Expected pattern after '@'" >> return (PWildcard ()))
          return (PAs () var p)
    pPatCon0 = do
      con <- pIdentifier0 InBlock Uppercase WCBacktrack
      noFail $ if d > 10
        then return (PCon () con [])
        else do args <- famany (pPattern 11)
                return (PCon () con args)
    pPatList0 = do
      char '['  -- special syntax, no need for pKeySym
      noFail $ do
        ps <- pPattern 0 `sepBy` (inlineWhite >> char ',')
        inlineWhite
        char ']' <|>> raise Error "Expected ']'"
        return (PList () ps)
    pPatParens0 = do
      char '('
      inlineWhite
      faasum'
        [do char ')'
            return (PTup () [])
        ,do p <- pPattern0 0
            inlineWhite
            faasum'
              [do char ')'
                  return p
              ,do char ','
                  ps <- pPattern 0 `sepBy1` (inlineWhite >> char ',')
                  return (PTup () (p : ps))]]

pELet0 :: FParser (Expr ())
pELet0 = do
  pKeyword "let"
  noFail $ do
    inlineWhite
    defss <- startLayoutBlock $ do
      -- The first occurrence is also going to skip whitespace in front,
      -- which is redundant -- but not harmful.
      famany $ do
        noFail skipWhiteComment
        -- Note: now not necessarily in the indented block. Which is
        -- precisely what we need here. If we see "in", let the 'many'
        -- choice fail so that the defs loop ends. But let it fail outside
        -- this asum so that it is the many that picks it up, not this
        -- asum.
        res <- faasum' [Nothing <$ pKeyword "in"  -- note: will be dropped due to the empty backtrack
                       ,Just <$> pFunDef0]
        case res of
          Nothing -> faempty
          Just defs -> return defs

    let defs = concat defss
    inlineWhite
    facatch (do raise Error "Expected 'in' after 'let'"
                return (ELet () defs (ETup () []))) $ do
      pKeyword "in"
      noFail $ do
        inlineWhite
        body <- pExpr <|>> (raise Error "Expected expression" >> return (ETup () []))
        return (ELet () defs body)

pECase0 :: FParser (Expr ())
pECase0 = do
  pKeyword "case"
  noFail $ do
    e <- pExpr <|>> (raise Error "Expected expression" >> return (ETup () []))
    inlineWhite
    facatch (raise Error "Expected 'of' after 'case'" >> return (ECase () e [])) $ do
      pKeyword "of"
      noFail $ do
        inlineWhite
        startLayoutBlock $ do
          -- The first clause is going to skip whitespace, but that's harmless
          -- (though redundant).
          let pClause = do
                noFail $ skipWhiteComment
                whenM (noFail $ not <$> isInsideBlock) (() <$ faempty)
                pat <- pPattern0 0
                noFail $ do
                  rhs <- pRHS "->"
                  return (pat, rhs)
          clauses <- famany pClause
          return (ECase () e clauses)

pEIf0 :: FParser (Expr ())
pEIf0 = do
  pKeyword "if"
  noFail $ do
    e1 <- pExpr <|>> (raise Error "Expected expression" >> return (ECon () (Name "True")))
    inlineWhite
    facatch (raise Error "Expected 'then' after 'if'" >> return (EIf () e1 (ETup () []) (ETup () []))) $ do
      pKeyword "then"
      noFail $ do
        e2 <- pExpr <|>> (raise Error "Expected expression" >> return (ETup () []))
        inlineWhite
        facatch (raise Error "Expected else after 'if'" >> return (EIf () e1 (ETup () []) (ETup () []))) $ do
          pKeyword "else"
          noFail $ do
            e3 <- pExpr <|>> (raise Error "Expected expression" >> return (ETup () []))
            return (EIf () e1 e2 e3)

pExprOpExpr :: Int -> FParser (Expr ())
pExprOpExpr d = inlineWhite >> pExprOpExpr0 d

pExprOpExpr0 :: Int -> FParser (Expr ())
pExprOpExpr0 d = do
  e0 <- pEApp0
  climbRight pExprOpExpr (snd <$> pInfixOp Don'tCare) (EOp ()) d e0 Nothing

climbRight
  :: (Int -> FParser e)  -- ^ Parse an expression at the given precedence level
  -> FParser ParsedOperator  -- ^ Parse an operator
  -> (e -> Operator -> e -> e)  -- ^ Build an operator application experssion
  -> Int  -- ^ Ambient precedence level: minimum precedence of top-level operator in result
  -> e  -- ^ lhs: Initial non-operator expression already parsed
  -> Maybe ParsedOperator  -- ^ Top-level operator in lhs (initialise with Nothing)
  -> FParser e
climbRight pExpr' pOper makeOp d lhs mlhsop =
  facatch (return lhs) $ do
    paop@(PaOp op d2 a2) <- pOper
    faguard (d2 >= d)  -- respect global minimum precedence
    case mlhsop of  -- check operator compatibility
      Just (PaOp _ d1 a1) ->
        faguard (d1 > d2 || (d1 == d2 && a1 == a2 && a1 /= AssocNone))
      Nothing ->
        return ()
    let oprhsd = case a2 of AssocRight -> d2 ; _ -> d2 + 1
    rhs <- pExpr' oprhsd
    climbRight pExpr' pOper makeOp d (makeOp lhs op rhs) (Just paop)

pEApp0 :: FParser (Expr ())
pEApp0 = do
  e1 <- pEAtom0
  es <- noFail $ famany (inlineWhite >> pEAtom0)
  case es of
    [] -> return e1
    _ -> return (EApp () e1 es)

pEAtom0 :: FParser (Expr ())
pEAtom0 = faasum'
  [ELit () <$> pLiteral0
  ,pEList0
  ,pEVarOrCon0 
  ,pEParens0]

pLiteral0 :: FParser Literal
pLiteral0 = faasum'
  [do as <- toList <$> fasome (satisfy isDigit)
      let a = read as :: Integer
      facatch (return (LInt a)) $ do
        char '.'
        bs <- toList <$> fasome (satisfy isDigit)
        let b = read bs :: Integer
        cs <- noFail $ faoptional $ do
                char 'e'
                cs <- toList <$> fasome (satisfy isDigit)
                return cs
        let c = maybe 0 read cs :: Integer
        return (LFloat ((fromIntegral a + fromIntegral b / 10 ^ length bs) * 10 ^ c))
  ,do char '\''
      facatch (raise Error "Unclosed character literal" >> return (LChar '?')) $ do
        cs <- noFail $ famany pStringChar
        char '\''
        noFail $ do
          c <- case cs of
                 [c] -> return c
                 _ -> raise Error "Character literal must contain one character" >> return '?'
          return (LChar c)
  ,do char '"'
      noFail $ do
        s <- famany pStringChar
        char '"' <|>> raise Error "Unclosed string literal"
        return (LString s)]

pStringChar :: FParser Char
pStringChar = faasum'
  [do char '\\'
      char 'x'
      let hexdig = do
            c <- satisfy $ \c' ->
                    let c = toLower c'
                    in 'a' <= c && c <= 'f' || '0' <= c && c <= '9'
            return $ if 'a' <= c then 10 + ord c - ord 'a'
                                 else ord c - ord '0'
      digs <- toList <$> fasome hexdig
      return (chr (sum (zipWith (*) (reverse digs) (iterate (*16) 1))))
  ,do char '\\'
      satisfy (const True) >>= \case
        'n' -> return '\n'
        'r' -> return '\r'
        't' -> return '\t'
        'a' -> return '\a'
        'b' -> return '\b'
        '\'' -> return '\''
        '\"' -> return '\"'
        '0' -> return '\0'
        c -> do raise Error $ "Invalid escape sequence: \\" ++ [c]
                return '?'
  ,do satisfy (\c -> c `notElem` "\n\r\\\'")]

pEList0 :: FParser (Expr ())
pEList0 = do
  char '['  -- special syntax, no need for pKeySym
  noFail $ do
    es <- sepBy pExpr (inlineWhite >> char ',')
    inlineWhite
    char ']' <|>> raise Error "Expected closing ']'"
    return (EList () es)

pEVarOrCon0 :: FParser (Expr ())
pEVarOrCon0 =
  pIdentifier0 InBlock Don'tCare () >>= \case
    (Lowercase, name) -> return (EVar () name)
    (Uppercase, name) -> return (ECon () name)

pEParens0 :: FParser (Expr ())
pEParens0 = do
  char '('
  noFail $ do
    e <- pExpr <|>> (raise Error "Expected expression" >> return (ETup () []))
    inlineWhite
    char ')' <|>> raise Error "Expected closing ')'"
    return e

data Associativity = AssocLeft | AssocRight | AssocNone
  deriving (Show, Eq)

data ParsedOperator = PaOp Operator Int Associativity
  deriving (Show)

pInfixOp :: Case care -> FParser (WithCaseOutput care ParsedOperator)
pInfixOp cs = do
  inlineWhite
  case cs of
    Lowercase -> pLowerInfixOp0
    Uppercase -> pUpperInfixOp0
    Don'tCare -> faasum' [(Lowercase,) <$> pLowerInfixOp0
                         ,(Uppercase,) <$> pUpperInfixOp0]

pLowerInfixOp0 :: FParser ParsedOperator
pLowerInfixOp0 =
  faasum' [PaOp OEqu 4 AssocNone  <$ pKeySym "=="
          ,PaOp OAdd 6 AssocLeft  <$ pKeySym "+"
          ,PaOp OSub 6 AssocLeft  <$ pKeySym "-"
          ,PaOp OMul 7 AssocLeft  <$ pKeySym "*"
          ,PaOp ODiv 7 AssocLeft  <$ pKeySym "/"
          ,PaOp OMod 7 AssocLeft  <$ pKeySym "%"
          ,PaOp OPow 8 AssocRight <$ pKeySym "^"
          ]

pUpperInfixOp0 :: FParser ParsedOperator
pUpperInfixOp0 =
  faasum' [PaOp OCons 5 AssocRight <$ pKeySym ":"]

pStandaloneTypesig0 :: FParser (Name, Type)
pStandaloneTypesig0 = do
  name <- pIdentifier0 AtLeft Lowercase WCBacktrack
  inlineWhite
  pKeySym "::"
  noFail $ pushContext ("type signature for " ++ pretty name) $ do
    ty <- pType <|>> (raise Error "Expected type" >> return (TTup []))
    return (name, ty)

pType :: FParser Type
pType = do
  ty1 <- pTypeApp
  facatch (return ty1) $ do
    inlineWhite
    pKeySym "->"
    noFail $ do
      ty2 <- pType <|>> (raise Error "Expected type" >> return (TTup []))
      return (TFun ty1 ty2)

pTypeApp :: FParser Type
pTypeApp = fasome pTypeAtom >>= \case
  t :| [] -> return t
  t :| ts -> return (TApp t ts)

pTypeAtom :: FParser Type
pTypeAtom = faasum' [pTypeParens, pTypeList, pTypeName]
  where
    pTypeParens = do
      inlineWhite
      char '('
      faasum'
        [do inlineWhite
            char ')'
            return (TTup [])
        ,do ty1 <- pType
            noFail $ do
              ty2s <- famany $ do
                inlineWhite
                char ','
                noFail $ pType <|>> (raise Error "Expected type" >> return (TTup []))
              inlineWhite
              char ')' <|>> raise Error "Expected closing ')'"
              case ty2s of
                [] -> return ty1
                _ -> return (TTup (ty1 : ty2s))]

    pTypeList = do
      inlineWhite
      char '['
      ty <- pType
      noFail $ char ']' <|>> raise Error "Expecte closing ']'"
      return (TList ty)

    pTypeName = do
      inlineWhite
      (cs, name) <- pIdentifier0 InBlock Don'tCare ()
      case cs of
        Uppercase -> return (TCon name)
        Lowercase -> return (TVar name)

-- | Parse the given name-like keyword, ensuring that it is the entire word.
pKeyword :: String -> FParser ()
pKeyword s = do
  string s
  -- traceM $ "pKeyword: parsed " ++ show s
  notFollowedBy (() <$ satisfy isNameContChar)

-- | Parse the given symbol-like keyword, ensuring that it is the entire symbol.
pKeySym :: String -> FParser ()
pKeySym s = do
  string s
  notFollowedBy (() <$ satisfy isSymbolChar)

data Case care where
  Uppercase :: Case 'True
  Lowercase :: Case 'True
  Don'tCare :: Case 'False
deriving instance Show (Case care)

type family WithCaseOutput care a where
  WithCaseOutput 'True a = a
  WithCaseOutput 'False a = (Case 'True, a)

type family If c a b where
  If 'True a b = a
  If 'False a b = b

data WrongCaseBacktrack
  = WCBacktrack  -- ^ If a word was found but it had the wrong case, fail and backtrack.
  | WCAssume     -- ^ Be certain that this case is expected here, and assume incorrect
                 --   case is a typo.
  deriving (Show)

-- | Consumes an identifier (word or parenthesised operator) at the current
-- position. The `var` production in Haskell2010.
-- var -> varid | "(" varsym ")"
pIdentifier0 :: BlockPos -> Case care -> If care WrongCaseBacktrack () -> FParser (WithCaseOutput care Name)
pIdentifier0 bpos cs wrongcase =
  pAlphaName0 bpos cs wrongcase <|>> pParens0 (pSymbol0 bpos cs)
  where
    -- | Parser between parens, with the opening paren at the current position.
    pParens0 :: FParser a -> FParser a
    pParens0 p = do
      char '('
      inlineWhite
      res <- p
      inlineWhite
      char ')'
      return res

-- | Consumes a word-like name at the current position with the given case. The
-- `varid` production in Haskell2010 for 'Lowercase', `conid' for 'Uppercase'.
--
-- > varid -> (small {small | large | digit | "'"}) without reservedid
pAlphaName0 :: BlockPos -> Case care -> If care WrongCaseBacktrack () -> FParser (WithCaseOutput care Name)
pAlphaName0 bpos cs wrongcase = do
  startPos <- gets psCur
  (_, s) <- readToken
      bpos
      (\atfst mc -> case (atfst, mc) of
          (True , Just c) | isNameHeadChar c -> Just (Right False)
          (True , _     )                    -> Nothing
          (False, Just c) | isNameContChar c -> Just (Right False)
          (False, _     )                    -> Just (Left ()))
      True
  faguard (s `notElem` ["case", "class", "data", "default", "deriving", "do", "else"
                       ,"foreign", "if", "import", "in", "infix", "infixl"
                       ,"infixr", "instance", "let", "module", "newtype", "of"
                       ,"then", "type", "where", "_"])
  (name, adjoin) <- case cs of
    Uppercase
      | isLower (head s) -> case wrongcase of
          WCBacktrack -> faempty
          WCAssume -> noFail $ do
            raiseAt startPos Error "Unexpected uppercase word at this position, assuming typo"
            return (toUpper (head s) : tail s, id)
      | otherwise -> return (s, id)
    Lowercase
      | isUpper (head s) -> case wrongcase of
          WCBacktrack -> faempty
          WCAssume -> noFail $ do
            raiseAt startPos Error "Unexpected lowercase word at this position, assuming typo"
            return (toLower (head s) : tail s, id)
      | otherwise -> return (s, id)
    Don'tCare
      | isLower (head s) -> return (s, (Lowercase,))
      | otherwise        -> return (s, (Uppercase,))
  return (adjoin (Name name))

isNameHeadChar :: Char -> Bool
isNameHeadChar c = isLetter c || c == '_'

isNameContChar :: Char -> Bool
isNameContChar c = isNameHeadChar c || isDigit c || c == '\''

-- | Consumes a symbol at the current position. The `varsym` production in
-- Haskell2010 for 'Lowercase', `consym` otherwise, and either if 'Don'tCare'.
--
-- > varsym -> ((symbol without ":") {symbol}) without (reservedop | dashes)
-- > consym -> (":" {symbol}) without reservedop
-- > symbol -> ascSymbol | uniSymbol without (special | "_" | "\"" | "'")
-- > ascSymbol -> ```!#$%&⋆+./<=>?@^|-~:```
-- > uniSymbol -> unicode symbol or punctuation
-- > dashes -> "--" {"-"}
-- > special -> ```(),;[]`{}```
-- > reservedop -> ".." | ":" | "::" | "=" | "\" | "|" | "<-" | "->" | "@" | "~" | "=>"
pSymbol0 :: BlockPos -> Case care -> FParser (WithCaseOutput care Name)
pSymbol0 bpos cs = do
  case bpos of
    AtLeft -> whenM (noFail $ not <$> isAtBlockLeft) (() <$ faempty)
    InBlock -> whenM (noFail $ not <$> isInsideBlock) faempty
  (c1, adjoin) <-
    case cs of Lowercase -> (,id) <$> satisfy (\c -> isSymbolChar c && c /= ':')
               Uppercase -> (,id) <$> satisfy (== ':')
               Don'tCare -> do c1 <- satisfy (\c -> isSymbolChar c)
                               return (c1, if c1 == ':' then (Uppercase,) else (Lowercase,))
  crest <- noFail $ famany (satisfy isSymbolChar)
  let name = c1 : crest
  faguard (name `notElem` ["..", ":", "::", "=", "\\", "|", "<-", "->", "@", "~", "=>"])
  faguard (take 2 name /= "--")
  return (adjoin (Name name))

isSymbolChar :: Char -> Bool
isSymbolChar c = (isAscSymbol || isUniSymbol) && not isSpecialExt
  where
    isSpecialExt = c `elem` "(),;[]`{}_\"'"
    isAscSymbol = c `elem` "!#$%&⋆+./<=>?@^|-~:"
    isUniSymbol = ord c > 127 && (isSymbol c || isPunctuation c)


sepBy1 :: FParser a -> FParser sep -> FParser [a]
sepBy1 p psep = do
  x1 <- p
  (psep >> (x1 :) <$> sepBy1 p psep) <|>> pure [x1]

sepBy :: FParser a -> FParser sep -> IParser [a]
sepBy p psep = sepBy1 p psep <|>> pure []

-- | Start a new layout block at the current position. The old layout block is
-- restored after completion of this subparser.
startLayoutBlock :: IParser a -> IParser a
startLayoutBlock p = do
  ps0 <- get
  put (ps0 { psBlk = psCur ps0 })
  res <- p
  modify (\ps -> ps { psBlk = psBlk ps0 })
  return res

data Fatality fatal where
  Error :: Fatality 'False
  Fatal :: Fatality 'True
deriving instance Show (Fatality fatal)

type family FatalCtx fatal a where
  FatalCtx 'False a = a ~ ()
  FatalCtx 'True a = ()

raise_ :: KnownFallible fail => Fatality fatal -> String -> Parser fail ()
raise_ Error = raise Error
raise_ Fatal = raise Fatal

raise :: (KnownFallible fail, FatalCtx fatal a) => Fatality fatal -> String -> Parser fail a
raise fat msg = gets psCur >>= \pos -> raiseAt pos fat msg

-- | Raise an error with the given fatality and description.
raiseAt :: (KnownFallible fail, FatalCtx fatal a) => Pos -> Fatality fatal -> String -> Parser fail a
raiseAt pos fat msg = do
  Context { ctxFile = fp , ctxStack = stk, ctxLines = srcLines } <- ask
  let err = ErrMsg fp stk pos msg (srcLines !! posLine pos)
  case fat of
    Error -> dictate (pure err)
    Fatal -> confess (pure err)

describeLocation :: IParser String
describeLocation = do
  fp <- asks ctxFile
  cur <- gets psCur
  return $ fp ++ ":" ++ show (posLine cur + 1) ++ ":" ++ show (posCol cur + 1)

-- | Registers a scope description on the stack for error reporting.
pushContext :: String -> Parser fail a -> Parser fail a
pushContext descr = local (\c -> c { ctxStack = descr : ctxStack c })

-- | Registers a scope description on the stack for error reporting, suffixed
-- with the current parsing location.
pushLocatedContext :: String -> Parser fail a -> Parser fail a
pushLocatedContext descr p = do
  loc <- noFail describeLocation
  pushContext (descr ++ " at " ++ loc) p

data BlockPos = AtLeft | InBlock
  deriving (Show)

-- | Consumes a token at the current position, asserting that we are
-- in the position indicated by the 'BlockPos' argument. The token is defined
-- by a pure stateful parser. If encountering a newline or EOF, the parser is
-- run on this character ('Nothing' for EOF); if this produces a result, the
-- result is returned; otherwise, the parser fails. The newline is not consumed.
readToken :: BlockPos -> (s -> Maybe Char -> Maybe (Either r s)) -> s -> FParser (r, String)
readToken bpos f s0 = do
  case bpos of
    AtLeft -> whenM (noFail $ not <$> isAtBlockLeft) (() <$ faempty)
    InBlock -> whenM (noFail $ not <$> isInsideBlock) faempty
  let loop :: (s -> Maybe Char -> Maybe (Either r s)) -> s -> FParser (r, String)
      loop f' st = do
        ps <- get
        case psRest ps of
          []       | Just (Left res) <- f' st Nothing     -> return (res, "")
                   | otherwise -> faempty
          '\n' : _ | Just (Left res) <- f' st (Just '\n') -> return (res, "")
          c : cs -> case f' st (Just c) of
                      Nothing -> faempty
                      Just (Left res) -> return (res, "")
                      Just (Right st') -> do
                          let Pos line col = psCur ps
                          put (ps { psCur = Pos line (col + 1), psRest = cs })
                          fmap (c :) <$> loop f' st'
  loop f s0

-- | Consumes all whitespace and comments (including newlines), but only if
-- this then leaves the parser inside the current block. If not, succeeds and
-- consumes nothing.
inlineWhite :: Parser fail ()
inlineWhite = do
  ps <- get
  noFail skipWhiteComment
  whenM (noFail $ not <$> isInsideBlock) $ put ps

-- | Consumes all whitespace and comments (including newlines). Note: this may
-- end outside the current block.
skipWhiteComment :: IParser ()
skipWhiteComment = do
  inlineSpaces
  _ <- famany (blockComment >> noFail inlineSpaces)
  optional_ lineComment
  optional_ (consumeNewline >> noFail skipWhiteComment)
  where
    -- | Consumes some inline whitespace. Stops before newlines.
    inlineSpaces :: IParser ()
    inlineSpaces = readWhileInline isSpace

-- | Consumes an delimited comment including both end markers. Note: this may
-- end outside the current block.
blockComment :: FParser ()
blockComment = do
  string "{-"  -- no need for pKeySym here
  let loop = do
        faasum [string "-}"
               ,eof >> raise Error "Unfinished {- -} comment at end of file"
               ,blockComment >> noFail loop
               ,consumeNewline >> noFail loop]
          (readWhileInline (`notElem` "{-"))  -- "-}" also starts with '-'
  noFail loop

-- | Consumes a line comment marker and the rest of the line, excluding
-- newline.
lineComment :: FParser ()
lineComment = do
  -- '--!' is an operator, so we need to parse a whole symbol here.
  pKeySym "--"
  noFail $ readWhileInline (const True)

-- | Raises an error if we're not currently at EOF.
assertEOF :: Fatality fatal -> IParser ()
assertEOF fat = gets psRest >>= \case
  [] -> return ()
  _ -> raise_ fat "Unexpected stuff"

-- | Returns whether the current position is _within_ the current block, for
-- soft-wrapping content. This means that col > blkCol.
isInsideBlock :: IParser Bool
isInsideBlock = do
  PS { psCur = cur, psBlk = blk } <- get
  return $ posLine cur >= posLine blk && posCol cur > posCol blk

-- | Returns whether the current position is at the left border of the block;
-- this is for list content such as function definitions or let bindings. This
-- means that col == blkCol.
isAtBlockLeft :: IParser Bool
isAtBlockLeft = do
  PS { psCur = cur, psBlk = blk } <- get
  return $ posLine cur >= posLine blk && posCol cur == posCol blk

-- | Consumes characters while the predicate holds or until (and excluding)
-- a newline, whichever comes first.
readWhileInline :: (Char -> Bool) -> IParser ()
readWhileInline p = do
  (taken, rest) <- span (\c -> p c && c /= '\n') <$> gets psRest
  modify (\ps -> ps { psCur = let Pos line col = psCur ps
                              in Pos line (col + length taken)
                    , psRest = rest })

-- | Consumes exactly one newline at the current position.
consumeNewline :: FParser ()
consumeNewline = gets psRest >>= \case
  '\n' : rest -> modify (\ps -> ps { psCur = Pos (posLine (psCur ps) + 1) 0
                                   , psRest = rest })
  _ -> faempty

-- | Consumes exactly one character, unequal to newline, at the current position.
satisfy :: (Char -> Bool) -> FParser Char
satisfy p = do
  -- traceM "entering satisfy"
  r <- gets psRest
  -- traceM "got rest"
  r `seq` return ()
  -- traceM "seqd rest"
  -- traceM ("rest is " ++ show r)
  case r of
    c : rest | c /= '\n', p c -> do
        modify (\ps -> let Pos line col = psCur ps
                       in ps { psCur = Pos line (col + 1)
                             , psRest = rest })
        return c
    _ -> faempty

-- | Consumes exactly this character at the current position. Must not be a
-- newline.
char :: Char -> FParser ()
char c = string [c]

-- | Consumes exactly this string at the current position. The string must not
-- contain a newline.
string :: String -> FParser ()
string s | any (== '\n') s = error "Newline in 'string' argument"
string s = do
  ps <- get
  let Pos line col = psCur ps
  if take (length s) (psRest ps) == s
    then put (ps { psCur = Pos line (col + length s)
                 , psRest = drop (length s) (psRest ps) })
    else faempty

-- lookAhead :: FParser a -> FParser a
-- lookAhead p = do
--   ps <- get
--   success <- (Just <$> p) <|>> pure Nothing
--   put ps  -- restore state, as if nothing happened
--   case success of
--     Nothing -> faempty
--     Just x -> return x

notFollowedBy :: FParser () -> FParser ()
notFollowedBy p = do
  ps <- get
  success <- (False <$ p) <|>> pure True
  put ps  -- restore state, as if nothing happened
  when (not success) faempty

-- | Only succeeds at EOF.
eof :: FParser ()
eof = gets psRest >>= \case [] -> return ()
                            _ -> faempty

whenM :: (Monad m, Monoid a) => m Bool -> m a -> m a
whenM mb mx = mb >>= \b -> if b then mx else return mempty

optional_ :: FAlternative f => f 'Fallible a -> f 'Infallible ()
optional_ a = (() <$ a) <|>> pure ()