summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-01-28 06:32:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-01-28 06:32:00 (GMT)
commitb9baaa3d13ed8d5ac0817292097b395775c0742e (patch)
tree2da5f50a43e679acaae14a0546535ceae1871977
parente29a60804b4acdeb46626233ee4001384978dff1 (diff)
version 0.3.40.3.4
-rw-r--r--libraries/prelude/prelude.purs371
-rw-r--r--purescript.cabal4
-rw-r--r--src/Data/Generics/Extras.hs4
-rw-r--r--src/Language/PureScript.hs18
-rw-r--r--src/Language/PureScript/CodeGen.hs7
-rw-r--r--src/Language/PureScript/CodeGen/Externs.hs4
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs7
-rw-r--r--src/Language/PureScript/CodeGen/JS/AST.hs93
-rw-r--r--src/Language/PureScript/CodeGen/Monad.hs12
-rw-r--r--src/Language/PureScript/CodeGen/Optimize.hs48
-rw-r--r--src/Language/PureScript/Declarations.hs86
-rw-r--r--src/Language/PureScript/Kinds.hs18
-rw-r--r--src/Language/PureScript/ModuleDependencies.hs20
-rw-r--r--src/Language/PureScript/Names.hs26
-rw-r--r--src/Language/PureScript/Options.hs23
-rw-r--r--src/Language/PureScript/Parser.hs13
-rw-r--r--src/Language/PureScript/Parser/Common.hs185
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs10
-rw-r--r--src/Language/PureScript/Parser/JS.hs4
-rw-r--r--src/Language/PureScript/Parser/Kinds.hs5
-rw-r--r--src/Language/PureScript/Parser/State.hs12
-rw-r--r--src/Language/PureScript/Parser/Types.hs10
-rw-r--r--src/Language/PureScript/Parser/Values.hs19
-rw-r--r--src/Language/PureScript/Pretty.hs9
-rw-r--r--src/Language/PureScript/Pretty/Common.hs68
-rw-r--r--src/Language/PureScript/Pretty/JS.hs19
-rw-r--r--src/Language/PureScript/Pretty/Kinds.hs4
-rw-r--r--src/Language/PureScript/Pretty/Types.hs7
-rw-r--r--src/Language/PureScript/Pretty/Values.hs7
-rw-r--r--src/Language/PureScript/Scope.hs7
-rw-r--r--src/Language/PureScript/Sugar.hs16
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs14
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs9
-rw-r--r--src/Language/PureScript/Sugar/DoNotation.hs6
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs8
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs13
-rw-r--r--src/Language/PureScript/Sugar/TypeDeclarations.hs8
-rw-r--r--src/Language/PureScript/TypeChecker.hs14
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs19
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs184
-rw-r--r--src/Language/PureScript/TypeChecker/Synonyms.hs10
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs189
-rw-r--r--src/Language/PureScript/Types.hs73
-rw-r--r--src/Language/PureScript/Unknown.hs4
-rw-r--r--src/Language/PureScript/Values.hs284
-rw-r--r--tests/Main.hs55
46 files changed, 1854 insertions, 172 deletions
diff --git a/libraries/prelude/prelude.purs b/libraries/prelude/prelude.purs
index 44d2203..414c4fd 100644
--- a/libraries/prelude/prelude.purs
+++ b/libraries/prelude/prelude.purs
@@ -49,8 +49,9 @@ module Maybe where
fromMaybe :: forall a. a -> Maybe a -> a
fromMaybe a = maybe a Prelude.id
- bindMaybe :: forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
- bindMaybe m f = maybe Nothing f m
+ instance Prelude.Monad Maybe where
+ ret = Just
+ (>>=) m f = maybe Nothing f m
module Either where
@@ -60,11 +61,13 @@ module Either where
either f _ (Left a) = f a
either _ g (Right b) = g b
- bindEither :: forall e a b. Either e a -> (a -> Either e b) -> Either e b
- bindEither = either (\e _ -> Left e) (\a f -> f a)
+ instance Prelude.Monad (Either e) where
+ ret = Right
+ (>>=) = either (\e _ -> Left e) (\a f -> f a)
module Arrays where
+ import Prelude
import Maybe
head :: forall a. [a] -> a
@@ -97,27 +100,77 @@ module Arrays where
\ return xs.length; \
\}" :: forall a. [a] -> Number
- foreign import indexOf :: forall a. [a] -> a -> Number
-
- foreign import lastIndexOf :: forall a. [a] -> a -> Number
-
- foreign import concat :: forall a. [a] -> [a] -> [a]
-
- foreign import join :: [String] -> String
-
- foreign import joinWith :: [String] -> String -> String
-
- foreign import push :: forall a. [a] -> a -> [a]
-
- foreign import reverse :: forall a. [a] -> [a]
-
- foreign import shift :: forall a. [a] -> [a]
-
- foreign import slice :: forall a. Number -> Number -> [a] -> [a]
-
- foreign import sort :: forall a. [a] -> [a]
-
- foreign import splice :: forall a. Number -> Number -> [a] -> [a] -> [a]
+ foreign import indexOf "function indexOf(l) {\
+ \ return function (e) {\
+ \ return l.indexOf(e);\
+ \ };\
+ \}" :: forall a. [a] -> a -> Number
+
+ foreign import lastIndexOf "function lastIndexOf(l) {\
+ \ return function (e) {\
+ \ return l.lastIndexOf(e);\
+ \ };\
+ \}" :: forall a. [a] -> a -> Number
+
+ foreign import concat "function concat(l1) {\
+ \ return function (l2) {\
+ \ return l1.concat(l2);\
+ \ };\
+ \}" :: forall a. [a] -> [a] -> [a]
+
+ foreign import join "function join(l) {\
+ \ return l.join();\
+ \}" :: [String] -> String
+
+ foreign import joinWith "function joinWith(l) {\
+ \ return function (s) {\
+ \ return l.join(s);\
+ \ };\
+ \}" :: [String] -> String -> String
+
+ foreign import push "function push(l) {\
+ \ return function (e) {\
+ \ var l1 = l.slice();\
+ \ l1.push(e); \
+ \ return l1;\
+ \ };\
+ \}" :: forall a. [a] -> a -> [a]
+
+ foreign import reverse "function reverse(l) {\
+ \ var l1 = l.slice();\
+ \ l1.reverse(); \
+ \ return l1;\
+ \}" :: forall a. [a] -> [a]
+
+ foreign import shift "function shift(l) {\
+ \ var l1 = l.slice();\
+ \ l1.shift();\
+ \ return l1;\
+ \}" :: forall a. [a] -> [a]
+
+ foreign import slice "function slice(s) {\
+ \ return function(e) {\
+ \ return function (l) {\
+ \ return l.slice(s, e);\
+ \ };\
+ \ };\
+ \}" :: forall a. Number -> Number -> [a] -> [a]
+
+ foreign import sort "function sort(l) {\
+ \ var l1 = l.slice();\
+ \ l.sort();\
+ \ 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]
infixr 6 :
@@ -158,6 +211,10 @@ module Arrays where
all _ [] = true
all p (a:as) = p a && all p as
+ instance (Prelude.Show a) => Prelude.Show [a] where
+ show [] = "[]"
+ show (x:xs) = show x ++ " : " ++ show xs
+
module Tuple where
import Arrays
@@ -187,57 +244,141 @@ module String where
\ return s.length;\
\}" :: String -> Number
- foreign import charAt :: Number -> String -> String
-
- foreign import indexOfS :: String -> String -> Number
-
- foreign import lastIndexOfS :: String -> String -> Number
-
- foreign import localeCompare :: String -> String -> Number
-
- foreign import replace :: String -> String -> String -> String
-
- foreign import sliceS :: Number -> Number -> String -> String
-
- foreign import split :: String -> String -> [String]
-
- foreign import substr :: Number -> Number -> String -> String
-
- foreign import substring :: Number -> Number -> String -> String
-
- foreign import toLower :: String -> String
-
- foreign import toUpper :: String -> String
-
- foreign import trim :: String -> String
+ foreign import charAt "function charAt(i) {\
+ \ return function(s) {\
+ \ return s.charAt(i); \
+ \ };\
+ \}" :: Number -> String -> String
+
+ foreign import indexOfS "function indexOfS(s1) {\
+ \ return function(s2) {\
+ \ return s2.indexOf(s2);\
+ \ }; \
+ \}" :: String -> String -> Number
+
+ foreign import lastIndexOfS "function lastIndexOfS(s1) {\
+ \ return function(s2) {\
+ \ return s2.lastIndexOf(s2);\
+ \ };\
+ \}" :: String -> String -> Number
+
+ foreign import localeCompare "function localeCompare(s1) {\
+ \ return function(s2) { \
+ \ return s1.localeCompare(s2);\
+ \ };\
+ \}" :: String -> String -> Number
+
+ foreign import replace "function replace(s1) {\
+ \ return function(s2) {\
+ \ return function(s3) {\
+ \ return s3.replace(s1, s2);\
+ \ };\
+ \ };\
+ \}" :: String -> String -> String -> String
+
+ foreign import sliceS "function sliceS(st) {\
+ \ return function(e) {\
+ \ return function(s) {\
+ \ return s.slice(st, e);\
+ \ };\
+ \ };\
+ \}" :: Number -> Number -> String -> String
+
+ foreign import split "function split(sep) {\
+ \ return function(s) {\
+ \ return s.split(s);\
+ \ };\
+ \}" :: String -> String -> [String]
+
+ foreign import substr "function substr(n1) {\
+ \ return function(n2) {\
+ \ return function(s) {\
+ \ return s.substr(n1, n2);\
+ \ };\
+ \ };\
+ \}" :: Number -> Number -> String -> String
+
+ foreign import substring "function substring(n1) {\
+ \ return function(n2) {\
+ \ return function(s) {\
+ \ return s.substring(n1, n2);\
+ \ };\
+ \ };\
+ \}" :: Number -> Number -> String -> String
+
+ foreign import toLower "function toLower(s) {\
+ \ return s.toLower();\
+ \}" :: String -> String
+
+ foreign import toUpper "function toUpper(s) {\
+ \ return s.toUpper();\
+ \}" :: String -> String
+
+ foreign import trim "function trim(s) {\
+ \ return s.trim();\
+ \}" :: String -> String
module Regex where
foreign import data Regex :: *
- foreign import regex :: String -> String -> Regex
-
- foreign import test :: Regex -> String -> Boolean
-
- foreign import match :: Regex -> String -> [String]
-
- foreign import replaceR :: Regex -> String -> String -> String
-
- foreign import search :: Regex -> String -> Number
+ foreign import regex "function regex(s1) {\
+ \ return function(s2) {\
+ \ return new Regex(s1, s2);\
+ \ };\
+ \}" :: String -> String -> Regex
+
+ foreign import test "function test(r) {\
+ \ return function (s) { \
+ \ return r.test(s);\
+ \ };\
+ \}" :: Regex -> String -> Boolean
+
+ foreign import match "function match(r) {\
+ \ return function (s) {\
+ \ return s.match(r); \
+ \ };\
+ \}" :: Regex -> String -> [String]
+
+ foreign import replaceR "function replaceR(r) {\
+ \ return function(s1) {\
+ \ return function(s2) { \
+ \ return s2.replace(r, s1);\
+ \ };\
+ \ };\
+ \}" :: Regex -> String -> String -> String
+
+ foreign import search "function search(r) {\
+ \ return function (s) {\
+ \ return s.search(r);\
+ \ };\
+ \}" :: Regex -> String -> Number
module Global where
- foreign import nan :: Number
+ foreign import nan "var nan = NaN;" :: Number
- foreign import infinity :: Number
+ foreign import infinity "var infinity = Infinity;" :: Number
- foreign import toExponential :: Number -> String
+ foreign import toExponential "function toExponential(n) {\
+ \ return n.toExponential();\
+ \}" :: Number -> String
- foreign import toFixed :: Number -> Number -> String
+ foreign import toFixed "function toFixed(d) {\
+ \ return function(n) {\
+ \ return n.toFixed(d);\
+ \ };\
+ \}" :: Number -> Number -> String
- foreign import toPrecision :: Number -> Number -> String
+ foreign import toPrecision "function toPrecision(d) {\
+ \ return function(n) {\
+ \ return n.toPrecision(d);\
+ \ };\
+ \}" :: Number -> Number -> String
- foreign import numberToString :: Number -> String
+ foreign import numberToString "function numberToString(n) {\
+ \ return n.toString();\
+ \}" :: Number -> String
foreign import isNaN :: Number -> Boolean
@@ -255,6 +396,9 @@ module Global where
foreign import decodeURI :: String -> String
+ instance Prelude.Show Number where
+ show = numberToString
+
module Math where
type Math =
@@ -277,19 +421,31 @@ module Math where
, tan :: Number -> Number
}
- foreign import math :: Math
+ foreign import math "var math = Math;" :: Math
module Eff where
foreign import data Eff :: # ! -> * -> *
- foreign import retEff "function retEff(a) { return function() { return a; }; }" :: forall e a. a -> Eff e a
+ foreign import retEff "function retEff(a) { \
+ \ return function() { \
+ \ return a; \
+ \ }; \
+ \}" :: forall e a. a -> Eff e a
- foreign import bindEff "function bindEff(a) { return function(f) { return function() { return f(a())(); }; }; }" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b
+ foreign import bindEff "function bindEff(a) { \
+ \ return function(f) { \
+ \ return function() { \
+ \ return f(a())(); \
+ \ }; \
+ \ }; \
+ \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b
type Pure a = forall e. Eff e a
- foreign import runPure "function runPure(f) { return f(); }" :: forall a. Pure a -> a
+ foreign import runPure "function runPure(f) { \
+ \ return f(); \
+ \}" :: forall a. Pure a -> a
instance Prelude.Monad (Eff e) where
ret = retEff
@@ -301,9 +457,23 @@ module Errors where
foreign import data Error :: * -> !
- foreign import throwError "function throwError(e) { return function() { throw e; }; }" :: forall a e r. e -> Eff (err :: Error e | r) a
-
- foreign import catchError "function catchError(c) { return function(t) { return function() { try { return t(); } catch(e) { return c(e)(); } }; }; }" :: forall e r a. (e -> Eff r a) -> Eff (err :: Error e | r) a -> Eff r a
+ foreign import throwError "function throwError(e) { \
+ \ return function() { \
+ \ throw e; \
+ \ }; \
+ \}" :: forall a e r. e -> Eff (err :: Error e | r) a
+
+ foreign import catchError "function catchError(c) { \
+ \ return function(t) { \
+ \ return function() { \
+ \ try { \
+ \ return t(); \
+ \ } catch(e) { \
+ \ return c(e)(); \
+ \ }\
+ \ }; \
+ \ }; \
+ \}" :: forall e r a. (e -> Eff r a) -> Eff (err :: Error e | r) a -> Eff r a
module IORef where
@@ -313,11 +483,25 @@ module IORef where
foreign import data IORef :: * -> *
- foreign import newIORef :: forall s r. s -> Eff (ref :: Ref | r) (IORef s)
-
- foreign import readIORef :: forall s r. IORef s -> Eff (ref :: Ref | r) s
-
- foreign import writeIORef :: forall s r. IORef s -> s -> Eff (ref :: Ref | r) {}
+ foreign import newIORef "function newIORef(val) {\
+ \ return function () {\
+ \ return { value: val };\
+ \ };\
+ \}" :: forall s r. s -> Eff (ref :: Ref | r) (IORef s)
+
+ foreign import readIORef "function readIORef(ref) {\
+ \ return function() {\
+ \ return ref.value;\
+ \ };\
+ \}" :: forall s r. IORef s -> Eff (ref :: Ref | r) s
+
+ foreign import writeIORef "function writeIORef(ref) {\
+ \ return function(val) {\
+ \ return function() {\
+ \ ref.value = val;\
+ \ };\
+ \ };\
+ \}" :: forall s r. IORef s -> s -> Eff (ref :: Ref | r) {}
module Trace where
@@ -326,7 +510,12 @@ module Trace where
foreign import data Trace :: !
- foreign import trace "function trace(s) { return function() { console.log(s); return {}; }; }" :: forall r. String -> Eff (trace :: Trace | r) {}
+ foreign import trace "function trace(s) { \
+ \ return function() { \
+ \ console.log(s); \
+ \ return {}; \
+ \ }; \
+ \}" :: forall r. String -> Eff (trace :: Trace | r) {}
print :: forall a r. (Prelude.Show a) => a -> Eff (trace :: Trace | r) {}
print o = trace (show o)
@@ -339,11 +528,27 @@ module ST where
foreign import data STRef :: * -> * -> *
- foreign import newSTRef :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)
-
- foreign import readSTRef :: forall a h r. STRef h a -> Eff (st :: ST h | r) a
-
- foreign import modifySTRef :: forall a h r. (a -> a) -> STRef h a -> Eff (st :: ST h | r) {}
-
- foreign import runST :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a
+ foreign import newSTRef "function newSTRef(val) {\
+ \ return function () {\
+ \ return { value: val };\
+ \ };\
+ \}" :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)
+
+ foreign import readSTRef "function readSTRef(ref) {\
+ \ return function() {\
+ \ return ref.value;\
+ \ };\
+ \}" :: forall a h r. STRef h a -> Eff (st :: ST h | r) a
+
+ foreign import modifySTRef "function modifySTRef(f) {\
+ \ return function(ref) {\
+ \ return function() {\
+ \ ref.value = f(ref.value);\
+ \ };\
+ \ };\
+ \}" :: forall a h r. (a -> a) -> STRef h a -> Eff (st :: ST h | r) {}
+
+ foreign import runST "function runST(f) {\
+ \ return f;\
+ \}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a
diff --git a/purescript.cabal b/purescript.cabal
index a3b3923..56778d8 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.3.3
+version: 0.3.4
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -89,7 +89,7 @@ executable psci
test-suite tests
build-depends: base >=4 && <5, containers -any, directory -any,
filepath -any, mtl -any, parsec -any, purescript -any, syb -any,
- transformers -any, utf8-string -any
+ transformers -any, utf8-string -any, process -any
type: exitcode-stdio-1.0
main-is: Main.hs
buildable: True
diff --git a/src/Data/Generics/Extras.hs b/src/Data/Generics/Extras.hs
index 02db199..80ffede 100644
--- a/src/Data/Generics/Extras.hs
+++ b/src/Data/Generics/Extras.hs
@@ -9,6 +9,7 @@
-- Portability :
--
-- |
+-- Additional SYB combinators
--
-----------------------------------------------------------------------------
@@ -18,6 +19,9 @@ module Data.Generics.Extras where
import Data.Data
+-- |
+-- Apply a top-down monadic transformation everywhere
+--
everywhereM' :: (Monad m, Data d) => (forall d1. (Data d1) => d1 -> m d1) -> d -> m d
everywhereM' f x = do
y <- f x
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index 45c9d75..8bff204 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -9,6 +9,7 @@
-- Portability :
--
-- |
+-- The main compiler module
--
-----------------------------------------------------------------------------
@@ -32,6 +33,23 @@ import Control.Monad (when, forM)
import Control.Applicative ((<$>))
import qualified Data.Map as M
+-- |
+-- Compile a collection of modules
+--
+-- The compilation pipeline proceeds as follows:
+--
+-- * Sort the modules based on module dependencies, checking for cyclic dependencies.
+--
+-- * Perform a set of desugaring passes.
+--
+-- * Type check, and elaborate values to include type annotations and type class dictionaries.
+--
+-- * Regroup values to take into account new value dependencies introduced by elaboration
+--
+-- * Generate Javascript, and perform optimization passes.
+--
+-- * Pretty-print the generated Javascript
+--
compile :: Options -> [Module] -> Either String (String, String, Environment)
compile opts ms = do
sorted <- sortModules ms
diff --git a/src/Language/PureScript/CodeGen.hs b/src/Language/PureScript/CodeGen.hs
index a5bee01..0540020 100644
--- a/src/Language/PureScript/CodeGen.hs
+++ b/src/Language/PureScript/CodeGen.hs
@@ -9,6 +9,13 @@
-- Portability :
--
-- |
+-- A collection of modules related to code generation:
+--
+-- [@Language.PureScript.CodeGen.JS@] Code generator for Javascript
+--
+-- [@Language.PureScript.CodeGen.Externs@] Code generator for extern (foreign import) files
+--
+-- [@Language.PureScript.CodeGen.Optimize@] Optimization passes for generated Javascript
--
-----------------------------------------------------------------------------
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
index 7fce595..e6d6c9f 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -9,6 +9,7 @@
-- Portability :
--
-- |
+-- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations.
--
-----------------------------------------------------------------------------
@@ -24,6 +25,9 @@ import Language.PureScript.Pretty
import Language.PureScript.Names
import Data.List (intercalate)
+-- |
+-- Generate foreign imports for all declarations in a module
+--
moduleToPs :: Module -> Environment -> String
moduleToPs (Module pname@(ProperName moduleName) decls) env =
"module " ++ moduleName ++ " where\n" ++
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 158dd67..4fed12e 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -9,6 +9,7 @@
-- Portability :
--
-- |
+-- This module generates code in the simplified Javascript intermediate representation from Purescript code
--
-----------------------------------------------------------------------------
@@ -41,6 +42,9 @@ import Language.PureScript.CodeGen.JS.AST as AST
import Language.PureScript.Types
import Language.PureScript.CodeGen.Optimize
+-- |
+-- Generate code in the simplified Javascript intermediate representation for all declarations in a module
+--
moduleToJs :: Options -> Module -> Environment -> [JS]
moduleToJs opts (Module pname@(ProperName name) decls) env =
mapMaybe filterRawDecls decls ++
@@ -58,6 +62,9 @@ moduleToJs opts (Module pname@(ProperName name) decls) env =
typeClassesLast _ (ExternDeclaration TypeClassDictionaryImport _ _ _) = LT
typeClassesLast _ _ = EQ
+-- |
+-- 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 ident (Just (valueToJs opts mp e val)),
diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs
index 7d531cf..58a8fa9 100644
--- a/src/Language/PureScript/CodeGen/JS/AST.hs
+++ b/src/Language/PureScript/CodeGen/JS/AST.hs
@@ -9,6 +9,7 @@
-- Portability :
--
-- |
+-- Data types for the intermediate simplified-Javascript AST
--
-----------------------------------------------------------------------------
@@ -21,36 +22,124 @@ import Language.PureScript.Values
import Data.Data
+-- |
+-- Data type for simplified Javascript expressions
+--
data JS
+ -- |
+ -- A numeric literal
+ --
= JSNumericLiteral (Either Integer Double)
+ -- |
+ -- A string literal
+ --
| JSStringLiteral String
+ -- |
+ -- A boolean literal
+ --
| JSBooleanLiteral Bool
+ -- |
+ -- A unary operator application
+ --
| JSUnary UnaryOperator JS
+ -- |
+ -- A binary operator application
+ --
| JSBinary BinaryOperator JS JS
+ -- |
+ -- An array literal
+ --
| JSArrayLiteral [JS]
+ -- |
+ -- An array indexer expression
+ --
| JSIndexer JS JS
+ -- |
+ -- An object literal
+ --
| JSObjectLiteral [(String, JS)]
+ -- |
+ -- An object property accessor expression
+ --
| JSAccessor String JS
+ -- |
+ -- A function introduction (optional name, arguments, body)
+ --
| JSFunction (Maybe Ident) [Ident] JS
+ -- |
+ -- Function application
+ --
| JSApp JS [JS]
+ -- |
+ -- Variable
+ --
| JSVar Ident
+ -- |
+ -- Conditional expression
+ --
| JSConditional JS JS JS
+ -- |
+ -- A block of expressions in braces
+ --
| JSBlock [JS]
+ -- |
+ -- A variable introduction and optional initialization
+ --
| JSVariableIntroduction Ident (Maybe JS)
+ -- |
+ -- A variable assignment
+ --
| JSAssignment JSAssignment JS
+ -- |
+ -- While loop
+ --
| JSWhile JS JS
+ -- |
+ -- For loop
+ --
| JSFor Ident JS JS JS
+ -- |
+ -- If-then-else statement
+ --
| JSIfElse JS JS (Maybe JS)
+ -- |
+ -- Return statement
+ --
| JSReturn JS
+ -- |
+ -- Throw statement
+ --
| JSThrow JS
+ -- |
+ -- Type-Of operator
+ --
| JSTypeOf JS
+ -- |
+ -- Labelled statement
+ --
| JSLabel String JS
+ -- |
+ -- Break statement
+ --
| JSBreak String
+ -- |
+ -- Continue statement
+ --
| JSContinue String
+ -- |
+ -- Raw Javascript (generated when parsing fails for an inline foreign import declaration)
+ --
| JSRaw String deriving (Show, Data, Typeable)
+-- |
+-- Data type for expressions which can appear on the left hand side of an assignment
+--
data JSAssignment
+ -- |
+ -- Assign a variable
+ --
= JSAssignVariable Ident
+ -- |
+ -- Assign an object property
+ --
| JSAssignProperty String JSAssignment deriving (Show, Data, Typeable)
-
-
diff --git a/src/Language/PureScript/CodeGen/Monad.hs b/src/Language/PureScript/CodeGen/Monad.hs
index 0e8b165..4fa9cbd 100644
--- a/src/Language/PureScript/CodeGen/Monad.hs
+++ b/src/Language/PureScript/CodeGen/Monad.hs
@@ -9,6 +9,9 @@
-- Portability :
--
-- |
+-- Code generation monad
+--
+-- This monad provides a supply of fresh names which can be used to create variables.
--
-----------------------------------------------------------------------------
@@ -20,11 +23,20 @@ import Control.Monad.State
import Control.Applicative
import Language.PureScript.Names
+-- |
+-- Code generation monad data type
+--
newtype Gen a = Gen { unGen :: State [Ident] a } deriving (Functor, Applicative, Monad, MonadState [Ident])
+-- |
+-- Run a computation in the code generation monad
+--
runGen :: [Ident] -> Gen a -> a
runGen names = flip evalState names . unGen
+-- |
+-- Generate a fresh name
+--
fresh :: Gen Ident
fresh = do
(s:ss) <- get
diff --git a/src/Language/PureScript/CodeGen/Optimize.hs b/src/Language/PureScript/CodeGen/Optimize.hs
index 509a776..5308425 100644
--- a/src/Language/PureScript/CodeGen/Optimize.hs
+++ b/src/Language/PureScript/CodeGen/Optimize.hs
@@ -9,6 +9,23 @@
-- Portability :
--
-- |
+-- This module optimizes code in the simplified-Javascript intermediate representation.
+--
+-- The following optimizations are supported:
+--
+-- * Collapsing nested blocks
+--
+-- * Tail call elimination
+--
+-- * Inlining of (>>=) and ret for the Eff monad
+--
+-- * Removal of unused variables
+--
+-- * Removal of unnecessary thunks
+--
+-- * Eta conversion
+--
+-- * Inlining variables
--
-----------------------------------------------------------------------------
@@ -28,6 +45,9 @@ import Language.PureScript.Sugar.TypeClasses
(mkDictionaryValueName)
import Language.PureScript.Types (Type(..))
+-- |
+-- Apply a series of optimizer passes to simplified Javascript code
+--
optimize :: Options -> JS -> JS
optimize opts =
collapseNestedBlocks
@@ -58,12 +78,12 @@ isReassigned var1 = everything (||) (mkQ False check)
check _ = False
isRebound :: (Data d) => JS -> d -> Bool
-isRebound (JSVar var1) = everything (||) (mkQ False check)
+isRebound js d = any (\var -> isReassigned var d) (variablesOf js)
where
- check :: JS -> Bool
- check (JSFunction _ args _) | var1 `elem` args = True
- check _ = False
-isRebound _ = const False
+ variablesOf (JSVar var) = [var]
+ variablesOf (JSAccessor _ val) = variablesOf val
+ variablesOf (JSIndexer index val) = variablesOf index ++ variablesOf val
+ variablesOf _ = []
isUsed :: (Data d) => Ident -> d -> Bool
isUsed var1 = everything (||) (mkQ False check)
@@ -72,9 +92,17 @@ isUsed var1 = everything (||) (mkQ False check)
check (JSVar var2) | var1 == var2 = True
check (JSAssignment target _) | var1 == targetVariable target = True
check _ = False
- targetVariable :: JSAssignment -> Ident
- targetVariable (JSAssignVariable var) = var
- targetVariable (JSAssignProperty _ tgt) = targetVariable tgt
+
+targetVariable :: JSAssignment -> Ident
+targetVariable (JSAssignVariable var) = var
+targetVariable (JSAssignProperty _ tgt) = targetVariable tgt
+
+isUpdated :: (Data d) => Ident -> d -> Bool
+isUpdated var1 = everything (||) (mkQ False check)
+ where
+ check :: JS -> Bool
+ check (JSAssignment target _) | var1 == targetVariable target = True
+ check _ = False
shouldInline :: JS -> Bool
shouldInline (JSVar _) = True
@@ -93,7 +121,9 @@ inlineVariables = everywhere (mkT removeFromBlock)
removeFromBlock js = js
go :: [JS] -> [JS]
go [] = []
- go (JSVariableIntroduction var (Just js) : sts) | shouldInline js && not (isReassigned var sts) && not (isRebound js sts) = go (replaceIdent var js sts)
+ go (s@(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
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
index 71c543e..3df4ec3 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -8,7 +8,7 @@
-- Stability : experimental
-- Portability :
--
--- |
+-- | Data types for modules and declarations
--
-----------------------------------------------------------------------------
@@ -24,59 +24,143 @@ import Language.PureScript.CodeGen.JS.AST
import qualified Data.Data as D
+-- |
+-- A precedence level for an infix operator
+--
type Precedence = Integer
+-- |
+-- Associativity for infix operators
+--
data Associativity = Infixl | Infixr deriving (Show, D.Data, D.Typeable)
+-- |
+-- Fixity data for infix operators
+--
data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)
+-- |
+-- A module declaration, consisting of a module name and a list of declarations
+--
data Module = Module ProperName [Declaration] deriving (Show, D.Data, D.Typeable)
+-- |
+-- The type of a foreign import
+--
data ForeignImportType
+ -- |
+ -- A regular foreign import
+ --
= ForeignImport
+ -- |
+ -- A type class dictionary import, generated during desugaring of type class declarations
+ --
| TypeClassDictionaryImport
+ -- |
+ -- A type class dictionary member accessor import, generated during desugaring of type class declarations
+ --
| TypeClassAccessorImport deriving (Show, Eq, D.Data, D.Typeable)
+-- |
+-- The data type of declarations
+--
data Declaration
+ -- |
+ -- A data type declaration (name, arguments, data constructors)
+ --
= DataDeclaration ProperName [String] [(ProperName, Maybe Type)]
+ -- |
+ -- A minimal mutually recursive set of data type declarations
+ --
| DataBindingGroupDeclaration [Declaration]
+ -- |
+ -- A type synonym declaration (name, arguments, type)
+ --
| TypeSynonymDeclaration ProperName [String] Type
+ -- |
+ -- A type declaration for a value (name, ty)
+ --
| TypeDeclaration Ident Type
+ -- |
+ -- A value declaration (name, top-level binders, optional guard, value)
+ --
| ValueDeclaration Ident [[Binder]] (Maybe Guard) Value
+ -- |
+ -- A minimal mutually recursive set of value declarations
+ --
| BindingGroupDeclaration [(Ident, Value)]
+ -- |
+ -- A foreign import declaration (type, name, optional inline Javascript, type)
+ --
| ExternDeclaration ForeignImportType Ident (Maybe JS) Type
+ -- |
+ -- A data type foreign import (name, kind)
+ --
| ExternDataDeclaration ProperName Kind
+ -- |
+ -- A fixity declaration (fixity data, operator name)
+ --
| FixityDeclaration Fixity String
+ -- |
+ -- A module import (module name, optional set of identifiers to import)
+ --
| ImportDeclaration ModuleName (Maybe [Either Ident ProperName])
+ -- |
+ -- A type class declaration (name, argument, member declarations)
+ --
| TypeClassDeclaration ProperName String [Declaration]
+ -- |
+ -- A type instance declaration (dependencies, class name, instance type, member declarations)
+ --
| 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 _ = False
+-- |
+-- Test if a declaration is a data type or type synonym declaration
+--
isDataDecl :: Declaration -> Bool
isDataDecl (DataDeclaration _ _ _) = True
isDataDecl (TypeSynonymDeclaration _ _ _) = True
isDataDecl _ = False
+-- |
+-- Test if a declaration is a module import
+--
isImportDecl :: Declaration -> Bool
isImportDecl (ImportDeclaration _ _) = True
isImportDecl _ = False
+-- |
+-- Test if a declaration is a data type foreign import
+--
isExternDataDecl :: Declaration -> Bool
isExternDataDecl (ExternDataDeclaration _ _) = True
isExternDataDecl _ = False
+-- |
+-- Test if a declaration is a fixity declaration
+--
isFixityDecl :: Declaration -> Bool
isFixityDecl (FixityDeclaration _ _) = True
isFixityDecl _ = False
+-- |
+-- Test if a declaration is a foreign import
+--
isExternDecl :: Declaration -> Bool
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
diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs
index 92f9f4e..9089d84 100644
--- a/src/Language/PureScript/Kinds.hs
+++ b/src/Language/PureScript/Kinds.hs
@@ -19,9 +19,27 @@ module Language.PureScript.Kinds where
import Data.Data
import Language.PureScript.Unknown
+-- |
+-- The data type of kinds
+--
data Kind
+ -- |
+ -- Unification variable of type Kind
+ --
= KUnknown (Unknown Kind)
+ -- |
+ -- The kind of types
+ --
| Star
+ -- |
+ -- The kind of effects
+ --
| Bang
+ -- |
+ -- Kinds for labelled, unordered rows without duplicates
+ --
| Row Kind
+ -- |
+ -- Function kinds
+ --
| FunKind Kind Kind deriving (Show, Eq, Data, Typeable)
diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs
index ecf917b..bdc82f0 100644
--- a/src/Language/PureScript/ModuleDependencies.hs
+++ b/src/Language/PureScript/ModuleDependencies.hs
@@ -8,7 +8,7 @@
-- Stability : experimental
-- Portability :
--
--- |
+-- | Provides the ability to sort modules based on module dependencies
--
-----------------------------------------------------------------------------
@@ -27,18 +27,19 @@ import Language.PureScript.Names
import Language.PureScript.Values
import Language.PureScript.Types
+-- |
+-- Sort a collection of modules based on module dependencies.
+--
+-- Reports an error if the module graph contains a cycle.
+--
sortModules :: [Module] -> Either String [Module]
sortModules ms = do
let verts = map (\m -> (m, getModuleName m, usedModules m)) ms
mapM toModule $ stronglyConnComp verts
-collapseBindingGroups :: [Declaration] -> [Declaration]
-collapseBindingGroups ds = concatMap go ds
- where
- go (DataBindingGroupDeclaration ds) = ds
- go (BindingGroupDeclaration ds) = map (\(ident, val) -> ValueDeclaration ident [] Nothing val) ds
- go other = [other]
-
+-- |
+-- Calculate a list of used modules based on explicit imports and qualified names
+--
usedModules :: (Data d) => d -> [ProperName]
usedModules = nub . everything (++) (mkQ [] qualifiedIdents `extQ` qualifiedProperNames `extQ` imports)
where
@@ -55,6 +56,9 @@ usedModules = nub . everything (++) (mkQ [] qualifiedIdents `extQ` qualifiedProp
getModuleName :: Module -> ProperName
getModuleName (Module pn _) = pn
+-- |
+-- Convert a strongly connected component of the module graph to a module
+--
toModule :: SCC Module -> Either String Module
toModule (AcyclicSCC m) = return m
toModule (CyclicSCC [m]) = return m
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index 219f5e5..abe5893 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -9,6 +9,7 @@
-- Portability :
--
-- |
+-- Data types for names
--
-----------------------------------------------------------------------------
@@ -18,28 +19,51 @@ module Language.PureScript.Names where
import Data.Data
-data Ident = Ident String | Op String deriving (Eq, Ord, Data, Typeable)
+-- |
+-- Names for value identifiers
+--
+data Ident
+ -- |
+ -- An alphanumeric identifier
+ --
+ = Ident String
+ -- |
+ -- A symbolic name for an infix operator
+ --
+ | Op String deriving (Eq, Ord, Data, Typeable)
instance Show Ident where
show (Ident s) = s
show (Op op) = '(':op ++ ")"
+-- |
+-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
+--
newtype ProperName = ProperName { runProperName :: String } deriving (Eq, Ord, Data, Typeable)
instance Show ProperName where
show = runProperName
+-- |
+-- Module names
+--
data ModuleName = ModuleName ProperName deriving (Eq, Ord, Data, Typeable)
instance Show ModuleName where
show (ModuleName name) = show name
+-- |
+-- A qualified name, i.e. a name with an optional module name
+--
data Qualified a = Qualified (Maybe ModuleName) a deriving (Eq, Ord, Data, Typeable)
instance (Show a) => Show (Qualified a) where
show (Qualified Nothing a) = show a
show (Qualified (Just (ModuleName name)) a) = show name ++ "." ++ show a
+-- |
+-- Provide a default module name, if a name is unqualified
+--
qualify :: ModuleName -> Qualified a -> (ModuleName, a)
qualify m (Qualified Nothing a) = (m, a)
qualify _ (Qualified (Just m) a) = (m, a)
diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs
index 2065656..ce24c22 100644
--- a/src/Language/PureScript/Options.hs
+++ b/src/Language/PureScript/Options.hs
@@ -9,17 +9,36 @@
-- Portability :
--
-- |
+-- The data type of compiler options
--
-----------------------------------------------------------------------------
module Language.PureScript.Options where
-data Options = Options
- { optionsTco :: Bool
+-- |
+-- The data type of compiler options
+--
+data Options = Options {
+ -- |
+ -- Perform tail-call elimination
+ --
+ optionsTco :: Bool
+ -- |
+ -- Perform type checks at runtime
+ --
, optionsPerformRuntimeTypeChecks :: Bool
+ -- |
+ -- Inline calls to ret and bind for the Eff monad
+ --
, optionsMagicDo :: Bool
+ -- |
+ -- Check the type of Main.main and generate its code
+ --
, optionsRunMain :: Bool
} deriving Show
+-- |
+-- Default compiler options
+--
defaultOptions :: Options
defaultOptions = Options False False False False
diff --git a/src/Language/PureScript/Parser.hs b/src/Language/PureScript/Parser.hs
index 503cf03..43fb8d4 100644
--- a/src/Language/PureScript/Parser.hs
+++ b/src/Language/PureScript/Parser.hs
@@ -9,6 +9,19 @@
-- Portability :
--
-- |
+-- A collection of parsers for core data types:
+--
+-- [@Language.PureScript.Parser.Kinds@] Parser for kinds
+--
+-- [@Language.PureScript.Parser.Values@] Parser for values
+--
+-- [@Language.PureScript.Parser.Types@] Parser for types
+--
+-- [@Language.PureScript.Parser.Declaration@] Parsers for declarations and modules
+--
+-- [@Language.PureScript.Parser.State@] Parser state, including indentation
+--
+-- [@Language.PureScript.Parser.Common@] Common parsing utility functions
--
-----------------------------------------------------------------------------
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index bb64947..43b283c 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -9,6 +9,7 @@
-- Portability :
--
-- |
+-- Constants, and utility functions to be used when parsing
--
-----------------------------------------------------------------------------
@@ -25,6 +26,9 @@ import qualified Text.Parsec.Token as PT
import Language.PureScript.Names
+-- |
+-- A list of reserved identifiers
+--
reservedNames :: [String]
reservedNames = [ "case"
, "of"
@@ -76,28 +80,52 @@ reservedNames = [ "case"
, "instance"
, "where" ]
+-- |
+-- A list of built-in operator names
+--
builtInOperators :: [String]
builtInOperators = [ "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"
, "==", "!=", "&&", "||", "&", "^", "|", "!!", "!" ]
+-- |
+-- A list of reserved operators
+--
reservedOpNames :: [String]
reservedOpNames = builtInOperators ++ [ "=>", "->", "=", ".", "\\" ]
+-- |
+-- Valid first characters for an identifier
+--
identStart :: P.Parsec String u Char
identStart = P.lower <|> P.oneOf "_"
+-- |
+-- Valid first characters for a proper name
+--
properNameStart :: P.Parsec String u Char
properNameStart = P.upper
+-- |
+-- Valid identifier characters
+--
identLetter :: P.Parsec String u Char
identLetter = P.alphaNum <|> P.oneOf "_'"
+-- |
+-- Valid first characters for an operator
+--
opStart :: P.Parsec String u Char
opStart = P.oneOf ":!#$%&*+./<=>?@\\^|-~"
+-- |
+-- Valid operators characters
+--
opLetter :: P.Parsec String u Char
opLetter = P.oneOf ":!#$%&*+./<=>?@\\^|-~"
+-- |
+-- The PureScript language definition
+--
langDef :: PT.GenLanguageDef String u Identity
langDef = PT.LanguageDef
{ PT.reservedNames = reservedNames
@@ -113,104 +141,209 @@ langDef = PT.LanguageDef
, PT.caseSensitive = True
}
+-- |
+-- A token parser based on the language definition
+--
tokenParser :: PT.GenTokenParser String u Identity
tokenParser = PT.makeTokenParser langDef
+-- |
+-- Parse a token
+--
lexeme :: P.Parsec String u a -> P.Parsec String u a
lexeme = PT.lexeme tokenParser
+-- |
+-- Parse an identifier
+--
identifier :: P.Parsec String u String
identifier = PT.identifier tokenParser
+-- |
+-- Parse a reserved word
+--
reserved :: String -> P.Parsec String u ()
reserved = PT.reserved tokenParser
+-- |
+-- Parse a reserved operator
+--
reservedOp :: String -> P.Parsec String u ()
reservedOp = PT.reservedOp tokenParser
+-- |
+-- Parse an operator
+--
operator :: P.Parsec String u String
operator = PT.operator tokenParser
+-- |
+-- Parse a string literal
+--
stringLiteral :: P.Parsec String u String
stringLiteral = PT.stringLiteral tokenParser
+-- |
+-- Parse whitespace
+--
whiteSpace :: P.Parsec String u ()
whiteSpace = PT.whiteSpace tokenParser
+-- |
+-- Semicolon
+--
semi :: P.Parsec String u String
semi = PT.semi tokenParser
+-- |
+-- Colon
+--
colon :: P.Parsec String u String
colon = PT.colon tokenParser
+-- |
+-- Period
+--
dot :: P.Parsec String u String
dot = PT.dot tokenParser
+-- |
+-- Comma
+--
comma :: P.Parsec String u String
comma = PT.comma tokenParser
+-- |
+-- Backtick
+--
tick :: P.Parsec String u Char
tick = lexeme $ P.char '`'
+-- |
+-- Pipe character
+--
pipe :: P.Parsec String u Char
pipe = lexeme $ P.char '|'
+-- |
+-- Natural number
+--
natural :: P.Parsec String u Integer
natural = PT.natural tokenParser
+-- |
+-- Parse a proper name
+--
+properName :: P.Parsec String u ProperName
+properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many (PT.identLetter langDef) P.<?> "name")
+
+-- |
+-- Parse a qualified name, i.e. M.name or just name
+--
+parseQualified :: P.Parsec String ParseState a -> P.Parsec String ParseState (Qualified a)
+parseQualified parser = qual
+ where
+ qual = (Qualified <$> (Just . ModuleName <$> P.try (properName <* delimiter)) <*> parser)
+ <|> (Qualified Nothing <$> P.try parser)
+ delimiter = indented *> dot
+
+-- |
+-- Parse an integer or floating point value
+--
+integerOrFloat :: P.Parsec String u (Either Integer Double)
+integerOrFloat = (Left <$> P.try (PT.natural tokenParser) <|>
+ Right <$> P.try (PT.float tokenParser)) P.<?> "number"
+
+-- |
+-- Parse an operator or a built-in operator
+--
+operatorOrBuiltIn :: P.Parsec String u String
+operatorOrBuiltIn = P.try operator <|> P.choice (map (\s -> P.try (reservedOp s) >> return s) builtInOperators)
+
+-- |
+-- Parse an identifier or parenthesized operator
+--
+parseIdent :: P.Parsec String ParseState Ident
+parseIdent = (Ident <$> identifier) <|> (Op <$> parens operatorOrBuiltIn)
+
+-- |
+-- Parse a token inside square brackets
+--
squares :: P.Parsec String ParseState a -> P.Parsec String ParseState a
squares = P.between (lexeme $ P.char '[') (lexeme $ indented *> P.char ']') . (indented *>)
+-- |
+-- Parse a token inside parentheses
+--
parens :: P.Parsec String ParseState a -> P.Parsec String ParseState a
parens = P.between (lexeme $ P.char '(') (lexeme $ indented *> P.char ')') . (indented *>)
+-- |
+-- Parse a token inside braces
+--
braces :: P.Parsec String ParseState a -> P.Parsec String ParseState a
braces = P.between (lexeme $ P.char '{') (lexeme $ indented *> P.char '}') . (indented *>)
+-- |
+-- Parse a token inside angle brackets
+--
angles :: P.Parsec String ParseState a -> P.Parsec String ParseState a
angles = P.between (lexeme $ P.char '<') (lexeme $ indented *> P.char '>') . (indented *>)
+-- |
+-- Parse zero or more values separated by a separator token
+--
sepBy :: P.Parsec String ParseState a -> P.Parsec String ParseState sep -> P.Parsec String ParseState [a]
sepBy p s = P.sepBy (indented *> p) (indented *> s)
+-- |
+-- Parse one or more values separated by a separator token
+--
sepBy1 :: P.Parsec String ParseState a -> P.Parsec String ParseState sep -> P.Parsec String ParseState [a]
sepBy1 p s = P.sepBy1 (indented *> p) (indented *> s)
+-- |
+-- Parse zero or more values separated by semicolons
+--
semiSep :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]
semiSep = flip sepBy semi
+-- |
+-- Parse one or more values separated by semicolons
+--
semiSep1 :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]
semiSep1 = flip sepBy1 semi
+-- |
+-- Parse zero or more values separated by commas
+--
commaSep :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]
commaSep = flip sepBy comma
+-- |
+-- Parse one or more values separated by commas
+--
commaSep1 :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]
commaSep1 = flip sepBy1 comma
-properName :: P.Parsec String u ProperName
-properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many (PT.identLetter langDef) P.<?> "name")
-
-parseQualified :: P.Parsec String ParseState a -> P.Parsec String ParseState (Qualified a)
-parseQualified parser = qual
- where
- qual = (Qualified <$> (Just . ModuleName <$> P.try (properName <* delimiter)) <*> parser)
- <|> (Qualified Nothing <$> P.try parser)
- delimiter = indented *> dot
-
-integerOrFloat :: P.Parsec String u (Either Integer Double)
-integerOrFloat = (Left <$> P.try (PT.natural tokenParser) <|>
- Right <$> P.try (PT.float tokenParser)) P.<?> "number"
-
+-- |
+-- Run the first parser, then match the second if possible, applying the specified function on a successful match
+--
augment :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a
augment p q f = flip (maybe id $ flip f) <$> p <*> P.optionMaybe q
+-- |
+-- Run the first parser, then match the second zero or more times, applying the specified function for each match
+--
fold :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a
fold first more combine = do
a <- first
bs <- P.many more
return $ foldl combine a bs
+-- |
+-- Build a parser from a smaller parser and a list of parsers for postfix operators
+--
buildPostfixParser :: P.Stream s m t => [a -> P.ParsecT s u m a] -> P.ParsecT s u m a -> P.ParsecT s u m a
buildPostfixParser fs first = do
a <- first
@@ -222,15 +355,15 @@ buildPostfixParser fs first = do
Nothing -> return a
Just a' -> go a'
-operatorOrBuiltIn :: P.Parsec String u String
-operatorOrBuiltIn = P.try operator <|> P.choice (map (\s -> P.try (reservedOp s) >> return s) builtInOperators)
-
-parseIdent :: P.Parsec String ParseState Ident
-parseIdent = (Ident <$> identifier) <|> (Op <$> parens operatorOrBuiltIn)
-
+-- |
+-- Parse an identifier in backticks or an operator
+--
parseIdentInfix :: P.Parsec String ParseState (Qualified Ident)
parseIdentInfix = (P.between tick tick (parseQualified (Ident <$> identifier))) <|> parseQualified (Op <$> operatorOrBuiltIn)
+-- |
+-- Mark the current indentation level
+--
mark :: P.Parsec String ParseState a -> P.Parsec String ParseState a
mark p = do
current <- indentationLevel <$> P.getState
@@ -240,17 +373,29 @@ mark p = do
P.modifyState $ \st -> st { indentationLevel = current }
return a
+-- |
+-- Check that the current identation level matches a predicate
+--
checkIndentation :: (P.Column -> P.Column -> Bool) -> P.Parsec String ParseState ()
checkIndentation rel = do
col <- P.sourceColumn <$> P.getPosition
current <- indentationLevel <$> P.getState
guard (col `rel` current)
+-- |
+-- Check that the current indentation level is past the current mark
+--
indented :: P.Parsec String ParseState ()
indented = checkIndentation (>) P.<?> "indentation"
+-- |
+-- Check that the current indentation level is at the same indentation as the current mark
+--
same :: P.Parsec String ParseState ()
same = checkIndentation (==) P.<?> "no indentation"
+-- |
+-- Run a parser which supports indentation
+--
runIndentParser :: P.Parsec String ParseState a -> String -> Either P.ParseError a
runIndentParser p = P.runParser p (ParseState 0) ""
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index c7ef5c8..9fee7cc 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -9,6 +9,7 @@
-- Portability :
--
-- |
+-- Parsers for module definitions and declarations
--
-----------------------------------------------------------------------------
@@ -120,6 +121,9 @@ parseTypeInstanceDeclaration = do
members <- mark (P.many (same *> parseValueDeclaration))
return $ TypeInstanceDeclaration (fromMaybe [] deps) className ty members
+-- |
+-- Parse a single declaration
+--
parseDeclaration :: P.Parsec String ParseState Declaration
parseDeclaration = P.choice
[ parseDataDeclaration
@@ -132,6 +136,9 @@ parseDeclaration = P.choice
, parseTypeClassDeclaration
, parseTypeInstanceDeclaration ] P.<?> "declaration"
+-- |
+-- Parse a module header and a collection of declarations
+--
parseModule :: P.Parsec String ParseState Module
parseModule = do
reserved "module"
@@ -141,5 +148,8 @@ parseModule = do
decls <- mark (P.many (same *> parseDeclaration))
return $ Module name decls
+-- |
+-- Parse a collection of modules
+--
parseModules :: P.Parsec String ParseState [Module]
parseModules = whiteSpace *> mark (P.many (same *> parseModule)) <* P.eof
diff --git a/src/Language/PureScript/Parser/JS.hs b/src/Language/PureScript/Parser/JS.hs
index ab07993..79a84d2 100644
--- a/src/Language/PureScript/Parser/JS.hs
+++ b/src/Language/PureScript/Parser/JS.hs
@@ -9,6 +9,7 @@
-- Portability :
--
-- |
+-- A parser for a small fragment of Javascript
--
-----------------------------------------------------------------------------
@@ -99,6 +100,9 @@ binary op s f = P.Infix (P.try $ C.reservedOp s >> return (JSBinary op)) f
unary :: UnaryOperator -> String -> P.Operator String u Identity JS
unary op s = P.Prefix (P.try $ C.reservedOp s >> return (JSUnary op))
+-- |
+-- Parse a simplified Javascript expression
+--
parseJS :: P.Parsec String u JS
parseJS =
(P.buildExpressionParser operators
diff --git a/src/Language/PureScript/Parser/Kinds.hs b/src/Language/PureScript/Parser/Kinds.hs
index cb88e52..9e06c65 100644
--- a/src/Language/PureScript/Parser/Kinds.hs
+++ b/src/Language/PureScript/Parser/Kinds.hs
@@ -9,6 +9,7 @@
-- Portability :
--
-- |
+-- A parser for kinds
--
-----------------------------------------------------------------------------
@@ -34,7 +35,9 @@ parseTypeAtom = indented *> P.choice (map P.try
[ parseStar
, parseBang
, parens parseKind ])
-
+-- |
+-- Parse a kind
+--
parseKind :: P.Parsec String ParseState Kind
parseKind = P.buildExpressionParser operators parseTypeAtom P.<?> "kind"
where
diff --git a/src/Language/PureScript/Parser/State.hs b/src/Language/PureScript/Parser/State.hs
index e20cb1d..f66516c 100644
--- a/src/Language/PureScript/Parser/State.hs
+++ b/src/Language/PureScript/Parser/State.hs
@@ -9,6 +9,7 @@
-- Portability :
--
-- |
+-- State for the parser monad
--
-----------------------------------------------------------------------------
@@ -16,7 +17,14 @@ module Language.PureScript.Parser.State where
import qualified Text.Parsec as P
-data ParseState = ParseState
- { indentationLevel :: P.Column } deriving Show
+-- |
+-- State for the parser monad
+--
+data ParseState = ParseState {
+ -- |
+ -- The most recently marked indentation level
+ --
+ indentationLevel :: P.Column
+ } deriving Show
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
index e6b1984..970e39a 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -9,13 +9,13 @@
-- Portability :
--
-- |
+-- Parsers for types
--
-----------------------------------------------------------------------------
module Language.PureScript.Parser.Types (
parseType,
- parsePolyType,
- parseRow
+ parsePolyType
) where
import Language.PureScript.Types
@@ -97,12 +97,18 @@ parseAnyType = (P.buildExpressionParser operators . buildPostfixParser postfixTa
postfixTable = [ \x -> TypeApp x <$> P.try (indented *> parseTypeAtom) ]
operators = [ [ P.Infix (lexeme (P.try (P.string "->")) >> return (\t1 t2 -> Function [t1] t2)) P.AssocRight ] ]
+-- |
+-- Parse a monotype
+--
parseType :: P.Parsec String ParseState Type
parseType = do
ty <- parseAnyType
unless (isMonoType ty) $ P.unexpected "polymorphic type"
return ty
+-- |
+-- Parse a polytype
+--
parsePolyType :: P.Parsec String ParseState Type
parsePolyType = do
ty <- parseAnyType
diff --git a/src/Language/PureScript/Parser/Values.hs b/src/Language/PureScript/Parser/Values.hs
index 5f70a77..7ef3b65 100644
--- a/src/Language/PureScript/Parser/Values.hs
+++ b/src/Language/PureScript/Parser/Values.hs
@@ -9,15 +9,16 @@
-- Portability :
--
-- |
+-- Parsers for values, statements, binders and guards
--
-----------------------------------------------------------------------------
module Language.PureScript.Parser.Values (
parseValue,
+ parseStatement,
parseGuard,
parseBinder,
parseBinderNoParens,
- parseDoNotationElement
) where
import Language.PureScript.Values
@@ -146,6 +147,9 @@ parseDoNotationElement = P.choice
, parseDoNotationLet
, P.try (DoNotationValue <$> parseValue) ]
+-- |
+-- Parse a value
+--
parseValue :: P.Parsec String ParseState Value
parseValue =
(buildExpressionParser operators
@@ -212,6 +216,9 @@ parseElseStatement = C.reserved "else" >> (ElseIf <$> parseIfStatement
parseReturn :: P.Parsec String ParseState Statement
parseReturn = Return <$> (C.reserved "return" *> parseValue <* C.indented <* C.semi)
+-- |
+-- Parse a statement
+--
parseStatement :: P.Parsec String ParseState Statement
parseStatement = P.choice
[ parseVariableIntroduction
@@ -273,11 +280,17 @@ parseBinderAtom = P.choice (map P.try
, parseArrayBinder
, C.parens parseBinder ]) P.<?> "binder"
+-- |
+-- Parse a binder
+--
parseBinder :: P.Parsec String ParseState Binder
parseBinder = (buildExpressionParser operators parseBinderAtom) P.<?> "expression"
where
operators = [ [ Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) AssocRight ] ]
+-- |
+-- Parse a binder as it would appear in a top level declaration
+--
parseBinderNoParens :: P.Parsec String ParseState Binder
parseBinderNoParens = P.choice (map P.try
[ parseNullBinder
@@ -290,7 +303,9 @@ parseBinderNoParens = P.choice (map P.try
, parseObjectBinder
, parseArrayBinder
, C.parens parseBinder ]) P.<?> "binder"
-
+-- |
+-- Parse a guard
+--
parseGuard :: P.Parsec String ParseState Guard
parseGuard = C.indented *> C.pipe *> C.indented *> parseValue
diff --git a/src/Language/PureScript/Pretty.hs b/src/Language/PureScript/Pretty.hs
index a5c03c5..7d569c5 100644
--- a/src/Language/PureScript/Pretty.hs
+++ b/src/Language/PureScript/Pretty.hs
@@ -9,6 +9,15 @@
-- Portability :
--
-- |
+-- A collection of pretty printers for core data types:
+--
+-- [@Language.PureScript.Pretty.Kinds@] Pretty printer for kinds
+--
+-- [@Language.PureScript.Pretty.Values@] Pretty printer for values
+--
+-- [@Language.PureScript.Pretty.Types@] Pretty printer for types
+--
+-- [@Language.PureScript.Pretty.JS@] Pretty printer for values, used for code generation
--
-----------------------------------------------------------------------------
diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs
index d9cf69d..82d6592 100644
--- a/src/Language/PureScript/Pretty/Common.hs
+++ b/src/Language/PureScript/Pretty/Common.hs
@@ -9,6 +9,7 @@
-- Portability :
--
-- |
+-- Common pretty-printing utility functions
--
-----------------------------------------------------------------------------
@@ -25,50 +26,107 @@ import Control.Arrow ((***), (<+>))
import Language.PureScript.Names
+-- |
+-- Convert an Ident into a valid Javascript identifier:
+--
+-- * Alphanumeric characters are kept unmodified
+--
+-- * Symbols are encoded as a dollar symbol ($) followed by their ordinal value
+--
identToJs :: Ident -> String
-identToJs (Ident name) = name
-identToJs (Op op) = concatMap opCharToString op
- where
- opCharToString :: Char -> String
- opCharToString = (:) '$'. show . ord
+identToJs (Ident name) = concatMap identCharToString name
+identToJs (Op op) = concatMap identCharToString op
+
+identCharToString :: Char -> String
+identCharToString c | isAlphaNum c = [c]
+identCharToString '_' = "_"
+identCharToString c = '$' : show (ord c)
+-- |
+-- A first-order pattern match
+--
+-- A pattern is a Kleisli arrow for the @StateT Maybe@ monad. That is, patterns can fail, and can carry user-defined state.
+--
newtype Pattern u a b = Pattern { runPattern :: A.Kleisli (StateT u Maybe) a b } deriving (C.Category, A.Arrow, A.ArrowZero, A.ArrowPlus)
instance Functor (Pattern u a) where
fmap f (Pattern p) = Pattern $ A.Kleisli $ fmap f . A.runKleisli p
+-- |
+-- Run a pattern with an input and initial user state
+--
+-- Returns Nothing if the pattern fails to match
+--
pattern :: Pattern u a b -> u -> a -> Maybe b
pattern p u = flip evalStateT u . A.runKleisli (runPattern p)
+-- |
+-- Construct a pattern from a function
+--
mkPattern :: (a -> Maybe b) -> Pattern u a b
mkPattern f = Pattern $ A.Kleisli (lift . f)
+-- |
+-- Construct a pattern from a stateful function
+--
mkPattern' :: (a -> StateT u Maybe b) -> Pattern u a b
mkPattern' = Pattern . A.Kleisli
+-- |
+-- Wrap a string in parentheses
+--
parens :: String -> String
parens s = ('(':s) ++ ")"
+-- |
+-- Construct a pattern which recursively matches on the left-hand-side
+--
chainl :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
chainl g f p = fix $ \c -> g >>> ((c <+> p) *** p) >>> A.arr (uncurry f)
+-- |
+-- Construct a pattern which recursively matches on the right-hand side
+--
chainr :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
chainr g f p = fix $ \c -> g >>> (p *** (c <+> p)) >>> A.arr (uncurry f)
+-- |
+-- Construct a pattern which recursively matches on one-side of a tuple
+--
wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Pattern u a r -> Pattern u a r
wrap g f p = fix $ \c -> g >>> (C.id *** (c <+> p)) >>> A.arr (uncurry f)
+-- |
+-- Construct a pattern which matches a part of a tuple
+--
split :: Pattern u a (s, t) -> (s -> t -> r) -> Pattern u a r
split s f = s >>> A.arr (uncurry f)
+-- |
+-- A table of operators
+--
data OperatorTable u a r = OperatorTable { runOperatorTable :: [ [Operator u a r] ] }
+-- |
+-- An operator:
+--
+-- [@AssocL@] A left-associative operator
+--
+-- [@AssocR@] A right-associative operator
+--
+-- [@Wrap@] A prefix-like or postfix-like operator
+--
+-- [@Split@] A prefix-like or postfix-like operator which does not recurse into its operand
+--
data Operator u a r where
AssocL :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r
AssocR :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r
Wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Operator u a r
Split :: Pattern u a (s, t) -> (s -> t -> r) -> Operator u a r
+-- |
+-- Build a pretty printer from an operator table and an indecomposable pattern
+--
buildPrettyPrinter :: OperatorTable u a r -> Pattern u a r -> Pattern u a r
buildPrettyPrinter table p = foldl (\p' ops -> foldl1 (<+>) (flip map ops $ \op ->
case op of
diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs
index 02ebf1c..de85700 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -9,6 +9,7 @@
-- Portability :
--
-- |
+-- Pretty printer for the Javascript AST
--
-----------------------------------------------------------------------------
@@ -30,9 +31,15 @@ import Control.Monad.State
newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Eq, Ord)
+-- |
+-- Number of characters per identation level
+--
blockIndent :: Int
blockIndent = 4
+-- |
+-- Pretty print with a new indentation level
+--
withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String
withIndent action = do
modify $ \st -> st { indent = indent st + blockIndent }
@@ -40,6 +47,9 @@ withIndent action = do
modify $ \st -> st { indent = indent st - blockIndent }
return result
+-- |
+-- Get the current indentation level
+--
currentIndent :: StateT PrinterState Maybe String
currentIndent = do
current <- get
@@ -187,15 +197,24 @@ binary op str = AssocR match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
match' (JSBinary op' v1 v2) | op' == op = Just (v1, v2)
match' _ = Nothing
+-- |
+-- Generate a pretty-printed string representing a Javascript expression
+--
prettyPrintJS1 :: JS -> String
prettyPrintJS1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'
+-- |
+-- 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
+-- |
+-- Generate an indented, pretty-printed string representing a Javascript expression
+--
prettyPrintJS' :: JS -> StateT PrinterState Maybe String
prettyPrintJS' = A.runKleisli $ runPattern matchValue
where
diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs
index aa358fe..cf5f8a2 100644
--- a/src/Language/PureScript/Pretty/Kinds.hs
+++ b/src/Language/PureScript/Pretty/Kinds.hs
@@ -9,6 +9,7 @@
-- Portability :
--
-- |
+-- Pretty printer for kinds
--
-----------------------------------------------------------------------------
@@ -43,6 +44,9 @@ funKind = mkPattern match
match (FunKind arg ret) = Just (arg, ret)
match _ = Nothing
+-- |
+-- Generate a pretty-printed string representing a Kind
+--
prettyPrintKind :: Kind -> String
prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind ()
where
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index c8fbfac..5f2da8d 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -9,6 +9,7 @@
-- Portability :
--
-- |
+-- Pretty printer for Types
--
-----------------------------------------------------------------------------
@@ -44,6 +45,9 @@ typeLiterals = mkPattern match
match row@(RCons _ _ _) = Just $ prettyPrintRow row
match _ = Nothing
+-- |
+-- Generate a pretty-printed string representing a Row
+--
prettyPrintRow :: Type -> String
prettyPrintRow = (\(tys, rest) -> intercalate ", " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs rest) . toList []
where
@@ -77,6 +81,9 @@ function = mkPattern match
match (Function args ret) = Just (args, ret)
match _ = Nothing
+-- |
+-- Generate a pretty-printed string representing a Type
+--
prettyPrintType :: Type -> String
prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType ()
where
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index a2b5c5e..554edd8 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -9,6 +9,7 @@
-- Portability :
--
-- |
+-- Pretty printer for values
--
-----------------------------------------------------------------------------
@@ -113,6 +114,9 @@ prettyPrintDoNotationElement (DoNotationValue val) = prettyPrintValue val
prettyPrintDoNotationElement (DoNotationBind binder val) = prettyPrintBinder binder ++ " <- " ++ prettyPrintValue val
prettyPrintDoNotationElement (DoNotationLet binder val) = "let " ++ prettyPrintBinder binder ++ " = " ++ prettyPrintValue val
+-- |
+-- Generate a pretty-printed string representing a Value
+--
prettyPrintValue :: Value -> String
prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue ()
where
@@ -170,6 +174,9 @@ prettyPrintBinderAtom = mkPattern match
match (NamedBinder ident binder) = Just $ show ident ++ "@" ++ prettyPrintBinder binder
match _ = Nothing
+-- |
+-- Generate a pretty-printed string representing a Binder
+--
prettyPrintBinder :: Binder -> String
prettyPrintBinder = fromMaybe (error "Incomplete pattern") . pattern matchBinder ()
where
diff --git a/src/Language/PureScript/Scope.hs b/src/Language/PureScript/Scope.hs
index 6665e26..c4b4164 100644
--- a/src/Language/PureScript/Scope.hs
+++ b/src/Language/PureScript/Scope.hs
@@ -9,6 +9,7 @@
-- Portability :
--
-- |
+-- Utility functions for working with names in scope
--
-----------------------------------------------------------------------------
@@ -25,6 +26,9 @@ import Language.PureScript.Values
import Language.PureScript.Names
import Language.PureScript.CodeGen.JS.AST
+-- |
+-- Gather all used names appearing inside a value
+--
usedNames :: (Data d) => d -> [Ident]
usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesS `extQ` namesB `extQ` namesJS) val
where
@@ -47,6 +51,9 @@ usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesS `extQ` namesB
namesJS (JSFor name _ _ _) = [name]
namesJS _ = []
+-- |
+-- Generate a set of names which are unused inside a value, of the form @_{n}@ for an integer @n@
+--
unusedNames :: (Data d) => d -> [Ident]
unusedNames val =
let
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index 92f1b81..0a1c001 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -9,6 +9,7 @@
-- Portability :
--
-- |
+-- Desugaring passes
--
-----------------------------------------------------------------------------
@@ -25,6 +26,21 @@ import Language.PureScript.Sugar.TypeDeclarations as S
import Language.PureScript.Sugar.BindingGroups as S
import Language.PureScript.Sugar.TypeClasses as S
+-- |
+-- The desugaring pipeline proceeds as follows:
+--
+-- * Introduce type synonyms for type class dictionaries
+--
+-- * Rebracket user-defined binary operators
+--
+-- * Desugar do-notation using the @Prelude.Monad@ type class
+--
+-- * Desugar top-level case declarations into explicit case expressions
+--
+-- * Desugar type declarations into value declarations with explicit type annotations
+--
+-- * Group mutually recursive value and data declarations into binding groups.
+--
desugar :: [Module] -> Either String [Module]
desugar = desugarTypeClasses
>=> rebracket
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index 006bcfd..de04561 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -9,6 +9,8 @@
-- Portability :
--
-- |
+-- This module implements the desugaring pass which creates binding groups from sets of
+-- mutually-recursive value declarations and mutually-recursive type declarations.
--
-----------------------------------------------------------------------------
@@ -30,12 +32,21 @@ import Language.PureScript.Names
import Language.PureScript.Values
import Language.PureScript.Types
+-- |
+-- Replace all sets of mutually-recursive declarations in a module with binding groups
+--
createBindingGroupsModule :: [Module] -> Either String [Module]
createBindingGroupsModule = mapM $ \(Module name ds) -> Module name <$> createBindingGroups ds
+-- |
+-- Collapse all binding groups in a module to individual declarations
+--
collapseBindingGroupsModule :: [Module] -> [Module]
collapseBindingGroupsModule = map $ \(Module name ds) -> Module name (collapseBindingGroups ds)
+-- |
+-- Replace all sets of mutually-recursive declarations with binding groups
+--
createBindingGroups :: [Declaration] -> Either String [Declaration]
createBindingGroups ds = do
let values = filter isValueDecl ds
@@ -54,6 +65,9 @@ createBindingGroups ds = do
filter isExternDecl ds ++
bindingGroupDecls
+-- |
+-- Collapse all binding groups to individual declarations
+--
collapseBindingGroups :: [Declaration] -> [Declaration]
collapseBindingGroups ds = concatMap go ds
where
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index 6b1ea46..bc8449e 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -9,6 +9,8 @@
-- Portability :
--
-- |
+-- This module implements the desugaring pass which replaces top-level binders with
+-- case expressions.
--
-----------------------------------------------------------------------------
@@ -27,9 +29,14 @@ import Language.PureScript.Values
import Language.PureScript.Declarations
import Language.PureScript.Scope
+-- |
+-- Replace all top-level binders in a module with case expressions.
+--
desugarCasesModule :: [Module] -> Either String [Module]
desugarCasesModule ms = forM ms $ \(Module name ds) -> Module name <$> desugarCases ds
-
+-- |
+-- Replace all top-level binders with case expressions.
+--
desugarCases :: [Declaration] -> Either String [Declaration]
desugarCases = fmap join . mapM toDecls . groupBy inSameGroup
diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs
index 6390ceb..f6d285e 100644
--- a/src/Language/PureScript/Sugar/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -9,6 +9,8 @@
-- Portability :
--
-- |
+-- This module implements the desugaring pass which replaces do-notation statements with
+-- appropriate calls to (>>=) from the Prelude.Monad type class.
--
-----------------------------------------------------------------------------
@@ -23,6 +25,10 @@ import Language.PureScript.Values
import Language.PureScript.Names
import Language.PureScript.Scope
+-- |
+-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,
+-- and all @DoNotationLet@ constructors with let expressions.
+--
desugarDo :: (Data d) => d -> Either String d
desugarDo = everywhereM (mkM replace)
where
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index 22cde6e..acda4ff 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -9,6 +9,11 @@
-- Portability :
--
-- |
+-- This module implements the desugaring pass which reapplies binary operators based
+-- on their fixity data and removes explicit parentheses.
+--
+-- The value parser ignores fixity data when parsing binary operator applications, so
+-- it is necessary to reorder them here.
--
-----------------------------------------------------------------------------
@@ -33,6 +38,9 @@ import qualified Text.Parsec as P
import qualified Text.Parsec.Pos as P
import qualified Text.Parsec.Expr as P
+-- |
+-- Remove explicit parentheses and reorder binary operator applications
+--
rebracket :: [Module] -> Either String [Module]
rebracket = go M.empty []
where
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 951ed0c..b7bd429 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -9,6 +9,8 @@
-- Portability :
--
-- |
+-- This module implements the desugaring pass which creates type synonyms for type class dictionaries
+-- and dictionary expressions for type class instances.
--
-----------------------------------------------------------------------------
@@ -38,6 +40,10 @@ type MemberMap = M.Map (ModuleName, ProperName) (String, [(String, Type)])
type Desugar = StateT MemberMap (Either String)
+-- |
+-- Add type synonym declarations for type class dictionary types, and value declarations for type class
+-- instance dictionary expressions.
+--
desugarTypeClasses :: [Module] -> Either String [Module]
desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
@@ -120,6 +126,9 @@ quantify ty' = foldr ForAll ty' tyVars
collect (TypeVar v) = [v]
collect _ = []
+-- |
+-- 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
@@ -135,6 +144,10 @@ typeToString mn (TypeConstructor ty') = return $ qualifiedToString mn ty'
typeToString mn (TypeApp ty' (TypeVar _)) = typeToString mn ty'
typeToString a b = Left $ "Type class instance must be of the form T a1 ... an " ++ show (a, b)
+-- |
+-- 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
diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs
index 1045ac5..53c54fc 100644
--- a/src/Language/PureScript/Sugar/TypeDeclarations.hs
+++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs
@@ -9,6 +9,8 @@
-- Portability :
--
-- |
+-- This module implements the desugaring pass which replaces top-level type declarations with
+-- type annotations on the corresponding expression.
--
-----------------------------------------------------------------------------
@@ -24,9 +26,15 @@ import Control.Monad (forM)
import Language.PureScript.Declarations
import Language.PureScript.Values
+-- |
+-- Replace all top level type declarations in a module with type annotations
+--
desugarTypeDeclarationsModule :: [Module] -> Either String [Module]
desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds) -> Module name <$> desugarTypeDeclarations ds
+-- |
+-- Replace all top level type declarations with type annotations
+--
desugarTypeDeclarations :: [Declaration] -> Either String [Declaration]
desugarTypeDeclarations (TypeDeclaration name ty : ValueDeclaration name' [] Nothing val : rest) | name == name' =
desugarTypeDeclarations (ValueDeclaration name [] Nothing (TypedValue True val ty) : rest)
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 8146fc5..fced1d9 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -9,6 +9,7 @@
-- Portability :
--
-- |
+-- The top-level type checker, which checks all declarations in a module.
--
-----------------------------------------------------------------------------
@@ -88,6 +89,19 @@ addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()
addTypeClassDictionaries entries = do
modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } }
+-- |
+-- Type check all declarations in a module
+--
+-- At this point, many declarations will have been desugared, but it is still necessary to
+--
+-- * Kind-check all types and add them to the @Environment@
+--
+-- * Type-check all values and add them to the @Environment@
+--
+-- * Bring type class instances into scope
+--
+-- * Process module imports
+--
typeCheckAll :: ModuleName -> [Declaration] -> Check [Declaration]
typeCheckAll _ [] = return []
typeCheckAll moduleName (d@(DataDeclaration name args dctors) : rest) = do
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index 5263a7f..1947876 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -9,6 +9,7 @@
-- Portability :
--
-- |
+-- This module implements the kind checker
--
-----------------------------------------------------------------------------
@@ -57,9 +58,15 @@ instance Unifiable Kind where
unknowns (FunKind k1 k2) = unknowns k1 ++ unknowns k2
unknowns _ = []
+-- |
+-- Infer the kind of a single type
+--
kindOf :: ModuleName -> Type -> Check Kind
kindOf moduleName ty = fmap (\(k, s) -> apply s k) . runSubst (SubstContext moduleName) $ starIfUnknown <$> infer ty
+-- |
+-- Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors
+--
kindsOf :: ModuleName -> ProperName -> [String] -> [Type] -> Check Kind
kindsOf moduleName name args ts = fmap (starIfUnknown . (\(k, s) -> apply s k)) . runSubst (SubstContext moduleName) $ do
tyCon <- fresh
@@ -68,6 +75,9 @@ kindsOf moduleName name args ts = fmap (starIfUnknown . (\(k, s) -> apply s k))
bindLocalTypeVariables moduleName dict $
solveTypes ts kargs tyCon
+-- |
+-- Simultaneously infer the kinds of several mutually recursive type constructors
+--
kindsOfAll :: ModuleName -> [(ProperName, [String], Type)] -> [(ProperName, [String], [Type])] -> Check ([Kind], [Kind])
kindsOfAll moduleName syns tys = fmap tidyUp . runSubst (SubstContext moduleName) $ do
synVars <- replicateM (length syns) fresh
@@ -90,6 +100,9 @@ kindsOfAll moduleName syns tys = fmap tidyUp . runSubst (SubstContext moduleName
where
tidyUp ((ks1, ks2), s) = (map starIfUnknown $ apply s ks1, map starIfUnknown $ apply s ks2)
+-- |
+-- Solve the set of kind constraints associated with the data constructors for a type constructor
+--
solveTypes :: [Type] -> [Kind] -> Kind -> Subst Kind
solveTypes ts kargs tyCon = do
ks <- mapM infer ts
@@ -97,11 +110,17 @@ solveTypes ts kargs tyCon = do
forM_ ks $ \k -> k ~~ Star
return tyCon
+-- |
+-- Default all unknown kinds to the Star kind of types
+--
starIfUnknown :: Kind -> Kind
starIfUnknown (KUnknown _) = Star
starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)
starIfUnknown k = k
+-- |
+-- Infer a kind for a type
+--
infer :: Type -> Subst Kind
infer Number = return Star
infer String = return Star
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 1ab2ea0..2d0e856 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -9,6 +9,7 @@
-- Portability :
--
-- |
+-- Monads for type checking and type inference and associated data types
--
-----------------------------------------------------------------------------
@@ -37,31 +38,91 @@ import Control.Arrow ((***))
import qualified Data.Map as M
+-- |
+-- The type of a name in the @Environment@
+--
data NameKind
+ -- |
+ -- A value introduced as a binding in a module
+ --
= Value
+ -- |
+ -- A foreign import
+ --
| Extern ForeignImportType
+ -- |
+ -- An alias for a value in another module, introduced using an import declaration
+ --
| Alias ModuleName Ident
+ -- |
+ -- A local name introduced using a lambda abstraction, variable introduction or binder
+ --
| LocalVariable
+ -- |
+ -- A data constructor
+ --
| DataConstructor deriving Show
+-- |
+-- The type of a type declaration
+--
data TypeDeclarationKind
+ -- |
+ -- A data constructor
+ --
= Data
+ -- |
+ -- A data type foreign import
+ --
| ExternData
+ -- |
+ -- A type synonym
+ --
| TypeSynonym
+ -- |
+ -- An alias for a type in another module, introduced using an import declaration
+ --
| DataAlias ModuleName ProperName
+ -- |
+ -- A local type name introduced using a forall quantifier
+ --
| LocalTypeVariable deriving Show
-data Environment = Environment
- { names :: M.Map (ModuleName, Ident) (Type, NameKind)
+-- |
+-- The @Environment@ defines all values and types which are currently in scope:
+--
+data Environment = Environment {
+ -- |
+ -- Value names currently in scope
+ --
+ names :: M.Map (ModuleName, Ident) (Type, NameKind)
+ -- |
+ -- Type names currently in scope
+ --
, types :: M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)
+ -- |
+ -- Data constructors currently in scope, along with their associated data type constructors
+ --
, dataConstructors :: M.Map (ModuleName, ProperName) (Type, NameKind)
+ -- |
+ -- Type synonyms currently in scope
+ --
, typeSynonyms :: M.Map (ModuleName, ProperName) ([String], Type)
+ -- |
+ -- Available type class dictionaries
+ --
, typeClassDictionaries :: [TypeClassDictionaryInScope]
} deriving (Show)
+-- |
+-- An empty environment with no values and no types defined
+--
emptyEnvironment :: Environment
emptyEnvironment = Environment M.empty M.empty M.empty M.empty []
+-- |
+-- Temporarily bind a collection of names to values
+--
bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind) -> m a -> m a
bindNames newNames action = do
orig <- get
@@ -70,6 +131,9 @@ bindNames newNames action = do
modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }
return a
+-- |
+-- Temporarily bind a collection of names to types
+--
bindTypes :: (MonadState CheckState m) => M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind) -> m a -> m a
bindTypes newNames action = do
orig <- get
@@ -78,6 +142,9 @@ bindTypes newNames action = do
modify $ \st -> st { checkEnv = (checkEnv st) { types = types . checkEnv $ orig } }
return a
+-- |
+-- Temporarily make a collection of type class dictionaries available
+--
withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a
withTypeClassDictionaries entries action = do
orig <- get
@@ -86,17 +153,29 @@ withTypeClassDictionaries entries action = do
modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }
return a
+-- |
+-- Get the currently available list of type class dictionaries
+--
getTypeClassDictionaries :: (Functor m, MonadState CheckState m) => m [TypeClassDictionaryInScope]
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
+-- |
+-- 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
+-- |
+-- Lookup the type of a value by name in the @Environment@
+--
lookupVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified Ident -> m Type
lookupVariable currentModule (Qualified moduleName var) = do
env <- getEnv
@@ -104,6 +183,9 @@ lookupVariable currentModule (Qualified moduleName var) = do
Nothing -> throwError $ show var ++ " is undefined"
Just (ty, _) -> return ty
+-- |
+-- Lookup the kind of a type by name in the @Environment@
+--
lookupTypeVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified ProperName -> m Kind
lookupTypeVariable currentModule (Qualified moduleName name) = do
env <- getEnv
@@ -111,63 +193,120 @@ lookupTypeVariable currentModule (Qualified moduleName name) = do
Nothing -> throwError $ "Type variable " ++ show name ++ " is undefined"
Just (k, _) -> return k
+-- |
+-- Canonicalize an identifier by resolving any aliases introduced by module imports
+--
canonicalize :: ModuleName -> Environment -> Qualified Ident -> (ModuleName, Ident)
canonicalize _ _ (Qualified (Just mn) i) = (mn, i)
canonicalize mn env (Qualified Nothing i) = case (mn, i) `M.lookup` names env of
Just (_, Alias mn' i') -> (mn', i')
_ -> (mn, i)
+-- |
+-- Canonicalize a type variable by resolving any aliases introduced by module imports
+--
canonicalizeType :: ModuleName -> Environment -> Qualified ProperName -> (ModuleName, ProperName)
canonicalizeType _ _ (Qualified (Just mn) nm) = (mn, nm)
canonicalizeType mn env (Qualified Nothing nm) = case (mn, nm) `M.lookup` types env of
Just (_, DataAlias mn' pn') -> (mn', pn')
_ -> (mn, nm)
-data CheckState = CheckState { checkEnv :: Environment
- , checkNextVar :: Int
- , checkNextDictName :: Int
- }
+-- |
+-- State required for type checking:
+--
+data CheckState = CheckState {
+ -- |
+ -- The current @Environment@
+ --
+ checkEnv :: Environment
+ -- |
+ -- The next fresh unification variable name
+ --
+ , checkNextVar :: Int
+ -- |
+ -- The next type class dictionary name
+ --
+ , checkNextDictName :: Int
+ }
+-- |
+-- The type checking monad, which provides the state of the type checker, and error reporting capabilities
+--
newtype Check a = Check { unCheck :: StateT CheckState (Either String) a }
deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError String)
+-- |
+-- Get the current @Environment@
+--
getEnv :: (Functor m, MonadState CheckState m) => m Environment
getEnv = checkEnv <$> get
+-- |
+-- Update the @Environment#
+--
putEnv :: (MonadState CheckState m) => Environment -> m ()
putEnv env = modify (\s -> s { checkEnv = env })
+-- |
+-- Modify the @Environment@
+--
modifyEnv :: (MonadState CheckState m) => (Environment -> Environment) -> m ()
modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
+-- |
+-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.
+--
runCheck :: Check a -> Either String (a, Environment)
runCheck c = do
(a, s) <- flip runStateT (CheckState emptyEnvironment 0 0) $ unCheck c
return (a, checkEnv s)
+-- |
+-- Make an assertion, failing with an error message
+--
guardWith :: (MonadError e m) => e -> Bool -> m ()
guardWith _ True = return ()
guardWith e False = throwError e
+-- |
+-- Rethrow an error with a more detailed error message in the case of failure
+--
rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
rethrow f = flip catchError $ \e -> throwError (f e)
+-- |
+-- Generate new type class dictionary name
+--
freshDictionaryName :: Check Int
freshDictionaryName = do
n <- checkNextDictName <$> get
modify $ \s -> s { checkNextDictName = succ (checkNextDictName s) }
return n
+-- |
+-- A substitution maintains a mapping from unification variables to their values, ensuring that
+-- the type of a unification variable matches the type of its value.
+--
newtype Substitution = Substitution { runSubstitution :: forall t. (Unifiable t) => Unknown t -> t }
instance Monoid Substitution where
mempty = Substitution unknown
s1 `mappend` s2 = Substitution $ \u -> apply s1 (apply s2 (unknown u))
+-- |
+-- State for the substitution monad, which contains the current substitution
+--
data SubstState = SubstState { substSubst :: Substitution }
+-- |
+-- Configuration for the substitution monad, constaining the current module
+--
newtype SubstContext = SubstContext { substCurrentModule :: ModuleName } deriving (Show)
+-- |
+-- The substitution monad, which provides the means to unify values to generate a substitution, in addition to
+-- the actions supported by the type checking monad @Check@.
+--
newtype Subst a = Subst { unSubst :: ReaderT SubstContext (StateT SubstState Check) a }
deriving (Functor, Monad, Applicative, MonadPlus, MonadReader SubstContext)
@@ -177,28 +316,46 @@ instance MonadState CheckState Subst where
deriving instance MonadError String Subst
+-- |
+-- Lift a computation in the @Check@ monad into the substitution monad.
+--
liftCheck :: Check a -> Subst a
liftCheck = Subst . lift . lift
+-- |
+-- Get the current substitution monad state
+--
getSubstState :: Subst SubstState
getSubstState = Subst . lift $ get
+-- |
+-- Run a computation in the substitution monad, generating a return value and the final substitution.
+--
runSubst :: SubstContext -> Subst a -> Check (a, Substitution)
runSubst context subst = do
(a, s) <- flip runStateT (SubstState mempty) . flip runReaderT context . unSubst $ subst
return (a, substSubst s)
+-- |
+-- Generate a substitution from a substitution function for a single type
+--
substituteWith :: (Typeable t) => (Unknown t -> t) -> Substitution
substituteWith f = Substitution $ \u -> fromMaybe (unknown u) $ do
u1 <- cast u
cast (f u1)
+-- |
+-- Substitute a single unification variable
+--
substituteOne :: (Unifiable t) => Unknown t -> t -> Substitution
substituteOne u t = substituteWith $ \u1 ->
case u1 of
u2 | u2 == u -> t
| otherwise -> unknown u2
+-- |
+-- Replace a unification variable with the specified value in the current substitution
+--
replace :: (Unifiable t) => Unknown t -> t -> Subst ()
replace u t' = do
sub <- substSubst <$> Subst get
@@ -210,6 +367,9 @@ replace u t' = do
_ -> current ~~ t
Subst . modify $ \s -> s { substSubst = substituteOne u t <> substSubst s }
+-- |
+-- Identifies types which support unification
+--
class (Typeable t, Data t, Show t) => Unifiable t where
unknown :: Unknown t -> t
(~~) :: t -> t -> Subst ()
@@ -224,21 +384,33 @@ instance (Unifiable a) => Unifiable [a] where
apply s = map (apply s)
unknowns = concatMap unknowns
+-- |
+-- Perform the occurs check, to make sure a unification variable does not occur inside a value
+--
occursCheck :: (Unifiable t) => Unknown s -> t -> Subst ()
occursCheck (Unknown u) t =
case isUnknown t of
Nothing -> guardWith "Occurs check fails" (u `notElem` unknowns t)
_ -> return ()
+-- |
+-- Generate a fresh untyped unification variable
+--
fresh' :: Subst Int
fresh' = do
n <- checkNextVar <$> get
modify $ \s -> s { checkNextVar = succ (checkNextVar s) }
return n
+-- |
+-- Generate a fresh unification variable at a specific type
+--
fresh :: (Unifiable t) => Subst t
fresh = unknown . Unknown <$> fresh'
+-- |
+-- Replace any unqualified names in a type wit their qualified versionss
+--
qualifyAllUnqualifiedNames :: (Data d) => ModuleName -> Environment -> d -> d
qualifyAllUnqualifiedNames mn env = everywhere (mkT go)
where
diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs
index 92d99bb..9c33c45 100644
--- a/src/Language/PureScript/TypeChecker/Synonyms.hs
+++ b/src/Language/PureScript/TypeChecker/Synonyms.hs
@@ -9,6 +9,7 @@
-- Portability :
--
-- |
+-- Functions for replacing fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor
--
-----------------------------------------------------------------------------
@@ -28,6 +29,9 @@ import Data.Generics.Extras
import Control.Monad.Writer
import Control.Monad.Error
+-- |
+-- Build a type substitution for a type synonym
+--
buildTypeSubstitution :: Environment -> ModuleName -> (ModuleName, ProperName) -> Int -> Type -> Either String (Maybe Type)
buildTypeSubstitution env moduleName name n = go n []
where
@@ -37,11 +41,17 @@ buildTypeSubstitution env moduleName name n = go n []
go m args (TypeApp f arg) = go (m - 1) (arg:args) f
go _ _ _ = return Nothing
+-- |
+-- Replace all instances of a specific type synonym with the @SaturatedTypeSynonym@ data constructor
+--
saturateTypeSynonym :: (Data d) => Environment -> ModuleName -> (ModuleName, ProperName) -> Int -> d -> Either String d
saturateTypeSynonym env moduleName name n = everywhereM' (mkM replace)
where
replace t = fmap (fromMaybe t) $ buildTypeSubstitution env moduleName name n t
+-- |
+-- Replace all type synonyms with the @SaturatedTypeSynonym@ data constructor
+--
saturateAllTypeSynonyms :: (Data d) => Environment -> ModuleName -> [((ModuleName, ProperName), Int)] -> d -> Either String d
saturateAllTypeSynonyms env moduleName syns d = foldM (\result (name, n) -> saturateTypeSynonym env moduleName name n result) d syns
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index b334154..0e4127b 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -9,6 +9,7 @@
-- Portability :
--
-- |
+-- This module implements the type checker
--
-----------------------------------------------------------------------------
@@ -19,6 +20,25 @@ module Language.PureScript.TypeChecker.Types (
typesOf
) where
+{-
+ The following functions represent the corresponding type checking judgements:
+
+ infer
+ Synthesize a type for a value
+
+ check
+ Check a value has a given type
+
+ checkProperties
+ Check an object with a given type contains specified properties
+
+ checkFunctionApplication
+ Check a function of a given type returns a value of another type when applied to its arguments
+
+ subsumes
+ Check a type subsumes another type
+-}
+
import Data.List
import Data.Maybe (maybeToList, isNothing, isJust, fromMaybe)
import qualified Data.Data as D
@@ -67,6 +87,9 @@ instance Unifiable Type where
unknowns (RCons _ ty r) = unknowns ty ++ unknowns r
unknowns _ = []
+-- |
+-- Unify two types, updating the current substitution
+--
unifyTypes :: Type -> Type -> Subst ()
unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $ do
unifyTypes' t1 t2
@@ -110,6 +133,13 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +
unifyTypes' r1 r2@REmpty = unifyRows r1 r2
unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."
+-- |
+-- Unify two rows, updating the current substitution
+--
+-- Common labels are first identified, and unified. Remaining labels and types are unified with a
+-- trailing row unification variable, if appropriate, otherwise leftover labels result in a unification
+-- error.
+--
unifyRows :: Type -> Type -> Subst ()
unifyRows r1 r2 =
let
@@ -136,9 +166,16 @@ unifyRows r1 r2 =
unifyRows' [] (Skolem s1) [] (Skolem s2) | s1 == s2 = return ()
unifyRows' sd3 r3 sd4 r4 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd3, r3)) ++ " with " ++ prettyPrintRow (rowFromList (sd4, r4)) ++ "."
+-- |
+-- Ensure type constructors are equal after canonicalization
+--
typeConstructorsAreEqual :: Environment -> ModuleName -> Qualified ProperName -> Qualified ProperName -> Bool
typeConstructorsAreEqual env moduleName = (==) `on` canonicalizeType moduleName env
+-- |
+-- Infer the types of multiple mutually-recursive values, and return elaborated values including
+-- type class dictionaries and type annotations.
+--
typesOf :: ModuleName -> [(Ident, Value)] -> Check [(Ident, (Value, Type))]
typesOf moduleName vals = do
tys <- fmap (\(tys, s) -> map (\(ident, (val, ty)) -> (ident, (overTypes (apply s) val, apply s ty))) tys)
@@ -173,19 +210,32 @@ typesOf moduleName vals = do
return (ident, (overTypes (desaturateAllTypeSynonyms . setifyAll) $ val'
, varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty))
+-- |
+-- Check if a value contains a type annotation
+--
isTyped :: (Ident, Value) -> (Ident, (Value, Maybe (Type, Bool)))
isTyped (name, TypedValue checkType value ty) = (name, (value, Just (ty, checkType)))
isTyped (name, value) = (name, (value, Nothing))
+-- |
+-- Map a function over type annotations appearing inside a value
+--
overTypes :: (Type -> Type) -> Value -> Value
overTypes f = everywhere (mkT f)
+-- |
+-- Replace type class dictionary placeholders with inferred type class dictionaries
+--
replaceTypeClassDictionaries :: ModuleName -> Value -> Check Value
replaceTypeClassDictionaries mn = everywhereM (mkM go)
where
go (TypeClassDictionary constraint dicts) = entails mn dicts constraint
go other = return other
+-- |
+-- 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
env <- getEnv
@@ -211,6 +261,10 @@ entails moduleName context goal@(className, ty) = do
canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm
canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm
+-- |
+-- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup),
+-- and return a substitution from type variables to types which makes the type heads unify.
+--
typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]
typeHeadsAreEqual _ _ String String = Just []
typeHeadsAreEqual _ _ Number Number = Just []
@@ -222,6 +276,9 @@ typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <
typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1
typeHeadsAreEqual _ _ _ _ = Nothing
+-- |
+-- Ensure unsolved unification variables do not escape
+--
escapeCheck :: Value -> Type -> Subst ()
escapeCheck value ty = do
subst <- substSubst <$> getSubstState
@@ -231,12 +288,18 @@ escapeCheck value ty = do
let unsolvedUnknowns = nub . unknowns $ apply subst t
guardWith "Escape check fails" $ null $ unsolvedUnknowns \\ visibleUnknowns
+-- |
+-- Find all type annotations occuring inside a value
+--
findAllTypes :: Value -> [Type]
findAllTypes = everything (++) (mkQ [] go)
where
go (TypedValue _ _ ty) = [ty]
go _ = []
+-- |
+-- Ensure skolem variables do not escape their scope
+--
skolemEscapeCheck :: Type -> Check ()
skolemEscapeCheck ty =
case something (mkQ Nothing findSkolems) ty of
@@ -246,12 +309,21 @@ skolemEscapeCheck ty =
findSkolems (Skolem _) = return ()
findSkolems _ = mzero
+-- |
+-- Ensure a row contains no duplicate labels
+--
setify :: Type -> Type
setify = rowFromList . first (M.toList . M.fromList) . rowToList
+-- |
+-- \"Setify\" all rows occuring inside a value
+--
setifyAll :: (D.Data d) => d -> d
setifyAll = everywhere (mkT setify)
+-- |
+-- Replace outermost unsolved unification variables with named type variables
+--
varIfUnknown :: Type -> Type
varIfUnknown ty =
let unks = nub $ unknowns ty
@@ -262,18 +334,31 @@ varIfUnknown ty =
typeToVar t = t
in mkForAll (sort . map toName $ unks) ty'
+-- |
+-- Replace named type variables with types
+--
replaceAllTypeVars :: (D.Data d) => [(String, Type)] -> d -> d
replaceAllTypeVars = foldl' (\f (name, ty) -> replaceTypeVars name ty . f) id
+-- |
+-- Replace named type variables with new unification variables
+--
replaceAllVarsWithUnknowns :: Type -> Subst Type
replaceAllVarsWithUnknowns (ForAll ident ty) = replaceVarWithUnknown ident ty >>= replaceAllVarsWithUnknowns
replaceAllVarsWithUnknowns ty = return ty
+-- |
+-- Replace a single type variable with a new unification variable
+--
replaceVarWithUnknown :: String -> Type -> Subst Type
replaceVarWithUnknown ident ty = do
tu <- fresh
return $ replaceTypeVars ident tu $ ty
+-- |
+-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate
+-- better error messages during unification.
+--
replaceAllTypeSynonyms :: (Functor m, MonadState CheckState m, MonadReader SubstContext m, MonadError String m) => (D.Data d) => d -> m d
replaceAllTypeSynonyms d = do
env <- getEnv
@@ -281,12 +366,18 @@ replaceAllTypeSynonyms d = do
let syns = map (\((path, name), (args, _)) -> ((path, name), length args)) . M.toList $ typeSynonyms env
either throwError return $ saturateAllTypeSynonyms env moduleName syns d
+-- |
+-- \"Desaturate\" @SaturatedTypeSynonym@s
+--
desaturateAllTypeSynonyms :: (D.Data d) => d -> d
desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)
where
replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args
replaceSaturatedTypeSynonym t = t
+-- |
+-- Replace a type synonym and its arguments with the aliased type
+--
expandTypeSynonym :: Qualified ProperName -> [Type] -> Subst Type
expandTypeSynonym name args = do
env <- getEnv
@@ -295,12 +386,21 @@ expandTypeSynonym name args = do
Just (synArgs, body) -> return $ replaceAllTypeVars (zip synArgs args) body
Nothing -> error "Type synonym was not defined"
+-- |
+-- Ensure a set of property names and value does not contain duplicate labels
+--
ensureNoDuplicateProperties :: (MonadError String m) => [(String, Value)] -> m ()
ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps
+-- |
+-- Infer a type for a value, rethrowing any error to provide a more useful error message
+--
infer :: Value -> Subst Value
infer val = rethrow (\e -> "Error inferring type of term " ++ prettyPrintValue val ++ ":\n" ++ e) $ infer' val
+-- |
+-- Infer a type for a value
+--
infer' :: Value -> Subst Value
infer' v@(NumericLiteral _) = return $ TypedValue True v Number
infer' v@(StringLiteral _) = return $ TypedValue True v String
@@ -399,6 +499,9 @@ infer' (TypedValue checkType val ty) = do
return $ TypedValue True val' ty
infer' _ = error "Invalid argument to infer"
+-- |
+-- Infer the type of a property inside a record with a given type
+--
inferProperty :: Type -> String -> Subst (Maybe Type)
inferProperty (Object row) prop = do
let (props, _) = rowToList row
@@ -411,6 +514,9 @@ inferProperty (ForAll ident ty) prop = do
inferProperty replaced prop
inferProperty _ _ = return Nothing
+-- |
+-- Infer the type of a unary operator application
+--
inferUnary :: UnaryOperator -> Value -> Subst Value
inferUnary op (TypedValue _ val valTy) =
case fromMaybe (error "Invalid operator") $ lookup op unaryOps of
@@ -419,6 +525,9 @@ inferUnary op (TypedValue _ val valTy) =
return $ TypedValue True (Unary op val) resTy
inferUnary _ _ = error "Invalid arguments to inferUnary"
+-- |
+-- Check the type of a unary operator application
+--
checkUnary :: UnaryOperator -> Value -> Type -> Subst Value
checkUnary op val res =
case fromMaybe (error "Invalid operator") $ lookup op unaryOps of
@@ -427,12 +536,18 @@ checkUnary op val res =
val' <- check val valTy
return $ Unary op val'
+-- |
+-- Built-in unary operators
+--
unaryOps :: [(UnaryOperator, (Type, Type))]
unaryOps = [ (Negate, (Number, Number))
, (Not, (Boolean, Boolean))
, (BitwiseNot, (Number, Number))
]
+-- |
+-- Infer the type of a binary operator application
+--
inferBinary :: BinaryOperator -> Value -> Value -> Subst Value
inferBinary op left@(TypedValue _ _ leftTy) right@(TypedValue _ _ rightTy) | isEqualityTest op = do
leftTy ~~ rightTy
@@ -445,6 +560,9 @@ inferBinary op left@(TypedValue _ _ leftTy) right@(TypedValue _ _ rightTy) =
return $ TypedValue True (Binary op left right) resTy
inferBinary _ _ _ = error "Invalid arguments to inferBinary"
+-- |
+-- Check the type of a binary operator application
+--
checkBinary :: BinaryOperator -> Value -> Value -> Type -> Subst Value
checkBinary op left right res | isEqualityTest op = do
res ~~ Boolean
@@ -460,11 +578,17 @@ checkBinary op left right res =
right' <- check right valTy
return $ Binary op left' right'
+-- |
+-- Check if a @BinaryOperator@ is an equality test
+--
isEqualityTest :: BinaryOperator -> Bool
isEqualityTest EqualTo = True
isEqualityTest NotEqualTo = True
isEqualityTest _ = False
+-- |
+-- Built-in binary operators
+--
binaryOps :: [(BinaryOperator, (Type, Type))]
binaryOps = [ (Add, (Number, Number))
, (Subtract, (Number, Number))
@@ -486,6 +610,9 @@ binaryOps = [ (Add, (Number, Number))
, (GreaterThanOrEqualTo, (Number, Boolean))
]
+-- |
+-- Infer the types of variables brought into scope by a binder
+--
inferBinder :: Type -> Binder -> Subst (M.Map Ident Type)
inferBinder _ NullBinder = return M.empty
inferBinder val (StringBinder _) = val ~~ String >> return M.empty
@@ -541,6 +668,9 @@ inferBinder val (NamedBinder name binder) = do
m <- inferBinder val binder
return $ M.insert name val m
+-- |
+-- Check the types of the return values in a set of binders in a case statement
+--
checkBinders :: [Type] -> Type -> [([Binder], Maybe Guard, Value)] -> Subst [([Binder], Maybe Guard, Value)]
checkBinders _ _ [] = return []
checkBinders nvals ret ((binders, grd, val):bs) = do
@@ -556,14 +686,21 @@ checkBinders nvals ret ((binders, grd, val):bs) = do
rs <- checkBinders nvals ret bs
return $ r : rs
+-- |
+-- Check that a local variable name is not already used
+--
assignVariable :: Ident -> Subst ()
assignVariable name = do
env <- checkEnv <$> get
moduleName <- substCurrentModule <$> ask
case M.lookup (moduleName, name) (names env) of
- Just (_, LocalVariable) -> throwError $ "Variable with name " ++ show name ++ " already exists."
+ Just _ -> throwError $ "Variable with name " ++ show name ++ " already exists."
_ -> return ()
+-- |
+-- Check the type of the return values of a statement, returning whether or not the statement returns on
+-- all code paths
+--
checkStatement :: M.Map Ident Type -> Type -> Statement -> Subst (Bool, M.Map Ident Type, Statement)
checkStatement mass _ (VariableIntroduction name val) = do
assignVariable name
@@ -593,6 +730,9 @@ checkStatement mass ret (Return val) = do
val' <- check val ret
return (True, mass, Return val')
+-- |
+-- Check the type of an if-then-else statement
+--
checkIfStatement :: M.Map Ident Type -> Type -> IfStatement -> Subst (Bool, IfStatement)
checkIfStatement mass ret (IfStatement val thens Nothing) = do
val' <- check val Boolean
@@ -604,12 +744,18 @@ checkIfStatement mass ret (IfStatement val thens (Just elses)) = do
(allCodePathsReturn2, elses') <- checkElseStatement mass ret elses
return (allCodePathsReturn1 && allCodePathsReturn2, IfStatement val' thens' (Just elses'))
+-- |
+-- Check the type of an else statement
+--
checkElseStatement :: M.Map Ident Type -> Type -> ElseStatement -> Subst (Bool, ElseStatement)
checkElseStatement mass ret (Else elses) = do
(allCodePathsReturn, _, elses') <- checkBlock mass ret elses
return (allCodePathsReturn, Else elses')
checkElseStatement mass ret (ElseIf ifst) = (id *** ElseIf) <$> checkIfStatement mass ret ifst
+-- |
+-- Check the type of the return value of a block of statements
+--
checkBlock :: M.Map Ident Type -> Type -> [Statement] -> Subst (Bool, M.Map Ident Type, [Statement])
checkBlock mass _ [] = return (False, mass, [])
checkBlock mass ret (s:ss) = do
@@ -622,11 +768,17 @@ checkBlock mass ret (s:ss) = do
(b, m, ss'') <- checkBlock mass1 ret ss'
return (b, m, s':ss'')
+-- |
+-- Skolemize a type variable by replacing its instances with fresh skolem constants
+--
skolemize :: String -> Type -> Subst Type
skolemize ident ty = do
tsk <- Skolem <$> fresh'
return $ replaceTypeVars ident tsk ty
+-- |
+-- Check the type of a value, rethrowing errors to provide a better error message
+--
check :: Value -> Type -> Subst Value
check val ty = rethrow errorMessage $ check' val ty
where
@@ -638,6 +790,9 @@ check val ty = rethrow errorMessage $ check' val ty
":\n" ++
msg
+-- |
+-- Check the type of a value
+--
check' :: Value -> Type -> Subst Value
check' val (ForAll idents ty) = do
sk <- skolemize idents ty
@@ -736,6 +891,11 @@ check' val (SaturatedTypeSynonym name args) = do
check val ty
check' val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty
+-- |
+-- Check the type of a collection of named record fields
+--
+-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.
+--
checkProperties :: [(String, Value)] -> Type -> Bool -> Subst [(String, Value)]
checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
go [] [] REmpty = return []
@@ -765,6 +925,9 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
return $ (p, v') : ps''
go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (Object row)
+-- |
+-- Check the type of a function application, rethrowing errors to provide a better error message
+--
checkFunctionApplication :: Value -> Type -> [Value] -> Type -> Subst Value
checkFunctionApplication fn fnTy args ret = rethrow errorMessage $ checkFunctionApplication' fn fnTy args ret
where
@@ -773,6 +936,9 @@ checkFunctionApplication fn fnTy args ret = rethrow errorMessage $ checkFunction
++ " to arguments " ++ intercalate ", " (map prettyPrintValue args)
++ ":\n" ++ msg
+-- |
+-- Check the type of a function application
+--
checkFunctionApplication' :: Value -> Type -> [Value] -> Type -> Subst Value
checkFunctionApplication' fn (Function argTys retTy) args ret = do
guardWith "Incorrect number of function arguments" (length args == length argTys)
@@ -800,12 +966,27 @@ checkFunctionApplication' _ fnTy args ret = throwError $ "Applying a function of
++ " to argument(s) " ++ intercalate ", " (map prettyPrintValue args)
++ " does not yield a value of type " ++ prettyPrintType ret ++ "."
+-- |
+-- Check whether one type subsumes another, rethrowing errors to provide a better error message
+--
subsumes :: Type -> Type -> Subst ()
-subsumes (ForAll ident ty1) ty2 = do
+subsumes ty1 ty2 = rethrow errorMessage $ subsumes' ty1 ty2
+ where
+ errorMessage msg = "Error checking that type "
+ ++ prettyPrintType ty1
+ ++ " subsumes type "
+ ++ prettyPrintType ty2
+ ++ ":\n" ++ msg
+
+-- |
+-- Check whether one type subsumes another
+--
+subsumes' :: Type -> Type -> Subst ()
+subsumes' (ForAll ident ty1) ty2 = do
replaced <- replaceVarWithUnknown ident ty1
replaced `subsumes` ty2
-subsumes (Function args1 ret1) (Function args2 ret2) = do
+subsumes' (Function args1 ret1) (Function args2 ret2) = do
zipWithM_ subsumes args2 args1
ret1 `subsumes` ret2
-subsumes ty1 ty2 = ty1 ~~ ty2
+subsumes' ty1 ty2 = ty1 ~~ ty2
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index a7ad809..9df92a6 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -9,6 +9,7 @@
-- Portability :
--
-- |
+-- Data types for types
--
-----------------------------------------------------------------------------
@@ -22,37 +23,100 @@ import Data.Generics (mkT, mkQ, everywhereBut)
import Language.PureScript.Names
import Language.PureScript.Unknown (Unknown(..))
+-- |
+-- The type of types
+--
data Type
+ -- |
+ -- A unification variable of type Type
+ --
= TUnknown (Unknown Type)
+ -- |
+ -- Javascript numbers
+ --
| Number
+ -- |
+ -- Javascript strings
+ --
| String
+ -- |
+ -- Javascript booleans
+ --
| Boolean
+ -- |
+ -- Javascript array type constructor
+ --
| Array
+ -- |
+ -- Records, parameterized by a row of types
+ --
| Object Type
+ -- |
+ -- A function, with zero or more arguments
+ --
| Function [Type] Type
+ -- |
+ -- A named type variable
+ --
| TypeVar String
+ -- |
+ -- A type constructor
+ --
| TypeConstructor (Qualified ProperName)
+ -- |
+ -- A type application
+ --
| TypeApp Type Type
+ -- |
+ -- A type synonym which is \"saturated\", i.e. fully applied
+ --
| SaturatedTypeSynonym (Qualified ProperName) [Type]
+ -- |
+ -- Forall quantifier
+ --
| ForAll String Type
+ -- |
+ -- A type with a set of type class constraints
+ --
| ConstrainedType [(Qualified ProperName, Type)] Type
+ -- |
+ -- A skolem constant
+ --
| Skolem Int
+ -- |
+ -- An empty row
+ --
| REmpty
+ -- |
+ -- A non-empty row
+ --
| RCons String Type Type deriving (Show, Eq, Data, Typeable)
+-- |
+-- Convert a row to a list of pairs of labels and types
+--
rowToList :: Type -> ([(String, Type)], Type)
rowToList (RCons name ty row) = let (tys, rest) = rowToList row
in ((name, ty):tys, rest)
rowToList r = ([], r)
+-- |
+-- Convert a list of labels and types to a row
+--
rowFromList :: ([(String, Type)], Type) -> Type
rowFromList ([], r) = r
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 = isPolyType ty
+-- |
+-- Check whather a type is a valid polytype
+--
isPolyType :: Type -> Bool
isPolyType (Object ps) = all isPolyType (map snd . fst $ rowToList ps)
isPolyType (Function args ret) = all isPolyType args && isPolyType ret
@@ -61,12 +125,21 @@ isPolyType (SaturatedTypeSynonym _ args) = all isPolyType args
isPolyType (ForAll _ ty) = isPolyType ty
isPolyType _ = True
+-- |
+-- Universally quantify a type
+--
mkForAll :: [String] -> Type -> Type
mkForAll = flip . foldl . flip $ ForAll
+-- |
+-- The empty record type
+--
unit :: Type
unit = Object REmpty
+-- |
+-- Replace a type variable, taking into account variable shadowing
+--
replaceTypeVars :: (Data d) => String -> Type -> d -> d
replaceTypeVars name t = everywhereBut (mkQ False isShadowed) (mkT replaceTypeVar)
where
diff --git a/src/Language/PureScript/Unknown.hs b/src/Language/PureScript/Unknown.hs
index 96e102b..a5f8e91 100644
--- a/src/Language/PureScript/Unknown.hs
+++ b/src/Language/PureScript/Unknown.hs
@@ -9,6 +9,7 @@
-- Portability :
--
-- |
+-- Data type for unification variables
--
-----------------------------------------------------------------------------
@@ -18,6 +19,9 @@ module Language.PureScript.Unknown where
import Data.Data
+-- |
+-- The type of typed unification variables
+--
newtype Unknown t = Unknown { runUnknown :: Int } deriving (Show, Eq, Ord, Data, Typeable)
diff --git a/src/Language/PureScript/Values.hs b/src/Language/PureScript/Values.hs
index 0051003..3c7bea1 100644
--- a/src/Language/PureScript/Values.hs
+++ b/src/Language/PureScript/Values.hs
@@ -9,6 +9,7 @@
-- Portability :
--
-- |
+-- Data types for values, statements, binders and do notation
--
-----------------------------------------------------------------------------
@@ -21,100 +22,369 @@ import Language.PureScript.Names
import Data.Data
+-- |
+-- A guard is just a boolean-valued expression that appears alongside a set of binders
+--
type Guard = Value
+-- |
+-- Built-in unary operators
+--
data UnaryOperator
+ -- |
+ -- Numeric negation
+ --
= Negate
+ -- |
+ -- Boolean negation
+ --
| Not
+ -- |
+ -- Bitwise negation
+ --
| BitwiseNot
+ -- |
+ -- Numeric unary \'plus\'
+ --
| Positive deriving (Show, Eq, Data, Typeable)
+-- |
+-- Built-in binary operators
+--
data BinaryOperator
+ -- |
+ -- Numeric addition
+ --
= Add
+ -- |
+ -- Numeric subtraction
+ --
| Subtract
+ -- |
+ -- Numeric multiplication
+ --
| Multiply
+ -- |
+ -- Numeric division
+ --
| Divide
+ -- |
+ -- Remainder
+ --
| Modulus
+ -- |
+ -- Generic equality test
+ --
| EqualTo
+ -- |
+ -- Generic inequality test
+ --
| NotEqualTo
+ -- |
+ -- Numeric less-than
+ --
| LessThan
+ -- |
+ -- Numeric less-than-or-equal
+ --
| LessThanOrEqualTo
+ -- |
+ -- Numeric greater-than
+ --
| GreaterThan
+ -- |
+ -- Numeric greater-than-or-equal
+ --
| GreaterThanOrEqualTo
+ -- |
+ -- Boolean and
+ --
| And
+ -- |
+ -- Boolean or
+ --
| Or
+ -- |
+ -- Bitwise and
+ --
| BitwiseAnd
+ -- |
+ -- Bitwise or
+ --
| BitwiseOr
+ -- |
+ -- Bitwise xor
+ --
| BitwiseXor
+ -- |
+ -- Bitwise left shift
+ --
| ShiftLeft
+ -- |
+ -- Bitwise right shift
+ --
| ShiftRight
+ -- |
+ -- Bitwise right shift with zero-fill
+ --
| ZeroFillShiftRight
+ -- |
+ -- String concatenation
+ --
| Concat deriving (Show, Eq, Data, Typeable)
+-- |
+-- Data type for values
+--
data Value
+ -- |
+ -- A numeric literal
+ --
= NumericLiteral (Either Integer Double)
+ -- |
+ -- A string literal
+ --
| StringLiteral String
+ -- |
+ -- A boolean literal
+ --
| BooleanLiteral Bool
+ -- |
+ -- Unary operator application
+ --
| Unary UnaryOperator Value
+ -- |
+ -- Binary operator application
+ --
| Binary BinaryOperator Value Value
+ -- |
+ -- Binary operator application. During the rebracketing phase of desugaring, this data constructor
+ -- will be removed.
+ --
| BinaryNoParens (Qualified Ident) Value Value
+ -- |
+ -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor
+ -- will be removed.
+ --
| Parens Value
+ -- |
+ -- An array literal
+ --
| ArrayLiteral [Value]
+ -- |
+ -- An array indexing expression
+ --
| Indexer Value Value
+ -- |
+ -- An object literal
+ --
| ObjectLiteral [(String, Value)]
+ -- |
+ -- An record property accessor expression
+ --
| Accessor String Value
+ -- |
+ -- Partial record update
+ --
| ObjectUpdate Value [(String, Value)]
+ -- |
+ -- Function introduction
+ --
| Abs [Ident] Value
+ -- |
+ -- Function application
+ --
| App Value [Value]
+ -- |
+ -- Variable
+ --
| Var (Qualified Ident)
+ -- |
+ -- Conditional (if-then-else expression)
+ --
| IfThenElse Value Value Value
+ -- |
+ -- A \"Block\" i.e. a collection of statements which evaluate to a value
+ --
| Block [Statement]
+ -- |
+ -- A data constructor
+ --
| Constructor (Qualified ProperName)
+ -- |
+ -- A case expression. During the case expansion phase of desugaring, top-level binders will get
+ -- desugared into case expressions, hence the need for guards and multiple binders per branch here.
+ --
| Case [Value] [([Binder], Maybe Guard, Value)]
+ -- |
+ -- A value with a type annotation
+ --
| TypedValue Bool Value Type
+ -- |
+ -- A do-notation block
+ --
| Do [DoNotationElement]
+ -- |
+ -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these
+ -- placeholders will be replaced with actual expressions representing type classes dictionaries which
+ -- can be evaluated at runtime. The constructor arguments represent (in order): the type class name and
+ -- instance type, and the type class dictionaries in scope.
+ --
| TypeClassDictionary (Qualified ProperName, Type) [TypeClassDictionaryInScope] deriving (Show, Data, Typeable)
+-- |
+-- The type of a type class dictionary
+--
data TypeClassDictionaryType
+ -- |
+ -- A regular type class dictionary
+ --
= TCDRegular
+ -- |
+ -- A type class dictionary which is an alias for an imported dictionary from another module
+ --
| TCDAlias (Qualified Ident) deriving (Show, Eq, Data, Typeable)
+-- |
+-- Data representing a type class dictionary which is in scope
+--
data TypeClassDictionaryInScope
- = TypeClassDictionaryInScope { tcdName :: Qualified Ident
- , tcdClassName :: Qualified ProperName
- , tcdInstanceType :: Type
- , tcdDependencies :: Maybe [(Qualified ProperName, Type)]
- , tcdType :: TypeClassDictionaryType
- } deriving (Show, Data, Typeable)
+ = TypeClassDictionaryInScope {
+ -- |
+ -- The identifier with which the dictionary can be accessed at runtime
+ --
+ tcdName :: Qualified Ident
+ -- |
+ -- The name of the type class to which this type class instance applies
+ --
+ , tcdClassName :: Qualified ProperName
+ -- |
+ -- The type to which this type class instance applies
+ --
+ , tcdInstanceType :: Type
+ -- |
+ -- Type class dependencies which must be satisfied to construct this dictionary
+ --
+ , tcdDependencies :: Maybe [(Qualified ProperName, Type)]
+ -- |
+ -- The type of this dictionary
+ --
+ , tcdType :: TypeClassDictionaryType
+ } deriving (Show, Data, Typeable)
+-- |
+-- A statement in a do-notation block
+--
data DoNotationElement
+ -- |
+ -- A monadic value without a binder
+ --
= DoNotationValue Value
+ -- |
+ -- A monadic value with a binder
+ --
| DoNotationBind Binder Value
+ -- |
+ -- A let statement, i.e. a pure value with a binder
+ --
| DoNotationLet Binder Value deriving (Show, Data, Typeable)
+-- |
+-- Data type for statements which can appear inside a @Block@ expression
+--
data Statement
+ -- |
+ -- A variable introduction and initial assignment
+ --
= VariableIntroduction Ident Value
+ -- |
+ -- A variable reassignment
+ --
| Assignment Ident Value
+ -- |
+ -- A while loop
+ --
| While Value [Statement]
+ -- |
+ -- A for loop
+ --
| For Ident Value Value [Statement]
+ -- |
+ -- An if-then-else statement
+ --
| If IfStatement
+ -- |
+ -- A return statement
+ --
| Return Value deriving (Show, Data, Typeable)
-data IfStatement = IfStatement Value [Statement] (Maybe ElseStatement) deriving (Show, Data, Typeable)
+-- |
+-- Data type for if-statements
+--
+data IfStatement
+ -- |
+ -- An if statement. Arguments are (in order): boolean condition, true branch, optional else branch.
+ --
+ = IfStatement Value [Statement] (Maybe ElseStatement) deriving (Show, Data, Typeable)
+-- |
+-- Data type for the else branch in an if-statement
+--
data ElseStatement
+ -- |
+ -- An else branch
+ --
= Else [Statement]
+ -- |
+ -- An else-if branch
+ --
| ElseIf IfStatement deriving (Show, Data, Typeable)
+-- |
+-- Data type for binders
+--
data Binder
+ -- |
+ -- Wildcard binder
+ --
= NullBinder
+ -- |
+ -- A binder which matches a boolean literal
+ --
| BooleanBinder Bool
+ -- |
+ -- A binder which matches a string literal
+ --
| StringBinder String
+ -- |
+ -- A binder which matches a numeric literal
+ --
| NumberBinder (Either Integer Double)
+ -- |
+ -- A binder which binds an identifier
+ --
| VarBinder Ident
+ -- |
+ -- A binder which matches a data constructor with no argument
+ --
| NullaryBinder (Qualified ProperName)
+ -- |
+ -- A binder which matches a data constructor with one argument
+ --
| UnaryBinder (Qualified ProperName) Binder
+ -- |
+ -- A binder which matches a record and binds its properties
+ --
| ObjectBinder [(String, Binder)]
+ -- |
+ -- A binder which matches an array and binds its elements
+ --
| ArrayBinder [Binder]
+ -- |
+ -- A binder which matches an array and binds its head and tail
+ --
| ConsBinder Binder Binder
+ -- |
+ -- A binder which binds its input to an identifier
+ --
| NamedBinder Ident Binder deriving (Show, Data, Typeable)
diff --git a/tests/Main.hs b/tests/Main.hs
index d008b74..5fc4b34 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -12,6 +12,8 @@
--
-----------------------------------------------------------------------------
+{-# LANGUAGE DoAndIfThenElse #-}
+
module Main (main) where
import qualified Language.PureScript as P
@@ -19,41 +21,66 @@ import qualified Language.PureScript as P
import Data.List (isSuffixOf)
import Control.Applicative
import Control.Monad
-import System.Exit (exitSuccess, exitFailure)
+import System.Exit
+import System.Process
import System.FilePath (pathSeparator)
import System.Directory (getCurrentDirectory, getDirectoryContents)
+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
-compile :: FilePath -> IO (Either String P.Environment)
-compile inputFile = do
- modules <- P.runIndentParser P.parseModules <$> U.readFile inputFile
+preludeFilename :: IO FilePath
+preludeFilename = Paths.getDataFileName "libraries/prelude/prelude.purs"
+
+readInput :: [FilePath] -> IO (Either ParseError [P.Module])
+readInput inputFiles = fmap (fmap concat . sequence) $ forM inputFiles $ \inputFile -> do
+ text <- U.readFile inputFile
+ return $ P.runIndentParser P.parseModules text
+
+compile :: P.Options -> [FilePath] -> IO (Either String String)
+compile opts inputFiles = do
+ modules <- readInput inputFiles
case modules of
Left parseError -> do
return (Left $ show parseError)
Right ms -> do
- case P.compile P.defaultOptions ms of
+ case P.compile opts ms of
Left typeError -> do
return (Left typeError)
- Right (_, _, env) -> do
- return (Right env)
+ Right (js, _, _) -> do
+ return (Right js)
-assert :: FilePath -> (Either String P.Environment -> Maybe String) -> IO ()
-assert inputFile f = do
- e <- compile inputFile
- case f e of
- Just err -> exitFailure
+assert :: P.Options -> [FilePath] -> (Either String String -> IO (Maybe String)) -> IO ()
+assert opts inputFiles f = do
+ e <- compile opts inputFiles
+ maybeErr <- f e
+ case maybeErr of
+ Just err -> putStrLn err >> exitFailure
Nothing -> return ()
assertCompiles :: FilePath -> IO ()
assertCompiles inputFile = do
putStrLn $ "assert " ++ inputFile ++ " compiles successfully"
- assert inputFile $ either Just (const Nothing)
+ prelude <- preludeFilename
+ assert (P.defaultOptions { P.optionsRunMain = True }) [prelude, inputFile] $ either (return . Just) $ \js -> do
+ args <- getArgs
+ if "--run-js" `elem` args
+ then do
+ (exitCode, out, err) <- readProcessWithExitCode "nodejs" [] js
+ case exitCode of
+ ExitSuccess -> putStrLn out >> return Nothing
+ ExitFailure code -> return $ Just err
+ else return Nothing
assertDoesNotCompile :: FilePath -> IO ()
assertDoesNotCompile inputFile = do
putStrLn $ "assert " ++ inputFile ++ " does not compile"
- assert inputFile $ either (const Nothing) (const $ Just "Should not have compiled")
+ assert P.defaultOptions [inputFile] $ \e ->
+ case e of
+ Left _ -> return Nothing
+ Right _ -> return $ Just "Should not have compiled"
main :: IO ()
main = do