module Unison.Syntax.Lexer.Token
  ( Token (..),
    tokenP,
    posP,
  )
where

import Data.Text qualified as Text
import Text.Megaparsec (MonadParsec, TraversableStream)
import Text.Megaparsec qualified as P
import Unison.Lexer.Pos (Pos (Pos))
import Unison.Parser.Ann (Ann (Ann), Annotated (..))
import Unison.Prelude

data Token a = Token
  { forall a. Token a -> a
payload :: a,
    forall a. Token a -> Pos
start :: !Pos,
    forall a. Token a -> Pos
end :: !Pos
  }
  deriving stock (Token a -> Token a -> Bool
(Token a -> Token a -> Bool)
-> (Token a -> Token a -> Bool) -> Eq (Token a)
forall a. Eq a => Token a -> Token a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Token a -> Token a -> Bool
== :: Token a -> Token a -> Bool
$c/= :: forall a. Eq a => Token a -> Token a -> Bool
/= :: Token a -> Token a -> Bool
Eq, Eq (Token a)
Eq (Token a) =>
(Token a -> Token a -> Ordering)
-> (Token a -> Token a -> Bool)
-> (Token a -> Token a -> Bool)
-> (Token a -> Token a -> Bool)
-> (Token a -> Token a -> Bool)
-> (Token a -> Token a -> Token a)
-> (Token a -> Token a -> Token a)
-> Ord (Token a)
Token a -> Token a -> Bool
Token a -> Token a -> Ordering
Token a -> Token a -> Token a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Token a)
forall a. Ord a => Token a -> Token a -> Bool
forall a. Ord a => Token a -> Token a -> Ordering
forall a. Ord a => Token a -> Token a -> Token a
$ccompare :: forall a. Ord a => Token a -> Token a -> Ordering
compare :: Token a -> Token a -> Ordering
$c< :: forall a. Ord a => Token a -> Token a -> Bool
< :: Token a -> Token a -> Bool
$c<= :: forall a. Ord a => Token a -> Token a -> Bool
<= :: Token a -> Token a -> Bool
$c> :: forall a. Ord a => Token a -> Token a -> Bool
> :: Token a -> Token a -> Bool
$c>= :: forall a. Ord a => Token a -> Token a -> Bool
>= :: Token a -> Token a -> Bool
$cmax :: forall a. Ord a => Token a -> Token a -> Token a
max :: Token a -> Token a -> Token a
$cmin :: forall a. Ord a => Token a -> Token a -> Token a
min :: Token a -> Token a -> Token a
Ord, Int -> Token a -> ShowS
[Token a] -> ShowS
Token a -> String
(Int -> Token a -> ShowS)
-> (Token a -> String) -> ([Token a] -> ShowS) -> Show (Token a)
forall a. Show a => Int -> Token a -> ShowS
forall a. Show a => [Token a] -> ShowS
forall a. Show a => Token a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Token a -> ShowS
showsPrec :: Int -> Token a -> ShowS
$cshow :: forall a. Show a => Token a -> String
show :: Token a -> String
$cshowList :: forall a. Show a => [Token a] -> ShowS
showList :: [Token a] -> ShowS
Show, (forall a b. (a -> b) -> Token a -> Token b)
-> (forall a b. a -> Token b -> Token a) -> Functor Token
forall a b. a -> Token b -> Token a
forall a b. (a -> b) -> Token a -> Token b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Token a -> Token b
fmap :: forall a b. (a -> b) -> Token a -> Token b
$c<$ :: forall a b. a -> Token b -> Token a
<$ :: forall a b. a -> Token b -> Token a
Functor, (forall m. Monoid m => Token m -> m)
-> (forall m a. Monoid m => (a -> m) -> Token a -> m)
-> (forall m a. Monoid m => (a -> m) -> Token a -> m)
-> (forall a b. (a -> b -> b) -> b -> Token a -> b)
-> (forall a b. (a -> b -> b) -> b -> Token a -> b)
-> (forall b a. (b -> a -> b) -> b -> Token a -> b)
-> (forall b a. (b -> a -> b) -> b -> Token a -> b)
-> (forall a. (a -> a -> a) -> Token a -> a)
-> (forall a. (a -> a -> a) -> Token a -> a)
-> (forall a. Token a -> [a])
-> (forall a. Token a -> Bool)
-> (forall a. Token a -> Int)
-> (forall a. Eq a => a -> Token a -> Bool)
-> (forall a. Ord a => Token a -> a)
-> (forall a. Ord a => Token a -> a)
-> (forall a. Num a => Token a -> a)
-> (forall a. Num a => Token a -> a)
-> Foldable Token
forall a. Eq a => a -> Token a -> Bool
forall a. Num a => Token a -> a
forall a. Ord a => Token a -> a
forall m. Monoid m => Token m -> m
forall a. Token a -> Bool
forall a. Token a -> Int
forall a. Token a -> [a]
forall a. (a -> a -> a) -> Token a -> a
forall m a. Monoid m => (a -> m) -> Token a -> m
forall b a. (b -> a -> b) -> b -> Token a -> b
forall a b. (a -> b -> b) -> b -> Token a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Token m -> m
fold :: forall m. Monoid m => Token m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Token a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Token a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Token a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Token a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Token a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Token a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Token a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Token a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Token a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Token a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Token a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Token a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Token a -> a
foldr1 :: forall a. (a -> a -> a) -> Token a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Token a -> a
foldl1 :: forall a. (a -> a -> a) -> Token a -> a
$ctoList :: forall a. Token a -> [a]
toList :: forall a. Token a -> [a]
$cnull :: forall a. Token a -> Bool
null :: forall a. Token a -> Bool
$clength :: forall a. Token a -> Int
length :: forall a. Token a -> Int
$celem :: forall a. Eq a => a -> Token a -> Bool
elem :: forall a. Eq a => a -> Token a -> Bool
$cmaximum :: forall a. Ord a => Token a -> a
maximum :: forall a. Ord a => Token a -> a
$cminimum :: forall a. Ord a => Token a -> a
minimum :: forall a. Ord a => Token a -> a
$csum :: forall a. Num a => Token a -> a
sum :: forall a. Num a => Token a -> a
$cproduct :: forall a. Num a => Token a -> a
product :: forall a. Num a => Token a -> a
Foldable, Functor Token
Foldable Token
(Functor Token, Foldable Token) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Token a -> f (Token b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Token (f a) -> f (Token a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Token a -> m (Token b))
-> (forall (m :: * -> *) a. Monad m => Token (m a) -> m (Token a))
-> Traversable Token
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Token (m a) -> m (Token a)
forall (f :: * -> *) a. Applicative f => Token (f a) -> f (Token a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Token a -> m (Token b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Token a -> f (Token b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Token a -> f (Token b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Token a -> f (Token b)
$csequenceA :: forall (f :: * -> *) a. Applicative f => Token (f a) -> f (Token a)
sequenceA :: forall (f :: * -> *) a. Applicative f => Token (f a) -> f (Token a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Token a -> m (Token b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Token a -> m (Token b)
$csequence :: forall (m :: * -> *) a. Monad m => Token (m a) -> m (Token a)
sequence :: forall (m :: * -> *) a. Monad m => Token (m a) -> m (Token a)
Traversable)

instance Annotated (Token a) where
  ann :: Token a -> Ann
ann (Token a
_ Pos
s Pos
e) = Pos -> Pos -> Ann
Ann Pos
s Pos
e

instance Applicative Token where
  pure :: forall a. a -> Token a
pure a
a = a -> Pos -> Pos -> Token a
forall a. a -> Pos -> Pos -> Token a
Token a
a (Int -> Int -> Pos
Pos Int
0 Int
0) (Int -> Int -> Pos
Pos Int
0 Int
0)
  Token a -> b
f Pos
start Pos
_ <*> :: forall a b. Token (a -> b) -> Token a -> Token b
<*> Token a
a Pos
_ Pos
end = b -> Pos -> Pos -> Token b
forall a. a -> Pos -> Pos -> Token a
Token (a -> b
f a
a) Pos
start Pos
end

-- This instance is odd, but useful.
--
-- The lexer prefers to throw custom errors as `Token Err`. It also calls out to other parsers (like the name segment
-- parser) that don't know about `Err`, but throw custom errors as `Token Something` for the lexer to inject into
-- `Token Err`.
--
-- ...then there are yet more callers of these other parsers that don't want an annoying `Token Something`, they just
-- want a simple string error message.
--
-- So, the flow aided by this instance is roughly:
--
--   1. Run some parser, using `withParsecT` as necessary to unify the potentially-different `Token Something` errors
--      as a `Token Text`.
--   2. `prettyErrorBundle` that thing.
instance P.ShowErrorComponent (Token Text) where
  showErrorComponent :: Token Text -> String
showErrorComponent = Text -> String
Text.unpack (Text -> String) -> (Token Text -> Text) -> Token Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token Text -> Text
forall a. Token a -> a
payload

tokenP :: (Ord e, TraversableStream s, MonadParsec e s m) => m a -> m (Token a)
tokenP :: forall e s (m :: * -> *) a.
(Ord e, TraversableStream s, MonadParsec e s m) =>
m a -> m (Token a)
tokenP m a
p = do
  Pos
start <- m Pos
forall e s (m :: * -> *).
(Ord e, TraversableStream s, MonadParsec e s m) =>
m Pos
posP
  a
payload <- m a
p
  Pos
end <- m Pos
forall e s (m :: * -> *).
(Ord e, TraversableStream s, MonadParsec e s m) =>
m Pos
posP
  pure Token {a
$sel:payload:Token :: a
payload :: a
payload, Pos
$sel:start:Token :: Pos
start :: Pos
start, Pos
$sel:end:Token :: Pos
end :: Pos
end}

posP :: (Ord e, TraversableStream s, MonadParsec e s m) => m Pos
posP :: forall e s (m :: * -> *).
(Ord e, TraversableStream s, MonadParsec e s m) =>
m Pos
posP = do
  SourcePos
p <- m SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
P.getSourcePos
  pure (Int -> Int -> Pos
Pos (Pos -> Int
P.unPos (SourcePos -> Pos
P.sourceLine SourcePos
p)) (Pos -> Int
P.unPos (SourcePos -> Pos
P.sourceColumn SourcePos
p)))