purescript · natefaubion · May 5, 2019 · Apr 10, 2019 · Apr 10, 2019 · Apr 11, 2019
diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs
@@ -18,6 +18,7 @@ import           Data.Text (Text)
 import qualified Data.Text as T
 import           Data.Traversable (for)
 import qualified Language.PureScript as P
+import qualified Language.PureScript.CST as CST
 import           Language.PureScript.Errors.JSON
 import           Language.PureScript.Make
 import qualified Options.Applicative as Opts
@@ -65,8 +66,8 @@ compile PSCMakeOptions{..} = do
     exitFailure
   moduleFiles <- readInput input
   (makeErrors, makeWarnings) <- runMake pscmOpts $ do
-    ms <- P.parseModulesFromFiles id moduleFiles
-    let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, Right fp)) ms
+    ms <- CST.parseModulesFromFiles id moduleFiles
+    let filePathMap = M.fromList $ map (\(fp, pm) -> (P.getModuleName $ CST.resPartial pm, Right fp)) ms
     foreigns <- inferForeignModules filePathMap
     let makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix
     P.make makeActions (map snd ms)

diff --git a/app/Command/Hierarchy.hs b/app/Command/Hierarchy.hs
@@ -33,6 +33,7 @@ import           System.Exit (exitFailure, exitSuccess)
 import           System.IO (hPutStr, stderr)
 import           System.IO.UTF8 (readUTF8FileT)
 import qualified Language.PureScript as P
+import qualified Language.PureScript.CST as CST
 import           Language.PureScript.Hierarchy (Graph(..), _unDigraph, _unGraphName, typeClasses)
 
 data HierarchyOptions = HierarchyOptions
@@ -43,7 +44,7 @@ data HierarchyOptions = HierarchyOptions
 readInput :: [FilePath] -> IO (Either P.MultipleErrors [P.Module])
 readInput paths = do
   content <- mapM (\path -> (path, ) <$> readUTF8FileT path) paths
-  return $ map snd <$> P.parseModulesFromFiles id content
+  return $ map snd <$> CST.parseFromFiles id content
 
 compile :: HierarchyOptions -> IO ()
 compile (HierarchyOptions inputGlob mOutput) = do

diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs
@@ -36,6 +36,7 @@ import           Data.Text (Text, unpack)
 import           Data.Traversable (for)
 import qualified Language.PureScript as P
 import qualified Language.PureScript.Bundle as Bundle
+import qualified Language.PureScript.CST as CST
 import           Language.PureScript.Interactive
 import           Network.HTTP.Types.Header (hContentType, hCacheControl,
                                             hPragma, hExpires)
@@ -315,10 +316,10 @@ command = loop <$> options
           when (null modules) . liftIO $ do
             putStr noInputMessage
             exitFailure
-          unless (supportModuleIsDefined (map snd modules)) . liftIO $ do
+          unless (supportModuleIsDefined (map (P.getModuleName . snd) modules)) . liftIO $ do
             putStr supportModuleMessage
             exitFailure
-          (externs, _) <- ExceptT . runMake . make $ modules
+          (externs, _) <- ExceptT . runMake . make $ fmap CST.pureResult <$> modules
           return (modules, externs)
         case psciBackend of
           Backend setup eval reload (shutdown :: state -> IO ()) ->

diff --git a/package.yaml b/package.yaml
@@ -97,6 +97,9 @@ library:
     - ConstraintKinds
     - DataKinds
     - DeriveFunctor
+    - DeriveFoldable
+    - DeriveTraversable
+    - DeriveGeneric
     - EmptyDataDecls
     - FlexibleContexts
     - KindSignatures
@@ -157,7 +160,9 @@ tests:
     dependencies:
       - purescript
       - tasty
+      - tasty-golden
       - tasty-hspec
+      - tasty-quickcheck
       - hspec
       - hspec-discover
       - HUnit

diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
@@ -35,6 +35,7 @@ import Language.PureScript.Comments
 import Language.PureScript.Environment
 import qualified Language.PureScript.Bundle as Bundle
 import qualified Language.PureScript.Constants as C
+import qualified Language.PureScript.CST.Errors as CST
 
 import qualified Text.Parsec as P
 
@@ -68,6 +69,7 @@ data SimpleErrorMessage
   = ModuleNotFound ModuleName
   | ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)
   | ErrorParsingModule P.ParseError
+  | ErrorParsingCSTModule CST.ParserError
   | MissingFFIModule ModuleName
   | UnnecessaryFFIModule ModuleName FilePath
   | MissingFFIImplementations ModuleName [Ident]

diff --git a/src/Language/PureScript/CST.hs b/src/Language/PureScript/CST.hs
@@ -0,0 +1,89 @@
+module Language.PureScript.CST
+  ( parseFromFile
+  , parseFromFiles
+  , parseModuleFromFile
+  , parseModulesFromFiles
+  , unwrapParserError
+  , toMultipleErrors
+  , toPositionedError
+  , pureResult
+  , module Language.PureScript.CST.Convert
+  , module Language.PureScript.CST.Errors
+  , module Language.PureScript.CST.Parser
+  , module Language.PureScript.CST.Types
+  ) where
+
+import Prelude
+
+import Control.Monad.Error.Class (MonadError(..))
+import Control.Parallel.Strategies (withStrategy, parList, evalTuple2, r0, rseq)
+import qualified Data.List.NonEmpty as NE
+import Data.Text (Text)
+import qualified Language.PureScript.AST as AST
+import qualified Language.PureScript.Errors as E
+import Language.PureScript.CST.Convert
+import Language.PureScript.CST.Errors
+import Language.PureScript.CST.Parser
+import Language.PureScript.CST.Types
+
+pureResult :: a -> PartialResult a
+pureResult a = PartialResult a (pure a)
+
+parseModulesFromFiles
+  :: forall m k
+   . MonadError E.MultipleErrors m
+  => (k -> FilePath)
+  -> [(k, Text)]
+  -> m [(k, PartialResult AST.Module)]
+parseModulesFromFiles toFilePath input =
+  flip E.parU (handleParserError toFilePath)
+    . inParallel
+    . flip fmap input
+    $ \(k, a) -> (k, parseModuleFromFile (toFilePath k) a)
+
+parseFromFiles
+  :: forall m k
+   . MonadError E.MultipleErrors m
+  => (k -> FilePath)
+  -> [(k, Text)]
+  -> m [(k, AST.Module)]
+parseFromFiles toFilePath input =
+  flip E.parU (handleParserError toFilePath)
+    . inParallel
+    . flip fmap input
+    $ \(k, a) -> (k, parseFromFile (toFilePath k) a)
+
+parseModuleFromFile :: FilePath -> Text -> Either (NE.NonEmpty ParserError) (PartialResult AST.Module)
+parseModuleFromFile fp content = fmap (convertModule fp) <$> parseModule content
+
+parseFromFile :: FilePath -> Text -> Either (NE.NonEmpty ParserError) AST.Module
+parseFromFile fp content = convertModule fp <$> parse content
+
+handleParserError
+  :: forall m k a
+   . MonadError E.MultipleErrors m
+  => (k -> FilePath)
+  -> (k, Either (NE.NonEmpty ParserError) a)
+  -> m (k, a)
+handleParserError toFilePath (k, res) =
+  (k,) <$> unwrapParserError (toFilePath k) res
+
+unwrapParserError
+  :: forall m a
+   . MonadError E.MultipleErrors m
+  => FilePath
+  -> Either (NE.NonEmpty ParserError) a
+  -> m a
+unwrapParserError fp =
+  either (throwError . toMultipleErrors fp) pure
+
+toMultipleErrors :: FilePath -> NE.NonEmpty ParserError -> E.MultipleErrors
+toMultipleErrors fp =
+  E.MultipleErrors . NE.toList . fmap (toPositionedError fp)
+
+toPositionedError :: FilePath -> ParserError -> E.ErrorMessage
+toPositionedError name perr =
+  E.ErrorMessage [E.positionedError $ sourceSpan name $ errRange perr] (E.ErrorParsingCSTModule perr)
+
+inParallel :: [(k, Either (NE.NonEmpty ParserError) a)] -> [(k, Either (NE.NonEmpty ParserError) a)]
+inParallel = withStrategy (parList (evalTuple2 r0 rseq))