c95fe8e · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Merge branch 'master' into pure11

c95fe8eAndy Arvanitis11 years ago

examples/failing/1169.pursnew file+12

compare with golang

unifiedsplit

@@ -0,0 +1,12 @@

1+-- @shouldFailWith IncorrectConstructorArity

2+module Test where

4+data Outer a = Outer a

6+data Inner a b = Inner a b

8+test1 :: forall a b. Outer (Inner a b) -> Boolean

9+test1 (Outer (Inner _)) = true

10+

11+test2 :: forall a b. Inner a b -> Boolean

12+test2 (Inner _) = true

examples/failing/1570.pursnew file+6

@@ -0,0 +1,6 @@

1+-- @shouldFailWith ExpectedType

2+module M where

4+data F a = F a

6+test = \(x :: F) -> x

examples/failing/EmptyClass.pursnew file+7

@@ -0,0 +1,7 @@

1+-- @shouldFailWith ErrorParsingModule

2+module Main where

4+class Foo x where

6+bar :: String

7+bar = "hello"

examples/failing/ExtraRecordField.purs+1−2

@@ -1,5 +1,4 @@

1−-- @shouldFailWith PropertyIsMissing

1+-- @shouldFailWith AdditionalProperty

2−-- TODO: Make this fail with a new error ExtraProperty instead.

3module ExtraRecordField where

2module ExtraRecordField where

5import Prelude ((<>))

4import Prelude ((<>))

examples/failing/MissingRecordField.purs+1−2

@@ -1,5 +1,4 @@

1−-- @shouldFailWith TypesDoNotUnify

1+-- @shouldFailWith PropertyIsMissing

2−-- TODO: Update type checker to make this fail with PropertyIsMissing instead.

3module MissingRecordField where

2module MissingRecordField where

5import Prelude ((>))

4import Prelude ((>))

examples/failing/MutRec.purs+1

@@ -1,4 +1,5 @@

1-- @shouldFailWith CycleInDeclaration

2+-- @shouldFailWith CycleInDeclaration

2module MutRec where

3module MutRec where

4import Prelude

5import Prelude

examples/passing/1570.pursnew file+6

@@ -0,0 +1,6 @@

1+module Main where

3+test :: forall a. a -> a

4+test = \(x :: a) -> x

6+main = Control.Monad.Eff.Console.log "Done"

examples/passing/NakedConstraint.purs+1−1

@@ -2,7 +2,7 @@ module Main where

3import Control.Monad.Eff.Console

5−class Partial where

5+class Partial

7data List a = Nil | Cons a (List a)

examples/passing/TypedBinders.purs+6−1

@@ -54,9 +54,14 @@ test3 n = case n of

54test4 :: Tuple Int Int -> Tuple Int Int

55test4 = (\(Tuple a b :: Tuple Int Int) -> Tuple b a)

57+type Int1 = Int

58+

59+test5 :: Int1 -> Int1

60+test5 = \(x :: Int1) -> x

61+

57main = do

62main = do

58 let t1 = test

63 let t1 = test

59 t2 = test2 id

64 t2 = test2 id

60 t3 = test3 1

65 t3 = test3 1

61 t4 = test4 (Tuple 1 0)

66 t4 = test4 (Tuple 1 0)

62− Control.Monad.Eff.Console.log "Done"

67+ Control.Monad.Eff.Console.log "Done"

psc/Main.hs+4−5

@@ -71,15 +71,14 @@ compile (PSCMakeOptions inputGlob inputForeignGlob outputDir opts usePrefix) = d

71 hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)

72 let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, fp)) ms

73 makeActions = buildMakeActions outputDir filePathMap foreigns usePrefix

74− e <- runMake opts $ P.make makeActions (map snd ms)

74+ (e, warnings') <- runMake opts $ P.make makeActions (map snd ms)

75+ when (P.nonEmpty warnings') $

76+ hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings')

75 case e of

77 case e of

76 Left errs -> do

78 Left errs -> do

77 hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)

79 hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)

78 exitFailure

80 exitFailure

79− Right (_, warnings') -> do

80− when (P.nonEmpty warnings') $

81− hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings')

82− exitSuccess

81+ Right _ -> exitSuccess

84warnFileTypeNotFound :: String -> IO ()

83warnFileTypeNotFound :: String -> IO ()

85warnFileTypeNotFound = hPutStrLn stderr . ("psc: No files found using pattern: " ++)

84warnFileTypeNotFound = hPutStrLn stderr . ("psc: No files found using pattern: " ++)

psci/PSCi.hs+5−5

@@ -71,7 +71,7 @@ supportModule :: P.Module

71supportModule =

72 case P.parseModulesFromFiles id [("", code)] of

73 Right [(_, P.Module ss cs _ ds exps)] -> P.Module ss cs supportModuleName ds exps

74− _ -> error "Support module could not be parsed"

74+ _ -> P.internalError "Support module could not be parsed"

75 where

76 code :: String

77 code = unlines

@@ -254,7 +254,7 @@ modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"

254-- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the

255-- options and ignores the warning messages.

256runMake :: P.Make a -> IO (Either P.MultipleErrors a)

257−runMake mk = fmap (fmap fst) $ P.runMake P.defaultOptions mk

257+runMake mk = fmap fst $ P.runMake P.defaultOptions mk

258

259makeIO :: (IOError -> P.ErrorMessage) -> IO a -> P.Make a

260makeIO f io = do

@@ -390,7 +390,7 @@ printModuleSignatures moduleName env =

390 findType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)

391 showType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> String

392 showType (mIdent, Just (mType, _, _)) = show mIdent ++ " :: " ++ P.prettyPrintType mType

393− showType _ = error "The impossible happened in printModuleSignatures."

393+ showType _ = P.internalError "The impossible happened in printModuleSignatures."

394

395-- |

396-- Browse a module and displays its signature (if module exists).

@@ -425,7 +425,7 @@ handleKindOf typ = do

425 case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of

426 Just (_, typ') -> do

427 let chk = P.CheckState env' 0 0 (Just mName)

428− k = fst . runWriter . runExceptT $ L.runStateT (P.unCheck (P.kindOf mName typ')) chk

428+ k = fst . runWriter . runExceptT $ L.runStateT (P.unCheck (P.kindOf typ')) chk

429 case k of

430 Left errStack -> PSCI . outputStrLn . P.prettyPrintMultipleErrors False $ errStack

431 Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind

@@ -482,7 +482,7 @@ handleCommand (KindOf typ) = handleKindOf typ

482handleCommand (BrowseModule moduleName) = handleBrowse moduleName

483handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules

484handleCommand (ShowInfo QueryImport) = handleShowImportedModules

485−handleCommand QuitPSCi = error "`handleCommand QuitPSCi` was called. This is a bug."

485+handleCommand QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug."

486

487whenFileExists :: FilePath -> (FilePath -> PSCI ()) -> PSCI ()

488whenFileExists filePath f = do

purescript.cabal+3−1

@@ -1,5 +1,5 @@

1name: purescript

2−version: 0.7.5

2+version: 0.7.5.3

3cabal-version: >=1.8

4build-type: Simple

5license: MIT

@@ -80,6 +80,7 @@ library

80 Language.PureScript.AST.Traversals

81 Language.PureScript.AST.Exported

82 Language.PureScript.Bundle

83+ Language.PureScript.Crash

83 Language.PureScript.Externs

84 Language.PureScript.Externs

84 Language.PureScript.CodeGen

85 Language.PureScript.CodeGen

85 Language.PureScript.CodeGen.JS

86 Language.PureScript.CodeGen.JS

@@ -185,6 +186,7 @@ library

185 Language.PureScript.Publish.ErrorsWarnings

186 Language.PureScript.Publish.ErrorsWarnings

186 Language.PureScript.Publish.BoxesHelpers

187 Language.PureScript.Publish.BoxesHelpers

187

188

189+ Control.Monad.Logger

188 Control.Monad.Unify

190 Control.Monad.Unify

189 Control.Monad.Supply

191 Control.Monad.Supply

190 Control.Monad.Supply.Class

192 Control.Monad.Supply.Class

src/Control/Monad/Logger.hsnew file+74

@@ -0,0 +1,74 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Control.Monad.Logger

4+-- Author : Phil Freeman

5+-- License : MIT (http://opensource.org/licenses/MIT)

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- | A replacement for WriterT IO which uses mutable references.

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE CPP #-}

16+{-# LANGUAGE FlexibleInstances #-}

17+{-# LANGUAGE MultiParamTypeClasses #-}

18+{-# LANGUAGE TypeFamilies #-}

19+

20+module Control.Monad.Logger where

21+

22+import Data.IORef

23+

24+#if __GLASGOW_HASKELL__ < 710

25+import Data.Monoid

26+import Control.Applicative

27+#endif

28+import Control.Monad (ap)

29+import Control.Monad.IO.Class

30+import Control.Monad.Writer.Class

31+import Control.Monad.Base (MonadBase(..))

32+import Control.Monad.Trans.Control (MonadBaseControl(..))

33+

34+-- | A replacement for WriterT IO which uses mutable references.

35+data Logger w a = Logger { runLogger :: IORef w -> IO a }

36+

37+-- | Run a Logger computation, starting with an empty log.

38+runLogger' :: (Monoid w) => Logger w a -> IO (a, w)

39+runLogger' l = do

40+ r <- newIORef mempty

41+ a <- runLogger l r

42+ w <- readIORef r

43+ return (a, w)

44+

45+instance Functor (Logger w) where

46+ fmap f (Logger l) = Logger $ \r -> fmap f (l r)

47+

48+instance (Monoid w) => Applicative (Logger w) where

49+ pure = Logger . const . pure

50+ (<*>) = ap

51+

52+instance (Monoid w) => Monad (Logger w) where

53+ return = pure

54+ Logger l >>= f = Logger $ \r -> l r >>= \a -> runLogger (f a) r

55+

56+instance (Monoid w) => MonadIO (Logger w) where

57+ liftIO = Logger . const

58+

59+instance (Monoid w) => MonadWriter w (Logger w) where

60+ tell w = Logger $ \r -> atomicModifyIORef' r $ \w' -> (mappend w' w, ())

61+ listen l = Logger $ \r -> do

62+ (a, w) <- liftIO (runLogger' l)

63+ atomicModifyIORef' r $ \w' -> (mappend w' w, (a, w))

64+ pass l = Logger $ \r -> do

65+ ((a, f), w) <- liftIO (runLogger' l)

66+ atomicModifyIORef' r $ \w' -> (mappend w' (f w), a)

67+

68+instance (Monoid w) => MonadBase IO (Logger w) where

69+ liftBase = liftIO

70+

71+instance (Monoid w) => MonadBaseControl IO (Logger w) where

72+ type StM (Logger w) a = a

73+ liftBaseWith f = Logger $ \r -> liftBaseWith $ \q -> f (q . flip runLogger r)

74+ restoreM = return

src/Language/PureScript.hs+1

@@ -26,6 +26,7 @@ module Language.PureScript

26import Data.Version (Version)

28import Language.PureScript.AST as P

29+import Language.PureScript.Crash as P

29import Language.PureScript.Comments as P

30import Language.PureScript.Comments as P

30import Language.PureScript.Environment as P

31import Language.PureScript.Environment as P

31import Language.PureScript.Errors as P hiding (indent)

32import Language.PureScript.Errors as P hiding (indent)

src/Language/PureScript/AST/Operators.hs+3−1

@@ -21,6 +21,8 @@ import qualified Data.Data as D

21import Data.Aeson ((.=))

22import qualified Data.Aeson as A

24+import Language.PureScript.Crash

25+

24-- |

26-- |

25-- A precedence level for an infix operator

27-- A precedence level for an infix operator

26--

28--

@@ -40,7 +42,7 @@ readAssoc :: String -> Associativity

40readAssoc "infixl" = Infixl

42readAssoc "infixl" = Infixl

41readAssoc "infixr" = Infixr

43readAssoc "infixr" = Infixr

42readAssoc "infix" = Infix

44readAssoc "infix" = Infix

43−readAssoc _ = error "readAssoc: no parse"

45+readAssoc _ = internalError "readAssoc: no parse"

45instance A.ToJSON Associativity where

47instance A.ToJSON Associativity where

46 toJSON = A.toJSON . showAssoc

48 toJSON = A.toJSON . showAssoc

src/Language/PureScript/CodeGen/JS.hs+3−2

@@ -38,6 +38,7 @@ import Control.Monad (replicateM, forM)

38import Control.Monad.Reader (MonadReader, asks)

39import Control.Monad.Supply.Class

41+import Language.PureScript.Crash

41import Language.PureScript.AST.SourcePos

42import Language.PureScript.AST.SourcePos

42import Language.PureScript.CodeGen.JS.AST as AST

43import Language.PureScript.CodeGen.JS.AST as AST

43import Language.PureScript.CodeGen.JS.Common as Common

44import Language.PureScript.CodeGen.JS.Common as Common

@@ -272,7 +273,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = do

272 go (v:vs) done' (b:bs) = do

273 go (v:vs) done' (b:bs) = do

273 done'' <- go vs done' bs

274 done'' <- go vs done' bs

274 binderToJs v done'' b

275 binderToJs v done'' b

275− go _ _ _ = error "Invalid arguments to bindersToJs"

276+ go _ _ _ = internalError "Invalid arguments to bindersToJs"

276

277

277 failedPatternError :: [String] -> JS

278 failedPatternError :: [String] -> JS

278 failedPatternError names = JSUnary JSNew $ JSApp (JSVar "Error") [JSBinary Add (JSStringLiteral errorMessage) (JSArrayLiteral $ zipWith valueError names vals)]

279 failedPatternError names = JSUnary JSNew $ JSApp (JSVar "Error") [JSBinary Add (JSStringLiteral errorMessage) (JSArrayLiteral $ zipWith valueError names vals)]

@@ -322,7 +323,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = do

322 js <- binderToJs argVar done'' binder

323 js <- binderToJs argVar done'' binder

323 return (JSVariableIntroduction argVar (Just (JSAccessor (identToJs field) (JSVar varName))) : js)

324 return (JSVariableIntroduction argVar (Just (JSAccessor (identToJs field) (JSVar varName))) : js)

324 binderToJs _ _ ConstructorBinder{} =

325 binderToJs _ _ ConstructorBinder{} =

325− error "binderToJs: Invalid ConstructorBinder in binderToJs"

326+ internalError "binderToJs: Invalid ConstructorBinder in binderToJs"

326 binderToJs varName done (NamedBinder _ ident binder) = do

327 binderToJs varName done (NamedBinder _ ident binder) = do

327 js <- binderToJs varName done binder

328 js <- binderToJs varName done binder

328 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)

329 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)

src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs+2−1

@@ -17,6 +17,7 @@ module Language.PureScript.CodeGen.JS.Optimizer.Common where

18import Data.Maybe (fromMaybe)

20+import Language.PureScript.Crash

20import Language.PureScript.CodeGen.JS.AST

21import Language.PureScript.CodeGen.JS.AST

22applyAll :: [a -> a] -> a -> a

23applyAll :: [a -> a] -> a -> a

@@ -63,7 +64,7 @@ targetVariable :: JS -> String

63targetVariable (JSVar var) = var

64targetVariable (JSVar var) = var

64targetVariable (JSAccessor _ tgt) = targetVariable tgt

65targetVariable (JSAccessor _ tgt) = targetVariable tgt

65targetVariable (JSIndexer _ tgt) = targetVariable tgt

66targetVariable (JSIndexer _ tgt) = targetVariable tgt

66−targetVariable _ = error "Invalid argument to targetVariable"

67+targetVariable _ = internalError "Invalid argument to targetVariable"

68isUpdated :: String -> JS -> Bool

69isUpdated :: String -> JS -> Bool

69isUpdated var1 = everythingOnJS (||) check

70isUpdated var1 = everythingOnJS (||) check

src/Language/PureScript/CoreFn/Desugar.hs+4−3

@@ -21,6 +21,7 @@ import qualified Data.Map as M

22import Control.Arrow (second, (***))

24+import Language.PureScript.Crash

24import Language.PureScript.AST.SourcePos

25import Language.PureScript.AST.SourcePos

25import Language.PureScript.AST.Traversals

26import Language.PureScript.AST.Traversals

26import Language.PureScript.CoreFn.Ann

27import Language.PureScript.CoreFn.Ann

@@ -41,7 +42,7 @@ import qualified Language.PureScript.AST as A

41--

42--

42moduleToCoreFn :: Environment -> A.Module -> Module Ann

43moduleToCoreFn :: Environment -> A.Module -> Module Ann

43moduleToCoreFn _ (A.Module _ _ _ _ Nothing) =

44moduleToCoreFn _ (A.Module _ _ _ _ Nothing) =

44− error "Module exports were not elaborated before moduleToCoreFn"

45+ internalError "Module exports were not elaborated before moduleToCoreFn"

45moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

46moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

46 let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls

47 let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls

47 exps' = nub $ concatMap exportToCoreFn exps

48 exps' = nub $ concatMap exportToCoreFn exps

@@ -98,7 +99,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

98 exprToCoreFn ss com ty (A.Abs (Left name) v) =

99 exprToCoreFn ss com ty (A.Abs (Left name) v) =

99 Abs (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)

100 Abs (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)

100 exprToCoreFn _ _ _ (A.Abs _ _) =

101 exprToCoreFn _ _ _ (A.Abs _ _) =

101− error "Abs with Binder argument was not desugared before exprToCoreFn mn"

102+ internalError "Abs with Binder argument was not desugared before exprToCoreFn mn"

102 exprToCoreFn ss com ty (A.App v1 v2) =

103 exprToCoreFn ss com ty (A.App v1 v2) =

103 App (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing v1) (exprToCoreFn ss [] Nothing v2)

104 App (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing v1) (exprToCoreFn ss [] Nothing v2)

104 exprToCoreFn ss com ty (A.Var ident) =

105 exprToCoreFn ss com ty (A.Var ident) =

@@ -193,7 +194,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

193 numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env

194 numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env

194 typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> (ModuleName, ProperName)

195 typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> (ModuleName, ProperName)

195 typeConstructor (Qualified (Just mn') _, (_, tyCtor, _, _)) = (mn', tyCtor)

196 typeConstructor (Qualified (Just mn') _, (_, tyCtor, _, _)) = (mn', tyCtor)

196− typeConstructor _ = error "Invalid argument to typeConstructor"

197+ typeConstructor _ = internalError "Invalid argument to typeConstructor"

197

198

198-- |

199-- |

199-- Find module names from qualified references to values. This is used to

200-- Find module names from qualified references to values. This is used to

src/Language/PureScript/Crash.hsnew file+9

@@ -0,0 +1,9 @@

1+module Language.PureScript.Crash where

3+-- | Exit with an error message and a crash report link.

4+internalError :: String -> a

5+internalError =

6+ error

7+ . ("An internal error ocurred during compilation: " ++)

8+ . (++ "\nPlease report this at https://github.com/purescript/purescript/issues")

9+ . show

src/Language/PureScript/Docs/Convert.hs+1−1

@@ -157,7 +157,7 @@ convertDeclaration (P.TypeClassDeclaration _ args implies ds) title =

157 convertClassMember (P.TypeDeclaration ident' ty) =

158 ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty)

159 convertClassMember _ =

160− error "Invalid argument to convertClassMember."

160+ P.internalError "convertDeclaration: Invalid argument to convertClassMember."

161convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title =

162 Just (Left (classNameString : typeNameStrings, AugmentChild childDecl))

163 where

src/Language/PureScript/Docs/RenderedCode/Render.hs+3−2

@@ -22,6 +22,7 @@ import Data.Maybe (fromMaybe)

22import Control.Arrow ((<+>))

23import Control.PatternArrows

25+import Language.PureScript.Crash

25import Language.PureScript.Names

26import Language.PureScript.Names

26import Language.PureScript.Types

27import Language.PureScript.Types

27import Language.PureScript.Kinds

28import Language.PureScript.Kinds

@@ -163,7 +164,7 @@ renderKind = kind . prettyPrintKind

163--

164--

164renderTypeAtom :: Type -> RenderedCode

165renderTypeAtom :: Type -> RenderedCode

165renderTypeAtom =

166renderTypeAtom =

166− fromMaybe (error "Incomplete pattern") . pattern matchTypeAtom () . preprocessType defaultRenderTypeOptions

167+ fromMaybe (internalError "Incomplete pattern") . pattern matchTypeAtom () . preprocessType defaultRenderTypeOptions

167

168

169

169-- |

170-- |

@@ -181,4 +182,4 @@ defaultRenderTypeOptions = RenderTypeOptions { prettyPrintObjects = True }

181

182

182renderTypeWithOptions :: RenderTypeOptions -> Type -> RenderedCode

183renderTypeWithOptions :: RenderTypeOptions -> Type -> RenderedCode

183renderTypeWithOptions opts =

184renderTypeWithOptions opts =

184− fromMaybe (error "Incomplete pattern") . pattern matchType () . preprocessType opts

185+ fromMaybe (internalError "Incomplete pattern") . pattern matchType () . preprocessType opts

src/Language/PureScript/Environment.hs+2−1

@@ -25,6 +25,7 @@ import qualified Data.Map as M

25import qualified Data.Text as T

26import qualified Data.Aeson as A

28+import Language.PureScript.Crash

28import Language.PureScript.Kinds

29import Language.PureScript.Kinds

29import Language.PureScript.Names

30import Language.PureScript.Names

30import Language.PureScript.TypeClassDictionaries

31import Language.PureScript.TypeClassDictionaries

@@ -252,7 +253,7 @@ primTypes = M.fromList [ (primName "Function" , (FunKind Star (FunKind Star Star

252--

253--

253lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type, [Ident])

254lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type, [Ident])

254lookupConstructor env ctor =

255lookupConstructor env ctor =

255− fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors env

256+ fromMaybe (internalError "Data constructor not found") $ ctor `M.lookup` dataConstructors env

256

257

257-- |

258-- |

258-- Checks whether a data constructor is for a newtype.

259-- Checks whether a data constructor is for a newtype.

src/Language/PureScript/Errors.hs+229−206

@@ -20,7 +20,7 @@

20module Language.PureScript.Errors where

22import Data.Either (lefts, rights)

23−import Data.List (intercalate, transpose, nub, nubBy, partition)

23+import Data.List (intercalate, transpose, nub, nubBy)

24import Data.Function (on)

25#if __GLASGOW_HASKELL__ < 710

26import Data.Foldable (fold, foldMap)

@@ -41,8 +41,8 @@ import Control.Applicative ((<$>), (<*>), Applicative, pure)

41import Control.Monad.Trans.State.Lazy

42import Control.Arrow(first)

44+import Language.PureScript.Crash

44import Language.PureScript.AST

45import Language.PureScript.AST

45−import Language.PureScript.Environment (isObject, isFunction)

46import Language.PureScript.Pretty

47import Language.PureScript.Types

48import Language.PureScript.Names

@@ -56,19 +56,16 @@ import Text.Parsec.Error (Message(..))

57-- | A type of error messages

58data SimpleErrorMessage

59− = ErrorParsingExterns P.ParseError

60− | ErrorParsingFFIModule FilePath

59+ = ErrorParsingFFIModule FilePath

61 | ErrorParsingModule P.ParseError

60 | ErrorParsingModule P.ParseError

62 | MissingFFIModule ModuleName

61 | MissingFFIModule ModuleName

63 | MultipleFFIModules ModuleName [FilePath]

62 | MultipleFFIModules ModuleName [FilePath]

64 | UnnecessaryFFIModule ModuleName FilePath

63 | UnnecessaryFFIModule ModuleName FilePath

65− | InvalidExternsFile FilePath

66 | CannotGetFileInfo FilePath

64 | CannotGetFileInfo FilePath

67 | CannotReadFile FilePath

65 | CannotReadFile FilePath

68 | CannotWriteFile FilePath

66 | CannotWriteFile FilePath

69 | InfiniteType Type

67 | InfiniteType Type

70 | InfiniteKind Kind

68 | InfiniteKind Kind

71− | CannotReorderOperators

72 | MultipleFixities Ident

69 | MultipleFixities Ident

73 | OrphanTypeDeclaration Ident

70 | OrphanTypeDeclaration Ident

74 | OrphanFixityDeclaration String

71 | OrphanFixityDeclaration String

@@ -108,11 +105,9 @@ data SimpleErrorMessage

108 | CycleInTypeSynonym (Maybe ProperName)

105 | CycleInTypeSynonym (Maybe ProperName)

109 | CycleInModules [ModuleName]

106 | CycleInModules [ModuleName]

110 | NameIsUndefined Ident

107 | NameIsUndefined Ident

111− | NameNotInScope Ident

112 | UndefinedTypeVariable ProperName

108 | UndefinedTypeVariable ProperName

113 | PartiallyAppliedSynonym (Qualified ProperName)

109 | PartiallyAppliedSynonym (Qualified ProperName)

114 | EscapedSkolem (Maybe Expr)

110 | EscapedSkolem (Maybe Expr)

115− | UnspecifiedSkolemScope

116 | TypesDoNotUnify Type Type

111 | TypesDoNotUnify Type Type

117 | KindsDoNotUnify Kind Kind

112 | KindsDoNotUnify Kind Kind

118 | ConstrainedTypeUnified Type Type

113 | ConstrainedTypeUnified Type Type

@@ -126,23 +121,23 @@ data SimpleErrorMessage

126 | ArgListLengthsDiffer Ident

121 | ArgListLengthsDiffer Ident

127 | OverlappingArgNames (Maybe Ident)

122 | OverlappingArgNames (Maybe Ident)

128 | MissingClassMember Ident

123 | MissingClassMember Ident

129− | ExtraneousClassMember Ident

124+ | ExtraneousClassMember Ident (Qualified ProperName)

130 | ExpectedType Type Kind

125 | ExpectedType Type Kind

131 | IncorrectConstructorArity (Qualified ProperName)

126 | IncorrectConstructorArity (Qualified ProperName)

132− | SubsumptionCheckFailed

133 | ExprDoesNotHaveType Expr Type

127 | ExprDoesNotHaveType Expr Type

134− | PropertyIsMissing String Type

128+ | PropertyIsMissing String

129+ | AdditionalProperty String

135 | CannotApplyFunction Type Expr

130 | CannotApplyFunction Type Expr

136 | TypeSynonymInstance

131 | TypeSynonymInstance

137 | OrphanInstance Ident (Qualified ProperName) [Type]

132 | OrphanInstance Ident (Qualified ProperName) [Type]

138− | InvalidNewtype

133+ | InvalidNewtype ProperName

139 | InvalidInstanceHead Type

134 | InvalidInstanceHead Type

140 | TransitiveExportError DeclarationRef [DeclarationRef]

135 | TransitiveExportError DeclarationRef [DeclarationRef]

141 | ShadowedName Ident

136 | ShadowedName Ident

142 | ShadowedTypeVar String

137 | ShadowedTypeVar String

143 | UnusedTypeVar String

138 | UnusedTypeVar String

144 | WildcardInferredType Type

139 | WildcardInferredType Type

145− | MissingTypeDeclaration Ident

140+ | MissingTypeDeclaration Ident Type

146 | NotExhaustivePattern [[Binder]] Bool

141 | NotExhaustivePattern [[Binder]] Bool

147 | OverlappingPattern [[Binder]] Bool

142 | OverlappingPattern [[Binder]] Bool

148 | IncompleteExhaustivityCheck

143 | IncompleteExhaustivityCheck

@@ -153,14 +148,15 @@ data SimpleErrorMessage

153

148

154-- | Error message hints, providing more detailed information about failure.

149-- | Error message hints, providing more detailed information about failure.

155data ErrorMessageHint

150data ErrorMessageHint

156− = NotYetDefined [Ident]

157− | ErrorUnifyingTypes Type Type

151+ = ErrorUnifyingTypes Type Type

158 | ErrorInExpression Expr

152 | ErrorInExpression Expr

159 | ErrorInModule ModuleName

153 | ErrorInModule ModuleName

160 | ErrorInInstance (Qualified ProperName) [Type]

154 | ErrorInInstance (Qualified ProperName) [Type]

161 | ErrorInSubsumption Type Type

155 | ErrorInSubsumption Type Type

156+ | ErrorCheckingAccessor Expr String

162 | ErrorCheckingType Expr Type

157 | ErrorCheckingType Expr Type

163 | ErrorCheckingKind Type

158 | ErrorCheckingKind Type

159+ | ErrorCheckingGuard

164 | ErrorInferringType Expr

160 | ErrorInferringType Expr

165 | ErrorInApplication Expr Type Expr

161 | ErrorInApplication Expr Type Expr

166 | ErrorInDataConstructor ProperName

162 | ErrorInDataConstructor ProperName

@@ -196,19 +192,16 @@ instance UnificationError Kind ErrorMessage where

196--

192--

197errorCode :: ErrorMessage -> String

193errorCode :: ErrorMessage -> String

198errorCode em = case unwrapErrorMessage em of

194errorCode em = case unwrapErrorMessage em of

199− ErrorParsingExterns{} -> "ErrorParsingExterns"

200 ErrorParsingFFIModule{} -> "ErrorParsingFFIModule"

195 ErrorParsingFFIModule{} -> "ErrorParsingFFIModule"

201 ErrorParsingModule{} -> "ErrorParsingModule"

196 ErrorParsingModule{} -> "ErrorParsingModule"

202 MissingFFIModule{} -> "MissingFFIModule"

197 MissingFFIModule{} -> "MissingFFIModule"

203 MultipleFFIModules{} -> "MultipleFFIModules"

198 MultipleFFIModules{} -> "MultipleFFIModules"

204 UnnecessaryFFIModule{} -> "UnnecessaryFFIModule"

199 UnnecessaryFFIModule{} -> "UnnecessaryFFIModule"

205− InvalidExternsFile{} -> "InvalidExternsFile"

206 CannotGetFileInfo{} -> "CannotGetFileInfo"

200 CannotGetFileInfo{} -> "CannotGetFileInfo"

207 CannotReadFile{} -> "CannotReadFile"

201 CannotReadFile{} -> "CannotReadFile"

208 CannotWriteFile{} -> "CannotWriteFile"

202 CannotWriteFile{} -> "CannotWriteFile"

209 InfiniteType{} -> "InfiniteType"

203 InfiniteType{} -> "InfiniteType"

210 InfiniteKind{} -> "InfiniteKind"

204 InfiniteKind{} -> "InfiniteKind"

211− CannotReorderOperators -> "CannotReorderOperators"

212 MultipleFixities{} -> "MultipleFixities"

205 MultipleFixities{} -> "MultipleFixities"

213 OrphanTypeDeclaration{} -> "OrphanTypeDeclaration"

206 OrphanTypeDeclaration{} -> "OrphanTypeDeclaration"

214 OrphanFixityDeclaration{} -> "OrphanFixityDeclaration"

207 OrphanFixityDeclaration{} -> "OrphanFixityDeclaration"

@@ -248,11 +241,9 @@ errorCode em = case unwrapErrorMessage em of

248 CycleInTypeSynonym{} -> "CycleInTypeSynonym"

241 CycleInTypeSynonym{} -> "CycleInTypeSynonym"

249 CycleInModules{} -> "CycleInModules"

242 CycleInModules{} -> "CycleInModules"

250 NameIsUndefined{} -> "NameIsUndefined"

243 NameIsUndefined{} -> "NameIsUndefined"

251− NameNotInScope{} -> "NameNotInScope"

252 UndefinedTypeVariable{} -> "UndefinedTypeVariable"

244 UndefinedTypeVariable{} -> "UndefinedTypeVariable"

253 PartiallyAppliedSynonym{} -> "PartiallyAppliedSynonym"

245 PartiallyAppliedSynonym{} -> "PartiallyAppliedSynonym"

254 EscapedSkolem{} -> "EscapedSkolem"

246 EscapedSkolem{} -> "EscapedSkolem"

255− UnspecifiedSkolemScope -> "UnspecifiedSkolemScope"

256 TypesDoNotUnify{} -> "TypesDoNotUnify"

247 TypesDoNotUnify{} -> "TypesDoNotUnify"

257 KindsDoNotUnify{} -> "KindsDoNotUnify"

248 KindsDoNotUnify{} -> "KindsDoNotUnify"

258 ConstrainedTypeUnified{} -> "ConstrainedTypeUnified"

249 ConstrainedTypeUnified{} -> "ConstrainedTypeUnified"

@@ -269,13 +260,13 @@ errorCode em = case unwrapErrorMessage em of

269 ExtraneousClassMember{} -> "ExtraneousClassMember"

260 ExtraneousClassMember{} -> "ExtraneousClassMember"

270 ExpectedType{} -> "ExpectedType"

261 ExpectedType{} -> "ExpectedType"

271 IncorrectConstructorArity{} -> "IncorrectConstructorArity"

262 IncorrectConstructorArity{} -> "IncorrectConstructorArity"

272− SubsumptionCheckFailed -> "SubsumptionCheckFailed"

273 ExprDoesNotHaveType{} -> "ExprDoesNotHaveType"

263 ExprDoesNotHaveType{} -> "ExprDoesNotHaveType"

274 PropertyIsMissing{} -> "PropertyIsMissing"

264 PropertyIsMissing{} -> "PropertyIsMissing"

265+ AdditionalProperty{} -> "AdditionalProperty"

275 CannotApplyFunction{} -> "CannotApplyFunction"

266 CannotApplyFunction{} -> "CannotApplyFunction"

276 TypeSynonymInstance -> "TypeSynonymInstance"

267 TypeSynonymInstance -> "TypeSynonymInstance"

277 OrphanInstance{} -> "OrphanInstance"

268 OrphanInstance{} -> "OrphanInstance"

278− InvalidNewtype -> "InvalidNewtype"

269+ InvalidNewtype{} -> "InvalidNewtype"

279 InvalidInstanceHead{} -> "InvalidInstanceHead"

270 InvalidInstanceHead{} -> "InvalidInstanceHead"

280 TransitiveExportError{} -> "TransitiveExportError"

271 TransitiveExportError{} -> "TransitiveExportError"

281 ShadowedName{} -> "ShadowedName"

272 ShadowedName{} -> "ShadowedName"

@@ -362,7 +353,6 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse

362 gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2

353 gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2

363 gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2

354 gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2

364 gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t

355 gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t

365− gSimple (PropertyIsMissing s t) = PropertyIsMissing s <$> f t

366 gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e

356 gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e

367 gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t

357 gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t

368 gSimple other = pure other

358 gSimple other = pure other

@@ -377,17 +367,18 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse

377-- Pretty print a single error, simplifying if necessary

367-- Pretty print a single error, simplifying if necessary

378--

368--

379prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State UnknownMap Box.Box

369prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State UnknownMap Box.Box

380−prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFirst . reverseHints <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)

370+prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)

381− where

371+ where

382

372

383 -- Pretty print an ErrorMessage

373 -- Pretty print an ErrorMessage

384 prettyPrintErrorMessage :: ErrorMessage -> Box.Box

374 prettyPrintErrorMessage :: ErrorMessage -> Box.Box

385 prettyPrintErrorMessage (ErrorMessage hints simple) =

375 prettyPrintErrorMessage (ErrorMessage hints simple) =

386 paras $

376 paras $

387− map renderHint hints ++

377+ [ foldr renderHint (indent (renderSimpleErrorMessage simple)) hints

388− renderSimpleErrorMessage simple :

378+ , Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri ++ " for more information, "

389− suggestions simple ++

390− [line $ "See " ++ wikiUri ++ " for more information, or to contribute content related to this " ++ levelText ++ "."]

379+ , line $ "or to contribute content related to this " ++ levelText ++ "."

380+ ]

381+ ]

391 where

382 where

392 wikiUri :: String

383 wikiUri :: String

393 wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e

384 wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e

@@ -405,12 +396,8 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

405 paras [ line "Unable to write file: "

396 paras [ line "Unable to write file: "

406 , indent . line $ path

397 , indent . line $ path

407 ]

398 ]

408− renderSimpleErrorMessage (ErrorParsingExterns err) =

409− paras [ lineWithLevel "parsing externs files: "

410− , prettyPrintParseError err

411− ]

412 renderSimpleErrorMessage (ErrorParsingFFIModule path) =

399 renderSimpleErrorMessage (ErrorParsingFFIModule path) =

413− paras [ line "Unable to parse module from FFI file: "

400+ paras [ line "Unable to parse foreign module:"

414 , indent . line $ path

401 , indent . line $ path

415 ]

402 ]

416 renderSimpleErrorMessage (ErrorParsingModule err) =

403 renderSimpleErrorMessage (ErrorParsingModule err) =

@@ -418,29 +405,22 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

418 , prettyPrintParseError err

405 , prettyPrintParseError err

419 ]

406 ]

420 renderSimpleErrorMessage (MissingFFIModule mn) =

407 renderSimpleErrorMessage (MissingFFIModule mn) =

421− line $ "Missing FFI implementations for module " ++ runModuleName mn

408+ line $ "The foreign module implementation for module " ++ runModuleName mn ++ " is missing."

422 renderSimpleErrorMessage (UnnecessaryFFIModule mn path) =

409 renderSimpleErrorMessage (UnnecessaryFFIModule mn path) =

423− paras [ line $ "Unnecessary FFI implementations have been provided for module " ++ runModuleName mn ++ ": "

410+ paras [ line $ "An unnecessary foreign module implementation was provided for module " ++ runModuleName mn ++ ": "

424 , indent . line $ path

411 , indent . line $ path

412+ , line $ "Module " ++ runModuleName mn ++ " does not contain any foreign import declarations, so a foreign module is not necessary."

425 ]

413 ]

426 renderSimpleErrorMessage (MultipleFFIModules mn paths) =

414 renderSimpleErrorMessage (MultipleFFIModules mn paths) =

427− paras [ line $ "Multiple FFI implementations have been provided for module " ++ runModuleName mn ++ ": "

415+ paras [ line $ "Multiple foreign module implementations have been provided for module " ++ runModuleName mn ++ ": "

428 , indent . paras $ map line paths

416 , indent . paras $ map line paths

429 ]

417 ]

430− renderSimpleErrorMessage (InvalidExternsFile path) =

431− paras [ line "Externs file is invalid: "

432− , indent . line $ path

433− ]

434 renderSimpleErrorMessage InvalidDoBind =

418 renderSimpleErrorMessage InvalidDoBind =

435− line "Bind statement cannot be the last statement in a do block. The last statement must be an expression."

419+ line "The last statement in a 'do' block must be an expression, but this block ends with a binder."

436 renderSimpleErrorMessage InvalidDoLet =

420 renderSimpleErrorMessage InvalidDoLet =

437− line "Let statement cannot be the last statement in a do block. The last statement must be an expression."

421+ line "The last statement in a 'do' block must be an expression, but this block ends with a let binding."

438− renderSimpleErrorMessage CannotReorderOperators =

439− line "Unable to reorder operators"

440− renderSimpleErrorMessage UnspecifiedSkolemScope =

441− line "Skolem variable scope is unspecified"

442 renderSimpleErrorMessage OverlappingNamesInLet =

422 renderSimpleErrorMessage OverlappingNamesInLet =

443− line "Overlapping names in let binding."

423+ line "The same name was used more than once in a let binding."

444 renderSimpleErrorMessage (InfiniteType ty) =

424 renderSimpleErrorMessage (InfiniteType ty) =

445 paras [ line "An infinite type was inferred for an expression: "

425 paras [ line "An infinite type was inferred for an expression: "

446 , indent $ typeAsBox ty

426 , indent $ typeAsBox ty

@@ -450,17 +430,17 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

450 , indent $ line $ prettyPrintKind ki

430 , indent $ line $ prettyPrintKind ki

451 ]

431 ]

452 renderSimpleErrorMessage (MultipleFixities name) =

432 renderSimpleErrorMessage (MultipleFixities name) =

453− line $ "Multiple fixity declarations for " ++ showIdent name

433+ line $ "There are multiple fixity/precedence declarations for " ++ showIdent name

454 renderSimpleErrorMessage (OrphanTypeDeclaration nm) =

434 renderSimpleErrorMessage (OrphanTypeDeclaration nm) =

455− line $ "Orphan type declaration for " ++ showIdent nm

435+ line $ "The type declaration for " ++ showIdent nm ++ " should be followed by its definition."

456 renderSimpleErrorMessage (OrphanFixityDeclaration op) =

436 renderSimpleErrorMessage (OrphanFixityDeclaration op) =

457− line $ "Orphan fixity declaration for " ++ show op

437+ line $ "The fixity/precedence declaration for " ++ show op ++ " should appear in the same module as its definition."

458 renderSimpleErrorMessage (RedefinedModule name filenames) =

438 renderSimpleErrorMessage (RedefinedModule name filenames) =

459− paras [ line ("Module " ++ runModuleName name ++ " has been defined multiple times:")

439+ paras [ line ("The module " ++ runModuleName name ++ " has been defined multiple times:")

460 , indent . paras $ map (line . displaySourceSpan) filenames

440 , indent . paras $ map (line . displaySourceSpan) filenames

461 ]

441 ]

462 renderSimpleErrorMessage (RedefinedIdent name) =

442 renderSimpleErrorMessage (RedefinedIdent name) =

463− line $ "Name " ++ showIdent name ++ " has been defined multiple times"

443+ line $ "The value " ++ showIdent name ++ " has been defined multiple times"

464 renderSimpleErrorMessage (UnknownModule mn) =

444 renderSimpleErrorMessage (UnknownModule mn) =

465 line $ "Unknown module " ++ runModuleName mn

445 line $ "Unknown module " ++ runModuleName mn

466 renderSimpleErrorMessage (UnknownType name) =

446 renderSimpleErrorMessage (UnknownType name) =

@@ -474,25 +454,36 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

474 renderSimpleErrorMessage (UnknownDataConstructor dc tc) =

454 renderSimpleErrorMessage (UnknownDataConstructor dc tc) =

475 line $ "Unknown data constructor " ++ showQualified runProperName dc ++ foldMap ((" for type constructor " ++) . showQualified runProperName) tc

455 line $ "Unknown data constructor " ++ showQualified runProperName dc ++ foldMap ((" for type constructor " ++) . showQualified runProperName) tc

476 renderSimpleErrorMessage (UnknownImportType mn name) =

456 renderSimpleErrorMessage (UnknownImportType mn name) =

477− line $ "Module " ++ runModuleName mn ++ " does not export type " ++ runProperName name

457+ paras [ line $ "Cannot import type " ++ runProperName name ++ " from module " ++ runModuleName mn

458+ , line "It either does not exist or the module does not export it."

459+ ]

478 renderSimpleErrorMessage (UnknownExportType name) =

460 renderSimpleErrorMessage (UnknownExportType name) =

479 line $ "Cannot export unknown type " ++ runProperName name

461 line $ "Cannot export unknown type " ++ runProperName name

480 renderSimpleErrorMessage (UnknownImportTypeClass mn name) =

462 renderSimpleErrorMessage (UnknownImportTypeClass mn name) =

481− line $ "Module " ++ runModuleName mn ++ " does not export type class " ++ runProperName name

463+ paras [ line $ "Cannot import type class " ++ runProperName name ++ " from module " ++ runModuleName mn

464+ , line "It either does not exist or the module does not export it."

465+ ]

482 renderSimpleErrorMessage (UnknownExportTypeClass name) =

466 renderSimpleErrorMessage (UnknownExportTypeClass name) =

483 line $ "Cannot export unknown type class " ++ runProperName name

467 line $ "Cannot export unknown type class " ++ runProperName name

484 renderSimpleErrorMessage (UnknownImportValue mn name) =

468 renderSimpleErrorMessage (UnknownImportValue mn name) =

485− line $ "Module " ++ runModuleName mn ++ " does not export value " ++ showIdent name

469+ paras [ line $ "Cannot import value " ++ showIdent name ++ " from module " ++ runModuleName mn

470+ , line "It either does not exist or the module does not export it."

471+ ]

486 renderSimpleErrorMessage (UnknownExportValue name) =

472 renderSimpleErrorMessage (UnknownExportValue name) =

487 line $ "Cannot export unknown value " ++ showIdent name

473 line $ "Cannot export unknown value " ++ showIdent name

488 renderSimpleErrorMessage (UnknownExportModule name) =

474 renderSimpleErrorMessage (UnknownExportModule name) =

475+ paras [ line $ "Cannot export unknown module " ++ runModuleName name

489− line $ "Cannot export unknown module " ++ runModuleName name ++ ", it either does not exist or has not been imported by the current module"

476+ , line "It either does not exist or has not been imported by the current module."

477+ ]

490 renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) =

478 renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) =

491 line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon

479 line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon

492 renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =

480 renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =

493− line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ " as it has not been declared"

481+ line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ ", as it has not been declared."

494 renderSimpleErrorMessage (ConflictingImport nm mn) =

482 renderSimpleErrorMessage (ConflictingImport nm mn) =

495− line $ "Cannot declare " ++ show nm ++ " since another declaration of that name was imported from " ++ runModuleName mn

483+ paras [ line $ "Cannot declare " ++ show nm ++ ", since another declaration of that name was imported from module " ++ runModuleName mn

484+ , line $ "Consider hiding " ++ show nm ++ " when importing " ++ runModuleName mn ++ ":"

485+ , indent . line $ "import " ++ runModuleName mn ++ " hiding (" ++ nm ++ ")"

486+ ]

496 renderSimpleErrorMessage (ConflictingImports nm m1 m2) =

487 renderSimpleErrorMessage (ConflictingImports nm m1 m2) =

497 line $ "Conflicting imports for " ++ nm ++ " from modules " ++ runModuleName m1 ++ " and " ++ runModuleName m2

488 line $ "Conflicting imports for " ++ nm ++ " from modules " ++ runModuleName m1 ++ " and " ++ runModuleName m2

498 renderSimpleErrorMessage (ConflictingTypeDecls nm) =

489 renderSimpleErrorMessage (ConflictingTypeDecls nm) =

@@ -500,13 +491,13 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

500 renderSimpleErrorMessage (ConflictingCtorDecls nm) =

491 renderSimpleErrorMessage (ConflictingCtorDecls nm) =

501 line $ "Conflicting data constructor declarations for " ++ runProperName nm

492 line $ "Conflicting data constructor declarations for " ++ runProperName nm

502 renderSimpleErrorMessage (TypeConflictsWithClass nm) =

493 renderSimpleErrorMessage (TypeConflictsWithClass nm) =

503− line $ "Type " ++ runProperName nm ++ " conflicts with type class declaration of the same name"

494+ line $ "Type " ++ runProperName nm ++ " conflicts with a type class declaration with the same name."

504 renderSimpleErrorMessage (CtorConflictsWithClass nm) =

495 renderSimpleErrorMessage (CtorConflictsWithClass nm) =

505− line $ "Data constructor " ++ runProperName nm ++ " conflicts with type class declaration of the same name"

496+ line $ "Data constructor " ++ runProperName nm ++ " conflicts with a type class declaration with the same name."

506 renderSimpleErrorMessage (ClassConflictsWithType nm) =

497 renderSimpleErrorMessage (ClassConflictsWithType nm) =

507− line $ "Type class " ++ runProperName nm ++ " conflicts with type declaration of the same name"

498+ line $ "Type class " ++ runProperName nm ++ " conflicts with a type declaration with the same name."

508 renderSimpleErrorMessage (ClassConflictsWithCtor nm) =

499 renderSimpleErrorMessage (ClassConflictsWithCtor nm) =

509− line $ "Type class " ++ runProperName nm ++ " conflicts with data constructor declaration of the same name"

500+ line $ "Type class " ++ runProperName nm ++ " conflicts with a data constructor declaration with the same name."

510 renderSimpleErrorMessage (DuplicateModuleName mn) =

501 renderSimpleErrorMessage (DuplicateModuleName mn) =

511 line $ "Module " ++ runModuleName mn ++ " has been defined multiple times."

502 line $ "Module " ++ runModuleName mn ++ " has been defined multiple times."

512 renderSimpleErrorMessage (DuplicateClassExport nm) =

503 renderSimpleErrorMessage (DuplicateClassExport nm) =

@@ -514,19 +505,24 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

514 renderSimpleErrorMessage (DuplicateValueExport nm) =

505 renderSimpleErrorMessage (DuplicateValueExport nm) =

515 line $ "Duplicate export declaration for value " ++ showIdent nm

506 line $ "Duplicate export declaration for value " ++ showIdent nm

516 renderSimpleErrorMessage (CycleInDeclaration nm) =

507 renderSimpleErrorMessage (CycleInDeclaration nm) =

517− line $ "Cycle in declaration of " ++ showIdent nm

508+ line $ "The value of " ++ showIdent nm ++ " is undefined here, so this reference is not allowed."

518 renderSimpleErrorMessage (CycleInModules mns) =

509 renderSimpleErrorMessage (CycleInModules mns) =

519− line $ "Cycle in module dependencies: " ++ intercalate ", " (map runModuleName mns)

510+ paras [ line $ "There is a cycle in module dependencies in these modules: "

511+ , indent $ paras (map (line . runModuleName) mns)

512+ ]

520− renderSimpleErrorMessage (CycleInTypeSynonym pn) =

513+ renderSimpleErrorMessage (CycleInTypeSynonym name) =

521− line $ "Cycle in type synonym" ++ foldMap ((" " ++) . runProperName) pn

514+ paras [ line $ case name of

515+ Just pn -> "A cycle appears in the definition of type synonym " ++ runProperName pn

516+ Nothing -> "A cycle appears in a set of type synonym definitions."

517+ , line "Cycles are disallowed because they can lead to loops in the type checker."

518+ , line "Consider using a 'newtype' instead."

519+ ]

522 renderSimpleErrorMessage (NameIsUndefined ident) =

520 renderSimpleErrorMessage (NameIsUndefined ident) =

523− line $ showIdent ident ++ " is undefined"

521+ line $ "Value " ++ showIdent ident ++ " is undefined."

524− renderSimpleErrorMessage (NameNotInScope ident) =

525− line $ showIdent ident ++ " may not be defined in the current scope"

526 renderSimpleErrorMessage (UndefinedTypeVariable name) =

522 renderSimpleErrorMessage (UndefinedTypeVariable name) =

527− line $ "Type variable " ++ runProperName name ++ " is undefined"

523+ line $ "Type variable " ++ runProperName name ++ " is undefined."

528 renderSimpleErrorMessage (PartiallyAppliedSynonym name) =

524 renderSimpleErrorMessage (PartiallyAppliedSynonym name) =

529− paras [ line $ "Partially applied type synonym " ++ showQualified runProperName name

525+ paras [ line $ "Type synonym " ++ showQualified runProperName name ++ " is partially applied."

530 , line "Type synonyms must be applied to all of their type arguments."

526 , line "Type synonyms must be applied to all of their type arguments."

531 ]

527 ]

532 renderSimpleErrorMessage (EscapedSkolem binding) =

528 renderSimpleErrorMessage (EscapedSkolem binding) =

@@ -535,70 +531,72 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

535 , indent $ prettyPrintValue expr

531 , indent $ prettyPrintValue expr

536 ]) binding

532 ]) binding

537 renderSimpleErrorMessage (TypesDoNotUnify t1 t2)

533 renderSimpleErrorMessage (TypesDoNotUnify t1 t2)

538− = paras [ line "Cannot unify type"

534+ = paras [ line "Could not match type"

539 , indent $ typeAsBox t1

535 , indent $ typeAsBox t1

540 , line "with type"

536 , line "with type"

541 , indent $ typeAsBox t2

537 , indent $ typeAsBox t2

542 ]

538 ]

543 renderSimpleErrorMessage (KindsDoNotUnify k1 k2) =

539 renderSimpleErrorMessage (KindsDoNotUnify k1 k2) =

544− paras [ line "Cannot unify kind"

540+ paras [ line "Could not match kind"

545 , indent $ line $ prettyPrintKind k1

541 , indent $ line $ prettyPrintKind k1

546 , line "with kind"

542 , line "with kind"

547 , indent $ line $ prettyPrintKind k2

543 , indent $ line $ prettyPrintKind k2

548 ]

544 ]

549 renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) =

545 renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) =

550− paras [ line "Cannot unify constrained type"

546+ paras [ line "Could not match constrained type"

551 , indent $ typeAsBox t1

547 , indent $ typeAsBox t1

552 , line "with type"

548 , line "with type"

553 , indent $ typeAsBox t2

549 , indent $ typeAsBox t2

554 ]

550 ]

555 renderSimpleErrorMessage (OverlappingInstances nm ts (d : ds)) =

551 renderSimpleErrorMessage (OverlappingInstances nm ts (d : ds)) =

556− paras [ line "Overlapping instances found for"

552+ paras [ line "Overlapping type class instances found for"

557 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

553 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

558 , Box.vcat Box.left (map typeAtomAsBox ts)

554 , Box.vcat Box.left (map typeAtomAsBox ts)

559 ]

555 ]

560 , line "The following instances were found:"

556 , line "The following instances were found:"

561 , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds)

557 , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds)

558+ , line "Overlapping type class instances can lead to different behavior based on the order of module imports, and for that reason are not recommended."

559+ , line "They may be disallowed completely in a future version of the compiler."

562 ]

560 ]

563− renderSimpleErrorMessage OverlappingInstances{} = error "OverlappingInstances: empty instance list"

561+ renderSimpleErrorMessage OverlappingInstances{} = internalError "OverlappingInstances: empty instance list"

564 renderSimpleErrorMessage (NoInstanceFound nm ts) =

562 renderSimpleErrorMessage (NoInstanceFound nm ts) =

565− paras [ line "No instance found for"

563+ paras [ line "No type class instance was found for"

566 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

564 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

567 , Box.vcat Box.left (map typeAtomAsBox ts)

565 , Box.vcat Box.left (map typeAtomAsBox ts)

568 ]

566 ]

569 ]

567 ]

570 renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =

568 renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =

571− paras [ line "Instance for"

569+ paras [ line "Type class instance for"

572 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

570 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

573 , Box.vcat Box.left (map typeAtomAsBox ts)

571 , Box.vcat Box.left (map typeAtomAsBox ts)

574 ]

572 ]

575 , line "is possibly infinite."

573 , line "is possibly infinite."

576 ]

574 ]

577 renderSimpleErrorMessage (CannotDerive nm ts) =

575 renderSimpleErrorMessage (CannotDerive nm ts) =

578− paras [ line "Cannot derive an instance for"

576+ paras [ line "Cannot derive a type class instance for"

579 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

577 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

580 , Box.vcat Box.left (map typeAtomAsBox ts)

578 , Box.vcat Box.left (map typeAtomAsBox ts)

581 ]

579 ]

582 ]

580 ]

583 renderSimpleErrorMessage (CannotFindDerivingType nm) =

581 renderSimpleErrorMessage (CannotFindDerivingType nm) =

584− line $ "Cannot derive instance, because the type declaration for " ++ runProperName nm ++ " could not be found."

582+ line $ "Cannot derive a type class instance, because the type declaration for " ++ runProperName nm ++ " could not be found."

585 renderSimpleErrorMessage (DuplicateLabel l expr) =

583 renderSimpleErrorMessage (DuplicateLabel l expr) =

586− paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ]

584+ paras $ [ line $ "Label " ++ show l ++ " appears more than once in a row type." ]

587 <> foldMap (\expr' -> [ line "Relevant expression: "

585 <> foldMap (\expr' -> [ line "Relevant expression: "

588 , indent $ prettyPrintValue expr'

586 , indent $ prettyPrintValue expr'

589 ]) expr

587 ]) expr

590 renderSimpleErrorMessage (DuplicateTypeArgument name) =

588 renderSimpleErrorMessage (DuplicateTypeArgument name) =

591− line $ "Duplicate type argument " ++ show name

589+ line $ "Type argument " ++ show name ++ " appears more than once."

592 renderSimpleErrorMessage (DuplicateValueDeclaration nm) =

590 renderSimpleErrorMessage (DuplicateValueDeclaration nm) =

593− line $ "Duplicate value declaration for " ++ showIdent nm

591+ line $ "Multiple value declarations exist for " ++ showIdent nm ++ "."

594 renderSimpleErrorMessage (ArgListLengthsDiffer ident) =

592 renderSimpleErrorMessage (ArgListLengthsDiffer ident) =

595 line $ "Argument list lengths differ in declaration " ++ showIdent ident

593 line $ "Argument list lengths differ in declaration " ++ showIdent ident

596 renderSimpleErrorMessage (OverlappingArgNames ident) =

594 renderSimpleErrorMessage (OverlappingArgNames ident) =

597 line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . showIdent) ident

595 line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . showIdent) ident

598 renderSimpleErrorMessage (MissingClassMember ident) =

596 renderSimpleErrorMessage (MissingClassMember ident) =

599− line $ "Member " ++ showIdent ident ++ " has not been implemented"

597+ line $ "Type class member " ++ showIdent ident ++ " has not been implemented."

600− renderSimpleErrorMessage (ExtraneousClassMember ident) =

598+ renderSimpleErrorMessage (ExtraneousClassMember ident className) =

601− line $ "Member " ++ showIdent ident ++ " is not a member of the class being instantiated"

599+ line $ showIdent ident ++ " is not a member of type class " ++ showQualified runProperName className

602 renderSimpleErrorMessage (ExpectedType ty kind) =

600 renderSimpleErrorMessage (ExpectedType ty kind) =

603 paras [ line "In a type-annotated expression x :: t, the type t must have kind *."

601 paras [ line "In a type-annotated expression x :: t, the type t must have kind *."

604 , line "The error arises from the type"

602 , line "The error arises from the type"

@@ -608,29 +606,27 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

608 , line "instead."

606 , line "instead."

609 ]

607 ]

610 renderSimpleErrorMessage (IncorrectConstructorArity nm) =

608 renderSimpleErrorMessage (IncorrectConstructorArity nm) =

611− line $ "Wrong number of arguments to constructor " ++ showQualified runProperName nm

609+ line $ "Data constructor " ++ showQualified runProperName nm ++ " was given the wrong number of arguments in a case expression."

612− renderSimpleErrorMessage SubsumptionCheckFailed = line "Unable to check type subsumption"

613 renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) =

610 renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) =

614 paras [ line "Expression"

611 paras [ line "Expression"

615 , indent $ prettyPrintValue expr

612 , indent $ prettyPrintValue expr

616 , line "does not have type"

613 , line "does not have type"

617 , indent $ typeAsBox ty

614 , indent $ typeAsBox ty

618 ]

615 ]

619− renderSimpleErrorMessage (PropertyIsMissing prop row) =

616+ renderSimpleErrorMessage (PropertyIsMissing prop) =

620− paras [ line "Row"

621− , indent $ prettyPrintRowWith '(' ')' row

622− , line $ "lacks required property " ++ show prop

617+ line $ "Type of expression lacks required label " ++ show prop ++ "."

623− ]

618+ renderSimpleErrorMessage (AdditionalProperty prop) =

619+ line $ "Type of expression contains additional label " ++ show prop ++ "."

624 renderSimpleErrorMessage (CannotApplyFunction fn arg) =

620 renderSimpleErrorMessage (CannotApplyFunction fn arg) =

625− paras [ line "Cannot apply function of type"

621+ paras [ line "A function of type"

626 , indent $ typeAsBox fn

622 , indent $ typeAsBox fn

627− , line "to argument"

623+ , line "can not be applied to the argument"

628 , indent $ prettyPrintValue arg

624 , indent $ prettyPrintValue arg

629 ]

625 ]

630 renderSimpleErrorMessage TypeSynonymInstance =

626 renderSimpleErrorMessage TypeSynonymInstance =

631− line "Type synonym instances are disallowed"

627+ line "Type class instances for type synonyms are disallowed."

632 renderSimpleErrorMessage (OrphanInstance nm cnm ts) =

628 renderSimpleErrorMessage (OrphanInstance nm cnm ts) =

633− paras [ line $ "Instance " ++ showIdent nm ++ " for "

629+ paras [ line $ "Type class instance " ++ showIdent nm ++ " for "

634 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cnm)

630 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cnm)

635 , Box.vcat Box.left (map typeAtomAsBox ts)

631 , Box.vcat Box.left (map typeAtomAsBox ts)

636 ]

632 ]

@@ -638,39 +634,44 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

638 , line "An orphan instance is an instance which is defined in neither the class module nor the data type module."

634 , line "An orphan instance is an instance which is defined in neither the class module nor the data type module."

639 , line "Consider moving the instance, if possible, or using a newtype wrapper."

635 , line "Consider moving the instance, if possible, or using a newtype wrapper."

640 ]

636 ]

641− renderSimpleErrorMessage InvalidNewtype =

637+ renderSimpleErrorMessage (InvalidNewtype name) =

638+ paras [ line $ "Newtype " ++ runProperName name ++ " is invalid."

642− line "Newtypes must define a single constructor with a single argument"

639+ , line "Newtypes must define a single constructor with a single argument."

640+ ]

643 renderSimpleErrorMessage (InvalidInstanceHead ty) =

641 renderSimpleErrorMessage (InvalidInstanceHead ty) =

644− paras [ line "Invalid type in class instance head:"

642+ paras [ line "Type class instance head is invalid due to use of type"

645 , indent $ typeAsBox ty

643 , indent $ typeAsBox ty

644+ , line "All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form."

646 ]

645 ]

647 renderSimpleErrorMessage (TransitiveExportError x ys) =

646 renderSimpleErrorMessage (TransitiveExportError x ys) =

648 paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")

647 paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")

649 : map (line . prettyPrintExport) ys

648 : map (line . prettyPrintExport) ys

650 renderSimpleErrorMessage (ShadowedName nm) =

649 renderSimpleErrorMessage (ShadowedName nm) =

651− line $ "Name '" ++ showIdent nm ++ "' was shadowed"

650+ line $ "Name '" ++ showIdent nm ++ "' was shadowed."

652 renderSimpleErrorMessage (ShadowedTypeVar tv) =

651 renderSimpleErrorMessage (ShadowedTypeVar tv) =

653− line $ "Type variable '" ++ tv ++ "' was shadowed"

652+ line $ "Type variable '" ++ tv ++ "' was shadowed."

654 renderSimpleErrorMessage (UnusedTypeVar tv) =

653 renderSimpleErrorMessage (UnusedTypeVar tv) =

655− line $ "Type variable '" ++ tv ++ "' was declared but not used"

654+ line $ "Type variable '" ++ tv ++ "' was declared but not used."

656 renderSimpleErrorMessage (ClassOperator className opName) =

655 renderSimpleErrorMessage (ClassOperator className opName) =

657− paras [ line $ "Class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "."

656+ paras [ line $ "Type class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "."

658 , line "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:"

657 , line "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:"

659 , indent . line $ showIdent opName ++ " = someMember"

658 , indent . line $ showIdent opName ++ " = someMember"

660 ]

659 ]

661 renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =

660 renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =

662− line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors"

661+ line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors."

663 renderSimpleErrorMessage (ImportHidingModule name) =

662 renderSimpleErrorMessage (ImportHidingModule name) =

663+ paras [ line $ "'hiding' imports cannot be used to hide modules."

664− line $ "Attempted to hide module " ++ runModuleName name ++ " in import expression, this is not permitted"

664+ , line $ "An attempt was made to hide the import of " ++ runModuleName name

665+ ]

665 renderSimpleErrorMessage (WildcardInferredType ty) =

666 renderSimpleErrorMessage (WildcardInferredType ty) =

666− paras [ line "The wildcard type definition has the inferred type "

667+ paras [ line "Wildcard type definition has the inferred type "

667 , indent $ typeAsBox ty

668 , indent $ typeAsBox ty

668 ]

669 ]

669− renderSimpleErrorMessage (MissingTypeDeclaration ident) =

670+ renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =

670 paras [ line $ "No type declaration was provided for the top-level declaration of " ++ showIdent ident ++ "."

671 paras [ line $ "No type declaration was provided for the top-level declaration of " ++ showIdent ident ++ "."

671 , line "It is good practice to provide type declarations as a form of documentation."

672 , line "It is good practice to provide type declarations as a form of documentation."

672− , line "Consider using a type wildcard to display the inferred type:"

673+ , line $ "The inferred type of " ++ showIdent ident ++ " was:"

673− , indent $ line $ showIdent ident ++ " :: _"

674+ , indent $ typeAsBox ty

674 ]

675 ]

675 renderSimpleErrorMessage (NotExhaustivePattern bs b) =

676 renderSimpleErrorMessage (NotExhaustivePattern bs b) =

676 paras $ [ line "A case expression could not be determined to cover all inputs."

677 paras $ [ line "A case expression could not be determined to cover all inputs."

@@ -685,95 +686,130 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

685 [ line "..." | not b ]

686 [ line "..." | not b ]

686 renderSimpleErrorMessage IncompleteExhaustivityCheck =

687 renderSimpleErrorMessage IncompleteExhaustivityCheck =

687 paras [ line "An exhaustivity check was abandoned due to too many possible cases."

688 paras [ line "An exhaustivity check was abandoned due to too many possible cases."

688− , line "You may want to decomposing your data types into smaller types."

689+ , line "You may want to decompose your data types into smaller types."

689− ]

690+ ]

690−

691+

691− renderHint :: ErrorMessageHint -> Box.Box

692+ renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

692− renderHint (NotYetDefined names) =

693− line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":"

694− renderHint (ErrorUnifyingTypes t1 t2) =

693+ renderHint (ErrorUnifyingTypes t1 t2) detail =

695− paras [ lineWithLevel "unifying type "

694+ paras [ detail

695+ , Box.hsep 1 Box.top [ line "while trying to match type"

696− , indent $ typeAsBox t1

696+ , typeAsBox t1

697+ ]

697− , line "with type"

698+ , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "with type"

699+ , typeAsBox t2

700+ ]

701+ ]

702+ renderHint (ErrorInExpression expr) detail =

703+ paras [ detail

704+ , Box.hsep 1 Box.top [ Box.text "in the expression"

705+ , prettyPrintValue expr

706+ ]

707+ ]

708+ renderHint (ErrorInModule mn) detail =

709+ paras [ line $ "in module " ++ runModuleName mn

710+ , detail

711+ ]

712+ renderHint (ErrorInSubsumption t1 t2) detail =

713+ paras [ detail

714+ , Box.hsep 1 Box.top [ line "while checking that type"

715+ , typeAsBox t1

716+ ]

717+ , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "is at least as general as type"

698− , indent $ typeAsBox t2

718+ , typeAsBox t2

719+ ]

720+ ]

721+ renderHint (ErrorInInstance nm ts) detail =

722+ paras [ detail

723+ , Box.hsep 1 Box.top [ line "in type class instance"

724+ , line (showQualified runProperName nm)

725+ , Box.vcat Box.left (map typeAtomAsBox ts)

726+ ]

727+ ]

728+ renderHint (ErrorCheckingKind ty) detail =

729+ paras [ detail

730+ , Box.hsep 1 Box.top [ line "while checking the kind of"

731+ , typeAsBox ty

732+ ]

733+ ]

734+ renderHint ErrorCheckingGuard detail =

735+ paras [ detail

736+ , line "while checking the type of a guard clause"

737+ ]

738+ renderHint (ErrorInferringType expr) detail =

739+ paras [ detail

740+ , Box.hsep 1 Box.top [ line "while inferring the type of"

741+ , prettyPrintValue expr

742+ ]

743+ ]

744+ renderHint (ErrorCheckingType expr ty) detail =

745+ paras [ detail

746+ , Box.hsep 1 Box.top [ line "while checking that expression"

747+ , prettyPrintValue expr

748+ ]

749+ , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "has type"

750+ , typeAsBox ty

751+ ]

752+ ]

753+ renderHint (ErrorCheckingAccessor expr prop) detail =

754+ paras [ detail

755+ , Box.hsep 1 Box.top [ line "while checking type of property accessor"

756+ , prettyPrintValue (Accessor prop expr)

757+ ]

758+ ]

759+ renderHint (ErrorInApplication f t a) detail =

760+ paras [ detail

761+ , Box.hsep 1 Box.top [ line "while applying a function"

762+ , prettyPrintValue f

763+ ]

764+ , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "of type"

765+ , typeAsBox t

766+ ]

767+ , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "to argument"

768+ , prettyPrintValue a

769+ ]

770+ ]

771+ renderHint (ErrorInDataConstructor nm) detail =

772+ paras [ detail

773+ , line $ "in data constructor " ++ runProperName nm

774+ ]

775+ renderHint (ErrorInTypeConstructor nm) detail =

776+ paras [ detail

777+ , line $ "in type constructor " ++ runProperName nm

778+ ]

779+ renderHint (ErrorInBindingGroup nms) detail =

780+ paras [ detail

781+ , line $ "in binding group " ++ intercalate ", " (map showIdent nms)

782+ ]

783+ renderHint ErrorInDataBindingGroup detail =

784+ paras [ detail

785+ , line "in data binding group"

786+ ]

787+ renderHint (ErrorInTypeSynonym name) detail =

788+ paras [ detail

789+ , line $ "in type synonym " ++ runProperName name

790+ ]

791+ renderHint (ErrorInValueDeclaration n) detail =

792+ paras [ detail

793+ , line $ "in value declaration " ++ showIdent n

794+ ]

795+ renderHint (ErrorInTypeDeclaration n) detail =

796+ paras [ detail

797+ , line $ "in type declaration for " ++ showIdent n

798+ ]

799+ renderHint (ErrorInForeignImport nm) detail =

800+ paras [ detail

801+ , line $ "in foreign import " ++ showIdent nm

802+ ]

803+ renderHint (PositionedError srcSpan) detail =

804+ paras [ line $ "at " ++ displaySourceSpan srcSpan

805+ , detail

699 ]

806 ]

700− renderHint (ErrorInExpression expr) =

701− paras [ lineWithLevel "in expression:"

702− , indent $ prettyPrintValue expr

703− ]

704− renderHint (ErrorInModule mn) =

705− paras [ lineWithLevel $ "in module " ++ runModuleName mn ++ ":"

706− ]

707− renderHint (ErrorInSubsumption t1 t2) =

708− paras [ lineWithLevel "checking that type "

709− , indent $ typeAsBox t1

710− , line "subsumes type"

711− , indent $ typeAsBox t2

712− ]

713− renderHint (ErrorInInstance nm ts) =

714− paras [ lineWithLevel "in type class instance"

715− , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

716− , Box.vcat Box.left (map typeAtomAsBox ts)

717− ]

718− ]

719− renderHint (ErrorCheckingKind ty) =

720− paras [ lineWithLevel "checking kind of type "

721− , indent $ typeAsBox ty

722− ]

723− renderHint (ErrorInferringType expr) =

724− paras [ lineWithLevel "inferring type of value "

725− , indent $ prettyPrintValue expr

726− ]

727− renderHint (ErrorCheckingType expr ty) =

728− paras [ lineWithLevel "checking that value "

729− , indent $ prettyPrintValue expr

730− , line "has type"

731− , indent $ typeAsBox ty

732− ]

733− renderHint (ErrorInApplication f t a) =

734− paras [ lineWithLevel "applying function"

735− , indent $ prettyPrintValue f

736− , line "of type"

737− , indent $ typeAsBox t

738− , line "to argument"

739− , indent $ prettyPrintValue a

740− ]

741− renderHint (ErrorInDataConstructor nm) =

742− lineWithLevel $ "in data constructor " ++ runProperName nm ++ ":"

743− renderHint (ErrorInTypeConstructor nm) =

744− lineWithLevel $ "in type constructor " ++ runProperName nm ++ ":"

745− renderHint (ErrorInBindingGroup nms) =

746− lineWithLevel $ "in binding group " ++ intercalate ", " (map showIdent nms) ++ ":"

747− renderHint ErrorInDataBindingGroup =

748− lineWithLevel "in data binding group:"

749− renderHint (ErrorInTypeSynonym name) =

750− lineWithLevel $ "in type synonym " ++ runProperName name ++ ":"

751− renderHint (ErrorInValueDeclaration n) =

752− lineWithLevel $ "in value declaration " ++ showIdent n ++ ":"

753− renderHint (ErrorInTypeDeclaration n) =

754− lineWithLevel $ "in type declaration for " ++ showIdent n ++ ":"

755− renderHint (ErrorInForeignImport nm) =

756− lineWithLevel $ "in foreign import " ++ showIdent nm ++ ":"

757− renderHint (PositionedError srcSpan) =

758− lineWithLevel $ "at " ++ displaySourceSpan srcSpan ++ ":"

759−

760− lineWithLevel :: String -> Box.Box

761− lineWithLevel text = line $ show level ++ " " ++ text

762

807

763 levelText :: String

808 levelText :: String

764 levelText = case level of

809 levelText = case level of

765 Error -> "error"

810 Error -> "error"

766 Warning -> "warning"

811 Warning -> "warning"

767

812

768− suggestions :: SimpleErrorMessage -> [Box.Box]

769− suggestions (ConflictingImport nm im) = [ line $ "Possible fix: hide " ++ show nm ++ " when importing " ++ runModuleName im ++ ":"

770− , indent . line $ "import " ++ runModuleName im ++ " hiding (" ++ nm ++ ")"

771− ]

772− suggestions (TypesDoNotUnify t1 t2)

773− | isObject t1 && isFunction t2 = [line "Note that function composition in PureScript is defined using (<<<)"]

774− | otherwise = []

775− suggestions _ = []

776−

777 paras :: [Box.Box] -> Box.Box

813 paras :: [Box.Box] -> Box.Box

778 paras = Box.vcat Box.left

814 paras = Box.vcat Box.left

779

815

@@ -786,19 +822,6 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

786 prettyPrintExport (ModuleRef name) = "module " ++ runModuleName name

822 prettyPrintExport (ModuleRef name) = "module " ++ runModuleName name

787 prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref

823 prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref

788

824

789− -- Hints get added at the front, so we need to reverse them before rendering

790− reverseHints :: ErrorMessage -> ErrorMessage

791− reverseHints (ErrorMessage hints simple) = ErrorMessage (reverse hints) simple

792−

793− -- | Put positional hints at the front of the list

794− positionHintsFirst :: ErrorMessage -> ErrorMessage

795− positionHintsFirst (ErrorMessage hints simple) = ErrorMessage (uncurry (++) $ partition (isPositionHint . hintCategory) hints) simple

796− where

797− isPositionHint :: HintCategory -> Bool

798− isPositionHint PositionHint = True

799− isPositionHint OtherHint = True

800− isPositionHint _ = False

801−

802 -- | Simplify an error message

825 -- | Simplify an error message

803 simplifyErrorMessage :: ErrorMessage -> ErrorMessage

826 simplifyErrorMessage :: ErrorMessage -> ErrorMessage

804 simplifyErrorMessage (ErrorMessage hints simple) = ErrorMessage (simplifyHints hints) simple

827 simplifyErrorMessage (ErrorMessage hints simple) = ErrorMessage (simplifyHints hints) simple

src/Language/PureScript/Externs.hs+22−21

@@ -38,6 +38,7 @@ import Data.Aeson.TH

39import qualified Data.Map as M

41+import Language.PureScript.Crash

41import Language.PureScript.AST

42import Language.PureScript.AST

42import Language.PureScript.Environment

43import Language.PureScript.Environment

43import Language.PureScript.Names

44import Language.PureScript.Names

@@ -50,57 +51,57 @@ import Paths_purescript as Paths

50-- | The data which will be serialized to an externs file

51-- | The data which will be serialized to an externs file

51data ExternsFile = ExternsFile

52data ExternsFile = ExternsFile

52 {

53 {

53− -- ^ The externs version

54+ -- | The externs version

54 efVersion :: String

55 efVersion :: String

55− -- ^ Module name

56+ -- | Module name

56 , efModuleName :: ModuleName

57 , efModuleName :: ModuleName

57− -- ^ List of module exports

58+ -- | List of module exports

58 , efExports :: [DeclarationRef]

59 , efExports :: [DeclarationRef]

59− -- ^ List of module imports

60+ -- | List of module imports

60 , efImports :: [ExternsImport]

61 , efImports :: [ExternsImport]

61− -- ^ List of operators and their fixities

62+ -- | List of operators and their fixities

62 , efFixities :: [ExternsFixity]

63 , efFixities :: [ExternsFixity]

63− -- ^ List of type and value declaration

64+ -- | List of type and value declaration

64 , efDeclarations :: [ExternsDeclaration]

65 , efDeclarations :: [ExternsDeclaration]

65 } deriving (Show, Read)

66 } deriving (Show, Read)

67-- | A module import in an externs file

68-- | A module import in an externs file

68data ExternsImport = ExternsImport

69data ExternsImport = ExternsImport

69 {

70 {

70− -- ^ The imported module

71+ -- | The imported module

71 eiModule :: ModuleName

72 eiModule :: ModuleName

72− -- ^ The import type: regular, qualified or hiding

73+ -- | The import type: regular, qualified or hiding

73 , eiImportType :: ImportDeclarationType

74 , eiImportType :: ImportDeclarationType

74− -- ^ The imported-as name, for qualified imports

75+ -- | The imported-as name, for qualified imports

75 , eiImportedAs :: Maybe ModuleName

76 , eiImportedAs :: Maybe ModuleName

76 } deriving (Show, Read)

77 } deriving (Show, Read)

78-- | A fixity declaration in an externs file

79-- | A fixity declaration in an externs file

79data ExternsFixity = ExternsFixity

80data ExternsFixity = ExternsFixity

80 {

81 {

81− -- ^ The associativity of the operator

82+ -- | The associativity of the operator

82 efAssociativity :: Associativity

83 efAssociativity :: Associativity

83− -- ^ The precedence level of the operator

84+ -- | The precedence level of the operator

84 , efPrecedence :: Precedence

85 , efPrecedence :: Precedence

85− -- ^ The operator symbol

86+ -- | The operator symbol

86 , efOperator :: String

87 , efOperator :: String

87 } deriving (Show, Read)

88 } deriving (Show, Read)

89-- | A type or value declaration appearing in an externs file

90-- | A type or value declaration appearing in an externs file

90data ExternsDeclaration =

91data ExternsDeclaration =

91− -- ^ A type declaration

92+ -- | A type declaration

92 EDType

93 EDType

93 { edTypeName :: ProperName

94 { edTypeName :: ProperName

94 , edTypeKind :: Kind

95 , edTypeKind :: Kind

95 , edTypeDeclarationKind :: TypeKind

96 , edTypeDeclarationKind :: TypeKind

96 }

97 }

97− -- ^ A type synonym

98+ -- | A type synonym

98 | EDTypeSynonym

99 | EDTypeSynonym

99 { edTypeSynonymName :: ProperName

100 { edTypeSynonymName :: ProperName

100 , edTypeSynonymArguments :: [(String, Maybe Kind)]

101 , edTypeSynonymArguments :: [(String, Maybe Kind)]

101 , edTypeSynonymType :: Type

102 , edTypeSynonymType :: Type

102 }

103 }

103− -- ^ A data construtor

104+ -- | A data construtor

104 | EDDataConstructor

105 | EDDataConstructor

105 { edDataCtorName :: ProperName

106 { edDataCtorName :: ProperName

106 , edDataCtorOrigin :: DataDeclType

107 , edDataCtorOrigin :: DataDeclType

@@ -108,19 +109,19 @@ data ExternsDeclaration =

108 , edDataCtorType :: Type

109 , edDataCtorType :: Type

109 , edDataCtorFields :: [Ident]

110 , edDataCtorFields :: [Ident]

110 }

111 }

111− -- ^ A value declaration

112+ -- | A value declaration

112 | EDValue

113 | EDValue

113 { edValueName :: Ident

114 { edValueName :: Ident

114 , edValueType :: Type

115 , edValueType :: Type

115 }

116 }

116− -- ^ A type class declaration

117+ -- | A type class declaration

117 | EDClass

118 | EDClass

118 { edClassName :: ProperName

119 { edClassName :: ProperName

119 , edClassTypeArguments :: [(String, Maybe Kind)]

120 , edClassTypeArguments :: [(String, Maybe Kind)]

120 , edClassMembers :: [(Ident, Type)]

121 , edClassMembers :: [(Ident, Type)]

121 , edClassConstraints :: [Constraint]

122 , edClassConstraints :: [Constraint]

122 }

123 }

123− -- ^ An instance declaration

124+ -- | An instance declaration

124 | EDInstance

125 | EDInstance

125 { edInstanceClassName :: Qualified ProperName

126 { edInstanceClassName :: Qualified ProperName

126 , edInstanceName :: Ident

127 , edInstanceName :: Ident

@@ -152,7 +153,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar

152

153

153-- | Generate an externs file for all declarations in a module

154-- | Generate an externs file for all declarations in a module

154moduleToExternsFile :: Module -> Environment -> ExternsFile

155moduleToExternsFile :: Module -> Environment -> ExternsFile

155−moduleToExternsFile (Module _ _ _ _ Nothing) _ = error "moduleToExternsFile: module exports were not elaborated"

156+moduleToExternsFile (Module _ _ _ _ Nothing) _ = internalError "moduleToExternsFile: module exports were not elaborated"

156moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

157moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

157 where

158 where

158 efVersion = showVersion Paths.version

159 efVersion = showVersion Paths.version

@@ -181,7 +182,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

181 toExternsDeclaration (PositionedDeclarationRef _ _ r) = toExternsDeclaration r

182 toExternsDeclaration (PositionedDeclarationRef _ _ r) = toExternsDeclaration r

182 toExternsDeclaration (TypeRef pn dctors) =

183 toExternsDeclaration (TypeRef pn dctors) =

183 case Qualified (Just mn) pn `M.lookup` types env of

184 case Qualified (Just mn) pn `M.lookup` types env of

184− Nothing -> error "toExternsDeclaration: no kind in toExternsDeclaration"

185+ Nothing -> internalError "toExternsDeclaration: no kind in toExternsDeclaration"

185 Just (kind, TypeSynonym)

186 Just (kind, TypeSynonym)

186 | Just (args, synTy) <- Qualified (Just mn) pn `M.lookup` typeSynonyms env -> [ EDType pn kind TypeSynonym, EDTypeSynonym pn args synTy ]

187 | Just (args, synTy) <- Qualified (Just mn) pn `M.lookup` typeSynonyms env -> [ EDType pn kind TypeSynonym, EDTypeSynonym pn args synTy ]

187 Just (kind, ExternData) -> [ EDType pn kind ExternData ]

188 Just (kind, ExternData) -> [ EDType pn kind ExternData ]

@@ -190,7 +191,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

190 | dctor <- fromMaybe (map fst tys) dctors

191 | dctor <- fromMaybe (map fst tys) dctors

191 , (dty, _, ty, args) <- maybeToList (M.lookup (Qualified (Just mn) dctor) (dataConstructors env))

192 , (dty, _, ty, args) <- maybeToList (M.lookup (Qualified (Just mn) dctor) (dataConstructors env))

192 ]

193 ]

193− _ -> error "toExternsDeclaration: Invalid input"

194+ _ -> internalError "toExternsDeclaration: Invalid input"

194 toExternsDeclaration (ValueRef ident)

195 toExternsDeclaration (ValueRef ident)

195 | Just (ty, _, _) <- (mn, ident) `M.lookup` names env

196 | Just (ty, _, _) <- (mn, ident) `M.lookup` names env

196 = [ EDValue ident ty ]

197 = [ EDValue ident ty ]

src/Language/PureScript/Linter.hs+2−1

@@ -30,6 +30,7 @@ import Control.Applicative

30#endif

31import Control.Monad.Writer.Class

33+import Language.PureScript.Crash

33import Language.PureScript.AST

34import Language.PureScript.AST

34import Language.PureScript.Names

35import Language.PureScript.Names

35import Language.PureScript.Errors

36import Language.PureScript.Errors

@@ -50,7 +51,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl

50 getDeclIdent (ValueDeclaration ident _ _ _) = Just ident

51 getDeclIdent (ValueDeclaration ident _ _ _) = Just ident

51 getDeclIdent (ExternDeclaration ident _) = Just ident

52 getDeclIdent (ExternDeclaration ident _) = Just ident

52 getDeclIdent (TypeInstanceDeclaration ident _ _ _ _) = Just ident

53 getDeclIdent (TypeInstanceDeclaration ident _ _ _ _) = Just ident

53− getDeclIdent (BindingGroupDeclaration _) = error "lint: binding groups should not be desugared yet."

54+ getDeclIdent (BindingGroupDeclaration _) = internalError "lint: binding groups should not be desugared yet."

54 getDeclIdent _ = Nothing

55 getDeclIdent _ = Nothing

56 lintDeclaration :: Declaration -> m ()

57 lintDeclaration :: Declaration -> m ()

src/Language/PureScript/Linter/Exhaustive.hs+4−3

@@ -38,6 +38,7 @@ import Control.Applicative

38import Control.Arrow (first, second)

39import Control.Monad.Writer.Class

41+import Language.PureScript.Crash

41import Language.PureScript.AST.Binders

42import Language.PureScript.AST.Binders

42import Language.PureScript.AST.Declarations

43import Language.PureScript.AST.Declarations

43import Language.PureScript.Environment

44import Language.PureScript.Environment

@@ -92,7 +93,7 @@ getConstructors env defmn n = extractConstructors lnte

93 extractConstructors :: Maybe (Kind, TypeKind) -> [(ProperName, [Type])]

94 extractConstructors :: Maybe (Kind, TypeKind) -> [(ProperName, [Type])]

94 extractConstructors (Just (_, DataType _ pt)) = pt

95 extractConstructors (Just (_, DataType _ pt)) = pt

95− extractConstructors _ = error "Data name not in the scope of the current environment in extractConstructors"

96+ extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors"

97-- |

98-- |

98-- Replicates a wildcard binder

99-- Replicates a wildcard binder

@@ -197,7 +198,7 @@ missingCasesMultiple env mn = go

197 where

198 where

198 (miss1, pr1) = missingCasesSingle env mn x y

199 (miss1, pr1) = missingCasesSingle env mn x y

199 (miss2, pr2) = go xs ys

200 (miss2, pr2) = go xs ys

200− go _ _ = error "Argument lengths did not match in missingCasesMultiple."

201+ go _ _ = internalError "Argument lengths did not match in missingCasesMultiple."

201

202

202-- |

203-- |

203-- Guard handling

204-- Guard handling

@@ -245,7 +246,7 @@ checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([init

245 step :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedudancyError Bool, [[Binder]]))

246 step :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedudancyError Bool, [[Binder]]))

246 step (uncovered, (nec, redundant)) ca =

247 step (uncovered, (nec, redundant)) ca =

247 let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered)

248 let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered)

248− (missed', approx) = splitAt 10000 (concat missed)

249+ (missed', approx) = splitAt 10000 (nub (concat missed))

249 cond = liftA2 (&&) (or <$> sequenceA pr) nec

250 cond = liftA2 (&&) (or <$> sequenceA pr) nec

250 in (missed', ( if null approx

251 in (missed', ( if null approx

251 then cond

252 then cond

src/Language/PureScript/Make.hs+35−33

@@ -43,9 +43,10 @@ import Control.Applicative

43#endif

44import Control.Monad

45import Control.Monad.Error.Class (MonadError(..))

46+import Control.Monad.Writer.Class (MonadWriter(..))

46import Control.Monad.Trans.Except

47import Control.Monad.Trans.Except

47import Control.Monad.Reader

48import Control.Monad.Reader

48−import Control.Monad.Writer.Strict

49+import Control.Monad.Logger

49import Control.Monad.Supply

50import Control.Monad.Supply

50import Control.Monad.Base (MonadBase(..))

51import Control.Monad.Base (MonadBase(..))

51import Control.Monad.Trans.Control (MonadBaseControl(..))

52import Control.Monad.Trans.Control (MonadBaseControl(..))

@@ -58,6 +59,7 @@ import Data.Time.Clock

58import Data.String (fromString)

59import Data.String (fromString)

59import Data.Foldable (for_)

60import Data.Foldable (for_)

60#if __GLASGOW_HASKELL__ < 710

61#if __GLASGOW_HASKELL__ < 710

62+import Data.Monoid (mempty, mconcat)

61import Data.Traversable (traverse)

63import Data.Traversable (traverse)

62#endif

64#endif

63import Data.Traversable (for)

65import Data.Traversable (for)

@@ -72,6 +74,7 @@ import System.Directory

72import System.FilePath ((</>), takeDirectory)

74import System.FilePath ((</>), takeDirectory)

73import System.IO.Error (tryIOError)

75import System.IO.Error (tryIOError)

77+import Language.PureScript.Crash

75import Language.PureScript.AST

78import Language.PureScript.AST

76import Language.PureScript.Externs

79import Language.PureScript.Externs

77import Language.PureScript.Environment

80import Language.PureScript.Environment

@@ -166,7 +169,7 @@ make MakeActions{..} ms = do

166 barriers <- zip (map getModuleName sorted) <$> replicateM (length ms) ((,) <$> C.newEmptyMVar <*> C.newEmptyMVar)

169 barriers <- zip (map getModuleName sorted) <$> replicateM (length ms) ((,) <$> C.newEmptyMVar <*> C.newEmptyMVar)

167

170

168 for_ sorted $ \m -> fork $ do

171 for_ sorted $ \m -> fork $ do

169− let deps = fromMaybe (error "make: module not found in dependency graph.") (lookup (getModuleName m) graph)

172+ let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup (getModuleName m) graph)

170 buildModule barriers (importPrim m) (deps `inOrderOf` map getModuleName sorted)

173 buildModule barriers (importPrim m) (deps `inOrderOf` map getModuleName sorted)

171

174

172 -- Wait for all threads to complete, and collect errors.

175 -- Wait for all threads to complete, and collect errors.

@@ -176,8 +179,7 @@ make MakeActions{..} ms = do

176 unless (null errors) $ throwError (mconcat errors)

179 unless (null errors) $ throwError (mconcat errors)

177

180

178 -- Bundle up all the externs and return them as an Environment

181 -- Bundle up all the externs and return them as an Environment

179− (warnings, externs) <- unzip . fromMaybe (error "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd)

182+ (_, externs) <- unzip . fromMaybe (internalError "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd)

180− tell (mconcat warnings)

181 return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment externs

183 return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment externs

182

184

183 where

185 where

@@ -205,21 +207,21 @@ make MakeActions{..} ms = do

205 -- We need to wait for dependencies to be built, before checking if the current

207 -- We need to wait for dependencies to be built, before checking if the current

206 -- module should be rebuilt, so the first thing to do is to wait on the

208 -- module should be rebuilt, so the first thing to do is to wait on the

207 -- MVars for the module's dependencies.

209 -- MVars for the module's dependencies.

208− mexterns <- fmap unzip . sequence <$> mapM (readMVar . fst . fromMaybe (error "make: no barrier") . flip lookup barriers) deps

210+ mexterns <- fmap unzip . sequence <$> mapM (readMVar . fst . fromMaybe (internalError "make: no barrier") . flip lookup barriers) deps

209

211

212+ case mexterns of

213+ Just (_, externs) -> do

210− outputTimestamp <- getOutputTimestamp moduleName

214+ outputTimestamp <- getOutputTimestamp moduleName

211− dependencyTimestamp <- maximumMaybe <$> mapM (fmap shouldExist . getOutputTimestamp) deps

215+ dependencyTimestamp <- maximumMaybe <$> mapM (fmap shouldExist . getOutputTimestamp) deps

212− inputTimestamp <- getInputTimestamp moduleName

216+ inputTimestamp <- getInputTimestamp moduleName

213

217

214− let shouldRebuild = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of

218+ let shouldRebuild = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of

215− (Right (Just t1), Just t3, Just t2) -> t1 > t2 || t3 > t2

219+ (Right (Just t1), Just t3, Just t2) -> t1 > t2 || t3 > t2

216− (Right (Just t1), Nothing, Just t2) -> t1 > t2

220+ (Right (Just t1), Nothing, Just t2) -> t1 > t2

217− (Left RebuildNever, _, Just _) -> False

221+ (Left RebuildNever, _, Just _) -> False

218− _ -> True

222+ _ -> True

219

223

220− let rebuild =

224+ let rebuild = do

221− case mexterns of

222− Just (_, externs) -> do

223 (exts, warnings) <- listen $ do

225 (exts, warnings) <- listen $ do

224 progress $ CompilingModule moduleName

226 progress $ CompilingModule moduleName

225 let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs

227 let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs

@@ -235,20 +237,20 @@ make MakeActions{..} ms = do

235 evalSupplyT nextVar $ codegen renamed env' $ encode exts

237 evalSupplyT nextVar $ codegen renamed env' $ encode exts

236 return exts

238 return exts

237 markComplete (Just (warnings, exts)) Nothing

239 markComplete (Just (warnings, exts)) Nothing

238− Nothing -> markComplete Nothing Nothing

240+

239−

240− if shouldRebuild

241+ if shouldRebuild

241− then rebuild

242+ then rebuild

242− else do

243+ else do

243− mexts <- decodeExterns . snd <$> readExterns moduleName

244+ mexts <- decodeExterns . snd <$> readExterns moduleName

244− case mexts of

245+ case mexts of

245− Just exts -> markComplete (Just (mempty, exts)) Nothing

246+ Just exts -> markComplete (Just (mempty, exts)) Nothing

246− Nothing -> rebuild

247+ Nothing -> rebuild

248+ Nothing -> markComplete Nothing Nothing

247 where

249 where

248 markComplete :: Maybe (MultipleErrors, ExternsFile) -> Maybe MultipleErrors -> m ()

250 markComplete :: Maybe (MultipleErrors, ExternsFile) -> Maybe MultipleErrors -> m ()

249 markComplete externs errors = do

251 markComplete externs errors = do

250− putMVar (fst $ fromMaybe (error "make: no barrier") $ lookup moduleName barriers) externs

252+ putMVar (fst $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) externs

251− putMVar (snd $ fromMaybe (error "make: no barrier") $ lookup moduleName barriers) errors

253+ putMVar (snd $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) errors

252

254

253 maximumMaybe :: (Ord a) => [a] -> Maybe a

255 maximumMaybe :: (Ord a) => [a] -> Maybe a

254 maximumMaybe [] = Nothing

256 maximumMaybe [] = Nothing

@@ -257,7 +259,7 @@ make MakeActions{..} ms = do

257 -- Make sure a dependency exists

259 -- Make sure a dependency exists

258 shouldExist :: Maybe UTCTime -> UTCTime

260 shouldExist :: Maybe UTCTime -> UTCTime

259 shouldExist (Just t) = t

261 shouldExist (Just t) = t

260− shouldExist _ = error "make: dependency should already have been built."

262+ shouldExist _ = internalError "make: dependency should already have been built."

261

263

262 decodeExterns :: B.ByteString -> Maybe ExternsFile

264 decodeExterns :: B.ByteString -> Maybe ExternsFile

263 decodeExterns bs = do

265 decodeExterns bs = do

@@ -283,22 +285,22 @@ importPrim = addDefaultImport (ModuleName [ProperName C.prim])

283-- |

285-- |

284-- A monad for running make actions

286-- A monad for running make actions

285--

287--

286−newtype Make a = Make { unMake :: ReaderT Options (WriterT MultipleErrors (ExceptT MultipleErrors IO)) a }

288+newtype Make a = Make { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a }

287 deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)

289 deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)

288

290

289instance MonadBase IO Make where

291instance MonadBase IO Make where

290 liftBase = liftIO

292 liftBase = liftIO

291

293

292instance MonadBaseControl IO Make where

294instance MonadBaseControl IO Make where

293− type StM Make a = Either MultipleErrors (a, MultipleErrors)

295+ type StM Make a = Either MultipleErrors a

294 liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake)

296 liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake)

295 restoreM = Make . restoreM

297 restoreM = Make . restoreM

296

298

297-- |

299-- |

298-- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.

300-- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.

299--

301--

300−runMake :: Options -> Make a -> IO (Either MultipleErrors (a, MultipleErrors))

302+runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors)

301−runMake opts = runExceptT . runWriterT . flip runReaderT opts . unMake

303+runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake

302

304

303makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a

305makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a

304makeIO f io = do

306makeIO f io = do

@@ -324,7 +326,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

324

326

325 getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))

327 getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))

326 getInputTimestamp mn = do

328 getInputTimestamp mn = do

327− let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap

329+ let path = fromMaybe (internalError "Module has no filename in 'make'") $ M.lookup mn filePathMap

328 e1 <- traverseEither getTimestamp path

330 e1 <- traverseEither getTimestamp path

329 fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns

331 fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns

330 return $ fmap (max fPath) e1

332 return $ fmap (max fPath) e1

src/Language/PureScript/ModuleDependencies.hs+2−1

@@ -25,6 +25,7 @@ import Data.Graph

25import Data.List (nub)

26import Data.Maybe (fromMaybe, mapMaybe)

28+import Language.PureScript.Crash

28import Language.PureScript.AST

29import Language.PureScript.AST

29import Language.PureScript.Names

30import Language.PureScript.Names

30import Language.PureScript.Types

31import Language.PureScript.Types

@@ -43,7 +44,7 @@ sortModules ms = do

43 ms' <- mapM toModule $ stronglyConnComp verts

44 ms' <- mapM toModule $ stronglyConnComp verts

44 let (graph, fromVertex, toVertex) = graphFromEdges verts

45 let (graph, fromVertex, toVertex) = graphFromEdges verts

45 moduleGraph = do (_, mn, _) <- verts

46 moduleGraph = do (_, mn, _) <- verts

46− let v = fromMaybe (error "sortModules: vertex not found") (toVertex mn)

47+ let v = fromMaybe (internalError "sortModules: vertex not found") (toVertex mn)

47 deps = reachable graph v

48 deps = reachable graph v

48 toKey i = case fromVertex i of (_, key, _) -> key

49 toKey i = case fromVertex i of (_, key, _) -> key

49 return (mn, filter (/= mn) (map toKey deps))

50 return (mn, filter (/= mn) (map toKey deps))

src/Language/PureScript/Parser/Declarations.hs+1−1

@@ -201,7 +201,7 @@ parseTypeClassDeclaration = do

201 idents <- P.many (indented *> kindedIdent)

202 members <- P.option [] . P.try $ do

203 indented *> reserved "where"

204− mark (P.many (same *> positioned parseTypeDeclaration))

204+ indented *> mark (P.many (same *> positioned parseTypeDeclaration))

205 return $ TypeClassDeclaration className idents implies members

206

207parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration)

src/Language/PureScript/Pretty/JS.hs+3−2

@@ -30,6 +30,7 @@ import Control.Monad.State

30import Control.PatternArrows

31import qualified Control.Arrow as A

33+import Language.PureScript.Crash

33import Language.PureScript.CodeGen.JS.AST

34import Language.PureScript.CodeGen.JS.AST

34import Language.PureScript.CodeGen.JS.Common

35import Language.PureScript.CodeGen.JS.Common

35import Language.PureScript.Pretty.Common

36import Language.PureScript.Pretty.Common

@@ -251,13 +252,13 @@ prettyStatements sts = do

251-- Generate a pretty-printed string representing a Javascript expression

252-- Generate a pretty-printed string representing a Javascript expression

252--

253--

253prettyPrintJS1 :: JS -> String

254prettyPrintJS1 :: JS -> String

254−prettyPrintJS1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'

255+prettyPrintJS1 = fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'

255

256

256-- |

257-- |

257-- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level

258-- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level

258--

259--

259prettyPrintJS :: [JS] -> String

260prettyPrintJS :: [JS] -> String

260−prettyPrintJS = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements

261+prettyPrintJS = fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements

261

262

262-- |

263-- |

263-- Generate an indented, pretty-printed string representing a Javascript expression

264-- Generate an indented, pretty-printed string representing a Javascript expression

src/Language/PureScript/Pretty/Kinds.hs+2−1

@@ -22,6 +22,7 @@ import Data.Maybe (fromMaybe)

22import Control.Arrow (ArrowPlus(..))

23import Control.PatternArrows

25+import Language.PureScript.Crash

25import Language.PureScript.Kinds

26import Language.PureScript.Kinds

26import Language.PureScript.Pretty.Common

27import Language.PureScript.Pretty.Common

@@ -47,7 +48,7 @@ funKind = mkPattern match

48-- | Generate a pretty-printed string representing a Kind

49-- | Generate a pretty-printed string representing a Kind

49prettyPrintKind :: Kind -> String

50prettyPrintKind :: Kind -> String

50−prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind ()

51+prettyPrintKind = fromMaybe (internalError "Incomplete pattern") . pattern matchKind ()

51 where

52 where

52 matchKind :: Pattern () Kind String

53 matchKind :: Pattern () Kind String

53 matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)

54 matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)

src/Language/PureScript/Pretty/Types.hs+13−6

@@ -27,6 +27,7 @@ import Data.Maybe (fromMaybe)

27import Control.Arrow ((<+>))

28import Control.PatternArrows

30+import Language.PureScript.Crash

30import Language.PureScript.Types

31import Language.PureScript.Types

31import Language.PureScript.Names

32import Language.PureScript.Names

32import Language.PureScript.Kinds

33import Language.PureScript.Kinds

@@ -45,14 +46,13 @@ typeLiterals = mkPattern match

45 match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor

46 match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor

46 match (TUnknown u) = Just $ text $ '_' : show u

47 match (TUnknown u) = Just $ text $ '_' : show u

47 match (Skolem name s _) = Just $ text $ name ++ show s

48 match (Skolem name s _) = Just $ text $ name ++ show s

48− match (ConstrainedType deps ty) = Just $ constraintsAsBox deps ty

49 match REmpty = Just $ text "()"

50 match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row

51 match _ = Nothing

53−constraintsAsBox :: [(Qualified ProperName, [Type])] -> Type -> Box

53+constraintsAsBox :: [(Qualified ProperName, [Type])] -> Box -> Box

54−constraintsAsBox [(pn, tys)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> typeAsBox ty

54+constraintsAsBox [(pn, tys)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> ty

55−constraintsAsBox xs ty = vcat left (zipWith (\i (pn, tys) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> typeAsBox ty)

55+constraintsAsBox xs ty = vcat left (zipWith (\i (pn, tys) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> ty)

57constraintAsBox :: Qualified ProperName -> [Type] -> Box

58constraintAsBox pn tys = hsep 1 left (text (runProperName (disqualify pn)) : map typeAtomAsBox tys)

@@ -114,6 +114,12 @@ insertPlaceholders = everywhereOnTypesTopDown convertForAlls . everywhereOnTypes

114 go idents other = PrettyPrintForAll idents other

115 convertForAlls other = other

116

117+constrained :: Pattern () Type ([Constraint], Type)

118+constrained = mkPattern match

119+ where

120+ match (ConstrainedType deps ty) = Just (deps, ty)

121+ match _ = Nothing

122+

117matchTypeAtom :: Pattern () Type Box

123matchTypeAtom :: Pattern () Type Box

118matchTypeAtom = typeLiterals <+> fmap ((`before` text ")") . (text "(" <>)) matchType

124matchTypeAtom = typeLiterals <+> fmap ((`before` text ")") . (text "(" <>)) matchType

119

125

@@ -125,6 +131,7 @@ matchType = buildPrettyPrinter operators matchTypeAtom

125 OperatorTable [ [ AssocL typeApp $ \f x -> f `beforeWithSpace` x ]

131 OperatorTable [ [ AssocL typeApp $ \f x -> f `beforeWithSpace` x ]

126 , [ AssocR appliedFunction $ \arg ret -> (arg <> text " ") `before` (text "-> " <> ret)

132 , [ AssocR appliedFunction $ \arg ret -> (arg <> text " ") `before` (text "-> " <> ret)

127 ]

133 ]

134+ , [ Wrap constrained $ \deps ty -> constraintsAsBox deps ty ]

128 , [ Wrap forall_ $ \idents ty -> text ("forall " ++ unwords idents ++ ". ") <> ty ]

135 , [ Wrap forall_ $ \idents ty -> text ("forall " ++ unwords idents ++ ". ") <> ty ]

129 , [ Wrap kinded $ \k ty -> ty `before` (text (" :: " ++ prettyPrintKind k)) ]

136 , [ Wrap kinded $ \k ty -> ty `before` (text (" :: " ++ prettyPrintKind k)) ]

130 ]

137 ]

@@ -136,14 +143,14 @@ forall_ = mkPattern match

136 match _ = Nothing

143 match _ = Nothing

137

144

138typeAtomAsBox :: Type -> Box

145typeAtomAsBox :: Type -> Box

139−typeAtomAsBox = fromMaybe (error "Incomplete pattern") . pattern matchTypeAtom () . insertPlaceholders

146+typeAtomAsBox = fromMaybe (internalError "Incomplete pattern") . pattern matchTypeAtom () . insertPlaceholders

140

147

141-- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses

148-- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses

142prettyPrintTypeAtom :: Type -> String

149prettyPrintTypeAtom :: Type -> String

143prettyPrintTypeAtom = render . typeAtomAsBox

150prettyPrintTypeAtom = render . typeAtomAsBox

144

151

145typeAsBox :: Type -> Box

152typeAsBox :: Type -> Box

146−typeAsBox = fromMaybe (error "Incomplete pattern") . pattern matchType () . insertPlaceholders

153+typeAsBox = fromMaybe (internalError "Incomplete pattern") . pattern matchType () . insertPlaceholders

147

154

148-- | Generate a pretty-printed string representing a Type

155-- | Generate a pretty-printed string representing a Type

149prettyPrintType :: Type -> String

156prettyPrintType :: Type -> String

src/Language/PureScript/Pretty/Values.hs+2−1

@@ -25,6 +25,7 @@ import Data.List (intercalate)

26import Control.Arrow (second)

28+import Language.PureScript.Crash

28import Language.PureScript.AST

29import Language.PureScript.AST

29import Language.PureScript.Names

30import Language.PureScript.Names

30import Language.PureScript.Pretty.Common

31import Language.PureScript.Pretty.Common

@@ -103,7 +104,7 @@ prettyPrintDeclaration (BindingGroupDeclaration ds) =

103 where

104 where

104 toDecl (nm, t, e) = ValueDeclaration nm t [] (Right e)

105 toDecl (nm, t, e) = ValueDeclaration nm t [] (Right e)

105prettyPrintDeclaration (PositionedDeclaration _ _ d) = prettyPrintDeclaration d

106prettyPrintDeclaration (PositionedDeclaration _ _ d) = prettyPrintDeclaration d

106−prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"

107+prettyPrintDeclaration _ = internalError "Invalid argument to prettyPrintDeclaration"

107

108

108prettyPrintCaseAlternative :: CaseAlternative -> Box

109prettyPrintCaseAlternative :: CaseAlternative -> Box

109prettyPrintCaseAlternative (CaseAlternative binders result) =

110prettyPrintCaseAlternative (CaseAlternative binders result) =

src/Language/PureScript/Sugar/BindingGroups.hs+17−15

@@ -16,6 +16,7 @@

17{-# LANGUAGE FlexibleContexts #-}

18{-# LANGUAGE CPP #-}

19+{-# LANGUAGE ScopedTypeVariables #-}

20module Language.PureScript.Sugar.BindingGroups (

21module Language.PureScript.Sugar.BindingGroups (

21 createBindingGroups,

22 createBindingGroups,

@@ -28,6 +29,7 @@ import Data.Graph

28import Data.List (nub, intersect)

29import Data.List (nub, intersect)

29import Data.Maybe (isJust, mapMaybe)

30import Data.Maybe (isJust, mapMaybe)

30#if __GLASGOW_HASKELL__ < 710

31#if __GLASGOW_HASKELL__ < 710

32+import Data.Foldable (foldMap)

31import Control.Applicative

33import Control.Applicative

32#endif

34#endif

33import Control.Monad ((<=<))

35import Control.Monad ((<=<))

@@ -35,6 +37,7 @@ import Control.Monad.Error.Class (MonadError(..))

36import qualified Data.Set as S

38import qualified Data.Set as S

40+import Language.PureScript.Crash

38import Language.PureScript.AST

41import Language.PureScript.AST

39import Language.PureScript.Names

42import Language.PureScript.Names

40import Language.PureScript.Types

43import Language.PureScript.Types

@@ -53,20 +56,20 @@ createBindingGroupsModule = mapM $ \(Module ss coms name ds exps) -> Module ss c

53collapseBindingGroupsModule :: [Module] -> [Module]

56collapseBindingGroupsModule :: [Module] -> [Module]

54collapseBindingGroupsModule = map $ \(Module ss coms name ds exps) -> Module ss coms name (collapseBindingGroups ds) exps

57collapseBindingGroupsModule = map $ \(Module ss coms name ds exps) -> Module ss coms name (collapseBindingGroups ds) exps

56−createBindingGroups :: (Functor m, Applicative m, MonadError MultipleErrors m) => ModuleName -> [Declaration] -> m [Declaration]

59+createBindingGroups :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m) => ModuleName -> [Declaration] -> m [Declaration]

57createBindingGroups moduleName = mapM f <=< handleDecls

60createBindingGroups moduleName = mapM f <=< handleDecls

59 where

62 where

60 (f, _, _) = everywhereOnValuesTopDownM return handleExprs return

63 (f, _, _) = everywhereOnValuesTopDownM return handleExprs return

62− handleExprs :: (Functor m, MonadError MultipleErrors m) => Expr -> m Expr

65+ handleExprs :: Expr -> m Expr

63 handleExprs (Let ds val) = flip Let val <$> handleDecls ds

66 handleExprs (Let ds val) = flip Let val <$> handleDecls ds

64 handleExprs other = return other

67 handleExprs other = return other

66 -- |

69 -- |

67 -- Replace all sets of mutually-recursive declarations with binding groups

70 -- Replace all sets of mutually-recursive declarations with binding groups

68 --

71 --

69− handleDecls :: (Functor m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

72+ handleDecls :: [Declaration] -> m [Declaration]

70 handleDecls ds = do

73 handleDecls ds = do

71 let values = filter isValueDecl ds

74 let values = filter isValueDecl ds

72 dataDecls = filter isDataDecl ds

75 dataDecls = filter isDataDecl ds

@@ -145,19 +148,19 @@ usedProperNames moduleName =

145getIdent :: Declaration -> Ident

148getIdent :: Declaration -> Ident

146getIdent (ValueDeclaration ident _ _ _) = ident

149getIdent (ValueDeclaration ident _ _ _) = ident

147getIdent (PositionedDeclaration _ _ d) = getIdent d

150getIdent (PositionedDeclaration _ _ d) = getIdent d

148−getIdent _ = error "Expected ValueDeclaration"

151+getIdent _ = internalError "Expected ValueDeclaration"

149

152

150getProperName :: Declaration -> ProperName

153getProperName :: Declaration -> ProperName

151getProperName (DataDeclaration _ pn _ _) = pn

154getProperName (DataDeclaration _ pn _ _) = pn

152getProperName (TypeSynonymDeclaration pn _ _) = pn

155getProperName (TypeSynonymDeclaration pn _ _) = pn

153getProperName (PositionedDeclaration _ _ d) = getProperName d

156getProperName (PositionedDeclaration _ _ d) = getProperName d

154−getProperName _ = error "Expected DataDeclaration"

157+getProperName _ = internalError "Expected DataDeclaration"

155

158

156-- |

159-- |

157-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).

160-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).

158--

161--

159--

162--

160−toBindingGroup :: (Functor m, MonadError MultipleErrors m) => ModuleName -> SCC Declaration -> m Declaration

163+toBindingGroup :: forall m. (Functor m, MonadError MultipleErrors m) => ModuleName -> SCC Declaration -> m Declaration

161toBindingGroup _ (AcyclicSCC d) = return d

164toBindingGroup _ (AcyclicSCC d) = return d

162toBindingGroup moduleName (CyclicSCC ds') =

165toBindingGroup moduleName (CyclicSCC ds') =

163 -- Once we have a mutually-recursive group of declarations, we need to sort

166 -- Once we have a mutually-recursive group of declarations, we need to sort

@@ -177,15 +180,14 @@ toBindingGroup moduleName (CyclicSCC ds') =

177 valueVerts :: [(Declaration, Ident, [Ident])]

180 valueVerts :: [(Declaration, Ident, [Ident])]

178 valueVerts = map (\d -> (d, getIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds'

181 valueVerts = map (\d -> (d, getIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds'

179

182

180− toBinding :: (MonadError MultipleErrors m) => SCC Declaration -> m (Ident, NameKind, Expr)

183+ toBinding :: SCC Declaration -> m (Ident, NameKind, Expr)

181 toBinding (AcyclicSCC d) = return $ fromValueDecl d

184 toBinding (AcyclicSCC d) = return $ fromValueDecl d

182− toBinding (CyclicSCC ~(d:ds)) = cycleError d ds

185+ toBinding (CyclicSCC ds) = throwError $ foldMap cycleError ds

183

186

184− cycleError :: (MonadError MultipleErrors m) => Declaration -> [Declaration] -> m a

187+ cycleError :: Declaration -> MultipleErrors

185− cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds

188+ cycleError (PositionedDeclaration p _ d) = onErrorMessages (withPosition p) $ cycleError d

186− cycleError (ValueDeclaration n _ _ (Right _)) [] = throwError . errorMessage $ CycleInDeclaration n

189+ cycleError (ValueDeclaration n _ _ (Right _)) = errorMessage $ CycleInDeclaration n

187− cycleError d ds@(_:_) = rethrow (addHint (NotYetDefined (map getIdent ds))) $ cycleError d []

188− cycleError _ _ = error "Expected ValueDeclaration"

190+ cycleError _ = internalError "cycleError: Expected ValueDeclaration"

189

191

190toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration

192toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration

191toDataBindingGroup (AcyclicSCC d) = return d

193toDataBindingGroup (AcyclicSCC d) = return d

@@ -203,6 +205,6 @@ isTypeSynonym _ = Nothing

203

205

204fromValueDecl :: Declaration -> (Ident, NameKind, Expr)

206fromValueDecl :: Declaration -> (Ident, NameKind, Expr)

205fromValueDecl (ValueDeclaration ident nameKind [] (Right val)) = (ident, nameKind, val)

207fromValueDecl (ValueDeclaration ident nameKind [] (Right val)) = (ident, nameKind, val)

206−fromValueDecl ValueDeclaration{} = error "Binders should have been desugared"

208+fromValueDecl ValueDeclaration{} = internalError "Binders should have been desugared"

207fromValueDecl (PositionedDeclaration _ _ d) = fromValueDecl d

209fromValueDecl (PositionedDeclaration _ _ d) = fromValueDecl d

208−fromValueDecl _ = error "Expected ValueDeclaration"

210+fromValueDecl _ = internalError "Expected ValueDeclaration"

src/Language/PureScript/Sugar/CaseDeclarations.hs+3−2

@@ -23,6 +23,7 @@ module Language.PureScript.Sugar.CaseDeclarations (

23 desugarCasesModule

24) where

26+import Language.PureScript.Crash

26import Data.Maybe (catMaybes)

27import Data.Maybe (catMaybes)

27import Data.List (nub, groupBy)

28import Data.List (nub, groupBy)

@@ -112,7 +113,7 @@ toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs =

112 fromVarBinder (VarBinder name) = return name

113 fromVarBinder (VarBinder name) = return name

113 fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b

114 fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b

114 fromVarBinder (TypedBinder _ b) = fromVarBinder b

115 fromVarBinder (TypedBinder _ b) = fromVarBinder b

115− fromVarBinder _ = error "fromVarBinder: Invalid argument"

116+ fromVarBinder _ = internalError "fromVarBinder: Invalid argument"

116toDecls ds@(ValueDeclaration ident _ bs result : _) = do

117toDecls ds@(ValueDeclaration ident _ bs result : _) = do

117 let tuples = map toTuple ds

118 let tuples = map toTuple ds

118 unless (all ((== length bs) . length . fst) tuples) $

119 unless (all ((== length bs) . length . fst) tuples) $

@@ -129,7 +130,7 @@ toDecls ds = return ds

129toTuple :: Declaration -> ([Binder], Either [(Guard, Expr)] Expr)

130toTuple :: Declaration -> ([Binder], Either [(Guard, Expr)] Expr)

130toTuple (ValueDeclaration _ _ bs result) = (bs, result)

131toTuple (ValueDeclaration _ _ bs result) = (bs, result)

131toTuple (PositionedDeclaration _ _ d) = toTuple d

132toTuple (PositionedDeclaration _ _ d) = toTuple d

132−toTuple _ = error "Not a value declaration"

133+toTuple _ = internalError "Not a value declaration"

133

134

134makeCaseDeclaration :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration

135makeCaseDeclaration :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration

135makeCaseDeclaration ident alternatives = do

136makeCaseDeclaration ident alternatives = do

src/Language/PureScript/Sugar/DoNotation.hs+2−1

@@ -22,6 +22,7 @@ module Language.PureScript.Sugar.DoNotation (

22 desugarDoModule

23) where

25+import Language.PureScript.Crash

25import Language.PureScript.Names

26import Language.PureScript.Names

26import Language.PureScript.AST

27import Language.PureScript.AST

27import Language.PureScript.Errors

28import Language.PureScript.Errors

@@ -56,7 +57,7 @@ desugarDo d =

56 replace other = return other

57 replace other = return other

58 go :: [DoNotationElement] -> m Expr

59 go :: [DoNotationElement] -> m Expr

59− go [] = error "The impossible happened in desugarDo"

60+ go [] = internalError "The impossible happened in desugarDo"

60 go [DoNotationValue val] = return val

61 go [DoNotationValue val] = return val

61 go (DoNotationValue val : rest) = do

62 go (DoNotationValue val : rest) = do

62 rest' <- go rest

63 rest' <- go rest

src/Language/PureScript/Sugar/Names.hs+8−3

@@ -22,14 +22,16 @@ import Data.List (find, nub)

22import Data.Maybe (fromMaybe, mapMaybe)

24#if __GLASGOW_HASKELL__ < 710

25+import Data.Monoid (mempty)

25import Control.Applicative (Applicative(..), (<$>), (<*>))

26import Control.Applicative (Applicative(..), (<$>), (<*>))

26#endif

27#endif

27import Control.Monad

28import Control.Monad

28import Control.Monad.Error.Class (MonadError(..))

29import Control.Monad.Error.Class (MonadError(..))

29−import Control.Monad.Writer (MonadWriter(..))

30+import Control.Monad.Writer (MonadWriter(..), censor)

31import qualified Data.Map as M

32import qualified Data.Map as M

34+import Language.PureScript.Crash

33import Language.PureScript.AST

35import Language.PureScript.AST

34import Language.PureScript.Names

36import Language.PureScript.Names

35import Language.PureScript.Types

37import Language.PureScript.Types

@@ -46,10 +48,13 @@ import Language.PureScript.Sugar.Names.Exports

46--

48--

47desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

49desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

48desugarImports externs modules = do

50desugarImports externs modules = do

49− env <- foldM externsEnv primEnv externs

51+ env <- silence $ foldM externsEnv primEnv externs

50 env' <- foldM updateEnv env modules

52 env' <- foldM updateEnv env modules

51 mapM (renameInModule' env') modules

53 mapM (renameInModule' env') modules

52 where

54 where

55+ silence :: m a -> m a

56+ silence = censor (const mempty)

57+

53 -- | Create an environment from a collection of externs files

58 -- | Create an environment from a collection of externs files

54 externsEnv :: Env -> ExternsFile -> m Env

59 externsEnv :: Env -> ExternsFile -> m Env

55 externsEnv env ExternsFile{..} = do

60 externsEnv env ExternsFile{..} = do

@@ -99,7 +104,7 @@ desugarImports externs modules = do

99 renameInModule' :: Env -> Module -> m Module

104 renameInModule' :: Env -> Module -> m Module

100 renameInModule' env m@(Module _ _ mn _ _) =

105 renameInModule' env m@(Module _ _ mn _ _) =

101 rethrow (addHint (ErrorInModule mn)) $ do

106 rethrow (addHint (ErrorInModule mn)) $ do

102− let (_, imps, exps) = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn env

107+ let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env

103 elaborateImports imps <$> renameInModule env imps (elaborateExports exps m)

108 elaborateImports imps <$> renameInModule env imps (elaborateExports exps m)

104

109

105-- |

110-- |

src/Language/PureScript/Sugar/Names/Exports.hs+8−7

@@ -33,6 +33,7 @@ import Control.Monad.Error.Class (MonadError(..))

34import qualified Data.Map as M

36+import Language.PureScript.Crash

36import Language.PureScript.AST

37import Language.PureScript.AST

37import Language.PureScript.Names

38import Language.PureScript.Names

38import Language.PureScript.Errors

39import Language.PureScript.Errors

@@ -52,7 +53,7 @@ findExportable (Module _ _ mn ds _) =

52 where

53 where

53 go exps'' (TypeDeclaration name _) = exportValue exps'' name mn

54 go exps'' (TypeDeclaration name _) = exportValue exps'' name mn

54 go exps'' (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go exps'' d

55 go exps'' (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go exps'' d

55− go _ _ = error "Invalid declaration in TypeClassDeclaration"

56+ go _ _ = internalError "Invalid declaration in TypeClassDeclaration"

56 updateExports exps (DataDeclaration _ tn _ dcs) = exportType exps tn (map fst dcs) mn

57 updateExports exps (DataDeclaration _ tn _ dcs) = exportType exps tn (map fst dcs) mn

57 updateExports exps (TypeSynonymDeclaration tn _ _) = exportType exps tn [] mn

58 updateExports exps (TypeSynonymDeclaration tn _ _) = exportType exps tn [] mn

58 updateExports exps (ExternDataDeclaration tn _) = exportType exps tn [] mn

59 updateExports exps (ExternDataDeclaration tn _) = exportType exps tn [] mn

@@ -137,24 +138,24 @@ resolveExports env mn imps exps refs =

137 resolveTypeExports tctors dctors = map go tctors

138 resolveTypeExports tctors dctors = map go tctors

138 where

139 where

139 go :: Qualified ProperName -> ((ProperName, [ProperName]), ModuleName)

140 go :: Qualified ProperName -> ((ProperName, [ProperName]), ModuleName)

140− go (Qualified (Just mn'') name) = fromMaybe (error "Missing value in resolveTypeExports") $ do

141+ go (Qualified (Just mn'') name) = fromMaybe (internalError "Missing value in resolveTypeExports") $ do

141 exps' <- envModuleExports <$> mn'' `M.lookup` env

142 exps' <- envModuleExports <$> mn'' `M.lookup` env

142 ((_, dctors'), mnOrig) <- find (\((name', _), _) -> name == name') (exportedTypes exps')

143 ((_, dctors'), mnOrig) <- find (\((name', _), _) -> name == name') (exportedTypes exps')

143 let relevantDctors = mapMaybe (\(Qualified mn''' dctor) -> if mn''' == Just mnOrig then Just dctor else Nothing) dctors

144 let relevantDctors = mapMaybe (\(Qualified mn''' dctor) -> if mn''' == Just mnOrig then Just dctor else Nothing) dctors

144 return ((name, intersect relevantDctors dctors'), mnOrig)

145 return ((name, intersect relevantDctors dctors'), mnOrig)

145− go (Qualified Nothing _) = error "Unqualified value in resolveTypeExports"

146+ go (Qualified Nothing _) = internalError "Unqualified value in resolveTypeExports"

146

147

148

148 -- Looks up an imported class and re-qualifies it with the original module it

149 -- Looks up an imported class and re-qualifies it with the original module it

149 -- came from.

150 -- came from.

150 resolveClass :: Qualified ProperName -> (ProperName, ModuleName)

151 resolveClass :: Qualified ProperName -> (ProperName, ModuleName)

151− resolveClass className = splitQual $ fromMaybe (error "Missing value in resolveClass") $

152+ resolveClass className = splitQual $ fromMaybe (internalError "Missing value in resolveClass") $

152 resolve exportedTypeClasses className

153 resolve exportedTypeClasses className

153

154

154 -- Looks up an imported value and re-qualifies it with the original module it

155 -- Looks up an imported value and re-qualifies it with the original module it

155 -- came from.

156 -- came from.

156 resolveValue :: Qualified Ident -> (Ident, ModuleName)

157 resolveValue :: Qualified Ident -> (Ident, ModuleName)

157− resolveValue ident = splitQual $ fromMaybe (error "Missing value in resolveValue") $

158+ resolveValue ident = splitQual $ fromMaybe (internalError "Missing value in resolveValue") $

158 resolve exportedValues ident

159 resolve exportedValues ident

159

160

160 resolve :: (Eq a) => (Exports -> [(a, ModuleName)]) -> Qualified a -> Maybe (Qualified a)

161 resolve :: (Eq a) => (Exports -> [(a, ModuleName)]) -> Qualified a -> Maybe (Qualified a)

@@ -162,13 +163,13 @@ resolveExports env mn imps exps refs =

162 exps' <- envModuleExports <$> mn'' `M.lookup` env

163 exps' <- envModuleExports <$> mn'' `M.lookup` env

163 mn''' <- snd <$> find ((== a) . fst) (f exps')

164 mn''' <- snd <$> find ((== a) . fst) (f exps')

164 return $ Qualified (Just mn''') a

165 return $ Qualified (Just mn''') a

165− resolve _ _ = error "Unqualified value in resolve"

166+ resolve _ _ = internalError "Unqualified value in resolve"

166

167

167 -- A partial function that takes a qualified value and extracts the value and

168 -- A partial function that takes a qualified value and extracts the value and

168 -- qualified module components.

169 -- qualified module components.

169 splitQual :: Qualified a -> (a, ModuleName)

170 splitQual :: Qualified a -> (a, ModuleName)

170 splitQual (Qualified (Just mn'') a) = (a, mn'')

171 splitQual (Qualified (Just mn'') a) = (a, mn'')

171− splitQual _ = error "Unqualified value in splitQual"

172+ splitQual _ = internalError "Unqualified value in splitQual"

172

173

173-- |

174-- |

174-- Filters the full list of exportable values, types, and classes for a module

175-- Filters the full list of exportable values, types, and classes for a module

src/Language/PureScript/Sugar/Names/Imports.hs+7−6

@@ -34,6 +34,7 @@ import Control.Monad.Writer (MonadWriter(..), censor)

35import qualified Data.Map as M

37+import Language.PureScript.Crash

37import Language.PureScript.AST

38import Language.PureScript.AST

38import Language.PureScript.Names

39import Language.PureScript.Names

39import Language.PureScript.Errors

40import Language.PureScript.Errors

@@ -115,7 +116,7 @@ resolveImport currentModule importModule exps imps impQual =

115 checkImportExists UnknownImportTypeClass (fst `map` exportedTypeClasses exps) name

116 checkImportExists UnknownImportTypeClass (fst `map` exportedTypeClasses exps) name

116 --check (ModuleRef name) =

117 --check (ModuleRef name) =

117 -- checkImportExists (const UnknownModule) (exportedModules exps) name

118 -- checkImportExists (const UnknownModule) (exportedModules exps) name

118− check _ = error "Invalid argument to checkRefs"

119+ check _ = internalError "Invalid argument to checkRefs"

119

120

120 -- Check that an explicitly imported item exists in the module it is being imported from

121 -- Check that an explicitly imported item exists in the module it is being imported from

121 checkImportExists :: (Eq a) => (ModuleName -> a -> SimpleErrorMessage) -> [a] -> a -> m ()

122 checkImportExists :: (Eq a) => (ModuleName -> a -> SimpleErrorMessage) -> [a] -> a -> m ()

@@ -171,13 +172,13 @@ resolveImport currentModule importModule exps imps impQual =

171 importExplicit imp (TypeClassRef name) = do

172 importExplicit imp (TypeClassRef name) = do

172 typeClasses' <- updateImports (importedTypeClasses imp) runProperName (exportedTypeClasses exps) name

173 typeClasses' <- updateImports (importedTypeClasses imp) runProperName (exportedTypeClasses exps) name

173 return $ imp { importedTypeClasses = typeClasses' }

174 return $ imp { importedTypeClasses = typeClasses' }

174− importExplicit _ _ = error "Invalid argument to importExplicit"

175+ importExplicit _ _ = internalError "Invalid argument to importExplicit"

175

176

176 -- Find all exported data constructors for a given type

177 -- Find all exported data constructors for a given type

177 allExportedDataConstructors :: ProperName -> [(ProperName, ModuleName)]

178 allExportedDataConstructors :: ProperName -> [(ProperName, ModuleName)]

178 allExportedDataConstructors name =

179 allExportedDataConstructors name =

179 case find ((== name) . fst . fst) (exportedTypes exps) of

180 case find ((== name) . fst . fst) (exportedTypes exps) of

180− Nothing -> error "Invalid state in allExportedDataConstructors"

181+ Nothing -> internalError "Invalid state in allExportedDataConstructors"

181 Just ((_, dctors), mn) -> map (, mn) dctors

182 Just ((_, dctors), mn) -> map (, mn) dctors

182

183

183 -- Add something to the Imports if it does not already exist there

184 -- Add something to the Imports if it does not already exist there

@@ -191,7 +192,7 @@ resolveImport currentModule importModule exps imps impQual =

191 -- If the name is not already present add it to the list, after looking up

192 -- If the name is not already present add it to the list, after looking up

192 -- where it was originally defined

193 -- where it was originally defined

193 Nothing ->

194 Nothing ->

194− let mnOrig = fromMaybe (error "Invalid state in updateImports") (name `lookup` exps')

195+ let mnOrig = fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps')

195 in return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name, mnOrig) imps'

196 in return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name, mnOrig) imps'

196

197

197 -- If the name already is present check whether it's a duplicate import

198 -- If the name already is present check whether it's a duplicate import

@@ -199,7 +200,7 @@ resolveImport currentModule importModule exps imps impQual =

199 -- re-exports A, importing A and B in C should not result in a "conflicting

200 -- re-exports A, importing A and B in C should not result in a "conflicting

200 -- import for `x`" error

201 -- import for `x`" error

201 Just (Qualified (Just mn) _, mnOrig)

202 Just (Qualified (Just mn) _, mnOrig)

202− | mnOrig == fromMaybe (error "Invalid state in updateImports") (name `lookup` exps') -> return imps'

203+ | mnOrig == fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps') -> return imps'

203 | otherwise -> throwError . errorMessage $ err

204 | otherwise -> throwError . errorMessage $ err

204 where

205 where

205 err = if currentModule `elem` [mn, importModule]

206 err = if currentModule `elem` [mn, importModule]

@@ -207,4 +208,4 @@ resolveImport currentModule importModule exps imps impQual =

207 else ConflictingImports (render name) mn importModule

208 else ConflictingImports (render name) mn importModule

208

209

209 Just (Qualified Nothing _, _) ->

210 Just (Qualified Nothing _, _) ->

210− error "Invalid state in updateImports"

211+ internalError "Invalid state in updateImports"

src/Language/PureScript/Sugar/Operators.hs+3−2

@@ -29,6 +29,7 @@ module Language.PureScript.Sugar.Operators (

29 desugarOperatorSections

30) where

32+import Language.PureScript.Crash

32import Language.PureScript.AST

33import Language.PureScript.AST

33import Language.PureScript.Errors

34import Language.PureScript.Errors

34import Language.PureScript.Names

35import Language.PureScript.Names

@@ -93,7 +94,7 @@ collectFixities (Module _ _ moduleName ds _) = concatMap collect ds

93 where

94 where

94 collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity)]

95 collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity)]

95 collect (PositionedDeclaration pos _ (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]

96 collect (PositionedDeclaration pos _ (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]

96− collect FixityDeclaration{} = error "Fixity without srcpos info"

97+ collect FixityDeclaration{} = internalError "Fixity without srcpos info"

97 collect _ = []

98 collect _ = []

99ensureNoDuplicates :: (MonadError MultipleErrors m) => [(Qualified Ident, SourceSpan)] -> m ()

100ensureNoDuplicates :: (MonadError MultipleErrors m) => [(Qualified Ident, SourceSpan)] -> m ()

@@ -129,7 +130,7 @@ matchOperators ops = parseChains

129 extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r

130 extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r

130 extendChain other = [Left other]

131 extendChain other = [Left other]

131 bracketChain :: Chain -> m Expr

132 bracketChain :: Chain -> m Expr

132− bracketChain = either (const . throwError . errorMessage $ CannotReorderOperators) return . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"

133+ bracketChain = either (\_ -> internalError "matchOperators: cannot reorder operators") return . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"

133 opTable = [P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft]

134 opTable = [P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft]

134 : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops

135 : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops

135 ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]

136 ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]

src/Language/PureScript/Sugar/TypeClasses.hs+9−8

@@ -24,6 +24,7 @@ module Language.PureScript.Sugar.TypeClasses

24 , superClassDictionaryNames

25 ) where

27+import Language.PureScript.Crash

27import Language.PureScript.AST hiding (isExported)

28import Language.PureScript.AST hiding (isExported)

28import Language.PureScript.Environment

29import Language.PureScript.Environment

29import Language.PureScript.Errors

30import Language.PureScript.Errors

@@ -75,7 +76,7 @@ desugarModule (Module ss coms name decls (Just exps)) = do

75 | isTypeClassDeclaration d1 && not (isTypeClassDeclaration d2) = LT

76 | isTypeClassDeclaration d1 && not (isTypeClassDeclaration d2) = LT

76 | not (isTypeClassDeclaration d1) && isTypeClassDeclaration d2 = GT

77 | not (isTypeClassDeclaration d1) && isTypeClassDeclaration d2 = GT

77 | otherwise = EQ

78 | otherwise = EQ

78−desugarModule _ = error "Exports should have been elaborated in name desugaring"

79+desugarModule _ = internalError "Exports should have been elaborated in name desugaring"

80{- Desugar type class and type class instance declarations

81{- Desugar type class and type class instance declarations

81--

82--

@@ -177,7 +178,7 @@ desugarDecl mn exps = go

177 go d@(TypeClassDeclaration name args implies members) = do

178 go d@(TypeClassDeclaration name args implies members) = do

178 modify (M.insert (mn, name) (args, implies, members))

179 modify (M.insert (mn, name) (args, implies, members))

179 return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)

180 return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)

180− go (TypeInstanceDeclaration _ _ _ _ DerivedInstance) = error "Derived instanced should have been desugared"

181+ go (TypeInstanceDeclaration _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared"

181 go d@(TypeInstanceDeclaration name deps className tys (ExplicitInstance members)) = do

182 go d@(TypeInstanceDeclaration name deps className tys (ExplicitInstance members)) = do

182 desugared <- desugarCases members

183 desugared <- desugarCases members

183 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared

184 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared

@@ -200,7 +201,7 @@ desugarDecl mn exps = go

200

201

201 isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool

202 isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool

202 isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps

203 isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps

203− isExported _ _ = error "Names should have been qualified in name desugaring"

204+ isExported _ _ = internalError "Names should have been qualified in name desugaring"

204

205

205 matchesTypeRef :: ProperName -> DeclarationRef -> Bool

206 matchesTypeRef :: ProperName -> DeclarationRef -> Bool

206 matchesTypeRef pn (TypeRef pn' _) = pn == pn'

207 matchesTypeRef pn (TypeRef pn' _) = pn == pn'

@@ -216,7 +217,7 @@ desugarDecl mn exps = go

216memberToNameAndType :: Declaration -> (Ident, Type)

217memberToNameAndType :: Declaration -> (Ident, Type)

217memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)

218memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)

218memberToNameAndType (PositionedDeclaration _ _ d) = memberToNameAndType d

219memberToNameAndType (PositionedDeclaration _ _ d) = memberToNameAndType d

219−memberToNameAndType _ = error "Invalid declaration in type class definition"

220+memberToNameAndType _ = internalError "Invalid declaration in type class definition"

220

221

221typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Declaration

222typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Declaration

222typeClassDictionaryDeclaration name args implies members =

223typeClassDictionaryDeclaration name args implies members =

@@ -236,7 +237,7 @@ typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =

236 moveQuantifiersToFront (quantify (ConstrainedType [(className, map (TypeVar . fst) args)] ty))

237 moveQuantifiersToFront (quantify (ConstrainedType [(className, map (TypeVar . fst) args)] ty))

237typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) =

238typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) =

238 PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d

239 PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d

239−typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"

240+typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration in type class definition"

240

241

241unit :: Type

242unit :: Type

242unit = TypeApp tyObject REmpty

243unit = TypeApp tyObject REmpty

@@ -289,18 +290,18 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

289

290

290 memberToValue :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [(Ident, Type)] -> Declaration -> Desugar m Expr

291 memberToValue :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [(Ident, Type)] -> Declaration -> Desugar m Expr

291 memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do

292 memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do

292− _ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident) return $ lookup ident tys'

293+ _ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident className) return $ lookup ident tys'

293 return val

294 return val

294 memberToValue tys' (PositionedDeclaration pos com d) = rethrowWithPosition pos $ do

295 memberToValue tys' (PositionedDeclaration pos com d) = rethrowWithPosition pos $ do

295 val <- memberToValue tys' d

296 val <- memberToValue tys' d

296 return (PositionedValue pos com val)

297 return (PositionedValue pos com val)

297− memberToValue _ _ = error "Invalid declaration in type instance definition"

298+ memberToValue _ _ = internalError "Invalid declaration in type instance definition"

298

299

299typeClassMemberName :: Declaration -> String

300typeClassMemberName :: Declaration -> String

300typeClassMemberName (TypeDeclaration ident _) = runIdent ident

301typeClassMemberName (TypeDeclaration ident _) = runIdent ident

301typeClassMemberName (ValueDeclaration ident _ _ _) = runIdent ident

302typeClassMemberName (ValueDeclaration ident _ _ _) = runIdent ident

302typeClassMemberName (PositionedDeclaration _ _ d) = typeClassMemberName d

303typeClassMemberName (PositionedDeclaration _ _ d) = typeClassMemberName d

303−typeClassMemberName _ = error "typeClassMemberName: Invalid declaration in type class definition"

304+typeClassMemberName _ = internalError "typeClassMemberName: Invalid declaration in type class definition"

304

305

305superClassDictionaryNames :: [Constraint] -> [String]

306superClassDictionaryNames :: [Constraint] -> [String]

306superClassDictionaryNames supers =

307superClassDictionaryNames supers =

src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+4−3

@@ -36,6 +36,7 @@ import Control.Monad (replicateM)

36import Control.Monad.Supply.Class (MonadSupply, freshName)

37import Control.Monad.Error.Class (MonadError(..))

39+import Language.PureScript.Crash

39import Language.PureScript.AST

40import Language.PureScript.AST

40import Language.PureScript.Environment

41import Language.PureScript.Environment

41import Language.PureScript.Errors

42import Language.PureScript.Errors

@@ -116,7 +117,7 @@ mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorCl

116 $ decomposeRec rec

117 $ decomposeRec rec

117 toSpineFun i _ = lamNull $ App (mkGenVar C.toSpine) i

118 toSpineFun i _ = lamNull $ App (mkGenVar C.toSpine) i

118mkSpineFunction mn (PositionedDeclaration _ _ d) = mkSpineFunction mn d

119mkSpineFunction mn (PositionedDeclaration _ _ d) = mkSpineFunction mn d

119−mkSpineFunction _ _ = error "mkSpineFunction: expected DataDeclaration"

120+mkSpineFunction _ _ = internalError "mkSpineFunction: expected DataDeclaration"

120

121

121mkSignatureFunction :: ModuleName -> Declaration -> Expr

122mkSignatureFunction :: ModuleName -> Declaration -> Expr

122mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map mkProdClause args

123mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map mkProdClause args

@@ -145,7 +146,7 @@ mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map m

145 mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature)

146 mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature)

146 (TypedValue False (mkGenVar "anyProxy") (proxy typ))

147 (TypedValue False (mkGenVar "anyProxy") (proxy typ))

147mkSignatureFunction mn (PositionedDeclaration _ _ d) = mkSignatureFunction mn d

148mkSignatureFunction mn (PositionedDeclaration _ _ d) = mkSignatureFunction mn d

148−mkSignatureFunction _ _ = error "mkSignatureFunction: expected DataDeclaration"

149+mkSignatureFunction _ _ = internalError "mkSignatureFunction: expected DataDeclaration"

149

150

150mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr

151mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr

151mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args)

152mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args)

@@ -194,7 +195,7 @@ mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch

194 mkRecFun xs = mkJust $ foldr (\s e -> lam s e) recLiteral (map fst xs)

195 mkRecFun xs = mkJust $ foldr (\s e -> lam s e) recLiteral (map fst xs)

195 where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs

196 where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs

196mkFromSpineFunction mn (PositionedDeclaration _ _ d) = mkFromSpineFunction mn d

197mkFromSpineFunction mn (PositionedDeclaration _ _ d) = mkFromSpineFunction mn d

197−mkFromSpineFunction _ _ = error "mkFromSpineFunction: expected DataDeclaration"

198+mkFromSpineFunction _ _ = internalError "mkFromSpineFunction: expected DataDeclaration"

198

199

199-- Helpers

200-- Helpers

200

201

src/Language/PureScript/Sugar/TypeDeclarations.hs+14−20

@@ -25,9 +25,8 @@ module Language.PureScript.Sugar.TypeDeclarations (

25#if __GLASGOW_HASKELL__ < 710

26import Control.Applicative

27#endif

28−import Control.Monad (forM, when)

28+import Control.Monad (forM)

29import Control.Monad.Error.Class (MonadError(..))

30−import Control.Monad.Writer.Class (MonadWriter(tell))

32import Language.PureScript.AST

31import Language.PureScript.AST

33import Language.PureScript.Names

32import Language.PureScript.Names

@@ -38,19 +37,19 @@ import Language.PureScript.Traversals

38-- |

37-- |

39-- Replace all top level type declarations in a module with type annotations

38-- Replace all top level type declarations in a module with type annotations

40--

39--

41−desugarTypeDeclarationsModule :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module]

40+desugarTypeDeclarationsModule :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]

42desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->

41desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->

43 rethrow (addHint (ErrorInModule name)) $

42 rethrow (addHint (ErrorInModule name)) $

44− Module ss coms name <$> desugarTypeDeclarations True ds <*> pure exps

43+ Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps

45 where

44 where

47− desugarTypeDeclarations :: Bool -> [Declaration] -> m [Declaration]

46+ desugarTypeDeclarations :: [Declaration] -> m [Declaration]

48− desugarTypeDeclarations reqd (PositionedDeclaration pos com d : ds) = do

47+ desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do

49− (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations reqd (d : ds)

48+ (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)

50 return (PositionedDeclaration pos com d' : ds')

49 return (PositionedDeclaration pos com d' : ds')

51− desugarTypeDeclarations reqd (TypeDeclaration name ty : d : rest) = do

50+ desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do

52 (_, nameKind, val) <- fromValueDeclaration d

51 (_, nameKind, val) <- fromValueDeclaration d

53− desugarTypeDeclarations reqd (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)

52+ desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)

54 where

53 where

55 fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr)

54 fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr)

56 fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)

55 fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)

@@ -58,19 +57,14 @@ desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->

58 (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'

57 (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'

59 return (ident, nameKind, PositionedValue pos com val)

58 return (ident, nameKind, PositionedValue pos com val)

60 fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name

59 fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name

61− desugarTypeDeclarations _ [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name

60+ desugarTypeDeclarations [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name

62− desugarTypeDeclarations reqd (ValueDeclaration name nameKind bs val : rest) = do

61+ desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do

63− -- At the top level, match a type signature or emit a warning.

64− when reqd $ case val of

65− Right TypedValue{} -> return ()

66− Left _ -> error "desugarTypeDeclarations: cases were not desugared"

67− _ -> tell (addHint (ErrorInValueDeclaration name) $ errorMessage $ MissingTypeDeclaration name)

68 let (_, f, _) = everywhereOnValuesTopDownM return go return

62 let (_, f, _) = everywhereOnValuesTopDownM return go return

69 f' (Left gs) = Left <$> mapM (pairM return f) gs

63 f' (Left gs) = Left <$> mapM (pairM return f) gs

70 f' (Right v) = Right <$> f v

64 f' (Right v) = Right <$> f v

71− (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations reqd rest

65+ (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations rest

72 where

66 where

73− go (Let ds val') = Let <$> desugarTypeDeclarations False ds <*> pure val'

67+ go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val'

74 go other = return other

68 go other = return other

75− desugarTypeDeclarations reqd (d:ds) = (:) d <$> desugarTypeDeclarations reqd ds

69+ desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds

76− desugarTypeDeclarations _ [] = return []

70+ desugarTypeDeclarations [] = return []

src/Language/PureScript/TypeChecker.hs+15−14

@@ -38,6 +38,7 @@ import Control.Applicative ((<$>), (<*))

38import Control.Monad.State

39import Control.Monad.Error.Class (MonadError(..))

41+import Language.PureScript.Crash

41import Language.PureScript.Types

42import Language.PureScript.Types

42import Language.PureScript.Names

43import Language.PureScript.Names

43import Language.PureScript.Kinds

44import Language.PureScript.Kinds

@@ -90,7 +91,7 @@ addTypeClass moduleName pn args implies ds =

90 where

91 where

91 toPair (TypeDeclaration ident ty) = (ident, ty)

92 toPair (TypeDeclaration ident ty) = (ident, ty)

92 toPair (PositionedDeclaration _ _ d) = toPair d

93 toPair (PositionedDeclaration _ _ d) = toPair d

93− toPair _ = error "Invalid declaration in TypeClassDeclaration"

94+ toPair _ = internalError "Invalid declaration in TypeClassDeclaration"

95addTypeClassDictionaries :: Maybe ModuleName -> M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope) -> Check ()

96addTypeClassDictionaries :: Maybe ModuleName -> M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope) -> Check ()

96addTypeClassDictionaries mn entries =

97addTypeClassDictionaries mn entries =

@@ -147,8 +148,8 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds

147 where

148 where

148 checkNewtype :: [(ProperName, [Type])] -> Check ()

149 checkNewtype :: [(ProperName, [Type])] -> Check ()

149 checkNewtype [(_, [_])] = return ()

150 checkNewtype [(_, [_])] = return ()

150− checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype

151+ checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype name

151− checkNewtype _ = throwError . errorMessage $ InvalidNewtype

152+ checkNewtype _ = throwError . errorMessage $ InvalidNewtype name

152 go (d@(DataBindingGroupDeclaration tys)) = do

153 go (d@(DataBindingGroupDeclaration tys)) = do

153 warnAndRethrow (addHint ErrorInDataBindingGroup) $ do

154 warnAndRethrow (addHint ErrorInDataBindingGroup) $ do

154 let syns = mapMaybe toTypeSynonym tys

155 let syns = mapMaybe toTypeSynonym tys

@@ -177,14 +178,14 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds

177 let args' = args `withKinds` kind

178 let args' = args `withKinds` kind

178 addTypeSynonym moduleName name args' ty kind

179 addTypeSynonym moduleName name args' ty kind

179 return $ TypeSynonymDeclaration name args ty

180 return $ TypeSynonymDeclaration name args ty

180− go (TypeDeclaration{}) = error "Type declarations should have been removed"

181+ go (TypeDeclaration{}) = internalError "Type declarations should have been removed"

181 go (ValueDeclaration name nameKind [] (Right val)) =

182 go (ValueDeclaration name nameKind [] (Right val)) =

182 warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do

183 warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do

183 valueIsNotDefined moduleName name

184 valueIsNotDefined moduleName name

184 [(_, (val', ty))] <- typesOf moduleName [(name, val)]

185 [(_, (val', ty))] <- typesOf moduleName [(name, val)]

185 addValue moduleName name ty nameKind

186 addValue moduleName name ty nameKind

186 return $ ValueDeclaration name nameKind [] $ Right val'

187 return $ ValueDeclaration name nameKind [] $ Right val'

187− go (ValueDeclaration{}) = error "Binders were not desugared"

188+ go (ValueDeclaration{}) = internalError "Binders were not desugared"

188 go (BindingGroupDeclaration vals) =

189 go (BindingGroupDeclaration vals) =

189 warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do

190 warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do

190 forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->

191 forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->

@@ -205,7 +206,7 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds

205 go (d@(ExternDeclaration name ty)) = do

206 go (d@(ExternDeclaration name ty)) = do

206 warnAndRethrow (addHint (ErrorInForeignImport name)) $ do

207 warnAndRethrow (addHint (ErrorInForeignImport name)) $ do

207 env <- getEnv

208 env <- getEnv

208− kind <- kindOf moduleName ty

209+ kind <- kindOf ty

209 guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star

210 guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star

210 case M.lookup (moduleName, name) (names env) of

211 case M.lookup (moduleName, name) (names env) of

211 Just _ -> throwError . errorMessage $ RedefinedIdent name

212 Just _ -> throwError . errorMessage $ RedefinedIdent name

@@ -245,7 +246,7 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds

245 memberName :: Declaration -> Ident

246 memberName :: Declaration -> Ident

246 memberName (ValueDeclaration ident _ _ _) = ident

247 memberName (ValueDeclaration ident _ _ _) = ident

247 memberName (PositionedDeclaration _ _ d) = memberName d

248 memberName (PositionedDeclaration _ _ d) = memberName d

248− memberName _ = error "checkInstanceMembers: Invalid declaration in type instance definition"

249+ memberName _ = internalError "checkInstanceMembers: Invalid declaration in type instance definition"

249

250

250 firstDuplicate :: (Eq a) => [a] -> Maybe a

251 firstDuplicate :: (Eq a) => [a] -> Maybe a

251 firstDuplicate (x : xs@(y : _))

252 firstDuplicate (x : xs@(y : _))

@@ -261,10 +262,10 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds

261 checkType :: Type -> Bool

262 checkType :: Type -> Bool

262 checkType (TypeVar _) = False

263 checkType (TypeVar _) = False

263 checkType (TypeConstructor (Qualified (Just mn'') _)) = moduleName == mn''

264 checkType (TypeConstructor (Qualified (Just mn'') _)) = moduleName == mn''

264− checkType (TypeConstructor (Qualified Nothing _)) = error "Unqualified type name in checkOrphanInstance"

265+ checkType (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance"

265 checkType (TypeApp t1 _) = checkType t1

266 checkType (TypeApp t1 _) = checkType t1

266− checkType _ = error "Invalid type in instance in checkOrphanInstance"

267+ checkType _ = internalError "Invalid type in instance in checkOrphanInstance"

267− checkOrphanInstance _ _ _ = error "Unqualified class name in checkOrphanInstance"

268+ checkOrphanInstance _ _ _ = internalError "Unqualified class name in checkOrphanInstance"

268

269

269 -- |

270 -- |

270 -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,

271 -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,

@@ -274,14 +275,14 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds

274 withKinds [] _ = []

275 withKinds [] _ = []

275 withKinds (s@(_, Just _ ):ss) (FunKind _ k) = s : withKinds ss k

276 withKinds (s@(_, Just _ ):ss) (FunKind _ k) = s : withKinds ss k

276 withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2

277 withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2

277− withKinds _ _ = error "Invalid arguments to peelKinds"

278+ withKinds _ _ = internalError "Invalid arguments to peelKinds"

278

279

279-- |

280-- |

280-- Type check an entire module and ensure all types and classes defined within the module that are

281-- Type check an entire module and ensure all types and classes defined within the module that are

281-- required by exported members are also exported.

282-- required by exported members are also exported.

282--

283--

283typeCheckModule :: Module -> Check Module

284typeCheckModule :: Module -> Check Module

284−typeCheckModule (Module _ _ _ _ Nothing) = error "exports should have been elaborated"

285+typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated"

285typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do

286typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do

286 modify (\s -> s { checkCurrentModule = Just mn })

287 modify (\s -> s { checkCurrentModule = Just mn })

287 decls' <- typeCheckAll mn exps decls

288 decls' <- typeCheckAll mn exps decls

@@ -331,7 +332,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint

331 findTcons :: Type -> [DeclarationRef]

332 findTcons :: Type -> [DeclarationRef]

332 findTcons = everythingOnTypes (++) go

333 findTcons = everythingOnTypes (++) go

333 where

334 where

334− go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [TypeRef name (error "Data constructors unused in checkTypesAreExported")]

335+ go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [TypeRef name (internalError "Data constructors unused in checkTypesAreExported")]

335 go _ = []

336 go _ = []

336

337

337 -- Check that all the classes defined in the current module that appear in member types have also

338 -- Check that all the classes defined in the current module that appear in member types have also

@@ -361,5 +362,5 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint

361 extractMemberName :: Declaration -> Ident

362 extractMemberName :: Declaration -> Ident

362 extractMemberName (PositionedDeclaration _ _ d) = extractMemberName d

363 extractMemberName (PositionedDeclaration _ _ d) = extractMemberName d

363 extractMemberName (TypeDeclaration memberName _) = memberName

364 extractMemberName (TypeDeclaration memberName _) = memberName

364− extractMemberName _ = error "Unexpected declaration in typeclass member list"

365+ extractMemberName _ = internalError "Unexpected declaration in typeclass member list"

365 checkClassMembersAreExported _ = return ()

366 checkClassMembersAreExported _ = return ()

src/Language/PureScript/TypeChecker/Entailment.hs+3−2

@@ -35,6 +35,7 @@ import Control.Monad.State

35import Control.Monad.Error.Class (MonadError(..))

36import Control.Monad.Writer.Class (tell)

38+import Language.PureScript.Crash

38import Language.PureScript.AST

39import Language.PureScript.AST

39import Language.PureScript.Errors

40import Language.PureScript.Errors

40import Language.PureScript.Names

41import Language.PureScript.Names

@@ -53,11 +54,11 @@ entails moduleName context = solve

53 where

54 where

54 forClassName :: Qualified ProperName -> [Type] -> [TypeClassDictionaryInScope]

55 forClassName :: Qualified ProperName -> [Type] -> [TypeClassDictionaryInScope]

55 forClassName cn@(Qualified (Just mn) _) tys = concatMap (findDicts cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))

56 forClassName cn@(Qualified (Just mn) _) tys = concatMap (findDicts cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))

56− forClassName _ _ = error "forClassName: expected qualified class name"

57+ forClassName _ _ = internalError "forClassName: expected qualified class name"

58 ctorModules :: Type -> Maybe ModuleName

59 ctorModules :: Type -> Maybe ModuleName

59 ctorModules (TypeConstructor (Qualified (Just mn) _)) = Just mn

60 ctorModules (TypeConstructor (Qualified (Just mn) _)) = Just mn

60− ctorModules (TypeConstructor (Qualified Nothing _)) = error "ctorModules: unqualified type name"

61+ ctorModules (TypeConstructor (Qualified Nothing _)) = internalError "ctorModules: unqualified type name"

61 ctorModules (TypeApp ty _) = ctorModules ty

62 ctorModules (TypeApp ty _) = ctorModules ty

62 ctorModules _ = Nothing

63 ctorModules _ = Nothing

src/Language/PureScript/TypeChecker/Kinds.hs+4−3

@@ -40,6 +40,7 @@ import Control.Monad.Error.Class (MonadError(..))

40import Control.Monad.State

41import Control.Monad.Unify

43+import Language.PureScript.Crash

43import Language.PureScript.Environment

44import Language.PureScript.Environment

44import Language.PureScript.Errors

45import Language.PureScript.Errors

45import Language.PureScript.Kinds

46import Language.PureScript.Kinds

@@ -75,8 +76,8 @@ instance Unifiable Check Kind where

75-- |

76-- |

76-- Infer the kind of a single type

77-- Infer the kind of a single type

77--

78--

78−kindOf :: ModuleName -> Type -> Check Kind

79+kindOf :: Type -> Check Kind

79−kindOf _ ty = fst <$> kindOfWithScopedVars ty

80+kindOf ty = fst <$> kindOfWithScopedVars ty

81-- |

82-- |

82-- Infer the kind of a single type, returning the kinds of any scoped type variables

83-- Infer the kind of a single type, returning the kinds of any scoped type variables

@@ -220,4 +221,4 @@ infer' other = (, []) <$> go other

220 k <- go ty

221 k <- go ty

221 k =?= Star

222 k =?= Star

222 return Star

223 return Star

223− go _ = error "Invalid argument to infer"

224+ go _ = internalError "Invalid argument to infer"

src/Language/PureScript/TypeChecker/Monad.hs+1−1

@@ -153,7 +153,7 @@ checkVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, Mona

153checkVisibility currentModule name@(Qualified _ var) = do

154 vis <- getVisibility currentModule name

155 case vis of

156− Undefined -> throwError . errorMessage $ NameNotInScope var

156+ Undefined -> throwError . errorMessage $ CycleInDeclaration var

157 _ -> return ()

158

159-- |

src/Language/PureScript/TypeChecker/Skolems.hs+11−5

@@ -33,6 +33,7 @@ import Control.Applicative

33import Control.Monad.Error.Class (MonadError(..))

34import Control.Monad.Unify

36+import Language.PureScript.Crash

36import Language.PureScript.AST

37import Language.PureScript.AST

37import Language.PureScript.Errors

38import Language.PureScript.Errors

38import Language.PureScript.TypeChecker.Monad

39import Language.PureScript.TypeChecker.Monad

@@ -71,11 +72,16 @@ skolemize ident sko scope = replaceTypeVars ident (Skolem ident sko scope)

71-- only example of scoped type variables.

72-- only example of scoped type variables.

72--

73--

73skolemizeTypesInValue :: String -> Int -> SkolemScope -> Expr -> Expr

74skolemizeTypesInValue :: String -> Int -> SkolemScope -> Expr -> Expr

74−skolemizeTypesInValue ident sko scope = let (_, f, _) = everywhereOnValues id go id in f

75+skolemizeTypesInValue ident sko scope = let (_, f, _) = everywhereOnValues id onExpr onBinder in f

75 where

76 where

77+ onExpr :: Expr -> Expr

76− go (SuperClassDictionary c ts) = SuperClassDictionary c (map (skolemize ident sko scope) ts)

78+ onExpr (SuperClassDictionary c ts) = SuperClassDictionary c (map (skolemize ident sko scope) ts)

77− go (TypedValue check val ty) = TypedValue check val (skolemize ident sko scope ty)

79+ onExpr (TypedValue check val ty) = TypedValue check val (skolemize ident sko scope ty)

80+ onExpr other = other

81+

82+ onBinder :: Binder -> Binder

83+ onBinder (TypedBinder ty b) = TypedBinder (skolemize ident sko scope ty) b

78− go other = other

84+ onBinder other = other

80-- |

86-- |

81-- Ensure skolem variables do not escape their scope

87-- Ensure skolem variables do not escape their scope

@@ -115,4 +121,4 @@ skolemEscapeCheck root@TypedValue{} =

115 where

121 where

116 go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = First (Just val)

122 go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = First (Just val)

117 go' _ = mempty

123 go' _ = mempty

118−skolemEscapeCheck _ = error "Untyped value passed to skolemEscapeCheck"

124+skolemEscapeCheck _ = internalError "Untyped value passed to skolemEscapeCheck"

src/Language/PureScript/TypeChecker/Subsumption.hs+12−4

@@ -20,9 +20,10 @@ module Language.PureScript.TypeChecker.Subsumption (

20import Data.List (sortBy)

21import Data.Ord (comparing)

23−import Control.Monad.Error.Class (MonadError(..))

24import Control.Monad.Unify

23import Control.Monad.Unify

24+import Control.Monad.Error.Class (throwError)

26+import Language.PureScript.Crash

26import Language.PureScript.AST

27import Language.PureScript.AST

27import Language.PureScript.Environment

28import Language.PureScript.Environment

28import Language.PureScript.Errors

29import Language.PureScript.Errors

@@ -50,7 +51,7 @@ subsumes' val ty1 (ForAll ident ty2 sco) =

50 sko <- newSkolemConstant

51 sko <- newSkolemConstant

51 let sk = skolemize ident sko sco' ty2

52 let sk = skolemize ident sko sco' ty2

52 subsumes val ty1 sk

53 subsumes val ty1 sk

53− Nothing -> throwError . errorMessage $ UnspecifiedSkolemScope

54+ Nothing -> internalError "subsumes: unspecified skolem scope"

54subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do

55subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do

55 _ <- subsumes Nothing arg2 arg1

56 _ <- subsumes Nothing arg2 arg1

56 _ <- subsumes Nothing ret1 ret2

57 _ <- subsumes Nothing ret1 ret2

@@ -77,10 +78,17 @@ subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyObject && f2 == tyObject

77 | p1 == p2 = do _ <- subsumes Nothing ty1 ty2

78 | p1 == p2 = do _ <- subsumes Nothing ty1 ty2

78 go ts1 ts2 r1' r2'

79 go ts1 ts2 r1' r2'

79 | p1 < p2 = do rest <- fresh

80 | p1 < p2 = do rest <- fresh

81+ -- What happens next is a bit of a hack.

82+ -- TODO: in the new type checker, object properties will probably be restricted to being monotypes

83+ -- in which case, this branch of the subsumes function should not even be necessary.

84+ case r2' of

85+ REmpty -> throwError . errorMessage $ AdditionalProperty p1

80− r2' =?= RCons p1 ty1 rest

86+ _ -> r2' =?= RCons p1 ty1 rest

81 go ts1 ((p2, ty2) : ts2) r1' rest

87 go ts1 ((p2, ty2) : ts2) r1' rest

82 | otherwise = do rest <- fresh

88 | otherwise = do rest <- fresh

89+ case r1' of

90+ REmpty -> throwError . errorMessage $ PropertyIsMissing p2

83− r1' =?= RCons p2 ty2 rest

91+ _ -> r1' =?= RCons p2 ty2 rest

84 go ((p1, ty1) : ts1) ts2 rest r2'

92 go ((p1, ty1) : ts1) ts2 rest r2'

85subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyObject = subsumes val ty2 ty1

93subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyObject = subsumes val ty2 ty1

86subsumes' val ty1 ty2 = do

94subsumes' val ty1 ty2 = do

src/Language/PureScript/TypeChecker/Types.hs+52−43

@@ -50,7 +50,9 @@ import Control.Monad

50import Control.Monad.State

51import Control.Monad.Unify

52import Control.Monad.Error.Class (MonadError(..))

53+import Control.Monad.Writer.Class (tell)

55+import Language.PureScript.Crash

54import Language.PureScript.AST

56import Language.PureScript.AST

55import Language.PureScript.Environment

57import Language.PureScript.Environment

56import Language.PureScript.Errors

58import Language.PureScript.Errors

@@ -77,7 +79,7 @@ typesOf moduleName vals = do

77 tys <- fmap tidyUp . liftUnifyWarnings replace $ do

79 tys <- fmap tidyUp . liftUnifyWarnings replace $ do

78 (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals

80 (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals

79 ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict

81 ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict

80− ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict

82+ ds2 <- forM untyped $ \e -> typeForBindingGroupElement True e dict untypedDict

81 return $ ds1 ++ ds2

83 return $ ds1 ++ ds2

83 forM tys $ \(ident, (val, ty)) -> do

85 forM tys $ \(ident, (val, ty)) -> do

@@ -93,6 +95,7 @@ typesOf moduleName vals = do

93 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts

95 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts

94 -- Replace all the wildcards types with their inferred types

96 -- Replace all the wildcards types with their inferred types

95 replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints $ WildcardInferredType (sub $? ty)

97 replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints $ WildcardInferredType (sub $? ty)

98+ replace sub (ErrorMessage hints (MissingTypeDeclaration name ty)) = ErrorMessage hints $ MissingTypeDeclaration name (varIfUnknown (sub $? ty))

96 replace _ em = em

99 replace _ em = em

100

98type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)

101type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)

@@ -134,11 +137,12 @@ checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do

134 else return (TypedValue False val' ty'')

137 else return (TypedValue False val' ty'')

135 return (ident, (val'', ty''))

138 return (ident, (val'', ty''))

136

139

137−typeForBindingGroupElement :: (Ident, Expr) -> TypeData -> UntypedData -> UnifyT Type Check (Ident, (Expr, Type))

140+typeForBindingGroupElement :: Bool -> (Ident, Expr) -> TypeData -> UntypedData -> UnifyT Type Check (Ident, (Expr, Type))

138−typeForBindingGroupElement (ident, val) dict untypedDict = do

141+typeForBindingGroupElement warn (ident, val) dict untypedDict = do

139 -- Infer the type with the new names in scope

142 -- Infer the type with the new names in scope

140 TypedValue _ val' ty <- bindNames dict $ infer val

143 TypedValue _ val' ty <- bindNames dict $ infer val

141− ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)

144+ ty =?= fromMaybe (internalError "name not found in dictionary") (lookup ident untypedDict)

145+ when warn . tell . errorMessage $ MissingTypeDeclaration ident ty

142 return (ident, (TypedValue True val' ty, ty))

146 return (ident, (TypedValue True val' ty, ty))

143

147

144-- |

148-- |

@@ -189,7 +193,7 @@ instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do

189 instantiatePolyTypeWithUnknowns val ty'

193 instantiatePolyTypeWithUnknowns val ty'

190instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do

194instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do

191 dicts <- getTypeClassDictionaries

195 dicts <- getTypeClassDictionaries

192− (_, ty') <- instantiatePolyTypeWithUnknowns (error "Types under a constraint cannot themselves be constrained") ty

196+ (_, ty') <- instantiatePolyTypeWithUnknowns (internalError "Types under a constraint cannot themselves be constrained") ty

193 return (foldl App val (map (flip TypeClassDictionary dicts) constraints), ty')

197 return (foldl App val (map (flip TypeClassDictionary dicts) constraints), ty')

194instantiatePolyTypeWithUnknowns val ty = return (val, ty)

198instantiatePolyTypeWithUnknowns val ty = return (val, ty)

195

199

@@ -228,7 +232,7 @@ infer' (ObjectUpdate o ps) = do

228 let oldTy = TypeApp tyObject $ rowFromList (oldTys, row)

232 let oldTy = TypeApp tyObject $ rowFromList (oldTys, row)

229 o' <- TypedValue True <$> check o oldTy <*> pure oldTy

233 o' <- TypedValue True <$> check o oldTy <*> pure oldTy

230 return $ TypedValue True (ObjectUpdate o' newVals) $ TypeApp tyObject $ rowFromList (newTys, row)

234 return $ TypedValue True (ObjectUpdate o' newVals) $ TypeApp tyObject $ rowFromList (newTys, row)

231−infer' (Accessor prop val) = do

235+infer' (Accessor prop val) = rethrow (addHint (ErrorCheckingAccessor val prop)) $ do

232 field <- fresh

236 field <- fresh

233 rest <- fresh

237 rest <- fresh

234 typed <- check val (TypeApp tyObject (RCons prop field rest))

238 typed <- check val (TypeApp tyObject (RCons prop field rest))

@@ -239,7 +243,7 @@ infer' (Abs (Left arg) ret) = do

239 withBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do

243 withBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do

240 body@(TypedValue _ _ bodyTy) <- infer' ret

244 body@(TypedValue _ _ bodyTy) <- infer' ret

241 return $ TypedValue True (Abs (Left arg) body) $ function ty bodyTy

245 return $ TypedValue True (Abs (Left arg) body) $ function ty bodyTy

242−infer' (Abs (Right _) _) = error "Binder was not desugared"

246+infer' (Abs (Right _) _) = internalError "Binder was not desugared"

243infer' (App f arg) = do

247infer' (App f arg) = do

244 f'@(TypedValue _ _ ft) <- infer f

248 f'@(TypedValue _ _ ft) <- infer f

245 (ret, app) <- checkFunctionApplication f' ft arg Nothing

249 (ret, app) <- checkFunctionApplication f' ft arg Nothing

@@ -284,7 +288,7 @@ infer' (TypedValue checkType val ty) = do

284 val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val

288 val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val

285 return $ TypedValue True val' ty'

289 return $ TypedValue True val' ty'

286infer' (PositionedValue pos _ val) = warnAndRethrowWithPosition pos $ infer' val

290infer' (PositionedValue pos _ val) = warnAndRethrowWithPosition pos $ infer' val

287−infer' _ = error "Invalid argument to infer"

291+infer' _ = internalError "Invalid argument to infer"

288

292

289inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Type Check Expr) -> UnifyT Type Check ([Declaration], Expr)

293inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Type Check Expr) -> UnifyT Type Check ([Declaration], Expr)

290inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret)

294inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret)

@@ -307,7 +311,7 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do

307 Just moduleName <- checkCurrentModule <$> get

311 Just moduleName <- checkCurrentModule <$> get

308 (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)

312 (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)

309 ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict

313 ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict

310− ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict

314+ ds2' <- forM untyped $ \e -> typeForBindingGroupElement False e dict untypedDict

311 let ds' = [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2']

315 let ds' = [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2']

312 bindNames dict $ do

316 bindNames dict $ do

313 makeBindingGroupVisible

317 makeBindingGroupVisible

@@ -315,7 +319,7 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do

315inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethrowWithPosition pos $ do

319inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethrowWithPosition pos $ do

316 (d' : ds', val') <- inferLetBinding seen (d : ds) ret j

320 (d' : ds', val') <- inferLetBinding seen (d : ds) ret j

317 return (PositionedDeclaration pos com d' : ds', val')

321 return (PositionedDeclaration pos com d' : ds', val')

318−inferLetBinding _ _ _ _ = error "Invalid argument to inferLetBinding"

322+inferLetBinding _ _ _ _ = internalError "Invalid argument to inferLetBinding"

319

323

320-- |

324-- |

321-- Infer the types of variables brought into scope by a binder

325-- Infer the types of variables brought into scope by a binder

@@ -332,20 +336,19 @@ inferBinder val (ConstructorBinder ctor binders) = do

332 env <- getEnv

336 env <- getEnv

333 case M.lookup ctor (dataConstructors env) of

337 case M.lookup ctor (dataConstructors env) of

334 Just (_, _, ty, _) -> do

338 Just (_, _, ty, _) -> do

335− (_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contain constraints") ty

339+ (_, fn) <- instantiatePolyTypeWithUnknowns (internalError "Data constructor types cannot contain constraints") ty

336 fn' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ fn

340 fn' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ fn

337− go binders fn'

341+ let (args, ret) = peelArgs fn'

338− where

339− go [] ty' = case (val, ty') of

340− (TypeConstructor _, TypeApp _ _) -> throwIncorrectArity

341− _ -> do

342− _ <- val =?= ty'

343− return M.empty

344− go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction =

345− M.union <$> inferBinder obj binder <*> go binders' ret

346− go _ _ = throwIncorrectArity

347− throwIncorrectArity = throwError . errorMessage $ IncorrectConstructorArity ctor

342+ unless (length args == length binders) . throwError . errorMessage $ IncorrectConstructorArity ctor

343+ ret =?= val

344+ M.unions <$> zipWithM inferBinder (reverse args) binders

348 _ -> throwError . errorMessage $ UnknownDataConstructor ctor Nothing

345 _ -> throwError . errorMessage $ UnknownDataConstructor ctor Nothing

346+ where

347+ peelArgs :: Type -> ([Type], Type)

348+ peelArgs = go []

349+ where

350+ go args (TypeApp (TypeApp fn arg) ret) | fn == tyFunction = go (arg : args) ret

351+ go args ret = (args, ret)

349inferBinder val (ObjectBinder props) = do

352inferBinder val (ObjectBinder props) = do

350 row <- fresh

353 row <- fresh

351 rest <- fresh

354 rest <- fresh

@@ -370,9 +373,15 @@ inferBinder val (NamedBinder name binder) = do

370 return $ M.insert name val m

373 return $ M.insert name val m

371inferBinder val (PositionedBinder pos _ binder) =

374inferBinder val (PositionedBinder pos _ binder) =

372 warnAndRethrowWithPosition pos $ inferBinder val binder

375 warnAndRethrowWithPosition pos $ inferBinder val binder

373−-- TODO: When adding support for polymorphic types, check subsumption here

376+-- TODO: When adding support for polymorphic types, check subsumption here,

374−-- and change the definition of `binderRequiresMonotype`

377+-- change the definition of `binderRequiresMonotype`,

378+-- and use `kindOfWithScopedVars`.

375−inferBinder val (TypedBinder ty binder) = val =?= ty >> inferBinder val binder

379+inferBinder val (TypedBinder ty binder) = do

380+ ty1 <- replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

381+ kind <- liftCheck $ kindOf ty1

382+ checkTypeKind ty1 kind

383+ val =?= ty1

384+ inferBinder val binder

376

385

377-- | Returns true if a binder requires its argument type to be a monotype.

386-- | Returns true if a binder requires its argument type to be a monotype.

378-- | If this is the case, we need to instantiate any polymorphic types before checking binders.

387-- | If this is the case, we need to instantiate any polymorphic types before checking binders.

@@ -409,7 +418,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do

409 case result of

418 case result of

410 Left gs -> do

419 Left gs -> do

411 gs' <- forM gs $ \(grd, val) -> do

420 gs' <- forM gs $ \(grd, val) -> do

412− grd' <- check grd tyBoolean

421+ grd' <- rethrow (addHint ErrorCheckingGuard) $ check grd tyBoolean

413 val' <- TypedValue True <$> check val ret <*> pure ret

422 val' <- TypedValue True <$> check val ret <*> pure ret

414 return (grd', val')

423 return (grd', val')

415 return $ Left gs'

424 return $ Left gs'

@@ -449,7 +458,7 @@ check' val t@(ConstrainedType constraints ty) = do

449 newDictionaries :: [(Qualified ProperName, Integer)] -> Qualified Ident -> (Qualified ProperName, [Type]) -> Check [TypeClassDictionaryInScope]

458 newDictionaries :: [(Qualified ProperName, Integer)] -> Qualified Ident -> (Qualified ProperName, [Type]) -> Check [TypeClassDictionaryInScope]

450 newDictionaries path name (className, instanceTy) = do

459 newDictionaries path name (className, instanceTy) = do

451 tcs <- gets (typeClasses . checkEnv)

460 tcs <- gets (typeClasses . checkEnv)

452− let (args, _, superclasses) = fromMaybe (error "newDictionaries: type class lookup failed") $ M.lookup className tcs

461+ let (args, _, superclasses) = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs

453 supDicts <- join <$> zipWithM (\(supName, supArgs) index ->

462 supDicts <- join <$> zipWithM (\(supName, supArgs) index ->

454 newDictionaries ((supName, index) : path)

463 newDictionaries ((supName, index) : path)

455 name

464 name

@@ -484,7 +493,7 @@ check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do

484 Just moduleName <- checkCurrentModule <$> get

493 Just moduleName <- checkCurrentModule <$> get

485 ret' <- withBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy

494 ret' <- withBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy

486 return $ TypedValue True (Abs (Left arg) ret') ty

495 return $ TypedValue True (Abs (Left arg) ret') ty

487−check' (Abs (Right _) _) _ = error "Binder was not desugared"

496+check' (Abs (Right _) _) _ = internalError "Binder was not desugared"

488check' (App f arg) ret = do

497check' (App f arg) ret = do

489 f'@(TypedValue _ _ ft) <- infer f

498 f'@(TypedValue _ _ ft) <- infer f

490 (_, app) <- checkFunctionApplication f' ft arg (Just ret)

499 (_, app) <- checkFunctionApplication f' ft arg (Just ret)

@@ -496,7 +505,7 @@ check' v@(Var var) ty = do

496 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

505 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

497 v' <- subsumes (Just v) repl ty'

506 v' <- subsumes (Just v) repl ty'

498 case v' of

507 case v' of

499− Nothing -> throwError . errorMessage $ SubsumptionCheckFailed

508+ Nothing -> internalError "check: unable to check the subsumes relation."

500 Just v'' -> return $ TypedValue True v'' ty'

509 Just v'' -> return $ TypedValue True v'' ty'

501check' (SuperClassDictionary className tys) _ = do

510check' (SuperClassDictionary className tys) _ = do

502 {-

511 {-

@@ -515,7 +524,7 @@ check' (TypedValue checkType val ty1) ty2 = do

515 ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2

524 ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2

516 val' <- subsumes (Just val) ty1' ty2'

525 val' <- subsumes (Just val) ty1' ty2'

517 case val' of

526 case val' of

518− Nothing -> throwError . errorMessage $ SubsumptionCheckFailed

527+ Nothing -> internalError "check: unable to check the subsumes relation."

519 Just _ -> do

528 Just _ -> do

520 val''' <- if checkType then withScopedTypeVars moduleName args (check val ty2') else return val

529 val''' <- if checkType then withScopedTypeVars moduleName args (check val ty2') else return val

521 return $ TypedValue checkType val''' ty2'

530 return $ TypedValue checkType val''' ty2'

@@ -528,24 +537,24 @@ check' (IfThenElse cond th el) ty = do

528 th' <- check th ty

537 th' <- check th ty

529 el' <- check el ty

538 el' <- check el ty

530 return $ TypedValue True (IfThenElse cond' th' el') ty

539 return $ TypedValue True (IfThenElse cond' th' el') ty

531−check' (ObjectLiteral ps) t@(TypeApp obj row) | obj == tyObject = do

540+check' e@(ObjectLiteral ps) t@(TypeApp obj row) | obj == tyObject = do

532 ensureNoDuplicateProperties ps

541 ensureNoDuplicateProperties ps

533− ps' <- checkProperties ps row False

542+ ps' <- checkProperties e ps row False

534 return $ TypedValue True (ObjectLiteral ps') t

543 return $ TypedValue True (ObjectLiteral ps') t

535check' (TypeClassDictionaryConstructorApp name ps) t = do

544check' (TypeClassDictionaryConstructorApp name ps) t = do

536 ps' <- check' ps t

545 ps' <- check' ps t

537 return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t

546 return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t

538−check' (ObjectUpdate obj ps) t@(TypeApp o row) | o == tyObject = do

547+check' e@(ObjectUpdate obj ps) t@(TypeApp o row) | o == tyObject = do

539 ensureNoDuplicateProperties ps

548 ensureNoDuplicateProperties ps

540 -- We need to be careful to avoid duplicate labels here.

549 -- We need to be careful to avoid duplicate labels here.

541− -- We check _obj_ agaist the type _t_ with the types in _ps_ replaced with unknowns.

550+ -- We check _obj_ against the type _t_ with the types in _ps_ replaced with unknowns.

542 let (propsToCheck, rest) = rowToList row

551 let (propsToCheck, rest) = rowToList row

543 (removedProps, remainingProps) = partition (\(p, _) -> p `elem` map fst ps) propsToCheck

552 (removedProps, remainingProps) = partition (\(p, _) -> p `elem` map fst ps) propsToCheck

544 us <- zip (map fst removedProps) <$> replicateM (length ps) fresh

553 us <- zip (map fst removedProps) <$> replicateM (length ps) fresh

545 obj' <- check obj (TypeApp tyObject (rowFromList (us ++ remainingProps, rest)))

554 obj' <- check obj (TypeApp tyObject (rowFromList (us ++ remainingProps, rest)))

546− ps' <- checkProperties ps row True

555+ ps' <- checkProperties e ps row True

547 return $ TypedValue True (ObjectUpdate obj' ps') t

556 return $ TypedValue True (ObjectUpdate obj' ps') t

548−check' (Accessor prop val) ty = do

557+check' (Accessor prop val) ty = rethrow (addHint (ErrorCheckingAccessor val prop)) $ do

549 rest <- fresh

558 rest <- fresh

550 val' <- check val (TypeApp tyObject (RCons prop ty rest))

559 val' <- check val (TypeApp tyObject (RCons prop ty rest))

551 return $ TypedValue True (Accessor prop val') ty

560 return $ TypedValue True (Accessor prop val') ty

@@ -557,7 +566,7 @@ check' v@(Constructor c) ty = do

557 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

566 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

558 mv <- subsumes (Just v) repl ty

567 mv <- subsumes (Just v) repl ty

559 case mv of

568 case mv of

560− Nothing -> throwError . errorMessage $ SubsumptionCheckFailed

569+ Nothing -> internalError "check: unable to check the subsumes relation."

561 Just v' -> return $ TypedValue True v' ty

570 Just v' -> return $ TypedValue True v' ty

562check' (Let ds val) ty = do

571check' (Let ds val) ty = do

563 (ds', val') <- inferLetBinding [] ds val (`check` ty)

572 (ds', val') <- inferLetBinding [] ds val (`check` ty)

@@ -572,7 +581,7 @@ check' val ty = do

572 TypedValue _ val' ty' <- infer val

581 TypedValue _ val' ty' <- infer val

573 mt <- subsumes (Just val') ty' ty

582 mt <- subsumes (Just val') ty' ty

574 case mt of

583 case mt of

575− Nothing -> throwError . errorMessage $ SubsumptionCheckFailed

584+ Nothing -> internalError "check: unable to check the subsumes relation."

576 Just v' -> return $ TypedValue True v' ty

585 Just v' -> return $ TypedValue True v' ty

577

586

578-- |

587-- |

@@ -580,8 +589,8 @@ check' val ty = do

580--

589--

581-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.

590-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.

582--

591--

583−checkProperties :: [(String, Expr)] -> Type -> Bool -> UnifyT Type Check [(String, Expr)]

592+checkProperties :: Expr -> [(String, Expr)] -> Type -> Bool -> UnifyT Type Check [(String, Expr)]

584−checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

593+checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' where

585 go [] [] REmpty = return []

594 go [] [] REmpty = return []

586 go [] [] u@(TUnknown _)

595 go [] [] u@(TUnknown _)

587 | lax = return []

596 | lax = return []

@@ -589,8 +598,8 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

589 return []

598 return []

590 go [] [] Skolem{} | lax = return []

599 go [] [] Skolem{} | lax = return []

591 go [] ((p, _): _) _ | lax = return []

600 go [] ((p, _): _) _ | lax = return []

592− | otherwise = throwError . errorMessage $ PropertyIsMissing p row

601+ | otherwise = throwError . errorMessage $ PropertyIsMissing p

593− go ((p,_):_) [] REmpty = throwError . errorMessage $ PropertyIsMissing p row

602+ go ((p,_):_) [] REmpty = throwError . errorMessage $ AdditionalProperty p

594 go ((p,v):ps') ts r =

603 go ((p,v):ps') ts r =

595 case lookup p ts of

604 case lookup p ts of

596 Nothing -> do

605 Nothing -> do

@@ -603,7 +612,7 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

603 v' <- check v ty

612 v' <- check v ty

604 ps'' <- go ps' (delete (p, ty) ts) r

613 ps'' <- go ps' (delete (p, ty) ts) r

605 return $ (p, v') : ps''

614 return $ (p, v') : ps''

606− go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType (ObjectLiteral ps) (TypeApp tyObject row)

615+ go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType expr (TypeApp tyObject row)

607

616

608-- |

617-- |

609-- Check the type of a function application, rethrowing errors to provide a better error message

618-- Check the type of a function application, rethrowing errors to provide a better error message

src/Language/PureScript/TypeChecker/Unify.hs+3−2

@@ -36,6 +36,7 @@ import Control.Monad.Unify

36import Control.Monad.Writer

37import Control.Monad.Error.Class (MonadError(..))

39+import Language.PureScript.Crash

39import Language.PureScript.Errors

40import Language.PureScript.Errors

40import Language.PureScript.TypeChecker.Monad

41import Language.PureScript.TypeChecker.Monad

41import Language.PureScript.TypeChecker.Skolems

42import Language.PureScript.TypeChecker.Skolems

@@ -74,12 +75,12 @@ unifyTypes t1 t2 = rethrow (addHint (ErrorUnifyingTypes t1 t2)) $

74 let sk1 = skolemize ident1 sko sc1' ty1

75 let sk1 = skolemize ident1 sko sc1' ty1

75 let sk2 = skolemize ident2 sko sc2' ty2

76 let sk2 = skolemize ident2 sko sc2' ty2

76 sk1 `unifyTypes` sk2

77 sk1 `unifyTypes` sk2

77− _ -> error "Skolemized type variable was not given a scope"

78+ _ -> internalError "unifyTypes: unspecified skolem scope"

78 unifyTypes' (ForAll ident ty1 (Just sc)) ty2 = do

79 unifyTypes' (ForAll ident ty1 (Just sc)) ty2 = do

79 sko <- newSkolemConstant

80 sko <- newSkolemConstant

80 let sk = skolemize ident sko sc ty1

81 let sk = skolemize ident sko sc ty1

81 sk `unifyTypes` ty2

82 sk `unifyTypes` ty2

82− unifyTypes' ForAll{} _ = throwError . errorMessage $ UnspecifiedSkolemScope

83+ unifyTypes' ForAll{} _ = internalError "unifyTypes: unspecified skolem scope"

83 unifyTypes' ty f@ForAll{} = f `unifyTypes` ty

84 unifyTypes' ty f@ForAll{} = f `unifyTypes` ty

84 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()

85 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()

85 unifyTypes' ty1@(TypeConstructor c1) ty2@(TypeConstructor c2) =

86 unifyTypes' ty1@(TypeConstructor c1) ty2@(TypeConstructor c2) =

tests/Main.hs+3−3

@@ -78,7 +78,7 @@ modulesDir :: FilePath

78modulesDir = ".test_modules" </> "node_modules"

80makeActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make

81−makeActions foreigns = (P.buildMakeActions modulesDir (error "makeActions: input file map was read.") foreigns False)

81+makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False)

82 { P.getInputTimestamp = getInputTimestamp

83 , P.getOutputTimestamp = getOutputTimestamp

84 }

@@ -94,7 +94,7 @@ makeActions foreigns = (P.buildMakeActions modulesDir (error "makeActions: input

94 getOutputTimestamp mn = do

95 let filePath = modulesDir </> P.runModuleName mn

96 exists <- liftIO $ doesDirectoryExist filePath

97− return (if exists then Just (error "getOutputTimestamp: read timestamp") else Nothing)

97+ return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing)

99readInput :: [FilePath] -> IO [(FilePath, String)]

100readInput inputFiles = forM inputFiles $ \inputFile -> do

@@ -104,7 +104,7 @@ readInput inputFiles = forM inputFiles $ \inputFile -> do

104type TestM = WriterT [(FilePath, String)] IO

105

106runTest :: P.Make a -> IO (Either P.MultipleErrors a)

107−runTest = fmap (fmap fst) . P.runMake P.defaultOptions

107+runTest = fmap fst . P.runMake P.defaultOptions

108

109compile :: [FilePath] -> M.Map P.ModuleName FilePath -> IO (Either P.MultipleErrors P.Environment)

110compile inputFiles foreigns = runTest $ do

tests/common/TestsSetup.hs+3−1

@@ -28,6 +28,8 @@ import System.Process

28import System.Directory

29import System.Info

31+import Language.PureScript.Crash

32+

31findNodeProcess :: IO (Maybe String)

33findNodeProcess :: IO (Maybe String)

32findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names

34findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names

33 where

35 where

@@ -35,7 +37,7 @@ findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names

36fetchSupportCode :: IO ()

38fetchSupportCode :: IO ()

37fetchSupportCode = do

39fetchSupportCode = do

38− node <- fromMaybe (error "cannot find node executable") <$> findNodeProcess

40+ node <- fromMaybe (internalError "cannot find node executable") <$> findNodeProcess

39 setCurrentDirectory "tests/support"

41 setCurrentDirectory "tests/support"

40 if System.Info.os == "mingw32"

42 if System.Info.os == "mingw32"

41 then callProcess "setup-win.cmd" []

43 then callProcess "setup-win.cmd" []