Merge pull request #313 from razzius/allow_pragmas

Implement pragma handling

ghc-parser/generic-src/Language/Haskell/GHC/Parser.hs

@@ -67,7 +67,7 @@ data ParseOutput a
 -- | Store locations along with a value.
 data Located a = Located {
     line :: LineNumber, -- Where this element is located.
-    unloc :: a          -- Located element. 
+    unloc :: a          -- Located element.
   } deriving (Eq, Show, Functor)
 
 
@@ -101,17 +101,17 @@ runParser flags (Parser parserType parser) str =
     toParseOut $ unP parser parseState
   where
     toParseOut :: ParseResult a -> ParseOutput a
-    toParseOut (PFailed span@(RealSrcSpan realSpan) err) = 
+    toParseOut (PFailed span@(RealSrcSpan realSpan) err) =
       let errMsg = printErrorBag $ unitBag $ mkPlainErrMsg flags span err
           line = srcLocLine $ realSrcSpanStart realSpan
           col = srcLocCol $ realSrcSpanStart realSpan
         in Failure errMsg $ Loc line col
 
-    toParseOut (PFailed span err) = 
+    toParseOut (PFailed span err) =
       let errMsg = printErrorBag $ unitBag $ mkPlainErrMsg flags span err
         in Failure errMsg $ Loc 0 0
 
-    toParseOut (POk parseState result) = 
+    toParseOut (POk parseState result) =
       let parseEnd = realSrcSpanStart $ last_loc parseState
           endLine = srcLocLine parseEnd
           endCol = srcLocCol parseEnd
@@ -126,7 +126,7 @@ runParser flags (Parser parserType parser) str =
 -- | Split a string at a given line and column. The column is included in
 -- the second part of the split.
 splitAtLoc :: LineNumber -> ColumnNumber -> String -> (String, String)
-splitAtLoc line col string = 
+splitAtLoc line col string =
   if line > length (lines string)
   then (string, "")
   else (before, after)
@@ -145,7 +145,7 @@ joinLines = intercalate "\n"
 -- | Split an input string into chunks based on indentation.
 -- A chunk is a line and all lines immediately following that are indented
 -- beyond the indentation of the first line. This parses Haskell layout
--- rules properly, and allows using multiline expressions via indentation. 
+-- rules properly, and allows using multiline expressions via indentation.
 layoutChunks :: String -> [Located String]
 layoutChunks = go 1
   where
@@ -164,16 +164,16 @@ layoutChunks = go 1
     layoutLines _ [] = []
 
     -- Use the indent of the first line to find the end of the first block.
-    layoutLines lineIdx all@(firstLine:rest) = 
+    layoutLines lineIdx all@(firstLine:rest) =
       let firstIndent = indentLevel firstLine
           blockEnded line = indentLevel line <= firstIndent in
         case findIndex blockEnded rest of
           -- If the first block doesn't end, return the whole string, since
-          -- that just means the block takes up the entire string. 
+          -- that just means the block takes up the entire string.
           Nothing -> [Located lineIdx $ intercalate "\n" all]
 
           -- We found the end of the block. Split this bit out and recurse.
-          Just idx -> 
+          Just idx ->
             let (before, after) = splitAt idx rest in
               Located lineIdx (joinLines $ firstLine:before) : go (lineIdx + idx + 1) (joinLines after)
 
@@ -183,7 +183,7 @@ layoutChunks = go 1
 
     -- Count a tab as two spaces.
     indentLevel ('\t':str) = 2 + indentLevel str
-  
+
     -- Count empty lines as a large indent level, so they're always with the previous expression.
     indentLevel "" = 100000
 
@@ -192,7 +192,7 @@ layoutChunks = go 1
 -- | Drop comments from Haskell source.
 -- Simply gets rid of them, does not replace them in any way.
 removeComments :: String -> String
-removeComments = removeOneLineComments . removeMultilineComments 0
+removeComments = removeOneLineComments . removeMultilineComments 0 0
   where
     removeOneLineComments str =
       case str of
@@ -200,7 +200,7 @@ removeComments = removeOneLineComments . removeMultilineComments 0
         ':':'!':remaining ->":!" ++ takeLine remaining ++ dropLine remaining
 
         -- Handle strings.
-        '"':remaining -> 
+        '"':remaining ->
           let quoted = takeString remaining
               len = length quoted in
             '"':quoted ++ removeOneLineComments (drop len remaining)
@@ -211,31 +211,40 @@ removeComments = removeOneLineComments . removeMultilineComments 0
       where
         dropLine = removeOneLineComments . dropWhile (/= '\n')
 
-    removeMultilineComments nesting str =
+    removeMultilineComments nesting pragmaNesting str =
       case str of
         -- Don't remove comments after cmd directives
         ':':'!':remaining ->":!" ++ takeLine remaining ++
-          removeMultilineComments nesting (dropWhile (/= '\n') remaining)
+          removeMultilineComments nesting pragmaNesting (dropWhile (/= '\n') remaining)
 
         -- Handle strings.
-        '"':remaining -> 
+        '"':remaining ->
           if nesting == 0
-          then 
+          then
             let quoted = takeString remaining
                 len = length quoted in
-              '"':quoted ++ removeMultilineComments nesting (drop len remaining)
+              '"':quoted ++ removeMultilineComments nesting pragmaNesting (drop len remaining)
           else
-            removeMultilineComments nesting remaining
-
-        '{':'-':remaining -> removeMultilineComments (nesting + 1) remaining
-        '-':'}':remaining -> 
+            removeMultilineComments nesting pragmaNesting remaining
+        '{':'-':'#':remaining ->
+          if nesting == 0
+          then "{-#" ++ removeMultilineComments nesting (pragmaNesting + 1) remaining
+          else removeMultilineComments nesting pragmaNesting remaining
+        '#':'-':'}':remaining ->
+          if nesting == 0
+          then if pragmaNesting > 0
+               then '#':'-':'}':removeMultilineComments nesting (pragmaNesting - 1) remaining
+               else '#':'-':'}':removeMultilineComments nesting pragmaNesting remaining
+          else removeMultilineComments nesting pragmaNesting remaining
+        '{':'-':remaining -> removeMultilineComments (nesting + 1) pragmaNesting remaining
+        '-':'}':remaining ->
           if nesting > 0
-          then removeMultilineComments (nesting - 1) remaining
-          else '-':'}':removeMultilineComments nesting remaining
-        x:xs -> 
+          then removeMultilineComments (nesting - 1) pragmaNesting remaining
+          else '-':'}':removeMultilineComments nesting pragmaNesting remaining
+        x:xs ->
           if nesting > 0
-          then removeMultilineComments nesting xs
-          else x:removeMultilineComments nesting xs
+          then removeMultilineComments nesting pragmaNesting xs
+          else x:removeMultilineComments nesting pragmaNesting xs
         [] -> []
 
     takeLine = takeWhile (/= '\n')

src/IHaskell/Eval/Evaluate.hs

@@ -13,7 +13,7 @@ import ClassyPrelude hiding (init, last, liftIO, head, hGetContents, tail, try)
 import Control.Concurrent (forkIO, threadDelay)
 import Prelude (putChar, head, tail, last, init, (!!))
 import Data.List.Utils
-import Data.List(findIndex, and)
+import Data.List (findIndex, and)
 import Data.String.Utils
 import Text.Printf
 import Data.Char as Char
@@ -258,7 +258,7 @@ evaluate kernelState code output = do
       -- Merge them with normal display outputs.
       dispsIO <- extractValue "IHaskell.Display.displayFromChan"
       dispsMay <- liftIO dispsIO
-      let result = 
+      let result =
             case dispsMay of
               Nothing -> evalResult evalOut
               Just disps -> evalResult evalOut <> disps
@@ -415,7 +415,7 @@ evalCommand output (Directive SetDynFlag flags) state =
           -- For -XNoImplicitPrelude, remove the Prelude import.
           -- For -XImplicitPrelude, add it back in.
           case flag of
-            "-XNoImplicitPrelude" -> 
+            "-XNoImplicitPrelude" ->
               evalImport "import qualified Prelude as Prelude"
             "-XImplicitPrelude" -> do
               importDecl <- parseImportDecl "import Prelude"
@@ -881,6 +881,13 @@ evalCommand _ (ParseError loc err) state = do
     evalComms = []
   }
 
+evalCommand _ (Pragma (PragmaUnsupported pragmaType) pragmas) state = wrapExecution state $
+  return $ displayError $ "Pragmas of type " ++ pragmaType ++
+                          "\nare not supported."
+
+evalCommand output (Pragma PragmaLanguage pragmas) state = do
+  write $ "Got LANGUAGE pragma " ++ show pragmas
+  evalCommand output (Directive SetExtension $ unwords pragmas) state
 
 hoogleResults :: KernelState -> [Hoogle.HoogleResult] -> EvalOut
 hoogleResults state results = EvalOut {
@@ -986,7 +993,7 @@ keepingItVariable act = do
       var name = name ++ rand
       goStmt s = runStmt s RunToCompletion
       itVariable = var "it_var_temp_"
-  
+
   goStmt $ printf "let %s = it" itVariable
   val <- act
   goStmt $ printf "let it = %s" itVariable

src/IHaskell/Eval/Parser.hs

@@ -11,6 +11,7 @@ module IHaskell.Eval.Parser (
     parseDirective,
     getModuleName,
     Located(..),
+    PragmaType(..),
     ) where
 
 -- Hide 'unlines' to use our own 'joinLines' instead.
@@ -20,6 +21,7 @@ import Data.List (findIndex, maximumBy, maximum, inits)
 import Data.String.Utils (startswith, strip, split)
 import Data.List.Utils (subIndex)
 import Prelude (init, last, head, tail)
+import Control.Monad (msum)
 
 import Bag
 import ErrUtils hiding (ErrMsg)
@@ -48,6 +50,7 @@ data CodeBlock
   | Directive DirectiveType String     -- ^ An IHaskell directive.
   | Module String                      -- ^ A full Haskell module, to be compiled and loaded.
   | ParseError StringLoc ErrMsg        -- ^ An error indicating that parsing the code block failed.
+  | Pragma PragmaType [String]         -- ^ A list of GHC pragmas (from a {-# LANGUAGE ... #-} block)
   deriving (Show, Eq)
 
 -- | Directive types. Each directive is associated with a string in the
@@ -66,6 +69,13 @@ data DirectiveType
   | GetKind         -- ^ Get the kind of a type via ':kind'.
   deriving (Show, Eq)
 
+-- | Pragma types. Only LANGUAGE pragmas are currently supported.
+-- Other pragma types are kept around as a string for error reporting.
+data PragmaType
+  = PragmaLanguage
+  | PragmaUnsupported String
+  deriving (Show, Eq)
+
 -- | Parse a string into code blocks.
 parseString :: String -> Ghc [Located CodeBlock]
 parseString codeString = do
@@ -86,10 +96,12 @@ parseString codeString = do
       return result
   where
     parseChunk :: GhcMonad m => String -> LineNumber -> m (Located CodeBlock)
-    parseChunk chunk line = Located line <$>
-      if isDirective chunk
-      then return $ parseDirective chunk line
-      else parseCodeChunk chunk line
+    parseChunk chunk line = Located line <$> handleChunk chunk line
+      where
+        handleChunk chunk line
+          | isDirective chunk = return $ parseDirective chunk line
+          | isPragma chunk = return $ parsePragma chunk line
+          | otherwise = parseCodeChunk chunk line
 
     processChunks :: GhcMonad m => [Located CodeBlock] -> [Located String] -> m [Located CodeBlock]
     processChunks accum remaining =
@@ -100,27 +112,37 @@ parseString codeString = do
         -- If we have more remaining, parse the current chunk and recurse.
         Located line chunk:remaining ->  do
           block <- parseChunk chunk line
-          activateParsingExtensions $ unloc block
+          activateExtensions $ unloc block
           processChunks (block : accum) remaining
 
-    -- Test wither a given chunk is a directive.
+    -- Test whether a given chunk is a directive.
     isDirective :: String -> Bool
     isDirective = startswith ":" . strip
 
+    -- Test if a chunk is a pragma.
+    isPragma :: String -> Bool
+    isPragma = startswith "{-#" . strip
+
     -- Number of lines in this string.
     nlines :: String -> Int
     nlines = length . lines
 
-activateParsingExtensions :: GhcMonad m => CodeBlock -> m ()
-activateParsingExtensions (Directive SetExtension ext) = void $ setExtension ext
-activateParsingExtensions (Directive SetDynFlag flags) =
+activateExtensions :: GhcMonad m => CodeBlock -> m ()
+activateExtensions (Directive SetExtension ext) = void $ setExtension ext
+activateExtensions (Directive SetDynFlag flags) =
   case stripPrefix "-X" flags of
     Just ext -> void $ setExtension ext
     Nothing -> return ()
-activateParsingExtensions _ = return ()
+activateExtensions (Pragma PragmaLanguage extensions) = void $ setAll extensions
+  where
+    setAll :: GhcMonad m => [String] -> m (Maybe String)
+    setAll exts = do
+      errs <- mapM setExtension exts
+      return $ msum errs
+activateExtensions _ = return ()
 
 -- | Parse a single chunk of code, as indicated by the layout of the code.
-parseCodeChunk :: GhcMonad m => String -> LineNumber  -> m CodeBlock
+parseCodeChunk :: GhcMonad m => String -> LineNumber -> m CodeBlock
 parseCodeChunk code startLine = do
     flags <- getSessionDynFlags
     let
@@ -191,11 +213,11 @@ parseCodeChunk code startLine = do
 -- signature, which is also joined with the subsequent declarations.
 joinFunctions :: [Located CodeBlock] -> [Located CodeBlock]
 joinFunctions [] = []
-joinFunctions blocks = 
+joinFunctions blocks =
   if signatureOrDecl $ unloc $ head blocks
   then Located lnum (conjoin $ map unloc decls) : joinFunctions rest
   else head blocks : joinFunctions (tail blocks)
-  where 
+  where
     decls = takeWhile (signatureOrDecl . unloc) blocks
     rest = drop (length decls) blocks
     lnum = line $ head decls
@@ -211,6 +233,21 @@ joinFunctions blocks =
     conjoin :: [CodeBlock] -> CodeBlock
     conjoin = Declaration . intercalate "\n" . map str
 
+
+-- | Parse a pragma of the form {-# LANGUAGE ... #-}
+parsePragma :: String       -- ^ Pragma string.
+            -> Int          -- ^ Line number at which the directive appears.
+            -> CodeBlock    -- ^ Pragma code block or a parse error.
+parsePragma ('{':'-':'#':pragma) line =
+  let commaToSpace :: Char -> Char
+      commaToSpace ',' = ' '
+      commaToSpace x   = x
+      pragmas = words $ takeWhile (/= '#') $ map commaToSpace pragma in
+  case pragmas of
+    [] -> Pragma (PragmaUnsupported "") []  --empty string pragmas are unsupported
+    "LANGUAGE":xs -> Pragma PragmaLanguage xs
+    x:xs -> Pragma (PragmaUnsupported x) xs
+
 -- | Parse a directive of the form :directiveName.
 parseDirective :: String       -- ^ Directive string.
                -> Int          -- ^ Line number at which the directive appears.

src/IHaskell/Eval/Util.hs

@@ -52,7 +52,7 @@ data ExtFlag
 -- If no such extension exist, yield @Nothing@.
 extensionFlag :: String         -- Extension name, such as @"DataKinds"@
               -> Maybe ExtFlag
-extensionFlag ext = 
+extensionFlag ext =
   case find (flagMatches ext) xFlags of
     Just (_, flag, _) -> Just $ SetFlag flag
     -- If it doesn't match an extension name, try matching against
@@ -68,7 +68,7 @@ extensionFlag ext =
 
     -- Check if a FlagSpec matches "No<ExtensionName>".
     -- In that case, we disable the extension.
-    flagMatchesNo ext (name, _, _) = ext == "No"  ++ name
+    flagMatchesNo ext (name, _, _) = ext == "No" ++ name
 
 -- | Set an extension and update flags.
 -- Return @Nothing@ on success. On failure, return an error message.
@@ -78,7 +78,7 @@ setExtension ext = do
   case extensionFlag ext of
     Nothing -> return $ Just $ "Could not parse extension name: " ++ ext
     Just flag -> do
-      setSessionDynFlags $ 
+      setSessionDynFlags $
         case flag of
           SetFlag ghcFlag -> xopt_set flags ghcFlag
           UnsetFlag ghcFlag -> xopt_unset flags ghcFlag
@@ -101,7 +101,7 @@ setFlags ext = do
 
     -- Create the parse errors.
     let noParseErrs = map (("Could not parse: " ++) . unLoc) unrecognized
-        allWarns = map unLoc warnings ++ 
+        allWarns = map unLoc warnings ++
                      ["-package not supported yet" | packageFlags flags /= packageFlags flags']
         warnErrs    = map ("Warning: " ++) allWarns
     return $ noParseErrs ++ warnErrs
@@ -178,7 +178,7 @@ evalImport imports = do
     -- Check whether an import is the same as another import (same module).
     importOf :: ImportDecl RdrName -> InteractiveImport -> Bool
     importOf _ (IIModule _) = False
-    importOf imp (IIDecl decl) = 
+    importOf imp (IIDecl decl) =
       ((==) `on` (unLoc . ideclName)) decl imp && not (ideclQualified decl)
 
     -- Check whether an import is an *implicit* import of something.