purescript 0.4.2 → 0.4.2.1

raw patch · 38 files changed

+816/−552 lines, 38 files

Files

• docgen/Main.hs +18/−18
• prelude/prelude.purs +98/−76
• psc/Main.hs +2/−2
• psci/Commands.hs +68/−0
• psci/Main.hs +146/−98
• psci/Parser.hs +92/−0
• purescript.cabal +5/−4
• src/Data/Generics/Extras.hs +35/−0
• src/Language/PureScript.hs +15/−19
• src/Language/PureScript/CodeGen/Common.hs +60/−58
• src/Language/PureScript/CodeGen/Externs.hs +2/−2
• src/Language/PureScript/CodeGen/JS.hs +12/−14
• src/Language/PureScript/CodeGen/Monad.hs +0/−1
• src/Language/PureScript/CodeGen/Optimize.hs +27/−29
• src/Language/PureScript/DeadCodeElimination.hs +5/−5
• src/Language/PureScript/Declarations.hs +11/−11
• src/Language/PureScript/ModuleDependencies.hs +1/−4
• src/Language/PureScript/Names.hs +8/−0
• src/Language/PureScript/Options.hs +1/−1
• src/Language/PureScript/Parser/Common.hs +2/−2
• src/Language/PureScript/Parser/Declarations.hs +9/−12
• src/Language/PureScript/Parser/Types.hs +8/−10
• src/Language/PureScript/Parser/Values.hs +11/−8
• src/Language/PureScript/Pretty/JS.hs +11/−13
• src/Language/PureScript/Pretty/Types.hs +3/−3
• src/Language/PureScript/Pretty/Values.hs +3/−3
• src/Language/PureScript/Scope.hs +4/−2
• src/Language/PureScript/Sugar/BindingGroups.hs +3/−3
• src/Language/PureScript/Sugar/CaseDeclarations.hs +1/−1
• src/Language/PureScript/Sugar/Operators.hs +12/−8
• src/Language/PureScript/Sugar/TypeClasses.hs +35/−37
• src/Language/PureScript/TypeChecker.hs +12/−12
• src/Language/PureScript/TypeChecker/Kinds.hs +6/−6
• src/Language/PureScript/TypeChecker/Monad.hs +9/−11
• src/Language/PureScript/TypeChecker/Types.hs +55/−57
• src/Language/PureScript/Types.hs +17/−11
• src/Language/PureScript/Values.hs +4/−4
• tests/Main.hs +5/−7

@@ -60,7 +60,7 @@  renderModule :: P.Module -> Docs renderModule (P.Module moduleName ds) = do-  headerLevel 2 $ "Module " ++ (P.runModuleName moduleName)+  headerLevel 2 $ "Module " ++ P.runModuleName moduleName   spacer   headerLevel 3 "Types"   spacer@@ -90,23 +90,23 @@ renderDeclaration n (P.ExternDeclaration _ ident _ ty) =   atIndent n $ show ident ++ " :: " ++ P.prettyPrintType ty renderDeclaration n (P.DataDeclaration name args ctors) = do-  let typeName = P.runProperName name ++ " " ++ intercalate " " args+  let typeName = P.runProperName name ++ " " ++ unwords args   atIndent n $ "data " ++ typeName ++ " where"-  forM_ ctors $ \(ctor, tys) -> do-    atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ concat (map (\ty -> P.prettyPrintType ty ++ " -> ") tys) ++ typeName+  forM_ ctors $ \(ctor, tys) ->+    atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ concatMap (\ty -> P.prettyPrintType ty ++ " -> ") tys ++ typeName renderDeclaration n (P.ExternDataDeclaration name kind) =   atIndent n $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind renderDeclaration n (P.TypeSynonymDeclaration name args ty) = do-  let typeName = P.runProperName name ++ " " ++ intercalate " " args+  let typeName = P.runProperName name ++ " " ++ unwords args   atIndent n $ "type " ++ typeName ++ " = " ++ P.prettyPrintType ty-renderDeclaration n (P.TypeClassDeclaration name arg ds) = do-  atIndent n $ "class " ++ P.runProperName name ++ " " ++ arg ++ " where"+renderDeclaration n (P.TypeClassDeclaration name args ds) = do+  atIndent n $ "class " ++ P.runProperName name ++ " " ++ unwords args ++ " where"   mapM_ (renderDeclaration (n + 2)) ds-renderDeclaration n (P.TypeInstanceDeclaration constraints name ty _) = do+renderDeclaration n (P.TypeInstanceDeclaration constraints name tys _) = do   let constraintsText = case constraints of                           [] -> ""-                          cs -> "(" ++ intercalate "," (map (\(pn, ty') -> show pn ++ " (" ++ P.prettyPrintType ty' ++ ")") cs) ++ ") => "-  atIndent n $ constraintsText ++ "instance " ++ show name ++ " " ++ P.prettyPrintType ty+                          cs -> "(" ++ intercalate "," (map (\(pn, tys') -> show pn ++ " (" ++ unwords (map (("(" ++) . (++ ")") . P.prettyPrintType) tys') ++ ")") cs) ++ ") => "+  atIndent n $ constraintsText ++ "instance " ++ show name ++ " " ++ unwords (map (("(" ++) . (++ ")") . P.prettyPrintType) tys) renderDeclaration _ _ = return ()  getName :: P.Declaration -> String@@ -120,22 +120,22 @@ getName _ = error "Invalid argument to getName"  isValueDeclaration :: P.Declaration -> Bool-isValueDeclaration (P.TypeDeclaration _ _) = True-isValueDeclaration (P.ExternDeclaration _ _ _ _) = True+isValueDeclaration P.TypeDeclaration{} = True+isValueDeclaration P.ExternDeclaration{} = True isValueDeclaration _ = False  isTypeDeclaration :: P.Declaration -> Bool-isTypeDeclaration (P.DataDeclaration _ _ _) = True-isTypeDeclaration (P.ExternDataDeclaration _ _) = True-isTypeDeclaration (P.TypeSynonymDeclaration _ _ _) = True+isTypeDeclaration P.DataDeclaration{} = True+isTypeDeclaration P.ExternDataDeclaration{} = True+isTypeDeclaration P.TypeSynonymDeclaration{} = True isTypeDeclaration _ = False  isTypeClassDeclaration :: P.Declaration -> Bool-isTypeClassDeclaration (P.TypeClassDeclaration _ _ _) = True+isTypeClassDeclaration P.TypeClassDeclaration{} = True isTypeClassDeclaration _ = False  isTypeInstanceDeclaration :: P.Declaration -> Bool-isTypeInstanceDeclaration (P.TypeInstanceDeclaration _ _ _ _) = True+isTypeInstanceDeclaration P.TypeInstanceDeclaration{} = True isTypeInstanceDeclaration _ = False  inputFile :: Term FilePath@@ -147,7 +147,7 @@ termInfo :: TermInfo termInfo = defTI   { termName = "docgen"-  , version  = showVersion $ Paths.version+  , version  = showVersion Paths.version   , termDoc  = "Generate Markdown documentation from PureScript extern files"   } 

@@ -162,17 +162,14 @@   -- Referential equality   data Ref a = Ref a -  foreign import refEq "function refEq(r1) {\-                       \  return function(r2) {\-                       \    return r1.values[0] === r2.values[0];\-                       \  };\-                       \}" :: forall a. Ref a -> Ref a -> Boolean--  foreign import refIneq "function refIneq(r1) {\-                         \  return function(r2) {\-                         \    return r1.values[0] !== r2.values[0];\-                         \  };\-                         \}" :: forall a. Ref a -> Ref a -> Boolean+  liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b+  liftRef f (Ref x) (Ref y) = f x y+  +  refEq :: forall a. Ref a -> Ref a -> Boolean+  refEq = liftRef unsafeRefEq+  +  refIneq :: forall a. Ref a -> Ref a -> Boolean+  refIneq = liftRef unsafeRefIneq    foreign import unsafeRefEq "function unsafeRefEq(r1) {\                              \  return function(r2) {\@@ -356,9 +353,10 @@                       \  };\                       \}" :: String -> String -> String -module Monoid where+module Data.Monoid where    import Prelude+  import Data.Array (foldl)    infixr 6 <> @@ -372,16 +370,15 @@    instance Monoid [a] where     mempty = []-    (<>) = Arrays.concat+    (<>) = Data.Array.concat    mconcat :: forall m. (Monoid m) => [m] -> m-  mconcat [] = mempty-  mconcat (m:ms) = m <> mconcat ms+  mconcat = foldl (<>) mempty -module Monad where+module Control.Monad where    import Prelude-  import Arrays+  import Data.Array    replicateM :: forall m a. (Monad m) => Number -> m a -> m [a]   replicateM 0 _ = return []@@ -428,7 +425,7 @@   when true m = m   when false _ = return {} -module Maybe where+module Data.Maybe where    import Prelude @@ -458,7 +455,7 @@     show (Just x) = "Just " ++ (show x)     show Nothing = "Nothing" -module Either where+module Data.Either where    import Prelude @@ -485,24 +482,18 @@     show (Left x) = "Left " ++ (show x)     show (Right y) = "Right " ++ (show y) -module Arrays where+module Data.Array where    import Prelude-  import Maybe--  head :: forall a. [a] -> a-  head (x : _) = x--  headSafe :: forall a. [a] -> Maybe a-  headSafe (x : _) = Just x-  headSafe _ = Nothing+  import Data.Maybe -  tail :: forall a. [a] -> [a]-  tail (_ : xs) = xs+  head :: forall a. [a] -> Maybe a+  head (x : _) = Just x+  head _ = Nothing -  tailSafe :: forall a. [a] -> Maybe [a]-  tailSafe (_ : xs) = Just xs-  tailSafe _ = Nothing+  tail :: forall a. [a] -> Maybe [a]+  tail (_ : xs) = Just xs+  tail _ = Nothing    map :: forall a b. (a -> b) -> [a] -> [b]   map _ [] = []@@ -512,9 +503,9 @@   foldr f a (b : bs) = f (foldr f a bs) b   foldr _ a [] = a -  foldl :: forall a b. (a -> b -> b) -> b -> [a] -> b+  foldl :: forall a b. (b -> a -> b) -> b -> [a] -> b   foldl _ b [] = b-  foldl f b (a:as) = foldl f (f a b) as+  foldl f b (a:as) = foldl f (f b a) as    foreign import length "function length(xs) {\                         \  return xs.length;\@@ -582,16 +573,39 @@                       \  return l1;\                       \}" :: forall a. [a] -> [a] -  foreign import splice "function splice(s) {\-                        \  return function(e) {\-                        \    return function(l1) {\-                        \      return function(l2) {\-                        \        return l2.splice(s, e, l1);\-                        \      }; \-                        \    }; \-                        \  };\-                        \}":: forall a. Number -> Number -> [a] -> [a] -> [a]+  foreign import insertAt +    "function insertAt(index) {\+    \  return function(a) {\+    \    return function(l) {\+    \      var l1 = l.slice();\+    \      l1.splice(index, 0, a);\+    \      return l1;\+    \    }; \+    \  };\+    \}":: forall a. Number -> a -> [a] -> [a] +  foreign import deleteAt +    "function deleteAt(index) {\+    \  return function(n) {\+    \    return function(l) {\+    \      var l1 = l.slice();\+    \      l1.splice(index, n);\+    \      return l1;\+    \    }; \+    \  };\+    \}":: forall a. Number -> Number -> [a] -> [a]++  foreign import updateAt +    "function updateAt(index) {\+    \  return function(a) {\+    \    return function(l) {\+    \      var l1 = l.slice();\+    \      l1[index] = a;\+    \      return l1;\+    \    }; \+    \  };\+    \}":: forall a. Number -> a -> [a] -> [a]+   infixr 6 :    (:) :: forall a. a -> [a] -> [a]@@ -647,11 +661,19 @@   instance Prelude.Alternative [] where     empty = []     (<|>) = concat+    +module Data.Array.Unsafe where -module Tuples where+  head :: forall a. [a] -> a+  head (x : _) = x +  tail :: forall a. [a] -> [a]+  tail (_ : xs) = xs++module Data.Tuple where+   import Prelude-  import Arrays+  import Data.Array    data Tuple a b = Tuple a b @@ -672,7 +694,7 @@     Tuple as bs -> Tuple (a : as) (b : bs)   unzip [] = Tuple [] [] -module String where+module Data.String where    foreign import lengthS "function lengthS(s) {\                          \  return s.length;\@@ -752,7 +774,7 @@                       \  return s.trim();\                       \}" :: String -> String -module Regex where+module Data.String.Regex where    foreign import data Regex :: * @@ -907,7 +929,7 @@   foreign import sqrt1_2 "var sqrt1_2 = Math.SQRT1_2;" :: Number   foreign import sqrt2   "var sqrt2   = Math.SQRT2;"   :: Number -module Eff where+module Control.Monad.Eff where    foreign import data Eff :: # ! -> * -> * @@ -936,29 +958,29 @@     (>>=) = bindEff    foreign import untilE "function untilE(f) {\-			\  return function() {\-			\    while (!f()) { }\-			\    return {};\-			\  };\+                        \  return function() {\+                        \    while (!f()) { }\+                        \    return {};\+                        \  };\                         \}" :: forall e. Eff e Boolean -> Eff e {}    foreign import whileE "function whileE(f) {\-			\  return function(a) {\-			\    return function() {\-			\      while (f()) {\+                        \  return function(a) {\+                        \    return function() {\+                        \      while (f()) {\                         \        a();\                         \      }\-			\      return {};\+                        \      return {};\                         \    };\                         \  };\                         \}" :: forall e a. Eff e Boolean -> Eff e a -> Eff e {}    foreign import forE "function forE(lo) {\-	              \  return function(hi) {\-	              \    return function(f) {\-	              \      return function() {\-	              \        for (var i = lo; i < hi; i++) {\-		      \          f(i)();\+                      \  return function(hi) {\+                      \    return function(f) {\+                      \      return function() {\+                      \        for (var i = lo; i < hi; i++) {\+                      \          f(i)();\                       \        }\                       \      };\                       \    };\@@ -967,9 +989,9 @@     foreign import foreachE "function foreachE(as) {\-	                  \  return function(f) {\-	                  \    for (var i = 0; i < as.length; i++) {\-		          \      f(as[i])();\+                          \  return function(f) {\+                          \    for (var i = 0; i < as.length; i++) {\+                          \      f(as[i])();\                           \    }\                           \  };\                           \}" :: forall e a. [a] -> (a -> Eff e {}) -> Eff e {}@@ -977,7 +999,7 @@  module Random where -  import Eff+  import Control.Monad.Eff    foreign import data Random :: ! @@ -985,9 +1007,9 @@                         \  return Math.random();\                         \}" :: forall e. Eff (random :: Random | e) Number -module Errors where+module Control.Monad.Error where -  import Eff+  import Control.Monad.Eff    foreign import data Error :: * -> ! @@ -1009,9 +1031,9 @@                             \  };\                             \}" :: forall e r a. (e -> Eff r a) -> Eff (err :: Error e | r) a -> Eff r a -module IORef where+module Data.IORef where -  import Eff+  import Control.Monad.Eff    foreign import data Ref :: ! @@ -1052,10 +1074,10 @@                                 \  return f;\                                 \}" :: forall eff a. Eff (ref :: Ref | eff) a -> Eff eff a -module Trace where+module Debug.Trace where    import Prelude-  import Eff+  import Control.Monad.Eff    foreign import data Trace :: ! @@ -1069,9 +1091,9 @@   print :: forall a r. (Prelude.Show a) => a -> Eff (trace :: Trace | r) {}   print o = trace (show o) -module ST where+module Control.Monad.ST where -  import Eff+  import Control.Monad.Eff    foreign import data ST :: * -> ! @@ -1145,9 +1167,9 @@                             \  return f;\                             \}" :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r [a] -module Enum where+module Data.Enum where -  import Maybe+  import Data.Maybe    class Enum a where     toEnum :: Number -> Maybe a

@@ -28,7 +28,7 @@ preludeFilename = Paths.getDataFileName "prelude/prelude.purs"  readInput :: Maybe [FilePath] -> IO (Either ParseError [P.Module])-readInput Nothing = getContents >>= return . P.runIndentParser "" P.parseModules+readInput Nothing = P.runIndentParser "" P.parseModules <$> getContents readInput (Just input) = fmap (fmap concat . sequence) $ forM input $ \inputFile -> do   text <- U.readFile inputFile   return $ P.runIndentParser inputFile P.parseModules text@@ -118,7 +118,7 @@ termInfo :: TermInfo termInfo = defTI   { termName = "psc"-  , version  = showVersion $ Paths.version+  , version  = showVersion Paths.version   , termDoc  = "Compiles PureScript to Javascript"   } 

@@ -0,0 +1,68 @@+-----------------------------------------------------------------------------+--+-- Module      :  Commands+-- Copyright   :  (c) Phil Freeman 2014+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- Commands for PSCI.+--+-----------------------------------------------------------------------------++module Commands where++import Language.PureScript++-- |+-- Valid Meta-commands for PSCI+--+data Command+  -- |+  -- A purescript expression+  --+  = Expression Value+  -- |+  -- Show the help command+  --+  | Help+  -- |+  -- Import a module from a loaded file+  --+  | Import ModuleName+  -- |+  -- Load a file for use with importing+  --+  | LoadFile FilePath+  -- |+  -- Exit PSCI+  --+  | Quit+  -- |+  -- Reset the state of the REPL+  --+  | Reset+  -- |+  -- Binds a value to a name+  --+  | Let (Value -> Value)+  -- |+  -- Find the type of an expression+  --+  | TypeOf Value++-- |+-- The help menu.+--+help :: [[String]]+help =+  [ [":?          ", "Show this help menu"]+  , [":i <module> ", "Import <module> for use in PSCI"]+  , [":m <file>   ", "Load <file> for importing"]+  , [":q          ", "Quit PSCi"]+  , [":r          ", "Reset"]+  , [":t <expr>   ", "Show the type of <expr>"]+  ]

@@ -13,7 +13,7 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DoAndIfThenElse, FlexibleContexts #-}  module Main where @@ -23,22 +23,29 @@ import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)-import Control.Monad.Trans.State+import Control.Monad.Trans.State.Strict -import Data.List (intercalate, isPrefixOf, nub, sort)+import Data.List (intercalate, isPrefixOf, nub, sortBy) import Data.Maybe (mapMaybe) import Data.Traversable (traverse)+import Data.Version (showVersion) +import Parser+ import System.Console.Haskeline-import System.Directory (findExecutable)+import System.Directory (doesFileExist, findExecutable, getHomeDirectory) import System.Exit import System.Environment.XDG.BaseDir+import System.FilePath ((</>), isPathSeparator)+import qualified System.Console.CmdTheLine as Cmd import System.Process +import Text.Parsec (ParseError)++import qualified Data.Map as M import qualified Language.PureScript as P import qualified Paths_purescript as Paths import qualified System.IO.UTF8 as U (readFile)-import qualified Text.Parsec as Parsec (Parsec, eof)  -- | -- The PSCI state.@@ -46,48 +53,45 @@ -- The let bindings are partial, -- because it makes more sense to apply the binding to the final evaluated expression. ---data PSCI = PSCI [P.ProperName] [P.Module] [P.Value -> P.Value]+data PSCiState = PSCiState+  { psciImportedFilenames   :: [FilePath]+  , psciImportedModuleNames :: [P.ModuleName]+  , psciLoadedModules       :: [P.Module]+  , psciLetBindings         :: [P.Value -> P.Value]+  }  -- State helpers  -- |--- Synonym to be more descriptive.--- This is just @lift@----inputTToState :: InputT IO a -> StateT PSCI (InputT IO) a-inputTToState = lift---- |--- Synonym to be more descriptive.--- This is just @lift . lift@+-- Updates the state to have more imported modules. ---ioToState :: IO a -> StateT PSCI (InputT IO) a-ioToState = lift . lift+updateImportedFiles :: FilePath -> PSCiState -> PSCiState+updateImportedFiles filename st = st { psciImportedFilenames = filename : psciImportedFilenames st }  -- | -- Updates the state to have more imported modules. ---updateImports :: String -> PSCI -> PSCI-updateImports name (PSCI i m b) = PSCI (i ++ [P.ProperName name]) m b+updateImports :: P.ModuleName -> PSCiState -> PSCiState+updateImports name st = st { psciImportedModuleNames = name : psciImportedModuleNames st }  -- | -- Updates the state to have more loaded files. ---updateModules :: [P.Module] -> PSCI -> PSCI-updateModules modules (PSCI i m b) = PSCI i (m ++ modules) b+updateModules :: [P.Module] -> PSCiState -> PSCiState+updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules }  -- | -- Updates the state to have more let bindings. ---updateLets :: (P.Value -> P.Value) -> PSCI -> PSCI-updateLets name (PSCI i m b) = PSCI i m (b ++ [name])+updateLets :: (P.Value -> P.Value) -> PSCiState -> PSCiState+updateLets name st = st { psciLetBindings = psciLetBindings st ++ [name] }  -- File helpers -- | -- Load the necessary modules. ---defaultImports :: [P.ProperName]-defaultImports = [P.ProperName "Prelude"]+defaultImports :: [P.ModuleName]+defaultImports = [P.ModuleName [P.ProperName "Prelude"]]  -- | -- Locates the node executable.@@ -95,7 +99,7 @@ -- findNodeProcess :: IO (Maybe String) findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names-    where names = ["nodejs", "node"]+  where names = ["nodejs", "node"]  -- | -- Grabs the filename where the history is stored.@@ -113,10 +117,14 @@ -- Loads a file for use with imports. -- loadModule :: FilePath -> IO (Either String [P.Module])-loadModule moduleFile = do-  moduleText <- U.readFile moduleFile-  return . either (Left . show) Right $ P.runIndentParser "" P.parseModules moduleText+loadModule filename = either (Left . show) Right . P.runIndentParser filename P.parseModules <$> U.readFile filename +-- |+-- Expands tilde in path.+--+expandTilde :: FilePath -> IO FilePath+expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory+expandTilde p = return p -- Messages  -- |@@ -154,23 +162,27 @@ -- | -- Loads module, function, and file completions. ---completion :: [P.Module] -> CompletionFunc IO-completion ms = completeWord Nothing " \t\n\r" findCompletions+completion :: CompletionFunc (StateT PSCiState IO)+completion = completeWord Nothing " \t\n\r" findCompletions   where-  findCompletions :: String -> IO [Completion]+  findCompletions :: String -> StateT PSCiState IO [Completion]   findCompletions str = do+    ms <- psciLoadedModules <$> get     files <- listFiles str-    let names = nub [ show qual-                    | P.Module moduleName ds <- ms-                    , ident <- mapMaybe getDeclName ds-                    , qual <- [ P.Qualified Nothing ident-                              , P.Qualified (Just moduleName) ident]-                    ]-    let matches = sort $ filter (isPrefixOf str) names-    return $ map simpleCompletion matches ++ files+    let matches = filter (isPrefixOf str) (names ms)+    return $ sortBy sorter $ map simpleCompletion matches ++ files   getDeclName :: P.Declaration -> Maybe P.Ident   getDeclName (P.ValueDeclaration ident _ _ _) = Just ident   getDeclName _ = Nothing+  names :: [P.Module] -> [String]+  names ms = nub [ show qual+              | P.Module moduleName ds <- ms+              , ident <- mapMaybe getDeclName ds+              , qual <- [ P.Qualified Nothing ident+                        , P.Qualified (Just moduleName) ident]+              ]+  sorter :: Completion -> Completion -> Ordering+  sorter (Completion _ d1 _) (Completion _ d2 _) = compare d1 d2  -- Compilation @@ -182,93 +194,129 @@ -- | -- Makes a volatile module to execute the current expression. ---createTemporaryModule :: [P.ProperName] -> [P.Value -> P.Value] -> P.Value -> P.Module-createTemporaryModule imports lets value =+createTemporaryModule :: Bool -> [P.ModuleName] -> [P.Value -> P.Value] -> P.Value -> P.Module+createTemporaryModule exec imports lets value =   let     moduleName = P.ModuleName [P.ProperName "Main"]     importDecl m = P.ImportDeclaration m Nothing-    traceModule = P.ModuleName [P.ProperName "Trace"]+    traceModule = P.ModuleName [P.ProperName "Debug", P.ProperName "Trace"]     trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))     value' = foldr ($) value lets-    mainDecl = P.ValueDeclaration (P.Ident "main") [] Nothing (P.App trace value')+    itDecl = P.ValueDeclaration (P.Ident "it") [] Nothing value'+    mainDecl = P.ValueDeclaration (P.Ident "main") [] Nothing (P.App trace (P.Var (P.Qualified Nothing (P.Ident "it"))))   in-    P.Module moduleName $ map (importDecl . P.ModuleName . return) imports ++ [mainDecl]+    P.Module moduleName $ map importDecl imports ++ if exec then [itDecl, mainDecl] else [itDecl]  -- | -- Takes a value declaration and evaluates it with the current state. ---handleDeclaration :: P.Value -> PSCI -> InputT IO ()-handleDeclaration value (PSCI imports loadedModules lets) = do-  let m = createTemporaryModule imports lets value-  case P.compile options (loadedModules ++ [m]) of+handleDeclaration :: P.Value -> PSCiState -> InputT (StateT PSCiState IO) ()+handleDeclaration value st = do+  let m = createTemporaryModule True (psciImportedModuleNames st) (psciLetBindings st) value+  case P.compile options (psciLoadedModules st ++ [m]) of     Left err -> outputStrLn err     Right (js, _, _) -> do-      process <- lift findNodeProcess-      result <- lift $ traverse (\node -> readProcessWithExitCode node [] js) process+      process <- lift . lift $ findNodeProcess+      result <- lift . lift $ traverse (\node -> readProcessWithExitCode node [] js) process       case result of         Just (ExitSuccess,   out, _)   -> outputStrLn out         Just (ExitFailure _, _,   err) -> outputStrLn err         Nothing                        -> outputStrLn "Couldn't find node.js" --- Parser helpers- -- |--- Parser for our PSCI version of @let@.--- This is essentially let from do-notation.--- However, since we don't support the @Eff@ monad, we actually want the normal @let@.+-- Takes a value and prints its type ---parseLet :: Parsec.Parsec String P.ParseState (P.Value -> P.Value)-parseLet = P.Let <$> (P.reserved "let" *> P.indented *> P.parseBinder)-                 <*> (P.indented *> P.reservedOp "=" *> P.parseValue)+handleTypeOf :: P.Value -> PSCiState -> InputT (StateT PSCiState IO) ()+handleTypeOf value st = do+  let m = createTemporaryModule False (psciImportedModuleNames st) (psciLetBindings st) value+  case P.compile options { P.optionsMain = Nothing } (psciLoadedModules st ++ [m]) of+    Left err -> outputStrLn err+    Right (_, _, env') ->+      case M.lookup (P.ModuleName [P.ProperName "Main"], P.Ident "it") (P.names env') of+        Just (ty, _) -> outputStrLn . P.prettyPrintType $ ty+        Nothing -> outputStrLn "Could not find type" +-- Commands+ -- |--- Parser for any other valid expression.+-- Parses the input and returns either a Metacommand or an expression. ---parseExpression :: Parsec.Parsec String P.ParseState P.Value-parseExpression = P.whiteSpace *> P.parseValue <* Parsec.eof---- Commands+getCommand :: InputT (StateT PSCiState IO) (Either ParseError (Maybe Command))+getCommand = do+  firstLine <- getInputLine "> "+  case firstLine of+    Nothing -> return (Right Nothing)+    Just s@ (':' : _) -> return . either Left (Right . Just) $ parseCommand s -- The start of a command+    Just s -> either Left (Right . Just) . parseCommand <$> go [s]+  where+    go :: [String] -> InputT (StateT PSCiState IO) String+    go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine "  "  -- | -- Performs an action for each meta-command given, and also for expressions.. ---handleCommand :: Command -> StateT PSCI (InputT IO) ()-handleCommand Empty = return ()-handleCommand (Expression ls) =-  case P.runIndentParser "" parseLet (unlines ls) of-    Left _ ->-      case P.runIndentParser "" parseExpression (unlines ls) of-        Left err -> inputTToState $ outputStrLn (show err)-        Right decl -> get >>= inputTToState . handleDeclaration decl-    Right l -> modify (updateLets l)-handleCommand Help = inputTToState $ outputStrLn helpMessage-handleCommand (Import moduleName) = modify (updateImports moduleName)+handleCommand :: Command -> InputT (StateT PSCiState IO) ()+handleCommand (Expression val) = lift get >>= handleDeclaration val+handleCommand (Let l) = lift $ modify (updateLets l)+handleCommand Help = outputStrLn helpMessage+handleCommand (Import moduleName) = lift $ modify (updateImports moduleName) handleCommand (LoadFile filePath) = do-  mf <- ioToState $ loadModule filePath-  case mf of-    Left err -> inputTToState $ outputStrLn err-    Right mf' -> modify (updateModules mf')-handleCommand Reload = do-  (Right prelude) <- ioToState $ getPreludeFilename >>= loadModule-  put (PSCI defaultImports prelude [])-handleCommand _ = inputTToState $ outputStrLn "Unknown command"+  absPath <- lift . lift $ expandTilde filePath+  exists <- lift . lift $ doesFileExist absPath+  if exists then do+    lift $ modify (updateImportedFiles absPath)+    either outputStrLn (lift . modify . updateModules) =<< (lift . lift $ loadModule absPath)+  else+    outputStrLn $ "Couldn't locate: " ++ filePath+handleCommand Reset = do+  preludeFilename <- lift . lift $ getPreludeFilename+  files <- psciImportedFilenames <$> lift get+  modulesOrFirstError <- fmap concat . sequence <$> mapM (lift . lift . loadModule) (preludeFilename : files)+  case modulesOrFirstError of+    Left err -> lift . lift $ putStrLn err >> exitFailure+    Right modules -> lift $ put (PSCiState (preludeFilename : files) defaultImports modules [])+handleCommand (TypeOf val) = lift get >>= handleTypeOf val+handleCommand _ = outputStrLn "Unknown command" +inputFiles :: Cmd.Term [FilePath]+inputFiles = Cmd.value $ Cmd.posAny [] $ Cmd.posInfo { Cmd.posName = "file(s)"+                                                     , Cmd.posDoc = "Optional .purs files to load on start" }+ -- | -- The PSCI main loop. ---main :: IO ()-main = do+loop :: [FilePath] -> IO ()+loop files = do   preludeFilename <- getPreludeFilename-  (Right prelude) <- loadModule preludeFilename-  historyFilename <- getHistoryFilename-  let settings = defaultSettings {historyFile = Just historyFilename}-  runInputT (setComplete (completion prelude) settings) $ do-    outputStrLn prologueMessage-    evalStateT go (PSCI defaultImports prelude [])-  where-    go :: StateT PSCI (InputT IO) ()-    go = do-      c <- inputTToState getCommand-      case c of-        Quit -> inputTToState $ outputStrLn quitMessage-        _    -> handleCommand c >> go+  modulesOrFirstError <- fmap concat . sequence <$> mapM loadModule (preludeFilename : files)+  case modulesOrFirstError of+    Left err -> putStrLn err >> exitFailure+    Right modules -> do+      historyFilename <- getHistoryFilename+      let settings = defaultSettings {historyFile = Just historyFilename}+      flip evalStateT (PSCiState (preludeFilename : files) defaultImports modules []) . runInputT (setComplete completion settings) $ do+        outputStrLn prologueMessage+        go+      where+        go :: InputT (StateT PSCiState IO) ()+        go = do+          c <- getCommand+          case c of+            Left err -> outputStrLn (show err) >> go+            Right Nothing -> go+            Right (Just Quit) -> outputStrLn quitMessage+            Right (Just c') -> handleCommand c' >> go++term :: Cmd.Term (IO ())+term = loop <$> inputFiles++termInfo :: Cmd.TermInfo+termInfo = Cmd.defTI+  { Cmd.termName = "psci"+  , Cmd.version  = showVersion Paths.version+  , Cmd.termDoc  = "Interactive mode for PureScript"+  }++main :: IO ()+main = Cmd.run (term, termInfo)+

@@ -0,0 +1,92 @@+-----------------------------------------------------------------------------+--+-- Module      :  Parser+-- Copyright   :  (c) Phil Freeman 2014+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- Parser for PSCI.+--+-----------------------------------------------------------------------------++module Parser (+    parseCommand+  ) where++import Commands++import Data.Char (isSpace)++import Control.Applicative hiding (many)++import Text.Parsec hiding ((<|>))++import qualified Language.PureScript as P++-- |+-- PSCI version of @let@.+-- This is essentially let from do-notation.+-- However, since we don't support the @Eff@ monad,+-- we actually want the normal @let@.+--+psciLet :: Parsec String P.ParseState Command+psciLet = Let <$> (P.Let <$> (P.reserved "let" *> P.indented *> P.parseBinder)+                         <*> (P.indented *> P.reservedOp "=" *> P.parseValue))++-- |+-- Parses PSCI metacommands or expressions input from the user.+--+parseCommand :: String -> Either ParseError Command+parseCommand = P.runIndentParser "" $ choice+                    [ P.whiteSpace *> char ':' *> (psciHelp <|> psciImport <|> psciLoadFile <|> psciQuit <|> psciReload <|> psciTypeOf)+                    , try psciLet+                    , psciExpression+                    ] <* eof++-- |+-- Parses expressions entered at the PSCI repl.+--+psciExpression :: Parsec String P.ParseState Command+psciExpression = Expression <$> P.parseValue++-- |+-- Parses 'Commands.Help' command.+--+psciHelp :: Parsec String P.ParseState Command+psciHelp = Help <$ char '?'++-- |+-- Parses 'Commands.Import' command.+--+psciImport :: Parsec String P.ParseState Command+psciImport = Import <$> (char 'i' *> P.whiteSpace *> P.moduleName)++-- |+-- Parses 'Commands.LoadFile' command.+--+psciLoadFile :: Parsec String P.ParseState Command+psciLoadFile = LoadFile . trimEnd <$> (char 'm' *> P.whiteSpace *> manyTill anyChar eof)+  where+  trimEnd = reverse . dropWhile isSpace . reverse++-- |+-- Parses 'Commands.Quit' command.+--+psciQuit :: Parsec String P.ParseState Command+psciQuit = Quit <$ char 'q'++-- |+-- Parses 'Commands.Reload' command.+--+psciReload :: Parsec String P.ParseState Command+psciReload = Reset <$ char 'r'++-- |+-- Parses 'Commands.TypeOf' command.+--+psciTypeOf :: Parsec String P.ParseState Command+psciTypeOf = TypeOf <$> (char 't' *> P.whiteSpace *> P.parseValue)

@@ -1,5 +1,5 @@ name: purescript-version: 0.4.2+version: 0.4.2.1 cabal-version: >=1.8 build-type: Custom license: MIT@@ -84,14 +84,15 @@     ghc-options: -Wall -O2 -fno-warn-unused-do-bind  executable psci-    build-depends: base >=4 && <5, containers -any, directory -any,+    build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,                    mtl -any, parsec -any, haskeline <=0.7.1.1, purescript -any,                    syb -any, transformers -any, utf8-string -any, process -any,-                   xdg-basedir -any+                   xdg-basedir -any, cmdtheline -any     main-is: Main.hs     buildable: True     hs-source-dirs: psci-    other-modules:+    other-modules: Commands+                   Parser     ghc-options: -Wall -O2  executable docgen

@@ -18,6 +18,7 @@ module Data.Generics.Extras where  import Data.Data+import Data.Maybe (fromMaybe)  -- | -- Apply a top-down monadic transformation everywhere@@ -26,3 +27,37 @@ everywhereM' f x = do   y <- f x   gmapM (everywhereM' f) y++-- |+-- Apply a top-down transformation, mutating a state when descending from parents to children+--+-- For example, if we want to relabel bound variables with a different data constructor, we can do so:+--+-- > data Expr = Var String+-- >           | Lam String Test+-- >           | App Test Test+-- >           | LocalVar String deriving (Show, Data, Typeable)+-- >+-- > test = App (Lam "a" (App (Var "a") (Var "b"))) (Var "a")+-- >+-- > varsToLocals :: Expr -> Expr+-- > varsToLocals = everywhereWithContext' [] (mkS go)+-- >   where+-- >   go locals (Var v) | v `elem` locals = (locals, LocalVar v)+-- >   go locals lam@(Lam local _) = (local : locals, lam)+-- >   go locals other = (locals, other)+--+everywhereWithContext' :: (Data d) => s -> (forall d1. (Data d1) => s -> d1 -> (s, d1)) -> d -> d+everywhereWithContext' s0 f x =+  let (s, y) = f s0 x in+  gmapT (everywhereWithContext' s f) y++-- |+-- Make a stateful transformation function+--+mkS :: (Data a, Data b) => (s -> a -> (s, a)) -> s -> b -> (s, b)+mkS f s b = fromMaybe (s, b) $ do+  a <- cast b+  let (s', a') = f s a+  b' <- cast a'+  return (s', b')

@@ -22,6 +22,7 @@ import Language.PureScript.Names as P import Language.PureScript.Parser as P import Language.PureScript.CodeGen as P+import Language.PureScript.CodeGen.Common as P import Language.PureScript.TypeChecker as P import Language.PureScript.Pretty as P import Language.PureScript.Sugar as P@@ -30,10 +31,9 @@ import Language.PureScript.DeadCodeElimination as P  import Data.List (intercalate)-import Data.Maybe (mapMaybe, fromMaybe)-import Control.Monad (when, forM)+import Data.Maybe (mapMaybe) import Control.Monad.State.Lazy-import Control.Applicative ((<$>), (<|>))+import Control.Applicative ((<$>)) import qualified Data.Map as M  -- |@@ -59,24 +59,20 @@ compile opts ms = do   sorted <- sortModules ms   desugared <- desugar sorted-  (elaborated, env) <- runCheck $ forM desugared $ \(Module moduleName decls) -> do-    modify (\s -> s { checkCurrentModule = Just moduleName })-    Module moduleName <$> typeCheckAll mainModuleIdent moduleName decls+  (elaborated, env) <- runCheck $ forM desugared $ \(Module moduleName' decls) -> do+    modify (\s -> s { checkCurrentModule = Just moduleName' })+    Module moduleName' <$> typeCheckAll mainModuleIdent moduleName' decls   regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated-  let entryPoints = (ModuleName . splitProperNames) `map` optionsModules opts+  let entryPoints = moduleNameFromString `map` optionsModules opts   let elim = if null entryPoints then regrouped else eliminateDeadCode env entryPoints regrouped   let js = mapMaybe (flip (moduleToJs opts) env) elim-  let exts = intercalate "\n" . map (flip moduleToPs env) $ elim-  js' <- case optionsMain opts of-    Just mainModuleName -> do-      when ((ModuleName [ProperName mainModuleName], Ident "main") `M.notMember` (names env)) $-        Left $ mainModuleName ++ ".main is undefined"-      return $ js ++ [JSApp (JSAccessor "main" (JSAccessor mainModuleName (JSVar "_ps"))) []]+  let exts = intercalate "\n" . map (`moduleToPs` env) $ elim+  js' <- case mainModuleIdent of+    Just mmi -> do+      when ((mmi, Ident "main") `M.notMember` names env) $+        Left $ show mmi ++ ".main is undefined"+      return $ js ++ [JSApp (JSAccessor "main" (JSAccessor (moduleNameToJs mmi) (JSVar "_ps"))) []]     _ -> return js-  return (prettyPrintJS [(wrapExportsContainer opts js')], exts, env)+  return (prettyPrintJS [wrapExportsContainer opts js'], exts, env)   where-  mainModuleIdent = ModuleName . splitProperNames <$> optionsMain opts-  splitProperNames s = case dropWhile (== '.') s of-    "" -> []-    s' -> ProperName w : splitProperNames s''-      where (w, s'') = break (== '.') s'+  mainModuleIdent = moduleNameFromString <$> optionsMain opts

@@ -69,64 +69,66 @@ -- nameIsJsReserved :: String -> Bool nameIsJsReserved name =-  elem name [ "abstract"-            , "boolean"-            , "break"-            , "byte"-            , "case"-            , "catch"-            , "char"-            , "class"-            , "const"-            , "continue"-            , "debugger"-            , "default"-            , "delete"-            , "do"-            , "double"-            , "else"-            , "enum"-            , "export"-            , "extends"-            , "final"-            , "finally"-            , "float"-            , "for"-            , "function"-            , "goto"-            , "if"-            , "implements"-            , "import"-            , "in"-            , "instanceof"-            , "int"-            , "interface"-            , "let"-            , "long"-            , "native"-            , "new"-            , "package"-            , "private"-            , "protected"-            , "public"-            , "return"-            , "short"-            , "static"-            , "super"-            , "switch"-            , "synchronized"-            , "this"-            , "throw"-            , "throws"-            , "transient"-            , "try"-            , "typeof"-            , "var"-            , "void"-            , "volatile"-            , "while"-            , "with"-            , "yield" ]+  name `elem` [ "abstract"+              , "arguments"+              , "boolean"+              , "break"+              , "byte"+              , "case"+              , "catch"+              , "char"+              , "class"+              , "const"+              , "continue"+              , "debugger"+              , "default"+              , "delete"+              , "do"+              , "double"+              , "else"+              , "enum"+              , "eval"+              , "export"+              , "extends"+              , "final"+              , "finally"+              , "float"+              , "for"+              , "function"+              , "goto"+              , "if"+              , "implements"+              , "import"+              , "in"+              , "instanceof"+              , "int"+              , "interface"+              , "let"+              , "long"+              , "native"+              , "new"+              , "package"+              , "private"+              , "protected"+              , "public"+              , "return"+              , "short"+              , "static"+              , "super"+              , "switch"+              , "synchronized"+              , "this"+              , "throw"+              , "throws"+              , "transient"+              , "try"+              , "typeof"+              , "var"+              , "void"+              , "volatile"+              , "while"+              , "with"+              , "yield" ]  moduleNameToJs :: ModuleName -> String moduleNameToJs (ModuleName pns) = intercalate "_" (runProperName `map` pns)

@@ -30,14 +30,14 @@ -- moduleToPs :: Module -> Environment -> String moduleToPs (Module mn decls) env =-  "module " ++ (runModuleName mn) ++ " where\n" +++  "module " ++ runModuleName mn ++ " where\n" ++   (intercalate "\n" . map ("  " ++) . concatMap (declToPs mn env) $ decls)  declToPs :: ModuleName -> Environment -> Declaration -> [String] declToPs path env (ValueDeclaration name _ _ _) = maybeToList $ do   (ty, _) <- M.lookup (path, name) $ names env   return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty-declToPs path env (BindingGroupDeclaration vals) = do+declToPs path env (BindingGroupDeclaration vals) =   flip mapMaybe vals $ \(name, _) -> do     (ty, _) <- M.lookup (path, name) $ names env     return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty

@@ -23,7 +23,6 @@ ) where  import Data.Maybe (fromMaybe, mapMaybe)-import Data.List (sortBy) import Data.Function (on) import Data.Data (Data) import Data.Generics (mkQ, everything)@@ -38,7 +37,6 @@ import Language.PureScript.Names import Language.PureScript.Scope import Language.PureScript.Declarations-import Language.PureScript.Pretty.Common import Language.PureScript.CodeGen.Monad import Language.PureScript.Options import Language.PureScript.CodeGen.JS.AST as AST@@ -57,16 +55,16 @@     [] -> Nothing     _ -> Just $ JSAssignment (JSAccessor (moduleNameToJs name) (JSVar "_ps")) $            JSApp (JSFunction Nothing ["module"] (JSBlock $ jsDecls ++ [JSReturn $ JSVar "module"]))-                 [(JSBinary Or (JSAccessor (moduleNameToJs name) (JSVar "_ps")) (JSObjectLiteral []))]+                 [JSBinary Or (JSAccessor (moduleNameToJs name) (JSVar "_ps")) (JSObjectLiteral [])]   where-  jsDecls = (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts name decl env) (decls))+  jsDecls = concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts name decl env) decls  -- | -- Generate code in the simplified Javascript intermediate representation for a declaration -- declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS] declToJs opts mp (ValueDeclaration ident _ _ val) e =-  Just $ [ JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))+  Just [ JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))          , setExportProperty ident (var ident) ] declToJs opts mp (BindingGroupDeclaration vals) e =   Just $ concatMap (\(ident, val) ->@@ -85,8 +83,8 @@         (JSBlock [JSReturn (go pn (index + 1) tys' (JSVar ("value" ++ show index) : values))]) declToJs opts mp (DataBindingGroupDeclaration ds) e =   Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds-declToJs _ mp (ExternDeclaration importTy ident (Just js) _) _ =-  Just $ [js, setExportProperty ident (var ident)]+declToJs _ _ (ExternDeclaration _ ident (Just js) _) _ =+  Just [js, setExportProperty ident (var ident)] declToJs _ _ _ _ = Nothing  -- |@@ -94,7 +92,7 @@ -- declaration from a module. -- setExportProperty :: Ident -> JS -> JS-setExportProperty ident val = JSAssignment (accessor ident (JSVar "module")) val+setExportProperty ident = JSAssignment (accessor ident (JSVar "module"))  -- | -- Generate code in the simplified Javascript intermediate representation for a variable based on a@@ -194,12 +192,12 @@ varToJs :: ModuleName -> Environment -> Qualified Ident -> JS varToJs m e qual@(Qualified _ ident) = go qual   where-  go qual = case M.lookup (qualify m qual) (names e) of+  go qual' = case M.lookup (qualify m qual') (names e) of     Just (_, ty) | isExtern ty -> var ident     Just (_, Alias aliasModule aliasIdent) -> go (Qualified (Just aliasModule) aliasIdent)-    _ -> case qual of+    _ -> case qual' of            Qualified Nothing _ -> var ident-           _ -> qualifiedToJS m id qual+           _ -> qualifiedToJS m id qual'   isExtern (Extern ForeignImport) = True   isExtern (Alias m' ident') = case M.lookup (m', ident') (names e) of     Just (_, ty') -> isExtern ty'@@ -212,7 +210,7 @@ -- qualifiedToJS :: ModuleName -> (a -> Ident) -> Qualified a -> JS qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSAccessor (moduleNameToJs m') $ JSVar "_ps")-qualifiedToJS m f (Qualified _ a) = JSVar $ identToJs (f a)+qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)  -- | -- Generate code in the simplified Javascript intermediate representation for pattern match binders@@ -256,7 +254,7 @@   return [JSIfElse (JSVar varName) (JSBlock done) Nothing] binderToJs _ _ varName done (BooleanBinder False) =   return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]-binderToJs m e varName done (VarBinder ident) =+binderToJs _ _ varName done (VarBinder ident) =   return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done) binderToJs m e varName done (ConstructorBinder ctor bs) = do   js <- go 0 done bs@@ -326,7 +324,7 @@   typeConstructor fn = error $ "Invalid arguments to typeConstructor: " ++ show fn  wrapExportsContainer :: Options -> [JS] -> JS-wrapExportsContainer opts modules = JSApp (JSFunction Nothing ["_ps"] $ JSBlock $ (JSStringLiteral "use strict") : modules) [exportSelector]+wrapExportsContainer opts modules = JSApp (JSFunction Nothing ["_ps"] $ JSBlock $ JSStringLiteral "use strict" : modules) [exportSelector]   where   exportSelector = JSConditional (JSBinary And (JSBinary NotEqualTo (JSTypeOf $ JSVar "module") (JSStringLiteral "undefined")) (JSAccessor "exports" (JSVar "module")))                            (JSAccessor "exports" (JSVar "module"))

@@ -21,7 +21,6 @@  import Control.Monad.State import Control.Applicative-import Language.PureScript.Names  -- | -- Code generation monad data type

@@ -73,10 +73,10 @@ applyAll = foldl1 (.)  untilFixedPoint :: (Eq a) => (a -> a) -> a -> a-untilFixedPoint f a = go a+untilFixedPoint f = go   where-  go a' = let a'' = f a' in-          if a'' == a' then a'' else go a''+  go a = let a' = f a in+          if a' == a then a' else go a'  replaceIdent :: (Data d) => String -> JS -> d -> d replaceIdent var1 js = everywhere (mkT replace)@@ -100,7 +100,7 @@   check _ = False  isRebound :: (Data d) => JS -> d -> Bool-isRebound js d = any (\var -> isReassigned var d) (everything (++) (mkQ [] variablesOf) js)+isRebound js d = any (`isReassigned` d) (everything (++) (mkQ [] variablesOf) js)   where   variablesOf (JSVar var) = [var]   variablesOf _ = []@@ -135,25 +135,23 @@ shouldInline (JSIndexer index val) = shouldInline index && shouldInline val shouldInline _ = False +removeFromBlock :: ([JS] -> [JS]) -> JS -> JS+removeFromBlock go (JSBlock sts) = JSBlock (go sts)+removeFromBlock _  js = js+ inlineVariables :: JS -> JS-inlineVariables = everywhere (mkT removeFromBlock)+inlineVariables = everywhere (mkT $ removeFromBlock go)   where-  removeFromBlock :: JS -> JS-  removeFromBlock (JSBlock sts) = JSBlock (go sts)-  removeFromBlock js = js   go :: [JS] -> [JS]   go [] = []-  go (s@(JSVariableIntroduction var (Just js)) : sts)+  go (JSVariableIntroduction var (Just js) : sts)     | shouldInline js && not (isReassigned var sts) && not (isRebound js sts) && not (isUpdated var sts) =       go (replaceIdent var js sts)   go (s:sts) = s : go sts  removeUnusedVariables :: JS -> JS-removeUnusedVariables = everywhere (mkT removeFromBlock)+removeUnusedVariables = everywhere (mkT $ removeFromBlock go)   where-  removeFromBlock :: JS -> JS-  removeFromBlock (JSBlock sts) = JSBlock (go sts)-  removeFromBlock js = js   go :: [JS] -> [JS]   go [] = []   go (JSVariableIntroduction var _ : sts) | not (isUsed var sts) = go sts@@ -165,8 +163,8 @@   convert :: JS -> JS   convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])     | all shouldInline args &&-      not (any (flip isRebound block) (map JSVar idents)) &&-      not (or (map (flip isRebound block) args))+      not (any (`isRebound` block) (map JSVar idents)) &&+      not (any (`isRebound` block) args)       = JSBlock (replaceIdents (zip idents args) body)   convert js = js @@ -191,7 +189,7 @@   copyVar :: String -> String   copyVar arg = "__copy_" ++ arg   convert :: JS -> JS-  convert js@(JSVariableIntroduction name (Just fn@(JSFunction _ _ _))) =+  convert js@(JSVariableIntroduction name (Just fn@JSFunction {})) =     let       (argss, body', replace) = collectAllFunctionArgs [] id fn     in case () of@@ -206,11 +204,11 @@   collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =     collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body   collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =-    (args : allArgs, body, \b -> f (JSFunction ident (map copyVar args) b))+    (args : allArgs, body, f . JSFunction ident (map copyVar args))   collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =     collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body   collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =-    (args : allArgs, body, \b -> f (JSReturn (JSFunction ident (map copyVar args) b)))+    (args : allArgs, body, f . JSReturn . JSFunction ident (map copyVar args))   collectAllFunctionArgs allArgs f body = (allArgs, body, f)   isTailCall :: String -> JS -> Bool   isTailCall ident js =@@ -312,19 +310,19 @@   isRetPoly (JSIndexer (JSStringLiteral "return") (JSAccessor "Prelude" (JSVar "_ps"))) = True   isRetPoly _ = False   -- Check if an expression represents a function in the Ef module-  isEffFunc name (JSAccessor name' (JSAccessor "Eff" (JSVar "_ps"))) | name == name' = True+  isEffFunc name (JSAccessor name' (JSAccessor "Control_Monad_Eff" (JSVar "_ps"))) | name == name' = True   isEffFunc _ _ = False   -- Module names   prelude = ModuleName [ProperName "Prelude"]-  effModule = ModuleName [ProperName "Eff"]+  effModule = ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"]   -- The name of the type class dictionary for the Monad Eff instance   Right (Ident effDictName) = mkDictionaryValueName     effModule     (Qualified (Just prelude) (ProperName "Monad"))-    (TypeConstructor (Qualified (Just effModule) (ProperName "Eff")))+    [TypeConstructor (Qualified (Just effModule) (ProperName "Eff"))]   -- Check if an expression represents the Monad Eff dictionary   isEffDict (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == effDictName = True-  isEffDict (JSApp (JSAccessor prop (JSAccessor "Eff" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == effDictName = True+  isEffDict (JSApp (JSAccessor prop (JSAccessor "Control_Monad_Eff" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == effDictName = True   isEffDict _ = False   -- Remove __do function applications which remain after desugaring   undo :: JS -> JS@@ -345,7 +343,7 @@         usages = findAllSTUsagesIn arg         allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages         localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs-    in everywhere (mkT $ convert allUsagesAreLocalVars) arg+    in everywhere (mkT $ convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg   convertBlock other = other   -- Convert a block in a safe way, preserving object wrappers of references,   -- or in a more aggressive way, turning wrappers into local variables depending on the@@ -359,17 +357,17 @@   convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc "modifySTRef" f =     if agg then JSAssignment ref (JSApp func [ref]) else  JSAssignment (JSAccessor "value" ref) (JSApp func [JSAccessor "value" ref])   convert _ (JSApp (JSApp (JSApp f [arr]) [i]) []) | isSTFunc "peekSTArray" f =-    (JSIndexer i arr)+    JSIndexer i arr   convert _ (JSApp (JSApp (JSApp (JSApp f [arr]) [i]) [val]) []) | isSTFunc "pokeSTArray" f =     JSAssignment (JSIndexer i arr) val   convert _ other = other   -- Check if an expression represents a function in the ST module-  isSTFunc name (JSAccessor name' (JSAccessor "ST" (JSVar "_ps"))) | name == name' = True+  isSTFunc name (JSAccessor name' (JSAccessor "Control_Monad_ST" (JSVar "_ps"))) | name == name' = True   isSTFunc _ _ = False   -- Find all ST Refs initialized in this block   findSTRefsIn = everything (++) (mkQ [] isSTRef)     where-    isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [arg]) []))) | isSTFunc "newSTRef" f = [ident]+    isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [_]) []))) | isSTFunc "newSTRef" f = [ident]     isSTRef _ = []   -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef   findAllSTUsagesIn = everything (++) (mkQ [] isSTUsage)@@ -400,7 +398,7 @@ inlineOperator op f = everywhere (mkT convert)   where   convert :: JS -> JS-  convert (JSApp (JSApp op [x]) [y]) | isOp op = f x y+  convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y   convert other = other   isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar "_ps"))) | longForm == identToJs (Op op) = True   isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | op == op' = True@@ -446,7 +444,7 @@     convert :: JS -> JS     convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict className classTy dict = JSBinary op x y     convert other = other-    isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar ps))) | longForm == identToJs (Op opString) = True+    isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar _))) | longForm == identToJs (Op opString) = True     isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | opString == op' = True     isOp _ = False   binaryFunction :: String -> String -> Type -> BinaryOperator -> JS -> JS@@ -470,5 +468,5 @@     Right (Ident dictName) = mkDictionaryValueName       (ModuleName [ProperName "Prim"])       (Qualified (Just (ModuleName [ProperName "Prelude"])) (ProperName className))-      ty+      [ty]   isOpDict _ _ _ = False

@@ -35,19 +35,19 @@   let declarations = concatMap (declarationsByModule env) ms       (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations       entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations-  in flip map ms $ \(Module moduleName ds) -> Module moduleName (filter (isUsed (moduleName) graph vertexFor entryPointVertices) ds)+  in flip map ms $ \(Module moduleName ds) -> Module moduleName (filter (isUsed moduleName graph vertexFor entryPointVertices) ds)  type Key = (ModuleName, Either Ident ProperName)  declarationsByModule :: Environment -> Module -> [(Key, [Key])]-declarationsByModule env (Module moduleName ds) = concatMap go $ ds+declarationsByModule env (Module moduleName ds) = concatMap go ds   where   go :: Declaration -> [(Key, [Key])]-  go d@(ValueDeclaration name _ _ _) = [((moduleName, Left name), dependencies env (moduleName) d)]+  go d@(ValueDeclaration name _ _ _) = [((moduleName, Left name), dependencies env moduleName d)]   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 env moduleName d)) names-  go (DataBindingGroupDeclaration ds) = concatMap go ds+  go d@(BindingGroupDeclaration names') = map (\(name, _) -> ((moduleName, Left name), dependencies env moduleName d)) names'+  go (DataBindingGroupDeclaration ds') = concatMap go ds'   go _ = []  dependencies :: (Data d) => Environment -> ModuleName -> d -> [Key]

@@ -112,60 +112,60 @@   -- |   -- A type class declaration (name, argument, member declarations)   ---  | TypeClassDeclaration ProperName String [Declaration]+  | TypeClassDeclaration ProperName [String] [Declaration]   -- |   -- A type instance declaration (dependencies, class name, instance type, member declarations)   ---  | TypeInstanceDeclaration [(Qualified ProperName, Type)] (Qualified ProperName) Type [Declaration]+  | TypeInstanceDeclaration [(Qualified ProperName, [Type])] (Qualified ProperName) [Type] [Declaration]   deriving (Show, D.Data, D.Typeable)  -- | -- Test if a declaration is a value declaration -- isValueDecl :: Declaration -> Bool-isValueDecl (ValueDeclaration _ _ _ _) = True+isValueDecl ValueDeclaration{} = True isValueDecl _ = False  -- | -- Test if a declaration is a data type or type synonym declaration -- isDataDecl :: Declaration -> Bool-isDataDecl (DataDeclaration _ _ _) = True-isDataDecl (TypeSynonymDeclaration _ _ _) = True+isDataDecl DataDeclaration{} = True+isDataDecl TypeSynonymDeclaration{} = True isDataDecl _ = False  -- | -- Test if a declaration is a module import -- isImportDecl :: Declaration -> Bool-isImportDecl (ImportDeclaration _ _) = True+isImportDecl ImportDeclaration{} = True isImportDecl _ = False  -- | -- Test if a declaration is a data type foreign import -- isExternDataDecl :: Declaration -> Bool-isExternDataDecl (ExternDataDeclaration _ _) = True+isExternDataDecl ExternDataDeclaration{} = True isExternDataDecl _ = False  -- | -- Test if a declaration is a fixity declaration -- isFixityDecl :: Declaration -> Bool-isFixityDecl (FixityDeclaration _ _) = True+isFixityDecl FixityDeclaration{} = True isFixityDecl _ = False  -- | -- Test if a declaration is a foreign import -- isExternDecl :: Declaration -> Bool-isExternDecl (ExternDeclaration _ _ _ _) = True+isExternDecl ExternDeclaration{} = True isExternDecl _ = False  -- | -- Test if a declaration is a type class or instance declaration -- isTypeClassDeclaration :: Declaration -> Bool-isTypeClassDeclaration (TypeClassDeclaration _ _ _) = True-isTypeClassDeclaration (TypeInstanceDeclaration _ _ _ _) = True+isTypeClassDeclaration TypeClassDeclaration{} = True+isTypeClassDeclaration TypeInstanceDeclaration{} = True isTypeClassDeclaration _ = False

@@ -19,13 +19,10 @@ import Data.Data import Data.Graph import Data.Generics-import Data.List (nub, intersect)-import Control.Applicative ((<$>))+import Data.List (nub)  import Language.PureScript.Declarations import Language.PureScript.Names-import Language.PureScript.Values-import Language.PureScript.Types  -- | -- Sort a collection of modules based on module dependencies.

@@ -70,6 +70,14 @@ runModuleName :: ModuleName -> String runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns) +moduleNameFromString :: String -> ModuleName+moduleNameFromString = ModuleName . splitProperNames+  where+  splitProperNames s = case dropWhile (== '.') s of+    "" -> []+    s' -> ProperName w : splitProperNames s''+      where (w, s'') = break (== '.') s'+ instance Show ModuleName where   show = runModuleName 

@@ -33,7 +33,7 @@   , optionsMagicDo :: Bool     -- |     -- When specified, checks the type of `main` in the module, and generate a call to run main-    -- after the module definitions. +    -- after the module definitions.     --   , optionsMain :: Maybe String     -- |

@@ -48,8 +48,8 @@                   , "let"                   , "true"                   , "false"-                  , "until"                   , "in"+                  , "where"                   ]  -- |@@ -328,7 +328,7 @@ -- Parse an identifier in backticks or an operator -- parseIdentInfix :: P.Parsec String ParseState (Qualified Ident)-parseIdentInfix = (P.between tick tick (parseQualified (Ident <$> identifier))) <|> Qualified Nothing <$> (Op <$> operator)+parseIdentInfix = P.between tick tick (parseQualified (Ident <$> identifier)) <|> Qualified Nothing <$> (Op <$> operator)  -- | -- Mark the current indentation level

@@ -20,11 +20,9 @@ ) where  import Data.Maybe (isJust, fromMaybe)-import Control.Monad (when) import Control.Applicative import qualified Text.Parsec as P -import Language.PureScript.Names import Language.PureScript.Parser.State import Language.PureScript.Parser.Common import Language.PureScript.Declarations@@ -32,7 +30,6 @@ import Language.PureScript.Parser.Types import Language.PureScript.Parser.Kinds import Language.PureScript.CodeGen.JS.AST-import Language.PureScript.Values  parseDataDeclaration :: P.Parsec String ParseState Declaration parseDataDeclaration = do@@ -59,15 +56,15 @@   ValueDeclaration <$> parseIdent                    <*> P.many parseBinderNoParens                    <*> P.optionMaybe parseGuard-                   <*> ((lexeme (indented *> P.char '=')) *> parseValue)+                   <*> (lexeme (indented *> P.char '=') *> parseValue)  parseExternDeclaration :: P.Parsec String ParseState Declaration-parseExternDeclaration = P.try (reserved "foreign") *> indented *> (reserved "import") *> indented *>+parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "import" *> indented *>    (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)                              <*> (lexeme (indented *> P.string "::") *> parseKind)    <|> do ident <- parseIdent           js <- P.optionMaybe (JSRaw <$> stringLiteral)-          ty <- (lexeme (indented *> P.string "::") *> parsePolyType)+          ty <- lexeme (indented *> P.string "::") *> parsePolyType           return $ ExternDeclaration (if isJust js then InlineJavascript else ForeignImport) ident js ty)  parseAssociativity :: P.Parsec String ParseState Associativity@@ -89,29 +86,29 @@ parseImportDeclaration = do   reserved "import"   indented-  moduleName <- moduleName+  moduleName' <- moduleName   idents <- P.optionMaybe $ parens $ commaSep1 (Left <$> parseIdent <|> Right <$> properName)-  return $ ImportDeclaration moduleName idents+  return $ ImportDeclaration moduleName' idents  parseTypeClassDeclaration :: P.Parsec String ParseState Declaration parseTypeClassDeclaration = do   reserved "class"   className <- indented *> properName-  ident <- indented *> identifier+  idents <- indented *> P.many identifier   indented *> reserved "where"   members <- mark (P.many (same *> parseTypeDeclaration))-  return $ TypeClassDeclaration className ident members+  return $ TypeClassDeclaration className idents members  parseTypeInstanceDeclaration :: P.Parsec String ParseState Declaration parseTypeInstanceDeclaration = do   reserved "instance"   deps <- P.optionMaybe $ do-    deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> parseType))+    deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom))     indented     reservedOp "=>"     return deps   className <- indented *> parseQualified properName-  ty <- indented *> parseType+  ty <- indented *> P.many parseTypeAtom   indented *> reserved "where"   members <- mark (P.many (same *> parseValueDeclaration))   return $ TypeInstanceDeclaration (fromMaybe [] deps) className ty members

@@ -51,15 +51,15 @@ parseTypeVariable :: P.Parsec String ParseState Type parseTypeVariable = do   ident <- identifier-  when (ident `elem` reservedTypeNames) $ P.unexpected $ ident+  when (ident `elem` reservedTypeNames) $ P.unexpected ident   return $ TypeVar ident  parseTypeConstructor :: P.Parsec String ParseState Type parseTypeConstructor = TypeConstructor <$> parseQualified properName  parseForAll :: P.Parsec String ParseState Type-parseForAll = (mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot)-                        <*> parseConstrainedType)+parseForAll = mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot)+                       <*> parseConstrainedType  -- | -- Parse a type as it appears in e.g. a data constructor@@ -85,7 +85,7 @@     constraints <- parens . commaSep1 $ do       className <- parseQualified properName       indented-      ty <- parseType+      ty <- P.many parseTypeAtom       return (className, ty)     _ <- lexeme $ P.string "=>"     return constraints@@ -94,7 +94,7 @@   return $ maybe ty (flip ConstrainedType ty) constraints  parseAnyType :: P.Parsec String ParseState Type-parseAnyType = (P.buildExpressionParser operators $ parseTypeAtom) P.<?> "type"+parseAnyType = P.buildExpressionParser operators parseTypeAtom P.<?> "type"   where   operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]               , [ P.Infix (P.try (lexeme (P.string "->")) >> return function) P.AssocRight ] ]@@ -112,9 +112,7 @@ -- Parse a polytype -- parsePolyType :: P.Parsec String ParseState Type-parsePolyType = do-  ty <- parseAnyType-  return ty+parsePolyType = parseAnyType  parseNameAndType :: P.Parsec String ParseState t -> P.Parsec String ParseState (String, t) parseNameAndType p = (,) <$> (indented *> identifier <* indented <* lexeme (P.string "::")) <*> p@@ -123,5 +121,5 @@ parseRowEnding = P.option REmpty (TypeVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier))  parseRow :: Bool -> P.Parsec String ParseState Type-parseRow nonEmpty = (curry rowFromList <$> (many $ parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row"-  where many = if nonEmpty then commaSep1 else commaSep+parseRow nonEmpty = (curry rowFromList <$> many' (parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row"+  where many' = if nonEmpty then commaSep1 else commaSep

@@ -20,13 +20,16 @@     parseBinderNoParens, ) where +import Control.Applicative+ import Language.PureScript.Values import Language.PureScript.Parser.State+import Language.PureScript.Parser.Types++import Text.Parsec.Expr+ import qualified Language.PureScript.Parser.Common as C-import Control.Applicative import qualified Text.Parsec as P-import Text.Parsec.Expr-import Language.PureScript.Parser.Types  booleanLiteral :: P.Parsec String ParseState Bool booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)@@ -59,7 +62,7 @@   return $ toFunction args value   where   toFunction :: [Value -> Value] -> Value -> Value-  toFunction args value = foldr (($)) value args+  toFunction args value = foldr ($) value args  parseVar :: P.Parsec String ParseState Value parseVar = Var <$> C.parseQualified C.parseIdent@@ -154,7 +157,7 @@   indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom   postfixTable1 = [ parseAccessor                   , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> C.braces (C.commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]-  postfixTable2 = [ \v -> P.try (C.indented *> indexersAndAccessors >>= return . flip App) <*> pure v+  postfixTable2 = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v                   , \v -> flip (TypedValue True) <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v                   ]   operators = [ [ Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->@@ -177,13 +180,13 @@ parseNullaryConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> pure []  parseConstructorBinder :: P.Parsec String ParseState Binder-parseConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> (many (C.indented *> parseBinderNoParens))+parseConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> many (C.indented *> parseBinderNoParens)  parseObjectBinder :: P.Parsec String ParseState Binder parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep (C.indented *> parseIdentifierAndBinder))  parseArrayBinder :: P.Parsec String ParseState Binder-parseArrayBinder = C.squares $ ArrayBinder <$> (C.commaSep (C.indented *> parseBinder))+parseArrayBinder = C.squares $ ArrayBinder <$> C.commaSep (C.indented *> parseBinder)  parseNamedBinder :: P.Parsec String ParseState Binder parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* C.lexeme (P.char '@'))@@ -203,7 +206,7 @@ -- Parse a binder -- parseBinder :: P.Parsec String ParseState Binder-parseBinder = (buildExpressionParser operators parseBinderAtom) P.<?> "expression"+parseBinder = buildExpressionParser operators parseBinderAtom P.<?> "expression"   where   operators = [ [ Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) AssocRight ] ]   parseBinderAtom :: P.Parsec String ParseState Binder

@@ -17,8 +17,6 @@     prettyPrintJS ) where -import Language.PureScript.Names-import Language.PureScript.Values import Language.PureScript.Pretty.Common import Language.PureScript.CodeGen.JS.AST @@ -69,7 +67,7 @@     , fmap (intercalate ", ") $ forM xs prettyPrintJS'     , return " ]"     ]-  match (JSObjectLiteral []) = return "{}" +  match (JSObjectLiteral []) = return "{}"   match (JSObjectLiteral ps) = fmap concat $ sequence     [ return "{\n"     , withIndent $ do@@ -82,10 +80,7 @@     ]   match (JSBlock sts) = fmap concat $ sequence     [ return "{\n"-    , withIndent $ do-        jss <- forM sts prettyPrintJS'-        indentString <- currentIndent-        return $ intercalate "\n" $ map (++ ";") $ map (indentString ++) jss+    , withIndent $ prettyStatements sts     , return "\n"     , currentIndent     , return "}"@@ -195,6 +190,12 @@     match' (JSBinary op' v1 v2) | op' == op = Just (v1, v2)     match' _ = Nothing +prettyStatements :: [JS] -> StateT PrinterState Maybe String+prettyStatements sts = do+  jss <- forM sts prettyPrintJS'+  indentString <- currentIndent+  return $ intercalate "\n" $ map ((++ ";") . (indentString ++)) jss+ -- | -- Generate a pretty-printed string representing a Javascript expression --@@ -205,10 +206,7 @@ -- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level -- prettyPrintJS :: [JS] -> String-prettyPrintJS sts = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) $ do-  jss <- forM sts prettyPrintJS'-  indentString <- currentIndent-  return $ intercalate "\n" $ map (++ ";") $ map (indentString ++) jss+prettyPrintJS = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements  -- | -- Generate an indented, pretty-printed string representing a Javascript expression@@ -224,8 +222,8 @@                   , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]                   , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]                   , [ Wrap lam $ \(name, args) ret -> "function "-                        ++ maybe "" id name-                        ++ "(" ++ (intercalate ", " args) ++ ") "+                        ++ fromMaybe "" name+                        ++ "(" ++ intercalate ", " args ++ ") "                         ++ ret ]                   , [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS1 th ++ " : " ++ prettyPrintJS1 el ]                   , [ binary    LessThan             "<" ]

@@ -35,14 +35,14 @@   match (Object row) = Just $ "{ " ++ prettyPrintRow row ++ " }"   match (TypeVar var) = Just var   match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"-  match ty@(TypeConstructor ctor) = Just $ show ctor+  match (TypeConstructor ctor) = Just $ show ctor   match (TUnknown (Unknown u)) = Just $ 'u' : show u   match (Skolem s _) = Just $ 's' : show s-  match (ConstrainedType deps ty) = Just $ "(" ++ intercalate "," (map (\(pn, ty') -> show pn ++ " (" ++ prettyPrintType ty' ++ ")") deps) ++ ") => " ++ prettyPrintType ty+  match (ConstrainedType deps ty) = Just $ "(" ++ intercalate "," (map (\(pn, ty') -> show pn ++ " (" ++ unwords (map prettyPrintType ty') ++ ")") deps) ++ ") => " ++ prettyPrintType ty   match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">"   match (ForAll ident ty _) = Just $ "forall " ++ ident ++ ". " ++ prettyPrintType ty   match REmpty = Just "()"-  match row@(RCons _ _ _) = Just $ '(' : prettyPrintRow row ++ ")"+  match row@RCons{} = Just $ '(' : prettyPrintRow row ++ ")"   match _ = Nothing  -- |

@@ -38,7 +38,7 @@   match (ArrayLiteral xs) = Just $ "[" ++ intercalate ", " (map prettyPrintValue xs) ++ "]"   match (ObjectLiteral ps) = Just $ "{" ++ intercalate ", " (map (uncurry prettyPrintObjectProperty) ps) ++ "}"   match (Constructor name) = Just $ show name-  match (Case values binders) = Just $ "case " ++ intercalate " " (map prettyPrintValue values) +++  match (Case values binders) = Just $ "case " ++ unwords (map prettyPrintValue values) ++     " of { " ++ intercalate " ; " (map prettyPrintCaseAlternative binders) ++ " }"   match (Var ident) = Just $ show ident   match (Do els) = Just $ " do { " ++ intercalate "; " (map prettyPrintDoNotationElement els) ++ " }"@@ -47,7 +47,7 @@  prettyPrintCaseAlternative :: ([Binder], Maybe Guard, Value) -> String prettyPrintCaseAlternative (binders, grd, val) = "(" ++ intercalate ", " (map prettyPrintBinder binders) ++ ") " ++-  (maybe "" (("| " ++) . prettyPrintValue) grd) ++ " -> " ++ prettyPrintValue val+  maybe "" (("| " ++) . prettyPrintValue) grd ++ " -> " ++ prettyPrintValue val  ifThenElse :: Pattern () Value ((Value, Value), Value) ifThenElse = mkPattern match@@ -118,7 +118,7 @@   match (BooleanBinder True) = Just "true"   match (BooleanBinder False) = Just "false"   match (VarBinder ident) = Just $ show ident-  match (ConstructorBinder ctor args) = Just $ show ctor ++ " " ++ intercalate " " (map (parens . prettyPrintBinder) args)+  match (ConstructorBinder ctor args) = Just $ show ctor ++ " " ++ unwords (map (parens . prettyPrintBinder) args)   match (ObjectBinder bs) = Just $ "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"   match (ArrayBinder bs) = Just $ "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ " ]"   match (NamedBinder ident binder) = Just $ show ident ++ "@" ++ prettyPrintBinder binder

@@ -18,6 +18,8 @@     unusedNames ) where +import Control.Applicative ((<$>))+ import Data.Data import Data.List ((\\), nub) import Data.Generics (extQ, mkQ, everything)@@ -41,8 +43,8 @@   namesB _ = []   namesJS :: JS -> [Ident]   namesJS (JSVar name) = [Ident name]-  namesJS (JSFunction (Just name) args _) = (Ident name) : (Ident `map` args)-  namesJS (JSFunction Nothing args _) = (Ident `map` args)+  namesJS (JSFunction (Just name) args _) = Ident name : (Ident <$> args)+  namesJS (JSFunction Nothing args _) = Ident <$> args   namesJS (JSVariableIntroduction name _) = [Ident name]   namesJS (JSFor name _ _ _) = [Ident name]   namesJS _ = []

@@ -69,7 +69,7 @@ -- Collapse all binding groups to individual declarations -- collapseBindingGroups :: [Declaration] -> [Declaration]-collapseBindingGroups ds = concatMap go ds+collapseBindingGroups = concatMap go   where   go (DataBindingGroupDeclaration ds) = ds   go (BindingGroupDeclaration ds) = map (\(ident, val) -> ValueDeclaration ident [] Nothing val) ds@@ -112,10 +112,10 @@   | all isTypeSynonym ds' = Left "Cycle in type synonyms"   | otherwise = return $ DataBindingGroupDeclaration ds'   where-  isTypeSynonym (TypeSynonymDeclaration _ _ _) = True+  isTypeSynonym TypeSynonymDeclaration{} = True   isTypeSynonym _ = False  fromValueDecl :: Declaration -> (Ident, Value) fromValueDecl (ValueDeclaration ident [] Nothing val) = (ident, val)-fromValueDecl (ValueDeclaration _ _ _ _) = error "Binders should have been desugared"+fromValueDecl ValueDeclaration{} = error "Binders should have been desugared" fromValueDecl _ = error "Expected ValueDeclaration"

@@ -75,7 +75,7 @@   let     argPattern = length . fst . head $ alternatives     args = take argPattern $ unusedNames (ident, alternatives)-    vars = map (\arg -> Var (Qualified Nothing arg)) args+    vars = map (Var . Qualified Nothing) args     binders = [ (bs, g, val) | (bs, (g, val)) <- alternatives ]     value = foldr (\arg ret -> Abs (Left arg) ret) (Case vars binders) args   in

@@ -27,13 +27,17 @@ import Language.PureScript.Declarations import Language.PureScript.Values +import Control.Applicative+import Control.Arrow (first)+import Control.Monad.State+ import Data.Function (on) import Data.List (groupBy, sortBy)+ import qualified Data.Map as M import qualified Data.Generics as G import qualified Data.Generics.Extras as G-import Control.Monad.State-import Control.Applicative+ import qualified Text.Parsec as P import qualified Text.Parsec.Pos as P import qualified Text.Parsec.Expr as P@@ -62,9 +66,9 @@     -- The fixity map can therefore map from module name/ident pairs to fixities, where the module name is the name     -- of the module imported into, not from. This is useful in matchOp, but here we have to discard the module name to     -- make sure that the generated code is correct.-    applyUserOp (Qualified _ name) t1 t2 = App (App (Var (Qualified Nothing name)) t1) t2+    applyUserOp (Qualified _ name) t1 = App (App (Var (Qualified Nothing name)) t1)     userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) . M.toList $ fixities-    sorted = reverse $ sortBy (compare `on` (\(_, _, p, _) -> p)) userOps+    sorted = sortBy (flip compare `on` (\(_, _, p, _) -> p)) userOps     groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted   in     map (map (\(name, f, _, a) -> (name, f, a))) groups@@ -72,10 +76,10 @@ type Chain = [Either Value (Qualified Ident)]  matchOperators :: ModuleName -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value-matchOperators moduleName ops val = G.everywhereM' (G.mkM parseChains) val+matchOperators moduleName ops = G.everywhereM' (G.mkM parseChains)   where   parseChains :: Value -> Either String Value-  parseChains b@(BinaryNoParens _ _ _) = bracketChain (extendChain b)+  parseChains b@BinaryNoParens{} = bracketChain (extendChain b)   parseChains other = return other   extendChain :: Value -> Chain   extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r@@ -108,7 +112,7 @@   collectFixities (M.insert qual fixity m) moduleName rest collectFixities m moduleName (ImportDeclaration importedModule _ : rest) = do   let fs = [ (i, fixity) | (Qualified mn i, fixity) <- M.toList m, mn == Just importedModule ]-  let m' = M.fromList (map (\(i, fixity) -> (Qualified (Just moduleName) i, fixity)) fs)-  collectFixities (M.union m' m) moduleName rest+  let m' = M.fromList (map (first (Qualified (Just moduleName))) fs)+  collectFixities (m' `M.union` m) moduleName rest collectFixities m moduleName (_:ds) = collectFixities m moduleName ds 

@@ -31,14 +31,12 @@  import Control.Applicative import Control.Monad.State-import Control.Arrow ((***))+import Control.Arrow (second) -import Data.Maybe (fromMaybe)-import Data.List (nub)-import Data.Generics (mkQ, everything)+import Data.List (intercalate) import Language.PureScript.CodeGen.Common (identToJs, moduleNameToJs) -type MemberMap = M.Map (ModuleName, ProperName) (String, [(String, Type)])+type MemberMap = M.Map (ModuleName, ProperName) ([String], [(String, Type)])  type Desugar = StateT MemberMap (Either String) @@ -91,10 +89,10 @@ --   __Test_Foo_array _1 = { foo: __Test_Foo_array_foo _1 :: [a] -> [a] (unchecked) } -- desugarDecl :: ModuleName -> Declaration -> Desugar [Declaration]-desugarDecl mn d@(TypeClassDeclaration name arg members) = do+desugarDecl mn d@(TypeClassDeclaration name args members) = do   let tys = map memberToNameAndType members-  modify (M.insert (mn, name) (arg, tys))-  return $ d : typeClassDictionaryDeclaration name arg members : map (typeClassMemberToDictionaryAccessor name arg) members+  modify (M.insert (mn, name) (args, tys))+  return $ d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor name args) members desugarDecl mn d@(TypeInstanceDeclaration deps name ty members) = do   desugared <- lift $ desugarCases members   entries <- mapM (typeInstanceDictionaryEntryDeclaration mn deps name ty) desugared@@ -106,50 +104,50 @@ memberToNameAndType (TypeDeclaration ident ty) = (identToJs ident, ty) memberToNameAndType _ = error "Invalid declaration in type class definition" -typeClassDictionaryDeclaration :: ProperName -> String -> [Declaration] -> Declaration-typeClassDictionaryDeclaration name arg members =-  TypeSynonymDeclaration name [arg] (Object $ rowFromList (map memberToNameAndType members, REmpty))+typeClassDictionaryDeclaration :: ProperName -> [String] -> [Declaration] -> Declaration+typeClassDictionaryDeclaration name args members =+  TypeSynonymDeclaration name args (Object $ rowFromList (map memberToNameAndType members, REmpty)) -typeClassMemberToDictionaryAccessor :: ProperName -> String -> Declaration -> Declaration-typeClassMemberToDictionaryAccessor name arg (TypeDeclaration ident ty) =+typeClassMemberToDictionaryAccessor :: ProperName -> [String] -> Declaration -> Declaration+typeClassMemberToDictionaryAccessor name args (TypeDeclaration ident ty) =   ExternDeclaration TypeClassAccessorImport ident     (Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSAccessor (identToJs ident) (JSVar "dict"))])))-    (ForAll arg (ConstrainedType [(Qualified Nothing name, TypeVar arg)] ty) Nothing)+    (quantify (ConstrainedType [(Qualified Nothing name, map TypeVar args)] ty)) typeClassMemberToDictionaryAccessor _ _ _ = error "Invalid declaration in type class definition" -typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> [Declaration] -> Desugar Declaration-typeInstanceDictionaryDeclaration mn deps name ty decls = do+typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration+typeInstanceDictionaryDeclaration mn deps name tys decls = do   m <- get-  (arg, instanceTys) <- lift $ maybe (Left $ "Type class " ++ show name ++ " is undefined. Type class names must be qualified.") Right+  (args, instanceTys) <- lift $ maybe (Left $ "Type class " ++ show name ++ " is undefined. Type class names must be qualified.") Right                         $ M.lookup (qualify mn name) m-  let memberTypes = map (id *** replaceTypeVars arg ty) instanceTys-  entryName <- lift $ mkDictionaryValueName mn name ty+  let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys+  entryName <- lift $ mkDictionaryValueName mn name tys   memberNames <- mapM (memberToNameAndValue memberTypes) decls   return $ ValueDeclaration entryName [] Nothing     (TypedValue True-      (foldr Abs (ObjectLiteral memberNames) (map (\n -> Left . Ident $ '_' : show n) [1..max 1 (length deps)]))+      (foldr (Abs . (\n -> Left . Ident $ '_' : show n)) (ObjectLiteral memberNames) [1..max 1 (length deps)])       (quantify (if null deps then-                   function unit (TypeApp (TypeConstructor name) ty)+                   function unit (foldl TypeApp (TypeConstructor name) tys)                  else-                   foldr function (TypeApp (TypeConstructor name) ty) (map (\(pn, ty') -> TypeApp (TypeConstructor pn) ty') deps)))+                   foldr (function . (\(pn, tys') -> foldl TypeApp (TypeConstructor pn) tys')) (foldl TypeApp (TypeConstructor name) tys) deps))     )   where   memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value)-  memberToNameAndValue tys (ValueDeclaration ident _ _ _) = do-    memberType <- lift . maybe (Left "Type class member type not found") Right $ lookup (identToJs ident) tys-    memberName <- mkDictionaryEntryName mn name ty ident+  memberToNameAndValue tys' (ValueDeclaration ident _ _ _) = do+    memberType <- lift . maybe (Left "Type class member type not found") Right $ lookup (identToJs ident) tys'+    memberName <- mkDictionaryEntryName mn name tys ident     return (identToJs ident, TypedValue False                                (foldl App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))                                (quantify memberType))   memberToNameAndValue _ _ = error "Invalid declaration in type instance definition" -typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> Declaration -> Desugar Declaration-typeInstanceDictionaryEntryDeclaration mn deps name ty (ValueDeclaration ident [] _ val) = do+typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> Declaration -> Desugar Declaration+typeInstanceDictionaryEntryDeclaration mn deps name tys (ValueDeclaration ident [] _ val) = do   m <- get-  valTy <- lift $ do (arg, members) <- lookupTypeClass m+  valTy <- lift $ do (args, members) <- lookupTypeClass m                      ty' <- lookupIdent members-                     return $ replaceTypeVars arg ty ty'-  entryName <- mkDictionaryEntryName mn name ty ident+                     return $ replaceAllTypeVars (zip args tys) ty'+  entryName <- mkDictionaryEntryName mn name tys ident   return $ ValueDeclaration entryName [] Nothing     (TypedValue True val (quantify (if null deps then valTy else ConstrainedType deps valTy)))   where@@ -164,10 +162,10 @@ -- | -- Generate a name for a type class dictionary, based on the module name, class name and type name ---mkDictionaryValueName :: ModuleName -> Qualified ProperName -> Type -> Either String Ident-mkDictionaryValueName mn cl ty = do-  tyStr <- typeToString mn ty-  return $ Ident $ "__" ++ qualifiedToString mn cl ++ "_" ++ tyStr+mkDictionaryValueName :: ModuleName -> Qualified ProperName -> [Type] -> Either String Ident+mkDictionaryValueName mn cl tys = do+  tyStr <- mapM (typeToString mn) tys+  return $ Ident $ "__" ++ qualifiedToString mn cl ++ "_" ++ intercalate "_" tyStr  typeToString :: ModuleName -> Type -> Either String String typeToString _ (TypeVar _) = return "var"@@ -179,7 +177,7 @@ -- Generate a name for a type class dictionary member, based on the module name, class name, type name and -- member name ---mkDictionaryEntryName :: ModuleName -> Qualified ProperName -> Type -> Ident -> Desugar Ident-mkDictionaryEntryName mn name ty ident = do-  Ident dictName <- lift $ mkDictionaryValueName mn name ty+mkDictionaryEntryName :: ModuleName -> Qualified ProperName -> [Type] -> Ident -> Desugar Ident+mkDictionaryEntryName mn name tys ident = do+  Ident dictName <- lift $ mkDictionaryValueName mn name tys   return $ Escaped $ dictName ++ "_" ++ identToJs ident

@@ -86,7 +86,7 @@   putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Value) (names env) })  addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()-addTypeClassDictionaries entries = do+addTypeClassDictionaries entries =   modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } }  checkTypeClassInstance :: ModuleName -> Type -> Check ()@@ -154,7 +154,7 @@     return $ ValueDeclaration name [] Nothing val'   ds <- typeCheckAll mainModuleName moduleName rest   return $ d : ds-typeCheckAll _ _ (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"+typeCheckAll _ _ (ValueDeclaration{} : _) = error "Binders were not desugared" typeCheckAll mainModuleName moduleName (BindingGroupDeclaration vals : rest) = do   d <- rethrow (("Error in binding group " ++ show (map fst vals) ++ ":\n") ++) $ do     forM_ (map fst vals) $ \name ->@@ -206,7 +206,7 @@   filterModule = filter ((== moduleName) . fst) . M.keys   moduleExists env = not (null (filterModule (names env))) || not (null (filterModule (types env)))   shadowIdents idents' env =-    forM_ idents' $ \ident -> do+    forM_ idents' $ \ident ->       case (moduleName, ident) `M.lookup` names env of         Just (_, Alias _ _) -> return ()         Just (pt, _) -> do@@ -214,7 +214,7 @@           modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias moduleName ident) (names e) })         Nothing -> throwError (show moduleName ++ "." ++ show ident ++ " is undefined")   shadowTypes pns env =-    forM_ pns $ \pn -> do+    forM_ pns $ \pn ->       case (moduleName, pn) `M.lookup` types env of         Nothing -> throwError (show moduleName ++ "." ++ show pn ++ " is undefined")         Just (_, DataAlias _ _) -> return ()@@ -222,7 +222,7 @@           guardWith (show currentModule ++ "." ++ show pn ++ " is already defined") $ (currentModule, pn) `M.notMember` types env           modifyEnv (\e -> e { types = M.insert (currentModule, pn) (k, DataAlias moduleName pn) (types e) })           let keys = map (snd . fst) . filter (\(_, (fn, _)) -> fn `constructs` pn) . M.toList . dataConstructors $ env-          forM_ keys $ \dctor -> do+          forM_ keys $ \dctor ->             case (moduleName, dctor) `M.lookup` dataConstructors env of               Just (_, Alias _ _) -> return ()               Just (ctorTy, _) -> do@@ -236,23 +236,23 @@                     ) (typeClassDictionaries env)     forM_ instances $ \tcd -> do       let (Qualified _ ident) = tcdName tcd-      addTypeClassDictionaries [tcd { tcdName = (Qualified (Just currentModule) ident), tcdType = TCDAlias (tcdName tcd) }]+      addTypeClassDictionaries [tcd { tcdName = Qualified (Just currentModule) ident, tcdType = TCDAlias (tcdName tcd) }]   constructs (TypeConstructor (Qualified (Just mn) pn')) pn     = mn == moduleName && pn' == pn   constructs (ForAll _ ty _) pn = ty `constructs` pn   constructs (TypeApp (TypeApp t _) ty) pn | t == tyFunction = ty `constructs` pn   constructs (TypeApp ty _) pn = ty `constructs` pn   constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn-typeCheckAll mainModuleName moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do+typeCheckAll mainModuleName moduleName (d@TypeClassDeclaration{} : rest) = do   env <- getEnv   ds <- typeCheckAll mainModuleName moduleName rest   return $ qualifyAllUnqualifiedNames moduleName env d : ds-typeCheckAll mainModuleName moduleName (d@(TypeInstanceDeclaration deps className ty _) : rest) = do+typeCheckAll mainModuleName moduleName (d@(TypeInstanceDeclaration deps className tys _) : rest) = do   env <- getEnv-  dictName <- Check . lift $ mkDictionaryValueName moduleName className ty-  checkTypeClassInstance moduleName ty-  forM_ deps $ checkTypeClassInstance moduleName . snd+  dictName <- Check . lift $ mkDictionaryValueName moduleName className tys+  mapM_ (checkTypeClassInstance moduleName) tys+  forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd   addTypeClassDictionaries (qualifyAllUnqualifiedNames moduleName env-    [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className ty (Just deps) TCDRegular])+    [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular])   ds <- typeCheckAll mainModuleName moduleName rest   return $ qualifyAllUnqualifiedNames moduleName env d : ds

@@ -14,7 +14,6 @@ -----------------------------------------------------------------------------  {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-}  module Language.PureScript.TypeChecker.Kinds (@@ -31,7 +30,6 @@  import Control.Monad.State import Control.Monad.Error-import Control.Monad.Reader import Control.Monad.Unify  import Control.Applicative@@ -59,7 +57,7 @@ -- Infer the kind of a single type -- kindOf :: ModuleName -> Type -> Check Kind-kindOf moduleName ty =+kindOf _ ty =   rethrow (("Error checking kind of " ++ prettyPrintType ty ++ ":\n") ++) $     fmap tidyUp . liftUnify $ starIfUnknown <$> infer ty   where@@ -87,8 +85,8 @@   let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars   bindLocalTypeVariables moduleName dict $ do     tyCons <- replicateM (length tys) fresh-    let dict = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons-    bindLocalTypeVariables moduleName dict $ do+    let dict' = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons+    bindLocalTypeVariables moduleName dict' $ do       data_ks <- zipWithM (\tyCon (_, args, ts) -> do         kargs <- replicateM (length args) fresh         let argDict = zip (map ProperName args) kargs@@ -159,7 +157,9 @@   k2 =?= Row k1   return $ Row k1 infer (ConstrainedType deps ty) = do-  mapM_ (infer . snd) deps+  forM_ deps $ \(className, tys) -> do+    _ <- infer $ foldl TypeApp (TypeConstructor className) tys+    return ()   k <- infer ty   k =?= Star   return Star

@@ -13,8 +13,8 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, RankNTypes, DeriveDataTypeable,-    GADTs, StandaloneDeriving, MultiParamTypeClasses, FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, RankNTypes,+    MultiParamTypeClasses, FlexibleContexts #-}  module Language.PureScript.TypeChecker.Monad where @@ -26,15 +26,13 @@  import Data.Data import Data.Maybe-import Data.Monoid import Data.Generics (mkT, everywhere)  import Control.Applicative import Control.Monad.State import Control.Monad.Error-import Control.Monad.Reader import Control.Monad.Unify-import Control.Arrow ((***))+import Control.Arrow (first)  import qualified Data.Map as M @@ -173,15 +171,15 @@ -- Temporarily bind a collection of names to local variables -- bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type)] -> m a -> m a-bindLocalVariables moduleName bindings action =-  bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((moduleName, name), (ty, LocalVariable))) action+bindLocalVariables moduleName bindings =+  bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((moduleName, name), (ty, LocalVariable)))  -- | -- Temporarily bind a collection of names to local type variables -- bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a-bindLocalTypeVariables moduleName bindings action =-  bindTypes (M.fromList $ flip map bindings $ \(name, k) -> ((moduleName, name), (k, LocalTypeVariable))) action+bindLocalTypeVariables moduleName bindings =+  bindTypes (M.fromList $ flip map bindings $ \(name, k) -> ((moduleName, name), (k, LocalTypeVariable)))  -- | -- Lookup the type of a value by name in the @Environment@@@ -322,7 +320,7 @@   case e of     Left err -> throwError err     Right (a, ust) -> do-      modify $ \st -> st { checkNextVar = unifyNextVar ust }+      modify $ \st' -> st' { checkNextVar = unifyNextVar ust }       return (a, unifyCurrentSubstitution ust)  -- |@@ -334,7 +332,7 @@   go :: Type -> Type   go (TypeConstructor nm) = TypeConstructor $ qualify' nm   go (SaturatedTypeSynonym nm args) = SaturatedTypeSynonym (qualify' nm) args-  go (ConstrainedType constraints ty) = ConstrainedType (map (qualify' *** id) constraints) ty+  go (ConstrainedType constraints ty) = ConstrainedType (map (first qualify') constraints) ty   go other = other   qualify' qual = let (mn', pn') = canonicalizeType mn env qual                   in Qualified (Just mn') pn'

@@ -14,7 +14,6 @@ -----------------------------------------------------------------------------  {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -60,7 +59,6 @@  import Control.Monad.State import Control.Monad.Error-import Control.Monad.Reader import Control.Monad.Unify  import Control.Applicative@@ -82,7 +80,7 @@ -- Unify two types, updating the current substitution -- unifyTypes :: Type -> Type -> UnifyT Type Check ()-unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $ do+unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $   unifyTypes' t1 t2   where   unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()@@ -104,8 +102,8 @@     sko <- newSkolemConstant     let sk = skolemize ident sko sc ty1     sk `unifyTypes` ty2-  unifyTypes' (ForAll _ _ _) _ = throwError "Skolem variable scope is unspecified"-  unifyTypes' ty f@(ForAll _ _ _) = f `unifyTypes` ty+  unifyTypes' ForAll{} _ = throwError "Skolem variable scope is unspecified"+  unifyTypes' ty f@ForAll{} = f `unifyTypes` ty   unifyTypes' (Object row1) (Object row2) = row1 =?= row2   unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()   unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do@@ -116,8 +114,8 @@     t3 `unifyTypes` t5     t4 `unifyTypes` t6   unifyTypes' (Skolem s1 _) (Skolem s2 _) | s1 == s2 = return ()-  unifyTypes' r1@(RCons _ _ _) r2 = unifyRows r1 r2-  unifyTypes' r1 r2@(RCons _ _ _) = unifyRows r1 r2+  unifyTypes' r1@RCons{} r2 = unifyRows r1 r2+  unifyTypes' r1 r2@RCons{} = unifyRows r1 r2   unifyTypes' r1@REmpty r2 = unifyRows r1 r2   unifyTypes' r1 r2@REmpty = unifyRows r1 r2   unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."@@ -187,30 +185,30 @@       -- 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-      triple@(_, (val, ty)) <- case e of+      triple@(_, (val', ty)) <- case e of         -- Typed declarations-        (ident, (val, Just (ty, checkType))) -> do+        (ident, (val', Just (ty, checkType))) -> do           -- Kind check           kind <- liftCheck $ kindOf moduleName ty           guardWith ("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')-          return (ident, (val', ty'))+          val'' <- bindNames dict' $ if checkType+                                   then TypedValue True <$> check val' ty' <*> pure ty'+                                   else return (TypedValue False val' ty')+          return (ident, (val'', ty'))         -- Untyped declarations-        (ident, (val, Nothing)) -> do+        (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))+          return (ident, (TypedValue True val'' ty, ty))       -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a       when (Just moduleName == mainModuleName && fst e == Ident "main") $ do         [eff, a] <- replicateM 2 fresh-        ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Eff"])) (ProperName "Eff"))) eff) a+        ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a       -- Make sure unification variables do not escape-      escapeCheck val ty+      escapeCheck val' ty       return triple   forM tys $ \(ident, (val, ty)) -> do     -- Replace type class dictionary placeholders with actual dictionaries@@ -221,7 +219,7 @@     -- top-level unification variables with named type variables.     let val'' = overTypes (desaturateAllTypeSynonyms . setifyAll) val'         ty' = varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty-    return $ (ident, (val'', ty'))+    return (ident, (val'', ty'))   where   -- 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@@ -260,14 +258,14 @@ -- Check that the current set of type class dictionaries entail the specified type class goal, and, if so, -- return a type class dictionary reference. ---entails :: ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, Type) -> Check Value-entails moduleName context goal@(className, ty) = do+entails :: ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Check Value+entails moduleName context goal@(className, tys) = do   env <- getEnv   case go env goal of-    [] -> throwError $ "No " ++ show className ++ " instance found for " ++ prettyPrintType ty+    [] -> throwError $ "No " ++ show className ++ " instance found for " ++ intercalate ", " (map prettyPrintType tys)     (dict : _) -> return dict   where-  go env (className', ty') =+  go env (className', tys') =     [ mkDictionary (canonicalizeDictionary tcd) args     | tcd <- context     -- Choose type class dictionaries in scope in the current module@@ -275,16 +273,16 @@     -- Make sure the type class name matches the one we are trying to satisfy     , typeConstructorsAreEqual env moduleName className' (tcdClassName tcd)     -- Make sure the type unifies with the type in the type instance definition-    , subst <- maybeToList $ typeHeadsAreEqual moduleName env ty' (tcdInstanceType tcd)+    , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)     -- Solve any necessary subgoals     , args <- solveSubgoals env subst (tcdDependencies tcd) ]   -- Create dictionaries for subgoals which still need to be solved by calling go recursively   -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type   -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.-  solveSubgoals :: Environment -> [(String, Type)] -> Maybe [(Qualified ProperName, Type)] -> [Maybe [Value]]+  solveSubgoals :: Environment -> [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [Value]]   solveSubgoals _ _ Nothing = return Nothing   solveSubgoals env subst (Just subgoals) = do-    dict <- mapM (go env) (map (id *** replaceAllTypeVars subst) subgoals)+    dict <- mapM (go env . second (map (replaceAllTypeVars subst))) subgoals     return $ Just dict   -- Make a dictionary from subgoal dictionaries by applying the correct function   mkDictionary :: Qualified Ident -> Maybe [Value] -> Value@@ -301,6 +299,12 @@   canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident   canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm   canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm+  -- Ensure that a substitution is valid+  verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]+  verifySubstitution subst = do+    let grps = groupBy ((==) `on` fst) subst+    guard (all ((==) 1 . length . nubBy ((==) `on` snd)) grps)+    return $ map head grps  -- | -- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup),@@ -314,7 +318,7 @@ typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2 typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1 typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e m name args of-  Left err -> Nothing+  Left  _  -> Nothing   Right t1 -> typeHeadsAreEqual m e t1 t2 typeHeadsAreEqual _ _ _ _ = Nothing @@ -344,7 +348,7 @@ -- skolemEscapeCheck :: Value -> Check () skolemEscapeCheck (TypedValue False _ _) = return ()-skolemEscapeCheck root@(TypedValue _ _ _) =+skolemEscapeCheck root@TypedValue{} =   -- Every skolem variable is created when a ForAll type is skolemized.   -- This determines the scope of that skolem variable, which is copied from the SkolemScope   -- field of the ForAll constructor.@@ -368,10 +372,10 @@       collect _ = []   go _ scos = ([], scos)   findBindingScope :: SkolemScope -> Maybe Value-  findBindingScope sco = something (mkQ Nothing go) root+  findBindingScope sco = something (mkQ Nothing go') root     where-    go val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = Just val-    go _ = Nothing+    go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = Just val+    go' _ = Nothing skolemEscapeCheck val = throwError $ "Untyped value passed to skolemEscapeCheck: " ++ prettyPrintValue val  -- |@@ -393,19 +397,13 @@ varIfUnknown ty =   let unks = nub $ unknowns ty       toName = (:) 't' . show-      ty' = everywhere (mkT typeToVar) $ ty+      ty' = everywhere (mkT typeToVar) ty       typeToVar :: Type -> Type       typeToVar (TUnknown (Unknown u)) = TypeVar (toName u)       typeToVar t = t   in mkForAll (sort . map (toName . runUnknown) $ unks) ty'  -- |--- Replace named type variables with types----replaceAllTypeVars :: [(String, Type)] -> Type -> Type-replaceAllTypeVars = foldl' (\f (name, ty) -> replaceTypeVars name ty . f) id---- | -- Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns -- or TypeClassDictionary values. --@@ -430,7 +428,7 @@ replaceVarWithUnknown :: String -> Type -> UnifyT Type Check Type replaceVarWithUnknown ident ty = do   tu <- fresh-  return $ replaceTypeVars ident tu $ ty+  return $ replaceTypeVars ident tu ty  -- | -- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate@@ -603,11 +601,11 @@       (_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contains constraints") ty       go binders fn         where-        go [] ty = do-          subsumes Nothing val ty+        go [] ty' = do+          subsumes Nothing val ty'           return M.empty-        go (binder : binders) (TypeApp (TypeApp t obj) ret) | t == tyFunction =-          M.union <$> inferBinder obj binder <*> go binders ret+        go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction =+          M.union <$> inferBinder obj binder <*> go binders' ret         go _ _ = throwError $ "Wrong number of arguments to constructor " ++ show ctor     _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined" inferBinder val (ObjectBinder props) = do@@ -713,7 +711,7 @@ -- Check the type of a value -- check' :: Value -> Type -> UnifyT Type Check Value-check' val t@(ForAll ident ty _) = do+check' val (ForAll ident ty _) = do   scope <- newSkolemScope   sko <- newSkolemConstant   let sk = skolemize ident sko scope ty@@ -722,15 +720,15 @@ check' val t@(ConstrainedType constraints ty) = do   env <- getEnv   Just moduleName <- checkCurrentModule <$> get-  dictNames <- flip mapM constraints $ \(Qualified _ (ProperName className), _) -> do+  dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do     n <- liftCheck freshDictionaryName     return $ Ident $ "__dict_" ++ className ++ "_" ++ show n   val' <- withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->     TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)       (qualifyAllUnqualifiedNames moduleName env constraints)) $         check val ty-  return $ TypedValue True (foldr Abs val' (map Left dictNames)) t-check' val t@(SaturatedTypeSynonym name args) = do+  return $ TypedValue True (foldr (Abs . Left) val' dictNames) t+check' val (SaturatedTypeSynonym name args) = do   ty <- introduceSkolemScope <=< expandTypeSynonym name $ args   val' <- check val ty   return $ TypedValue True val' ty@@ -747,8 +745,8 @@ check' v@(BooleanLiteral _) t | t == tyBoolean =   return $ TypedValue True v t check' (ArrayLiteral vals) t@(TypeApp a ty) | a == tyArray = do-  arr <- ArrayLiteral <$> forM vals (\val -> check val ty)-  return $ TypedValue True arr t+  array <- ArrayLiteral <$> forM vals (`check` ty)+  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@@ -944,17 +942,17 @@   go ts1' ts2' r1' r2'   return val   where-  go [] ts2 r1 r2 = r1 =?= rowFromList (ts2, r2)-  go ts1 [] r1 r2 = r2 =?= rowFromList (ts1, r1)-  go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1 r2+  go [] ts2 r1' r2' = r1' =?= rowFromList (ts2, r2')+  go ts1 [] r1' r2' = r2' =?= rowFromList (ts1, r1')+  go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1' r2'     | p1 == p2 = do subsumes Nothing ty1 ty2-                    go ts1 ts2 r1 r2+                    go ts1 ts2 r1' r2'     | p1 < p2 = do rest <- fresh-                   r2 =?= RCons p1 ty1 rest-                   go ts1 ((p2, ty2) : ts2) r1 rest+                   r2' =?= RCons p1 ty1 rest+                   go ts1 ((p2, ty2) : ts2) r1' rest     | p1 > p2 = do rest <- fresh-                   r1 =?= RCons p2 ty2 rest-                   go ((p1, ty1) : ts1) ts2 rest r2+                   r1' =?= RCons p2 ty2 rest+                   go ((p1, ty1) : ts1) ts2 rest r2' subsumes' val ty1 ty2@(Object _) = subsumes val ty2 ty1 subsumes' val ty1 ty2 = do   ty1 =?= ty2

@@ -19,10 +19,10 @@  import Data.Data import Data.List (nub)-import Data.Generics (everything, mkT, mkQ, everywhereBut)+import Data.Generics (everything, mkQ)  import Control.Monad.Unify-import Control.Arrow ((***))+import Control.Arrow (second)  import Language.PureScript.Names @@ -66,7 +66,7 @@   -- |   -- A type with a set of type class constraints   ---  | ConstrainedType [(Qualified ProperName, Type)] Type+  | ConstrainedType [(Qualified ProperName, [Type])] Type   -- |   -- A skolem constant   --@@ -122,7 +122,7 @@ -- Smart constructor for function types -- function :: Type -> Type -> Type-function t1 t2 = TypeApp (TypeApp tyFunction t1) t2+function t1 = TypeApp (TypeApp tyFunction t1)  -- | -- Convert a row to a list of pairs of labels and types@@ -143,8 +143,8 @@ -- Check whether a type is a monotype -- isMonoType :: Type -> Bool-isMonoType (ForAll _ _ _) = False-isMonoType ty = True+isMonoType ForAll{} = False+isMonoType _        = True  -- | -- Universally quantify a type@@ -168,17 +168,17 @@     where     go :: [String] -> Type -> Type     go bs (Object r) = Object $ go bs r-    go bs (TypeVar v) | v == name = replacement+    go _  (TypeVar v) | v == name = replacement     go bs (TypeApp t1 t2) = TypeApp (go bs t1) (go bs t2)-    go bs (SaturatedTypeSynonym name ts) = SaturatedTypeSynonym name $ map (go bs) ts+    go bs (SaturatedTypeSynonym name' ts) = SaturatedTypeSynonym name' $ map (go bs) ts     go bs f@(ForAll v t sco) | v == name = f                              | v `elem` usedTypeVariables replacement =                                  let v' = genName v (name : bs ++ usedTypeVariables replacement)                                      t' = replaceTypeVars' bs v (TypeVar v') t                                  in ForAll v' (go (v' : bs) t') sco                              | otherwise = ForAll v (go (v : bs) t) sco-    go bs (ConstrainedType cs t) = ConstrainedType (map (id *** go bs) cs) (go bs t)-    go bs (RCons name t r) = RCons name (go bs t) (go bs r)+    go bs (ConstrainedType cs t) = ConstrainedType (map (second $ map (go bs)) cs) (go bs t)+    go bs (RCons name' t r) = RCons name' (go bs t) (go bs r)     go _ ty = ty   genName orig inUse = try 0     where@@ -186,6 +186,12 @@           | otherwise = orig ++ show n  -- |+-- Replace named type variables with types+--+replaceAllTypeVars :: [(String, Type)] -> Type -> Type+replaceAllTypeVars = foldl (\f (name, ty) -> replaceTypeVars name ty . f) id++-- | -- Collect all type variables appearing in a type -- usedTypeVariables :: Type -> [String]@@ -206,7 +212,7 @@   go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2   go bound (SaturatedTypeSynonym _ ts) = concatMap (go bound) ts   go bound (ForAll v t _) = go (v : bound) t-  go bound (ConstrainedType cs t) = concatMap (go bound . snd) cs ++ go bound t+  go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) . snd) cs ++ go bound t   go bound (RCons _ t r) = go bound t ++ go bound r   go _ _ = [] 

@@ -112,7 +112,7 @@   -- can be evaluated at runtime. The constructor arguments represent (in order): the type class name and   -- instance type, and the type class dictionaries in scope.   ---  | TypeClassDictionary (Qualified ProperName, Type) [TypeClassDictionaryInScope] deriving (Show, Data, Typeable)+  | TypeClassDictionary (Qualified ProperName, [Type]) [TypeClassDictionaryInScope] deriving (Show, Data, Typeable)  -- | -- The type of a type class dictionary@@ -141,13 +141,13 @@     --     , tcdClassName :: Qualified ProperName     -- |-    -- The type to which this type class instance applies+    -- The types to which this type class instance applies     ---    , tcdInstanceType :: Type+    , tcdInstanceTypes :: [Type]     -- |     -- Type class dependencies which must be satisfied to construct this dictionary     ---    , tcdDependencies :: Maybe [(Qualified ProperName, Type)]+    , tcdDependencies :: Maybe [(Qualified ProperName, [Type])]     -- |     -- The type of this dictionary     --

@@ -20,7 +20,6 @@  import Data.List (isSuffixOf) import Data.Traversable (traverse)-import Control.Applicative import Control.Monad import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import System.Exit@@ -31,7 +30,6 @@ import Text.Parsec (ParseError) import qualified Paths_purescript as Paths import qualified System.IO.UTF8 as U-import qualified Data.Map as M  preludeFilename :: IO FilePath preludeFilename = Paths.getDataFileName "prelude/prelude.purs"@@ -45,13 +43,13 @@ compile opts inputFiles = do   modules <- readInput inputFiles   case modules of-    Left parseError -> do+    Left parseError ->       return (Left $ show parseError)-    Right ms -> do+    Right ms ->       case P.compile opts ms of-        Left typeError -> do+        Left typeError ->           return (Left typeError)-        Right (js, _, _) -> do+        Right (js, _, _) ->           return (Right js)  assert :: P.Options -> [FilePath] -> (Either String String -> IO (Maybe String)) -> IO ()@@ -93,7 +91,7 @@ main :: IO () main = do   cd <- getCurrentDirectory-  putStrLn $ cd+  putStrLn cd   let examples = cd ++ pathSeparator : "examples"   let passing = examples ++ pathSeparator : "passing"   passingTestCases <- getDirectoryContents passing