{- FOURMOLU_DISABLE -}
-- The MIT License (MIT)

-- Copyright (c) 2016-2024 Objectionary.com

-- Permission is hereby granted, free of charge, to any person obtaining a copy
-- of this software and associated documentation files (the "Software"), to deal
-- in the Software without restriction, including without limitation the rights
-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-- copies of the Software, and to permit persons to whom the Software is
-- furnished to do so, subject to the following conditions:

-- The above copyright notice and this permission notice shall be included
-- in all copies or substantial portions of the Software.

-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-- FITNESS FOR A PARTICULAR PURPOSE AND NON-INFRINGEMENT. IN NO EVENT SHALL THE
-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
-- SOFTWARE.
{- FOURMOLU_ENABLE -}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}

module Language.EO.Phi.Preprocess where

import Control.Monad (void)
import Data.Void (Void)
import Language.EO.Phi.Syntax.Abs
import Replace.Megaparsec (splitCap)
import Text.Megaparsec (MonadParsec (..), Parsec, Stream (..), between, choice, match, oneOf, optional, sepBy)
import Text.Megaparsec.Byte.Lexer qualified as L
import Text.Megaparsec.Char (space, string)

symbol :: String -> Parser String
symbol :: String -> Parser String
symbol = ParsecT Void String Identity ()
-> Tokens String -> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
L.symbol ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space

lexeme :: Parser a -> Parser a
lexeme :: forall a. Parser a -> Parser a
lexeme = ParsecT Void String Identity ()
-> ParsecT Void String Identity a -> ParsecT Void String Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space

type Parser = Parsec Void String

parseTail :: Parser String
parseTail :: Parser String
parseTail = Maybe String
-> (Token String -> Bool)
-> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
"LabelId") (Token String -> [Token String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
[Token String]
" \r\n\t,.|':;!?][}{)(⟧⟦↦")

parseLabelId :: Parser LabelId
parseLabelId :: Parser LabelId
parseLabelId = Parser LabelId -> Parser LabelId
forall a. Parser a -> Parser a
lexeme do
  Char
l <- [Token String] -> ParsecT Void String Identity (Token String)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf [Char
'a' .. Char
'z']
  String
ls <- Parser String
parseTail
  LabelId -> Parser LabelId
forall a. a -> ParsecT Void String Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LabelId -> Parser LabelId) -> LabelId -> Parser LabelId
forall a b. (a -> b) -> a -> b
$ String -> LabelId
LabelId (Char
l Char -> String -> String
forall a. a -> [a] -> [a]
: String
ls)

parseToken :: String -> (String -> a) -> Parser a
parseToken :: forall a. String -> (String -> a) -> Parser a
parseToken String
prefix String -> a
cons = Parser a -> Parser a
forall a. Parser a -> Parser a
lexeme do
  ParsecT Void String Identity (Tokens String)
-> ParsecT Void String Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void String Identity (Tokens String)
 -> ParsecT Void String Identity ())
-> ParsecT Void String Identity (Tokens String)
-> ParsecT Void String Identity ()
forall a b. (a -> b) -> a -> b
$ Tokens String -> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string String
Tokens String
prefix
  String
ls <- Parser String
parseTail
  a -> Parser a
forall a. a -> ParsecT Void String Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Parser a) -> a -> Parser a
forall a b. (a -> b) -> a -> b
$ String -> a
cons (String
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
ls)

parseObjectMetaId :: Parser ObjectMetaId
parseObjectMetaId :: Parser ObjectMetaId
parseObjectMetaId = String -> (String -> ObjectMetaId) -> Parser ObjectMetaId
forall a. String -> (String -> a) -> Parser a
parseToken String
"!b" String -> ObjectMetaId
ObjectMetaId

parseBytesMetaId :: Parser BytesMetaId
parseBytesMetaId :: Parser BytesMetaId
parseBytesMetaId = String -> (String -> BytesMetaId) -> Parser BytesMetaId
forall a. String -> (String -> a) -> Parser a
parseToken String
"!y" String -> BytesMetaId
BytesMetaId

parseLabelMetaId :: Parser LabelMetaId
parseLabelMetaId :: Parser LabelMetaId
parseLabelMetaId = String -> (String -> LabelMetaId) -> Parser LabelMetaId
forall a. String -> (String -> a) -> Parser a
parseToken String
"!τ" String -> LabelMetaId
LabelMetaId

parseMetaId :: Parser MetaId
parseMetaId :: Parser MetaId
parseMetaId =
  [Parser MetaId] -> Parser MetaId
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ ObjectMetaId -> MetaId
MetaIdObject (ObjectMetaId -> MetaId) -> Parser ObjectMetaId -> Parser MetaId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ObjectMetaId
parseObjectMetaId
    , BytesMetaId -> MetaId
MetaIdBytes (BytesMetaId -> MetaId) -> Parser BytesMetaId -> Parser MetaId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser BytesMetaId
parseBytesMetaId
    , LabelMetaId -> MetaId
MetaIdLabel (LabelMetaId -> MetaId) -> Parser LabelMetaId -> Parser MetaId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser LabelMetaId
parseLabelMetaId
    ]

parseAlphaIndex :: Parser AlphaIndex
parseAlphaIndex :: Parser AlphaIndex
parseAlphaIndex = String -> (String -> AlphaIndex) -> Parser AlphaIndex
forall a. String -> (String -> a) -> Parser a
parseToken String
"α" String -> AlphaIndex
AlphaIndex

parseAttribute :: Parser Attribute
parseAttribute :: Parser Attribute
parseAttribute = Parser Attribute -> Parser Attribute
forall a. Parser a -> Parser a
lexeme do
  [Parser Attribute] -> Parser Attribute
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ Attribute
Phi Attribute -> Parser String -> Parser Attribute
forall a b.
a
-> ParsecT Void String Identity b -> ParsecT Void String Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> Parser String
symbol String
"φ"
    , Attribute
Rho Attribute -> Parser String -> Parser Attribute
forall a b.
a
-> ParsecT Void String Identity b -> ParsecT Void String Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> Parser String
symbol String
"ρ"
    , LabelId -> Attribute
Label (LabelId -> Attribute) -> Parser LabelId -> Parser Attribute
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser LabelId
parseLabelId
    , AlphaIndex -> Attribute
Alpha (AlphaIndex -> Attribute) -> Parser AlphaIndex -> Parser Attribute
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser AlphaIndex
parseAlphaIndex
    ]

parseBindingArrow :: Parser ()
parseBindingArrow :: ParsecT Void String Identity ()
parseBindingArrow = Parser String -> ParsecT Void String Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser String -> ParsecT Void String Identity ())
-> Parser String -> ParsecT Void String Identity ()
forall a b. (a -> b) -> a -> b
$ String -> Parser String
symbol String
"↦"

parseAttributeSugar :: Parser AttributeSugar
parseAttributeSugar :: Parser AttributeSugar
parseAttributeSugar = do
  [Parser AttributeSugar] -> Parser AttributeSugar
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ do
        LabelId
labelId <- Parser LabelId
parseLabelId
        Maybe [Attribute]
attrs <- ParsecT Void String Identity [Attribute]
-> ParsecT Void String Identity (Maybe [Attribute])
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT Void String Identity [Attribute]
 -> ParsecT Void String Identity (Maybe [Attribute]))
-> ParsecT Void String Identity [Attribute]
-> ParsecT Void String Identity (Maybe [Attribute])
forall a b. (a -> b) -> a -> b
$ Parser String
-> Parser String
-> ParsecT Void String Identity [Attribute]
-> ParsecT Void String Identity [Attribute]
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (String -> Parser String
symbol String
"(") (String -> Parser String
symbol String
")") (Parser Attribute
-> Parser String -> ParsecT Void String Identity [Attribute]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy Parser Attribute
parseAttribute (String -> Parser String
symbol String
","))
        case Maybe [Attribute]
attrs of
          Maybe [Attribute]
Nothing -> AttributeSugar -> Parser AttributeSugar
forall a. a -> ParsecT Void String Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AttributeSugar -> Parser AttributeSugar)
-> AttributeSugar -> Parser AttributeSugar
forall a b. (a -> b) -> a -> b
$ Attribute -> AttributeSugar
AttributeNoSugar (LabelId -> Attribute
Label LabelId
labelId)
          Just [Attribute]
attrs' -> AttributeSugar -> Parser AttributeSugar
forall a. a -> ParsecT Void String Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AttributeSugar -> Parser AttributeSugar)
-> AttributeSugar -> Parser AttributeSugar
forall a b. (a -> b) -> a -> b
$ LabelId -> [Attribute] -> AttributeSugar
AttributeSugar LabelId
labelId [Attribute]
attrs'
    , Attribute -> AttributeSugar
AttributeNoSugar (Attribute -> AttributeSugar)
-> Parser Attribute -> Parser AttributeSugar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Attribute
parseAttribute
    ]

type Attr = Either MetaId AttributeSugar

parseAlphaBindingSugar :: Parser Attr
parseAlphaBindingSugar :: Parser Attr
parseAlphaBindingSugar = do
  Attr
attr <-
    [Parser Attr] -> Parser Attr
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
      [ MetaId -> Attr
forall a b. a -> Either a b
Left (MetaId -> Attr) -> Parser MetaId -> Parser Attr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MetaId
parseMetaId
      , AttributeSugar -> Attr
forall a b. b -> Either a b
Right (AttributeSugar -> Attr) -> Parser AttributeSugar -> Parser Attr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser AttributeSugar
parseAttributeSugar
      ]
  ParsecT Void String Identity ()
parseBindingArrow
  Parser String -> ParsecT Void String Identity ()
forall a.
ParsecT Void String Identity a -> ParsecT Void String Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (String -> Parser String
symbol String
"∅")
  Attr -> Parser Attr
forall a. a -> ParsecT Void String Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attr
attr

splitInput :: Parser a -> String -> [Either String (Tokens [Char], a)]
splitInput :: forall a. Parser a -> String -> [Either String (Tokens String, a)]
splitInput Parser a
sep = Parsec Void String (String, a)
-> String -> [Either String (String, a)]
forall e s a.
(Ord e, Stream s, Tokens s ~ s) =>
Parsec e s a -> s -> [Either s a]
splitCap (Parser a -> ParsecT Void String Identity (Tokens String, a)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> m (Tokens s, a)
match Parser a
sep)

addPrefix :: Parser Attr -> String -> [String]
addPrefix :: Parser Attr -> String -> [String]
addPrefix Parser Attr
sep = (Either String (String, Attr) -> String)
-> [Either String (String, Attr)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> String)
-> ((String, Attr) -> String)
-> Either String (String, Attr)
-> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> String
forall a. a -> a
id (\(String
x, Attr
a) -> Attr -> String
forall {a}. Either a AttributeSugar -> String
choosePrefix Attr
a String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
x)) ([Either String (String, Attr)] -> [String])
-> (String -> [Either String (String, Attr)]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser Attr -> String -> [Either String (Tokens String, Attr)]
forall a. Parser a -> String -> [Either String (Tokens String, a)]
splitInput Parser Attr
sep
 where
  choosePrefix :: Either a AttributeSugar -> String
choosePrefix = \case
    Right AttributeSugar{} -> String
"~"
    Either a AttributeSugar
_ -> String
"#"

preprocess' :: Parser Attr -> String -> String
preprocess' :: Parser Attr -> String -> String
preprocess' Parser Attr
sep = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser Attr -> String -> [String]
addPrefix Parser Attr
sep

preprocess :: String -> String
preprocess :: String -> String
preprocess = Parser Attr -> String -> String
preprocess' Parser Attr
parseAlphaBindingSugar

input1 :: String
input1 :: String
input1 = String
"{⟦ org ↦ ⟦ ⟧(α0 ↦ !b1) ⟧}"

-- >>> preprocess input1
-- "{\10214 #org \8614 \10214 \10215(#\945\&0 \8614 !b1) \10215}"