#19 Allow parsers to be IO functions

src/core/Language/Astview/Language.hs

@@ -15,6 +15,7 @@ module Language.Astview.Language
   , Ast(..)
   , Error (..)
   , SrcLocException(..)
+  , Parser(..)
   )
 where
 import Prelude hiding (span)
@@ -59,6 +60,11 @@ instance Show AstNode where
 -- |An (untyped) abstract syntax tree is just a tree of 'AstNode's.
 newtype Ast = Ast { ast :: Tree AstNode }
 
+-- |A parser is a function which transforms a string into an untyped abstract
+-- syntax tree.
+data Parser = PureParser (String -> Either Error Ast)
+            | IoParser (String -> IO (Either Error Ast))
+
 -- |A value of 'Language' states how files (associated with this language by
 -- their file extentions 'exts') are being parsed.
 -- The file extentions of all languages known to astview may overlap, since
@@ -70,7 +76,7 @@ data Language = Language
   -- ^ (kate) syntax highlighter name. Use @[]@ if no highlighting is desired.
   , exts :: [String]
    -- ^ file extentions which should be associated with this language
-  , parse :: String -> Either Error Ast -- ^ parse function
+  , parser :: Parser -- ^ parse function
   }
 
 -- |Since parsers return different

src/core/Language/Astview/Languages/Haskell.hs

@@ -2,7 +2,7 @@ module Language.Astview.Languages.Haskell (haskellExts) where
 import           Prelude                                hiding (span)
 
 import           Language.Astview.DataTree              (dataToAstIgnoreByExample)
-import           Language.Astview.Language              hiding (parse)
+import           Language.Astview.Language
 
 import           Data.Generics                          (Data, extQ)
 import           Data.Generics.Zipper                   (down', query, toZipper)
@@ -11,7 +11,7 @@ import           Language.Haskell.Exts.Parser           (ParseResult (..),parseM
 import qualified Language.Haskell.Exts.SrcLoc           as HsSrcLoc
 
 haskellExts :: Language
-haskellExts = Language "Haskell" "Haskell" [".hs"] parsehs
+haskellExts = Language "Haskell" "Haskell" [".hs"] (PureParser parsehs)
 
 parsehs :: String -> Either Error Ast
 parsehs s = case parseModule s of

src/core/Language/Astview/Languages/HaskellCore.hs

@@ -7,7 +7,7 @@ import           Data.Generics.Zipper      (down', query, toZipper)
 import           Data.Tree                 (Tree (Node))
 
 import           Language.Astview.DataTree (manual)
-import           Language.Astview.Language hiding (parse)
+import           Language.Astview.Language
 
 import qualified DynFlags                  as GHC
 import           FastString
@@ -24,16 +24,16 @@ import           StringBuffer
 
 import           GHC.Paths                 (libdir)
 
-import           System.IO.Unsafe
-
 haskellCore :: Language
-haskellCore = Language "HaskellCore" "Haskell" [".hs"] parsehs
+haskellCore = Language "HaskellCore" "Haskell" [".hs"] (IoParser parsehs)
 
-parsehs :: String -> Either Error Ast
-parsehs s =
-  case runParser s parseModule of
-    POk _ parsed -> Right (coreToAst parsed)
-    PFailed ss msg -> Left $ makeError ss (showSDoc (unsafePerformIO getDynFlags) msg)
+parsehs :: String -> IO (Either Error Ast)
+parsehs s = do
+  dynFlags <- getDynFlags
+  return $
+    case runParser dynFlags s parseModule of
+      POk _ parsed -> Right (coreToAst parsed)
+      PFailed ss msg -> Left $ makeError ss (showSDoc dynFlags msg)
 
 makeError :: GHC.SrcSpan -> String -> Error
 makeError ss s =
@@ -51,13 +51,13 @@ ghcss2ss real
                    (GHC.srcLocLine end)
                    (GHC.srcLocCol end)
 
-runParser :: String -> P a -> ParseResult a
-runParser str parser = unP parser parseState
+runParser :: GHC.DynFlags -> String -> P a -> ParseResult a
+runParser flags str parser = unP parser parseState
     where
       filename = "<interactive>"
       location = GHC.mkRealSrcLoc (mkFastString filename) 1 1
       buffer = stringToStringBuffer str
-      parseState = mkPState (unsafePerformIO getDynFlags) buffer location
+      parseState = mkPState flags buffer location
 
 getDynFlags :: IO GHC.DynFlags
 getDynFlags =

src/core/Language/Astview/Languages/Python.hs

@@ -10,7 +10,7 @@ import Data.Generics (Data,extQ)
 import Data.Generics.Zipper(toZipper,down,query)
 
 python :: Language
-python = Language "Python" "Python" [".py"] parsePy
+python = Language "Python" "Python" [".py"] (PureParser parsePy)
 
 parsePy :: String -> Either Error Ast
 parsePy s = case parseModule s [] of

src/gui/Language/Astview/Gui/Actions.hs

@@ -58,7 +58,10 @@ actionGetAst :: Language -> AstAction (Either Error Ast)
 actionGetAst l = do
   plain <- getText
   flattening <- getFlattenLists
-  return $ (if flattening then flatten else id) <$> parse l plain
+  errOrAst <- case parser l of
+    PureParser p -> return $ p plain
+    IoParser p -> liftIO $ p plain
+  return $ (if flattening then flatten else id) <$> errOrAst
 
 -- | parses the contents of the sourceview with the selected language
 actionParse :: Language -> AstAction (Tree String)