purescript 0.5.3 → 0.5.4

raw patch · 32 files changed

+1021/−260 lines, 32 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• docgen/Main.hs +7/−6
• hierarchy/Main.hs +2/−1
• prelude/prelude.purs +185/−31
• psci/Commands.hs +5/−0
• psci/Main.hs +36/−1
• psci/Parser.hs +8/−1
• purescript.cabal +2/−1
• src/Language/PureScript.hs +23/−16
• src/Language/PureScript/CodeGen/Common.hs +58/−6
• src/Language/PureScript/CodeGen/Externs.hs +6/−2
• src/Language/PureScript/CodeGen/JS.hs +91/−41
• src/Language/PureScript/CodeGen/JS/AST.hs +12/−1
• src/Language/PureScript/Constants.hs +23/−2
• src/Language/PureScript/DeadCodeElimination.hs +16/−8
• src/Language/PureScript/Declarations.hs +14/−3
• src/Language/PureScript/Environment.hs +33/−3
• src/Language/PureScript/Optimizer.hs +1/−0
• src/Language/PureScript/Optimizer/Blocks.hs +12/−3
• src/Language/PureScript/Optimizer/Inliner.hs +43/−2
• src/Language/PureScript/Optimizer/MagicDo.hs +9/−0
• src/Language/PureScript/Parser/Common.hs +1/−0
• src/Language/PureScript/Parser/Declarations.hs +2/−2
• src/Language/PureScript/Parser/Types.hs +1/−13
• src/Language/PureScript/Pretty/JS.hs +11/−3
• src/Language/PureScript/Pretty/Values.hs +7/−2
• src/Language/PureScript/Renamer.hs +206/−0
• src/Language/PureScript/Sugar/BindingGroups.hs +1/−1
• src/Language/PureScript/Sugar/Names.hs +6/−4
• src/Language/PureScript/Sugar/TypeClasses.hs +101/−43
• src/Language/PureScript/TypeChecker.hs +20/−14
• src/Language/PureScript/TypeChecker/Monad.hs +35/−4
• src/Language/PureScript/TypeChecker/Types.hs +44/−46

@@ -25,6 +25,7 @@ import qualified System.IO.UTF8 as U import System.Console.CmdTheLine import System.Exit (exitSuccess, exitFailure)+import System.IO (stderr)  docgen :: Bool -> [FilePath] -> IO () docgen showHierarchy input = do@@ -37,7 +38,7 @@   text <- U.readFile input   case P.runIndentParser input P.parseModules text of     Left err -> do-      U.print err+      U.hPutStr stderr $ show err       exitFailure     Right ms -> do       return ms@@ -106,7 +107,7 @@   where   matches (P.TypeDeclaration ident _) (P.ValueRef ident') = ident == ident'   matches (P.ExternDeclaration _ ident _ _) (P.ValueRef ident') = ident == ident'-  matches (P.DataDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident'+  matches (P.DataDeclaration _ ident _ _) (P.TypeRef ident' _) = ident == ident'   matches (P.ExternDataDeclaration ident _) (P.TypeRef ident' _) = ident == ident'   matches (P.TypeSynonymDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident'   matches (P.TypeClassDeclaration ident _ _ _) (P.TypeClassRef ident') = ident == ident'@@ -138,10 +139,10 @@   atIndent n $ show ident ++ " :: " ++ prettyPrintType' ty renderDeclaration n _ (P.ExternDeclaration _ ident _ ty) =   atIndent n $ show ident ++ " :: " ++ prettyPrintType' ty-renderDeclaration n exps (P.DataDeclaration name args ctors) = do+renderDeclaration n exps (P.DataDeclaration dtype name args ctors) = do   let typeName = P.runProperName name ++ (if null args then "" else " " ++ unwords args)   let exported = filter (isDctorExported name exps . fst) ctors-  atIndent n $ "data " ++ typeName ++ (if null exported then "" else " where")+  atIndent n $ show dtype ++ " " ++ typeName ++ (if null exported then "" else " where")   forM_ exported $ \(ctor, tys) ->     atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ concatMap (\ty -> prettyPrintType' ty ++ " -> ") tys ++ typeName renderDeclaration n _ (P.ExternDataDeclaration name kind) =@@ -168,14 +169,14 @@ prettyPrintType' = P.prettyPrintType . P.everywhereOnTypes dePrim   where   dePrim ty@(P.TypeConstructor (P.Qualified _ name))-    | ty == P.tyBoolean || ty == P.tyNumber || ty == P.tyString = +    | ty == P.tyBoolean || ty == P.tyNumber || ty == P.tyString =       P.TypeConstructor $ P.Qualified Nothing name   dePrim other = other  getName :: P.Declaration -> String getName (P.TypeDeclaration ident _) = show ident getName (P.ExternDeclaration _ ident _ _) = show ident-getName (P.DataDeclaration name _ _) = P.runProperName name+getName (P.DataDeclaration _ name _ _) = P.runProperName name getName (P.ExternDataDeclaration name _) = P.runProperName name getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name getName (P.TypeClassDeclaration name _ _ _) = P.runProperName name

@@ -26,6 +26,7 @@ import System.Directory (createDirectoryIfMissing) import System.FilePath ((</>)) import System.Exit (exitFailure, exitSuccess)+import System.IO (stderr)  import Text.Parsec (ParseError) @@ -57,7 +58,7 @@ compile input mOutput = do   modules <- readInput input   case modules of-    Left err -> U.print err >> exitFailure+    Left err -> U.hPutStr stderr (show err) >> exitFailure     Right ms -> do       for_ ms $ \(P.Module moduleName decls _) ->         let name = runModuleName moduleName

@@ -228,7 +228,7 @@     (%) = numMod     negate = numNegate -  data Unit = Unit {}+  newtype Unit = Unit {}    unit :: Unit   unit = Unit {}@@ -332,12 +332,21 @@     LT -> false     _ -> true -  foreign import unsafeCompare-    "function unsafeCompare(n1) {\-    \  return function(n2) {\-    \    return n1 < n2 ? LT : n1 > n2 ? GT : EQ;\+  foreign import unsafeCompareImpl+    "function unsafeCompareImpl(lt) {\+    \  return function (eq) {\+    \    return function (gt) {\+    \      return function (x) {\+    \        return function (y) {\+    \          return x < y ? lt : x > y ? gt : eq;\+    \        };\+    \      };\+    \    };\     \  };\-    \}" :: forall a. a -> a -> Ordering+    \}" :: forall a. Ordering -> Ordering -> Ordering -> a -> a -> Ordering+    +  unsafeCompare :: forall a. a -> a -> Ordering+  unsafeCompare = unsafeCompareImpl LT EQ GT    instance ordUnit :: Ord Unit where     compare (Unit {}) (Unit {}) = EQ@@ -490,88 +499,128 @@   foreign import data Fn3 :: * -> * -> * -> * -> *   foreign import data Fn4 :: * -> * -> * -> * -> * -> *   foreign import data Fn5 :: * -> * -> * -> * -> * -> * -> *+  foreign import data Fn6 :: * -> * -> * -> * -> * -> * -> * -> *+  foreign import data Fn7 :: * -> * -> * -> * -> * -> * -> * -> * -> *+  foreign import data Fn8 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> *+  foreign import data Fn9 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *+  foreign import data Fn10 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *    foreign import mkFn0-    "function mkFn0(f) {\+    "function mkFn0(fn) {\     \  return function() {\-    \    return f({});\+    \    return fn({});\     \  };\     \}" :: forall a. (Unit -> a) -> Fn0 a    foreign import mkFn1-    "function mkFn1(f) {\+    "function mkFn1(fn) {\     \  return function(a) {\-    \    return f(a);\+    \    return fn(a);\     \  };\     \}" :: forall a b. (a -> b) -> Fn1 a b    foreign import mkFn2-    "function mkFn2(f) {\+    "function mkFn2(fn) {\     \  return function(a, b) {\-    \    return f(a)(b);\+    \    return fn(a)(b);\     \  };\     \}" :: forall a b c. (a -> b -> c) -> Fn2 a b c    foreign import mkFn3-    "function mkFn3(f) {\+    "function mkFn3(fn) {\     \  return function(a, b, c) {\-    \    return f(a)(b)(c);\+    \    return fn(a)(b)(c);\     \  };\     \}" :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d    foreign import mkFn4-    "function mkFn4(f) {\+    "function mkFn4(fn) {\     \  return function(a, b, c, d) {\-    \    return f(a)(b)(c)(d);\+    \    return fn(a)(b)(c)(d);\     \  };\     \}" :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e    foreign import mkFn5-    "function mkFn5(f) {\+    "function mkFn5(fn) {\     \  return function(a, b, c, d, e) {\-    \    return f(a)(b)(c)(d)(e);\+    \    return fn(a)(b)(c)(d)(e);\     \  };\     \}" :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f +  foreign import mkFn6+    "function mkFn6(fn) {\+    \  return function(a, b, c, d, e, f) {\+    \    return fn(a)(b)(c)(d)(e)(f);\+    \  };\+    \}" :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> Fn6 a b c d e f g++  foreign import mkFn7+    "function mkFn7(fn) {\+    \  return function(a, b, c, d, e, f, g) {\+    \    return fn(a)(b)(c)(d)(e)(f)(g);\+    \  };\+    \}" :: forall a b c d e f g h. (a -> b -> c -> d -> e -> f -> g -> h) -> Fn7 a b c d e f g h++  foreign import mkFn8+    "function mkFn8(fn) {\+    \  return function(a, b, c, d, e, f, g, h) {\+    \    return fn(a)(b)(c)(d)(e)(f)(g)(h);\+    \  };\+    \}" :: forall a b c d e f g h i. (a -> b -> c -> d -> e -> f -> g -> h -> i) -> Fn8 a b c d e f g h i++  foreign import mkFn9+    "function mkFn9(fn) {\+    \  return function(a, b, c, d, e, f, g, h, i) {\+    \    return fn(a)(b)(c)(d)(e)(f)(g)(h)(i);\+    \  };\+    \}" :: forall a b c d e f g h i j. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -> Fn9 a b c d e f g h i j++  foreign import mkFn10+    "function mkFn10(fn) {\+    \  return function(a, b, c, d, e, f, g, h, i, j) {\+    \    return fn(a)(b)(c)(d)(e)(f)(g)(h)(i)(j);\+    \  };\+    \}" :: forall a b c d e f g h i j k. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) -> Fn10 a b c d e f g h i j k+   foreign import runFn0-    "function runFn0(f) {\-    \  return f();\+    "function runFn0(fn) {\+    \  return fn();\     \}" :: forall a. Fn0 a -> a    foreign import runFn1-    "function runFn1(f) {\+    "function runFn1(fn) {\     \  return function(a) {\-    \    return f(a);\+    \    return fn(a);\     \  };\     \}" :: forall a b. Fn1 a b -> a -> b    foreign import runFn2-    "function runFn2(f) {\+    "function runFn2(fn) {\     \  return function(a) {\     \    return function(b) {\-    \      return f(a, b);\+    \      return fn(a, b);\     \    };\     \  };\     \}" :: forall a b c. Fn2 a b c -> a -> b -> c    foreign import runFn3-    "function runFn3(f) {\+    "function runFn3(fn) {\     \  return function(a) {\     \    return function(b) {\     \      return function(c) {\-    \        return f(a, b, c);\+    \        return fn(a, b, c);\     \      };\     \    };\     \  };\     \}" :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d    foreign import runFn4-    "function runFn4(f) {\+    "function runFn4(fn) {\     \  return function(a) {\     \    return function(b) {\     \      return function(c) {\     \        return function(d) {\-    \          return f(a, b, c, d);\+    \          return fn(a, b, c, d);\     \        };\     \      };\     \    };\@@ -579,13 +628,13 @@     \}" :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e    foreign import runFn5-    "function runFn5(f) {\+    "function runFn5(fn) {\     \  return function(a) {\     \    return function(b) {\     \      return function(c) {\     \        return function(d) {\     \          return function(e) {\-    \            return f(a, b, c, d, e);\+    \            return fn(a, b, c, d, e);\     \          };\     \        };\     \      };\@@ -593,9 +642,114 @@     \  };\     \}" :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f +  foreign import runFn6+    "function runFn6(fn) {\+    \  return function(a) {\+    \    return function(b) {\+    \      return function(c) {\+    \        return function(d) {\+    \          return function(e) {\+    \            return function(f) {\+    \              return fn(a, b, c, d, e, f);\+    \            };\+    \          };\+    \        };\+    \      };\+    \    };\+    \  };\+    \}" :: forall a b c d e f g. Fn6 a b c d e f g -> a -> b -> c -> d -> e -> f -> g++  foreign import runFn7+    "function runFn7(fn) {\+    \  return function(a) {\+    \    return function(b) {\+    \      return function(c) {\+    \        return function(d) {\+    \          return function(e) {\+    \            return function(f) {\+    \              return function(g) {\+    \                return fn(a, b, c, d, e, f, g);\+    \              };\+    \            };\+    \          };\+    \        };\+    \      };\+    \    };\+    \  };\+    \}" :: forall a b c d e f g h. Fn7 a b c d e f g h -> a -> b -> c -> d -> e -> f -> g -> h++  foreign import runFn8+    "function runFn8(fn) {\+    \  return function(a) {\+    \    return function(b) {\+    \      return function(c) {\+    \        return function(d) {\+    \          return function(e) {\+    \            return function(f) {\+    \              return function(g) {\+    \                return function(h) {\+    \                  return fn(a, b, c, d, e, f, g, h);\+    \                };\+    \              };\+    \            };\+    \          };\+    \        };\+    \      };\+    \    };\+    \  };\+    \}" :: forall a b c d e f g h i. Fn8 a b c d e f g h i -> a -> b -> c -> d -> e -> f -> g -> h -> i++  foreign import runFn9+    "function runFn9(fn) {\+    \  return function(a) {\+    \    return function(b) {\+    \      return function(c) {\+    \        return function(d) {\+    \          return function(e) {\+    \            return function(f) {\+    \              return function(g) {\+    \                return function(h) {\+    \                  return function(i) {\+    \                    return fn(a, b, c, d, e, f, g, h, i);\+    \                  };\+    \                };\+    \              };\+    \            };\+    \          };\+    \        };\+    \      };\+    \    };\+    \  };\+    \}" :: forall a b c d e f g h i j. Fn9 a b c d e f g h i j -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j++  foreign import runFn10+    "function runFn10(fn) {\+    \  return function(a) {\+    \    return function(b) {\+    \      return function(c) {\+    \        return function(d) {\+    \          return function(e) {\+    \            return function(f) {\+    \              return function(g) {\+    \                return function(h) {\+    \                  return function(i) {\+    \                    return function(j) {\+    \                      return fn(a, b, c, d, e, f, g, h, i, j);\+    \                    };\+    \                  };\+    \                };\+    \              };\+    \            };\+    \          };\+    \        };\+    \      };\+    \    };\+    \  };\+    \}" :: forall a b c d e f g h i j k. Fn10 a b c d e f g h i j k -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k+ module Data.Eq where -  data Ref a = Ref a+  newtype Ref a = Ref a    liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b   liftRef f (Ref x) (Ref y) = f x y

@@ -53,6 +53,10 @@   -- Find the type of an expression   --   | TypeOf Value+  -- |+  -- Find the kind of an expression+  -- +  | KindOf Type  -- | -- The help menu.@@ -65,4 +69,5 @@   , [":q          ", "Quit PSCi"]   , [":r          ", "Reset"]   , [":t <expr>   ", "Show the type of <expr>"]+  , [":k <type>   ", "Show the kind of <type>"]   ]

@@ -24,6 +24,7 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad.Trans.State.Strict+import qualified Control.Monad.Trans.State.Lazy as L import Control.Monad.Error (ErrorT(..), MonadError) import Control.Monad.Error.Class (MonadError(..)) @@ -256,6 +257,18 @@   in     P.Module moduleName ((importDecl `map` imports) ++ decls) Nothing +-- |+-- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration.+--+createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module+createTemporaryModuleForKind PSCiState{psciImportedModuleNames = imports} typ =+  let+    moduleName = P.ModuleName [P.ProperName "Main"]+    importDecl m = P.ImportDeclaration m Nothing Nothing+    itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ+  in+    P.Module moduleName ((importDecl `map` imports) ++ [itDecl]) Nothing+ modulesDir :: FilePath modulesDir = ".psci_modules" ++ pathSeparator : "node_modules" @@ -293,9 +306,30 @@     Left err -> PSCI $ outputStrLn err     Right env' ->       case M.lookup (P.ModuleName [P.ProperName "Main"], P.Ident "it") (P.names env') of-        Just (ty, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty+        Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty         Nothing -> PSCI $ outputStrLn "Could not find type" +-- |+-- Takes a value and prints its kind+--+handleKindOf :: P.Type -> PSCI ()+handleKindOf typ = do+  st <- PSCI $ lift get+  let m = createTemporaryModuleForKind st typ+      mName = P.ModuleName [P.ProperName "Main"]+  e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("Main.purs", m)])+  case e of+    Left err -> PSCI $ outputStrLn err+    Right env' ->+      case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of+        Just (_, typ') -> do+          let chk = P.CheckState env' 0 0 (Just mName)+              k   = L.runStateT (P.unCheck (P.kindOf mName typ')) chk+          case k of +            Left errStack   -> PSCI . outputStrLn . P.prettyPrintErrorStack False $ errStack+            Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind+        Nothing -> PSCI $ outputStrLn "Could not find kind"+ -- Commands  -- |@@ -339,6 +373,7 @@     Left err -> psciIO $ putStrLn err >> exitFailure     Right modules -> PSCI . lift $ put (PSCiState files defaultImports modules []) handleCommand (TypeOf val) = handleTypeOf val+handleCommand (KindOf typ) = handleKindOf typ handleCommand _ = PSCI $ outputStrLn "Unknown command"  inputFiles :: Cmd.Term [FilePath]

@@ -42,7 +42,7 @@ -- parseCommand :: String -> Either ParseError Command parseCommand = P.runIndentParser "" $ choice-                    [ P.whiteSpace *> char ':' *> (psciHelp <|> psciImport <|> psciLoadFile <|> psciQuit <|> psciReload <|> psciTypeOf)+                    [ P.whiteSpace *> char ':' *> (psciHelp <|> psciImport <|> psciLoadFile <|> psciQuit <|> psciReload <|> psciTypeOf <|> psciKindOf)                     , try psciLet                     , psciExpression                     ] <* eof@@ -90,3 +90,10 @@ -- psciTypeOf :: Parsec String P.ParseState Command psciTypeOf = TypeOf <$> (char 't' *> P.whiteSpace *> P.parseValue)+++-- |+-- Parses 'Commands.KindOf' command.+--+psciKindOf :: Parsec String P.ParseState Command+psciKindOf = KindOf <$> (char 'k' *> P.whiteSpace *> P.parseType)

@@ -1,5 +1,5 @@ name: purescript-version: 0.5.3+version: 0.5.4 cabal-version: >=1.8 build-type: Custom license: MIT@@ -76,6 +76,7 @@                      Language.PureScript.Pretty.Kinds                      Language.PureScript.Pretty.Types                      Language.PureScript.Pretty.Values+                     Language.PureScript.Renamer                      Language.PureScript.TypeChecker                      Language.PureScript.TypeChecker.Kinds                      Language.PureScript.TypeChecker.Monad

@@ -31,6 +31,7 @@ import Language.PureScript.Errors as P import Language.PureScript.DeadCodeElimination as P import Language.PureScript.Supply as P+import Language.PureScript.Renamer as P  import qualified Language.PureScript.Constants as C @@ -70,14 +71,15 @@  compile' :: Environment -> Options -> [Module] -> Either String (String, String, Environment) compile' env opts ms = do-  (sorted, _) <- sortModules $ if optionsNoPrelude opts then ms else (map importPrelude ms)+  (sorted, _) <- sortModules $ map importPrim $ if optionsNoPrelude opts then ms else (map importPrelude ms)   (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted   (elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent   regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated   let entryPoints = moduleNameFromString `map` optionsModules opts   let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped+  let renamed = renameInModules elim   let codeGenModules = moduleNameFromString `map` optionsCodeGenModules opts-  let modulesToCodeGen = if null codeGenModules then elim else filter (\(Module mn _ _) -> mn `elem` codeGenModules) elim+  let modulesToCodeGen = if null codeGenModules then renamed else filter (\(Module mn _ _) -> mn `elem` codeGenModules) renamed   let js = evalSupply nextVar $ concat <$> mapM (\m -> moduleToJs Globals opts m env') modulesToCodeGen   let exts = intercalate "\n" . map (`moduleToPs` env') $ modulesToCodeGen   js' <- generateMain env' opts js@@ -170,7 +172,7 @@ make outputDir opts ms = do   let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms) -  (sorted, graph) <- liftError $ sortModules $ if optionsNoPrelude opts then map snd ms else (map (importPrelude . snd) ms)+  (sorted, graph) <- liftError $ sortModules $ map importPrim $ if optionsNoPrelude opts then map snd ms else (map (importPrelude . snd) ms)    toRebuild <- foldM (\s (Module moduleName' _ _) -> do     let filePath = runModuleName moduleName'@@ -212,9 +214,11 @@     regrouped <- lift . liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated      let mod' = Module moduleName' regrouped exps-    js <- prettyPrintJS <$> moduleToJs CommonJS opts mod' env'-    let exts = moduleToPs mod' env'+    let [renamed] = renameInModules [mod']  +    js <- prettyPrintJS <$> moduleToJs CommonJS opts renamed env'+    let exts = moduleToPs renamed env'+     lift $ writeTextFile jsFile js     lift $ writeTextFile externsFile exts @@ -241,16 +245,19 @@   combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst)  -- |--- Add an import declaration for the Prelude to a module if it does not already explicitly import--- it.+-- Add an import declaration for a module if it does not already explicitly import it. ---importPrelude :: Module -> Module-importPrelude m@(Module mn decls exps)  =-  if isPreludeImport `any` decls || mn == prelude then m-  else Module mn (preludeImport : decls) exps+addDefaultImport :: ModuleName -> Module -> Module+addDefaultImport toImport m@(Module mn decls exps)  =+  if isExistingImport `any` decls || mn == toImport then m+  else Module mn (ImportDeclaration toImport Nothing Nothing : decls) exps   where-  prelude = ModuleName [ProperName C.prelude]-  isPreludeImport (ImportDeclaration (ModuleName [ProperName mn']) _ _) | mn' == C.prelude = True-  isPreludeImport (PositionedDeclaration _ d) = isPreludeImport d-  isPreludeImport _ = False-  preludeImport = ImportDeclaration prelude Nothing Nothing+  isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True+  isExistingImport (PositionedDeclaration _ d) = isExistingImport d+  isExistingImport _ = False++importPrim :: Module -> Module+importPrim = addDefaultImport (ModuleName [ProperName C.prim])++importPrelude :: Module -> Module+importPrelude = addDefaultImport (ModuleName [ProperName C.prelude])

@@ -17,7 +17,14 @@  import Data.Char import Data.List (intercalate)+import Data.Maybe (fromMaybe)+import Data.Function (on)++import qualified Data.Map as M+ import Language.PureScript.Names+import Language.PureScript.Environment+import Language.PureScript.Types  -- | -- Convert an Ident into a valid Javascript identifier:@@ -34,6 +41,12 @@ identToJs (Op op) = concatMap identCharToString op  -- |+-- Test if a string is a valid JS identifier without escaping.+--+identNeedsEscaping :: String -> Bool+identNeedsEscaping s = s /= identToJs (Ident s)++-- | -- Attempts to find a human-readable name for a symbol, if none has been specified returns the -- ordinal value. --@@ -130,12 +143,51 @@               , "with"               , "yield" ] +moduleNameToJs :: ModuleName -> String+moduleNameToJs (ModuleName pns) = intercalate "_" (runProperName `map` pns)+ -- |--- Test if a string is a valid JS identifier (may return false negatives)+-- Finds the value stored for a data constructor in the current environment.+-- This is a partial function, but if an invalid type has reached this far then+-- something has gone wrong in typechecking. ---isIdent :: String -> Bool-isIdent s@(first : rest) | not (nameIsJsReserved s) && isAlpha first && all isAlphaNum rest = True-isIdent _ = False+lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type)+lookupConstructor e ctor = fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors e -moduleNameToJs :: ModuleName -> String-moduleNameToJs (ModuleName pns) = intercalate "_" (runProperName `map` pns)+-- |+-- Checks whether a data constructor is the only constructor for that type, used+-- to simplify the check when generating code for binders.+--+isOnlyConstructor :: Environment -> Qualified ProperName -> Bool+isOnlyConstructor e ctor = numConstructors (ctor, lookupConstructor e ctor) == 1+  where+  numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> Int+  numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors e+  typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> (ModuleName, ProperName)+  typeConstructor (Qualified (Just moduleName) _, (_, tyCtor, _)) = (moduleName, tyCtor)+  typeConstructor _ = error "Invalid argument to isOnlyConstructor"++-- |+-- Checks whether a data constructor is for a newtype.+--+isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool+isNewtypeConstructor e ctor = case lookupConstructor e ctor of+  (Newtype, _, _) -> True+  (Data, _, _) -> False++-- |+-- Checks the number of arguments a data constructor accepts.+--+getConstructorArity :: Environment -> Qualified ProperName -> Int+getConstructorArity e = go . (\(_, _, ctors) -> ctors) . lookupConstructor e+  where+  go :: Type -> Int+  go (TypeApp (TypeApp f _) t) | f == tyFunction = go t + 1+  go (ForAll _ ty _) = go ty+  go _ = 0++-- |+-- Checks whether a data constructor has no arguments, for example, `Nothing`.+--+isNullaryConstructor :: Environment -> Qualified ProperName -> Bool+isNullaryConstructor e = (== 0) . getConstructorArity e

@@ -24,6 +24,7 @@  import Control.Monad.Writer +import Language.PureScript.CodeGen.Common import Language.PureScript.TypeClassDictionaries import Language.PureScript.Declarations import Language.PureScript.Pretty@@ -60,7 +61,10 @@               printDctor dctor = case dctor `lookup` tys of                                    Nothing -> Nothing                                    Just tyArgs -> Just $ show dctor ++ " " ++ unwords (map prettyPrintTypeAtom tyArgs)-          tell ["data " ++ show pn ++ " " ++ unwords args ++ (if null dctors' then "" else " = " ++ intercalate " | " (mapMaybe printDctor dctors'))]+          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'))]         Just (_, TypeSynonym) ->           case Qualified (Just moduleName) pn `M.lookup` typeSynonyms env of             Nothing -> error $ show pn ++ " has no type synonym info in exportToPs"@@ -71,7 +75,7 @@     exportToPs (ValueRef ident) =       case (moduleName, ident) `M.lookup` names env of         Nothing -> error $ show ident ++ " has no type in exportToPs"-        Just (ty, nameKind) | nameKind == Value || nameKind == Extern ForeignImport || nameKind == Extern InlineJavascript ->+        Just (ty, nameKind, _) | nameKind == Value || nameKind == Extern ForeignImport || nameKind == Extern InlineJavascript ->           tell ["foreign import " ++ show ident ++ " :: " ++ prettyPrintType ty]         _ -> return ()     exportToPs (TypeClassRef className) =

@@ -20,18 +20,16 @@     ModuleType(..),     declToJs,     moduleToJs,-    isIdent+    identNeedsEscaping ) where -import Data.Maybe (catMaybes, fromJust, fromMaybe)+import Data.Maybe (catMaybes, fromJust) import Data.Function (on)-import Data.List (nub, (\\))+import Data.List (nub, (\\), delete, sortBy)  import Control.Monad (replicateM, forM) import Control.Applicative -import qualified Data.Map as M- import Language.PureScript.Names import Language.PureScript.Declarations import Language.PureScript.Options@@ -42,6 +40,7 @@ import Language.PureScript.Environment import Language.PureScript.Supply import Language.PureScript.Traversals (sndM)+import qualified Language.PureScript.Constants as C  -- | -- Different types of modules which are supported@@ -54,7 +53,7 @@ -- moduleToJs :: (Functor m, Applicative m, Monad m) => ModuleType -> Options -> Module -> Environment -> SupplyT m [JS] moduleToJs mt opts (Module name decls (Just exps)) env = do-  let jsImports = map (importToJs mt opts) . (\\ [name]) . nub $ concatMap imports decls+  let jsImports = map (importToJs mt opts) . delete (ModuleName [ProperName C.prim]) . (\\ [name]) . nub $ concatMap imports decls   jsDecls <- mapM (\decl -> declToJs opts name decl env) decls   let optimized = concat $ map (map $ optimize opts) $ catMaybes jsDecls   let isModuleEmpty = null optimized@@ -79,14 +78,19 @@     Globals -> JSAccessor (moduleNameToJs mn) (JSVar (fromJust (optionsBrowserNamespace opts)))  imports :: Declaration -> [ModuleName]-imports =-  let (f, _, _, _, _) = everythingOnValues (++) (const []) collect (const []) (const []) (const [])-  in f+imports (ImportDeclaration mn _ _) = [mn]+imports other =+  let (f, _, _, _, _) = everythingOnValues (++) (const []) collectV collectB (const []) (const [])+  in f other   where-  collect :: Value -> [ModuleName]-  collect (Var (Qualified (Just mn) _)) = [mn]-  collect (Constructor (Qualified (Just mn) _)) = [mn]-  collect _ = []+  collectV :: Value -> [ModuleName]+  collectV (Var (Qualified (Just mn) _)) = [mn]+  collectV (Constructor (Qualified (Just mn) _)) = [mn]+  collectV (TypeClassDictionaryConstructorApp (Qualified (Just mn) _) _) = [mn]+  collectV _ = []+  collectB :: Binder -> [ModuleName]+  collectB (ConstructorBinder (Qualified (Just mn) _) _) = [mn]+  collectB _ = []  -- | -- Generate code in the simplified Javascript intermediate representation for a declaration@@ -100,19 +104,55 @@     js <- valueToJs opts mp e val     return $ JSVariableIntroduction (identToJs ident) (Just js)   return $ Just jss-declToJs _ mp (DataDeclaration _ _ ctors) _ = do+declToJs _ _ (DataDeclaration Newtype _ _ [((ProperName ctor), _)]) _ =+  return $ Just $ [JSVariableIntroduction ctor (Just $+                    JSObjectLiteral [("create",+                      JSFunction Nothing ["value"]+                        (JSBlock [JSReturn $ JSVar "value"]))])]+declToJs _ _ (DataDeclaration Newtype _ _ _) _ =+  error "newtype has multiple constructors"+declToJs _ mp (DataDeclaration Data _ _ ctors) e = do   return $ Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->-    [JSVariableIntroduction ctor (Just (go pn 0 tys []))]+      let propName = if isNullaryConstructor e (Qualified (Just mp) pn) then "value" else "create"+      in [ makeConstructor ctor (length tys)+         , JSAssignment (JSAccessor propName (JSVar ctor)) (go pn 0 (length tys) [])+         ]     where-    go :: ProperName -> Integer -> [Type] -> [JS] -> JS-    go pn _ [] values =-      JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn))), ("values", JSArrayLiteral $ reverse values) ]-    go pn index (_ : tys') values =+    makeConstructor :: String -> Int -> JS+    makeConstructor ctorName n =+      let+        args = [ "value" ++ show index | index <- [0..n-1] ]+        body = [ JSAssignment (JSAccessor arg (JSVar "this")) (JSVar arg) | arg <- args ]+      in JSFunction (Just ctorName) args (JSBlock body)+    go :: ProperName -> Int -> Int -> [JS] -> JS+    go pn _ 0 values = JSUnary JSNew $ JSApp (JSVar $ runProperName pn) (reverse values)+    go pn index n values =       JSFunction Nothing ["value" ++ show index]-        (JSBlock [JSReturn (go pn (index + 1) tys' (JSVar ("value" ++ show index) : values))])+        (JSBlock [JSReturn (go pn (index + 1) (n - 1) (JSVar ("value" ++ show index) : values))]) declToJs opts mp (DataBindingGroupDeclaration ds) e = do   jss <- mapM (\decl -> declToJs opts mp decl e) ds   return $ Just $ concat $ catMaybes jss+declToJs _ _ (TypeClassDeclaration name _ supers members) _ =+  return $ Just $ [+    JSFunction (Just $ runProperName name) (identToJs `map` args)+      (JSBlock $ assn `map` args)]+  where+  assn :: Ident -> JS+  assn arg = JSAssignment (accessor arg (JSVar "this")) (var arg)+  args :: [Ident]+  args = sortBy (compare `on` runIdent) $ memberNames ++ superNames+  memberNames :: [Ident]+  memberNames = memberToName `map` members+  superNames :: [Ident]+  superNames = [ toSuperName superclass index+               | (index, (superclass, _)) <- zip [0..] supers+               ]+  toSuperName :: Qualified ProperName -> Integer -> Ident+  toSuperName pn index = Ident $ C.__superclass_ ++ show pn ++ "_" ++ show index+  memberToName :: Declaration -> Ident+  memberToName (TypeDeclaration ident _) = ident+  memberToName (PositionedDeclaration _ d) = memberToName d+  memberToName _ = error "Invalid declaration in type class definition" declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = return $ Just [js] declToJs opts mp (PositionedDeclaration _ d) e = declToJs opts mp d e declToJs _ _ _ _ = return Nothing@@ -124,6 +164,7 @@ exportToJs (TypeRef _ (Just dctors)) = map ((\n -> (n, var (Ident n))) . runProperName) dctors exportToJs (ValueRef name) = [(runIdent name, var name)] exportToJs (TypeInstanceRef name) = [(runIdent name, var name)]+exportToJs (TypeClassRef name) = [(runProperName name, var $ Ident $ runProperName name)] exportToJs _ = []  -- |@@ -143,8 +184,8 @@ accessor (Op op) = JSIndexer (JSStringLiteral op)  accessorString :: String -> JS -> JS-accessorString prop | isIdent prop = JSAccessor prop-                    | otherwise = JSIndexer (JSStringLiteral prop)+accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)+                    | otherwise = JSAccessor prop  -- | -- Generate code in the simplified Javascript intermediate representation for a value or expression.@@ -155,17 +196,36 @@ valueToJs _ _ _ (BooleanLiteral b) = return $ JSBooleanLiteral b valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral <$> mapM (valueToJs opts m e) xs valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM (valueToJs opts m e)) ps+valueToJs opts m e (TypeClassDictionaryConstructorApp name (TypedValue _ (ObjectLiteral ps) _)) =+  JSUnary JSNew . JSApp (qualifiedToJS m (Ident . runProperName) name) <$> mapM (valueToJs opts m e . snd) (sortBy (compare `on` fst) ps)+valueToJs _ _ _ TypeClassDictionaryConstructorApp{} =+  error "TypeClassDictionaryConstructorApp did not contain object literal" valueToJs opts m e (ObjectUpdate o ps) = do   obj <- valueToJs opts m e o   sts <- mapM (sndM (valueToJs opts m e)) ps   extendObj obj sts-valueToJs _ m _ (Constructor name) = return $ qualifiedToJS m (Ident . runProperName) name+valueToJs _ m e (Constructor name) =+  let propName = if isNullaryConstructor e name then "value" else "create"+  in return $ JSAccessor propName $ qualifiedToJS m (Ident . runProperName) name valueToJs opts m e (Case values binders) = do   vals <- mapM (valueToJs opts m e) values   bindersToJs opts m e binders vals valueToJs opts m e (IfThenElse cond th el) = JSConditional <$> valueToJs opts m e cond <*> valueToJs opts m e th <*> valueToJs opts m e el valueToJs opts m e (Accessor prop val) = accessorString prop <$> valueToJs opts m e val-valueToJs opts m e (App val arg) = JSApp <$> valueToJs opts m e val <*> (return <$> valueToJs opts m e arg)+valueToJs opts m e v@App{} = do+  let (f, args) = unApp v []+  args' <- mapM (valueToJs opts m e) args+  case f of+    Constructor name | isNewtypeConstructor e name && length args == 1 -> return (head args')+    Constructor name | getConstructorArity e name == length args ->+      return $ JSUnary JSNew $ JSApp (qualifiedToJS m (Ident . runProperName) name) args'+    _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs opts m e f+  where+  unApp :: Value -> [Value] -> (Value, [Value])+  unApp (App val arg) args = unApp val (arg : args)+  unApp (PositionedValue _ val) args = unApp val args+  unApp (TypedValue _ val _) args = unApp val args+  unApp other args = (other, args) valueToJs opts m e (Let ds val) = do   decls <- concat . catMaybes <$> mapM (flip (declToJs opts m) e) ds   ret <- valueToJs opts m e val@@ -260,7 +320,7 @@   jss <- forM binders $ \(CaseAlternative bs grd result) -> do     ret <- valueToJs opts m e result     go valNames [JSReturn ret] bs grd-  return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))+  return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") $ [(JSStringLiteral "Failed pattern match")]])))                  vals   where     go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder] -> Maybe Guard -> SupplyT m [JS]@@ -289,13 +349,17 @@   return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing] binderToJs _ _ varName done (VarBinder ident) =   return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)+binderToJs m e varName done (ConstructorBinder ctor bs) | isNewtypeConstructor e ctor =+  case bs of+    [b] -> binderToJs m e varName done b+    _ -> error "binder for newtype constructor should have a single argument" binderToJs m e varName done (ConstructorBinder ctor bs) = do   js <- go 0 done bs   if isOnlyConstructor e ctor   then     return js   else-    return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ctor)))+    return [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS m (Ident . runProperName) ctor))                      (JSBlock js)                      Nothing]   where@@ -305,7 +369,7 @@     argVar <- freshName     done'' <- go (index + 1) done' bs'     js <- binderToJs m e argVar done'' binder-    return (JSVariableIntroduction argVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSAccessor "values" (JSVar varName)))) : js)+    return (JSVariableIntroduction argVar (Just (JSAccessor ("value" ++ show index) (JSVar varName))) : js) binderToJs m e varName done (ObjectBinder bs) = go done bs   where   go :: (Functor m, Applicative m, Monad m) => [JS] -> [(String, Binder)] -> SupplyT m [JS]@@ -341,17 +405,3 @@   return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js) binderToJs m e varName done (PositionedBinder _ binder) =   binderToJs m e varName done binder---- |--- Checks whether a data constructor is the only constructor for that type, used to simplify the--- check when generating code for binders.----isOnlyConstructor :: Environment -> Qualified ProperName -> Bool-isOnlyConstructor e ctor =-  let ty = fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors e-  in numConstructors (ctor, ty) == 1-  where-  numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors e-  typeConstructor (Qualified (Just moduleName) _, (tyCtor, _)) = (moduleName, tyCtor)-  typeConstructor _ = error "Invalid argument to isOnlyConstructor"-

@@ -38,7 +38,11 @@   -- |   -- Numeric unary \'plus\'   ---  | Positive deriving (Show, Eq, Data, Typeable)+  | Positive+  -- |+  -- Constructor+  --+  | JSNew deriving (Show, Eq, Data, Typeable)  -- | -- Built-in binary operators@@ -218,6 +222,10 @@   --   | JSTypeOf JS   -- |+  -- InstanceOf test+  --+  | JSInstanceOf JS JS+  -- |   -- Labelled statement   --   | JSLabel String JS@@ -262,6 +270,7 @@   go (JSThrow js) = f (JSThrow (go js))   go (JSTypeOf js) = f (JSTypeOf (go js))   go (JSLabel name js) = f (JSLabel name (go js))+  go (JSInstanceOf j1 j2) = f (JSInstanceOf (go j1) (go j2))   go other = f other  everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS@@ -288,6 +297,7 @@   go (JSThrow j) = JSThrow (go (f j))   go (JSTypeOf j) = JSTypeOf (go (f j))   go (JSLabel name j) = JSLabel name (go (f j))+  go (JSInstanceOf j1 j2) = JSInstanceOf (go (f j1)) (go (f j2))   go other = f other  everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r@@ -314,4 +324,5 @@   go j@(JSThrow j1) = f j <> go j1   go j@(JSTypeOf j1) = f j <> go j1   go j@(JSLabel _ j1) = f j <> go j1+  go j@(JSInstanceOf j1 j2) = f j <> go j1 <> go j2   go other = f other

@@ -23,6 +23,9 @@ (#) :: String (#) = "#" +(<>) :: String+(<>) = "<>"+ (++) :: String (++) = "++" @@ -105,6 +108,9 @@ return :: String return = "return" +pure' :: String+pure' = "pure"+ returnEscaped :: String returnEscaped = "$return" @@ -141,11 +147,20 @@ pokeSTArray :: String pokeSTArray = "pokeSTArray" +mkFn :: String+mkFn = "mkFn"++runFn :: String+runFn = "runFn"+ -- Type Class Dictionary Names  monadEffDictionary :: String monadEffDictionary = "monadEff" +applicativeEffDictionary :: String+applicativeEffDictionary = "applicativeEff"+ bindEffDictionary :: String bindEffDictionary = "bindEff" @@ -173,6 +188,9 @@ semigroupString :: String semigroupString = "semigroupString" +semigroupoidArr :: String+semigroupoidArr = "semigroupoidArr"+ -- Main module  main :: String@@ -180,8 +198,8 @@  -- Code Generation -__superclasses :: String-__superclasses = "__superclasses"+__superclass_ :: String+__superclass_ = "__superclass_"  -- Modules @@ -199,3 +217,6 @@  st :: String st = "Control_Monad_ST"++dataFunction :: String+dataFunction = "Data_Function"

@@ -39,7 +39,8 @@   entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations    filterExport :: [Declaration] -> DeclarationRef -> Maybe DeclarationRef-  filterExport decls r@(TypeRef name _) | (any $ typeExists name) decls = Just r+  filterExport decls r@(TypeRef name _) | (any $ typeOrClassExists name) decls = Just r+  filterExport decls r@(TypeClassRef name) | (any $ typeOrClassExists name) decls = Just r   filterExport decls r@(ValueRef name) | (any $ valueExists name) decls = Just r   filterExport decls r@(TypeInstanceRef name) | (any $ valueExists name) decls = Just r   filterExport _ _ = Nothing@@ -51,11 +52,12 @@   valueExists name (PositionedDeclaration _ d) = valueExists name d   valueExists _ _ = False -  typeExists :: ProperName -> Declaration -> Bool-  typeExists name (DataDeclaration name' _ _) = name == name'-  typeExists name (DataBindingGroupDeclaration decls) = any (typeExists name) decls-  typeExists name (PositionedDeclaration _ d) = typeExists name d-  typeExists _ _ = False+  typeOrClassExists :: ProperName -> Declaration -> Bool+  typeOrClassExists name (DataDeclaration _ name' _ _) = name == name'+  typeOrClassExists name (TypeClassDeclaration name' _ _ _) = name == name'+  typeOrClassExists name (DataBindingGroupDeclaration decls) = any (typeOrClassExists name) decls+  typeOrClassExists name (PositionedDeclaration _ d) = typeOrClassExists name d+  typeOrClassExists _ _ = False  type Key = (ModuleName, Either Ident ProperName) @@ -64,10 +66,11 @@   where   go :: Declaration -> [(Key, [Key])]   go d@(ValueDeclaration name _ _ _ _) = [((moduleName, Left name), dependencies moduleName d)]-  go (DataDeclaration _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors+  go (DataDeclaration _ _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors   go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]   go d@(BindingGroupDeclaration names') = map (\(name, _, _) -> ((moduleName, Left name), dependencies moduleName d)) names'   go (DataBindingGroupDeclaration ds') = concatMap go ds'+  go (TypeClassDeclaration name _ _ _) = [((moduleName, Right name), [])]   go (PositionedDeclaration _ d) = go d   go _ = [] @@ -80,6 +83,8 @@   values (Var ident) = let (mn, name) = qualify moduleName ident in [(mn, Left name)]   values (Constructor (Qualified (Just mn) name)) = [(mn, Right name)]   values (Constructor (Qualified Nothing _)) = error "Found unqualified data constructor"+  values (TypeClassDictionaryConstructorApp (Qualified (Just mn) name) _) = [(mn, Right name)]+  values (TypeClassDictionaryConstructorApp (Qualified Nothing _) _) = error "Found unqualified class dictionary constructor"   values _ = []  isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Declaration -> Bool@@ -89,7 +94,7 @@ isUsed moduleName graph vertexFor entryPointVertices (FixityDeclaration _ name) =   let Just v' = vertexFor (moduleName, Left $ Op name)   in any (\v -> path graph v v') entryPointVertices-isUsed moduleName graph vertexFor entryPointVertices (DataDeclaration _ _ dctors) =+isUsed moduleName graph vertexFor entryPointVertices (DataDeclaration _ _ _ dctors) =   any (\(pn, _) -> let Just v' = vertexFor (moduleName, Right pn)                    in any (\v -> path graph v v') entryPointVertices) dctors isUsed moduleName graph vertexFor entryPointVertices (ExternDeclaration _ name _ _) =@@ -100,6 +105,9 @@                         in any (\v -> path graph v v') entryPointVertices) ds isUsed moduleName graph vertexFor entryPointVertices (DataBindingGroupDeclaration ds) =   any (isUsed moduleName graph vertexFor entryPointVertices) ds+isUsed moduleName graph vertexFor entryPointVertices (TypeClassDeclaration name _ _ _) =+  let Just v' = vertexFor (moduleName, Right name)+  in any (\v -> path graph v v') entryPointVertices isUsed moduleName graph vertexFor entryPointVertices (PositionedDeclaration _ d) =   isUsed moduleName graph vertexFor entryPointVertices d isUsed _ _ _ _ _ = True

@@ -118,9 +118,9 @@ -- data Declaration   -- |-  -- A data type declaration (name, arguments, data constructors)+  -- A data type declaration (data or newtype, name, arguments, data constructors)   ---  = DataDeclaration ProperName [String] [(ProperName, [Type])]+  = DataDeclaration DataDeclType ProperName [String] [(ProperName, [Type])]   -- |   -- A minimal mutually recursive set of data type declarations   --@@ -332,6 +332,11 @@   --   | Do [DoNotationElement]   -- |+  -- An application of a typeclass dictionary constructor. The value should be+  -- an ObjectLiteral.+  --+  | TypeClassDictionaryConstructorApp (Qualified ProperName) Value+  -- |   -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these   -- placeholders will be replaced with actual expressions representing type classes dictionaries which   -- can be evaluated at runtime. The constructor arguments represent (in order): whether or not to look@@ -483,6 +488,7 @@   g' (Parens v) = g (Parens (g' v))   g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))   g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))+  g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))   g' (Accessor prop v) = g (Accessor prop (g' v))   g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))   g' (Abs name v) = g (Abs name (g' v))@@ -538,6 +544,7 @@   g' (Parens v) = Parens <$> (g v >>= g')   g' (ArrayLiteral vs) = ArrayLiteral <$> mapM (g' <=< g) vs   g' (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g' <=< g)) vs+  g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')   g' (Accessor prop v) = Accessor prop <$> (g v >>= g')   g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> mapM (sndM (g' <=< g)) vs   g' (Abs name v) = Abs name <$> (g v >>= g')@@ -587,6 +594,7 @@   g' (Parens v) = (Parens <$> g' v) >>= g   g' (ArrayLiteral vs) = (ArrayLiteral <$> mapM g' vs) >>= g   g' (ObjectLiteral vs) = (ObjectLiteral <$> mapM (sndM g') vs) >>= g+  g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g   g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g   g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> mapM (sndM g') vs) >>= g   g' (Abs name v) = (Abs name <$> g' v) >>= g@@ -639,6 +647,7 @@   g' v@(Parens v1) = g v <> g' v1   g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)   g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)+  g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1   g' v@(Accessor _ v1) = g v <> g' v1   g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)   g' v@(Abs _ v1) = g v <> g' v1@@ -702,6 +711,7 @@   g' s (Parens v1) = (g'' s) v1   g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)   g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)+  g' s (TypeClassDictionaryConstructorApp _ v1) = (g'' s) v1   g' s (Accessor _ v1) = (g'' s) v1   g' s (ObjectUpdate obj vs) = foldl (<>) ((g'' s) obj) (map (g'' s . snd) vs)   g' s (Abs _ v1) = (g'' s) v1@@ -767,6 +777,7 @@   g' s (Parens v) = Parens <$> g'' s v   g' s (ArrayLiteral vs) = ArrayLiteral <$> mapM (g'' s) vs   g' s (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g'' s)) vs+  g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g'' s) v   g' s (Accessor prop v) = Accessor prop <$> g'' s v   g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> mapM (sndM (g'' s)) vs   g' s (Abs name v) = Abs name <$> g'' s v@@ -803,7 +814,7 @@ accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Value -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r) accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)   where-  forDecls (DataDeclaration _ _ dctors) = mconcat (concatMap (map f . snd) dctors)+  forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)   forDecls (ExternDeclaration _ _ _ ty) = f ty   forDecls (ExternInstanceDeclaration _ cs _ tys) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)   forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . snd) implies)

@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- ----- Module      :  Language.PureScript.Prim+-- Module      :  Language.PureScript.Environment -- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors -- License     :  MIT --@@ -33,7 +33,7 @@   -- |   -- Value names currently in scope   ---    names :: M.Map (ModuleName, Ident) (Type, NameKind)+    names :: M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)   -- |   -- Type names currently in scope   --@@ -41,7 +41,7 @@   -- |   -- Data constructors currently in scope, along with their associated data type constructors   ---  , dataConstructors :: M.Map (Qualified ProperName) (ProperName, Type)+  , dataConstructors :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type)   -- |   -- Type synonyms currently in scope   --@@ -76,6 +76,19 @@   | InlineJavascript deriving (Show, Eq, Data, Typeable)  -- |+-- The visibility of a name in scope+--+data NameVisibility+  -- |+  -- The name is defined in the current binding group, but is not visible+  --+  = Undefined+  -- |+  -- The name is defined in the another binding group, or has been made visible by a function binder+  --+  | Defined deriving (Show, Eq)++-- | -- The kind of a name -- data NameKind@@ -124,6 +137,23 @@   -- A local type variable   --   | LocalTypeVariable deriving (Show, Eq, Data, Typeable)++-- |+-- The type ('data' or 'newtype') of a data type declaration+--+data DataDeclType+  -- |+  -- A standard data constructor+  --+  = Data+  -- |+  -- A newtype constructor+  --+  | Newtype deriving (Eq, Ord, Data, Typeable)++instance Show DataDeclType where+  show Data = "data"+  show Newtype = "newtype"  -- | -- Construct a ProperName in the Prim module

@@ -53,6 +53,7 @@ optimize opts | optionsNoOptimizations opts = id               | otherwise = untilFixedPoint (applyAll   [ collapseNestedBlocks+  , collapseNestedIfs   , tco opts   , magicDo opts   , removeCodeAfterReturnStatements

@@ -13,9 +13,10 @@ -- ----------------------------------------------------------------------------- -module Language.PureScript.Optimizer.Blocks (-  collapseNestedBlocks-) where+module Language.PureScript.Optimizer.Blocks+  ( collapseNestedBlocks+  , collapseNestedIfs+  ) where  import Language.PureScript.CodeGen.JS.AST @@ -31,3 +32,11 @@   go :: JS -> [JS]   go (JSBlock sts) = sts   go s = [s]++collapseNestedIfs :: JS -> JS+collapseNestedIfs = everywhereOnJS collapse+  where+  collapse :: JS -> JS+  collapse (JSIfElse cond1 (JSBlock [JSIfElse cond2 body Nothing]) Nothing) =+      JSIfElse (JSBinary And cond1 cond2) body Nothing+  collapse js = js

@@ -22,6 +22,8 @@   evaluateIifes ) where +import Data.Maybe (fromMaybe)+ import Language.PureScript.CodeGen.JS.AST import Language.PureScript.CodeGen.Common (identToJs) import Language.PureScript.Optimizer.Common@@ -47,6 +49,8 @@       not (any (`isRebound` block) (map JSVar idents)) &&       not (any (`isRebound` block) args)       = JSBlock (map (replaceIdents (zip idents args)) body)+  convert (JSFunction Nothing ["_"] (JSBlock [JSReturn (JSApp fn@JSVar{} [JSObjectLiteral []])]))+      = fn   convert js = js  unThunk :: JS -> JS@@ -88,7 +92,7 @@   isOp _ = False  inlineCommonOperators :: JS -> JS-inlineCommonOperators = applyAll+inlineCommonOperators = applyAll $   [ binary C.numNumber (C.+) Add   , binary C.numNumber (C.-) Subtract   , binary C.numNumber (C.*) Multiply@@ -108,6 +112,7 @@   , binary C.eqBoolean (C.==) EqualTo   , binary C.eqBoolean (C./=) NotEqualTo +  , binary C.semigroupString (C.<>) Add   , binary C.semigroupString (C.++) Add    , binaryFunction C.bitsNumber C.shl ShiftLeft@@ -121,7 +126,8 @@   , binary C.boolLikeBoolean (C.&&) And   , binary C.boolLikeBoolean (C.||) Or   , unary  C.boolLikeBoolean C.not Not-  ]+  ] +++  [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]   where   binary :: String -> String -> BinaryOperator -> JS -> JS   binary dictName opString op = everywhereOnJS convert@@ -150,3 +156,38 @@     isOp _ = False   isOpDict dictName (JSApp (JSAccessor prop (JSVar prelude)) [JSObjectLiteral []]) = prelude == C.prelude && prop == dictName   isOpDict _ _ = False+  mkFn :: Int -> JS -> JS+  mkFn 0 = everywhereOnJS convert+    where+    convert :: JS -> JS+    convert (JSApp mkFnN [JSFunction Nothing [_] (JSBlock js)]) | isNFn C.mkFn 0 mkFnN =+      JSFunction Nothing [] (JSBlock js)+    convert other = other+  mkFn n = everywhereOnJS convert+    where+    convert :: JS -> JS+    convert orig@(JSApp mkFnN [fn]) | isNFn C.mkFn n mkFnN =+      case collectArgs n [] fn of+        Just (args, js) -> JSFunction Nothing args (JSBlock js)+        Nothing -> orig+    convert other = other+    collectArgs :: Int -> [String] -> JS -> Maybe ([String], [JS])+    collectArgs 1 acc (JSFunction Nothing [oneArg] (JSBlock js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js)+    collectArgs m acc (JSFunction Nothing [oneArg] (JSBlock [JSReturn ret])) = collectArgs (m - 1) (oneArg : acc) ret+    collectArgs _ _   _ = Nothing++  isNFn :: String -> Int -> JS -> Bool+  isNFn prefix n (JSVar name) = name == (prefix ++ show n)+  isNFn prefix n (JSAccessor name (JSVar dataFunction)) | dataFunction == C.dataFunction = name == (prefix ++ show n)+  isNFn _ _ _ = False++  runFn :: Int -> JS -> JS+  runFn n = everywhereOnJS convert+    where+    convert :: JS -> JS+    convert js = fromMaybe js $ go n [] js++    go :: Int -> [JS] -> JS -> Maybe JS+    go 0 acc (JSApp runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp fn acc)+    go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs+    go _ _   _ = Nothing

@@ -57,6 +57,8 @@   convert :: JS -> JS   -- Desugar return   convert (JSApp (JSApp ret [val]) []) | isReturn ret = val+  -- Desugar pure+  convert (JSApp (JSApp pure' [val]) []) | isPure pure' = val   -- Desugar >>   convert (JSApp (JSApp bind [m]) [JSFunction Nothing ["_"] (JSBlock js)]) | isBind bind && isJSReturn (last js) =     let JSReturn ret = last js in@@ -78,6 +80,9 @@   -- Check if an expression represents a monomorphic call to return for the Eff monad   isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict C.monadEffDictionary effDict = True   isReturn _ = False+  -- Check if an expression represents a monomorphic call to pure for the Eff applicative+  isPure (JSApp purePoly [effDict]) | isPurePoly purePoly && isEffDict C.applicativeEffDictionary effDict = True+  isPure _ = False   -- Check if an expression represents the polymorphic >>= function   isBindPoly (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == identToJs (Op (C.>>=))   isBindPoly (JSIndexer (JSStringLiteral bind) (JSVar prelude)) = prelude == C.prelude && bind == (C.>>=)@@ -86,6 +91,10 @@   isRetPoly (JSAccessor returnEscaped (JSVar prelude)) = prelude == C.prelude && returnEscaped == C.returnEscaped   isRetPoly (JSIndexer (JSStringLiteral return') (JSVar prelude)) = prelude == C.prelude && return' == C.return   isRetPoly _ = False+  -- Check if an expression represents the polymorphic pure function+  isPurePoly (JSAccessor pure' (JSVar prelude)) = prelude == C.prelude && pure' == C.pure'+  isPurePoly (JSIndexer (JSStringLiteral pure') (JSVar prelude)) = prelude == C.prelude && pure' == C.pure'+  isPurePoly _ = False   -- Check if an expression represents a function in the Ef module   isEffFunc name (JSAccessor name' (JSVar eff)) = eff == C.eff && name == name'   isEffFunc _ _ = False

@@ -31,6 +31,7 @@ -- reservedPsNames :: [String] reservedPsNames = [ "data"+                  , "newtype"                   , "type"                   , "foreign"                   , "import"

@@ -48,13 +48,13 @@  parseDataDeclaration :: P.Parsec String ParseState Declaration parseDataDeclaration = do-  reserved "data"+  dtype <- (reserved "data" *> return Data) <|> (reserved "newtype" *> return Newtype)   name <- indented *> properName   tyArgs <- many (indented *> identifier)   ctors <- P.option [] $ do     _ <- lexeme $ indented *> P.char '='     sepBy1 ((,) <$> properName <*> P.many (indented *> parseTypeAtom)) pipe-  return $ DataDeclaration name tyArgs ctors+  return $ DataDeclaration dtype name tyArgs ctors  parseTypeDeclaration :: P.Parsec String ParseState Declaration parseTypeDeclaration =

@@ -30,15 +30,6 @@ import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P -parseNumber :: P.Parsec String ParseState Type-parseNumber = const tyNumber <$> reserved "Number"--parseString :: P.Parsec String ParseState Type-parseString = const tyString <$> reserved "String"--parseBoolean :: P.Parsec String ParseState Type-parseBoolean = const tyBoolean <$> reserved "Boolean"- parseArray :: P.Parsec String ParseState Type parseArray = squares $ return tyArray @@ -69,10 +60,7 @@ -- parseTypeAtom :: P.Parsec String ParseState Type parseTypeAtom = indented *> P.choice (map P.try-            [ parseNumber-            , parseString-            , parseBoolean-            , parseArray+            [ parseArray             , parseArrayOf             , parseFunction             , parseObject

@@ -18,7 +18,7 @@ ) where  import Language.PureScript.Pretty.Common-import Language.PureScript.CodeGen.JS (isIdent)+import Language.PureScript.CodeGen.JS (identNeedsEscaping) import Language.PureScript.CodeGen.JS.AST  import Data.List@@ -56,8 +56,8 @@     ]     where     objectPropertyToString :: String -> String-    objectPropertyToString s | isIdent s = s-                             | otherwise = show s+    objectPropertyToString s | identNeedsEscaping s = show s+                             | otherwise = s   match (JSBlock sts) = fmap concat $ sequence     [ return "{\n"     , withIndent $ prettyStatements sts@@ -174,6 +174,12 @@   match (JSTypeOf val) = Just ((), val)   match _ = Nothing +instanceOf :: Pattern PrinterState JS (JS, JS)+instanceOf = mkPattern match+  where+  match (JSInstanceOf val ty) = Just (val, ty)+  match _ = Nothing+ unary :: UnaryOperator -> String -> Operator PrinterState JS String unary op str = Wrap match (++)   where@@ -223,6 +229,7 @@     OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]                   , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]                   , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]+                  , [ unary JSNew "new " ]                   , [ Wrap lam $ \(name, args) ret -> "function "                         ++ fromMaybe "" name                         ++ "(" ++ intercalate ", " args ++ ") "@@ -232,6 +239,7 @@                   , [ binary    GreaterThan          ">" ]                   , [ binary    GreaterThanOrEqualTo ">=" ]                   , [ Wrap typeOf $ \_ s -> "typeof " ++ s ]+                  , [ AssocR instanceOf $ \v1 v2 -> v1 ++ " instanceof " ++ v2 ]                   , [ unary     Not                  "!" ]                   , [ unary     BitwiseNot           "~" ]                   , [ unary     Negate               "-" ]

@@ -51,6 +51,11 @@     , currentIndent     , return "}"     ]+  match (TypeClassDictionaryConstructorApp className ps) = fmap concat $ sequence+    [ return ((show className) ++ "(\n")+    , match ps+    , return ")"+    ]   match (Constructor name) = return $ show name   match (Case values binders) = fmap concat $ sequence     [ return "case "@@ -73,8 +78,8 @@     , withIndent $ prettyPrintMany prettyPrintDoNotationElement els     , currentIndent     ]-  match (TypeClassDictionary _ _ _) = return "<<dict>>"-  match (SuperClassDictionary _ _) = return "<<superclass dict>>"+  match (TypeClassDictionary name _ _) = return $ "<<dict " ++ show name ++ ">>"+  match (SuperClassDictionary name _) = return $ "<<superclass dict " ++ show name ++ ">>"   match (TypedValue _ val _) = prettyPrintValue' val   match (PositionedValue _ val) = prettyPrintValue' val   match _ = mzero

@@ -0,0 +1,206 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Renamer+-- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- Renaming pass that prevents shadowing of local identifiers.+--+-----------------------------------------------------------------------------++module Language.PureScript.Renamer (renameInModules) where++import Control.Applicative+import Control.Monad.State++import Data.List (find)++import qualified Data.Map as M+import qualified Data.Set as S++import Language.PureScript.Declarations+import Language.PureScript.Environment+import Language.PureScript.Names+import Language.PureScript.Traversals++-- |+-- The state object used in this module+--+data RenameState = RenameState {+    -- |+    -- A map from names bound (in the input) to their names (in the output)+    --+    rsBoundNames :: M.Map Ident Ident+    -- |+    -- The set of names which have been used and are in scope in the output+    --+  , rsUsedNames :: S.Set Ident+  }++type Rename = State RenameState++initState :: [Ident] -> RenameState+initState scope = RenameState (M.fromList (zip scope scope)) (S.fromList scope)++-- |+-- Runs renaming starting with a list of idents for the initial scope.+--+runRename :: [Ident] -> Rename a -> a+runRename scope = flip evalState (initState scope)++-- |+-- Creates a new renaming scope using the current as a basis. Used to backtrack+-- when leaving an Abs.+--+newScope :: Rename a -> Rename a+newScope x = do+  scope <- get+  a <- x+  put scope+  return a++-- |+-- Adds a new scope entry for an ident. If the ident is already present, a new+-- unique name is generated and stored.+--+updateScope :: Ident -> Rename Ident+updateScope name = do+  scope <- get+  let name' = case name `S.member` rsUsedNames scope of+                True ->+                  let+                    newNames = [ Ident (runIdent name ++ "_" ++ show (i :: Int)) | i <- [1..] ]+                    Just newName = find (`S.notMember` rsUsedNames scope) newNames+                  in newName+                False -> name+  modify $ \s -> s { rsBoundNames = M.insert name name' (rsBoundNames s)+                   , rsUsedNames  = S.insert name' (rsUsedNames s)+                   }+  return name'++-- |+-- Finds the new name to use for an ident.+--+lookupIdent :: Ident -> Rename Ident+lookupIdent name = do+  name' <- gets $ M.lookup name . rsBoundNames+  case name' of+    Just name'' -> return name''+    Nothing -> error $ "Rename scope is missing ident '" ++ show name ++ "'"++-- |+-- Finds idents introduced by declarations.+--+findDeclIdents :: [Declaration] -> [Ident]+findDeclIdents = concatMap go+  where+  go (ValueDeclaration ident _ _ _ _) = [ident]+  go (BindingGroupDeclaration ds) = map (\(name, _, _) -> name) ds+  go (ExternDeclaration _ ident _ _) = [ident]+  go (TypeClassDeclaration _ _ _ ds) = findDeclIdents ds+  go (PositionedDeclaration _ d) = go d+  go _ = []++-- |+-- Renames within each declaration in a module.+--+renameInModules :: [Module] -> [Module]+renameInModules = map go+  where+  go :: Module -> Module+  go (Module mn decls exps) = Module mn (renameInDecl' (findDeclIdents decls) `map` decls) exps+  renameInDecl' :: [Ident] -> Declaration -> Declaration+  renameInDecl' scope = runRename scope . renameInDecl True++-- |+-- Renames within a declaration. isTopLevel is used to determine whether the+-- declaration is a module member or appearing within a Let. At the top level+-- declarations are not renamed or added to the scope (they should already have+-- been added), whereas in a Let declarations are renamed if their name shadows+-- another in the current scope.+--+renameInDecl :: Bool -> Declaration -> Rename Declaration+renameInDecl isTopLevel (ValueDeclaration name nameKind [] Nothing val) = do+  name' <- if isTopLevel then return name else updateScope name+  ValueDeclaration name' nameKind [] Nothing <$> renameInValue val+renameInDecl isTopLevel (BindingGroupDeclaration ds) = do+  ds' <- mapM updateNames ds+  BindingGroupDeclaration <$> mapM updateValues ds'+  where+  updateNames :: (Ident, NameKind, Value) -> Rename (Ident, NameKind, Value)+  updateNames (name, nameKind, val) = do+    name' <- if isTopLevel then return name else updateScope name+    return (name', nameKind, val)+  updateValues :: (Ident, NameKind, Value) -> Rename (Ident, NameKind, Value)+  updateValues (name, nameKind, val) =+    (,,) name nameKind <$> renameInValue val+renameInDecl _ (TypeInstanceDeclaration name cs className args ds) =+  TypeInstanceDeclaration name cs className args <$> mapM (renameInDecl True) ds+renameInDecl isTopLevel (PositionedDeclaration pos d) =+  PositionedDeclaration pos <$> renameInDecl isTopLevel d+renameInDecl _ other = return other++-- |+-- Renames within a value.+--+renameInValue :: Value -> Rename Value+renameInValue (UnaryMinus v) =+  UnaryMinus <$> renameInValue v+renameInValue (ArrayLiteral vs) =+  ArrayLiteral <$> mapM renameInValue vs+renameInValue (ObjectLiteral vs) =+  ObjectLiteral <$> mapM (\(name, v) -> (,) name <$> renameInValue v) vs+renameInValue (Accessor prop v) =+  Accessor prop <$> renameInValue v+renameInValue (ObjectUpdate obj vs) =+  ObjectUpdate <$> renameInValue obj <*> mapM (\(name, v) -> (,) name <$> renameInValue v) vs+renameInValue (Abs (Left name) v) =+  newScope $ Abs . Left <$> updateScope name <*> renameInValue v+renameInValue (App v1 v2) =+  App <$> renameInValue v1 <*> renameInValue v2+renameInValue (Var (Qualified Nothing name)) =+  Var . Qualified Nothing <$> lookupIdent name+renameInValue (IfThenElse v1 v2 v3) =+  IfThenElse <$> renameInValue v1 <*> renameInValue v2 <*> renameInValue v3+renameInValue (Case vs alts) =+  newScope $ Case <$> mapM renameInValue vs <*> mapM renameInCaseAlternative alts+renameInValue (TypedValue check v ty) =+  TypedValue check <$> renameInValue v <*> pure ty+renameInValue (Let ds v) =+  newScope $ Let <$> mapM (renameInDecl False) ds <*> renameInValue v+renameInValue (TypeClassDictionaryConstructorApp name v) =+  TypeClassDictionaryConstructorApp name <$> renameInValue v+renameInValue (PositionedValue pos v) =+  PositionedValue pos <$> renameInValue v+renameInValue v = return v++-- |+-- Renames within case alternatives.+--+renameInCaseAlternative :: CaseAlternative -> Rename CaseAlternative+renameInCaseAlternative (CaseAlternative bs g v) =+  CaseAlternative <$> mapM renameInBinder bs <*> maybeM renameInValue g <*> renameInValue v++-- |+-- Renames within binders.+--+renameInBinder :: Binder -> Rename Binder+renameInBinder (VarBinder name) =+  VarBinder <$> updateScope name+renameInBinder (ConstructorBinder name bs) =+  ConstructorBinder name <$> mapM renameInBinder bs+renameInBinder (ObjectBinder bs) =+  ObjectBinder <$> mapM (sndM renameInBinder) bs+renameInBinder (ArrayBinder bs) =+  ArrayBinder <$> mapM renameInBinder bs+renameInBinder (ConsBinder b1 b2) =+  ConsBinder <$> renameInBinder b1 <*> renameInBinder b2+renameInBinder (NamedBinder name b) =+  NamedBinder <$> updateScope name <*> renameInBinder b+renameInBinder (PositionedBinder _ b) = renameInBinder b+renameInBinder other = return other

@@ -118,7 +118,7 @@ getIdent _ = error "Expected ValueDeclaration"  getProperName :: Declaration -> ProperName-getProperName (DataDeclaration pn _ _) = pn+getProperName (DataDeclaration _ pn _ _) = pn getProperName (TypeSynonymDeclaration pn _ _) = pn getProperName (PositionedDeclaration _ d) = getProperName d getProperName _ = error "Expected DataDeclaration"

@@ -31,6 +31,8 @@ import Language.PureScript.Errors import Language.PureScript.Traversals +import qualified Language.PureScript.Constants as C+ -- | -- The global export environment - every declaration exported from every module. --@@ -180,8 +182,8 @@    updateDecl :: (Maybe SourcePos, [Ident]) -> Declaration -> Either ErrorStack ((Maybe SourcePos, [Ident]), Declaration)   updateDecl (_, bound) d@(PositionedDeclaration pos _) = return ((Just pos, bound), d)-  updateDecl (pos, bound) (DataDeclaration name args dctors) =-    (,) (pos, bound) <$> (DataDeclaration name args <$> mapM (sndM (mapM (updateTypesEverywhere pos))) dctors)+  updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =+    (,) (pos, bound) <$> (DataDeclaration dtype name args <$> mapM (sndM (mapM (updateTypesEverywhere pos))) dctors)   updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) =     (,) (pos, bound) <$> (TypeSynonymDeclaration name ps <$> updateTypesEverywhere pos ty)   updateDecl (pos, bound) (TypeClassDeclaration className args implies ds) =@@ -272,7 +274,7 @@ -- Finds all exported declarations in a set of modules. -- findExports :: [Module] -> Either ErrorStack ExportEnvironment-findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) primExports+findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) primExports   where    -- The exported types from the Prim module@@ -295,7 +297,7 @@     go env'' (TypeDeclaration name _) = addValue env'' mn name     go env'' (PositionedDeclaration pos d) = rethrowWithPosition pos $ go env'' d     go _ _ = error "Invalid declaration in TypeClassDeclaration"-  addDecl mn env (DataDeclaration tn _ dcs) = addType env mn tn (map fst dcs)+  addDecl mn env (DataDeclaration _ tn _ dcs) = addType env mn tn (map fst dcs)   addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []   addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []   addDecl mn env (ValueDeclaration name _ _ _ _) = addValue env mn name

@@ -33,9 +33,9 @@ import Control.Monad.Error import Control.Monad.State import Control.Arrow (first, second)-import Data.List ((\\))+import Data.List ((\\), find) import Data.Monoid ((<>))-import Data.Maybe (catMaybes, mapMaybe)+import Data.Maybe (catMaybes, mapMaybe, isJust)  import qualified Data.Map as M @@ -52,7 +52,7 @@  desugarModule :: Module -> Desugar Module desugarModule (Module name decls (Just exps)) = do-  (newExpss, declss) <- unzip <$> mapM (desugarDecl name) decls+  (newExpss, declss) <- unzip <$> mapM (desugarDecl name exps) decls   return $ Module name (concat declss) $ Just (exps ++ catMaybes newExpss) desugarModule _ = error "Exports should have been elaborated in name desugaring" @@ -82,63 +82,120 @@ --   instance subString :: Sub String where --     sub = "" ----- becomes+-- becomes: --+--   <TypeClassDeclaration Foo ...>+-- --   type Foo a = { foo :: a -> a } -----   foreign import foo "function foo(dict) {\---                      \  return dict.foo;\---                      \}" :: forall a. (Foo a) => a -> a+--   -- this following type is marked as not needing to be checked so a new Abs+--   -- is not introduced around the definition in type checking, but when+--   -- called the dictionary value is still passed in for the `dict` argument+--   foo :: forall a. (Foo a) => a -> a+--   foo dict = dict.foo -- --   fooString :: {} -> Foo String---   fooString _ = { foo: \s -> s ++ s }+--   fooString _ = <TypeClassDictionaryConstructorApp Foo { foo: \s -> s ++ s }> -- --   fooArray :: forall a. (Foo a) => Foo [a]---   fooArray = { foo: map foo }+--   fooArray = <TypeClassDictionaryConstructorApp Foo { foo: map foo }> -- --   {- Superclasses -} -----   ...+--   <TypeClassDeclaration Sub ...> -----   subString :: {} -> { __superclasses :: { "Foo": {} -> Foo String }, sub :: String }---   subString _ = {---     __superclasses: {---       "Foo": \_ -> <dictionary placeholder to be inserted during type checking\>---     }---     sub: ""---   }+--   type Sub a = { sub :: a+--                , "__superclass_Foo_0" :: {} -> Foo a+--                }+--+--   -- As with `foo` above, this type is unchecked at the declaration+--   sub :: forall a. (Sub a) => a+--   sub dict = dict.sub+--+--   subString :: {} -> Sub String+--   subString _ = { sub: "",+--                 , "__superclass_Foo_0": \_ -> <SuperClassDictionary Foo String>+--                 }+--+-- and finally as the generated javascript:+--+--   function Foo(foo) {+--       this.foo = foo;+--   };+--+--   var foo = function (dict) {+--       return dict.foo;+--   };+--+--   var fooString = function (_) {+--       return new Foo(function (s) {+--           return s + s;+--       });+--   };+--+--   var fooArray = function (__dict_Foo_15) {+--       return new Foo(map(foo(__dict_Foo_15)));+--   };+--+--   function Sub(__superclass_Foo_0, sub) {+--       this["__superclass_Foo_0"] = __superclass_Foo_0;+--       this.sub = sub;+--   };+--+--   var sub = function (dict) {+--       return dict.sub;+--   };+--+--   var subString = function (_) {+--       return new Sub(fooString, "");+--   }; -}-desugarDecl :: ModuleName -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])-desugarDecl mn d@(TypeClassDeclaration name args implies members) = do+desugarDecl :: ModuleName -> [DeclarationRef] -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])+desugarDecl mn _ d@(TypeClassDeclaration name args implies members) = do   modify (M.insert (mn, name) d)   return $ (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)-desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do+desugarDecl mn exps d@(TypeInstanceDeclaration name deps className tys members) = do   desugared <- lift $ desugarCases members-  dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared-  return $ (Just $ TypeInstanceRef name, [d, dictDecl])-desugarDecl mn (PositionedDeclaration pos d) = do-  (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn d+  dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared+  let expRef = if isExportedClass className && all isExportedType (getConstructors `concatMap` tys)+               then Just $ TypeInstanceRef name+               else Nothing+  return $ (expRef, [d, dictDecl])+  where+  isExportedClass :: Qualified ProperName -> Bool+  isExportedClass = isExported (elem . TypeClassRef)+  isExportedType :: Qualified ProperName -> Bool+  isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn)+  isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool+  isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps+  isExported _ _ = error "Names should have been qualified in name desugaring"+  matchesTypeRef :: ProperName -> DeclarationRef -> Bool+  matchesTypeRef pn (TypeRef pn' _) = pn == pn'+  matchesTypeRef _ _ = False+  getConstructors :: Type -> [Qualified ProperName]+  getConstructors = everythingOnTypes (++) getConstructor+  getConstructor :: Type -> [Qualified ProperName]+  getConstructor (TypeConstructor tcname) = [tcname]+  getConstructor _ = []+desugarDecl mn exps (PositionedDeclaration pos d) = do+  (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d   return (dr, map (PositionedDeclaration pos) ds)-desugarDecl _ other = return (Nothing, [other])+desugarDecl _ _ other = return (Nothing, [other])  memberToNameAndType :: Declaration -> (Ident, Type) memberToNameAndType (TypeDeclaration ident ty) = (ident, ty) memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d memberToNameAndType _ = error "Invalid declaration in type class definition" -identToProperty :: Ident -> String-identToProperty (Ident name) = name-identToProperty (Op op) = op- typeClassDictionaryDeclaration :: ProperName -> [String] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Declaration typeClassDictionaryDeclaration name args implies members =-  let superclassesType = TypeApp tyObject (rowFromList ([ (fieldName, function unit tySynApp)-                                                        | (index, (superclass, tyArgs)) <- zip [0..] implies-                                                        , let tySynApp = foldl TypeApp (TypeConstructor superclass) tyArgs-                                                        , let fieldName = mkSuperclassDictionaryName superclass index-                                                        ], REmpty))-      members' = map (first identToProperty . memberToNameAndType) members-      mtys = if null implies then members' else (C.__superclasses, superclassesType) : members'+  let superclassTypes = [ (fieldName, function unit tySynApp)+                        | (index, (superclass, tyArgs)) <- zip [0..] implies+                        , let tySynApp = foldl TypeApp (TypeConstructor superclass) tyArgs+                        , let fieldName = mkSuperclassDictionaryName superclass index+                        ]+      members' = map (first runIdent . memberToNameAndType) members+      mtys = members' ++ superclassTypes   in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (mtys, REmpty))  typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> Declaration -> Declaration@@ -151,7 +208,7 @@ typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"  mkSuperclassDictionaryName :: Qualified ProperName -> Integer -> String-mkSuperclassDictionaryName pn index = show pn ++ "_" ++ show index+mkSuperclassDictionaryName pn index = C.__superclass_ ++ show pn ++ "_" ++ show index  unit :: Type unit = TypeApp tyObject REmpty@@ -175,25 +232,26 @@       -- Replace the type arguments with the appropriate types in the member types       let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys       -- Create values for the type instance members-      memberNames <- map (first identToProperty) <$> mapM (memberToNameAndValue memberTypes) decls+      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.-      let superclasses = ObjectLiteral+      let superclasses =             [ (fieldName, Abs (Left (Ident "_")) (SuperClassDictionary superclass tyArgs))             | (index, (superclass, suTyArgs)) <- zip [0..] implies             , let tyArgs = map (replaceAllTypeVars (zip args tys)) suTyArgs             , let fieldName = mkSuperclassDictionaryName superclass index             ] -      let memberNames' = if null implies then memberNames else (C.__superclasses, superclasses) : memberNames+      let memberNames' = ObjectLiteral (memberNames ++ superclasses)           dictTy = foldl TypeApp (TypeConstructor className) tys           constrainedTy = quantify (if null deps then function unit dictTy else ConstrainedType deps dictTy)-          dict = if null deps then Abs (Left (Ident "_")) (ObjectLiteral memberNames') else ObjectLiteral memberNames'--      return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)+          dict = TypeClassDictionaryConstructorApp className memberNames'+          dict' = if null deps then Abs (Left (Ident "_")) dict else dict+          result = ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict' constrainedTy)+      return result    where 

@@ -39,21 +39,21 @@ import Language.PureScript.Environment import Language.PureScript.Errors -addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()-addDataType moduleName name args dctors ctorKind = do+addDataType :: ModuleName -> DataDeclType -> ProperName -> [String] -> [(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 name args dctor tys+      addDataConstructor moduleName dtype name args dctor tys -addDataConstructor :: ModuleName -> ProperName -> [String] -> ProperName -> [Type] -> Check ()-addDataConstructor moduleName name args dctor tys = do+addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()+addDataConstructor moduleName dtype name args dctor tys = do   env <- getEnv   let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)   let dctorTy = foldr function retTy tys   let polyType = mkForAll args dctorTy-  putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (name, polyType) (dataConstructors env) }+  putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType) (dataConstructors env) }  addTypeSynonym :: ModuleName -> ProperName -> [String] -> Type -> Kind -> Check () addTypeSynonym moduleName name args ty kind = do@@ -71,7 +71,7 @@ addValue :: ModuleName -> Ident -> Type -> NameKind -> Check () addValue moduleName name ty nameKind = do   env <- getEnv-  putEnv (env { names = M.insert (moduleName, name) (ty, nameKind) (names env) })+  putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })  addTypeClass :: ModuleName -> ProperName -> [String] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Check () addTypeClass moduleName pn args implies ds =@@ -111,19 +111,25 @@ -- typeCheckAll :: Maybe ModuleName -> ModuleName -> [Declaration] -> Check [Declaration] typeCheckAll _ _ [] = return []-typeCheckAll mainModuleName moduleName (d@(DataDeclaration name args dctors) : rest) = do+typeCheckAll mainModuleName moduleName (d@(DataDeclaration dtype name args dctors) : rest) = do   rethrow (strMsg ("Error in type constructor " ++ show name) <>) $ do+    when (dtype == Newtype) $ checkNewtype dctors     ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)-    addDataType moduleName name args dctors ctorKind+    addDataType moduleName dtype name args dctors ctorKind   ds <- typeCheckAll mainModuleName moduleName rest   return $ d : ds+  where+  checkNewtype :: [(ProperName, [Type])] -> Check ()+  checkNewtype [(_, [_])] = return ()+  checkNewtype [(_, _)] = throwError . strMsg $ "newtypes constructors must have a single argument"+  checkNewtype _ = throwError . strMsg $ "newtypes must have a single constructor" typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do   rethrow (strMsg "Error in data binding group" <>) $ do     let syns = mapMaybe toTypeSynonym tys     let dataDecls = mapMaybe toDataDecl tys-    (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)-    forM_ (zip dataDecls data_ks) $ \((name, args, dctors), ctorKind) ->-      addDataType moduleName name args dctors ctorKind+    (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) ->+      addDataType moduleName dtype name args dctors ctorKind     forM_ (zip syns syn_ks) $ \((name, args, ty), kind) ->       addTypeSynonym moduleName name args ty kind   ds <- typeCheckAll mainModuleName moduleName rest@@ -132,7 +138,7 @@   toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)   toTypeSynonym (PositionedDeclaration _ d') = toTypeSynonym d'   toTypeSynonym _ = Nothing-  toDataDecl (DataDeclaration nm args dctors) = Just (nm, args, dctors)+  toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)   toDataDecl (PositionedDeclaration _ d') = toDataDecl d'   toDataDecl _ = Nothing typeCheckAll mainModuleName moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do@@ -174,7 +180,7 @@     guardWith (strMsg "Expected kind *") $ kind == Star     case M.lookup (moduleName, name) (names env) of       Just _ -> throwError . strMsg $ show name ++ " is already defined"-      Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy) (names env) })+      Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy, Defined) (names env) })   ds <- typeCheckAll mainModuleName moduleName rest   return $ d : ds typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = do

@@ -39,7 +39,7 @@ -- | -- Temporarily bind a collection of names to values ---bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind) -> m a -> m a+bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> m a -> m a bindNames newNames action = do   orig <- get   modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }@@ -79,9 +79,9 @@ -- | -- Temporarily bind a collection of names to local variables ---bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type)] -> m a -> m a+bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type, NameVisibility)] -> m a -> m a bindLocalVariables moduleName bindings =-  bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((moduleName, name), (ty, LocalVariable)))+  bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> ((moduleName, name), (ty, LocalVariable, visibility)))  -- | -- Temporarily bind a collection of names to local type variables@@ -91,6 +91,17 @@   bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (Just moduleName) pn, (kind, LocalTypeVariable)))  -- |+-- Update the visibility of all names to Defined+--+makeBindingGroupVisible :: (Functor m, MonadState CheckState m) => m a -> m a+makeBindingGroupVisible action = do+  orig <- get+  modify $ \st -> st { checkEnv = (checkEnv st) { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names . checkEnv $ st) } }+  a <- action+  modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }+  return a++-- | -- Lookup the type of a value by name in the @Environment@ -- lookupVariable :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type@@ -98,7 +109,27 @@   env <- getEnv   case M.lookup (fromMaybe currentModule moduleName, var) (names env) of     Nothing -> throwError . strMsg $ show var ++ " is undefined"-    Just (ty, _) -> return ty+    Just (ty, _, _) -> return ty++-- |+-- Lookup the visibility of a value by name in the @Environment@+--+getVisibility :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility+getVisibility currentModule (Qualified moduleName var) = do+  env <- getEnv+  case M.lookup (fromMaybe currentModule moduleName, var) (names env) of+    Nothing -> throwError . strMsg $ show var ++ " is undefined"+    Just (_, _, vis) -> return vis++-- |+-- Assert that a name is visible+--+checkVisibility :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m ()+checkVisibility currentModule name@(Qualified _ var) = do+  vis <- getVisibility currentModule name+  case vis of+    Undefined -> throwError . strMsg $ show var ++ " may not be defined in the current scope."+    _ -> return ()  -- | -- Lookup the kind of a type by name in the @Environment@

@@ -194,7 +194,7 @@   -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values   tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts -typeDictionaryForBindingGroup :: ModuleName -> [(Ident, Value)] -> UnifyT Type Check ([(Ident, (Value, Maybe (Type, Bool)))], M.Map (ModuleName, Ident) (Type, NameKind), [(Ident, Type)])+typeDictionaryForBindingGroup :: ModuleName -> [(Ident, Value)] -> UnifyT Type Check ([(Ident, (Value, Maybe (Type, Bool)))], M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility), [(Ident, Type)]) typeDictionaryForBindingGroup moduleName vals = do   let     -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed@@ -212,15 +212,14 @@     -- Make a map of names to the unification variables of untyped declarations     untypedDict = zip (map fst untyped) untypedNames     -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking-    dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable))) $ typedDict ++ untypedDict)+    dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable, Undefined))) $ typedDict ++ untypedDict)   return (es, dict, untypedDict) -typeForBindingGroupElement :: ModuleName -> (Ident, (Value, Maybe (Type, Bool))) -> M.Map (ModuleName, Ident) (Type, NameKind) -> [(Ident, Type)] -> UnifyT Type Check (Ident, (Value, Type))-typeForBindingGroupElement moduleName e@(_, (val, _)) dict untypedDict = do+typeForBindingGroupElement :: ModuleName -> (Ident, (Value, Maybe (Type, Bool))) -> M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> [(Ident, Type)] -> UnifyT Type Check (Ident, (Value, Type))+typeForBindingGroupElement moduleName el dict untypedDict =   -- If the declaration is a function, it has access to other values in the binding group.   -- If not, the generated code might fail at runtime since those values might be undefined.-  let dict' = if isFunction val then dict else M.empty-  case e of+  case el of     -- Typed declarations     (ident, (val', Just (ty, checkType))) -> do       -- Kind check@@ -228,27 +227,18 @@       guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star       -- Check the type with the new names in scope       ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty-      val'' <- bindNames dict' $ if checkType-                               then TypedValue True <$> check val' ty' <*> pure ty'-                               else return (TypedValue False val' ty')+      val'' <- if checkType+               then bindNames dict $ TypedValue True <$> check val' ty' <*> pure ty'+               else return (TypedValue False val' ty')       return (ident, (val'', ty'))     -- Untyped declarations     (ident, (val', Nothing)) -> do       -- Infer the type with the new names in scope-      TypedValue _ val'' ty <- bindNames dict' $ infer val'+      TypedValue _ val'' ty <- bindNames dict $ infer val'       ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)       return (ident, (TypedValue True val'' ty, ty))  -- |--- Check if a value introduces a function----isFunction :: Value -> Bool-isFunction (Abs _ _) = True-isFunction (TypedValue _ val _) = isFunction val-isFunction (PositionedValue _ val) = isFunction val-isFunction _ = False---- | -- Check if a value contains a type annotation -- isTyped :: (Ident, Value) -> (Ident, (Value, Maybe (Type, Bool)))@@ -317,7 +307,7 @@     filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True     filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True     filterModule _ = False-	+     solve context' (className, tys) trySuperclasses =       let         dicts = go trySuperclasses className tys@@ -336,7 +326,7 @@ 	    , 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'@@ -350,7 +340,7 @@ 	    -- 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.@@ -370,8 +360,8 @@ 	  dictionaryValueToValue (GlobalDictionaryValue fnName) = App (Var fnName) (ObjectLiteral []) 	  dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts) 	  dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) =-	    App (Accessor (show superclassName ++ "_" ++ show index)-	                  (Accessor C.__superclasses (dictionaryValueToValue dict)))+	    App (Accessor (C.__superclass_ ++ show superclassName ++ "_" ++ show index)+	                  (dictionaryValueToValue dict)) 	        (ObjectLiteral []) 	  -- Ensure that a substitution is valid 	  verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]@@ -630,7 +620,7 @@ infer' (Abs (Left arg) ret) = do   ty <- fresh   Just moduleName <- checkCurrentModule <$> get-  bindLocalVariables moduleName [(arg, ty)] $ do+  makeBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do     body@(TypedValue _ _ bodyTy) <- infer' ret     return $ TypedValue True (Abs (Left arg) body) $ function ty bodyTy infer' (Abs (Right _) _) = error "Binder was not desugared"@@ -640,6 +630,7 @@   return $ TypedValue True app ret infer' (Var var) = do   Just moduleName <- checkCurrentModule <$> get+  checkVisibility moduleName var   ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var   case ty of     ConstrainedType constraints ty' -> do@@ -650,8 +641,8 @@   env <- getEnv   case M.lookup c (dataConstructors env) of     Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"-    Just (_, ty) -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty-                       return $ TypedValue True v ty'+    Just (_, _, ty) -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty+                          return $ TypedValue True v ty' infer' (Case vals binders) = do   ts <- mapM infer vals   ret <- fresh@@ -680,29 +671,29 @@ infer' _ = error "Invalid argument to infer"  inferLetBinding :: [Declaration] -> [Declaration] -> Value -> (Value -> UnifyT Type Check Value) -> UnifyT Type Check ([Declaration], Value)-inferLetBinding seen [] ret j = (,) seen <$> j ret+inferLetBinding seen [] ret j = (,) seen <$> makeBindingGroupVisible (j ret) inferLetBinding seen (ValueDeclaration ident nameKind [] Nothing tv@(TypedValue checkType val ty) : rest) ret j = do   Just moduleName <- checkCurrentModule <$> get   kind <- liftCheck $ kindOf moduleName ty   guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star-  let dict = if isFunction val then M.singleton (moduleName, ident) (ty, nameKind) else M.empty+  let dict = M.singleton (moduleName, ident) (ty, nameKind, Undefined)   ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty   TypedValue _ val' ty'' <- if checkType then bindNames dict (check val ty') else return tv-  bindNames (M.singleton (moduleName, ident) (ty'', nameKind)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing (TypedValue checkType val' ty'')]) rest ret j+  bindNames (M.singleton (moduleName, ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing (TypedValue checkType val' ty'')]) rest ret j inferLetBinding seen (ValueDeclaration ident nameKind [] Nothing val : rest) ret j = do   valTy <- fresh   Just moduleName <- checkCurrentModule <$> get-  let dict = if isFunction val then M.singleton (moduleName, ident) (valTy, nameKind) else M.empty+  let dict = M.singleton (moduleName, ident) (valTy, nameKind, Undefined)   TypedValue _ val' valTy' <- bindNames dict $ infer val   valTy =?= valTy'-  bindNames (M.singleton (moduleName, ident) (valTy', nameKind)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing val']) rest ret j+  bindNames (M.singleton (moduleName, ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing val']) rest ret j inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do   Just moduleName <- checkCurrentModule <$> get   (es, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)   ds' <- forM es $ \e -> do     (ident, (val', _)) <- typeForBindingGroupElement moduleName e dict untypedDict     return $ (ident, LocalVariable, val')-  bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j+  makeBindingGroupVisible $ bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j inferLetBinding seen (PositionedDeclaration pos d : ds) ret j = rethrowWithPosition pos $ do   ((d' : ds'), val') <- inferLetBinding seen (d : ds) ret j   return (PositionedDeclaration pos d' : ds', val')@@ -735,9 +726,9 @@ inferBinder val (ConstructorBinder ctor binders) = do   env <- getEnv   case M.lookup ctor (dataConstructors env) of-    Just (_, ty) -> do+    Just (_, _, ty) -> do       (_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contain constraints") ty-      fn' <- replaceAllTypeSynonyms fn+      fn' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ fn       go binders fn'         where         go [] ty' = do@@ -786,7 +777,7 @@ checkBinders nvals ret (CaseAlternative binders grd val : bs) = do   Just moduleName <- checkCurrentModule <$> get   m1 <- M.unions <$> zipWithM inferBinder nvals binders-  r <- bindLocalVariables moduleName (M.toList m1) $ do+  r <- bindLocalVariables moduleName [ (name, ty, Defined) | (name, ty) <- M.toList m1 ] $ do     val' <- TypedValue True <$> check val ret <*> pure ret     case grd of       Nothing -> return $ CaseAlternative binders Nothing val'@@ -861,7 +852,7 @@   dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do     n <- liftCheck freshDictionaryName     return $ Ident $ "__dict_" ++ className ++ "_" ++ show n-  val' <- withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->+  val' <- makeBindingGroupVisible $ withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->     TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)       constraints) $ check val ty   return $ TypedValue True (foldr (Abs . Left) val' dictNames) t@@ -886,7 +877,7 @@   return $ TypedValue True array t check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) | t == tyFunction = do   Just moduleName <- checkCurrentModule <$> get-  ret' <- bindLocalVariables moduleName [(arg, argTy)] $ check ret retTy+  ret' <- makeBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy   return $ TypedValue True (Abs (Left arg) ret') ty check' (Abs (Right _) _) _ = error "Binder was not desugared" check' (App f arg) ret = do@@ -895,6 +886,7 @@   return $ TypedValue True app ret check' v@(Var var) ty = do   Just moduleName <- checkCurrentModule <$> get+  checkVisibility moduleName var   repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var   ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty   v' <- subsumes (Just v) repl ty'@@ -939,6 +931,9 @@   ensureNoDuplicateProperties ps   ps' <- checkProperties ps row False   return $ TypedValue True (ObjectLiteral ps') t+check' (TypeClassDictionaryConstructorApp name ps) t = do+  ps' <- check' ps t+  return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t check' (ObjectUpdate obj ps) t@(TypeApp o row) | o == tyObject = do   ensureNoDuplicateProperties ps   us <- zip (map fst ps) <$> replicateM (length ps) fresh@@ -956,7 +951,7 @@   env <- getEnv   case M.lookup c (dataConstructors env) of     Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"-    Just (_, ty1) -> do+    Just (_, _, ty1) -> do       repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1       _ <- subsumes Nothing repl ty       return $ TypedValue True (Constructor c) ty@@ -1013,7 +1008,9 @@ -- Check the type of a function application, rethrowing errors to provide a better error message -- checkFunctionApplication :: Value -> Type -> Value -> Maybe Type -> UnifyT Type Check (Type, Value)-checkFunctionApplication fn fnTy arg ret = rethrow (mkErrorStack errorMessage (Just (ValueError fn)) <>) $ checkFunctionApplication' fn fnTy arg ret+checkFunctionApplication fn fnTy arg ret = rethrow (mkErrorStack errorMessage (Just (ValueError fn)) <>) $ do+  subst <- unifyCurrentSubstitution <$> UnifyT get+  checkFunctionApplication' fn (subst $? fnTy) arg (($?) subst <$> ret)   where   errorMessage = "Error applying function of type "     ++ prettyPrintType fnTy@@ -1025,10 +1022,12 @@ checkFunctionApplication' :: Value -> Type -> Value -> Maybe Type -> UnifyT Type Check (Type, Value) checkFunctionApplication' fn (TypeApp (TypeApp tyFunction' argTy) retTy) arg ret = do   tyFunction' =?= tyFunction-  _ <- maybe (return Nothing) (subsumes Nothing retTy) ret-  subst <- unifyCurrentSubstitution <$> UnifyT get-  arg' <- check arg (subst $? argTy)-  return (retTy, App fn arg')+  arg' <- check arg argTy+  case ret of+    Nothing -> return (retTy, App fn arg')+    Just ret' -> do+      Just app' <- subsumes (Just (App fn arg')) retTy ret'+      return (retTy, app') checkFunctionApplication' fn (ForAll ident ty _) arg ret = do   replaced <- replaceVarWithUnknown ident ty   checkFunctionApplication fn replaced arg ret@@ -1088,8 +1087,7 @@   subsumes val ty1 ty2 subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do   dicts <- getTypeClassDictionaries-  _ <- subsumes' Nothing ty1 ty2-  return . Just $ foldl App val (map (flip (TypeClassDictionary True) dicts) constraints)+  subsumes' (Just $ foldl App val (map (flip (TypeClassDictionary True) dicts) constraints)) ty1 ty2 subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyObject && f2 == tyObject = do   let     (ts1, r1') = rowToList r1