purescript 0.7.3.0 → 0.7.4.1

raw patch · 85 files changed

+1728/−1072 lines, 85 files

Files

examples/failing/438.purs +1/−1
examples/failing/EmptyDo.purs +6/−0
examples/failing/ImportHidingModule.purs +10/−0
examples/failing/OverlappingInstances.purs +0/−14
examples/failing/OverlappingInstances2.purs +0/−24
examples/failing/OverlappingReExport.purs +10/−0
examples/failing/Superclasses4.purs +0/−15
examples/failing/Superclasses5.purs +25/−0
examples/passing/ExplicitImportReExport.purs +16/−0
examples/passing/ModuleExportHiding.purs +0/−11
examples/passing/OverlappingInstances.purs +13/−0
examples/passing/OverlappingInstances2.purs +23/−0
examples/passing/OverlappingInstances3.purs +16/−0
examples/passing/ReExportQualified.purs +16/−0
examples/passing/Superclasses2.purs +0/−23
hierarchy/Main.hs +2/−2
psc/Main.hs +10/−8
psci/Completion.hs +7/−1
psci/PSCi.hs +13/−10
psci/Parser.hs +4/−0
psci/tests/Main.hs +9/−2
purescript.cabal +10/−4
src/Control/Monad/Supply.hs +3/−0
src/Control/Monad/Unify.hs +2/−1
src/Language/PureScript.hs +1/−1
src/Language/PureScript/AST/Declarations.hs +16/−8
src/Language/PureScript/AST/Exported.hs +1/−1
src/Language/PureScript/AST/SourcePos.hs +10/−4
src/Language/PureScript/AST/Traversals.hs +9/−1
src/Language/PureScript/Bundle.hs +3/−0
src/Language/PureScript/CodeGen/Externs.hs +24/−16
src/Language/PureScript/CodeGen/JS.hs +3/−0
src/Language/PureScript/CodeGen/JS/AST.hs +5/−0
src/Language/PureScript/CodeGen/JS/Optimizer.hs +4/−1
src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +13/−9
src/Language/PureScript/Constants.hs +5/−2
src/Language/PureScript/CoreFn/Desugar.hs +4/−4
src/Language/PureScript/Docs/Convert.hs +1/−1
src/Language/PureScript/Docs/ParseAndDesugar.hs +8/−3
src/Language/PureScript/Docs/RenderedCode/Render.hs +5/−0
src/Language/PureScript/Docs/RenderedCode/Types.hs +3/−0
src/Language/PureScript/Docs/Types.hs +4/−2
src/Language/PureScript/Errors.hs +219/−112
src/Language/PureScript/Kinds.hs +3/−0
src/Language/PureScript/Linter.hs +6/−3
src/Language/PureScript/Linter/Exhaustive.hs +16/−18
src/Language/PureScript/Make.hs +20/−15
src/Language/PureScript/ModuleDependencies.hs +3/−3
src/Language/PureScript/Names.hs +16/−1
src/Language/PureScript/Parser/Declarations.hs +20/−9
src/Language/PureScript/Parser/JS.hs +3/−0
src/Language/PureScript/Parser/Kinds.hs +4/−0
src/Language/PureScript/Pretty/JS.hs +4/−0
src/Language/PureScript/Pretty/Values.hs +5/−1
src/Language/PureScript/Publish.hs +4/−1
src/Language/PureScript/Publish/ErrorsWarnings.hs +5/−0
src/Language/PureScript/Renamer.hs +5/−1
src/Language/PureScript/Sugar.hs +6/−2
src/Language/PureScript/Sugar/BindingGroups.hs +7/−4
src/Language/PureScript/Sugar/CaseDeclarations.hs +9/−5
src/Language/PureScript/Sugar/DoNotation.hs +6/−3
src/Language/PureScript/Sugar/Names.hs +131/−496
src/Language/PureScript/Sugar/Names/Env.hs +197/−0
src/Language/PureScript/Sugar/Names/Exports.hs +236/−0
src/Language/PureScript/Sugar/Names/Imports.hs +202/−0
src/Language/PureScript/Sugar/ObjectWildcards.hs +6/−3
src/Language/PureScript/Sugar/Operators.hs +10/−7
src/Language/PureScript/Sugar/TypeClasses.hs +7/−4
src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +32/−29
src/Language/PureScript/Sugar/TypeDeclarations.hs +7/−4
src/Language/PureScript/Traversals.hs +4/−0
src/Language/PureScript/TypeChecker.hs +20/−25
src/Language/PureScript/TypeChecker/Entailment.hs +58/−88
src/Language/PureScript/TypeChecker/Kinds.hs +9/−4
src/Language/PureScript/TypeChecker/Monad.hs +10/−3
src/Language/PureScript/TypeChecker/Skolems.hs +4/−0
src/Language/PureScript/TypeChecker/Subsumption.hs +1/−1
src/Language/PureScript/TypeChecker/Synonyms.hs +6/−1
src/Language/PureScript/TypeChecker/Types.hs +36/−20
src/Language/PureScript/TypeChecker/Unify.hs +5/−3
src/Language/PureScript/TypeClassDictionaries.hs +7/−19
src/Language/PureScript/Types.hs +3/−0
tests/Main.hs +10/−18
tests/common/TestsSetup.hs +48/−0
tests/support/setup-win.cmd +3/−0

examples/failing/438.purs view

@@ -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.

+ examples/failing/EmptyDo.purs view

@@ -0,0 +1,6 @@+-- @shouldFailWith ErrorParsingModule++module Main where++main = do+

+ examples/failing/ImportHidingModule.purs view

@@ -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)

− examples/failing/OverlappingInstances.purs

@@ -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

− examples/failing/OverlappingInstances2.purs

@@ -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

+ examples/failing/OverlappingReExport.purs view

@@ -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

− examples/failing/Superclasses4.purs

@@ -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

+ examples/failing/Superclasses5.purs view

@@ -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

+ examples/passing/ExplicitImportReExport.purs view

@@ -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

− examples/passing/ModuleExportHiding.purs

@@ -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"

+ examples/passing/OverlappingInstances.purs view

@@ -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"

+ examples/passing/OverlappingInstances2.purs view

@@ -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"

+ examples/passing/OverlappingInstances3.purs view

@@ -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)

+ examples/passing/ReExportQualified.purs view

@@ -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)

− examples/passing/Superclasses2.purs

@@ -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

hierarchy/Main.hs view

@@ -2,7 +2,7 @@ -- -- Module      :  Main -- Copyright   :  (c) Hardy Jones 2014--- License     :  MIT+-- License     :  MIT (http://opensource.org/licenses/MIT) -- -- Maintainer  :  Hardy Jones <jones3.hardy@gmail.com> -- Stability   :  experimental@@ -65,7 +65,7 @@   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

psc/Main.hs view

@@ -1,8 +1,8 @@ ----------------------------------------------------------------------------- -- -- Module      :  Main--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT+-- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess+-- License     :  MIT (http://opensource.org/licenses/MIT) -- -- Maintainer  :  Phil Freeman <paf31@cantab.net> -- Stability   :  experimental@@ -22,8 +22,9 @@ 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

psci/Completion.hs view

@@ -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

psci/PSCi.hs view

@@ -1,8 +1,8 @@ ----------------------------------------------------------------------------- -- -- Module      :  PSCi--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT+-- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess+-- License     :  MIT (http://opensource.org/licenses/MIT) -- -- Maintainer  :  Phil Freeman <paf31@cantab.net> -- Stability   :  experimental@@ -17,12 +17,15 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE CPP #-}  module PSCi where  import Data.Foldable (traverse_) import Data.List (intercalate, nub, sort)+#if __GLASGOW_HASKELL__ < 710 import Data.Traversable (traverse)+#endif import Data.Tuple (swap) import Data.Version (showVersion) import qualified Data.Map as M@@ -36,7 +39,7 @@ import Control.Monad.Trans.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 "<internal>") [] 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 "<internal>") [] 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 "<internal>") [] 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

psci/Parser.hs view

@@ -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 ((<|>))

psci/tests/Main.hs view

@@ -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

purescript.cabal view

@@ -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

src/Control/Monad/Supply.hs view

@@ -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

src/Control/Monad/Unify.hs view

@@ -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

src/Language/PureScript.hs view

@@ -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

src/Language/PureScript/AST/Declarations.hs view

@@ -1,8 +1,8 @@ ----------------------------------------------------------------------------- -- -- Module      :  Language.PureScript.AST.Declarations--- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors--- License     :  MIT+-- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess+-- License     :  MIT (http://opensource.org/licenses/MIT) -- -- Maintainer  :  Phil Freeman <paf31@cantab.net> -- Stability   :  experimental@@ -12,7 +12,9 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}  module Language.PureScript.AST.Declarations where @@ -21,7 +23,9 @@  import 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.   --

src/Language/PureScript/AST/Exported.hs view

@@ -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)

src/Language/PureScript/AST/SourcePos.hs view

@@ -1,8 +1,8 @@ ----------------------------------------------------------------------------- -- -- Module      :  Language.PureScript.AST.SourcePos--- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors--- License     :  MIT+-- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess+-- License     :  MIT (http://opensource.org/licenses/MIT) -- -- Maintainer  :  Phil Freeman <paf31@cantab.net> -- Stability   :  experimental@@ -12,7 +12,10 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, RecordWildCards, OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}  module Language.PureScript.AST.SourcePos where @@ -65,7 +68,7 @@ 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)

src/Language/PureScript/AST/Traversals.hs view

@@ -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

src/Language/PureScript/Bundle.hs view

@@ -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

src/Language/PureScript/CodeGen/Externs.hs view

@@ -1,8 +1,8 @@ ----------------------------------------------------------------------------- -- -- Module      :  Language.PureScript.CodeGen.Externs--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT+-- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess+-- License     :  MIT (http://opensource.org/licenses/MIT) -- -- Maintainer  :  Phil Freeman <paf31@cantab.net> -- Stability   :  experimental@@ -36,28 +36,31 @@ -- 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]

src/Language/PureScript/CodeGen/JS.hs view

@@ -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)

src/Language/PureScript/CodeGen/JS/AST.hs view

@@ -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

src/Language/PureScript/CodeGen/JS/Optimizer.hs view

@@ -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

src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs view

@@ -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)

src/Language/PureScript/Constants.hs view

@@ -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

src/Language/PureScript/CoreFn/Desugar.hs view

@@ -1,8 +1,8 @@ ----------------------------------------------------------------------------- -- -- Module      :  Language.PureScript.CoreFn.Desugar--- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors--- License     :  MIT+-- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess+-- License     :  MIT (http://opensource.org/licenses/MIT) -- -- Maintainer  :  Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com> -- Stability   :  experimental@@ -40,9 +40,9 @@ -- 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

src/Language/PureScript/Docs/Convert.hs view

@@ -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

src/Language/PureScript/Docs/ParseAndDesugar.hs view

@@ -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'

src/Language/PureScript/Docs/RenderedCode/Render.hs view

@@ -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 ((<+>))

src/Language/PureScript/Docs/RenderedCode/Types.hs view

@@ -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(..))

src/Language/PureScript/Docs/Types.hs view

@@ -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 ((.=))

src/Language/PureScript/Errors.hs view

@@ -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 <https://github.com/aslatter/parsec/blob/v3.1.9/Text/Parsec/Error.hs#L173>.+--+prettyPrintParseErrorMessages :: String -> String -> String -> String -> String -> [Message] -> Box.Box+prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs+  | null msgs = Box.text msgUnknown+  | otherwise = Box.vcat Box.left $ map Box.text $ clean [showSysUnExpect,showUnExpect,showExpect,showMessages]++  where+  (sysUnExpect,msgs1) = span ((SysUnExpect "") ==) msgs+  (unExpect,msgs2)    = span ((UnExpect    "") ==) msgs1+  (expect,messages)   = span ((Expect      "") ==) msgs2++  showExpect      = showMany msgExpecting expect+  showUnExpect    = showMany msgUnExpected unExpect+  showSysUnExpect | not (null unExpect) ||+                    null sysUnExpect = ""+                  | null firstMsg    = msgUnExpected ++ " " ++ msgEndOfInput+                  | otherwise        = msgUnExpected ++ " " ++ firstMsg+    where+    firstMsg  = PE.messageString (head sysUnExpect)++  showMessages      = showMany "" messages++  -- helpers+  showMany pre msgs' = case clean (map PE.messageString msgs') of+                         [] -> ""+                         ms | null pre  -> commasOr ms+                            | otherwise -> pre ++ " " ++ commasOr ms++  commasOr []       = ""+  commasOr [m]      = m+  commasOr ms       = commaSep (init ms) ++ " " ++ msgOr ++ " " ++ last ms++  commaSep          = separate ", " . clean++  separate   _ []     = ""+  separate   _ [m]    = m+  separate sep (m:ms) = m ++ sep ++ separate sep ms++  clean             = nub . filter (not . null)++indent :: Box.Box -> Box.Box+indent = Box.moveRight 2++line :: String -> Box.Box+line = Box.text+ renderBox :: Box.Box -> String renderBox = unlines . map trimEnd . lines . Box.render   where@@ -808,15 +906,24 @@ 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

src/Language/PureScript/Kinds.hs view

@@ -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)  -- |

src/Language/PureScript/Linter.hs view

@@ -1,8 +1,8 @@ ----------------------------------------------------------------------------- -- -- Module      :  Language.PureScript.Linter--- Copyright   :  (c) Copyright 2015 PureScript--- License     :  MIT+-- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess+-- License     :  MIT (http://opensource.org/licenses/MIT) -- -- Maintainer  :  Phil Freeman <paf31@cantab.net> -- Stability   :  experimental@@ -15,6 +15,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}  module Language.PureScript.Linter (lint, module L) where @@ -24,7 +25,9 @@  import 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))

src/Language/PureScript/Linter/Exhaustive.hs view

@@ -1,8 +1,8 @@ ----------------------------------------------------------------------------- -- -- Module      :  Language.PureScript.Exhaustive--- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors--- License     :  MIT+-- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess+-- License     :  MIT (http://opensource.org/licenses/MIT) -- -- Maintainer  :  Phil Freeman <paf31@cantab.net> -- Stability   :  experimental@@ -13,13 +13,14 @@ -- | The algorithm analyses the clauses of a definition one by one from top -- | to bottom, where in each step it has the cases already missing (uncovered), -- | and it generates the new set of missing cases.--- +-- -----------------------------------------------------------------------------  {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-} -module Language.PureScript.Linter.Exhaustive +module Language.PureScript.Linter.Exhaustive   ( checkExhaustive   , checkExhaustiveModule   ) where@@ -207,7 +208,7 @@   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

src/Language/PureScript/Make.hs view

@@ -1,8 +1,8 @@ ----------------------------------------------------------------------------- -- -- Module      :  Make--- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors--- License     :  MIT+-- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess+-- License     :  MIT (http://opensource.org/licenses/MIT) -- -- Maintainer  :  Phil Freeman <paf31@cantab.net> -- Stability   :  experimental@@ -19,6 +19,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}  module Language.PureScript.Make   (@@ -28,20 +29,22 @@   , 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

src/Language/PureScript/ModuleDependencies.hs view

@@ -1,8 +1,8 @@ ----------------------------------------------------------------------------- -- -- Module      :  Language.PureScript.ModuleDependencies--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT+-- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess+-- License     :  MIT (http://opensource.org/licenses/MIT) -- -- Maintainer  :  Phil Freeman <paf31@cantab.net> -- Stability   :  experimental@@ -42,7 +42,7 @@ -- 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)

src/Language/PureScript/Names.hs view

@@ -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

src/Language/PureScript/Parser/Declarations.hs view

@@ -1,8 +1,8 @@ ----------------------------------------------------------------------------- -- -- Module      :  Language.PureScript.Parser.Declarations--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT+-- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess+-- License     :  MIT (http://opensource.org/licenses/MIT) -- -- Maintainer  :  Phil Freeman <paf31@cantab.net> -- Stability   :  experimental@@ -64,8 +64,6 @@   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)))

src/Language/PureScript/Parser/JS.hs view

@@ -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(..))

src/Language/PureScript/Parser/Kinds.hs view

@@ -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

src/Language/PureScript/Pretty/JS.hs view

@@ -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

src/Language/PureScript/Pretty/Values.hs view

@@ -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 $ "<<dict " ++ show name ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ">>"+  match (TypeClassDictionary (name, tys) _) = return $ "<<dict " ++ show name ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ">>"   match (SuperClassDictionary name _) = return $ "<<superclass dict " ++ show name ++ ">>"   match (TypedValue _ val _) = prettyPrintValue' val   match (PositionedValue _ _ val) = prettyPrintValue' val

src/Language/PureScript/Publish.hs view

@@ -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)

src/Language/PureScript/Publish/ErrorsWarnings.hs view

@@ -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

src/Language/PureScript/Renamer.hs view

@@ -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)

src/Language/PureScript/Sugar.hs view

@@ -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

src/Language/PureScript/Sugar/BindingGroups.hs view

@@ -1,8 +1,8 @@ ----------------------------------------------------------------------------- -- -- Module      :  Language.PureScript.BindingGroups--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT+-- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess+-- License     :  MIT (http://opensource.org/licenses/MIT) -- -- Maintainer  :  Phil Freeman <paf31@cantab.net> -- Stability   :  experimental@@ -15,6 +15,7 @@ -----------------------------------------------------------------------------  {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}  module Language.PureScript.Sugar.BindingGroups (     createBindingGroups,@@ -26,7 +27,9 @@ 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

src/Language/PureScript/Sugar/CaseDeclarations.hs view

@@ -1,8 +1,8 @@ ----------------------------------------------------------------------------- -- -- Module      :  Language.PureScript.CaseDeclarations--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT+-- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess+-- License     :  MIT (http://opensource.org/licenses/MIT) -- -- Maintainer  :  Phil Freeman <paf31@cantab.net> -- Stability   :  experimental@@ -14,7 +14,9 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}  module Language.PureScript.Sugar.CaseDeclarations (     desugarCases,@@ -24,7 +26,9 @@ 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

src/Language/PureScript/Sugar/DoNotation.hs view

@@ -1,8 +1,8 @@ ----------------------------------------------------------------------------- -- -- Module      :  Language.PureScript.Sugar.DoNotation--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT+-- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess+-- License     :  MIT (http://opensource.org/licenses/MIT) -- -- Maintainer  :  Phil Freeman <paf31@cantab.net> -- Stability   :  experimental@@ -16,6 +16,7 @@  {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}  module Language.PureScript.Sugar.DoNotation (     desugarDoModule@@ -27,7 +28,9 @@  import 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)

src/Language/PureScript/Sugar/Names.hs view

@@ -1,8 +1,7 @@ ----------------------------------------------------------------------------- -- -- Module      :  Language.PureScript.Sugar.Names--- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors--- License     :  MIT+-- License     :  MIT (http://opensource.org/licenses/MIT) -- -- Maintainer  :  Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com> -- Stability   :  experimental@@ -12,250 +11,90 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE PatternGuards #-} -module Language.PureScript.Sugar.Names (-  desugarImports-) where+module Language.PureScript.Sugar.Names (desugarImports) where -import Data.List (find, nub, (\\))-import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe)+import Data.List (find, nub)+import Data.Maybe (fromMaybe, mapMaybe) +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative (Applicative(..), (<$>), (<*>))+#endif import Control.Monad import Control.Monad.Error.Class (MonadError(..))+import Control.Monad.Writer (MonadWriter(..))  import qualified Data.Map as M  import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Types-import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Traversals--import qualified Language.PureScript.Constants as C---- |--- The global export environment - every declaration exported from every module.----type ExportEnvironment = M.Map ModuleName Exports---- |--- The exported declarations from a module.----data Exports = Exports-  {-  -- |-  -- The types exported from each module-  ---    exportedTypes :: [(ProperName, [ProperName])]-  -- |-  -- The classes exported from each module-  ---  , exportedTypeClasses :: [ProperName]-  -- |-  -- The values exported from each module-  ---  , exportedValues :: [Ident]-  -- |-  -- The modules exported from each module-  ---  , exportedModules :: [ModuleName]-  } deriving (Show)---- |--- An imported environment for a particular module. This also contains the module's own members.----data ImportEnvironment = ImportEnvironment-  {-  -- |-  -- Local names for types within a module mapped to to their qualified names-  ---    importedTypes :: M.Map (Qualified ProperName) (Qualified ProperName)-  -- |-  -- Local names for data constructors within a module mapped to to their qualified names-  ---  , importedDataConstructors :: M.Map (Qualified ProperName) (Qualified ProperName)-  -- |-  -- Local names for classes within a module mapped to to their qualified names-  ---  , importedTypeClasses :: M.Map (Qualified ProperName) (Qualified ProperName)-  -- |-  -- Local names for values within a module mapped to to their qualified names-  ---  , importedValues :: M.Map (Qualified Ident) (Qualified Ident)-  } deriving (Show)---- |--- Updates the exports for a module from the global environment. If the module was not previously--- present in the global environment, it is created.----updateExportedModule :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> (Exports -> m Exports) -> m ExportEnvironment-updateExportedModule env mn update = do-  let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env-  exports' <- update exports-  return $ M.insert mn exports' env---- |--- Adds an empty module to an ExportEnvironment.----addEmptyModule :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> m ExportEnvironment-addEmptyModule env name =-  if name `M.member` env-    then throwError . errorMessage $ RedefinedModule name-    else return $ M.insert name (Exports [] [] [] []) env---- |--- Adds a type belonging to a module to the export environment.----addType :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> m ExportEnvironment-addType env mn name dctors = updateExportedModule env mn $ \m -> do-  let exTypes = exportedTypes m-  let exDctors = snd `concatMap` exTypes-  let exClasses = exportedTypeClasses m-  when (any ((== name) . fst) exTypes) $ throwConflictError ConflictingTypeDecls name-  when (name `elem` exClasses) $ throwConflictError TypeConflictsWithClass name-  forM_ dctors $ \dctor -> do-    when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor-    when (dctor `elem` exClasses) $ throwConflictError CtorConflictsWithClass dctor-  return $ m { exportedTypes = (name, dctors) : exTypes }---- |--- Adds a class to the export environment.----addTypeClass :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> ProperName -> m ExportEnvironment-addTypeClass env mn name = updateExportedModule env mn $ \m -> do-  let exTypes = exportedTypes m-  let exDctors = snd `concatMap` exTypes-  when (any ((== name) . fst) exTypes) $ throwConflictError ClassConflictsWithType name-  when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name-  classes <- addExport DuplicateClassExport (exportedTypeClasses m) name-  return $ m { exportedTypeClasses = classes }---- |--- Adds a class to the export environment.----addValue :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> Ident -> m ExportEnvironment-addValue env mn name = updateExportedModule env mn $ \m -> do-  values <- addExport DuplicateValueExport (exportedValues m) name-  return $ m { exportedValues = values }---- |--- Adds an entry to a list of exports unless it is already present, in which case an error is--- returned.----addExport :: (Applicative m, MonadError MultipleErrors m, Eq a, Show a) => (a -> SimpleErrorMessage) -> [a] -> a -> m [a]-addExport what exports name =-  if name `elem` exports-  then throwConflictError what name-  else return $ name : exports+import Language.PureScript.Sugar.Names.Env+import Language.PureScript.Sugar.Names.Imports+import Language.PureScript.Sugar.Names.Exports  -- |--- Replaces all local names with qualified names within a set of modules.+-- Replaces all local names with qualified names within a list of modules. The+-- modules should be topologically sorted beforehand. ---desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]+desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module] desugarImports modules = do-  unfilteredExports <- findExports modules-  exports <- foldM filterModuleExports unfilteredExports modules-  let modules' = moduleReexports <$> modules-  mapM (renameInModule' unfilteredExports exports) modules'+  env <- foldM updateEnv initEnv modules+  mapM (renameInModule' env) modules   where-  moduleReexports :: Module -> Module-  moduleReexports (Module coms mn decls exps) =-    let importedMods = catMaybes findImports'-    in (Module coms mn (decls ++ (concatMap reexports importedMods)) exps)-    where-    imports :: [Declaration]-    imports = filter isImportDecl decls-    findImports' :: [Maybe (Declaration, Module)]-    findImports' = go <$> modules-      where-      go :: Module -> Maybe (Declaration, Module)-      go m@(Module _ mn' _ (Just exps'))-        | any isModExport exps', Just d <- find ((== mn') . importedModName) imports = Just (d, m)-        where-        importedModName :: Declaration -> ModuleName-        importedModName (ImportDeclaration imn _ _) = imn-        importedModName (PositionedDeclaration _ _ d) = importedModName d-        importedModName _ = error "Not an import decl"-      go _ = Nothing-    reexports :: (Declaration, Module) -> [Declaration]-    reexports (ImportDeclaration _ (Hiding refs) _, (Module coms' mn' ds' (Just exps'))) =-      case nonHiddenRefs of-        [] -> []-        _ -> reexports (ImportDeclaration mn' Implicit Nothing, Module coms' mn' ds' (Just nonHiddenRefs))-      where-      nonHiddenRefs :: [DeclarationRef]-      nonHiddenRefs = filter isModExport exps' \\ filter isModExport refs-    reexports (ImportDeclaration _ ty qual, Module _ _ _ (Just exps')) =-      let ty' = case ty of-                  Explicit _ -> Explicit []-                  _ -> ty-      in (\m -> ImportDeclaration m ty' qual) <$> (catMaybes $ go <$> exps')-      where-      go :: DeclarationRef -> Maybe ModuleName-      go (ModuleRef mn') = Just mn'-      go _ = Nothing-    reexports (PositionedDeclaration _ _ d, m@(Module _ _ _ (Just _))) = reexports (d, m)-    reexports _ = []--  isModExport :: DeclarationRef -> Bool-  isModExport (ModuleRef _) = True-  isModExport _ = False--  -- Filters the exports for a module in the global exports environment so that only explicitly-  -- exported members remain. If the module does not explicitly export anything, everything is-  -- exported.-  filterModuleExports :: ExportEnvironment -> Module -> m ExportEnvironment-  filterModuleExports env (Module _ mn _ (Just exps))-    | any isSelfModuleExport exps, Just exps' <- M.lookup mn env =-        let moduleNames = filter (/= mn) $ (\(ModuleRef mn') -> mn') <$> filter isModExport exps-        in return $ M.insert mn (exps' {exportedModules = moduleNames}) env-    where-    isSelfModuleExport :: DeclarationRef -> Bool-    isSelfModuleExport (ModuleRef mn') | mn' == mn = True-    isSelfModuleExport (PositionedDeclarationRef _ _ ref) = isSelfModuleExport ref-    isSelfModuleExport _ = False-  filterModuleExports env (Module _ mn _ (Just exps)) = filterExports mn exps env-  filterModuleExports env _ = return env+  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

+ src/Language/PureScript/Sugar/Names/Env.hs view

@@ -0,0 +1,197 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Sugar.Names.Env+-- License     :  MIT (http://opensource.org/licenses/MIT)+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleContexts #-}+--{-# LANGUAGE ScopedTypeVariables #-}+--{-# LANGUAGE PatternGuards #-}+--{-# LANGUAGE RankNTypes #-}+--{-# LANGUAGE TupleSections #-}++module Language.PureScript.Sugar.Names.Env+  ( Imports(..)+  , nullImports+  , Exports(..)+  , nullExports+  , Env+  , initEnv+  , envModuleSourceSpan+  , envModuleImports+  , envModuleExports+  , exportType+  , exportTypeClass+  , exportValue+  ) where++import Control.Monad+import Control.Monad.Error.Class (MonadError(..))++import qualified Data.Map as M++import Language.PureScript.AST+import Language.PureScript.Names+import Language.PureScript.Environment+import Language.PureScript.Errors++-- |+-- The imported declarations for a module, including the module's own members.+--+data Imports = Imports+  {+  -- |+  -- Local names for types within a module mapped to to their qualified names+  --+    importedTypes :: M.Map (Qualified ProperName) (Qualified ProperName, ModuleName)+  -- |+  -- Local names for data constructors within a module mapped to to their qualified names+  --+  , importedDataConstructors :: M.Map (Qualified ProperName) (Qualified ProperName, ModuleName)+  -- |+  -- Local names for classes within a module mapped to to their qualified names+  --+  , importedTypeClasses :: M.Map (Qualified ProperName) (Qualified ProperName, ModuleName)+  -- |+  -- Local names for values within a module mapped to to their qualified names+  --+  , importedValues :: M.Map (Qualified Ident) (Qualified Ident, ModuleName)+  -- |+  -- The list of modules that have been imported into the current scope.+  --+  , importedModules :: [ModuleName]+  } deriving (Show)++-- |+-- An empty 'Imports' value.+--+nullImports :: Imports+nullImports = Imports M.empty M.empty M.empty M.empty []++-- |+-- The exported declarations from a module.+--+data Exports = Exports+  {+  -- |+  -- The types exported from each module along with the module they originally+  -- came from.+  --+    exportedTypes :: [((ProperName, [ProperName]), ModuleName)]+  -- |+  -- The classes exported from each module along with the module they originally+  -- came from.+  --+  , exportedTypeClasses :: [(ProperName, ModuleName)]+  -- |+  -- The values exported from each module along with the module they originally+  -- came from.+  --+  , exportedValues :: [(Ident, ModuleName)]+  } deriving (Show)++-- |+-- An empty 'Exports' value.+--+nullExports :: Exports+nullExports = Exports [] [] []++-- |+-- The imports and exports for a collection of modules. The 'SourceSpan' is used+-- to store the source location of the module with a given name, used to provide+-- useful information when there is a duplicate module definition.+--+type Env = M.Map ModuleName (SourceSpan, Imports, Exports)++-- |+-- Extracts the 'SourceSpan' from an 'Env' value.+--+envModuleSourceSpan :: (SourceSpan, a, b) -> SourceSpan+envModuleSourceSpan (ss, _, _) = ss++-- |+-- Extracts the 'Imports' from an 'Env' value.+--+envModuleImports :: (a, Imports, b) -> Imports+envModuleImports (_, imps, _) = imps++-- |+-- Extracts the 'Exports' from an 'Env' value.+--+envModuleExports :: (a, b, Exports) -> Exports+envModuleExports (_, _, exps) = exps++-- |+-- The exported types from the @Prim@ module+--+primExports :: Exports+primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] []+  where+  mkTypeEntry (Qualified _ name) = ((name, []), ModuleName [ProperName "Prim"])++-- |+-- The initial global import/export environment containing the @Prim@ module.+--+initEnv :: Env+initEnv = M.singleton+  (ModuleName [ProperName "Prim"])+  (internalModuleSourceSpan "<Prim>", nullImports, primExports)++-- |+-- Safely adds a type and its data constructors to some exports, returning an+-- error if a conflict occurs.+--+exportType :: (MonadError MultipleErrors m) => Exports -> ProperName -> [ProperName] -> ModuleName -> m Exports+exportType exps name dctors mn = do+  let exTypes = exportedTypes exps+  let exDctors = (snd . fst) `concatMap` exTypes+  let exClasses = exportedTypeClasses exps+  when (any (\((name', _), _) -> name == name') exTypes) $ throwConflictError ConflictingTypeDecls name+  when (any ((== name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name+  forM_ dctors $ \dctor -> do+    when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor+    when (any ((== dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor+  return $ exps { exportedTypes = ((name, dctors), mn) : exTypes }++-- |+-- Safely adds a class to some exports, returning an error if a conflict occurs.+--+exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName -> ModuleName -> m Exports+exportTypeClass exps name mn = do+  let exTypes = exportedTypes exps+  let exDctors = (snd . fst) `concatMap` exTypes+  when (any (\((name', _), _) -> name == name') exTypes) $ throwConflictError ClassConflictsWithType name+  when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name+  classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps)+  return $ exps { exportedTypeClasses = classes }++-- |+-- Safely adds a value to some exports, returning an error if a conflict occurs.+--+exportValue :: (MonadError MultipleErrors m) => Exports -> Ident -> ModuleName -> m Exports+exportValue exps name mn = do+  values <- addExport DuplicateValueExport name mn (exportedValues exps)+  return $ exps { exportedValues = values }++-- |+-- Adds an entry to a list of exports unless it is already present, in which case an error is+-- returned.+--+addExport :: (MonadError MultipleErrors m, Eq a, Show a) => (a -> SimpleErrorMessage) -> a -> ModuleName -> [(a, ModuleName)] -> m [(a, ModuleName)]+addExport what name mn exports =+  if any ((== name) . fst) exports+  then throwConflictError what name+  else return $ (name, mn) : exports++-- |+-- Raises an error for when there is more than one definition for something.+--+throwConflictError :: (MonadError MultipleErrors m, Show a) => (a -> SimpleErrorMessage) -> a -> m b+throwConflictError conflict = throwError . errorMessage . conflict

+ src/Language/PureScript/Sugar/Names/Exports.hs view

@@ -0,0 +1,236 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Sugar.Names.Exports+-- License     :  MIT (http://opensource.org/licenses/MIT)+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++module Language.PureScript.Sugar.Names.Exports+  ( findExportable+  , resolveExports+  ) where++import Data.List (find, intersect)+import Data.Maybe (fromMaybe, mapMaybe)++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative (Applicative(..), (<$>))+#endif+import Control.Monad+import Control.Monad.Error.Class (MonadError(..))++import qualified Data.Map as M++import Language.PureScript.AST+import Language.PureScript.Names+import Language.PureScript.Errors+import Language.PureScript.Sugar.Names.Env++-- |+-- Finds all exportable members of a module, disregarding any explicit exports.+--+findExportable :: forall m. (Applicative m, MonadError MultipleErrors m) => Module -> m Exports+findExportable (Module _ _ mn ds _) =+  rethrow (onErrorMessages (ErrorInModule mn)) $ foldM updateExports nullExports ds+  where+  updateExports :: Exports -> Declaration -> m Exports+  updateExports exps (TypeClassDeclaration tcn _ _ ds') = do+    exps' <- exportTypeClass exps tcn mn+    foldM go exps' ds'+    where+    go exps'' (TypeDeclaration name _) = exportValue exps'' name mn+    go exps'' (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go exps'' d+    go _ _ = error "Invalid declaration in TypeClassDeclaration"+  updateExports exps (DataDeclaration _ tn _ dcs) = exportType exps tn (map fst dcs) mn+  updateExports exps (TypeSynonymDeclaration tn _ _) = exportType exps tn [] mn+  updateExports exps (ExternDataDeclaration tn _) = exportType exps tn [] mn+  updateExports exps (ValueDeclaration name _ _ _) = exportValue exps name mn+  updateExports exps (ExternDeclaration name _) = exportValue exps name mn+  updateExports exps (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ updateExports exps d+  updateExports exps _ = return exps++-- |+-- Resolves the exports for a module, filtering out members that have not been+-- exported and elaborating re-exports of other modules.+--+resolveExports :: forall m. (Applicative m, MonadError MultipleErrors m) => Env -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports+resolveExports env mn imps exps refs =+  rethrow (onErrorMessages (ErrorInModule mn)) $ do+    filtered <- filterModule mn exps refs+    foldM elaborateModuleExports filtered refs++  where++  -- Takes the current module's imports, the accumulated list of exports, and a+  -- `DeclarationRef` for an explicit export. When the ref refers to another+  -- module, export anything from the imports that matches for that module.+  elaborateModuleExports :: Exports -> DeclarationRef -> m Exports+  elaborateModuleExports result (PositionedDeclarationRef pos _ r) =+    rethrowWithPosition pos $ elaborateModuleExports result r+  elaborateModuleExports result (ModuleRef name) | name == mn = do+    let types' = exportedTypes result ++ exportedTypes exps+    let classes' = exportedTypeClasses result ++ exportedTypeClasses exps+    let values' = exportedValues result ++ exportedValues exps+    return result { exportedTypes = types'+                  , exportedTypeClasses = classes'+                  , exportedValues = values' }+  elaborateModuleExports result (ModuleRef name) = do+    let isPseudo = isPseudoModule name+    when (not isPseudo && not (isImportedModule name)) $+      throwError . errorMessage . UnknownExportModule $ name+    let reTypes = extract isPseudo name (importedTypes imps)+    let reDctors = extract isPseudo name (importedDataConstructors imps)+    let reClasses = extract isPseudo name (importedTypeClasses imps)+    let reValues = extract isPseudo name (importedValues imps)+    result' <- foldM (\exps' ((tctor, dctors), mn') -> exportType exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors)+    result'' <- foldM (uncurry . exportTypeClass) result' (map resolveClass reClasses)+    foldM (uncurry . exportValue) result'' (map resolveValue reValues)+  elaborateModuleExports result _ = return result++  -- Extracts a list of values for a module based on a lookup table. If the+  -- boolean is true the values are filtered by the qualification of the+  extract :: Bool -> ModuleName -> M.Map (Qualified a) (Qualified a, ModuleName) -> [Qualified a]+  extract True name = map fst . M.elems . M.filterWithKey (\k _ -> eqQual name k)+  extract False name = map fst . M.elems . M.filter (eqQual name . fst)++  -- Check whether a module name refers to a "pseudo module" that came into+  -- existence in an import scope due to importing one or more modules as+  -- qualified.+  isPseudoModule :: ModuleName -> Bool+  isPseudoModule = testQuals M.keys+    where+    -- Test for the presence of a `ModuleName` in a set of imports, using a+    -- function to either extract the keys or values. We test the keys to see if a+    -- value being re-exported belongs to a qualified module, and we test the+    -- values if that fails to see whether the value has been imported at all.+    testQuals :: (forall a. M.Map (Qualified a) (Qualified a, ModuleName) -> [Qualified a]) -> ModuleName -> Bool+    testQuals f mn' = any (eqQual mn') (f (importedTypes imps))+                   || any (eqQual mn') (f (importedDataConstructors imps))+                   || any (eqQual mn') (f (importedTypeClasses imps))+                   || any (eqQual mn') (f (importedValues imps))++  -- Check whether a module name refers to a module that has been imported+  -- without qualification into an import scope.+  isImportedModule :: ModuleName -> Bool+  isImportedModule = flip elem (importedModules imps)++  -- Check whether a module name matches that of a qualified value.+  eqQual :: ModuleName -> Qualified a -> Bool+  eqQual mn'' (Qualified (Just mn''') _) = mn'' == mn'''+  eqQual _ _ = False++  -- Constructs a list of types with their data constructors and the original+  -- module they were defined in from a list of type and data constructor names.+  resolveTypeExports :: [Qualified ProperName] -> [Qualified ProperName] -> [((ProperName, [ProperName]), ModuleName)]+  resolveTypeExports tctors dctors = map go tctors+    where+    go :: Qualified ProperName -> ((ProperName, [ProperName]), ModuleName)+    go (Qualified (Just mn'') name) = fromMaybe (error "Missing value in resolveTypeExports") $ do+      exps' <- envModuleExports <$> mn'' `M.lookup` env+      ((_, dctors'), mnOrig) <- find (\((name', _), _) -> name == name') (exportedTypes exps')+      let relevantDctors = mapMaybe (\(Qualified mn''' dctor) -> if mn''' == Just mnOrig then Just dctor else Nothing) dctors+      return ((name, intersect relevantDctors dctors'), mnOrig)+    go (Qualified Nothing _) = error "Unqualified value in resolveTypeExports"+++  -- Looks up an imported class and re-qualifies it with the original module it+  -- came from.+  resolveClass :: Qualified ProperName -> (ProperName, ModuleName)+  resolveClass className = splitQual $ fromMaybe (error "Missing value in resolveClass") $+    resolve exportedTypeClasses className++  -- Looks up an imported value and re-qualifies it with the original module it+  -- came from.+  resolveValue :: Qualified Ident -> (Ident, ModuleName)+  resolveValue ident = splitQual $ fromMaybe (error "Missing value in resolveValue") $+    resolve exportedValues ident++  resolve :: (Eq a) => (Exports -> [(a, ModuleName)]) -> Qualified a -> Maybe (Qualified a)+  resolve f (Qualified (Just mn'') a) = do+    exps' <- envModuleExports <$> mn'' `M.lookup` env+    mn''' <- snd <$> find ((== a) . fst) (f exps')+    return $ Qualified (Just mn''') a+  resolve _ _ = error "Unqualified value in resolve"++  -- A partial function that takes a qualified value and extracts the value and+  -- qualified module components.+  splitQual :: Qualified a -> (a, ModuleName)+  splitQual (Qualified (Just mn'') a) = (a, mn'')+  splitQual _ = error "Unqualified value in splitQual"++-- |+-- Filters the full list of exportable values, types, and classes for a module+-- based on a list of export declaration references.+--+filterModule :: forall m. (Applicative m, MonadError MultipleErrors m) => ModuleName -> Exports -> [DeclarationRef] -> m Exports+filterModule mn exps refs = do+  types <- foldM (filterTypes $ exportedTypes exps) [] refs+  values <- foldM (filterValues $ exportedValues exps) [] refs+  classes <- foldM (filterClasses $ exportedTypeClasses exps) [] refs+  return exps { exportedTypes = types , exportedTypeClasses = classes , exportedValues = values }++  where++  -- Takes a list of all the exportable types with their data constructors, the+  -- accumulated list of filtered exports, and a `DeclarationRef` for an+  -- explicit export. When the ref refers to a type in the list of exportable+  -- values, the type and specified data constructors are included in the+  -- result.+  filterTypes :: [((ProperName, [ProperName]), ModuleName)] -> [((ProperName, [ProperName]), ModuleName)] -> DeclarationRef -> m [((ProperName, [ProperName]), ModuleName)]+  filterTypes exps' result (PositionedDeclarationRef pos _ r) =+    rethrowWithPosition pos $ filterTypes exps' result r+  filterTypes exps' result (TypeRef name expDcons) =+    case (\((name', _), mn') -> name == name' && mn == mn') `find` exps' of+      Nothing -> throwError . errorMessage . UnknownExportType $ name+      Just ((_, dcons), _) -> do+        let expDcons' = fromMaybe dcons expDcons+        mapM_ (checkDcon name dcons) expDcons'+        return $ ((name, expDcons'), mn) : result+  filterTypes _ result _ = return result++  -- Ensures a data constructor is exportable for a given type. Takes a type+  -- name, a list of exportable data constructors for the type, and the name of+  -- the data constructor to check.+  checkDcon :: ProperName -> [ProperName] -> ProperName -> m ()+  checkDcon tcon exps' name =+    if name `elem` exps'+    then return ()+    else throwError . errorMessage $ UnknownExportDataConstructor tcon name++  -- Takes a list of all the exportable classes, the accumulated list of+  -- filtered exports, and a `DeclarationRef` for an explicit export. When the+  -- ref refers to a class in the list of exportable classes, the class is+  -- included in the result.+  filterClasses :: [(ProperName, ModuleName)] -> [(ProperName, ModuleName)] -> DeclarationRef -> m [(ProperName, ModuleName)]+  filterClasses exps' result (PositionedDeclarationRef pos _ r) =+    rethrowWithPosition pos $ filterClasses exps' result r+  filterClasses exps' result (TypeClassRef name) =+    if (name, mn) `elem` exps'+    then return $ (name, mn) : result+    else throwError . errorMessage . UnknownExportTypeClass $ name+  filterClasses _ result _ = return result++  -- Takes a list of all the exportable values, the accumulated list of filtered+  -- exports, and a `DeclarationRef` for an explicit export. When the ref refers+  -- to a value in the list of exportable values, the value is included in the+  -- result.+  filterValues :: [(Ident, ModuleName)] -> [(Ident, ModuleName)] -> DeclarationRef -> m [(Ident, ModuleName)]+  filterValues exps' result (PositionedDeclarationRef pos _ r) =+    rethrowWithPosition pos $ filterValues exps' result r+  filterValues exps' result (ValueRef name) =+    if (name, mn) `elem` exps'+    then return $ (name, mn) : result+    else throwError . errorMessage . UnknownExportValue $ name+  filterValues _ result _ = return result

+ src/Language/PureScript/Sugar/Names/Imports.hs view

@@ -0,0 +1,202 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Sugar.Names.Imports+-- License     :  MIT (http://opensource.org/licenses/MIT)+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++module Language.PureScript.Sugar.Names.Imports (resolveImports) where++import Data.List (find)+import Data.Maybe (fromMaybe, isNothing)++import Control.Arrow (first)+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative (Applicative(..), (<$>))+#endif+import Control.Monad+import Control.Monad.Error.Class (MonadError(..))+import Control.Monad.Writer (MonadWriter(..), censor)++import qualified Data.Map as M++import Language.PureScript.AST+import Language.PureScript.Names+import Language.PureScript.Errors+import Language.PureScript.Sugar.Names.Env++-- Finds the imports within a module, mapping the imported module name to an optional set of+-- explicitly imported declarations.+findImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Declaration] -> m (M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])+findImports = foldM (go Nothing) M.empty+  where+  go pos result (ImportDeclaration mn typ qual) = do+    checkImportRefType typ+    let imp = (pos, typ, qual)+    return $ M.insert mn (maybe [imp] (imp :) (mn `M.lookup` result)) result+  go _ result (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go (Just pos) result d+  go _ result _ = return result++  -- Ensure that classes don't appear in an `import X hiding (...)`+  checkImportRefType :: ImportDeclarationType -> m ()+  checkImportRefType (Hiding refs) = mapM_ checkImportRef refs+  checkImportRefType _ = return ()+  checkImportRef :: DeclarationRef -> m ()+  checkImportRef (ModuleRef name) = throwError . errorMessage $ ImportHidingModule name+  checkImportRef _ = return ()++-- |+-- Constructs a set of imports for a module.+--+resolveImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> Module -> m Imports+resolveImports env (Module _ _ currentModule decls _) =+  censor (onErrorMessages (ErrorInModule currentModule)) $ do+    scope <- M.insert currentModule [(Nothing, Implicit, Nothing)] <$> findImports decls+    foldM resolveImport' nullImports (M.toList scope)+  where++  resolveImport' :: Imports -> (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) -> m Imports+  resolveImport' ie (mn, imps) = foldM go ie imps+    where+    go :: Imports -> (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -> m Imports+    go ie' (pos, typ, impQual) = do+      modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env+      let ie'' = ie' { importedModules = mn : importedModules ie' }+      positioned $ resolveImport currentModule mn modExports ie'' impQual typ+      where+      positioned err = case pos of+        Nothing -> err+        Just pos' -> rethrowWithPosition pos' err++-- |+-- Extends the local environment for a module by resolving an import of another module.+--+resolveImport :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> ModuleName -> Exports -> Imports -> Maybe ModuleName -> ImportDeclarationType -> m Imports+resolveImport currentModule importModule exps imps impQual =+  resolveByType+  where++  resolveByType :: ImportDeclarationType -> m Imports+  resolveByType Implicit = importAll importExplicit+  resolveByType (Explicit explImports) = checkRefs explImports >> foldM importExplicit imps explImports+  resolveByType (Hiding hiddenImports) = checkRefs hiddenImports >> importAll (importNonHidden hiddenImports)++  -- Check that a 'DeclarationRef' refers to an importable symbol+  checkRefs :: [DeclarationRef] -> m ()+  checkRefs = mapM_ check+    where+    check (PositionedDeclarationRef pos _ r) =+      rethrowWithPosition pos $ check r+    check (ValueRef name) =+      checkImportExists UnknownImportValue (fst `map` exportedValues exps) name+    check (TypeRef name dctors) = do+      checkImportExists UnknownImportType ((fst . fst) `map` exportedTypes exps) name+      let allDctors = fst `map` allExportedDataConstructors name+      maybe (return ()) (mapM_ $ checkDctorExists name allDctors) dctors+    check (TypeClassRef name) =+      checkImportExists UnknownImportTypeClass (fst `map` exportedTypeClasses exps) name+    --check (ModuleRef name) =+    --  checkImportExists (const UnknownModule) (exportedModules exps) name+    check _ = error "Invalid argument to checkRefs"++  -- Check that an explicitly imported item exists in the module it is being imported from+  checkImportExists :: (Eq a, Show a) => (ModuleName -> a -> SimpleErrorMessage) -> [a] -> a -> m ()+  checkImportExists unknown exports item =+    when (item `notElem` exports) $ throwError . errorMessage $ unknown importModule item++  -- Ensure that an explicitly imported data constructor exists for the type it is being imported+  -- from+  checkDctorExists :: ProperName -> [ProperName] -> ProperName -> m ()+  checkDctorExists tcon = checkImportExists (flip UnknownImportDataConstructor tcon)++  importNonHidden :: [DeclarationRef] -> Imports -> DeclarationRef -> m Imports+  importNonHidden hidden m ref | isHidden ref = return m+                               | otherwise = importExplicit m ref+    where+    -- TODO: rework this to be not confusing+    isHidden :: DeclarationRef -> Bool+    isHidden ref'@(TypeRef _ _) = foldl (checkTypeRef ref') False hidden+    isHidden ref' = ref' `elem` hidden+    checkTypeRef :: DeclarationRef -> Bool -> DeclarationRef -> Bool+    checkTypeRef _ True _ = True+    checkTypeRef r acc (PositionedDeclarationRef _ _ h) = checkTypeRef r acc h+    checkTypeRef (TypeRef _ Nothing) acc (TypeRef _ (Just _)) = acc+    checkTypeRef (TypeRef name (Just dctor)) _ (TypeRef name' (Just dctor')) = name == name' && dctor == dctor'+    checkTypeRef (TypeRef name _) _ (TypeRef name' Nothing) = name == name'+    checkTypeRef (PositionedDeclarationRef _ _ r) acc hiddenRef = checkTypeRef r acc hiddenRef+    checkTypeRef _ acc _ = acc++  -- Import all symbols+  importAll :: (Imports -> DeclarationRef -> m Imports) -> m Imports+  importAll importer = do+    imp' <- foldM (\m ((name, dctors), _) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps)+    imp'' <- foldM (\m (name, _) -> importer m (ValueRef name)) imp' (exportedValues exps)+    foldM (\m (name, _) -> importer m (TypeClassRef name)) imp'' (exportedTypeClasses exps)++  -- Import something explicitly+  importExplicit :: Imports -> DeclarationRef -> m Imports+  importExplicit imp (PositionedDeclarationRef pos _ r) =+    rethrowWithPosition pos . warnWithPosition pos $ importExplicit imp r+  importExplicit imp (ValueRef name) = do+    values' <- updateImports (importedValues imp) (exportedValues exps) name+    return $ imp { importedValues = values' }+  importExplicit imp (TypeRef name dctors) = do+    types' <- updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name+    let exportedDctors :: [(ProperName, ModuleName)]+        exportedDctors = allExportedDataConstructors name+        dctorNames :: [ProperName]+        dctorNames = fst `map` exportedDctors+    maybe (return ()) (mapM_ $ checkDctorExists name dctorNames) dctors+    when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name+    dctors' <- foldM (flip updateImports exportedDctors) (importedDataConstructors imp) (fromMaybe dctorNames dctors)+    return $ imp { importedTypes = types', importedDataConstructors = dctors' }+  importExplicit imp (TypeClassRef name) = do+    typeClasses' <- updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name+    return $ imp { importedTypeClasses = typeClasses' }+  importExplicit _ _ = error "Invalid argument to importExplicit"++  -- Find all exported data constructors for a given type+  allExportedDataConstructors :: ProperName -> [(ProperName, ModuleName)]+  allExportedDataConstructors name =+    case find ((== name) . fst . fst) (exportedTypes exps) of+      Nothing -> error "Invalid state in allExportedDataConstructors"+      Just ((_, dctors), mn) -> map (, mn) dctors++  -- Add something to the Imports if it does not already exist there+  updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a, ModuleName)+                                   -> [(a, ModuleName)]+                                   -> a+                                   -> m (M.Map (Qualified a) (Qualified a, ModuleName))+  updateImports imps' exps' name = case M.lookup (Qualified impQual name) imps' of++    -- If the name is not already present add it to the list, after looking up+    -- where it was originally defined+    Nothing ->+      let mnOrig = fromMaybe (error "Invalid state in updateImports") (name `lookup` exps')+      in return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name, mnOrig) imps'++    -- If the name already is present check whether it's a duplicate import+    -- before rejecting it. For example, if module A defines X, and module B+    -- re-exports A, importing A and B in C should not result in a "conflicting+    -- import for `x`" error+    Just (Qualified (Just mn) _, mnOrig)+       | mnOrig == fromMaybe (error "Invalid state in updateImports") (name `lookup` exps') -> return imps'+       | otherwise -> throwError . errorMessage $ err+        where+        err = if currentModule `elem` [mn, importModule]+              then ConflictingImport (show name) importModule+              else ConflictingImports (show name) mn importModule++    Just (Qualified Nothing _, _) ->+      error "Invalid state in updateImports"

src/Language/PureScript/Sugar/ObjectWildcards.hs view

@@ -1,8 +1,8 @@ ----------------------------------------------------------------------------- -- -- Module      :  Language.PureScript.Sugar.ObjectWildcards--- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors--- License     :  MIT+-- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess+-- License     :  MIT (http://opensource.org/licenses/MIT) -- -- Maintainer  :  Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com> -- Stability   :  experimental@@ -14,12 +14,15 @@  {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}  module Language.PureScript.Sugar.ObjectWildcards (   desugarObjectConstructors ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative+#endif import Control.Arrow (second) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Supply.Class@@ -32,7 +35,7 @@ import Language.PureScript.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

src/Language/PureScript/Sugar/Operators.hs view

@@ -1,8 +1,8 @@ ----------------------------------------------------------------------------- -- -- Module      :  Language.PureScript.Sugar.Operators--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT+-- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess+-- License     :  MIT (http://opensource.org/licenses/MIT) -- -- Maintainer  :  Phil Freeman <paf31@cantab.net> -- Stability   :  experimental@@ -20,6 +20,7 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}  module Language.PureScript.Sugar.Operators (   rebracket,@@ -31,7 +32,9 @@ import Language.PureScript.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

src/Language/PureScript/Sugar/TypeClasses.hs view

@@ -1,8 +1,8 @@ ----------------------------------------------------------------------------- -- -- Module      :  Language.PureScript.Sugar.TypeClasses--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT+-- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess+-- License     :  MIT (http://opensource.org/licenses/MIT) -- -- Maintainer  :  Phil Freeman <paf31@cantab.net> -- Stability   :  experimental@@ -15,6 +15,7 @@ -----------------------------------------------------------------------------  {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}  module Language.PureScript.Sugar.TypeClasses   ( desugarTypeClasses@@ -33,7 +34,9 @@  import 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

src/Language/PureScript/Sugar/TypeClasses/Deriving.hs view

@@ -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 _ = []

src/Language/PureScript/Sugar/TypeDeclarations.hs view

@@ -1,8 +1,8 @@ ----------------------------------------------------------------------------- -- -- Module      :  Language.PureScript.Sugar.TypeDeclarations--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT+-- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess+-- License     :  MIT (http://opensource.org/licenses/MIT) -- -- Maintainer  :  Phil Freeman <paf31@cantab.net> -- Stability   :  experimental@@ -15,13 +15,16 @@ -----------------------------------------------------------------------------  {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}  module Language.PureScript.Sugar.TypeDeclarations (     desugarTypeDeclarations,     desugarTypeDeclarationsModule ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative+#endif import Control.Monad (forM) import Control.Monad.Error.Class (MonadError(..)) @@ -35,9 +38,9 @@ -- 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

src/Language/PureScript/Traversals.hs view

@@ -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

src/Language/PureScript/TypeChecker.hs view

@@ -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 ()

src/Language/PureScript/TypeChecker/Entailment.hs view

@@ -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))

src/Language/PureScript/TypeChecker/Kinds.hs view

@@ -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

src/Language/PureScript/TypeChecker/Monad.hs view

@@ -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

src/Language/PureScript/TypeChecker/Skolems.hs view

@@ -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

src/Language/PureScript/TypeChecker/Subsumption.hs view

@@ -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

src/Language/PureScript/TypeChecker/Synonyms.hs view

@@ -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

src/Language/PureScript/TypeChecker/Types.hs view

@@ -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

src/Language/PureScript/TypeChecker/Unify.hs view

@@ -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

src/Language/PureScript/TypeClassDictionaries.hs view

@@ -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)  -- |

src/Language/PureScript/Types.hs view

@@ -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

tests/Main.hs view

@@ -1,8 +1,7 @@ ----------------------------------------------------------------------------- -- -- Module      :  Main--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT+-- License     :  MIT (http://opensource.org/licenses/MIT) -- -- Maintainer  :  Phil Freeman <paf31@cantab.net> -- Stability   :  experimental@@ -17,6 +16,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}  -- Failing tests can specify the kind of error that should be thrown with a -- @shouldFailWith declaration. For example:@@ -42,18 +42,22 @@ import 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 =

+ tests/common/TestsSetup.hs view

@@ -0,0 +1,48 @@+-----------------------------------------------------------------------------+--+-- Module      :  Main+-- License     :  MIT (http://opensource.org/licenses/MIT)+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}++module TestsSetup where++import Data.Maybe (fromMaybe)++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif+import Control.Monad++import Control.Monad.Trans.Maybe++import System.Process+import System.Directory+import System.Info++findNodeProcess :: IO (Maybe String)+findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names+  where+  names = ["nodejs", "node"]++fetchSupportCode :: IO ()+fetchSupportCode = do+  node <- fromMaybe (error "cannot find node executable") <$> findNodeProcess+  setCurrentDirectory "tests/support"+  if System.Info.os == "mingw32"+    then callProcess "setup-win.cmd" []+    else do+      callProcess "npm" ["install"]+      -- Sometimes we run as a root (e.g. in simple docker containers)+      -- And we are non-interactive: https://github.com/bower/bower/issues/1162+      callProcess "node_modules/.bin/bower" ["--allow-root", "install", "--config.interactive=false"]+  callProcess node ["setup.js"]+  setCurrentDirectory "../.."

+ tests/support/setup-win.cmd view

@@ -0,0 +1,3 @@+@echo off+call npm install+call node_modules\.bin\bower install --config.interactive=false