-- |
-- Module      : MonusWeightedSearch.Examples.Parsing
-- Copyright   : (c) Donnacha Oisín Kidney 2021
-- Maintainer  : mail@doisinkidney.com
-- Stability   : experimental
-- Portability : non-portable
--
-- A probabilistic parser, implemented using the 'Heap' monad.
--
-- The main interesting thing about this parser is that it is defined by
-- flipping the order of 'State' and 'Heap' in the monad stack (the other way
-- around you get a monad for things like Dijkstra's algorithm,
-- "MonusWeightedSearch.Examples.Dijkstra").
--
-- The parser itself is a /probabilistic/ parser, meaning that it can have a
-- preference for certain parse trees over others, based on their likelihood.
-- When the parser is run the output is listed in order of each likelihood.

module MonusWeightedSearch.Examples.Parsing where

import Control.Applicative
import Control.Monad.Heap
import Control.Monad.State
import Data.Monus.Prob
import Control.Monad.Writer
import Control.Monad (guard)

-- | A standard parser type.
--
-- Compare to @type Parser a b = [a] -> [(b, [a])]@: we have swapped out the
-- list here for the heap, allowing for efficient ordering of results.
type Parser a = StateT [a] (Heap Prob)

-- | Parse an empty string.
eof :: Parser a ()
eof :: forall a. Parser a ()
eof = ([a] -> Heap Prob ((), [a])) -> StateT [a] (Heap Prob) ()
forall s (m :: Type -> Type) a. (s -> m (a, s)) -> StateT s m a
StateT \case
  [] -> ((), [a]) -> Heap Prob ((), [a])
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((), [])
  [a]
_ -> Heap Prob ((), [a])
forall (f :: Type -> Type) a. Alternative f => f a
empty

-- | Parse a single char.
anyChar :: Parser a a
anyChar :: forall a. Parser a a
anyChar = ([a] -> Heap Prob (a, [a])) -> StateT [a] (Heap Prob) a
forall s (m :: Type -> Type) a. (s -> m (a, s)) -> StateT s m a
StateT \case
  (a
x:[a]
xs) -> (a, [a]) -> Heap Prob (a, [a])
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (a
x, [a]
xs)
  [] -> Heap Prob (a, [a])
forall (f :: Type -> Type) a. Alternative f => f a
empty

-- | Filter the output of a parse.
satisfy :: (b -> Bool) -> Parser a b -> Parser a b
satisfy :: forall b a. (b -> Bool) -> Parser a b -> Parser a b
satisfy b -> Bool
p Parser a b
xs = do
  b
x <- Parser a b
xs
  Bool -> StateT [a] (Heap Prob) ()
forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard (b -> Bool
p b
x)
  pure b
x

-- | Assign a parse result a /probability/: when the parser is run, it will
-- order results from most to least likely.
condition :: (b -> Prob) -> Parser a b -> Parser a b
condition :: forall b a. (b -> Prob) -> Parser a b -> Parser a b
condition b -> Prob
c Parser a b
xs = do
  b
x <- Parser a b
xs
  Prob -> StateT [a] (Heap Prob) ()
forall w (m :: Type -> Type). MonadWriter w m => w -> m ()
tell (b -> Prob
c b
x)
  pure b
x

-- | Parse a string, ordering the results from most to least likely.
parse :: Parser a b -> [a] -> [(b, Prob)]
parse :: forall a b. Parser a b -> [a] -> [(b, Prob)]
parse Parser a b
p [a]
xs = Heap Prob b -> [(b, Prob)]
forall w a. Monus w => Heap w a -> [(a, w)]
search (Parser a b -> [a] -> Heap Prob b
forall (m :: Type -> Type) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Parser a b
p Parser a b -> StateT [a] (Heap Prob) () -> Parser a b
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f a
<* StateT [a] (Heap Prob) ()
forall a. Parser a ()
eof) [a]
xs)