diff --git a/examples/failing/438.purs b/examples/failing/438.purs --- 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 --- /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 --- /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/OverlappingInstances.purs b/examples/failing/OverlappingInstances.purs deleted file mode 100644 --- a/examples/failing/OverlappingInstances.purs +++ /dev/null @@ -1,14 +0,0 @@ --- @shouldFailWith OverlappingInstances -module OverlappingInstances where - -import Prelude - -data A = A - -instance showA1 :: Show A where - show A = "Instance 1" - -instance showA2 :: Show A where - show A = "Instance 2" - -main = Control.Monad.Eff.Console.log $ show A diff --git a/examples/failing/OverlappingInstances2.purs b/examples/failing/OverlappingInstances2.purs deleted file mode 100644 --- a/examples/failing/OverlappingInstances2.purs +++ /dev/null @@ -1,24 +0,0 @@ --- @shouldFailWith OverlappingInstances -module OverlappingInstances where - -import Prelude - -data A = A | B - -instance eqA1 :: Eq A where - eq A A = true - eq B B = true - eq _ _ = false - -instance eqA2 :: Eq A where - eq _ _ = true - -instance ordA :: Ord A where - compare A B = LT - compare B A = GT - compare _ _ = EQ - -test :: forall a. (Ord a) => a -> a -> String -test x y = show $ x == y - -main = Control.Monad.Eff.Console.log $ test A B diff --git a/examples/failing/OverlappingReExport.purs b/examples/failing/OverlappingReExport.purs new file mode 100644 --- /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/failing/Superclasses4.purs b/examples/failing/Superclasses4.purs deleted file mode 100644 --- a/examples/failing/Superclasses4.purs +++ /dev/null @@ -1,15 +0,0 @@ --- @shouldFailWith OverlappingInstances -module OverlappingInstances where - -import Prelude - -class Foo a - -instance foo1 :: Foo Number - -instance foo2 :: Foo Number - -test :: forall a. (Foo a) => a -> a -test a = a - -test1 = test 0.0 diff --git a/examples/failing/Superclasses5.purs b/examples/failing/Superclasses5.purs new file mode 100644 --- /dev/null +++ b/examples/failing/Superclasses5.purs @@ -0,0 +1,25 @@ +-- @shouldFailWith NoInstanceFound + +module Main where + +import Prelude + +class Su a where + su :: a -> a + +class (Su (Array a)) <= Cl a where + cl :: a -> a -> a + +instance suNumber :: Su Number where + su n = n + 1.0 + +instance suArray :: (Su a) => Su (Array a) where + su [x] = [su x] + +instance clNumber :: Cl Number where + cl n m = n + m + +test :: forall a. (Cl a) => a -> Array a +test x = su [cl x x] + +main = Control.Monad.Eff.Console.print $ test 10.0 diff --git a/examples/passing/ExplicitImportReExport.purs b/examples/passing/ExplicitImportReExport.purs new file mode 100644 --- /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 --- 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/passing/OverlappingInstances.purs b/examples/passing/OverlappingInstances.purs new file mode 100644 --- /dev/null +++ b/examples/passing/OverlappingInstances.purs @@ -0,0 +1,13 @@ +module Main where + +import Prelude + +data A = A + +instance showA1 :: Show A where + show A = "Instance 1" + +instance showA2 :: Show A where + show A = "Instance 2" + +main = Test.Assert.assert $ show A == "Instance 1" diff --git a/examples/passing/OverlappingInstances2.purs b/examples/passing/OverlappingInstances2.purs new file mode 100644 --- /dev/null +++ b/examples/passing/OverlappingInstances2.purs @@ -0,0 +1,23 @@ +module Main where + +import Prelude + +data A = A | B + +instance eqA1 :: Eq A where + eq A A = true + eq B B = true + eq _ _ = false + +instance eqA2 :: Eq A where + eq _ _ = true + +instance ordA :: Ord A where + compare A B = LT + compare B A = GT + compare _ _ = EQ + +test :: forall a. (Ord a) => a -> a -> String +test x y = show $ x == y + +main = Test.Assert.assert $ test A B == "false" diff --git a/examples/passing/OverlappingInstances3.purs b/examples/passing/OverlappingInstances3.purs new file mode 100644 --- /dev/null +++ b/examples/passing/OverlappingInstances3.purs @@ -0,0 +1,16 @@ +module Main where + +import Prelude + +class Foo a + +instance foo1 :: Foo Number + +instance foo2 :: Foo Number + +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 --- /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/examples/passing/Superclasses2.purs b/examples/passing/Superclasses2.purs deleted file mode 100644 --- a/examples/passing/Superclasses2.purs +++ /dev/null @@ -1,23 +0,0 @@ -module Main where - -import Prelude - -class Su a where - su :: a -> a - -class (Su (Array a)) <= Cl a where - cl :: a -> a -> a - -instance suNumber :: Su Number where - su n = n + 1.0 - -instance suArray :: (Su a) => Su (Array a) where - su [x] = [su x] - -instance clNumber :: Cl Number where - cl n m = n + m - -test :: forall a. (Cl a) => a -> Array a -test x = su [cl x x] - -main = Control.Monad.Eff.Console.print $ test 10.0 diff --git a/hierarchy/Main.hs b/hierarchy/Main.hs --- 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 -- Stability : experimental @@ -65,7 +65,7 @@ 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 --- 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 -- Stability : experimental @@ -22,8 +22,9 @@ 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 @@ 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 @@ 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 @@ 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 @@ <*> verboseErrors <*> (not <$> comments) <*> requirePath - + pscMakeOptions :: Parser PSCMakeOptions pscMakeOptions = PSCMakeOptions <$> many inputFile <*> many inputForeignFile diff --git a/psci/Completion.hs b/psci/Completion.hs --- 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 @@ 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 --- 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 -- 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.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 @@ 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 @@ 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 "") [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing -- | @@ -227,7 +230,7 @@ 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 "") [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing -- | -- Makes a volatile module to execute the current imports. @@ -237,7 +240,7 @@ let moduleName = P.ModuleName [P.ProperName "$PSCI"] in - P.Module [] moduleName (importDecl `map` imports) Nothing + P.Module (P.internalModuleSourceSpan "") [] moduleName (importDecl `map` imports) Nothing importDecl :: ImportedModule -> P.Declaration importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ @@ -308,7 +311,7 @@ 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 @@ 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 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 --- a/psci/Parser.hs +++ b/psci/Parser.hs @@ -13,6 +13,8 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} + module Parser ( parseCommand ) where @@ -22,7 +24,9 @@ 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 --- 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 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 --- 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 @@ , 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 @@ 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 @@ 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 @@ 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 --- 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 --- a/src/Control/Monad/Unify.hs +++ b/src/Control/Monad/Unify.hs @@ -28,6 +28,7 @@ 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 @@ -- 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 --- a/src/Language/PureScript.hs +++ b/src/Language/PureScript.hs @@ -28,7 +28,7 @@ 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 --- 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 -- 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 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 @@ -- 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 @@ 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 @@ -- | 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 @@ -- 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 --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -23,7 +23,7 @@ -- 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 --- 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 -- 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 @@ displaySourceSpan :: SourceSpan -> String displaySourceSpan sp = spanName sp ++ " " ++ - displayStartEndPos sp + displayStartEndPos sp instance A.ToJSON SourceSpan where toJSON SourceSpan{..} = @@ -73,3 +76,6 @@ , "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 --- 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 @@ 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 --- 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 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 --- 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 -- Stability : experimental @@ -36,28 +36,31 @@ -- 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 () @@ -69,6 +72,11 @@ exportsOp _ = False 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] diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs --- 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 @@ 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 --- 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 --- 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' :: (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 --- 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 @@ -- (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 @@ 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 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -89,6 +89,9 @@ (<<<) :: String (<<<) = "<<<" +compose :: String +compose = "compose" + -- Functions negate :: String @@ -235,8 +238,8 @@ 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 --- 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 , Gary Burgess -- Stability : experimental @@ -40,9 +40,9 @@ -- 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 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -25,7 +25,7 @@ -- 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 --- 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 @@ 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 (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.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 --- 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 @@ 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 --- 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 @@ , 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 --- 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 @@ 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 --- 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.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.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 @@ | MultipleFixities Ident | OrphanTypeDeclaration Ident | OrphanFixityDeclaration String - | RedefinedModule ModuleName + | RedefinedModule ModuleName [SourceSpan] | RedefinedIdent Ident | OverlappingNamesInLet | UnknownModule ModuleName @@ -75,6 +83,15 @@ | 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 @@ | 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 @@ | NotExhaustivePattern [[Binder]] Bool | OverlappingPattern [[Binder]] Bool | ClassOperator ProperName Ident + | MisleadingEmptyTypeImport ModuleName ProperName + | ImportHidingModule ModuleName deriving (Show) -- | @@ -164,82 +184,94 @@ -- 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 @@ 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 @@ ] 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 @@ ] 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 @@ 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 @@ 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 @@ , 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 @@ , 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 @@ ] 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,23 +756,7 @@ 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 -- prettyPrintExport :: DeclarationRef -> String @@ -789,6 +833,60 @@ , 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 . +-- +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 @@ 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 --- 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 --- 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 -- 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 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 @@ -- | -- | 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 --- 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 -- 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 @@ 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 @@ 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 @@ -- 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 @@ 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 @@ -- | -- 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 @@ 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 --- 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 -- Stability : experimental @@ -19,6 +19,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} module Language.PureScript.Make ( @@ -28,20 +29,22 @@ , 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.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 @@ -- 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 @@ -> 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 @@ 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 @@ 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 @@ -- 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 --- 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 -- Stability : experimental @@ -42,7 +42,7 @@ -- 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 --- 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 @@ 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 --- 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 -- Stability : experimental @@ -64,8 +64,6 @@ 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 @@ 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 @@ 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 @@ 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 = 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 --- 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 --- 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 @@ 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 --- 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 @@ 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 --- 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 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 @@ ] 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 $ "<>" + match (TypeClassDictionary (name, tys) _) = return $ "<>" match (SuperClassDictionary name _) = return $ "<>" match (TypedValue _ val _) = prettyPrintValue' val match (PositionedValue _ _ val) = prettyPrintValue' val diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs --- 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 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 --- 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 @@ , 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 --- 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 --- 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 @@ -- -- * 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 --- 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 -- Stability : experimental @@ -15,6 +15,7 @@ ----------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} module Language.PureScript.Sugar.BindingGroups ( createBindingGroups, @@ -26,7 +27,9 @@ 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 @@ -- 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 --- 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 -- 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 @@ 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 @@ -- 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 --- 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 -- Stability : experimental @@ -16,6 +16,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} module Language.PureScript.Sugar.DoNotation ( desugarDoModule @@ -27,7 +28,9 @@ 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 @@ -- 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 --- 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 , Gary Burgess -- 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 + 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 - -- 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 _ _) = + 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 @@ -- 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 @@ 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 @@ 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) - -- 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) + updateDataConstructorName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName) + updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) + + 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 --- /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 , Gary Burgess +-- 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 "", 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 --- /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 , Gary Burgess +-- 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 --- /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 , Gary Burgess +-- 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 --- 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 , Gary Burgess -- 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.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 --- 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 -- 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.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 @@ 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 @@ 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 @@ 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 @@ 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 --- 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 -- Stability : experimental @@ -15,6 +15,7 @@ ----------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} module Language.PureScript.Sugar.TypeClasses ( desugarTypeClasses @@ -33,7 +34,9 @@ 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 = 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 --- 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.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 @@ -- | 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ decomposeRec :: Type -> [(String, Type)] decomposeRec = sortBy (comparing fst) . go where go (RCons str typ typs) = (str, typ) : decomposeRec typs - go _ = [] + go _ = [] diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs --- 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 -- 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 @@ -- 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 --- 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 --- 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 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 @@ 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 @@ -- * 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ -- 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 --- 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 @@ 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.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 @@ 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 @@ 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 --- 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.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 @@ -- 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 --- 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 --- 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 @@ 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 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -69,7 +69,7 @@ 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 --- 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 @@ 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 --- 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.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 @@ 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 @@ 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 (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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ -- 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 @@ 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 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 --- 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 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 --- a/src/Language/PureScript/TypeClassDictionaries.hs +++ b/src/Language/PureScript/TypeClassDictionaries.hs @@ -26,30 +26,18 @@ -- 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 --- 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 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 --- 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 -- 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 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.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 @@ 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 @@ -204,16 +206,6 @@ let fp' = fromMaybe fp $ stripPrefix (failing ++ [pathSeparator]) fp 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 = diff --git a/tests/common/TestsSetup.hs b/tests/common/TestsSetup.hs new file mode 100644 --- /dev/null +++ b/tests/common/TestsSetup.hs @@ -0,0 +1,48 @@ +----------------------------------------------------------------------------- +-- +-- Module : Main +-- License : MIT (http://opensource.org/licenses/MIT) +-- +-- Maintainer : Phil Freeman +-- 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 --- /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