summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-02-25 00:27:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-02-25 00:27:00 (GMT)
commit4f0ee1881db1a659a4030d6a35487bd9c6d01379 (patch)
tree4959422111ff0253c9cdc8d852542b85329869ab
parent412228ecc467e2195eaa03bdac3fadb64e0b9cbe (diff)
version 0.4.2.10.4.2.1
-rw-r--r--docgen/Main.hs36
-rw-r--r--prelude/prelude.purs174
-rw-r--r--psc/Main.hs4
-rw-r--r--psci/Commands.hs68
-rw-r--r--psci/Main.hs244
-rw-r--r--psci/Parser.hs92
-rw-r--r--purescript.cabal9
-rw-r--r--src/Data/Generics/Extras.hs35
-rw-r--r--src/Language/PureScript.hs34
-rw-r--r--src/Language/PureScript/CodeGen/Common.hs118
-rw-r--r--src/Language/PureScript/CodeGen/Externs.hs4
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs26
-rw-r--r--src/Language/PureScript/CodeGen/Monad.hs1
-rw-r--r--src/Language/PureScript/CodeGen/Optimize.hs56
-rw-r--r--src/Language/PureScript/DeadCodeElimination.hs10
-rw-r--r--src/Language/PureScript/Declarations.hs22
-rw-r--r--src/Language/PureScript/ModuleDependencies.hs5
-rw-r--r--src/Language/PureScript/Names.hs8
-rw-r--r--src/Language/PureScript/Options.hs2
-rw-r--r--src/Language/PureScript/Parser/Common.hs4
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs21
-rw-r--r--src/Language/PureScript/Parser/Types.hs18
-rw-r--r--src/Language/PureScript/Parser/Values.hs19
-rw-r--r--src/Language/PureScript/Pretty/JS.hs24
-rw-r--r--src/Language/PureScript/Pretty/Types.hs6
-rw-r--r--src/Language/PureScript/Pretty/Values.hs6
-rw-r--r--src/Language/PureScript/Scope.hs6
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs6
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs2
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs20
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs72
-rw-r--r--src/Language/PureScript/TypeChecker.hs24
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs12
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs20
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs112
-rw-r--r--src/Language/PureScript/Types.hs28
-rw-r--r--src/Language/PureScript/Values.hs8
-rw-r--r--tests/Main.hs12
38 files changed, 816 insertions, 552 deletions
diff --git a/docgen/Main.hs b/docgen/Main.hs
index ed8d46e..bf817b5 100644
--- a/docgen/Main.hs
+++ b/docgen/Main.hs
@@ -60,7 +60,7 @@ renderModules ms = do
renderModule :: P.Module -> Docs
renderModule (P.Module moduleName ds) = do
- headerLevel 2 $ "Module " ++ (P.runModuleName moduleName)
+ headerLevel 2 $ "Module " ++ P.runModuleName moduleName
spacer
headerLevel 3 "Types"
spacer
@@ -90,23 +90,23 @@ renderDeclaration n (P.TypeDeclaration ident ty) =
renderDeclaration n (P.ExternDeclaration _ ident _ ty) =
atIndent n $ show ident ++ " :: " ++ P.prettyPrintType ty
renderDeclaration n (P.DataDeclaration name args ctors) = do
- let typeName = P.runProperName name ++ " " ++ intercalate " " args
+ let typeName = P.runProperName name ++ " " ++ unwords args
atIndent n $ "data " ++ typeName ++ " where"
- forM_ ctors $ \(ctor, tys) -> do
- atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ concat (map (\ty -> P.prettyPrintType ty ++ " -> ") tys) ++ typeName
+ forM_ ctors $ \(ctor, tys) ->
+ atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ concatMap (\ty -> P.prettyPrintType ty ++ " -> ") tys ++ typeName
renderDeclaration n (P.ExternDataDeclaration name kind) =
atIndent n $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind
renderDeclaration n (P.TypeSynonymDeclaration name args ty) = do
- let typeName = P.runProperName name ++ " " ++ intercalate " " args
+ let typeName = P.runProperName name ++ " " ++ unwords args
atIndent n $ "type " ++ typeName ++ " = " ++ P.prettyPrintType ty
-renderDeclaration n (P.TypeClassDeclaration name arg ds) = do
- atIndent n $ "class " ++ P.runProperName name ++ " " ++ arg ++ " where"
+renderDeclaration n (P.TypeClassDeclaration name args ds) = do
+ atIndent n $ "class " ++ P.runProperName name ++ " " ++ unwords args ++ " where"
mapM_ (renderDeclaration (n + 2)) ds
-renderDeclaration n (P.TypeInstanceDeclaration constraints name ty _) = do
+renderDeclaration n (P.TypeInstanceDeclaration constraints name tys _) = do
let constraintsText = case constraints of
[] -> ""
- cs -> "(" ++ intercalate "," (map (\(pn, ty') -> show pn ++ " (" ++ P.prettyPrintType ty' ++ ")") cs) ++ ") => "
- atIndent n $ constraintsText ++ "instance " ++ show name ++ " " ++ P.prettyPrintType ty
+ cs -> "(" ++ intercalate "," (map (\(pn, tys') -> show pn ++ " (" ++ unwords (map (("(" ++) . (++ ")") . P.prettyPrintType) tys') ++ ")") cs) ++ ") => "
+ atIndent n $ constraintsText ++ "instance " ++ show name ++ " " ++ unwords (map (("(" ++) . (++ ")") . P.prettyPrintType) tys)
renderDeclaration _ _ = return ()
getName :: P.Declaration -> String
@@ -120,22 +120,22 @@ getName (P.TypeInstanceDeclaration _ name _ _) = show name
getName _ = error "Invalid argument to getName"
isValueDeclaration :: P.Declaration -> Bool
-isValueDeclaration (P.TypeDeclaration _ _) = True
-isValueDeclaration (P.ExternDeclaration _ _ _ _) = True
+isValueDeclaration P.TypeDeclaration{} = True
+isValueDeclaration P.ExternDeclaration{} = True
isValueDeclaration _ = False
isTypeDeclaration :: P.Declaration -> Bool
-isTypeDeclaration (P.DataDeclaration _ _ _) = True
-isTypeDeclaration (P.ExternDataDeclaration _ _) = True
-isTypeDeclaration (P.TypeSynonymDeclaration _ _ _) = True
+isTypeDeclaration P.DataDeclaration{} = True
+isTypeDeclaration P.ExternDataDeclaration{} = True
+isTypeDeclaration P.TypeSynonymDeclaration{} = True
isTypeDeclaration _ = False
isTypeClassDeclaration :: P.Declaration -> Bool
-isTypeClassDeclaration (P.TypeClassDeclaration _ _ _) = True
+isTypeClassDeclaration P.TypeClassDeclaration{} = True
isTypeClassDeclaration _ = False
isTypeInstanceDeclaration :: P.Declaration -> Bool
-isTypeInstanceDeclaration (P.TypeInstanceDeclaration _ _ _ _) = True
+isTypeInstanceDeclaration P.TypeInstanceDeclaration{} = True
isTypeInstanceDeclaration _ = False
inputFile :: Term FilePath
@@ -147,7 +147,7 @@ term = docgen <$> inputFile
termInfo :: TermInfo
termInfo = defTI
{ termName = "docgen"
- , version = showVersion $ Paths.version
+ , version = showVersion Paths.version
, termDoc = "Generate Markdown documentation from PureScript extern files"
}
diff --git a/prelude/prelude.purs b/prelude/prelude.purs
index b22d78b..fea92d2 100644
--- a/prelude/prelude.purs
+++ b/prelude/prelude.purs
@@ -162,17 +162,14 @@ module Prelude where
-- Referential equality
data Ref a = Ref a
- foreign import refEq "function refEq(r1) {\
- \ return function(r2) {\
- \ return r1.values[0] === r2.values[0];\
- \ };\
- \}" :: forall a. Ref a -> Ref a -> Boolean
-
- foreign import refIneq "function refIneq(r1) {\
- \ return function(r2) {\
- \ return r1.values[0] !== r2.values[0];\
- \ };\
- \}" :: forall a. Ref a -> Ref a -> Boolean
+ liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b
+ liftRef f (Ref x) (Ref y) = f x y
+
+ refEq :: forall a. Ref a -> Ref a -> Boolean
+ refEq = liftRef unsafeRefEq
+
+ refIneq :: forall a. Ref a -> Ref a -> Boolean
+ refIneq = liftRef unsafeRefIneq
foreign import unsafeRefEq "function unsafeRefEq(r1) {\
\ return function(r2) {\
@@ -356,9 +353,10 @@ module Prelude where
\ };\
\}" :: String -> String -> String
-module Monoid where
+module Data.Monoid where
import Prelude
+ import Data.Array (foldl)
infixr 6 <>
@@ -372,16 +370,15 @@ module Monoid where
instance Monoid [a] where
mempty = []
- (<>) = Arrays.concat
+ (<>) = Data.Array.concat
mconcat :: forall m. (Monoid m) => [m] -> m
- mconcat [] = mempty
- mconcat (m:ms) = m <> mconcat ms
+ mconcat = foldl (<>) mempty
-module Monad where
+module Control.Monad where
import Prelude
- import Arrays
+ import Data.Array
replicateM :: forall m a. (Monad m) => Number -> m a -> m [a]
replicateM 0 _ = return []
@@ -428,7 +425,7 @@ module Monad where
when true m = m
when false _ = return {}
-module Maybe where
+module Data.Maybe where
import Prelude
@@ -458,7 +455,7 @@ module Maybe where
show (Just x) = "Just " ++ (show x)
show Nothing = "Nothing"
-module Either where
+module Data.Either where
import Prelude
@@ -485,24 +482,18 @@ module Either where
show (Left x) = "Left " ++ (show x)
show (Right y) = "Right " ++ (show y)
-module Arrays where
+module Data.Array where
import Prelude
- import Maybe
+ import Data.Maybe
- head :: forall a. [a] -> a
- head (x : _) = x
-
- headSafe :: forall a. [a] -> Maybe a
- headSafe (x : _) = Just x
- headSafe _ = Nothing
-
- tail :: forall a. [a] -> [a]
- tail (_ : xs) = xs
+ head :: forall a. [a] -> Maybe a
+ head (x : _) = Just x
+ head _ = Nothing
- tailSafe :: forall a. [a] -> Maybe [a]
- tailSafe (_ : xs) = Just xs
- tailSafe _ = Nothing
+ tail :: forall a. [a] -> Maybe [a]
+ tail (_ : xs) = Just xs
+ tail _ = Nothing
map :: forall a b. (a -> b) -> [a] -> [b]
map _ [] = []
@@ -512,9 +503,9 @@ module Arrays where
foldr f a (b : bs) = f (foldr f a bs) b
foldr _ a [] = a
- foldl :: forall a b. (a -> b -> b) -> b -> [a] -> b
+ foldl :: forall a b. (b -> a -> b) -> b -> [a] -> b
foldl _ b [] = b
- foldl f b (a:as) = foldl f (f a b) as
+ foldl f b (a:as) = foldl f (f b a) as
foreign import length "function length(xs) {\
\ return xs.length;\
@@ -582,15 +573,38 @@ module Arrays where
\ return l1;\
\}" :: forall a. [a] -> [a]
- foreign import splice "function splice(s) {\
- \ return function(e) {\
- \ return function(l1) {\
- \ return function(l2) {\
- \ return l2.splice(s, e, l1);\
- \ }; \
- \ }; \
- \ };\
- \}":: forall a. Number -> Number -> [a] -> [a] -> [a]
+ foreign import insertAt
+ "function insertAt(index) {\
+ \ return function(a) {\
+ \ return function(l) {\
+ \ var l1 = l.slice();\
+ \ l1.splice(index, 0, a);\
+ \ return l1;\
+ \ }; \
+ \ };\
+ \}":: forall a. Number -> a -> [a] -> [a]
+
+ foreign import deleteAt
+ "function deleteAt(index) {\
+ \ return function(n) {\
+ \ return function(l) {\
+ \ var l1 = l.slice();\
+ \ l1.splice(index, n);\
+ \ return l1;\
+ \ }; \
+ \ };\
+ \}":: forall a. Number -> Number -> [a] -> [a]
+
+ foreign import updateAt
+ "function updateAt(index) {\
+ \ return function(a) {\
+ \ return function(l) {\
+ \ var l1 = l.slice();\
+ \ l1[index] = a;\
+ \ return l1;\
+ \ }; \
+ \ };\
+ \}":: forall a. Number -> a -> [a] -> [a]
infixr 6 :
@@ -647,11 +661,19 @@ module Arrays where
instance Prelude.Alternative [] where
empty = []
(<|>) = concat
+
+module Data.Array.Unsafe where
+
+ head :: forall a. [a] -> a
+ head (x : _) = x
-module Tuples where
+ tail :: forall a. [a] -> [a]
+ tail (_ : xs) = xs
+
+module Data.Tuple where
import Prelude
- import Arrays
+ import Data.Array
data Tuple a b = Tuple a b
@@ -672,7 +694,7 @@ module Tuples where
Tuple as bs -> Tuple (a : as) (b : bs)
unzip [] = Tuple [] []
-module String where
+module Data.String where
foreign import lengthS "function lengthS(s) {\
\ return s.length;\
@@ -752,7 +774,7 @@ module String where
\ return s.trim();\
\}" :: String -> String
-module Regex where
+module Data.String.Regex where
foreign import data Regex :: *
@@ -907,7 +929,7 @@ module Math where
foreign import sqrt1_2 "var sqrt1_2 = Math.SQRT1_2;" :: Number
foreign import sqrt2 "var sqrt2 = Math.SQRT2;" :: Number
-module Eff where
+module Control.Monad.Eff where
foreign import data Eff :: # ! -> * -> *
@@ -936,29 +958,29 @@ module Eff where
(>>=) = bindEff
foreign import untilE "function untilE(f) {\
- \ return function() {\
- \ while (!f()) { }\
- \ return {};\
- \ };\
+ \ return function() {\
+ \ while (!f()) { }\
+ \ return {};\
+ \ };\
\}" :: forall e. Eff e Boolean -> Eff e {}
foreign import whileE "function whileE(f) {\
- \ return function(a) {\
- \ return function() {\
- \ while (f()) {\
+ \ return function(a) {\
+ \ return function() {\
+ \ while (f()) {\
\ a();\
\ }\
- \ return {};\
+ \ return {};\
\ };\
\ };\
\}" :: forall e a. Eff e Boolean -> Eff e a -> Eff e {}
foreign import forE "function forE(lo) {\
- \ return function(hi) {\
- \ return function(f) {\
- \ return function() {\
- \ for (var i = lo; i < hi; i++) {\
- \ f(i)();\
+ \ return function(hi) {\
+ \ return function(f) {\
+ \ return function() {\
+ \ for (var i = lo; i < hi; i++) {\
+ \ f(i)();\
\ }\
\ };\
\ };\
@@ -967,9 +989,9 @@ module Eff where
foreign import foreachE "function foreachE(as) {\
- \ return function(f) {\
- \ for (var i = 0; i < as.length; i++) {\
- \ f(as[i])();\
+ \ return function(f) {\
+ \ for (var i = 0; i < as.length; i++) {\
+ \ f(as[i])();\
\ }\
\ };\
\}" :: forall e a. [a] -> (a -> Eff e {}) -> Eff e {}
@@ -977,7 +999,7 @@ module Eff where
module Random where
- import Eff
+ import Control.Monad.Eff
foreign import data Random :: !
@@ -985,9 +1007,9 @@ module Random where
\ return Math.random();\
\}" :: forall e. Eff (random :: Random | e) Number
-module Errors where
+module Control.Monad.Error where
- import Eff
+ import Control.Monad.Eff
foreign import data Error :: * -> !
@@ -1009,9 +1031,9 @@ module Errors where
\ };\
\}" :: forall e r a. (e -> Eff r a) -> Eff (err :: Error e | r) a -> Eff r a
-module IORef where
+module Data.IORef where
- import Eff
+ import Control.Monad.Eff
foreign import data Ref :: !
@@ -1052,10 +1074,10 @@ module IORef where
\ return f;\
\}" :: forall eff a. Eff (ref :: Ref | eff) a -> Eff eff a
-module Trace where
+module Debug.Trace where
import Prelude
- import Eff
+ import Control.Monad.Eff
foreign import data Trace :: !
@@ -1069,9 +1091,9 @@ module Trace where
print :: forall a r. (Prelude.Show a) => a -> Eff (trace :: Trace | r) {}
print o = trace (show o)
-module ST where
+module Control.Monad.ST where
- import Eff
+ import Control.Monad.Eff
foreign import data ST :: * -> !
@@ -1145,9 +1167,9 @@ module ST where
\ return f;\
\}" :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r [a]
-module Enum where
+module Data.Enum where
- import Maybe
+ import Data.Maybe
class Enum a where
toEnum :: Number -> Maybe a
diff --git a/psc/Main.hs b/psc/Main.hs
index 15dc7e2..86baae9 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -28,7 +28,7 @@ preludeFilename :: IO FilePath
preludeFilename = Paths.getDataFileName "prelude/prelude.purs"
readInput :: Maybe [FilePath] -> IO (Either ParseError [P.Module])
-readInput Nothing = getContents >>= return . P.runIndentParser "" P.parseModules
+readInput Nothing = P.runIndentParser "" P.parseModules <$> getContents
readInput (Just input) = fmap (fmap concat . sequence) $ forM input $ \inputFile -> do
text <- U.readFile inputFile
return $ P.runIndentParser inputFile P.parseModules text
@@ -118,7 +118,7 @@ term prelude = compile <$> options <*> stdInOrInputFiles prelude <*> outputFile
termInfo :: TermInfo
termInfo = defTI
{ termName = "psc"
- , version = showVersion $ Paths.version
+ , version = showVersion Paths.version
, termDoc = "Compiles PureScript to Javascript"
}
diff --git a/psci/Commands.hs b/psci/Commands.hs
new file mode 100644
index 0000000..28fc2b8
--- /dev/null
+++ b/psci/Commands.hs
@@ -0,0 +1,68 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Commands
+-- Copyright : (c) Phil Freeman 2014
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+-- Commands for PSCI.
+--
+-----------------------------------------------------------------------------
+
+module Commands where
+
+import Language.PureScript
+
+-- |
+-- Valid Meta-commands for PSCI
+--
+data Command
+ -- |
+ -- A purescript expression
+ --
+ = Expression Value
+ -- |
+ -- Show the help command
+ --
+ | Help
+ -- |
+ -- Import a module from a loaded file
+ --
+ | Import ModuleName
+ -- |
+ -- Load a file for use with importing
+ --
+ | LoadFile FilePath
+ -- |
+ -- Exit PSCI
+ --
+ | Quit
+ -- |
+ -- Reset the state of the REPL
+ --
+ | Reset
+ -- |
+ -- Binds a value to a name
+ --
+ | Let (Value -> Value)
+ -- |
+ -- Find the type of an expression
+ --
+ | TypeOf Value
+
+-- |
+-- The help menu.
+--
+help :: [[String]]
+help =
+ [ [":? ", "Show this help menu"]
+ , [":i <module> ", "Import <module> for use in PSCI"]
+ , [":m <file> ", "Load <file> for importing"]
+ , [":q ", "Quit PSCi"]
+ , [":r ", "Reset"]
+ , [":t <expr> ", "Show the type of <expr>"]
+ ]
diff --git a/psci/Main.hs b/psci/Main.hs
index 8909369..d29d294 100644
--- a/psci/Main.hs
+++ b/psci/Main.hs
@@ -13,7 +13,7 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DoAndIfThenElse, FlexibleContexts #-}
module Main where
@@ -23,22 +23,29 @@ import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
-import Control.Monad.Trans.State
+import Control.Monad.Trans.State.Strict
-import Data.List (intercalate, isPrefixOf, nub, sort)
+import Data.List (intercalate, isPrefixOf, nub, sortBy)
import Data.Maybe (mapMaybe)
import Data.Traversable (traverse)
+import Data.Version (showVersion)
+
+import Parser
import System.Console.Haskeline
-import System.Directory (findExecutable)
+import System.Directory (doesFileExist, findExecutable, getHomeDirectory)
import System.Exit
import System.Environment.XDG.BaseDir
+import System.FilePath ((</>), isPathSeparator)
+import qualified System.Console.CmdTheLine as Cmd
import System.Process
+import Text.Parsec (ParseError)
+
+import qualified Data.Map as M
import qualified Language.PureScript as P
import qualified Paths_purescript as Paths
import qualified System.IO.UTF8 as U (readFile)
-import qualified Text.Parsec as Parsec (Parsec, eof)
-- |
-- The PSCI state.
@@ -46,48 +53,45 @@ import qualified Text.Parsec as Parsec (Parsec, eof)
-- The let bindings are partial,
-- because it makes more sense to apply the binding to the final evaluated expression.
--
-data PSCI = PSCI [P.ProperName] [P.Module] [P.Value -> P.Value]
+data PSCiState = PSCiState
+ { psciImportedFilenames :: [FilePath]
+ , psciImportedModuleNames :: [P.ModuleName]
+ , psciLoadedModules :: [P.Module]
+ , psciLetBindings :: [P.Value -> P.Value]
+ }
-- State helpers
-- |
--- Synonym to be more descriptive.
--- This is just @lift@
---
-inputTToState :: InputT IO a -> StateT PSCI (InputT IO) a
-inputTToState = lift
-
--- |
--- Synonym to be more descriptive.
--- This is just @lift . lift@
+-- Updates the state to have more imported modules.
--
-ioToState :: IO a -> StateT PSCI (InputT IO) a
-ioToState = lift . lift
+updateImportedFiles :: FilePath -> PSCiState -> PSCiState
+updateImportedFiles filename st = st { psciImportedFilenames = filename : psciImportedFilenames st }
-- |
-- Updates the state to have more imported modules.
--
-updateImports :: String -> PSCI -> PSCI
-updateImports name (PSCI i m b) = PSCI (i ++ [P.ProperName name]) m b
+updateImports :: P.ModuleName -> PSCiState -> PSCiState
+updateImports name st = st { psciImportedModuleNames = name : psciImportedModuleNames st }
-- |
-- Updates the state to have more loaded files.
--
-updateModules :: [P.Module] -> PSCI -> PSCI
-updateModules modules (PSCI i m b) = PSCI i (m ++ modules) b
+updateModules :: [P.Module] -> PSCiState -> PSCiState
+updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules }
-- |
-- Updates the state to have more let bindings.
--
-updateLets :: (P.Value -> P.Value) -> PSCI -> PSCI
-updateLets name (PSCI i m b) = PSCI i m (b ++ [name])
+updateLets :: (P.Value -> P.Value) -> PSCiState -> PSCiState
+updateLets name st = st { psciLetBindings = psciLetBindings st ++ [name] }
-- File helpers
-- |
-- Load the necessary modules.
--
-defaultImports :: [P.ProperName]
-defaultImports = [P.ProperName "Prelude"]
+defaultImports :: [P.ModuleName]
+defaultImports = [P.ModuleName [P.ProperName "Prelude"]]
-- |
-- Locates the node executable.
@@ -95,7 +99,7 @@ defaultImports = [P.ProperName "Prelude"]
--
findNodeProcess :: IO (Maybe String)
findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
- where names = ["nodejs", "node"]
+ where names = ["nodejs", "node"]
-- |
-- Grabs the filename where the history is stored.
@@ -113,10 +117,14 @@ getPreludeFilename = Paths.getDataFileName "prelude/prelude.purs"
-- Loads a file for use with imports.
--
loadModule :: FilePath -> IO (Either String [P.Module])
-loadModule moduleFile = do
- moduleText <- U.readFile moduleFile
- return . either (Left . show) Right $ P.runIndentParser "" P.parseModules moduleText
+loadModule filename = either (Left . show) Right . P.runIndentParser filename P.parseModules <$> U.readFile filename
+-- |
+-- Expands tilde in path.
+--
+expandTilde :: FilePath -> IO FilePath
+expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory
+expandTilde p = return p
-- Messages
-- |
@@ -154,23 +162,27 @@ quitMessage = "See ya!"
-- |
-- Loads module, function, and file completions.
--
-completion :: [P.Module] -> CompletionFunc IO
-completion ms = completeWord Nothing " \t\n\r" findCompletions
+completion :: CompletionFunc (StateT PSCiState IO)
+completion = completeWord Nothing " \t\n\r" findCompletions
where
- findCompletions :: String -> IO [Completion]
+ findCompletions :: String -> StateT PSCiState IO [Completion]
findCompletions str = do
+ ms <- psciLoadedModules <$> get
files <- listFiles str
- let names = nub [ show qual
- | P.Module moduleName ds <- ms
- , ident <- mapMaybe getDeclName ds
- , qual <- [ P.Qualified Nothing ident
- , P.Qualified (Just moduleName) ident]
- ]
- let matches = sort $ filter (isPrefixOf str) names
- return $ map simpleCompletion matches ++ files
+ let matches = filter (isPrefixOf str) (names ms)
+ return $ sortBy sorter $ map simpleCompletion matches ++ files
getDeclName :: P.Declaration -> Maybe P.Ident
getDeclName (P.ValueDeclaration ident _ _ _) = Just ident
getDeclName _ = Nothing
+ names :: [P.Module] -> [String]
+ names ms = nub [ show qual
+ | P.Module moduleName ds <- ms
+ , ident <- mapMaybe getDeclName ds
+ , qual <- [ P.Qualified Nothing ident
+ , P.Qualified (Just moduleName) ident]
+ ]
+ sorter :: Completion -> Completion -> Ordering
+ sorter (Completion _ d1 _) (Completion _ d2 _) = compare d1 d2
-- Compilation
@@ -182,93 +194,129 @@ 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 =
+createTemporaryModule :: Bool -> [P.ModuleName] -> [P.Value -> P.Value] -> P.Value -> P.Module
+createTemporaryModule exec imports lets value =
let
moduleName = P.ModuleName [P.ProperName "Main"]
importDecl m = P.ImportDeclaration m Nothing
- traceModule = P.ModuleName [P.ProperName "Trace"]
+ traceModule = P.ModuleName [P.ProperName "Debug", P.ProperName "Trace"]
trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))
value' = foldr ($) value lets
- mainDecl = P.ValueDeclaration (P.Ident "main") [] Nothing (P.App trace value')
+ itDecl = P.ValueDeclaration (P.Ident "it") [] Nothing value'
+ mainDecl = P.ValueDeclaration (P.Ident "main") [] Nothing (P.App trace (P.Var (P.Qualified Nothing (P.Ident "it"))))
in
- P.Module moduleName $ map (importDecl . P.ModuleName . return) imports ++ [mainDecl]
+ P.Module moduleName $ map importDecl imports ++ if exec then [itDecl, mainDecl] else [itDecl]
-- |
-- Takes a value declaration and evaluates it with the current state.
--
-handleDeclaration :: P.Value -> PSCI -> InputT IO ()
-handleDeclaration value (PSCI imports loadedModules lets) = do
- let m = createTemporaryModule imports lets value
- case P.compile options (loadedModules ++ [m]) of
+handleDeclaration :: P.Value -> PSCiState -> InputT (StateT PSCiState IO) ()
+handleDeclaration value st = do
+ let m = createTemporaryModule True (psciImportedModuleNames st) (psciLetBindings st) value
+ case P.compile options (psciLoadedModules st ++ [m]) of
Left err -> outputStrLn err
Right (js, _, _) -> do
- process <- lift findNodeProcess
- result <- lift $ traverse (\node -> readProcessWithExitCode node [] js) process
+ process <- lift . lift $ findNodeProcess
+ result <- lift . lift $ traverse (\node -> readProcessWithExitCode node [] js) process
case result of
Just (ExitSuccess, out, _) -> outputStrLn out
Just (ExitFailure _, _, err) -> outputStrLn err
Nothing -> outputStrLn "Couldn't find node.js"
--- Parser helpers
-
-- |
--- Parser for our PSCI version of @let@.
--- This is essentially let from do-notation.
--- However, since we don't support the @Eff@ monad, we actually want the normal @let@.
+-- Takes a value and prints its type
--
-parseLet :: Parsec.Parsec String P.ParseState (P.Value -> P.Value)
-parseLet = P.Let <$> (P.reserved "let" *> P.indented *> P.parseBinder)
- <*> (P.indented *> P.reservedOp "=" *> P.parseValue)
+handleTypeOf :: P.Value -> PSCiState -> InputT (StateT PSCiState IO) ()
+handleTypeOf value st = do
+ let m = createTemporaryModule False (psciImportedModuleNames st) (psciLetBindings st) value
+ case P.compile options { P.optionsMain = Nothing } (psciLoadedModules st ++ [m]) of
+ Left err -> outputStrLn err
+ Right (_, _, env') ->
+ case M.lookup (P.ModuleName [P.ProperName "Main"], P.Ident "it") (P.names env') of
+ Just (ty, _) -> outputStrLn . P.prettyPrintType $ ty
+ Nothing -> outputStrLn "Could not find type"
+
+-- Commands
-- |
--- Parser for any other valid expression.
+-- Parses the input and returns either a Metacommand or an expression.
--
-parseExpression :: Parsec.Parsec String P.ParseState P.Value
-parseExpression = P.whiteSpace *> P.parseValue <* Parsec.eof
-
--- Commands
+getCommand :: InputT (StateT PSCiState IO) (Either ParseError (Maybe Command))
+getCommand = do
+ firstLine <- getInputLine "> "
+ case firstLine of
+ Nothing -> return (Right Nothing)
+ Just s@ (':' : _) -> return . either Left (Right . Just) $ parseCommand s -- The start of a command
+ Just s -> either Left (Right . Just) . parseCommand <$> go [s]
+ where
+ go :: [String] -> InputT (StateT PSCiState IO) String
+ go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " "
-- |
-- Performs an action for each meta-command given, and also for expressions..
--
-handleCommand :: Command -> StateT PSCI (InputT IO) ()
-handleCommand Empty = return ()
-handleCommand (Expression ls) =
- case P.runIndentParser "" parseLet (unlines ls) of
- Left _ ->
- case P.runIndentParser "" parseExpression (unlines ls) of
- Left err -> inputTToState $ outputStrLn (show err)
- Right decl -> get >>= inputTToState . handleDeclaration decl
- Right l -> modify (updateLets l)
-handleCommand Help = inputTToState $ outputStrLn helpMessage
-handleCommand (Import moduleName) = modify (updateImports moduleName)
+handleCommand :: Command -> InputT (StateT PSCiState IO) ()
+handleCommand (Expression val) = lift get >>= handleDeclaration val
+handleCommand (Let l) = lift $ modify (updateLets l)
+handleCommand Help = outputStrLn helpMessage
+handleCommand (Import moduleName) = lift $ modify (updateImports moduleName)
handleCommand (LoadFile filePath) = do
- mf <- ioToState $ loadModule filePath
- case mf of
- Left err -> inputTToState $ outputStrLn err
- Right mf' -> modify (updateModules mf')
-handleCommand Reload = do
- (Right prelude) <- ioToState $ getPreludeFilename >>= loadModule
- put (PSCI defaultImports prelude [])
-handleCommand _ = inputTToState $ outputStrLn "Unknown command"
+ absPath <- lift . lift $ expandTilde filePath
+ exists <- lift . lift $ doesFileExist absPath
+ if exists then do
+ lift $ modify (updateImportedFiles absPath)
+ either outputStrLn (lift . modify . updateModules) =<< (lift . lift $ loadModule absPath)
+ else
+ outputStrLn $ "Couldn't locate: " ++ filePath
+handleCommand Reset = do
+ preludeFilename <- lift . lift $ getPreludeFilename
+ files <- psciImportedFilenames <$> lift get
+ modulesOrFirstError <- fmap concat . sequence <$> mapM (lift . lift . loadModule) (preludeFilename : files)
+ case modulesOrFirstError of
+ Left err -> lift . lift $ putStrLn err >> exitFailure
+ Right modules -> lift $ put (PSCiState (preludeFilename : files) defaultImports modules [])
+handleCommand (TypeOf val) = lift get >>= handleTypeOf val
+handleCommand _ = outputStrLn "Unknown command"
+
+inputFiles :: Cmd.Term [FilePath]
+inputFiles = Cmd.value $ Cmd.posAny [] $ Cmd.posInfo { Cmd.posName = "file(s)"
+ , Cmd.posDoc = "Optional .purs files to load on start" }
-- |
-- The PSCI main loop.
--
-main :: IO ()
-main = do
+loop :: [FilePath] -> IO ()
+loop files = do
preludeFilename <- getPreludeFilename
- (Right prelude) <- loadModule preludeFilename
- historyFilename <- getHistoryFilename
- let settings = defaultSettings {historyFile = Just historyFilename}
- runInputT (setComplete (completion prelude) settings) $ do
- outputStrLn prologueMessage
- evalStateT go (PSCI defaultImports prelude [])
- where
- go :: StateT PSCI (InputT IO) ()
- go = do
- c <- inputTToState getCommand
- case c of
- Quit -> inputTToState $ outputStrLn quitMessage
- _ -> handleCommand c >> go
+ modulesOrFirstError <- fmap concat . sequence <$> mapM loadModule (preludeFilename : files)
+ case modulesOrFirstError of
+ Left err -> putStrLn err >> exitFailure
+ Right modules -> do
+ historyFilename <- getHistoryFilename
+ let settings = defaultSettings {historyFile = Just historyFilename}
+ flip evalStateT (PSCiState (preludeFilename : files) defaultImports modules []) . runInputT (setComplete completion settings) $ do
+ outputStrLn prologueMessage
+ go
+ where
+ go :: InputT (StateT PSCiState IO) ()
+ go = do
+ c <- getCommand
+ case c of
+ Left err -> outputStrLn (show err) >> go
+ Right Nothing -> go
+ Right (Just Quit) -> outputStrLn quitMessage
+ Right (Just c') -> handleCommand c' >> go
+
+term :: Cmd.Term (IO ())
+term = loop <$> inputFiles
+
+termInfo :: Cmd.TermInfo
+termInfo = Cmd.defTI
+ { Cmd.termName = "psci"
+ , Cmd.version = showVersion Paths.version
+ , Cmd.termDoc = "Interactive mode for PureScript"
+ }
+
+main :: IO ()
+main = Cmd.run (term, termInfo)
+
diff --git a/psci/Parser.hs b/psci/Parser.hs
new file mode 100644
index 0000000..e781683
--- /dev/null
+++ b/psci/Parser.hs
@@ -0,0 +1,92 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Parser
+-- Copyright : (c) Phil Freeman 2014
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+-- Parser for PSCI.
+--
+-----------------------------------------------------------------------------
+
+module Parser (
+ parseCommand
+ ) where
+
+import Commands
+
+import Data.Char (isSpace)
+
+import Control.Applicative hiding (many)
+
+import Text.Parsec hiding ((<|>))
+
+import qualified Language.PureScript as P
+
+-- |
+-- PSCI version of @let@.
+-- This is essentially let from do-notation.
+-- However, since we don't support the @Eff@ monad,
+-- we actually want the normal @let@.
+--
+psciLet :: Parsec String P.ParseState Command
+psciLet = Let <$> (P.Let <$> (P.reserved "let" *> P.indented *> P.parseBinder)
+ <*> (P.indented *> P.reservedOp "=" *> P.parseValue))
+
+-- |
+-- Parses PSCI metacommands or expressions input from the user.
+--
+parseCommand :: String -> Either ParseError Command
+parseCommand = P.runIndentParser "" $ choice
+ [ P.whiteSpace *> char ':' *> (psciHelp <|> psciImport <|> psciLoadFile <|> psciQuit <|> psciReload <|> psciTypeOf)
+ , try psciLet
+ , psciExpression
+ ] <* eof
+
+-- |
+-- Parses expressions entered at the PSCI repl.
+--
+psciExpression :: Parsec String P.ParseState Command
+psciExpression = Expression <$> P.parseValue
+
+-- |
+-- Parses 'Commands.Help' command.
+--
+psciHelp :: Parsec String P.ParseState Command
+psciHelp = Help <$ char '?'
+
+-- |
+-- Parses 'Commands.Import' command.
+--
+psciImport :: Parsec String P.ParseState Command
+psciImport = Import <$> (char 'i' *> P.whiteSpace *> P.moduleName)
+
+-- |
+-- Parses 'Commands.LoadFile' command.
+--
+psciLoadFile :: Parsec String P.ParseState Command
+psciLoadFile = LoadFile . trimEnd <$> (char 'm' *> P.whiteSpace *> manyTill anyChar eof)
+ where
+ trimEnd = reverse . dropWhile isSpace . reverse
+
+-- |
+-- Parses 'Commands.Quit' command.
+--
+psciQuit :: Parsec String P.ParseState Command
+psciQuit = Quit <$ char 'q'
+
+-- |
+-- Parses 'Commands.Reload' command.
+--
+psciReload :: Parsec String P.ParseState Command
+psciReload = Reset <$ char 'r'
+
+-- |
+-- Parses 'Commands.TypeOf' command.
+--
+psciTypeOf :: Parsec String P.ParseState Command
+psciTypeOf = TypeOf <$> (char 't' *> P.whiteSpace *> P.parseValue)
diff --git a/purescript.cabal b/purescript.cabal
index fa60a8c..37b7294 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.4.2
+version: 0.4.2.1
cabal-version: >=1.8
build-type: Custom
license: MIT
@@ -84,14 +84,15 @@ executable psc
ghc-options: -Wall -O2 -fno-warn-unused-do-bind
executable psci
- build-depends: base >=4 && <5, containers -any, directory -any,
+ build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
mtl -any, parsec -any, haskeline <=0.7.1.1, purescript -any,
syb -any, transformers -any, utf8-string -any, process -any,
- xdg-basedir -any
+ xdg-basedir -any, cmdtheline -any
main-is: Main.hs
buildable: True
hs-source-dirs: psci
- other-modules:
+ other-modules: Commands
+ Parser
ghc-options: -Wall -O2
executable docgen
diff --git a/src/Data/Generics/Extras.hs b/src/Data/Generics/Extras.hs
index 80ffede..f8f45b3 100644
--- a/src/Data/Generics/Extras.hs
+++ b/src/Data/Generics/Extras.hs
@@ -18,6 +18,7 @@
module Data.Generics.Extras where
import Data.Data
+import Data.Maybe (fromMaybe)
-- |
-- Apply a top-down monadic transformation everywhere
@@ -26,3 +27,37 @@ everywhereM' :: (Monad m, Data d) => (forall d1. (Data d1) => d1 -> m d1) -> d -
everywhereM' f x = do
y <- f x
gmapM (everywhereM' f) y
+
+-- |
+-- Apply a top-down transformation, mutating a state when descending from parents to children
+--
+-- For example, if we want to relabel bound variables with a different data constructor, we can do so:
+--
+-- > data Expr = Var String
+-- > | Lam String Test
+-- > | App Test Test
+-- > | LocalVar String deriving (Show, Data, Typeable)
+-- >
+-- > test = App (Lam "a" (App (Var "a") (Var "b"))) (Var "a")
+-- >
+-- > varsToLocals :: Expr -> Expr
+-- > varsToLocals = everywhereWithContext' [] (mkS go)
+-- > where
+-- > go locals (Var v) | v `elem` locals = (locals, LocalVar v)
+-- > go locals lam@(Lam local _) = (local : locals, lam)
+-- > go locals other = (locals, other)
+--
+everywhereWithContext' :: (Data d) => s -> (forall d1. (Data d1) => s -> d1 -> (s, d1)) -> d -> d
+everywhereWithContext' s0 f x =
+ let (s, y) = f s0 x in
+ gmapT (everywhereWithContext' s f) y
+
+-- |
+-- Make a stateful transformation function
+--
+mkS :: (Data a, Data b) => (s -> a -> (s, a)) -> s -> b -> (s, b)
+mkS f s b = fromMaybe (s, b) $ do
+ a <- cast b
+ let (s', a') = f s a
+ b' <- cast a'
+ return (s', b')
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index b8378cb..5b2f7cf 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -22,6 +22,7 @@ import Language.PureScript.Declarations as P
import Language.PureScript.Names as P
import Language.PureScript.Parser as P
import Language.PureScript.CodeGen as P
+import Language.PureScript.CodeGen.Common as P
import Language.PureScript.TypeChecker as P
import Language.PureScript.Pretty as P
import Language.PureScript.Sugar as P
@@ -30,10 +31,9 @@ import Language.PureScript.ModuleDependencies as P
import Language.PureScript.DeadCodeElimination as P
import Data.List (intercalate)
-import Data.Maybe (mapMaybe, fromMaybe)
-import Control.Monad (when, forM)
+import Data.Maybe (mapMaybe)
import Control.Monad.State.Lazy
-import Control.Applicative ((<$>), (<|>))
+import Control.Applicative ((<$>))
import qualified Data.Map as M
-- |
@@ -59,24 +59,20 @@ compile :: Options -> [Module] -> Either String (String, String, Environment)
compile opts ms = do
sorted <- sortModules ms
desugared <- desugar sorted
- (elaborated, env) <- runCheck $ forM desugared $ \(Module moduleName decls) -> do
- modify (\s -> s { checkCurrentModule = Just moduleName })
- Module moduleName <$> typeCheckAll mainModuleIdent moduleName decls
+ (elaborated, env) <- runCheck $ forM desugared $ \(Module moduleName' decls) -> do
+ modify (\s -> s { checkCurrentModule = Just moduleName' })
+ Module moduleName' <$> typeCheckAll mainModuleIdent moduleName' decls
regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
- let entryPoints = (ModuleName . splitProperNames) `map` optionsModules opts
+ let entryPoints = moduleNameFromString `map` optionsModules opts
let elim = if null entryPoints then regrouped else eliminateDeadCode env entryPoints regrouped
let js = mapMaybe (flip (moduleToJs opts) env) elim
- let exts = intercalate "\n" . map (flip moduleToPs env) $ elim
- js' <- case optionsMain opts of
- Just mainModuleName -> do
- when ((ModuleName [ProperName mainModuleName], Ident "main") `M.notMember` (names env)) $
- Left $ mainModuleName ++ ".main is undefined"
- return $ js ++ [JSApp (JSAccessor "main" (JSAccessor mainModuleName (JSVar "_ps"))) []]
+ let exts = intercalate "\n" . map (`moduleToPs` env) $ elim
+ js' <- case mainModuleIdent of
+ Just mmi -> do
+ when ((mmi, Ident "main") `M.notMember` names env) $
+ Left $ show mmi ++ ".main is undefined"
+ return $ js ++ [JSApp (JSAccessor "main" (JSAccessor (moduleNameToJs mmi) (JSVar "_ps"))) []]
_ -> return js
- return (prettyPrintJS [(wrapExportsContainer opts js')], exts, env)
+ return (prettyPrintJS [wrapExportsContainer opts js'], exts, env)
where
- mainModuleIdent = ModuleName . splitProperNames <$> optionsMain opts
- splitProperNames s = case dropWhile (== '.') s of
- "" -> []
- s' -> ProperName w : splitProperNames s''
- where (w, s'') = break (== '.') s'
+ mainModuleIdent = moduleNameFromString <$> optionsMain opts
diff --git a/src/Language/PureScript/CodeGen/Common.hs b/src/Language/PureScript/CodeGen/Common.hs
index 0766256..288ba23 100644
--- a/src/Language/PureScript/CodeGen/Common.hs
+++ b/src/Language/PureScript/CodeGen/Common.hs
@@ -69,64 +69,66 @@ identCharToString c = '$' : show (ord c)
--
nameIsJsReserved :: String -> Bool
nameIsJsReserved name =
- elem name [ "abstract"
- , "boolean"
- , "break"
- , "byte"
- , "case"
- , "catch"
- , "char"
- , "class"
- , "const"
- , "continue"
- , "debugger"
- , "default"
- , "delete"
- , "do"
- , "double"
- , "else"
- , "enum"
- , "export"
- , "extends"
- , "final"
- , "finally"
- , "float"
- , "for"
- , "function"
- , "goto"
- , "if"
- , "implements"
- , "import"
- , "in"
- , "instanceof"
- , "int"
- , "interface"
- , "let"
- , "long"
- , "native"
- , "new"
- , "package"
- , "private"
- , "protected"
- , "public"
- , "return"
- , "short"
- , "static"
- , "super"
- , "switch"
- , "synchronized"
- , "this"
- , "throw"
- , "throws"
- , "transient"
- , "try"
- , "typeof"
- , "var"
- , "void"
- , "volatile"
- , "while"
- , "with"
- , "yield" ]
+ name `elem` [ "abstract"
+ , "arguments"
+ , "boolean"
+ , "break"
+ , "byte"
+ , "case"
+ , "catch"
+ , "char"
+ , "class"
+ , "const"
+ , "continue"
+ , "debugger"
+ , "default"
+ , "delete"
+ , "do"
+ , "double"
+ , "else"
+ , "enum"
+ , "eval"
+ , "export"
+ , "extends"
+ , "final"
+ , "finally"
+ , "float"
+ , "for"
+ , "function"
+ , "goto"
+ , "if"
+ , "implements"
+ , "import"
+ , "in"
+ , "instanceof"
+ , "int"
+ , "interface"
+ , "let"
+ , "long"
+ , "native"
+ , "new"
+ , "package"
+ , "private"
+ , "protected"
+ , "public"
+ , "return"
+ , "short"
+ , "static"
+ , "super"
+ , "switch"
+ , "synchronized"
+ , "this"
+ , "throw"
+ , "throws"
+ , "transient"
+ , "try"
+ , "typeof"
+ , "var"
+ , "void"
+ , "volatile"
+ , "while"
+ , "with"
+ , "yield" ]
moduleNameToJs :: ModuleName -> String
moduleNameToJs (ModuleName pns) = intercalate "_" (runProperName `map` pns)
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
index 52c6f2b..facf5e6 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -30,14 +30,14 @@ import Data.List (intercalate)
--
moduleToPs :: Module -> Environment -> String
moduleToPs (Module mn decls) env =
- "module " ++ (runModuleName mn) ++ " where\n" ++
+ "module " ++ runModuleName mn ++ " where\n" ++
(intercalate "\n" . map (" " ++) . concatMap (declToPs mn env) $ decls)
declToPs :: ModuleName -> Environment -> Declaration -> [String]
declToPs path env (ValueDeclaration name _ _ _) = maybeToList $ do
(ty, _) <- M.lookup (path, name) $ names env
return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty
-declToPs path env (BindingGroupDeclaration vals) = do
+declToPs path env (BindingGroupDeclaration vals) =
flip mapMaybe vals $ \(name, _) -> do
(ty, _) <- M.lookup (path, name) $ names env
return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index fde641a..ff9e47a 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -23,7 +23,6 @@ module Language.PureScript.CodeGen.JS (
) where
import Data.Maybe (fromMaybe, mapMaybe)
-import Data.List (sortBy)
import Data.Function (on)
import Data.Data (Data)
import Data.Generics (mkQ, everything)
@@ -38,7 +37,6 @@ import Language.PureScript.Values
import Language.PureScript.Names
import Language.PureScript.Scope
import Language.PureScript.Declarations
-import Language.PureScript.Pretty.Common
import Language.PureScript.CodeGen.Monad
import Language.PureScript.Options
import Language.PureScript.CodeGen.JS.AST as AST
@@ -57,16 +55,16 @@ moduleToJs opts (Module name decls) env =
[] -> Nothing
_ -> Just $ JSAssignment (JSAccessor (moduleNameToJs name) (JSVar "_ps")) $
JSApp (JSFunction Nothing ["module"] (JSBlock $ jsDecls ++ [JSReturn $ JSVar "module"]))
- [(JSBinary Or (JSAccessor (moduleNameToJs name) (JSVar "_ps")) (JSObjectLiteral []))]
+ [JSBinary Or (JSAccessor (moduleNameToJs name) (JSVar "_ps")) (JSObjectLiteral [])]
where
- jsDecls = (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts name decl env) (decls))
+ jsDecls = concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts name decl env) decls
-- |
-- Generate code in the simplified Javascript intermediate representation for a declaration
--
declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS]
declToJs opts mp (ValueDeclaration ident _ _ val) e =
- Just $ [ JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))
+ Just [ JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))
, setExportProperty ident (var ident) ]
declToJs opts mp (BindingGroupDeclaration vals) e =
Just $ concatMap (\(ident, val) ->
@@ -85,8 +83,8 @@ declToJs _ mp (DataDeclaration _ _ ctors) _ =
(JSBlock [JSReturn (go pn (index + 1) tys' (JSVar ("value" ++ show index) : values))])
declToJs opts mp (DataBindingGroupDeclaration ds) e =
Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds
-declToJs _ mp (ExternDeclaration importTy ident (Just js) _) _ =
- Just $ [js, setExportProperty ident (var ident)]
+declToJs _ _ (ExternDeclaration _ ident (Just js) _) _ =
+ Just [js, setExportProperty ident (var ident)]
declToJs _ _ _ _ = Nothing
-- |
@@ -94,7 +92,7 @@ declToJs _ _ _ _ = Nothing
-- declaration from a module.
--
setExportProperty :: Ident -> JS -> JS
-setExportProperty ident val = JSAssignment (accessor ident (JSVar "module")) val
+setExportProperty ident = JSAssignment (accessor ident (JSVar "module"))
-- |
-- Generate code in the simplified Javascript intermediate representation for a variable based on a
@@ -194,12 +192,12 @@ runtimeTypeChecks arg ty =
varToJs :: ModuleName -> Environment -> Qualified Ident -> JS
varToJs m e qual@(Qualified _ ident) = go qual
where
- go qual = case M.lookup (qualify m qual) (names e) of
+ go qual' = case M.lookup (qualify m qual') (names e) of
Just (_, ty) | isExtern ty -> var ident
Just (_, Alias aliasModule aliasIdent) -> go (Qualified (Just aliasModule) aliasIdent)
- _ -> case qual of
+ _ -> case qual' of
Qualified Nothing _ -> var ident
- _ -> qualifiedToJS m id qual
+ _ -> qualifiedToJS m id qual'
isExtern (Extern ForeignImport) = True
isExtern (Alias m' ident') = case M.lookup (m', ident') (names e) of
Just (_, ty') -> isExtern ty'
@@ -212,7 +210,7 @@ varToJs m e qual@(Qualified _ ident) = go qual
--
qualifiedToJS :: ModuleName -> (a -> Ident) -> Qualified a -> JS
qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSAccessor (moduleNameToJs m') $ JSVar "_ps")
-qualifiedToJS m f (Qualified _ a) = JSVar $ identToJs (f a)
+qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)
-- |
-- Generate code in the simplified Javascript intermediate representation for pattern match binders
@@ -256,7 +254,7 @@ binderToJs _ _ varName done (BooleanBinder True) =
return [JSIfElse (JSVar varName) (JSBlock done) Nothing]
binderToJs _ _ varName done (BooleanBinder False) =
return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
-binderToJs m e varName done (VarBinder ident) =
+binderToJs _ _ varName done (VarBinder ident) =
return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)
binderToJs m e varName done (ConstructorBinder ctor bs) = do
js <- go 0 done bs
@@ -326,7 +324,7 @@ isOnlyConstructor m e ctor =
typeConstructor fn = error $ "Invalid arguments to typeConstructor: " ++ show fn
wrapExportsContainer :: Options -> [JS] -> JS
-wrapExportsContainer opts modules = JSApp (JSFunction Nothing ["_ps"] $ JSBlock $ (JSStringLiteral "use strict") : modules) [exportSelector]
+wrapExportsContainer opts modules = JSApp (JSFunction Nothing ["_ps"] $ JSBlock $ JSStringLiteral "use strict" : modules) [exportSelector]
where
exportSelector = JSConditional (JSBinary And (JSBinary NotEqualTo (JSTypeOf $ JSVar "module") (JSStringLiteral "undefined")) (JSAccessor "exports" (JSVar "module")))
(JSAccessor "exports" (JSVar "module"))
diff --git a/src/Language/PureScript/CodeGen/Monad.hs b/src/Language/PureScript/CodeGen/Monad.hs
index b2bebce..d6b0d71 100644
--- a/src/Language/PureScript/CodeGen/Monad.hs
+++ b/src/Language/PureScript/CodeGen/Monad.hs
@@ -21,7 +21,6 @@ module Language.PureScript.CodeGen.Monad where
import Control.Monad.State
import Control.Applicative
-import Language.PureScript.Names
-- |
-- Code generation monad data type
diff --git a/src/Language/PureScript/CodeGen/Optimize.hs b/src/Language/PureScript/CodeGen/Optimize.hs
index 199d41d..f99b465 100644
--- a/src/Language/PureScript/CodeGen/Optimize.hs
+++ b/src/Language/PureScript/CodeGen/Optimize.hs
@@ -73,10 +73,10 @@ applyAll :: [a -> a] -> a -> a
applyAll = foldl1 (.)
untilFixedPoint :: (Eq a) => (a -> a) -> a -> a
-untilFixedPoint f a = go a
+untilFixedPoint f = go
where
- go a' = let a'' = f a' in
- if a'' == a' then a'' else go a''
+ go a = let a' = f a in
+ if a' == a then a' else go a'
replaceIdent :: (Data d) => String -> JS -> d -> d
replaceIdent var1 js = everywhere (mkT replace)
@@ -100,7 +100,7 @@ isReassigned var1 = everything (||) (mkQ False check)
check _ = False
isRebound :: (Data d) => JS -> d -> Bool
-isRebound js d = any (\var -> isReassigned var d) (everything (++) (mkQ [] variablesOf) js)
+isRebound js d = any (`isReassigned` d) (everything (++) (mkQ [] variablesOf) js)
where
variablesOf (JSVar var) = [var]
variablesOf _ = []
@@ -135,25 +135,23 @@ shouldInline (JSAccessor _ val) = shouldInline val
shouldInline (JSIndexer index val) = shouldInline index && shouldInline val
shouldInline _ = False
+removeFromBlock :: ([JS] -> [JS]) -> JS -> JS
+removeFromBlock go (JSBlock sts) = JSBlock (go sts)
+removeFromBlock _ js = js
+
inlineVariables :: JS -> JS
-inlineVariables = everywhere (mkT removeFromBlock)
+inlineVariables = everywhere (mkT $ removeFromBlock go)
where
- removeFromBlock :: JS -> JS
- removeFromBlock (JSBlock sts) = JSBlock (go sts)
- removeFromBlock js = js
go :: [JS] -> [JS]
go [] = []
- go (s@(JSVariableIntroduction var (Just js)) : sts)
+ go (JSVariableIntroduction var (Just js) : sts)
| shouldInline js && not (isReassigned var sts) && not (isRebound js sts) && not (isUpdated var sts) =
go (replaceIdent var js sts)
go (s:sts) = s : go sts
removeUnusedVariables :: JS -> JS
-removeUnusedVariables = everywhere (mkT removeFromBlock)
+removeUnusedVariables = everywhere (mkT $ removeFromBlock go)
where
- removeFromBlock :: JS -> JS
- removeFromBlock (JSBlock sts) = JSBlock (go sts)
- removeFromBlock js = js
go :: [JS] -> [JS]
go [] = []
go (JSVariableIntroduction var _ : sts) | not (isUsed var sts) = go sts
@@ -165,8 +163,8 @@ etaConvert = everywhere (mkT convert)
convert :: JS -> JS
convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])
| all shouldInline args &&
- not (any (flip isRebound block) (map JSVar idents)) &&
- not (or (map (flip isRebound block) args))
+ not (any (`isRebound` block) (map JSVar idents)) &&
+ not (any (`isRebound` block) args)
= JSBlock (replaceIdents (zip idents args) body)
convert js = js
@@ -191,7 +189,7 @@ tco' = everywhere (mkT convert)
copyVar :: String -> String
copyVar arg = "__copy_" ++ arg
convert :: JS -> JS
- convert js@(JSVariableIntroduction name (Just fn@(JSFunction _ _ _))) =
+ convert js@(JSVariableIntroduction name (Just fn@JSFunction {})) =
let
(argss, body', replace) = collectAllFunctionArgs [] id fn
in case () of
@@ -206,11 +204,11 @@ tco' = everywhere (mkT convert)
collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =
collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body
collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =
- (args : allArgs, body, \b -> f (JSFunction ident (map copyVar args) b))
+ (args : allArgs, body, f . JSFunction ident (map copyVar args))
collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =
collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body
collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =
- (args : allArgs, body, \b -> f (JSReturn (JSFunction ident (map copyVar args) b)))
+ (args : allArgs, body, f . JSReturn . JSFunction ident (map copyVar args))
collectAllFunctionArgs allArgs f body = (allArgs, body, f)
isTailCall :: String -> JS -> Bool
isTailCall ident js =
@@ -312,19 +310,19 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
isRetPoly (JSIndexer (JSStringLiteral "return") (JSAccessor "Prelude" (JSVar "_ps"))) = True
isRetPoly _ = False
-- Check if an expression represents a function in the Ef module
- isEffFunc name (JSAccessor name' (JSAccessor "Eff" (JSVar "_ps"))) | name == name' = True
+ isEffFunc name (JSAccessor name' (JSAccessor "Control_Monad_Eff" (JSVar "_ps"))) | name == name' = True
isEffFunc _ _ = False
-- Module names
prelude = ModuleName [ProperName "Prelude"]
- effModule = ModuleName [ProperName "Eff"]
+ effModule = ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"]
-- The name of the type class dictionary for the Monad Eff instance
Right (Ident effDictName) = mkDictionaryValueName
effModule
(Qualified (Just prelude) (ProperName "Monad"))
- (TypeConstructor (Qualified (Just effModule) (ProperName "Eff")))
+ [TypeConstructor (Qualified (Just effModule) (ProperName "Eff"))]
-- Check if an expression represents the Monad Eff dictionary
isEffDict (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == effDictName = True
- isEffDict (JSApp (JSAccessor prop (JSAccessor "Eff" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == effDictName = True
+ isEffDict (JSApp (JSAccessor prop (JSAccessor "Control_Monad_Eff" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == effDictName = True
isEffDict _ = False
-- Remove __do function applications which remain after desugaring
undo :: JS -> JS
@@ -345,7 +343,7 @@ inlineST = everywhere (mkT convertBlock)
usages = findAllSTUsagesIn arg
allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages
localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs
- in everywhere (mkT $ convert allUsagesAreLocalVars) arg
+ in everywhere (mkT $ convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg
convertBlock other = other
-- Convert a block in a safe way, preserving object wrappers of references,
-- or in a more aggressive way, turning wrappers into local variables depending on the
@@ -359,17 +357,17 @@ inlineST = everywhere (mkT convertBlock)
convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc "modifySTRef" f =
if agg then JSAssignment ref (JSApp func [ref]) else JSAssignment (JSAccessor "value" ref) (JSApp func [JSAccessor "value" ref])
convert _ (JSApp (JSApp (JSApp f [arr]) [i]) []) | isSTFunc "peekSTArray" f =
- (JSIndexer i arr)
+ JSIndexer i arr
convert _ (JSApp (JSApp (JSApp (JSApp f [arr]) [i]) [val]) []) | isSTFunc "pokeSTArray" f =
JSAssignment (JSIndexer i arr) val
convert _ other = other
-- Check if an expression represents a function in the ST module
- isSTFunc name (JSAccessor name' (JSAccessor "ST" (JSVar "_ps"))) | name == name' = True
+ isSTFunc name (JSAccessor name' (JSAccessor "Control_Monad_ST" (JSVar "_ps"))) | name == name' = True
isSTFunc _ _ = False
-- Find all ST Refs initialized in this block
findSTRefsIn = everything (++) (mkQ [] isSTRef)
where
- isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [arg]) []))) | isSTFunc "newSTRef" f = [ident]
+ isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [_]) []))) | isSTFunc "newSTRef" f = [ident]
isSTRef _ = []
-- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef
findAllSTUsagesIn = everything (++) (mkQ [] isSTUsage)
@@ -400,7 +398,7 @@ inlineOperator :: String -> (JS -> JS -> JS) -> JS -> JS
inlineOperator op f = everywhere (mkT convert)
where
convert :: JS -> JS
- convert (JSApp (JSApp op [x]) [y]) | isOp op = f x y
+ convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y
convert other = other
isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar "_ps"))) | longForm == identToJs (Op op) = True
isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | op == op' = True
@@ -446,7 +444,7 @@ inlineCommonOperators = applyAll
convert :: JS -> JS
convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict className classTy dict = JSBinary op x y
convert other = other
- isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar ps))) | longForm == identToJs (Op opString) = True
+ isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar _))) | longForm == identToJs (Op opString) = True
isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | opString == op' = True
isOp _ = False
binaryFunction :: String -> String -> Type -> BinaryOperator -> JS -> JS
@@ -470,5 +468,5 @@ inlineCommonOperators = applyAll
Right (Ident dictName) = mkDictionaryValueName
(ModuleName [ProperName "Prim"])
(Qualified (Just (ModuleName [ProperName "Prelude"])) (ProperName className))
- ty
+ [ty]
isOpDict _ _ _ = False
diff --git a/src/Language/PureScript/DeadCodeElimination.hs b/src/Language/PureScript/DeadCodeElimination.hs
index 8de1cc4..0f3b297 100644
--- a/src/Language/PureScript/DeadCodeElimination.hs
+++ b/src/Language/PureScript/DeadCodeElimination.hs
@@ -35,19 +35,19 @@ 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 (\((mn, _), _) -> mn `elem` entryPoints) $ declarations
- in flip map ms $ \(Module moduleName ds) -> Module moduleName (filter (isUsed (moduleName) graph vertexFor entryPointVertices) ds)
+ in flip map ms $ \(Module moduleName ds) -> Module moduleName (filter (isUsed moduleName graph vertexFor entryPointVertices) ds)
type Key = (ModuleName, Either Ident ProperName)
declarationsByModule :: Environment -> Module -> [(Key, [Key])]
-declarationsByModule env (Module moduleName ds) = concatMap go $ ds
+declarationsByModule env (Module moduleName ds) = concatMap go ds
where
go :: Declaration -> [(Key, [Key])]
- go d@(ValueDeclaration name _ _ _) = [((moduleName, Left name), dependencies env (moduleName) d)]
+ go d@(ValueDeclaration name _ _ _) = [((moduleName, Left name), dependencies env moduleName d)]
go (DataDeclaration _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors
go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]
- go d@(BindingGroupDeclaration names) = map (\(name, _) -> ((moduleName, Left name), dependencies env moduleName d)) names
- go (DataBindingGroupDeclaration ds) = concatMap go ds
+ go d@(BindingGroupDeclaration names') = map (\(name, _) -> ((moduleName, Left name), dependencies env moduleName d)) names'
+ go (DataBindingGroupDeclaration ds') = concatMap go ds'
go _ = []
dependencies :: (Data d) => Environment -> ModuleName -> d -> [Key]
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
index 934137c..3d73627 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -112,60 +112,60 @@ data Declaration
-- |
-- A type class declaration (name, argument, member declarations)
--
- | TypeClassDeclaration ProperName String [Declaration]
+ | TypeClassDeclaration ProperName [String] [Declaration]
-- |
-- A type instance declaration (dependencies, class name, instance type, member declarations)
--
- | TypeInstanceDeclaration [(Qualified ProperName, Type)] (Qualified ProperName) Type [Declaration]
+ | TypeInstanceDeclaration [(Qualified ProperName, [Type])] (Qualified ProperName) [Type] [Declaration]
deriving (Show, D.Data, D.Typeable)
-- |
-- Test if a declaration is a value declaration
--
isValueDecl :: Declaration -> Bool
-isValueDecl (ValueDeclaration _ _ _ _) = True
+isValueDecl ValueDeclaration{} = True
isValueDecl _ = False
-- |
-- Test if a declaration is a data type or type synonym declaration
--
isDataDecl :: Declaration -> Bool
-isDataDecl (DataDeclaration _ _ _) = True
-isDataDecl (TypeSynonymDeclaration _ _ _) = True
+isDataDecl DataDeclaration{} = True
+isDataDecl TypeSynonymDeclaration{} = True
isDataDecl _ = False
-- |
-- Test if a declaration is a module import
--
isImportDecl :: Declaration -> Bool
-isImportDecl (ImportDeclaration _ _) = True
+isImportDecl ImportDeclaration{} = True
isImportDecl _ = False
-- |
-- Test if a declaration is a data type foreign import
--
isExternDataDecl :: Declaration -> Bool
-isExternDataDecl (ExternDataDeclaration _ _) = True
+isExternDataDecl ExternDataDeclaration{} = True
isExternDataDecl _ = False
-- |
-- Test if a declaration is a fixity declaration
--
isFixityDecl :: Declaration -> Bool
-isFixityDecl (FixityDeclaration _ _) = True
+isFixityDecl FixityDeclaration{} = True
isFixityDecl _ = False
-- |
-- Test if a declaration is a foreign import
--
isExternDecl :: Declaration -> Bool
-isExternDecl (ExternDeclaration _ _ _ _) = True
+isExternDecl ExternDeclaration{} = True
isExternDecl _ = False
-- |
-- Test if a declaration is a type class or instance declaration
--
isTypeClassDeclaration :: Declaration -> Bool
-isTypeClassDeclaration (TypeClassDeclaration _ _ _) = True
-isTypeClassDeclaration (TypeInstanceDeclaration _ _ _ _) = True
+isTypeClassDeclaration TypeClassDeclaration{} = True
+isTypeClassDeclaration TypeInstanceDeclaration{} = True
isTypeClassDeclaration _ = False
diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs
index 714e252..7b15f40 100644
--- a/src/Language/PureScript/ModuleDependencies.hs
+++ b/src/Language/PureScript/ModuleDependencies.hs
@@ -19,13 +19,10 @@ module Language.PureScript.ModuleDependencies (
import Data.Data
import Data.Graph
import Data.Generics
-import Data.List (nub, intersect)
-import Control.Applicative ((<$>))
+import Data.List (nub)
import Language.PureScript.Declarations
import Language.PureScript.Names
-import Language.PureScript.Values
-import Language.PureScript.Types
-- |
-- Sort a collection of modules based on module dependencies.
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index 6fd6e0d..3f87e12 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -70,6 +70,14 @@ data ModuleName = ModuleName [ProperName] deriving (Eq, Ord, Data, Typeable)
runModuleName :: ModuleName -> String
runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns)
+moduleNameFromString :: String -> ModuleName
+moduleNameFromString = ModuleName . splitProperNames
+ where
+ splitProperNames s = case dropWhile (== '.') s of
+ "" -> []
+ s' -> ProperName w : splitProperNames s''
+ where (w, s'') = break (== '.') s'
+
instance Show ModuleName where
show = runModuleName
diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs
index 6d35885..1ddcb3c 100644
--- a/src/Language/PureScript/Options.hs
+++ b/src/Language/PureScript/Options.hs
@@ -33,7 +33,7 @@ data Options = Options {
, optionsMagicDo :: Bool
-- |
-- When specified, checks the type of `main` in the module, and generate a call to run main
- -- after the module definitions.
+ -- after the module definitions.
--
, optionsMain :: Maybe String
-- |
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index c998e65..dde950d 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -48,8 +48,8 @@ reservedPsNames = [ "data"
, "let"
, "true"
, "false"
- , "until"
, "in"
+ , "where"
]
-- |
@@ -328,7 +328,7 @@ buildPostfixParser fs first = do
-- Parse an identifier in backticks or an operator
--
parseIdentInfix :: P.Parsec String ParseState (Qualified Ident)
-parseIdentInfix = (P.between tick tick (parseQualified (Ident <$> identifier))) <|> Qualified Nothing <$> (Op <$> operator)
+parseIdentInfix = P.between tick tick (parseQualified (Ident <$> identifier)) <|> Qualified Nothing <$> (Op <$> operator)
-- |
-- Mark the current indentation level
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 6571f28..6a0f4ee 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -20,11 +20,9 @@ module Language.PureScript.Parser.Declarations (
) where
import Data.Maybe (isJust, fromMaybe)
-import Control.Monad (when)
import Control.Applicative
import qualified Text.Parsec as P
-import Language.PureScript.Names
import Language.PureScript.Parser.State
import Language.PureScript.Parser.Common
import Language.PureScript.Declarations
@@ -32,7 +30,6 @@ import Language.PureScript.Parser.Values
import Language.PureScript.Parser.Types
import Language.PureScript.Parser.Kinds
import Language.PureScript.CodeGen.JS.AST
-import Language.PureScript.Values
parseDataDeclaration :: P.Parsec String ParseState Declaration
parseDataDeclaration = do
@@ -59,15 +56,15 @@ parseValueDeclaration =
ValueDeclaration <$> parseIdent
<*> P.many parseBinderNoParens
<*> P.optionMaybe parseGuard
- <*> ((lexeme (indented *> P.char '=')) *> parseValue)
+ <*> (lexeme (indented *> P.char '=') *> parseValue)
parseExternDeclaration :: P.Parsec String ParseState Declaration
-parseExternDeclaration = P.try (reserved "foreign") *> indented *> (reserved "import") *> indented *>
+parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "import" *> indented *>
(ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)
<*> (lexeme (indented *> P.string "::") *> parseKind)
<|> do ident <- parseIdent
js <- P.optionMaybe (JSRaw <$> stringLiteral)
- ty <- (lexeme (indented *> P.string "::") *> parsePolyType)
+ ty <- lexeme (indented *> P.string "::") *> parsePolyType
return $ ExternDeclaration (if isJust js then InlineJavascript else ForeignImport) ident js ty)
parseAssociativity :: P.Parsec String ParseState Associativity
@@ -89,29 +86,29 @@ parseImportDeclaration :: P.Parsec String ParseState Declaration
parseImportDeclaration = do
reserved "import"
indented
- moduleName <- moduleName
+ moduleName' <- moduleName
idents <- P.optionMaybe $ parens $ commaSep1 (Left <$> parseIdent <|> Right <$> properName)
- return $ ImportDeclaration moduleName idents
+ return $ ImportDeclaration moduleName' idents
parseTypeClassDeclaration :: P.Parsec String ParseState Declaration
parseTypeClassDeclaration = do
reserved "class"
className <- indented *> properName
- ident <- indented *> identifier
+ idents <- indented *> P.many identifier
indented *> reserved "where"
members <- mark (P.many (same *> parseTypeDeclaration))
- return $ TypeClassDeclaration className ident members
+ return $ TypeClassDeclaration className idents members
parseTypeInstanceDeclaration :: P.Parsec String ParseState Declaration
parseTypeInstanceDeclaration = do
reserved "instance"
deps <- P.optionMaybe $ do
- deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> parseType))
+ deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom))
indented
reservedOp "=>"
return deps
className <- indented *> parseQualified properName
- ty <- indented *> parseType
+ ty <- indented *> P.many parseTypeAtom
indented *> reserved "where"
members <- mark (P.many (same *> parseValueDeclaration))
return $ TypeInstanceDeclaration (fromMaybe [] deps) className ty members
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
index ecd9bdc..314dd3c 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -51,15 +51,15 @@ parseObject = braces $ Object <$> parseRow False
parseTypeVariable :: P.Parsec String ParseState Type
parseTypeVariable = do
ident <- identifier
- when (ident `elem` reservedTypeNames) $ P.unexpected $ ident
+ when (ident `elem` reservedTypeNames) $ P.unexpected ident
return $ TypeVar ident
parseTypeConstructor :: P.Parsec String ParseState Type
parseTypeConstructor = TypeConstructor <$> parseQualified properName
parseForAll :: P.Parsec String ParseState Type
-parseForAll = (mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot)
- <*> parseConstrainedType)
+parseForAll = mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot)
+ <*> parseConstrainedType
-- |
-- Parse a type as it appears in e.g. a data constructor
@@ -85,7 +85,7 @@ parseConstrainedType = do
constraints <- parens . commaSep1 $ do
className <- parseQualified properName
indented
- ty <- parseType
+ ty <- P.many parseTypeAtom
return (className, ty)
_ <- lexeme $ P.string "=>"
return constraints
@@ -94,7 +94,7 @@ parseConstrainedType = do
return $ maybe ty (flip ConstrainedType ty) constraints
parseAnyType :: P.Parsec String ParseState Type
-parseAnyType = (P.buildExpressionParser operators $ parseTypeAtom) P.<?> "type"
+parseAnyType = P.buildExpressionParser operators parseTypeAtom P.<?> "type"
where
operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]
, [ P.Infix (P.try (lexeme (P.string "->")) >> return function) P.AssocRight ] ]
@@ -112,9 +112,7 @@ parseType = do
-- Parse a polytype
--
parsePolyType :: P.Parsec String ParseState Type
-parsePolyType = do
- ty <- parseAnyType
- return ty
+parsePolyType = parseAnyType
parseNameAndType :: P.Parsec String ParseState t -> P.Parsec String ParseState (String, t)
parseNameAndType p = (,) <$> (indented *> identifier <* indented <* lexeme (P.string "::")) <*> p
@@ -123,5 +121,5 @@ parseRowEnding :: P.Parsec String ParseState Type
parseRowEnding = P.option REmpty (TypeVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier))
parseRow :: Bool -> P.Parsec String ParseState Type
-parseRow nonEmpty = (curry rowFromList <$> (many $ parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row"
- where many = if nonEmpty then commaSep1 else commaSep
+parseRow nonEmpty = (curry rowFromList <$> many' (parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row"
+ where many' = if nonEmpty then commaSep1 else commaSep
diff --git a/src/Language/PureScript/Parser/Values.hs b/src/Language/PureScript/Parser/Values.hs
index 0ce9882..ad03dd3 100644
--- a/src/Language/PureScript/Parser/Values.hs
+++ b/src/Language/PureScript/Parser/Values.hs
@@ -20,13 +20,16 @@ module Language.PureScript.Parser.Values (
parseBinderNoParens,
) where
+import Control.Applicative
+
import Language.PureScript.Values
import Language.PureScript.Parser.State
+import Language.PureScript.Parser.Types
+
+import Text.Parsec.Expr
+
import qualified Language.PureScript.Parser.Common as C
-import Control.Applicative
import qualified Text.Parsec as P
-import Text.Parsec.Expr
-import Language.PureScript.Parser.Types
booleanLiteral :: P.Parsec String ParseState Bool
booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)
@@ -59,7 +62,7 @@ parseAbs = do
return $ toFunction args value
where
toFunction :: [Value -> Value] -> Value -> Value
- toFunction args value = foldr (($)) value args
+ toFunction args value = foldr ($) value args
parseVar :: P.Parsec String ParseState Value
parseVar = Var <$> C.parseQualified C.parseIdent
@@ -154,7 +157,7 @@ parseValue =
indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom
postfixTable1 = [ parseAccessor
, \v -> P.try $ flip ObjectUpdate <$> (C.indented *> C.braces (C.commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]
- postfixTable2 = [ \v -> P.try (C.indented *> indexersAndAccessors >>= return . flip App) <*> pure v
+ postfixTable2 = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v
, \v -> flip (TypedValue True) <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v
]
operators = [ [ Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->
@@ -177,13 +180,13 @@ parseNullaryConstructorBinder :: P.Parsec String ParseState Binder
parseNullaryConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> pure []
parseConstructorBinder :: P.Parsec String ParseState Binder
-parseConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> (many (C.indented *> parseBinderNoParens))
+parseConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> many (C.indented *> parseBinderNoParens)
parseObjectBinder :: P.Parsec String ParseState Binder
parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep (C.indented *> parseIdentifierAndBinder))
parseArrayBinder :: P.Parsec String ParseState Binder
-parseArrayBinder = C.squares $ ArrayBinder <$> (C.commaSep (C.indented *> parseBinder))
+parseArrayBinder = C.squares $ ArrayBinder <$> C.commaSep (C.indented *> parseBinder)
parseNamedBinder :: P.Parsec String ParseState Binder
parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* C.lexeme (P.char '@'))
@@ -203,7 +206,7 @@ parseIdentifierAndBinder = do
-- Parse a binder
--
parseBinder :: P.Parsec String ParseState Binder
-parseBinder = (buildExpressionParser operators parseBinderAtom) P.<?> "expression"
+parseBinder = buildExpressionParser operators parseBinderAtom P.<?> "expression"
where
operators = [ [ Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) AssocRight ] ]
parseBinderAtom :: P.Parsec String ParseState Binder
diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs
index 35bf7e3..afb5da4 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -17,8 +17,6 @@ module Language.PureScript.Pretty.JS (
prettyPrintJS
) where
-import Language.PureScript.Names
-import Language.PureScript.Values
import Language.PureScript.Pretty.Common
import Language.PureScript.CodeGen.JS.AST
@@ -69,7 +67,7 @@ literals = mkPattern' match
, fmap (intercalate ", ") $ forM xs prettyPrintJS'
, return " ]"
]
- match (JSObjectLiteral []) = return "{}"
+ match (JSObjectLiteral []) = return "{}"
match (JSObjectLiteral ps) = fmap concat $ sequence
[ return "{\n"
, withIndent $ do
@@ -82,10 +80,7 @@ literals = mkPattern' match
]
match (JSBlock sts) = fmap concat $ sequence
[ return "{\n"
- , withIndent $ do
- jss <- forM sts prettyPrintJS'
- indentString <- currentIndent
- return $ intercalate "\n" $ map (++ ";") $ map (indentString ++) jss
+ , withIndent $ prettyStatements sts
, return "\n"
, currentIndent
, return "}"
@@ -195,6 +190,12 @@ binary op str = AssocR match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
match' (JSBinary op' v1 v2) | op' == op = Just (v1, v2)
match' _ = Nothing
+prettyStatements :: [JS] -> StateT PrinterState Maybe String
+prettyStatements sts = do
+ jss <- forM sts prettyPrintJS'
+ indentString <- currentIndent
+ return $ intercalate "\n" $ map ((++ ";") . (indentString ++)) jss
+
-- |
-- Generate a pretty-printed string representing a Javascript expression
--
@@ -205,10 +206,7 @@ prettyPrintJS1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (Print
-- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level
--
prettyPrintJS :: [JS] -> String
-prettyPrintJS sts = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) $ do
- jss <- forM sts prettyPrintJS'
- indentString <- currentIndent
- return $ intercalate "\n" $ map (++ ";") $ map (indentString ++) jss
+prettyPrintJS = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements
-- |
-- Generate an indented, pretty-printed string representing a Javascript expression
@@ -224,8 +222,8 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue
, [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]
, [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]
, [ Wrap lam $ \(name, args) ret -> "function "
- ++ maybe "" id name
- ++ "(" ++ (intercalate ", " args) ++ ") "
+ ++ fromMaybe "" name
+ ++ "(" ++ intercalate ", " args ++ ") "
++ ret ]
, [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS1 th ++ " : " ++ prettyPrintJS1 el ]
, [ binary LessThan "<" ]
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index 2c9621e..c267f44 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -35,14 +35,14 @@ typeLiterals = mkPattern match
match (Object row) = Just $ "{ " ++ prettyPrintRow row ++ " }"
match (TypeVar var) = Just var
match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"
- match ty@(TypeConstructor ctor) = Just $ show ctor
+ match (TypeConstructor ctor) = Just $ show ctor
match (TUnknown (Unknown u)) = Just $ 'u' : show u
match (Skolem s _) = Just $ 's' : show s
- match (ConstrainedType deps ty) = Just $ "(" ++ intercalate "," (map (\(pn, ty') -> show pn ++ " (" ++ prettyPrintType ty' ++ ")") deps) ++ ") => " ++ prettyPrintType ty
+ match (ConstrainedType deps ty) = Just $ "(" ++ intercalate "," (map (\(pn, ty') -> show pn ++ " (" ++ unwords (map prettyPrintType ty') ++ ")") deps) ++ ") => " ++ prettyPrintType ty
match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">"
match (ForAll ident ty _) = Just $ "forall " ++ ident ++ ". " ++ prettyPrintType ty
match REmpty = Just "()"
- match row@(RCons _ _ _) = Just $ '(' : prettyPrintRow row ++ ")"
+ match row@RCons{} = Just $ '(' : prettyPrintRow row ++ ")"
match _ = Nothing
-- |
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index f288174..6121322 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -38,7 +38,7 @@ 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 (Case values binders) = Just $ "case " ++ intercalate " " (map prettyPrintValue values) ++
+ match (Case values binders) = Just $ "case " ++ unwords (map prettyPrintValue values) ++
" of { " ++ intercalate " ; " (map prettyPrintCaseAlternative binders) ++ " }"
match (Var ident) = Just $ show ident
match (Do els) = Just $ " do { " ++ intercalate "; " (map prettyPrintDoNotationElement els) ++ " }"
@@ -47,7 +47,7 @@ literals = mkPattern match
prettyPrintCaseAlternative :: ([Binder], Maybe Guard, Value) -> String
prettyPrintCaseAlternative (binders, grd, val) = "(" ++ intercalate ", " (map prettyPrintBinder binders) ++ ") " ++
- (maybe "" (("| " ++) . prettyPrintValue) grd) ++ " -> " ++ prettyPrintValue val
+ maybe "" (("| " ++) . prettyPrintValue) grd ++ " -> " ++ prettyPrintValue val
ifThenElse :: Pattern () Value ((Value, Value), Value)
ifThenElse = mkPattern match
@@ -118,7 +118,7 @@ prettyPrintBinderAtom = mkPattern match
match (BooleanBinder True) = Just "true"
match (BooleanBinder False) = Just "false"
match (VarBinder ident) = Just $ show ident
- match (ConstructorBinder ctor args) = Just $ show ctor ++ " " ++ intercalate " " (map (parens . prettyPrintBinder) args)
+ match (ConstructorBinder ctor args) = Just $ show ctor ++ " " ++ unwords (map (parens . prettyPrintBinder) args)
match (ObjectBinder bs) = Just $ "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"
match (ArrayBinder bs) = Just $ "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ " ]"
match (NamedBinder ident binder) = Just $ show ident ++ "@" ++ prettyPrintBinder binder
diff --git a/src/Language/PureScript/Scope.hs b/src/Language/PureScript/Scope.hs
index d6d0b0a..c2509dc 100644
--- a/src/Language/PureScript/Scope.hs
+++ b/src/Language/PureScript/Scope.hs
@@ -18,6 +18,8 @@ module Language.PureScript.Scope (
unusedNames
) where
+import Control.Applicative ((<$>))
+
import Data.Data
import Data.List ((\\), nub)
import Data.Generics (extQ, mkQ, everything)
@@ -41,8 +43,8 @@ usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesB `extQ` namesJ
namesB _ = []
namesJS :: JS -> [Ident]
namesJS (JSVar name) = [Ident name]
- namesJS (JSFunction (Just name) args _) = (Ident name) : (Ident `map` args)
- namesJS (JSFunction Nothing args _) = (Ident `map` args)
+ namesJS (JSFunction (Just name) args _) = Ident name : (Ident <$> args)
+ namesJS (JSFunction Nothing args _) = Ident <$> args
namesJS (JSVariableIntroduction name _) = [Ident name]
namesJS (JSFor name _ _ _) = [Ident name]
namesJS _ = []
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index c933dc3..00b4732 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -69,7 +69,7 @@ createBindingGroups moduleName ds = do
-- Collapse all binding groups to individual declarations
--
collapseBindingGroups :: [Declaration] -> [Declaration]
-collapseBindingGroups ds = concatMap go ds
+collapseBindingGroups = concatMap go
where
go (DataBindingGroupDeclaration ds) = ds
go (BindingGroupDeclaration ds) = map (\(ident, val) -> ValueDeclaration ident [] Nothing val) ds
@@ -112,10 +112,10 @@ toDataBindingGroup (CyclicSCC ds')
| all isTypeSynonym ds' = Left "Cycle in type synonyms"
| otherwise = return $ DataBindingGroupDeclaration ds'
where
- isTypeSynonym (TypeSynonymDeclaration _ _ _) = True
+ isTypeSynonym TypeSynonymDeclaration{} = True
isTypeSynonym _ = False
fromValueDecl :: Declaration -> (Ident, Value)
fromValueDecl (ValueDeclaration ident [] Nothing val) = (ident, val)
-fromValueDecl (ValueDeclaration _ _ _ _) = error "Binders should have been desugared"
+fromValueDecl ValueDeclaration{} = error "Binders should have been desugared"
fromValueDecl _ = error "Expected ValueDeclaration"
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index 3f02a72..d748648 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -75,7 +75,7 @@ makeCaseDeclaration ident alternatives =
let
argPattern = length . fst . head $ alternatives
args = take argPattern $ unusedNames (ident, alternatives)
- vars = map (\arg -> Var (Qualified Nothing arg)) args
+ vars = map (Var . Qualified Nothing) args
binders = [ (bs, g, val) | (bs, (g, val)) <- alternatives ]
value = foldr (\arg ret -> Abs (Left arg) ret) (Case vars binders) args
in
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index 16fc125..c07ca08 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -27,13 +27,17 @@ import Language.PureScript.Names
import Language.PureScript.Declarations
import Language.PureScript.Values
+import Control.Applicative
+import Control.Arrow (first)
+import Control.Monad.State
+
import Data.Function (on)
import Data.List (groupBy, sortBy)
+
import qualified Data.Map as M
import qualified Data.Generics as G
import qualified Data.Generics.Extras as G
-import Control.Monad.State
-import Control.Applicative
+
import qualified Text.Parsec as P
import qualified Text.Parsec.Pos as P
import qualified Text.Parsec.Expr as P
@@ -62,9 +66,9 @@ customOperatorTable fixities =
-- The fixity map can therefore map from module name/ident pairs to fixities, where the module name is the name
-- of the module imported into, not from. This is useful in matchOp, but here we have to discard the module name to
-- make sure that the generated code is correct.
- applyUserOp (Qualified _ name) t1 t2 = App (App (Var (Qualified Nothing name)) t1) t2
+ applyUserOp (Qualified _ name) t1 = App (App (Var (Qualified Nothing name)) t1)
userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) . M.toList $ fixities
- sorted = reverse $ sortBy (compare `on` (\(_, _, p, _) -> p)) userOps
+ sorted = sortBy (flip compare `on` (\(_, _, p, _) -> p)) userOps
groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted
in
map (map (\(name, f, _, a) -> (name, f, a))) groups
@@ -72,10 +76,10 @@ customOperatorTable fixities =
type Chain = [Either Value (Qualified Ident)]
matchOperators :: ModuleName -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value
-matchOperators moduleName ops val = G.everywhereM' (G.mkM parseChains) val
+matchOperators moduleName ops = G.everywhereM' (G.mkM parseChains)
where
parseChains :: Value -> Either String Value
- parseChains b@(BinaryNoParens _ _ _) = bracketChain (extendChain b)
+ parseChains b@BinaryNoParens{} = bracketChain (extendChain b)
parseChains other = return other
extendChain :: Value -> Chain
extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r
@@ -108,7 +112,7 @@ collectFixities m moduleName (FixityDeclaration fixity name : rest) = do
collectFixities (M.insert qual fixity m) moduleName rest
collectFixities m moduleName (ImportDeclaration importedModule _ : rest) = do
let fs = [ (i, fixity) | (Qualified mn i, fixity) <- M.toList m, mn == Just importedModule ]
- let m' = M.fromList (map (\(i, fixity) -> (Qualified (Just moduleName) i, fixity)) fs)
- collectFixities (M.union m' m) moduleName rest
+ let m' = M.fromList (map (first (Qualified (Just moduleName))) fs)
+ collectFixities (m' `M.union` m) moduleName rest
collectFixities m moduleName (_:ds) = collectFixities m moduleName ds
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 90926f7..f0ad912 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -31,14 +31,12 @@ import qualified Data.Map as M
import Control.Applicative
import Control.Monad.State
-import Control.Arrow ((***))
+import Control.Arrow (second)
-import Data.Maybe (fromMaybe)
-import Data.List (nub)
-import Data.Generics (mkQ, everything)
+import Data.List (intercalate)
import Language.PureScript.CodeGen.Common (identToJs, moduleNameToJs)
-type MemberMap = M.Map (ModuleName, ProperName) (String, [(String, Type)])
+type MemberMap = M.Map (ModuleName, ProperName) ([String], [(String, Type)])
type Desugar = StateT MemberMap (Either String)
@@ -91,10 +89,10 @@ desugarModule (Module name decls) = Module name <$> concat <$> mapM (desugarDecl
-- __Test_Foo_array _1 = { foo: __Test_Foo_array_foo _1 :: [a] -> [a] (unchecked) }
--
desugarDecl :: ModuleName -> Declaration -> Desugar [Declaration]
-desugarDecl mn d@(TypeClassDeclaration name arg members) = do
+desugarDecl mn d@(TypeClassDeclaration name args members) = do
let tys = map memberToNameAndType members
- modify (M.insert (mn, name) (arg, tys))
- return $ d : typeClassDictionaryDeclaration name arg members : map (typeClassMemberToDictionaryAccessor name arg) members
+ modify (M.insert (mn, name) (args, tys))
+ return $ d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor name args) members
desugarDecl mn d@(TypeInstanceDeclaration deps name ty members) = do
desugared <- lift $ desugarCases members
entries <- mapM (typeInstanceDictionaryEntryDeclaration mn deps name ty) desugared
@@ -106,50 +104,50 @@ memberToNameAndType :: Declaration -> (String, Type)
memberToNameAndType (TypeDeclaration ident ty) = (identToJs ident, ty)
memberToNameAndType _ = error "Invalid declaration in type class definition"
-typeClassDictionaryDeclaration :: ProperName -> String -> [Declaration] -> Declaration
-typeClassDictionaryDeclaration name arg members =
- TypeSynonymDeclaration name [arg] (Object $ rowFromList (map memberToNameAndType members, REmpty))
+typeClassDictionaryDeclaration :: ProperName -> [String] -> [Declaration] -> Declaration
+typeClassDictionaryDeclaration name args members =
+ TypeSynonymDeclaration name args (Object $ rowFromList (map memberToNameAndType members, REmpty))
-typeClassMemberToDictionaryAccessor :: ProperName -> String -> Declaration -> Declaration
-typeClassMemberToDictionaryAccessor name arg (TypeDeclaration ident ty) =
+typeClassMemberToDictionaryAccessor :: ProperName -> [String] -> Declaration -> Declaration
+typeClassMemberToDictionaryAccessor name args (TypeDeclaration ident ty) =
ExternDeclaration TypeClassAccessorImport ident
(Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSAccessor (identToJs ident) (JSVar "dict"))])))
- (ForAll arg (ConstrainedType [(Qualified Nothing name, TypeVar arg)] ty) Nothing)
+ (quantify (ConstrainedType [(Qualified Nothing name, map TypeVar args)] ty))
typeClassMemberToDictionaryAccessor _ _ _ = error "Invalid declaration in type class definition"
-typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> [Declaration] -> Desugar Declaration
-typeInstanceDictionaryDeclaration mn deps name ty decls = do
+typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration
+typeInstanceDictionaryDeclaration mn deps name tys decls = do
m <- get
- (arg, instanceTys) <- lift $ maybe (Left $ "Type class " ++ show name ++ " is undefined. Type class names must be qualified.") Right
+ (args, instanceTys) <- lift $ maybe (Left $ "Type class " ++ show name ++ " is undefined. Type class names must be qualified.") Right
$ M.lookup (qualify mn name) m
- let memberTypes = map (id *** replaceTypeVars arg ty) instanceTys
- entryName <- lift $ mkDictionaryValueName mn name ty
+ let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys
+ entryName <- lift $ mkDictionaryValueName mn name tys
memberNames <- mapM (memberToNameAndValue memberTypes) decls
return $ ValueDeclaration entryName [] Nothing
(TypedValue True
- (foldr Abs (ObjectLiteral memberNames) (map (\n -> Left . Ident $ '_' : show n) [1..max 1 (length deps)]))
+ (foldr (Abs . (\n -> Left . Ident $ '_' : show n)) (ObjectLiteral memberNames) [1..max 1 (length deps)])
(quantify (if null deps then
- function unit (TypeApp (TypeConstructor name) ty)
+ function unit (foldl TypeApp (TypeConstructor name) tys)
else
- foldr function (TypeApp (TypeConstructor name) ty) (map (\(pn, ty') -> TypeApp (TypeConstructor pn) ty') deps)))
+ foldr (function . (\(pn, tys') -> foldl TypeApp (TypeConstructor pn) tys')) (foldl TypeApp (TypeConstructor name) tys) deps))
)
where
memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value)
- memberToNameAndValue tys (ValueDeclaration ident _ _ _) = do
- memberType <- lift . maybe (Left "Type class member type not found") Right $ lookup (identToJs ident) tys
- memberName <- mkDictionaryEntryName mn name ty ident
+ memberToNameAndValue tys' (ValueDeclaration ident _ _ _) = do
+ memberType <- lift . maybe (Left "Type class member type not found") Right $ lookup (identToJs ident) tys'
+ memberName <- mkDictionaryEntryName mn name tys ident
return (identToJs ident, TypedValue False
(foldl App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))
(quantify memberType))
memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"
-typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> Declaration -> Desugar Declaration
-typeInstanceDictionaryEntryDeclaration mn deps name ty (ValueDeclaration ident [] _ val) = do
+typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> Declaration -> Desugar Declaration
+typeInstanceDictionaryEntryDeclaration mn deps name tys (ValueDeclaration ident [] _ val) = do
m <- get
- valTy <- lift $ do (arg, members) <- lookupTypeClass m
+ valTy <- lift $ do (args, members) <- lookupTypeClass m
ty' <- lookupIdent members
- return $ replaceTypeVars arg ty ty'
- entryName <- mkDictionaryEntryName mn name ty ident
+ return $ replaceAllTypeVars (zip args tys) ty'
+ entryName <- mkDictionaryEntryName mn name tys ident
return $ ValueDeclaration entryName [] Nothing
(TypedValue True val (quantify (if null deps then valTy else ConstrainedType deps valTy)))
where
@@ -164,10 +162,10 @@ qualifiedToString _ (Qualified (Just mn) pn) = moduleNameToJs mn ++ "_" ++ runPr
-- |
-- Generate a name for a type class dictionary, based on the module name, class name and type name
--
-mkDictionaryValueName :: ModuleName -> Qualified ProperName -> Type -> Either String Ident
-mkDictionaryValueName mn cl ty = do
- tyStr <- typeToString mn ty
- return $ Ident $ "__" ++ qualifiedToString mn cl ++ "_" ++ tyStr
+mkDictionaryValueName :: ModuleName -> Qualified ProperName -> [Type] -> Either String Ident
+mkDictionaryValueName mn cl tys = do
+ tyStr <- mapM (typeToString mn) tys
+ return $ Ident $ "__" ++ qualifiedToString mn cl ++ "_" ++ intercalate "_" tyStr
typeToString :: ModuleName -> Type -> Either String String
typeToString _ (TypeVar _) = return "var"
@@ -179,7 +177,7 @@ typeToString _ _ = Left "Type class instance must be of the form T a1 ... an"
-- Generate a name for a type class dictionary member, based on the module name, class name, type name and
-- member name
--
-mkDictionaryEntryName :: ModuleName -> Qualified ProperName -> Type -> Ident -> Desugar Ident
-mkDictionaryEntryName mn name ty ident = do
- Ident dictName <- lift $ mkDictionaryValueName mn name ty
+mkDictionaryEntryName :: ModuleName -> Qualified ProperName -> [Type] -> Ident -> Desugar Ident
+mkDictionaryEntryName mn name tys ident = do
+ Ident dictName <- lift $ mkDictionaryValueName mn name tys
return $ Escaped $ dictName ++ "_" ++ identToJs ident
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 985ced7..012794b 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -86,7 +86,7 @@ addValue moduleName name ty = do
putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Value) (names env) })
addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()
-addTypeClassDictionaries entries = do
+addTypeClassDictionaries entries =
modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } }
checkTypeClassInstance :: ModuleName -> Type -> Check ()
@@ -154,7 +154,7 @@ typeCheckAll mainModuleName moduleName (ValueDeclaration name [] Nothing val : r
return $ ValueDeclaration name [] Nothing val'
ds <- typeCheckAll mainModuleName moduleName rest
return $ d : ds
-typeCheckAll _ _ (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"
+typeCheckAll _ _ (ValueDeclaration{} : _) = error "Binders were not desugared"
typeCheckAll mainModuleName moduleName (BindingGroupDeclaration vals : rest) = do
d <- rethrow (("Error in binding group " ++ show (map fst vals) ++ ":\n") ++) $ do
forM_ (map fst vals) $ \name ->
@@ -206,7 +206,7 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident
filterModule = filter ((== moduleName) . fst) . M.keys
moduleExists env = not (null (filterModule (names env))) || not (null (filterModule (types env)))
shadowIdents idents' env =
- forM_ idents' $ \ident -> do
+ forM_ idents' $ \ident ->
case (moduleName, ident) `M.lookup` names env of
Just (_, Alias _ _) -> return ()
Just (pt, _) -> do
@@ -214,7 +214,7 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident
modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias moduleName ident) (names e) })
Nothing -> throwError (show moduleName ++ "." ++ show ident ++ " is undefined")
shadowTypes pns env =
- forM_ pns $ \pn -> do
+ forM_ pns $ \pn ->
case (moduleName, pn) `M.lookup` types env of
Nothing -> throwError (show moduleName ++ "." ++ show pn ++ " is undefined")
Just (_, DataAlias _ _) -> return ()
@@ -222,7 +222,7 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident
guardWith (show currentModule ++ "." ++ show pn ++ " is already defined") $ (currentModule, pn) `M.notMember` types env
modifyEnv (\e -> e { types = M.insert (currentModule, pn) (k, DataAlias moduleName pn) (types e) })
let keys = map (snd . fst) . filter (\(_, (fn, _)) -> fn `constructs` pn) . M.toList . dataConstructors $ env
- forM_ keys $ \dctor -> do
+ forM_ keys $ \dctor ->
case (moduleName, dctor) `M.lookup` dataConstructors env of
Just (_, Alias _ _) -> return ()
Just (ctorTy, _) -> do
@@ -236,23 +236,23 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident
) (typeClassDictionaries env)
forM_ instances $ \tcd -> do
let (Qualified _ ident) = tcdName tcd
- addTypeClassDictionaries [tcd { tcdName = (Qualified (Just currentModule) ident), tcdType = TCDAlias (tcdName tcd) }]
+ addTypeClassDictionaries [tcd { tcdName = Qualified (Just currentModule) ident, tcdType = TCDAlias (tcdName tcd) }]
constructs (TypeConstructor (Qualified (Just mn) pn')) pn
= mn == moduleName && pn' == pn
constructs (ForAll _ ty _) pn = ty `constructs` pn
constructs (TypeApp (TypeApp t _) ty) pn | t == tyFunction = ty `constructs` pn
constructs (TypeApp ty _) pn = ty `constructs` pn
constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn
-typeCheckAll mainModuleName moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do
+typeCheckAll mainModuleName moduleName (d@TypeClassDeclaration{} : rest) = do
env <- getEnv
ds <- typeCheckAll mainModuleName moduleName rest
return $ qualifyAllUnqualifiedNames moduleName env d : ds
-typeCheckAll mainModuleName moduleName (d@(TypeInstanceDeclaration deps className ty _) : rest) = do
+typeCheckAll mainModuleName moduleName (d@(TypeInstanceDeclaration deps className tys _) : rest) = do
env <- getEnv
- dictName <- Check . lift $ mkDictionaryValueName moduleName className ty
- checkTypeClassInstance moduleName ty
- forM_ deps $ checkTypeClassInstance moduleName . snd
+ dictName <- Check . lift $ mkDictionaryValueName moduleName className tys
+ mapM_ (checkTypeClassInstance moduleName) tys
+ forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
addTypeClassDictionaries (qualifyAllUnqualifiedNames moduleName env
- [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className ty (Just deps) TCDRegular])
+ [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular])
ds <- typeCheckAll mainModuleName moduleName rest
return $ qualifyAllUnqualifiedNames moduleName env d : ds
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index 3283520..068faf4 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -14,7 +14,6 @@
-----------------------------------------------------------------------------
{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Language.PureScript.TypeChecker.Kinds (
@@ -31,7 +30,6 @@ import Language.PureScript.Pretty
import Control.Monad.State
import Control.Monad.Error
-import Control.Monad.Reader
import Control.Monad.Unify
import Control.Applicative
@@ -59,7 +57,7 @@ instance Unifiable Check Kind where
-- Infer the kind of a single type
--
kindOf :: ModuleName -> Type -> Check Kind
-kindOf moduleName ty =
+kindOf _ ty =
rethrow (("Error checking kind of " ++ prettyPrintType ty ++ ":\n") ++) $
fmap tidyUp . liftUnify $ starIfUnknown <$> infer ty
where
@@ -87,8 +85,8 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do
let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars
bindLocalTypeVariables moduleName dict $ do
tyCons <- replicateM (length tys) fresh
- let dict = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons
- bindLocalTypeVariables moduleName dict $ do
+ let dict' = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons
+ bindLocalTypeVariables moduleName dict' $ do
data_ks <- zipWithM (\tyCon (_, args, ts) -> do
kargs <- replicateM (length args) fresh
let argDict = zip (map ProperName args) kargs
@@ -159,7 +157,9 @@ infer (RCons _ ty row) = do
k2 =?= Row k1
return $ Row k1
infer (ConstrainedType deps ty) = do
- mapM_ (infer . snd) deps
+ forM_ deps $ \(className, tys) -> do
+ _ <- infer $ foldl TypeApp (TypeConstructor className) tys
+ return ()
k <- infer ty
k =?= Star
return Star
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index c206590..6d9b73c 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -13,8 +13,8 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, RankNTypes, DeriveDataTypeable,
- GADTs, StandaloneDeriving, MultiParamTypeClasses, FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, RankNTypes,
+ MultiParamTypeClasses, FlexibleContexts #-}
module Language.PureScript.TypeChecker.Monad where
@@ -26,15 +26,13 @@ import Language.PureScript.Declarations
import Data.Data
import Data.Maybe
-import Data.Monoid
import Data.Generics (mkT, everywhere)
import Control.Applicative
import Control.Monad.State
import Control.Monad.Error
-import Control.Monad.Reader
import Control.Monad.Unify
-import Control.Arrow ((***))
+import Control.Arrow (first)
import qualified Data.Map as M
@@ -173,15 +171,15 @@ getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get
-- Temporarily bind a collection of names to local variables
--
bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type)] -> m a -> m a
-bindLocalVariables moduleName bindings action =
- bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((moduleName, name), (ty, LocalVariable))) action
+bindLocalVariables moduleName bindings =
+ bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((moduleName, name), (ty, LocalVariable)))
-- |
-- Temporarily bind a collection of names to local type variables
--
bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a
-bindLocalTypeVariables moduleName bindings action =
- bindTypes (M.fromList $ flip map bindings $ \(name, k) -> ((moduleName, name), (k, LocalTypeVariable))) action
+bindLocalTypeVariables moduleName bindings =
+ bindTypes (M.fromList $ flip map bindings $ \(name, k) -> ((moduleName, name), (k, LocalTypeVariable)))
-- |
-- Lookup the type of a value by name in the @Environment@
@@ -322,7 +320,7 @@ liftUnify unify = do
case e of
Left err -> throwError err
Right (a, ust) -> do
- modify $ \st -> st { checkNextVar = unifyNextVar ust }
+ modify $ \st' -> st' { checkNextVar = unifyNextVar ust }
return (a, unifyCurrentSubstitution ust)
-- |
@@ -334,7 +332,7 @@ qualifyAllUnqualifiedNames mn env = everywhere (mkT go)
go :: Type -> Type
go (TypeConstructor nm) = TypeConstructor $ qualify' nm
go (SaturatedTypeSynonym nm args) = SaturatedTypeSynonym (qualify' nm) args
- go (ConstrainedType constraints ty) = ConstrainedType (map (qualify' *** id) constraints) ty
+ go (ConstrainedType constraints ty) = ConstrainedType (map (first qualify') constraints) ty
go other = other
qualify' qual = let (mn', pn') = canonicalizeType mn env qual
in Qualified (Just mn') pn'
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 01f302e..0a3a9f2 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -14,7 +14,6 @@
-----------------------------------------------------------------------------
{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
@@ -60,7 +59,6 @@ import Language.PureScript.Pretty
import Control.Monad.State
import Control.Monad.Error
-import Control.Monad.Reader
import Control.Monad.Unify
import Control.Applicative
@@ -82,7 +80,7 @@ instance Unifiable Check Type where
-- Unify two types, updating the current substitution
--
unifyTypes :: Type -> Type -> UnifyT Type Check ()
-unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $ do
+unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $
unifyTypes' t1 t2
where
unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()
@@ -104,8 +102,8 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +
sko <- newSkolemConstant
let sk = skolemize ident sko sc ty1
sk `unifyTypes` ty2
- unifyTypes' (ForAll _ _ _) _ = throwError "Skolem variable scope is unspecified"
- unifyTypes' ty f@(ForAll _ _ _) = f `unifyTypes` ty
+ unifyTypes' ForAll{} _ = throwError "Skolem variable scope is unspecified"
+ unifyTypes' ty f@ForAll{} = f `unifyTypes` ty
unifyTypes' (Object row1) (Object row2) = row1 =?= row2
unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()
unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do
@@ -116,8 +114,8 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +
t3 `unifyTypes` t5
t4 `unifyTypes` t6
unifyTypes' (Skolem s1 _) (Skolem s2 _) | s1 == s2 = return ()
- unifyTypes' r1@(RCons _ _ _) r2 = unifyRows r1 r2
- unifyTypes' r1 r2@(RCons _ _ _) = unifyRows r1 r2
+ unifyTypes' r1@RCons{} r2 = unifyRows r1 r2
+ unifyTypes' r1 r2@RCons{} = unifyRows r1 r2
unifyTypes' r1@REmpty r2 = unifyRows r1 r2
unifyTypes' r1 r2@REmpty = unifyRows r1 r2
unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."
@@ -187,30 +185,30 @@ typesOf mainModuleName moduleName vals = do
-- If the declaration is a function, it has access to other values in the binding group.
-- If not, the generated code might fail at runtime since those values might be undefined.
let dict' = if isFunction val then dict else M.empty
- triple@(_, (val, ty)) <- case e of
+ triple@(_, (val', ty)) <- case e of
-- Typed declarations
- (ident, (val, Just (ty, checkType))) -> do
+ (ident, (val', Just (ty, checkType))) -> do
-- Kind check
kind <- liftCheck $ kindOf moduleName ty
guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
-- Check the type with the new names in scope
ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
- val' <- bindNames dict' $ if checkType
- then TypedValue True <$> check val ty' <*> pure ty'
- else return (TypedValue False val ty')
- return (ident, (val', ty'))
+ val'' <- bindNames dict' $ if checkType
+ then TypedValue True <$> check val' ty' <*> pure ty'
+ else return (TypedValue False val' ty')
+ return (ident, (val'', ty'))
-- Untyped declarations
- (ident, (val, Nothing)) -> do
+ (ident, (val', Nothing)) -> do
-- Infer the type with the new names in scope
- TypedValue _ val' ty <- bindNames dict' $ infer val
+ TypedValue _ val'' ty <- bindNames dict' $ infer val'
ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
- return (ident, (TypedValue True val' ty, ty))
+ return (ident, (TypedValue True val'' ty, ty))
-- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a
when (Just moduleName == mainModuleName && fst e == Ident "main") $ do
[eff, a] <- replicateM 2 fresh
- ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Eff"])) (ProperName "Eff"))) eff) a
+ ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a
-- Make sure unification variables do not escape
- escapeCheck val ty
+ escapeCheck val' ty
return triple
forM tys $ \(ident, (val, ty)) -> do
-- Replace type class dictionary placeholders with actual dictionaries
@@ -221,7 +219,7 @@ typesOf mainModuleName moduleName vals = do
-- top-level unification variables with named type variables.
let val'' = overTypes (desaturateAllTypeSynonyms . setifyAll) val'
ty' = varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty
- return $ (ident, (val'', ty'))
+ return (ident, (val'', ty'))
where
-- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts
@@ -260,14 +258,14 @@ replaceTypeClassDictionaries mn = everywhereM' (mkM go)
-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
-- return a type class dictionary reference.
--
-entails :: ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, Type) -> Check Value
-entails moduleName context goal@(className, ty) = do
+entails :: ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Check Value
+entails moduleName context goal@(className, tys) = do
env <- getEnv
case go env goal of
- [] -> throwError $ "No " ++ show className ++ " instance found for " ++ prettyPrintType ty
+ [] -> throwError $ "No " ++ show className ++ " instance found for " ++ intercalate ", " (map prettyPrintType tys)
(dict : _) -> return dict
where
- go env (className', ty') =
+ go env (className', tys') =
[ mkDictionary (canonicalizeDictionary tcd) args
| tcd <- context
-- Choose type class dictionaries in scope in the current module
@@ -275,16 +273,16 @@ entails moduleName context goal@(className, ty) = do
-- Make sure the type class name matches the one we are trying to satisfy
, typeConstructorsAreEqual env moduleName className' (tcdClassName tcd)
-- Make sure the type unifies with the type in the type instance definition
- , subst <- maybeToList $ typeHeadsAreEqual moduleName env ty' (tcdInstanceType tcd)
+ , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
-- Solve any necessary subgoals
, args <- solveSubgoals env subst (tcdDependencies tcd) ]
-- Create dictionaries for subgoals which still need to be solved by calling go recursively
-- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
-- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
- solveSubgoals :: Environment -> [(String, Type)] -> Maybe [(Qualified ProperName, Type)] -> [Maybe [Value]]
+ solveSubgoals :: Environment -> [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [Value]]
solveSubgoals _ _ Nothing = return Nothing
solveSubgoals env subst (Just subgoals) = do
- dict <- mapM (go env) (map (id *** replaceAllTypeVars subst) subgoals)
+ dict <- mapM (go env . second (map (replaceAllTypeVars subst))) subgoals
return $ Just dict
-- Make a dictionary from subgoal dictionaries by applying the correct function
mkDictionary :: Qualified Ident -> Maybe [Value] -> Value
@@ -301,6 +299,12 @@ entails moduleName context goal@(className, ty) = do
canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident
canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm
canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm
+ -- Ensure that a substitution is valid
+ verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]
+ verifySubstitution subst = do
+ let grps = groupBy ((==) `on` fst) subst
+ guard (all ((==) 1 . length . nubBy ((==) `on` snd)) grps)
+ return $ map head grps
-- |
-- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup),
@@ -314,7 +318,7 @@ typeHeadsAreEqual m e (TypeConstructor c1) (TypeConstructor c2) | typeConstructo
typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2
typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1
typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e m name args of
- Left err -> Nothing
+ Left _ -> Nothing
Right t1 -> typeHeadsAreEqual m e t1 t2
typeHeadsAreEqual _ _ _ _ = Nothing
@@ -344,7 +348,7 @@ findAllTypes = everything (++) (mkQ [] go)
--
skolemEscapeCheck :: Value -> Check ()
skolemEscapeCheck (TypedValue False _ _) = return ()
-skolemEscapeCheck root@(TypedValue _ _ _) =
+skolemEscapeCheck root@TypedValue{} =
-- Every skolem variable is created when a ForAll type is skolemized.
-- This determines the scope of that skolem variable, which is copied from the SkolemScope
-- field of the ForAll constructor.
@@ -368,10 +372,10 @@ skolemEscapeCheck root@(TypedValue _ _ _) =
collect _ = []
go _ scos = ([], scos)
findBindingScope :: SkolemScope -> Maybe Value
- findBindingScope sco = something (mkQ Nothing go) root
+ findBindingScope sco = something (mkQ Nothing go') root
where
- go val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = Just val
- go _ = Nothing
+ go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = Just val
+ go' _ = Nothing
skolemEscapeCheck val = throwError $ "Untyped value passed to skolemEscapeCheck: " ++ prettyPrintValue val
-- |
@@ -393,19 +397,13 @@ varIfUnknown :: Type -> Type
varIfUnknown ty =
let unks = nub $ unknowns ty
toName = (:) 't' . show
- ty' = everywhere (mkT typeToVar) $ ty
+ ty' = everywhere (mkT typeToVar) ty
typeToVar :: Type -> Type
typeToVar (TUnknown (Unknown u)) = TypeVar (toName u)
typeToVar t = t
in mkForAll (sort . map (toName . runUnknown) $ unks) ty'
-- |
--- Replace named type variables with types
---
-replaceAllTypeVars :: [(String, Type)] -> Type -> Type
-replaceAllTypeVars = foldl' (\f (name, ty) -> replaceTypeVars name ty . f) id
-
--- |
-- Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns
-- or TypeClassDictionary values.
--
@@ -430,7 +428,7 @@ instantiatePolyTypeWithUnknowns val ty = return (val, ty)
replaceVarWithUnknown :: String -> Type -> UnifyT Type Check Type
replaceVarWithUnknown ident ty = do
tu <- fresh
- return $ replaceTypeVars ident tu $ ty
+ return $ replaceTypeVars ident tu ty
-- |
-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate
@@ -603,11 +601,11 @@ inferBinder val (ConstructorBinder ctor binders) = do
(_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contains constraints") ty
go binders fn
where
- go [] ty = do
- subsumes Nothing val ty
+ go [] ty' = do
+ subsumes Nothing val ty'
return M.empty
- go (binder : binders) (TypeApp (TypeApp t obj) ret) | t == tyFunction =
- M.union <$> inferBinder obj binder <*> go binders ret
+ go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction =
+ M.union <$> inferBinder obj binder <*> go binders' ret
go _ _ = throwError $ "Wrong number of arguments to constructor " ++ show ctor
_ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
inferBinder val (ObjectBinder props) = do
@@ -713,7 +711,7 @@ check val ty = rethrow errorMessage $ check' val ty
-- Check the type of a value
--
check' :: Value -> Type -> UnifyT Type Check Value
-check' val t@(ForAll ident ty _) = do
+check' val (ForAll ident ty _) = do
scope <- newSkolemScope
sko <- newSkolemConstant
let sk = skolemize ident sko scope ty
@@ -722,15 +720,15 @@ check' val t@(ForAll ident ty _) = do
check' val t@(ConstrainedType constraints ty) = do
env <- getEnv
Just moduleName <- checkCurrentModule <$> get
- dictNames <- flip mapM constraints $ \(Qualified _ (ProperName className), _) -> do
+ dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do
n <- liftCheck freshDictionaryName
return $ Ident $ "__dict_" ++ className ++ "_" ++ show n
val' <- withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->
TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)
(qualifyAllUnqualifiedNames moduleName env constraints)) $
check val ty
- return $ TypedValue True (foldr Abs val' (map Left dictNames)) t
-check' val t@(SaturatedTypeSynonym name args) = do
+ return $ TypedValue True (foldr (Abs . Left) val' dictNames) t
+check' val (SaturatedTypeSynonym name args) = do
ty <- introduceSkolemScope <=< expandTypeSynonym name $ args
val' <- check val ty
return $ TypedValue True val' ty
@@ -747,8 +745,8 @@ check' v@(StringLiteral _) t | t == tyString =
check' v@(BooleanLiteral _) t | t == tyBoolean =
return $ TypedValue True v t
check' (ArrayLiteral vals) t@(TypeApp a ty) | a == tyArray = do
- arr <- ArrayLiteral <$> forM vals (\val -> check val ty)
- return $ TypedValue True arr t
+ array <- ArrayLiteral <$> forM vals (`check` ty)
+ return $ TypedValue True array t
check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) | t == tyFunction = do
Just moduleName <- checkCurrentModule <$> get
ret' <- bindLocalVariables moduleName [(arg, argTy)] $ check ret retTy
@@ -944,17 +942,17 @@ subsumes' val (Object r1) (Object r2) = do
go ts1' ts2' r1' r2'
return val
where
- go [] ts2 r1 r2 = r1 =?= rowFromList (ts2, r2)
- go ts1 [] r1 r2 = r2 =?= rowFromList (ts1, r1)
- go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1 r2
+ go [] ts2 r1' r2' = r1' =?= rowFromList (ts2, r2')
+ go ts1 [] r1' r2' = r2' =?= rowFromList (ts1, r1')
+ go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1' r2'
| p1 == p2 = do subsumes Nothing ty1 ty2
- go ts1 ts2 r1 r2
+ go ts1 ts2 r1' r2'
| p1 < p2 = do rest <- fresh
- r2 =?= RCons p1 ty1 rest
- go ts1 ((p2, ty2) : ts2) r1 rest
+ r2' =?= RCons p1 ty1 rest
+ go ts1 ((p2, ty2) : ts2) r1' rest
| p1 > p2 = do rest <- fresh
- r1 =?= RCons p2 ty2 rest
- go ((p1, ty1) : ts1) ts2 rest r2
+ r1' =?= RCons p2 ty2 rest
+ go ((p1, ty1) : ts1) ts2 rest r2'
subsumes' val ty1 ty2@(Object _) = subsumes val ty2 ty1
subsumes' val ty1 ty2 = do
ty1 =?= ty2
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index 85d0d60..7ca3e5d 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -19,10 +19,10 @@ module Language.PureScript.Types where
import Data.Data
import Data.List (nub)
-import Data.Generics (everything, mkT, mkQ, everywhereBut)
+import Data.Generics (everything, mkQ)
import Control.Monad.Unify
-import Control.Arrow ((***))
+import Control.Arrow (second)
import Language.PureScript.Names
@@ -66,7 +66,7 @@ data Type
-- |
-- A type with a set of type class constraints
--
- | ConstrainedType [(Qualified ProperName, Type)] Type
+ | ConstrainedType [(Qualified ProperName, [Type])] Type
-- |
-- A skolem constant
--
@@ -122,7 +122,7 @@ tyArray = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"])
-- Smart constructor for function types
--
function :: Type -> Type -> Type
-function t1 t2 = TypeApp (TypeApp tyFunction t1) t2
+function t1 = TypeApp (TypeApp tyFunction t1)
-- |
-- Convert a row to a list of pairs of labels and types
@@ -143,8 +143,8 @@ rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r))
-- Check whether a type is a monotype
--
isMonoType :: Type -> Bool
-isMonoType (ForAll _ _ _) = False
-isMonoType ty = True
+isMonoType ForAll{} = False
+isMonoType _ = True
-- |
-- Universally quantify a type
@@ -168,17 +168,17 @@ replaceTypeVars = replaceTypeVars' []
where
go :: [String] -> Type -> Type
go bs (Object r) = Object $ go bs r
- go bs (TypeVar v) | v == name = replacement
+ go _ (TypeVar v) | v == name = replacement
go bs (TypeApp t1 t2) = TypeApp (go bs t1) (go bs t2)
- go bs (SaturatedTypeSynonym name ts) = SaturatedTypeSynonym name $ map (go bs) ts
+ go bs (SaturatedTypeSynonym name' ts) = SaturatedTypeSynonym name' $ map (go bs) ts
go bs f@(ForAll v t sco) | v == name = f
| v `elem` usedTypeVariables replacement =
let v' = genName v (name : bs ++ usedTypeVariables replacement)
t' = replaceTypeVars' bs v (TypeVar v') t
in ForAll v' (go (v' : bs) t') sco
| otherwise = ForAll v (go (v : bs) t) sco
- go bs (ConstrainedType cs t) = ConstrainedType (map (id *** go bs) cs) (go bs t)
- go bs (RCons name t r) = RCons name (go bs t) (go bs r)
+ go bs (ConstrainedType cs t) = ConstrainedType (map (second $ map (go bs)) cs) (go bs t)
+ go bs (RCons name' t r) = RCons name' (go bs t) (go bs r)
go _ ty = ty
genName orig inUse = try 0
where
@@ -186,6 +186,12 @@ replaceTypeVars = replaceTypeVars' []
| otherwise = orig ++ show n
-- |
+-- Replace named type variables with types
+--
+replaceAllTypeVars :: [(String, Type)] -> Type -> Type
+replaceAllTypeVars = foldl (\f (name, ty) -> replaceTypeVars name ty . f) id
+
+-- |
-- Collect all type variables appearing in a type
--
usedTypeVariables :: Type -> [String]
@@ -206,7 +212,7 @@ freeTypeVariables = nub . go []
go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2
go bound (SaturatedTypeSynonym _ ts) = concatMap (go bound) ts
go bound (ForAll v t _) = go (v : bound) t
- go bound (ConstrainedType cs t) = concatMap (go bound . snd) cs ++ go bound t
+ go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) . snd) cs ++ go bound t
go bound (RCons _ t r) = go bound t ++ go bound r
go _ _ = []
diff --git a/src/Language/PureScript/Values.hs b/src/Language/PureScript/Values.hs
index 9873c68..3add094 100644
--- a/src/Language/PureScript/Values.hs
+++ b/src/Language/PureScript/Values.hs
@@ -112,7 +112,7 @@ data Value
-- can be evaluated at runtime. The constructor arguments represent (in order): the type class name and
-- instance type, and the type class dictionaries in scope.
--
- | TypeClassDictionary (Qualified ProperName, Type) [TypeClassDictionaryInScope] deriving (Show, Data, Typeable)
+ | TypeClassDictionary (Qualified ProperName, [Type]) [TypeClassDictionaryInScope] deriving (Show, Data, Typeable)
-- |
-- The type of a type class dictionary
@@ -141,13 +141,13 @@ data TypeClassDictionaryInScope
--
, tcdClassName :: Qualified ProperName
-- |
- -- The type to which this type class instance applies
+ -- The types to which this type class instance applies
--
- , tcdInstanceType :: Type
+ , tcdInstanceTypes :: [Type]
-- |
-- Type class dependencies which must be satisfied to construct this dictionary
--
- , tcdDependencies :: Maybe [(Qualified ProperName, Type)]
+ , tcdDependencies :: Maybe [(Qualified ProperName, [Type])]
-- |
-- The type of this dictionary
--
diff --git a/tests/Main.hs b/tests/Main.hs
index 1411c89..fe06cf0 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -20,7 +20,6 @@ import qualified Language.PureScript as P
import Data.List (isSuffixOf)
import Data.Traversable (traverse)
-import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import System.Exit
@@ -31,7 +30,6 @@ import System.Environment (getArgs)
import Text.Parsec (ParseError)
import qualified Paths_purescript as Paths
import qualified System.IO.UTF8 as U
-import qualified Data.Map as M
preludeFilename :: IO FilePath
preludeFilename = Paths.getDataFileName "prelude/prelude.purs"
@@ -45,13 +43,13 @@ compile :: P.Options -> [FilePath] -> IO (Either String String)
compile opts inputFiles = do
modules <- readInput inputFiles
case modules of
- Left parseError -> do
+ Left parseError ->
return (Left $ show parseError)
- Right ms -> do
+ Right ms ->
case P.compile opts ms of
- Left typeError -> do
+ Left typeError ->
return (Left typeError)
- Right (js, _, _) -> do
+ Right (js, _, _) ->
return (Right js)
assert :: P.Options -> [FilePath] -> (Either String String -> IO (Maybe String)) -> IO ()
@@ -93,7 +91,7 @@ assertDoesNotCompile inputFile = do
main :: IO ()
main = do
cd <- getCurrentDirectory
- putStrLn $ cd
+ putStrLn cd
let examples = cd ++ pathSeparator : "examples"
let passing = examples ++ pathSeparator : "passing"
passingTestCases <- getDirectoryContents passing