Move to src/, working HLS in examples/

1 files changed, 0 insertions, 824 deletions

diff --git a/Parser.hs b/Parser.hs
deleted file mode 100644
index 0f0bd0c..0000000
--- a/Parser.hs
+++ /dev/null
@@ -1,824 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TypeOperators #-}
--- 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.Bifunctor (first)
-import Data.Char
-import Data.Either (partitionEithers)
-import Data.List.NonEmpty (NonEmpty(..))
-import Data.These
-import Data.Tuple (swap)
-
--- import Debug.Trace
-
-import AST
-
-
--- Positions are zero-based in both dimensions.
--- See 'isInsideBlock' and 'isAtBlockLeft' for the two relevant "inside the
--- block" conditions.
-data PS = PS
-  { psBlkLine :: Int  -- ^ Start line of current layout block
-  , psBlkCol :: Int   -- ^ Start column of current layout block
-  , psLine :: Int  -- ^ Current line
-  , psCol :: Int   -- ^ Current column
-  , psRest :: String  -- ^ Rest of the input
-  }
-  deriving (Show)
-
-data Context = Context
-  { ctxFile :: FilePath
-  , ctxStack :: [String]  -- ^ Stack of syntax scopes, for error reporting
-  }
-  deriving (Show)
-
--- ReaderT Context (ChronicleT [ErrMsg] (State PS) a)
--- Context -> ChronicleT [ErrMsg] (State PS) a
--- Context -> State PS (These [ErrMsg] a)
--- Context -> PS -> Identity (These [ErrMsg] a, PS)
--- Context -> PS -> (These [ErrMsg] a, PS)
--- whereas I want:
--- Context -> PS -> These [ErrMsg] (a, PS)
--- which is not any transformer stack, but a new monad.
-newtype Parser a = Parser { runParser :: Context -> PS -> These [ErrMsg] (PS, a) }
-
-instance Functor Parser where
-  fmap f (Parser g) = Parser (\ctx ps -> fmap (fmap f) (g ctx ps))
-
-instance Applicative Parser where
-  pure x = Parser (\_ ps -> That (ps, x))
-  (<*>) = ap
-
-instance Monad Parser where
-  Parser g >>= f = Parser $ \ctx ps ->
-    case g ctx ps of
-      This errs -> This errs
-      That (ps', x) -> runParser (f x) ctx ps'
-      These errs (ps', x) -> case runParser (f x) ctx ps' of
-                               This errs' -> This (errs <> errs')
-                               That res -> These errs res
-                               These errs' res -> These (errs <> errs') res
-
-instance Alternative Parser where
-  empty = Parser (\_ _ -> This [])
-  Parser f <|> Parser g = Parser $ \ctx ps ->
-    case f ctx ps of
-      This _ -> g ctx ps
-      success -> success
-
-instance MonadState PS Parser where
-  state f = Parser $ \_ ps -> That (swap (f ps))
-
-instance MonadReader Context Parser where
-  reader f = Parser $ \ctx ps -> That (ps, f ctx)
-  local f (Parser g) = Parser (g . f)
-
-instance MonadChronicle [ErrMsg] Parser where
-  dictate errs = Parser (\_ ps -> These errs (ps, ()))
-  confess errs = Parser (\_ _ -> This errs)
-  memento (Parser f) = Parser (\ctx ps -> case f ctx ps of
-                                            This errs -> That (ps, Left errs)
-                                            That res -> That (Right <$> res)
-                                            These errs res -> These errs (Right <$> res))
-  absolve def (Parser f) = Parser (\ctx ps -> case f ctx ps of
-                                                This _ -> That (ps, def)
-                                                success -> success)
-  condemn (Parser f) = Parser (\ctx ps -> case f ctx ps of
-                                            These errs _ -> This errs
-                                            res -> res)
-  retcon g (Parser f) = Parser (\ctx ps -> first g (f ctx ps))
-  chronicle th = Parser (\_ ps -> (ps,) <$> th)
-
--- Positions are zero-based in both dimensions
-data ErrMsg = ErrMsg
-  { errFile :: FilePath
-  , errStk :: [String]
-  , errLine :: Int
-  , errCol :: Int
-  , errMsg :: String }
-  deriving (Show)
-
-printErrMsg :: ErrMsg -> String
-printErrMsg (ErrMsg fp stk y x s) =
-  unlines (map (\descr -> "In " ++ descr ++ ":") (reverse stk)) ++
-  fp ++ ":" ++ show (y + 1) ++ ":" ++ show (x + 1) ++ ": " ++ s
-
-parse :: FilePath -> String -> These [ErrMsg] (Program ())
-parse fp source = fmap snd $ runParser pProgram (Context fp []) (PS 0 0 0 0 source)
-
-pProgram :: Parser (Program ())
-pProgram = do
-  defs <- many pTopDef
-  let (datadefs, fundefs) = partitionEithers defs
-  skipWhiteComment
-  assertEOF Error
-  return (Program datadefs fundefs)
-
-pTopDef :: Parser (Either DataDef (FunDef ()))
-pTopDef = do
-  skipWhiteComment
-  Left <$> pDataDef0 <|> Right <$> pFunDef0
-
-pDataDef0 :: Parser DataDef
-pDataDef0 = do
-  pKeyword "data"
-  inlineWhite
-  name <- pIdentifier0 InBlock Uppercase
-  params <- many (inlineWhite >> pIdentifier0 InBlock Lowercase)
-  cons <- pDatacons "="
-  return (DataDef name params cons)
-  where
-    pDatacons :: String -> Parser [(Name, [Type])]
-    pDatacons leader = do
-      inlineWhite
-      pKeySym leader
-      inlineWhite
-      name <- pIdentifier0 InBlock Uppercase
-      fields <- many pTypeAtom
-      rest <- pDatacons "|" <|> return []
-      return ((name, fields) : rest)
-
-pFunDef0 :: Parser (FunDef ())
-pFunDef0 = do
-  mtypesig <- optional pStandaloneTypesig0
-  let mname = fst <$> mtypesig
-      mtype = snd <$> mtypesig
-  (clauses, name) <- someClauses mname
-  return (FunDef name mtype clauses)
-  where
-    someClauses :: Maybe Name -> Parser (NonEmpty (FunEq ()), Name)
-    someClauses Nothing = do
-        clause@(FunEq name _ _) <- pFunEq Nothing
-        (,name) . (clause :|) <$> many (pFunEq (Just name))
-    someClauses (Just name) = (,name) <$> someNE (pFunEq (Just name))
-
--- | Given the name of the type signature, if any.
-pFunEq :: Maybe Name -> Parser (FunEq ())
-pFunEq mCheckName = do
-  skipWhiteComment
-  assertAtBlockLeft Fatal "Expected function clause, found indented stuff"
-
-  name <- pIdentifier0 AtLeft Lowercase
-  case mCheckName of
-    Just checkName | name /= checkName ->
-        raise Fatal "Name of function clause does not correspond with type signature"
-    _ -> return ()
-
-  pats <- many (pPattern 11)
-  rhs <- pRHS "="
-  return (FunEq name pats rhs)
-
--- | Pass "=" for function definitions and "->" for case clauses.
-pRHS :: String -> Parser (RHS ())
-pRHS sepsym = do
-  -- TODO: parse guards
-  inlineWhite
-  pKeySym sepsym
-  Plain <$> pExpr
-
-pPattern :: Int -> Parser (Pattern ())
-pPattern d = inlineWhite >> pPattern0 d
-
-pPattern0 :: Int -> Parser (Pattern ())
-pPattern0 d = do
-  asum [pPatWildcard0
-       ,pPatVarOrAs0
-       ,pPatCon0
-       ,pPatList0
-       ,pPatParens0]
-  where
-    pPatWildcard0 = pKeySym "_" >> return (PWildcard ())
-    pPatVarOrAs0 = do
-      var <- pIdentifier0 InBlock Lowercase
-      asum [do inlineWhite
-               pKeySym "@"
-               p <- pPattern 11
-               return (PAs () var p)
-           ,return (PVar () var)]
-    pPatCon0 = do
-      con <- pIdentifier0 InBlock Uppercase
-      if d > 0
-        then return (PCon () con [])
-        else do args <- many (pPattern 11)
-                return (PCon () con args)
-    pPatList0 = do
-      char '['  -- special syntax, no need for pKeySym
-      ps <- pPattern 0 `sepBy` (inlineWhite >> char ',')
-      inlineWhite
-      char ']'
-      return (PList () ps)
-    pPatParens0 = do
-      char '('
-      inlineWhite
-      asum [do char ')'
-               return (PTup () [])
-           ,do p <- pPattern0 0
-               inlineWhite
-               asum [do char ')'
-                        return p
-                    ,do char ','
-                        ps <- pPattern 0 `sepBy1` (inlineWhite >> char ',')
-                        return (PTup () (p : ps))]]
-
-pExpr :: Parser (Expr ())
-pExpr = do
-  inlineWhite
-  -- basics: lit, list, var, con, tup
-  -- expression atom: application of basics
-  -- expression parser: op
-  -- around: let, case, if
-  asum [pELet0
-       ,pECase0
-       ,pEIf0
-       ,pExprOpExpr0 0]
-
-pELet0 :: Parser (Expr ())
-pELet0 = do
-  pKeyword "let"
-  inlineWhite
-  startLayoutBlock $ do
-    -- The first occurrence is also going to skip whitespace in front,
-    -- which is redundant -- but not harmful.
-    defs <- many $ do
-      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 <- asum [Nothing <$ lookAhead (pKeyword "in")
-                  ,Just <$> pFunDef0]
-      case res of
-        Nothing -> empty
-        Just def -> return def
-    inlineWhite
-    body <- pExpr
-    return (ELet () defs body)
-
-pECase0 :: Parser (Expr ())
-pECase0 = do
-  pKeyword "case"
-  e <- pExpr
-  inlineWhite
-  pKeyword "of"
-  inlineWhite
-  startLayoutBlock $ do
-    -- The first clause is going to skip whitespace, but that's harmless
-    -- (though redundant).
-    let pClause = do
-          skipWhiteComment
-          whenM (not <$> isInsideBlock) (() <$ empty)
-          pat <- pPattern0 0
-          rhs <- pRHS "->"
-          return (pat, rhs)
-    clauses <- many pClause
-    return (ECase () e clauses)
-
-pEIf0 :: Parser (Expr ())
-pEIf0 = do
-  pKeyword "if"
-  e1 <- pExpr
-  inlineWhite
-  pKeyword "then"
-  e2 <- pExpr
-  inlineWhite
-  pKeyword "else"
-  e3 <- pExpr
-  return (EIf () e1 e2 e3)
-
-pExprOpExpr :: Int -> Parser (Expr ())
-pExprOpExpr d = inlineWhite >> pExprOpExpr0 d
-
-pExprOpExpr0 :: Int -> Parser (Expr ())
-pExprOpExpr0 d = do
-  e0 <- pEApp0
-  climbRight e0 Nothing
-  where
-    climbRight :: Expr () -> Maybe ParsedOperator -> Parser (Expr ())
-    climbRight lhs mlhsop = do
-      asum [do paop@(PaOp op d2 a2) <- pInfixOp
-               guard (d2 >= d)  -- respect global minimum precedence
-               case mlhsop of  -- check operator compatibility
-                 Just (PaOp _ d1 a1) ->
-                     guard (d1 > d2 || (d1 == d2 && a1 == a2 && a1 /= AssocNone))
-                 Nothing ->
-                     return ()
-               let oprhsd = case a2 of AssocRight -> d2 ; _ -> d2 + 1
-               rhs <- pExprOpExpr oprhsd
-               climbRight (EOp () lhs op rhs) (Just paop)
-           ,return lhs]
-
-pEApp0 :: Parser (Expr ())
-pEApp0 = do
-  e1 <- pEAtom0
-  es <- many (inlineWhite >> pEAtom0)
-  case es of
-    [] -> return e1
-    _ -> return (EApp () e1 es)
-
-pEAtom0 :: Parser (Expr ())
-pEAtom0 = (ELit () <$> pLiteral0) <|> pEList0 <|> pEVar0 <|> pECon0 <|> pEParens0
-
-pLiteral0 :: Parser Literal
-pLiteral0 = asum
-  [do as <- some (satisfy isDigit)
-      let a = read as :: Integer
-      asum
-        [do char '.'
-            bs <- some (satisfy isDigit)
-            let b = read bs :: Integer
-            cs <- optional $ do
-                    char 'e'
-                    cs <- some (satisfy isDigit)
-                    return cs
-            let c = maybe 0 read cs :: Integer
-            return (LFloat ((fromIntegral a + fromIntegral b / 10 ^ length bs) * 10 ^ c))
-        ,return (LInt a)]
-  ,do char '\''
-      c <- pStringChar
-      char '\''
-      return (LChar c)
-  ,do char '"'
-      s <- many pStringChar
-      char '"'
-      return (LString s)]
-
-pStringChar :: Parser Char
-pStringChar = asum
-  [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 <- some 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 :: Parser (Expr ())
-pEList0 = do
-  char '['  -- special syntax, no need for pKeySym
-  es <- sepBy pExpr (inlineWhite >> char ',')
-  inlineWhite
-  char ']'
-  return (EList () es)
-
-pEVar0 :: Parser (Expr ())
-pEVar0 = EVar () <$> pIdentifier0 InBlock Lowercase
-
-pECon0 :: Parser (Expr ())
-pECon0 = ECon () <$> pIdentifier0 InBlock Uppercase
-
-pEParens0 :: Parser (Expr ())
-pEParens0 = do
-  char '('
-  e <- pExpr
-  inlineWhite
-  char ')'
-  return e
-
-data Associativity = AssocLeft | AssocRight | AssocNone
-  deriving (Show, Eq)
-
-data ParsedOperator = PaOp Operator Int Associativity
-  deriving (Show)
-
-pInfixOp :: Parser ParsedOperator
-pInfixOp = do
-  inlineWhite
-  asum [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 "^"
-       ]
-
-pStandaloneTypesig0 :: Parser (Name, Type)
-pStandaloneTypesig0 = do
-  assertAtBlockLeft Fatal "Expected top-level definition, found indented stuff"
-  name@(Name namestr) <- pIdentifier0 AtLeft Lowercase
-  inlineWhite
-  pKeySym "::"
-  pushContext ("type signature for '" ++ namestr ++ "'") $ do
-      ty <- pType
-      return (name, ty)
-
-pType :: Parser Type
-pType = do
-  ty1 <- pTypeApp
-  asum [do inlineWhite
-           pKeySym "->"
-           ty2 <- pType
-           return (TFun ty1 ty2)
-       ,return ty1]
-
-pTypeApp :: Parser Type
-pTypeApp = many pTypeAtom >>= \case
-  [] -> raise Fatal "Expected type"
-  [t] -> return t
-  t:ts -> return (TApp t ts)
-
-pTypeAtom :: Parser Type
-pTypeAtom = pTypeParens <|> pTypeList <|> pTypeName
-  where
-    pTypeParens = do
-      inlineWhite
-      char '('
-      asum [do inlineWhite
-               char ')'
-               return (TTup [])
-           ,do ty1 <- pType
-               ty2s <- many $ do
-                 inlineWhite
-                 char ','
-                 pType
-               inlineWhite
-               char ')'
-               case ty2s of
-                 [] -> return ty1
-                 _ -> return (TTup (ty1 : ty2s))]
-
-    pTypeList = do
-      inlineWhite
-      char '['
-      ty <- pType
-      char ']'
-      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 -> Parser ()
-pKeyword s = do
-  string s
-  notFollowedBy (() <$ satisfy isNameContChar)
-
--- | Parse the given symbol-like keyword, ensuring that it is the entire symbol.
-pKeySym :: String -> Parser ()
-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)
-
--- | Consumes an identifier (word or parenthesised operator) at the current
--- position. The `var` production in Haskell2010.
--- var -> varid | "(" varsym ")"
-pIdentifier0 :: BlockPos -> Case care -> Parser (WithCaseOutput care Name)
-pIdentifier0 bpos cs = pAlphaName0 bpos cs <|> pParens0 (pSymbol0 bpos cs)
-  where
-    -- | Parser between parens, with the opening paren at the current position.
-    pParens0 :: Parser a -> Parser 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 -> Parser (WithCaseOutput care Name)
-pAlphaName0 bpos cs = do
-  (_, 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
-  (name, adjoin) <- case cs of
-    Uppercase
-      | isLower (head s) -> do
-          raise Error "Unexpected uppercase word at this position, assuming typo"
-          return (toUpper (head s) : tail s, id)
-      | otherwise -> return (s, id)
-    Lowercase
-      | isUpper (head s) -> do
-          raise 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, (Lowercase,))
-  guard (name `notElem` ["case", "class", "data", "default", "deriving", "do", "else"
-                        ,"foreign", "if", "import", "in", "infix", "infixl"
-                        ,"infixr", "instance", "let", "module", "newtype", "of"
-                        ,"then", "type", "where", "_"])
-  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 -> Parser (WithCaseOutput care Name)
-pSymbol0 bpos cs = do
-  case bpos of
-    AtLeft -> assertAtBlockLeft Fatal "Expected symbol, but found indented expression"
-    InBlock -> assertInsideBlock Fatal "Expected symbol, but found end of indented expression"
-  (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 <- many (satisfy isSymbolChar)
-  let name = c1 : crest
-  guard (name `notElem` ["..", ":", "::", "=", "\\", "|", "<-", "->", "@", "~", "=>"])
-  guard (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 :: Parser a -> Parser sep -> Parser [a]
-sepBy1 p psep = do
-  x1 <- p
-  (psep >> (x1 :) <$> sepBy1 p psep) <|> return [x1]
-
-sepBy :: Parser a -> Parser sep -> Parser [a]
-sepBy p psep = sepBy1 p psep <|> return []
-
--- | Start a new layout block at the current position. The old layout block is
--- restored after completion of this subparser.
-startLayoutBlock :: Parser a -> Parser a
-startLayoutBlock p = do
-  ps0 <- get
-  put (ps0 { psBlkLine = psLine ps0
-           , psBlkCol = psCol ps0 })
-  res <- p
-  modify (\ps -> ps { psBlkLine = psBlkLine ps0
-                    , psBlkCol = psBlkCol 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 an error with the given fatality and description.
-raise :: FatalCtx fatal a => Fatality fatal -> String -> Parser a
-raise fat msg = do
-  Context { ctxFile = fp , ctxStack = stk } <- ask
-  PS { psLine = line, psCol = col } <- get
-  let fun = case fat of
-              Error -> dictate . pure
-              Fatal -> confess . pure
-  fun (ErrMsg fp stk line col msg)
-
-raise' :: Fatality fatal -> String -> Parser ()
-raise' Error = raise Error
-raise' Fatal = raise Fatal
-
--- | Registers a scope description on the stack for error reporting.
-pushContext :: String -> Parser a -> Parser a
-pushContext descr = local (\c -> c { ctxStack = descr : ctxStack c })
-
-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 -> Parser (r, String)
-readToken bpos f s0 = do
-  case bpos of
-    AtLeft -> assertAtBlockLeft Fatal "Expected token, but found indented expression"
-    InBlock -> assertInsideBlock Fatal "Expected token, but found end of indented expression"
-  let loop :: (s -> Maybe Char -> Maybe (Either r s)) -> s -> Parser (r, String)
-      loop f' st = do
-        ps <- get
-        case psRest ps of
-          []       | Just (Left res) <- f' st Nothing     -> return (res, "")
-                   | otherwise -> empty
-          '\n' : _ | Just (Left res) <- f' st (Just '\n') -> return (res, "")
-          c : cs -> case f' st (Just c) of
-                      Nothing -> empty
-                      Just (Left res) -> return (res, "")
-                      Just (Right st') -> do
-                          put (ps { psCol = psCol ps + 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, this fails.
-inlineWhite :: Parser ()
-inlineWhite = do
-  skipWhiteComment
-  whenM (not <$> isInsideBlock) empty
-
--- | Consumes all whitespace and comments (including newlines). Note: this may
--- end outside the current block.
-skipWhiteComment :: Parser ()
-skipWhiteComment = do
-  inlineSpaces
-  _ <- many (blockComment >> inlineSpaces)
-  optional_ lineComment
-  optional_ (consumeNewline >> skipWhiteComment)
-  where
-    -- | Consumes some inline whitespace. Stops before newlines.
-    inlineSpaces :: Parser ()
-    inlineSpaces = readWhileInline isSpace
-
--- | Consumes an delimited comment including both end markers. Note: this may
--- end outside the current block.
-blockComment :: Parser ()
-blockComment = do
-  string "{-"  -- no need for pKeySym here
-  let loop = do
-        readWhileInline (`notElem` "{-")  -- "-}" also starts with '-'
-        asum [string "-}"
-             ,eof >> raise Error "Unfinished {- -} comment at end of file"
-             ,blockComment >> loop
-             ,consumeNewline >> loop]
-  loop
-
--- | Consumes a line comment marker and the rest of the line, excluding
--- newline.
-lineComment :: Parser ()
-lineComment = do
-  -- '--!' is an operator, so we need to parse a whole symbol here.
-  pKeySym "--"
-  readWhileInline (const True)
-
--- | Raises an error if we're not currently at the given column.
-assertAtBlockLeft :: Fatality fatal -> String -> Parser ()
-assertAtBlockLeft fat msg = whenM (not <$> isAtBlockLeft) $ raise' fat msg
-
--- | Raises an error if psCol is not greater than psRefCol.
-assertInsideBlock :: Fatality fatal -> String -> Parser ()
-assertInsideBlock fat msg = whenM (not <$> isInsideBlock) $ raise' fat msg
-
--- | Raises an error if we're not currently at EOF.
-assertEOF :: Fatality fatal -> Parser ()
-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 :: Parser Bool
-isInsideBlock = do
-  ps <- get
-  return $ psLine ps >= psBlkLine ps && psCol ps > psBlkCol ps
-
--- | 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 :: Parser Bool
-isAtBlockLeft = do
-  ps <- get
-  return $ psLine ps >= psBlkLine ps && psCol ps == psBlkCol ps
-
--- | Consumes characters while the predicate holds or until (and excluding)
--- a newline, whichever comes first.
-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 })
-
--- | Consumes exactly one newline at the current position.
-consumeNewline :: Parser ()
-consumeNewline = gets psRest >>= \case
-  '\n' : rest -> modify (\ps -> ps { psLine = psLine ps + 1
-                                   , psCol = 0
-                                   , psRest = rest })
-  _ -> empty
-
--- | Consumes exactly one character, unequal to newline, at the current position.
-satisfy :: (Char -> Bool) -> Parser 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 -> ps { psCol = psCol ps + 1
-                          , psRest = rest })
-        return c
-    _ -> empty
-
--- | Consumes exactly this character at the current position. Must not be a
--- newline.
-char :: Char -> Parser ()
-char c = string [c]
-
--- | Consumes exactly this string at the current position. The string must not
--- contain a newline.
-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
-
-lookAhead :: Parser () -> Parser ()
-lookAhead p = do
-  ps <- get
-  success <- absolve False (True <$ p)
-  put ps  -- restore state, as if nothing happened
-  when (not success) empty
-
-notFollowedBy :: Parser () -> Parser ()
-notFollowedBy p = do
-  ps <- get
-  success <- absolve True (False <$ p)
-  put ps  -- restore state, as if nothing happened
-  when (not success) empty
-
--- | Only succeeds at EOF.
-eof :: Parser ()
-eof = gets psRest >>= \case [] -> return ()
-                            _ -> empty
-
-whenM :: (Monad m, Monoid a) => m Bool -> m a -> m a
-whenM mb mx = mb >>= \b -> if b then mx else return mempty
-
-optional_ :: Alternative f => f a -> f ()
-optional_ a = (() <$ a) <|> pure ()
-
-someNE :: Alternative f => f a -> f (NonEmpty a)
-someNE a = (:|) <$> a <*> many a