{-# LANGUAGE FlexibleInstances #-}

module Language.Elsa.Parser
  ( parse
  , parseFile
  ) where

import qualified Control.Exception          as Ex
import           Control.Monad          (void)
import           Text.Megaparsec hiding (parse)
import qualified Text.Megaparsec.Char.Lexer as L
import           Text.Megaparsec.Char
import           Text.Megaparsec.Stream ()
import qualified Data.List as L
import           Language.Elsa.Types
import           Language.Elsa.UX
import           Data.List.NonEmpty         as NE

type Parser = Parsec SourcePos Text

--------------------------------------------------------------------------------
parse :: FilePath -> Text -> SElsa
--------------------------------------------------------------------------------
parse :: Text -> Text -> SElsa
parse = forall a. Parser a -> Text -> Text -> a
parseWith Parser SElsa
elsa

parseWith  :: Parser a -> FilePath -> Text -> a
parseWith :: forall a. Parser a -> Text -> Text -> a
parseWith Parser a
p Text
f Text
s = case forall e s a.
Parsec e s a -> Text -> s -> Either (ParseErrorBundle s e) a
runParser (forall a. Parser a -> Parser a
whole Parser a
p) Text
f Text
s of
                    Left ParseErrorBundle Text SourcePos
pErrs -> forall a e. Exception e => e -> a
Ex.throw (ParseErrorBundle Text SourcePos -> Text -> Text -> [UserError]
mkErrors ParseErrorBundle Text SourcePos
pErrs Text
f Text
s) -- panic (show err) (posSpan . NE.head . errorPos $ err)
                    Right a
e  -> a
e

mkErrors :: ParseErrorBundle Text SourcePos -> FilePath -> Text -> [UserError]
mkErrors :: ParseErrorBundle Text SourcePos -> Text -> Text -> [UserError]
mkErrors ParseErrorBundle Text SourcePos
b Text
f Text
s = [ Text -> SourceSpan -> UserError
mkError (forall s e.
(VisualStream s, ShowErrorComponent e) =>
ParseError s e -> Text
parseErrorPretty ParseError Text SourcePos
e) (forall {s} {e}. ParseError s e -> SourceSpan
span ParseError Text SourcePos
e) | ParseError Text SourcePos
e <- forall a. NonEmpty a -> [a]
NE.toList (forall s e. ParseErrorBundle s e -> NonEmpty (ParseError s e)
bundleErrors ParseErrorBundle Text SourcePos
b)]
  where
    span :: ParseError s e -> SourceSpan
span ParseError s e
e = let (Int
l, Int
c) = Text -> Int -> (Int, Int)
lineCol Text
s (forall s e. ParseError s e -> Int
errorOffset ParseError s e
e) in SourcePos -> SourceSpan
posSpan (Text -> Pos -> Pos -> SourcePos
SourcePos Text
f (Int -> Pos
mkPos Int
l) (Int -> Pos
mkPos Int
c))

-- PosState looks relevant for finding line/column, but I (Justin) don't know how to use it

lineCol :: String -> Int -> (Int, Int)
lineCol :: Text -> Int -> (Int, Int)
lineCol Text
s Int
i = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {a} {b}. (Num a, Num b) => (a, b) -> Char -> (a, b)
f (Int
1, Int
1) (forall a. Int -> [a] -> [a]
Prelude.take Int
i Text
s)
  where
    f :: (a, b) -> Char -> (a, b)
f (a
l, b
c) Char
char = if Char
char forall a. Eq a => a -> a -> Bool
== Char
'\n' then (a
l forall a. Num a => a -> a -> a
+ a
1, b
1) else (a
l, b
c forall a. Num a => a -> a -> a
+ b
1)

instance ShowErrorComponent SourcePos where
  showErrorComponent :: SourcePos -> Text
showErrorComponent = forall a. Show a => a -> Text
show
 

-- panic msg sp = throw [Error msg sp]
-- instance Located (ParseError SourcePos Text) where
--  sourceSpan = posSpan . errorPos

-- instance PPrint (ParseError SourcePos Text) where
--   pprint = show

--------------------------------------------------------------------------------
parseFile :: FilePath -> IO SElsa
--------------------------------------------------------------------------------
parseFile :: Text -> IO SElsa
parseFile Text
f = Text -> Text -> SElsa
parse Text
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> IO Text
readFile Text
f

-- https://mrkkrp.github.io/megaparsec/tutorials/parsing-simple-imperative-language.html

-- | Top-level parsers (should consume all input)
whole :: Parser a -> Parser a
whole :: forall a. Parser a -> Parser a
whole Parser a
p = Parser ()
sc forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
eof

-- RJ: rename me "space consumer"
sc :: Parser ()
sc :: Parser ()
sc = forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
spaceChar) Parser ()
lineCmnt Parser ()
blockCmnt
  where
    lineCmnt :: Parser ()
lineCmnt  = forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
L.skipLineComment  Tokens Text
"--"
    blockCmnt :: Parser ()
blockCmnt = forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> Tokens s -> m ()
L.skipBlockComment Tokens Text
"{-" Tokens Text
"-}"

-- | `symbol s` parses just the string s (and trailing whitespace)
symbol :: String -> Parser String
symbol :: Text -> Parser Text
symbol = forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
L.symbol Parser ()
sc

arrow :: Parser String
arrow :: Parser Text
arrow = Text -> Parser Text
symbol Text
"->"

colon :: Parser String
colon :: Parser Text
colon = Text -> Parser Text
symbol Text
":"

equal :: Parser String
equal :: Parser Text
equal = Text -> Parser Text
symbol Text
"="

lam :: Parser String
lam :: Parser Text
lam = Text -> Parser Text
symbol Text
"\\"


-- | 'parens' parses something between parenthesis.
parens :: Parser a -> Parser a
parens :: forall a. Parser a -> Parser a
parens = forall a. Text -> Text -> Parser a -> Parser a
betweenS Text
"(" Text
")"

betweenS :: String -> String -> Parser a -> Parser a
betweenS :: forall a. Text -> Text -> Parser a -> Parser a
betweenS Text
l Text
r = forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Text -> Parser Text
symbol Text
l) (Text -> Parser Text
symbol Text
r)

-- | `lexeme p` consume whitespace after running p
lexeme :: Parser a -> Parser (a, SourceSpan)
lexeme :: forall a. Parser a -> Parser (a, SourceSpan)
lexeme Parser a
p = forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
sc (forall a. Parser a -> Parser (a, SourceSpan)
withSpan Parser a
p)

-- | `rWord`
rWord   :: String -> Parser SourceSpan
rWord :: Text -> Parser SourceSpan
rWord Text
w = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Parser a -> Parser (a, SourceSpan)
withSpan (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Text
w) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
sc)

-- | list of reserved words
keywords :: [Text]
keywords :: [Text]
keywords = [ Text
"let"  , Text
"eval" ]

-- | `identifier` parses identifiers: lower-case alphabets followed by alphas or digits
identifier :: Parser (String, SourceSpan)
identifier :: Parser (Text, SourceSpan)
identifier = forall a. Parser a -> Parser (a, SourceSpan)
lexeme (Parser Text
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *}. MonadFail m => Text -> m Text
check)
  where
    p :: Parser Text
p       = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
letterChar forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser Char
identChar -- alphaNumChar
    check :: Text -> m Text
check Text
x = if Text
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
keywords
                then forall (m :: * -> *) a. MonadFail m => Text -> m a
fail forall a b. (a -> b) -> a -> b
$ Text
"keyword " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> Text
show Text
x forall a. [a] -> [a] -> [a]
++ Text
" cannot be an identifier"
                else forall (m :: * -> *) a. Monad m => a -> m a
return Text
x

identChar :: Parser Char
identChar :: Parser Char
identChar =  forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar
         forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf [Char
'_', Char
'#', Char
'\'']

-- | `binder` parses BareBind, used for let-binds and function parameters.
binder :: Parser SBind
binder :: Parser SBind
binder = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Text -> a -> Bind a
Bind forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Text, SourceSpan)
identifier

withSpan' :: Parser (SourceSpan -> a) -> Parser a
withSpan' :: forall a. Parser (SourceSpan -> a) -> Parser a
withSpan' Parser (SourceSpan -> a)
p = do
  SourcePos
p1 <- forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
  SourceSpan -> a
f  <- Parser (SourceSpan -> a)
p
  SourcePos
p2 <- forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
  forall (m :: * -> *) a. Monad m => a -> m a
return (SourceSpan -> a
f (SourcePos -> SourcePos -> SourceSpan
SS SourcePos
p1 SourcePos
p2))

withSpan :: Parser a -> Parser (a, SourceSpan)
withSpan :: forall a. Parser a -> Parser (a, SourceSpan)
withSpan Parser a
p = do
  SourcePos
p1 <- forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
  a
x  <- Parser a
p
  SourcePos
p2 <- forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
  forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, SourcePos -> SourcePos -> SourceSpan
SS SourcePos
p1 SourcePos
p2)

--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
elsa :: Parser SElsa
elsa :: Parser SElsa
elsa = forall a. [Defn a] -> [Eval a] -> Elsa a
Elsa forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser SDefn
defn forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser (Eval SourceSpan)
eval

defn :: Parser SDefn
defn :: Parser SDefn
defn = do
  Text -> Parser SourceSpan
rWord Text
"let"
  SBind
b <- Parser SBind
binder forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text
equal
  SExpr
e <- Parser SExpr
expr
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Bind a -> Expr a -> Defn a
Defn SBind
b SExpr
e)

eval :: Parser SEval
eval :: Parser (Eval SourceSpan)
eval = do
  Text -> Parser SourceSpan
rWord Text
"eval"
  SBind
name  <- Parser SBind
binder
  Parser Text
colon
  SExpr
root  <- Parser SExpr
expr
  [SStep]
steps <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser SStep
step
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Bind a -> Expr a -> [Step a] -> Eval a
Eval SBind
name SExpr
root [SStep]
steps

step :: Parser SStep
step :: Parser SStep
step = forall a. Eqn a -> Expr a -> Step a
Step forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SEqn
eqn forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser SExpr
expr

eqn :: Parser SEqn
eqn :: Parser SEqn
eqn =  forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (forall a. Parser (SourceSpan -> a) -> Parser a
withSpan' (Text -> Parser Text
symbol Text
"=a>" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> Eqn a
AlphEq))
   forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (forall a. Parser (SourceSpan -> a) -> Parser a
withSpan' (Text -> Parser Text
symbol Text
"=b>" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> Eqn a
BetaEq))
   forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (forall a. Parser (SourceSpan -> a) -> Parser a
withSpan' (Text -> Parser Text
symbol Text
"<b=" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> Eqn a
UnBeta))
   forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (forall a. Parser (SourceSpan -> a) -> Parser a
withSpan' (Text -> Parser Text
symbol Text
"=d>" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> Eqn a
DefnEq))
   forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (forall a. Parser (SourceSpan -> a) -> Parser a
withSpan' (Text -> Parser Text
symbol Text
"=*>" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> Eqn a
TrnsEq))
   forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (forall a. Parser (SourceSpan -> a) -> Parser a
withSpan' (Text -> Parser Text
symbol Text
"<*=" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> Eqn a
UnTrEq))
   forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>     (forall a. Parser (SourceSpan -> a) -> Parser a
withSpan' (Text -> Parser Text
symbol Text
"=~>" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> Eqn a
NormEq))

expr :: Parser SExpr
expr :: Parser SExpr
expr =  forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser SExpr
lamExpr
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser SExpr
appExpr
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser SExpr
idExpr
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser SExpr
parenExpr

parenExpr :: Parser SExpr
parenExpr :: Parser SExpr
parenExpr = forall a. Parser a -> Parser a
parens Parser SExpr
expr

idExpr :: Parser SExpr
idExpr :: Parser SExpr
idExpr = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Text -> a -> Expr a
EVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Text, SourceSpan)
identifier

appExpr :: Parser SExpr
appExpr :: Parser SExpr
appExpr  = SExpr -> [SExpr] -> SExpr
apps forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SExpr
funExpr forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy1 Parser SExpr
funExpr Parser ()
sc
  where
    apps :: SExpr -> [SExpr] -> SExpr
apps = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' (\SExpr
e1 SExpr
e2 -> forall a. Expr a -> Expr a -> a -> Expr a
EApp SExpr
e1 SExpr
e2 (forall (t :: * -> *) a. Tagged t => t a -> a
tag SExpr
e1 forall a. Monoid a => a -> a -> a
`mappend` forall (t :: * -> *) a. Tagged t => t a -> a
tag SExpr
e2))

funExpr :: Parser SExpr
funExpr :: Parser SExpr
funExpr = forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser SExpr
idExpr forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser SExpr
parenExpr

lamExpr :: Parser SExpr
lamExpr :: Parser SExpr
lamExpr = do
  Parser Text
lam
  [SBind]
xs    <- forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy Parser SBind
binder Parser ()
sc forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text
arrow
  SExpr
e     <- Parser SExpr
expr
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => [Bind a] -> Expr a -> Expr a
mkLam [SBind]
xs SExpr
e)