Parser.hs

module Parser where

import Data.Char
import Control.Monad

import PGF2
import SusanneFormat
import Debug.Trace

newtype P a = P {runP :: PGF -> Concr -> [ParseTree] -> Maybe ([ParseTree], a)}

instance Monad P where
  return x = P (\pgf cnc ts -> Just (ts, x))
  f >>= g  = P (\pgf cnc ts -> case runP f pgf cnc ts of
                                    Nothing     -> Nothing
                                    Just (ts,x) -> runP (g x) pgf cnc ts)

instance MonadPlus P where
  mzero = P (\pgf cnc ts -> Nothing)
  mplus f g = P (\pgf cnc ts -> mplus (runP f pgf cnc ts) (runP g pgf cnc ts))

getConcr = P (\pgf cnc ts -> Just (ts,cnc))

match convert tag_spec = P (\pgf cnc ts ->
  case ts of
    (t@(Phrase tag1 mods1 fn1 _ _):ts)
      | tag == tag1 &&
        all (flip elem mods1) mods &&
        (null fn || fn == fn1)  -> Just (ts,convert pgf cnc t)
    (t@(Word _ tag1 _ _):ts)
      | tag == tag1 && null mods-> Just (ts,convert pgf cnc t)
    _                           -> Nothing)
  where
    (f,_) = readTag (Word "<match>" undefined undefined undefined) tag_spec
    Phrase tag mods fn _ _ = f []

many1 f = do
  x  <- f
  xs <- many f
  return (x:xs)

many f = 
  do x  <- f
     xs <- many f
     return (x:xs)
  `mplus`
  do return []

inside tag_spec p = P (\pgf cnc ts ->
  case ts of
    (t@(Phrase tag1 mods1 fn1 _ ts'):ts)
      | tag == tag1 &&
        all (flip elem mods1) mods &&
        (null fn || fn == fn1)  -> case runP p pgf cnc ts' of
                                     Just ([],x) -> Just (ts,x)
                                     _           -> Nothing
    _                           -> Nothing)
  where
    (f,_) = readTag (Word "<match>" undefined undefined undefined) tag_spec
    Phrase tag mods fn _ _ = f []

insideOpt convert tag_spec p = P (\pgf cnc ts ->
  case ts of
    (t@(Phrase tag1 mods1 fn1 _ ts'):ts)
      | tag == tag1 &&
        all (flip elem mods1) mods &&
        (null fn || fn == fn1)  -> case runP p pgf cnc ts' of
                                     Just ([],x) -> Just (ts,x)
                                     _           -> Just (ts,convert pgf cnc t)
    _                           -> Nothing)
  where
    (f,_) = readTag (Word "<match>" undefined undefined undefined) tag_spec
    Phrase tag mods fn _ _ = f []

lemma tag cat an0 = P (\pgf cnc ts ->
  case ts of
    (t@(Word _ tag1 form _):ts) | tag == tag1 -> case runP (lookupForm cat an0 form) pgf cnc ts of
                                                   Nothing -> Just (ts,t)
                                                   x       -> x
    _                                         -> Nothing)

lookupForm cat an0 form = P (\pgf cnc ts ->
  case [f | (f,an,_) <- lookupMorpho cnc form, hasCat pgf f cat, an == an0] of
    []  -> case [f | (f,an,_) <- lookupMorpho cnc (map toLower form), hasCat pgf f cat, an == an0] of
             [f] -> Just (ts,App f [])
             _   -> Nothing
    [f] -> Just (ts,App f [])
    _   -> Nothing)
  where
    hasCat pgf f cat =
      case functionType pgf f of
        (DTyp _ cat1 _) -> cat1 == cat

opt f =
  do x <- f
     return (Just x)
  `mplus`
  do return Nothing

word tag = P (\pgf cnc ts ->
  case ts of
    ((Word _ tag1 form _):ts) | tag == tag1 -> Just (ts,form)
    _                                       -> Nothing)