purescript 0.5.6.3 → 0.5.7

raw patch · 34 files changed

+655/−327 lines, 34 filesdep −xdg-basedirsetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: xdg-basedir

API changes (from Hackage documentation)

Files

• Setup.hs +1/−33
• docgen/Main.hs +11/−3
• examples/failing/DuplicateProperties1.purs +9/−0
• examples/failing/DuplicateProperties2.purs +9/−0
• examples/failing/Foldable.purs +12/−0
• examples/failing/MissingClassExport.purs +4/−0
• examples/failing/MissingClassMemberExport.purs +4/−0
• examples/failing/OverlappingInstances.purs +11/−0
• examples/failing/OverlappingInstances2.purs +23/−0
• examples/passing/652.purs +15/−0
• examples/passing/BindingGroups.purs +8/−0
• examples/passing/EmptyRow.purs +8/−0
• examples/passing/KindedType.purs +31/−0
• psc-make/Main.hs +1/−5
• psc/Main.hs +1/−5
• psci/Main.hs +32/−5
• purescript.cabal +4/−4
• src/Language/PureScript.hs +3/−47
• src/Language/PureScript/CodeGen/Externs.hs +16/−4
• src/Language/PureScript/CodeGen/JS.hs +1/−38
• src/Language/PureScript/Declarations.hs +3/−3
• src/Language/PureScript/Environment.hs +3/−3
• src/Language/PureScript/Optimizer/MagicDo.hs +2/−2
• src/Language/PureScript/Options.hs +2/−6
• src/Language/PureScript/Parser/Declarations.hs +10/−3
• src/Language/PureScript/Parser/Types.hs +8/−6
• src/Language/PureScript/Pretty/Types.hs +9/−0
• src/Language/PureScript/Sugar/BindingGroups.hs +64/−10
• src/Language/PureScript/Sugar/CaseDeclarations.hs +1/−1
• src/Language/PureScript/Sugar/TypeClasses.hs +9/−11
• src/Language/PureScript/TypeChecker.hs +116/−23
• src/Language/PureScript/TypeChecker/Kinds.hs +16/−5
• src/Language/PureScript/TypeChecker/Types.hs +168/−89
• src/Language/PureScript/Types.hs +40/−21

@@ -1,38 +1,6 @@-{-# LANGUAGE CPP #-}--#ifndef POSIX_LIKE-#define POSIX_LIKE !(defined(_WIN32_HOST_OS) || defined(_WIN64_HOST_OS)) && \-                  (defined(unix_HOST_OS) || defined(__unix___HOST_OS) || \-                   defined(__unix_HOST_OS) || defined(linux_HOST_OS) || \-                   defined(__linux___HOST_OS) || defined(__linux_HOST_OS) || \-                   (defined(__APPLE___HOST_OS) && defined(__MACH___HOST_OS)))-#endif- module Main where -import Control.Monad--import Distribution.PackageDescription import Distribution.Simple-import Distribution.Simple.LocalBuildInfo-import Distribution.Simple.Setup -import System.Directory-import System.Environment.XDG.BaseDir-#if POSIX_LIKE-import System.Posix.Files-#endif- main :: IO ()-main = defaultMainWithHooks $ simpleUserHooks {postInst = setupXDG}--setupXDG :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO ()-setupXDG _ _ _ _ = do-    configDir <- getUserConfigDir "purescript"-    configExists <- doesDirectoryExist configDir-    unless configExists $ do-        createDirectoryIfMissing True configDir-#if POSIX_LIKE-        setFileMode configDir ownerModes-#endif-#undef POSIX_LIKE+main = defaultMain

@@ -141,7 +141,7 @@   atIndent n $ show ident ++ " :: " ++ prettyPrintType' ty renderDeclaration n exps (P.DataDeclaration dtype name args ctors) = do   let-    typeApp  = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map P.TypeVar args)+    typeApp  = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)     typeName = prettyPrintType' typeApp     exported = filter (isDctorExported name exps . fst) ctors   atIndent n $ show dtype ++ " " ++ typeName ++ (if null exported then "" else " where")@@ -151,13 +151,17 @@ renderDeclaration n _ (P.ExternDataDeclaration name kind) =   atIndent n $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind renderDeclaration n _ (P.TypeSynonymDeclaration name args ty) = do-  let typeName = P.runProperName name ++ " " ++ unwords args+  let+    typeApp  = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)+    typeName = prettyPrintType' typeApp       atIndent n $ "type " ++ typeName ++ " = " ++ prettyPrintType' ty renderDeclaration n exps (P.TypeClassDeclaration name args implies ds) = do   let impliesText = case implies of                       [] -> ""                       is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= "-  atIndent n $ "class " ++ impliesText ++ P.runProperName name ++ " " ++ unwords args ++ " where"+      classApp  = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)+      className = prettyPrintType' classApp+  atIndent n $ "class " ++ impliesText ++ className ++ " where"   mapM_ (renderDeclaration (n + 2) exps) ds renderDeclaration n _ (P.TypeInstanceDeclaration name constraints className tys _) = do   let constraintsText = case constraints of@@ -167,6 +171,10 @@ renderDeclaration n exps (P.PositionedDeclaration _ d) =   renderDeclaration n exps d renderDeclaration _ _ _ = return ()++toTypeVar :: (String, Maybe P.Kind) -> P.Type+toTypeVar (s, Nothing) = P.TypeVar s+toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k  prettyPrintType' :: P.Type -> String prettyPrintType' = P.prettyPrintType . P.everywhereOnTypes dePrim

@@ -0,0 +1,9 @@+module DuplicateProperties where++foreign import data Test :: # * -> *++foreign import subtractX "" :: forall r. Test (x :: Unit | r) -> Test r++foreign import hasX "" :: Test (x :: Unit, y :: Unit)++baz = subtractX (subtractX hasX)

@@ -0,0 +1,9 @@+module DuplicateProperties where++foreign import data Test :: # * -> *++foreign import subtractX "" :: forall r. Test (x :: Unit | r) -> Test r++foreign import hasX "" :: forall r. Test (x :: Unit, y :: Unit | r)++baz = subtractX (subtractX hasX)

@@ -0,0 +1,12 @@+module Main where++class Foldable f where+  fold :: forall a b. (a -> b -> b) -> b -> f a -> b+  size :: forall a. f a -> Number++instance foldableArray :: Foldable [] where+  fold _ z [] = z+  fold f z (x:xs) = x `f` (fold f z xs)+  size = fold (const ((+) 1)) 0++x = size [1,2,3]

@@ -0,0 +1,4 @@+module Test (bar) where++  class Foo a where+    bar :: a -> a

@@ -0,0 +1,4 @@+module Test (Foo) where++  class Foo a where+    bar :: a -> a

@@ -0,0 +1,11 @@+module OverlappingInstances where++data A = A++instance showA1 :: Show A where+  show A = "Instance 1"++instance showA2 :: Show A where+  show A = "Instance 2"++main = Debug.Trace.trace $ show A

@@ -0,0 +1,23 @@+module OverlappingInstances where++data A = A | B++instance eqA1 :: Eq A where+  (==) A A = true+  (==) B B = true+  (==) _ _ = false+  (/=) x y = not (x == y)++instance eqA2 :: Eq A where+  (==) _ _ = true+  (/=) _ _ = false++instance ordA :: Ord A where+  compare A B = LT+  compare B A = GT+  compare _ _ = EQ++test :: forall a. (Ord a) => a -> a -> String+test x y = show $ x == y++main = Debug.Trace.trace $ test A B

@@ -0,0 +1,15 @@+module Main where++class Foo a b++class Bar a c++class (Foo a b, Bar a c) <= Baz a b c++instance foo :: Foo (a -> b) a++instance bar :: Bar (a -> b) b++instance baz :: (Eq a) => Baz (a -> b) a b++main = Debug.Trace.trace "Done"

@@ -0,0 +1,8 @@+module Main where+  +foo = bar +  where bar r = r + 1++r = foo 2++main = Debug.Trace.trace "Done"

@@ -0,0 +1,8 @@+module Main where++data Foo r = Foo { | r } ++test :: Foo ()+test = Foo {}++main = Debug.Trace.trace "Done"

@@ -0,0 +1,31 @@+module Main where++type Star2Star f = f :: * -> *++type Star t = t :: *++test1 :: Star2Star [] String+test1 = ["test"]++f :: Star (String -> String)+f s = s++test2 = f "test"++data Proxy (f :: * -> *) = Proxy++test3 :: Proxy []+test3 = Proxy++type Test (f :: * -> *) = f String++test4 :: Test []+test4 = ["test"]++class Clazz (a :: *) where+  def :: a++instance clazzString :: Clazz String where+  def = "test"	++main = Debug.Trace.trace "Done"

@@ -104,10 +104,6 @@ noTco = value $ flag $ (optInfo [ "no-tco" ])      { optDoc = "Disable tail call optimizations" } -performRuntimeTypeChecks :: Term Bool-performRuntimeTypeChecks = value $ flag $ (optInfo [ "runtime-type-checks" ])-     { optDoc = "Generate runtime type checks" }- noPrelude :: Term Bool noPrelude = value $ flag $ (optInfo [ "no-prelude" ])      { optDoc = "Omit the Prelude" }@@ -125,7 +121,7 @@      { optDoc = "Display verbose error messages" }  options :: Term (P.Options P.Make)-options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> pure Nothing <*> noOpts <*> verboseErrors <*> pure P.MakeOptions+options = P.Options <$> noPrelude <*> noTco <*> noMagicDo <*> pure Nothing <*> noOpts <*> verboseErrors <*> pure P.MakeOptions  noPrefix :: Term Bool noPrefix = value $ flag $ (optInfo ["p", "no-prefix" ])

@@ -96,10 +96,6 @@ noTco = value $ flag $ (optInfo [ "no-tco" ])      { optDoc = "Disable tail call optimizations" } -performRuntimeTypeChecks :: Term Bool-performRuntimeTypeChecks = value $ flag $ (optInfo [ "runtime-type-checks" ])-     { optDoc = "Generate runtime type checks" }- noPrelude :: Term Bool noPrelude = value $ flag $ (optInfo [ "no-prelude" ])      { optDoc = "Omit the Prelude" }@@ -137,7 +133,7 @@      { optDoc = "Do not include comment header"}  options :: Term (P.Options P.Compile)-options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> runMain <*> noOpts <*> verboseErrors <*> additionalOptions+options = P.Options <$> noPrelude <*> noTco <*> noMagicDo <*> runMain <*> noOpts <*> verboseErrors <*> additionalOptions   where   additionalOptions = P.CompileOptions <$> browserNamespace <*> dceModules <*> codeGenModules 

@@ -43,7 +43,6 @@         findExecutable, getHomeDirectory, getCurrentDirectory) import System.Process (readProcessWithExitCode) import System.Exit-import System.Environment.XDG.BaseDir import System.FilePath        (pathSeparator, takeDirectory, (</>), isPathSeparator) import qualified System.Console.CmdTheLine as Cmd@@ -114,7 +113,11 @@ -- Grabs the filename where the history is stored. -- getHistoryFilename :: IO FilePath-getHistoryFilename = getUserConfigFile "purescript" "psci_history"+getHistoryFilename = do+  home <- getHomeDirectory+  let filename = home </> ".purescript" </> "psci_history"+  mkdirp filename+  return filename  -- | -- Loads a file for use with imports.@@ -199,7 +202,7 @@ -- | Compilation options. -- options :: P.Options P.Make-options = P.Options False False False False Nothing False False P.MakeOptions+options = P.Options False False False Nothing False False P.MakeOptions  -- | -- PSCI monad@@ -263,6 +266,17 @@   in     P.Module moduleName ((importDecl `map` imports) ++ [itDecl]) Nothing +-- |+-- Makes a volatile module to execute the current imports.+--+createTemporaryModuleForImports :: PSCiState -> P.Module+createTemporaryModuleForImports PSCiState{psciImportedModuleNames = imports} =+  let+    moduleName = P.ModuleName [P.ProperName "$PSCI"]+    importDecl m = P.ImportDeclaration m P.Unqualified Nothing+  in+    P.Module moduleName (importDecl `map` imports) Nothing+ modulesDir :: FilePath modulesDir = ".psci_modules" ++ pathSeparator : "node_modules" @@ -289,6 +303,20 @@         Nothing                        -> PSCI $ outputStrLn "Couldn't find node.js"  -- |+-- Imports a module, preserving the initial state on failure.+--+handleImport :: P.ModuleName -> PSCI ()+handleImport moduleName = do+   s <- liftM (updateImports moduleName) $ PSCI $ lift get+   let m = createTemporaryModuleForImports s+   e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules s ++ [("$PSCI.purs", m)]) []+   case e of+     Left err -> PSCI $ outputStrLn err+     Right _  -> do+       PSCI $ lift $ put s+       return ()++-- | -- Takes a value and prints its type -- handleTypeOf :: P.Expr -> PSCI ()@@ -347,7 +375,7 @@ handleCommand :: Command -> PSCI () handleCommand (Expression val) = handleDeclaration val handleCommand Help = PSCI $ outputStrLn helpMessage-handleCommand (Import moduleName) = PSCI $ lift $ modify (updateImports moduleName)+handleCommand (Import moduleName) = handleImport moduleName handleCommand (Let l) = PSCI $ lift $ modify (updateLets l) handleCommand (LoadFile filePath) = do   absPath <- psciIO $ expandTilde filePath@@ -435,4 +463,3 @@  main :: IO () main = Cmd.run (term, termInfo)-

@@ -1,7 +1,7 @@ name: purescript-version: 0.5.6.3+version: 0.5.7 cabal-version: >=1.8-build-type: Custom+build-type: Simple  license: MIT license-file: LICENSE copyright: (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors@@ -30,7 +30,7 @@                    transformers >= 0.3 && < 0.5, utf8-string -any,                    pattern-arrows >= 0.0.2 && < 0.1,                    monad-unify >= 0.2.2 && < 0.3,-                   xdg-basedir -any, time -any+                   time -any     if (!os(windows))         build-depends: unix -any     exposed-modules: Language.PureScript@@ -115,7 +115,7 @@     build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,                    mtl -any, parsec -any, haskeline >= 0.7.0.0, purescript -any,                    transformers -any, utf8-string -any, process -any,-                   xdg-basedir -any, cmdtheline -any+                   cmdtheline -any     main-is: Main.hs     buildable: True     hs-source-dirs: psci

@@ -38,12 +38,11 @@ import qualified Language.PureScript.Constants as C import qualified Paths_purescript as Paths -import Data.List (find, sortBy, groupBy, intercalate)+import Data.List (sortBy, groupBy, intercalate) import Data.Time.Clock import Data.Function (on) import Data.Maybe (listToMaybe, fromMaybe) import Control.Monad.Error-import Control.Monad.State.Lazy import Control.Arrow ((&&&)) import Control.Applicative import qualified Data.Map as M@@ -51,7 +50,6 @@  import System.FilePath ((</>), pathSeparator) import System.Directory (getHomeDirectory, doesFileExist)-import System.Environment.XDG.BaseDir (getUserConfigDir)  -- | -- Compile a collection of modules@@ -94,43 +92,6 @@   where   mainModuleIdent = moduleNameFromString <$> optionsMain opts -typeCheckModule :: Maybe ModuleName -> Module -> Check Module-typeCheckModule mainModuleName (Module mn decls exps) = do-  modify (\s -> s { checkCurrentModule = Just mn })-  decls' <- typeCheckAll mainModuleName mn exps decls-  mapM_ checkTypesAreExported exps'-  return $ Module mn decls' exps-  where--  exps' = fromMaybe (error "exports should have been elaborated") exps--  -- Check that all the type constructors defined in the current module that appear in member types-  -- have also been exported from the module-  checkTypesAreExported :: DeclarationRef -> Check ()-  checkTypesAreExported (ValueRef name) = do-    ty <- lookupVariable mn (Qualified (Just mn) name)-    case find isTconHidden (findTcons ty) of-      Just hiddenType -> throwError . strMsg $-        "Error in module '" ++ show mn ++ "':\n\-        \Exporting declaration '" ++ show name ++ "' requires type '" ++ show hiddenType ++ "' to be exported as well"-      Nothing -> return ()-  checkTypesAreExported _ = return ()--  -- Find the type constructors exported from the current module used in a type-  findTcons :: Type -> [ProperName]-  findTcons = everythingOnTypes (++) go-    where-    go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [name]-    go _ = []--  -- Checks whether a type constructor is not being exported from the current module-  isTconHidden :: ProperName -> Bool-  isTconHidden tyName = all go exps'-    where-    go (TypeRef tyName' _) = tyName' /= tyName-    go _ = True-- generateMain :: Environment -> Options Compile -> [JS] -> Either String [JS] generateMain env opts js =   case moduleNameFromString <$> optionsMain opts of@@ -272,16 +233,11 @@  preludeFilename :: IO FilePath preludeFilename = fromMaybe missingPrelude . listToMaybe <$> do-  fs <- sequence [xdsPrelude, homePrelude, cabalPrelude]+  fs <- sequence [homePrelude, cabalPrelude]   filterM doesFileExist fs   where   missingPrelude :: FilePath-  missingPrelude = error "No Prelude found in user home, XDS user config directory or cabal path."--  xdsPrelude :: IO FilePath-  xdsPrelude = do-    configDir <- getUserConfigDir "purescript"-    return $ configDir </> "prelude" </> "prelude.purs"+  missingPrelude = error "No Prelude found in user home or cabal path."    homePrelude :: IO FilePath   homePrelude = do

@@ -29,6 +29,8 @@ import Language.PureScript.Declarations import Language.PureScript.Pretty import Language.PureScript.Names+import Language.PureScript.Kinds+import Language.PureScript.Types import Language.PureScript.Environment  -- |@@ -64,12 +66,15 @@           let dtype = if length dctors' == 1 && isNewtypeConstructor env (Qualified (Just moduleName) $ head dctors')                       then "newtype"                       else "data"-          tell [dtype ++ " " ++ show pn ++ " " ++ unwords args ++ (if null dctors' then "" else " = " ++ intercalate " | " (mapMaybe printDctor dctors'))]+              typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing pn)) (map toTypeVar args)+          tell [dtype ++ " " ++ typeName ++ (if null dctors' then "" else " = " ++ intercalate " | " (mapMaybe printDctor dctors'))]         Just (_, TypeSynonym) ->           case Qualified (Just moduleName) pn `M.lookup` typeSynonyms env of             Nothing -> error $ show pn ++ " has no type synonym info in exportToPs"             Just (args, synTy) ->-              tell ["type " ++ show pn ++ " " ++ unwords args ++ " = " ++ prettyPrintType synTy]+              let+                typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing pn)) (map toTypeVar args)+              in tell ["type " ++ typeName ++ " = " ++ prettyPrintType synTy]         _ -> error "Invalid input in exportToPs"      exportToPs (ValueRef ident) =@@ -82,8 +87,11 @@       case Qualified (Just moduleName) className `M.lookup` typeClasses env of         Nothing -> error $ show className ++ " has no type class definition in exportToPs"         Just (args, members, implies) -> do-          let impliesString = if null implies then "" else "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) implies) ++ ") <= "-          tell ["class " ++ impliesString ++ show className ++ " " ++ unwords args ++ " where"]+          let impliesString = if null implies +                              then "" +                              else "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) implies) ++ ") <= "+              typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing className)) (map toTypeVar args)+          tell ["class " ++ impliesString ++ typeName ++ " where"]           forM_ (filter (isValueExported . fst) members) $ \(member ,ty) ->             tell [ "  " ++ show member ++ " :: " ++ prettyPrintType ty ] @@ -94,6 +102,10 @@                               [] -> ""                               cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => "       tell ["foreign import instance " ++ show ident ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)]++    toTypeVar :: (String, Maybe Kind) -> Type+    toTypeVar (s, Nothing) = TypeVar s+    toTypeVar (s, Just k) = KindedType (TypeVar s) k      isValueExported :: Ident -> Bool     isValueExported ident = ValueRef ident `elem` exts

@@ -33,7 +33,6 @@ import Language.PureScript.Declarations import Language.PureScript.Options import Language.PureScript.CodeGen.JS.AST as AST-import Language.PureScript.Types import Language.PureScript.Optimizer import Language.PureScript.CodeGen.Common import Language.PureScript.Environment@@ -95,7 +94,7 @@   js <- valueToJs opts mp e val   return $ Just [JSVariableIntroduction (identToJs ident) (Just js)] declToJs opts mp (BindingGroupDeclaration vals) e = do-  jss <- flip mapM vals $ \(ident, _, val) -> do+  jss <- forM vals $ \(ident, _, val) -> do     js <- valueToJs opts mp e val     return $ JSVariableIntroduction (identToJs ident) (Just js)   return $ Just jss@@ -228,10 +227,6 @@ valueToJs opts m e (Abs (Left arg) val) = do   ret <- valueToJs opts m e val   return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])-valueToJs opts m e (TypedValue _ (Abs (Left arg) val) ty) | optionsPerformRuntimeTypeChecks opts = do-  let arg' = identToJs arg-  ret <- valueToJs opts m e val-  return $ JSFunction Nothing [arg'] (JSBlock $ runtimeTypeChecks arg' ty ++ [JSReturn ret]) valueToJs _ m _ (Var ident) = return $ varToJs m ident valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val valueToJs opts m e (PositionedValue _ val) = valueToJs opts m e val@@ -256,38 +251,6 @@     stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js     extend = map stToAssign sts   return $ JSApp (JSFunction Nothing [] block) []---- |--- Generate code in the simplified Javascript intermediate representation for runtime type checks.----runtimeTypeChecks :: String -> Type -> [JS]-runtimeTypeChecks arg ty =-  let-    argTy = getFunctionArgumentType ty-  in-    maybe [] (argumentCheck (JSVar arg)) argTy-  where-  getFunctionArgumentType :: Type -> Maybe Type-  getFunctionArgumentType (TypeApp (TypeApp t funArg) _) | t == tyFunction = Just funArg-  getFunctionArgumentType (ForAll _ ty' _) = getFunctionArgumentType ty'-  getFunctionArgumentType _ = Nothing-  argumentCheck :: JS -> Type -> [JS]-  argumentCheck val t | t == tyNumber = [typeCheck val "number"]-  argumentCheck val t | t == tyString = [typeCheck val "string"]-  argumentCheck val t | t == tyBoolean = [typeCheck val "boolean"]-  argumentCheck val (TypeApp t _) | t == tyArray = [arrayCheck val]-  argumentCheck val (TypeApp t row) | t == tyObject =-    let-      (pairs, _) = rowToList row-    in-      typeCheck val "object" : concatMap (\(prop, ty') -> argumentCheck (accessorString prop val) ty') pairs-  argumentCheck val (TypeApp (TypeApp t _) _) | t == tyFunction = [typeCheck val "function"]-  argumentCheck val (ForAll _ ty' _) = argumentCheck val ty'-  argumentCheck _ _ = []-  typeCheck :: JS -> String -> JS-  typeCheck js ty' = JSIfElse (JSBinary NotEqualTo (JSTypeOf js) (JSStringLiteral ty')) (JSBlock [JSThrow (JSStringLiteral $ ty' ++ " expected")]) Nothing-  arrayCheck :: JS -> JS-  arrayCheck js = JSIfElse (JSUnary Not (JSApp (JSAccessor "isArray" (JSVar "Array")) [js])) (JSBlock [JSThrow (JSStringLiteral "Array expected")]) Nothing  -- | -- Generate code in the simplified Javascript intermediate representation for a reference to a

@@ -138,7 +138,7 @@   -- |   -- A data type declaration (data or newtype, name, arguments, data constructors)   ---  = DataDeclaration DataDeclType ProperName [String] [(ProperName, [Type])]+  = DataDeclaration DataDeclType ProperName [(String, Maybe Kind)] [(ProperName, [Type])]   -- |   -- A minimal mutually recursive set of data type declarations   --@@ -146,7 +146,7 @@   -- |   -- A type synonym declaration (name, arguments, type)   ---  | TypeSynonymDeclaration ProperName [String] Type+  | TypeSynonymDeclaration ProperName [(String, Maybe Kind)] Type   -- |   -- A type declaration for a value (name, ty)   --@@ -183,7 +183,7 @@   -- |   -- A type class declaration (name, argument, implies, member declarations)   ---  | TypeClassDeclaration ProperName [String] [(Qualified ProperName, [Type])] [Declaration]+  | TypeClassDeclaration ProperName [(String, Maybe Kind)] [(Qualified ProperName, [Type])] [Declaration]   -- |   -- A type instance declaration (name, dependencies, class name, instance types, member   -- declarations)

@@ -45,7 +45,7 @@   -- |   -- Type synonyms currently in scope   ---  , typeSynonyms :: M.Map (Qualified ProperName) ([String], Type)+  , typeSynonyms :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], Type)   -- |   -- Available type class dictionaries   --@@ -53,7 +53,7 @@   -- |   -- Type classes   ---  , typeClasses :: M.Map (Qualified ProperName) ([String], [(Ident, Type)], [(Qualified ProperName, [Type])])+  , typeClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [(Qualified ProperName, [Type])])   } deriving (Show)  -- |@@ -124,7 +124,7 @@   -- |   -- Data type   ---  = DataType [String] [(ProperName, [Type])]+  = DataType [(String, Maybe Kind)] [(ProperName, [Type])]   -- |   -- Type synonym   --

@@ -99,8 +99,8 @@   isEffFunc name (JSAccessor name' (JSVar eff)) = eff == C.eff && name == name'   isEffFunc _ _ = False   -- Check if an expression represents the Monad Eff dictionary-  isEffDict name (JSApp (JSVar ident) []) | ident == name = True-  isEffDict name (JSApp (JSAccessor prop (JSVar eff)) []) = eff == C.eff && prop == name+  isEffDict name (JSVar ident) | ident == name = True+  isEffDict name (JSAccessor prop (JSVar eff)) = eff == C.eff && prop == name   isEffDict _ _ = False   -- Remove __do function applications which remain after desugaring   undo :: JS -> JS

@@ -53,10 +53,6 @@     --   , optionsNoTco :: Bool     -- |-    -- Perform type checks at runtime-    ---  , optionsPerformRuntimeTypeChecks :: Bool-    -- |     -- Disable inlining of calls to return and bind for the Eff monad     --   , optionsNoMagicDo :: Bool@@ -84,10 +80,10 @@ -- Default compiler options -- defaultCompileOptions :: Options Compile-defaultCompileOptions = Options False False False False Nothing False False (CompileOptions "PS" [] [])+defaultCompileOptions = Options False False False Nothing False False (CompileOptions "PS" [] [])  -- | -- Default make options -- defaultMakeOptions :: Options Make-defaultMakeOptions = Options False False False False Nothing False False MakeOptions+defaultMakeOptions = Options False False False Nothing False False MakeOptions

@@ -13,6 +13,8 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE TupleSections #-}+ module Language.PureScript.Parser.Declarations (     parseDeclaration,     parseModule,@@ -28,6 +30,7 @@ import Control.Applicative import Control.Arrow ((+++)) +import Language.PureScript.Kinds import Language.PureScript.Parser.State import Language.PureScript.Parser.Common import Language.PureScript.Declarations@@ -48,11 +51,15 @@   where   toSourcePos p = SourcePos (P.sourceName p) (P.sourceLine p) (P.sourceColumn p) +kindedIdent :: P.Parsec String ParseState (String, Maybe Kind)+kindedIdent = (, Nothing) <$> identifier +          <|> parens ((,) <$> identifier <*> (Just <$> (indented *> lexeme (P.string "::") *> indented *> parseKind)))+ parseDataDeclaration :: P.Parsec String ParseState Declaration parseDataDeclaration = do   dtype <- (reserved "data" *> return Data) <|> (reserved "newtype" *> return Newtype)   name <- indented *> properName-  tyArgs <- many (indented *> identifier)+  tyArgs <- many (indented *> kindedIdent)   ctors <- P.option [] $ do     _ <- lexeme $ indented *> P.char '='     sepBy1 ((,) <$> properName <*> P.many (indented *> parseTypeAtom)) pipe@@ -66,7 +73,7 @@ parseTypeSynonymDeclaration :: P.Parsec String ParseState Declaration parseTypeSynonymDeclaration =   TypeSynonymDeclaration <$> (P.try (reserved "type") *> indented *> properName)-                         <*> many (indented *> identifier)+                         <*> many (indented *> kindedIdent)                          <*> (lexeme (indented *> P.char '=') *> parsePolyType)  parseValueDeclaration :: P.Parsec String ParseState Declaration@@ -163,7 +170,7 @@     reservedOp "<="     return implies   className <- indented *> properName-  idents <- P.many (indented *> identifier)+  idents <- P.many (indented *> kindedIdent)   members <- P.option [] . P.try $ do     indented *> reserved "where"     mark (P.many (same *> positioned parseTypeDeclaration))

@@ -25,6 +25,7 @@ import Language.PureScript.Types import Language.PureScript.Parser.State import Language.PureScript.Parser.Common+import Language.PureScript.Parser.Kinds import Language.PureScript.Environment  import qualified Text.Parsec as P@@ -40,7 +41,7 @@ parseFunction = parens $ P.try (lexeme (P.string "->")) >> return tyFunction  parseObject :: P.Parsec String ParseState Type-parseObject = braces $ TypeApp tyObject <$> parseRow False+parseObject = braces $ TypeApp tyObject <$> parseRow  parseTypeVariable :: P.Parsec String ParseState Type parseTypeVariable = do@@ -67,7 +68,7 @@             , parseTypeVariable             , parseTypeConstructor             , parseForAll-            , parens (parseRow True)+            , parens parseRow             , parens parsePolyType ])  parseConstrainedType :: P.Parsec String ParseState Type@@ -85,10 +86,12 @@   return $ maybe ty (flip ConstrainedType ty) constraints  parseAnyType :: P.Parsec String ParseState Type-parseAnyType = P.buildExpressionParser operators parseTypeAtom P.<?> "type"+parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P.<?> "type"   where   operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]               , [ P.Infix (P.try (lexeme (P.string "->")) >> return function) P.AssocRight ] ]+  postfixTable = [ \t -> KindedType t <$> (P.try (lexeme (indented *> P.string "::")) *> parseKind)+                 ]  -- | -- Parse a monotype@@ -111,6 +114,5 @@ parseRowEnding :: P.Parsec String ParseState Type parseRowEnding = P.option REmpty (TypeVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier)) -parseRow :: Bool -> P.Parsec String ParseState Type-parseRow nonEmpty = (curry rowFromList <$> many' (parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row"-  where many' = if nonEmpty then commaSep1 else commaSep+parseRow :: P.Parsec String ParseState Type+parseRow = (curry rowFromList <$> commaSep (parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row"

@@ -26,7 +26,9 @@ import Control.PatternArrows  import Language.PureScript.Types+import Language.PureScript.Kinds import Language.PureScript.Pretty.Common+import Language.PureScript.Pretty.Kinds import Language.PureScript.Environment  typeLiterals :: Pattern () Type String@@ -71,6 +73,12 @@   match (PrettyPrintFunction arg ret) = Just (arg, ret)   match _ = Nothing +kinded :: Pattern () Type (Kind, Type)+kinded = mkPattern match+  where+  match (KindedType t k) = Just (k, t)+  match _ = Nothing+ insertPlaceholders :: Type -> Type insertPlaceholders = everywhereOnTypesTopDown convertForAlls . everywhereOnTypes convert   where@@ -96,6 +104,7 @@                   , [ AssocR appliedFunction $ \arg ret -> arg ++ " -> " ++ ret                     ]                   , [ Wrap forall_ $ \idents ty -> "forall " ++ unwords idents ++ ". " ++ ty ]+                  , [ Wrap kinded $ \k ty -> ty ++ " :: " ++ prettyPrintKind k ]                   ]  forall_ :: Pattern () Type ([String], Type)

@@ -24,8 +24,11 @@ import Data.Graph import Data.List (nub, intersect) import Data.Maybe (isJust, mapMaybe)+import Data.Monoid ((<>)) import Control.Applicative ((<$>), (<*>), pure) +import qualified Data.Set as S+ import Language.PureScript.Declarations import Language.PureScript.Names import Language.PureScript.Types@@ -56,7 +59,7 @@   dataBindingGroupDecls <- mapM toDataBindingGroup $ stronglyConnComp dataVerts   let allIdents = map getIdent values       valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values-      bindingGroupDecls = map toBindingGroup $ stronglyConnComp valueVerts+  bindingGroupDecls <- mapM (toBindingGroup moduleName) $ stronglyConnComp valueVerts   return $ filter isImportDecl ds ++            filter isExternDataDecl ds ++            filter isExternInstanceDecl ds ++@@ -91,14 +94,33 @@  usedIdents :: ModuleName -> Declaration -> [Ident] usedIdents moduleName =-  let (f, _, _, _, _) = everythingOnValues (++) (const []) usedNames (const []) (const []) (const [])+  let (f, _, _, _, _) = everythingWithContextOnValues S.empty [] (++) def usedNamesE usedNamesB def def   in nub . f   where-  usedNames :: Expr -> [Ident]-  usedNames (Var (Qualified Nothing name)) = [name]-  usedNames (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]-  usedNames _ = []+  def s _ = (s, [])+  +  usedNamesE :: S.Set Ident -> Expr -> (S.Set Ident, [Ident])+  usedNamesE scope (Var (Qualified Nothing name)) | name `S.notMember` scope = (scope, [name])+  usedNamesE scope (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' && name `S.notMember` scope = (scope, [name])+  usedNamesE scope (Abs (Left name) _) = (name `S.insert` scope, [])+  usedNamesE scope _ = (scope, [])+  +  usedNamesB :: S.Set Ident -> Binder -> (S.Set Ident, [Ident])+  usedNamesB scope binder = (scope `S.union` S.fromList (binderNames binder), []) +usedImmediateIdents :: ModuleName -> Declaration -> [Ident]+usedImmediateIdents moduleName =+  let (f, _, _, _, _) = everythingWithContextOnValues True [] (++) def usedNamesE def def def+  in nub . f+  where+  def s _ = (s, [])+  +  usedNamesE :: Bool -> Expr -> (Bool, [Ident])+  usedNamesE True (Var (Qualified Nothing name)) = (True, [name])+  usedNamesE True (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = (True, [name])+  usedNamesE True (Abs _ _) = (False, [])+  usedNamesE scope _ = (scope, [])+ usedProperNames :: ModuleName -> Declaration -> [ProperName] usedProperNames moduleName =   let (f, _, _, _, _) = accumTypes (everythingOnTypes (++) usedNames)@@ -123,10 +145,42 @@ getProperName (PositionedDeclaration _ d) = getProperName d getProperName _ = error "Expected DataDeclaration" -toBindingGroup :: SCC Declaration -> Declaration-toBindingGroup (AcyclicSCC d) = d-toBindingGroup (CyclicSCC [d]) = d-toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration $ map fromValueDecl ds'+-- |+-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).+-- +--+toBindingGroup :: ModuleName -> SCC Declaration -> Either ErrorStack Declaration+toBindingGroup _ (AcyclicSCC d) = return d+toBindingGroup _ (CyclicSCC [d]) = return d+toBindingGroup moduleName (CyclicSCC ds') =+  -- Once we have a mutually-recursive group of declarations, we need to sort+  -- them further by their immediate dependencies (those outside function+  -- bodies). In particular, this is relevant for type instance dictionaries+  -- whose members require other type instances (for example, functorEff+  -- defines (<$>) = liftA1, which depends on applicativeEff). Note that+  -- superclass references are still inside functions, so don't count here.+  -- If we discover declarations that still contain mutually-recursive+  -- immediate references, we're guaranteed to get an undefined reference at+  -- runtime, so treat this as an error. See also github issue #365.+  BindingGroupDeclaration <$> mapM toBinding (stronglyConnComp valueVerts)+  where+  idents :: [Ident]+  idents = map (\(_, i, _) -> i) valueVerts++  valueVerts :: [(Declaration, Ident, [Ident])]+  valueVerts = map (\d -> (d, getIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds'++  toBinding :: SCC Declaration -> Either ErrorStack (Ident, NameKind, Expr)+  toBinding (AcyclicSCC d) = return $ fromValueDecl d+  toBinding (CyclicSCC ~(d:ds)) = cycleError d ds++  cycleError :: Declaration -> [Declaration] -> Either ErrorStack a+  cycleError (PositionedDeclaration p d) ds = rethrowWithPosition p $ cycleError d ds+  cycleError (ValueDeclaration n _ _ _ e) [] = Left $+    mkErrorStack ("Cycle in definition of " ++ show n) (Just (ExprError e))+  cycleError d ds@(_:_) = rethrow (<> mkErrorStack ("The following are not yet defined here: " ++ unwords (map (show . getIdent) ds)) Nothing) $ cycleError d []+  cycleError _ _ = error "Expected ValueDeclaration"+  toDataBindingGroup :: SCC Declaration -> Either ErrorStack Declaration toDataBindingGroup (AcyclicSCC d) = return d

@@ -91,7 +91,7 @@   unless (all ((== length bs) . length . fst) tuples) $       throwError $ mkErrorStack ("Argument list lengths differ in declaration " ++ show ident) Nothing   unless (not (null bs) || isJust g) $-      throwError $ mkErrorStack ("Top level case disallowed in declaration " ++ show ident) Nothing+      throwError $ mkErrorStack ("Duplicate value declaration '" ++ show ident ++ "'") Nothing   caseDecl <- makeCaseDeclaration ident tuples   return [caseDecl] toDecls (PositionedDeclaration pos d : ds) = do

@@ -21,6 +21,7 @@ import Language.PureScript.Declarations import Language.PureScript.Names import Language.PureScript.Types+import Language.PureScript.Kinds import Language.PureScript.Sugar.CaseDeclarations import Language.PureScript.Environment import Language.PureScript.Errors@@ -197,7 +198,7 @@ memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d memberToNameAndType _ = error "Invalid declaration in type class definition" -typeClassDictionaryDeclaration :: ProperName -> [String] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Declaration+typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Declaration typeClassDictionaryDeclaration name args implies members =   let superclassTypes = [ (fieldName, function unit tySynApp)                         | (index, (superclass, tyArgs)) <- zip [0..] implies@@ -208,11 +209,11 @@       mtys = members' ++ superclassTypes   in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (mtys, REmpty)) -typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> Declaration -> Declaration+typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Declaration -> Declaration typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =   ValueDeclaration ident TypeClassAccessorImport [] Nothing $     TypedValue False (Abs (Left $ Ident "dict") (Accessor (runIdent ident) (Var $ Qualified Nothing (Ident "dict")))) $-    moveQuantifiersToFront (quantify (ConstrainedType [(Qualified (Just mn) name, map TypeVar args)] ty))+    moveQuantifiersToFront (quantify (ConstrainedType [(Qualified (Just mn) name, map (TypeVar . fst) args)] ty)) typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =   PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"@@ -240,27 +241,24 @@       let instanceTys = map memberToNameAndType tyDecls        -- Replace the type arguments with the appropriate types in the member types-      let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys+      let memberTypes = map (second (replaceAllTypeVars (zip (map fst args) tys))) instanceTys       -- Create values for the type instance members       memberNames <- map (first runIdent) <$> mapM (memberToNameAndValue memberTypes) decls       -- Create the type of the dictionary       -- The type is an object type, but depending on type instance dependencies, may be constrained.-      -- The dictionary itself is an object literal, but for reasons related to recursion, the dictionary-      -- must be guarded by at least one function abstraction. For that reason, if the dictionary has no-      -- dependencies, we introduce an unnamed function parameter.+      -- The dictionary itself is an object literal.       let superclasses =             [ (fieldName, Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs))             | (index, (superclass, suTyArgs)) <- zip [0..] implies-            , let tyArgs = map (replaceAllTypeVars (zip args tys)) suTyArgs+            , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs             , let fieldName = mkSuperclassDictionaryName superclass index             ]        let memberNames' = ObjectLiteral (memberNames ++ superclasses)           dictTy = foldl TypeApp (TypeConstructor className) tys-          constrainedTy = quantify (if null deps then function unit dictTy else ConstrainedType deps dictTy)+          constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)           dict = TypeClassDictionaryConstructorApp className memberNames'-          dict' = if null deps then Abs (Left (Ident C.__unused)) dict else dict-          result = ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict' constrainedTy)+          result = ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)       return result    where

@@ -17,7 +17,7 @@  module Language.PureScript.TypeChecker (     module T,-    typeCheckAll+    typeCheckModule ) where  import Language.PureScript.TypeChecker.Monad as T@@ -26,7 +26,7 @@ import Language.PureScript.TypeChecker.Synonyms as T  import Data.Maybe-import Data.List (nub, (\\))+import Data.List (nub, (\\), find, intercalate) import Data.Monoid ((<>)) import Data.Foldable (for_) import qualified Data.Map as M@@ -42,13 +42,13 @@ import Language.PureScript.Environment import Language.PureScript.Errors -addDataType :: ModuleName -> DataDeclType -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()+addDataType :: ModuleName -> DataDeclType -> ProperName -> [(String, Maybe Kind)] -> [(ProperName, [Type])] -> Kind -> Check () addDataType moduleName dtype name args dctors ctorKind = do   env <- getEnv   putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }   forM_ dctors $ \(dctor, tys) ->     rethrow (strMsg ("Error in data constructor " ++ show dctor) <>) $-      addDataConstructor moduleName dtype name args dctor tys+      addDataConstructor moduleName dtype name (map fst args) dctor tys  addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check () addDataConstructor moduleName dtype name args dctor tys = do@@ -58,7 +58,7 @@   let polyType = mkForAll args dctorTy   putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType) (dataConstructors env) } -addTypeSynonym :: ModuleName -> ProperName -> [String] -> Type -> Kind -> Check ()+addTypeSynonym :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Type -> Kind -> Check () addTypeSynonym moduleName name args ty kind = do   env <- getEnv   putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env)@@ -76,7 +76,7 @@   env <- getEnv   putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) }) -addTypeClass :: ModuleName -> ProperName -> [String] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Check ()+addTypeClass :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Check () addTypeClass moduleName pn args implies ds =   let members = map toPair ds in   modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }@@ -119,19 +119,20 @@ -- --  * Process module imports ---typeCheckAll :: Maybe ModuleName -> ModuleName -> Maybe [DeclarationRef] -> [Declaration] -> Check [Declaration]+typeCheckAll :: Maybe ModuleName -> ModuleName -> [DeclarationRef] -> [Declaration] -> Check [Declaration] typeCheckAll mainModuleName moduleName exps = go   where   go :: [Declaration] -> Check [Declaration]   go [] = return []-  go (d@(DataDeclaration dtype name args dctors) : rest) = do+  go (DataDeclaration dtype name args dctors : rest) = do     rethrow (strMsg ("Error in type constructor " ++ show name) <>) $ do       when (dtype == Newtype) $ checkNewtype dctors-      checkDuplicateTypeArguments args+      checkDuplicateTypeArguments $ map fst args       ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)-      addDataType moduleName dtype name args dctors ctorKind+      let args' = args `withKinds` ctorKind+      addDataType moduleName dtype name args' dctors ctorKind     ds <- go rest-    return $ d : ds+    return $ DataDeclaration dtype name args dctors : ds     where     checkNewtype :: [(ProperName, [Type])] -> Check ()     checkNewtype [(_, [_])] = return ()@@ -143,11 +144,13 @@       let dataDecls = mapMaybe toDataDecl tys       (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)       forM_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do-        checkDuplicateTypeArguments args-        addDataType moduleName dtype name args dctors ctorKind+        checkDuplicateTypeArguments $ map fst args+        let args' = args `withKinds` ctorKind +        addDataType moduleName dtype name args' dctors ctorKind       forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do-        checkDuplicateTypeArguments args-        addTypeSynonym moduleName name args ty kind+        checkDuplicateTypeArguments $ map fst args+        let args' = args `withKinds` kind+        addTypeSynonym moduleName name args' ty kind     ds <- go rest     return $ d : ds     where@@ -157,13 +160,14 @@     toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)     toDataDecl (PositionedDeclaration _ d') = toDataDecl d'     toDataDecl _ = Nothing-  go (d@(TypeSynonymDeclaration name args ty) : rest) = do+  go (TypeSynonymDeclaration name args ty : rest) = do     rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ do-      checkDuplicateTypeArguments args+      checkDuplicateTypeArguments $ map fst args       kind <- kindsOf False moduleName name args [ty]-      addTypeSynonym moduleName name args ty kind+      let args' = args `withKinds` kind+      addTypeSynonym moduleName name args' ty kind     ds <- go rest-    return $ d : ds+    return $ TypeSynonymDeclaration name args ty : ds   go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"   go (ValueDeclaration name nameKind [] Nothing val : rest) = do     d <- rethrow (strMsg ("Error in declaration " ++ show name) <>) $ do@@ -219,7 +223,7 @@     addTypeClass moduleName pn args implies tys     ds <- go rest     return $ d : ds-  go (TypeInstanceDeclaration dictName deps className tys _ : rest) = do+  go (TypeInstanceDeclaration dictName deps className tys _ : rest) =     go (ExternInstanceDeclaration dictName deps className tys : rest)   go (d@(ExternInstanceDeclaration dictName deps className tys) : rest) = do     mapM_ (checkTypeClassInstance moduleName) tys@@ -229,18 +233,107 @@     return $ d : ds     where     isInstanceExported :: Bool-    isInstanceExported = maybe True (any exportsInstance) exps -    +    isInstanceExported = any exportsInstance exps+     exportsInstance :: DeclarationRef -> Bool     exportsInstance (TypeInstanceRef name) | name == dictName = True     exportsInstance (PositionedDeclarationRef _ r) = exportsInstance r     exportsInstance _ = False-    +   go (PositionedDeclaration pos d : rest) =     rethrowWithPosition pos $ do       (d' : rest') <- go (d : rest)       return (PositionedDeclaration pos d' : rest')+  +  -- |+  -- This function adds the argument kinds for a type constructor so that they may appear in the externs file, +  -- extracted from the kind of the type constructor itself.+  --+  withKinds :: [(String, Maybe Kind)] -> Kind -> [(String, Maybe Kind)]+  withKinds []                  _               = []+  withKinds (s@(_, Just _ ):ss) (FunKind _   k) = s : withKinds ss k+  withKinds (  (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2+  withKinds _                   _               = error "Invalid arguments to peelKinds" +-- |+-- Type check an entire module and ensure all types and classes defined within the module that are+-- required by exported members are also exported.+--+typeCheckModule :: Maybe ModuleName -> Module -> Check Module+typeCheckModule _ (Module _ _ Nothing) = error "exports should have been elaborated"+typeCheckModule mainModuleName (Module mn decls (Just exps)) = do+  modify (\s -> s { checkCurrentModule = Just mn })+  decls' <- typeCheckAll mainModuleName mn exps decls+  forM_ exps $ \e -> do+    checkTypesAreExported e+    checkClassMembersAreExported e+    checkClassesAreExported e+  return $ Module mn decls' (Just exps)+  where +  checkMemberExport :: (Show a) => String -> (Type -> [a]) -> (a -> Bool) -> DeclarationRef -> Check ()+  checkMemberExport thing extract test (ValueRef name) = do+    ty <- lookupVariable mn (Qualified (Just mn) name)+    case find test (extract ty) of+      Just hiddenType -> throwError . strMsg $+        "Error in module '" ++ show mn ++ "':\n\+        \Exporting declaration '" ++ show name ++ "' requires " ++ thing ++ " '" ++ show hiddenType ++ "' to be exported as well"+      Nothing -> return ()+  checkMemberExport _ _ _ _ = return () +  -- Check that all the type constructors defined in the current module that appear in member types+  -- have also been exported from the module+  checkTypesAreExported :: DeclarationRef -> Check ()+  checkTypesAreExported = checkMemberExport "type" findTcons isTconHidden+    where+    findTcons :: Type -> [ProperName]+    findTcons = everythingOnTypes (++) go+      where+      go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [name]+      go _ = []+    isTconHidden :: ProperName -> Bool+    isTconHidden tyName = all go exps+      where+      go (TypeRef tyName' _) = tyName' /= tyName+      go _ = True +  -- Check that all the classes defined in the current module that appear in member types have also+  -- been exported from the module+  checkClassesAreExported :: DeclarationRef -> Check ()+  checkClassesAreExported = checkMemberExport "class" findClasses isClassHidden+    where+    findClasses :: Type -> [ProperName]+    findClasses = everythingOnTypes (++) go+      where+      go (ConstrainedType cs _) = mapMaybe (extractCurrentModuleClass . fst) cs+      go _ = []+    extractCurrentModuleClass :: Qualified ProperName -> Maybe ProperName+    extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name+    extractCurrentModuleClass _ = Nothing+    isClassHidden :: ProperName -> Bool+    isClassHidden clsName = all go exps+      where+      go (TypeClassRef clsName') = clsName' /= clsName+      go _ = True++  checkClassMembersAreExported :: DeclarationRef -> Check ()+  checkClassMembersAreExported (TypeClassRef name) = do+    let members = ValueRef `map` head (mapMaybe findClassMembers decls)+    let missingMembers = members \\ exps+    unless (null missingMembers) $+      throwError . strMsg $+        "Error in module '" ++ show mn ++ "':\n\+        \Class '" ++ show name ++ "' is exported but is missing member exports for '" ++ intercalate "', '" (map (show . runValueRef) missingMembers) ++ "'"+    where+    runValueRef :: DeclarationRef -> Ident+    runValueRef (ValueRef refName) = refName+    runValueRef _ = error "non-ValueRef passed to runValueRef"+    findClassMembers :: Declaration -> Maybe [Ident]+    findClassMembers (TypeClassDeclaration name' _ _ ds) | name == name' = Just $ map extractMemberName ds+    findClassMembers (PositionedDeclaration _ d) = findClassMembers d+    findClassMembers _ = Nothing+    extractMemberName :: Declaration -> Ident+    extractMemberName (PositionedDeclaration _ d) = extractMemberName d+    extractMemberName (TypeDeclaration memberName _) = memberName+    extractMemberName _ = error "Unexpected declaration in typeclass member list"+  checkClassMembersAreExported _ = return ()

@@ -80,20 +80,27 @@ -- | -- Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors ---kindsOf :: Bool -> ModuleName -> ProperName -> [String] -> [Type] -> Check Kind+kindsOf :: Bool -> ModuleName -> ProperName -> [(String, Maybe Kind)] -> [Type] -> Check Kind kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do   tyCon <- fresh   kargs <- replicateM (length args) fresh-  let dict = (name, tyCon) : zipWith (\arg kind -> (arg, kind)) (map ProperName args) kargs+  rest <- zipWithM freshKindVar args kargs+  let dict = (name, tyCon) : rest    bindLocalTypeVariables moduleName dict $     solveTypes isData ts kargs tyCon   where   tidyUp (k, sub) = starIfUnknown $ sub $? k+  +freshKindVar :: (String, Maybe Kind) -> Kind -> UnifyT Kind Check (ProperName, Kind)+freshKindVar (arg, Nothing) kind = return (ProperName arg, kind)+freshKindVar (arg, Just kind') kind = do+  kind =?= kind'+  return (ProperName arg, kind')  -- | -- Simultaneously infer the kinds of several mutually recursive type constructors ---kindsOfAll :: ModuleName -> [(ProperName, [String], Type)] -> [(ProperName, [String], [Type])] -> Check ([Kind], [Kind])+kindsOfAll :: ModuleName -> [(ProperName, [(String, Maybe Kind)], Type)] -> [(ProperName, [(String, Maybe Kind)], [Type])] -> Check ([Kind], [Kind]) kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do   synVars <- replicateM (length syns) fresh   let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars@@ -103,12 +110,12 @@     bindLocalTypeVariables moduleName dict' $ do       data_ks <- zipWithM (\tyCon (_, args, ts) -> do         kargs <- replicateM (length args) fresh-        let argDict = zip (map ProperName args) kargs+        argDict <- zipWithM freshKindVar args kargs         bindLocalTypeVariables moduleName argDict $           solveTypes True ts kargs tyCon) tyCons tys       syn_ks <- zipWithM (\synVar (_, args, ty) -> do         kargs <- replicateM (length args) fresh-        let argDict = zip (map ProperName args) kargs+        argDict <- zipWithM freshKindVar args kargs         bindLocalTypeVariables moduleName argDict $           solveTypes False [ty] kargs synVar) synVars syns       return (syn_ks, data_ks)@@ -179,6 +186,10 @@   k <- infer ty   k =?= Star   return Star+infer' (KindedType ty k) = do+  k' <- infer ty+  k =?= k'+  return k' infer' _ = error "Invalid argument to infer"  

@@ -124,6 +124,8 @@     t3 `unifyTypes` t5     t4 `unifyTypes` t6   unifyTypes' (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = return ()+  unifyTypes' (KindedType ty1 _) ty2 = ty1 `unifyTypes` ty2+  unifyTypes' ty1 (KindedType ty2 _) = ty1 `unifyTypes` ty2   unifyTypes' r1@RCons{} r2 = unifyRows r1 r2   unifyTypes' r1 r2@RCons{} = unifyRows r1 r2   unifyTypes' r1@REmpty r2 = unifyRows r1 r2@@ -154,12 +156,12 @@   unifyRows' :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> UnifyT Type Check ()   unifyRows' [] (TUnknown u) sd r = u =:= rowFromList (sd, r)   unifyRows' sd r [] (TUnknown u) = u =:= rowFromList (sd, r)-  unifyRows' ((name, ty):row) r others u@(TUnknown un) = do-    occursCheck un ty-    forM_ row $ \(_, t) -> occursCheck un t-    u' <- fresh-    u =?= RCons name ty u'-    unifyRows' row r others u'+  unifyRows' sd1 (TUnknown u1) sd2 (TUnknown u2) = do+    forM_ sd1 $ \(_, t) -> occursCheck u2 t+    forM_ sd2 $ \(_, t) -> occursCheck u1 t+    rest <- fresh+    u1 =:= rowFromList (sd2, rest)+    u2 =:= rowFromList (sd1, rest)   unifyRows' [] REmpty [] REmpty = return ()   unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()   unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return ()@@ -188,6 +190,8 @@     val' <- replaceTypeClassDictionaries moduleName val     -- Check skolem variables did not escape their scope     skolemEscapeCheck val'+    -- Check rows do not contain duplicate labels+    checkDuplicateLabels val'     -- Remove type synonyms placeholders, remove duplicate row fields, and replace     -- top-level unification variables with named type variables.     let val'' = overTypes (desaturateAllTypeSynonyms . setifyAll) val'@@ -316,89 +320,119 @@     filterModule _ = False      solve context' (className, tys) trySuperclasses =-      let-        dicts = go trySuperclasses className tys-      in case sortedNubBy dictTrace (chooseSimplestDictionaries dicts) of-           [] -> throwError . strMsg $ "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)-           [_] -> return $ dictionaryValueToValue $ head dicts-           _ -> throwError . strMsg $ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)+      checkOverlaps $ go trySuperclasses className tys       where-	  go trySuperclasses' className' tys' =-	    -- Look for regular type instances-	    [ mkDictionary (canonicalizeDictionary tcd) args-	    | tcd <- context'-	    -- Make sure the type class name matches the one we are trying to satisfy-	    , className' == tcdClassName tcd-	    -- Make sure the type unifies with the type in the type instance definition-	    , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)-	    -- Solve any necessary subgoals-	    , args <- solveSubgoals subst (tcdDependencies tcd) ] ++--	    -- Look for implementations via superclasses-	    [ SubclassDictionaryValue suDict superclass index-	    | trySuperclasses'-	    , (subclassName, (args, _, implies)) <- M.toList (typeClasses env)-	    -- Try each superclass-	    , (index, (superclass, suTyArgs)) <- zip [0..] implies-	    -- Make sure the type class name matches the superclass name-	    , className' == superclass-	    -- Make sure the types unify with the types in the superclass implication-	    , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs-	    -- Finally, satisfy the subclass constraint-	    , args' <- maybeToList $ mapM (flip lookup subst) args-	    , suDict <- go True subclassName args' ]--	  -- Create dictionaries for subgoals which still need to be solved by calling go recursively-	  -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type-	  -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.-	  solveSubgoals :: [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [DictionaryValue]]-	  solveSubgoals _ Nothing = return Nothing-	  solveSubgoals subst (Just subgoals) = do-	    dict <- mapM (uncurry (go True) . second (map (replaceAllTypeVars subst))) subgoals-	    return $ Just dict-	  -- Make a dictionary from subgoal dictionaries by applying the correct function-	  mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue-	  mkDictionary fnName Nothing = LocalDictionaryValue fnName-	  mkDictionary fnName (Just []) = GlobalDictionaryValue fnName-	  mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts-	  -- Turn a DictionaryValue into a Expr-	  dictionaryValueToValue :: DictionaryValue -> Expr-	  dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName-	  dictionaryValueToValue (GlobalDictionaryValue fnName) = App (Var fnName) valUndefined-	  dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)-	  dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) =-	    App (Accessor (C.__superclass_ ++ show superclassName ++ "_" ++ show index)-	                  (dictionaryValueToValue dict))-	        valUndefined-	  -- Ensure that a substitution is valid-	  verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]-	  verifySubstitution subst = do-	    let grps = groupBy ((==) `on` fst) subst-	    guard (all (pairwise (unifiesWith env) . map snd) grps)-	    return $ map head grps-	  -- Choose the simplest DictionaryValues from a list of candidates-	  -- The reason for this function is as follows:-	  -- When considering overlapping instances, we don't want to consider the same dictionary-	  -- to be an overlap of itself when obtained as a superclass of another class.-	  -- Observing that we probably don't want to select a superclass instance when an instance-	  -- is available directly, and that there is no way for a superclass instance to actually-	  -- introduce an overlap that wouldn't have been there already, we simply remove dictionaries-	  -- obtained as superclass instances if there are simpler instances available.-	  chooseSimplestDictionaries :: [DictionaryValue] -> [DictionaryValue]-	  chooseSimplestDictionaries ds = case filter isSimpleDictionaryValue ds of-	                                    [] -> ds-	                                    simple -> simple-	  isSimpleDictionaryValue SubclassDictionaryValue{} = False-	  isSimpleDictionaryValue (DependentDictionaryValue _ ds) = all isSimpleDictionaryValue ds-	  isSimpleDictionaryValue _ = True-	  -- |-	  -- Get the "trace" of a DictionaryValue - that is, remove all SubclassDictionaryValue-	  -- data constructors-	  ---	  dictTrace :: DictionaryValue -> DictionaryValue-	  dictTrace (DependentDictionaryValue fnName dicts) = DependentDictionaryValue fnName $ map dictTrace dicts-	  dictTrace (SubclassDictionaryValue dict _ _) = dictTrace dict-	  dictTrace other = other+      go trySuperclasses' className' tys' =+        -- Look for regular type instances+        [ mkDictionary (canonicalizeDictionary tcd) args+        | tcd <- context'+        -- Make sure the type class name matches the one we are trying to satisfy+        , className' == tcdClassName tcd+        -- Make sure the type unifies with the type in the type instance definition+        , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)+        -- Solve any necessary subgoals+        , args <- solveSubgoals subst (tcdDependencies tcd) ] +++      +        -- Look for implementations via superclasses+        [ SubclassDictionaryValue suDict superclass index+        | trySuperclasses'+        , (subclassName, (args, _, implies)) <- M.toList (typeClasses env)+        -- Try each superclass+        , (index, (superclass, suTyArgs)) <- zip [0..] implies+        -- Make sure the type class name matches the superclass name+        , className' == superclass+        -- Make sure the types unify with the types in the superclass implication+        , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs+        -- Finally, satisfy the subclass constraint+        , args' <- maybeToList $ mapM (flip lookup subst) (map fst args)+        , suDict <- go True subclassName args' ]+      +      -- Create dictionaries for subgoals which still need to be solved by calling go recursively+      -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type+      -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.+      solveSubgoals :: [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [DictionaryValue]]+      solveSubgoals _ Nothing = return Nothing+      solveSubgoals subst (Just subgoals) = do+        dict <- mapM (uncurry (go True) . second (map (replaceAllTypeVars subst))) subgoals+        return $ Just dict+      -- Make a dictionary from subgoal dictionaries by applying the correct function+      mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue+      mkDictionary fnName Nothing = LocalDictionaryValue fnName+      mkDictionary fnName (Just []) = GlobalDictionaryValue fnName+      mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts+      -- Turn a DictionaryValue into a Expr+      dictionaryValueToValue :: DictionaryValue -> Expr+      dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName+      dictionaryValueToValue (GlobalDictionaryValue fnName) = Var fnName+      dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)+      dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) =+        App (Accessor (C.__superclass_ ++ show superclassName ++ "_" ++ show index)+                      (dictionaryValueToValue dict))+            valUndefined+      -- Ensure that a substitution is valid+      verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]+      verifySubstitution subst = do+        let grps = groupBy ((==) `on` fst) subst+        guard (all (pairwise (unifiesWith env) . map snd) grps)+        return $ map head grps+      -- |+      -- Check for overlapping instances+      --+      checkOverlaps :: [DictionaryValue] -> Check Expr    +      checkOverlaps dicts = +        case [ (d1, d2) | d1 <- dicts, d2 <- dicts, d1 `overlapping` d2 ] of+          (d1, d2) : _ -> throwError . strMsg $ unlines+            [ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintType tys) ++ "."+            , "For example:"+            , prettyPrintDictionaryValue d1+            , "and:"+            , prettyPrintDictionaryValue d2+            ]+          _ -> case chooseSimplestDictionaries dicts of+                 [] -> throwError . strMsg $ +                         "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)+                 d : _ -> return $ dictionaryValueToValue d+      -- Choose the simplest DictionaryValues from a list of candidates+      -- The reason for this function is as follows:+      -- When considering overlapping instances, we don't want to consider the same dictionary+      -- to be an overlap of itself when obtained as a superclass of another class.+      -- Observing that we probably don't want to select a superclass instance when an instance+      -- is available directly, and that there is no way for a superclass instance to actually+      -- introduce an overlap that wouldn't have been there already, we simply remove dictionaries+      -- obtained as superclass instances if there are simpler instances available.+      chooseSimplestDictionaries :: [DictionaryValue] -> [DictionaryValue]+      chooseSimplestDictionaries ds = case filter isSimpleDictionaryValue ds of+                                        [] -> ds+                                        simple -> simple+      isSimpleDictionaryValue SubclassDictionaryValue{} = False+      isSimpleDictionaryValue (DependentDictionaryValue _ ds) = all isSimpleDictionaryValue ds+      isSimpleDictionaryValue _ = True+      -- |+      -- Check if two dictionaries are overlapping+      -- +      -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have+      -- been caught when constructing superclass dictionaries.+      --+      overlapping :: DictionaryValue -> DictionaryValue -> Bool+      overlapping (LocalDictionaryValue nm1)         (LocalDictionaryValue nm2)  | nm1 == nm2 = False+      overlapping (GlobalDictionaryValue nm1)        (GlobalDictionaryValue nm2) | nm1 == nm2 = False+      overlapping (DependentDictionaryValue nm1 ds1) (DependentDictionaryValue nm2 ds2) +        | nm1 == nm2 = any id $ zipWith overlapping ds1 ds2+      overlapping (SubclassDictionaryValue _ _ _) _ = False+      overlapping _ (SubclassDictionaryValue _ _ _) = False+      overlapping _ _ = True+      -- |+      -- Render a DictionaryValue fit for human consumption in error messages+      --+      prettyPrintDictionaryValue :: DictionaryValue -> String+      prettyPrintDictionaryValue = unlines . indented 0+        where+        indented n (LocalDictionaryValue _)           = [spaces n ++ "Dictionary in scope"]+        indented n (GlobalDictionaryValue nm)         = [spaces n ++ show nm]+        indented n (DependentDictionaryValue nm args) = (spaces n ++ show nm ++ " via") : concatMap (indented (n + 2)) args+        indented n (SubclassDictionaryValue sup nm _) = (spaces n ++ show nm ++ " via superclass") : indented (n + 2) sup+        +        spaces n = replicate n ' ' ++ "- "      valUndefined :: Expr     valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))@@ -482,6 +516,41 @@ skolemEscapeCheck val = throwError $ mkErrorStack "Untyped value passed to skolemEscapeCheck" (Just (ExprError val))  -- |+-- Ensure rows do not contain duplicate labels+--+checkDuplicateLabels :: Expr -> Check ()+checkDuplicateLabels = +  let (_, f, _) = everywhereOnValuesM def go def +  in void . f+  where +  def :: a -> Check a+  def = return+   +  go :: Expr -> Check Expr+  go e@(TypedValue _ _ ty) = checkDups ty >> return e+  go other = return other+  +  checkDups :: Type -> Check ()+  checkDups (TypeApp t1 t2) = checkDups t1 >> checkDups t2+  checkDups (SaturatedTypeSynonym _ ts) = mapM_ checkDups ts+  checkDups (ForAll _ t _) = checkDups t+  checkDups (ConstrainedType args t) = do+    mapM_ (checkDups) $ concatMap snd args+    checkDups t +  checkDups r@(RCons _ _ _) = +    let (ls, _) = rowToList r in +    case firstDup . sort . map fst $ ls of+      Just l -> throwError . strMsg $ "Duplicate label " ++ show l ++ " in row"+      Nothing -> return ()+  checkDups _ = return ()+  +  firstDup :: (Eq a) => [a] -> Maybe a+  firstDup (x : xs@(x' : _)) +    | x == x' = Just x+    | otherwise = firstDup xs+  firstDup _ = Nothing++-- | -- Ensure a row contains no duplicate labels -- setify :: Type -> Type@@ -563,7 +632,7 @@ expandTypeSynonym' env name args =   case M.lookup name (typeSynonyms env) of     Just (synArgs, body) -> do-      let repl = replaceAllTypeVars (zip synArgs args) body+      let repl = replaceAllTypeVars (zip (map fst synArgs) args) body       replaceAllTypeSynonyms' env repl     Nothing -> error "Type synonym was not defined" @@ -974,6 +1043,10 @@ check' val ty | containsTypeSynonyms ty = do   ty' <- introduceSkolemScope <=< expandAllTypeSynonyms $ ty   check val ty'+check' val kt@(KindedType ty kind) = do+  guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star+  val' <- check' val ty+  return $ TypedValue True val' kt check' (PositionedValue pos val) ty =   rethrowWithPosition pos $ check val ty check' val ty = throwError $ mkErrorStack ("Expr does not have type " ++ prettyPrintType ty) (Just (ExprError val))@@ -1056,6 +1129,8 @@ checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg ret = do   ty <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs   checkFunctionApplication fn ty arg ret+checkFunctionApplication' fn (KindedType ty _) arg ret = do+  checkFunctionApplication fn ty arg ret checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do   dicts <- getTypeClassDictionaries   checkFunctionApplication' (foldl App fn (map (flip (TypeClassDictionary True) dicts) constraints)) fnTy arg ret@@ -1099,6 +1174,10 @@   subsumes val ty1 ty2 subsumes' val ty1 (SaturatedTypeSynonym name tyArgs) = do   ty2 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs+  subsumes val ty1 ty2+subsumes' val (KindedType ty1 _) ty2 = do+  subsumes val ty1 ty2+subsumes' val ty1 (KindedType ty2 _) = do   subsumes val ty1 ty2 subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do   dicts <- getTypeClassDictionaries

@@ -26,6 +26,7 @@ import Control.Monad ((<=<))  import Language.PureScript.Names+import Language.PureScript.Kinds import Language.PureScript.Traversals  -- |@@ -78,6 +79,11 @@   --   | RCons String Type Type   -- |+  -- A type with a kind annotation+  -- +  | KindedType Type Kind+  --+  -- |   -- A placeholder used in pretty printing   --   | PrettyPrintFunction Type Type@@ -126,23 +132,36 @@ -- Replace a type variable, taking into account variable shadowing -- replaceTypeVars :: String -> Type -> Type -> Type-replaceTypeVars = replaceTypeVars' []+replaceTypeVars v r = replaceAllTypeVars [(v, r)]++-- |+-- Replace named type variables with types+--+replaceAllTypeVars :: [(String, Type)] -> Type -> Type+replaceAllTypeVars = go []   where-  replaceTypeVars' bound name replacement = go bound+      +  go :: [String] -> [(String, Type)] -> Type -> Type+  go _  m (TypeVar v) = +    case v `lookup` m of+      Just r -> r+      Nothing -> TypeVar v+  go bs m (TypeApp t1 t2) = TypeApp (go bs m t1) (go bs m t2)+  go bs m (SaturatedTypeSynonym name' ts) = SaturatedTypeSynonym name' $ map (go bs m) ts+  go bs m f@(ForAll v t sco) | v `elem` keys = go bs (filter ((/= v) . fst) m) f+                             | v `elem` usedVars =+                               let v' = genName v (keys ++ bs ++ usedVars)+                                   t' = go bs [(v, TypeVar v')] t+                               in ForAll v' (go (v' : bs) m t') sco+                             | otherwise = ForAll v (go (v : bs) m t) sco     where-    go :: [String] -> Type -> Type-    go _  (TypeVar v) | v == name = replacement-    go bs (TypeApp t1 t2) = TypeApp (go bs t1) (go bs t2)-    go bs (SaturatedTypeSynonym name' ts) = SaturatedTypeSynonym name' $ map (go bs) ts-    go bs f@(ForAll v t sco) | v == name = f-                             | v `elem` usedTypeVariables replacement =-                                 let v' = genName v (name : bs ++ usedTypeVariables replacement)-                                     t' = replaceTypeVars' bs v (TypeVar v') t-                                 in ForAll v' (go (v' : bs) t') sco-                             | otherwise = ForAll v (go (v : bs) t) sco-    go bs (ConstrainedType cs t) = ConstrainedType (map (second $ map (go bs)) cs) (go bs t)-    go bs (RCons name' t r) = RCons name' (go bs t) (go bs r)-    go _ ty = ty+    keys = map fst m+    usedVars = concatMap (usedTypeVariables . snd) m+  go bs m (ConstrainedType cs t) = ConstrainedType (map (second $ map (go bs m)) cs) (go bs m t)+  go bs m (RCons name' t r) = RCons name' (go bs m t) (go bs m r)+  go bs m (KindedType t k) = KindedType (go bs m t) k+  go _  _ ty = ty+     genName orig inUse = try 0     where     try :: Integer -> String@@ -150,12 +169,6 @@           | otherwise = orig ++ show n  -- |--- Replace named type variables with types----replaceAllTypeVars :: [(String, Type)] -> Type -> Type-replaceAllTypeVars = foldl (\f (name, ty) -> replaceTypeVars name ty . f) id---- | -- Collect all type variables appearing in a type -- usedTypeVariables :: Type -> [String]@@ -177,6 +190,7 @@   go bound (ForAll v t _) = go (v : bound) t   go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) . snd) cs ++ go bound t   go bound (RCons _ t r) = go bound t ++ go bound r+  go bound (KindedType t _) = go bound t   go _ _ = []  -- |@@ -213,6 +227,7 @@   go (ForAll arg ty sco) = f (ForAll arg (go ty) sco)   go (ConstrainedType cs ty) = f (ConstrainedType (map (fmap (map go)) cs) (go ty))   go (RCons name ty rest) = f (RCons name (go ty) (go rest))+  go (KindedType ty k) = f (KindedType (go ty) k)   go (PrettyPrintFunction t1 t2) = f (PrettyPrintFunction (go t1) (go t2))   go (PrettyPrintArray t) = f (PrettyPrintArray (go t))   go (PrettyPrintObject t) = f (PrettyPrintObject (go t))@@ -227,6 +242,7 @@   go (ForAll arg ty sco) = ForAll arg (go (f ty)) sco   go (ConstrainedType cs ty) = ConstrainedType (map (fmap (map (go . f))) cs) (go (f ty))   go (RCons name ty rest) = RCons name (go (f ty)) (go (f rest))+  go (KindedType ty k) = KindedType (go (f ty)) k   go (PrettyPrintFunction t1 t2) = PrettyPrintFunction (go (f t1)) (go (f t2))   go (PrettyPrintArray t) = PrettyPrintArray (go (f t))   go (PrettyPrintObject t) = PrettyPrintObject (go (f t))@@ -241,6 +257,7 @@   go (ForAll arg ty sco) = (ForAll arg <$> go ty <*> pure sco) >>= f   go (ConstrainedType cs ty) = (ConstrainedType <$> mapM (sndM (mapM go)) cs <*> go ty) >>= f   go (RCons name ty rest) = (RCons name <$> go ty <*> go rest) >>= f+  go (KindedType ty k) = (KindedType <$> go ty <*> pure k) >>= f   go (PrettyPrintFunction t1 t2) = (PrettyPrintFunction <$> go t1 <*> go t2) >>= f   go (PrettyPrintArray t) = (PrettyPrintArray <$> go t) >>= f   go (PrettyPrintObject t) = (PrettyPrintObject <$> go t) >>= f@@ -255,6 +272,7 @@   go (ForAll arg ty sco) = ForAll arg <$> (f ty >>= go) <*> pure sco   go (ConstrainedType cs ty) = ConstrainedType <$> mapM (sndM (mapM (go <=< f))) cs <*> (f ty >>= go)   go (RCons name ty rest) = RCons name <$> (f ty >>= go) <*> (f rest >>= go)+  go (KindedType ty k) = KindedType <$> (f ty >>= go) <*> pure k   go (PrettyPrintFunction t1 t2) = PrettyPrintFunction <$> (f t1 >>= go) <*> (f t2 >>= go)   go (PrettyPrintArray t) = PrettyPrintArray <$> (f t >>= go)   go (PrettyPrintObject t) = PrettyPrintObject <$> (f t >>= go)@@ -269,6 +287,7 @@   go t@(ForAll _ ty _) = f t <> go ty   go t@(ConstrainedType cs ty) = foldl (<>) (f t) (map go $ concatMap snd cs) <> go ty   go t@(RCons _ ty rest) = f t <> go ty <> go rest+  go t@(KindedType ty _) = f t <> go ty   go t@(PrettyPrintFunction t1 t2) = f t <> go t1 <> go t2   go t@(PrettyPrintArray t1) = f t <> go t1   go t@(PrettyPrintObject t1) = f t <> go t1