AB grammars and extensible effects can do some fun things—depends on Eff1.hs found on <http://okmij.org/ftp/Haskell/extensible/>

AB_grammar.hs

{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleInstances, FlexibleContexts,
             TypeFamilies, GADTs, TypeOperators, DataKinds, PolyKinds, RankNTypes,
             KindSignatures, UndecidableInstances, StandaloneDeriving,
             RecordWildCards, DeriveFunctor, DeriveFoldable, DeriveTraversable  #-}
module AB where


import           Prelude hiding (lookup, lex)
import           Control.Applicative ((<|>),empty)
import           Data.Maybe (maybeToList)
import           Data.Singletons.Decide (Decision(..),(:~:)(..),(%~))
import           Data.Singletons.Prelude
import           Data.Singletons.TH (singletons)
import           Eff1 (Eff,Reader,Writer,ask,tell,run,runReader,runWriter)
import           Text.Parsec (char,letter,spaces,many1,chainr1)
import qualified Text.Parsec (parse)


-- * Syntactic & Semantic Types

singletons [d|

  data SynT = S | N | NP | SynT :-> SynT | SynT :<- SynT deriving (Show,Eq)
  data SemT = E | T | SemT :=> SemT deriving (Show,Eq)

  |]

infixr 5 :->
infixl 5 :<-
infixr 5 :=>

type S      = 'S
type N      = 'N
type NP     = 'NP
type IV     = NP :-> S
type TV     = IV :<- NP
type a :-> b = a ':-> b
type b :<- a = b ':<- a

sS  :: SSynT S
sS  = SS
sN  :: SSynT N
sN  = SN
sNP :: SSynT NP
sNP = SNP
mNP :: SSynT (NP :<- NP)
mNP = SNP :%<- SNP
sIV :: SSynT IV
sIV = SNP :%-> SS
sTV :: SSynT TV
sTV = sIV :%<- SNP

type E      = 'E
type T      = 'T
type a :=> b = a ':=> b


-- * Translation from Syntactic to Semantic Types

type family Tr (t :: SynT) :: SemT where
  Tr 'S        = 'T
  Tr 'N        = 'E ':=> 'T
  Tr 'NP       = 'E
  Tr (a ':-> b) = Tr a ':=> Tr b
  Tr (b ':<- a) = Tr a ':=> Tr b

data Typed (expr :: SemT -> *) where
  Typed :: (SSynT a, expr (Tr a)) -> Typed expr


-- * Parse Trees

data Tree a where
  Leaf :: a -> Tree a
  Node :: Tree a -> Tree a -> Tree a

deriving instance (Show a) => (Show (Tree a))
deriving instance (Functor Tree)
deriving instance (Foldable Tree)
deriving instance (Traversable Tree)


-- * Lexicon & Parsing

data Lexicon expr = Lexicon
  { lookup :: String -> [Typed expr]
  , apply  :: forall a b. expr (a :=> b) -> expr a -> expr b
  }


maybeApply :: Lexicon expr -> Typed expr -> Typed expr -> Maybe (Typed expr)
maybeApply lex (Typed (a1,x)) (Typed (a2 :%-> b,f)) =
  case a1 %~ a2 of
    Proved Refl -> pure (Typed (b, apply lex f x))
    _           -> empty
maybeApply lex (Typed (b :%<- a1,f)) (Typed (a2,x)) =
  case a1 %~ a2 of
    Proved Refl -> pure (Typed (b, apply lex f x))
    _           -> empty
maybeApply _ _ _ = empty


parse :: Lexicon expr -> String -> SSynT a -> [expr (Tr a)]
parse lex str a1 =
  case Text.Parsec.parse sent "" str of
    Left  _ -> empty
    Right t -> exec =<< (comp =<< traverse (lookup lex) t)
  where
    exec (Typed (a2,x)) =
      case a1 %~ a2 of
        Proved Refl -> pure x
        _           -> empty

    comp (Leaf e)     = pure e
    comp (Node t1 t2) =
      do e1 <- comp t1; e2 <- comp t2; maybeToList (maybeApply lex e1 e2)

    sent = chainr1 atom node
      where
        word = Leaf <$> many1 letter
        atom = word <|> (char '(' *> (sent <* char ')'))
        node = pure Node <* spaces



-- * Example using Eff in Haskell

data Entity = Tim | Bob

data Pred where
  Like   :: Entity -> Entity -> Pred
  Stupid :: Entity -> Pred

deriving instance Show Entity
deriving instance Show Pred


type family ToEff r t :: * where
  ToEff r E        = Eff r Entity
  ToEff r T        = Eff r Pred
  ToEff r (a :=> b) = ToEff r a -> ToEff r b

newtype Ext r a = Ext (ToEff r a)

type RW = (Reader Entity ': Writer Pred ': '[])


-- * Example using freer monad, more extensible effects

lex :: String -> [Typed (Ext RW)]
lex "tim"    = pure (Typed (sNP , Ext (pure Tim)))
lex "bob"    = pure (Typed (sNP , Ext (pure Bob)))
lex "likes"  = pure (Typed (sTV , Ext (\y x -> Like <$> x <*> y)))
lex "stupid" = pure (Typed (mNP , Ext (\x -> x >>= \x -> tell (Stupid x) *> pure x)))
lex "him"    = pure (Typed (sNP , Ext ask))

app :: (ToEff r t ~ (ToEff r a -> ToEff r b)) => Ext r t -> Ext r a -> Ext r b
app (Ext f) (Ext x) = Ext (f x)

ext :: Lexicon (Ext RW)
ext = Lexicon { lookup = lex, apply = app }

runExt :: Ext RW T -> Entity -> (Pred, [Pred])
runExt (Ext e) x = run (runWriter (runReader e x))

s1 :: [(Pred, [Pred])]
s1 = runExt <$> parse ext "(stupid bob) likes him" SS <*> pure Tim
-- [(Like Bob Tim,[Stupid Bob])]


-- -}
-- -}
-- -}
-- -}
-- -}