packages feed

purescript 0.4.1 → 0.4.2

raw patch · 31 files changed

+604/−469 lines, 31 filesdep +unixdep +xdg-basedirbuild-type:Customsetup-changed

Dependencies added: unix, xdg-basedir

Files

+ Setup.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE CPP #-}++#ifndef POSIX_LIKE+#define POSIX_LIKE !(defined(_WIN32_HOST_OS) || defined(_WIN64_HOST_OS)) && \+                  (defined(unix_HOST_OS) || defined(__unix___HOST_OS) || \+                   defined(__unix_HOST_OS) || defined(linux_HOST_OS) || \+                   defined(__linux___HOST_OS) || defined(__linux_HOST_OS) || \+                   (defined(__APPLE___HOST_OS) && defined(__MACH___HOST_OS)))+#endif++module Main where++import Control.Monad++import Distribution.PackageDescription+import Distribution.Simple+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Setup++import System.Directory+import System.Environment.XDG.BaseDir+#if POSIX_LIKE+import System.Posix.Files+#endif++main :: IO ()+main = defaultMainWithHooks $ simpleUserHooks {postInst = setupXDG}++setupXDG :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO ()+setupXDG _ _ _ _ = do+    configDir <- getUserConfigDir "purescript"+    configExists <- doesDirectoryExist configDir+    unless configExists $ do+        createDirectoryIfMissing True configDir+#if POSIX_LIKE+        setFileMode configDir ownerModes+#endif+#undef POSIX_LIKE
− Setup.lhs 
@@ -1,6 +0,0 @@-#!/usr/bin/runhaskell -> module Main where-> import Distribution.Simple-> main :: IO ()-> main = defaultMain-
docgen/Main.hs view
@@ -59,8 +59,8 @@   mapM_ renderModule ms  renderModule :: P.Module -> Docs-renderModule (P.Module (P.ProperName moduleName) ds) = do-  headerLevel 2 $ "Module " ++ moduleName+renderModule (P.Module moduleName ds) = do+  headerLevel 2 $ "Module " ++ (P.runModuleName moduleName)   spacer   headerLevel 3 "Types"   spacer
prelude/prelude.purs view
@@ -578,7 +578,7 @@    foreign import sort "function sort(l) {\                       \  var l1 = l.slice();\-                      \  l.sort();\+                      \  l1.sort();\                       \  return l1;\                       \}" :: forall a. [a] -> [a] @@ -608,19 +608,19 @@   filter _ [] = []   filter p (x:xs) | p x = x : filter p xs   filter p (_:xs) = filter p xs+  +  find :: forall a. (a -> Boolean) -> [a] -> Maybe a+  find _ [] = Nothing+  find p (x:xs) | p x = Just x+  find p (_:xs) = find p xs    isEmpty :: forall a. [a] -> Boolean   isEmpty [] = true   isEmpty _ = false    range :: Number -> Number -> [Number]-  range lo hi = {-      var ns = [];-      for (n <- lo until hi) {-        ns = push ns n;-      }-      return ns;-    }+  range lo hi | lo > hi = []+  range lo hi = lo : range (lo + 1) hi    zipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]   zipWith f (a:as) (b:bs) = f a b : zipWith f as bs@@ -635,8 +635,7 @@   all p (a:as) = p a && all p as    instance (Prelude.Show a) => Prelude.Show [a] where-    show [] = "[]"-    show (x:xs) = show x ++ " : " ++ show xs+    show xs = "[" ++ joinWith (map show xs) "," ++ "]"    instance Prelude.Functor [] where     (<$>) = map@@ -952,7 +951,7 @@ 			\      return {};\                         \    };\                         \  };\-                        \}" :: forall e. Eff e Boolean -> Eff e {} -> Eff e {}+                        \}" :: forall e a. Eff e Boolean -> Eff e a -> Eff e {}    foreign import forE "function forE(lo) {\ 	              \  return function(hi) {\@@ -1078,6 +1077,8 @@    foreign import data STRef :: * -> * -> * +  foreign import data STArray :: * -> * -> *+   foreign import newSTRef "function newSTRef(val) {\                           \  return function () {\                           \    return { value: val };\@@ -1093,20 +1094,61 @@   foreign import modifySTRef "function modifySTRef(ref) {\                              \  return function(f) {\                              \    return function() {\-                             \      ref.value = f(ref.value);\+                             \      return ref.value = f(ref.value);\                              \    };\                              \  };\-                             \}" :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) {}+                             \}" :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a    foreign import writeSTRef "function writeSTRef(ref) {\                             \  return function(a) {\                             \    return function() {\-                            \      ref.value = a;\+                            \      return ref.value = a;\                             \    };\                             \  };\-                            \}" :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) {}+                            \}" :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a +  foreign import newSTArray "function newSTArray(len) {\+                            \  return function(a) {\+                            \    return function() {\+                            \      var arr = [];\+                            \      for (var i = 0; i < len; i++) {\+                            \        arr[i] = a;\+                            \      };\+                            \      return arr;\+                            \    };\+                            \  };\+                            \}" :: forall a h r. Number -> a -> Eff (st :: ST h | r) (STArray h a)++  foreign import peekSTArray "function peekSTArray(arr) {\+                             \  return function(i) {\+                             \    return function() {\+                             \      return arr[i];\+                             \    };\+                             \  };\+                             \}" :: forall a h r. STArray h a -> Eff (st :: ST h | r) a++  foreign import pokeSTArray "function pokeSTArray(arr) {\+                             \  return function(i) {\+                             \    return function(a) {\+                             \      return function() {\+                             \        return arr[i] = a;\+                             \      };\+                             \    };\+                             \  };\+                             \}" :: forall a h r. STArray h a -> Number -> a -> Eff (st :: ST h | r) a+   foreign import runST "function runST(f) {\                        \  return f;\                        \}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a +  foreign import runSTArray "function runSTArray(f) {\+                            \  return f;\+                            \}" :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r [a]++module Enum where++  import Maybe++  class Enum a where+    toEnum :: Number -> Maybe a+    fromEnum :: a -> Number
psci/Main.hs view
@@ -9,6 +9,7 @@ -- Portability : -- -- |+-- PureScript Compiler Interactive. -- ----------------------------------------------------------------------------- @@ -16,131 +17,258 @@  module Main where -import Control.Monad.IO.Class+import Commands+ import Control.Applicative+import Control.Monad import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)+import Control.Monad.Trans.State -import Data.List (nub, isPrefixOf)+import Data.List (intercalate, isPrefixOf, nub, sort) import Data.Maybe (mapMaybe)+import Data.Traversable (traverse) -import System.Process import System.Console.Haskeline+import System.Directory (findExecutable)+import System.Exit+import System.Environment.XDG.BaseDir+import System.Process  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 (eof)+import qualified Text.Parsec as Parsec (Parsec, eof) +-- |+-- The PSCI state.+-- Holds a list of imported modules, loaded files, and partial let bindings.+-- 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]++-- 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@+--+ioToState :: IO a -> StateT PSCI (InputT IO) a+ioToState = lift . lift++-- |+-- 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++-- |+-- Updates the state to have more loaded files.+--+updateModules :: [P.Module] -> PSCI -> PSCI+updateModules modules (PSCI i m b) = PSCI i (m ++ modules) b++-- |+-- 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])++-- File helpers+-- |+-- Load the necessary modules.+--+defaultImports :: [P.ProperName]+defaultImports = [P.ProperName "Prelude"]++-- |+-- Locates the node executable.+-- Checks for either @nodejs@ or @node@.+--+findNodeProcess :: IO (Maybe String)+findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names+    where names = ["nodejs", "node"]++-- |+-- Grabs the filename where the history is stored.+--+getHistoryFilename :: IO FilePath+getHistoryFilename = getUserConfigFile "purescript" "psci_history"++-- |+-- Grabs the filename where prelude is.+-- getPreludeFilename :: IO FilePath getPreludeFilename = Paths.getDataFileName "prelude/prelude.purs" -options :: P.Options-options = P.Options True False True Nothing True "PS" []+-- |+-- 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 +-- Messages++-- |+-- The help message.+--+helpMessage :: String+helpMessage = "The following commands are available:\n\n    " +++  intercalate "\n    " (map (intercalate "    ") help)++-- |+-- The welcome prologue.+--+prologueMessage :: String+prologueMessage = intercalate "\n"+  [ " ____                 ____            _       _   "+  , "|  _ \\ _   _ _ __ ___/ ___|  ___ _ __(_)_ __ | |_ "+  , "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|"+  , "|  __/| |_| | | |  __/___) | (__| |  | | |_) | |_ "+  , "|_|    \\__,_|_|  \\___|____/ \\___|_|  |_| .__/ \\__|"+  , "                                       |_|        "+  , ""+  , ":? shows help"+  , ""+  , "Expressions are terminated using Ctrl+D"+  ]++-- |+-- The quit message.+--+quitMessage :: String+quitMessage = "See ya!"++-- Haskeline completions++-- |+-- Loads module, function, and file completions.+-- completion :: [P.Module] -> CompletionFunc IO completion ms = completeWord Nothing " \t\n\r" findCompletions   where   findCompletions :: String -> IO [Completion]   findCompletions str = do     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 (P.ModuleName moduleName)) ident]-                      ]-    let matches = filter (isPrefixOf str) names+    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   getDeclName :: P.Declaration -> Maybe P.Ident   getDeclName (P.ValueDeclaration ident _ _ _) = Just ident   getDeclName _ = Nothing -createTemporaryModule :: [P.ProperName] -> P.Value -> P.Module-createTemporaryModule imports value =+-- Compilation++-- | Compilation options.+--+options :: P.Options+options = P.Options True False True (Just "Main") True "PS" []++-- |+-- Makes a volatile module to execute the current expression.+--+createTemporaryModule :: [P.ProperName] -> [P.Value -> P.Value] -> P.Value -> P.Module+createTemporaryModule imports lets value =   let-    moduleName = P.ProperName "Main"+    moduleName = P.ModuleName [P.ProperName "Main"]     importDecl m = P.ImportDeclaration m Nothing-    traceModule = P.ModuleName (P.ProperName "Trace")+    traceModule = P.ModuleName [P.ProperName "Trace"]     trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))-    mainDecl = P.ValueDeclaration (P.Ident "main") [] Nothing-        (P.Do [ P.DoNotationBind (P.VarBinder (P.Ident "it")) value-              , P.DoNotationValue (P.App trace (P.Var (P.Qualified Nothing (P.Ident "it"))) )-              ])+    value' = foldr ($) value lets+    mainDecl = P.ValueDeclaration (P.Ident "main") [] Nothing (P.App trace value')   in-    P.Module moduleName $ map (importDecl . P.ModuleName) imports ++ [mainDecl]+    P.Module moduleName $ map (importDecl . P.ModuleName . return) imports ++ [mainDecl] -handleDeclaration :: [P.Module] -> [P.ProperName] -> P.Value -> InputT IO ()-handleDeclaration loadedModules imports value = do-  let m = createTemporaryModule imports value+-- |+-- 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     Left err -> outputStrLn err     Right (js, _, _) -> do-      output <- liftIO $ readProcess "nodejs" [] js-      outputStrLn output+      process <- lift findNodeProcess+      result <- 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" -data Command-  = Empty-  | Expression [String]-  | Import String-  | LoadModule FilePath-  | Reload deriving (Show, Eq)+-- Parser helpers -getCommand :: InputT IO Command-getCommand = do-  firstLine <- getInputLine  "> "-  case firstLine of-    Nothing -> return Empty-    Just (':':'i':' ':moduleName) -> return $ Import moduleName-    Just (':':'m':' ':modulePath) -> return $ LoadModule modulePath-    Just ":r" -> return Reload-    Just (':':_) -> outputStrLn "Unknown command" >> getCommand-    Just other -> Expression <$> go [other]-  where-  go ls = do-    l <- getInputLine "  "-    case l of-      Nothing -> return $ reverse ls-      Just l' -> go (l' : ls)+-- |+-- 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@.+--+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) -loadModule :: FilePath -> IO (Either String [P.Module])-loadModule moduleFile = do-  print moduleFile-  moduleText <- U.readFile moduleFile-  return . either (Left . show) Right $ P.runIndentParser "" P.parseModules moduleText+-- |+-- Parser for any other valid expression.+--+parseExpression :: Parsec.Parsec String P.ParseState P.Value+parseExpression = P.whiteSpace *> P.parseValue <* Parsec.eof +-- Commands++-- |+-- 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 (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"++-- |+-- The PSCI main loop.+-- main :: IO () main = do   preludeFilename <- getPreludeFilename   (Right prelude) <- loadModule preludeFilename-  runInputT (setComplete (completion prelude) defaultSettings) $ do-    outputStrLn " ____                 ____            _       _   "-    outputStrLn "|  _ \\ _   _ _ __ ___/ ___|  ___ _ __(_)_ __ | |_ "-    outputStrLn "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|"-    outputStrLn "|  __/| |_| | | |  __/___) | (__| |  | | |_) | |_ "-    outputStrLn "|_|    \\__,_|_|  \\___|____/ \\___|_|  |_| .__/ \\__|"-    outputStrLn "                                       |_|        "-    outputStrLn ""-    outputStrLn "Expressions are terminated using Ctrl+D"-    go [P.ProperName "Prelude"] prelude+  historyFilename <- getHistoryFilename+  let settings = defaultSettings {historyFile = Just historyFilename}+  runInputT (setComplete (completion prelude) settings) $ do+    outputStrLn prologueMessage+    evalStateT go (PSCI defaultImports prelude [])   where-  go imports loadedModules = do-    cmd <- getCommand-    case cmd of-      Empty -> go imports loadedModules-      Expression ls -> do-        case P.runIndentParser "" (P.whiteSpace *> P.parseValue <* Parsec.eof) (unlines ls) of-          Left err -> outputStrLn (show err)-          Right decl -> handleDeclaration loadedModules imports decl-        go imports loadedModules-      Import moduleName -> go (imports ++ [P.ProperName moduleName]) loadedModules-      LoadModule moduleFile -> do-        ms <- lift $ loadModule moduleFile-        case ms of-          Left err -> outputStrLn err-          Right ms' -> go imports (loadedModules ++ ms')-      Reload -> do-        preludeFilename <- lift getPreludeFilename-        (Right prelude) <- lift $ loadModule preludeFilename-        go [P.ProperName "Prelude"] prelude--+    go :: StateT PSCI (InputT IO) ()+    go = do+      c <- inputTToState getCommand+      case c of+        Quit -> inputTToState $ outputStrLn quitMessage+        _    -> handleCommand c >> go
purescript.cabal view
@@ -1,7 +1,7 @@ name: purescript-version: 0.4.1+version: 0.4.2 cabal-version: >=1.8-build-type: Simple+build-type: Custom license: MIT license-file: LICENSE copyright: (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors@@ -10,14 +10,20 @@ synopsis: PureScript Programming Language Compiler description: A small compile-to-JS language with extensible records and type-safe blocks category: Language-author: Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>+Homepage: http://www.purescript.org/+author: Phil Freeman <paf31@cantab.net>,+        Gary Burgess <gary.burgess@gmail.com>,+        Hardy Jones <jones3.hardy@gmail.com> data-files: prelude/prelude.purs data-dir: ""  library     build-depends: base >=4 && <5, cmdtheline -any, containers -any,                    directory -any, filepath -any, mtl -any, parsec -any, syb -any,-                   transformers -any, utf8-string -any, pattern-arrows -any, monad-unify >= 0.2 && < 0.3+                   transformers -any, utf8-string -any, pattern-arrows -any, monad-unify >= 0.2 && < 0.3,+                   xdg-basedir -any+    if (!os(windows))+        build-depends: unix -any     exposed-modules: Data.Generics.Extras                      Language.PureScript                      Language.PureScript.Options@@ -36,6 +42,7 @@                      Language.PureScript.Sugar.BindingGroups                      Language.PureScript.Sugar.Operators                      Language.PureScript.Sugar.TypeClasses+                     Language.PureScript.Sugar.Let                      Language.PureScript.CodeGen                      Language.PureScript.CodeGen.Common                      Language.PureScript.CodeGen.Externs@@ -77,9 +84,10 @@     ghc-options: -Wall -O2 -fno-warn-unused-do-bind  executable psci-    build-depends: base >=4 && <5, containers -any, mtl -any,-                   parsec -any, haskeline <=0.7.1.1, purescript -any, syb -any,-                   transformers -any, utf8-string -any, process -any+    build-depends: base >=4 && <5, containers -any, directory -any,+                   mtl -any, parsec -any, haskeline <=0.7.1.1, purescript -any,+                   syb -any, transformers -any, utf8-string -any, process -any,+                   xdg-basedir -any     main-is: Main.hs     buildable: True     hs-source-dirs: psci
src/Language/PureScript.hs view
@@ -60,19 +60,23 @@   sorted <- sortModules ms   desugared <- desugar sorted   (elaborated, env) <- runCheck $ forM desugared $ \(Module moduleName decls) -> do-    modify (\s -> s { checkCurrentModule = Just (ModuleName moduleName) })-    Module moduleName <$> typeCheckAll mainModuleIdent (ModuleName moduleName) decls+    modify (\s -> s { checkCurrentModule = Just moduleName })+    Module moduleName <$> typeCheckAll mainModuleIdent moduleName decls   regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated-  let entryPoints = optionsModules opts+  let entryPoints = (ModuleName . splitProperNames) `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)) $+      when ((ModuleName [ProperName mainModuleName], Ident "main") `M.notMember` (names env)) $         Left $ mainModuleName ++ ".main is undefined"       return $ js ++ [JSApp (JSAccessor "main" (JSAccessor mainModuleName (JSVar "_ps"))) []]     _ -> return js   return (prettyPrintJS [(wrapExportsContainer opts js')], exts, env)   where-  mainModuleIdent = ModuleName . ProperName <$> (optionsMain opts)+  mainModuleIdent = ModuleName . splitProperNames <$> optionsMain opts+  splitProperNames s = case dropWhile (== '.') s of+    "" -> []+    s' -> ProperName w : splitProperNames s''+      where (w, s'') = break (== '.') s'
src/Language/PureScript/CodeGen/Common.hs view
@@ -16,6 +16,7 @@ module Language.PureScript.CodeGen.Common where  import Data.Char+import Data.List (intercalate) import Language.PureScript.Names  -- |@@ -127,3 +128,5 @@             , "with"             , "yield" ] +moduleNameToJs :: ModuleName -> String+moduleNameToJs (ModuleName pns) = intercalate "_" (runProperName `map` pns)
src/Language/PureScript/CodeGen/Externs.hs view
@@ -29,9 +29,9 @@ -- Generate foreign imports for all declarations in a module -- moduleToPs :: Module -> Environment -> String-moduleToPs (Module pname@(ProperName moduleName) decls) env =-  "module " ++ moduleName ++ " where\n" ++-  (intercalate "\n" . map ("  " ++) . concatMap (declToPs (ModuleName pname) env) $ decls)+moduleToPs (Module mn decls) env =+  "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
src/Language/PureScript/CodeGen/JS.hs view
@@ -52,14 +52,14 @@ -- module. -- moduleToJs :: Options -> Module -> Environment -> Maybe JS-moduleToJs opts (Module pname@(ProperName name) decls) env =+moduleToJs opts (Module name decls) env =   case jsDecls of     [] -> Nothing-    _ -> Just $ JSAssignment (JSAccessor name (JSVar "_ps")) $+    _ -> Just $ JSAssignment (JSAccessor (moduleNameToJs name) (JSVar "_ps")) $            JSApp (JSFunction Nothing ["module"] (JSBlock $ jsDecls ++ [JSReturn $ JSVar "module"]))-                 [(JSBinary Or (JSAccessor name (JSVar "_ps")) (JSObjectLiteral []))]+                 [(JSBinary Or (JSAccessor (moduleNameToJs name) (JSVar "_ps")) (JSObjectLiteral []))]   where-  jsDecls = (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts (ModuleName pname) 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@@ -128,13 +128,12 @@     Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS m id (Qualified (Just aliasModule) aliasIdent)     _ -> JSVar . runProperName $ name valueToJs _ m _ (Constructor name) = qualifiedToJS m (Ident . runProperName) name-valueToJs opts m e (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs opts m e) sts))) [] valueToJs opts m e (Case values binders) = bindersToJs opts m e binders (map (valueToJs opts m e) values) valueToJs opts m e (IfThenElse cond th el) = JSConditional (valueToJs opts m e cond) (valueToJs opts m e th) (valueToJs opts m e el) valueToJs opts m e (Accessor prop val) = JSAccessor prop (valueToJs opts m e val) valueToJs opts m e (App val arg) = JSApp (valueToJs opts m e val) [valueToJs opts m e arg]-valueToJs opts m e (Abs arg val) = JSFunction Nothing [identToJs arg] (JSBlock [JSReturn (valueToJs opts m (bindName m arg e) val)])-valueToJs opts m e (TypedValue _ (Abs arg val) ty) | optionsPerformRuntimeTypeChecks opts = let arg' = identToJs arg in JSFunction Nothing [arg'] (JSBlock $ runtimeTypeChecks arg' ty ++ [JSReturn (valueToJs opts m e val)])+valueToJs opts m e (Abs (Left arg) val) = JSFunction Nothing [identToJs arg] (JSBlock [JSReturn (valueToJs opts m (bindName m arg e) val)])+valueToJs opts m e (TypedValue _ (Abs (Left arg) val) ty) | optionsPerformRuntimeTypeChecks opts = let arg' = identToJs arg in JSFunction Nothing [arg'] (JSBlock $ runtimeTypeChecks arg' ty ++ [JSReturn (valueToJs opts m e val)]) valueToJs _ m e (Var ident) = varToJs m e ident valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val valueToJs _ _ _ (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"@@ -212,7 +211,7 @@ -- variable that may have a qualified name. -- qualifiedToJS :: ModuleName -> (a -> Ident) -> Qualified a -> JS-qualifiedToJS m f (Qualified (Just m'@(ModuleName (ProperName mn))) a) | m /= m' = accessor (f a) (JSAccessor mn $ JSVar "_ps")+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)  -- |@@ -325,24 +324,6 @@   typeConstructor (TypeApp (TypeApp t _) ty) | t == tyFunction = typeConstructor ty   typeConstructor (TypeApp ty _) = typeConstructor ty   typeConstructor fn = error $ "Invalid arguments to typeConstructor: " ++ show fn---- |--- Generate code in the simplified Javascript intermediate representation for a statement in a--- PureScript block.----statementToJs :: Options -> ModuleName -> Environment -> Statement -> JS-statementToJs opts m e (VariableIntroduction ident value) = JSVariableIntroduction (identToJs ident) (Just (valueToJs opts m e value))-statementToJs opts m e (Assignment target value) = JSAssignment (JSVar (identToJs target)) (valueToJs opts m e value)-statementToJs opts m e (While cond sts) = JSWhile (valueToJs opts m e cond) (JSBlock (map (statementToJs opts m e) sts))-statementToJs opts m e (For ident start end sts) = JSFor (identToJs ident) (valueToJs opts m e start) (valueToJs opts m e end) (JSBlock (map (statementToJs opts m e) sts))-statementToJs opts m e (If ifst) = ifToJs ifst-  where-  ifToJs :: IfStatement -> JS-  ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs opts m e cond) (JSBlock (map (statementToJs opts m e) thens)) (fmap elseToJs elses)-  elseToJs :: ElseStatement -> JS-  elseToJs (Else sts) = JSBlock (map (statementToJs opts m e) sts)-  elseToJs (ElseIf elif) = ifToJs elif-statementToJs opts m e (Return value) = JSReturn (valueToJs opts m e value)  wrapExportsContainer :: Options -> [JS] -> JS wrapExportsContainer opts modules = JSApp (JSFunction Nothing ["_ps"] $ JSBlock $ (JSStringLiteral "use strict") : modules) [exportSelector]
src/Language/PureScript/CodeGen/Optimize.hs view
@@ -38,7 +38,8 @@ ) where  import Data.Data-import Data.Maybe (fromMaybe)+import Data.List (nub)+import Data.Maybe (fromJust, isJust, fromMaybe) import Data.Generics  import Language.PureScript.Names@@ -95,6 +96,7 @@   check :: JS -> Bool   check (JSFunction _ args _) | var1 `elem` args = True   check (JSVariableIntroduction arg _) | var1 == arg = True+  check (JSAssignment (JSVar arg) _) | var1 == arg = True   check _ = False  isRebound :: (Data d) => JS -> d -> Bool@@ -254,52 +256,136 @@   isSelfCall _ _ = False  magicDo :: Options -> JS -> JS-magicDo opts | optionsMagicDo opts = magicDo'+magicDo opts | optionsMagicDo opts = inlineST . magicDo'              | otherwise = id +-- |+-- Inline type class dictionaries for >>= and return for the Eff monad+--+-- E.g.+--+--  Prelude[">>="](dict)(m1)(function(x) {+--    return ...;+--  })+--+-- becomes+--+--  function __do {+--    var x = m1();+--    ...+--  }+-- magicDo' :: JS -> JS magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)   where+  -- The name of the function block which is added to denote a do block   fnName = "__do"-+  -- Desugar monomorphic calls to >>= and return for the Eff monad   convert :: JS -> JS+  -- Desugar return   convert (JSApp (JSApp ret [val]) []) | isReturn ret = val+  -- Desugae >>   convert (JSApp (JSApp bind [m]) [JSFunction Nothing ["_"] (JSBlock [JSReturn ret])]) | isBind bind =     JSFunction (Just fnName) [] $ JSBlock [ JSApp m [], JSReturn (JSApp ret []) ]+  -- Desugar >>=   convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock [JSReturn ret])]) | isBind bind =     JSFunction (Just fnName) [] $ JSBlock [ JSVariableIntroduction arg (Just (JSApp m [])), JSReturn (JSApp ret []) ]+  -- Desugar untilE+  convert (JSApp (JSApp f [arg]) []) | isEffFunc "untilE" f =+    JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn (JSObjectLiteral []) ])) []+  -- Desugar whileE+  convert (JSApp (JSApp (JSApp f [arg1]) [arg2]) []) | isEffFunc "whileE" f =+    JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn (JSObjectLiteral []) ])) []   convert other = other-+  -- Check if an expression represents a monomorphic call to >>= for the Eff monad   isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict effDict = True   isBind _ = False-+  -- Check if an expression represents a monomorphic call to return for the Eff monad   isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict effDict = True   isReturn _ = False-+  -- Check if an expression represents the polymorphic >>= function   isBindPoly (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) | prop == identToJs (Op ">>=") = True   isBindPoly (JSIndexer (JSStringLiteral ">>=") (JSAccessor "Prelude" (JSVar "_ps"))) = True   isBindPoly _ = False-+  -- Check if an expression represents the polymorphic return function   isRetPoly (JSAccessor "$return" (JSAccessor "Prelude" (JSVar "_ps"))) = True   isRetPoly (JSIndexer (JSStringLiteral "return") (JSAccessor "Prelude" (JSVar "_ps"))) = True   isRetPoly _ = False--  prelude = ModuleName (ProperName "Prelude")-  effModule = ModuleName (ProperName "Eff")-+  -- Check if an expression represents a function in the Ef module+  isEffFunc name (JSAccessor name' (JSAccessor "Eff" (JSVar "_ps"))) | name == name' = True+  isEffFunc _ _ = False+  -- Module names+  prelude = ModuleName [ProperName "Prelude"]+  effModule = ModuleName [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")))-+  -- 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 _ = False-+  -- Remove __do function applications which remain after desugaring   undo :: JS -> JS   undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body   undo other = other +-- |+-- Inline functions in the ST module+--+inlineST :: JS -> JS+inlineST = everywhere (mkT convertBlock)+  where+  -- Look for runST blocks and inline the STRefs there.+  -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then+  -- we can be more aggressive about inlining, and actually turn STRefs into local variables.+  convertBlock (JSApp f [arg]) | isSTFunc "runST" f || isSTFunc "runSTArray" f =+    let refs = nub . findSTRefsIn $ arg+        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+  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+  -- agg(ressive) parameter.+  convert agg (JSApp (JSApp f [arg]) []) | isSTFunc "newSTRef" f =+    if agg then arg else JSObjectLiteral [("value", arg)]+  convert agg (JSApp (JSApp f [ref]) []) | isSTFunc "readSTRef" f =+    if agg then ref else JSAccessor "value" ref+  convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc "writeSTRef" f =+    if agg then JSAssignment ref arg else JSAssignment (JSAccessor "value" ref) arg+  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)+  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 _ _ = 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 _ = []+  -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef+  findAllSTUsagesIn = everything (++) (mkQ [] isSTUsage)+    where+    isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc "readSTRef" f = [ref]+    isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc "writeSTRef" f || isSTFunc "modifySTRef" f = [ref]+    isSTUsage _ = []+  -- Find all uses of a variable+  appearingIn ref = everything (++) (mkQ [] isVar)+    where+    isVar e@(JSVar v) | v == ref = [e]+    isVar _ = []+  -- Convert a JS value to a String if it is a JSVar+  toVar (JSVar v) = Just v+  toVar _ = Nothing+ collapseNestedBlocks :: JS -> JS collapseNestedBlocks = everywhere (mkT collapse)   where@@ -382,7 +468,7 @@   isOpDict className ty (JSApp (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == dictName = True     where     Right (Ident dictName) = mkDictionaryValueName-      (ModuleName (ProperName "Prim"))-      (Qualified (Just (ModuleName (ProperName "Prelude"))) (ProperName className))+      (ModuleName [ProperName "Prim"])+      (Qualified (Just (ModuleName [ProperName "Prelude"])) (ProperName className))       ty   isOpDict _ _ _ = False
src/Language/PureScript/DeadCodeElimination.hs view
@@ -30,12 +30,12 @@ -- | -- Eliminate all declarations which are not a transitive dependency of the entry point module ---eliminateDeadCode :: Environment -> [String] -> [Module] -> [Module]+eliminateDeadCode :: Environment -> [ModuleName] -> [Module] -> [Module] eliminateDeadCode env entryPoints ms =   let declarations = concatMap (declarationsByModule env) ms       (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations-      entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((ModuleName (ProperName mn), _), _) -> mn `elem` entryPoints) $ declarations-  in flip map ms $ \(Module moduleName ds) -> Module moduleName (filter (isUsed (ModuleName moduleName) graph vertexFor entryPointVertices) ds)+      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)  type Key = (ModuleName, Either Ident ProperName) @@ -43,10 +43,10 @@ declarationsByModule env (Module moduleName ds) = concatMap go $ ds   where   go :: Declaration -> [(Key, [Key])]-  go d@(ValueDeclaration name _ _ _) = [((ModuleName moduleName, Left name), dependencies env (ModuleName moduleName) d)]-  go (DataDeclaration _ _ dctors) = map (\(name, _) -> ((ModuleName moduleName, Right name), [])) dctors-  go (ExternDeclaration _ name _ _) = [((ModuleName moduleName, Left name), [])]-  go d@(BindingGroupDeclaration names) = map (\(name, _) -> ((ModuleName moduleName, Left name), dependencies env (ModuleName moduleName) d)) names+  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 _ = []
src/Language/PureScript/Declarations.hs view
@@ -42,7 +42,7 @@ -- | -- A module declaration, consisting of a module name and a list of declarations ---data Module = Module ProperName [Declaration] deriving (Show, D.Data, D.Typeable)+data Module = Module ModuleName [Declaration] deriving (Show, D.Data, D.Typeable)  -- | -- The type of a foreign import
src/Language/PureScript/ModuleDependencies.hs view
@@ -40,21 +40,21 @@ -- | -- Calculate a list of used modules based on explicit imports and qualified names ---usedModules :: (Data d) => d -> [ProperName]+usedModules :: (Data d) => d -> [ModuleName] usedModules = nub . everything (++) (mkQ [] qualifiedIdents `extQ` qualifiedProperNames `extQ` imports)   where-  qualifiedIdents :: Qualified Ident -> [ProperName]-  qualifiedIdents (Qualified (Just (ModuleName pn)) _) = [pn]+  qualifiedIdents :: Qualified Ident -> [ModuleName]+  qualifiedIdents (Qualified (Just mn) _) = [mn]   qualifiedIdents _ = []-  qualifiedProperNames :: Qualified ProperName -> [ProperName]-  qualifiedProperNames (Qualified (Just (ModuleName pn)) _) = [pn]+  qualifiedProperNames :: Qualified ProperName -> [ModuleName]+  qualifiedProperNames (Qualified (Just mn) _) = [mn]   qualifiedProperNames _ = []-  imports :: Declaration -> [ProperName]-  imports (ImportDeclaration (ModuleName pn) _) = [pn]+  imports :: Declaration -> [ModuleName]+  imports (ImportDeclaration mn _) = [mn]   imports _ = [] -getModuleName :: Module -> ProperName-getModuleName (Module pn _) = pn+getModuleName :: Module -> ModuleName+getModuleName (Module mn _) = mn  -- | -- Convert a strongly connected component of the module graph to a module
src/Language/PureScript/Names.hs view
@@ -17,6 +17,7 @@  module Language.PureScript.Names where +import Data.List import Data.Data import Data.Function (on) @@ -64,10 +65,13 @@ -- | -- Module names ---data ModuleName = ModuleName { runModuleName :: ProperName } deriving (Eq, Ord, Data, Typeable)+data ModuleName = ModuleName [ProperName] deriving (Eq, Ord, Data, Typeable) +runModuleName :: ModuleName -> String+runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns)+ instance Show ModuleName where-  show (ModuleName name) = show name+  show = runModuleName  -- | -- A qualified name, i.e. a name with an optional module name@@ -76,7 +80,7 @@  instance (Show a) => Show (Qualified a) where   show (Qualified Nothing a) = show a-  show (Qualified (Just (ModuleName name)) a) = show name ++ "." ++ show a+  show (Qualified (Just name) a) = show name ++ "." ++ show a  -- | -- Provide a default module name, if a name is unqualified
src/Language/PureScript/Parser/Common.hs view
@@ -49,7 +49,7 @@                   , "true"                   , "false"                   , "until"-+                  , "in"                   ]  -- |@@ -204,14 +204,23 @@ properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many P.alphaNum P.<?> "name")  -- |+-- Parse a module name+--+moduleName :: P.Parsec String ParseState ModuleName+moduleName = ModuleName <$> P.try (sepBy properName dot)++-- | -- Parse a qualified name, i.e. M.name or just name -- parseQualified :: P.Parsec String ParseState a -> P.Parsec String ParseState (Qualified a)-parseQualified parser = qual+parseQualified parser = part []   where-  qual = (Qualified <$> (Just . ModuleName <$> P.try (properName <* delimiter)) <*> parser)-     <|> (Qualified Nothing <$> P.try parser)-  delimiter = indented *> dot+  part path = (do name <- P.try (properName <* delimiter)+                  part (updatePath path name))+              <|> (Qualified (qual path) <$> P.try parser)+  delimiter = indented *> dot <* P.notFollowedBy dot+  updatePath path name = path ++ [name]+  qual path = if null path then Nothing else Just $ ModuleName path  -- | -- Parse an integer or floating point value
src/Language/PureScript/Parser/Declarations.hs view
@@ -89,7 +89,7 @@ parseImportDeclaration = do   reserved "import"   indented-  moduleName <- ModuleName <$> properName+  moduleName <- moduleName   idents <- P.optionMaybe $ parens $ commaSep1 (Left <$> parseIdent <|> Right <$> properName)   return $ ImportDeclaration moduleName idents @@ -138,7 +138,7 @@ parseModule = do   reserved "module"   indented-  name <- properName+  name <- moduleName   _ <- lexeme $ P.string "where"   decls <- mark (P.many (same *> parseDeclaration))   return $ Module name decls
src/Language/PureScript/Parser/Values.hs view
@@ -15,7 +15,6 @@  module Language.PureScript.Parser.Values (     parseValue,-    parseStatement,     parseGuard,     parseBinder,     parseBinderNoParens,@@ -54,7 +53,7 @@ parseAbs :: P.Parsec String ParseState Value parseAbs = do   C.reservedOp "\\"-  args <- P.many1 (C.indented *> (Abs <$> C.parseIdent))+  args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))   C.indented *> C.reservedOp "->"   value <- parseValue   return $ toFunction args value@@ -83,16 +82,19 @@                              <*> (C.indented *> C.reserved "then" *> C.indented *> parseValue)                              <*> (C.indented *> C.reserved "else" *> C.indented *> parseValue) -parseBlock :: P.Parsec String ParseState Value-parseBlock = Block <$> parseManyStatements--parseManyStatements :: P.Parsec String ParseState [Statement]-parseManyStatements = (do-  _ <- C.lexeme $ P.char '{'+parseLet :: P.Parsec String ParseState Value+parseLet = do+  C.reserved "let"   C.indented-  sts <- C.mark (P.many (C.same *> C.mark parseStatement))-  _ <- C.lexeme (P.char '}')-  return sts) P.<?> "block"+  binder <- parseBinder+  C.indented+  C.reservedOp "="+  C.indented+  value <- parseValue+  C.indented+  C.reserved "in"+  result <- parseValue+  return $ Let binder value result  parseValueAtom :: P.Parsec String ParseState Value parseValueAtom = P.choice@@ -104,10 +106,10 @@             , parseAbs             , P.try parseConstructor             , P.try parseVar-            , parseBlock             , parseCase             , parseIfThenElse             , parseDo+            , parseLet             , Parens <$> C.parens parseValue ]  parsePropertyUpdate :: P.Parsec String ParseState (String, Value)@@ -159,63 +161,6 @@                     return (BinaryNoParens ident))) AssocRight ]               ] -parseVariableIntroduction :: P.Parsec String ParseState Statement-parseVariableIntroduction = do-  C.reserved "var"-  name <- C.indented *> C.parseIdent-  _ <- C.lexeme $ C.indented *> P.char '='-  value <- parseValue-  _ <- C.indented *> C.semi-  return $ VariableIntroduction name value--parseAssignment :: P.Parsec String ParseState Statement-parseAssignment = do-  tgt <- P.try $ do-    tgt <- C.parseIdent-    _ <- C.lexeme $ C.indented *> P.char '='-    return tgt-  value <- parseValue-  _ <- C.indented *> C.semi-  return $ Assignment tgt value--parseWhile :: P.Parsec String ParseState Statement-parseWhile = While <$> (C.reserved "while" *> C.indented *> C.parens parseValue)-                   <*> (C.indented *> parseManyStatements)--parseFor :: P.Parsec String ParseState Statement-parseFor = For <$> (C.reserved "for" *> C.indented *> C.lexeme (P.char '(') *> C.indented *> C.parseIdent)-               <*> (C.indented *> C.lexeme (P.string "<-") *> parseValue)-               <*> (C.indented *> C.reserved "until" *> parseValue <* C.indented <* C.lexeme (P.char ')'))-               <*> parseManyStatements--parseIf :: P.Parsec String ParseState Statement-parseIf = If <$> parseIfStatement--parseIfStatement :: P.Parsec String ParseState IfStatement-parseIfStatement =-  IfStatement <$> (C.reserved "if" *> C.indented *> C.parens parseValue)-              <*> parseManyStatements-              <*> P.optionMaybe parseElseStatement--parseElseStatement :: P.Parsec String ParseState ElseStatement-parseElseStatement = C.reserved "else" >> (ElseIf <$> parseIfStatement-                                           <|> Else <$> parseManyStatements)--parseReturn :: P.Parsec String ParseState Statement-parseReturn = Return <$> (C.reserved "return" *> parseValue <* C.indented <* C.semi)---- |--- Parse a statement----parseStatement :: P.Parsec String ParseState Statement-parseStatement = P.choice-                 [ parseAssignment-                 , parseVariableIntroduction-                 , parseWhile-                 , parseFor-                 , parseIf-                 , parseReturn ] P.<?> "statement"- parseStringBinder :: P.Parsec String ParseState Binder parseStringBinder = StringBinder <$> C.stringLiteral @@ -254,19 +199,6 @@   binder <- C.indented *> parseBinder   return (name, binder) -parseBinderAtom :: P.Parsec String ParseState Binder-parseBinderAtom = P.choice (map P.try-                  [ parseNullBinder-                  , parseStringBinder-                  , parseBooleanBinder-                  , parseNumberBinder-                  , parseNamedBinder-                  , parseVarBinder-                  , parseConstructorBinder-                  , parseObjectBinder-                  , parseArrayBinder-                  , C.parens parseBinder ]) P.<?> "binder"- -- | -- Parse a binder --@@ -274,6 +206,18 @@ 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+  parseBinderAtom = P.choice (map P.try+                    [ parseNullBinder+                    , parseStringBinder+                    , parseBooleanBinder+                    , parseNumberBinder+                    , parseNamedBinder+                    , parseVarBinder+                    , parseConstructorBinder+                    , parseObjectBinder+                    , parseArrayBinder+                    , C.parens parseBinder ]) P.<?> "binder"  -- | -- Parse a binder as it would appear in a top level declaration
src/Language/PureScript/Pretty/Values.hs view
@@ -38,7 +38,6 @@   match (ArrayLiteral xs) = Just $ "[" ++ intercalate ", " (map prettyPrintValue xs) ++ "]"   match (ObjectLiteral ps) = Just $ "{" ++ intercalate ", " (map (uncurry prettyPrintObjectProperty) ps) ++ "}"   match (Constructor name) = Just $ show name-  match (Block sts) = Just $ "do { " ++ intercalate " ; " (map prettyPrintStatement sts) ++ " }"   match (Case values binders) = Just $ "case " ++ intercalate " " (map prettyPrintValue values) ++     " of { " ++ intercalate " ; " (map prettyPrintCaseAlternative binders) ++ " }"   match (Var ident) = Just $ show ident@@ -77,7 +76,7 @@ lam :: Pattern () Value (String, Value) lam = mkPattern match   where-  match (Abs arg val) = Just (show arg, val)+  match (Abs (Left arg) val) = Just (show arg, val)   match _ = Nothing  typed :: Pattern () Value (Type, Value)@@ -148,25 +147,3 @@  prettyPrintObjectProperty :: String -> Value -> String prettyPrintObjectProperty key value = key ++ ": " ++ prettyPrintValue value--prettyPrintStatement :: Statement -> String-prettyPrintStatement (VariableIntroduction ident value) = "var " ++ show ident ++ " = " ++ prettyPrintValue value-prettyPrintStatement (Assignment target value) = show target ++ " = " ++ prettyPrintValue value-prettyPrintStatement (While cond sts) = "while " ++ prettyPrintValue cond ++ ": {" ++ intercalate ";" (map prettyPrintStatement sts) ++ " }"-prettyPrintStatement (For ident start end sts) = "for " ++ show ident-  ++ " <- " ++ prettyPrintValue start-  ++ " until " ++ prettyPrintValue end ++ ": {"-  ++ intercalate "; " (map prettyPrintStatement sts) ++ " }"-prettyPrintStatement (If ifst) = prettyPrintIfStatement ifst-prettyPrintStatement (Return value) = "return " ++ prettyPrintValue value--prettyPrintIfStatement :: IfStatement -> String-prettyPrintIfStatement (IfStatement cond thens elst) =-  "if "-  ++ prettyPrintValue cond ++ ": {"-  ++ intercalate "; " (map prettyPrintStatement thens) ++ " }"-  ++ maybe "" prettyPrintElseStatement elst--prettyPrintElseStatement :: ElseStatement -> String-prettyPrintElseStatement (Else sts) = "else: {" ++ intercalate "; " (map prettyPrintStatement sts) ++ " }"-prettyPrintElseStatement (ElseIf ifst) = "else " ++ prettyPrintIfStatement ifst
src/Language/PureScript/Scope.hs view
@@ -30,16 +30,12 @@ -- Gather all used names appearing inside a value -- usedNames :: (Data d) => d -> [Ident]-usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesS `extQ` namesB `extQ` namesJS) val+usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesB `extQ` namesJS) val   where   namesV :: Value -> [Ident]-  namesV (Abs arg _) = [arg]+  namesV (Abs (Left arg) _) = [arg]   namesV (Var (Qualified Nothing name)) = [name]   namesV _ = []-  namesS :: Statement -> [Ident]-  namesS (VariableIntroduction name _) = [name]-  namesS (For name _ _ _) = [name]-  namesS _ = []   namesB :: Binder -> [Ident]   namesB (VarBinder name) = [name]   namesB _ = []
src/Language/PureScript/Sugar.hs view
@@ -16,6 +16,7 @@ module Language.PureScript.Sugar (desugar, module S) where  import Control.Monad+import Control.Arrow ((>>>))  import Language.PureScript.Declarations @@ -25,10 +26,13 @@ import Language.PureScript.Sugar.TypeDeclarations as S import Language.PureScript.Sugar.BindingGroups as S import Language.PureScript.Sugar.TypeClasses as S+import Language.PureScript.Sugar.Let as S  -- | -- The desugaring pipeline proceeds as follows: --+--  * Desugar let bindings+-- --  * Introduce type synonyms for type class dictionaries -- --  * Rebracket user-defined binary operators@@ -45,6 +49,7 @@ desugar = desugarTypeClasses           >=> rebracket           >=> desugarDo-          >=> desugarCasesModule+          >=> desugarLetBindings+          >>> desugarCasesModule           >=> desugarTypeDeclarationsModule           >=> createBindingGroupsModule
src/Language/PureScript/Sugar/BindingGroups.hs view
@@ -36,7 +36,7 @@ -- Replace all sets of mutually-recursive declarations in a module with binding groups -- createBindingGroupsModule :: [Module] -> Either String [Module]-createBindingGroupsModule = mapM $ \(Module name ds) -> Module name <$> createBindingGroups (ModuleName name) ds+createBindingGroupsModule = mapM $ \(Module name ds) -> Module name <$> createBindingGroups name ds  -- | -- Collapse all binding groups in a module to individual declarations
src/Language/PureScript/Sugar/CaseDeclarations.hs view
@@ -20,6 +20,8 @@ ) where  import Data.List (groupBy)+import Data.Generics (mkT, everywhere)+ import Control.Applicative ((<$>)) import Control.Monad (forM, join, unless) import Control.Monad.Error.Class@@ -33,7 +35,18 @@ -- Replace all top-level binders in a module with case expressions. -- desugarCasesModule :: [Module] -> Either String [Module]-desugarCasesModule ms = forM ms $ \(Module name ds) -> Module name <$> desugarCases ds+desugarCasesModule ms = forM ms $ \(Module name ds) -> Module name <$> (desugarCases . desugarAbs $ ds)++desugarAbs :: [Declaration] -> [Declaration]+desugarAbs = everywhere (mkT replace)+  where+  replace (Abs (Right binder) val) =+    let+      ident = head $ unusedNames (binder, val)+    in+      Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [([binder], Nothing, val)]+  replace other = other+ -- | -- Replace all top-level binders with case expressions. --@@ -64,7 +77,7 @@     args = take argPattern $ unusedNames (ident, alternatives)     vars = map (\arg -> Var (Qualified Nothing arg)) args     binders = [ (bs, g, val) | (bs, (g, val)) <- alternatives ]-    value = foldr (\args' ret -> Abs args' ret) (Case vars binders) args+    value = foldr (\arg ret -> Abs (Left arg) ret) (Case vars binders) args   in     ValueDeclaration ident [] Nothing value
src/Language/PureScript/Sugar/DoNotation.hs view
@@ -33,7 +33,7 @@ desugarDo = everywhereM (mkM replace)   where   prelude :: ModuleName-  prelude = ModuleName (ProperName "Prelude")+  prelude = ModuleName [ProperName "Prelude"]   ret :: Value   ret = Var (Qualified (Just prelude) (Ident "ret"))   bind :: Value@@ -46,16 +46,16 @@   go [DoNotationValue val] = return val   go (DoNotationValue val : rest) = do     rest' <- go rest-    return $ App (App bind val) (Abs (Ident "_") rest')+    return $ App (App bind val) (Abs (Left (Ident "_")) rest')   go [DoNotationBind _ _] = Left "Bind statement cannot be the last statement in a do block"   go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)   go (DoNotationBind (VarBinder ident) val : rest) = do     rest' <- go rest-    return $ App (App bind val) (Abs ident rest')+    return $ App (App bind val) (Abs (Left ident) rest')   go (DoNotationBind binder val : rest) = do     rest' <- go rest     let ident = head $ unusedNames rest'-    return $ App (App bind val) (Abs ident (Case [Var (Qualified Nothing ident)] [([binder], Nothing, rest')]))+    return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [([binder], Nothing, rest')]))   go [DoNotationLet _ _] = Left "Let statement cannot be the last statement in a do block"   go (DoNotationLet binder val : rest) = do     rest' <- go rest
+ src/Language/PureScript/Sugar/Let.hs view
@@ -0,0 +1,32 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Sugar.Let+-- Copyright   :  (c) Phil Freeman 2014+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- This module implements the desugaring pass which turns let bindings into function applications.+--+-----------------------------------------------------------------------------++module Language.PureScript.Sugar.Let (+  desugarLetBindings+) where++import Data.Generics (mkT, everywhere)++import Language.PureScript.Values+import Language.PureScript.Declarations++-- |+-- Turn let bindings into function applications+--+desugarLetBindings :: [Module] -> [Module]+desugarLetBindings = everywhere (mkT go)+  where+  go (Let binder value result) = Case [value] [([binder], Nothing, result)]+  go other = other
src/Language/PureScript/Sugar/Operators.hs view
@@ -46,9 +46,9 @@   where   go _ rb [] = return . reverse $ rb   go m rb (Module name ds : ms) = do-    m' <- M.union m <$> collectFixities m (ModuleName name) ds+    m' <- M.union m <$> collectFixities m name ds     let opTable = customOperatorTable m'-    ds' <- G.everywhereM' (G.mkM (matchOperators (ModuleName name) opTable)) ds+    ds' <- G.everywhereM' (G.mkM (matchOperators name opTable)) ds     go m' (Module name (G.everywhere (G.mkT removeParens) ds') : rb) ms  removeParens :: Value -> Value
src/Language/PureScript/Sugar/TypeClasses.hs view
@@ -36,7 +36,7 @@ import Data.Maybe (fromMaybe) import Data.List (nub) import Data.Generics (mkQ, everything)-import Language.PureScript.CodeGen.Common (identToJs)+import Language.PureScript.CodeGen.Common (identToJs, moduleNameToJs)  type MemberMap = M.Map (ModuleName, ProperName) (String, [(String, Type)]) @@ -50,7 +50,7 @@ desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule  desugarModule :: Module -> Desugar Module-desugarModule (Module name decls) = Module name <$> concat <$> mapM (desugarDecl (ModuleName name)) decls+desugarModule (Module name decls) = Module name <$> concat <$> mapM (desugarDecl name) decls  -- | -- Desugar type class and type class instance declarations@@ -127,7 +127,7 @@   memberNames <- mapM (memberToNameAndValue memberTypes) decls   return $ ValueDeclaration entryName [] Nothing     (TypedValue True-      (foldr Abs (ObjectLiteral memberNames) (map (\n -> Ident ('_' : show n)) [1..max 1 (length deps)]))+      (foldr Abs (ObjectLiteral memberNames) (map (\n -> Left . Ident $ '_' : show n) [1..max 1 (length deps)]))       (quantify (if null deps then                    function unit (TypeApp (TypeConstructor name) ty)                  else@@ -159,7 +159,7 @@  qualifiedToString :: ModuleName -> Qualified ProperName -> String qualifiedToString mn (Qualified Nothing pn) = qualifiedToString mn (Qualified (Just mn) pn)-qualifiedToString _ (Qualified (Just (ModuleName mn)) pn) = runProperName mn ++ "_" ++ runProperName pn+qualifiedToString _ (Qualified (Just mn) pn) = moduleNameToJs mn ++ "_" ++ runProperName pn  -- | -- Generate a name for a type class dictionary, based on the module name, class name and type name
src/Language/PureScript/TypeChecker/Monad.hs view
@@ -118,11 +118,11 @@ -- The basic types existing in the external javascript environment -- jsTypes ::M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)-jsTypes = M.fromList [ ((ModuleName $ ProperName "Prim", ProperName "Function"), (FunKind Star $ FunKind Star Star, ExternData))-                     , ((ModuleName $ ProperName "Prim", ProperName "Array"), (FunKind Star Star, ExternData))-                     , ((ModuleName $ ProperName "Prim", ProperName "String"), (Star, ExternData))-                     , ((ModuleName $ ProperName "Prim", ProperName "Number"), (Star, ExternData))-                     , ((ModuleName $ ProperName "Prim", ProperName "Boolean"), (Star, ExternData)) ]+jsTypes = M.fromList [ ((ModuleName [ProperName "Prim"], ProperName "Function"), (FunKind Star $ FunKind Star Star, ExternData))+                     , ((ModuleName [ProperName "Prim"], ProperName "Array"), (FunKind Star Star, ExternData))+                     , ((ModuleName [ProperName "Prim"], ProperName "String"), (Star, ExternData))+                     , ((ModuleName [ProperName "Prim"], ProperName "Number"), (Star, ExternData))+                     , ((ModuleName [ProperName "Prim"], ProperName "Boolean"), (Star, ExternData)) ]  -- | -- The initial environment with no values and only the default javascript types defined
src/Language/PureScript/TypeChecker/Types.hs view
@@ -208,7 +208,7 @@       -- 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 "Eff"])) (ProperName "Eff"))) eff) a       -- Make sure unification variables do not escape       escapeCheck val ty       return triple@@ -524,12 +524,13 @@       _ <- subsumes Nothing objTy (Object (RCons prop field rest))       return $ TypedValue True (Accessor prop typed) field     Just ty -> return $ TypedValue True (Accessor prop typed) ty-infer' (Abs arg ret) = do+infer' (Abs (Left arg) ret) = do   ty <- fresh   Just moduleName <- checkCurrentModule <$> get   bindLocalVariables moduleName [(arg, ty)] $ do     body@(TypedValue _ _ bodyTy) <- infer' ret-    return $ TypedValue True (Abs arg body) $ function ty bodyTy+    return $ TypedValue True (Abs (Left arg) body) $ function ty bodyTy+infer' (Abs (Right _) _) = error "Binder was not desugared" infer' (App f arg) = do   f'@(TypedValue _ _ ft) <- infer f   (ret, app) <- checkFunctionApplication f' ft arg@@ -543,11 +544,6 @@       dicts <- getTypeClassDictionaries       return $ TypedValue True (foldl App (Var var) (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) ty'     _ -> return $ TypedValue True (Var var) ty-infer' (Block ss) = do-  ret <- fresh-  (allCodePathsReturn, _, ss') <- checkBlock M.empty ret ss-  guardWith "Block is missing a return statement" allCodePathsReturn-  return $ TypedValue True (Block ss') ret infer' v@(Constructor c) = do   env <- getEnv   Just moduleName <- checkCurrentModule <$> get@@ -673,77 +669,6 @@     _ -> return ()  -- |--- Check the type of the return values of a statement, returning whether or not the statement returns on--- all code paths----checkStatement :: M.Map Ident Type -> Type -> Statement -> UnifyT Type Check (Bool, M.Map Ident Type, Statement)-checkStatement mass _ (VariableIntroduction name val) = do-  assignVariable name-  val'@(TypedValue _ _ t) <- infer val-  return (False, M.insert name t mass, VariableIntroduction name val')-checkStatement mass _ (Assignment ident val) = do-  val'@(TypedValue _ _ t) <- infer val-  case M.lookup ident mass of-    Nothing -> throwError $ "No local variable with name " ++ show ident-    Just ty -> do t =?= ty-                  return (False, mass, Assignment ident val')-checkStatement mass ret (While val inner) = do-  val' <- check val tyBoolean-  (allCodePathsReturn, _, inner') <- checkBlock mass ret inner-  return (allCodePathsReturn, mass, While val' inner')-checkStatement mass ret (If ifst) = do-  (allCodePathsReturn, ifst') <- checkIfStatement mass ret ifst-  return (allCodePathsReturn, mass, If ifst')-checkStatement mass ret (For ident start end inner) = do-  Just moduleName <- checkCurrentModule <$> get-  assignVariable ident-  start' <- check start tyNumber-  end' <- check end tyNumber-  (allCodePathsReturn, _, inner') <- bindLocalVariables moduleName [(ident, tyNumber)] $ checkBlock mass ret inner-  return (allCodePathsReturn, mass, For ident start' end' inner')-checkStatement mass ret (Return val) = do-  val' <- check val ret-  return (True, mass, Return (TypedValue True val' ret))---- |--- Check the type of an if-then-else statement----checkIfStatement :: M.Map Ident Type -> Type -> IfStatement -> UnifyT Type Check (Bool, IfStatement)-checkIfStatement mass ret (IfStatement val thens Nothing) = do-  val' <- check val tyBoolean-  (_, _, thens') <- checkBlock mass ret thens-  return (False, IfStatement val' thens' Nothing)-checkIfStatement mass ret (IfStatement val thens (Just elses)) = do-  val' <- check val tyBoolean-  (allCodePathsReturn1, _, thens') <- checkBlock mass ret thens-  (allCodePathsReturn2, elses') <- checkElseStatement mass ret elses-  return (allCodePathsReturn1 && allCodePathsReturn2, IfStatement val' thens' (Just elses'))---- |--- Check the type of an else statement----checkElseStatement :: M.Map Ident Type -> Type -> ElseStatement -> UnifyT Type Check (Bool, ElseStatement)-checkElseStatement mass ret (Else elses) = do-  (allCodePathsReturn, _, elses') <- checkBlock mass ret elses-  return (allCodePathsReturn, Else elses')-checkElseStatement mass ret (ElseIf ifst) = (id *** ElseIf) <$> checkIfStatement mass ret ifst---- |--- Check the type of the return value of a block of statements----checkBlock :: M.Map Ident Type -> Type -> [Statement] -> UnifyT Type Check (Bool, M.Map Ident Type, [Statement])-checkBlock mass _ [] = return (False, mass, [])-checkBlock mass ret (s:ss) = do-  Just moduleName <- checkCurrentModule <$> get-  (b1, mass1, s') <- checkStatement mass ret s-  bindLocalVariables moduleName (M.toList mass1) $ case (b1, ss) of-    (True, []) -> return (True, mass1, [s'])-    (True, _) -> throwError "Unreachable code"-    (False, ss') -> do-      (b, m, ss'') <- checkBlock mass1 ret ss'-      return (b, m, s':ss'')---- | -- Generate a new skolem constant -- newSkolemConstant :: UnifyT Type Check Int@@ -804,7 +729,7 @@     TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)       (qualifyAllUnqualifiedNames moduleName env constraints)) $         check val ty-  return $ TypedValue True (foldr Abs val' dictNames) t+  return $ TypedValue True (foldr Abs val' (map Left dictNames)) t check' val t@(SaturatedTypeSynonym name args) = do   ty <- introduceSkolemScope <=< expandTypeSynonym name $ args   val' <- check val ty@@ -824,10 +749,11 @@ check' (ArrayLiteral vals) t@(TypeApp a ty) | a == tyArray = do   arr <- ArrayLiteral <$> forM vals (\val -> check val ty)   return $ TypedValue True arr t-check' (Abs arg ret) ty@(TypeApp (TypeApp t argTy) retTy) | t == tyFunction = do+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-  return $ TypedValue True (Abs arg ret') ty+  return $ TypedValue True (Abs (Left arg) ret') ty+check' (Abs (Right _) _) _ = error "Binder was not desugared" check' (App f arg) ret = do   f'@(TypedValue _ _ ft) <- infer f   (ret', app) <- checkFunctionApplication f' ft arg@@ -879,10 +805,6 @@   rest <- fresh   val' <- check val (Object (RCons prop ty rest))   return $ TypedValue True (Accessor prop val') ty-check' (Block ss) ret = do-  (allCodePathsReturn, _, ss') <- checkBlock M.empty ret ss-  guardWith "Block is missing a return statement" allCodePathsReturn-  return $ TypedValue True (Block ss') ret check' (Constructor c) ty = do   env <- getEnv   Just moduleName <- checkCurrentModule <$> get
src/Language/PureScript/Types.hs view
@@ -92,31 +92,31 @@ -- Type constructor for functions -- tyFunction :: Type-tyFunction = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prim") (ProperName "Function")+tyFunction = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Function")  -- | -- Type constructor for strings -- tyString :: Type-tyString = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prim") (ProperName "String")+tyString = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "String")  -- | -- Type constructor for numbers -- tyNumber :: Type-tyNumber = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prim") (ProperName "Number")+tyNumber = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Number")  -- | -- Type constructor for booleans -- tyBoolean :: Type-tyBoolean = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prim") (ProperName "Boolean")+tyBoolean = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Boolean")  -- | -- Type constructor for arrays -- tyArray :: Type-tyArray = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prim") (ProperName "Array")+tyArray = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Array")  -- | -- Smart constructor for function types
src/Language/PureScript/Values.hs view
@@ -72,7 +72,7 @@   -- |   -- Function introduction   ---  | Abs Ident Value+  | Abs (Either Ident Binder) Value   -- |   -- Function application   --@@ -86,10 +86,6 @@   --   | IfThenElse Value Value Value   -- |-  -- A \"Block\" i.e. a collection of statements which evaluate to a value-  ---  | Block [Statement]-  -- |   -- A data constructor   --   | Constructor (Qualified ProperName)@@ -103,6 +99,10 @@   --   | TypedValue Bool Value Type   -- |+  -- A let binding+  --+  | Let Binder Value Value+  -- |   -- A do-notation block   --   | Do [DoNotationElement]@@ -170,57 +170,6 @@   -- A let statement, i.e. a pure value with a binder   --   | DoNotationLet Binder Value deriving (Show, Data, Typeable)---- |--- Data type for statements which can appear inside a @Block@ expression----data Statement-  -- |-  -- A variable introduction and initial assignment-  ---  = VariableIntroduction Ident Value-  -- |-  -- A variable reassignment-  ---  | Assignment Ident Value-  -- |-  -- A while loop-  ---  | While Value [Statement]-  -- |-  -- A for loop-  ---  | For Ident Value Value [Statement]-  -- |-  -- An if-then-else statement-  ---  | If IfStatement-  -- |-  -- A return statement-  ---  | Return Value deriving (Show, Data, Typeable)---- |--- Data type for if-statements----data IfStatement-  -- |-  -- An if statement. Arguments are (in order): boolean condition, true branch, optional else branch.-  ---  = IfStatement Value [Statement] (Maybe ElseStatement) deriving (Show, Data, Typeable)---- |--- Data type for the else branch in an if-statement----data ElseStatement-  -- |-  -- An else branch-  ---  = Else [Statement]-  -- |-  -- An else-if branch-  ---  | ElseIf IfStatement deriving (Show, Data, Typeable)  -- | -- Data type for binders