{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
module Glam.Utils where

import Control.Monad.Reader
import Data.Bifunctor (first)
import Data.Char
import Data.String
import Data.Void
import Text.Megaparsec hiding (State, parse)
import Text.Megaparsec.Char
import Text.Megaparsec.Char.Lexer qualified as L

-- * Parsing

type IndentRef = Maybe SourcePos

type Parser = ReaderT IndentRef (Parsec Void String)

parse :: Parser a -> String -> String -> Either String a
parse :: forall a. Parser a -> String -> String -> Either String a
parse Parser a
p String
f String
s = (ParseErrorBundle String Void -> String)
-> Either (ParseErrorBundle String Void) a -> Either String a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> String
forall a. HasCallStack => [a] -> [a]
init (String -> String)
-> (ParseErrorBundle String Void -> String)
-> ParseErrorBundle String Void
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle String Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty) (Either (ParseErrorBundle String Void) a -> Either String a)
-> Either (ParseErrorBundle String Void) a -> Either String a
forall a b. (a -> b) -> a -> b
$ Parsec Void String a
-> String -> String -> Either (ParseErrorBundle String Void) a
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser (Parser a -> IndentRef -> Parsec Void String a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Parser a
p IndentRef
forall a. Maybe a
Nothing) String
f String
s

whitespace :: Parser ()
whitespace :: Parser ()
whitespace = Parser () -> Parser () -> Parser () -> Parser ()
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1 (Tokens String -> Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
L.skipLineComment Tokens String
"--") (Tokens String -> Tokens String -> Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> Tokens s -> m ()
L.skipBlockComment Tokens String
"{-" Tokens String
"-}")

alpha :: Parser Char
alpha :: Parser Char
alpha = Parser Char
ReaderT IndentRef (Parsec Void String) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
letterChar Parser Char -> Parser Char -> Parser Char
forall a.
ReaderT IndentRef (Parsec Void String) a
-> ReaderT IndentRef (Parsec Void String) a
-> ReaderT IndentRef (Parsec Void String) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token String
-> ReaderT IndentRef (Parsec Void String) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'_'

isRest :: Char -> Bool
isRest :: Char -> Bool
isRest Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char -> Bool
isAlpha Char
c

lexeme :: Parser a -> Parser a
lexeme :: forall a. Parser a -> Parser a
lexeme Parser a
p = do
    SourcePos { sourceLine :: SourcePos -> Pos
sourceLine = Pos
curLine, sourceColumn :: SourcePos -> Pos
sourceColumn = Pos
curColumn } <- ReaderT IndentRef (Parsec Void String) SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
    IndentRef
ref <- ReaderT IndentRef (Parsec Void String) IndentRef
forall r (m :: * -> *). MonadReader r m => m r
ask
    case IndentRef
ref of
        Just SourcePos { sourceLine :: SourcePos -> Pos
sourceLine = Pos
refLine, sourceColumn :: SourcePos -> Pos
sourceColumn = Pos
refColumn }
            | Pos
curLine Pos -> Pos -> Bool
forall a. Ord a => a -> a -> Bool
> Pos
refLine, Pos
curColumn Pos -> Pos -> Bool
forall a. Ord a => a -> a -> Bool
<= Pos
refColumn ->
                Ordering -> Pos -> Pos -> Parser ()
forall e s (m :: * -> *) a.
MonadParsec e s m =>
Ordering -> Pos -> Pos -> m a
L.incorrectIndent Ordering
GT Pos
refColumn Pos
curColumn
        IndentRef
_ -> () -> Parser ()
forall a. a -> ReaderT IndentRef (Parsec Void String) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Parser a
p Parser a -> Parser () -> Parser a
forall a b.
ReaderT IndentRef (Parsec Void String) a
-> ReaderT IndentRef (Parsec Void String) b
-> ReaderT IndentRef (Parsec Void String) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
whitespace

symbol, keyword :: String -> Parser String
symbol :: String -> Parser String
symbol  String
s = Parser String -> Parser String
forall a. Parser a -> Parser a
lexeme (Tokens String
-> ReaderT IndentRef (Parsec Void String) (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string String
Tokens String
s)
keyword :: String -> Parser String
keyword String
s = String -> Parser String -> Parser String
forall a.
String
-> ReaderT IndentRef (Parsec Void String) a
-> ReaderT IndentRef (Parsec Void String) a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label (String -> String
forall a. Show a => a -> String
show String
s) (Parser String -> Parser String) -> Parser String -> Parser String
forall a b. (a -> b) -> a -> b
$ Parser String -> Parser String
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser String -> Parser String) -> Parser String -> Parser String
forall a b. (a -> b) -> a -> b
$ Parser String -> Parser String
forall a. Parser a -> Parser a
lexeme (Parser String -> Parser String) -> Parser String -> Parser String
forall a b. (a -> b) -> a -> b
$ Tokens String
-> ReaderT IndentRef (Parsec Void String) (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string String
Tokens String
s Parser String -> Parser () -> Parser String
forall a b.
ReaderT IndentRef (Parsec Void String) a
-> ReaderT IndentRef (Parsec Void String) b
-> ReaderT IndentRef (Parsec Void String) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReaderT IndentRef (Parsec Void String) (Token String) -> Parser ()
forall a. ReaderT IndentRef (Parsec Void String) a -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy ((Token String -> Bool)
-> ReaderT IndentRef (Parsec Void String) (Token String)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token String -> Bool
isRest)

instance {-# OVERLAPPING #-} a ~ String => IsString (Parser a) where
    fromString :: String -> Parser a
fromString = String -> Parser a
String -> Parser String
keyword

colon, semicolon, comma, equal, dot, lambda :: Parser String
colon :: Parser String
colon     = String -> Parser String
symbol String
":"
semicolon :: Parser String
semicolon = String -> Parser String
symbol String
";"
comma :: Parser String
comma     = String -> Parser String
symbol String
","
equal :: Parser String
equal     = String -> Parser String
symbol String
"="
dot :: Parser String
dot       = String -> Parser String
symbol String
"."
lambda :: Parser String
lambda    = String -> Parser String
symbol String
"λ" Parser String -> Parser String -> Parser String
forall a.
ReaderT IndentRef (Parsec Void String) a
-> ReaderT IndentRef (Parsec Void String) a
-> ReaderT IndentRef (Parsec Void String) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Parser String
symbol String
"\\"

parens, braces, lineFolded :: Parser a -> Parser a
parens :: forall a. Parser a -> Parser a
parens       = Parser String
-> Parser String
-> ReaderT IndentRef (Parsec Void String) a
-> ReaderT IndentRef (Parsec Void String) a
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
")")
braces :: forall a. Parser a -> Parser a
braces       = Parser String
-> Parser String
-> ReaderT IndentRef (Parsec Void String) a
-> ReaderT IndentRef (Parsec Void String) a
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
"}")
lineFolded :: forall a. Parser a -> Parser a
lineFolded Parser a
p = do
    SourcePos
pos <- ReaderT IndentRef (Parsec Void String) SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
    (IndentRef -> IndentRef) -> Parser a -> Parser a
forall a.
(IndentRef -> IndentRef)
-> ReaderT IndentRef (Parsec Void String) a
-> ReaderT IndentRef (Parsec Void String) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\IndentRef
_ -> SourcePos -> IndentRef
forall a. a -> Maybe a
Just SourcePos
pos) Parser a
p

word :: Parser String
word :: Parser String
word = (:) (Char -> String -> String)
-> Parser Char
-> ReaderT IndentRef (Parsec Void String) (String -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char
alpha ReaderT IndentRef (Parsec Void String) (String -> String)
-> Parser String -> Parser String
forall a b.
ReaderT IndentRef (Parsec Void String) (a -> b)
-> ReaderT IndentRef (Parsec Void String) a
-> ReaderT IndentRef (Parsec Void String) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe String
-> (Token String -> Bool)
-> ReaderT IndentRef (Parsec Void String) (Tokens String)
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 String -> Bool
isRest Parser String -> String -> Parser String
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"word"

number :: Parser Integer
number :: Parser Integer
number = Parser Integer -> Parser Integer
forall a. Parser a -> Parser a
lexeme Parser Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal

mkIdentifier :: [String] -> Parser String
mkIdentifier :: [String] -> Parser String
mkIdentifier [String]
reserved = String -> Parser String -> Parser String
forall a.
String
-> ReaderT IndentRef (Parsec Void String) a
-> ReaderT IndentRef (Parsec Void String) a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"identifier" (Parser String -> Parser String) -> Parser String -> Parser String
forall a b. (a -> b) -> a -> b
$ Parser String -> Parser String
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser String -> Parser String) -> Parser String -> Parser String
forall a b. (a -> b) -> a -> b
$ Parser String -> Parser String
forall a. Parser a -> Parser a
lexeme do
    String
w <- Parser String
word
    if String
w String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
reserved
        then String -> Parser String
forall a. String -> ReaderT IndentRef (Parsec Void String) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser String) -> String -> Parser String
forall a b. (a -> b) -> a -> b
$ String
"unexpected keyword " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
w
        else String -> Parser String
forall a. a -> ReaderT IndentRef (Parsec Void String) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
w

-- * Type checking

infix 1 |-
|- :: (r -> r) -> m a -> m a
(|-) = (r -> r) -> m a -> m a
forall a. (r -> r) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local

-- | Like 'lookup', but also returns the de Bruijn /level/ of the variable.
lookupLevel :: Eq a => a -> [(a, b)] -> Maybe (b, Int)
lookupLevel :: forall a b. Eq a => a -> [(a, b)] -> Maybe (b, Int)
lookupLevel a
_ [] = Maybe (b, Int)
forall a. Maybe a
Nothing
lookupLevel a
x ((a
y, b
c):[(a, b)]
ys)
    | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y = (b, Int) -> Maybe (b, Int)
forall a. a -> Maybe a
Just (b
c, [(a, b)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(a, b)]
ys)
    | Bool
otherwise = a -> [(a, b)] -> Maybe (b, Int)
forall a b. Eq a => a -> [(a, b)] -> Maybe (b, Int)
lookupLevel a
x [(a, b)]
ys