{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}
-- |

module Duet.Parser where

import           Control.Monad
import           Control.Monad.Catch
import           Control.Monad.IO.Class
import           Data.List
import qualified Data.Map.Strict as M
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import           Duet.Printer
import           Duet.Tokenizer
import           Duet.Types
import           Text.Parsec hiding (satisfy, anyToken)

parseFile :: (MonadIO m, MonadThrow m) => FilePath -> m [Decl UnkindedType Identifier Location]
parseFile fp = do
  t <- liftIO (T.readFile fp)
  parseText fp t

parseText :: MonadThrow m => SourceName -> Text -> m [Decl UnkindedType Identifier Location]
parseText fp inp =
  case parse tokensTokenizer fp (inp) of
    Left e -> throwM (TokenizerError e)
    Right tokens' ->
      case runParser tokensParser 0 fp tokens' of
        Left e -> throwM (ParserError e)
        Right ast -> pure ast

parseTextWith
  :: (Num u, MonadThrow m)
  => Parsec [(Token, Location)] u a -> SourceName -> Text -> m a
parseTextWith p fp inp =
  case parse tokensTokenizer fp (inp) of
    Left e -> throwM (TokenizerError e)
    Right tokens' ->
      case runParser p 0 fp tokens' of
        Left e -> throwM (ParserError e)
        Right ast -> pure ast

parseType' :: Num u => SourceName -> Parsec [(Token, Location)] u b -> Text -> Either ParseError b
parseType' fp p inp =
  case parse tokensTokenizer fp (inp) of
    Left e -> Left e
    Right tokens' ->
      case runParser p 0 fp tokens' of
        Left e -> Left e
        Right ast -> Right ast

tokensParser :: TokenParser [Decl UnkindedType Identifier Location]
tokensParser = moduleParser <* endOfTokens

moduleParser :: TokenParser [Decl UnkindedType Identifier Location]
moduleParser =
  many
    (varfundeclExplicit <|> fmap (uncurry DataDecl) datadecl <|>
     fmap (uncurry ClassDecl) classdecl <|>
     fmap (uncurry InstanceDecl) instancedecl)

classdecl :: TokenParser (Location, Class UnkindedType Identifier Location)
classdecl =
  go <?> "class declaration (e.g. class Show a where show a :: a -> String)"
  where
    go = do
      u <- getState
      loc <- equalToken ClassToken
      setState (locationStartColumn loc)
      (c, _) <-
        consumeToken
          (\case
             Constructor c -> Just c
             _ -> Nothing) <?>
        "new class name e.g. Show"
      vars <- many1 kindableTypeVariable
      mwhere <-
        fmap (const True) (equalToken Where) <|> fmap (const False) endOfDecl
      methods <-
        if mwhere
          then do
            (_, identLoc) <-
              lookAhead
                (consumeToken
                   (\case
                      Variable i -> Just i
                      _ -> Nothing)) <?>
              "class methods e.g. foo :: a -> Int"
            (many1 (methodParser (locationStartColumn identLoc))) <* endOfDecl
          else (pure [])
      setState u
      _ <- (pure () <* satisfyToken (== NonIndentedNewline)) <|> endOfTokens
      pure
        ( loc
        , Class
          { className = Identifier (T.unpack c)
          , classTypeVariables = vars
          , classSuperclasses = []
          , classInstances = []
          , classMethods = M.fromList methods
          })
      where
        endOfDecl =
          (pure () <* satisfyToken (== NonIndentedNewline)) <|> endOfTokens
        methodParser startCol = go' <?> "method signature e.g. foo :: a -> Y"
          where
            go' = do
              u <- getState
              (v, p) <-
                consumeToken
                  (\case
                     Variable i -> Just i
                     _ -> Nothing)
              when
                (locationStartColumn p /= startCol)
                (unexpected
                   ("method name at column " ++
                    show (locationStartColumn p) ++
                    ", it should start at column " ++
                    show startCol ++ " to match the others"))
              setState startCol
              _ <- equalToken Colons <?> "‘::’ for method signature"
              scheme <- parseScheme <?> "method type signature e.g. foo :: Int"
              setState u
              pure (Identifier (T.unpack v), scheme)

kindableTypeVariable :: Stream s m (Token, Location) => ParsecT s Int m (TypeVariable Identifier)
kindableTypeVariable = (unkinded <|> kinded) <?> "type variable (e.g. ‘a’, ‘f’, etc.)"
  where
    kinded =
      kparens
        (do t <- unkinded
            _ <- equalToken Colons
            k <- kindParser
            pure (TypeVariable (typeVariableIdentifier t) k))
      where
        kparens :: TokenParser a -> TokenParser a
        kparens p = g <?> "parens e.g. (x)"
          where
            g = do
              _ <- equalToken OpenParen
              e <-
                p <?> "type with kind inside parentheses e.g. (t :: Type)"
              _ <- equalToken CloseParen <?> "closing parenthesis ‘)’"
              pure e
    unkinded = do
      (v, _) <-
        consumeToken
          (\case
             Variable i -> Just i
             _ -> Nothing) <?>
        "variable name"
      pure (TypeVariable (Identifier (T.unpack v)) StarKind)

parseScheme
  :: Stream s m (Token, Location)
  => ParsecT s Int m (Scheme UnkindedType Identifier UnkindedType)
parseScheme = do
  explicit <-
    fmap (const True) (lookAhead (equalToken ForallToken)) <|> pure False
  if explicit
    then quantified
    else do
      ty@(Qualified _ qt) <- parseQualified
      pure (Forall (nub (collectTypeVariables qt)) ty)
  where
    quantified = do
      _ <- equalToken ForallToken
      vars <- many1 kindableTypeVariable <?> "type variables"
      _ <- equalToken Period
      ty <- parseQualified
      pure (Forall vars ty)

parseSchemePredicate
  :: Stream s m (Token, Location)
  => ParsecT s Int m (Scheme UnkindedType Identifier (Predicate UnkindedType))
parseSchemePredicate = do
  explicit <-
    fmap (const True) (lookAhead (equalToken ForallToken)) <|> pure False
  if explicit
    then quantified
    else do
      ty@(Qualified _ (IsIn _ qt)) <- parseQualifiedPredicate
      pure (Forall (nub (concatMap collectTypeVariables qt)) ty)
  where
    quantified = do
      _ <- equalToken ForallToken
      vars <- many1 kindableTypeVariable <?> "type variables"
      _ <- equalToken Period
      ty <- parseQualifiedPredicate
      pure (Forall vars ty)

parseQualified
  :: Stream s m (Token, Location)
  => ParsecT s Int m (Qualified UnkindedType Identifier (UnkindedType Identifier))
parseQualified = do
  ty <- parsedTypeLike
  (case ty of
     ParsedQualified ps x -> Qualified <$> mapM toUnkindedPred ps <*> toType x
       where toUnkindedPred (IsIn c ts) = IsIn c <$> mapM toType ts
     _ -> do
       t <- toType ty
       pure (Qualified [] t)) <?>
    "qualified type e.g. Show x => x"

parseQualifiedPredicate
  :: Stream s m (Token, Location)
  => ParsecT s Int m (Qualified UnkindedType Identifier (Predicate UnkindedType Identifier))
parseQualifiedPredicate = do
  ty <- parsedTypeLike
  (case ty of
     ParsedQualified ps x -> Qualified <$> mapM toUnkindedPred ps <*> toPredicateUnkinded x
       where toUnkindedPred (IsIn c ts) = IsIn c <$> mapM toType ts
     _ -> do
       t <- toPredicateUnkinded ty
       pure (Qualified [] t)) <?>
    "qualified type e.g. Show x => x"

collectTypeVariables :: UnkindedType i -> [TypeVariable i]
collectTypeVariables =
  \case
     UnkindedTypeConstructor {} -> []
     UnkindedTypeVariable i -> [TypeVariable i StarKind]
     UnkindedTypeApp f x -> collectTypeVariables f ++ collectTypeVariables x

instancedecl :: TokenParser (Location, Instance UnkindedType Identifier Location)
instancedecl =
  go <?> "instance declaration (e.g. instance Show Int where show = ...)"
  where
    go = do
      u <- getState
      loc <- equalToken InstanceToken
      setState (locationStartColumn loc)
      predicate@(Forall _ (Qualified _ (IsIn (Identifier c) _))) <-
        parseSchemePredicate
      mwhere <-
        fmap (const True) (equalToken Where) <|> fmap (const False) endOfDecl
      methods <-
        if mwhere
          then do
            (_, identLoc) <-
              lookAhead
                (consumeToken
                   (\case
                      Variable i -> Just i
                      _ -> Nothing)) <?>
              "instance methods e.g. foo :: a -> Int"
            (many1 (methodParser (locationStartColumn identLoc))) <* endOfDecl
          else (pure [])
      setState u
      _ <- (pure () <* satisfyToken (== NonIndentedNewline)) <|> endOfTokens
      let dictName = "$dict" ++ c
      pure
        ( loc
        , Instance
          { instancePredicate = predicate
          , instanceDictionary =
              Dictionary (Identifier dictName) (M.fromList methods)
          })
      where
        endOfDecl =
          (pure () <* satisfyToken (== NonIndentedNewline)) <|> endOfTokens
        methodParser startCol =
          go' <?> "method implementation e.g. foo = \\x -> f x"
          where
            go' = do
              u <- getState
              (v, p) <-
                consumeToken
                  (\case
                     Variable i -> Just i
                     _ -> Nothing)
              when
                (locationStartColumn p /= startCol)
                (unexpected
                   ("method name at column " ++
                    show (locationStartColumn p) ++
                    ", it should start at column " ++
                    show startCol ++ " to match the others"))
              setState startCol
              _ <- equalToken Equals <?> "‘=’ for method declaration e.g. x = 1"
              e <- expParser
              setState u
              pure (Identifier (T.unpack v), (p, makeAlt (expressionLabel e) e))

parseType :: Stream s m (Token, Location) => ParsecT s Int m (UnkindedType Identifier)
parseType = do
  x <- parsedTypeLike
  toType x

toPredicateUnkinded :: Stream s m t => ParsedType i -> ParsecT s u m (Predicate UnkindedType i)
toPredicateUnkinded = toPredicate >=> go
  where go (IsIn c tys) = IsIn c <$> mapM toType tys

toType :: Stream s m t => ParsedType i -> ParsecT s u m (UnkindedType i)
toType = go
  where
    go =
      \case
        ParsedTypeConstructor i -> pure (UnkindedTypeConstructor i)
        ParsedTypeVariable i -> pure (UnkindedTypeVariable i)
        ParsedTypeApp t1 t2 -> UnkindedTypeApp <$> go t1 <*> go t2
        ParsedQualified {} -> unexpected "qualification context"
        ParsedTuple {} -> unexpected "tuple"

datadecl :: TokenParser (Location, DataType UnkindedType Identifier)
datadecl = go <?> "data declaration (e.g. data Maybe a = Just a | Nothing)"
  where
    go = do
      loc <- equalToken Data
      (v, _) <-
        consumeToken
          (\case
             Constructor i -> Just i
             _ -> Nothing) <?>
        "new type name (e.g. Foo)"
      vs <- many kindableTypeVariable
      _ <- equalToken Equals
      cs <- sepBy1 consp (equalToken Bar)
      _ <- (pure () <* satisfyToken (== NonIndentedNewline)) <|> endOfTokens
      pure (loc, DataType (Identifier (T.unpack v)) vs cs)

kindParser :: Stream s m (Token, Location) => ParsecT s Int m Kind
kindParser = infix'
  where
    infix' = do
      left <- star
      tok <-
        fmap Just (operator <?> ("arrow " ++ curlyQuotes "->")) <|> pure Nothing
      case tok of
        Just (RightArrow, _) -> do
          right <-
            kindParser <?>
            ("right-hand side of function arrow " ++ curlyQuotes "->")
          pure (FunctionKind left right)
        _ -> pure left
      where
        operator =
          satisfyToken
            (\case
               RightArrow {} -> True
               _ -> False)
    star = do
      (c, _) <-
        consumeToken
          (\case
             Constructor c
               | c == "Type" -> Just StarKind
             _ -> Nothing)
      pure c

consp :: TokenParser (DataTypeConstructor UnkindedType Identifier)
consp = do c <- consParser
           slots <- many slot
           pure (DataTypeConstructor c slots)
  where consParser = go <?> "value constructor (e.g. Just)"
          where
            go = do
              (c, _) <-
                consumeToken
                  (\case
                     Constructor c -> Just c
                     _ -> Nothing)
              pure
                (Identifier (T.unpack c))

slot :: TokenParser (UnkindedType Identifier)
slot = consParser <|> variableParser <|> parens parseType
  where
    variableParser = go <?> "type variable (e.g. ‘a’, ‘s’, etc.)"
      where
        go = do
          (v, _) <-
            consumeToken
              (\case
                 Variable i -> Just i
                 _ -> Nothing)
          pure (UnkindedTypeVariable (Identifier (T.unpack v)))
    consParser = go <?> "type constructor (e.g. Maybe)"
      where
        go = do
          (c, _) <-
            consumeToken
              (\case
                 Constructor c -> Just c
                 _ -> Nothing)
          pure (UnkindedTypeConstructor (Identifier (T.unpack c)))

data ParsedType i
  = ParsedTypeConstructor i
  | ParsedTypeVariable i
  | ParsedTypeApp (ParsedType i) (ParsedType i)
  | ParsedQualified [Predicate ParsedType i] (ParsedType i)
  | ParsedTuple [ParsedType i]
  deriving (Show)

parsedTypeLike :: TokenParser (ParsedType Identifier)
parsedTypeLike = infix' <|> app <|> unambiguous
  where
    infix' = do
      left <- (app <|> unambiguous) <?> "left-hand side of function arrow"
      tok <-
        fmap Just (operator <?> ("function arrow " ++ curlyQuotes "->")) <|>
        fmap Just (operator2 <?> ("constraint arrow " ++ curlyQuotes "=>")) <|>
        pure Nothing
      case tok of
        Just (RightArrow, _) -> do
          right <-
            parsedTypeLike <?>
            ("right-hand side of function arrow " ++ curlyQuotes "->")
          pure
            (ParsedTypeApp
               (ParsedTypeApp (ParsedTypeConstructor (Identifier "(->)")) left)
               right)
        Just (Imply, _) -> do
          left' <- parsedTypeToPredicates left <?> "constraints e.g. Show a or (Read a, Show a)"
          right <-
            parsedTypeLike <?>
            ("right-hand side of constraints " ++ curlyQuotes "=>")
          pure (ParsedQualified left' right)
        _ -> pure left
      where
        operator =
          satisfyToken
            (\case
               RightArrow {} -> True
               _ -> False)
        operator2 =
          satisfyToken
            (\case
               Imply {} -> True
               _ -> False)
    app = do
      f <- unambiguous
      args <- many unambiguous
      pure (foldl' ParsedTypeApp f args)
    unambiguous =
      atomicType <|>
      parensTy
        (do xs <- sepBy1 parsedTypeLike (equalToken Comma)
            case xs of
              [x] -> pure x
              _ -> pure (ParsedTuple xs))
    atomicType = consParse <|> varParse
    consParse = do
      (v, _) <-
        consumeToken
          (\case
             Constructor i -> Just i
             _ -> Nothing) <?>
        "type constructor (e.g. Int, Maybe)"
      pure (ParsedTypeConstructor (Identifier (T.unpack v)))
    varParse = do
      (v, _) <-
        consumeToken
          (\case
             Variable i -> Just i
             _ -> Nothing) <?>
        "type variable (e.g. a, f)"
      pure (ParsedTypeVariable (Identifier (T.unpack v)))
    parensTy p = go <?> "parentheses e.g. (T a)"
      where
        go = do
          _ <- equalToken OpenParen
          e <- p <?> "type inside parentheses e.g. (Maybe a)"
          _ <- equalToken CloseParen <?> "closing parenthesis ‘)’"
          pure e

parsedTypeToPredicates :: Stream s m t => ParsedType i -> ParsecT s u m [Predicate ParsedType i]
parsedTypeToPredicates =
  \case
    ParsedTuple xs -> mapM toPredicate xs
    x -> fmap return (toPredicate x)

toPredicate :: Stream s m t => ParsedType i -> ParsecT s u m (Predicate ParsedType i)
toPredicate t =
  case targs t of
    (ParsedTypeConstructor i, vars@ (_:_)) -> do
      pure (IsIn i vars)
    _ -> unexpected "non-class constraint"

toVar :: Stream s m t1 => ParsedType t -> ParsecT s u m (ParsedType t)
toVar =
  \case
    v@ParsedTypeVariable {} -> pure v
    _ -> unexpected "non-type-variable"

targs :: ParsedType t -> (ParsedType t, [ParsedType t])
targs e = go e []
  where
    go (ParsedTypeApp f x) args = go f (x : args)
    go f args = (f, args)

varfundecl :: TokenParser (ImplicitlyTypedBinding UnkindedType Identifier Location)
varfundecl = go <?> "variable declaration (e.g. x = 1, f = \\x -> x * x)"
  where
    go = do
      (v, loc) <-
         consumeToken
           (\case
              Variable i -> Just i
              _ -> Nothing) <?>
         "variable name"
      _ <- equalToken Equals <?> "‘=’ for variable declaration e.g. x = 1"
      e <- expParser
      _ <- (pure () <* satisfyToken (==NonIndentedNewline)) <|> endOfTokens
      pure (ImplicitlyTypedBinding loc (Identifier (T.unpack v), loc) [makeAlt loc e])

varfundeclExplicit :: TokenParser (Decl UnkindedType Identifier Location)
varfundeclExplicit =
  go <?> "explicitly typed variable declaration (e.g. x :: Int and x = 1)"
  where
    go = do
      (v0, loc) <-
        consumeToken
          (\case
             Variable i -> Just i
             _ -> Nothing) <?>
        "variable name"
      (tok, _) <- anyToken <?> curlyQuotes "::" ++ " or " ++ curlyQuotes "="
      case tok of
        Colons -> do
          scheme <- parseScheme <?> "type signature e.g. foo :: Int"
          _ <- (pure () <* satisfyToken (== NonIndentedNewline)) <|> endOfTokens
          (v, _) <-
            consumeToken
              (\case
                 Variable i -> Just i
                 _ -> Nothing) <?>
            "variable name"
          when
            (v /= v0)
            (unexpected "variable binding name different to the type signature")
          _ <- equalToken Equals <?> "‘=’ for variable declaration e.g. x = 1"
          e <- expParser
          _ <- (pure () <* satisfyToken (== NonIndentedNewline)) <|> endOfTokens
          pure
            (BindDecl
               loc
               (ExplicitBinding
                  (ExplicitlyTypedBinding loc
                     (Identifier (T.unpack v), loc)
                     scheme
                     [makeAlt loc e])))
        Equals -> do
          e <- expParser
          _ <- (pure () <* satisfyToken (== NonIndentedNewline)) <|> endOfTokens
          pure
            (BindDecl
               loc
               (ImplicitBinding
                  (ImplicitlyTypedBinding
                     loc
                     (Identifier (T.unpack v0), loc)
                     [makeAlt loc e])))
        t -> unexpected (tokenStr t)


makeAlt :: l -> Expression t i l -> Alternative t i l
makeAlt loc e =
  case e of
    LambdaExpression _ alt -> alt
    _ -> Alternative loc [] e

case' :: TokenParser (Expression UnkindedType Identifier Location)
case' = do
  u <- getState
  loc <- equalToken Case
  setState (locationStartColumn loc)
  e <- expParser <?> "expression to do case analysis e.g. case e of ..."
  _ <- equalToken Of
  p <- lookAhead altPat <?> "case pattern"
  alts <- many (altParser (Just e) (locationStartColumn (patternLabel p)))
  setState u
  pure (CaseExpression loc e alts)

altsParser
  :: Stream s m (Token, Location)
  => ParsecT s Int m [(CaseAlt UnkindedType Identifier Location)]
altsParser = many (altParser Nothing 1)

altParser
  :: Maybe (Expression UnkindedType Identifier Location)
  -> Int
  -> TokenParser (CaseAlt UnkindedType Identifier Location)
altParser e' startCol =
  (do u <- getState
      p <- altPat
      when
        (locationStartColumn (patternLabel p) /= startCol)
        (unexpected
           ("pattern at column " ++
            show (locationStartColumn (patternLabel p)) ++
            ", it should start at column " ++
            show startCol ++ " to match the others"))
      setState startCol
      _ <- equalToken RightArrow
      e <- expParser
      setState u
      pure (CaseAlt (Location 0 0 0 0) p e)) <?>
  ("case alternative" ++
   (case e' of
      Just eeee ->
        " e.g.\n\ncase " ++
        printExpression defaultPrint eeee ++
        " of\n  Just bar -> bar"
      Nothing -> ""))

altPat :: TokenParser (Pattern UnkindedType Identifier Location)
altPat = bang <|> varp <|> intliteral <|> consParser <|> stringlit
  where
    bang =
      (BangPattern <$>
       (consumeToken
          (\case
             Bang -> Just Bang
             _ -> Nothing) *>
        patInner)) <?> "bang pattern"
    patInner = parenpat <|> varp <|> intliteral <|> unaryConstructor
    parenpat = go
      where
        go = do
          _ <- equalToken OpenParen
          e <- varp <|> altPat
          _ <- equalToken CloseParen <?> "closing parenthesis ‘)’"
          pure e
    intliteral = go <?> "integer (e.g. 42, 123)"
      where
        go = do
          (c, loc) <-
            consumeToken
              (\case
                 Integer c -> Just c
                 _ -> Nothing)
          pure (LiteralPattern loc (IntegerLiteral c))
    stringlit = go <?> "string (e.g. 42, 123)"
      where
        go = do
          (c, loc) <-
            consumeToken
              (\case
                 String c -> Just c
                 _ -> Nothing)
          pure (LiteralPattern loc (StringLiteral (T.unpack c)))
    varp = go <?> "variable pattern (e.g. x)"
      where
        go = do
          (v, loc) <-
            consumeToken
              (\case
                 Variable i -> Just i
                 _ -> Nothing)
          pure
            (if T.isPrefixOf "_" v
               then WildcardPattern loc (T.unpack v)
               else VariablePattern loc (Identifier (T.unpack v)))
    unaryConstructor = go <?> "unary constructor (e.g. Nothing)"
      where
        go = do
          (c, loc) <-
            consumeToken
              (\case
                 Constructor c -> Just c
                 _ -> Nothing)
          pure (ConstructorPattern loc (Identifier (T.unpack c)) [])
    consParser = go <?> "constructor pattern (e.g. Just x)"
      where
        go = do
          (c, loc) <-
            consumeToken
              (\case
                 Constructor c -> Just c
                 _ -> Nothing)
          args <- many patInner
          pure (ConstructorPattern loc (Identifier (T.unpack c)) args)

expParser :: TokenParser (Expression UnkindedType Identifier Location)
expParser = case' <|> lambda <|> ifParser <|> infix' <|> app <|> atomic
  where
    app = do
      left <- funcOp <?> "function expression"
      right <- many unambiguous <?> "function arguments"
      case right of
        [] -> pure left
        _ -> pure (foldl (ApplicationExpression (Location 0 0 0 0)) left right)
    infix' =
      (do left <- (app <|> unambiguous) <?> "left-hand side of operator"
          tok <- fmap Just (operator <?> "infix operator") <|> pure Nothing
          case tok of
            Just (Operator t, _) -> do
              right <-
                (app <|> unambiguous) <?>
                ("right-hand side of " ++
                 curlyQuotes (T.unpack t) ++ " operator")
              badop <- fmap Just (lookAhead operator) <|> pure Nothing
              let infixexp =
                    InfixExpression
                      (Location 0 0 0 0)
                      left
                      (let i = ((T.unpack t))
                       in (i, VariableExpression (Location 0 0 0 0) (Identifier i)))
                      right
              maybe
                (return ())
                (\op ->
                   unexpected
                     (concat
                        [ tokenString op ++
                          ". When more than one operator is used\n"
                        , "in the same expression, use parentheses, like this:\n"
                        , "(" ++
                          printExpression defaultPrint infixexp ++
                          ") " ++
                          (case op of
                             (Operator i, _) -> T.unpack i ++ " ..."
                             _ -> "* ...") ++
                          "\n"
                        , "Or like this:\n"
                        , printExpressionAppArg defaultPrint left ++
                          " " ++
                          T.unpack t ++
                          " (" ++
                          printExpressionAppArg defaultPrint right ++
                          " " ++
                          case op of
                            (Operator i, _) -> T.unpack i ++ " ...)"
                            _ -> "* ...)"
                        ]))
                badop
              pure infixexp
            _ -> pure left) <?>
      "infix expression (e.g. x * y)"
      where
        operator =
          satisfyToken
            (\case
               Operator {} -> True
               _ -> False)
    funcOp = varParser <|> constructorParser <|> parensExpr
    unambiguous = parensExpr <|> atomic
    parensExpr = parens expParser

operatorParser
  :: Stream s m (Token, Location)
  => ParsecT s Int m (String, Expression t Identifier Location)
operatorParser = do
  tok <-
    satisfyToken
      (\case
         Operator {} -> True
         _ -> False)
  pure
    (case tok of
       (Operator t, _) ->
         let i = (T.unpack t)
         in (i, VariableExpression (Location 0 0 0 0) (Identifier i))
       _ -> error "should be operator...")

lambda :: TokenParser (Expression UnkindedType Identifier Location)
lambda = do
  loc <- equalToken Backslash <?> "lambda expression (e.g. \\x -> x)"
  args <- many1 funcParam <?> "lambda parameters"
  _ <- equalToken RightArrow
  e <- expParser
  pure (LambdaExpression loc (Alternative loc args e))

funcParams :: TokenParser [Pattern UnkindedType Identifier Location]
funcParams = many1 funcParam

funcParam :: TokenParser (Pattern UnkindedType Identifier Location)
funcParam = go <?> "function parameter (e.g. ‘x’, ‘limit’, etc.)"
  where
    go = do
      (v, loc) <-
        consumeToken
          (\case
             Variable i -> Just i
             _ -> Nothing)
      pure (VariablePattern loc (Identifier (T.unpack v)))

atomic :: TokenParser (Expression UnkindedType Identifier Location)
atomic =
  varParser <|> charParser <|> stringParser <|> integerParser <|> decimalParser <|>
  constructorParser
  where
    charParser = go <?> "character (e.g. 'a')"
      where
        go = do
          (c, loc) <-
            consumeToken
              (\case
                 Character c -> Just c
                 _ -> Nothing)
          pure (LiteralExpression loc (CharacterLiteral c))
    stringParser = go <?> "string (e.g. \"a\")"
      where
        go = do
          (c, loc) <-
            consumeToken
              (\case
                 String c -> Just c
                 _ -> Nothing)
          pure (LiteralExpression loc (StringLiteral (T.unpack c)))

    integerParser = go <?> "integer (e.g. 42, 123)"
      where
        go = do
          (c, loc) <-
            consumeToken
              (\case
                 Integer c -> Just c
                 _ -> Nothing)
          pure (LiteralExpression loc (IntegerLiteral c))
    decimalParser = go <?> "decimal (e.g. 42, 123)"
      where
        go = do
          (c, loc) <-
            consumeToken
              (\case
                 Decimal c -> Just c
                 _ -> Nothing)
          pure (LiteralExpression loc (RationalLiteral (realToFrac c)))

constructorParser :: TokenParser (Expression UnkindedType Identifier Location)
constructorParser = go <?> "constructor (e.g. Just)"
  where
    go = do
      (c, loc) <-
        consumeToken
          (\case
             Constructor c -> Just c
             _ -> Nothing)
      pure
        (ConstructorExpression loc (Identifier (T.unpack c)))

parens :: TokenParser a -> TokenParser a
parens p = go <?> "parens e.g. (x)"
  where go = do
         _ <- equalToken OpenParen
         e <- p <?> "expression inside parentheses e.g. (foo)"
         _ <- equalToken CloseParen<?> "closing parenthesis ‘)’"
         pure e

varParser :: TokenParser (Expression UnkindedType Identifier Location)
varParser = go <?> "variable (e.g. ‘foo’, ‘id’, etc.)"
  where
    go = do
      (v, loc) <-
        consumeToken
          (\case
             Variable i -> Just i
             _ -> Nothing)
      pure (if T.isPrefixOf "_" v
               then ConstantExpression loc (Identifier (T.unpack v))
               else VariableExpression loc (Identifier (T.unpack v)))

ifParser :: TokenParser (Expression UnkindedType Identifier Location)
ifParser = go <?> "if expression (e.g. ‘if p then x else y’)"
  where
    go = do
      loc <- equalToken If
      p <- expParser <?> "condition expresion of if-expression"
      _ <- equalToken Then <?> "‘then’ keyword for if-expression"
      e1 <- expParser <?> "‘then’ clause of if-expression"
      _ <- equalToken Else <?> "‘else’ keyword for if-expression"
      e2 <- expParser <?> "‘else’ clause of if-expression"
      pure
        (IfExpression
           loc
           { locationEndLine = locationEndLine (expressionLocation loc e2)
           , locationEndColumn = locationEndColumn (expressionLocation loc e2)
           }
           p
           e1
           e2)
    expressionLocation nil e = foldr const nil e