summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-02-21 04:42:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-02-21 04:42:00 (GMT)
commit412228ecc467e2195eaa03bdac3fadb64e0b9cbe (patch)
treeb44f4dfd98b2924fa2ccb44566cbb04f4d735fb3
parent2403a4abf8d4388fe87ec237a41a25ac7c2ee486 (diff)
version 0.4.20.4.2
-rw-r--r--Setup.hs38
-rw-r--r--Setup.lhs6
-rw-r--r--docgen/Main.hs4
-rw-r--r--prelude/prelude.purs72
-rw-r--r--psci/Main.hs302
-rw-r--r--purescript.cabal22
-rw-r--r--src/Language/PureScript.hs14
-rw-r--r--src/Language/PureScript/CodeGen/Common.hs3
-rw-r--r--src/Language/PureScript/CodeGen/Externs.hs6
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs33
-rw-r--r--src/Language/PureScript/CodeGen/Optimize.hs116
-rw-r--r--src/Language/PureScript/DeadCodeElimination.hs14
-rw-r--r--src/Language/PureScript/Declarations.hs2
-rw-r--r--src/Language/PureScript/ModuleDependencies.hs18
-rw-r--r--src/Language/PureScript/Names.hs10
-rw-r--r--src/Language/PureScript/Parser/Common.hs19
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs4
-rw-r--r--src/Language/PureScript/Parser/Values.hs108
-rw-r--r--src/Language/PureScript/Pretty/Values.hs25
-rw-r--r--src/Language/PureScript/Scope.hs8
-rw-r--r--src/Language/PureScript/Sugar.hs7
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs2
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs17
-rw-r--r--src/Language/PureScript/Sugar/DoNotation.hs8
-rw-r--r--src/Language/PureScript/Sugar/Let.hs32
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs4
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs8
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs10
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs94
-rw-r--r--src/Language/PureScript/Types.hs10
-rw-r--r--src/Language/PureScript/Values.hs61
31 files changed, 606 insertions, 471 deletions
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..8f5b661
--- /dev/null
+++ b/Setup.hs
@@ -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
diff --git a/Setup.lhs b/Setup.lhs
deleted file mode 100644
index a630405..0000000
--- a/Setup.lhs
+++ /dev/null
@@ -1,6 +0,0 @@
-#!/usr/bin/runhaskell
-> module Main where
-> import Distribution.Simple
-> main :: IO ()
-> main = defaultMain
-
diff --git a/docgen/Main.hs b/docgen/Main.hs
index 9cd2a43..ed8d46e 100644
--- a/docgen/Main.hs
+++ b/docgen/Main.hs
@@ -59,8 +59,8 @@ renderModules ms = do
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
diff --git a/prelude/prelude.purs b/prelude/prelude.purs
index cba4d1b..b22d78b 100644
--- a/prelude/prelude.purs
+++ b/prelude/prelude.purs
@@ -578,7 +578,7 @@ module Arrays where
foreign import sort "function sort(l) {\
\ var l1 = l.slice();\
- \ l.sort();\
+ \ l1.sort();\
\ return l1;\
\}" :: forall a. [a] -> [a]
@@ -608,19 +608,19 @@ module Arrays where
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 @@ module Arrays where
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 @@ module Eff where
\ 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 @@ module ST where
foreign import data STRef :: * -> * -> *
+ foreign import data STArray :: * -> * -> *
+
foreign import newSTRef "function newSTRef(val) {\
\ return function () {\
\ return { value: val };\
@@ -1093,20 +1094,61 @@ module ST where
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
diff --git a/psci/Main.hs b/psci/Main.hs
index f657a7e..8909369 100644
--- a/psci/Main.hs
+++ b/psci/Main.hs
@@ -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
-
-data Command
- = Empty
- | Expression [String]
- | Import String
- | LoadModule FilePath
- | Reload deriving (Show, Eq)
-
-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)
+ 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"
-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 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@.
+--
+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)
+
+-- |
+-- 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
diff --git a/purescript.cabal b/purescript.cabal
index 875acd6..fa60a8c 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -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 @@ stability: experimental
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 @@ library
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 @@ executable psc
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
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index 1ec7ea7..b8378cb 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -60,19 +60,23 @@ 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 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'
diff --git a/src/Language/PureScript/CodeGen/Common.hs b/src/Language/PureScript/CodeGen/Common.hs
index ec8bbcf..0766256 100644
--- a/src/Language/PureScript/CodeGen/Common.hs
+++ b/src/Language/PureScript/CodeGen/Common.hs
@@ -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 @@ nameIsJsReserved name =
, "with"
, "yield" ]
+moduleNameToJs :: ModuleName -> String
+moduleNameToJs (ModuleName pns) = intercalate "_" (runProperName `map` pns)
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
index e6d6c9f..52c6f2b 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -29,9 +29,9 @@ import Data.List (intercalate)
-- 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
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 43e8aa4..fde641a 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -52,14 +52,14 @@ import Language.PureScript.TypeChecker.Monad (canonicalizeDataConstructor)
-- 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 @@ valueToJs _ m e (Constructor (Qualified Nothing name)) =
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 @@ varToJs m e qual@(Qualified _ ident) = go qual
-- 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)
-- |
@@ -326,24 +325,6 @@ isOnlyConstructor m e ctor =
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]
where
diff --git a/src/Language/PureScript/CodeGen/Optimize.hs b/src/Language/PureScript/CodeGen/Optimize.hs
index 63d77cc..199d41d 100644
--- a/src/Language/PureScript/CodeGen/Optimize.hs
+++ b/src/Language/PureScript/CodeGen/Optimize.hs
@@ -38,7 +38,8 @@ module Language.PureScript.CodeGen.Optimize (
) 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 @@ isReassigned var1 = everything (||) (mkQ False check)
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 @@ tco' = everywhere (mkT convert)
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 @@ inlineCommonOperators = applyAll
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
diff --git a/src/Language/PureScript/DeadCodeElimination.hs b/src/Language/PureScript/DeadCodeElimination.hs
index 6fb80a7..8de1cc4 100644
--- a/src/Language/PureScript/DeadCodeElimination.hs
+++ b/src/Language/PureScript/DeadCodeElimination.hs
@@ -30,12 +30,12 @@ import Language.PureScript.TypeChecker.Monad
-- |
-- 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 :: Environment -> Module -> [(Key, [Key])]
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 _ = []
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
index b13d4d9..934137c 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -42,7 +42,7 @@ data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable
-- |
-- 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
diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs
index bdc82f0..714e252 100644
--- a/src/Language/PureScript/ModuleDependencies.hs
+++ b/src/Language/PureScript/ModuleDependencies.hs
@@ -40,21 +40,21 @@ sortModules ms = do
-- |
-- 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
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index e232909..6fd6e0d 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -17,6 +17,7 @@
module Language.PureScript.Names where
+import Data.List
import Data.Data
import Data.Function (on)
@@ -64,10 +65,13 @@ instance Show ProperName where
-- |
-- 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 @@ data Qualified a = Qualified (Maybe ModuleName) a deriving (Eq, Ord, Data, Typea
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
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index 7ea2711..c998e65 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -49,7 +49,7 @@ reservedPsNames = [ "data"
, "true"
, "false"
, "until"
-
+ , "in"
]
-- |
@@ -204,14 +204,23 @@ properName :: P.Parsec String u ProperName
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
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 7858419..6571f28 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -89,7 +89,7 @@ parseImportDeclaration :: P.Parsec String ParseState Declaration
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 :: P.Parsec String ParseState Module
parseModule = do
reserved "module"
indented
- name <- properName
+ name <- moduleName
_ <- lexeme $ P.string "where"
decls <- mark (P.many (same *> parseDeclaration))
return $ Module name decls
diff --git a/src/Language/PureScript/Parser/Values.hs b/src/Language/PureScript/Parser/Values.hs
index 6d45baf..0ce9882 100644
--- a/src/Language/PureScript/Parser/Values.hs
+++ b/src/Language/PureScript/Parser/Values.hs
@@ -15,7 +15,6 @@
module Language.PureScript.Parser.Values (
parseValue,
- parseStatement,
parseGuard,
parseBinder,
parseBinderNoParens,
@@ -54,7 +53,7 @@ parseIdentifierAndValue = (,) <$> (C.indented *> C.identifier <* C.indented <* C
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 @@ parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parse
<*> (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
+ binder <- parseBinder
C.indented
- sts <- C.mark (P.many (C.same *> C.mark parseStatement))
- _ <- C.lexeme (P.char '}')
- return sts) P.<?> "block"
+ 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 @@ parseValueAtom = P.choice
, 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 @@ parseValue =
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 @@ parseIdentifierAndBinder = do
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 :: P.Parsec String ParseState Binder
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
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index 1e47f52..f288174 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -38,7 +38,6 @@ literals = mkPattern match
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 @@ app = mkPattern match
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 @@ prettyPrintObjectPropertyBinder key binder = key ++ ": " ++ prettyPrintBinder bi
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
diff --git a/src/Language/PureScript/Scope.hs b/src/Language/PureScript/Scope.hs
index f473ba4..d6d0b0a 100644
--- a/src/Language/PureScript/Scope.hs
+++ b/src/Language/PureScript/Scope.hs
@@ -30,16 +30,12 @@ import Language.PureScript.CodeGen.JS.AST
-- 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 _ = []
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index 0a1c001..4d4a3d5 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -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.CaseDeclarations as S
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 :: [Module] -> Either String [Module]
desugar = desugarTypeClasses
>=> rebracket
>=> desugarDo
- >=> desugarCasesModule
+ >=> desugarLetBindings
+ >>> desugarCasesModule
>=> desugarTypeDeclarationsModule
>=> createBindingGroupsModule
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index ff92518..c933dc3 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -36,7 +36,7 @@ import Language.PureScript.Types
-- 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
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index 344d45e..3f02a72 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -20,6 +20,8 @@ module Language.PureScript.Sugar.CaseDeclarations (
) 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 @@ import Language.PureScript.Scope
-- 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 @@ makeCaseDeclaration ident alternatives =
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
diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs
index 35d2484..aedbe6d 100644
--- a/src/Language/PureScript/Sugar/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -33,7 +33,7 @@ desugarDo :: (Data d) => d -> Either String d
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 @@ desugarDo = everywhereM (mkM replace)
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
diff --git a/src/Language/PureScript/Sugar/Let.hs b/src/Language/PureScript/Sugar/Let.hs
new file mode 100644
index 0000000..a6c8d63
--- /dev/null
+++ b/src/Language/PureScript/Sugar/Let.hs
@@ -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
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index a103b25..16fc125 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -46,9 +46,9 @@ rebracket = go M.empty []
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
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 3c08625..90926f7 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -36,7 +36,7 @@ import Control.Arrow ((***))
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 :: [Module] -> Either String [Module]
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 @@ typeInstanceDictionaryDeclaration mn deps name ty decls = do
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 @@ typeInstanceDictionaryEntryDeclaration _ _ _ _ _ = error "Invalid declaration in
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
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 2d35e92..c206590 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -118,11 +118,11 @@ data Environment = Environment {
-- 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
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 3e9166d..01f302e 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -208,7 +208,7 @@ typesOf mainModuleName moduleName vals = do
-- 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 @@ infer' (Accessor prop val) = do
_ <- 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 @@ infer' (Var var) = do
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 @@ assignVariable name = do
_ -> 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 @@ check' val t@(ConstrainedType constraints ty) = do
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' v@(BooleanLiteral _) t | t == tyBoolean =
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 @@ check' (Accessor prop val) ty = do
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
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index c5e9dff..85d0d60 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -92,31 +92,31 @@ data Type
-- 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
diff --git a/src/Language/PureScript/Values.hs b/src/Language/PureScript/Values.hs
index 3049a01..9873c68 100644
--- a/src/Language/PureScript/Values.hs
+++ b/src/Language/PureScript/Values.hs
@@ -72,7 +72,7 @@ data Value
-- |
-- Function introduction
--
- | Abs Ident Value
+ | Abs (Either Ident Binder) Value
-- |
-- Function application
--
@@ -86,10 +86,6 @@ data Value
--
| 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 @@ data Value
--
| TypedValue Bool Value Type
-- |
+ -- A let binding
+ --
+ | Let Binder Value Value
+ -- |
-- A do-notation block
--
| Do [DoNotationElement]
@@ -172,57 +172,6 @@ data DoNotationElement
| 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
--
data Binder