added the GF version of Talbanken which was imported by Malin

1 files changed, 193 insertions, 0 deletions

diff --git a/treebanks/talbanken/MonadSP.hs b/treebanks/talbanken/MonadSP.hs
new file mode 100644
index 000000000..ceddddfe5
--- /dev/null
+++ b/treebanks/talbanken/MonadSP.hs
@@ -0,0 +1,193 @@
+{-# 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 ((),[])) 
+