Changed the lexing and parsing of PRAGMAs again, to allow unknown pragmas

With my previous change to PRAGMAs, unknown pragmas would fatally fail in the lexer, so that an unknown pragma would always stop compilation, which is not good.  I've changed it more towards Adam's suggestion of re-lexing and re-parsing the pragma from the parser, so we now gracefully ignore unknown pragmas again.  The lexer is a bit messy, though.

frontends/LexOccam.x

@@ -20,6 +20,7 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 -- | Lexically analyse occam code.
 module LexOccam where
 
+import Control.Monad.Error
 import Data.Generics
 
 import Errors
@@ -35,8 +36,8 @@ $hexDigit = [0-9 a-f A-F]
 $horizSpace = [\ \t]
 $vertSpace = [\r\n]
 
-@directive = "COMMENT" | "ELSE" | "ENDIF" | "IF" | "INCLUDE"
-           | "OPTION" | "RELAX" | "USE" | "DEFINE"
+@directive = "COMMENT"  | "DEFINE" | "ELSE" | "ENDIF" | "IF" | "INCLUDE"
+           | "OPTION" | "PRAGMA" | "RELAX" | "USE"
 
 @preprocessor = "#" @directive [^\n]*
 
@@ -100,12 +101,15 @@ occam :-
 -- In state two, we're reading the rest of the line.
 -- In state three, we're in the middle of a multi-line string.
 -- In state four, we're in the middle of a pragma-external string
+-- In state five, we're lexing a pragma.  State five is only entered specifically,
+--   when we re-lex and re-parse pragmas (but it makes it easiest to put it
+--   in this file too, since it can lex occam).
 
 <0>           $horizSpace*   { mkState one }
 
-<one>         "#PRAGMA" $horizSpace+ "SHARED" { mkToken TokPreprocessor two }
-<one>         "#PRAGMA" $horizSpace+ "PERMITALIASES" { mkToken TokPreprocessor two }
-<one>         "#PRAGMA" $horizSpace+ "EXTERNAL" $horizSpace* \" { mkToken TokPreprocessor four }
+<five>        "SHARED" { mkToken Pragma two }
+<five>        "PERMITALIASES" { mkToken Pragma two }
+<five>        "EXTERNAL" $horizSpace* \" { mkToken Pragma four }
 <four>        \" $horizSpace* $vertSpace+ { mkState 0 }
 
 <one>         @preprocessor  { mkToken TokPreprocessor 0 }
@@ -134,7 +138,7 @@ occam :-
 <four>    @hexLiteral    { mkToken TokHexLiteral four }
 <four>    @realLiteral   { mkToken TokRealLiteral four }
 
-<two, four>         $horizSpace+   ;
+<two, four, five>         $horizSpace+   ;
 
 {
 -- | An occam source token and its position.
@@ -215,5 +219,30 @@ runLexer filename str = go (alexStartPos, '\n', str) 0
                  metaLine = line,
                  metaColumn = col
                }
+
+-- | Run the lexer, returning a list of tokens.
+-- (This is based on the `alexScanTokens` function that Alex provides.)
+runPragmaLexer :: String -> String -> Either (Maybe Meta, String) [Token]
+runPragmaLexer filename str = go (alexStartPos, '\n', str) five
+  where
+    go inp@(pos@(AlexPn _ line col), _, str) code =
+         case alexScan inp code of
+           AlexEOF -> return []
+           AlexError _ -> throwError (Just meta, "Unrecognised token")
+           AlexSkip inp' len -> go inp' code
+           AlexToken inp' len act ->
+             do let (t, code) = act pos (take len str)
+                ts <- go inp' code
+                return $ case t of
+                           Just (Token _ tt) -> Token meta tt : ts
+                           Nothing -> ts
+
+      where
+        meta = emptyMeta {
+                 metaFile = Just filename,
+                 metaLine = line,
+                 metaColumn = col
+               }
+
 }
 

frontends/ParseOccam.hs

@@ -1344,12 +1344,25 @@ structuredTypeField
 --}}}
 --{{{ pragmas
 pragma :: OccParser ()
-pragma = do Pragma p <- genToken isPragma
+pragma = do Pragma rawP <- genToken isPragma
             m <- getPosition >>* sourcePosToMeta
-            case map (flip matchRegex p . mkRegex)
-                   [ "^SHARED.*"
-                   , "^PERMITALIASES.*"
-                   , "^EXTERNAL.*"] of
+            pragToks <- case runPragmaLexer "<unknown(pragma)>" rawP of
+              Left _ -> return []
+              Right toks -> return toks
+            cs <- getCompState
+            maybeParse <- return $
+                        -- Maybe monad:
+              (\prod -> do otherToks <- safeTail pragToks
+                           eitherToMaybe $ runParser (prod >> getState) ([], cs) "" otherToks
+              ) $        -- Maybe monad again:
+               case
+                 [ do Token _ (Pragma firstTok) <- listToMaybe pragToks
+                      matchRegex (mkRegex pt) firstTok
+                 | pt <- [ "^SHARED.*"
+                        , "^PERMITALIASES.*"
+                        , "^EXTERNAL.*"
+                        ]
+                 ] of
               [Just _, _, _] -> do
                 vars <- sepBy1 identifier sComma
                 mapM_ (\var ->
@@ -1386,11 +1399,18 @@ pragma = do Pragma p <- genToken isPragma
                   , csExternals = (on, fs) : csExternals st
                   }
               _ -> warnP m WarnUnknownPreprocessorDirective $
-                "Unknown PRAGMA: " ++ p
+                "Unknown PRAGMA: " ++ show (listToMaybe pragToks)
+            case maybeParse of
+              Just st -> setState st
+              Nothing -> return ()
             eol
   where
     isPragma (Token _ p@(Pragma {})) = Just p
     isPragma _ = Nothing
+
+    safeTail [] = Nothing
+    safeTail (_:xs) = Just xs
+
 --}}}
 --{{{ processes
 process :: OccParser A.Process