{-# LANGUAGE RecursiveDo #-}
import Control.Applicative
import Text.Earley
import qualified Data.HashSet as HS

type Noun      = String
type Verb      = String
type Adjective = String

nouns, verbs, adjectives :: HS.HashSet String
nouns      = HS.fromList ["parsers", "sentences", "grammars"]
verbs      = HS.fromList ["parse", "munch", "annihilate", "confuse", "use"]
adjectives = HS.fromList ["many", "great", "long", "confusing"]


data Sentence = Sentence NounPhrase VerbPhrase
  deriving Show
data NounPhrase = NounPhrase Adjective NounPhrase
                | Noun Noun
  deriving Show
data VerbPhrase = VerbPhrase Verb NounPhrase
                | Verb Verb
  deriving Show

sentence :: Grammar r (Prod r String String Sentence)
sentence = mdo
  noun       <- rule $ satisfy (`HS.member` nouns)      <?> "noun"
  verb       <- rule $ satisfy (`HS.member` verbs)      <?> "verb"
  adjective  <- rule $ satisfy (`HS.member` adjectives) <?> "adjective"
  nounPhrase <- rule $  NounPhrase <$> adjective <*> nounPhrase
                    <|> Noun <$> noun
                    <?> "noun phrase"
  verbPhrase <- rule $  VerbPhrase <$> verb <*> nounPhrase
                    <|> Verb <$> verb
                    <?> "verb phrase"
  return $ Sentence <$> nounPhrase <*> verbPhrase <?> "sentence"

main :: IO ()
main = do
  let p = fullParses (parser sentence) . words
  print $ p "parsers use grammars"
  print $ p "parsers munch long sentences"
  print $ p "many great sentences confuse parsers"
  print $ p "parsers use use"
  print $ p "grammars many great confusing"