Probabilistic Parser Combinators

import Text.Megaparsec
import Text.Megaparsec.Char
import Data.Char
import qualified Data.Text as T
import Control.Monad.Bayes.Class
import Control.Monad.Bayes.Sampler.Strict
import Control.Monad.Bayes.Weighted
import Control.Monad.Bayes.Population
import Control.Monad.Bayes.Enumerator
import Control.Monad.Bayes.Inference.SMC
import Control.Monad.Trans (lift)
import Control.Monad (join, replicateM)
import Data.Void
import Control.Monad.Bayes.Enumerator
import Text.Pretty.Simple

:e OverloadedStrings
:e FlexibleContexts
:e GADTs
:e LambdaCase

Probability interfaces nicely with parser combinators from libraries like megaparsec. A parser in this setting is roughly a function [Char] -> m (a, [Char]), in other words a function which (monadically) strips off a prefix of the input string and returns a result.

To make this probabilistic, we simply set m to a probability monad. The result of parsing is then a distribution over possible parses (and possible parse failures).

alphabet = map (: []) ['h', 'i', 'x']

noise x = do
    perturb <- lift $ bernoulli 0.1
    if perturb then lift $ uniformD alphabet else return x

letter = do
    true <-  lift $ uniformD ["h", "i","x"]
    predicted <- noise true
    observed <- lookAhead (foldr1 (<|>) ["h","i", "x"])
    lift . condition $ predicted == observed
    string observed
    return $ head true 
    
word = (do 
    wd <- some letter
    lift $ factor (if wd `elem` ["hi", "goodbye"] then 100 else 1)
    return wd
    ) <* eof

errorBundlePretty' :: (TraversableStream s, VisualStream s) => ParseErrorBundle s Void -> String 
errorBundlePretty' = errorBundlePretty


run parser input = either (T.pack . errorBundlePretty' ) (T.pack . show) <$> runParserT parser "" input

pPrintCustom = pPrintOpt CheckColorTty defaultOutputOptionsNoColor {outputOptionsCompact = True, outputOptionsIndentAmount = 2} 

runWordParser w = do
    x <- sampler 
        . population 
        . smc SMCConfig {numSteps = 5, numParticles = 3000, resampler = resampleMultinomial} 
        $ run word w
    pPrintCustom $ toEmpiricalWeighted x
    
runWordParser "hx"

[
  ( ""hi"", 0.7563333333333333 )
,
  ( ""hx"", 0.20799999999999993 )
,
  ( ""xx"", 1.5000000000000038 e- 2 )
,
  ( ""hh"", 1.06666666666667 e- 2 )
,
  ( ""ix"", 1.0000000000000014 e- 2 )
]

runWordParser "ii"

[
  ( ""hi"", 0.7813333333333331 )
,
  ( ""ii"", 0.2046666666666667 )
,
  ( ""xi"", 6.66666666666668 e- 3 )
,
  ( ""ix"", 4.333333333333346 e- 3 )
,
  ( ""ih"", 1.6666666666666711 e- 3 )
,
  ( ""xh"", 1.0000000000000028 e- 3 )
,
  ( ""xx"", 3.333333333333342 e- 4 )
]

runWordParser "hii"

[
  ( ""hii"", 0.8063333333333336 )
,
  ( ""xii"", 3.9333333333333186 e- 2 )
,
  ( ""hhi"", 3.533333333333321 e- 2 )
,
  ( ""hix"", 2.966666666666659 e- 2 )
,
  ( ""hih"", 2.8999999999999908 e- 2 )
,
  ( ""hxi"", 2.633333333333325 e- 2 )
,
  ( ""iii"", 1.666666666666663 e- 2 )
,
  ( ""hxx"", 4.333333333333327 e- 3 )
,
  ( ""xih"", 3.999999999999995 e- 3 )
,
  ( ""ixi"", 3.6666666666666636 e- 3 )
,
  ( ""hhx"", 2.666666666666665 e- 3 )
,
  ( ""xxi"", 2.3333333333333314 e- 3 )
,
  ( ""hhh"", 3.333333333333324 e- 4 )
]