{-# LANGUAGE
OverloadedStrings
, ConstraintKinds
, DeriveGeneric
, FlexibleContexts
, DataKinds
#-}
module LText.Expr where
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), suchThat, sized, resize, oneof, listOf1)
data Expr
= Abs String Expr
| App Expr Expr
| Var String
| Lit { Expr -> [Text]
litContent :: [LT.Text], Expr -> FilePath
litSource :: FilePath, Expr -> Bool
litInError :: Bool }
| Concat { Expr -> Expr
concatLeft :: Expr, Expr -> Expr
concatRight :: Expr, Expr -> FilePath
concatSource :: FilePath, Expr -> Bool
concatInError :: Bool }
deriving (Int -> Expr -> ShowS
[Expr] -> ShowS
Expr -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Expr] -> ShowS
$cshowList :: [Expr] -> ShowS
show :: Expr -> FilePath
$cshow :: Expr -> FilePath
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)
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]
_ FilePath
_ Bool
_) = Int
1
sizeOfExpr (Var FilePath
_) = Int
1
sizeOfExpr (Abs FilePath
_ 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 FilePath
_ Bool
_) = 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
term :: Gen FilePath
term = forall a. Gen a -> Gen [a]
listOf1 (forall a. Arbitrary a => Gen a
arbitrary forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` 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)
abs' :: Gen Expr
abs' = forall a. (Int -> Gen a) -> Gen a
sized forall a b. (a -> b) -> a -> b
$ \Int
n -> do
FilePath
x <- Gen FilePath
term
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
$ FilePath -> Expr -> Expr
Abs FilePath
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
FilePath
x <- Gen FilePath
term
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FilePath -> Expr
Var FilePath
x
shrink :: Expr -> [Expr]
shrink (Lit [Text]
_ FilePath
_ Bool
_) = []
shrink (Var FilePath
_) = []
shrink (Abs FilePath
_ Expr
e) = [Expr
e]
shrink (App Expr
e1 Expr
e2) = [Expr
e1,Expr
e2]
shrink (Concat Expr
e1 Expr
e2 FilePath
_ Bool
_) = [Expr
e1,Expr
e2]
type MonadPrettyPrint m =
( MonadThrow m
, MonadIO m
)
ppExpr :: MonadPrettyPrint m => Expr -> m String
ppExpr :: forall (m :: * -> *). MonadPrettyPrint m => Expr -> m FilePath
ppExpr Expr
e = Doc -> FilePath
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 FilePath
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.<> FilePath -> Doc
text FilePath
x) Doc -> Doc -> Doc
<+> FilePath -> Doc
text FilePath
"->"
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 FilePath
x) Doc
e'''
App Expr
e1 Expr
e2 ->
let e1Hat :: m Doc
e1Hat = case Expr
e1 of
Abs FilePath
_ 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 FilePath
_ 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 FilePath
x ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FilePath -> Doc
text FilePath
x
Lit [Text]
_ FilePath
source Bool
True ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Doc
text forall a b. (a -> b) -> a -> b
$ FilePath
"[text from \"" forall a. [a] -> [a] -> [a]
++ FilePath
source forall a. [a] -> [a] -> [a]
++ FilePath
"\"]"
Lit [Text]
x FilePath
_ Bool
_ ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
LT.unpack forall a b. (a -> b) -> a -> b
$ [Text] -> Text
LT.unlines [Text]
x
Concat Expr
_ Expr
_ FilePath
source Bool
True ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Doc
text forall a b. (a -> b) -> a -> b
$ FilePath
"[text from \"" forall a. [a] -> [a] -> [a]
++ FilePath
source forall a. [a] -> [a] -> [a]
++ FilePath
"\"]"
Concat Expr
x Expr
y FilePath
_ Bool
_ ->
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 -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ScopeUse] -> ShowS
$cshowList :: [ScopeUse] -> ShowS
show :: ScopeUse -> FilePath
$cshow :: ScopeUse -> FilePath
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 -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ParseState] -> ShowS
$cshowList :: [ParseState] -> ShowS
show :: ParseState -> FilePath
$cshow :: ParseState -> FilePath
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 -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ParseError] -> ShowS
$cshowList :: [ParseError] -> ShowS
show :: ParseError -> FilePath
$cshow :: ParseError -> FilePath
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 -> FilePath -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$
case ParseError
e of
BracketsInsideLambda [Lexeme]
ls ->
FilePath
"[Parse Error] Brackets are inside a lambda declaration,\
\ with trailing token stream: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show [Lexeme]
ls
LambdaInsideLambda [Lexeme]
ls ->
FilePath
"[Parse Error] A lambda is inside a lambda declaration,\
\ with trailing token stream: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show [Lexeme]
ls
LambdaInStaleScope [Lexeme]
ls Expr
e' ->
FilePath
"[Parse Error] A lambda is inside a stale scope,\
\ with trailing token stream: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show [Lexeme]
ls forall a. [a] -> [a] -> [a]
++ FilePath
" and parse state " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Expr
e'
ArrowWithoutLambda [Lexeme]
ls ->
FilePath
"[Parse Error] An arrow was found without a preceding lambda,\
\ with trailing token stream: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show [Lexeme]
ls
ArrowInScope [Lexeme]
ls ->
FilePath
"[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 -> FilePath
show [Lexeme]
ls
ParseError
EmptyExpression ->
FilePath
"[Parse Error] Empty expression"
LexerError FilePath
err ->
FilePath
"[Lexer Error] " forall a. [a] -> [a] -> [a]
++ FilePath
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 FilePath a
parseOnly Parser [Lexeme]
lex Text
t of
Left FilePath
err -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ FilePath -> ParseError
LexerError FilePath
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 FilePath
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
$ FilePath -> Expr -> Expr
Abs FilePath
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
$ FilePath -> Expr
Var FilePath
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
$ FilePath -> Expr
Var FilePath
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'
data Lexeme
= Lambda
| Arrow
| Ident String
| Bracketed { Lexeme -> [Lexeme]
getBracketed :: [Lexeme] }
deriving (Int -> Lexeme -> ShowS
[Lexeme] -> ShowS
Lexeme -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Lexeme] -> ShowS
$cshowList :: [Lexeme] -> ShowS
show :: Lexeme -> FilePath
$cshow :: Lexeme -> FilePath
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)
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 -> FilePath -> Parser i a
<?> FilePath
"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 -> FilePath -> Parser i a
<?> FilePath
"arrow"
ident :: Parser Lexeme
ident :: Parser Text Lexeme
ident = do
Parser ()
skipSpace
FilePath -> 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 -> FilePath -> Parser i a
<?> FilePath
"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 -> FilePath -> Parser i a
<?> FilePath
"right paren"
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Lexeme] -> Lexeme
Bracketed [Lexeme]
ls