{-# 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), 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)



-- | 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]
_ 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
  )


-- | TODO: pretty print exceptions
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'


-- * Lexing

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)


-- | 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 -> 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