--  --                                                          ; {{{1
--
--  File        : Koneko/Misc.hs
--  Maintainer  : Felix C. Stegerman <flx@obfusk.net>
--  Date        : 2020-11-11
--
--  Copyright   : Copyright (C) 2020  Felix C. Stegerman
--  Version     : v0.0.1
--  License     : GPLv3+
--
--  --                                                          ; }}}1

{-# LANGUAGE OverloadedStrings #-}

module Koneko.Misc (
  Parser, isIdent, pIdent, pIdent_, pInt, pFloat, isSpaceOrComma,
  lexeme, symbol, speof, sp, sp1, spaceOrComment, prompt, firstJust,
  parseMaybe
) where

import Data.Char (isSpace)
import Data.Functor
import Data.List ((\\))
import Data.Maybe (isJust, maybeToList)
import Data.Text (Text)
import Data.Void (Void)
import System.IO (hFlush, stdout)
import System.IO.Error (catchIOError, isEOFError)
import Text.Megaparsec
import Text.Megaparsec.Char hiding (space, space1)

import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Text.Megaparsec.Char.Lexer as L

-- parser: common --

type Parser = Parsec Void Text

                                                              --  {{{1
-- | Is the string an identifier?
--
-- NB: only partially checks whether it is a *valid* identifier (i.e.
-- whether it is not e.g. "nil").
--
-- >>> :set -XOverloadedStrings
-- >>> isIdent "nil"  -- OOPS
-- True
-- >>> isIdent ""
-- False
-- >>> isIdent "42"
-- False
-- >>> isIdent "foo-bar'"
-- True
-- >>> isIdent "[子猫]"
-- True
-- >>> isIdent "'foo"
-- False
-- >>> isIdent "@$%^&*!"
-- True
-- >>> isIdent "["
-- False
-- >>> isIdent "]"
-- False
-- >>> isIdent "x]"
-- True
-- >>> isIdent "x["
-- False
-- >>> isIdent "x:"
-- False
--

                                                              --  }}}1
isIdent :: Text -> Bool
isIdent :: Text -> Bool
isIdent Text
s = Parser Text -> Text -> Bool
forall a. Parser a -> Text -> Bool
parses Parser Text
pIdent Text
s Bool -> Bool -> Bool
&& Bool -> Bool
not (Parser Integer -> Text -> Bool
forall a. Parser a -> Text -> Bool
parses Parser Integer
pInt Text
s Bool -> Bool -> Bool
|| Parser Double -> Text -> Bool
forall a. Parser a -> Text -> Bool
parses Parser Double
pFloat Text
s)

-- | NB: also matches float and int
pIdent :: Parser Text
pIdent :: Parser Text
pIdent = Maybe Char -> Parser Text
pIdent_ Maybe Char
forall a. Maybe a
Nothing

-- TODO
pIdent_ :: Maybe Char-> Parser Text
pIdent_ :: Maybe Char -> Parser Text
pIdent_ Maybe Char
ok = String -> Text
T.pack (String -> Text)
-> ParsecT Void Text Identity String -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT Void Text Identity String
-> ParsecT Void Text Identity String
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT Void Text Identity String
a ParsecT Void Text Identity String
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity String
b)
  where
    a :: ParsecT Void Text Identity String
a       = (Char -> String -> String
forall a. a -> [a] -> [a]
:[]) (Char -> String)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
okChar ParsecT Void Text Identity String
-> ParsecT Void Text Identity ()
-> ParsecT Void Text Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy ParsecT Void Text Identity Char
miChar
    b :: ParsecT Void Text Identity String
b       = (:)   (Char -> String -> String)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (String -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
hdChar ParsecT Void Text Identity (String -> String)
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (ParsecT Void Text Identity Char -> ParsecT Void Text Identity Char
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT Void Text Identity Char
b1 ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Char
tlChar)
    b1 :: ParsecT Void Text Identity Char
b1      = ParsecT Void Text Identity Char
miChar ParsecT Void Text Identity Char
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (ParsecT Void Text Identity ()
speof ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ParsecT Void Text Identity (Token Text)
bad ParsecT Void Text Identity (Token Text)
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT Void Text Identity ()
speof))
    okChar :: ParsecT Void Text Identity Char
okChar  = ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
letterChar ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
numberChar ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
symbolChar ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Token Text] -> ParsecT Void Text Identity (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf String
[Token Text]
specialChar
    hdChar :: ParsecT Void Text Identity Char
hdChar  = ParsecT Void Text Identity Char
okChar ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Token Text] -> ParsecT Void Text Identity (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf String
[Token Text]
brackets
    miChar :: ParsecT Void Text Identity Char
miChar  = ParsecT Void Text Identity Char
hdChar ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Token Text] -> ParsecT Void Text Identity (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf String
[Token Text]
badStart
    tlChar :: ParsecT Void Text Identity Char
tlChar  = ParsecT Void Text Identity Char
okChar ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Token Text] -> ParsecT Void Text Identity (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf String
[Token Text]
bracketsC ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
good
    bad :: ParsecT Void Text Identity (Token Text)
bad     = [Token Text] -> ParsecT Void Text Identity (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf ([Token Text] -> ParsecT Void Text Identity (Token Text))
-> [Token Text] -> ParsecT Void Text Identity (Token Text)
forall a b. (a -> b) -> a -> b
$ String
badEnd   String -> String -> String
forall a. Eq a => [a] -> [a] -> [a]
\\ Maybe Char -> String
forall a. Maybe a -> [a]
maybeToList Maybe Char
ok
    good :: ParsecT Void Text Identity (Token Text)
good    = [Token Text] -> ParsecT Void Text Identity (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf ([Token Text] -> ParsecT Void Text Identity (Token Text))
-> [Token Text] -> ParsecT Void Text Identity (Token Text)
forall a b. (a -> b) -> a -> b
$ String
goodTail String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe Char -> String
forall a. Maybe a -> [a]
maybeToList Maybe Char
ok

brackets, bracketsO, bracketsC, specialChar, badStart, goodTail,
  badEnd :: [Char]

brackets :: String
brackets      = String
bracketsO String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
bracketsC
bracketsO :: String
bracketsO     = String
"({["
bracketsC :: String
bracketsC     = String
")}]"
specialChar :: String
specialChar   = String
"@%&*-_/?"
badStart :: String
badStart      = String
goodTail String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"
goodTail :: String
goodTail      = String
"'!"
badEnd :: String
badEnd        = String
bracketsO String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"

pInt :: Parser Integer
pInt :: Parser Integer
pInt = Parser Integer
hex Parser Integer -> Parser Integer -> Parser Integer
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Integer
bin Parser Integer -> Parser Integer -> Parser Integer
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Integer
dec
  where
    hex :: Parser Integer
hex = Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"0x" ParsecT Void Text Identity (Tokens Text)
-> Parser Integer -> Parser Integer
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.hexadecimal
    bin :: Parser Integer
bin = Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"0b" ParsecT Void Text Identity (Tokens Text)
-> Parser Integer -> Parser Integer
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.binary
    dec :: Parser Integer
dec = Parser Integer -> Parser Integer
forall a. Num a => Parser a -> Parser a
signed Parser Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal

pFloat :: Parser Double
pFloat :: Parser Double
pFloat = Parser Double -> Parser Double
forall a. Num a => Parser a -> Parser a
signed Parser Double
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, RealFloat a) =>
m a
L.float

-- parser: helpers --

signed :: Num a => Parser a -> Parser a
signed :: Parser a -> Parser a
signed = ParsecT Void Text Identity () -> Parser a -> Parser a
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m () -> m a -> m a
L.signed (ParsecT Void Text Identity () -> Parser a -> Parser a)
-> ParsecT Void Text Identity () -> Parser a -> Parser a
forall a b. (a -> b) -> a -> b
$ () -> ParsecT Void Text Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

isSpaceOrComma :: Char -> Bool
isSpaceOrComma :: Char -> Bool
isSpaceOrComma Char
c = Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
','

parses :: Parser a -> Text -> Bool
parses :: Parser a -> Text -> Bool
parses Parser a
p = Maybe a -> Bool
forall a. Maybe a -> Bool
isJust (Maybe a -> Bool) -> (Text -> Maybe a) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser a -> Text -> Maybe a
forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
parseMaybe Parser a
p

-- parser: utilities --

lexeme :: Parser a -> Parser a
lexeme :: Parser a -> Parser a
lexeme Parser a
p = Parser a
p Parser a -> ParsecT Void Text Identity () -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity ()
speof

symbol :: Text -> Parser Text
symbol :: Text -> Parser Text
symbol = Parser Text -> Parser Text
forall a. Parser a -> Parser a
lexeme (Parser Text -> Parser Text)
-> (Text -> Parser Text) -> Text -> Parser Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Parser Text
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string

speof, sp, sp1, spaceOrComment, space1 :: Parser ()

speof :: ParsecT Void Text Identity ()
speof = ParsecT Void Text Identity ()
sp1 ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
sp :: ParsecT Void Text Identity ()
sp    = ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (m :: * -> *) a. MonadPlus m => m a -> m ()
skipMany ParsecT Void Text Identity ()
spaceOrComment
sp1 :: ParsecT Void Text Identity ()
sp1   = ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (m :: * -> *) a. MonadPlus m => m a -> m ()
skipSome ParsecT Void Text Identity ()
spaceOrComment

spaceOrComment :: ParsecT Void Text Identity ()
spaceOrComment = ParsecT Void Text Identity ()
space1 ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Tokens Text -> ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
L.skipLineComment Tokens Text
";")

space1 :: ParsecT Void Text Identity ()
space1 = Parser Text -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text -> ParsecT Void Text Identity ())
-> Parser Text -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> 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)
takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"white space") Char -> Bool
Token Text -> Bool
isSpaceOrComma

-- utilities --

prompt :: Maybe Text -> IO (Maybe Text)
prompt :: Maybe Text -> IO (Maybe Text)
prompt Maybe Text
x = (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> IO Text -> IO (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Text
f) IO (Maybe Text) -> (IOError -> IO (Maybe Text)) -> IO (Maybe Text)
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` IOError -> IO (Maybe Text)
forall a. IOError -> IO (Maybe a)
g
  where
    f :: IO Text
f   = IO () -> (Text -> IO ()) -> Maybe Text -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Text -> IO ()
h Maybe Text
x IO () -> IO Text -> IO Text
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO Text
T.getLine
    g :: IOError -> IO (Maybe a)
g IOError
e = if IOError -> Bool
isEOFError IOError
e then Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing else IOError -> IO (Maybe a)
forall a. IOError -> IO a
ioError IOError
e
    h :: Text -> IO ()
h Text
s = do Text -> IO ()
T.putStr Text
s; Handle -> IO ()
hFlush Handle
stdout

-- miscellaneous --

firstJust :: Monad m => [m (Maybe a)] -> m (Maybe a)
firstJust :: [m (Maybe a)] -> m (Maybe a)
firstJust []      = Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
firstJust (m (Maybe a)
x:[m (Maybe a)]
xt)  = m (Maybe a)
x m (Maybe a) -> (Maybe a -> m (Maybe a)) -> m (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (Maybe a) -> (a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([m (Maybe a)] -> m (Maybe a)
forall (m :: * -> *) a. Monad m => [m (Maybe a)] -> m (Maybe a)
firstJust [m (Maybe a)]
xt) (Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> m (Maybe a)) -> (a -> Maybe a) -> a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just)

-- vim: set tw=70 sw=2 sts=2 et fdm=marker :