[add ability to have complex pragmas, fix pragma parsing, allow warnings to accumulate during parsing and lexing. make parse monad member of useful classes
John Meacham <john@repetae.net>**20051206042714] {
hunk ./DerivingDrift/Drift.hs 28
-        ParseOk e -> e
+        ParseOk _ e -> e
hunk ./FrontEnd/FrontEnd.hs 67
-        Right o -> return o
-        Left s -> warn (srcLoc m) "unknown-option" ("Unknown OPTIONS in pragma module" <+> fromModule (hsModuleName m) <+>  s) >> return options
+        Just o -> return o
+        Nothing -> warn (srcLoc m) "unknown-option" ("Unknown OPTIONS in pragma module" <+> fromModule (hsModuleName m) <+>  show (hsModuleOptions m)) >> return options
hunk ./FrontEnd/Lexer.hs 27
+import Warning
hunk ./FrontEnd/Lexer.hs 43
+        | PragmaRules
hunk ./FrontEnd/Lexer.hs 198
-            '{':'-':'#':s | takeWhile isAlphaNum (dropWhile isSpace s) `Map.member` pragmas -> return bol
+            '{':'-':'#':s
+                | pname `Map.member` pragmas -> return bol
+                | otherwise -> do
+                    addWarn "unknown-pragma" $ "The pragma '" ++ pname ++ "' is unknown"
+                    discard 2
+                    bol <- lexNestedComment bol
+                    lexWhiteSpace bol
+                   where pname =  takeWhile isIdent (dropWhile isSpace s)
hunk ./FrontEnd/Lexer.hs 287
-            w <- lexWhile isAlphaNum
+            w <- lexWhile isIdent
hunk ./FrontEnd/Lexer.hs 289
-                (False,w') -> return (PragmaStart w')
-                (True,w') -> lexRawPragma w'
+                Right t -> return t
+                Left w' -> lexRawPragma w'
hunk ./FrontEnd/Lexer.hs 579
--- pragmas for which we want to parse the insides of
+
+-- pragmas which just have a simple string based start rule.
hunk ./FrontEnd/Lexer.hs 590
+-- pragmas with a special starting token
+pragmas_parsed = [
+    (["RULES"],PragmaRules)
+    ]
+
+pragmas_all = pragmas_parsed ++ [ (xs,PragmaStart x) | xs@(~(x:_)) <- pragmas_std ]
hunk ./FrontEnd/Lexer.hs 597
-pragmas = Map.fromList $ [ (y,(True,x)) | xs@(x:_)  <- pragmas_raw, y <- xs] ++  [ (y,(False,x)) | xs@(x:_)  <- pragmas_std , y <- xs]
+pragmas = Map.fromList $ [ (y,Left x) | xs@(x:_)  <- pragmas_raw, y <- xs] ++  [ (y,Right w) | (xs@(~(x:_)),w)  <- pragmas_all , y <- xs]
hunk ./FrontEnd/Lexer.hs 599
-normPragma :: String -> (Bool,String)
-normPragma s | Just v <- Map.lookup s pragmas  = v
+normPragma :: String -> Either String Token
+normPragma s | ~(Just v) <- Map.lookup s pragmas  = v
hunk ./FrontEnd/ParseMonad.hs 29
+import Warning
hunk ./FrontEnd/ParseMonad.hs 33
-	= ParseOk a		-- ^ The parse succeeded, yielding a value.
+	= ParseOk [Warning] a	-- ^ The parse succeeded, yielding a value and a set of warnings.
hunk ./FrontEnd/ParseMonad.hs 46
-type ParseState = [LexContext]
+--type ParseState = [LexContext]
+data ParseState = ParseState { psLexContext :: [LexContext], psWarnings :: [Warning] }
+    deriving(Show)
hunk ./FrontEnd/ParseMonad.hs 51
-indentOfParseState (Layout n:_) = n
+indentOfParseState ParseState { psLexContext = (Layout n:_) } = n
hunk ./FrontEnd/ParseMonad.hs 54
+emptyParseState = ParseState { psLexContext = [], psWarnings = [] }
+
hunk ./FrontEnd/ParseMonad.hs 86
-runParserWithMode mode (P m) s = case m s 0 1 start [] mode of
-	Ok _ a -> ParseOk a
+runParserWithMode mode (P m) s = case m s 0 1 start emptyParseState mode of
+	Ok s a -> ParseOk (psWarnings s) a
hunk ./FrontEnd/ParseMonad.hs 114
-getSrcLoc :: P SrcLoc
-getSrcLoc = P $ \_i _x _y l s _m -> Ok s l
+--getSrcLoc :: P SrcLoc
+
+instance MonadSrcLoc P where
+    getSrcLoc = P $ \_i _x _y l s _m -> Ok s l
+
+instance MonadWarn P where
+    addWarning w = P $ \_i _x _y _l s _m -> Ok s { psWarnings = w:psWarnings s } ()
hunk ./FrontEnd/ParseMonad.hs 139
-	P $ \_i _x _y _l s _m -> Ok (ctxt:s) ()
+	P $ \_i _x _y _l s _m -> Ok s { psLexContext = ctxt:psLexContext s } ()
hunk ./FrontEnd/ParseMonad.hs 143
-      case stk of
+      case psLexContext stk of
hunk ./FrontEnd/ParseMonad.hs 145
-            Ok s ()
+            Ok stk { psLexContext = s } ()
hunk ./FrontEnd/ParseMonad.hs 159
+instance MonadWarn (Lex r) where
+    addWarning w = Lex $ \k -> addWarning w >> k ()
+instance MonadSrcLoc (Lex r) where
+    getSrcLoc = Lex $ \k -> getSrcLoc >>= k
+
hunk ./FrontEnd/ParseMonad.hs 250
-		runP (cont ()) r x y loc (ctxt:stk)
+		runP (cont ()) r x y loc stk { psLexContext = ctxt:psLexContext stk }
hunk ./FrontEnd/ParseMonad.hs 253
-popContextL fn = Lex $ \cont -> P $ \r x y loc stk -> case stk of
-		(_:ctxt) -> runP (cont ()) r x y loc ctxt
+popContextL fn = Lex $ \cont -> P $ \r x y loc stk -> case psLexContext stk of
+		(_:ctxt) -> runP (cont ()) r x y loc stk { psLexContext = ctxt }
hunk ./FrontEnd/Warning.hs 1
-module Warning(Warning(..), MonadWarn(..), processErrors, warn, warnF, err, addDiag, addWarn, processIOErrors) where
+module Warning(Warning(..), MonadWarn(..), MonadSrcLoc(..), processErrors, warn, warnF, err, addDiag, addWarn, processIOErrors) where
hunk ./Ho.hs 403
-                      ParseOk e -> return e
+                      ParseOk ws e -> processErrors ws >> return e
hunk ./Interactive.hs 97
-                      ParseOk e -> return e
+                      ParseOk _ e -> return e
hunk ./test/Forall.hs 74
---f (Bob x) = x 'y'
+f (Bob x) = x 'y'
hunk ./test/Forall.hs 77
---    putChar $ f (Bob id)
+    putChar $ f (Bob id)
}
