SimpleParser.hs

{-# Language OverloadedStrings #-}
{-# Language FlexibleContexts #-}
module Foo where
import Control.Monad.Cont
import qualified Control.Monad.State as S
import Text.Megaparsec
import Text.Megaparsec.Char
import Data.Text (Text, pack)
import Data.Void
import Control.Applicative
import Data.Data

data Expr
   = And Expr Expr
   | Or Expr Expr
   | Imp Expr Expr
   | Bind Var Qualifier Expr
   --giving this a dependently typed flavor might be nicer
   | NConstraint Noun Entity
   | Constraint1 VP1 Entity
   | Constraint2 VP2 Entity Entity
   | Constraint3 VP3 Entity Entity Entity
   deriving (Show, Ord, Eq, Typeable)
data Noun = Woman | Boxer | Gift
  deriving (Show, Ord, Eq, Bounded, Enum)
data Entity = Var Var | Constant PN
  deriving (Show, Ord, Eq)
data Qualifier = Existential | Universal
  deriving (Show, Ord, Eq)
newtype Var = V Int
  deriving (Show, Ord, Eq)
data PN = Emily | Lana | Mark
  deriving (Show, Enum, Ord, Eq, Bounded)
data VP1 = Falls | Flies
  deriving (Show, Enum, Ord, Eq, Bounded)
data VP2 = Hits | Likes | Knows
  deriving (Show, Enum, Ord, Eq, Bounded)
data VP3 = Gives
  deriving (Show, Enum, Ord, Eq, Bounded)

main :: IO ()
main = print $ prettyPrint $ doParse "a boxer likes every boxer who knows Emily"
-- "Exists a.(Boxer(a) && All b.(Boxer(b) && Knows(b, Emily)->Likes(a, b)))"

-- ParsecT to parse, ContT for cps, State as a unqiue variable supply
type Parser r = ParsecT Void Text (ContT r (S.State Int))

pSentence :: Parser Expr Expr
pSentence = pNP <**> pVP

pNoun :: Parser Expr (Entity -> Expr)
pNoun = do
  noun <- NConstraint <$> pEnum
  relClause <- optional $ do
      _ <- string' "who " <|> string' "which " <|> string' "that "
      pVP
  case relClause of
      Nothing -> return noun
      Just clause -> return $ \e -> And (noun e) (clause e)

pVP :: Parser Expr (Entity -> Expr)
pVP = Constraint1 <$> pEnum
   <|> (\n a s -> Constraint2 n s a) <$> pEnum <*> pNP
   <|> (\n a b s -> Constraint3 n s a b)  <$> pEnum <*> pNP <*> pNP

pPN :: Parser r Entity
pPN =  Constant <$> pEnum
pDet :: Parser Expr Entity
pDet = pQualEvery <|> pQualA
pQualEvery, pQualA :: Parser Expr Entity
pQualEvery = string' "every " *> pNoun >>= mkUniversal
pQualA = string' "a " *> pNoun >>= mkExistential

getVar :: (S.MonadState Int m) => m Var
getVar = do
    i <- S.get
    S.put (i+1)
    return (V i)
mkBinding :: Qualifier -> (Expr -> Expr -> Expr) -> (Entity -> Expr) -> Parser Expr Entity
mkBinding qual conj n =  lift $ ContT $ \k -> do
    v <- getVar
    r <- k (Var v)
    return $ Bind v qual (conj (n $ Var v) r)
mkExistential :: (Entity -> Expr) -> Parser Expr Entity
mkExistential = mkBinding Existential And
mkUniversal :: (Entity -> Expr) -> Parser Expr Entity
mkUniversal = mkBinding Universal Imp
    

pNP :: Parser Expr Entity
pNP = pPN <|> pDet

pEnum :: (Bounded a, Enum a, Show a) => Parser r a
pEnum = choice [v <$ prVariant v | v <- [minBound..maxBound]] <* space
  where prVariant = try . string' . pack . show

doParse :: Text -> Expr
doParse t = flip S.evalState 0 $ flip runContT return $ unwrap <$> runParserT pSentence "" t
  where
    unwrap (Left err) = error (parseErrorPretty  err)
    unwrap (Right r) = r
prettyPrint :: Expr -> Text
prettyPrint (And a b) = prettyPrint a <> " && " <> prettyPrint b
prettyPrint (Or a b) = prettyPrint a <> " || " <> prettyPrint b
prettyPrint (Imp a b) = prettyPrint a <> "->" <> prettyPrint b
prettyPrint (Bind v Existential b) = "Exists " <> prVar v <> ".(" <> prettyPrint b <>")"
prettyPrint (Bind v Universal b) = "All " <> prVar v <> ".(" <> prettyPrint b<>")"
prettyPrint (NConstraint n e) = pack (show n) <> "(" <> prEntity e <> ")"
prettyPrint (Constraint1 n e) = pack (show n) <> "(" <> prEntity e <> ")"
prettyPrint (Constraint2 n e e2) = pack (show n) <> "(" <> prEntity e <> ", " <> prEntity e2 <> ")"
prettyPrint (Constraint3 n e e2 e3) = pack (show n) <> "(" <> prEntity e <> ", " <> prEntity e2 <> ", " <> prEntity e3 <>")"
prEntity :: Entity -> Text
prEntity (Var v) = prVar v
prEntity (Constant pn) = pack (show pn)
prVar :: Var -> Text
prVar (V a) = pack [toEnum (a +fromEnum 'a')]