{-# 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.Monad
  ( MonadSyntax(..)

  -- * Describing syntax
  , describe
  , atom
  , cons
  , depCons
  , depConsCond
  , followedBy
  , rep
  , list
  , backwards
  , emptyList
  , atomic
  , anyList
  , sideCondition
  , sideCondition'
  , satisfy

  -- * Eliminating location information
  , syntaxToDatum
  , datum

  -- * Parsing context
  , position
  , withProgressStep

  -- * Control structures
  , commit
  , parse

  -- * Progress through a parsing problem
  , ProgressStep(..)
  , Progress
  , emptyProgress
  , pushProgress

  -- * Errors
  , later
  , Reason(..)
  ) where

import Control.Applicative
import Control.Monad (MonadPlus(..), ap)
import Control.Monad.Reader (MonadReader(..), ReaderT(..))
import qualified Control.Monad.State.Strict as Strict
import qualified Control.Monad.State.Lazy as Lazy
import Control.Monad.State.Class
import Control.Monad.Trans.Class (MonadTrans(..))
import qualified Control.Monad.Writer.Strict as Strict
import qualified Control.Monad.Writer.Lazy as Lazy
import Control.Monad.Writer.Class

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

import Lang.Crucible.Syntax.SExpr

import What4.ProgramLoc (Posd(..), Position)

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

-- | Components of a path taken through a syntax object to reach the
-- current focus.
data ProgressStep =
    First -- ^ The head of a list was followed
  | Rest -- ^ The tail of a list was followed
  | Late -- ^ The path was annotated as 'later'
  deriving (ProgressStep -> ProgressStep -> Bool
(ProgressStep -> ProgressStep -> Bool)
-> (ProgressStep -> ProgressStep -> Bool) -> Eq ProgressStep
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProgressStep -> ProgressStep -> Bool
== :: ProgressStep -> ProgressStep -> Bool
$c/= :: ProgressStep -> ProgressStep -> Bool
/= :: ProgressStep -> ProgressStep -> Bool
Eq, Int -> ProgressStep -> ShowS
[ProgressStep] -> ShowS
ProgressStep -> String
(Int -> ProgressStep -> ShowS)
-> (ProgressStep -> String)
-> ([ProgressStep] -> ShowS)
-> Show ProgressStep
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProgressStep -> ShowS
showsPrec :: Int -> ProgressStep -> ShowS
$cshow :: ProgressStep -> String
show :: ProgressStep -> String
$cshowList :: [ProgressStep] -> ShowS
showList :: [ProgressStep] -> ShowS
Show)

instance Ord ProgressStep where
  compare :: ProgressStep -> ProgressStep -> Ordering
compare ProgressStep
First ProgressStep
First = Ordering
EQ
  compare ProgressStep
First ProgressStep
_ = Ordering
LT
  compare ProgressStep
Rest ProgressStep
First = Ordering
GT
  compare ProgressStep
Rest ProgressStep
Rest = Ordering
EQ
  compare ProgressStep
Rest ProgressStep
_ = Ordering
LT
  compare ProgressStep
Late ProgressStep
Late = Ordering
EQ
  compare ProgressStep
Late ProgressStep
_ = Ordering
GT

-- | The path taken through a syntax object to reach the current
-- focus.
newtype Progress = Progress [ProgressStep]
  deriving (Progress -> Progress -> Bool
(Progress -> Progress -> Bool)
-> (Progress -> Progress -> Bool) -> Eq Progress
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Progress -> Progress -> Bool
== :: Progress -> Progress -> Bool
$c/= :: Progress -> Progress -> Bool
/= :: Progress -> Progress -> Bool
Eq, Int -> Progress -> ShowS
[Progress] -> ShowS
Progress -> String
(Int -> Progress -> ShowS)
-> (Progress -> String) -> ([Progress] -> ShowS) -> Show Progress
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Progress -> ShowS
showsPrec :: Int -> Progress -> ShowS
$cshow :: Progress -> String
show :: Progress -> String
$cshowList :: [Progress] -> ShowS
showList :: [Progress] -> ShowS
Show)

-- | An empty path, used to initialize parsers
emptyProgress :: Progress
emptyProgress :: Progress
emptyProgress = [ProgressStep] -> Progress
Progress []

-- | Add a step to a progress path
pushProgress :: ProgressStep -> Progress -> Progress
pushProgress :: ProgressStep -> Progress -> Progress
pushProgress ProgressStep
p (Progress [ProgressStep]
ps) = [ProgressStep] -> Progress
Progress (ProgressStep
p ProgressStep -> [ProgressStep] -> [ProgressStep]
forall a. a -> [a] -> [a]
: [ProgressStep]
ps)

instance Ord Progress where
  compare :: Progress -> Progress -> Ordering
compare (Progress [ProgressStep]
xs) (Progress [ProgressStep]
ys) =
    case ([ProgressStep]
xs, [ProgressStep]
ys) of
      ([], []) -> Ordering
EQ
      ([], ProgressStep
_:[ProgressStep]
_) -> Ordering
LT
      (ProgressStep
_:[ProgressStep]
_, []) -> Ordering
GT
      (ProgressStep
x:[ProgressStep]
xs', ProgressStep
y:[ProgressStep]
ys') ->
        case Progress -> Progress -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([ProgressStep] -> Progress
Progress [ProgressStep]
xs') ([ProgressStep] -> Progress
Progress [ProgressStep]
ys') of
          Ordering
LT -> Ordering
LT
          Ordering
GT -> Ordering
GT
          Ordering
EQ -> ProgressStep -> ProgressStep -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ProgressStep
x ProgressStep
y


-- | The reason why a failure has occurred, consisting of description
-- 'message' combined with the focus that was described.
data Reason atom = Reason { forall atom. Reason atom -> Syntax atom
expr :: Syntax atom
                          , forall atom. Reason atom -> Text
message :: Text
                          }
  deriving ((forall a b. (a -> b) -> Reason a -> Reason b)
-> (forall a b. a -> Reason b -> Reason a) -> Functor Reason
forall a b. a -> Reason b -> Reason a
forall a b. (a -> b) -> Reason a -> Reason 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) -> Reason a -> Reason b
fmap :: forall a b. (a -> b) -> Reason a -> Reason b
$c<$ :: forall a b. a -> Reason b -> Reason a
<$ :: forall a b. a -> Reason b -> Reason a
Functor, Int -> Reason atom -> ShowS
[Reason atom] -> ShowS
Reason atom -> String
(Int -> Reason atom -> ShowS)
-> (Reason atom -> String)
-> ([Reason atom] -> ShowS)
-> Show (Reason atom)
forall atom. Show atom => Int -> Reason atom -> ShowS
forall atom. Show atom => [Reason atom] -> ShowS
forall atom. Show atom => Reason atom -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall atom. Show atom => Int -> Reason atom -> ShowS
showsPrec :: Int -> Reason atom -> ShowS
$cshow :: forall atom. Show atom => Reason atom -> String
show :: Reason atom -> String
$cshowList :: forall atom. Show atom => [Reason atom] -> ShowS
showList :: [Reason atom] -> ShowS
Show, Reason atom -> Reason atom -> Bool
(Reason atom -> Reason atom -> Bool)
-> (Reason atom -> Reason atom -> Bool) -> Eq (Reason atom)
forall atom. Eq atom => Reason atom -> Reason atom -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall atom. Eq atom => Reason atom -> Reason atom -> Bool
== :: Reason atom -> Reason atom -> Bool
$c/= :: forall atom. Eq atom => Reason atom -> Reason atom -> Bool
/= :: Reason atom -> Reason atom -> Bool
Eq)

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

-- | Monads that can parse syntax need a few fundamental operations.
-- A parsing monad maintains an implicit "focus", which is the syntax
-- currently being matched, as well as the progress, which is the path
-- taken through the surrounding syntactic context to reach the
-- current focus. Additionally, the reason for a failure will always
-- be reported with respect to explicit descriptions - these are
-- inserted through 'withReason'.
class (Alternative m, Monad m) => MonadSyntax atom m | m -> atom where
  -- | Succeed with the current focus.
  anything :: m (Syntax atom)
  -- | Succeed with the current progress.
  progress :: m Progress
  -- | Run a new parser with a different focus.
  withFocus :: Syntax atom -> m a -> m a
  -- | Run a parser in a modified notion of progress.
  withProgress :: (Progress -> Progress) -> m a -> m a
  -- | Run a parser with a new reason for failure.
  withReason :: Reason atom -> m a -> m a
  -- | Fail, and additionally prohibit backtracking across the failure.
  cut :: m a
  -- | Delimit the dynamic extent of a 'cut'.
  delimit :: m a -> m a
  -- | Make the first solution reported by a computation into the only
  -- solution reported, eliminating further backtracking and previous
  -- errors. This allows syntax to be matched in exclusive "layers",
  -- reminiscent of the effect of trampolining through a macro
  -- expander. Use when solutions are expected to be unique.
  call :: m a -> m a

instance MonadSyntax atom m => MonadSyntax atom (ReaderT r m) where
  anything :: ReaderT r m (Syntax atom)
anything = m (Syntax atom) -> ReaderT r m (Syntax atom)
forall (m :: * -> *) a. Monad m => m a -> ReaderT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (Syntax atom)
forall atom (m :: * -> *). MonadSyntax atom m => m (Syntax atom)
anything
  cut :: forall a. ReaderT r m a
cut = m a -> ReaderT r m a
forall (m :: * -> *) a. Monad m => m a -> ReaderT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m a
forall a. m a
forall atom (m :: * -> *) a. MonadSyntax atom m => m a
cut
  progress :: ReaderT r m Progress
progress = m Progress -> ReaderT r m Progress
forall (m :: * -> *) a. Monad m => m a -> ReaderT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Progress
forall atom (m :: * -> *). MonadSyntax atom m => m Progress
progress
  delimit :: forall a. ReaderT r m a -> ReaderT r m a
delimit ReaderT r m a
m =
    do r
r <- ReaderT r m r
forall r (m :: * -> *). MonadReader r m => m r
ask
       m a -> ReaderT r m a
forall (m :: * -> *) a. Monad m => m a -> ReaderT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ReaderT r m a) -> m a -> ReaderT r m a
forall a b. (a -> b) -> a -> b
$ m a -> m a
forall a. m a -> m a
forall atom (m :: * -> *) a. MonadSyntax atom m => m a -> m a
delimit (ReaderT r m a -> r -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT r m a
m r
r)
  call :: forall a. ReaderT r m a -> ReaderT r m a
call ReaderT r m a
m =
    do r
r <- ReaderT r m r
forall r (m :: * -> *). MonadReader r m => m r
ask
       m a -> ReaderT r m a
forall (m :: * -> *) a. Monad m => m a -> ReaderT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ReaderT r m a) -> m a -> ReaderT r m a
forall a b. (a -> b) -> a -> b
$ m a -> m a
forall a. m a -> m a
forall atom (m :: * -> *) a. MonadSyntax atom m => m a -> m a
call (ReaderT r m a -> r -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT r m a
m r
r)
  withFocus :: forall a. Syntax atom -> ReaderT r m a -> ReaderT r m a
withFocus Syntax atom
stx ReaderT r m a
m =
    do r
r <- ReaderT r m r
forall r (m :: * -> *). MonadReader r m => m r
ask
       m a -> ReaderT r m a
forall (m :: * -> *) a. Monad m => m a -> ReaderT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ReaderT r m a) -> m a -> ReaderT r m a
forall a b. (a -> b) -> a -> b
$ Syntax atom -> m a -> m a
forall a. Syntax atom -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Syntax atom -> m a -> m a
withFocus Syntax atom
stx (ReaderT r m a -> r -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT r m a
m r
r)
  withProgress :: forall a. (Progress -> Progress) -> ReaderT r m a -> ReaderT r m a
withProgress Progress -> Progress
p ReaderT r m a
m =
    do r
r <- ReaderT r m r
forall r (m :: * -> *). MonadReader r m => m r
ask
       m a -> ReaderT r m a
forall (m :: * -> *) a. Monad m => m a -> ReaderT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ReaderT r m a) -> m a -> ReaderT r m a
forall a b. (a -> b) -> a -> b
$ (Progress -> Progress) -> m a -> m a
forall a. (Progress -> Progress) -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
(Progress -> Progress) -> m a -> m a
withProgress Progress -> Progress
p (ReaderT r m a -> r -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT r m a
m r
r)
  withReason :: forall a. Reason atom -> ReaderT r m a -> ReaderT r m a
withReason Reason atom
why ReaderT r m a
m =
    do r
r <- ReaderT r m r
forall r (m :: * -> *). MonadReader r m => m r
ask
       m a -> ReaderT r m a
forall (m :: * -> *) a. Monad m => m a -> ReaderT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ReaderT r m a) -> m a -> ReaderT r m a
forall a b. (a -> b) -> a -> b
$ Reason atom -> m a -> m a
forall a. Reason atom -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Reason atom -> m a -> m a
withReason Reason atom
why (ReaderT r m a -> r -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT r m a
m r
r)

instance (MonadPlus m, MonadSyntax atom m) => MonadSyntax atom (Strict.StateT s m) where
  anything :: StateT s m (Syntax atom)
anything = m (Syntax atom) -> StateT s m (Syntax atom)
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (Syntax atom)
forall atom (m :: * -> *). MonadSyntax atom m => m (Syntax atom)
anything
  cut :: forall a. StateT s m a
cut = m a -> StateT s m a
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m a
forall a. m a
forall atom (m :: * -> *) a. MonadSyntax atom m => m a
cut
  progress :: StateT s m Progress
progress = m Progress -> StateT s m Progress
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Progress
forall atom (m :: * -> *). MonadSyntax atom m => m Progress
progress
  delimit :: forall a. StateT s m a -> StateT s m a
delimit StateT s m a
m =
    do s
st <- StateT s m s
forall s (m :: * -> *). MonadState s m => m s
get
       (a
s, s
st') <- m (a, s) -> StateT s m (a, s)
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (a, s) -> StateT s m (a, s)) -> m (a, s) -> StateT s m (a, s)
forall a b. (a -> b) -> a -> b
$ m (a, s) -> m (a, s)
forall a. m a -> m a
forall atom (m :: * -> *) a. MonadSyntax atom m => m a -> m a
delimit (StateT s m a -> s -> m (a, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
Strict.runStateT StateT s m a
m s
st)
       s -> StateT s m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put s
st'
       a -> StateT s m a
forall a. a -> StateT s m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
s
  call :: forall a. StateT s m a -> StateT s m a
call StateT s m a
m =
    do s
st <- StateT s m s
forall s (m :: * -> *). MonadState s m => m s
get
       (a
s, s
st') <- m (a, s) -> StateT s m (a, s)
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (a, s) -> StateT s m (a, s)) -> m (a, s) -> StateT s m (a, s)
forall a b. (a -> b) -> a -> b
$ m (a, s) -> m (a, s)
forall a. m a -> m a
forall atom (m :: * -> *) a. MonadSyntax atom m => m a -> m a
call (StateT s m a -> s -> m (a, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
Strict.runStateT StateT s m a
m s
st)
       s -> StateT s m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put s
st'
       a -> StateT s m a
forall a. a -> StateT s m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
s
  withFocus :: forall a. Syntax atom -> StateT s m a -> StateT s m a
withFocus Syntax atom
stx StateT s m a
m =
    do s
st <- StateT s m s
forall s (m :: * -> *). MonadState s m => m s
get
       (a
s, s
st') <- m (a, s) -> StateT s m (a, s)
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (a, s) -> StateT s m (a, s)) -> m (a, s) -> StateT s m (a, s)
forall a b. (a -> b) -> a -> b
$ Syntax atom -> m (a, s) -> m (a, s)
forall a. Syntax atom -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Syntax atom -> m a -> m a
withFocus Syntax atom
stx (StateT s m a -> s -> m (a, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
Strict.runStateT StateT s m a
m s
st)
       s -> StateT s m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put s
st'
       a -> StateT s m a
forall a. a -> StateT s m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
s
  withProgress :: forall a. (Progress -> Progress) -> StateT s m a -> StateT s m a
withProgress Progress -> Progress
p StateT s m a
m =
    do s
st <- StateT s m s
forall s (m :: * -> *). MonadState s m => m s
get
       (a
s, s
st') <- m (a, s) -> StateT s m (a, s)
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (a, s) -> StateT s m (a, s)) -> m (a, s) -> StateT s m (a, s)
forall a b. (a -> b) -> a -> b
$ (Progress -> Progress) -> m (a, s) -> m (a, s)
forall a. (Progress -> Progress) -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
(Progress -> Progress) -> m a -> m a
withProgress Progress -> Progress
p (StateT s m a -> s -> m (a, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
Strict.runStateT StateT s m a
m s
st)
       s -> StateT s m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put s
st'
       a -> StateT s m a
forall a. a -> StateT s m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
s
  withReason :: forall a. Reason atom -> StateT s m a -> StateT s m a
withReason Reason atom
why StateT s m a
m =
    do s
st <- StateT s m s
forall s (m :: * -> *). MonadState s m => m s
get
       (a
s, s
st') <- m (a, s) -> StateT s m (a, s)
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (a, s) -> StateT s m (a, s)) -> m (a, s) -> StateT s m (a, s)
forall a b. (a -> b) -> a -> b
$ Reason atom -> m (a, s) -> m (a, s)
forall a. Reason atom -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Reason atom -> m a -> m a
withReason Reason atom
why (StateT s m a -> s -> m (a, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
Strict.runStateT StateT s m a
m s
st)
       s -> StateT s m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put s
st'
       a -> StateT s m a
forall a. a -> StateT s m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
s

instance (MonadPlus m, MonadSyntax atom m) => MonadSyntax atom (Lazy.StateT s m) where
  anything :: StateT s m (Syntax atom)
anything = m (Syntax atom) -> StateT s m (Syntax atom)
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (Syntax atom)
forall atom (m :: * -> *). MonadSyntax atom m => m (Syntax atom)
anything
  cut :: forall a. StateT s m a
cut = m a -> StateT s m a
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m a
forall a. m a
forall atom (m :: * -> *) a. MonadSyntax atom m => m a
cut
  progress :: StateT s m Progress
progress = m Progress -> StateT s m Progress
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Progress
forall atom (m :: * -> *). MonadSyntax atom m => m Progress
progress
  delimit :: forall a. StateT s m a -> StateT s m a
delimit StateT s m a
m =
    do s
st <- StateT s m s
forall s (m :: * -> *). MonadState s m => m s
get
       (a
s, s
st') <- m (a, s) -> StateT s m (a, s)
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (a, s) -> StateT s m (a, s)) -> m (a, s) -> StateT s m (a, s)
forall a b. (a -> b) -> a -> b
$ m (a, s) -> m (a, s)
forall a. m a -> m a
forall atom (m :: * -> *) a. MonadSyntax atom m => m a -> m a
delimit (StateT s m a -> s -> m (a, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
Lazy.runStateT StateT s m a
m s
st)
       s -> StateT s m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put s
st'
       a -> StateT s m a
forall a. a -> StateT s m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
s
  call :: forall a. StateT s m a -> StateT s m a
call StateT s m a
m =
    do s
st <- StateT s m s
forall s (m :: * -> *). MonadState s m => m s
get
       (a
s, s
st') <- m (a, s) -> StateT s m (a, s)
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (a, s) -> StateT s m (a, s)) -> m (a, s) -> StateT s m (a, s)
forall a b. (a -> b) -> a -> b
$ m (a, s) -> m (a, s)
forall a. m a -> m a
forall atom (m :: * -> *) a. MonadSyntax atom m => m a -> m a
call (StateT s m a -> s -> m (a, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
Lazy.runStateT StateT s m a
m s
st)
       s -> StateT s m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put s
st'
       a -> StateT s m a
forall a. a -> StateT s m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
s
  withFocus :: forall a. Syntax atom -> StateT s m a -> StateT s m a
withFocus Syntax atom
stx StateT s m a
m =
    do s
st <- StateT s m s
forall s (m :: * -> *). MonadState s m => m s
get
       (a
s, s
st') <- m (a, s) -> StateT s m (a, s)
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (a, s) -> StateT s m (a, s)) -> m (a, s) -> StateT s m (a, s)
forall a b. (a -> b) -> a -> b
$ Syntax atom -> m (a, s) -> m (a, s)
forall a. Syntax atom -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Syntax atom -> m a -> m a
withFocus Syntax atom
stx (StateT s m a -> s -> m (a, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
Lazy.runStateT StateT s m a
m s
st)
       s -> StateT s m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put s
st'
       a -> StateT s m a
forall a. a -> StateT s m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
s
  withProgress :: forall a. (Progress -> Progress) -> StateT s m a -> StateT s m a
withProgress Progress -> Progress
p StateT s m a
m =
    do s
st <- StateT s m s
forall s (m :: * -> *). MonadState s m => m s
get
       (a
s, s
st') <- m (a, s) -> StateT s m (a, s)
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (a, s) -> StateT s m (a, s)) -> m (a, s) -> StateT s m (a, s)
forall a b. (a -> b) -> a -> b
$ (Progress -> Progress) -> m (a, s) -> m (a, s)
forall a. (Progress -> Progress) -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
(Progress -> Progress) -> m a -> m a
withProgress Progress -> Progress
p (StateT s m a -> s -> m (a, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
Lazy.runStateT StateT s m a
m s
st)
       s -> StateT s m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put s
st'
       a -> StateT s m a
forall a. a -> StateT s m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
s
  withReason :: forall a. Reason atom -> StateT s m a -> StateT s m a
withReason Reason atom
why StateT s m a
m =
    do s
st <- StateT s m s
forall s (m :: * -> *). MonadState s m => m s
get
       (a
s, s
st') <- m (a, s) -> StateT s m (a, s)
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (a, s) -> StateT s m (a, s)) -> m (a, s) -> StateT s m (a, s)
forall a b. (a -> b) -> a -> b
$ Reason atom -> m (a, s) -> m (a, s)
forall a. Reason atom -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Reason atom -> m a -> m a
withReason Reason atom
why (StateT s m a -> s -> m (a, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
Lazy.runStateT StateT s m a
m s
st)
       s -> StateT s m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put s
st'
       a -> StateT s m a
forall a. a -> StateT s m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
s

instance (Monoid w, MonadSyntax atom m) => MonadSyntax atom (Strict.WriterT w m) where
  anything :: WriterT w m (Syntax atom)
anything = m (Syntax atom) -> WriterT w m (Syntax atom)
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (Syntax atom)
forall atom (m :: * -> *). MonadSyntax atom m => m (Syntax atom)
anything
  cut :: forall a. WriterT w m a
cut = m a -> WriterT w m a
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m a
forall a. m a
forall atom (m :: * -> *) a. MonadSyntax atom m => m a
cut
  progress :: WriterT w m Progress
progress = m Progress -> WriterT w m Progress
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Progress
forall atom (m :: * -> *). MonadSyntax atom m => m Progress
progress
  delimit :: forall a. WriterT w m a -> WriterT w m a
delimit WriterT w m a
m =
    do (a
x, w
w) <- m (a, w) -> WriterT w m (a, w)
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (a, w) -> WriterT w m (a, w)) -> m (a, w) -> WriterT w m (a, w)
forall a b. (a -> b) -> a -> b
$ m (a, w) -> m (a, w)
forall a. m a -> m a
forall atom (m :: * -> *) a. MonadSyntax atom m => m a -> m a
delimit (m (a, w) -> m (a, w)) -> m (a, w) -> m (a, w)
forall a b. (a -> b) -> a -> b
$ WriterT w m a -> m (a, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
Strict.runWriterT WriterT w m a
m
       w -> WriterT w m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell w
w
       a -> WriterT w m a
forall a. a -> WriterT w m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
  call :: forall a. WriterT w m a -> WriterT w m a
call WriterT w m a
m =
    do (a
x, w
w) <- m (a, w) -> WriterT w m (a, w)
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (a, w) -> WriterT w m (a, w)) -> m (a, w) -> WriterT w m (a, w)
forall a b. (a -> b) -> a -> b
$ m (a, w) -> m (a, w)
forall a. m a -> m a
forall atom (m :: * -> *) a. MonadSyntax atom m => m a -> m a
call (m (a, w) -> m (a, w)) -> m (a, w) -> m (a, w)
forall a b. (a -> b) -> a -> b
$ WriterT w m a -> m (a, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
Strict.runWriterT WriterT w m a
m
       w -> WriterT w m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell w
w
       a -> WriterT w m a
forall a. a -> WriterT w m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
  withFocus :: forall a. Syntax atom -> WriterT w m a -> WriterT w m a
withFocus Syntax atom
stx WriterT w m a
m =
    do (a
x, w
w) <- m (a, w) -> WriterT w m (a, w)
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (a, w) -> WriterT w m (a, w)) -> m (a, w) -> WriterT w m (a, w)
forall a b. (a -> b) -> a -> b
$ Syntax atom -> m (a, w) -> m (a, w)
forall a. Syntax atom -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Syntax atom -> m a -> m a
withFocus Syntax atom
stx (m (a, w) -> m (a, w)) -> m (a, w) -> m (a, w)
forall a b. (a -> b) -> a -> b
$ WriterT w m a -> m (a, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
Strict.runWriterT WriterT w m a
m
       w -> WriterT w m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell w
w
       a -> WriterT w m a
forall a. a -> WriterT w m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
  withProgress :: forall a. (Progress -> Progress) -> WriterT w m a -> WriterT w m a
withProgress Progress -> Progress
p WriterT w m a
m =
    do (a
x, w
w) <- m (a, w) -> WriterT w m (a, w)
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (a, w) -> WriterT w m (a, w)) -> m (a, w) -> WriterT w m (a, w)
forall a b. (a -> b) -> a -> b
$ (Progress -> Progress) -> m (a, w) -> m (a, w)
forall a. (Progress -> Progress) -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
(Progress -> Progress) -> m a -> m a
withProgress Progress -> Progress
p (m (a, w) -> m (a, w)) -> m (a, w) -> m (a, w)
forall a b. (a -> b) -> a -> b
$ WriterT w m a -> m (a, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
Strict.runWriterT WriterT w m a
m
       w -> WriterT w m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell w
w
       a -> WriterT w m a
forall a. a -> WriterT w m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
  withReason :: forall a. Reason atom -> WriterT w m a -> WriterT w m a
withReason Reason atom
why WriterT w m a
m =
    do (a
x, w
w) <- m (a, w) -> WriterT w m (a, w)
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (a, w) -> WriterT w m (a, w)) -> m (a, w) -> WriterT w m (a, w)
forall a b. (a -> b) -> a -> b
$ Reason atom -> m (a, w) -> m (a, w)
forall a. Reason atom -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Reason atom -> m a -> m a
withReason Reason atom
why (m (a, w) -> m (a, w)) -> m (a, w) -> m (a, w)
forall a b. (a -> b) -> a -> b
$ WriterT w m a -> m (a, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
Strict.runWriterT WriterT w m a
m
       w -> WriterT w m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell w
w
       a -> WriterT w m a
forall a. a -> WriterT w m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

instance (Monoid w, MonadSyntax atom m) => MonadSyntax atom (Lazy.WriterT w m) where
  anything :: WriterT w m (Syntax atom)
anything = m (Syntax atom) -> WriterT w m (Syntax atom)
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (Syntax atom)
forall atom (m :: * -> *). MonadSyntax atom m => m (Syntax atom)
anything
  cut :: forall a. WriterT w m a
cut = m a -> WriterT w m a
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m a
forall a. m a
forall atom (m :: * -> *) a. MonadSyntax atom m => m a
cut
  progress :: WriterT w m Progress
progress = m Progress -> WriterT w m Progress
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Progress
forall atom (m :: * -> *). MonadSyntax atom m => m Progress
progress
  delimit :: forall a. WriterT w m a -> WriterT w m a
delimit WriterT w m a
m =
    do (a
x, w
w) <- m (a, w) -> WriterT w m (a, w)
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (a, w) -> WriterT w m (a, w)) -> m (a, w) -> WriterT w m (a, w)
forall a b. (a -> b) -> a -> b
$ m (a, w) -> m (a, w)
forall a. m a -> m a
forall atom (m :: * -> *) a. MonadSyntax atom m => m a -> m a
delimit (m (a, w) -> m (a, w)) -> m (a, w) -> m (a, w)
forall a b. (a -> b) -> a -> b
$ WriterT w m a -> m (a, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
Lazy.runWriterT WriterT w m a
m
       w -> WriterT w m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell w
w
       a -> WriterT w m a
forall a. a -> WriterT w m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
  call :: forall a. WriterT w m a -> WriterT w m a
call WriterT w m a
m =
    do (a
x, w
w) <- m (a, w) -> WriterT w m (a, w)
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (a, w) -> WriterT w m (a, w)) -> m (a, w) -> WriterT w m (a, w)
forall a b. (a -> b) -> a -> b
$ m (a, w) -> m (a, w)
forall a. m a -> m a
forall atom (m :: * -> *) a. MonadSyntax atom m => m a -> m a
call (m (a, w) -> m (a, w)) -> m (a, w) -> m (a, w)
forall a b. (a -> b) -> a -> b
$ WriterT w m a -> m (a, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
Lazy.runWriterT WriterT w m a
m
       w -> WriterT w m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell w
w
       a -> WriterT w m a
forall a. a -> WriterT w m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
  withFocus :: forall a. Syntax atom -> WriterT w m a -> WriterT w m a
withFocus Syntax atom
stx WriterT w m a
m =
    do (a
x, w
w) <- m (a, w) -> WriterT w m (a, w)
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (a, w) -> WriterT w m (a, w)) -> m (a, w) -> WriterT w m (a, w)
forall a b. (a -> b) -> a -> b
$ Syntax atom -> m (a, w) -> m (a, w)
forall a. Syntax atom -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Syntax atom -> m a -> m a
withFocus Syntax atom
stx (m (a, w) -> m (a, w)) -> m (a, w) -> m (a, w)
forall a b. (a -> b) -> a -> b
$ WriterT w m a -> m (a, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
Lazy.runWriterT WriterT w m a
m
       w -> WriterT w m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell w
w
       a -> WriterT w m a
forall a. a -> WriterT w m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
  withProgress :: forall a. (Progress -> Progress) -> WriterT w m a -> WriterT w m a
withProgress Progress -> Progress
p WriterT w m a
m =
    do (a
x, w
w) <- m (a, w) -> WriterT w m (a, w)
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (a, w) -> WriterT w m (a, w)) -> m (a, w) -> WriterT w m (a, w)
forall a b. (a -> b) -> a -> b
$ (Progress -> Progress) -> m (a, w) -> m (a, w)
forall a. (Progress -> Progress) -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
(Progress -> Progress) -> m a -> m a
withProgress Progress -> Progress
p (m (a, w) -> m (a, w)) -> m (a, w) -> m (a, w)
forall a b. (a -> b) -> a -> b
$ WriterT w m a -> m (a, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
Lazy.runWriterT WriterT w m a
m
       w -> WriterT w m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell w
w
       a -> WriterT w m a
forall a. a -> WriterT w m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
  withReason :: forall a. Reason atom -> WriterT w m a -> WriterT w m a
withReason Reason atom
why WriterT w m a
m =
    do (a
x, w
w) <- m (a, w) -> WriterT w m (a, w)
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (a, w) -> WriterT w m (a, w)) -> m (a, w) -> WriterT w m (a, w)
forall a b. (a -> b) -> a -> b
$ Reason atom -> m (a, w) -> m (a, w)
forall a. Reason atom -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Reason atom -> m a -> m a
withReason Reason atom
why (m (a, w) -> m (a, w)) -> m (a, w) -> m (a, w)
forall a b. (a -> b) -> a -> b
$ WriterT w m a -> m (a, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
Lazy.runWriterT WriterT w m a
m
       w -> WriterT w m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell w
w
       a -> WriterT w m a
forall a. a -> WriterT w m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

-- | Strip location information from a syntax object
syntaxToDatum :: Syntactic expr atom => expr -> Datum atom
syntaxToDatum :: forall expr atom. Syntactic expr atom => expr -> Datum atom
syntaxToDatum (A atom
x) = Layer Datum atom -> Datum atom
forall a. Layer Datum a -> Datum a
Datum (Layer Datum atom -> Datum atom) -> Layer Datum atom -> Datum atom
forall a b. (a -> b) -> a -> b
$ atom -> Layer Datum atom
forall (f :: * -> *) a. a -> Layer f a
Atom atom
x
syntaxToDatum (L [Syntax atom]
ls) = Layer Datum atom -> Datum atom
forall a. Layer Datum a -> Datum a
Datum (Layer Datum atom -> Datum atom) -> Layer Datum atom -> Datum atom
forall a b. (a -> b) -> a -> b
$ [Datum atom] -> Layer Datum atom
forall (f :: * -> *) a. [f a] -> Layer f a
List ([Datum atom] -> Layer Datum atom)
-> [Datum atom] -> Layer Datum atom
forall a b. (a -> b) -> a -> b
$ (Syntax atom -> Datum atom) -> [Syntax atom] -> [Datum atom]
forall a b. (a -> b) -> [a] -> [b]
map Syntax atom -> Datum atom
forall expr atom. Syntactic expr atom => expr -> Datum atom
syntaxToDatum [Syntax atom]
ls
syntaxToDatum expr
_ = String -> Datum atom
forall a. HasCallStack => String -> a
error String
"syntaxToDatum: impossible case - bad Syntactic instance"

-- | Succeed if and only if the focus satisfies a Boolean predicate.
satisfy :: MonadSyntax atom m => (Syntax atom -> Bool) -> m (Syntax atom)
satisfy :: forall atom (m :: * -> *).
MonadSyntax atom m =>
(Syntax atom -> Bool) -> m (Syntax atom)
satisfy Syntax atom -> Bool
p =
  do Syntax atom
foc <- m (Syntax atom)
forall atom (m :: * -> *). MonadSyntax atom m => m (Syntax atom)
anything
     if Syntax atom -> Bool
p Syntax atom
foc
       then Syntax atom -> m (Syntax atom)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Syntax atom
foc
       else m (Syntax atom)
forall a. m a
forall (f :: * -> *) a. Alternative f => f a
empty

-- | Succeed only if the focus, having been stripped of position
-- information, is structurally equal to some datum.
datum :: (MonadSyntax atom m, IsAtom atom, Eq atom) => Datum atom -> m ()
datum :: forall atom (m :: * -> *).
(MonadSyntax atom m, IsAtom atom, Eq atom) =>
Datum atom -> m ()
datum Datum atom
dat =
  Text -> m () -> m ()
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Text -> m a -> m a
describe (PrintRules atom -> Datum atom -> Text
forall a. IsAtom a => PrintRules a -> Datum a -> Text
datumToText PrintRules atom
forall a. Monoid a => a
mempty Datum atom
dat) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    (Syntax atom -> Bool) -> m (Syntax atom)
forall atom (m :: * -> *).
MonadSyntax atom m =>
(Syntax atom -> Bool) -> m (Syntax atom)
satisfy (\Syntax atom
stx -> Datum atom
dat Datum atom -> Datum atom -> Bool
forall a. Eq a => a -> a -> Bool
== Syntax atom -> Datum atom
forall expr atom. Syntactic expr atom => expr -> Datum atom
syntaxToDatum Syntax atom
stx) m (Syntax atom) -> m () -> m ()
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Succeed if and only if the focus is some particular given atom.
atom :: (MonadSyntax atom m, IsAtom atom, Eq atom) => atom -> m ()
atom :: forall atom (m :: * -> *).
(MonadSyntax atom m, IsAtom atom, Eq atom) =>
atom -> m ()
atom atom
a = Datum atom -> m ()
forall atom (m :: * -> *).
(MonadSyntax atom m, IsAtom atom, Eq atom) =>
Datum atom -> m ()
datum (Layer Datum atom -> Datum atom
forall a. Layer Datum a -> Datum a
Datum (atom -> Layer Datum atom
forall (f :: * -> *) a. a -> Layer f a
Atom atom
a))

-- | Succeed if and only if the focus is any atom, returning the atom.
atomic :: MonadSyntax atom m => m atom
atomic :: forall atom (m :: * -> *). MonadSyntax atom m => m atom
atomic = Text -> (Datum atom -> Maybe atom) -> m (Datum atom) -> m atom
forall atom (m :: * -> *) a b.
MonadSyntax atom m =>
Text -> (a -> Maybe b) -> m a -> m b
sideCondition Text
"an atom" Datum atom -> Maybe atom
forall {a}. Datum a -> Maybe a
perhapsAtom (Syntax atom -> Datum atom
forall expr atom. Syntactic expr atom => expr -> Datum atom
syntaxToDatum (Syntax atom -> Datum atom) -> m (Syntax atom) -> m (Datum atom)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Syntax atom)
forall atom (m :: * -> *). MonadSyntax atom m => m (Syntax atom)
anything)
  where perhapsAtom :: Datum a -> Maybe a
perhapsAtom (Datum (Atom a
a)) = a -> Maybe a
forall a. a -> Maybe a
Just a
a
        perhapsAtom Datum a
_ = Maybe a
forall a. Maybe a
Nothing

-- | Annotate a parser with a description, documenting its role in the
-- grammar. These descriptions are used to construct error messages.
describe :: MonadSyntax atom m => Text -> m a -> m a
describe :: forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Text -> m a -> m a
describe !Text
d m a
p =
  do Syntax atom
foc <- m (Syntax atom)
forall atom (m :: * -> *). MonadSyntax atom m => m (Syntax atom)
anything
     Reason atom -> m a -> m a
forall a. Reason atom -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Reason atom -> m a -> m a
withReason (Syntax atom -> Text -> Reason atom
forall atom. Syntax atom -> Text -> Reason atom
Reason Syntax atom
foc Text
d) m a
p

-- | Succeed if and only if the focus is the empty list.
emptyList :: MonadSyntax atom m => m ()
emptyList :: forall atom (m :: * -> *). MonadSyntax atom m => m ()
emptyList = Text -> m () -> m ()
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Text -> m a -> m a
describe (String -> Text
T.pack String
"empty expression ()") ((Syntax atom -> Bool) -> m (Syntax atom)
forall atom (m :: * -> *).
MonadSyntax atom m =>
(Syntax atom -> Bool) -> m (Syntax atom)
satisfy (Datum atom -> Bool
forall {a}. Datum a -> Bool
isNil (Datum atom -> Bool)
-> (Syntax atom -> Datum atom) -> Syntax atom -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Syntax atom -> Datum atom
forall expr atom. Syntactic expr atom => expr -> Datum atom
syntaxToDatum) m (Syntax atom) -> m () -> m ()
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  where isNil :: Datum a -> Bool
isNil (Datum (List [])) = Bool
True
        isNil Datum a
_ = Bool
False

-- | Succeed if and only if the focus is a list, returning its contents.
anyList :: MonadSyntax atom m => m [Syntax atom]
anyList :: forall atom (m :: * -> *). MonadSyntax atom m => m [Syntax atom]
anyList = Text
-> (Syntax atom -> Maybe [Syntax atom])
-> m (Syntax atom)
-> m [Syntax atom]
forall atom (m :: * -> *) a b.
MonadSyntax atom m =>
Text -> (a -> Maybe b) -> m a -> m b
sideCondition Text
"zero or more expressions, in parentheses" Syntax atom -> Maybe [Syntax atom]
forall {a}. Syntax a -> Maybe [Syntax a]
isList m (Syntax atom)
forall atom (m :: * -> *). MonadSyntax atom m => m (Syntax atom)
anything
  where isList :: Syntax a -> Maybe [Syntax a]
isList (Syntax (Posd (Layer Syntax a) -> Layer Syntax a
forall v. Posd v -> v
pos_val -> List [Syntax a]
xs)) = [Syntax a] -> Maybe [Syntax a]
forall a. a -> Maybe a
Just [Syntax a]
xs
        isList Syntax a
_ = Maybe [Syntax a]
forall a. Maybe a
Nothing

-- | If the current focus is a list, apply one parser to its head and
-- another to its tail.
cons :: MonadSyntax atom m => m a -> m b -> m (a, b)
cons :: forall atom (m :: * -> *) a b.
MonadSyntax atom m =>
m a -> m b -> m (a, b)
cons m a
a m b
d = m a -> (a -> m (a, b)) -> m (a, b)
forall atom (m :: * -> *) a b.
MonadSyntax atom m =>
m a -> (a -> m b) -> m b
depCons m a
a (\a
x -> m b
d m b -> (b -> m (a, b)) -> m (a, b)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \b
y -> (a, b) -> m (a, b)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
x, b
y))

-- | If the current focus is a list, apply one parser to its head and
-- another to its tail, ignoring the result of the head.
followedBy :: MonadSyntax atom m => m a -> m b -> m b
followedBy :: forall atom (m :: * -> *) a b.
MonadSyntax atom m =>
m a -> m b -> m b
followedBy m a
a m b
d = m a -> (a -> m b) -> m b
forall atom (m :: * -> *) a b.
MonadSyntax atom m =>
m a -> (a -> m b) -> m b
depCons m a
a (m b -> a -> m b
forall a b. a -> b -> a
const m b
d)

-- | Return the source position of the focus.
position :: MonadSyntax atom m => m Position
position :: forall atom (m :: * -> *). MonadSyntax atom m => m Position
position = Syntax atom -> Position
forall a. Syntax a -> Position
syntaxPos (Syntax atom -> Position) -> m (Syntax atom) -> m Position
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Syntax atom)
forall atom (m :: * -> *). MonadSyntax atom m => m (Syntax atom)
anything

-- | Manually add a progress step to the current path through the
-- context. Use this to appropriately guard calls to 'parse'.
withProgressStep :: (MonadSyntax atom m) => ProgressStep -> m a -> m a
withProgressStep :: forall atom (m :: * -> *) a.
MonadSyntax atom m =>
ProgressStep -> m a -> m a
withProgressStep ProgressStep
s = (Progress -> Progress) -> m a -> m a
forall a. (Progress -> Progress) -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
(Progress -> Progress) -> m a -> m a
withProgress (ProgressStep -> Progress -> Progress
pushProgress ProgressStep
s)

-- | A dependent cons (see 'depcons') that can impose a validation
-- step on the head of a list focus. If the head fails the validation
-- (that is, the second action returns 'Left'), the error is reported
-- in the head position.
depConsCond :: MonadSyntax atom m => m a -> (a -> m (Either Text b)) -> m b
depConsCond :: forall atom (m :: * -> *) a b.
MonadSyntax atom m =>
m a -> (a -> m (Either Text b)) -> m b
depConsCond m a
a a -> m (Either Text b)
d =
  do Syntax atom
focus <- m (Syntax atom)
forall atom (m :: * -> *). MonadSyntax atom m => m (Syntax atom)
anything
     case Syntax atom
focus of
       L (Syntax atom
e:[Syntax atom]
es) ->
         do a
x <- Syntax atom -> m a -> m a
forall a. Syntax atom -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Syntax atom -> m a -> m a
withFocus Syntax atom
e (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ ProgressStep -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
ProgressStep -> m a -> m a
withProgressStep ProgressStep
First (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ m a
a
            let cdr :: Syntax atom
cdr = Posd (Layer Syntax atom) -> Syntax atom
forall a. Posd (Layer Syntax a) -> Syntax a
Syntax (Position -> Layer Syntax atom -> Posd (Layer Syntax atom)
forall v. Position -> v -> Posd v
Posd (Syntax atom -> Position
forall a. Syntax a -> Position
syntaxPos Syntax atom
focus) ([Syntax atom] -> Layer Syntax atom
forall (f :: * -> *) a. [f a] -> Layer f a
List [Syntax atom]
es))
            Either Text b
res <- Syntax atom -> m (Either Text b) -> m (Either Text b)
forall a. Syntax atom -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Syntax atom -> m a -> m a
withFocus Syntax atom
cdr (m (Either Text b) -> m (Either Text b))
-> m (Either Text b) -> m (Either Text b)
forall a b. (a -> b) -> a -> b
$ ProgressStep -> m (Either Text b) -> m (Either Text b)
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
ProgressStep -> m a -> m a
withProgressStep ProgressStep
Rest (m (Either Text b) -> m (Either Text b))
-> m (Either Text b) -> m (Either Text b)
forall a b. (a -> b) -> a -> b
$ a -> m (Either Text b)
d a
x
            case Either Text b
res of
              Right b
answer -> b -> m b
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return b
answer
              Left Text
what -> Syntax atom -> m b -> m b
forall a. Syntax atom -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Syntax atom -> m a -> m a
withFocus Syntax atom
e (m b -> m b) -> m b -> m b
forall a b. (a -> b) -> a -> b
$ ProgressStep -> m b -> m b
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
ProgressStep -> m a -> m a
withProgressStep ProgressStep
First (m b -> m b) -> m b -> m b
forall a b. (a -> b) -> a -> b
$ m b -> m b
forall atom (m :: * -> *) a. MonadSyntax atom m => m a -> m a
later (m b -> m b) -> m b -> m b
forall a b. (a -> b) -> a -> b
$ Text -> m b -> m b
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Text -> m a -> m a
describe Text
what m b
forall a. m a
forall (f :: * -> *) a. Alternative f => f a
empty
       Syntax atom
_ -> m b
forall a. m a
forall (f :: * -> *) a. Alternative f => f a
empty

-- | Use the result of parsing the head of the current-focused list to
-- compute a parsing action to use for the tail of the list.
depCons :: MonadSyntax atom m => m a -> (a -> m b) -> m b
depCons :: forall atom (m :: * -> *) a b.
MonadSyntax atom m =>
m a -> (a -> m b) -> m b
depCons m a
a a -> m b
d =
  do Syntax atom
focus <- m (Syntax atom)
forall atom (m :: * -> *). MonadSyntax atom m => m (Syntax atom)
anything
     case Syntax atom
focus of
       L (Syntax atom
e:[Syntax atom]
es) ->
         do a
x <- Syntax atom -> m a -> m a
forall a. Syntax atom -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Syntax atom -> m a -> m a
withFocus Syntax atom
e (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ ProgressStep -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
ProgressStep -> m a -> m a
withProgressStep ProgressStep
First (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ m a
a
            let cdr :: Syntax atom
cdr = Posd (Layer Syntax atom) -> Syntax atom
forall a. Posd (Layer Syntax a) -> Syntax a
Syntax (Position -> Layer Syntax atom -> Posd (Layer Syntax atom)
forall v. Position -> v -> Posd v
Posd (Syntax atom -> Position
forall a. Syntax a -> Position
syntaxPos Syntax atom
focus) ([Syntax atom] -> Layer Syntax atom
forall (f :: * -> *) a. [f a] -> Layer f a
List [Syntax atom]
es))
            Syntax atom -> m b -> m b
forall a. Syntax atom -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Syntax atom -> m a -> m a
withFocus Syntax atom
cdr (m b -> m b) -> m b -> m b
forall a b. (a -> b) -> a -> b
$ ProgressStep -> m b -> m b
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
ProgressStep -> m a -> m a
withProgressStep ProgressStep
Rest (m b -> m b) -> m b -> m b
forall a b. (a -> b) -> a -> b
$ a -> m b
d a
x
       Syntax atom
_ -> m b
forall a. m a
forall (f :: * -> *) a. Alternative f => f a
empty

-- | Produce a parser that matches a list of things matched by another
-- parser.
rep :: MonadSyntax atom m => m a -> m [a]
rep :: forall atom (m :: * -> *) a. MonadSyntax atom m => m a -> m [a]
rep m a
p =
  do Syntax atom
focus <- m (Syntax atom)
forall atom (m :: * -> *). MonadSyntax atom m => m (Syntax atom)
anything
     case Syntax atom
focus of
       L [] ->
         [a] -> m [a]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
       L (Syntax atom
e:[Syntax atom]
es) ->
         do a
x <- Syntax atom -> m a -> m a
forall a. Syntax atom -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Syntax atom -> m a -> m a
withFocus Syntax atom
e (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ ProgressStep -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
ProgressStep -> m a -> m a
withProgressStep ProgressStep
First m a
p
            let cdr :: Syntax atom
cdr = Posd (Layer Syntax atom) -> Syntax atom
forall a. Posd (Layer Syntax a) -> Syntax a
Syntax (Position -> Layer Syntax atom -> Posd (Layer Syntax atom)
forall v. Position -> v -> Posd v
Posd (Syntax atom -> Position
forall a. Syntax a -> Position
syntaxPos Syntax atom
focus) ([Syntax atom] -> Layer Syntax atom
forall (f :: * -> *) a. [f a] -> Layer f a
List [Syntax atom]
es))
            [a]
xs <- Syntax atom -> m [a] -> m [a]
forall a. Syntax atom -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Syntax atom -> m a -> m a
withFocus Syntax atom
cdr (m [a] -> m [a]) -> m [a] -> m [a]
forall a b. (a -> b) -> a -> b
$ ProgressStep -> m [a] -> m [a]
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
ProgressStep -> m a -> m a
withProgressStep ProgressStep
Rest (m [a] -> m [a]) -> m [a] -> m [a]
forall a b. (a -> b) -> a -> b
$ m a -> m [a]
forall atom (m :: * -> *) a. MonadSyntax atom m => m a -> m [a]
rep m a
p
            [a] -> m [a]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs)
       Syntax atom
_ -> m [a]
forall a. m a
forall (f :: * -> *) a. Alternative f => f a
empty

-- | Manually override the focus. Use this with care - it can lead to
-- bogus error selection unless 'withProgress' is used to provide an
-- appropriate path.
parse :: MonadSyntax atom m => Syntax atom -> m a -> m a
parse :: forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Syntax atom -> m a -> m a
parse = Syntax atom -> m a -> m a
forall a. Syntax atom -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Syntax atom -> m a -> m a
withFocus

-- | Match a list focus elementwise.
list :: MonadSyntax atom m => [m a] -> m [a]
list :: forall atom (m :: * -> *) a. MonadSyntax atom m => [m a] -> m [a]
list [m a]
parsers = Text -> m [a] -> m [a]
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Text -> m a -> m a
describe Text
desc (m [a] -> m [a]) -> m [a] -> m [a]
forall a b. (a -> b) -> a -> b
$ [m a] -> m [a]
forall {m :: * -> *} {atom} {a}.
MonadSyntax atom m =>
[m a] -> m [a]
list' [m a]
parsers
  where desc :: Text
desc =
          Text -> Text -> Text
forall a. Monoid a => a -> a -> a
mappend (String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show ([m a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [m a]
parsers))) (String -> Text
T.pack String
" expressions")
        list' :: [m a] -> m [a]
list' [m a]
ps =
          do Syntax atom
focus <- m (Syntax atom)
forall atom (m :: * -> *). MonadSyntax atom m => m (Syntax atom)
anything
             case Syntax atom
focus of
               L [Syntax atom]
es -> Position -> [m a] -> [Syntax atom] -> m [a]
go (Syntax atom -> Position
forall a. Syntax a -> Position
syntaxPos Syntax atom
focus) [m a]
ps [Syntax atom]
es
               Syntax atom
_ -> m [a]
forall a. m a
forall (f :: * -> *) a. Alternative f => f a
empty

        go :: Position -> [m a] -> [Syntax atom] -> m [a]
go Position
_ [] [] = [a] -> m [a]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        go Position
_ (m a
_:[m a]
_) [] = m [a]
forall a. m a
forall (f :: * -> *) a. Alternative f => f a
empty
        go Position
_ [] (Syntax atom
_:[Syntax atom]
_) = m [a]
forall a. m a
forall (f :: * -> *) a. Alternative f => f a
empty
        go Position
loc (m a
p:[m a]
ps) (Syntax atom
e:[Syntax atom]
es) =
          do a
x <- Syntax atom -> m a -> m a
forall a. Syntax atom -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Syntax atom -> m a -> m a
withFocus Syntax atom
e (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ ProgressStep -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
ProgressStep -> m a -> m a
withProgressStep ProgressStep
First m a
p
             [a]
xs <- Syntax atom -> m [a] -> m [a]
forall a. Syntax atom -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Syntax atom -> m a -> m a
withFocus (Posd (Layer Syntax atom) -> Syntax atom
forall a. Posd (Layer Syntax a) -> Syntax a
Syntax (Position -> Layer Syntax atom -> Posd (Layer Syntax atom)
forall v. Position -> v -> Posd v
Posd Position
loc ([Syntax atom] -> Layer Syntax atom
forall (f :: * -> *) a. [f a] -> Layer f a
List [Syntax atom]
es))) (m [a] -> m [a]) -> m [a] -> m [a]
forall a b. (a -> b) -> a -> b
$
                   ProgressStep -> m [a] -> m [a]
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
ProgressStep -> m a -> m a
withProgressStep ProgressStep
Rest (m [a] -> m [a]) -> m [a] -> m [a]
forall a b. (a -> b) -> a -> b
$
                   [m a] -> m [a]
list' [m a]
ps
             [a] -> m [a]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs)

-- | Transform a parser such that its errors are considered to occur
-- after others, and thus be reported with a higher priority.
later :: MonadSyntax atom m => m a -> m a
later :: forall atom (m :: * -> *) a. MonadSyntax atom m => m a -> m a
later = ProgressStep -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
ProgressStep -> m a -> m a
withProgressStep ProgressStep
Late

-- | Impose a side condition on a parser, failing with the given
-- description if the side condition is 'Nothing'.
sideCondition :: MonadSyntax atom m => Text -> (a -> Maybe b) -> m a -> m b
sideCondition :: forall atom (m :: * -> *) a b.
MonadSyntax atom m =>
Text -> (a -> Maybe b) -> m a -> m b
sideCondition !Text
msg a -> Maybe b
ok m a
p =
  do a
x <- m a
p
     case a -> Maybe b
ok a
x of
       Just b
y -> b -> m b
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
y
       Maybe b
Nothing ->
         m b -> m b
forall atom (m :: * -> *) a. MonadSyntax atom m => m a -> m a
later (m b -> m b) -> m b -> m b
forall a b. (a -> b) -> a -> b
$ Text -> m b -> m b
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Text -> m a -> m a
describe Text
msg m b
forall a. m a
forall (f :: * -> *) a. Alternative f => f a
empty

-- | Impose a Boolean side condition on a parser, failing with the
-- given description if the side condition is 'False'.
sideCondition' :: MonadSyntax atom m => Text -> (a -> Bool) -> m a -> m a
sideCondition' :: forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Text -> (a -> Bool) -> m a -> m a
sideCondition' !Text
msg a -> Bool
ok m a
p = Text -> (a -> Maybe a) -> m a -> m a
forall atom (m :: * -> *) a b.
MonadSyntax atom m =>
Text -> (a -> Maybe b) -> m a -> m b
sideCondition Text
msg (\a
x -> if a -> Bool
ok a
x then a -> Maybe a
forall a. a -> Maybe a
Just a
x else Maybe a
forall a. Maybe a
Nothing) m a
p

-- | When the current focus is a list, reverse its contents while
-- invoking another parser. If it is not a list, fail.
backwards :: MonadSyntax atom m => m a -> m a
backwards :: forall atom (m :: * -> *) a. MonadSyntax atom m => m a -> m a
backwards m a
p =
  do Syntax atom
foc <- m (Syntax atom)
forall atom (m :: * -> *). MonadSyntax atom m => m (Syntax atom)
anything
     case Syntax atom
foc of
      l :: Syntax atom
l@(L [Syntax atom]
xs) -> Syntax atom -> m a -> m a
forall a. Syntax atom -> m a -> m a
forall atom (m :: * -> *) a.
MonadSyntax atom m =>
Syntax atom -> m a -> m a
withFocus (Posd (Layer Syntax atom) -> Syntax atom
forall a. Posd (Layer Syntax a) -> Syntax a
Syntax (Position -> Layer Syntax atom -> Posd (Layer Syntax atom)
forall v. Position -> v -> Posd v
Posd (Syntax atom -> Position
forall a. Syntax a -> Position
syntaxPos Syntax atom
l) ([Syntax atom] -> Layer Syntax atom
forall (f :: * -> *) a. [f a] -> Layer f a
List ([Syntax atom] -> [Syntax atom]
forall a. [a] -> [a]
reverse [Syntax atom]
xs)))) m a
p
      Syntax atom
_ -> m a
forall a. m a
forall (f :: * -> *) a. Alternative f => f a
empty

-- | Trivially succeed, but prevent backtracking.
commit :: MonadSyntax atom m => m ()
commit :: forall atom (m :: * -> *). MonadSyntax atom m => m ()
commit = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () m () -> m () -> m ()
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m ()
forall a. m a
forall atom (m :: * -> *) a. MonadSyntax atom m => m a
cut