summaryrefslogtreecommitdiff
path: root/src/GF/GFCC/Raw/ParGFCCRaw.hs
diff options
context:
space:
mode:
authoraarne <aarne@cs.chalmers.se>2008-06-25 16:43:48 +0000
committeraarne <aarne@cs.chalmers.se>2008-06-25 16:43:48 +0000
commitb96b36f43de3e2f8b58d5f539daa6f6d47f25870 (patch)
tree0992334be13cec6538a1dea22fbbf26ad6bdf224 /src/GF/GFCC/Raw/ParGFCCRaw.hs
parentfe367412e0aeb4ad5c02de68e6eca382e0f96984 (diff)
removed src for 2.9
Diffstat (limited to 'src/GF/GFCC/Raw/ParGFCCRaw.hs')
-rw-r--r--src/GF/GFCC/Raw/ParGFCCRaw.hs99
1 files changed, 0 insertions, 99 deletions
diff --git a/src/GF/GFCC/Raw/ParGFCCRaw.hs b/src/GF/GFCC/Raw/ParGFCCRaw.hs
deleted file mode 100644
index b71904948..000000000
--- a/src/GF/GFCC/Raw/ParGFCCRaw.hs
+++ /dev/null
@@ -1,99 +0,0 @@
-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