summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2015-08-28 15:17:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-08-28 15:17:00 (GMT)
commit414866c38a08e4a8a56cc3b7e8b0712743cb9551 (patch)
treece9d6748a22f873d7a11a6f3ae2093d9c8b6457d
parent3b2f791c57e95d3fb9c48ae7d48fa6944476d2b4 (diff)
version 0.7.4.10.7.4.1
-rw-r--r--examples/failing/438.purs2
-rw-r--r--examples/failing/EmptyDo.purs6
-rw-r--r--examples/failing/ImportHidingModule.purs10
-rw-r--r--examples/failing/OverlappingReExport.purs10
-rw-r--r--examples/failing/Superclasses5.purs (renamed from examples/passing/Superclasses2.purs)2
-rw-r--r--examples/passing/ExplicitImportReExport.purs16
-rw-r--r--examples/passing/ModuleExportHiding.purs11
-rw-r--r--examples/passing/OverlappingInstances.purs (renamed from examples/failing/OverlappingInstances.purs)5
-rw-r--r--examples/passing/OverlappingInstances2.purs (renamed from examples/failing/OverlappingInstances2.purs)5
-rw-r--r--examples/passing/OverlappingInstances3.purs (renamed from examples/failing/Superclasses4.purs)5
-rw-r--r--examples/passing/ReExportQualified.purs16
-rw-r--r--hierarchy/Main.hs4
-rw-r--r--psc/Main.hs18
-rw-r--r--psci/Completion.hs8
-rw-r--r--psci/PSCi.hs23
-rw-r--r--psci/Parser.hs4
-rw-r--r--psci/tests/Main.hs11
-rw-r--r--purescript.cabal14
-rw-r--r--src/Control/Monad/Supply.hs3
-rw-r--r--src/Control/Monad/Unify.hs3
-rw-r--r--src/Language/PureScript.hs2
-rw-r--r--src/Language/PureScript/AST/Declarations.hs24
-rw-r--r--src/Language/PureScript/AST/Exported.hs2
-rw-r--r--src/Language/PureScript/AST/SourcePos.hs14
-rw-r--r--src/Language/PureScript/AST/Traversals.hs10
-rw-r--r--src/Language/PureScript/Bundle.hs3
-rw-r--r--src/Language/PureScript/CodeGen/Externs.hs40
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs3
-rw-r--r--src/Language/PureScript/CodeGen/JS/AST.hs5
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer.hs5
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs22
-rw-r--r--src/Language/PureScript/Constants.hs7
-rw-r--r--src/Language/PureScript/CoreFn/Desugar.hs8
-rw-r--r--src/Language/PureScript/Docs/Convert.hs2
-rw-r--r--src/Language/PureScript/Docs/ParseAndDesugar.hs11
-rw-r--r--src/Language/PureScript/Docs/RenderedCode/Render.hs5
-rw-r--r--src/Language/PureScript/Docs/RenderedCode/Types.hs3
-rw-r--r--src/Language/PureScript/Docs/Types.hs6
-rw-r--r--src/Language/PureScript/Errors.hs331
-rw-r--r--src/Language/PureScript/Kinds.hs3
-rw-r--r--src/Language/PureScript/Linter.hs9
-rw-r--r--src/Language/PureScript/Linter/Exhaustive.hs34
-rw-r--r--src/Language/PureScript/Make.hs35
-rw-r--r--src/Language/PureScript/ModuleDependencies.hs6
-rw-r--r--src/Language/PureScript/Names.hs17
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs29
-rw-r--r--src/Language/PureScript/Parser/JS.hs3
-rw-r--r--src/Language/PureScript/Parser/Kinds.hs4
-rw-r--r--src/Language/PureScript/Pretty/JS.hs4
-rw-r--r--src/Language/PureScript/Pretty/Values.hs6
-rw-r--r--src/Language/PureScript/Publish.hs5
-rw-r--r--src/Language/PureScript/Publish/ErrorsWarnings.hs5
-rw-r--r--src/Language/PureScript/Renamer.hs6
-rw-r--r--src/Language/PureScript/Sugar.hs8
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs11
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs14
-rw-r--r--src/Language/PureScript/Sugar/DoNotation.hs9
-rw-r--r--src/Language/PureScript/Sugar/Names.hs629
-rw-r--r--src/Language/PureScript/Sugar/Names/Env.hs197
-rw-r--r--src/Language/PureScript/Sugar/Names/Exports.hs236
-rw-r--r--src/Language/PureScript/Sugar/Names/Imports.hs202
-rw-r--r--src/Language/PureScript/Sugar/ObjectWildcards.hs9
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs17
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs11
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses/Deriving.hs61
-rw-r--r--src/Language/PureScript/Sugar/TypeDeclarations.hs11
-rw-r--r--src/Language/PureScript/Traversals.hs4
-rw-r--r--src/Language/PureScript/TypeChecker.hs45
-rw-r--r--src/Language/PureScript/TypeChecker/Entailment.hs146
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs13
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs13
-rw-r--r--src/Language/PureScript/TypeChecker/Skolems.hs4
-rw-r--r--src/Language/PureScript/TypeChecker/Subsumption.hs2
-rw-r--r--src/Language/PureScript/TypeChecker/Synonyms.hs7
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs56
-rw-r--r--src/Language/PureScript/TypeChecker/Unify.hs8
-rw-r--r--src/Language/PureScript/TypeClassDictionaries.hs26
-rw-r--r--src/Language/PureScript/Types.hs3
-rw-r--r--tests/Main.hs28
-rw-r--r--tests/common/TestsSetup.hs48
-rw-r--r--tests/support/setup-win.cmd3
81 files changed, 1661 insertions, 1005 deletions
diff --git a/examples/failing/438.purs b/examples/failing/438.purs
index 2084170..e7f080b 100644
--- a/examples/failing/438.purs
+++ b/examples/failing/438.purs
@@ -1,4 +1,4 @@
--- @shouldFailWith NoInstanceFound
+-- @shouldFailWith PossiblyInfiniteInstance
-- See issue 438 for details: this test is mainly here to test that code like
-- this doesn't cause the compiler to loop.
diff --git a/examples/failing/EmptyDo.purs b/examples/failing/EmptyDo.purs
new file mode 100644
index 0000000..926a149
--- /dev/null
+++ b/examples/failing/EmptyDo.purs
@@ -0,0 +1,6 @@
+-- @shouldFailWith ErrorParsingModule
+
+module Main where
+
+main = do
+
diff --git a/examples/failing/ImportHidingModule.purs b/examples/failing/ImportHidingModule.purs
new file mode 100644
index 0000000..4d91014
--- /dev/null
+++ b/examples/failing/ImportHidingModule.purs
@@ -0,0 +1,10 @@
+-- @shouldFailWith ImportHidingModule
+module A where
+ x = 1
+
+module B (module B, module A) where
+ import A
+ y = 1
+
+module C where
+ import B hiding (module A)
diff --git a/examples/failing/OverlappingReExport.purs b/examples/failing/OverlappingReExport.purs
new file mode 100644
index 0000000..af85a5a
--- /dev/null
+++ b/examples/failing/OverlappingReExport.purs
@@ -0,0 +1,10 @@
+-- @shouldFailWith DuplicateValueExport
+module A where
+ x = true
+
+module B where
+ x = false
+
+module C (module A, module M2) where
+ import A
+ import qualified B as M2
diff --git a/examples/passing/Superclasses2.purs b/examples/failing/Superclasses5.purs
index 5f14df3..b93c5f4 100644
--- a/examples/passing/Superclasses2.purs
+++ b/examples/failing/Superclasses5.purs
@@ -1,3 +1,5 @@
+-- @shouldFailWith NoInstanceFound
+
module Main where
import Prelude
diff --git a/examples/passing/ExplicitImportReExport.purs b/examples/passing/ExplicitImportReExport.purs
new file mode 100644
index 0000000..3c7dd2b
--- /dev/null
+++ b/examples/passing/ExplicitImportReExport.purs
@@ -0,0 +1,16 @@
+-- from #1244
+module Foo where
+
+ foo :: Int
+ foo = 3
+
+module Bar (module Foo) where
+
+ import Foo
+
+module Baz where
+
+ import Bar (foo)
+
+ baz :: Int
+ baz = foo
diff --git a/examples/passing/ModuleExportHiding.purs b/examples/passing/ModuleExportHiding.purs
deleted file mode 100644
index 3a59b71..0000000
--- a/examples/passing/ModuleExportHiding.purs
+++ /dev/null
@@ -1,11 +0,0 @@
-module A (module Prelude) where
- import Prelude
-
-module Main where
- import Control.Monad.Eff.Console
- import A hiding (module Prelude)
-
- otherwise = false
-
- main = do
- print "1.0"
diff --git a/examples/failing/OverlappingInstances.purs b/examples/passing/OverlappingInstances.purs
index fb15f8c..94b2aa5 100644
--- a/examples/failing/OverlappingInstances.purs
+++ b/examples/passing/OverlappingInstances.purs
@@ -1,5 +1,4 @@
--- @shouldFailWith OverlappingInstances
-module OverlappingInstances where
+module Main where
import Prelude
@@ -11,4 +10,4 @@ instance showA1 :: Show A where
instance showA2 :: Show A where
show A = "Instance 2"
-main = Control.Monad.Eff.Console.log $ show A
+main = Test.Assert.assert $ show A == "Instance 1"
diff --git a/examples/failing/OverlappingInstances2.purs b/examples/passing/OverlappingInstances2.purs
index 1811754..76012ca 100644
--- a/examples/failing/OverlappingInstances2.purs
+++ b/examples/passing/OverlappingInstances2.purs
@@ -1,5 +1,4 @@
--- @shouldFailWith OverlappingInstances
-module OverlappingInstances where
+module Main where
import Prelude
@@ -21,4 +20,4 @@ instance ordA :: Ord A where
test :: forall a. (Ord a) => a -> a -> String
test x y = show $ x == y
-main = Control.Monad.Eff.Console.log $ test A B
+main = Test.Assert.assert $ test A B == "false"
diff --git a/examples/failing/Superclasses4.purs b/examples/passing/OverlappingInstances3.purs
index 7b3e3ae..4c6b354 100644
--- a/examples/failing/Superclasses4.purs
+++ b/examples/passing/OverlappingInstances3.purs
@@ -1,5 +1,4 @@
--- @shouldFailWith OverlappingInstances
-module OverlappingInstances where
+module Main where
import Prelude
@@ -13,3 +12,5 @@ test :: forall a. (Foo a) => a -> a
test a = a
test1 = test 0.0
+
+main = Test.Assert.assert (test1 == 0.0)
diff --git a/examples/passing/ReExportQualified.purs b/examples/passing/ReExportQualified.purs
new file mode 100644
index 0000000..cf1c037
--- /dev/null
+++ b/examples/passing/ReExportQualified.purs
@@ -0,0 +1,16 @@
+module A where
+ x = "Do"
+
+module B where
+ y = "ne"
+
+module C (module A, module M2) where
+ import A
+ import qualified B as M2
+
+module Main where
+
+ import Prelude
+ import C
+
+ main = Control.Monad.Eff.Console.log (x ++ y)
diff --git a/hierarchy/Main.hs b/hierarchy/Main.hs
index b8f2841..76b8c95 100644
--- a/hierarchy/Main.hs
+++ b/hierarchy/Main.hs
@@ -2,7 +2,7 @@
--
-- Module : Main
-- Copyright : (c) Hardy Jones 2014
--- License : MIT
+-- License : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer : Hardy Jones <jones3.hardy@gmail.com>
-- Stability : experimental
@@ -65,7 +65,7 @@ compile (HierarchyOptions inputGlob mOutput) = do
case modules of
Left errs -> hPutStr stderr (P.prettyPrintMultipleErrors False errs) >> exitFailure
Right ms -> do
- for_ ms $ \(P.Module _ moduleName decls _) ->
+ for_ ms $ \(P.Module _ _ moduleName decls _) ->
let name = runModuleName moduleName
tcs = filter P.isTypeClassDeclaration decls
supers = sort . nub . filter (not . null) $ fmap superClasses tcs
diff --git a/psc/Main.hs b/psc/Main.hs
index 4ac18c0..be0d11a 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -1,8 +1,8 @@
-----------------------------------------------------------------------------
--
-- Module : Main
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
+-- License : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer : Phil Freeman <paf31@cantab.net>
-- Stability : experimental
@@ -22,8 +22,9 @@ module Main where
import Control.Applicative
import Control.Monad
import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.Writer
+import Control.Monad.Writer.Strict
+import Data.List (isSuffixOf, partition)
import Data.Version (showVersion)
import qualified Data.Map as M
@@ -56,9 +57,10 @@ compile (PSCMakeOptions inputGlob inputForeignGlob outputDir opts usePrefix) = d
when (null input) $ do
hPutStrLn stderr "psc: No input files."
exitFailure
- moduleFiles <- readInput (InputOptions input)
+ let (jsFiles, pursFiles) = partition (isSuffixOf ".js") input
+ moduleFiles <- readInput (InputOptions pursFiles)
inputForeign <- globWarningOnMisses warnFileTypeNotFound inputForeignGlob
- foreignFiles <- forM inputForeign (\inFile -> (inFile,) <$> readFile inFile)
+ foreignFiles <- forM (inputForeign ++ jsFiles) (\inFile -> (inFile,) <$> readFile inFile)
case runWriterT (parseInputs moduleFiles foreignFiles) of
Left errs -> do
hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
@@ -66,7 +68,7 @@ compile (PSCMakeOptions inputGlob inputForeignGlob outputDir opts usePrefix) = d
Right ((ms, foreigns), warnings) -> do
when (P.nonEmpty warnings) $
hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)
- let filePathMap = M.fromList $ map (\(fp, P.Module _ mn _ _) -> (mn, fp)) ms
+ let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, fp)) ms
makeActions = buildMakeActions outputDir filePathMap foreigns usePrefix
e <- runMake opts $ P.make makeActions (map snd ms)
case e of
@@ -79,7 +81,7 @@ compile (PSCMakeOptions inputGlob inputForeignGlob outputDir opts usePrefix) = d
exitSuccess
warnFileTypeNotFound :: String -> IO ()
-warnFileTypeNotFound = hPutStrLn stderr . ((++) "psc: No files found using pattern: ")
+warnFileTypeNotFound = hPutStrLn stderr . ("psc: No files found using pattern: " ++)
globWarningOnMisses :: (String -> IO ()) -> [FilePath] -> IO [FilePath]
globWarningOnMisses warn = concatMapM globWithWarning
@@ -168,7 +170,7 @@ options = P.Options <$> noTco
<*> verboseErrors
<*> (not <$> comments)
<*> requirePath
-
+
pscMakeOptions :: Parser PSCMakeOptions
pscMakeOptions = PSCMakeOptions <$> many inputFile
<*> many inputForeignFile
diff --git a/psci/Completion.hs b/psci/Completion.hs
index 2936f47..b4716cd 100644
--- a/psci/Completion.hs
+++ b/psci/Completion.hs
@@ -1,13 +1,19 @@
+{-# LANGUAGE CPP #-}
+
module Completion where
import Data.Maybe (mapMaybe)
import Data.List (nub, nubBy, sortBy, isPrefixOf, stripPrefix)
import Data.Char (isUpper)
import Data.Function (on)
+#if __GLASGOW_HASKELL__ < 710
import Data.Traversable (traverse)
+#endif
import Control.Arrow (second)
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>), (<*>))
+#endif
import Control.Monad.Trans.Reader (asks, runReaderT, ReaderT)
import Control.Monad.Trans.State.Strict
@@ -216,7 +222,7 @@ dctorNames = nubOnFst . concatMap go . P.exportedDeclarations
go _ = []
moduleNames :: [P.Module] -> [String]
-moduleNames ms = nub [show moduleName | P.Module _ moduleName _ _ <- ms]
+moduleNames ms = nub [show moduleName | P.Module _ _ moduleName _ _ <- ms]
directivesFirst :: Completion -> Completion -> Ordering
directivesFirst (Completion _ d1 _) (Completion _ d2 _) = go d1 d2
diff --git a/psci/PSCi.hs b/psci/PSCi.hs
index 5d52c22..8512f68 100644
--- a/psci/PSCi.hs
+++ b/psci/PSCi.hs
@@ -1,8 +1,8 @@
-----------------------------------------------------------------------------
--
-- Module : PSCi
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
+-- License : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer : Phil Freeman <paf31@cantab.net>
-- Stability : experimental
@@ -17,12 +17,15 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE CPP #-}
module PSCi where
import Data.Foldable (traverse_)
import Data.List (intercalate, nub, sort)
+#if __GLASGOW_HASKELL__ < 710
import Data.Traversable (traverse)
+#endif
import Data.Tuple (swap)
import Data.Version (showVersion)
import qualified Data.Map as M
@@ -36,7 +39,7 @@ import Control.Monad.Trans.Except (runExceptT)
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import Control.Monad.Trans.State.Strict
import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Writer (runWriter)
+import Control.Monad.Writer.Strict (runWriter)
import qualified Control.Monad.Trans.State.Lazy as L
import Options.Applicative as Opts
@@ -67,7 +70,7 @@ supportModuleName = P.ModuleName [P.ProperName "$PSCI", P.ProperName "Support"]
supportModule :: P.Module
supportModule =
case P.parseModulesFromFiles id [("", code)] of
- Right [(_, P.Module cs _ ds exps)] -> P.Module cs supportModuleName ds exps
+ Right [(_, P.Module ss cs _ ds exps)] -> P.Module ss cs supportModuleName ds exps
_ -> error "Support module could not be parsed"
where
code :: String
@@ -215,7 +218,7 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi
mainDecl = P.ValueDeclaration (P.Ident "main") P.Public [] $ Right mainValue
decls = if exec then [itDecl, mainDecl] else [itDecl]
in
- P.Module [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing
+ P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing
-- |
@@ -227,7 +230,7 @@ createTemporaryModuleForKind PSCiState{psciImportedModules = imports, psciLetBin
moduleName = P.ModuleName [P.ProperName "$PSCI"]
itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ
in
- P.Module [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing
+ P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing
-- |
-- Makes a volatile module to execute the current imports.
@@ -237,7 +240,7 @@ createTemporaryModuleForImports PSCiState{psciImportedModules = imports} =
let
moduleName = P.ModuleName [P.ProperName "$PSCI"]
in
- P.Module [] moduleName (importDecl `map` imports) Nothing
+ P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName (importDecl `map` imports) Nothing
importDecl :: ImportedModule -> P.Declaration
importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ
@@ -308,7 +311,7 @@ handleShowLoadedModules = do
psciIO $ readModules loadedModules >>= putStrLn
return ()
where readModules = return . unlines . sort . nub . map toModuleName
- toModuleName = N.runModuleName . (\ (P.Module _ mdName _ _) -> mdName) . snd
+ toModuleName = N.runModuleName . (\ (P.Module _ _ mdName _ _) -> mdName) . snd
-- |
-- Show the imported modules in psci.
@@ -399,7 +402,7 @@ handleBrowse moduleName = do
case env of
Left errs -> printErrors errs
Right env' ->
- if moduleName `notElem` (nub . map ((\ (P.Module _ modName _ _ ) -> modName) . snd)) (psciLoadedModules st)
+ if moduleName `notElem` (nub . map ((\ (P.Module _ _ modName _ _ ) -> modName) . snd)) (psciLoadedModules st)
then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."
else printModuleSignatures moduleName env'
@@ -485,7 +488,7 @@ whenFileExists :: FilePath -> (FilePath -> PSCI ()) -> PSCI ()
whenFileExists filePath f = do
absPath <- psciIO $ expandTilde filePath
exists <- psciIO $ doesFileExist absPath
- if exists
+ if exists
then f absPath
else PSCI . outputStrLn $ "Couldn't locate: " ++ filePath
diff --git a/psci/Parser.hs b/psci/Parser.hs
index 549fb17..e506c4a 100644
--- a/psci/Parser.hs
+++ b/psci/Parser.hs
@@ -13,6 +13,8 @@
--
-----------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
+
module Parser
( parseCommand
) where
@@ -22,7 +24,9 @@ import Prelude hiding (lex)
import Data.Char (isSpace)
import Data.List (intercalate)
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative hiding (many)
+#endif
import Text.Parsec hiding ((<|>))
diff --git a/psci/tests/Main.hs b/psci/tests/Main.hs
index 2fdbba0..bc4af94 100644
--- a/psci/tests/Main.hs
+++ b/psci/tests/Main.hs
@@ -1,11 +1,15 @@
-{-# LANGUAGE RecordWildCards, TupleSections #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE CPP #-}
module Main where
import Control.Monad.Trans.State.Strict (runStateT)
import Control.Monad (when, forM)
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
-import Control.Monad.Writer (runWriterT)
+#endif
+import Control.Monad.Writer.Strict (runWriterT)
import Control.Monad.Trans.Except (runExceptT)
import Data.List (sort)
@@ -24,8 +28,11 @@ import PSCi
import Completion
import Types
+import TestsSetup
+
main :: IO ()
main = do
+ fetchSupportCode
Counts{..} <- runTestTT allTests
when (errors + failures > 0) exitFailure
diff --git a/purescript.cabal b/purescript.cabal
index 0140e8e..3dd3a2b 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.7.3.0
+version: 0.7.4.1
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -23,6 +23,7 @@ extra-source-files: examples/passing/*.purs
, tests/support/setup.js
, tests/support/package.json
, tests/support/bower.json
+ , tests/support/setup-win.cmd
, psci/tests/data/Sample.purs
source-repository head
@@ -119,10 +120,13 @@ library
Language.PureScript.Sugar.CaseDeclarations
Language.PureScript.Sugar.DoNotation
Language.PureScript.Sugar.Names
+ Language.PureScript.Sugar.Names.Env
+ Language.PureScript.Sugar.Names.Imports
+ Language.PureScript.Sugar.Names.Exports
Language.PureScript.Sugar.ObjectWildcards
Language.PureScript.Sugar.Operators
Language.PureScript.Sugar.TypeClasses
- Language.PureScript.Sugar.TypeClasses.Deriving
+ Language.PureScript.Sugar.TypeClasses.Deriving
Language.PureScript.Sugar.TypeDeclarations
Language.PureScript.Traversals
Language.PureScript.TypeChecker
@@ -243,8 +247,9 @@ test-suite tests
Glob -any
type: exitcode-stdio-1.0
main-is: Main.hs
+ other-modules: TestsSetup
buildable: True
- hs-source-dirs: tests
+ hs-source-dirs: tests tests/common
test-suite psci-tests
build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
@@ -254,6 +259,7 @@ test-suite psci-tests
Glob -any
type: exitcode-stdio-1.0
main-is: Main.hs
+ other-modules: TestsSetup
buildable: True
- hs-source-dirs: psci psci/tests
+ hs-source-dirs: psci psci/tests tests/common
ghc-options: -Wall
diff --git a/src/Control/Monad/Supply.hs b/src/Control/Monad/Supply.hs
index 1920c67..ef08980 100644
--- a/src/Control/Monad/Supply.hs
+++ b/src/Control/Monad/Supply.hs
@@ -14,12 +14,15 @@
-----------------------------------------------------------------------------
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE CPP #-}
module Control.Monad.Supply where
import Data.Functor.Identity
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Monad.State
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Reader
diff --git a/src/Control/Monad/Unify.hs b/src/Control/Monad/Unify.hs
index ade324b..53db603 100644
--- a/src/Control/Monad/Unify.hs
+++ b/src/Control/Monad/Unify.hs
@@ -28,6 +28,7 @@ import Data.Monoid
import Control.Applicative
import Control.Monad.State
import Control.Monad.Error.Class (MonadError(..))
+import Control.Monad.Writer.Class (MonadWriter(..))
import Data.HashMap.Strict as M
@@ -92,7 +93,7 @@ class UnificationError t e where
-- The type checking monad, which provides the state of the type checker, and error reporting capabilities
--
newtype UnifyT t m a = UnifyT { unUnify :: StateT (UnifyState t) m a }
- deriving (Functor, Monad, Applicative, Alternative, MonadPlus)
+ deriving (Functor, Monad, Applicative, Alternative, MonadPlus, MonadWriter w)
instance (MonadState s m) => MonadState s (UnifyT t m) where
get = UnifyT . lift $ get
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index c2fa84b..670ce24 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -28,7 +28,7 @@ import Data.Version (Version)
import Language.PureScript.AST as P
import Language.PureScript.Comments as P
import Language.PureScript.Environment as P
-import Language.PureScript.Errors as P
+import Language.PureScript.Errors as P hiding (indent)
import Language.PureScript.Kinds as P
import Language.PureScript.Linter as P
import Language.PureScript.Make as P
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index 490bc61..6e1e507 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -1,8 +1,8 @@
-----------------------------------------------------------------------------
--
-- Module : Language.PureScript.AST.Declarations
--- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
--- License : MIT
+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
+-- License : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer : Phil Freeman <paf31@cantab.net>
-- Stability : experimental
@@ -12,7 +12,9 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.AST.Declarations where
@@ -21,7 +23,9 @@ import qualified Data.Map as M
import Control.Monad.Identity
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Language.PureScript.AST.Binders
import Language.PureScript.AST.Operators
@@ -38,11 +42,11 @@ import Language.PureScript.Environment
-- a list of declarations, and a list of the declarations that are
-- explicitly exported. If the export list is Nothing, everything is exported.
--
-data Module = Module [Comment] ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, D.Data, D.Typeable)
+data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, D.Data, D.Typeable)
-- | Return a module's name.
getModuleName :: Module -> ModuleName
-getModuleName (Module _ name _ _) = name
+getModuleName (Module _ _ name _ _) = name
-- |
-- An item in a list of explicit imports or exports
@@ -84,6 +88,10 @@ instance Eq DeclarationRef where
r == (PositionedDeclarationRef _ _ r') = r == r'
_ == _ = False
+isModuleRef :: DeclarationRef -> Bool
+isModuleRef (ModuleRef _) = True
+isModuleRef _ = False
+
-- |
-- The data type which specifies type of import declaration
--
@@ -172,10 +180,10 @@ data TypeInstanceBody
-- | This is a regular (explicit) instance
| ExplicitInstance [Declaration]
deriving (Show, D.Data, D.Typeable)
-
+
mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody
mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)
-
+
-- | A traversal for TypeInstanceBody
traverseTypeInstanceBody :: (Applicative f) => ([Declaration] -> f [Declaration]) -> TypeInstanceBody -> f TypeInstanceBody
traverseTypeInstanceBody _ DerivedInstance = pure DerivedInstance
@@ -386,7 +394,7 @@ data Expr
-- at superclass implementations when searching for a dictionary, the type class name and
-- instance type, and the type class dictionaries in scope.
--
- | TypeClassDictionary Bool Constraint (M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))
+ | TypeClassDictionary Constraint (M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))
-- |
-- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring.
--
diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs
index 8f2007c..54f55f4 100644
--- a/src/Language/PureScript/AST/Exported.hs
+++ b/src/Language/PureScript/AST/Exported.hs
@@ -23,7 +23,7 @@ import Language.PureScript.Names
-- instances will be incorrectly removed in some cases.
--
exportedDeclarations :: Module -> [Declaration]
-exportedDeclarations (Module _ _ decls exps) = go decls
+exportedDeclarations (Module _ _ _ decls exps) = go decls
where
go = flattenDecls
>>> filter (isExported exps)
diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs
index 3d5eb49..a60f932 100644
--- a/src/Language/PureScript/AST/SourcePos.hs
+++ b/src/Language/PureScript/AST/SourcePos.hs
@@ -1,8 +1,8 @@
-----------------------------------------------------------------------------
--
-- Module : Language.PureScript.AST.SourcePos
--- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
--- License : MIT
+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
+-- License : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer : Phil Freeman <paf31@cantab.net>
-- Stability : experimental
@@ -12,7 +12,10 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, RecordWildCards, OverloadedStrings #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
module Language.PureScript.AST.SourcePos where
@@ -65,7 +68,7 @@ displayStartEndPos sp =
displaySourceSpan :: SourceSpan -> String
displaySourceSpan sp =
spanName sp ++ " " ++
- displayStartEndPos sp
+ displayStartEndPos sp
instance A.ToJSON SourceSpan where
toJSON SourceSpan{..} =
@@ -73,3 +76,6 @@ instance A.ToJSON SourceSpan where
, "start" .= spanStart
, "end" .= spanEnd
]
+
+internalModuleSourceSpan :: String -> SourceSpan
+internalModuleSourceSpan name = SourceSpan name (SourcePos 0 0) (SourcePos 0 0)
diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
index 0a33f2a..c31c59b 100644
--- a/src/Language/PureScript/AST/Traversals.hs
+++ b/src/Language/PureScript/AST/Traversals.hs
@@ -12,13 +12,21 @@
--
-----------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
+
module Language.PureScript.AST.Traversals where
+#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (Monoid(..), mconcat)
+#endif
import Data.Maybe (mapMaybe)
+#if __GLASGOW_HASKELL__ < 710
import Data.Traversable (traverse)
+#endif
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Monad
import Control.Arrow ((***), (+++), second)
@@ -396,7 +404,7 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con
forDecls (TypeDeclaration _ ty) = f ty
forDecls _ = mempty
- forValues (TypeClassDictionary _ (_, cs) _) = mconcat (map f cs)
+ forValues (TypeClassDictionary (_, cs) _) = mconcat (map f cs)
forValues (SuperClassDictionary _ tys) = mconcat (map f tys)
forValues (TypedValue _ _ ty) = f ty
forValues _ = mempty
diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs
index 1046c57..6db4539 100644
--- a/src/Language/PureScript/Bundle.hs
+++ b/src/Language/PureScript/Bundle.hs
@@ -20,6 +20,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.Bundle (
bundle
@@ -38,7 +39,9 @@ import Data.Version (showVersion)
import qualified Data.Set as S
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Monad
import Control.Monad.Error.Class
import Language.JavaScript.Parser
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
index 4a6f074..4e4c0e3 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -1,8 +1,8 @@
-----------------------------------------------------------------------------
--
-- Module : Language.PureScript.CodeGen.Externs
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
+-- License : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer : Phil Freeman <paf31@cantab.net>
-- Stability : experimental
@@ -36,28 +36,31 @@ import Language.PureScript.Types
-- Generate foreign imports for all declarations in a module
--
moduleToPs :: Module -> Environment -> String
-moduleToPs (Module _ _ _ Nothing) _ = error "Module exports were not elaborated in moduleToPs"
-moduleToPs (Module _ moduleName ds (Just exts)) env = intercalate "\n" . execWriter $ do
- let exps = listExports exts
+moduleToPs (Module _ _ _ _ Nothing) _ = error "Module exports were not elaborated in moduleToPs"
+moduleToPs (Module _ _ moduleName ds (Just exts)) env = intercalate "\n" . execWriter $ do
+ let exps = listRefs exts
tell ["module " ++ runModuleName moduleName ++ (if null exps then "" else " (" ++ exps ++ ")") ++ " where"]
mapM_ declToPs ds
mapM_ exportToPs exts
where
- listExports :: [DeclarationRef] -> String
- listExports = intercalate ", " . mapMaybe listExport
+ listRefs :: [DeclarationRef] -> String
+ listRefs = intercalate ", " . mapMaybe listRef
- listExport :: DeclarationRef -> Maybe String
- listExport (PositionedDeclarationRef _ _ d) = listExport d
- listExport (TypeRef name Nothing) = Just $ show name ++ "()"
- listExport (TypeRef name (Just dctors)) = Just $ show name ++ "(" ++ intercalate ", " (map show dctors) ++ ")"
- listExport (ValueRef name) = Just $ show name
- listExport (TypeClassRef name) = Just $ show name
- listExport (ModuleRef name) = Just $ "module " ++ show name
- listExport _ = Nothing
+ listRef :: DeclarationRef -> Maybe String
+ listRef (PositionedDeclarationRef _ _ d) = listRef d
+ listRef (TypeRef name Nothing) = Just $ show name ++ "()"
+ listRef (TypeRef name (Just dctors)) = Just $ show name ++ "(" ++ intercalate ", " (map show dctors) ++ ")"
+ listRef (ValueRef name) = Just $ show name
+ listRef (TypeClassRef name) = Just $ show name
+ listRef (ModuleRef name) = Just $ "module " ++ show name
+ listRef _ = Nothing
declToPs :: Declaration -> Writer [String] ()
- declToPs (ImportDeclaration mn _ _) = tell ["import " ++ show mn ++ " ()"]
+ declToPs (ImportDeclaration mn imp Nothing) =
+ tell ["import " ++ show mn ++ importToPs imp]
+ declToPs (ImportDeclaration mn imp (Just qual)) =
+ tell ["import qualified " ++ show mn ++ importToPs imp ++ " as " ++ show qual]
declToPs (FixityDeclaration (Fixity assoc prec) op) =
case find exportsOp exts of
Nothing -> return ()
@@ -70,6 +73,11 @@ moduleToPs (Module _ moduleName ds (Just exts)) env = intercalate "\n" . execWri
declToPs (PositionedDeclaration _ com d) = mapM_ commentToPs com >> declToPs d
declToPs _ = return ()
+ importToPs :: ImportDeclarationType -> String
+ importToPs Implicit = ""
+ importToPs (Explicit refs) = " (" ++ listRefs refs ++ ")"
+ importToPs (Hiding refs) = " hiding (" ++ listRefs refs ++ ")"
+
commentToPs :: Comment -> Writer [String] ()
commentToPs (LineComment s) = tell ["-- " ++ s]
commentToPs (BlockComment s) = tell ["{- " ++ s ++ " -}"]
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index ccb854f..9eadca9 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -17,6 +17,7 @@
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.CodeGen.JS
( module AST
@@ -28,7 +29,9 @@ module Language.PureScript.CodeGen.JS
import Data.List ((\\), delete, intersect)
import qualified Data.Traversable as T (traverse)
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Arrow ((&&&))
import Control.Monad (replicateM, forM)
import Control.Monad.Reader (MonadReader, asks)
diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs
index 83b7228..24d961a 100644
--- a/src/Language/PureScript/CodeGen/JS/AST.hs
+++ b/src/Language/PureScript/CodeGen/JS/AST.hs
@@ -14,13 +14,18 @@
-----------------------------------------------------------------------------
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.CodeGen.JS.AST where
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative, (<$>), (<*>))
+#endif
import Control.Monad.Identity
import Data.Data
+#if __GLASGOW_HASKELL__ < 710
import Data.Traversable (traverse)
+#endif
import Language.PureScript.Comments
import Language.PureScript.Traversals
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer.hs b/src/Language/PureScript/CodeGen/JS/Optimizer.hs
index 4616bb6..9d2e2ab 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer.hs
@@ -32,12 +32,15 @@
-----------------------------------------------------------------------------
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.CodeGen.JS.Optimizer (
optimize
) where
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative)
+#endif
import Control.Monad.Reader (MonadReader, ask, asks)
import Control.Monad.Supply.Class (MonadSupply)
@@ -63,7 +66,7 @@ optimize js = do
optimize' :: (Monad m, MonadReader Options m, Applicative m, MonadSupply m) => JS -> m JS
optimize' js = do
opts <- ask
- untilFixedPoint (inlineArrComposition . applyAll
+ untilFixedPoint (inlineFnComposition . applyAll
[ collapseNestedBlocks
, collapseNestedIfs
, tco opts
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
index e460ad2..59bbba4 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
@@ -13,18 +13,22 @@
--
-----------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
+
module Language.PureScript.CodeGen.JS.Optimizer.Inliner (
inlineVariables,
inlineValues,
inlineOperator,
inlineCommonOperators,
- inlineArrComposition,
+ inlineFnComposition,
etaConvert,
unThunk,
evaluateIifes
) where
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative)
+#endif
import Control.Monad.Supply.Class (MonadSupply, freshName)
import Data.Maybe (fromMaybe)
@@ -240,18 +244,18 @@ inlineCommonOperators = applyAll $
-- (f <<< g $ x) = f (g x)
-- (f <<< g) = \x -> f (g x)
-inlineArrComposition :: (Applicative m, MonadSupply m) => JS -> m JS
-inlineArrComposition = everywhereOnJSTopDownM convert
+inlineFnComposition :: (Applicative m, MonadSupply m) => JS -> m JS
+inlineFnComposition = everywhereOnJSTopDownM convert
where
convert :: (MonadSupply m) => JS -> m JS
- convert (JSApp (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) [z]) | isArrCompose dict' fn =
+ convert (JSApp (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) [z]) | isFnCompose dict' fn =
return $ JSApp x [JSApp y [z]]
- convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isArrCompose dict' fn = do
+ convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isFnCompose dict' fn = do
arg <- freshName
return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp x [JSApp y [JSVar arg]]])
convert other = return other
- isArrCompose :: JS -> JS -> Bool
- isArrCompose dict' fn = isDict semigroupoidArr dict' && isPreludeFn (C.<<<) fn
+ isFnCompose :: JS -> JS -> Bool
+ isFnCompose dict' fn = isDict semigroupoidFn dict' && (isPreludeFn (C.<<<) fn || isPreludeFn (C.compose) fn)
isDict :: (String, String) -> JS -> Bool
isDict (moduleName, dictName) (JSAccessor x (JSVar y)) = x == dictName && y == moduleName
@@ -310,5 +314,5 @@ boundedBoolean = (C.prelude, C.boundedBoolean)
booleanAlgebraBoolean :: (String, String)
booleanAlgebraBoolean = (C.prelude, C.booleanAlgebraBoolean)
-semigroupoidArr :: (String, String)
-semigroupoidArr = (C.prelude, C.semigroupoidArr)
+semigroupoidFn :: (String, String)
+semigroupoidFn = (C.prelude, C.semigroupoidFn)
diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs
index 2449468..1614449 100644
--- a/src/Language/PureScript/Constants.hs
+++ b/src/Language/PureScript/Constants.hs
@@ -89,6 +89,9 @@ unsafeIndex = "unsafeIndex"
(<<<) :: String
(<<<) = "<<<"
+compose :: String
+compose = "compose"
+
-- Functions
negate :: String
@@ -235,8 +238,8 @@ booleanAlgebraBoolean = "booleanAlgebraBoolean"
semigroupString :: String
semigroupString = "semigroupString"
-semigroupoidArr :: String
-semigroupoidArr = "semigroupoidArr"
+semigroupoidFn :: String
+semigroupoidFn = "semigroupoidFn"
-- Generic Deriving
diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs
index 711c0f9..a963d7b 100644
--- a/src/Language/PureScript/CoreFn/Desugar.hs
+++ b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -1,8 +1,8 @@
-----------------------------------------------------------------------------
--
-- Module : Language.PureScript.CoreFn.Desugar
--- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
--- License : MIT
+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
+-- License : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
-- Stability : experimental
@@ -40,9 +40,9 @@ import qualified Language.PureScript.AST as A
-- Desugars a module from AST to CoreFn representation.
--
moduleToCoreFn :: Environment -> A.Module -> Module Ann
-moduleToCoreFn _ (A.Module _ _ _ Nothing) =
+moduleToCoreFn _ (A.Module _ _ _ _ Nothing) =
error "Module exports were not elaborated before moduleToCoreFn"
-moduleToCoreFn env (A.Module coms mn decls (Just exps)) =
+moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls
exps' = nub $ concatMap exportToCoreFn exps
externs = nub $ mapMaybe externToCoreFn decls
diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs
index 0276342..cfeaee0 100644
--- a/src/Language/PureScript/Docs/Convert.hs
+++ b/src/Language/PureScript/Docs/Convert.hs
@@ -25,7 +25,7 @@ import Language.PureScript.Docs.Types
-- Convert a single Module.
--
convertModule :: P.Module -> Module
-convertModule m@(P.Module coms moduleName _ _) =
+convertModule m@(P.Module _ coms moduleName _ _) =
Module (show moduleName) comments (declarations m)
where
comments = convertComments coms
diff --git a/src/Language/PureScript/Docs/ParseAndDesugar.hs b/src/Language/PureScript/Docs/ParseAndDesugar.hs
index 300adb2..9dcfc7f 100644
--- a/src/Language/PureScript/Docs/ParseAndDesugar.hs
+++ b/src/Language/PureScript/Docs/ParseAndDesugar.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.Docs.ParseAndDesugar
( parseAndDesugar
@@ -8,9 +9,12 @@ module Language.PureScript.Docs.ParseAndDesugar
import qualified Data.Map as M
import Control.Arrow (first)
import Control.Monad
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Monad.Trans.Except
+import Control.Monad.Writer.Strict (runWriterT)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.IO.Class (MonadIO(..))
@@ -103,9 +107,9 @@ fileInfoToString (Local fn) = fn
fileInfoToString (FromDep _ fn) = fn
addDefaultImport :: P.ModuleName -> P.Module -> P.Module
-addDefaultImport toImport m@(P.Module coms mn decls exps) =
+addDefaultImport toImport m@(P.Module ss coms mn decls exps) =
if isExistingImport `any` decls || mn == toImport then m
- else P.Module coms mn (P.ImportDeclaration toImport P.Implicit Nothing : decls) exps
+ else P.Module ss coms mn (P.ImportDeclaration toImport P.Implicit Nothing : decls) exps
where
isExistingImport (P.ImportDeclaration mn' _ _) | mn' == toImport = True
isExistingImport (P.PositionedDeclaration _ _ d) = isExistingImport d
@@ -118,7 +122,8 @@ desugar :: [P.Module] -> Either P.MultipleErrors [P.Module]
desugar = P.evalSupplyT 0 . desugar'
where
desugar' :: [P.Module] -> P.SupplyT (Either P.MultipleErrors) [P.Module]
- desugar' = mapM P.desugarDoModule >=> P.desugarCasesModule >=> P.desugarImports
+ desugar' = mapM P.desugarDoModule >=> P.desugarCasesModule >=> ignoreWarnings . P.desugarImports
+ ignoreWarnings m = liftM fst (runWriterT m)
parseFile :: FilePath -> IO (FilePath, String)
parseFile input' = (,) input' <$> readFile input'
diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs
index 0f7d416..9ab8a1c 100644
--- a/src/Language/PureScript/Docs/RenderedCode/Render.hs
+++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
-- | Functions for producing RenderedCode values from PureScript Type values.
@@ -11,7 +12,11 @@ module Language.PureScript.Docs.RenderedCode.Render (
renderTypeWithOptions
) where
+#if __GLASGOW_HASKELL__ < 710
import Data.Monoid ((<>), mconcat, mempty)
+#else
+import Data.Monoid ((<>))
+#endif
import Data.Maybe (fromMaybe)
import Control.Arrow ((<+>))
diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs
index bfc020c..63e2b21 100644
--- a/src/Language/PureScript/Docs/RenderedCode/Types.hs
+++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
-- | Data types and functions for representing a simplified form of PureScript
-- code, intended for use in e.g. HTML documentation.
@@ -30,9 +31,11 @@ module Language.PureScript.Docs.RenderedCode.Types
, keywordWhere
) where
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>), (<*>), (*>), pure)
import Data.Foldable
import Data.Monoid
+#endif
import qualified Data.Aeson as A
import Data.Aeson.BetterErrors
import Control.Monad.Error.Class (MonadError(..))
diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs
index fccea8a..61fba63 100644
--- a/src/Language/PureScript/Docs/Types.hs
+++ b/src/Language/PureScript/Docs/Types.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.Docs.Types
( module Language.PureScript.Docs.Types
@@ -10,9 +11,10 @@ module Language.PureScript.Docs.Types
where
import Control.Arrow (first, (***))
-import Control.Applicative ((<$>), (<*>), pure)
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative ((<$>), (<$), (<*>), pure)
+#endif
import Control.Monad (when)
-import Data.Functor ((<$))
import Data.Maybe (mapMaybe)
import Data.Version
import Data.Aeson ((.=))
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 8d403f9..77a6a40 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -15,14 +15,18 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.Errors where
import Data.Either (lefts, rights)
import Data.List (intercalate, transpose)
import Data.Function (on)
-import Data.Monoid
+#if __GLASGOW_HASKELL__ < 710
import Data.Foldable (fold, foldMap)
+#else
+import Data.Foldable (fold)
+#endif
import qualified Data.Map as M
@@ -30,7 +34,9 @@ import Control.Monad
import Control.Monad.Unify
import Control.Monad.Writer
import Control.Monad.Error.Class (MonadError(..))
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>), (<*>), Applicative, pure)
+#endif
import Control.Monad.Trans.State.Lazy
import Control.Arrow(first)
@@ -40,11 +46,13 @@ import Language.PureScript.Pretty
import Language.PureScript.Types
import Language.PureScript.Names
import Language.PureScript.Kinds
-import Language.PureScript.TypeClassDictionaries
import qualified Text.PrettyPrint.Boxes as Box
import qualified Text.Parsec as P
+import qualified Text.Parsec.Error as PE
+import Text.Parsec.Error (Message(..))
+import Data.List (nub)
-- |
-- A type of error messages
@@ -66,7 +74,7 @@ data SimpleErrorMessage
| MultipleFixities Ident
| OrphanTypeDeclaration Ident
| OrphanFixityDeclaration String
- | RedefinedModule ModuleName
+ | RedefinedModule ModuleName [SourceSpan]
| RedefinedIdent Ident
| OverlappingNamesInLet
| UnknownModule ModuleName
@@ -75,6 +83,15 @@ data SimpleErrorMessage
| UnknownValue (Qualified Ident)
| UnknownDataConstructor (Qualified ProperName) (Maybe (Qualified ProperName))
| UnknownTypeConstructor (Qualified ProperName)
+ | UnknownImportType ModuleName ProperName
+ | UnknownExportType ProperName
+ | UnknownImportTypeClass ModuleName ProperName
+ | UnknownExportTypeClass ProperName
+ | UnknownImportValue ModuleName Ident
+ | UnknownExportValue Ident
+ | UnknownExportModule ModuleName
+ | UnknownImportDataConstructor ModuleName ProperName ProperName
+ | UnknownExportDataConstructor ProperName ProperName
| ConflictingImport String ModuleName
| ConflictingImports String ModuleName ModuleName
| ConflictingTypeDecls ProperName
@@ -100,8 +117,9 @@ data SimpleErrorMessage
| TypesDoNotUnify Type Type
| KindsDoNotUnify Kind Kind
| ConstrainedTypeUnified Type Type
- | OverlappingInstances (Qualified ProperName) [Type] [DictionaryValue]
+ | OverlappingInstances (Qualified ProperName) [Type] [Qualified Ident]
| NoInstanceFound (Qualified ProperName) [Type]
+ | PossiblyInfiniteInstance (Qualified ProperName) [Type]
| CannotDerive (Qualified ProperName) [Type]
| CannotFindDerivingType ProperName
| DuplicateLabel String (Maybe Expr)
@@ -126,6 +144,8 @@ data SimpleErrorMessage
| NotExhaustivePattern [[Binder]] Bool
| OverlappingPattern [[Binder]] Bool
| ClassOperator ProperName Ident
+ | MisleadingEmptyTypeImport ModuleName ProperName
+ | ImportHidingModule ModuleName
deriving (Show)
-- |
@@ -164,82 +184,94 @@ instance UnificationError Kind ErrorMessage where
--
errorCode :: ErrorMessage -> String
errorCode em = case unwrapErrorMessage em of
- (ErrorParsingExterns _) -> "ErrorParsingExterns"
- (ErrorParsingFFIModule _) -> "ErrorParsingFFIModule"
- (ErrorParsingModule _) -> "ErrorParsingModule"
- MissingFFIModule{} -> "MissingFFIModule"
- MultipleFFIModules{} -> "MultipleFFIModules"
- UnnecessaryFFIModule{} -> "UnnecessaryFFIModule"
- (InvalidExternsFile _) -> "InvalidExternsFile"
- (CannotGetFileInfo _) -> "CannotGetFileInfo"
- (CannotReadFile _) -> "CannotReadFile"
- (CannotWriteFile _) -> "CannotWriteFile"
- (InfiniteType _) -> "InfiniteType"
- (InfiniteKind _) -> "InfiniteKind"
- CannotReorderOperators -> "CannotReorderOperators"
- (MultipleFixities _) -> "MultipleFixities"
- (OrphanTypeDeclaration _) -> "OrphanTypeDeclaration"
- (OrphanFixityDeclaration _) -> "OrphanFixityDeclaration"
- (RedefinedModule _) -> "RedefinedModule"
- (RedefinedIdent _) -> "RedefinedIdent"
- OverlappingNamesInLet -> "OverlappingNamesInLet"
- (UnknownModule _) -> "UnknownModule"
- (UnknownType _) -> "UnknownType"
- (UnknownTypeClass _) -> "UnknownTypeClass"
- (UnknownValue _) -> "UnknownValue"
- (UnknownDataConstructor _ _) -> "UnknownDataConstructor"
- (UnknownTypeConstructor _) -> "UnknownTypeConstructor"
- (ConflictingImport _ _) -> "ConflictingImport"
- (ConflictingImports _ _ _) -> "ConflictingImports"
- (ConflictingTypeDecls _) -> "ConflictingTypeDecls"
- (ConflictingCtorDecls _) -> "ConflictingCtorDecls"
- (TypeConflictsWithClass _) -> "TypeConflictsWithClass"
- (CtorConflictsWithClass _) -> "CtorConflictsWithClass"
- (ClassConflictsWithType _) -> "ClassConflictsWithType"
- (ClassConflictsWithCtor _) -> "ClassConflictsWithCtor"
- (DuplicateClassExport _) -> "DuplicateClassExport"
- (DuplicateValueExport _) -> "DuplicateValueExport"
- (DuplicateTypeArgument _) -> "DuplicateTypeArgument"
- InvalidDoBind -> "InvalidDoBind"
- InvalidDoLet -> "InvalidDoLet"
- (CycleInDeclaration _) -> "CycleInDeclaration"
- (CycleInTypeSynonym _) -> "CycleInTypeSynonym"
- (CycleInModules _) -> "CycleInModules"
- (NameIsUndefined _) -> "NameIsUndefined"
- (NameNotInScope _) -> "NameNotInScope"
- (UndefinedTypeVariable _) -> "UndefinedTypeVariable"
- (PartiallyAppliedSynonym _) -> "PartiallyAppliedSynonym"
- (EscapedSkolem _) -> "EscapedSkolem"
- UnspecifiedSkolemScope -> "UnspecifiedSkolemScope"
- (TypesDoNotUnify _ _) -> "TypesDoNotUnify"
- (KindsDoNotUnify _ _) -> "KindsDoNotUnify"
- (ConstrainedTypeUnified _ _) -> "ConstrainedTypeUnified"
- (OverlappingInstances _ _ _) -> "OverlappingInstances"
- (NoInstanceFound _ _) -> "NoInstanceFound"
- (CannotDerive _ _) -> "CannotDerive"
- (CannotFindDerivingType _) -> "CannotFindDerivingType"
- (DuplicateLabel _ _) -> "DuplicateLabel"
- (DuplicateValueDeclaration _) -> "DuplicateValueDeclaration"
- (ArgListLengthsDiffer _) -> "ArgListLengthsDiffer"
- (OverlappingArgNames _) -> "OverlappingArgNames"
- (MissingClassMember _) -> "MissingClassMember"
- (ExtraneousClassMember _) -> "ExtraneousClassMember"
- (ExpectedType _) -> "ExpectedType"
- (IncorrectConstructorArity _) -> "IncorrectConstructorArity"
- SubsumptionCheckFailed -> "SubsumptionCheckFailed"
- (ExprDoesNotHaveType _ _) -> "ExprDoesNotHaveType"
- (PropertyIsMissing _ _) -> "PropertyIsMissing"
- (CannotApplyFunction _ _) -> "CannotApplyFunction"
- TypeSynonymInstance -> "TypeSynonymInstance"
- (OrphanInstance _ _ _) -> "OrphanInstance"
- InvalidNewtype -> "InvalidNewtype"
- (InvalidInstanceHead _) -> "InvalidInstanceHead"
- (TransitiveExportError _ _) -> "TransitiveExportError"
- (ShadowedName _) -> "ShadowedName"
- (WildcardInferredType _) -> "WildcardInferredType"
- (NotExhaustivePattern _ _) -> "NotExhaustivePattern"
- (OverlappingPattern _ _) -> "OverlappingPattern"
- (ClassOperator _ _) -> "ClassOperator"
+ ErrorParsingExterns{} -> "ErrorParsingExterns"
+ ErrorParsingFFIModule{} -> "ErrorParsingFFIModule"
+ ErrorParsingModule{} -> "ErrorParsingModule"
+ MissingFFIModule{} -> "MissingFFIModule"
+ MultipleFFIModules{} -> "MultipleFFIModules"
+ UnnecessaryFFIModule{} -> "UnnecessaryFFIModule"
+ InvalidExternsFile{} -> "InvalidExternsFile"
+ CannotGetFileInfo{} -> "CannotGetFileInfo"
+ CannotReadFile{} -> "CannotReadFile"
+ CannotWriteFile{} -> "CannotWriteFile"
+ InfiniteType{} -> "InfiniteType"
+ InfiniteKind{} -> "InfiniteKind"
+ CannotReorderOperators -> "CannotReorderOperators"
+ MultipleFixities{} -> "MultipleFixities"
+ OrphanTypeDeclaration{} -> "OrphanTypeDeclaration"
+ OrphanFixityDeclaration{} -> "OrphanFixityDeclaration"
+ RedefinedModule{} -> "RedefinedModule"
+ RedefinedIdent{} -> "RedefinedIdent"
+ OverlappingNamesInLet -> "OverlappingNamesInLet"
+ UnknownModule{} -> "UnknownModule"
+ UnknownType{} -> "UnknownType"
+ UnknownTypeClass{} -> "UnknownTypeClass"
+ UnknownValue{} -> "UnknownValue"
+ UnknownDataConstructor{} -> "UnknownDataConstructor"
+ UnknownTypeConstructor{} -> "UnknownTypeConstructor"
+ UnknownImportType{} -> "UnknownImportType"
+ UnknownExportType{} -> "UnknownExportType"
+ UnknownImportTypeClass{} -> "UnknownImportTypeClass"
+ UnknownExportTypeClass{} -> "UnknownExportTypeClass"
+ UnknownImportValue{} -> "UnknownImportValue"
+ UnknownExportValue{} -> "UnknownExportValue"
+ UnknownExportModule{} -> "UnknownExportModule"
+ UnknownImportDataConstructor{} -> "UnknownImportDataConstructor"
+ UnknownExportDataConstructor{} -> "UnknownExportDataConstructor"
+ ConflictingImport{} -> "ConflictingImport"
+ ConflictingImports{} -> "ConflictingImports"
+ ConflictingTypeDecls{} -> "ConflictingTypeDecls"
+ ConflictingCtorDecls{} -> "ConflictingCtorDecls"
+ TypeConflictsWithClass{} -> "TypeConflictsWithClass"
+ CtorConflictsWithClass{} -> "CtorConflictsWithClass"
+ ClassConflictsWithType{} -> "ClassConflictsWithType"
+ ClassConflictsWithCtor{} -> "ClassConflictsWithCtor"
+ DuplicateClassExport{} -> "DuplicateClassExport"
+ DuplicateValueExport{} -> "DuplicateValueExport"
+ DuplicateTypeArgument{} -> "DuplicateTypeArgument"
+ InvalidDoBind -> "InvalidDoBind"
+ InvalidDoLet -> "InvalidDoLet"
+ CycleInDeclaration{} -> "CycleInDeclaration"
+ CycleInTypeSynonym{} -> "CycleInTypeSynonym"
+ CycleInModules{} -> "CycleInModules"
+ NameIsUndefined{} -> "NameIsUndefined"
+ NameNotInScope{} -> "NameNotInScope"
+ UndefinedTypeVariable{} -> "UndefinedTypeVariable"
+ PartiallyAppliedSynonym{} -> "PartiallyAppliedSynonym"
+ EscapedSkolem{} -> "EscapedSkolem"
+ UnspecifiedSkolemScope -> "UnspecifiedSkolemScope"
+ TypesDoNotUnify{} -> "TypesDoNotUnify"
+ KindsDoNotUnify{} -> "KindsDoNotUnify"
+ ConstrainedTypeUnified{} -> "ConstrainedTypeUnified"
+ OverlappingInstances{} -> "OverlappingInstances"
+ NoInstanceFound{} -> "NoInstanceFound"
+ PossiblyInfiniteInstance{} -> "PossiblyInfiniteInstance"
+ CannotDerive{} -> "CannotDerive"
+ CannotFindDerivingType{} -> "CannotFindDerivingType"
+ DuplicateLabel{} -> "DuplicateLabel"
+ DuplicateValueDeclaration{} -> "DuplicateValueDeclaration"
+ ArgListLengthsDiffer{} -> "ArgListLengthsDiffer"
+ OverlappingArgNames{} -> "OverlappingArgNames"
+ MissingClassMember{} -> "MissingClassMember"
+ ExtraneousClassMember{} -> "ExtraneousClassMember"
+ ExpectedType{} -> "ExpectedType"
+ IncorrectConstructorArity{} -> "IncorrectConstructorArity"
+ SubsumptionCheckFailed -> "SubsumptionCheckFailed"
+ ExprDoesNotHaveType{} -> "ExprDoesNotHaveType"
+ PropertyIsMissing{} -> "PropertyIsMissing"
+ CannotApplyFunction{} -> "CannotApplyFunction"
+ TypeSynonymInstance -> "TypeSynonymInstance"
+ OrphanInstance{} -> "OrphanInstance"
+ InvalidNewtype -> "InvalidNewtype"
+ InvalidInstanceHead{} -> "InvalidInstanceHead"
+ TransitiveExportError{} -> "TransitiveExportError"
+ ShadowedName{} -> "ShadowedName"
+ WildcardInferredType{} -> "WildcardInferredType"
+ NotExhaustivePattern{} -> "NotExhaustivePattern"
+ OverlappingPattern{} -> "OverlappingPattern"
+ ClassOperator{} -> "ClassOperator"
+ MisleadingEmptyTypeImport{} -> "MisleadingEmptyTypeImport"
+ ImportHidingModule{} -> "ImportHidingModule"
-- |
-- A stack trace for an error
@@ -367,7 +399,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
prettyPrintErrorMessage em =
paras $
go em:suggestions em ++
- [line $ "See " ++ wikiUri ++ " for more information, or to contribute content related to this error."]
+ [line $ "See " ++ wikiUri ++ " for more information, or to contribute content related to this " ++ levelText ++ "."]
where
wikiUri :: String
wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e
@@ -387,7 +419,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
]
goSimple (ErrorParsingExterns err) =
paras [ lineWithLevel "parsing externs files: "
- , indent . line . show $ err
+ , indent . prettyPrintParseError $ err
]
goSimple (ErrorParsingFFIModule path) =
paras [ line "Unable to parse module from FFI file: "
@@ -395,7 +427,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
]
goSimple (ErrorParsingModule err) =
paras [ line "Unable to parse module: "
- , indent . line . show $ err
+ , indent . prettyPrintParseError $ err
]
goSimple (MissingFFIModule mn) =
line $ "Missing FFI implementations for module " ++ show mn
@@ -434,8 +466,9 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
line $ "Orphan type declaration for " ++ show nm
goSimple (OrphanFixityDeclaration op) =
line $ "Orphan fixity declaration for " ++ show op
- goSimple (RedefinedModule name) =
- line $ "Module " ++ show name ++ " has been defined multiple times"
+ goSimple (RedefinedModule name filenames) =
+ paras $ [ line $ "Module " ++ show name ++ " has been defined multiple times:"
+ ] ++ map (indent . line . displaySourceSpan) filenames
goSimple (RedefinedIdent name) =
line $ "Name " ++ show name ++ " has been defined multiple times"
goSimple (UnknownModule mn) =
@@ -450,10 +483,28 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
line $ "Unknown type constructor " ++ show name
goSimple (UnknownDataConstructor dc tc) =
line $ "Unknown data constructor " ++ show dc ++ foldMap ((" for type constructor " ++) . show) tc
+ goSimple (UnknownImportType mn name) =
+ line $ "Module " ++ show mn ++ " does not export type " ++ show name
+ goSimple (UnknownExportType name) =
+ line $ "Cannot export unknown type " ++ show name
+ goSimple (UnknownImportTypeClass mn name) =
+ line $ "Module " ++ show mn ++ " does not export type class " ++ show name
+ goSimple (UnknownExportTypeClass name) =
+ line $ "Cannot export unknown type class " ++ show name
+ goSimple (UnknownImportValue mn name) =
+ line $ "Module " ++ show mn ++ " does not export value " ++ show name
+ goSimple (UnknownExportValue name) =
+ line $ "Cannot export unknown value " ++ show name
+ goSimple (UnknownExportModule name) =
+ line $ "Cannot export unknown module " ++ show name ++ ", it either does not exist or has not been imported by the current module"
+ goSimple (UnknownImportDataConstructor mn tcon dcon) =
+ line $ "Module " ++ show mn ++ " does not export data constructor " ++ show dcon ++ " for type " ++ show tcon
+ goSimple (UnknownExportDataConstructor tcon dcon) =
+ line $ "Cannot export data constructor " ++ show dcon ++ " for type " ++ show tcon ++ " as it has not been declared"
goSimple (ConflictingImport nm mn) =
line $ "Cannot declare " ++ show nm ++ " since another declaration of that name was imported from " ++ show mn
goSimple (ConflictingImports nm m1 m2) =
- line $ "Conflicting imports for " ++ show nm ++ " from modules " ++ show m1 ++ " and " ++ show m2
+ line $ "Conflicting imports for " ++ nm ++ " from modules " ++ show m1 ++ " and " ++ show m2
goSimple (ConflictingTypeDecls nm) =
line $ "Conflicting type declarations for " ++ show nm
goSimple (ConflictingCtorDecls nm) =
@@ -507,12 +558,15 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
, line "with type"
, indent $ line $ prettyPrintType t2
]
- goSimple (OverlappingInstances nm ts ds) =
+ goSimple (OverlappingInstances nm ts (d : ds)) =
paras [ line $ "Overlapping instances found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"
- , paras $ map prettyPrintDictionaryValue ds
+ , indent $ paras (line (show d ++ " (chosen)") : map (line . show) ds)
]
+ goSimple OverlappingInstances{} = error "OverlappingInstances: empty instance list"
goSimple (NoInstanceFound nm ts) =
line $ "No instance found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts)
+ goSimple (PossiblyInfiniteInstance nm ts) =
+ line $ "Instance for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ " is possibly infinite."
goSimple (CannotDerive nm ts) =
line $ "Cannot derive " ++ show nm ++ " instance for " ++ unwords (map prettyPrintTypeAtom ts)
goSimple (CannotFindDerivingType nm) =
@@ -573,6 +627,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
, indent $ line $ "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:"
, indent $ line $ show opName ++ " = someMember"
]
+ goSimple (MisleadingEmptyTypeImport mn name) =
+ line $ "Importing type " ++ show name ++ "(..) from " ++ show mn ++ " is misleading as it has no exported data constructors"
+ goSimple (ImportHidingModule name) =
+ line $ "Attempted to hide module " ++ show name ++ " in import expression, this is not permitted"
goSimple (WildcardInferredType ty) =
line $ "The wildcard type definition has the inferred type " ++ prettyPrintType ty
goSimple (NotExhaustivePattern bs b) =
@@ -676,12 +734,14 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
]
go (SimpleErrorWrapper sem) = goSimple sem
- line :: String -> Box.Box
- line = Box.text
-
lineWithLevel :: String -> Box.Box
lineWithLevel text = line $ show level ++ " " ++ text
+ levelText :: String
+ levelText = case level of
+ Error -> "error"
+ Warning -> "warning"
+
suggestions :: ErrorMessage -> [Box.Box]
suggestions = suggestions' . unwrapErrorMessage
where
@@ -696,22 +756,6 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
paras :: [Box.Box] -> Box.Box
paras = Box.vcat Box.left
- indent :: Box.Box -> Box.Box
- indent = Box.moveRight 2
-
- -- |
- -- Render a DictionaryValue fit for human consumption in error messages
- --
- prettyPrintDictionaryValue :: DictionaryValue -> Box.Box
- prettyPrintDictionaryValue (LocalDictionaryValue _) = line "Dictionary in scope"
- prettyPrintDictionaryValue (GlobalDictionaryValue nm) = line (show nm)
- prettyPrintDictionaryValue (DependentDictionaryValue nm args) = paras [ line $ (show nm) ++ " via"
- , indent $ paras $ map prettyPrintDictionaryValue args
- ]
- prettyPrintDictionaryValue (SubclassDictionaryValue sup nm _) = paras [ line $ (show nm) ++ " via superclass"
- , indent $ prettyPrintDictionaryValue sup
- ]
-
-- |
-- Pretty print and export declaration
--
@@ -789,6 +833,60 @@ prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = do
, Box.vsep 1 Box.left result
]
+-- | Pretty print a Parsec ParseError as a Box
+prettyPrintParseError :: P.ParseError -> Box.Box
+prettyPrintParseError = (prettyPrintParseErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input") . PE.errorMessages
+
+-- |
+-- Pretty print ParseError detail messages.
+--
+-- Adapted from 'Text.Parsec.Error.showErrorMessages', see <https://github.com/aslatter/parsec/blob/v3.1.9/Text/Parsec/Error.hs#L173>.
+--
+prettyPrintParseErrorMessages :: String -> String -> String -> String -> String -> [Message] -> Box.Box
+prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs
+ | null msgs = Box.text msgUnknown
+ | otherwise = Box.vcat Box.left $ map Box.text $ clean [showSysUnExpect,showUnExpect,showExpect,showMessages]
+
+ where
+ (sysUnExpect,msgs1) = span ((SysUnExpect "") ==) msgs
+ (unExpect,msgs2) = span ((UnExpect "") ==) msgs1
+ (expect,messages) = span ((Expect "") ==) msgs2
+
+ showExpect = showMany msgExpecting expect
+ showUnExpect = showMany msgUnExpected unExpect
+ showSysUnExpect | not (null unExpect) ||
+ null sysUnExpect = ""
+ | null firstMsg = msgUnExpected ++ " " ++ msgEndOfInput
+ | otherwise = msgUnExpected ++ " " ++ firstMsg
+ where
+ firstMsg = PE.messageString (head sysUnExpect)
+
+ showMessages = showMany "" messages
+
+ -- helpers
+ showMany pre msgs' = case clean (map PE.messageString msgs') of
+ [] -> ""
+ ms | null pre -> commasOr ms
+ | otherwise -> pre ++ " " ++ commasOr ms
+
+ commasOr [] = ""
+ commasOr [m] = m
+ commasOr ms = commaSep (init ms) ++ " " ++ msgOr ++ " " ++ last ms
+
+ commaSep = separate ", " . clean
+
+ separate _ [] = ""
+ separate _ [m] = m
+ separate sep (m:ms) = m ++ sep ++ separate sep ms
+
+ clean = nub . filter (not . null)
+
+indent :: Box.Box -> Box.Box
+indent = Box.moveRight 2
+
+line :: String -> Box.Box
+line = Box.text
+
renderBox :: Box.Box -> String
renderBox = unlines . map trimEnd . lines . Box.render
where
@@ -808,15 +906,24 @@ interpretMultipleErrorsAndWarnings (err, ws) = do
rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
rethrow f = flip catchError $ \e -> throwError (f e)
+warnAndRethrow :: (MonadError e m, MonadWriter e m) => (e -> e) -> m a -> m a
+warnAndRethrow f = rethrow f . censor f
+
-- |
-- Rethrow an error with source position information
--
rethrowWithPosition :: (MonadError MultipleErrors m) => SourceSpan -> m a -> m a
-rethrowWithPosition pos = rethrow (onErrorMessages withPosition)
- where
- withPosition :: ErrorMessage -> ErrorMessage
- withPosition (PositionedError _ err) = withPosition err
- withPosition err = PositionedError pos err
+rethrowWithPosition pos = rethrow (onErrorMessages (withPosition pos))
+
+warnWithPosition :: (MonadWriter MultipleErrors m) => SourceSpan -> m a -> m a
+warnWithPosition pos = censor (onErrorMessages (withPosition pos))
+
+warnAndRethrowWithPosition :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => SourceSpan -> m a -> m a
+warnAndRethrowWithPosition pos = rethrowWithPosition pos . warnWithPosition pos
+
+withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage
+withPosition _ (PositionedError pos err) = withPosition pos err
+withPosition pos err = PositionedError pos err
-- |
-- Collect errors in in parallel
diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs
index e5d29dd..4355844 100644
--- a/src/Language/PureScript/Kinds.hs
+++ b/src/Language/PureScript/Kinds.hs
@@ -14,13 +14,16 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.Kinds where
import Data.Data
import qualified Data.Aeson.TH as A
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Monad.Unify (Unknown)
-- |
diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs
index 7a66663..9d1f6dc 100644
--- a/src/Language/PureScript/Linter.hs
+++ b/src/Language/PureScript/Linter.hs
@@ -1,8 +1,8 @@
-----------------------------------------------------------------------------
--
-- Module : Language.PureScript.Linter
--- Copyright : (c) Copyright 2015 PureScript
--- License : MIT
+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
+-- License : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer : Phil Freeman <paf31@cantab.net>
-- Stability : experimental
@@ -15,6 +15,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.Linter (lint, module L) where
@@ -24,7 +25,9 @@ import Data.Monoid
import qualified Data.Set as S
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Monad.Writer.Class
import Language.PureScript.AST
@@ -36,7 +39,7 @@ import Language.PureScript.Linter.Exhaustive as L
-- |
-- | Right now, this pass only performs a shadowing check.
lint :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Module -> m ()
-lint (Module _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_ lintDeclaration ds
+lint (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_ lintDeclaration ds
where
moduleNames :: S.Set Ident
moduleNames = S.fromList (nub (mapMaybe getDeclIdent ds))
diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs
index 698dc2e..7bd22da 100644
--- a/src/Language/PureScript/Linter/Exhaustive.hs
+++ b/src/Language/PureScript/Linter/Exhaustive.hs
@@ -1,8 +1,8 @@
-----------------------------------------------------------------------------
--
-- Module : Language.PureScript.Exhaustive
--- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
--- License : MIT
+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
+-- License : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer : Phil Freeman <paf31@cantab.net>
-- Stability : experimental
@@ -13,13 +13,14 @@
-- | The algorithm analyses the clauses of a definition one by one from top
-- | to bottom, where in each step it has the cases already missing (uncovered),
-- | and it generates the new set of missing cases.
---
+--
-----------------------------------------------------------------------------
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
-module Language.PureScript.Linter.Exhaustive
+module Language.PureScript.Linter.Exhaustive
( checkExhaustive
, checkExhaustiveModule
) where
@@ -207,7 +208,7 @@ isExhaustiveGuard (Left gs) = not . null $ filter (\(g, _) -> isOtherwise g) gs
isOtherwise (TypedValue _ (BooleanLiteral True) _) = True
isOtherwise (TypedValue _ (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) _) = True
isOtherwise _ = False
-isExhaustiveGuard (Right _) = True
+isExhaustiveGuard (Right _) = True
-- |
-- Returns the uncovered set of case alternatives
@@ -217,7 +218,7 @@ missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAl
missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Maybe Bool)
missingAlternative env mn ca uncovered
- | isExhaustiveGuard (caseAlternativeResult ca) = mcases
+ | isExhaustiveGuard (caseAlternativeResult ca) = mcases
| otherwise = ([uncovered], snd mcases)
where
mcases = missingCases env mn uncovered ca
@@ -227,9 +228,9 @@ missingAlternative env mn ca uncovered
-- Starting with the set `uncovered = { _ }` (nothing covered, one `_` for each function argument),
-- it partitions that set with the new uncovered cases, until it consumes the whole set of clauses.
-- Then, returns the uncovered set of case alternatives.
---
-checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Environment -> ModuleName -> [CaseAlternative] -> m ()
-checkExhaustive env mn cas = makeResult . first nub $ foldl' step ([initial], (pure True, [])) cas
+--
+checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Environment -> ModuleName -> Int -> [CaseAlternative] -> m ()
+checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas
where
step :: ([[Binder]], (Maybe Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Maybe Bool, [[Binder]]))
step (uncovered, (nec, redundant)) ca =
@@ -237,13 +238,10 @@ checkExhaustive env mn cas = makeResult . first nub $ foldl' step ([initial], (p
cond = or <$> sequenceA pr
in (concat missed, (liftA2 (&&) cond nec,
if fromMaybe True cond then redundant else caseAlternativeBinders ca : redundant))
+#if __GLASGOW_HASKELL__ < 710
where
sequenceA = foldr (liftA2 (:)) (pure [])
-
- initial :: [Binder]
- initial = initialize numArgs
- where
- numArgs = length . caseAlternativeBinders . head $ cas
+#endif
makeResult :: ([[Binder]], (Maybe Bool, [[Binder]])) -> m ()
makeResult (bss, (_, bss')) =
@@ -255,7 +253,7 @@ checkExhaustive env mn cas = makeResult . first nub $ foldl' step ([initial], (p
-- |
-- Exhaustivity checking over a list of declarations
---
+--
checkExhaustiveDecls :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> ModuleName -> [Declaration] -> m ()
checkExhaustiveDecls env mn ds =
let (f, _, _) = everywhereOnValuesTopDownM return checkExpr return
@@ -274,12 +272,12 @@ checkExhaustiveDecls env mn ds =
in mapM_ f' ds
where
checkExpr :: Expr -> m Expr
- checkExpr c@(Case _ cas) = checkExhaustive env mn cas >> return c
+ checkExpr c@(Case expr cas) = checkExhaustive env mn (length expr) cas >> return c
checkExpr other = return other
-- |
-- Exhaustivity checking over a single module
---
+--
checkExhaustiveModule :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> Module -> m ()
-checkExhaustiveModule env (Module _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ checkExhaustiveDecls env mn ds
+checkExhaustiveModule env (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ checkExhaustiveDecls env mn ds
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index eae2bd1..598f33e 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -1,8 +1,8 @@
-----------------------------------------------------------------------------
--
-- Module : Make
--- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
--- License : MIT
+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
+-- License : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer : Phil Freeman <paf31@cantab.net>
-- Stability : experimental
@@ -19,6 +19,7 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.Make
(
@@ -28,20 +29,22 @@ module Language.PureScript.Make
, MakeActions(..)
, Externs()
, make
-
+
-- * Implementation of Make API using files on disk
, Make(..)
, runMake
, buildMakeActions
) where
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Arrow ((&&&))
import Control.Monad
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Trans.Except
import Control.Monad.Reader
-import Control.Monad.Writer
+import Control.Monad.Writer.Strict
import Control.Monad.Supply
import Data.Function (on)
@@ -49,7 +52,9 @@ import Data.List (sortBy, groupBy)
import Data.Maybe (fromMaybe)
import Data.Time.Clock
import Data.Foldable (for_)
+#if __GLASGOW_HASKELL__ < 710
import Data.Traversable (traverse)
+#endif
import Data.Version (showVersion)
import qualified Data.Map as M
import qualified Data.Set as S
@@ -92,7 +97,7 @@ renderProgressMessage (CompilingModule mn) = "Compiling " ++ runModuleName mn
-- This type exists to make two things abstract:
--
-- * The particular backend being used (Javascript, C++11, etc.)
---
+--
-- * The details of how files are read/written etc.
--
data MakeActions m = MakeActions {
@@ -148,7 +153,7 @@ make :: forall m. (Functor m, Applicative m, Monad m, MonadReader Options m, Mon
-> m Environment
make MakeActions{..} ms = do
(sorted, graph) <- sortModules $ map importPrim ms
- toRebuild <- foldM (\s (Module _ moduleName' _ _) -> do
+ toRebuild <- foldM (\s (Module _ _ moduleName' _ _) -> do
inputTimestamp <- getInputTimestamp moduleName'
outputTimestamp <- getOutputTimestamp moduleName'
return $ case (inputTimestamp, outputTimestamp) of
@@ -167,12 +172,12 @@ make MakeActions{..} ms = do
go env ((False, m) : ms') = do
(_, env') <- lift . runCheck' env $ typeCheckModule Nothing m
go env' ms'
- go env ((True, m@(Module coms moduleName' _ exps)) : ms') = do
- lift . progress $ CompilingModule moduleName'
- (checked@(Module _ _ elaborated _), env') <- lift . runCheck' env $ typeCheckModule Nothing m
+ go env ((True, m@(Module ss coms moduleName' _ exps)) : ms') = do
+ lift . progress $ CompilingModule moduleName'
+ (checked@(Module _ _ _ elaborated _), env') <- lift . runCheck' env $ typeCheckModule Nothing m
checkExhaustiveModule env' checked
regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated
- let mod' = Module coms moduleName' regrouped exps
+ let mod' = Module ss coms moduleName' regrouped exps
corefn = CF.moduleToCoreFn env' mod'
[renamed] = renameInModules [corefn]
exts = moduleToPs mod' env'
@@ -181,15 +186,15 @@ make MakeActions{..} ms = do
rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
rebuildIfNecessary _ _ [] = return []
- rebuildIfNecessary graph toRebuild (m@(Module _ moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
+ rebuildIfNecessary graph toRebuild (m@(Module _ _ moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
let deps = fromMaybe [] $ moduleName' `M.lookup` graph
toRebuild' = toRebuild `S.union` S.fromList deps
(:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
- rebuildIfNecessary graph toRebuild (Module _ moduleName' _ _ : ms') = do
+ rebuildIfNecessary graph toRebuild (Module _ _ moduleName' _ _ : ms') = do
(path, externs) <- readExterns moduleName'
externsModules <- fmap (map snd) . alterErrors $ parseModulesFromFiles id [(path, externs)]
case externsModules of
- [m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
+ [m'@(Module _ _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
_ -> throwError . errorMessage . InvalidExternsFile $ path
where
alterErrors = flip catchError $ \(MultipleErrors errs) ->
@@ -207,9 +212,9 @@ reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
-- Add an import declaration for a module if it does not already explicitly import it.
--
addDefaultImport :: ModuleName -> Module -> Module
-addDefaultImport toImport m@(Module coms mn decls exps) =
+addDefaultImport toImport m@(Module ss coms mn decls exps) =
if isExistingImport `any` decls || mn == toImport then m
- else Module coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps
+ else Module ss coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps
where
isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs
index ff5aef1..0425a43 100644
--- a/src/Language/PureScript/ModuleDependencies.hs
+++ b/src/Language/PureScript/ModuleDependencies.hs
@@ -1,8 +1,8 @@
-----------------------------------------------------------------------------
--
-- Module : Language.PureScript.ModuleDependencies
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
+-- License : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer : Phil Freeman <paf31@cantab.net>
-- Stability : experimental
@@ -42,7 +42,7 @@ type ModuleGraph = [(ModuleName, [ModuleName])]
--
sortModules :: (MonadError MultipleErrors m) => [Module] -> m ([Module], ModuleGraph)
sortModules ms = do
- let verts = map (\m@(Module _ _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms
+ let verts = map (\m@(Module _ _ _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms
ms' <- mapM toModule $ stronglyConnComp verts
let moduleGraph = map (\(_, mn, deps) -> (mn, deps)) verts
return (ms', moduleGraph)
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index c89a939..28eb8ae 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -13,7 +13,9 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, GADTs #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE GADTs #-}
module Language.PureScript.Names where
@@ -100,3 +102,16 @@ instance (a ~ ProperName) => A.FromJSON (Qualified a) where
qualify :: ModuleName -> Qualified a -> (ModuleName, a)
qualify m (Qualified Nothing a) = (m, a)
qualify _ (Qualified (Just m) a) = (m, a)
+
+-- |
+-- Makes a qualified value from a name and module name.
+--
+mkQualified :: a -> ModuleName -> Qualified a
+mkQualified name mn = Qualified (Just mn) name
+
+-- |
+-- Checks whether a qualified value is actually qualified with a module reference
+--
+isUnqualified :: Qualified a -> Bool
+isUnqualified (Qualified Nothing _) = True
+isUnqualified _ = False
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 475a9b0..cb54ddc 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -1,8 +1,8 @@
-----------------------------------------------------------------------------
--
-- Module : Language.PureScript.Parser.Declarations
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
+-- License : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer : Phil Freeman <paf31@cantab.net>
-- Stability : experimental
@@ -64,8 +64,6 @@ withSourceSpan f p = do
end <- P.getPosition
let sp = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end)
return $ f sp comments x
- where
- toSourcePos pos = SourcePos (P.sourceLine pos) (P.sourceColumn pos)
kindedIdent :: TokenParser (String, Maybe Kind)
kindedIdent = (, Nothing) <$> identifier
@@ -230,7 +228,7 @@ parseTypeInstanceDeclaration = do
indented *> reserved "where"
mark (P.many (same *> positioned parseValueDeclaration))
return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty (ExplicitInstance members)
-
+
parseDerivingInstanceDeclaration :: TokenParser Declaration
parseDerivingInstanceDeclaration = do
reserved "derive"
@@ -277,19 +275,22 @@ parseLocalDeclaration = positioned (P.choice
parseModule :: TokenParser Module
parseModule = do
comments <- C.readComments
+ start <- P.getPosition
reserved "module"
indented
name <- moduleName
exports <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef
reserved "where"
decls <- mark (P.many (same *> parseDeclaration))
- return $ Module comments name decls exports
+ end <- P.getPosition
+ let ss = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end)
+ return $ Module ss comments name decls exports
-- |
-- Parse a collection of modules
--
parseModulesFromFiles :: forall m k. (MonadError MultipleErrors m, Functor m) =>
- (k -> String) -> [(k, String)] -> m [(k, Module)]
+ (k -> FilePath) -> [(k, String)] -> m [(k, Module)]
parseModulesFromFiles toFilePath input = do
modules <- parU input $ \(k, content) -> do
let filename = toFilePath k
@@ -299,10 +300,20 @@ parseModulesFromFiles toFilePath input = do
return $ collect modules
where
wrapError :: Either P.ParseError a -> m a
- wrapError = either (throwError . errorMessage . ErrorParsingModule) return
+ wrapError = either (throwError . MultipleErrors . pure . toPositionedError) return
collect :: [(k, [v])] -> [(k, v)]
collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ]
+toPositionedError :: P.ParseError -> ErrorMessage
+toPositionedError perr = PositionedError (SourceSpan name start end) (SimpleErrorWrapper (ErrorParsingModule perr))
+ where
+ name = (P.sourceName . P.errorPos) perr
+ start = (toSourcePos . P.errorPos) perr
+ end = start
+
+toSourcePos :: P.SourcePos -> SourcePos
+toSourcePos pos = SourcePos (P.sourceLine pos) (P.sourceColumn pos)
+
-- |
-- Parse a collection of modules
--
@@ -429,7 +440,7 @@ parseDo :: TokenParser Expr
parseDo = do
reserved "do"
C.indented
- Do <$> C.mark (P.many (C.same *> C.mark parseDoNotationElement))
+ Do <$> C.mark (P.many1 (C.same *> C.mark parseDoNotationElement))
parseDoNotationLet :: TokenParser DoNotationElement
parseDoNotationLet = DoNotationLet <$> (reserved "let" *> C.indented *> C.mark (P.many1 (C.same *> parseLocalDeclaration)))
diff --git a/src/Language/PureScript/Parser/JS.hs b/src/Language/PureScript/Parser/JS.hs
index d6466e7..43cb04e 100644
--- a/src/Language/PureScript/Parser/JS.hs
+++ b/src/Language/PureScript/Parser/JS.hs
@@ -13,13 +13,16 @@
-----------------------------------------------------------------------------
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.Parser.JS
( ForeignJS()
, parseForeignModulesFromFiles
) where
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((*>), (<*))
+#endif
import Control.Monad (forM_, when, msum)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Writer.Class (MonadWriter(..))
diff --git a/src/Language/PureScript/Parser/Kinds.hs b/src/Language/PureScript/Parser/Kinds.hs
index 230f78f..9773b42 100644
--- a/src/Language/PureScript/Parser/Kinds.hs
+++ b/src/Language/PureScript/Parser/Kinds.hs
@@ -13,6 +13,8 @@
--
-----------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
+
module Language.PureScript.Parser.Kinds (
parseKind
) where
@@ -20,7 +22,9 @@ module Language.PureScript.Parser.Kinds (
import Language.PureScript.Kinds
import Language.PureScript.Parser.Common
import Language.PureScript.Parser.Lexer
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import qualified Text.Parsec as P
import qualified Text.Parsec.Expr as P
diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs
index ae0060a..6fcf1cc 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -13,6 +13,8 @@
--
-----------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
+
module Language.PureScript.Pretty.JS (
prettyPrintJS
) where
@@ -20,7 +22,9 @@ module Language.PureScript.Pretty.JS (
import Data.List
import Data.Maybe (fromMaybe)
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Arrow ((<+>))
import Control.Monad.State
import Control.PatternArrows
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index b4772ef..e476b37 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -13,6 +13,8 @@
--
-----------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
+
module Language.PureScript.Pretty.Values (
prettyPrintValue,
prettyPrintBinder,
@@ -25,7 +27,9 @@ import Data.List (intercalate)
import Control.Arrow ((<+>), runKleisli, second)
import Control.PatternArrows
import Control.Monad.State
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Language.PureScript.AST
import Language.PureScript.Names
@@ -74,7 +78,7 @@ literals = mkPattern' match
]
match (OperatorSection op (Right val)) = return $ "(" ++ prettyPrintValue op ++ " " ++ prettyPrintValue val ++ ")"
match (OperatorSection op (Left val)) = return $ "(" ++ prettyPrintValue val ++ " " ++ prettyPrintValue op ++ ")"
- match (TypeClassDictionary _ (name, tys) _) = return $ "<<dict " ++ show name ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ">>"
+ match (TypeClassDictionary (name, tys) _) = return $ "<<dict " ++ show name ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ">>"
match (SuperClassDictionary name _) = return $ "<<superclass dict " ++ show name ++ ">>"
match (TypedValue _ val _) = prettyPrintValue' val
match (PositionedValue _ _ val) = prettyPrintValue' val
diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs
index 99258eb..b8e8453 100644
--- a/src/Language/PureScript/Publish.hs
+++ b/src/Language/PureScript/Publish.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.Publish
( preparePackage
@@ -32,14 +33,16 @@ import Safe (headMay)
import Data.Aeson.BetterErrors
import qualified Data.Text as T
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Category ((>>>))
import Control.Arrow ((***))
import Control.Exception (catch, try)
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import Control.Monad.Trans.Except
import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.Writer
+import Control.Monad.Writer.Strict
import System.Directory (doesFileExist, findExecutable)
import System.Process (readProcess)
diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs
index b1704d3..b4d5125 100644
--- a/src/Language/PureScript/Publish/ErrorsWarnings.hs
+++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.Publish.ErrorsWarnings
( PackageError(..)
@@ -15,12 +16,16 @@ module Language.PureScript.Publish.ErrorsWarnings
, renderWarnings
) where
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
+#endif
import Data.Aeson.BetterErrors
import Data.Version
import Data.Maybe
import Data.Monoid
+#if __GLASGOW_HASKELL__ < 710
import Data.Foldable (foldMap)
+#endif
import Data.List (intersperse, intercalate)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs
index 394097d..7576e51 100644
--- a/src/Language/PureScript/Renamer.hs
+++ b/src/Language/PureScript/Renamer.hs
@@ -14,11 +14,15 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.Renamer (renameInModules) where
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Monad.State
import Data.List (find)
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index 9c9f875..eeafd21 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -14,13 +14,17 @@
-----------------------------------------------------------------------------
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.Sugar (desugar, module S) where
import Control.Monad
import Control.Category ((>>>))
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
-import Control.Monad.Error.Class (MonadError(..))
+#endif
+import Control.Monad.Error.Class (MonadError())
+import Control.Monad.Writer.Class (MonadWriter())
import Control.Monad.Supply.Class
import Language.PureScript.AST
@@ -59,7 +63,7 @@ import Language.PureScript.Sugar.TypeDeclarations as S
--
-- * Group mutually recursive value and data declarations into binding groups.
--
-desugar :: (Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]
+desugar :: (Applicative m, MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module]
desugar = map removeSignedLiterals
>>> mapM desugarObjectConstructors
>=> mapM desugarOperatorSections
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index 28c0d81..968ef1e 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -1,8 +1,8 @@
-----------------------------------------------------------------------------
--
-- Module : Language.PureScript.BindingGroups
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
+-- License : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer : Phil Freeman <paf31@cantab.net>
-- Stability : experimental
@@ -15,6 +15,7 @@
-----------------------------------------------------------------------------
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.Sugar.BindingGroups (
createBindingGroups,
@@ -26,7 +27,9 @@ module Language.PureScript.Sugar.BindingGroups (
import Data.Graph
import Data.List (nub, intersect)
import Data.Maybe (isJust, mapMaybe)
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Monad ((<=<))
import Control.Monad.Error.Class (MonadError(..))
@@ -42,13 +45,13 @@ import Language.PureScript.Errors
-- Replace all sets of mutually-recursive declarations in a module with binding groups
--
createBindingGroupsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
-createBindingGroupsModule = mapM $ \(Module coms name ds exps) -> Module coms name <$> createBindingGroups name ds <*> pure exps
+createBindingGroupsModule = mapM $ \(Module ss coms name ds exps) -> Module ss coms name <$> createBindingGroups name ds <*> pure exps
-- |
-- Collapse all binding groups in a module to individual declarations
--
collapseBindingGroupsModule :: [Module] -> [Module]
-collapseBindingGroupsModule = map $ \(Module coms name ds exps) -> Module coms name (collapseBindingGroups ds) exps
+collapseBindingGroupsModule = map $ \(Module ss coms name ds exps) -> Module ss coms name (collapseBindingGroups ds) exps
createBindingGroups :: (Functor m, Applicative m, MonadError MultipleErrors m) => ModuleName -> [Declaration] -> m [Declaration]
createBindingGroups moduleName = mapM f <=< handleDecls
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index 74485ac..af7ab01 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -1,8 +1,8 @@
-----------------------------------------------------------------------------
--
-- Module : Language.PureScript.CaseDeclarations
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
+-- License : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer : Phil Freeman <paf31@cantab.net>
-- Stability : experimental
@@ -14,7 +14,9 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.Sugar.CaseDeclarations (
desugarCases,
@@ -24,7 +26,9 @@ module Language.PureScript.Sugar.CaseDeclarations (
import Data.Maybe (catMaybes)
import Data.List (nub, groupBy)
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Monad ((<=<), forM, replicateM, join, unless)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Supply.Class
@@ -45,9 +49,9 @@ isLeft (Right _) = False
-- Replace all top-level binders in a module with case expressions.
--
desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]
-desugarCasesModule ms = forM ms $ \(Module coms name ds exps) ->
+desugarCasesModule ms = forM ms $ \(Module ss coms name ds exps) ->
rethrow (onErrorMessages (ErrorInModule name)) $
- Module coms name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps
+ Module ss coms name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps
desugarAbs :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
desugarAbs = flip parU f
diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs
index 9b70061..17da9d3 100644
--- a/src/Language/PureScript/Sugar/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -1,8 +1,8 @@
-----------------------------------------------------------------------------
--
-- Module : Language.PureScript.Sugar.DoNotation
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
+-- License : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer : Phil Freeman <paf31@cantab.net>
-- Stability : experimental
@@ -16,6 +16,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.Sugar.DoNotation (
desugarDoModule
@@ -27,7 +28,9 @@ import Language.PureScript.Errors
import qualified Language.PureScript.Constants as C
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Supply.Class
@@ -36,7 +39,7 @@ import Control.Monad.Supply.Class
-- and all @DoNotationLet@ constructors with let expressions.
--
desugarDoModule :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
-desugarDoModule (Module coms mn ds exts) = Module coms mn <$> parU ds desugarDo <*> pure exts
+desugarDoModule (Module ss coms mn ds exts) = Module ss coms mn <$> parU ds desugarDo <*> pure exts
desugarDo :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration
desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (rethrowWithPosition pos $ desugarDo d)
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index 949aefd..dd282c9 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -1,8 +1,7 @@
-----------------------------------------------------------------------------
--
-- Module : Language.PureScript.Sugar.Names
--- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
--- License : MIT
+-- License : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
-- Stability : experimental
@@ -12,250 +11,90 @@
--
-----------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE PatternGuards #-}
-module Language.PureScript.Sugar.Names (
- desugarImports
-) where
+module Language.PureScript.Sugar.Names (desugarImports) where
-import Data.List (find, nub, (\\))
-import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe)
+import Data.List (find, nub)
+import Data.Maybe (fromMaybe, mapMaybe)
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative(..), (<$>), (<*>))
+#endif
import Control.Monad
import Control.Monad.Error.Class (MonadError(..))
+import Control.Monad.Writer (MonadWriter(..))
import qualified Data.Map as M
import Language.PureScript.AST
import Language.PureScript.Names
import Language.PureScript.Types
-import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Traversals
-
-import qualified Language.PureScript.Constants as C
-
--- |
--- The global export environment - every declaration exported from every module.
---
-type ExportEnvironment = M.Map ModuleName Exports
-
--- |
--- The exported declarations from a module.
---
-data Exports = Exports
- {
- -- |
- -- The types exported from each module
- --
- exportedTypes :: [(ProperName, [ProperName])]
- -- |
- -- The classes exported from each module
- --
- , exportedTypeClasses :: [ProperName]
- -- |
- -- The values exported from each module
- --
- , exportedValues :: [Ident]
- -- |
- -- The modules exported from each module
- --
- , exportedModules :: [ModuleName]
- } deriving (Show)
-
--- |
--- An imported environment for a particular module. This also contains the module's own members.
---
-data ImportEnvironment = ImportEnvironment
- {
- -- |
- -- Local names for types within a module mapped to to their qualified names
- --
- importedTypes :: M.Map (Qualified ProperName) (Qualified ProperName)
- -- |
- -- Local names for data constructors within a module mapped to to their qualified names
- --
- , importedDataConstructors :: M.Map (Qualified ProperName) (Qualified ProperName)
- -- |
- -- Local names for classes within a module mapped to to their qualified names
- --
- , importedTypeClasses :: M.Map (Qualified ProperName) (Qualified ProperName)
- -- |
- -- Local names for values within a module mapped to to their qualified names
- --
- , importedValues :: M.Map (Qualified Ident) (Qualified Ident)
- } deriving (Show)
-
--- |
--- Updates the exports for a module from the global environment. If the module was not previously
--- present in the global environment, it is created.
---
-updateExportedModule :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> (Exports -> m Exports) -> m ExportEnvironment
-updateExportedModule env mn update = do
- let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env
- exports' <- update exports
- return $ M.insert mn exports' env
-
--- |
--- Adds an empty module to an ExportEnvironment.
---
-addEmptyModule :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> m ExportEnvironment
-addEmptyModule env name =
- if name `M.member` env
- then throwError . errorMessage $ RedefinedModule name
- else return $ M.insert name (Exports [] [] [] []) env
-
--- |
--- Adds a type belonging to a module to the export environment.
---
-addType :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> m ExportEnvironment
-addType env mn name dctors = updateExportedModule env mn $ \m -> do
- let exTypes = exportedTypes m
- let exDctors = snd `concatMap` exTypes
- let exClasses = exportedTypeClasses m
- when (any ((== name) . fst) exTypes) $ throwConflictError ConflictingTypeDecls name
- when (name `elem` exClasses) $ throwConflictError TypeConflictsWithClass name
- forM_ dctors $ \dctor -> do
- when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor
- when (dctor `elem` exClasses) $ throwConflictError CtorConflictsWithClass dctor
- return $ m { exportedTypes = (name, dctors) : exTypes }
-
--- |
--- Adds a class to the export environment.
---
-addTypeClass :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> ProperName -> m ExportEnvironment
-addTypeClass env mn name = updateExportedModule env mn $ \m -> do
- let exTypes = exportedTypes m
- let exDctors = snd `concatMap` exTypes
- when (any ((== name) . fst) exTypes) $ throwConflictError ClassConflictsWithType name
- when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name
- classes <- addExport DuplicateClassExport (exportedTypeClasses m) name
- return $ m { exportedTypeClasses = classes }
-
--- |
--- Adds a class to the export environment.
---
-addValue :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> Ident -> m ExportEnvironment
-addValue env mn name = updateExportedModule env mn $ \m -> do
- values <- addExport DuplicateValueExport (exportedValues m) name
- return $ m { exportedValues = values }
-
--- |
--- Adds an entry to a list of exports unless it is already present, in which case an error is
--- returned.
---
-addExport :: (Applicative m, MonadError MultipleErrors m, Eq a, Show a) => (a -> SimpleErrorMessage) -> [a] -> a -> m [a]
-addExport what exports name =
- if name `elem` exports
- then throwConflictError what name
- else return $ name : exports
+import Language.PureScript.Sugar.Names.Env
+import Language.PureScript.Sugar.Names.Imports
+import Language.PureScript.Sugar.Names.Exports
-- |
--- Replaces all local names with qualified names within a set of modules.
+-- Replaces all local names with qualified names within a list of modules. The
+-- modules should be topologically sorted beforehand.
--
-desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
+desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module]
desugarImports modules = do
- unfilteredExports <- findExports modules
- exports <- foldM filterModuleExports unfilteredExports modules
- let modules' = moduleReexports <$> modules
- mapM (renameInModule' unfilteredExports exports) modules'
+ env <- foldM updateEnv initEnv modules
+ mapM (renameInModule' env) modules
where
- moduleReexports :: Module -> Module
- moduleReexports (Module coms mn decls exps) =
- let importedMods = catMaybes findImports'
- in (Module coms mn (decls ++ (concatMap reexports importedMods)) exps)
- where
- imports :: [Declaration]
- imports = filter isImportDecl decls
- findImports' :: [Maybe (Declaration, Module)]
- findImports' = go <$> modules
- where
- go :: Module -> Maybe (Declaration, Module)
- go m@(Module _ mn' _ (Just exps'))
- | any isModExport exps', Just d <- find ((== mn') . importedModName) imports = Just (d, m)
- where
- importedModName :: Declaration -> ModuleName
- importedModName (ImportDeclaration imn _ _) = imn
- importedModName (PositionedDeclaration _ _ d) = importedModName d
- importedModName _ = error "Not an import decl"
- go _ = Nothing
- reexports :: (Declaration, Module) -> [Declaration]
- reexports (ImportDeclaration _ (Hiding refs) _, (Module coms' mn' ds' (Just exps'))) =
- case nonHiddenRefs of
- [] -> []
- _ -> reexports (ImportDeclaration mn' Implicit Nothing, Module coms' mn' ds' (Just nonHiddenRefs))
- where
- nonHiddenRefs :: [DeclarationRef]
- nonHiddenRefs = filter isModExport exps' \\ filter isModExport refs
- reexports (ImportDeclaration _ ty qual, Module _ _ _ (Just exps')) =
- let ty' = case ty of
- Explicit _ -> Explicit []
- _ -> ty
- in (\m -> ImportDeclaration m ty' qual) <$> (catMaybes $ go <$> exps')
- where
- go :: DeclarationRef -> Maybe ModuleName
- go (ModuleRef mn') = Just mn'
- go _ = Nothing
- reexports (PositionedDeclaration _ _ d, m@(Module _ _ _ (Just _))) = reexports (d, m)
- reexports _ = []
-
- isModExport :: DeclarationRef -> Bool
- isModExport (ModuleRef _) = True
- isModExport _ = False
-
- -- Filters the exports for a module in the global exports environment so that only explicitly
- -- exported members remain. If the module does not explicitly export anything, everything is
- -- exported.
- filterModuleExports :: ExportEnvironment -> Module -> m ExportEnvironment
- filterModuleExports env (Module _ mn _ (Just exps))
- | any isSelfModuleExport exps, Just exps' <- M.lookup mn env =
- let moduleNames = filter (/= mn) $ (\(ModuleRef mn') -> mn') <$> filter isModExport exps
- in return $ M.insert mn (exps' {exportedModules = moduleNames}) env
- where
- isSelfModuleExport :: DeclarationRef -> Bool
- isSelfModuleExport (ModuleRef mn') | mn' == mn = True
- isSelfModuleExport (PositionedDeclarationRef _ _ ref) = isSelfModuleExport ref
- isSelfModuleExport _ = False
- filterModuleExports env (Module _ mn _ (Just exps)) = filterExports mn exps env
- filterModuleExports env _ = return env
-
- -- Rename and check all the names within a module. We tweak the global exports environment so
- -- the module has access to an unfiltered list of its own members.
- renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> m Module
- renameInModule' unfilteredExports exports m@(Module _ mn _ _) =
+ updateEnv :: Env -> Module -> m Env
+ updateEnv env m@(Module ss _ mn _ refs) =
+ case mn `M.lookup` env of
+ Just m' -> throwError . errorMessage $ RedefinedModule mn [envModuleSourceSpan m', ss]
+ Nothing -> do
+ members <- findExportable m
+ let env' = M.insert mn (ss, nullImports, members) env
+ imps <- resolveImports env' m
+ exps <- maybe (return members) (resolveExports env' mn imps members) refs
+ return $ M.insert mn (ss, imps, exps) env
+
+ renameInModule' :: Env -> Module -> m Module
+ renameInModule' env m@(Module _ _ mn _ _) =
rethrow (onErrorMessages (ErrorInModule mn)) $ do
- let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports
- let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports
- imports <- resolveImports env m
- elaborateImports <$> renameInModule imports env (elaborateExports exps m)
+ let (_, imps, exps) = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn env
+ elaborateImports imps <$> renameInModule env imps (elaborateExports exps m)
-- |
--- Make all exports for a module explicit. This may still effect modules that have an exports list,
--- as it will also make all data constructor exports explicit.
+-- Make all exports for a module explicit. This may still effect modules that
+-- have an exports list, as it will also make all data constructor exports
+-- explicit.
--
elaborateExports :: Exports -> Module -> Module
-elaborateExports exps (Module coms mn decls _) = Module coms mn decls (Just $
- map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) (exportedTypes exps) ++
- map TypeClassRef (exportedTypeClasses exps) ++
- map ValueRef (exportedValues exps) ++
- map ModuleRef (exportedModules exps))
+elaborateExports exps (Module ss coms mn decls refs) =
+ Module ss coms mn decls $
+ Just $ map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) (my exportedTypes) ++
+ map TypeClassRef (my exportedTypeClasses) ++
+ map ValueRef (my exportedValues) ++
+ maybe [] (filter isModuleRef) refs
+ where
+ -- Extracts a list of values from the exports and filters out any values that
+ -- are re-exports from other modules.
+ my :: (Exports -> [(a, ModuleName)]) -> [a]
+ my f = fst `map` filter ((== mn) . snd) (f exps)
-- |
-- Add `import X ()` for any modules where there are only fully qualified references to members.
-- This ensures transitive instances are included when using a member from a module.
--
-elaborateImports :: Module -> Module
-elaborateImports (Module coms mn decls exps) = Module coms mn decls' exps
+elaborateImports :: Imports -> Module -> Module
+elaborateImports imps (Module ss coms mn decls exps) = Module ss coms mn decls' exps
where
decls' :: [Declaration]
decls' =
let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues (const []) (const []) (const [])
in mkImport `map` nub (f `concatMap` decls) ++ decls
fqValues :: Expr -> [ModuleName]
- fqValues (Var (Qualified (Just mn') _)) = [mn']
+ fqValues (Var (Qualified (Just mn') _)) | notElem mn' (importedModules imps) = [mn']
fqValues _ = []
mkImport :: ModuleName -> Declaration
mkImport mn' = ImportDeclaration mn' (Explicit []) Nothing
@@ -264,14 +103,15 @@ elaborateImports (Module coms mn decls exps) = Module coms mn decls' exps
-- Replaces all local names with qualified names within a module and checks that all existing
-- qualified names are valid.
--
-renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m) => ImportEnvironment -> ExportEnvironment -> Module -> m Module
-renameInModule imports exports (Module coms mn decls exps) =
- Module coms mn <$> parU decls go <*> pure exps
+renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m) => Env -> Imports -> Module -> m Module
+renameInModule env imports (Module ss coms mn decls exps) =
+ Module ss coms mn <$> parU decls go <*> pure exps
where
(go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS
updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> m ((Maybe SourceSpan, [Ident]), Declaration)
- updateDecl (_, bound) d@(PositionedDeclaration pos _ _) = return ((Just pos, bound), d)
+ updateDecl (_, bound) d@(PositionedDeclaration pos _ _) =
+ return ((Just pos, bound), d)
updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =
(,) (pos, bound) <$> (DataDeclaration dtype name args <$> mapM (sndM (mapM (updateTypesEverywhere pos))) dctors)
updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) =
@@ -289,30 +129,37 @@ renameInModule imports exports (Module coms mn decls exps) =
updateDecl s d = return (s, d)
updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> m ((Maybe SourceSpan, [Ident]), Expr)
- updateValue (_, bound) v@(PositionedValue pos' _ _) = return ((Just pos', bound), v)
- updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')
+ updateValue (_, bound) v@(PositionedValue pos' _ _) =
+ return ((Just pos', bound), v)
+ updateValue (pos, bound) (Abs (Left arg) val') =
+ return ((pos, arg : bound), Abs (Left arg) val')
updateValue (pos, bound) (Let ds val') = do
- let args = mapMaybe letBoundVariable ds
- unless (length (nub args) == length args) $
- maybe id rethrowWithPosition pos $
- throwError . errorMessage $ OverlappingNamesInLet
- return ((pos, args ++ bound), Let ds val')
- where
+ let args = mapMaybe letBoundVariable ds
+ unless (length (nub args) == length args) $
+ maybe id rethrowWithPosition pos $
+ throwError . errorMessage $ OverlappingNamesInLet
+ return ((pos, args ++ bound), Let ds val')
updateValue (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =
(,) (pos, bound) <$> (Var <$> updateValueName name' pos)
updateValue (pos, bound) (Var name'@(Qualified (Just _) _)) =
(,) (pos, bound) <$> (Var <$> updateValueName name' pos)
- updateValue s@(pos, _) (Constructor name) = (,) s <$> (Constructor <$> updateDataConstructorName name pos)
- updateValue s@(pos, _) (TypedValue check val ty) = (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)
+ updateValue s@(pos, _) (Constructor name) =
+ (,) s <$> (Constructor <$> updateDataConstructorName name pos)
+ updateValue s@(pos, _) (TypedValue check val ty) =
+ (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)
updateValue s v = return (s, v)
updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> m ((Maybe SourceSpan, [Ident]), Binder)
- updateBinder (_, bound) v@(PositionedBinder pos _ _) = return ((Just pos, bound), v)
- updateBinder s@(pos, _) (ConstructorBinder name b) = (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)
- updateBinder s v = return (s, v)
+ updateBinder (_, bound) v@(PositionedBinder pos _ _) =
+ return ((Just pos, bound), v)
+ updateBinder s@(pos, _) (ConstructorBinder name b) =
+ (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)
+ updateBinder s v =
+ return (s, v)
updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> m ((Maybe SourceSpan, [Ident]), CaseAlternative)
- updateCase (pos, bound) c@(CaseAlternative bs _) = return ((pos, concatMap binderNames bs ++ bound), c)
+ updateCase (pos, bound) c@(CaseAlternative bs _) =
+ return ((pos, concatMap binderNames bs ++ bound), c)
letBoundVariable :: Declaration -> Maybe Ident
letBoundVariable (ValueDeclaration ident _ _ _) = Just ident
@@ -320,290 +167,78 @@ renameInModule imports exports (Module coms mn decls exps) =
letBoundVariable _ = Nothing
updateTypesEverywhere :: Maybe SourceSpan -> Type -> m Type
- updateTypesEverywhere pos0 = everywhereOnTypesM (updateType pos0)
+ updateTypesEverywhere pos = everywhereOnTypesM updateType
where
- updateType :: Maybe SourceSpan -> Type -> m Type
- updateType pos (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos
- updateType pos (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name pos <*> pure tys
- updateType pos (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t
- updateType _ t = return t
+ updateType :: Type -> m Type
+ updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos
+ updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name pos <*> pure tys
+ updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t
+ updateType t = return t
+ updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint]
updateConstraints pos = mapM (\(name, ts) -> (,) <$> updateClassName name pos <*> mapM (updateTypesEverywhere pos) ts)
- updateTypeName = update UnknownType importedTypes (\mes -> isJust . (`lookup` exportedTypes mes))
- updateClassName = update UnknownTypeClass importedTypeClasses (flip elem . exportedTypeClasses)
- updateValueName = update UnknownValue importedValues (flip elem . exportedValues)
- updateDataConstructorName = update (flip UnknownDataConstructor Nothing) importedDataConstructors (\mes -> flip elem (join $ snd `map` exportedTypes mes))
+ updateTypeName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)
+ updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes)
+
+ updateDataConstructorName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)
+ updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes)
- -- Update names so unqualified references become qualified, and locally qualified references
- -- are replaced with their canoncial qualified names (e.g. M.Map -> Data.Map.Map)
+ updateClassName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)
+ updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses)
+
+ updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident)
+ updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues)
+
+ -- Used when performing an update to qualify values and classes with their
+ -- module of original definition.
+ resolve :: (Eq a) => [(a, ModuleName)] -> a -> Maybe (Qualified a)
+ resolve as name = mkQualified name <$> name `lookup` as
+
+ -- Used when performing an update to qualify types with their module of
+ -- original definition.
+ resolveType :: [((ProperName, [ProperName]), ModuleName)] -> ProperName -> Maybe (Qualified ProperName)
+ resolveType tys name = mkQualified name . snd <$> find ((== name) . fst . fst) tys
+
+ -- Used when performing an update to qualify data constructors with their
+ -- module of original definition.
+ resolveDctor :: [((ProperName, [ProperName]), ModuleName)] -> ProperName -> Maybe (Qualified ProperName)
+ resolveDctor tys name = mkQualified name . snd <$> find (elem name . snd . fst) tys
+
+ -- Update names so unqualified references become qualified, and locally
+ -- qualified references are replaced with their canoncial qualified names
+ -- (e.g. M.Map -> Data.Map.Map).
update :: (Ord a, Show a) => (Qualified a -> SimpleErrorMessage)
- -> (ImportEnvironment -> M.Map (Qualified a) (Qualified a))
- -> (Exports -> a -> Bool)
+ -> M.Map (Qualified a) (Qualified a, ModuleName)
+ -> (Exports -> a -> Maybe (Qualified a))
-> Qualified a
-> Maybe SourceSpan
-> m (Qualified a)
- update unknown getI checkE qname@(Qualified mn' name) pos = positioned $ case (M.lookup qname imports', mn') of
- (Just qname', _) -> return qname'
- (Nothing, Just mn'') -> do
- when (isExplicitQualModule mn'') . throwError . errorMessage $ unknown qname
- modExports <- getExports mn''
- if checkE modExports name
- then return qname
- else throwError . errorMessage $ unknown qname
- _ -> throwError . errorMessage $ unknown qname
+ update unknown imps getE qname@(Qualified mn' name) pos = positioned $
+ case (M.lookup qname imps, mn') of
+ -- We found the name in our imports, so we return the name for it,
+ -- qualifying with the name of the module it was originally defined in
+ -- rather than the module we're importing from, to handle the case of
+ -- re-exports.
+ (Just (_, mnOrig), _) -> return $ Qualified (Just mnOrig) name
+ -- If the name wasn't found in our imports but was qualified then we need
+ -- to check whether it's a failed import from a "pseudo" module (created
+ -- by qualified importing). If that's not the case, then we just need to
+ -- check it refers to a symbol in another module.
+ (Nothing, Just mn'') -> do
+ when (isExplicitQualModule mn'') . throwError . errorMessage $ unknown qname
+ modExports <- getExports mn''
+ maybe (throwError . errorMessage $ unknown qname) return (getE modExports name)
+ -- If neither of the above cases are true then it's an undefined or
+ -- unimported symbol.
+ _ -> throwError . errorMessage $ unknown qname
where
isExplicitQualModule :: ModuleName -> Bool
- isExplicitQualModule = flip elem $ mapMaybe (\(Qualified q _) -> q) (M.keys imports')
- imports' = getI imports
+ isExplicitQualModule = flip elem $ mapMaybe (\(Qualified q _) -> q) (M.keys imps)
positioned err = case pos of
Nothing -> err
Just pos' -> rethrowWithPosition pos' err
-- Gets the exports for a module, or an error message if the module doesn't exist
getExports :: ModuleName -> m Exports
- getExports mn' = maybe (throwError . errorMessage $ UnknownModule mn') return $ M.lookup mn' exports
-
--- |
--- Finds all exported declarations in a set of modules.
---
-findExports :: forall m. (Applicative m, MonadError MultipleErrors m) => [Module] -> m ExportEnvironment
-findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) primExports
- where
-
- -- The exported types from the Prim module
- primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] [] []
- where
- mkTypeEntry (Qualified _ name) = (name, [])
-
- -- Add all of the exported declarations from a module to the global export environment
- addModule :: ExportEnvironment -> Module -> m ExportEnvironment
- addModule env (Module _ mn ds _) = do
- env' <- addEmptyModule env mn
- rethrow (onErrorMessages (ErrorInModule mn)) $ foldM (addDecl mn) env' ds
-
- -- Add a declaration from a module to the global export environment
- addDecl :: ModuleName -> ExportEnvironment -> Declaration -> m ExportEnvironment
- addDecl mn env (TypeClassDeclaration tcn _ _ ds) = do
- env' <- addTypeClass env mn tcn
- foldM go env' ds
- where
- go env'' (TypeDeclaration name _) = addValue env'' mn name
- go env'' (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go env'' d
- go _ _ = error "Invalid declaration in TypeClassDeclaration"
- addDecl mn env (DataDeclaration _ tn _ dcs) = addType env mn tn (map fst dcs)
- addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []
- addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []
- addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name
- addDecl mn env (ExternDeclaration name _) = addValue env mn name
- addDecl mn env (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ addDecl mn env d
- addDecl _ env _ = return env
-
--- |
--- Filters the exports for a module to ensure only explicit exports are kept in the global exports
--- environment.
---
-filterExports :: forall m. (Applicative m, MonadError MultipleErrors m) => ModuleName -> [DeclarationRef] -> ExportEnvironment -> m ExportEnvironment
-filterExports mn exps env = do
- let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)
- moduleExports' <- rethrow (onErrorMessages (ErrorInModule mn)) $ filterModule moduleExports
- return $ M.insert mn moduleExports' env
- where
-
- -- Filter the exports for the specific module
- filterModule :: Exports -> m Exports
- filterModule exported = do
- types' <- foldM (filterTypes $ exportedTypes exported) [] exps
- values <- foldM (filterValues $ exportedValues exported) [] exps
- classes <- foldM (filterClasses $ exportedTypeClasses exported) [] exps
- modules <- foldM (filterModules $ exportedModules exported) [] exps
- return exported { exportedTypes = types', exportedTypeClasses = classes, exportedValues = values, exportedModules = modules }
-
- -- Ensure the exported types and data constructors exist in the module and add them to the set of
- -- exports
- filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> m [(ProperName, [ProperName])]
- filterTypes expTys result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterTypes expTys result r
- filterTypes expTys result (TypeRef name expDcons) = do
- dcons <- maybe (throwError . errorMessage . UnknownType $ Qualified (Just mn) name) return $ name `lookup` expTys
- dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons
- return $ (name, dcons') : result
- filterTypes _ result _ = return result
-
- -- Ensure the exported data constructors exists for a type and add them to the list of exports
- filterDcons :: ProperName -> [ProperName] -> [ProperName] -> ProperName -> m [ProperName]
- filterDcons tcon exps' result name =
- if name `elem` exps'
- then return $ name : result
- else throwError . errorMessage $ UnknownDataConstructor (Qualified (Just mn) name) (Just (Qualified (Just mn) tcon))
-
- -- Ensure the exported classes exist in the module and add them to the set of exports
- filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> m [ProperName]
- filterClasses exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterClasses exps' result r
- filterClasses exps' result (TypeClassRef name) =
- if name `elem` exps'
- then return $ name : result
- else throwError . errorMessage . UnknownTypeClass $ Qualified (Just mn) name
- filterClasses _ result _ = return result
-
- -- Ensure the exported values exist in the module and add them to the set of exports
- filterValues :: [Ident] -> [Ident] -> DeclarationRef -> m [Ident]
- filterValues exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterValues exps' result r
- filterValues exps' result (ValueRef name) =
- if name `elem` exps'
- then return $ name : result
- else throwError . errorMessage . UnknownValue $ Qualified (Just mn) name
- filterValues _ result _ = return result
-
- -- Add the exported modules to the set of exports
- filterModules :: [ModuleName] -> [ModuleName] -> DeclarationRef -> m [ModuleName]
- filterModules exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterModules exps' result r
- filterModules _ result (ModuleRef name) = return $ name : result
- filterModules _ result _ = return result
-
--- |
--- Finds the imports within a module, mapping the imported module name to an optional set of
--- explicitly imported declarations.
---
-findImports :: [Declaration] -> M.Map ModuleName (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)
-findImports = foldl (findImports' Nothing) M.empty
- where
- findImports' pos result (ImportDeclaration mn typ qual) = M.insert mn (pos, typ, qual) result
- findImports' _ result (PositionedDeclaration pos _ d) = findImports' (Just pos) result d
- findImports' _ result _ = result
-
--- |
--- Constructs a local environment for a module.
---
-resolveImports :: forall m. (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> Module -> m ImportEnvironment
-resolveImports env (Module _ currentModule decls _) =
- foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
- where
-
- -- A Map from module name to the source position for the import, the list of imports from that
- -- module (where Nothing indicates everything is to be imported), and optionally a qualified name
- -- for the module
- scope :: M.Map ModuleName (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)
- scope = M.insert currentModule (Nothing, Implicit, Nothing) (findImports decls)
-
- resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)) -> m ImportEnvironment
- resolveImport' imp (mn, (pos, typ, impQual)) = do
- modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) return $ mn `M.lookup` env
- positioned $ resolveImport currentModule mn modExports imp impQual typ
- where
- positioned err = case pos of
- Nothing -> err
- Just pos' -> rethrowWithPosition pos' err
-
--- |
--- Extends the local environment for a module by resolving an import of another module.
---
-resolveImport :: forall m. (Applicative m, MonadError MultipleErrors m) => ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> ImportDeclarationType -> m ImportEnvironment
-resolveImport currentModule importModule exps imps impQual =
- resolveByType
- where
-
- resolveByType :: ImportDeclarationType -> m ImportEnvironment
- resolveByType Implicit = importAll importExplicit
- resolveByType (Explicit explImports) = (checkedRefs >=> foldM importExplicit imps) explImports
- resolveByType (Hiding hiddenImports) = do
- hiddenImports' <- checkedRefs hiddenImports
- importAll (importNonHidden hiddenImports')
-
- importNonHidden :: [DeclarationRef] -> ImportEnvironment -> DeclarationRef -> m ImportEnvironment
- importNonHidden hidden m ref =
- if isHidden hidden ref
- then return m
- else importExplicit m ref
-
- isHidden :: [DeclarationRef] -> DeclarationRef -> Bool
- isHidden hidden ref@(TypeRef _ _) =
- let
- checkTypeRef _ True _ = True
- checkTypeRef (TypeRef _ Nothing) acc (TypeRef _ (Just _)) = acc
- checkTypeRef (TypeRef name (Just dctor)) _ (TypeRef name' (Just dctor')) = name == name' && dctor == dctor'
- checkTypeRef (TypeRef name _) _ (TypeRef name' Nothing) = name == name'
- checkTypeRef (PositionedDeclarationRef _ _ r) acc hiddenRef = checkTypeRef r acc hiddenRef
- checkTypeRef _ acc _ = acc
- in foldl (checkTypeRef ref) False hidden
- isHidden hidden ref = ref `elem` hidden
-
- -- Import all symbols
- importAll :: (ImportEnvironment -> DeclarationRef -> m ImportEnvironment) -> m ImportEnvironment
- importAll importer = do
- imp' <- foldM (\m (name, dctors) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps)
- imp'' <- foldM (\m name -> importer m (ValueRef name)) imp' (exportedValues exps)
- foldM (\m name -> importer m (TypeClassRef name)) imp'' (exportedTypeClasses exps)
-
- -- Import something explicitly
- importExplicit :: ImportEnvironment -> DeclarationRef -> m ImportEnvironment
- importExplicit imp (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ importExplicit imp r
- importExplicit imp (ValueRef name) = do
- values' <- updateImports (importedValues imp) name
- return $ imp { importedValues = values' }
- importExplicit imp (TypeRef name dctors) = do
- types' <- updateImports (importedTypes imp) name
- let allDctors = allExportedDataConstructors name
- dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
- dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'
- return $ imp { importedTypes = types', importedDataConstructors = dctors'' }
- importExplicit imp (TypeClassRef name) = do
- typeClasses' <- updateImports (importedTypeClasses imp) name
- return $ imp { importedTypeClasses = typeClasses' }
- importExplicit _ _ = error "Invalid argument to importExplicit"
-
- -- Check if DeclarationRef points to an existent symbol
- checkedRefs :: [DeclarationRef] -> m [DeclarationRef]
- checkedRefs = mapM check
- where
- check (PositionedDeclarationRef pos _ r) =
- rethrowWithPosition pos $ check r
- check ref@(ValueRef name) =
- checkImportExists UnknownValue values name >> return ref
- check ref@(TypeRef name dctors) = do
- _ <- checkImportExists UnknownType availableTypes name
- let allDctors = allExportedDataConstructors name
- _ <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
- return ref
- check ref@(TypeClassRef name) =
- checkImportExists UnknownTypeClass classes name >> return ref
- check ref@(ModuleRef name) =
- checkImportExists (UnknownModule . (\(Qualified _ m) -> m)) (exportedModules exps) name >> return ref
- check _ = error "Invalid argument to checkRefIsValid"
-
- -- Find all exported data constructors for a given type
- allExportedDataConstructors :: ProperName -> [ProperName]
- allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps
-
- -- Add something to the ImportEnvironment if it does not already exist there
- updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a) -> a -> m (M.Map (Qualified a) (Qualified a))
- updateImports m name = case M.lookup (Qualified impQual name) m of
- Nothing -> return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name) m
- Just (Qualified Nothing _) -> error "Invalid state in updateImports"
- Just (Qualified (Just mn) _) -> throwError . errorMessage $ err
- where
- err = if currentModule `elem` [mn, importModule]
- then ConflictingImport (show name) importModule
- else ConflictingImports (show name) mn importModule
-
- -- The available values, types, and classes in the module being imported
- values = exportedValues exps
- availableTypes = fst `map` exportedTypes exps
- classes = exportedTypeClasses exps
-
- -- Ensure that an explicitly imported data constructor exists for the type it is being imported
- -- from
- checkDctorExists :: [ProperName] -> ProperName -> m ProperName
- checkDctorExists = checkImportExists (flip UnknownDataConstructor Nothing)
-
- -- Check that an explicitly imported item exists in the module it is being imported from
- checkImportExists :: (Eq a, Show a) => (Qualified a -> SimpleErrorMessage) -> [a] -> a -> m a
- checkImportExists unknown exports item =
- if item `elem` exports
- then return item
- else throwError . errorMessage . unknown $ Qualified (Just importModule) item
-
--- |
--- Raises an error for when there is more than one definition for something.
---
-throwConflictError :: (Applicative m, MonadError MultipleErrors m, Show a) => (a -> SimpleErrorMessage) -> a -> m b
-throwConflictError conflict = throwError . errorMessage . conflict
+ getExports mn' = maybe (throwError . errorMessage $ UnknownModule mn') (return . envModuleExports) $ M.lookup mn' env
diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs
new file mode 100644
index 0000000..115fbaf
--- /dev/null
+++ b/src/Language/PureScript/Sugar/Names/Env.hs
@@ -0,0 +1,197 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Sugar.Names.Env
+-- License : MIT (http://opensource.org/licenses/MIT)
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE FlexibleContexts #-}
+--{-# LANGUAGE ScopedTypeVariables #-}
+--{-# LANGUAGE PatternGuards #-}
+--{-# LANGUAGE RankNTypes #-}
+--{-# LANGUAGE TupleSections #-}
+
+module Language.PureScript.Sugar.Names.Env
+ ( Imports(..)
+ , nullImports
+ , Exports(..)
+ , nullExports
+ , Env
+ , initEnv
+ , envModuleSourceSpan
+ , envModuleImports
+ , envModuleExports
+ , exportType
+ , exportTypeClass
+ , exportValue
+ ) where
+
+import Control.Monad
+import Control.Monad.Error.Class (MonadError(..))
+
+import qualified Data.Map as M
+
+import Language.PureScript.AST
+import Language.PureScript.Names
+import Language.PureScript.Environment
+import Language.PureScript.Errors
+
+-- |
+-- The imported declarations for a module, including the module's own members.
+--
+data Imports = Imports
+ {
+ -- |
+ -- Local names for types within a module mapped to to their qualified names
+ --
+ importedTypes :: M.Map (Qualified ProperName) (Qualified ProperName, ModuleName)
+ -- |
+ -- Local names for data constructors within a module mapped to to their qualified names
+ --
+ , importedDataConstructors :: M.Map (Qualified ProperName) (Qualified ProperName, ModuleName)
+ -- |
+ -- Local names for classes within a module mapped to to their qualified names
+ --
+ , importedTypeClasses :: M.Map (Qualified ProperName) (Qualified ProperName, ModuleName)
+ -- |
+ -- Local names for values within a module mapped to to their qualified names
+ --
+ , importedValues :: M.Map (Qualified Ident) (Qualified Ident, ModuleName)
+ -- |
+ -- The list of modules that have been imported into the current scope.
+ --
+ , importedModules :: [ModuleName]
+ } deriving (Show)
+
+-- |
+-- An empty 'Imports' value.
+--
+nullImports :: Imports
+nullImports = Imports M.empty M.empty M.empty M.empty []
+
+-- |
+-- The exported declarations from a module.
+--
+data Exports = Exports
+ {
+ -- |
+ -- The types exported from each module along with the module they originally
+ -- came from.
+ --
+ exportedTypes :: [((ProperName, [ProperName]), ModuleName)]
+ -- |
+ -- The classes exported from each module along with the module they originally
+ -- came from.
+ --
+ , exportedTypeClasses :: [(ProperName, ModuleName)]
+ -- |
+ -- The values exported from each module along with the module they originally
+ -- came from.
+ --
+ , exportedValues :: [(Ident, ModuleName)]
+ } deriving (Show)
+
+-- |
+-- An empty 'Exports' value.
+--
+nullExports :: Exports
+nullExports = Exports [] [] []
+
+-- |
+-- The imports and exports for a collection of modules. The 'SourceSpan' is used
+-- to store the source location of the module with a given name, used to provide
+-- useful information when there is a duplicate module definition.
+--
+type Env = M.Map ModuleName (SourceSpan, Imports, Exports)
+
+-- |
+-- Extracts the 'SourceSpan' from an 'Env' value.
+--
+envModuleSourceSpan :: (SourceSpan, a, b) -> SourceSpan
+envModuleSourceSpan (ss, _, _) = ss
+
+-- |
+-- Extracts the 'Imports' from an 'Env' value.
+--
+envModuleImports :: (a, Imports, b) -> Imports
+envModuleImports (_, imps, _) = imps
+
+-- |
+-- Extracts the 'Exports' from an 'Env' value.
+--
+envModuleExports :: (a, b, Exports) -> Exports
+envModuleExports (_, _, exps) = exps
+
+-- |
+-- The exported types from the @Prim@ module
+--
+primExports :: Exports
+primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] []
+ where
+ mkTypeEntry (Qualified _ name) = ((name, []), ModuleName [ProperName "Prim"])
+
+-- |
+-- The initial global import/export environment containing the @Prim@ module.
+--
+initEnv :: Env
+initEnv = M.singleton
+ (ModuleName [ProperName "Prim"])
+ (internalModuleSourceSpan "<Prim>", nullImports, primExports)
+
+-- |
+-- Safely adds a type and its data constructors to some exports, returning an
+-- error if a conflict occurs.
+--
+exportType :: (MonadError MultipleErrors m) => Exports -> ProperName -> [ProperName] -> ModuleName -> m Exports
+exportType exps name dctors mn = do
+ let exTypes = exportedTypes exps
+ let exDctors = (snd . fst) `concatMap` exTypes
+ let exClasses = exportedTypeClasses exps
+ when (any (\((name', _), _) -> name == name') exTypes) $ throwConflictError ConflictingTypeDecls name
+ when (any ((== name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name
+ forM_ dctors $ \dctor -> do
+ when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor
+ when (any ((== dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor
+ return $ exps { exportedTypes = ((name, dctors), mn) : exTypes }
+
+-- |
+-- Safely adds a class to some exports, returning an error if a conflict occurs.
+--
+exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName -> ModuleName -> m Exports
+exportTypeClass exps name mn = do
+ let exTypes = exportedTypes exps
+ let exDctors = (snd . fst) `concatMap` exTypes
+ when (any (\((name', _), _) -> name == name') exTypes) $ throwConflictError ClassConflictsWithType name
+ when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name
+ classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps)
+ return $ exps { exportedTypeClasses = classes }
+
+-- |
+-- Safely adds a value to some exports, returning an error if a conflict occurs.
+--
+exportValue :: (MonadError MultipleErrors m) => Exports -> Ident -> ModuleName -> m Exports
+exportValue exps name mn = do
+ values <- addExport DuplicateValueExport name mn (exportedValues exps)
+ return $ exps { exportedValues = values }
+
+-- |
+-- Adds an entry to a list of exports unless it is already present, in which case an error is
+-- returned.
+--
+addExport :: (MonadError MultipleErrors m, Eq a, Show a) => (a -> SimpleErrorMessage) -> a -> ModuleName -> [(a, ModuleName)] -> m [(a, ModuleName)]
+addExport what name mn exports =
+ if any ((== name) . fst) exports
+ then throwConflictError what name
+ else return $ (name, mn) : exports
+
+-- |
+-- Raises an error for when there is more than one definition for something.
+--
+throwConflictError :: (MonadError MultipleErrors m, Show a) => (a -> SimpleErrorMessage) -> a -> m b
+throwConflictError conflict = throwError . errorMessage . conflict
diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs
new file mode 100644
index 0000000..2c0f87c
--- /dev/null
+++ b/src/Language/PureScript/Sugar/Names/Exports.hs
@@ -0,0 +1,236 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Sugar.Names.Exports
+-- License : MIT (http://opensource.org/licenses/MIT)
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+
+module Language.PureScript.Sugar.Names.Exports
+ ( findExportable
+ , resolveExports
+ ) where
+
+import Data.List (find, intersect)
+import Data.Maybe (fromMaybe, mapMaybe)
+
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative (Applicative(..), (<$>))
+#endif
+import Control.Monad
+import Control.Monad.Error.Class (MonadError(..))
+
+import qualified Data.Map as M
+
+import Language.PureScript.AST
+import Language.PureScript.Names
+import Language.PureScript.Errors
+import Language.PureScript.Sugar.Names.Env
+
+-- |
+-- Finds all exportable members of a module, disregarding any explicit exports.
+--
+findExportable :: forall m. (Applicative m, MonadError MultipleErrors m) => Module -> m Exports
+findExportable (Module _ _ mn ds _) =
+ rethrow (onErrorMessages (ErrorInModule mn)) $ foldM updateExports nullExports ds
+ where
+ updateExports :: Exports -> Declaration -> m Exports
+ updateExports exps (TypeClassDeclaration tcn _ _ ds') = do
+ exps' <- exportTypeClass exps tcn mn
+ foldM go exps' ds'
+ where
+ go exps'' (TypeDeclaration name _) = exportValue exps'' name mn
+ go exps'' (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go exps'' d
+ go _ _ = error "Invalid declaration in TypeClassDeclaration"
+ updateExports exps (DataDeclaration _ tn _ dcs) = exportType exps tn (map fst dcs) mn
+ updateExports exps (TypeSynonymDeclaration tn _ _) = exportType exps tn [] mn
+ updateExports exps (ExternDataDeclaration tn _) = exportType exps tn [] mn
+ updateExports exps (ValueDeclaration name _ _ _) = exportValue exps name mn
+ updateExports exps (ExternDeclaration name _) = exportValue exps name mn
+ updateExports exps (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ updateExports exps d
+ updateExports exps _ = return exps
+
+-- |
+-- Resolves the exports for a module, filtering out members that have not been
+-- exported and elaborating re-exports of other modules.
+--
+resolveExports :: forall m. (Applicative m, MonadError MultipleErrors m) => Env -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports
+resolveExports env mn imps exps refs =
+ rethrow (onErrorMessages (ErrorInModule mn)) $ do
+ filtered <- filterModule mn exps refs
+ foldM elaborateModuleExports filtered refs
+
+ where
+
+ -- Takes the current module's imports, the accumulated list of exports, and a
+ -- `DeclarationRef` for an explicit export. When the ref refers to another
+ -- module, export anything from the imports that matches for that module.
+ elaborateModuleExports :: Exports -> DeclarationRef -> m Exports
+ elaborateModuleExports result (PositionedDeclarationRef pos _ r) =
+ rethrowWithPosition pos $ elaborateModuleExports result r
+ elaborateModuleExports result (ModuleRef name) | name == mn = do
+ let types' = exportedTypes result ++ exportedTypes exps
+ let classes' = exportedTypeClasses result ++ exportedTypeClasses exps
+ let values' = exportedValues result ++ exportedValues exps
+ return result { exportedTypes = types'
+ , exportedTypeClasses = classes'
+ , exportedValues = values' }
+ elaborateModuleExports result (ModuleRef name) = do
+ let isPseudo = isPseudoModule name
+ when (not isPseudo && not (isImportedModule name)) $
+ throwError . errorMessage . UnknownExportModule $ name
+ let reTypes = extract isPseudo name (importedTypes imps)
+ let reDctors = extract isPseudo name (importedDataConstructors imps)
+ let reClasses = extract isPseudo name (importedTypeClasses imps)
+ let reValues = extract isPseudo name (importedValues imps)
+ result' <- foldM (\exps' ((tctor, dctors), mn') -> exportType exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors)
+ result'' <- foldM (uncurry . exportTypeClass) result' (map resolveClass reClasses)
+ foldM (uncurry . exportValue) result'' (map resolveValue reValues)
+ elaborateModuleExports result _ = return result
+
+ -- Extracts a list of values for a module based on a lookup table. If the
+ -- boolean is true the values are filtered by the qualification of the
+ extract :: Bool -> ModuleName -> M.Map (Qualified a) (Qualified a, ModuleName) -> [Qualified a]
+ extract True name = map fst . M.elems . M.filterWithKey (\k _ -> eqQual name k)
+ extract False name = map fst . M.elems . M.filter (eqQual name . fst)
+
+ -- Check whether a module name refers to a "pseudo module" that came into
+ -- existence in an import scope due to importing one or more modules as
+ -- qualified.
+ isPseudoModule :: ModuleName -> Bool
+ isPseudoModule = testQuals M.keys
+ where
+ -- Test for the presence of a `ModuleName` in a set of imports, using a
+ -- function to either extract the keys or values. We test the keys to see if a
+ -- value being re-exported belongs to a qualified module, and we test the
+ -- values if that fails to see whether the value has been imported at all.
+ testQuals :: (forall a. M.Map (Qualified a) (Qualified a, ModuleName) -> [Qualified a]) -> ModuleName -> Bool
+ testQuals f mn' = any (eqQual mn') (f (importedTypes imps))
+ || any (eqQual mn') (f (importedDataConstructors imps))
+ || any (eqQual mn') (f (importedTypeClasses imps))
+ || any (eqQual mn') (f (importedValues imps))
+
+ -- Check whether a module name refers to a module that has been imported
+ -- without qualification into an import scope.
+ isImportedModule :: ModuleName -> Bool
+ isImportedModule = flip elem (importedModules imps)
+
+ -- Check whether a module name matches that of a qualified value.
+ eqQual :: ModuleName -> Qualified a -> Bool
+ eqQual mn'' (Qualified (Just mn''') _) = mn'' == mn'''
+ eqQual _ _ = False
+
+ -- Constructs a list of types with their data constructors and the original
+ -- module they were defined in from a list of type and data constructor names.
+ resolveTypeExports :: [Qualified ProperName] -> [Qualified ProperName] -> [((ProperName, [ProperName]), ModuleName)]
+ resolveTypeExports tctors dctors = map go tctors
+ where
+ go :: Qualified ProperName -> ((ProperName, [ProperName]), ModuleName)
+ go (Qualified (Just mn'') name) = fromMaybe (error "Missing value in resolveTypeExports") $ do
+ exps' <- envModuleExports <$> mn'' `M.lookup` env
+ ((_, dctors'), mnOrig) <- find (\((name', _), _) -> name == name') (exportedTypes exps')
+ let relevantDctors = mapMaybe (\(Qualified mn''' dctor) -> if mn''' == Just mnOrig then Just dctor else Nothing) dctors
+ return ((name, intersect relevantDctors dctors'), mnOrig)
+ go (Qualified Nothing _) = error "Unqualified value in resolveTypeExports"
+
+
+ -- Looks up an imported class and re-qualifies it with the original module it
+ -- came from.
+ resolveClass :: Qualified ProperName -> (ProperName, ModuleName)
+ resolveClass className = splitQual $ fromMaybe (error "Missing value in resolveClass") $
+ resolve exportedTypeClasses className
+
+ -- Looks up an imported value and re-qualifies it with the original module it
+ -- came from.
+ resolveValue :: Qualified Ident -> (Ident, ModuleName)
+ resolveValue ident = splitQual $ fromMaybe (error "Missing value in resolveValue") $
+ resolve exportedValues ident
+
+ resolve :: (Eq a) => (Exports -> [(a, ModuleName)]) -> Qualified a -> Maybe (Qualified a)
+ resolve f (Qualified (Just mn'') a) = do
+ exps' <- envModuleExports <$> mn'' `M.lookup` env
+ mn''' <- snd <$> find ((== a) . fst) (f exps')
+ return $ Qualified (Just mn''') a
+ resolve _ _ = error "Unqualified value in resolve"
+
+ -- A partial function that takes a qualified value and extracts the value and
+ -- qualified module components.
+ splitQual :: Qualified a -> (a, ModuleName)
+ splitQual (Qualified (Just mn'') a) = (a, mn'')
+ splitQual _ = error "Unqualified value in splitQual"
+
+-- |
+-- Filters the full list of exportable values, types, and classes for a module
+-- based on a list of export declaration references.
+--
+filterModule :: forall m. (Applicative m, MonadError MultipleErrors m) => ModuleName -> Exports -> [DeclarationRef] -> m Exports
+filterModule mn exps refs = do
+ types <- foldM (filterTypes $ exportedTypes exps) [] refs
+ values <- foldM (filterValues $ exportedValues exps) [] refs
+ classes <- foldM (filterClasses $ exportedTypeClasses exps) [] refs
+ return exps { exportedTypes = types , exportedTypeClasses = classes , exportedValues = values }
+
+ where
+
+ -- Takes a list of all the exportable types with their data constructors, the
+ -- accumulated list of filtered exports, and a `DeclarationRef` for an
+ -- explicit export. When the ref refers to a type in the list of exportable
+ -- values, the type and specified data constructors are included in the
+ -- result.
+ filterTypes :: [((ProperName, [ProperName]), ModuleName)] -> [((ProperName, [ProperName]), ModuleName)] -> DeclarationRef -> m [((ProperName, [ProperName]), ModuleName)]
+ filterTypes exps' result (PositionedDeclarationRef pos _ r) =
+ rethrowWithPosition pos $ filterTypes exps' result r
+ filterTypes exps' result (TypeRef name expDcons) =
+ case (\((name', _), mn') -> name == name' && mn == mn') `find` exps' of
+ Nothing -> throwError . errorMessage . UnknownExportType $ name
+ Just ((_, dcons), _) -> do
+ let expDcons' = fromMaybe dcons expDcons
+ mapM_ (checkDcon name dcons) expDcons'
+ return $ ((name, expDcons'), mn) : result
+ filterTypes _ result _ = return result
+
+ -- Ensures a data constructor is exportable for a given type. Takes a type
+ -- name, a list of exportable data constructors for the type, and the name of
+ -- the data constructor to check.
+ checkDcon :: ProperName -> [ProperName] -> ProperName -> m ()
+ checkDcon tcon exps' name =
+ if name `elem` exps'
+ then return ()
+ else throwError . errorMessage $ UnknownExportDataConstructor tcon name
+
+ -- Takes a list of all the exportable classes, the accumulated list of
+ -- filtered exports, and a `DeclarationRef` for an explicit export. When the
+ -- ref refers to a class in the list of exportable classes, the class is
+ -- included in the result.
+ filterClasses :: [(ProperName, ModuleName)] -> [(ProperName, ModuleName)] -> DeclarationRef -> m [(ProperName, ModuleName)]
+ filterClasses exps' result (PositionedDeclarationRef pos _ r) =
+ rethrowWithPosition pos $ filterClasses exps' result r
+ filterClasses exps' result (TypeClassRef name) =
+ if (name, mn) `elem` exps'
+ then return $ (name, mn) : result
+ else throwError . errorMessage . UnknownExportTypeClass $ name
+ filterClasses _ result _ = return result
+
+ -- Takes a list of all the exportable values, the accumulated list of filtered
+ -- exports, and a `DeclarationRef` for an explicit export. When the ref refers
+ -- to a value in the list of exportable values, the value is included in the
+ -- result.
+ filterValues :: [(Ident, ModuleName)] -> [(Ident, ModuleName)] -> DeclarationRef -> m [(Ident, ModuleName)]
+ filterValues exps' result (PositionedDeclarationRef pos _ r) =
+ rethrowWithPosition pos $ filterValues exps' result r
+ filterValues exps' result (ValueRef name) =
+ if (name, mn) `elem` exps'
+ then return $ (name, mn) : result
+ else throwError . errorMessage . UnknownExportValue $ name
+ filterValues _ result _ = return result
diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs
new file mode 100644
index 0000000..b82182e
--- /dev/null
+++ b/src/Language/PureScript/Sugar/Names/Imports.hs
@@ -0,0 +1,202 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Sugar.Names.Imports
+-- License : MIT (http://opensource.org/licenses/MIT)
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+
+module Language.PureScript.Sugar.Names.Imports (resolveImports) where
+
+import Data.List (find)
+import Data.Maybe (fromMaybe, isNothing)
+
+import Control.Arrow (first)
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative (Applicative(..), (<$>))
+#endif
+import Control.Monad
+import Control.Monad.Error.Class (MonadError(..))
+import Control.Monad.Writer (MonadWriter(..), censor)
+
+import qualified Data.Map as M
+
+import Language.PureScript.AST
+import Language.PureScript.Names
+import Language.PureScript.Errors
+import Language.PureScript.Sugar.Names.Env
+
+-- Finds the imports within a module, mapping the imported module name to an optional set of
+-- explicitly imported declarations.
+findImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Declaration] -> m (M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])
+findImports = foldM (go Nothing) M.empty
+ where
+ go pos result (ImportDeclaration mn typ qual) = do
+ checkImportRefType typ
+ let imp = (pos, typ, qual)
+ return $ M.insert mn (maybe [imp] (imp :) (mn `M.lookup` result)) result
+ go _ result (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go (Just pos) result d
+ go _ result _ = return result
+
+ -- Ensure that classes don't appear in an `import X hiding (...)`
+ checkImportRefType :: ImportDeclarationType -> m ()
+ checkImportRefType (Hiding refs) = mapM_ checkImportRef refs
+ checkImportRefType _ = return ()
+ checkImportRef :: DeclarationRef -> m ()
+ checkImportRef (ModuleRef name) = throwError . errorMessage $ ImportHidingModule name
+ checkImportRef _ = return ()
+
+-- |
+-- Constructs a set of imports for a module.
+--
+resolveImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> Module -> m Imports
+resolveImports env (Module _ _ currentModule decls _) =
+ censor (onErrorMessages (ErrorInModule currentModule)) $ do
+ scope <- M.insert currentModule [(Nothing, Implicit, Nothing)] <$> findImports decls
+ foldM resolveImport' nullImports (M.toList scope)
+ where
+
+ resolveImport' :: Imports -> (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) -> m Imports
+ resolveImport' ie (mn, imps) = foldM go ie imps
+ where
+ go :: Imports -> (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -> m Imports
+ go ie' (pos, typ, impQual) = do
+ modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env
+ let ie'' = ie' { importedModules = mn : importedModules ie' }
+ positioned $ resolveImport currentModule mn modExports ie'' impQual typ
+ where
+ positioned err = case pos of
+ Nothing -> err
+ Just pos' -> rethrowWithPosition pos' err
+
+-- |
+-- Extends the local environment for a module by resolving an import of another module.
+--
+resolveImport :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> ModuleName -> Exports -> Imports -> Maybe ModuleName -> ImportDeclarationType -> m Imports
+resolveImport currentModule importModule exps imps impQual =
+ resolveByType
+ where
+
+ resolveByType :: ImportDeclarationType -> m Imports
+ resolveByType Implicit = importAll importExplicit
+ resolveByType (Explicit explImports) = checkRefs explImports >> foldM importExplicit imps explImports
+ resolveByType (Hiding hiddenImports) = checkRefs hiddenImports >> importAll (importNonHidden hiddenImports)
+
+ -- Check that a 'DeclarationRef' refers to an importable symbol
+ checkRefs :: [DeclarationRef] -> m ()
+ checkRefs = mapM_ check
+ where
+ check (PositionedDeclarationRef pos _ r) =
+ rethrowWithPosition pos $ check r
+ check (ValueRef name) =
+ checkImportExists UnknownImportValue (fst `map` exportedValues exps) name
+ check (TypeRef name dctors) = do
+ checkImportExists UnknownImportType ((fst . fst) `map` exportedTypes exps) name
+ let allDctors = fst `map` allExportedDataConstructors name
+ maybe (return ()) (mapM_ $ checkDctorExists name allDctors) dctors
+ check (TypeClassRef name) =
+ checkImportExists UnknownImportTypeClass (fst `map` exportedTypeClasses exps) name
+ --check (ModuleRef name) =
+ -- checkImportExists (const UnknownModule) (exportedModules exps) name
+ check _ = error "Invalid argument to checkRefs"
+
+ -- Check that an explicitly imported item exists in the module it is being imported from
+ checkImportExists :: (Eq a, Show a) => (ModuleName -> a -> SimpleErrorMessage) -> [a] -> a -> m ()
+ checkImportExists unknown exports item =
+ when (item `notElem` exports) $ throwError . errorMessage $ unknown importModule item
+
+ -- Ensure that an explicitly imported data constructor exists for the type it is being imported
+ -- from
+ checkDctorExists :: ProperName -> [ProperName] -> ProperName -> m ()
+ checkDctorExists tcon = checkImportExists (flip UnknownImportDataConstructor tcon)
+
+ importNonHidden :: [DeclarationRef] -> Imports -> DeclarationRef -> m Imports
+ importNonHidden hidden m ref | isHidden ref = return m
+ | otherwise = importExplicit m ref
+ where
+ -- TODO: rework this to be not confusing
+ isHidden :: DeclarationRef -> Bool
+ isHidden ref'@(TypeRef _ _) = foldl (checkTypeRef ref') False hidden
+ isHidden ref' = ref' `elem` hidden
+ checkTypeRef :: DeclarationRef -> Bool -> DeclarationRef -> Bool
+ checkTypeRef _ True _ = True
+ checkTypeRef r acc (PositionedDeclarationRef _ _ h) = checkTypeRef r acc h
+ checkTypeRef (TypeRef _ Nothing) acc (TypeRef _ (Just _)) = acc
+ checkTypeRef (TypeRef name (Just dctor)) _ (TypeRef name' (Just dctor')) = name == name' && dctor == dctor'
+ checkTypeRef (TypeRef name _) _ (TypeRef name' Nothing) = name == name'
+ checkTypeRef (PositionedDeclarationRef _ _ r) acc hiddenRef = checkTypeRef r acc hiddenRef
+ checkTypeRef _ acc _ = acc
+
+ -- Import all symbols
+ importAll :: (Imports -> DeclarationRef -> m Imports) -> m Imports
+ importAll importer = do
+ imp' <- foldM (\m ((name, dctors), _) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps)
+ imp'' <- foldM (\m (name, _) -> importer m (ValueRef name)) imp' (exportedValues exps)
+ foldM (\m (name, _) -> importer m (TypeClassRef name)) imp'' (exportedTypeClasses exps)
+
+ -- Import something explicitly
+ importExplicit :: Imports -> DeclarationRef -> m Imports
+ importExplicit imp (PositionedDeclarationRef pos _ r) =
+ rethrowWithPosition pos . warnWithPosition pos $ importExplicit imp r
+ importExplicit imp (ValueRef name) = do
+ values' <- updateImports (importedValues imp) (exportedValues exps) name
+ return $ imp { importedValues = values' }
+ importExplicit imp (TypeRef name dctors) = do
+ types' <- updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name
+ let exportedDctors :: [(ProperName, ModuleName)]
+ exportedDctors = allExportedDataConstructors name
+ dctorNames :: [ProperName]
+ dctorNames = fst `map` exportedDctors
+ maybe (return ()) (mapM_ $ checkDctorExists name dctorNames) dctors
+ when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name
+ dctors' <- foldM (flip updateImports exportedDctors) (importedDataConstructors imp) (fromMaybe dctorNames dctors)
+ return $ imp { importedTypes = types', importedDataConstructors = dctors' }
+ importExplicit imp (TypeClassRef name) = do
+ typeClasses' <- updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name
+ return $ imp { importedTypeClasses = typeClasses' }
+ importExplicit _ _ = error "Invalid argument to importExplicit"
+
+ -- Find all exported data constructors for a given type
+ allExportedDataConstructors :: ProperName -> [(ProperName, ModuleName)]
+ allExportedDataConstructors name =
+ case find ((== name) . fst . fst) (exportedTypes exps) of
+ Nothing -> error "Invalid state in allExportedDataConstructors"
+ Just ((_, dctors), mn) -> map (, mn) dctors
+
+ -- Add something to the Imports if it does not already exist there
+ updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a, ModuleName)
+ -> [(a, ModuleName)]
+ -> a
+ -> m (M.Map (Qualified a) (Qualified a, ModuleName))
+ updateImports imps' exps' name = case M.lookup (Qualified impQual name) imps' of
+
+ -- If the name is not already present add it to the list, after looking up
+ -- where it was originally defined
+ Nothing ->
+ let mnOrig = fromMaybe (error "Invalid state in updateImports") (name `lookup` exps')
+ in return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name, mnOrig) imps'
+
+ -- If the name already is present check whether it's a duplicate import
+ -- before rejecting it. For example, if module A defines X, and module B
+ -- re-exports A, importing A and B in C should not result in a "conflicting
+ -- import for `x`" error
+ Just (Qualified (Just mn) _, mnOrig)
+ | mnOrig == fromMaybe (error "Invalid state in updateImports") (name `lookup` exps') -> return imps'
+ | otherwise -> throwError . errorMessage $ err
+ where
+ err = if currentModule `elem` [mn, importModule]
+ then ConflictingImport (show name) importModule
+ else ConflictingImports (show name) mn importModule
+
+ Just (Qualified Nothing _, _) ->
+ error "Invalid state in updateImports"
diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs
index 4753723..6b4f6cd 100644
--- a/src/Language/PureScript/Sugar/ObjectWildcards.hs
+++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs
@@ -1,8 +1,8 @@
-----------------------------------------------------------------------------
--
-- Module : Language.PureScript.Sugar.ObjectWildcards
--- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
--- License : MIT
+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
+-- License : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
-- Stability : experimental
@@ -14,12 +14,15 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.Sugar.ObjectWildcards (
desugarObjectConstructors
) where
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Arrow (second)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Supply.Class
@@ -32,7 +35,7 @@ import Language.PureScript.Errors
import Language.PureScript.Names
desugarObjectConstructors :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
-desugarObjectConstructors (Module coms mn ds exts) = Module coms mn <$> mapM desugarDecl ds <*> pure exts
+desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> mapM desugarDecl ds <*> pure exts
where
desugarDecl :: Declaration -> m Declaration
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index 61becc6..17e5a41 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -1,8 +1,8 @@
-----------------------------------------------------------------------------
--
-- Module : Language.PureScript.Sugar.Operators
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
+-- License : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer : Phil Freeman <paf31@cantab.net>
-- Stability : experimental
@@ -20,6 +20,7 @@
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.Sugar.Operators (
rebracket,
@@ -31,7 +32,9 @@ import Language.PureScript.AST
import Language.PureScript.Errors
import Language.PureScript.Names
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Monad.State
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Supply.Class
@@ -57,7 +60,7 @@ rebracket ms = do
mapM (rebracketModule opTable) ms
removeSignedLiterals :: Module -> Module
-removeSignedLiterals (Module coms mn ds exts) = Module coms mn (map f' ds) exts
+removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts
where
(f', _, _) = everywhereOnValues id go id
@@ -65,9 +68,9 @@ removeSignedLiterals (Module coms mn ds exts) = Module coms mn (map f' ds) exts
go other = other
rebracketModule :: (Applicative m, MonadError MultipleErrors m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> m Module
-rebracketModule opTable (Module coms mn ds exts) =
+rebracketModule opTable (Module ss coms mn ds exts) =
let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return
- in Module coms mn <$> (map removeParens <$> parU ds f) <*> pure exts
+ in Module ss coms mn <$> (map removeParens <$> parU ds f) <*> pure exts
removeParens :: Declaration -> Declaration
removeParens =
@@ -78,7 +81,7 @@ removeParens =
go val = val
collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity)]
-collectFixities (Module _ moduleName ds _) = concatMap collect ds
+collectFixities (Module _ _ moduleName ds _) = concatMap collect ds
where
collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity)]
collect (PositionedDeclaration pos _ (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]
@@ -152,7 +155,7 @@ matchOp op = do
guard $ ident == op
desugarOperatorSections :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
-desugarOperatorSections (Module coms mn ds exts) = Module coms mn <$> mapM goDecl ds <*> pure exts
+desugarOperatorSections (Module ss coms mn ds exts) = Module ss coms mn <$> mapM goDecl ds <*> pure exts
where
goDecl :: Declaration -> m Declaration
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 541c152..aa9a1f8 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -1,8 +1,8 @@
-----------------------------------------------------------------------------
--
-- Module : Language.PureScript.Sugar.TypeClasses
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
+-- License : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer : Phil Freeman <paf31@cantab.net>
-- Stability : experimental
@@ -15,6 +15,7 @@
-----------------------------------------------------------------------------
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.Sugar.TypeClasses
( desugarTypeClasses
@@ -33,7 +34,9 @@ import Language.PureScript.Types
import qualified Language.PureScript.Constants as C
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Arrow (first, second)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.State
@@ -54,9 +57,9 @@ desugarTypeClasses :: (Functor m, Applicative m, MonadSupply m, MonadError Multi
desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
desugarModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> Desugar m Module
-desugarModule (Module coms name decls (Just exps)) = do
+desugarModule (Module ss coms name decls (Just exps)) = do
(newExpss, declss) <- unzip <$> parU (sortBy classesFirst decls) (desugarDecl name exps)
- return $ Module coms name (concat declss) $ Just (exps ++ catMaybes newExpss)
+ return $ Module ss coms name (concat declss) $ Just (exps ++ catMaybes newExpss)
where
classesFirst :: Declaration -> Declaration -> Ordering
classesFirst d1 d2
diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
index 2e4a306..10dc9e1 100644
--- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
@@ -19,6 +19,7 @@
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.Sugar.TypeClasses.Deriving (
deriveInstances
@@ -28,7 +29,9 @@ import Data.List
import Data.Maybe (fromMaybe)
import Data.Ord (comparing)
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Monad (replicateM)
import Control.Monad.Supply.Class (MonadSupply, freshName)
import Control.Monad.Error.Class (MonadError(..))
@@ -42,17 +45,17 @@ import qualified Language.PureScript.Constants as C
-- | Elaborates deriving instance declarations by code generation.
deriveInstances :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m) => Module -> m Module
-deriveInstances (Module coms mn ds exts) = Module coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts
+deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts
--- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,
+-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,
-- elaborates that into an instance declaration via code generation.
deriveInstance :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> Declaration -> m Declaration
-deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance)
+deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance)
| className == Qualified (Just dataGeneric) (ProperName C.generic)
, Just (Qualified mn' tyCon) <- unwrapTypeConstructor ty
, mn == fromMaybe mn mn'
= TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon
-deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
+deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
= throwError . errorMessage $ CannotDerive className tys
deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d
deriveInstance _ _ e = return e
@@ -90,7 +93,7 @@ findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType
mkSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorClause args
where
- prodConstructor :: Expr -> Expr
+ prodConstructor :: Expr -> Expr
prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd")))
recordConstructor :: Expr -> Expr
@@ -100,10 +103,10 @@ mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorCl
mkCtorClause (ctorName, tys) = do
idents <- replicateM (length tys) (fmap Ident freshName)
return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))
- where
- caseResult idents =
- App (prodConstructor (StringLiteral . runProperName $ ctorName))
- . ArrayLiteral
+ where
+ caseResult idents =
+ App (prodConstructor (StringLiteral . runProperName $ ctorName))
+ . ArrayLiteral
$ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys
toSpineFun :: Expr -> Type -> Expr
@@ -118,15 +121,15 @@ mkSpineFunction _ _ = error "mkSpineFunction: expected DataDeclaration"
mkSignatureFunction :: ModuleName -> Declaration -> Expr
mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map mkProdClause args
where
- mkSigProd :: [Expr] -> Expr
+ mkSigProd :: [Expr] -> Expr
mkSigProd = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd"))) . ArrayLiteral
- mkSigRec :: [Expr] -> Expr
+ mkSigRec :: [Expr] -> Expr
mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral
-
+
proxy :: Type -> Type
proxy = TypeApp (TypeConstructor (Qualified (Just dataGeneric) (ProperName "Proxy")))
-
+
mkProdClause :: (ProperName, [Type]) -> Expr
mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (runProperName ctorName))
, ("sigValues", ArrayLiteral . map mkProductSignature $ tys)
@@ -147,24 +150,24 @@ mkSignatureFunction _ _ = error "mkSignatureFunction: expected DataDeclaration"
mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args)
where
- mkJust :: Expr -> Expr
+ mkJust :: Expr -> Expr
mkJust = App (Constructor (Qualified (Just dataMaybe) (ProperName "Just")))
- mkNothing :: Expr
+ mkNothing :: Expr
mkNothing = Constructor (Qualified (Just dataMaybe) (ProperName "Nothing"))
-
- prodBinder :: [Binder] -> Binder
+
+ prodBinder :: [Binder] -> Binder
prodBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SProd"))
- recordBinder :: [Binder] -> Binder
+ recordBinder :: [Binder] -> Binder
recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord"))
-
+
mkAlternative :: (ProperName, [Type]) -> m CaseAlternative
mkAlternative (ctorName, tys) = do
idents <- replicateM (length tys) (fmap Ident freshName)
return $ CaseAlternative [ prodBinder [ StringBinder (runProperName ctorName), ArrayBinder (map VarBinder idents)]]
- . Right
- $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))
+ . Right
+ $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))
(zipWith fromSpineFun (map (Var . (Qualified Nothing)) idents) tys)
addCatch :: [CaseAlternative] -> [CaseAlternative]
@@ -172,19 +175,19 @@ mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch
where
catchAll = CaseAlternative [NullBinder] (Right mkNothing)
- fromSpineFun e r
- | Just rec <- objectType r
+ fromSpineFun e r
+ | Just rec <- objectType r
= App (lamCase "r" [ mkRecCase (decomposeRec rec)
, CaseAlternative [NullBinder] (Right mkNothing)
- ])
+ ])
(App e (mkPrelVar "unit"))
fromSpineFun e _ = App (mkGenVar C.fromSpine) (App e (mkPrelVar "unit"))
-
- mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs)
+
+ mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs)
]
- ]
- . Right
+ ]
+ . Right
$ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar x)) y) rs)
mkRecFun :: [(String, Type)] -> Expr
@@ -226,4 +229,4 @@ mkGenVar s = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic]
decomposeRec :: Type -> [(String, Type)]
decomposeRec = sortBy (comparing fst) . go
where go (RCons str typ typs) = (str, typ) : decomposeRec typs
- go _ = [] \ No newline at end of file
+ go _ = []
diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs
index b2c1832..1ed4231 100644
--- a/src/Language/PureScript/Sugar/TypeDeclarations.hs
+++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs
@@ -1,8 +1,8 @@
-----------------------------------------------------------------------------
--
-- Module : Language.PureScript.Sugar.TypeDeclarations
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
+-- License : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer : Phil Freeman <paf31@cantab.net>
-- Stability : experimental
@@ -15,13 +15,16 @@
-----------------------------------------------------------------------------
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.Sugar.TypeDeclarations (
desugarTypeDeclarations,
desugarTypeDeclarationsModule
) where
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Monad (forM)
import Control.Monad.Error.Class (MonadError(..))
@@ -35,9 +38,9 @@ import Language.PureScript.Traversals
-- Replace all top level type declarations in a module with type annotations
--
desugarTypeDeclarationsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
-desugarTypeDeclarationsModule ms = forM ms $ \(Module coms name ds exps) ->
+desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->
rethrow (onErrorMessages (ErrorInModule name)) $
- Module coms name <$> desugarTypeDeclarations ds <*> pure exps
+ Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps
-- |
-- Replace all top level type declarations with type annotations
diff --git a/src/Language/PureScript/Traversals.hs b/src/Language/PureScript/Traversals.hs
index 3132327..67bb513 100644
--- a/src/Language/PureScript/Traversals.hs
+++ b/src/Language/PureScript/Traversals.hs
@@ -12,9 +12,13 @@
--
-----------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
+
module Language.PureScript.Traversals where
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
fstM :: (Functor f) => (a -> f c) -> (a, b) -> f (c, b)
fstM f (a, b) = flip (,) b <$> f a
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 5a7a253..0a126dd 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -14,6 +14,7 @@
-----------------------------------------------------------------------------
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.TypeChecker (
module T,
@@ -31,7 +32,9 @@ import Data.Foldable (for_)
import qualified Data.Map as M
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>), (<*))
+#endif
import Control.Monad.State
import Control.Monad.Error.Class (MonadError(..))
@@ -48,7 +51,7 @@ addDataType moduleName dtype name args dctors ctorKind = do
env <- getEnv
putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
forM_ dctors $ \(dctor, tys) ->
- rethrow (onErrorMessages (ErrorInDataConstructor dctor)) $
+ warnAndRethrow (onErrorMessages (ErrorInDataConstructor dctor)) $
addDataConstructor moduleName dtype name (map fst args) dctor tys
addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
@@ -130,11 +133,11 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms
-- * Process module imports
--
typeCheckAll :: Maybe ModuleName -> ModuleName -> [DeclarationRef] -> [Declaration] -> Check [Declaration]
-typeCheckAll mainModuleName moduleName exps ds = mapM go ds <* mapM_ checkOrphanFixities ds
+typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds
where
go :: Declaration -> Check Declaration
go (DataDeclaration dtype name args dctors) = do
- rethrow (onErrorMessages (ErrorInTypeConstructor name)) $ do
+ warnAndRethrow (onErrorMessages (ErrorInTypeConstructor name)) $ do
when (dtype == Newtype) $ checkNewtype dctors
checkDuplicateTypeArguments $ map fst args
ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
@@ -147,7 +150,7 @@ typeCheckAll mainModuleName moduleName exps ds = mapM go ds <* mapM_ checkOrphan
checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype
checkNewtype _ = throwError . errorMessage $ InvalidNewtype
go (d@(DataBindingGroupDeclaration tys)) = do
- rethrow (onErrorMessages ErrorInDataBindingGroup) $ do
+ warnAndRethrow (onErrorMessages ErrorInDataBindingGroup) $ do
let syns = mapMaybe toTypeSynonym tys
let dataDecls = mapMaybe toDataDecl tys
(syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
@@ -168,7 +171,7 @@ typeCheckAll mainModuleName moduleName exps ds = mapM go ds <* mapM_ checkOrphan
toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'
toDataDecl _ = Nothing
go (TypeSynonymDeclaration name args ty) = do
- rethrow (onErrorMessages (ErrorInTypeSynonym name)) $ do
+ warnAndRethrow (onErrorMessages (ErrorInTypeSynonym name)) $ do
checkDuplicateTypeArguments $ map fst args
kind <- kindsOf False moduleName name args [ty]
let args' = args `withKinds` kind
@@ -176,14 +179,14 @@ typeCheckAll mainModuleName moduleName exps ds = mapM go ds <* mapM_ checkOrphan
return $ TypeSynonymDeclaration name args ty
go (TypeDeclaration{}) = error "Type declarations should have been removed"
go (ValueDeclaration name nameKind [] (Right val)) =
- rethrow (onErrorMessages (ErrorInValueDeclaration name)) $ do
+ warnAndRethrow (onErrorMessages (ErrorInValueDeclaration name)) $ do
valueIsNotDefined moduleName name
[(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]
addValue moduleName name ty nameKind
return $ ValueDeclaration name nameKind [] $ Right val'
go (ValueDeclaration{}) = error "Binders were not desugared"
go (BindingGroupDeclaration vals) =
- rethrow (onErrorMessages (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do
+ warnAndRethrow (onErrorMessages (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do
forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->
valueIsNotDefined moduleName name
tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
@@ -200,7 +203,7 @@ typeCheckAll mainModuleName moduleName exps ds = mapM go ds <* mapM_ checkOrphan
putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }
return d
go (d@(ExternDeclaration name ty)) = do
- rethrow (onErrorMessages (ErrorInForeignImport name)) $ do
+ warnAndRethrow (onErrorMessages (ErrorInForeignImport name)) $ do
env <- getEnv
kind <- kindOf moduleName ty
guardWith (errorMessage (ExpectedType kind)) $ kind == Star
@@ -221,14 +224,14 @@ typeCheckAll mainModuleName moduleName exps ds = mapM go ds <* mapM_ checkOrphan
go (d@(ExternInstanceDeclaration dictName deps className tys)) =
goInstance d dictName deps className tys
go (PositionedDeclaration pos com d) =
- rethrowWithPosition pos $ PositionedDeclaration pos com <$> go d
+ warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d
checkOrphanFixities :: Declaration -> Check ()
checkOrphanFixities (FixityDeclaration _ name) = do
env <- getEnv
guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env
checkOrphanFixities (PositionedDeclaration pos _ d) =
- rethrowWithPosition pos $ checkOrphanFixities d
+ warnAndRethrowWithPosition pos $ checkOrphanFixities d
checkOrphanFixities _ = return ()
goInstance :: Declaration -> Ident -> [Constraint] -> Qualified ProperName -> [Type] -> Check Declaration
@@ -236,16 +239,16 @@ typeCheckAll mainModuleName moduleName exps ds = mapM go ds <* mapM_ checkOrphan
mapM_ (checkTypeClassInstance moduleName) tys
forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
checkOrphanInstance moduleName className tys
- let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular isInstanceExported
+ let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps) TCDRegular
addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (canonicalizeDictionary dict) dict
return d
where
checkOrphanInstance :: ModuleName -> Qualified ProperName -> [Type] -> Check ()
- checkOrphanInstance mn (Qualified (Just mn') _) tys
- | mn == mn' || any checkType tys = return ()
- | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys
+ checkOrphanInstance mn (Qualified (Just mn') _) tys'
+ | mn == mn' || any checkType tys' = return ()
+ | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys'
where
checkType :: Type -> Bool
checkType (TypeVar _) = False
@@ -255,14 +258,6 @@ typeCheckAll mainModuleName moduleName exps ds = mapM go ds <* mapM_ checkOrphan
checkType _ = error "Invalid type in instance in checkOrphanInstance"
checkOrphanInstance _ _ _ = error "Unqualified class name in checkOrphanInstance"
- isInstanceExported :: Bool
- isInstanceExported = any exportsInstance exps
-
- exportsInstance :: DeclarationRef -> Bool
- exportsInstance (TypeInstanceRef name) | name == dictName = True
- exportsInstance (PositionedDeclarationRef _ _ r) = exportsInstance r
- exportsInstance _ = False
-
-- |
-- This function adds the argument kinds for a type constructor so that they may appear in the externs file,
-- extracted from the kind of the type constructor itself.
@@ -278,15 +273,15 @@ typeCheckAll mainModuleName moduleName exps ds = mapM go ds <* mapM_ checkOrphan
-- required by exported members are also exported.
--
typeCheckModule :: Maybe ModuleName -> Module -> Check Module
-typeCheckModule _ (Module _ _ _ Nothing) = error "exports should have been elaborated"
-typeCheckModule mainModuleName (Module coms mn decls (Just exps)) = rethrow (onErrorMessages (ErrorInModule mn)) $ do
+typeCheckModule _ (Module _ _ _ _ Nothing) = error "exports should have been elaborated"
+typeCheckModule mainModuleName (Module ss coms mn decls (Just exps)) = warnAndRethrow (onErrorMessages (ErrorInModule mn)) $ do
modify (\s -> s { checkCurrentModule = Just mn })
decls' <- typeCheckAll mainModuleName mn exps decls
forM_ exps $ \e -> do
checkTypesAreExported e
checkClassMembersAreExported e
checkClassesAreExported e
- return $ Module coms mn decls' (Just exps)
+ return $ Module ss coms mn decls' (Just exps)
where
checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> Check ()
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
index b9b94e2..4a24e75 100644
--- a/src/Language/PureScript/TypeChecker/Entailment.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -14,6 +14,7 @@
-----------------------------------------------------------------------------
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.TypeChecker.Entailment (
entails
@@ -22,13 +23,18 @@ module Language.PureScript.TypeChecker.Entailment (
import Data.Function (on)
import Data.List
import Data.Maybe (maybeToList)
+#if __GLASGOW_HASKELL__ < 710
import Data.Foldable (foldMap)
+#endif
import qualified Data.Map as M
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Arrow (Arrow(..))
import Control.Monad.State
import Control.Monad.Error.Class (MonadError(..))
+import Control.Monad.Writer.Class (tell)
import Language.PureScript.AST
import Language.PureScript.Errors
@@ -41,13 +47,11 @@ import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Types
import qualified Language.PureScript.Constants as C
-newtype Work = Work Integer deriving (Show, Eq, Ord, Num)
-
-- |
-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
-- return a type class dictionary reference.
--
-entails :: Environment -> ModuleName -> M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) -> Constraint -> Bool -> Check Expr
+entails :: Environment -> ModuleName -> M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) -> Constraint -> Check Expr
entails env moduleName context = solve
where
forClassName :: Qualified ProperName -> [TypeClassDictionaryInScope]
@@ -56,56 +60,61 @@ entails env moduleName context = solve
findDicts :: Qualified ProperName -> Maybe ModuleName -> [TypeClassDictionaryInScope]
findDicts cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup context
- solve :: Constraint -> Bool -> Check Expr
- solve (className, tys) trySuperclasses = do
- let dicts = flip evalStateT (Work 0) $ go trySuperclasses className tys
- checkOverlaps dicts
+ solve :: Constraint -> Check Expr
+ solve (className, tys) = do
+ dict <- go 0 className tys
+ return $ dictionaryValueToValue dict
where
- go :: Bool -> Qualified ProperName -> [Type] -> StateT Work [] DictionaryValue
- go trySuperclasses' className' tys' = do
- workDone <- get
- guard $ workDone < 1000
- modify (1 +)
- directInstances <|> superclassInstances
+ go :: Int -> Qualified ProperName -> [Type] -> Check DictionaryValue
+ go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'
+ go work className' tys' = do
+ let instances = do
+ tcd <- forClassName className'
+ -- Make sure the type unifies with the type in the type instance definition
+ subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
+ return (subst, tcd)
+ (subst, tcd) <- unique instances
+ -- Solve any necessary subgoals
+ args <- solveSubgoals subst (tcdDependencies tcd)
+ return $ foldr (\(superclassName, index) dict -> SubclassDictionaryValue dict superclassName index)
+ (mkDictionary (canonicalizeDictionary tcd) args)
+ (tcdPath tcd)
where
- directInstances :: StateT Work [] DictionaryValue
- directInstances = do
- tcd <- lift $ forClassName className'
- -- Make sure the type unifies with the type in the type instance definition
- subst <- lift . maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
- -- Solve any necessary subgoals
- args <- solveSubgoals subst (tcdDependencies tcd)
- return $ mkDictionary (canonicalizeDictionary tcd) args
+
+ unique :: [(a, TypeClassDictionaryInScope)] -> Check (a, TypeClassDictionaryInScope)
+ unique [] = throwError . errorMessage $ NoInstanceFound className' tys'
+ unique [a] = return a
+ unique tcds | pairwise overlapping (map snd tcds) = do
+ tell . errorMessage $ OverlappingInstances className' tys' (map (tcdName . snd) tcds)
+ return (head tcds)
+ | otherwise = return (minimumBy (compare `on` length . tcdPath . snd) tcds)
- superclassInstances :: StateT Work [] DictionaryValue
- superclassInstances = do
- guard trySuperclasses'
- (subclassName, (args, _, implies)) <- lift $ M.toList (typeClasses env)
- -- Try each superclass
- (index, (superclass, suTyArgs)) <- lift $ zip [0..] implies
- -- Make sure the type class name matches the superclass name
- guard $ className' == superclass
- -- Make sure the types unify with the types in the superclass implication
- subst <- lift . maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs
- -- Finally, satisfy the subclass constraint
- args' <- lift . maybeToList $ mapM ((`lookup` subst) . fst) args
- suDict <- go True subclassName args'
- return $ SubclassDictionaryValue suDict superclass index
+ -- |
+ -- Check if two dictionaries are overlapping
+ --
+ -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have
+ -- been caught when constructing superclass dictionaries.
+ overlapping :: TypeClassDictionaryInScope -> TypeClassDictionaryInScope -> Bool
+ overlapping TypeClassDictionaryInScope{ tcdPath = _ : _ } _ = False
+ overlapping _ TypeClassDictionaryInScope{ tcdPath = _ : _ } = False
+ overlapping TypeClassDictionaryInScope{ tcdDependencies = Nothing } _ = False
+ overlapping _ TypeClassDictionaryInScope{ tcdDependencies = Nothing } = False
+ overlapping tcd1 tcd2 = tcdName tcd1 /= tcdName tcd2
- -- Create dictionaries for subgoals which still need to be solved by calling go recursively
- -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
- -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
- solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> StateT Work [] (Maybe [DictionaryValue])
- solveSubgoals _ Nothing = return Nothing
- solveSubgoals subst (Just subgoals) = do
- dict <- mapM (uncurry (go True) . second (map (replaceAllTypeVars subst))) subgoals
- return $ Just dict
+ -- Create dictionaries for subgoals which still need to be solved by calling go recursively
+ -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
+ -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
+ solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> Check (Maybe [DictionaryValue])
+ solveSubgoals _ Nothing = return Nothing
+ solveSubgoals subst (Just subgoals) = do
+ dict <- mapM (uncurry (go (work + 1)) . second (map (replaceAllTypeVars subst))) subgoals
+ return $ Just dict
- -- Make a dictionary from subgoal dictionaries by applying the correct function
- mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue
- mkDictionary fnName Nothing = LocalDictionaryValue fnName
- mkDictionary fnName (Just []) = GlobalDictionaryValue fnName
- mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts
+ -- Make a dictionary from subgoal dictionaries by applying the correct function
+ mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue
+ mkDictionary fnName Nothing = LocalDictionaryValue fnName
+ mkDictionary fnName (Just []) = GlobalDictionaryValue fnName
+ mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts
-- Turn a DictionaryValue into a Expr
dictionaryValueToValue :: DictionaryValue -> Expr
@@ -122,46 +131,7 @@ entails env moduleName context = solve
let grps = groupBy ((==) `on` fst) subst
guard (all (pairwise (unifiesWith env) . map snd) grps)
return $ map head grps
- -- |
- -- Check for overlapping instances
- --
- checkOverlaps :: [DictionaryValue] -> Check Expr
- checkOverlaps dicts =
- case [ (d1, d2) | d1 <- dicts, d2 <- dicts, d1 `overlapping` d2 ] of
- ds@(_ : _) -> throwError . errorMessage $ OverlappingInstances className tys $ nub (map fst ds)
- _ -> case chooseSimplestDictionaries dicts of
- [] -> throwError . errorMessage $ NoInstanceFound className tys
- d : _ -> return $ dictionaryValueToValue d
- -- Choose the simplest DictionaryValues from a list of candidates
- -- The reason for this function is as follows:
- -- When considering overlapping instances, we don't want to consider the same dictionary
- -- to be an overlap of itself when obtained as a superclass of another class.
- -- Observing that we probably don't want to select a superclass instance when an instance
- -- is available directly, and that there is no way for a superclass instance to actually
- -- introduce an overlap that wouldn't have been there already, we simply remove dictionaries
- -- obtained as superclass instances if there are simpler instances available.
- chooseSimplestDictionaries :: [DictionaryValue] -> [DictionaryValue]
- chooseSimplestDictionaries ds = case filter isSimpleDictionaryValue ds of
- [] -> ds
- simple -> simple
- isSimpleDictionaryValue SubclassDictionaryValue{} = False
- isSimpleDictionaryValue (DependentDictionaryValue _ ds) = all isSimpleDictionaryValue ds
- isSimpleDictionaryValue _ = True
- -- |
- -- Check if two dictionaries are overlapping
- --
- -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have
- -- been caught when constructing superclass dictionaries.
- --
- overlapping :: DictionaryValue -> DictionaryValue -> Bool
- overlapping (LocalDictionaryValue nm1) (LocalDictionaryValue nm2) | nm1 == nm2 = False
- overlapping (GlobalDictionaryValue nm1) (GlobalDictionaryValue nm2) | nm1 == nm2 = False
- overlapping (DependentDictionaryValue nm1 ds1) (DependentDictionaryValue nm2 ds2)
- | nm1 == nm2 = or $ zipWith overlapping ds1 ds2
- overlapping SubclassDictionaryValue{} _ = False
- overlapping _ SubclassDictionaryValue{} = False
- overlapping _ _ = True
-
+
valUndefined :: Expr
valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index 5e56310..5cfe53e 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -14,7 +14,10 @@
-----------------------------------------------------------------------------
{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TupleSections #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.TypeChecker.Kinds (
kindOf,
@@ -29,7 +32,9 @@ import qualified Data.HashMap.Strict as H
import qualified Data.Map as M
import Control.Arrow (second)
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Monad
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.State
@@ -72,12 +77,12 @@ instance Unifiable Check Kind where
--
kindOf :: ModuleName -> Type -> Check Kind
kindOf _ ty = fst <$> kindOfWithScopedVars ty
-
+
-- |
-- Infer the kind of a single type, returning the kinds of any scoped type variables
--
-kindOfWithScopedVars :: Type -> Check (Kind, [(String, Kind)])
-kindOfWithScopedVars ty =
+kindOfWithScopedVars :: Type -> Check (Kind, [(String, Kind)])
+kindOfWithScopedVars ty =
rethrow (onErrorMessages (ErrorCheckingKind ty)) $
fmap tidyUp . liftUnify $ infer ty
where
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 6d84a46..62c5648 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -13,18 +13,25 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, RankNTypes,
- MultiParamTypeClasses, FlexibleContexts, GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.TypeChecker.Monad where
import Data.Maybe
import qualified Data.Map as M
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Monad.State
import Control.Monad.Unify
-import Control.Monad.Writer
+import Control.Monad.Writer.Strict
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Trans.Except
diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs
index fc9992e..f282e14 100644
--- a/src/Language/PureScript/TypeChecker/Skolems.hs
+++ b/src/Language/PureScript/TypeChecker/Skolems.hs
@@ -13,6 +13,8 @@
--
-----------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
+
module Language.PureScript.TypeChecker.Skolems (
newSkolemConstant,
introduceSkolemScope,
@@ -25,7 +27,9 @@ module Language.PureScript.TypeChecker.Skolems (
import Data.List (nub, (\\))
import Data.Monoid
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Unify
diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs
index 3ac5751..b370a29 100644
--- a/src/Language/PureScript/TypeChecker/Subsumption.hs
+++ b/src/Language/PureScript/TypeChecker/Subsumption.hs
@@ -69,7 +69,7 @@ subsumes' val ty1 (KindedType ty2 _) =
subsumes val ty1 ty2
subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do
dicts <- getTypeClassDictionaries
- subsumes' (Just $ foldl App val (map (flip (TypeClassDictionary True) dicts) constraints)) ty1 ty2
+ subsumes' (Just $ foldl App val (map (flip TypeClassDictionary dicts) constraints)) ty1 ty2
subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyObject && f2 == tyObject = do
let
(ts1, r1') = rowToList r1
diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs
index 087b131..71a2422 100644
--- a/src/Language/PureScript/TypeChecker/Synonyms.hs
+++ b/src/Language/PureScript/TypeChecker/Synonyms.hs
@@ -13,7 +13,10 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, GADTs #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.TypeChecker.Synonyms (
saturateAllTypeSynonyms,
@@ -27,7 +30,9 @@ module Language.PureScript.TypeChecker.Synonyms (
import Data.Maybe (fromMaybe)
import qualified Data.Map as M
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.State
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 87866a8..2121a97 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -13,7 +13,10 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.TypeChecker.Types (
typesOf
@@ -40,7 +43,9 @@ import Data.List
import Data.Maybe (fromMaybe)
import qualified Data.Map as M
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Monad
import Control.Monad.State
import Control.Monad.Unify
@@ -166,7 +171,7 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f'
where
g :: Expr -> Expr
g (TypedValue checkTy val t) = TypedValue checkTy val (f t)
- g (TypeClassDictionary b (nm, tys) sco) = TypeClassDictionary b (nm, map f tys) sco
+ g (TypeClassDictionary (nm, tys) sco) = TypeClassDictionary (nm, map f tys) sco
g other = other
-- |
@@ -177,9 +182,9 @@ replaceTypeClassDictionaries mn =
let (_, f, _) = everywhereOnValuesTopDownM return go return
in f
where
- go (TypeClassDictionary trySuperclasses constraint dicts) = do
+ go (TypeClassDictionary constraint dicts) = do
env <- getEnv
- entails env mn dicts constraint trySuperclasses
+ entails env mn dicts constraint
go other = return other
-- |
@@ -202,7 +207,7 @@ instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do
instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do
dicts <- getTypeClassDictionaries
(_, ty') <- instantiatePolyTypeWithUnknowns (error "Types under a constraint cannot themselves be constrained") ty
- return (foldl App val (map (flip (TypeClassDictionary True) dicts) constraints), ty')
+ return (foldl App val (map (flip TypeClassDictionary dicts) constraints), ty')
instantiatePolyTypeWithUnknowns val ty = return (val, ty)
-- |
@@ -268,7 +273,7 @@ infer' (Var var) = do
case ty of
ConstrainedType constraints ty' -> do
dicts <- getTypeClassDictionaries
- return $ TypedValue True (foldl App (Var var) (map (flip (TypeClassDictionary True) dicts) constraints)) ty'
+ return $ TypedValue True (foldl App (Var var) (map (flip TypeClassDictionary dicts) constraints)) ty'
_ -> return $ TypedValue True (Var var) ty
infer' v@(Constructor c) = do
env <- getEnv
@@ -292,7 +297,7 @@ infer' (Let ds val) = do
return $ TypedValue True (Let ds' val') valTy
infer' (SuperClassDictionary className tys) = do
dicts <- getTypeClassDictionaries
- return $ TypeClassDictionary False (className, tys) dicts
+ return $ TypeClassDictionary (className, tys) dicts
infer' (TypedValue checkType val ty) = do
Just moduleName <- checkCurrentModule <$> get
(kind, args) <- liftCheck $ kindOfWithScopedVars ty
@@ -300,7 +305,7 @@ infer' (TypedValue checkType val ty) = do
ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val
return $ TypedValue True val' ty'
-infer' (PositionedValue pos _ val) = rethrowWithPosition pos $ infer' val
+infer' (PositionedValue pos _ val) = warnAndRethrowWithPosition pos $ infer' val
infer' _ = error "Invalid argument to infer"
inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Type Check Expr) -> UnifyT Type Check ([Declaration], Expr)
@@ -329,7 +334,7 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
bindNames dict $ do
makeBindingGroupVisible
inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j
-inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = rethrowWithPosition pos $ do
+inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethrowWithPosition pos $ do
(d' : ds', val') <- inferLetBinding seen (d : ds) ret j
return (PositionedDeclaration pos com d' : ds', val')
inferLetBinding _ _ _ _ = error "Invalid argument to inferLetBinding"
@@ -401,7 +406,7 @@ inferBinder val (NamedBinder name binder) = do
m <- inferBinder val binder
return $ M.insert name val m
inferBinder val (PositionedBinder pos _ binder) =
- rethrowWithPosition pos $ inferBinder val binder
+ warnAndRethrowWithPosition pos $ inferBinder val binder
-- |
-- Check the types of the return values in a set of binders in a case statement
@@ -449,10 +454,25 @@ check' val t@(ConstrainedType constraints ty) = do
dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do
n <- liftCheck freshDictionaryName
return $ Ident $ "__dict_" ++ className ++ "_" ++ show n
- val' <- withBindingGroupVisible $ withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->
- TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular False) (map (Qualified Nothing) dictNames)
- constraints) $ check val ty
+ dicts <- join <$> liftCheck (zipWithM (newDictionaries []) (map (Qualified Nothing) dictNames) constraints)
+ val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty
return $ TypedValue True (foldr (Abs . Left) val' dictNames) t
+ where
+ -- | Add a dictionary for the constraint to the scope, and dictionaries
+ -- for all implies superclass instances.
+ newDictionaries :: [(Qualified ProperName, Integer)] -> Qualified Ident -> (Qualified ProperName, [Type]) -> Check [TypeClassDictionaryInScope]
+ newDictionaries path name (className, instanceTy) = do
+ tcs <- gets (typeClasses . checkEnv)
+ let (args, _, superclasses) = fromMaybe (error "newDictionaries: type class lookup failed") $ M.lookup className tcs
+ supDicts <- join <$> zipWithM (\(supName, supArgs) index ->
+ newDictionaries ((supName, index) : path)
+ name
+ (supName, instantiateSuperclass (map fst args) supArgs instanceTy)
+ ) superclasses [0..]
+ return (TypeClassDictionaryInScope name path className instanceTy Nothing TCDRegular : supDicts)
+
+ instantiateSuperclass :: [String] -> [Type] -> [Type] -> [Type]
+ instantiateSuperclass args supArgs tys = map (replaceAllTypeVars (zip args tys)) supArgs
check' val (SaturatedTypeSynonym name args) = do
ty <- introduceSkolemScope <=< expandTypeSynonym name $ args
check val ty
@@ -501,13 +521,9 @@ check' (SuperClassDictionary className tys) _ = do
-- TypeClassDictionary placeholder. The reason we do this is that it is necessary to have the
-- correct super instance dictionaries in scope, and these are not available when the type class
-- declaration gets desugared.
- --
- -- Note also that the first argument to TypeClassDictionary is False, meaning we _do not_ want
- -- to consider superclass instances when searching for this dictionary - doing so might lead
- -- to traversing a cycle in the instance graph.
-}
dicts <- getTypeClassDictionaries
- return $ TypeClassDictionary False (className, tys) dicts
+ return $ TypeClassDictionary (className, tys) dicts
check' (TypedValue checkType val ty1) ty2 = do
Just moduleName <- checkCurrentModule <$> get
(kind, args) <- liftCheck $ kindOfWithScopedVars ty1
@@ -570,7 +586,7 @@ check' val kt@(KindedType ty kind) = do
val' <- check' val ty
return $ TypedValue True val' kt
check' (PositionedValue pos _ val) ty =
- rethrowWithPosition pos $ check' val ty
+ warnAndRethrowWithPosition pos $ check' val ty
check' val ty = throwError . errorMessage $ ExprDoesNotHaveType val ty
containsTypeSynonyms :: Type -> Bool
@@ -648,7 +664,7 @@ checkFunctionApplication' fn (KindedType ty _) arg ret =
checkFunctionApplication fn ty arg ret
checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do
dicts <- getTypeClassDictionaries
- checkFunctionApplication' (foldl App fn (map (flip (TypeClassDictionary True) dicts) constraints)) fnTy arg ret
+ checkFunctionApplication' (foldl App fn (map (flip TypeClassDictionary dicts) constraints)) fnTy arg ret
checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} _ =
return (fnTy, App fn dict)
checkFunctionApplication' _ fnTy arg _ = throwError . errorMessage $ CannotApplyFunction fnTy arg
diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs
index 5b68246..e803dbf 100644
--- a/src/Language/PureScript/TypeChecker/Unify.hs
+++ b/src/Language/PureScript/TypeChecker/Unify.hs
@@ -14,7 +14,9 @@
-----------------------------------------------------------------------------
{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
module Language.PureScript.TypeChecker.Unify (
unifyTypes,
@@ -157,14 +159,14 @@ unifiesWith _ REmpty REmpty = True
unifiesWith e r1@(RCons _ _ _) r2@(RCons _ _ _) =
let (s1, r1') = rowToList r1
(s2, r2') = rowToList r2
-
+
int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
in all (\(t1, t2) -> unifiesWith e t1 t2) int && go sd1 r1' sd2 r2'
where
go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Bool
- go [] REmpty [] REmpty = True
+ go [] REmpty [] REmpty = True
go [] (TypeVar v1) [] (TypeVar v2) = v1 == v2
go [] (Skolem _ s1 _) [] (Skolem _ s2 _) = s1 == s2
go _ (TUnknown _) _ _ = True
diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs
index e0780dd..33435c2 100644
--- a/src/Language/PureScript/TypeClassDictionaries.hs
+++ b/src/Language/PureScript/TypeClassDictionaries.hs
@@ -26,30 +26,18 @@ import Language.PureScript.Types
--
data TypeClassDictionaryInScope
= TypeClassDictionaryInScope {
- -- |
- -- The identifier with which the dictionary can be accessed at runtime
- --
+ -- | The identifier with which the dictionary can be accessed at runtime
tcdName :: Qualified Ident
- -- |
- -- The name of the type class to which this type class instance applies
- --
+ -- | How to obtain this instance via superclass relationships
+ , tcdPath :: [(Qualified ProperName, Integer)]
+ -- | The name of the type class to which this type class instance applies
, tcdClassName :: Qualified ProperName
- -- |
- -- The types to which this type class instance applies
- --
+ -- | The types to which this type class instance applies
, tcdInstanceTypes :: [Type]
- -- |
- -- Type class dependencies which must be satisfied to construct this dictionary
- --
+ -- | Type class dependencies which must be satisfied to construct this dictionary
, tcdDependencies :: Maybe [Constraint]
- -- |
- -- The type of this dictionary
- --
+ -- | The type of this dictionary
, tcdType :: TypeClassDictionaryType
- -- |
- -- Is this instance exported by its module?
- --
- , tcdExported :: Bool
} deriving (Show, Data, Typeable)
-- |
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index 4481d4b..c9b6ef4 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -16,6 +16,7 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE CPP #-}
module Language.PureScript.Types where
@@ -26,7 +27,9 @@ import qualified Data.Aeson.TH as A
import Control.Monad.Unify
import Control.Arrow (second)
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Monad ((<=<))
import Language.PureScript.Names
diff --git a/tests/Main.hs b/tests/Main.hs
index acb9aa6..6644c8a 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -1,8 +1,7 @@
-----------------------------------------------------------------------------
--
-- Module : Main
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
+-- License : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer : Phil Freeman <paf31@cantab.net>
-- Stability : experimental
@@ -17,6 +16,7 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
-- Failing tests can specify the kind of error that should be thrown with a
-- @shouldFailWith declaration. For example:
@@ -42,18 +42,22 @@ import qualified Language.PureScript.CoreFn as CF
import Data.Char (isSpace)
import Data.Maybe (mapMaybe, fromMaybe)
import Data.List (isSuffixOf, sort, stripPrefix)
+#if __GLASGOW_HASKELL__ < 710
import Data.Traversable (traverse)
+#endif
import Data.Time.Clock (UTCTime())
import qualified Data.Map as M
import Control.Monad
import Control.Monad.IO.Class (liftIO)
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
+#endif
import Control.Arrow ((>>>))
import Control.Monad.Reader
-import Control.Monad.Writer
+import Control.Monad.Writer.Strict
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Except
import Control.Monad.Error.Class
@@ -62,10 +66,13 @@ import System.Exit
import System.Process
import System.FilePath
import System.Directory
+import qualified System.Info
import qualified System.FilePath.Glob as Glob
import Text.Parsec (ParseError)
+import TestsSetup
+
modulesDir :: FilePath
modulesDir = ".test_modules" </> "node_modules"
@@ -166,11 +173,6 @@ assertDoesNotCompile inputFiles foreigns = do
trim =
dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
-findNodeProcess :: IO (Maybe String)
-findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
- where
- names = ["nodejs", "node"]
-
main :: IO ()
main = do
fetchSupportCode
@@ -205,16 +207,6 @@ main = do
in putStrLn $ fp' ++ ": " ++ err
exitFailure
-fetchSupportCode :: IO ()
-fetchSupportCode = do
- setCurrentDirectory "tests/support"
- callProcess "npm" ["install"]
- -- Sometimes we run as a root (e.g. in simple docker containers)
- -- And we are non-interactive: https://github.com/bower/bower/issues/1162
- callProcess "node_modules/.bin/bower" ["--allow-root", "install", "--config.interactive=false"]
- callProcess "node" ["setup.js"]
- setCurrentDirectory "../.."
-
supportModules :: [String]
supportModules =
[ "Control.Monad.Eff.Class"
diff --git a/tests/common/TestsSetup.hs b/tests/common/TestsSetup.hs
new file mode 100644
index 0000000..cc853ec
--- /dev/null
+++ b/tests/common/TestsSetup.hs
@@ -0,0 +1,48 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Main
+-- License : MIT (http://opensource.org/licenses/MIT)
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE CPP #-}
+
+module TestsSetup where
+
+import Data.Maybe (fromMaybe)
+
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative
+#endif
+import Control.Monad
+
+import Control.Monad.Trans.Maybe
+
+import System.Process
+import System.Directory
+import System.Info
+
+findNodeProcess :: IO (Maybe String)
+findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
+ where
+ names = ["nodejs", "node"]
+
+fetchSupportCode :: IO ()
+fetchSupportCode = do
+ node <- fromMaybe (error "cannot find node executable") <$> findNodeProcess
+ setCurrentDirectory "tests/support"
+ if System.Info.os == "mingw32"
+ then callProcess "setup-win.cmd" []
+ else do
+ callProcess "npm" ["install"]
+ -- Sometimes we run as a root (e.g. in simple docker containers)
+ -- And we are non-interactive: https://github.com/bower/bower/issues/1162
+ callProcess "node_modules/.bin/bower" ["--allow-root", "install", "--config.interactive=false"]
+ callProcess node ["setup.js"]
+ setCurrentDirectory "../.."
diff --git a/tests/support/setup-win.cmd b/tests/support/setup-win.cmd
new file mode 100644
index 0000000..2b40898
--- /dev/null
+++ b/tests/support/setup-win.cmd
@@ -0,0 +1,3 @@
+@echo off
+call npm install
+call node_modules\.bin\bower install --config.interactive=false