forked from GitHub/gf-core
104 lines
3.2 KiB
Haskell
104 lines
3.2 KiB
Haskell
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)
|