-- | This currently contains a mix of general lexing utilities and identifier-y lexers.
module Unison.Syntax.Lexer
  ( Token (..),
    Line,
    Column,
    Pos (..),
    touches,

    -- * Character classifiers
    wordyIdChar,
    wordyIdStartChar,
    symbolyIdChar,

    -- * other utils
    local,
    space,
    lit,
    commitAfter2,
    (<+>),
    some',
    someTill',
    sepBy1',
    separated,
    wordySep,
    pop,
    typeOrAbilityAlt,
    inc,
  )
where

import Control.Monad.State qualified as S
import Data.Char (isSpace)
import Data.List.NonEmpty (NonEmpty ((:|)))
import Text.Megaparsec qualified as P
import Text.Megaparsec.Char qualified as CP
import Text.Megaparsec.Char.Lexer qualified as LP
import Unison.Lexer.Pos (Column, Line, Pos (Pos), column, line)
import Unison.Prelude
import Unison.Syntax.Lexer.Token (Token (..))
import Unison.Syntax.NameSegment (symbolyIdChar, wordyIdChar, wordyIdStartChar)
import Unison.Syntax.ReservedWords (typeOrAbility)

local :: (P.MonadParsec e s' m, S.MonadState s m) => (s -> s) -> m a -> m a
local :: forall e s' (m :: * -> *) s a.
(MonadParsec e s' m, MonadState s m) =>
(s -> s) -> m a -> m a
local s -> s
f m a
p = do
  s
env0 <- m s
forall s (m :: * -> *). MonadState s m => m s
S.get
  s -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (s -> s
f s
env0)
  Either (ParseError s' e) a
e <- m a -> m (Either (ParseError s' e) a)
forall a. m a -> m (Either (ParseError s' e) a)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> m (Either (ParseError s e) a)
P.observing m a
p
  s -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put s
env0
  case Either (ParseError s' e) a
e of
    Left ParseError s' e
e -> ParseError s' e -> m a
forall a. ParseError s' e -> m a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
ParseError s e -> m a
P.parseError ParseError s' e
e
    Right a
a -> a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

space :: (P.MonadParsec e String m) => m ()
space :: forall e (m :: * -> *). MonadParsec e String m => m ()
space =
  m () -> m () -> m () -> m ()
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
LP.space
    m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
CP.space1
    (m ()
fold m () -> m () -> m ()
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens String -> m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
LP.skipLineComment Tokens String
"--")
    (Tokens String -> Tokens String -> m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> Tokens s -> m ()
LP.skipBlockCommentNested Tokens String
"{-" Tokens String
"-}")
  where
    fold :: m ()
fold = m () -> m ()
forall a. m a -> m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"---" m String -> m (Tokens String) -> m (Tokens String)
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m (Tokens String)
forall e s (m :: * -> *). MonadParsec e s m => m (Tokens s)
P.takeRest m (Tokens String) -> m () -> m ()
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

lit :: (P.MonadParsec e String m) => String -> m String
lit :: forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit = m String -> m String
forall a. m a -> m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try (m String -> m String)
-> (String -> m String) -> String -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m () -> Tokens String -> m (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
LP.symbol (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

commitAfter2 :: (P.MonadParsec e s m) => m a -> m b -> (a -> b -> m c) -> m c
commitAfter2 :: forall e s (m :: * -> *) a b c.
MonadParsec e s m =>
m a -> m b -> (a -> b -> m c) -> m c
commitAfter2 m a
a m b
b a -> b -> m c
f = do
  (a
a, b
b) <- m (a, b) -> m (a, b)
forall a. m a -> m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try (m (a, b) -> m (a, b)) -> m (a, b) -> m (a, b)
forall a b. (a -> b) -> a -> b
$ (a -> b -> (a, b)) -> m a -> m b -> m (a, b)
forall a b c. (a -> b -> c) -> m a -> m b -> m c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) m a
a m b
b
  a -> b -> m c
f a
a b
b

infixl 2 <+>

(<+>) :: (Applicative f, Monoid a) => f a -> f a -> f a
<+> :: forall (f :: * -> *) a.
(Applicative f, Monoid a) =>
f a -> f a -> f a
(<+>) = (a -> a -> a) -> f a -> f a -> f a
forall a b c. (a -> b -> c) -> f a -> f b -> f c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)

-- | Like `P.some`, but returns an actual `NonEmpty`.
some' :: (P.MonadParsec e s m) => m a -> m (NonEmpty a)
some' :: forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> m (NonEmpty a)
some' m a
p = (a -> [a] -> NonEmpty a) -> m a -> m [a] -> m (NonEmpty a)
forall a b c. (a -> b -> c) -> m a -> m b -> m c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
(:|) m a
p (m [a] -> m (NonEmpty a)) -> m [a] -> m (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ m a -> m [a]
forall a. m a -> m [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many m a
p

-- | Like `P.someTill`, but returns an actual `NonEmpty`.
someTill' :: (P.MonadParsec e s m) => m a -> m end -> m (NonEmpty a)
someTill' :: forall e s (m :: * -> *) a end.
MonadParsec e s m =>
m a -> m end -> m (NonEmpty a)
someTill' m a
p m end
end = (a -> [a] -> NonEmpty a) -> m a -> m [a] -> m (NonEmpty a)
forall a b c. (a -> b -> c) -> m a -> m b -> m c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
(:|) m a
p (m [a] -> m (NonEmpty a)) -> m [a] -> m (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ m a -> m end -> m [a]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
P.manyTill m a
p m end
end

-- | Like `P.sepBy1`, but returns an actual `NonEmpty`.
sepBy1' :: (P.MonadParsec e s m) => m a -> m sep -> m (NonEmpty a)
sepBy1' :: forall e s (m :: * -> *) a end.
MonadParsec e s m =>
m a -> m end -> m (NonEmpty a)
sepBy1' m a
p m sep
sep = (a -> [a] -> NonEmpty a) -> m a -> m [a] -> m (NonEmpty a)
forall a b c. (a -> b -> c) -> m a -> m b -> m c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
(:|) m a
p (m [a] -> m (NonEmpty a))
-> (m a -> m [a]) -> m a -> m (NonEmpty a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> m [a]
forall a. m a -> m [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (m a -> m (NonEmpty a)) -> m a -> m (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ m sep
sep m sep -> m a -> m a
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m a
p

separated :: (P.MonadParsec e s m) => (P.Token s -> Bool) -> m a -> m a
separated :: forall e s (m :: * -> *) a.
MonadParsec e s m =>
(Token s -> Bool) -> m a -> m a
separated Token s -> Bool
ok m a
p = m a -> m a
forall a. m a -> m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ m a
p m a -> m () -> m a
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* m () -> m ()
forall a. m a -> m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.lookAhead (m (Token s) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((Token s -> Bool) -> m (Token s)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
P.satisfy Token s -> Bool
ok) m () -> m () -> m ()
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
P.eof)

wordySep :: Char -> Bool
wordySep :: Char -> Bool
wordySep Char
c = Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Bool -> Bool
not (Char -> Bool
wordyIdChar Char
c)

-- `True` if the tokens are adjacent, with no space separating the two
touches :: Token a -> Token b -> Bool
touches :: forall a b. Token a -> Token b -> Bool
touches (Token a -> Pos
forall a. Token a -> Pos
end -> Pos
t) (Token b -> Pos
forall a. Token a -> Pos
start -> Pos
t2) =
  Pos -> Column
line Pos
t Column -> Column -> Bool
forall a. Eq a => a -> a -> Bool
== Pos -> Column
line Pos
t2 Bool -> Bool -> Bool
&& Pos -> Column
column Pos
t Column -> Column -> Bool
forall a. Eq a => a -> a -> Bool
== Pos -> Column
column Pos
t2

pop :: [a] -> [a]
pop :: forall a. [a] -> [a]
pop = Column -> [a] -> [a]
forall a. Column -> [a] -> [a]
drop Column
1

typeOrAbilityAlt :: (Alternative f) => (Text -> f a) -> f a
typeOrAbilityAlt :: forall (f :: * -> *) a. Alternative f => (Text -> f a) -> f a
typeOrAbilityAlt Text -> f a
f =
  [f a] -> f a
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ([f a] -> f a) -> [f a] -> f a
forall a b. (a -> b) -> a -> b
$ (Text -> f a) -> [Text] -> [f a]
forall a b. (a -> b) -> [a] -> [b]
map Text -> f a
f (Set Text -> [Text]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set Text
typeOrAbility)

inc :: Pos -> Pos
inc :: Pos -> Pos
inc (Pos Column
line Column
col) = Column -> Column -> Pos
Pos Column
line (Column
col Column -> Column -> Column
forall a. Num a => a -> a -> a
+ Column
1)