{-# LANGUAGE OverloadedStrings #-}

module Codec.CBOR.Cuddle.Parser.Lexer (
  Parser,
  charInRange,
  space,
  pComment,
  sameLineComment,
  (|||),
  pCommentBlock,
) where

import Codec.CBOR.Cuddle.Comments (Comment (..))
import Control.Applicative.Combinators.NonEmpty qualified as NE
import Data.Foldable1 (Foldable1 (..))
import Data.Functor (($>))
import Data.Text (Text)
import Data.Void (Void)
import Text.Megaparsec (
  MonadParsec (..),
  Parsec,
  sepEndBy,
  (<|>),
 )
import Text.Megaparsec.Char (char, eol)
import Text.Megaparsec.Char qualified as L

type Parser = Parsec Void Text

charInRange :: Char -> Char -> Char -> Bool
charInRange :: Char -> Char -> Char -> Bool
charInRange Char
lb Char
ub Char
x = Char
lb Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
x Bool -> Bool -> Bool
&& Char
x Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
ub

(|||) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool)
(a -> Bool
x ||| :: forall a. (a -> Bool) -> (a -> Bool) -> a -> Bool
||| a -> Bool
y) a
a = a -> Bool
x a
a Bool -> Bool -> Bool
|| a -> Bool
y a
a

pComment :: Parser Comment
pComment :: Parser Comment
pComment =
  Text -> Comment
Comment (Text -> Comment)
-> ParsecT Void Text Identity Text -> Parser Comment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"comment" (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
';' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe String
forall a. Maybe a
Nothing Char -> Bool
Token Text -> Bool
validChar ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol)
  where
    validChar :: Char -> Bool
validChar = Char -> Char -> Char -> Bool
charInRange Char
'\x20' Char
'\x7e' (Char -> Bool) -> (Char -> Bool) -> Char -> Bool
forall a. (a -> Bool) -> (a -> Bool) -> a -> Bool
||| Char -> Char -> Char -> Bool
charInRange Char
'\x80' Char
'\x10fffd'

pCommentBlock :: Parser Comment
pCommentBlock :: Parser Comment
pCommentBlock = NonEmpty Comment -> Comment
forall m. Semigroup m => NonEmpty m -> m
forall (t :: * -> *) m. (Foldable1 t, Semigroup m) => t m -> m
fold1 (NonEmpty Comment -> Comment)
-> ParsecT Void Text Identity (NonEmpty Comment) -> Parser Comment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Comment -> ParsecT Void Text Identity (NonEmpty Comment)
forall (m :: * -> *) a. Alternative m => m a -> m (NonEmpty a)
NE.some (ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
L.hspace ParsecT Void Text Identity () -> Parser Comment -> Parser Comment
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Comment
pComment)

space :: Parser Comment
space :: Parser Comment
space = [Comment] -> Comment
forall a. Monoid a => [a] -> a
mconcat ([Comment] -> Comment)
-> ParsecT Void Text Identity [Comment] -> Parser Comment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
L.space ParsecT Void Text Identity ()
-> ParsecT Void Text Identity [Comment]
-> ParsecT Void Text Identity [Comment]
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Comment
-> ParsecT Void Text Identity ()
-> ParsecT Void Text Identity [Comment]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepEndBy Parser Comment
pComment ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
L.space)

sameLineComment :: Parser Comment
sameLineComment :: Parser Comment
sameLineComment =
  Parser Comment -> Parser Comment
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
(<>) (Comment -> Comment -> Comment)
-> Parser Comment
-> ParsecT Void Text Identity (Comment -> Comment)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
L.hspace ParsecT Void Text Identity () -> Parser Comment -> Parser Comment
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Comment
pComment) ParsecT Void Text Identity (Comment -> Comment)
-> Parser Comment -> Parser Comment
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Comment
space) Parser Comment -> Parser Comment -> Parser Comment
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
L.space ParsecT Void Text Identity () -> Comment -> Parser Comment
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Comment
forall a. Monoid a => a
mempty)