blob: b71904948dcf4c10d6f7298f9c8c6f0bf88a63f8 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
|
module GF.GFCC.Raw.ParGFCCRaw (parseGrammar) where
import GF.GFCC.Raw.AbsGFCCRaw
import Control.Monad
import Data.Char
parseGrammar :: String -> IO Grammar
parseGrammar s = case runP pGrammar s of
Just (x,"") -> return x
_ -> fail "Parse error"
pGrammar :: P Grammar
pGrammar = liftM Grm pTerms
pTerms :: P [RExp]
pTerms = liftM2 (:) (pTerm 1) pTerms <++ (skipSpaces >> return [])
pTerm :: Int -> P RExp
pTerm n = skipSpaces >> (pParen <++ pApp <++ pNum <++ pStr <++ pMeta)
where pParen = between (char '(') (char ')') (pTerm 0)
pApp = liftM2 App pIdent (if n == 0 then pTerms else return [])
pStr = char '"' >> liftM AStr (manyTill (pEsc <++ get) (char '"'))
pEsc = char '\\' >> get
pNum = do x <- munch1 isDigit
((char '.' >> munch1 isDigit >>= \y -> return (AFlt (read (x++"."++y))))
<++
return (AInt (read x)))
pMeta = char '?' >> return AMet
pIdent = liftM CId $ liftM2 (:) (satisfy isIdentFirst) (munch isIdentRest)
isIdentFirst c = c == '_' || isAlpha c
isIdentRest c = c == '_' || c == '\'' || isAlphaNum c
-- Parser combinators with only left-biased choice
newtype P a = P { runP :: String -> Maybe (a,String) }
instance Monad P where
return x = P (\ts -> Just (x,ts))
P p >>= f = P (\ts -> p ts >>= \ (x,ts') -> runP (f x) ts')
fail _ = pfail
instance MonadPlus P where
mzero = pfail
mplus = (<++)
get :: P Char
get = P (\ts -> case ts of
[] -> Nothing
c:cs -> Just (c,cs))
look :: P String
look = P (\ts -> Just (ts,ts))
(<++) :: P a -> P a -> P a
P p <++ P q = P (\ts -> p ts `mplus` q ts)
pfail :: P a
pfail = P (\ts -> Nothing)
satisfy :: (Char -> Bool) -> P Char
satisfy p = do c <- get
if p c then return c else pfail
char :: Char -> P Char
char c = satisfy (c==)
string :: String -> P String
string this = look >>= scan this
where
scan [] _ = return this
scan (x:xs) (y:ys) | x == y = get >> scan xs ys
scan _ _ = pfail
skipSpaces :: P ()
skipSpaces = look >>= skip
where
skip (c:s) | isSpace c = get >> skip s
skip _ = return ()
manyTill :: P a -> P end -> P [a]
manyTill p end = scan
where scan = (end >> return []) <++ liftM2 (:) p scan
munch :: (Char -> Bool) -> P String
munch p = munch1 p <++ return []
munch1 :: (Char -> Bool) -> P String
munch1 p = liftM2 (:) (satisfy p) (munch p)
choice :: [P a] -> P a
choice = msum
between :: P open -> P close -> P a -> P a
between open close p = do open
x <- p
close
return x
|
