{-# LANGUAGE
    OverloadedStrings
  , ConstraintKinds
  , DeriveGeneric
  , FlexibleContexts
  , DataKinds
  #-}

module LText.Expr where

{-
Represents the expression usable from the command line, and within
a delimitation.
-}

import Prelude hiding (lex)
import Data.Attoparsec.Text
import Data.Text as T (Text)
import qualified Data.Text.Lazy as LT
import Data.Char (isPunctuation, isSymbol, isAlphaNum)
import Text.PrettyPrint (Doc, parens, text, (<+>), nest, ($$), render)
import qualified Text.PrettyPrint as PP

import Control.Applicative ((<|>), many)
import Control.Monad (void)
import Control.Monad.Catch (Exception, MonadThrow, throwM)
import Control.Monad.State (StateT, MonadState, put, get, evalStateT)
import Control.Monad.IO.Class (MonadIO)

import GHC.Generics (Generic)
import System.IO (stderr, hPutStrLn)
import System.Exit (exitFailure)

import Test.QuickCheck (Arbitrary (arbitrary, shrink), Gen, suchThat, sized, resize, oneof)
import Test.QuickCheck.Combinators (Between (..))



data Expr
  = Abs String Expr
  | App Expr Expr
  | Var String
  | Lit [LT.Text]
  | Concat Expr Expr
  deriving (Int -> Expr -> ShowS
[Expr] -> ShowS
Expr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Expr] -> ShowS
$cshowList :: [Expr] -> ShowS
show :: Expr -> String
$cshow :: Expr -> String
showsPrec :: Int -> Expr -> ShowS
$cshowsPrec :: Int -> Expr -> ShowS
Show, Expr -> Expr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Expr -> Expr -> Bool
$c/= :: Expr -> Expr -> Bool
== :: Expr -> Expr -> Bool
$c== :: Expr -> Expr -> Bool
Eq)



-- | Only considers Abs, App and Var
instance Arbitrary Expr where
  arbitrary :: Gen Expr
arbitrary = forall a. (Int -> Gen a) -> Gen a
sized forall a b. (a -> b) -> a -> b
$ \Int
n ->
    if Int
n forall a. Ord a => a -> a -> Bool
<= Int
1
    then Gen Expr
var
    else forall a. Int -> Gen a -> Gen a
resize (Int
nforall a. Num a => a -> a -> a
-Int
1) (forall a. [Gen a] -> Gen a
oneof [Gen Expr
abs', Gen Expr
app, Gen Expr
var]) forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (\Expr
e -> Expr -> Int
sizeOfExpr Expr
e forall a. Ord a => a -> a -> Bool
<= Int
10)
    where
      sizeOfExpr :: Expr -> Int
      sizeOfExpr :: Expr -> Int
sizeOfExpr (Lit [Text]
_) = Int
1
      sizeOfExpr (Var String
_) = Int
1
      sizeOfExpr (Abs String
_ Expr
e) = Int
1 forall a. Num a => a -> a -> a
+ Expr -> Int
sizeOfExpr Expr
e
      sizeOfExpr (App Expr
e1 Expr
e2) = Int
1 forall a. Num a => a -> a -> a
+ Expr -> Int
sizeOfExpr Expr
e1 forall a. Num a => a -> a -> a
+ Expr -> Int
sizeOfExpr Expr
e2
      sizeOfExpr (Concat Expr
e1 Expr
e2) = Int
1 forall a. Num a => a -> a -> a
+ Expr -> Int
sizeOfExpr Expr
e1 forall a. Num a => a -> a -> a
+ Expr -> Int
sizeOfExpr Expr
e2

      isFilename :: Char -> Bool
isFilename Char
c = Char
c forall a. Eq a => a -> a -> Bool
/= Char
'\\'
                  Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
'('
                  Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
')'
                  Bool -> Bool -> Bool
&& (Char -> Bool
isAlphaNum Char
c
                  Bool -> Bool -> Bool
|| Char -> Bool
isSymbol Char
c
                  Bool -> Bool -> Bool
|| Char -> Bool
isPunctuation Char
c)
      abs' :: Gen Expr
abs' = forall a. (Int -> Gen a) -> Gen a
sized forall a b. (a -> b) -> a -> b
$ \Int
n -> do
        (Between String
x) <- forall a. Arbitrary a => Gen a
arbitrary forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (\(Between String
x') -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isFilename String
x')
                       :: Gen (Between 1 5 [] Char)
        Expr
e <- forall a. Int -> Gen a -> Gen a
resize (Int
nforall a. Num a => a -> a -> a
-Int
1) forall a. Arbitrary a => Gen a
arbitrary
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> Expr -> Expr
Abs String
x Expr
e
      app :: Gen Expr
app = forall a. (Int -> Gen a) -> Gen a
sized forall a b. (a -> b) -> a -> b
$ \Int
n -> do
        Expr
e1 <- forall a. Int -> Gen a -> Gen a
resize (Int
nforall a. Num a => a -> a -> a
-Int
1) forall a. Arbitrary a => Gen a
arbitrary
        Expr
e2 <- forall a. Int -> Gen a -> Gen a
resize (Int
nforall a. Num a => a -> a -> a
-Int
1) forall a. Arbitrary a => Gen a
arbitrary
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Expr -> Expr -> Expr
App Expr
e1 Expr
e2
      var :: Gen Expr
var = do
        (Between String
x) <- forall a. Arbitrary a => Gen a
arbitrary forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (\(Between String
x') -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isFilename String
x')
                       :: Gen (Between 1 5 [] Char)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> Expr
Var String
x

  shrink :: Expr -> [Expr]
shrink (Lit [Text]
_)        = []
  shrink (Var String
_)        = []
  shrink (Abs String
_ Expr
e)      = [Expr
e]
  shrink (App Expr
e1 Expr
e2)    = [Expr
e1,Expr
e2]
  shrink (Concat Expr
e1 Expr
e2) = [Expr
e1,Expr
e2]



type MonadPrettyPrint m =
  ( MonadThrow m
  , MonadIO m
  )


-- | TODO: pretty print exceptions
ppExpr :: MonadPrettyPrint m => Expr -> m String
ppExpr :: forall (m :: * -> *). MonadPrettyPrint m => Expr -> m String
ppExpr Expr
e = Doc -> String
render forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadPrettyPrint m => Expr -> m Doc
go Expr
e
  where
    go :: MonadPrettyPrint m => Expr -> m Doc
    go :: forall (m :: * -> *). MonadPrettyPrint m => Expr -> m Doc
go Expr
e' =
      case Expr
e' of
        Abs String
x Expr
e'' -> do
          Doc
e''' <- forall (m :: * -> *). MonadPrettyPrint m => Expr -> m Doc
go Expr
e''
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (Char -> Doc
PP.char Char
'\\' Doc -> Doc -> Doc
PP.<> String -> Doc
text String
x) Doc -> Doc -> Doc
<+> String -> Doc
text String
"->"
                              Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest (Int
5 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length String
x) Doc
e'''
        App Expr
e1 Expr
e2 ->
          let e1Hat :: m Doc
e1Hat = case Expr
e1 of
                Abs String
_ Expr
_ -> Doc -> Doc
parens forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadPrettyPrint m => Expr -> m Doc
go Expr
e1
                Expr
_       -> forall (m :: * -> *). MonadPrettyPrint m => Expr -> m Doc
go Expr
e1
              e2Hat :: m Doc
e2Hat = case Expr
e2 of
                Abs String
_ Expr
_ -> Doc -> Doc
parens forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadPrettyPrint m => Expr -> m Doc
go Expr
e2
                App Expr
_ Expr
_ -> Doc -> Doc
parens forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadPrettyPrint m => Expr -> m Doc
go Expr
e2
                Expr
_       -> forall (m :: * -> *). MonadPrettyPrint m => Expr -> m Doc
go Expr
e2
          in  Doc -> Doc -> Doc
(<+>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Doc
e1Hat forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Doc
e2Hat
        Var String
x ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
x
        Lit [Text]
x ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
LT.unpack forall a b. (a -> b) -> a -> b
$ [Text] -> Text
LT.unlines [Text]
x
        Concat Expr
x Expr
y ->
          Doc -> Doc -> Doc
(<+>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadPrettyPrint m => Expr -> m Doc
go Expr
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). MonadPrettyPrint m => Expr -> m Doc
go Expr
y


data ScopeUse = Fresh | Stale Expr
  deriving (Int -> ScopeUse -> ShowS
[ScopeUse] -> ShowS
ScopeUse -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScopeUse] -> ShowS
$cshowList :: [ScopeUse] -> ShowS
show :: ScopeUse -> String
$cshow :: ScopeUse -> String
showsPrec :: Int -> ScopeUse -> ShowS
$cshowsPrec :: Int -> ScopeUse -> ShowS
Show, ScopeUse -> ScopeUse -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScopeUse -> ScopeUse -> Bool
$c/= :: ScopeUse -> ScopeUse -> Bool
== :: ScopeUse -> ScopeUse -> Bool
$c== :: ScopeUse -> ScopeUse -> Bool
Eq)

data ParseState
  = InsideLambda   -- ^ \..->
  | Scope ScopeUse -- ^ (..)
  deriving (Int -> ParseState -> ShowS
[ParseState] -> ShowS
ParseState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParseState] -> ShowS
$cshowList :: [ParseState] -> ShowS
show :: ParseState -> String
$cshow :: ParseState -> String
showsPrec :: Int -> ParseState -> ShowS
$cshowsPrec :: Int -> ParseState -> ShowS
Show, ParseState -> ParseState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParseState -> ParseState -> Bool
$c/= :: ParseState -> ParseState -> Bool
== :: ParseState -> ParseState -> Bool
$c== :: ParseState -> ParseState -> Bool
Eq)

initParseState :: ParseState
initParseState :: ParseState
initParseState = ScopeUse -> ParseState
Scope ScopeUse
Fresh

data ParseError
  = BracketsInsideLambda [Lexeme]
  | LambdaInsideLambda   [Lexeme]
  | LambdaInStaleScope   [Lexeme] Expr
  | ArrowWithoutLambda   [Lexeme]
  | ArrowInScope         [Lexeme]
  | EmptyExpression
  | LexerError String
  deriving (Int -> ParseError -> ShowS
[ParseError] -> ShowS
ParseError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParseError] -> ShowS
$cshowList :: [ParseError] -> ShowS
show :: ParseError -> String
$cshow :: ParseError -> String
showsPrec :: Int -> ParseError -> ShowS
$cshowsPrec :: Int -> ParseError -> ShowS
Show, ParseError -> ParseError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParseError -> ParseError -> Bool
$c/= :: ParseError -> ParseError -> Bool
== :: ParseError -> ParseError -> Bool
$c== :: ParseError -> ParseError -> Bool
Eq, forall x. Rep ParseError x -> ParseError
forall x. ParseError -> Rep ParseError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ParseError x -> ParseError
$cfrom :: forall x. ParseError -> Rep ParseError x
Generic)

instance Exception ParseError

handleParseError :: ParseError -> IO a
handleParseError :: forall a. ParseError -> IO a
handleParseError ParseError
e = do
  Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$
    case ParseError
e of
      BracketsInsideLambda [Lexeme]
ls ->
        String
"[Parse Error] Brackets are inside a lambda declaration,\
        \ with trailing token stream: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Lexeme]
ls
      LambdaInsideLambda [Lexeme]
ls ->
        String
"[Parse Error] A lambda is inside a lambda declaration,\
        \ with trailing token stream: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Lexeme]
ls
      LambdaInStaleScope [Lexeme]
ls Expr
e' ->
        String
"[Parse Error] A lambda is inside a stale scope,\
        \ with trailing token stream: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Lexeme]
ls forall a. [a] -> [a] -> [a]
++ String
" and parse state " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Expr
e'
      ArrowWithoutLambda [Lexeme]
ls ->
        String
"[Parse Error] An arrow was found without a preceding lambda,\
        \ with trailing token stream: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Lexeme]
ls
      ArrowInScope [Lexeme]
ls ->
        String
"[Parse Error] An arrow alone was found inside a function body,\
        \ with trailing token stream: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Lexeme]
ls
      ParseError
EmptyExpression ->
        String
"[Parse Error] Empty expression"
      LexerError String
err ->
        String
"[Lexer Error] " forall a. [a] -> [a] -> [a]
++ String
err
  forall a. IO a
exitFailure


type MonadParse m =
  ( MonadState ParseState m
  , MonadThrow m
  , MonadIO m
  )

runParse :: Text -> IO Expr
runParse :: Text -> IO Expr
runParse = forall a. StateT ParseState IO a -> IO a
runParserT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadParse m => Text -> m Expr
parseExpr


runParserT :: StateT ParseState IO a -> IO a
runParserT :: forall a. StateT ParseState IO a -> IO a
runParserT StateT ParseState IO a
xs = forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT ParseState IO a
xs ParseState
initParseState


parseExpr :: MonadParse m => Text -> m Expr
parseExpr :: forall (m :: * -> *). MonadParse m => Text -> m Expr
parseExpr Text
t =
  case forall a. Parser a -> Text -> Either String a
parseOnly Parser [Lexeme]
lex Text
t of
    Left String
err -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> ParseError
LexerError String
err
    Right [Lexeme]
ls -> forall (m :: * -> *). MonadParse m => [Lexeme] -> m Expr
expr [Lexeme]
ls




expr :: MonadParse m => [Lexeme] -> m Expr
expr :: forall (m :: * -> *). MonadParse m => [Lexeme] -> m Expr
expr [Lexeme]
ls =
  case [Lexeme]
ls of
    [] -> do
      ParseState
s <- forall s (m :: * -> *). MonadState s m => m s
get
      case ParseState
s of
        Scope (Stale Expr
e) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Expr
e
        ParseState
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ParseError
EmptyExpression
    (Lexeme
Lambda:[Lexeme]
ls') -> do
      ParseState
s <- forall s (m :: * -> *). MonadState s m => m s
get
      case ParseState
s of
        ParseState
InsideLambda    -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Lexeme] -> ParseError
LambdaInsideLambda forall a b. (a -> b) -> a -> b
$ Lexeme
Lambda forall a. a -> [a] -> [a]
: [Lexeme]
ls'
        Scope (Stale Expr
e) -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ [Lexeme] -> Expr -> ParseError
LambdaInStaleScope (Lexeme
Lambda forall a. a -> [a] -> [a]
: [Lexeme]
ls') Expr
e
        Scope ScopeUse
Fresh     -> do
          forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
InsideLambda
          forall (m :: * -> *). MonadParse m => [Lexeme] -> m Expr
expr [Lexeme]
ls'
    (Lexeme
Arrow:[Lexeme]
ls') -> do
      ParseState
s <- forall s (m :: * -> *). MonadState s m => m s
get
      case ParseState
s of
        Scope ScopeUse
_      -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Lexeme] -> ParseError
ArrowInScope forall a b. (a -> b) -> a -> b
$ Lexeme
Arrow forall a. a -> [a] -> [a]
: [Lexeme]
ls'
        ParseState
InsideLambda -> do
          forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ ScopeUse -> ParseState
Scope ScopeUse
Fresh
          forall (m :: * -> *). MonadParse m => [Lexeme] -> m Expr
expr [Lexeme]
ls'
    (Ident String
x:[Lexeme]
ls') -> do
      ParseState
s <- forall s (m :: * -> *). MonadState s m => m s
get
      case ParseState
s of
        ParseState
InsideLambda -> do
          Expr
e <- forall (m :: * -> *). MonadParse m => [Lexeme] -> m Expr
expr [Lexeme]
ls'
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> Expr -> Expr
Abs String
x Expr
e
        Scope ScopeUse
Fresh -> do
          forall s (m :: * -> *). MonadState s m => s -> m ()
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScopeUse -> ParseState
Scope forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> ScopeUse
Stale forall a b. (a -> b) -> a -> b
$ String -> Expr
Var String
x
          forall (m :: * -> *). MonadParse m => [Lexeme] -> m Expr
expr [Lexeme]
ls'
        Scope (Stale Expr
f) -> do
          forall s (m :: * -> *). MonadState s m => s -> m ()
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScopeUse -> ParseState
Scope forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> ScopeUse
Stale forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Expr -> Expr
App Expr
f forall a b. (a -> b) -> a -> b
$ String -> Expr
Var String
x
          forall (m :: * -> *). MonadParse m => [Lexeme] -> m Expr
expr [Lexeme]
ls'
    (Bracketed [Lexeme]
bs:[Lexeme]
ls') -> do
      ParseState
s <- forall s (m :: * -> *). MonadState s m => m s
get
      case ParseState
s of
        ParseState
InsideLambda -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Lexeme] -> ParseError
BracketsInsideLambda forall a b. (a -> b) -> a -> b
$ [Lexeme] -> Lexeme
Bracketed [Lexeme]
bs forall a. a -> [a] -> [a]
: [Lexeme]
ls'
        Scope ScopeUse
Fresh  -> do
          Expr
e <- forall (m :: * -> *). MonadParse m => [Lexeme] -> m Expr
expr [Lexeme]
bs
          forall s (m :: * -> *). MonadState s m => s -> m ()
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScopeUse -> ParseState
Scope forall a b. (a -> b) -> a -> b
$ Expr -> ScopeUse
Stale Expr
e
          forall (m :: * -> *). MonadParse m => [Lexeme] -> m Expr
expr [Lexeme]
ls'
        Scope (Stale Expr
f) -> do
          forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ ScopeUse -> ParseState
Scope ScopeUse
Fresh
          Expr
e <- forall (m :: * -> *). MonadParse m => [Lexeme] -> m Expr
expr [Lexeme]
bs
          forall s (m :: * -> *). MonadState s m => s -> m ()
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScopeUse -> ParseState
Scope forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> ScopeUse
Stale forall a b. (a -> b) -> a -> b
$ Expr -> Expr -> Expr
App Expr
f Expr
e
          forall (m :: * -> *). MonadParse m => [Lexeme] -> m Expr
expr [Lexeme]
ls'


-- * Lexing

data Lexeme
  = Lambda
  | Arrow
  | Ident String
  | Bracketed { Lexeme -> [Lexeme]
getBracketed :: [Lexeme] }
  deriving (Int -> Lexeme -> ShowS
[Lexeme] -> ShowS
Lexeme -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Lexeme] -> ShowS
$cshowList :: [Lexeme] -> ShowS
show :: Lexeme -> String
$cshow :: Lexeme -> String
showsPrec :: Int -> Lexeme -> ShowS
$cshowsPrec :: Int -> Lexeme -> ShowS
Show, Lexeme -> Lexeme -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Lexeme -> Lexeme -> Bool
$c/= :: Lexeme -> Lexeme -> Bool
== :: Lexeme -> Lexeme -> Bool
$c== :: Lexeme -> Lexeme -> Bool
Eq)


-- | Expects to be wrapped in parens
lex :: Parser [Lexeme]
lex :: Parser [Lexeme]
lex = forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser Text Lexeme
lambda forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Lexeme
arrow forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Lexeme
bracketed forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Lexeme
ident)

lambda :: Parser Lexeme
lambda :: Parser Text Lexeme
lambda = do
  Parser ()
skipSpace
  Lexeme
Lambda forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Char
char Char
'\\' forall i a. Parser i a -> String -> Parser i a
<?> String
"lambda"

arrow :: Parser Lexeme
arrow :: Parser Text Lexeme
arrow = do
  Parser ()
skipSpace
  Lexeme
Arrow forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
string Text
"->" forall i a. Parser i a -> String -> Parser i a
<?> String
"arrow"

ident :: Parser Lexeme
ident :: Parser Text Lexeme
ident = do
  Parser ()
skipSpace
  String -> Lexeme
Ident forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many1 ((Char -> Bool) -> Parser Char
satisfy Char -> Bool
isFilename)
  where
    isFilename :: Char -> Bool
isFilename Char
c = Char
c forall a. Eq a => a -> a -> Bool
/= Char
'\\'
                Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
'('
                Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
')'
                Bool -> Bool -> Bool
&& (Char -> Bool
isAlphaNum Char
c
                Bool -> Bool -> Bool
|| Char -> Bool
isSymbol Char
c
                Bool -> Bool -> Bool
|| Char -> Bool
isPunctuation Char
c)

bracketed :: Parser Lexeme
bracketed :: Parser Text Lexeme
bracketed  = do
  Parser ()
skipSpace
  forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> Parser Char
char Char
'(') forall i a. Parser i a -> String -> Parser i a
<?> String
"left paren"
  [Lexeme]
ls <- Parser [Lexeme]
lex
  Parser ()
skipSpace
  forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> Parser Char
char Char
')') forall i a. Parser i a -> String -> Parser i a
<?> String
"right paren"
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Lexeme] -> Lexeme
Bracketed [Lexeme]
ls