{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

module Lang.Crucible.Syntax.ExprParse
  ( SyntaxParse
  , syntaxParseIO

  -- * Errors
  , SyntaxError(..)
  , printSyntaxError

  -- * Testing utilities
  , TrivialAtom(..)
  , test
  ) where

import Control.Applicative
import Control.Lens hiding (List, cons, backwards)
import Control.Monad (MonadPlus(..), ap)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Reader (MonadReader(..), ReaderT(..))
import qualified Control.Monad.State.Strict as Strict

import Data.Foldable as Foldable
import Data.List
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty (NonEmpty(..))
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T

import GHC.Stack

import Lang.Crucible.Syntax.SExpr

import qualified Text.Megaparsec as MP

import Lang.Crucible.Syntax.Monad

data Search a = Try a (Search a) | Fail | Cut
  deriving (forall a b. (a -> b) -> Search a -> Search b)
-> (forall a b. a -> Search b -> Search a) -> Functor Search
forall a b. a -> Search b -> Search a
forall a b. (a -> b) -> Search a -> Search b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Search a -> Search b
fmap :: forall a b. (a -> b) -> Search a -> Search b
$c<$ :: forall a b. a -> Search b -> Search a
<$ :: forall a b. a -> Search b -> Search a
Functor

instance Applicative Search where
  pure :: forall a. a -> Search a
pure a
x = a -> Search a -> Search a
forall a. a -> Search a -> Search a
Try a
x Search a
forall a. Search a
Fail
  <*> :: forall a b. Search (a -> b) -> Search a -> Search b
(<*>) = Search (a -> b) -> Search a -> Search b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Alternative Search where
  empty :: forall a. Search a
empty = Search a
forall a. Search a
Fail
  Search a
x <|> :: forall a. Search a -> Search a -> Search a
<|> Search a
y =
    case Search a
x of
      Try a
first Search a
rest -> a -> Search a -> Search a
forall a. a -> Search a -> Search a
Try a
first (Search a
rest Search a -> Search a -> Search a
forall a. Search a -> Search a -> Search a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Search a
y)
      Search a
Fail -> Search a
y
      Search a
Cut -> Search a
forall a. Search a
Cut

instance Monad Search where
  Search a
m >>= :: forall a b. Search a -> (a -> Search b) -> Search b
>>= a -> Search b
f =
    case Search a
m of
      Try a
x Search a
more -> a -> Search b
f a
x Search b -> Search b -> Search b
forall a. Search a -> Search a -> Search a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Search a
more Search a -> (a -> Search b) -> Search b
forall a b. Search a -> (a -> Search b) -> Search b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Search b
f)
      Search a
Fail -> Search b
forall a. Search a
Fail
      Search a
Cut -> Search b
forall a. Search a
Fail

instance MonadPlus Search where
  mzero :: forall a. Search a
mzero = Search a
forall a. Search a
forall (f :: * -> *) a. Alternative f => f a
empty
  mplus :: forall a. Search a -> Search a -> Search a
mplus = Search a -> Search a -> Search a
forall a. Search a -> Search a -> Search a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

instance Semigroup (Search a) where
  <> :: Search a -> Search a -> Search a
(<>) = Search a -> Search a -> Search a
forall a. Search a -> Search a -> Search a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

instance Monoid (Search a) where
  mempty :: Search a
mempty  = Search a
forall a. Search a
forall (f :: * -> *) a. Alternative f => f a
empty

instance Foldable Search where
  foldMap :: forall m a. Monoid m => (a -> m) -> Search a -> m
foldMap a -> m
f (Try a
x Search a
xs) = a -> m
f a
x m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` (a -> m) -> Search a -> m
forall m a. Monoid m => (a -> m) -> Search a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Search a
xs
  foldMap a -> m
_ Search a
_ = m
forall a. Monoid a => a
mempty

  toList :: forall a. Search a -> [a]
toList (Try a
x Search a
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Search a -> [a]
forall a. Search a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Search a
xs
  toList Search a
_          = []

instance Traversable Search where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Search a -> f (Search b)
traverse a -> f b
f (Try a
x Search a
xs) = b -> Search b -> Search b
forall a. a -> Search a -> Search a
Try (b -> Search b -> Search b) -> f b -> f (Search b -> Search b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
x f (Search b -> Search b) -> f (Search b) -> f (Search b)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (a -> f b) -> Search a -> f (Search b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Search a -> f (Search b)
traverse a -> f b
f Search a
xs
  traverse a -> f b
_ Search a
Fail = Search b -> f (Search b)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Search b
forall a. Search a
Fail
  traverse a -> f b
_ Search a
Cut = Search b -> f (Search b)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Search b
forall a. Search a
Cut

delimitSearch :: Search a -> Search a
delimitSearch :: forall a. Search a -> Search a
delimitSearch (Try a
first Search a
rest) = a -> Search a -> Search a
forall a. a -> Search a -> Search a
Try a
first (Search a -> Search a) -> Search a -> Search a
forall a b. (a -> b) -> a -> b
$ Search a -> Search a
forall a. Search a -> Search a
delimitSearch Search a
rest
delimitSearch Search a
Fail = Search a
forall a. Search a
Fail
delimitSearch Search a
Cut = Search a
forall a. Search a
Fail

cutSearch :: Search a
cutSearch :: forall a. Search a
cutSearch = Search a
forall a. Search a
Cut

data Failure atom = Ok | Oops Progress (NonEmpty (Reason atom))
  deriving ((forall a b. (a -> b) -> Failure a -> Failure b)
-> (forall a b. a -> Failure b -> Failure a) -> Functor Failure
forall a b. a -> Failure b -> Failure a
forall a b. (a -> b) -> Failure a -> Failure b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Failure a -> Failure b
fmap :: forall a b. (a -> b) -> Failure a -> Failure b
$c<$ :: forall a b. a -> Failure b -> Failure a
<$ :: forall a b. a -> Failure b -> Failure a
Functor, Int -> Failure atom -> ShowS
[Failure atom] -> ShowS
Failure atom -> String
(Int -> Failure atom -> ShowS)
-> (Failure atom -> String)
-> ([Failure atom] -> ShowS)
-> Show (Failure atom)
forall atom. Show atom => Int -> Failure atom -> ShowS
forall atom. Show atom => [Failure atom] -> ShowS
forall atom. Show atom => Failure atom -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall atom. Show atom => Int -> Failure atom -> ShowS
showsPrec :: Int -> Failure atom -> ShowS
$cshow :: forall atom. Show atom => Failure atom -> String
show :: Failure atom -> String
$cshowList :: forall atom. Show atom => [Failure atom] -> ShowS
showList :: [Failure atom] -> ShowS
Show)

instance Semigroup (Failure atom) where
  Failure atom
Ok              <> :: Failure atom -> Failure atom -> Failure atom
<> Failure atom
e2 = Failure atom
e2
  e1 :: Failure atom
e1@(Oops Progress
_ NonEmpty (Reason atom)
_)   <> Failure atom
Ok = Failure atom
e1
  e1 :: Failure atom
e1@(Oops Progress
p1 NonEmpty (Reason atom)
r1) <> e2 :: Failure atom
e2@(Oops Progress
p2 NonEmpty (Reason atom)
r2) =
    case Progress -> Progress -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Progress
p1 Progress
p2 of
      Ordering
LT -> Failure atom
e2
      Ordering
GT -> Failure atom
e1
      Ordering
EQ -> Progress -> NonEmpty (Reason atom) -> Failure atom
forall atom. Progress -> NonEmpty (Reason atom) -> Failure atom
Oops Progress
p1 (NonEmpty (Reason atom)
r1 NonEmpty (Reason atom)
-> NonEmpty (Reason atom) -> NonEmpty (Reason atom)
forall a. Semigroup a => a -> a -> a
<> NonEmpty (Reason atom)
r2)

instance Monoid (Failure atom) where
  mempty :: Failure atom
mempty = Failure atom
forall atom. Failure atom
Ok

data P atom a = P { forall atom a. P atom a -> Search a
_success :: Search a
                  , forall atom a. P atom a -> Failure atom
_failure :: Failure atom
                  }
  deriving (forall a b. (a -> b) -> P atom a -> P atom b)
-> (forall a b. a -> P atom b -> P atom a) -> Functor (P atom)
forall a b. a -> P atom b -> P atom a
forall a b. (a -> b) -> P atom a -> P atom b
forall atom a b. a -> P atom b -> P atom a
forall atom a b. (a -> b) -> P atom a -> P atom b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall atom a b. (a -> b) -> P atom a -> P atom b
fmap :: forall a b. (a -> b) -> P atom a -> P atom b
$c<$ :: forall atom a b. a -> P atom b -> P atom a
<$ :: forall a b. a -> P atom b -> P atom a
Functor

instance Semigroup (P atom a) where
  P Search a
s1 Failure atom
f1 <> :: P atom a -> P atom a -> P atom a
<> P Search a
s2 Failure atom
f2 = Search a -> Failure atom -> P atom a
forall atom a. Search a -> Failure atom -> P atom a
P (Search a
s1 Search a -> Search a -> Search a
forall a. Semigroup a => a -> a -> a
<> Search a
s2) (Failure atom
f1 Failure atom -> Failure atom -> Failure atom
forall a. Semigroup a => a -> a -> a
<> Failure atom
f2)

instance Monoid (P atom a) where
  mempty :: P atom a
mempty = Search a -> Failure atom -> P atom a
forall atom a. Search a -> Failure atom -> P atom a
P Search a
forall a. Monoid a => a
mempty Failure atom
forall a. Monoid a => a
mempty

instance Applicative (P atom) where
  pure :: forall a. a -> P atom a
pure a
x = Search a -> Failure atom -> P atom a
forall atom a. Search a -> Failure atom -> P atom a
P (a -> Search a
forall a. a -> Search a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x) Failure atom
forall a. Monoid a => a
mempty
  P atom (a -> b)
f <*> :: forall a b. P atom (a -> b) -> P atom a -> P atom b
<*> P atom a
x = P atom (a -> b) -> P atom a -> P atom b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap P atom (a -> b)
f P atom a
x

instance Alternative (P atom) where
  empty :: forall a. P atom a
empty = P atom a
forall a. Monoid a => a
mempty
  <|> :: forall a. P atom a -> P atom a -> P atom a
(<|>) = P atom a -> P atom a -> P atom a
forall a. Monoid a => a -> a -> a
mappend

instance Monad (P atom) where
  (P Search a
xs Failure atom
e) >>= :: forall a b. P atom a -> (a -> P atom b) -> P atom b
>>= a -> P atom b
f = P atom b -> P atom b -> P atom b
forall a. Monoid a => a -> a -> a
mappend ((a -> P atom b) -> Search a -> P atom b
forall m a. Monoid m => (a -> m) -> Search a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> P atom b
f Search a
xs) (Search b -> Failure atom -> P atom b
forall atom a. Search a -> Failure atom -> P atom a
P Search b
forall a. Search a
forall (f :: * -> *) a. Alternative f => f a
empty Failure atom
e)

instance MonadPlus (P atom) where
  mzero :: forall a. P atom a
mzero = P atom a
forall a. P atom a
forall (f :: * -> *) a. Alternative f => f a
empty
  mplus :: forall a. P atom a -> P atom a -> P atom a
mplus = P atom a -> P atom a -> P atom a
forall a. P atom a -> P atom a -> P atom a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

newtype STP atom a = STP { forall atom a. STP atom a -> IO (P atom a)
runSTP :: IO (P atom a) }
  deriving ((forall a b. (a -> b) -> STP atom a -> STP atom b)
-> (forall a b. a -> STP atom b -> STP atom a)
-> Functor (STP atom)
forall a b. a -> STP atom b -> STP atom a
forall a b. (a -> b) -> STP atom a -> STP atom b
forall atom a b. a -> STP atom b -> STP atom a
forall atom a b. (a -> b) -> STP atom a -> STP atom b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall atom a b. (a -> b) -> STP atom a -> STP atom b
fmap :: forall a b. (a -> b) -> STP atom a -> STP atom b
$c<$ :: forall atom a b. a -> STP atom b -> STP atom a
<$ :: forall a b. a -> STP atom b -> STP atom a
Functor, NonEmpty (STP atom a) -> STP atom a
STP atom a -> STP atom a -> STP atom a
(STP atom a -> STP atom a -> STP atom a)
-> (NonEmpty (STP atom a) -> STP atom a)
-> (forall b. Integral b => b -> STP atom a -> STP atom a)
-> Semigroup (STP atom a)
forall b. Integral b => b -> STP atom a -> STP atom a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall atom a. NonEmpty (STP atom a) -> STP atom a
forall atom a. STP atom a -> STP atom a -> STP atom a
forall atom a b. Integral b => b -> STP atom a -> STP atom a
$c<> :: forall atom a. STP atom a -> STP atom a -> STP atom a
<> :: STP atom a -> STP atom a -> STP atom a
$csconcat :: forall atom a. NonEmpty (STP atom a) -> STP atom a
sconcat :: NonEmpty (STP atom a) -> STP atom a
$cstimes :: forall atom a b. Integral b => b -> STP atom a -> STP atom a
stimes :: forall b. Integral b => b -> STP atom a -> STP atom a
Semigroup, Semigroup (STP atom a)
STP atom a
Semigroup (STP atom a) =>
STP atom a
-> (STP atom a -> STP atom a -> STP atom a)
-> ([STP atom a] -> STP atom a)
-> Monoid (STP atom a)
[STP atom a] -> STP atom a
STP atom a -> STP atom a -> STP atom a
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall atom a. Semigroup (STP atom a)
forall atom a. STP atom a
forall atom a. [STP atom a] -> STP atom a
forall atom a. STP atom a -> STP atom a -> STP atom a
$cmempty :: forall atom a. STP atom a
mempty :: STP atom a
$cmappend :: forall atom a. STP atom a -> STP atom a -> STP atom a
mappend :: STP atom a -> STP atom a -> STP atom a
$cmconcat :: forall atom a. [STP atom a] -> STP atom a
mconcat :: [STP atom a] -> STP atom a
Monoid)

instance Applicative (STP atom) where
  pure :: forall a. a -> STP atom a
pure = IO (P atom a) -> STP atom a
forall atom a. IO (P atom a) -> STP atom a
STP (IO (P atom a) -> STP atom a)
-> (a -> IO (P atom a)) -> a -> STP atom a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. P atom a -> IO (P atom a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (P atom a -> IO (P atom a))
-> (a -> P atom a) -> a -> IO (P atom a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> P atom a
forall a. a -> P atom a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  <*> :: forall a b. STP atom (a -> b) -> STP atom a -> STP atom b
(<*>) = STP atom (a -> b) -> STP atom a -> STP atom b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad (STP atom) where
  STP IO (P atom a)
m >>= :: forall a b. STP atom a -> (a -> STP atom b) -> STP atom b
>>= a -> STP atom b
f = IO (P atom b) -> STP atom b
forall atom a. IO (P atom a) -> STP atom a
STP (IO (P atom b) -> STP atom b) -> IO (P atom b) -> STP atom b
forall a b. (a -> b) -> a -> b
$ do
    P Search a
xs Failure atom
e <- IO (P atom a)
m
    IO (P atom b) -> IO (P atom b) -> IO (P atom b)
forall a. Monoid a => a -> a -> a
mappend (STP atom b -> IO (P atom b)
forall atom a. STP atom a -> IO (P atom a)
runSTP ((a -> STP atom b) -> Search a -> STP atom b
forall m a. Monoid m => (a -> m) -> Search a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> STP atom b
f Search a
xs)) (P atom b -> IO (P atom b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (P atom b -> IO (P atom b)) -> P atom b -> IO (P atom b)
forall a b. (a -> b) -> a -> b
$ Search b -> Failure atom -> P atom b
forall atom a. Search a -> Failure atom -> P atom a
P Search b
forall a. Search a
forall (f :: * -> *) a. Alternative f => f a
empty Failure atom
e)

instance MonadIO (STP atom) where
  liftIO :: forall a. IO a -> STP atom a
liftIO IO a
m = IO (P atom a) -> STP atom a
forall atom a. IO (P atom a) -> STP atom a
STP (IO (P atom a) -> STP atom a) -> IO (P atom a) -> STP atom a
forall a b. (a -> b) -> a -> b
$ a -> P atom a
forall a. a -> P atom a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> P atom a) -> IO a -> IO (P atom a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
m

data SyntaxParseCtx atom =
  SyntaxParseCtx { forall atom. SyntaxParseCtx atom -> Progress
_parseProgress :: Progress
                 , forall atom. SyntaxParseCtx atom -> Reason atom
_parseReason :: Reason atom
                 , forall atom. SyntaxParseCtx atom -> Syntax atom
_parseFocus :: Syntax atom
                 }
  deriving Int -> SyntaxParseCtx atom -> ShowS
[SyntaxParseCtx atom] -> ShowS
SyntaxParseCtx atom -> String
(Int -> SyntaxParseCtx atom -> ShowS)
-> (SyntaxParseCtx atom -> String)
-> ([SyntaxParseCtx atom] -> ShowS)
-> Show (SyntaxParseCtx atom)
forall atom. Show atom => Int -> SyntaxParseCtx atom -> ShowS
forall atom. Show atom => [SyntaxParseCtx atom] -> ShowS
forall atom. Show atom => SyntaxParseCtx atom -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall atom. Show atom => Int -> SyntaxParseCtx atom -> ShowS
showsPrec :: Int -> SyntaxParseCtx atom -> ShowS
$cshow :: forall atom. Show atom => SyntaxParseCtx atom -> String
show :: SyntaxParseCtx atom -> String
$cshowList :: forall atom. Show atom => [SyntaxParseCtx atom] -> ShowS
showList :: [SyntaxParseCtx atom] -> ShowS
Show

parseProgress :: Simple Lens (SyntaxParseCtx atom) Progress
parseProgress :: forall atom (f :: * -> *).
Functor f =>
(Progress -> f Progress)
-> SyntaxParseCtx atom -> f (SyntaxParseCtx atom)
parseProgress = (SyntaxParseCtx atom -> Progress)
-> (SyntaxParseCtx atom -> Progress -> SyntaxParseCtx atom)
-> Lens
     (SyntaxParseCtx atom) (SyntaxParseCtx atom) Progress Progress
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens SyntaxParseCtx atom -> Progress
forall atom. SyntaxParseCtx atom -> Progress
_parseProgress (\SyntaxParseCtx atom
s Progress
v -> SyntaxParseCtx atom
s { _parseProgress = v })

parseReason :: Simple Lens (SyntaxParseCtx atom) (Reason atom)
parseReason :: forall atom (f :: * -> *).
Functor f =>
(Reason atom -> f (Reason atom))
-> SyntaxParseCtx atom -> f (SyntaxParseCtx atom)
parseReason = (SyntaxParseCtx atom -> Reason atom)
-> (SyntaxParseCtx atom -> Reason atom -> SyntaxParseCtx atom)
-> Lens
     (SyntaxParseCtx atom)
     (SyntaxParseCtx atom)
     (Reason atom)
     (Reason atom)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens SyntaxParseCtx atom -> Reason atom
forall atom. SyntaxParseCtx atom -> Reason atom
_parseReason (\SyntaxParseCtx atom
s Reason atom
v -> SyntaxParseCtx atom
s { _parseReason = v })

parseFocus :: Simple Lens (SyntaxParseCtx atom) (Syntax atom)
parseFocus :: forall atom (f :: * -> *).
Functor f =>
(Syntax atom -> f (Syntax atom))
-> SyntaxParseCtx atom -> f (SyntaxParseCtx atom)
parseFocus = (SyntaxParseCtx atom -> Syntax atom)
-> (SyntaxParseCtx atom -> Syntax atom -> SyntaxParseCtx atom)
-> Lens
     (SyntaxParseCtx atom)
     (SyntaxParseCtx atom)
     (Syntax atom)
     (Syntax atom)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens SyntaxParseCtx atom -> Syntax atom
forall atom. SyntaxParseCtx atom -> Syntax atom
_parseFocus (\SyntaxParseCtx atom
s Syntax atom
v -> SyntaxParseCtx atom
s { _parseFocus = v })

-- | The default parsing monad. Use its 'MonadSyntax' instance to write parsers.
newtype SyntaxParse atom a =
  SyntaxParse { forall atom a.
SyntaxParse atom a -> ReaderT (SyntaxParseCtx atom) (STP atom) a
runSyntaxParse :: ReaderT (SyntaxParseCtx atom)
                                          (STP atom)
                                          a }
  deriving ( (forall a b. (a -> b) -> SyntaxParse atom a -> SyntaxParse atom b)
-> (forall a b. a -> SyntaxParse atom b -> SyntaxParse atom a)
-> Functor (SyntaxParse atom)
forall a b. a -> SyntaxParse atom b -> SyntaxParse atom a
forall a b. (a -> b) -> SyntaxParse atom a -> SyntaxParse atom b
forall atom a b. a -> SyntaxParse atom b -> SyntaxParse atom a
forall atom a b.
(a -> b) -> SyntaxParse atom a -> SyntaxParse atom b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall atom a b.
(a -> b) -> SyntaxParse atom a -> SyntaxParse atom b
fmap :: forall a b. (a -> b) -> SyntaxParse atom a -> SyntaxParse atom b
$c<$ :: forall atom a b. a -> SyntaxParse atom b -> SyntaxParse atom a
<$ :: forall a b. a -> SyntaxParse atom b -> SyntaxParse atom a
Functor, Functor (SyntaxParse atom)
Functor (SyntaxParse atom) =>
(forall a. a -> SyntaxParse atom a)
-> (forall a b.
    SyntaxParse atom (a -> b)
    -> SyntaxParse atom a -> SyntaxParse atom b)
-> (forall a b c.
    (a -> b -> c)
    -> SyntaxParse atom a -> SyntaxParse atom b -> SyntaxParse atom c)
-> (forall a b.
    SyntaxParse atom a -> SyntaxParse atom b -> SyntaxParse atom b)
-> (forall a b.
    SyntaxParse atom a -> SyntaxParse atom b -> SyntaxParse atom a)
-> Applicative (SyntaxParse atom)
forall atom. Functor (SyntaxParse atom)
forall a. a -> SyntaxParse atom a
forall atom a. a -> SyntaxParse atom a
forall a b.
SyntaxParse atom a -> SyntaxParse atom b -> SyntaxParse atom a
forall a b.
SyntaxParse atom a -> SyntaxParse atom b -> SyntaxParse atom b
forall a b.
SyntaxParse atom (a -> b)
-> SyntaxParse atom a -> SyntaxParse atom b
forall atom a b.
SyntaxParse atom a -> SyntaxParse atom b -> SyntaxParse atom a
forall atom a b.
SyntaxParse atom a -> SyntaxParse atom b -> SyntaxParse atom b
forall atom a b.
SyntaxParse atom (a -> b)
-> SyntaxParse atom a -> SyntaxParse atom b
forall a b c.
(a -> b -> c)
-> SyntaxParse atom a -> SyntaxParse atom b -> SyntaxParse atom c
forall atom a b c.
(a -> b -> c)
-> SyntaxParse atom a -> SyntaxParse atom b -> SyntaxParse atom c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall atom a. a -> SyntaxParse atom a
pure :: forall a. a -> SyntaxParse atom a
$c<*> :: forall atom a b.
SyntaxParse atom (a -> b)
-> SyntaxParse atom a -> SyntaxParse atom b
<*> :: forall a b.
SyntaxParse atom (a -> b)
-> SyntaxParse atom a -> SyntaxParse atom b
$cliftA2 :: forall atom a b c.
(a -> b -> c)
-> SyntaxParse atom a -> SyntaxParse atom b -> SyntaxParse atom c
liftA2 :: forall a b c.
(a -> b -> c)
-> SyntaxParse atom a -> SyntaxParse atom b -> SyntaxParse atom c
$c*> :: forall atom a b.
SyntaxParse atom a -> SyntaxParse atom b -> SyntaxParse atom b
*> :: forall a b.
SyntaxParse atom a -> SyntaxParse atom b -> SyntaxParse atom b
$c<* :: forall atom a b.
SyntaxParse atom a -> SyntaxParse atom b -> SyntaxParse atom a
<* :: forall a b.
SyntaxParse atom a -> SyntaxParse atom b -> SyntaxParse atom a
Applicative, Applicative (SyntaxParse atom)
Applicative (SyntaxParse atom) =>
(forall a b.
 SyntaxParse atom a
 -> (a -> SyntaxParse atom b) -> SyntaxParse atom b)
-> (forall a b.
    SyntaxParse atom a -> SyntaxParse atom b -> SyntaxParse atom b)
-> (forall a. a -> SyntaxParse atom a)
-> Monad (SyntaxParse atom)
forall atom. Applicative (SyntaxParse atom)
forall a. a -> SyntaxParse atom a
forall atom a. a -> SyntaxParse atom a
forall a b.
SyntaxParse atom a -> SyntaxParse atom b -> SyntaxParse atom b
forall a b.
SyntaxParse atom a
-> (a -> SyntaxParse atom b) -> SyntaxParse atom b
forall atom a b.
SyntaxParse atom a -> SyntaxParse atom b -> SyntaxParse atom b
forall atom a b.
SyntaxParse atom a
-> (a -> SyntaxParse atom b) -> SyntaxParse atom b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall atom a b.
SyntaxParse atom a
-> (a -> SyntaxParse atom b) -> SyntaxParse atom b
>>= :: forall a b.
SyntaxParse atom a
-> (a -> SyntaxParse atom b) -> SyntaxParse atom b
$c>> :: forall atom a b.
SyntaxParse atom a -> SyntaxParse atom b -> SyntaxParse atom b
>> :: forall a b.
SyntaxParse atom a -> SyntaxParse atom b -> SyntaxParse atom b
$creturn :: forall atom a. a -> SyntaxParse atom a
return :: forall a. a -> SyntaxParse atom a
Monad
           , MonadReader (SyntaxParseCtx atom), Monad (SyntaxParse atom)
Monad (SyntaxParse atom) =>
(forall a. IO a -> SyntaxParse atom a)
-> MonadIO (SyntaxParse atom)
forall atom. Monad (SyntaxParse atom)
forall a. IO a -> SyntaxParse atom a
forall atom a. IO a -> SyntaxParse atom a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall atom a. IO a -> SyntaxParse atom a
liftIO :: forall a. IO a -> SyntaxParse atom a
MonadIO
           )

instance Alternative (SyntaxParse atom) where
  empty :: forall a. SyntaxParse atom a
empty =
    ReaderT (SyntaxParseCtx atom) (STP atom) a -> SyntaxParse atom a
forall atom a.
ReaderT (SyntaxParseCtx atom) (STP atom) a -> SyntaxParse atom a
SyntaxParse (ReaderT (SyntaxParseCtx atom) (STP atom) a -> SyntaxParse atom a)
-> ReaderT (SyntaxParseCtx atom) (STP atom) a -> SyntaxParse atom a
forall a b. (a -> b) -> a -> b
$ (SyntaxParseCtx atom -> STP atom a)
-> ReaderT (SyntaxParseCtx atom) (STP atom) a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((SyntaxParseCtx atom -> STP atom a)
 -> ReaderT (SyntaxParseCtx atom) (STP atom) a)
-> (SyntaxParseCtx atom -> STP atom a)
-> ReaderT (SyntaxParseCtx atom) (STP atom) a
forall a b. (a -> b) -> a -> b
$ \(SyntaxParseCtx Progress
p Reason atom
r Syntax atom
_) ->
      IO (P atom a) -> STP atom a
forall atom a. IO (P atom a) -> STP atom a
STP (IO (P atom a) -> STP atom a) -> IO (P atom a) -> STP atom a
forall a b. (a -> b) -> a -> b
$ P atom a -> IO (P atom a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (P atom a -> IO (P atom a)) -> P atom a -> IO (P atom a)
forall a b. (a -> b) -> a -> b
$ Search a -> Failure atom -> P atom a
forall atom a. Search a -> Failure atom -> P atom a
P Search a
forall a. Search a
forall (f :: * -> *) a. Alternative f => f a
empty (Progress -> NonEmpty (Reason atom) -> Failure atom
forall atom. Progress -> NonEmpty (Reason atom) -> Failure atom
Oops Progress
p (Reason atom -> NonEmpty (Reason atom)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Reason atom
r))
  (SyntaxParse (ReaderT SyntaxParseCtx atom -> STP atom a
x)) <|> :: forall a.
SyntaxParse atom a -> SyntaxParse atom a -> SyntaxParse atom a
<|> (SyntaxParse (ReaderT SyntaxParseCtx atom -> STP atom a
y)) =
    ReaderT (SyntaxParseCtx atom) (STP atom) a -> SyntaxParse atom a
forall atom a.
ReaderT (SyntaxParseCtx atom) (STP atom) a -> SyntaxParse atom a
SyntaxParse (ReaderT (SyntaxParseCtx atom) (STP atom) a -> SyntaxParse atom a)
-> ReaderT (SyntaxParseCtx atom) (STP atom) a -> SyntaxParse atom a
forall a b. (a -> b) -> a -> b
$ (SyntaxParseCtx atom -> STP atom a)
-> ReaderT (SyntaxParseCtx atom) (STP atom) a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((SyntaxParseCtx atom -> STP atom a)
 -> ReaderT (SyntaxParseCtx atom) (STP atom) a)
-> (SyntaxParseCtx atom -> STP atom a)
-> ReaderT (SyntaxParseCtx atom) (STP atom) a
forall a b. (a -> b) -> a -> b
$ \SyntaxParseCtx atom
ctx -> IO (P atom a) -> STP atom a
forall atom a. IO (P atom a) -> STP atom a
STP (IO (P atom a) -> STP atom a) -> IO (P atom a) -> STP atom a
forall a b. (a -> b) -> a -> b
$ do
      P atom a
a <- STP atom a -> IO (P atom a)
forall atom a. STP atom a -> IO (P atom a)
runSTP (STP atom a -> IO (P atom a)) -> STP atom a -> IO (P atom a)
forall a b. (a -> b) -> a -> b
$ SyntaxParseCtx atom -> STP atom a
x SyntaxParseCtx atom
ctx
      P atom a
b <- STP atom a -> IO (P atom a)
forall atom a. STP atom a -> IO (P atom a)
runSTP (STP atom a -> IO (P atom a)) -> STP atom a -> IO (P atom a)
forall a b. (a -> b) -> a -> b
$ SyntaxParseCtx atom -> STP atom a
y SyntaxParseCtx atom
ctx
      P atom a -> IO (P atom a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (P atom a -> IO (P atom a)) -> P atom a -> IO (P atom a)
forall a b. (a -> b) -> a -> b
$ P atom a
a P atom a -> P atom a -> P atom a
forall a. P atom a -> P atom a -> P atom a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P atom a
b

instance MonadPlus (SyntaxParse atom) where
  mzero :: forall a. SyntaxParse atom a
mzero = SyntaxParse atom a
forall a. SyntaxParse atom a
forall (f :: * -> *) a. Alternative f => f a
empty
  mplus :: forall a.
SyntaxParse atom a -> SyntaxParse atom a -> SyntaxParse atom a
mplus = SyntaxParse atom a -> SyntaxParse atom a -> SyntaxParse atom a
forall a.
SyntaxParse atom a -> SyntaxParse atom a -> SyntaxParse atom a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

instance MonadSyntax atom (SyntaxParse atom) where
  anything :: SyntaxParse atom (Syntax atom)
anything = Getting (Syntax atom) (SyntaxParseCtx atom) (Syntax atom)
-> SyntaxParse atom (Syntax atom)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Syntax atom) (SyntaxParseCtx atom) (Syntax atom)
forall atom (f :: * -> *).
Functor f =>
(Syntax atom -> f (Syntax atom))
-> SyntaxParseCtx atom -> f (SyntaxParseCtx atom)
parseFocus
  progress :: SyntaxParse atom Progress
progress = Getting Progress (SyntaxParseCtx atom) Progress
-> SyntaxParse atom Progress
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Progress (SyntaxParseCtx atom) Progress
forall atom (f :: * -> *).
Functor f =>
(Progress -> f Progress)
-> SyntaxParseCtx atom -> f (SyntaxParseCtx atom)
parseProgress
  withFocus :: forall a. Syntax atom -> SyntaxParse atom a -> SyntaxParse atom a
withFocus Syntax atom
stx = (SyntaxParseCtx atom -> SyntaxParseCtx atom)
-> SyntaxParse atom a -> SyntaxParse atom a
forall a.
(SyntaxParseCtx atom -> SyntaxParseCtx atom)
-> SyntaxParse atom a -> SyntaxParse atom a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((SyntaxParseCtx atom -> SyntaxParseCtx atom)
 -> SyntaxParse atom a -> SyntaxParse atom a)
-> (SyntaxParseCtx atom -> SyntaxParseCtx atom)
-> SyntaxParse atom a
-> SyntaxParse atom a
forall a b. (a -> b) -> a -> b
$ ASetter
  (SyntaxParseCtx atom)
  (SyntaxParseCtx atom)
  (Syntax atom)
  (Syntax atom)
-> Syntax atom -> SyntaxParseCtx atom -> SyntaxParseCtx atom
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (SyntaxParseCtx atom)
  (SyntaxParseCtx atom)
  (Syntax atom)
  (Syntax atom)
forall atom (f :: * -> *).
Functor f =>
(Syntax atom -> f (Syntax atom))
-> SyntaxParseCtx atom -> f (SyntaxParseCtx atom)
parseFocus Syntax atom
stx
  withProgress :: forall a.
(Progress -> Progress) -> SyntaxParse atom a -> SyntaxParse atom a
withProgress Progress -> Progress
f = (SyntaxParseCtx atom -> SyntaxParseCtx atom)
-> SyntaxParse atom a -> SyntaxParse atom a
forall a.
(SyntaxParseCtx atom -> SyntaxParseCtx atom)
-> SyntaxParse atom a -> SyntaxParse atom a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((SyntaxParseCtx atom -> SyntaxParseCtx atom)
 -> SyntaxParse atom a -> SyntaxParse atom a)
-> (SyntaxParseCtx atom -> SyntaxParseCtx atom)
-> SyntaxParse atom a
-> SyntaxParse atom a
forall a b. (a -> b) -> a -> b
$ ASetter
  (SyntaxParseCtx atom) (SyntaxParseCtx atom) Progress Progress
-> (Progress -> Progress)
-> SyntaxParseCtx atom
-> SyntaxParseCtx atom
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (SyntaxParseCtx atom) (SyntaxParseCtx atom) Progress Progress
forall atom (f :: * -> *).
Functor f =>
(Progress -> f Progress)
-> SyntaxParseCtx atom -> f (SyntaxParseCtx atom)
parseProgress Progress -> Progress
f
  withReason :: forall a. Reason atom -> SyntaxParse atom a -> SyntaxParse atom a
withReason Reason atom
r = (SyntaxParseCtx atom -> SyntaxParseCtx atom)
-> SyntaxParse atom a -> SyntaxParse atom a
forall a.
(SyntaxParseCtx atom -> SyntaxParseCtx atom)
-> SyntaxParse atom a -> SyntaxParse atom a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((SyntaxParseCtx atom -> SyntaxParseCtx atom)
 -> SyntaxParse atom a -> SyntaxParse atom a)
-> (SyntaxParseCtx atom -> SyntaxParseCtx atom)
-> SyntaxParse atom a
-> SyntaxParse atom a
forall a b. (a -> b) -> a -> b
$ ASetter
  (SyntaxParseCtx atom)
  (SyntaxParseCtx atom)
  (Reason atom)
  (Reason atom)
-> Reason atom -> SyntaxParseCtx atom -> SyntaxParseCtx atom
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (SyntaxParseCtx atom)
  (SyntaxParseCtx atom)
  (Reason atom)
  (Reason atom)
forall atom (f :: * -> *).
Functor f =>
(Reason atom -> f (Reason atom))
-> SyntaxParseCtx atom -> f (SyntaxParseCtx atom)
parseReason Reason atom
r
  cut :: forall a. SyntaxParse atom a
cut =
    ReaderT (SyntaxParseCtx atom) (STP atom) a -> SyntaxParse atom a
forall atom a.
ReaderT (SyntaxParseCtx atom) (STP atom) a -> SyntaxParse atom a
SyntaxParse (ReaderT (SyntaxParseCtx atom) (STP atom) a -> SyntaxParse atom a)
-> ReaderT (SyntaxParseCtx atom) (STP atom) a -> SyntaxParse atom a
forall a b. (a -> b) -> a -> b
$
    (SyntaxParseCtx atom -> STP atom a)
-> ReaderT (SyntaxParseCtx atom) (STP atom) a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((SyntaxParseCtx atom -> STP atom a)
 -> ReaderT (SyntaxParseCtx atom) (STP atom) a)
-> (SyntaxParseCtx atom -> STP atom a)
-> ReaderT (SyntaxParseCtx atom) (STP atom) a
forall a b. (a -> b) -> a -> b
$
    \(SyntaxParseCtx Progress
p Reason atom
r Syntax atom
_) ->
      IO (P atom a) -> STP atom a
forall atom a. IO (P atom a) -> STP atom a
STP (IO (P atom a) -> STP atom a) -> IO (P atom a) -> STP atom a
forall a b. (a -> b) -> a -> b
$ P atom a -> IO (P atom a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (P atom a -> IO (P atom a)) -> P atom a -> IO (P atom a)
forall a b. (a -> b) -> a -> b
$
      Search a -> Failure atom -> P atom a
forall atom a. Search a -> Failure atom -> P atom a
P Search a
forall a. Search a
cutSearch (Progress -> NonEmpty (Reason atom) -> Failure atom
forall atom. Progress -> NonEmpty (Reason atom) -> Failure atom
Oops Progress
p (Reason atom -> NonEmpty (Reason atom)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Reason atom
r))
  delimit :: forall a. SyntaxParse atom a -> SyntaxParse atom a
delimit (SyntaxParse (ReaderT SyntaxParseCtx atom -> STP atom a
f)) =
    ReaderT (SyntaxParseCtx atom) (STP atom) a -> SyntaxParse atom a
forall atom a.
ReaderT (SyntaxParseCtx atom) (STP atom) a -> SyntaxParse atom a
SyntaxParse (ReaderT (SyntaxParseCtx atom) (STP atom) a -> SyntaxParse atom a)
-> ReaderT (SyntaxParseCtx atom) (STP atom) a -> SyntaxParse atom a
forall a b. (a -> b) -> a -> b
$
    (SyntaxParseCtx atom -> STP atom a)
-> ReaderT (SyntaxParseCtx atom) (STP atom) a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((SyntaxParseCtx atom -> STP atom a)
 -> ReaderT (SyntaxParseCtx atom) (STP atom) a)
-> (SyntaxParseCtx atom -> STP atom a)
-> ReaderT (SyntaxParseCtx atom) (STP atom) a
forall a b. (a -> b) -> a -> b
$
    \SyntaxParseCtx atom
r -> IO (P atom a) -> STP atom a
forall atom a. IO (P atom a) -> STP atom a
STP (IO (P atom a) -> STP atom a) -> IO (P atom a) -> STP atom a
forall a b. (a -> b) -> a -> b
$ do
      P Search a
s Failure atom
e <- STP atom a -> IO (P atom a)
forall atom a. STP atom a -> IO (P atom a)
runSTP (STP atom a -> IO (P atom a)) -> STP atom a -> IO (P atom a)
forall a b. (a -> b) -> a -> b
$ SyntaxParseCtx atom -> STP atom a
f SyntaxParseCtx atom
r
      P atom a -> IO (P atom a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (P atom a -> IO (P atom a)) -> P atom a -> IO (P atom a)
forall a b. (a -> b) -> a -> b
$ Search a -> Failure atom -> P atom a
forall atom a. Search a -> Failure atom -> P atom a
P (Search a -> Search a
forall a. Search a -> Search a
delimitSearch Search a
s) Failure atom
e
  call :: forall a. SyntaxParse atom a -> SyntaxParse atom a
call (SyntaxParse (ReaderT SyntaxParseCtx atom -> STP atom a
p)) =
    ReaderT (SyntaxParseCtx atom) (STP atom) a -> SyntaxParse atom a
forall atom a.
ReaderT (SyntaxParseCtx atom) (STP atom) a -> SyntaxParse atom a
SyntaxParse (ReaderT (SyntaxParseCtx atom) (STP atom) a -> SyntaxParse atom a)
-> ReaderT (SyntaxParseCtx atom) (STP atom) a -> SyntaxParse atom a
forall a b. (a -> b) -> a -> b
$
    (SyntaxParseCtx atom -> STP atom a)
-> ReaderT (SyntaxParseCtx atom) (STP atom) a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((SyntaxParseCtx atom -> STP atom a)
 -> ReaderT (SyntaxParseCtx atom) (STP atom) a)
-> (SyntaxParseCtx atom -> STP atom a)
-> ReaderT (SyntaxParseCtx atom) (STP atom) a
forall a b. (a -> b) -> a -> b
$
    \SyntaxParseCtx atom
r -> IO (P atom a) -> STP atom a
forall atom a. IO (P atom a) -> STP atom a
STP (IO (P atom a) -> STP atom a) -> IO (P atom a) -> STP atom a
forall a b. (a -> b) -> a -> b
$ do
      P Search a
s Failure atom
e <- STP atom a -> IO (P atom a)
forall atom a. STP atom a -> IO (P atom a)
runSTP (STP atom a -> IO (P atom a)) -> STP atom a -> IO (P atom a)
forall a b. (a -> b) -> a -> b
$ SyntaxParseCtx atom -> STP atom a
p SyntaxParseCtx atom
r
      P atom a -> IO (P atom a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (P atom a -> IO (P atom a)) -> P atom a -> IO (P atom a)
forall a b. (a -> b) -> a -> b
$ case Search a
s of
        Try a
x Search a
_ -> Search a -> Failure atom -> P atom a
forall atom a. Search a -> Failure atom -> P atom a
P (a -> Search a -> Search a
forall a. a -> Search a -> Search a
Try a
x Search a
forall a. Search a
Fail) Failure atom
forall atom. Failure atom
Ok
        Search a
Cut -> Search a -> Failure atom -> P atom a
forall atom a. Search a -> Failure atom -> P atom a
P Search a
forall a. Search a
Cut Failure atom
e
        Search a
Fail -> Search a -> Failure atom -> P atom a
forall atom a. Search a -> Failure atom -> P atom a
P Search a
forall a. Search a
Fail Failure atom
e

-- | Syntax errors explain why the error occurred.
data SyntaxError atom = SyntaxError (NonEmpty (Reason atom))
  deriving (Int -> SyntaxError atom -> ShowS
[SyntaxError atom] -> ShowS
SyntaxError atom -> String
(Int -> SyntaxError atom -> ShowS)
-> (SyntaxError atom -> String)
-> ([SyntaxError atom] -> ShowS)
-> Show (SyntaxError atom)
forall atom. Show atom => Int -> SyntaxError atom -> ShowS
forall atom. Show atom => [SyntaxError atom] -> ShowS
forall atom. Show atom => SyntaxError atom -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall atom. Show atom => Int -> SyntaxError atom -> ShowS
showsPrec :: Int -> SyntaxError atom -> ShowS
$cshow :: forall atom. Show atom => SyntaxError atom -> String
show :: SyntaxError atom -> String
$cshowList :: forall atom. Show atom => [SyntaxError atom] -> ShowS
showList :: [SyntaxError atom] -> ShowS
Show, SyntaxError atom -> SyntaxError atom -> Bool
(SyntaxError atom -> SyntaxError atom -> Bool)
-> (SyntaxError atom -> SyntaxError atom -> Bool)
-> Eq (SyntaxError atom)
forall atom.
Eq atom =>
SyntaxError atom -> SyntaxError atom -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall atom.
Eq atom =>
SyntaxError atom -> SyntaxError atom -> Bool
== :: SyntaxError atom -> SyntaxError atom -> Bool
$c/= :: forall atom.
Eq atom =>
SyntaxError atom -> SyntaxError atom -> Bool
/= :: SyntaxError atom -> SyntaxError atom -> Bool
Eq)

-- | Convert an internal error structure into a form suitable for
-- humans to read.
printSyntaxError :: IsAtom atom => SyntaxError atom -> Text
printSyntaxError :: forall atom. IsAtom atom => SyntaxError atom -> Text
printSyntaxError (SyntaxError NonEmpty (Reason atom)
rs) =
  Text -> [Text] -> Text
T.intercalate Text
"\n\tor\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. Eq a => [a] -> [a]
nub ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ ((Position, NonEmpty (Reason atom)) -> Text)
-> [(Position, NonEmpty (Reason atom))] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Position, NonEmpty (Reason atom)) -> Text
forall {a} {a}.
(Show a, IsAtom a) =>
(a, NonEmpty (Reason a)) -> Text
printGroup ([(Position, NonEmpty (Reason atom))] -> [Text])
-> [(Position, NonEmpty (Reason atom))] -> [Text]
forall a b. (a -> b) -> a -> b
$ NonEmpty (Reason atom) -> [(Position, NonEmpty (Reason atom))]
forall {a}.
NonEmpty (Reason a) -> [(Position, NonEmpty (Reason a))]
groupReasons NonEmpty (Reason atom)
rs
 where
    reasonPos :: Reason a -> Position
reasonPos (Reason Syntax a
found Text
_) = Syntax a -> Position
forall a. Syntax a -> Position
syntaxPos Syntax a
found
    groupReasons :: NonEmpty (Reason a) -> [(Position, NonEmpty (Reason a))]
groupReasons NonEmpty (Reason a)
reasons =
      [ (Reason a -> Position
forall {a}. Reason a -> Position
reasonPos Reason a
repr, NonEmpty (Reason a)
g)
      | g :: NonEmpty (Reason a)
g@(Reason a
repr :| [Reason a]
_) <- (Reason a -> Reason a -> Bool)
-> [Reason a] -> [NonEmpty (Reason a)]
forall (f :: * -> *) a.
Foldable f =>
(a -> a -> Bool) -> f a -> [NonEmpty a]
NE.groupBy (\Reason a
x Reason a
y -> Reason a -> Position
forall {a}. Reason a -> Position
reasonPos Reason a
x Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
== Reason a -> Position
forall {a}. Reason a -> Position
reasonPos Reason a
y) (NonEmpty (Reason a) -> [Reason a]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Reason a)
reasons)
      ]
    printGroup :: (a, NonEmpty (Reason a)) -> Text
printGroup (a
p, r :: Reason a
r@(Reason Syntax a
found Text
_) :| [Reason a]
more) =
      [Text] -> Text
T.concat
      [ Text
"At ", String -> Text
T.pack (a -> String
forall a. Show a => a -> String
show a
p)
      , Text
", expected ", Text -> [Text] -> Text
T.intercalate Text
" or " ([Text] -> [Text]
forall a. Eq a => [a] -> [a]
nub ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort [ Text
wanted | Reason Syntax a
_ Text
wanted <- Reason a
rReason a -> [Reason a] -> [Reason a]
forall a. a -> [a] -> [a]
:[Reason a]
more ])
      , Text
" but got ", PrintRules a -> Syntax a -> Text
forall expr a.
(Syntactic expr a, IsAtom a) =>
PrintRules a -> expr -> Text
toText PrintRules a
forall a. Monoid a => a
mempty Syntax a
found]

-- | Attempt to parse the given piece of syntax, returning the first success found,
--   or the error(s) with the greatest progress otherwise.
syntaxParseIO :: IsAtom atom => SyntaxParse atom a -> Syntax atom -> IO (Either (SyntaxError atom) a)
syntaxParseIO :: forall atom a.
IsAtom atom =>
SyntaxParse atom a
-> Syntax atom -> IO (Either (SyntaxError atom) a)
syntaxParseIO SyntaxParse atom a
p Syntax atom
stx = do
  (P Search a
yes Failure atom
no) <-
        STP atom a -> IO (P atom a)
forall atom a. STP atom a -> IO (P atom a)
runSTP (STP atom a -> IO (P atom a)) -> STP atom a -> IO (P atom a)
forall a b. (a -> b) -> a -> b
$ ReaderT (SyntaxParseCtx atom) (STP atom) a
-> SyntaxParseCtx atom -> STP atom a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (SyntaxParse atom a -> ReaderT (SyntaxParseCtx atom) (STP atom) a
forall atom a.
SyntaxParse atom a -> ReaderT (SyntaxParseCtx atom) (STP atom) a
runSyntaxParse SyntaxParse atom a
p) (SyntaxParseCtx atom -> STP atom a)
-> SyntaxParseCtx atom -> STP atom a
forall a b. (a -> b) -> a -> b
$
          Progress -> Reason atom -> Syntax atom -> SyntaxParseCtx atom
forall atom.
Progress -> Reason atom -> Syntax atom -> SyntaxParseCtx atom
SyntaxParseCtx Progress
emptyProgress (Syntax atom -> Text -> Reason atom
forall atom. Syntax atom -> Text -> Reason atom
Reason Syntax atom
stx (String -> Text
T.pack String
"bad syntax")) Syntax atom
stx
  case Search a -> [a]
forall a. Search a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Search a
yes of
    [] ->
      Either (SyntaxError atom) a -> IO (Either (SyntaxError atom) a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (SyntaxError atom) a -> IO (Either (SyntaxError atom) a))
-> Either (SyntaxError atom) a -> IO (Either (SyntaxError atom) a)
forall a b. (a -> b) -> a -> b
$ SyntaxError atom -> Either (SyntaxError atom) a
forall a b. a -> Either a b
Left (SyntaxError atom -> Either (SyntaxError atom) a)
-> SyntaxError atom -> Either (SyntaxError atom) a
forall a b. (a -> b) -> a -> b
$ NonEmpty (Reason atom) -> SyntaxError atom
forall atom. NonEmpty (Reason atom) -> SyntaxError atom
SyntaxError (NonEmpty (Reason atom) -> SyntaxError atom)
-> NonEmpty (Reason atom) -> SyntaxError atom
forall a b. (a -> b) -> a -> b
$
        case Failure atom
no of
          Failure atom
Ok        -> String -> NonEmpty (Reason atom)
forall a. HasCallStack => String -> a
error String
"Internal error: no reason provided, yet no successful parse found."
          Oops Progress
_ NonEmpty (Reason atom)
rs -> NonEmpty (Reason atom)
rs
    (a
r:[a]
_) -> Either (SyntaxError atom) a -> IO (Either (SyntaxError atom) a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (SyntaxError atom) a -> IO (Either (SyntaxError atom) a))
-> Either (SyntaxError atom) a -> IO (Either (SyntaxError atom) a)
forall a b. (a -> b) -> a -> b
$ a -> Either (SyntaxError atom) a
forall a b. b -> Either a b
Right a
r

-- | A trivial atom, which is a wrapper around 'Text', for use when testing the library.
newtype TrivialAtom = TrivialAtom Text deriving (Int -> TrivialAtom -> ShowS
[TrivialAtom] -> ShowS
TrivialAtom -> String
(Int -> TrivialAtom -> ShowS)
-> (TrivialAtom -> String)
-> ([TrivialAtom] -> ShowS)
-> Show TrivialAtom
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TrivialAtom -> ShowS
showsPrec :: Int -> TrivialAtom -> ShowS
$cshow :: TrivialAtom -> String
show :: TrivialAtom -> String
$cshowList :: [TrivialAtom] -> ShowS
showList :: [TrivialAtom] -> ShowS
Show, TrivialAtom -> TrivialAtom -> Bool
(TrivialAtom -> TrivialAtom -> Bool)
-> (TrivialAtom -> TrivialAtom -> Bool) -> Eq TrivialAtom
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TrivialAtom -> TrivialAtom -> Bool
== :: TrivialAtom -> TrivialAtom -> Bool
$c/= :: TrivialAtom -> TrivialAtom -> Bool
/= :: TrivialAtom -> TrivialAtom -> Bool
Eq)

instance IsAtom TrivialAtom where
  showAtom :: TrivialAtom -> Text
showAtom (TrivialAtom Text
x) = Text
x

instance IsString TrivialAtom where
  fromString :: String -> TrivialAtom
fromString String
x = Text -> TrivialAtom
TrivialAtom (String -> Text
forall a. IsString a => String -> a
fromString String
x)

-- | Test a parser on some input, displaying the result.
test :: (HasCallStack, Show a) => Text -> SyntaxParse TrivialAtom a -> IO ()
test :: forall a.
(HasCallStack, Show a) =>
Text -> SyntaxParse TrivialAtom a -> IO ()
test Text
txt SyntaxParse TrivialAtom a
p =
  case Parsec Void Text (Syntax TrivialAtom)
-> String
-> Text
-> Either (ParseErrorBundle Text Void) (Syntax TrivialAtom)
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
MP.parse (Parser ()
skipWhitespace Parser ()
-> Parsec Void Text (Syntax TrivialAtom)
-> Parsec Void Text (Syntax TrivialAtom)
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser TrivialAtom -> Parsec Void Text (Syntax TrivialAtom)
forall a. Parser a -> Parser (Syntax a)
sexp (Text -> TrivialAtom
TrivialAtom (Text -> TrivialAtom)
-> ParsecT Void Text Identity Text -> Parser TrivialAtom
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
identifier) Parsec Void Text (Syntax TrivialAtom)
-> Parser () -> Parsec Void Text (Syntax TrivialAtom)
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
MP.eof) String
"input" Text
txt of
     Left ParseErrorBundle Text Void
err -> String -> IO ()
putStrLn String
"Reader error: " IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
putStrLn (ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
MP.errorBundlePretty ParseErrorBundle Text Void
err)
     Right Syntax TrivialAtom
sexpr ->
       SyntaxParse TrivialAtom a
-> Syntax TrivialAtom -> IO (Either (SyntaxError TrivialAtom) a)
forall atom a.
IsAtom atom =>
SyntaxParse atom a
-> Syntax atom -> IO (Either (SyntaxError atom) a)
syntaxParseIO SyntaxParse TrivialAtom a
p Syntax TrivialAtom
sexpr IO (Either (SyntaxError TrivialAtom) a)
-> (Either (SyntaxError TrivialAtom) a -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
         Left SyntaxError TrivialAtom
e -> Text -> IO ()
T.putStrLn (SyntaxError TrivialAtom -> Text
forall atom. IsAtom atom => SyntaxError atom -> Text
printSyntaxError SyntaxError TrivialAtom
e)
         Right a
ok -> a -> IO ()
forall a. Show a => a -> IO ()
print a
ok