{-# 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
type Parser = Parsec Void Text
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)
pIdent :: Parser Text
pIdent :: Parser Text
pIdent = Maybe Char -> Parser Text
pIdent_ Maybe Char
forall a. Maybe a
Nothing
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
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
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
= 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
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
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)