gf-core/treebanks/talbanken/MonadSP.hs

{-# LANGUAGE FlexibleInstances, 
             MultiParamTypeClasses, 
             ScopedTypeVariables, 
             FlexibleContexts, 
             UndecidableInstances #-}
module MonadSP  ( Rule(..), Grammar, grammar
             , P, parse
             , cat, word, word2, lemma, inside, insideSuff, transform
             , many, many1, opt
             , optEat, consume, wordlookup,write
             ) where
import Data.Tree
import Data.Char
import Data.List
import qualified Data.Map as Map
import Control.Monad
import Control.Monad.State
import Control.Monad.Writer
import PGF hiding (Tree,parse)


infix 1 :->


data Rule    m t e = t :-> P t e m e
type Grammar m t e = t -> PGF -> Morpho -> [Tree t] -> m e

instance Show t => Show (Rule m t e) where
  show (t :-> x) = show t


grammar :: (MonadWriter [String] m,MonadState s m,Ord t,Show t,Show e) 
        => ([e] -> e) -> [Rule m t e] -> Grammar m t e
grammar def rules = gr 
  where
    gr = \tag -> do
      
      let retry = \pgf m ts -> case ts of 
            [Node w []] -> return (def [])
            trs         -> def `liftM` sequence [ gr tag pgf m trs' 
                                                | Node tag trs' <- trs]
 
      case Map.lookup tag pmap of
        Just f -> \pgf m ts -> do 
           stored <- get 
           r <- unP f gr pgf m ts 
           case r of
              Just (e,[]) -> return e
              Just (e,xs) -> tell ["Rest parse"] >> retry pgf m ts -- use xs here?
              Nothing     -> put stored          >> retry pgf m ts
        Nothing -> retry 

    -- If many rules match, try all of them (mplus)
    pmap = Map.fromListWith mplus (map (\(t :-> r) -> (t,r)) rules)

newtype P t e m a = P {unP :: Grammar m t e -> PGF -> Morpho -> [Tree t] -> m (Maybe (a,[Tree t]))} 

instance Monad m => Monad (P t e m) where
  return x = P $ \gr pgf m ts -> return (Just (x,ts))
  f >>= g  = P $ \gr pgf m ts -> unP f gr pgf m ts >>= \r -> case r of
                                  Just (x,ts') -> unP (g x) gr pgf m ts'
                                  Nothing      -> return Nothing

instance MonadState s m => MonadPlus (P t e m) where
  mzero     = P $ \gr pgf m ts -> return Nothing
  mplus f g = P $ \gr pgf m ts -> do 
    store <- get
    res <- unP f gr pgf m ts
    case res of
      Just x  -> return (Just x)
      Nothing -> put store >> unP g gr pgf m ts
      
instance MonadState s m => MonadState s (P t e m) where
  put s = P $ \gr pgf m ts -> put s >> return (Just ((),ts))
  get   = P $ \gr pgf m ts -> get >>= \s -> return (Just (s,ts))
  
instance MonadWriter w m => MonadWriter w (P t e m) where
  tell w = P $ \gr pgf m ts -> tell w >> return (Just ((),ts))
  listen = error "listen not implemented for P"
  pass   = error "pass not implemented for P"
                                     
-- write x = tell [x]
write :: MonadWriter [w] m => w -> P t e m ()
write = tell . return

instance MonadTrans (P t e) where
  lift m = P $ \gr p morpho ts -> m >>= \r -> return (Just (r,ts))

parse :: Monad m => Grammar m t e -> PGF -> Morpho -> Tree t -> m e
parse gr pgf morpho (Node tag ts) = gr tag pgf morpho ts

silent m     = (m,[])
speak  s (m,w) = (m,s:w)
speaks s (m,w) = (m,s++w)
addS   s m = (m,s)
add    s m = (m,[s])


cat :: (Monad m,Eq t,Show t) => [t] -> P [t] e m e
cat tag = P $ \gr pgf morpho ts ->
  case ts of
    Node tag1 ts1 : ts | tag `isPrefixOf` tag1
                                       -> gr tag1 pgf morpho ts1 >>= \r -> return (Just (r,ts))
    _                                  -> return Nothing

word :: (Monad m,Show t,Eq t) => [t] -> P [t] e m [t]
word tag = P $ \gr pgf morpho ts -> return $
  case ts of
    (Node tag1 [Node w []] : ts) | tag `isPrefixOf` tag1 
                                               -> Just (w,ts)
    _                                          -> Nothing


word2 :: (Monad m,Eq t) => t -> P t e m t
word2 tag = P $ \gr pgf morpho ts -> return $
  case ts of
    (Node tag1 [Node tag2 [Node w []]] : ts) | tag == tag1 -> Just (w,ts)
    _                                                      -> Nothing


inside, insideSuff :: (MonadWriter [String] m,Eq t,Show t)=> [t] -> P [t] e m a -> P [t] e m a          
insideSuff = inside' isSuffixOf
inside     = inside' isPrefixOf

inside' :: (MonadWriter [String] m,Eq t,Show t)=>
              ([t] -> [t] -> Bool) -> [t] -> P [t] e m a -> P [t] e m a          
inside' isEq tag f = P $ \gr pgf morpho ts ->
  case ts of
    Node tag1 ts1 : ts | tag `isEq` tag1 -> do
                            tell [show tag++" "++show tag1]
                            unP f gr pgf morpho ts1 >>= \r -> case r of
                                            Just (x,[]) -> return (Just (x,ts))
                                            Just (x,xs) -> tell ["inside fail "++show xs] >> return Nothing
                                            Nothing     -> return Nothing
    _                       -> return Nothing


magicLookup :: String -> String -> String -> Morpho -> PGF -> [Lemma]
magicLookup w cat0 an0 morpho pgf = [ lem 
                                | (lem, an1) <- lookupMorpho morpho (map toLower w)
                                , let cat1 = maybe "" (showType []) (functionType pgf lem)
                                , cat0 == cat1 && an0 == an1
                                ] 

wordlookup :: MonadWriter [String] m => String -> String -> String -> P String e m CId
wordlookup w cat0 an0 = P $ \gr pgf morpho ts -> do
  tell ["wordlookup: " ++ w ++ show ts ++ show cat0]
  let wds = magicLookup w cat0 an0 morpho pgf
  tell [show wds]
  case wds of
    (wd:_) -> return $ Just (wd,ts)
    []     -> return Nothing
  
  
lemma :: MonadWriter [String] m => String -> String -> P String e m CId
lemma cat = liftM head . lemmas cat

lemmas :: MonadWriter [String] m => String -> String -> P String e m [CId]
lemmas cat0 an0 = P $ \gr pgf morpho ts -> do
   tell ["lemma: "++show ts++show cat0]
   case ts of
     Node w [] : ts -> case magicLookup w cat0 an0 morpho pgf of
                          (id:ids) -> tell ["lemma ok"] >> return (Just (id:ids,ts))
                          _        -> tell ["no word "++w++cat0++an0]  >> return Nothing
     _              -> tell ["tried to lemma a tag"]    >> return Nothing


transform :: Monad m => ([Tree t] -> [Tree t]) -> P t e m ()
transform f = P $ \gr pgf morpho ts -> return (Just ((),f ts))

many :: MonadState s m => P t e m a -> P t e m [a]
many f = many1 f
         `mplus`
         return []

many1 :: MonadState s m => P t e m a -> P t e m [a]
many1 f = do x  <- f
             xs <- many f
             return (x:xs)

opt :: MonadState s m => P t e m a -> a -> P t e m a
opt f x = mplus f (return x)  

optEat :: MonadState s m => P t e m a -> a -> P t e m a
optEat f x = mplus f (consume >> return x)  


consume :: Monad m => P t e m ()
consume = P $ \gr pgf morpho ts ->
  case ts of
   Node x w:ws -> return (Just ((),ws))
   []          -> return (Just ((),[]))