summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-02-04 19:31:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-02-04 19:31:00 (GMT)
commit5133c26a62ad14eca37d034a026478e781fdde25 (patch)
tree435e620cbac38c14c3b7d83824c8a15288ded7c6
parentff34fd8cef528db27adeb7244eba5ffcd8d65e18 (diff)
version 0.3.8.10.3.8.1
-rw-r--r--libraries/prelude/prelude.purs346
-rw-r--r--psc/Main.hs6
-rw-r--r--psci/Main.hs2
-rw-r--r--purescript.cabal3
-rw-r--r--src/Language/PureScript.hs2
-rw-r--r--src/Language/PureScript/CodeGen/Common.hs56
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs95
-rw-r--r--src/Language/PureScript/CodeGen/JS/AST.hs130
-rw-r--r--src/Language/PureScript/CodeGen/Monad.hs6
-rw-r--r--src/Language/PureScript/CodeGen/Optimize.hs154
-rw-r--r--src/Language/PureScript/Kinds.hs4
-rw-r--r--src/Language/PureScript/Options.hs6
-rw-r--r--src/Language/PureScript/Parser/Common.hs19
-rw-r--r--src/Language/PureScript/Parser/JS.hs20
-rw-r--r--src/Language/PureScript/Parser/Values.hs6
-rw-r--r--src/Language/PureScript/Pretty/Common.hs48
-rw-r--r--src/Language/PureScript/Pretty/JS.hs23
-rw-r--r--src/Language/PureScript/Pretty/Kinds.hs2
-rw-r--r--src/Language/PureScript/Pretty/Types.hs4
-rw-r--r--src/Language/PureScript/Pretty/Values.hs49
-rw-r--r--src/Language/PureScript/Scope.hs10
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs26
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs4
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs50
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs8
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs245
-rw-r--r--src/Language/PureScript/Types.hs2
-rw-r--r--src/Language/PureScript/Values.hs118
-rw-r--r--tests/Main.hs2
29 files changed, 795 insertions, 651 deletions
diff --git a/libraries/prelude/prelude.purs b/libraries/prelude/prelude.purs
index 38dc570..e236070 100644
--- a/libraries/prelude/prelude.purs
+++ b/libraries/prelude/prelude.purs
@@ -6,29 +6,33 @@ module Prelude where
foreign import data Array :: * -> *
foreign import data Function :: * -> * -> *
- id :: forall a. a -> a
- id = \x -> x
-
flip :: forall a b c. (a -> b -> c) -> b -> a -> c
- flip = \f -> \b -> \a -> f a b
+ flip f b a = f a b
konst :: forall a b. a -> b -> a
- konst = \a -> \b -> a
+ konst a _ = a
- (|>) :: forall a b c. (a -> b) -> (b -> c) -> a -> c
- (|>) = \f -> \g -> \a -> g (f a)
+ infixr 5 >>>
+ infixr 5 <<<
- infixr 5 |>
+ class Category a where
+ id :: forall t. a t t
+ (<<<) :: forall b c d. a c d -> a b c -> a b d
+ (>>>) :: forall b c d. a b c -> a c d -> a b d
- (<|) :: forall a b c. (b -> c) -> (a -> b) -> a -> c
- (<|) = flip (|>)
+ instance Category (->) where
+ id x = x
+ (<<<) f g x = f (g x)
+ (>>>) f g x = g (f x)
- infixr 5 <|
+ infixr 1000 $
+ infixl 1000 #
($) :: forall a b. (a -> b) -> a -> b
($) f x = f x
- infixr 1000 $
+ (#) :: forall a b. a -> (a -> b) -> b
+ (#) x f = f x
class Show a where
show :: a -> String
@@ -40,12 +44,292 @@ module Prelude where
show true = "true"
show false = "false"
+ foreign import showNumber "function showNumber(n) {\
+ \ return n.toString();\
+ \}" :: Number -> String
+
+ instance Prelude.Show Number where
+ show = showNumber
+
+ class Read a where
+ read :: String -> a
+
+ instance Read String where
+ read s = s
+
+ instance Read Boolean where
+ read "true" = true
+ read _ = false
+
class Monad m where
ret :: forall a. a -> m a
(>>=) :: forall a b. m a -> (a -> m b) -> m b
+ infixl 5 *
+ infixl 5 /
+ infixl 5 %
+
+ infixl 7 -
+ infixl 7 +
+
+ class Num a where
+ (+) :: a -> a -> a
+ (-) :: a -> a -> a
+ (*) :: a -> a -> a
+ (/) :: a -> a -> a
+ (%) :: a -> a -> a
+ negate :: a -> a
+
+ foreign import numAdd "function numAdd(n1) {\
+ \ return function(n2) {\
+ \ return n1 + n2;\
+ \ };\
+ \}" :: Number -> Number -> Number
+
+ foreign import numSub "function numSub(n1) {\
+ \ return function(n2) {\
+ \ return n1 - n2;\
+ \ };\
+ \}" :: Number -> Number -> Number
+
+ foreign import numMul "function numMul(n1) {\
+ \ return function(n2) {\
+ \ return n1 * n2;\
+ \ };\
+ \}" :: Number -> Number -> Number
+
+ foreign import numDiv "function numDiv(n1) {\
+ \ return function(n2) {\
+ \ return n1 / n2;\
+ \ };\
+ \}" :: Number -> Number -> Number
+
+ foreign import numMod "function numMod(n1) {\
+ \ return function(n2) {\
+ \ return n1 % n2;\
+ \ };\
+ \}" :: Number -> Number -> Number
+
+ foreign import numNegate "function numNegate(n) {\
+ \ return -n;\
+ \}" :: Number -> Number
+
+ instance Num Number where
+ (+) = numAdd
+ (-) = numSub
+ (*) = numMul
+ (/) = numDiv
+ (%) = numMod
+ negate = numNegate
+
+ infixl 9 ==
+ infixl 9 /=
+
+ class Eq a where
+ (==) :: a -> a -> Boolean
+ (/=) :: a -> a -> Boolean
+
+ -- Referential equality
+ data Ref a = Ref a
+
+ foreign import refEq "function refEq(r1) {\
+ \ return function(r2) {\
+ \ return r1.value === r2.value;\
+ \ };\
+ \}" :: forall a. Ref a -> Ref a -> Boolean
+
+ foreign import refIneq "function refIneq(r1) {\
+ \ return function(r2) {\
+ \ return r1.value !== r2.value;\
+ \ };\
+ \}" :: forall a. Ref a -> Ref a -> Boolean
+
+ foreign import unsafeRefEq "function unsafeRefEq(r1) {\
+ \ return function(r2) {\
+ \ return r1 === r2;\
+ \ };\
+ \}" :: forall a. a -> a -> Boolean
+
+ foreign import unsafeRefIneq "function unsafeRefIneq(r1) {\
+ \ return function(r2) {\
+ \ return r1 !== r2;\
+ \ };\
+ \}" :: forall a. a -> a -> Boolean
+
+ instance Eq (Ref a) where
+ (==) = refEq
+ (/=) = refIneq
+
+ instance Eq String where
+ (==) = unsafeRefEq
+ (/=) = unsafeRefIneq
+
+ instance Eq Number where
+ (==) = unsafeRefEq
+ (/=) = unsafeRefIneq
+
+ instance Eq Boolean where
+ (==) = unsafeRefEq
+ (/=) = unsafeRefIneq
+
+ instance (Eq a) => Eq [a] where
+ (==) [] [] = true
+ (==) (x:xs) (y:ys) = x == y && xs == ys
+ (==) _ _ = false
+ (/=) xs ys = not (xs == ys)
+
+ infixl 3 <
+ infixl 3 >
+ infixl 3 <=
+ infixl 3 >=
+
+ class Ord a where
+ (<) :: a -> a -> Boolean
+ (>) :: a -> a -> Boolean
+ (<=) :: a -> a -> Boolean
+ (>=) :: a -> a -> Boolean
+
+ foreign import numLess "function numLess(n1) {\
+ \ return function(n2) {\
+ \ return n1 < n2;\
+ \ };\
+ \}" :: Number -> Number -> Boolean
+
+ foreign import numLessEq "function numLessEq(n1) {\
+ \ return function(n2) {\
+ \ return n1 <= n2;\
+ \ };\
+ \}" :: Number -> Number -> Boolean
+
+ foreign import numGreater "function numGreater(n1) {\
+ \ return function(n2) {\
+ \ return n1 > n2;\
+ \ };\
+ \}" :: Number -> Number -> Boolean
+
+ foreign import numGreaterEq "function numGreaterEq(n1) {\
+ \ return function(n2) {\
+ \ return n1 >= n2;\
+ \ };\
+ \}" :: Number -> Number -> Boolean
+
+ instance Ord Number where
+ (<) = numLess
+ (>) = numGreater
+ (<=) = numLessEq
+ (>=) = numGreaterEq
+
+ infixl 10 &
+ infixl 10 |
+ infixl 10 ^
+
+ class Bits b where
+ (&) :: b -> b -> b
+ (|) :: b -> b -> b
+ (^) :: b -> b -> b
+ shl :: b -> Number -> b
+ shr :: b -> Number -> b
+ zshr :: b -> Number -> b
+ complement :: b -> b
+
+ foreign import numShl "function numShl(n1) {\
+ \ return function(n2) {\
+ \ return n1 << n2;\
+ \ };\
+ \}" :: Number -> Number -> Number
+
+ foreign import numShr "function numShr(n1) {\
+ \ return function(n2) {\
+ \ return n1 >> n2;\
+ \ };\
+ \}" :: Number -> Number -> Number
+
+ foreign import numZshr "function numZshr(n1) {\
+ \ return function(n2) {\
+ \ return n1 >>> n2;\
+ \ };\
+ \}" :: Number -> Number -> Number
+
+ foreign import numAnd "function numAnd(n1) {\
+ \ return function(n2) {\
+ \ return n1 & n2;\
+ \ };\
+ \}" :: Number -> Number -> Number
+
+ foreign import numOr "function numOr(n1) {\
+ \ return function(n2) {\
+ \ return n1 | n2;\
+ \ };\
+ \}" :: Number -> Number -> Number
+
+ foreign import numXor "function numXor(n1) {\
+ \ return function(n2) {\
+ \ return n1 ^ n2;\
+ \ };\
+ \}" :: Number -> Number -> Number
+
+ foreign import numComplement "function numComplement(n) {\
+ \ return ~n;\
+ \}" :: Number -> Number
+
+ instance Bits Number where
+ (&) = numAnd
+ (|) = numOr
+ (^) = numXor
+ shl = numShl
+ shr = numShr
+ zshr = numZshr
+ complement = numComplement
+
+ infixl 4 !!
+
+ foreign import (!!) "function $bang$bang(xs) {\
+ \ return function(n) {\
+ \ return xs[n];\
+ \ };\
+ \}" :: forall a. [a] -> Number -> a
+
+ infixr 11 ||
+ infixr 11 &&
+
+ class BoolLike b where
+ (&&) :: b -> b -> b
+ (||) :: b -> b -> b
+ not :: b -> b
+
+ foreign import boolAnd "function boolAnd(b1) {\
+ \ return function(b2) {\
+ \ return b1 && b2;\
+ \ };\
+ \}" :: Boolean -> Boolean -> Boolean
+
+ foreign import boolOr "function boolOr(b1) {\
+ \ return function(b2) {\
+ \ return b1 || b2;\
+ \ };\
+ \}" :: Boolean -> Boolean -> Boolean
+
+ foreign import boolNot "function boolNot(b) {\
+ \ return !b;\
+ \}" :: Boolean -> Boolean
+
+ instance BoolLike Boolean where
+ (&&) = boolAnd
+ (||) = boolOr
+ not = boolNot
+
+ infixr 6 ++
+
+ foreign import (++) "function $plus$plus(s1) {\
+ \ return function(s2) {\
+ \ return s1 + s2;\
+ \ };\
+ \}" :: String -> String -> String
+
module Maybe where
+ import Prelude
+
data Maybe a = Nothing | Just a
maybe :: forall a b. b -> (a -> b) -> Maybe a -> b
@@ -53,7 +337,7 @@ module Maybe where
maybe _ f (Just a) = f a
fromMaybe :: forall a. a -> Maybe a -> a
- fromMaybe a = maybe a Prelude.id
+ fromMaybe a = maybe a (Prelude.id :: forall a. a -> a)
instance Prelude.Monad Maybe where
ret = Just
@@ -65,11 +349,11 @@ module Either where
either :: forall a b c. (a -> c) -> (b -> c) -> Either a b -> c
either f _ (Left a) = f a
- either _ g (Right b) = g b
+ either _ g (Right b) = g b
instance Prelude.Monad (Either e) where
ret = Right
- (>>=) = either (\e _ -> Left e) (\a f -> f a)
+ (>>=) = either (\e _ -> Left e) (\a f -> f a)
module Arrays where
@@ -92,7 +376,7 @@ module Arrays where
map :: forall a b. (a -> b) -> [a] -> [b]
map _ [] = []
- map f (x:xs) = f x : map f xs
+ map f (x:xs) = f x : map f xs
foldr :: forall a b. (a -> b -> a) -> a -> [b] -> a
foldr f a (b : bs) = f (foldr f a bs) b
@@ -194,7 +478,7 @@ module Arrays where
empty :: forall a. [a] -> Boolean
empty [] = true
- empty _ = false
+ empty _ = false
range :: Number -> Number -> [Number]
range lo hi = {
@@ -223,6 +507,7 @@ module Arrays where
module Tuple where
+ import Prelude
import Arrays
type Tuple a b = { fst :: a, snd :: b }
@@ -234,7 +519,7 @@ module Tuple where
uncurry f t = f t.fst t.snd
tuple :: forall a b. a -> b -> Tuple a b
- tuple = curry Prelude.id
+ tuple = curry (\t -> t)
zip :: forall a b. [a] -> [b] -> [Tuple a b]
zip = zipWith tuple
@@ -382,12 +667,6 @@ module Global where
\ };\
\}" :: Number -> Number -> String
- foreign import numberToString "function numberToString(n) {\
- \ return n.toString();\
- \}" :: Number -> String
-
- foreign import isNaN :: Number -> Boolean
-
foreign import isFinite :: Number -> Boolean
foreign import parseFloat :: String -> Number
@@ -402,8 +681,7 @@ module Global where
foreign import decodeURI :: String -> String
- instance Prelude.Show Number where
- show = numberToString
+ foreign import isNaN :: Number -> Boolean
module Math where
@@ -493,7 +771,7 @@ module Eff where
\ return f(a())(); \
\ }; \
\ }; \
- \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b
+ \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b
type Pure a = forall e. Eff e a
@@ -544,11 +822,11 @@ module Errors where
module IORef where
import Eff
-
+
foreign import data Ref :: !
-
+
foreign import data IORef :: * -> *
-
+
foreign import newIORef "function newIORef(val) {\
\ return function () {\
\ return { value: val };\
@@ -582,9 +860,9 @@ module Trace where
import Prelude
import Eff
-
+
foreign import data Trace :: !
-
+
foreign import trace "function trace(s) { \
\ return function() { \
\ console.log(s); \
@@ -593,7 +871,7 @@ module Trace where
\}" :: forall r. String -> Eff (trace :: Trace | r) {}
print :: forall a r. (Prelude.Show a) => a -> Eff (trace :: Trace | r) {}
- print o = trace (show o)
+ print o = trace (show o)
module ST where
@@ -630,7 +908,7 @@ module ST where
\ };\
\ };\
\}" :: forall a h r. STRef h a -> 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/psc/Main.hs b/psc/Main.hs
index 8ce229a..8927b6c 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -90,8 +90,12 @@ runMain :: Term Bool
runMain = value $ flag $ (optInfo [ "run-main" ])
{ optDoc = "Generate code to run the main method in the Main module." }
+noOpts :: Term Bool
+noOpts = value $ flag $ (optInfo [ "no-opts" ])
+ { optDoc = "Skip the optimization phase." }
+
options :: Term P.Options
-options = P.Options <$> tco <*> performRuntimeTypeChecks <*> magicDo <*> runMain
+options = P.Options <$> tco <*> performRuntimeTypeChecks <*> magicDo <*> runMain <*> noOpts
stdInOrInputFiles :: FilePath -> Term (Maybe [FilePath])
stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inputFiles
diff --git a/psci/Main.hs b/psci/Main.hs
index c953a2f..8adb710 100644
--- a/psci/Main.hs
+++ b/psci/Main.hs
@@ -35,7 +35,7 @@ getPreludeFilename :: IO FilePath
getPreludeFilename = Paths.getDataFileName "libraries/prelude/prelude.purs"
options :: P.Options
-options = P.Options True False True True
+options = P.Options True False True True True
completion :: [P.Module] -> CompletionFunc IO
completion ms = completeWord Nothing " \t\n\r" findCompletions
diff --git a/purescript.cabal b/purescript.cabal
index 3432fe6..2ddd476 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.3.7
+version: 0.3.8.1
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -36,6 +36,7 @@ library
Language.PureScript.Sugar.Operators
Language.PureScript.Sugar.TypeClasses
Language.PureScript.CodeGen
+ Language.PureScript.CodeGen.Common
Language.PureScript.CodeGen.Externs
Language.PureScript.CodeGen.JS
Language.PureScript.CodeGen.JS.AST
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index 062b66f..fce4c95 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -65,6 +65,6 @@ compile opts ms = do
_ | optionsRunMain opts -> do
when ((ModuleName (ProperName "Main"), Ident "main") `M.notMember` (names env)) $
Left "Main.main is undefined"
- return $ js ++ [JSApp (JSAccessor "main" (JSVar (Ident "Main"))) []]
+ return $ js ++ [JSApp (JSAccessor "main" (JSVar "Main")) []]
| otherwise -> return js
return (prettyPrintJS js', exts, env)
diff --git a/src/Language/PureScript/CodeGen/Common.hs b/src/Language/PureScript/CodeGen/Common.hs
new file mode 100644
index 0000000..e581057
--- /dev/null
+++ b/src/Language/PureScript/CodeGen/Common.hs
@@ -0,0 +1,56 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.CodeGen.Common
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+-- Common code generation utility functions
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.CodeGen.Common where
+
+import Data.Char
+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) = concatMap identCharToString name
+identToJs (Op op) = concatMap identCharToString op
+identToJs (Escaped name) = name
+
+identCharToString :: Char -> String
+identCharToString c | isAlphaNum c = [c]
+identCharToString '_' = "_"
+identCharToString '.' = "$dot"
+identCharToString '$' = "$dollar"
+identCharToString '~' = "$tilde"
+identCharToString '=' = "$eq"
+identCharToString '<' = "$less"
+identCharToString '>' = "$greater"
+identCharToString '!' = "$bang"
+identCharToString '#' = "$hash"
+identCharToString '%' = "$percent"
+identCharToString '^' = "$up"
+identCharToString '&' = "$amp"
+identCharToString '|' = "$bar"
+identCharToString '*' = "$times"
+identCharToString '/' = "$div"
+identCharToString '+' = "$plus"
+identCharToString '-' = "$minus"
+identCharToString ':' = "$colon"
+identCharToString '\\' = "$bslash"
+identCharToString '?' = "$qmark"
+identCharToString '@' = "$at"
+identCharToString c = '$' : show (ord c)
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 286029e..bd3ace3 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -41,6 +41,7 @@ import Language.PureScript.Options
import Language.PureScript.CodeGen.JS.AST as AST
import Language.PureScript.Types
import Language.PureScript.CodeGen.Optimize
+import Language.PureScript.CodeGen.Common (identToJs)
import Language.PureScript.TypeChecker.Monad (canonicalizeDataConstructor)
-- |
@@ -48,50 +49,51 @@ import Language.PureScript.TypeChecker.Monad (canonicalizeDataConstructor)
--
moduleToJs :: Options -> Module -> Environment -> [JS]
moduleToJs opts (Module pname@(ProperName name) decls) env =
- [ JSVariableIntroduction (Ident name) Nothing
- , JSApp (JSFunction Nothing [Ident name]
- (JSBlock (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts (ModuleName pname) decl env) (sortBy typeClassesLast decls))))
- [JSAssignment (JSAssignVariable (Ident name))
- (JSBinary Or (JSVar (Ident name)) (JSObjectLiteral []))]
+ [ JSVariableIntroduction name Nothing
+ , JSApp (JSFunction Nothing [name]
+ (JSBlock (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts (ModuleName pname) decl env) (decls))))
+ [JSAssignment (JSVar name)
+ (JSBinary Or (JSVar name) (JSObjectLiteral []))]
]
- where
- typeClassesLast (ExternDeclaration TypeClassDictionaryImport _ _ _) (ExternDeclaration TypeClassDictionaryImport _ _ _) = EQ
- typeClassesLast (ExternDeclaration TypeClassDictionaryImport _ _ _) _ = GT
- 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)),
- setProperty (identToJs ident) (JSVar ident) mp ]
+ Just $ JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))
+ : setProperty ident (var ident) mp
declToJs opts mp (BindingGroupDeclaration vals) e =
Just $ concatMap (\(ident, val) ->
- [ JSVariableIntroduction ident (Just (valueToJs opts mp e val)),
- setProperty (identToJs ident) (JSVar ident) mp ]
+ JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))
+ : setProperty ident (var ident) mp
) vals
declToJs _ mp (DataDeclaration _ _ ctors) _ =
Just $ flip concatMap ctors $ \(pn@(ProperName ctor), maybeTy) ->
let
ctorJs =
case maybeTy of
- Nothing -> JSVariableIntroduction (Ident ctor) (Just (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn))) ]))
- Just _ -> JSFunction (Just (Ident ctor)) [Ident "value"]
+ Nothing -> JSVariableIntroduction ctor (Just (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn))) ]))
+ Just _ -> JSFunction (Just ctor) ["value"]
(JSBlock [JSReturn
(JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn)))
- , ("value", JSVar (Ident "value")) ])])
- in [ ctorJs, setProperty ctor (JSVar (Ident ctor)) mp ]
+ , ("value", JSVar "value") ])])
+ in ctorJs : setProperty (Escaped ctor) (JSVar ctor) mp
declToJs opts mp (DataBindingGroupDeclaration ds) e =
Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds
declToJs _ mp (ExternDeclaration importTy ident (Just js) _) _ =
- Just [ js
- , setProperty (identToJs ident) (JSVar ident) mp ]
+ Just $ js : setProperty ident (var ident) mp
declToJs _ _ _ _ = Nothing
-setProperty :: String -> JS -> ModuleName -> JS
-setProperty prop val (ModuleName (ProperName moduleName)) = JSAssignment (JSAssignProperty prop (JSAssignVariable (Ident moduleName))) val
+setProperty :: Ident -> JS -> ModuleName -> [JS]
+setProperty ident@(Op op) val (ModuleName (ProperName moduleName)) =
+ [ JSAssignment (JSAccessor (identToJs ident) (JSVar moduleName)) val
+ , JSAssignment (JSIndexer (JSStringLiteral op) (JSVar moduleName)) (JSAccessor (identToJs ident) (JSVar moduleName)) ]
+setProperty ident val (ModuleName (ProperName moduleName)) =
+ [ JSAssignment (JSAccessor (identToJs ident) (JSVar moduleName)) val ]
+
+var :: Ident -> JS
+var = JSVar . identToJs
valueToJs :: Options -> ModuleName -> Environment -> Value -> JS
valueToJs _ _ _ (NumericLiteral n) = JSNumericLiteral n
@@ -99,28 +101,25 @@ valueToJs _ _ _ (StringLiteral s) = JSStringLiteral s
valueToJs _ _ _ (BooleanLiteral b) = JSBooleanLiteral b
valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs opts m e) xs)
valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs opts m e)) ps)
-valueToJs opts m e (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs opts m e o, JSObjectLiteral (map (second (valueToJs opts m e)) ps)]
+valueToJs opts m e (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar "Object")) [ valueToJs opts m e o, JSObjectLiteral (map (second (valueToJs opts m e)) ps)]
valueToJs _ m e (Constructor (Qualified Nothing name)) =
case M.lookup (m, name) (dataConstructors e) of
Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS identToJs (Qualified (Just aliasModule) aliasIdent)
- _ -> JSVar . Ident . runProperName $ name
+ _ -> JSVar . runProperName $ name
valueToJs _ _ _ (Constructor name) = qualifiedToJS runProperName name
valueToJs opts m e (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs opts m e) sts))) []
valueToJs opts m e (Case values binders) = bindersToJs opts m e binders (map (valueToJs opts m e) values)
valueToJs opts m e (IfThenElse cond th el) = JSConditional (valueToJs opts m e cond) (valueToJs opts m e th) (valueToJs opts m e el)
valueToJs opts m e (Accessor prop val) = JSAccessor prop (valueToJs opts m e val)
-valueToJs opts m e (Indexer index val) = JSIndexer (valueToJs opts m e index) (valueToJs opts m e val)
valueToJs opts m e (App val arg) = JSApp (valueToJs opts m e val) [valueToJs opts m e arg]
-valueToJs opts m e (Abs arg val) = JSFunction Nothing [arg] (JSBlock [JSReturn (valueToJs opts m e val)])
-valueToJs opts m e (TypedValue _ (Abs arg val) ty) | optionsPerformRuntimeTypeChecks opts = JSFunction Nothing [arg] (JSBlock $ runtimeTypeChecks arg ty ++ [JSReturn (valueToJs opts m e val)])
-valueToJs opts m e (Unary op val) = JSUnary op (valueToJs opts m e val)
-valueToJs opts m e (Binary op v1 v2) = JSBinary op (valueToJs opts m e v1) (valueToJs opts m e v2)
+valueToJs opts m e (Abs arg val) = JSFunction Nothing [identToJs arg] (JSBlock [JSReturn (valueToJs opts m e val)])
+valueToJs opts m e (TypedValue _ (Abs arg val) ty) | optionsPerformRuntimeTypeChecks opts = let arg' = identToJs arg in JSFunction Nothing [arg'] (JSBlock $ runtimeTypeChecks arg' ty ++ [JSReturn (valueToJs opts m e val)])
valueToJs _ m e (Var ident) = varToJs m e ident
valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val
valueToJs _ _ _ (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"
valueToJs _ _ _ _ = error "Invalid argument to valueToJs"
-runtimeTypeChecks :: Ident -> Type -> [JS]
+runtimeTypeChecks :: String -> Type -> [JS]
runtimeTypeChecks arg ty =
let
argTy = getFunctionArgumentType ty
@@ -147,16 +146,18 @@ runtimeTypeChecks arg ty =
typeCheck :: JS -> String -> JS
typeCheck js ty' = JSIfElse (JSBinary NotEqualTo (JSTypeOf js) (JSStringLiteral ty')) (JSBlock [JSThrow (JSStringLiteral $ ty' ++ " expected")]) Nothing
arrayCheck :: JS -> JS
- arrayCheck js = JSIfElse (JSUnary Not (JSApp (JSAccessor "isArray" (JSVar (Ident "Array"))) [js])) (JSBlock [JSThrow (JSStringLiteral "Array expected")]) Nothing
+ arrayCheck js = JSIfElse (JSUnary Not (JSApp (JSAccessor "isArray" (JSVar "Array")) [js])) (JSBlock [JSThrow (JSStringLiteral "Array expected")]) Nothing
varToJs :: ModuleName -> Environment -> Qualified Ident -> JS
-varToJs m e qual@(Qualified _ ident) = case M.lookup (qualify m qual) (names e) of
- Just (_, ty) | isExtern ty -> JSVar ident
- Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS identToJs (Qualified (Just aliasModule) aliasIdent)
- _ -> case qual of
- Qualified Nothing _ -> JSVar ident
- _ -> qualifiedToJS identToJs qual
+varToJs m e qual@(Qualified _ ident) = go qual
where
+ go qual = case M.lookup (qualify m qual) (names e) of
+ Just (_, ty) | isExtern ty -> var ident
+ Just (_, Alias aliasModule aliasIdent) -> go (Qualified (Just aliasModule) aliasIdent)
+ _ -> case qual of
+ Qualified Nothing _ -> var ident
+ Qualified (Just (ModuleName (ProperName mn))) (Op op) -> JSIndexer (JSStringLiteral op) (JSVar mn)
+ _ -> qualifiedToJS identToJs qual
isExtern (Extern ForeignImport) = True
isExtern (Alias m' ident') = case M.lookup (m', ident') (names e) of
Just (_, ty') -> isExtern ty'
@@ -164,17 +165,17 @@ varToJs m e qual@(Qualified _ ident) = case M.lookup (qualify m qual) (names e)
isExtern _ = False
qualifiedToJS :: (a -> String) -> Qualified a -> JS
-qualifiedToJS f (Qualified (Just (ModuleName (ProperName m))) a) = JSAccessor (f a) (JSVar (Ident m))
-qualifiedToJS f (Qualified Nothing a) = JSVar (Ident (f a))
+qualifiedToJS f (Qualified (Just (ModuleName (ProperName m))) a) = JSAccessor (f a) (JSVar m)
+qualifiedToJS f (Qualified Nothing a) = JSVar (f a)
bindersToJs :: Options -> ModuleName -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> JS
-bindersToJs opts m e binders vals = runGen (unusedNames (binders, vals)) $ do
+bindersToJs opts m e binders vals = runGen (map identToJs (unusedNames (binders, vals))) $ do
valNames <- replicateM (length vals) fresh
jss <- forM binders $ \(bs, grd, result) -> go valNames [JSReturn (valueToJs opts m e result)] bs grd
return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
vals
where
- go :: [Ident] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]
+ go :: [String] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]
go _ done [] Nothing = return done
go _ done [] (Just cond) = return [JSIfElse (valueToJs opts m e cond) (JSBlock done) Nothing]
go (v:vs) done' (b:bs) grd = do
@@ -182,7 +183,7 @@ bindersToJs opts m e binders vals = runGen (unusedNames (binders, vals)) $ do
binderToJs m e v done'' b
go _ _ _ _ = error "Invalid arguments to bindersToJs"
-binderToJs :: ModuleName -> Environment -> Ident -> [JS] -> Binder -> Gen [JS]
+binderToJs :: ModuleName -> Environment -> String -> [JS] -> Binder -> Gen [JS]
binderToJs _ _ _ done NullBinder = return done
binderToJs _ _ varName done (StringBinder str) =
return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]
@@ -193,7 +194,7 @@ binderToJs _ _ varName done (BooleanBinder True) =
binderToJs _ _ varName done (BooleanBinder False) =
return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
binderToJs _ _ varName done (VarBinder ident) =
- return (JSVariableIntroduction ident (Just (JSVar varName)) : done)
+ return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)
binderToJs m e varName done (NullaryBinder ctor) =
if isOnlyConstructor m e ctor
then
@@ -243,7 +244,7 @@ binderToJs m e varName done (ConsBinder headBinder tailBinder) = do
)) Nothing]
binderToJs m e varName done (NamedBinder ident binder) = do
js <- binderToJs m e varName done binder
- return (JSVariableIntroduction ident (Just (JSVar varName)) : js)
+ return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)
isOnlyConstructor :: ModuleName -> Environment -> Qualified ProperName -> Bool
isOnlyConstructor m e ctor =
@@ -258,10 +259,10 @@ isOnlyConstructor m e ctor =
typeConstructor fn = error $ "Invalid arguments to typeConstructor: " ++ show fn
statementToJs :: Options -> ModuleName -> Environment -> Statement -> JS
-statementToJs opts m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs opts m e value))
-statementToJs opts m e (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs opts m e value)
+statementToJs opts m e (VariableIntroduction ident value) = JSVariableIntroduction (identToJs ident) (Just (valueToJs opts m e value))
+statementToJs opts m e (Assignment target value) = JSAssignment (JSVar (identToJs target)) (valueToJs opts m e value)
statementToJs opts m e (While cond sts) = JSWhile (valueToJs opts m e cond) (JSBlock (map (statementToJs opts m e) sts))
-statementToJs opts m e (For ident start end sts) = JSFor ident (valueToJs opts m e start) (valueToJs opts m e end) (JSBlock (map (statementToJs opts m e) sts))
+statementToJs opts m e (For ident start end sts) = JSFor (identToJs ident) (valueToJs opts m e start) (valueToJs opts m e end) (JSBlock (map (statementToJs opts m e) sts))
statementToJs opts m e (If ifst) = ifToJs ifst
where
ifToJs :: IfStatement -> JS
diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs
index 05454e2..2cd82af 100644
--- a/src/Language/PureScript/CodeGen/JS/AST.hs
+++ b/src/Language/PureScript/CodeGen/JS/AST.hs
@@ -17,11 +17,112 @@
module Language.PureScript.CodeGen.JS.AST where
-import Language.PureScript.Names
-import Language.PureScript.Values
-
import Data.Data
+
+
+-- |
+-- 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 deriving (Show, Eq, Data, Typeable)
+
-- |
-- Data type for simplified Javascript expressions
--
@@ -65,7 +166,7 @@ data JS
-- |
-- A function introduction (optional name, arguments, body)
--
- | JSFunction (Maybe Ident) [Ident] JS
+ | JSFunction (Maybe String) [String] JS
-- |
-- Function application
--
@@ -73,7 +174,7 @@ data JS
-- |
-- Variable
--
- | JSVar Ident
+ | JSVar String
-- |
-- Conditional expression
--
@@ -85,11 +186,11 @@ data JS
-- |
-- A variable introduction and optional initialization
--
- | JSVariableIntroduction Ident (Maybe JS)
+ | JSVariableIntroduction String (Maybe JS)
-- |
-- A variable assignment
--
- | JSAssignment JSAssignment JS
+ | JSAssignment JS JS
-- |
-- While loop
--
@@ -97,7 +198,7 @@ data JS
-- |
-- For loop
--
- | JSFor Ident JS JS JS
+ | JSFor String JS JS JS
-- |
-- If-then-else statement
--
@@ -130,16 +231,3 @@ data JS
-- Raw Javascript (generated when parsing fails for an inline foreign import declaration)
--
| JSRaw String deriving (Show, Eq, 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, Eq, Data, Typeable)
diff --git a/src/Language/PureScript/CodeGen/Monad.hs b/src/Language/PureScript/CodeGen/Monad.hs
index 4fa9cbd..b2bebce 100644
--- a/src/Language/PureScript/CodeGen/Monad.hs
+++ b/src/Language/PureScript/CodeGen/Monad.hs
@@ -26,18 +26,18 @@ import Language.PureScript.Names
-- |
-- Code generation monad data type
--
-newtype Gen a = Gen { unGen :: State [Ident] a } deriving (Functor, Applicative, Monad, MonadState [Ident])
+newtype Gen a = Gen { unGen :: State [String] a } deriving (Functor, Applicative, Monad, MonadState [String])
-- |
-- Run a computation in the code generation monad
--
-runGen :: [Ident] -> Gen a -> a
+runGen :: [String] -> Gen a -> a
runGen names = flip evalState names . unGen
-- |
-- Generate a fresh name
--
-fresh :: Gen Ident
+fresh :: Gen String
fresh = do
(s:ss) <- get
put ss
diff --git a/src/Language/PureScript/CodeGen/Optimize.hs b/src/Language/PureScript/CodeGen/Optimize.hs
index 581b81d..4427a4f 100644
--- a/src/Language/PureScript/CodeGen/Optimize.hs
+++ b/src/Language/PureScript/CodeGen/Optimize.hs
@@ -27,7 +27,9 @@
--
-- * Inlining variables
--
--- * Inline Prelude.($)
+-- * Inline Prelude.($), Prelude.(#), Prelude.(++), Prelude.(!!)
+--
+-- * Inlining primitive Javascript operators
--
-----------------------------------------------------------------------------
@@ -42,16 +44,17 @@ import Data.Generics
import Language.PureScript.Names
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.Options
-import Language.PureScript.Pretty.Common (identToJs)
+import Language.PureScript.CodeGen.Common (identToJs)
import Language.PureScript.Sugar.TypeClasses
(mkDictionaryValueName)
-import Language.PureScript.Types (Type(..))
+import Language.PureScript.Types
-- |
-- Apply a series of optimizer passes to simplified Javascript code
--
optimize :: Options -> JS -> JS
-optimize opts = untilFixedPoint $ applyAll
+optimize opts | optionsNoOptimizations opts = id
+ | otherwise = untilFixedPoint $ applyAll
[ collapseNestedBlocks
, tco opts
, magicDo opts
@@ -59,7 +62,11 @@ optimize opts = untilFixedPoint $ applyAll
, unThunk
, etaConvert
, inlineVariables
- , inlineDollar ]
+ , inlineOperator "$" $ \f x -> JSApp f [x]
+ , inlineOperator "#" $ \x f -> JSApp f [x]
+ , inlineOperator "!!" $ flip JSIndexer
+ , inlineOperator "++" $ JSBinary Add
+ , inlineCommonOperators ]
applyAll :: [a -> a] -> a -> a
applyAll = foldl1 (.)
@@ -70,19 +77,19 @@ untilFixedPoint f a = go a
go a' = let a'' = f a' in
if a'' == a' then a'' else go a''
-replaceIdent :: (Data d) => Ident -> JS -> d -> d
+replaceIdent :: (Data d) => String -> JS -> d -> d
replaceIdent var1 js = everywhere (mkT replace)
where
replace (JSVar var2) | var1 == var2 = js
replace other = other
-replaceIdents :: (Data d) => [(Ident, JS)] -> d -> d
+replaceIdents :: (Data d) => [(String, JS)] -> d -> d
replaceIdents vars = everywhere (mkT replace)
where
replace v@(JSVar var) = fromMaybe v $ lookup var vars
replace other = other
-isReassigned :: (Data d) => Ident -> d -> Bool
+isReassigned :: (Data d) => String -> d -> Bool
isReassigned var1 = everything (||) (mkQ False check)
where
check :: JS -> Bool
@@ -97,7 +104,7 @@ isRebound js d = any (\var -> isReassigned var d) (variablesOf js)
variablesOf (JSIndexer index val) = variablesOf index ++ variablesOf val
variablesOf _ = []
-isUsed :: (Data d) => Ident -> d -> Bool
+isUsed :: (Data d) => String -> d -> Bool
isUsed var1 = everything (||) (mkQ False check)
where
check :: JS -> Bool
@@ -105,11 +112,13 @@ isUsed var1 = everything (||) (mkQ False check)
check (JSAssignment target _) | var1 == targetVariable target = True
check _ = False
-targetVariable :: JSAssignment -> Ident
-targetVariable (JSAssignVariable var) = var
-targetVariable (JSAssignProperty _ tgt) = targetVariable tgt
+targetVariable :: JS -> String
+targetVariable (JSVar var) = var
+targetVariable (JSAccessor _ tgt) = targetVariable tgt
+targetVariable (JSIndexer _ tgt) = targetVariable tgt
+targetVariable _ = error "Invalid argument to targetVariable"
-isUpdated :: (Data d) => Ident -> d -> Bool
+isUpdated :: (Data d) => String -> d -> Bool
isUpdated var1 = everything (||) (mkQ False check)
where
check :: JS -> Bool
@@ -173,12 +182,10 @@ tco' = everywhere (mkT convert)
where
tcoLabel :: String
tcoLabel = "tco"
- tcoVar :: Ident -> Ident
- tcoVar (Ident arg) = Ident $ "__tco_" ++ arg
- tcoVar _ = error "Invalid name in tcoVar"
- copyVar :: Ident -> Ident
- copyVar (Ident arg) = Ident $ "__copy_" ++ arg
- copyVar _ = error "Invalid name in copyVar"
+ tcoVar :: String -> String
+ tcoVar arg = "__tco_" ++ arg
+ copyVar :: String -> String
+ copyVar arg = "__copy_" ++ arg
convert :: JS -> JS
convert js@(JSVariableIntroduction name (Just fn@(JSFunction _ _ _))) =
let
@@ -191,7 +198,7 @@ tco' = everywhere (mkT convert)
JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))
| otherwise -> js
convert js = js
- collectAllFunctionArgs :: [[Ident]] -> (JS -> JS) -> JS -> ([[Ident]], JS, JS -> JS)
+ collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> ([[String]], JS, JS -> JS)
collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =
collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body
collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =
@@ -201,7 +208,7 @@ tco' = everywhere (mkT convert)
collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =
(args : allArgs, body, \b -> f (JSReturn (JSFunction ident (map copyVar args) b)))
collectAllFunctionArgs allArgs f body = (allArgs, body, f)
- isTailCall :: Ident -> JS -> Bool
+ isTailCall :: String -> JS -> Bool
isTailCall ident js =
let
numSelfCalls = everything (+) (mkQ 0 countSelfCalls) js
@@ -220,7 +227,7 @@ tco' = everywhere (mkT convert)
countSelfCallsInTailPosition _ = 0
countSelfCallsUnderFunctions (JSFunction _ _ js') = everything (+) (mkQ 0 countSelfCalls) js'
countSelfCallsUnderFunctions _ = 0
- toLoop :: Ident -> [Ident] -> JS -> JS
+ toLoop :: String -> [String] -> JS -> JS
toLoop ident allArgs js = JSBlock $
map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++
[ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhere (mkT loopify) js ]) ]
@@ -233,13 +240,13 @@ tco' = everywhere (mkT convert)
JSBlock $ zipWith (\val arg ->
JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs
++ map (\arg ->
- JSAssignment (JSAssignVariable arg) (JSVar (tcoVar arg))) allArgs
+ JSAssignment (JSVar arg) (JSVar (tcoVar arg))) allArgs
++ [ JSContinue tcoLabel ]
loopify other = other
collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]
collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn
collectSelfCallArgs allArgumentValues _ = allArgumentValues
- isSelfCall :: Ident -> JS -> Bool
+ isSelfCall :: String -> JS -> Bool
isSelfCall ident (JSApp (JSVar ident') _) | ident == ident' = True
isSelfCall ident (JSApp fn _) = isSelfCall ident fn
isSelfCall _ _ = False
@@ -251,23 +258,24 @@ magicDo opts | optionsMagicDo opts = magicDo'
magicDo' :: JS -> JS
magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
where
- fnName = Ident "__do"
+ fnName = "__do"
convert :: JS -> JS
convert (JSApp (JSApp ret [val]) []) | isReturn ret = val
- convert (JSApp (JSApp bind [m]) [JSFunction Nothing [Ident "_"] (JSBlock [JSReturn ret])]) | isBind bind =
+ convert (JSApp (JSApp bind [m]) [JSFunction Nothing ["_"] (JSBlock [JSReturn ret])]) | isBind bind =
JSFunction (Just fnName) [] $ JSBlock [ JSApp m [], JSReturn (JSApp ret []) ]
convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock [JSReturn ret])]) | isBind bind =
JSFunction (Just fnName) [] $ JSBlock [ JSVariableIntroduction arg (Just (JSApp m [])), JSReturn (JSApp ret []) ]
convert other = other
- isBind (JSApp bindPoly [JSApp effDict []]) | isBindPoly bindPoly && isEffDict effDict = True
+ isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict effDict = True
isBind _ = False
- isReturn (JSApp retPoly [JSApp effDict []]) | isRetPoly retPoly && isEffDict effDict = True
+ isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict effDict = True
isReturn _ = False
- isBindPoly (JSVar (Op ">>=")) = True
- isBindPoly (JSAccessor prop (JSVar (Ident "Prelude"))) | prop == identToJs (Op ">>=") = True
+ isBindPoly (JSVar op) | op == identToJs (Op ">>=") = True
+ isBindPoly (JSAccessor prop (JSVar "Prelude")) | prop == identToJs (Op ">>=") = True
+ isBindPoly (JSIndexer (JSStringLiteral ">>=") (JSVar "Prelude")) = True
isBindPoly _ = False
- isRetPoly (JSVar (Ident "ret")) = True
- isRetPoly (JSAccessor "ret" (JSVar (Ident "Prelude"))) = True
+ isRetPoly (JSVar "ret") = True
+ isRetPoly (JSAccessor "ret" (JSVar "Prelude")) = True
isRetPoly _ = False
prelude = ModuleName (ProperName "Prelude")
effModule = ModuleName (ProperName "Eff")
@@ -275,8 +283,8 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
effModule
(Qualified (Just prelude) (ProperName "Monad"))
(TypeConstructor (Qualified (Just effModule) (ProperName "Eff")))
- isEffDict (JSVar (Ident ident)) | ident == effDictName = True
- isEffDict (JSAccessor prop (JSVar (Ident "Eff"))) | prop == effDictName = True
+ isEffDict (JSVar ident) | ident == effDictName = True
+ isEffDict (JSAccessor prop (JSVar "Eff")) | prop == effDictName = True
isEffDict _ = False
undo :: JS -> JS
undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body
@@ -292,11 +300,79 @@ collapseNestedBlocks = everywhere (mkT collapse)
go (JSBlock sts) = sts
go s = [s]
-inlineDollar :: JS -> JS
-inlineDollar = everywhere (mkT convert)
+inlineOperator :: String -> (JS -> JS -> JS) -> JS -> JS
+inlineOperator op f = everywhere (mkT convert)
where
convert :: JS -> JS
- convert (JSApp (JSApp dollar [f]) [x]) | isDollar dollar = JSApp f [x]
+ convert (JSApp (JSApp op [x]) [y]) | isOp op = f x y
convert other = other
- isDollar (JSAccessor name (JSVar (Ident "Prelude"))) | name == identToJs (Op "$") = True
- isDollar _ = False
+ isOp (JSAccessor longForm (JSVar "Prelude")) | longForm == identToJs (Op op) = True
+ isOp (JSIndexer (JSStringLiteral op') (JSVar "Prelude")) | op == op' = True
+ isOp _ = False
+
+inlineCommonOperators :: JS -> JS
+inlineCommonOperators = applyAll
+ [ binary "+" "Num" tyNumber Add
+ , binary "-" "Num" tyNumber Subtract
+ , binary "*" "Num" tyNumber Multiply
+ , binary "/" "Num" tyNumber Divide
+ , binary "%" "Num" tyNumber Modulus
+ , unary "negate" "Num" tyNumber Negate
+
+ , binary "<" "Ord" tyNumber LessThan
+ , binary ">" "Ord" tyNumber GreaterThan
+ , binary "<=" "Ord" tyNumber LessThanOrEqualTo
+ , binary ">=" "Ord" tyNumber GreaterThanOrEqualTo
+
+ , binary "==" "Eq" tyNumber EqualTo
+ , binary "/=" "Eq" tyNumber NotEqualTo
+ , binary "==" "Eq" tyString EqualTo
+ , binary "/=" "Eq" tyString NotEqualTo
+ , binary "==" "Eq" tyBoolean EqualTo
+ , binary "/=" "Eq" tyBoolean NotEqualTo
+
+ , binaryFunction "shl" "Bits" tyNumber ShiftLeft
+ , binaryFunction "shr" "Bits" tyNumber ShiftRight
+ , binaryFunction "zshr" "Bits" tyNumber ZeroFillShiftRight
+ , binary "&" "Bits" tyNumber BitwiseAnd
+ , binary "|" "Bits" tyNumber BitwiseOr
+ , binary "^" "Bits" tyNumber BitwiseXor
+ , unary "complement" "Bits" tyNumber BitwiseNot
+
+ , binary "&&" "BoolLike" tyBoolean And
+ , binary "||" "BoolLike" tyBoolean Or
+ , unary "not" "BoolLike" tyBoolean Not
+ ]
+ where
+ binary :: String -> String -> Type -> BinaryOperator -> JS -> JS
+ binary opString className classTy op = everywhere (mkT convert)
+ where
+ convert :: JS -> JS
+ convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict className classTy dict = JSBinary op x y
+ convert other = other
+ isOp (JSAccessor longForm (JSVar "Prelude")) | longForm == identToJs (Op opString) = True
+ isOp (JSIndexer (JSStringLiteral op') (JSVar "Prelude")) | opString == op' = True
+ isOp _ = False
+ binaryFunction :: String -> String -> Type -> BinaryOperator -> JS -> JS
+ binaryFunction fnName className classTy op = everywhere (mkT convert)
+ where
+ convert :: JS -> JS
+ convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict className classTy dict = JSBinary op x y
+ convert other = other
+ isOp (JSAccessor fnName' (JSVar "Prelude")) | fnName == fnName' = True
+ isOp _ = False
+ unary :: String -> String -> Type -> UnaryOperator -> JS -> JS
+ unary fnName className classTy op = everywhere (mkT convert)
+ where
+ convert :: JS -> JS
+ convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict className classTy dict = JSUnary op x
+ convert other = other
+ isOp (JSAccessor fnName' (JSVar "Prelude")) | fnName' == fnName = True
+ isOp _ = False
+ isOpDict className ty (JSAccessor prop (JSVar "Prelude")) | prop == dictName = True
+ where
+ Right (Ident dictName) = mkDictionaryValueName
+ (ModuleName (ProperName "Prelude"))
+ (Qualified (Just (ModuleName (ProperName "Prelude"))) (ProperName className))
+ ty
+ isOpDict _ _ _ = False
diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs
index c385832..016a318 100644
--- a/src/Language/PureScript/Kinds.hs
+++ b/src/Language/PureScript/Kinds.hs
@@ -18,7 +18,7 @@ module Language.PureScript.Kinds where
import Data.Data
-import Control.Monad.Unify (TypedUnknown(..))
+import Control.Monad.Unify (Unknown)
-- |
-- The data type of kinds
@@ -27,7 +27,7 @@ data Kind
-- |
-- Unification variable of type Kind
--
- = KUnknown (TypedUnknown Kind)
+ = KUnknown Unknown
-- |
-- The kind of types
--
diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs
index ce24c22..a4e038e 100644
--- a/src/Language/PureScript/Options.hs
+++ b/src/Language/PureScript/Options.hs
@@ -35,10 +35,14 @@ data Options = Options {
-- Check the type of Main.main and generate its code
--
, optionsRunMain :: Bool
+ -- |
+ -- Skip all optimizations
+ --
+ , optionsNoOptimizations :: Bool
} deriving Show
-- |
-- Default compiler options
--
defaultOptions :: Options
-defaultOptions = Options False False False False
+defaultOptions = Options False False False False False
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index c8f8f61..cfc1cdf 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -83,17 +83,10 @@ reservedNames = [ "case"
, "undefined" ]
-- |
--- A list of built-in operator names
---
-builtInOperators :: [String]
-builtInOperators = [ "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"
- , "==", "!=", "&&", "||", "&", "^", "|", "!!", "!" ]
-
--- |
-- A list of reserved operators
--
reservedOpNames :: [String]
-reservedOpNames = builtInOperators ++ [ "=>", "->", "=", ".", "\\" ]
+reservedOpNames = [ "=>", "->", "=", ".", "\\" ]
-- |
-- Valid first characters for an identifier
@@ -257,16 +250,10 @@ 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)
+parseIdent = (Ident <$> identifier) <|> (Op <$> parens operator)
-- |
@@ -374,7 +361,7 @@ buildPostfixParser fs first = do
-- Parse an identifier in backticks or an operator
--
parseIdentInfix :: P.Parsec String ParseState (Qualified Ident)
-parseIdentInfix = (P.between tick tick (parseQualified (Ident <$> identifier))) <|> parseQualified (Op <$> operatorOrBuiltIn)
+parseIdentInfix = (P.between tick tick (parseQualified (Ident <$> identifier))) <|> parseQualified (Op <$> operator)
-- |
-- Mark the current indentation level
diff --git a/src/Language/PureScript/Parser/JS.hs b/src/Language/PureScript/Parser/JS.hs
index 79a84d2..adf6dde 100644
--- a/src/Language/PureScript/Parser/JS.hs
+++ b/src/Language/PureScript/Parser/JS.hs
@@ -52,8 +52,8 @@ parseIdentifierAndValue = (,) <$> (C.identifier <* C.colon)
parseFunction :: P.Parsec String u JS
parseFunction = do
C.reserved "function"
- name <- P.optionMaybe (Ident <$> C.identifier)
- args <- P.parens C.tokenParser $ P.commaSep C.tokenParser (Ident <$> C.identifier)
+ name <- P.optionMaybe C.identifier
+ args <- P.parens C.tokenParser $ P.commaSep C.tokenParser C.identifier
body <- parseJS
return $ JSFunction name args body
@@ -61,7 +61,7 @@ parseBlock :: P.Parsec String u JS
parseBlock = JSBlock <$> P.braces C.tokenParser (P.many parseJS)
parseVar :: P.Parsec String u JS
-parseVar = JSVar <$> Ident <$> C.identifier
+parseVar = JSVar <$> C.identifier
parseJSAtom :: P.Parsec String u JS
parseJSAtom = P.choice
@@ -74,7 +74,6 @@ parseJSAtom = P.choice
, parseBlock
, P.try parseVar
, parseVariableIntroduction
- , P.try parseAssignment
, parseWhile
, parseIf
, parseReturn
@@ -110,7 +109,7 @@ parseJS =
$ indexersAndAccessors) P.<?> "javascript"
where
indexersAndAccessors = C.buildPostfixParser postfixTable1 parseJSAtom
- postfixTable1 = [ parseAccessor, parseIndexer, parseConditional ]
+ postfixTable1 = [ parseAccessor, parseIndexer, parseConditional, parseAssignment ]
postfixTable2 = [ \v -> P.try $ JSApp v <$> (P.parens C.tokenParser (P.commaSep C.tokenParser parseJS)) ]
operators = [ [ binary LessThan "<" P.AssocLeft]
, [ binary LessThanOrEqualTo "<=" P.AssocLeft]
@@ -123,7 +122,6 @@ parseJS =
, [ binary Multiply "*" P.AssocLeft]
, [ binary Divide "/" P.AssocLeft]
, [ binary Modulus "%" P.AssocLeft]
- , [ binary Concat "+" P.AssocLeft]
, [ binary Add "+" P.AssocLeft]
, [ binary Subtract "-" P.AssocLeft]
, [ binary ShiftLeft "<<" P.AssocLeft]
@@ -141,7 +139,7 @@ parseJS =
parseVariableIntroduction :: P.Parsec String u JS
parseVariableIntroduction = do
C.reserved "var"
- name <- Ident <$> P.identifier C.tokenParser
+ name <- P.identifier C.tokenParser
value <- P.optionMaybe $ do
_ <- C.lexeme $ P.char '='
value <- parseJS
@@ -149,17 +147,13 @@ parseVariableIntroduction = do
return value
return $ JSVariableIntroduction name value
-parseAssignment :: P.Parsec String u JS
-parseAssignment = do
- tgt <- parseAssignmentTarget
+parseAssignment :: JS -> P.Parsec String u JS
+parseAssignment tgt = do
_ <- C.lexeme $ P.char '='
value <- parseJS
_ <- C.semi
return $ JSAssignment tgt value
-parseAssignmentTarget :: P.Parsec String u JSAssignment
-parseAssignmentTarget = C.buildPostfixParser [] (JSAssignVariable <$> Ident <$> P.identifier C.tokenParser)
-
parseWhile :: P.Parsec String u JS
parseWhile = JSWhile <$> (C.reserved "while" *> P.parens C.tokenParser parseJS)
<*> parseJS
diff --git a/src/Language/PureScript/Parser/Values.hs b/src/Language/PureScript/Parser/Values.hs
index 671d5df..6ea2f4f 100644
--- a/src/Language/PureScript/Parser/Values.hs
+++ b/src/Language/PureScript/Parser/Values.hs
@@ -155,11 +155,7 @@ parseValue =
postfixTable2 = [ \v -> P.try (C.indented *> indexersAndAccessors >>= return . flip App) <*> pure v
, \v -> flip (TypedValue True) <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v
]
- operators = [ [ Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "!") >> return (Unary Not)
- , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "~") >> return (Unary BitwiseNot)
- , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "-") >> return (Unary Negate)
- , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "+") >> return id ]
- , [ Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->
+ operators = [ [ Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->
return (BinaryNoParens ident))) AssocRight ]
]
diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs
index db74a3a..af07ae4 100644
--- a/src/Language/PureScript/Pretty/Common.hs
+++ b/src/Language/PureScript/Pretty/Common.hs
@@ -13,56 +13,8 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs #-}
-
module Language.PureScript.Pretty.Common where
-import Data.Char
-import Control.Monad.State
-import qualified Control.Category as C
-import Control.Category ((>>>))
-import qualified Control.Arrow as A
-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) = concatMap identCharToString name
-identToJs (Op op) = concatMap identCharToString op
-identToJs (Escaped name) = name
-
-identCharToString :: Char -> String
-identCharToString c | isAlphaNum c = [c]
-identCharToString '_' = "_"
-identCharToString '.' = "$dot"
-identCharToString '$' = "$dollar"
-identCharToString '~' = "$tilde"
-identCharToString '=' = "$eq"
-identCharToString '<' = "$less"
-identCharToString '>' = "$greater"
-identCharToString '!' = "$bang"
-identCharToString '#' = "$hash"
-identCharToString '%' = "$percent"
-identCharToString '^' = "$up"
-identCharToString '&' = "$amp"
-identCharToString '|' = "$bar"
-identCharToString '*' = "$times"
-identCharToString '/' = "$div"
-identCharToString '+' = "$plus"
-identCharToString '-' = "$minus"
-identCharToString ':' = "$colon"
-identCharToString '\\' = "$bslash"
-identCharToString '?' = "$qmark"
-identCharToString '@' = "$at"
-identCharToString c = '$' : show (ord c)
-
-- |
-- Wrap a string in parentheses
--
diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs
index 668efdc..92e3bae 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -89,14 +89,14 @@ literals = mkPattern' match
, currentIndent
, return "}"
]
- match (JSVar ident) = return (identToJs ident)
+ match (JSVar ident) = return ident
match (JSVariableIntroduction ident value) = fmap concat $ sequence
[ return "var "
- , return $ identToJs ident
+ , return ident
, maybe (return "") (fmap (" = " ++) . prettyPrintJS') value
]
match (JSAssignment target value) = fmap concat $ sequence
- [ return $ targetToJs target
+ [ prettyPrintJS' target
, return " = "
, prettyPrintJS' value
]
@@ -107,11 +107,11 @@ literals = mkPattern' match
, prettyPrintJS' sts
]
match (JSFor ident start end sts) = fmap concat $ sequence
- [ return $ "for (" ++ identToJs ident ++ " = "
+ [ return $ "for (" ++ ident ++ " = "
, prettyPrintJS' start
- , return $ "; " ++ identToJs ident ++ " < "
+ , return $ "; " ++ ident ++ " < "
, prettyPrintJS' end
- , return $ "; " ++ identToJs ident ++ "++) "
+ , return $ "; " ++ ident ++ "++) "
, prettyPrintJS' sts
]
match (JSIfElse cond thens elses) = fmap concat $ sequence
@@ -138,10 +138,6 @@ literals = mkPattern' match
match (JSRaw js) = return js
match _ = mzero
-targetToJs :: JSAssignment -> String
-targetToJs (JSAssignVariable ident) = identToJs ident
-targetToJs (JSAssignProperty prop target) = targetToJs target ++ "." ++ prop
-
conditional :: Pattern PrinterState JS ((JS, JS), JS)
conditional = mkPattern match
where
@@ -160,7 +156,7 @@ indexer = mkPattern' match
match (JSIndexer index val) = (,) <$> prettyPrintJS' index <*> pure val
match _ = mzero
-lam :: Pattern PrinterState JS ((Maybe Ident, [Ident]), JS)
+lam :: Pattern PrinterState JS ((Maybe String, [String]), JS)
lam = mkPattern match
where
match (JSFunction name args ret) = Just ((name, args), ret)
@@ -227,8 +223,8 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue
, [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]
, [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]
, [ Wrap lam $ \(name, args) ret -> "function "
- ++ maybe "" identToJs name
- ++ "(" ++ intercalate ", " (map identToJs args) ++ ") "
+ ++ maybe "" id name
+ ++ "(" ++ (intercalate ", " args) ++ ") "
++ ret ]
, [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS1 th ++ " : " ++ prettyPrintJS1 el ]
, [ binary LessThan "<" ]
@@ -243,7 +239,6 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue
, [ binary Multiply "*" ]
, [ binary Divide "/" ]
, [ binary Modulus "%" ]
- , [ binary Concat "+" ]
, [ binary Add "+" ]
, [ binary Subtract "-" ]
, [ binary ShiftLeft "<<" ]
diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs
index 1254c0c..6c67928 100644
--- a/src/Language/PureScript/Pretty/Kinds.hs
+++ b/src/Language/PureScript/Pretty/Kinds.hs
@@ -31,7 +31,7 @@ typeLiterals = mkPattern match
where
match Star = Just "*"
match Bang = Just "!"
- match (KUnknown (TypedUnknown (Unknown u))) = Just $ 'u' : show u
+ match (KUnknown (Unknown u)) = Just $ 'u' : show u
match _ = Nothing
matchRow :: Pattern () Kind ((), Kind)
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index d69cf1c..3f5bba4 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -35,7 +35,7 @@ typeLiterals = mkPattern match
match (TypeVar var) = Just var
match (TypeApp arr ty) | arr == tyArray = Just $ "[" ++ prettyPrintType ty ++ "]"
match (TypeConstructor ctor) = Just $ show ctor
- match (TUnknown (TypedUnknown (Unknown u))) = Just $ 'u' : show u
+ match (TUnknown (Unknown u)) = Just $ 'u' : show u
match (Skolem s) = Just $ 's' : show s
match (ConstrainedType deps ty) = Just $ "(" ++ intercalate "," (map (\(pn, ty') -> show pn ++ " (" ++ prettyPrintType ty' ++ ")") deps) ++ ") => " ++ prettyPrintType ty
match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">"
@@ -54,7 +54,7 @@ prettyPrintRow = (\(tys, rest) -> intercalate ", " (map (uncurry nameAndTypeToPs
nameAndTypeToPs name ty = name ++ " :: " ++ prettyPrintType ty
tailToPs :: Type -> String
tailToPs REmpty = ""
- tailToPs (TUnknown (TypedUnknown (Unknown u))) = " | u" ++ show u
+ tailToPs (TUnknown (Unknown u)) = " | u" ++ show u
tailToPs (TypeVar var) = " | " ++ var
tailToPs (Skolem s) = " | s" ++ show s
tailToPs _ = error "Invalid row tail"
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index e917df7..0932d84 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -62,12 +62,6 @@ accessor = mkPattern match
match (Accessor prop val) = Just (prop, val)
match _ = Nothing
-indexer :: Pattern () Value (Value, Value)
-indexer = mkPattern match
- where
- match (Indexer index val) = Just (index, val)
- match _ = Nothing
-
objectUpdate :: Pattern () Value ([String], Value)
objectUpdate = mkPattern match
where
@@ -92,24 +86,6 @@ typed = mkPattern match
match (TypedValue _ val ty) = Just (ty, val)
match _ = Nothing
-unary :: UnaryOperator -> String -> Operator () Value String
-unary op str = Wrap match (++)
- where
- match :: Pattern () Value (String, Value)
- match = mkPattern match'
- where
- match' (Unary op' val) | op' == op = Just (str, val)
- match' _ = Nothing
-
-binary :: BinaryOperator -> String -> Operator () Value String
-binary op str = AssocR match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
- where
- match :: Pattern () Value (Value, Value)
- match = mkPattern match'
- where
- match' (Binary op' v1 v2) | op' == op = Just (v1, v2)
- match' _ = Nothing
-
prettyPrintDoNotationElement :: DoNotationElement -> String
prettyPrintDoNotationElement (DoNotationValue val) = prettyPrintValue val
prettyPrintDoNotationElement (DoNotationBind binder val) = prettyPrintBinder binder ++ " <- " ++ prettyPrintValue val
@@ -131,31 +107,6 @@ prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue (
, [ Split lam $ \arg val -> "\\" ++ arg ++ " -> " ++ prettyPrintValue val ]
, [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintValue th ++ " : " ++ prettyPrintValue el ]
, [ Wrap typed $ \ty val -> val ++ " :: " ++ prettyPrintType ty ]
- , [ AssocR indexer (\index val -> val ++ " !! " ++ index) ]
- , [ binary LessThan "<" ]
- , [ binary LessThanOrEqualTo "<=" ]
- , [ binary GreaterThan ">" ]
- , [ binary GreaterThanOrEqualTo ">=" ]
- , [ unary Not "!" ]
- , [ unary BitwiseNot "~" ]
- , [ unary Negate "-" ]
- , [ unary Positive "+" ]
- , [ binary Multiply "*" ]
- , [ binary Divide "/" ]
- , [ binary Modulus "%" ]
- , [ binary Concat "++" ]
- , [ binary Add "+" ]
- , [ binary Subtract "-" ]
- , [ binary ShiftLeft "<<" ]
- , [ binary ShiftRight ">>" ]
- , [ binary ZeroFillShiftRight ">>>" ]
- , [ binary EqualTo "==" ]
- , [ binary NotEqualTo "!=" ]
- , [ binary BitwiseAnd "&" ]
- , [ binary BitwiseXor "^" ]
- , [ binary BitwiseOr "|" ]
- , [ binary And "&&" ]
- , [ binary Or "||" ]
]
prettyPrintBinderAtom :: Pattern () Binder String
diff --git a/src/Language/PureScript/Scope.hs b/src/Language/PureScript/Scope.hs
index 43d85f5..f473ba4 100644
--- a/src/Language/PureScript/Scope.hs
+++ b/src/Language/PureScript/Scope.hs
@@ -44,11 +44,11 @@ usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesS `extQ` namesB
namesB (VarBinder name) = [name]
namesB _ = []
namesJS :: JS -> [Ident]
- namesJS (JSVar name) = [name]
- namesJS (JSFunction (Just name) args _) = name : args
- namesJS (JSFunction Nothing args _) = args
- namesJS (JSVariableIntroduction name _) = [name]
- namesJS (JSFor name _ _ _) = [name]
+ namesJS (JSVar name) = [Ident name]
+ namesJS (JSFunction (Just name) args _) = (Ident name) : (Ident `map` args)
+ namesJS (JSFunction Nothing args _) = (Ident `map` args)
+ namesJS (JSVariableIntroduction name _) = [Ident name]
+ namesJS (JSFor name _ _ _) = [Ident name]
namesJS _ = []
-- |
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index 202a6f2..b6c3852 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -60,7 +60,7 @@ customOperatorTable fixities =
let
applyUserOp name t1 t2 = App (App (Var name) t1) t2
userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) . M.toList $ fixities
- sorted = sortBy (compare `on` (\(_, _, p, _) -> p)) (userOps ++ builtIns)
+ sorted = sortBy (compare `on` (\(_, _, p, _) -> p)) userOps
groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted
in
map (map (\(name, f, _, a) -> (name, f, a))) groups
@@ -111,27 +111,3 @@ collectFixities m moduleName (_:ds) = collectFixities m moduleName ds
globalOp :: String -> Qualified Ident
globalOp = Qualified Nothing . Op
-builtIns :: [(Qualified Ident, Value -> Value -> Value, Precedence, Associativity)]
-builtIns = [ (globalOp "<", Binary LessThan, 3, Infixl)
- , (globalOp "<=", Binary LessThanOrEqualTo, 3, Infixl)
- , (globalOp ">", Binary GreaterThan, 3, Infixl)
- , (globalOp ">=", Binary GreaterThanOrEqualTo, 3, Infixl)
- , (globalOp "!!", flip Indexer, 4, Infixl)
- , (globalOp "*", Binary Multiply, 5, Infixl)
- , (globalOp "/", Binary Divide, 5, Infixl)
- , (globalOp "%", Binary Modulus, 5, Infixl)
- , (globalOp "++", Binary Concat, 6, Infixr)
- , (globalOp "+", Binary Add, 7, Infixl)
- , (globalOp "-", Binary Subtract, 7, Infixl)
- , (globalOp "<<", Binary ShiftLeft, 8, Infixl)
- , (globalOp ">>", Binary ShiftRight, 8, Infixl)
- , (globalOp ">>>", Binary ZeroFillShiftRight, 8, Infixl)
- , (globalOp "==", Binary EqualTo, 9, Infixl)
- , (globalOp "!=", Binary NotEqualTo, 9, Infixl)
- , (globalOp "&", Binary BitwiseAnd, 10, Infixl)
- , (globalOp "^", Binary BitwiseXor, 10, Infixl)
- , (globalOp "|", Binary BitwiseOr, 10, Infixl)
- , (globalOp "&&", Binary And, 11, Infixr)
- , (globalOp "||", Binary Or, 11, Infixr)
- ]
-
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 9e2ff37..5e1600c 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -34,7 +34,7 @@ import Control.Monad.State
import Data.Maybe (fromMaybe)
import Data.List (nub)
import Data.Generics (mkQ, everything)
-import Language.PureScript.Pretty.Common (identToJs)
+import Language.PureScript.CodeGen.Common (identToJs)
type MemberMap = M.Map (ModuleName, ProperName) (String, [(String, Type)])
@@ -73,7 +73,7 @@ typeClassDictionaryDeclaration name arg members =
typeClassMemberToDictionaryAccessor :: ProperName -> String -> Declaration -> Declaration
typeClassMemberToDictionaryAccessor name arg (TypeDeclaration ident ty) =
ExternDeclaration TypeClassAccessorImport ident
- (Just (JSFunction (Just ident) [Ident "dict"] (JSBlock [JSReturn (JSAccessor (identToJs ident) (JSVar (Ident "dict")))])))
+ (Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSAccessor (identToJs ident) (JSVar "dict"))])))
(ForAll arg (ConstrainedType [(Qualified Nothing name, TypeVar arg)] ty))
typeClassMemberToDictionaryAccessor _ _ _ = error "Invalid declaration in type class definition"
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index c2b2796..72768a0 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -38,37 +38,43 @@ import Control.Applicative
import qualified Data.Map as M
-instance Unifiable Check Kind where
+instance Partial Kind where
unknown = KUnknown
isUnknown (KUnknown u) = Just u
isUnknown _ = Nothing
- KUnknown u1 ?= KUnknown u2 | u1 == u2 = return ()
- KUnknown u ?= k = replace u k
- k ?= KUnknown u = replace u k
- Star ?= Star = return ()
- Bang ?= Bang = return ()
- Row k1 ?= Row k2 = k1 ?= k2
- FunKind k1 k2 ?= FunKind k3 k4 = do
- k1 ?= k3
- k2 ?= k4
- k1 ?= k2 = UnifyT . lift . throwError $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "."
+
+instance Unifiable Check Kind where
+ KUnknown u1 =?= KUnknown u2 | u1 == u2 = return ()
+ KUnknown u =?= k = u =:= k
+ k =?= KUnknown u = u =:= k
+ Star =?= Star = return ()
+ Bang =?= Bang = return ()
+ Row k1 =?= Row k2 = k1 =?= k2
+ FunKind k1 k2 =?= FunKind k3 k4 = do
+ k1 =?= k3
+ k2 =?= k4
+ k1 =?= k2 = UnifyT . lift . throwError $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "."
-- |
-- Infer the kind of a single type
--
kindOf :: ModuleName -> Type -> Check Kind
-kindOf moduleName ty = liftUnify $ starIfUnknown <$> infer ty
+kindOf moduleName ty = fmap tidyUp . liftUnify $ starIfUnknown <$> infer ty
+ where
+ tidyUp (k, sub) = sub $? k
-- |
-- 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 . liftUnify $ do
+kindsOf moduleName name args ts = fmap tidyUp . liftUnify $ do
tyCon <- fresh
kargs <- replicateM (length args) fresh
let dict = (name, tyCon) : zip (map ProperName args) kargs
bindLocalTypeVariables moduleName dict $
solveTypes ts kargs tyCon
+ where
+ tidyUp (k, sub) = sub $? k
-- |
-- Simultaneously infer the kinds of several mutually recursive type constructors
@@ -93,16 +99,16 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do
solveTypes [ty] kargs synVar) synVars syns
return (syn_ks, data_ks)
where
- tidyUp (ks1, ks2) = (map starIfUnknown ks1, map starIfUnknown ks2)
+ tidyUp ((ks1, ks2), sub) = (map (starIfUnknown . (sub $?)) ks1, map (starIfUnknown . (sub $?)) ks2)
-- |
-- Solve the set of kind constraints associated with the data constructors for a type constructor
--
-solveTypes :: [Type] -> [Kind] -> Kind -> UnifyT Check Kind
+solveTypes :: [Type] -> [Kind] -> Kind -> UnifyT Kind Check Kind
solveTypes ts kargs tyCon = do
ks <- mapM infer ts
- tyCon ?= foldr FunKind Star kargs
- forM_ ks $ \k -> k ?= Star
+ tyCon =?= foldr FunKind Star kargs
+ forM_ ks $ \k -> k =?= Star
return tyCon
-- |
@@ -116,10 +122,10 @@ starIfUnknown k = k
-- |
-- Infer a kind for a type
--
-infer :: Type -> UnifyT Check Kind
+infer :: Type -> UnifyT Kind Check Kind
infer (Object row) = do
k <- infer row
- k ?= Row Star
+ k =?= Row Star
return Star
infer (TypeVar v) = do
Just moduleName <- checkCurrentModule <$> get
@@ -134,7 +140,7 @@ infer (TypeApp t1 t2) = do
k0 <- fresh
k1 <- infer t1
k2 <- infer t2
- k1 ?= FunKind k2 k0
+ k1 =?= FunKind k2 k0
return k0
infer (ForAll ident ty) = do
k <- fresh
@@ -146,11 +152,11 @@ infer REmpty = do
infer (RCons _ ty row) = do
k1 <- infer ty
k2 <- infer row
- k2 ?= Row k1
+ k2 =?= Row k1
return $ Row k1
infer (ConstrainedType deps ty) = do
mapM_ (infer . snd) deps
k <- infer ty
- k ?= Star
+ k =?= Star
return Star
infer _ = error "Invalid argument to infer"
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 392e876..1a954ca 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -210,7 +210,7 @@ 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)
-
+
-- |
-- Canonicalize a data constructor by resolving any aliases introduced by module imports
--
@@ -299,13 +299,13 @@ freshDictionaryName = do
-- |
-- Lift a computation in the @Check@ monad into the substitution monad.
--
-liftCheck :: Check a -> UnifyT Check a
+liftCheck :: Check a -> UnifyT t Check a
liftCheck = UnifyT . lift . lift
-- |
-- Run a computation in the substitution monad, generating a return value and the final substitution.
--
-liftUnify :: (Data a) => UnifyT Check a -> Check a
+liftUnify :: (Partial t) => UnifyT t Check a -> Check (a, Substitution t)
liftUnify unify = do
st <- get
e <- runUnify (defaultUnifyState { unifyNextVar = checkNextVar st }) unify
@@ -313,7 +313,7 @@ liftUnify unify = do
Left err -> throwError err
Right (a, ust) -> do
modify $ \st -> st { checkNextVar = unifyNextVar ust }
- return $ runSubstitution (unifyCurrentSubstitution ust) a
+ return (a, unifyCurrentSubstitution ust)
-- |
-- Replace any unqualified names in a type wit their qualified versionss
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 966fafc..9bbf7d7 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -67,22 +67,24 @@ import Control.Arrow (Arrow(..))
import qualified Data.Map as M
import Data.Function (on)
-instance Unifiable Check Type where
+instance Partial Type where
unknown = TUnknown
isUnknown (TUnknown u) = Just u
isUnknown _ = Nothing
- (?=) = unifyTypes
+
+instance Unifiable Check Type where
+ (=?=) = unifyTypes
-- |
-- Unify two types, updating the current substitution
--
-unifyTypes :: Type -> Type -> UnifyT Check ()
+unifyTypes :: Type -> Type -> UnifyT Type Check ()
unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $ do
unifyTypes' t1 t2
where
unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()
- unifyTypes' (TUnknown u) t = replace u t
- unifyTypes' t (TUnknown u) = replace u t
+ unifyTypes' (TUnknown u) t = u =:= t
+ unifyTypes' t (TUnknown u) = u =:= t
unifyTypes' (SaturatedTypeSynonym name args) ty = do
ty1 <- expandTypeSynonym name args
ty1 `unifyTypes` ty
@@ -95,7 +97,7 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +
sk <- skolemize ident ty1
sk `unifyTypes` ty2
unifyTypes' ty f@(ForAll _ _) = f `unifyTypes` ty
- unifyTypes' (Object row1) (Object row2) = row1 ?= row2
+ unifyTypes' (Object row1) (Object row2) = row1 =?= row2
unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()
unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do
env <- getEnv
@@ -118,7 +120,7 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +
-- trailing row unification variable, if appropriate, otherwise leftover labels result in a unification
-- error.
--
-unifyRows :: Type -> Type -> UnifyT Check ()
+unifyRows :: Type -> Type -> UnifyT Type Check ()
unifyRows r1 r2 =
let
(s1, r1') = rowToList r1
@@ -127,17 +129,17 @@ unifyRows r1 r2 =
sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
in do
- forM_ int (uncurry (?=))
+ forM_ int (uncurry (=?=))
unifyRows' sd1 r1' sd2 r2'
where
- unifyRows' :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> UnifyT Check ()
- unifyRows' [] (TUnknown u) sd r = replace u (rowFromList (sd, r))
- unifyRows' sd r [] (TUnknown u) = replace u (rowFromList (sd, r))
+ unifyRows' :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> UnifyT Type Check ()
+ unifyRows' [] (TUnknown u) sd r = u =:= rowFromList (sd, r)
+ unifyRows' sd r [] (TUnknown u) = u =:= rowFromList (sd, r)
unifyRows' ((name, ty):row) r others u@(TUnknown un) = do
occursCheck un ty
forM_ row $ \(_, t) -> occursCheck un t
u' <- fresh
- u ?= RCons name ty u'
+ u =?= RCons name ty u'
unifyRows' row r others u'
unifyRows' [] REmpty [] REmpty = return ()
unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()
@@ -156,7 +158,7 @@ typeConstructorsAreEqual env moduleName = (==) `on` canonicalizeType moduleName
--
typesOf :: ModuleName -> [(Ident, Value)] -> Check [(Ident, (Value, Type))]
typesOf moduleName vals = do
- tys <- liftUnify $ do
+ tys <- fmap tidyUp . liftUnify $ do
let es = map isTyped vals
typed = filter (isJust . snd . snd) es
untyped = filter (isNothing . snd . snd) es
@@ -174,11 +176,11 @@ typesOf moduleName vals = do
return (ident, (val', ty'))
(ident, (val, Nothing)) -> do
TypedValue _ val' ty <- bindNames dict $ infer val
- ty ?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
+ ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
return (ident, (val', ty))
when (moduleName == ModuleName (ProperName "Main") && fst e == Ident "main") $ do
[eff, a] <- replicateM 2 fresh
- ty ?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName (ProperName "Eff"))) (ProperName "Eff"))) eff) a
+ ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName (ProperName "Eff"))) (ProperName "Eff"))) eff) a
escapeCheck val ty
return triple
forM_ tys $ skolemEscapeCheck . snd . snd
@@ -186,6 +188,8 @@ typesOf moduleName vals = do
val' <- replaceTypeClassDictionaries moduleName val
return (ident, (overTypes (desaturateAllTypeSynonyms . setifyAll) $ val'
, varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty))
+ where
+ tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts
-- |
-- Check if a value contains a type annotation
@@ -257,14 +261,14 @@ typeHeadsAreEqual _ _ _ _ = Nothing
-- |
-- Ensure unsolved unification variables do not escape
--
-escapeCheck :: Value -> Type -> UnifyT Check ()
+escapeCheck :: Value -> Type -> UnifyT Type Check ()
escapeCheck value ty = do
subst <- unifyCurrentSubstitution <$> UnifyT get
- let visibleUnknowns = nub $ unknowns $ runSubstitution subst ty
+ let visibleUnknowns = nub $ unknowns $ subst $? ty
let allUnknowns = findAllTypes value
forM_ allUnknowns $ \t -> do
- let unsolvedUnknowns = nub . unknowns $ runSubstitution subst t
- guardWith ("Escape check fails" ++ show ( runSubstitution subst ty, runSubstitution subst t)) $ null $ unsolvedUnknowns \\ visibleUnknowns
+ let unsolvedUnknowns = nub . unknowns $ subst $? t
+ guardWith ("Escape check fails" ++ show (subst $? ty, subst $? t)) $ null $ unsolvedUnknowns \\ visibleUnknowns
-- |
-- Find all type annotations occuring inside a value
@@ -308,7 +312,7 @@ varIfUnknown ty =
toName = (:) 't' . show
ty' = everywhere (mkT typeToVar) $ ty
typeToVar :: Type -> Type
- typeToVar (TUnknown (TypedUnknown (Unknown u))) = TypeVar (toName u)
+ typeToVar (TUnknown (Unknown u)) = TypeVar (toName u)
typeToVar t = t
in mkForAll (sort . map (toName . runUnknown) $ unks) ty'
@@ -321,14 +325,14 @@ replaceAllTypeVars = foldl' (\f (name, ty) -> replaceTypeVars name ty . f) id
-- |
-- Replace named type variables with new unification variables
--
-replaceAllVarsWithUnknowns :: Type -> UnifyT Check Type
+replaceAllVarsWithUnknowns :: Type -> UnifyT Type Check 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 -> UnifyT Check Type
+replaceVarWithUnknown :: String -> Type -> UnifyT Type Check Type
replaceVarWithUnknown ident ty = do
tu <- fresh
return $ replaceTypeVars ident tu $ ty
@@ -356,7 +360,7 @@ desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)
-- |
-- Replace a type synonym and its arguments with the aliased type
--
-expandTypeSynonym :: Qualified ProperName -> [Type] -> UnifyT Check Type
+expandTypeSynonym :: Qualified ProperName -> [Type] -> UnifyT Type Check Type
expandTypeSynonym name args = do
env <- getEnv
Just moduleName <- checkCurrentModule <$> get
@@ -373,28 +377,21 @@ ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (
-- |
-- Infer a type for a value, rethrowing any error to provide a more useful error message
--
-infer :: Value -> UnifyT Check Value
+infer :: Value -> UnifyT Type Check Value
infer val = rethrow (\e -> "Error inferring type of term " ++ prettyPrintValue val ++ ":\n" ++ e) $ infer' val
-- |
-- Infer a type for a value
--
-infer' :: Value -> UnifyT Check Value
+infer' :: Value -> UnifyT Type Check Value
infer' v@(NumericLiteral _) = return $ TypedValue True v tyNumber
infer' v@(StringLiteral _) = return $ TypedValue True v tyString
infer' v@(BooleanLiteral _) = return $ TypedValue True v tyBoolean
infer' (ArrayLiteral vals) = do
ts <- mapM infer vals
els <- fresh
- forM_ ts $ \(TypedValue _ _ t) -> els ?= TypeApp tyArray t
+ forM_ ts $ \(TypedValue _ _ t) -> els =?= TypeApp tyArray t
return $ TypedValue True (ArrayLiteral ts) els
-infer' (Unary op val) = do
- v <- infer val
- inferUnary op v
-infer' (Binary op left right) = do
- v1 <- infer left
- v2 <- infer right
- inferBinary op v1 v2
infer' (ObjectLiteral ps) = do
ensureNoDuplicateProperties ps
ts <- mapM (infer . snd) ps
@@ -409,11 +406,6 @@ infer' (ObjectUpdate o ps) = do
oldTys <- zip (map fst ps) <$> replicateM (length ps) fresh
o' <- check o $ Object $ rowFromList (oldTys, row)
return $ TypedValue True (ObjectUpdate o' newVals) $ Object $ rowFromList (newTys, row)
-infer' (Indexer index val) = do
- el <- fresh
- index' <- check index tyNumber
- val' <- check val (TypeApp tyArray el)
- return $ TypedValue True (Indexer (TypedValue True index' tyNumber) (TypedValue True val' (TypeApp tyArray el))) el
infer' (Accessor prop val) = do
typed@(TypedValue _ _ objTy) <- infer val
propTy <- inferProperty objTy prop
@@ -466,7 +458,7 @@ infer' (IfThenElse cond th el) = do
cond' <- check cond tyBoolean
v2@(TypedValue _ _ t2) <- infer th
v3@(TypedValue _ _ t3) <- infer el
- t2 ?= t3
+ t2 =?= t3
return $ TypedValue True (IfThenElse cond' v2 v3) t2
infer' (TypedValue checkType val ty) = do
Just moduleName <- checkCurrentModule <$> get
@@ -480,7 +472,7 @@ infer' _ = error "Invalid argument to infer"
-- |
-- Infer the type of a property inside a record with a given type
--
-inferProperty :: Type -> String -> UnifyT Check (Maybe Type)
+inferProperty :: Type -> String -> UnifyT Type Check (Maybe Type)
inferProperty (Object row) prop = do
let (props, _) = rowToList row
return $ lookup prop props
@@ -493,109 +485,13 @@ inferProperty (ForAll ident ty) prop = do
inferProperty _ _ = return Nothing
-- |
--- Infer the type of a unary operator application
---
-inferUnary :: UnaryOperator -> Value -> UnifyT Check Value
-inferUnary op (TypedValue _ val valTy) =
- case fromMaybe (error "Invalid operator") $ lookup op unaryOps of
- (valTy', resTy) -> do
- valTy' ?= 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 -> UnifyT Check Value
-checkUnary op val res =
- case fromMaybe (error "Invalid operator") $ lookup op unaryOps of
- (valTy, resTy) -> do
- res ?= resTy
- val' <- check val valTy
- return $ Unary op val'
-
--- |
--- Built-in unary operators
---
-unaryOps :: [(UnaryOperator, (Type, Type))]
-unaryOps = [ (Negate, (tyNumber, tyNumber))
- , (Not, (tyBoolean, tyBoolean))
- , (BitwiseNot, (tyNumber, tyNumber))
- ]
-
--- |
--- Infer the type of a binary operator application
---
-inferBinary :: BinaryOperator -> Value -> Value -> UnifyT Check Value
-inferBinary op left@(TypedValue _ _ leftTy) right@(TypedValue _ _ rightTy) | isEqualityTest op = do
- leftTy ?= rightTy
- return $ TypedValue True (Binary op left right) tyBoolean
-inferBinary op left@(TypedValue _ _ leftTy) right@(TypedValue _ _ rightTy) =
- case fromMaybe (error "Invalid operator") $ lookup op binaryOps of
- (valTy, resTy) -> do
- leftTy ?= valTy
- rightTy ?= valTy
- 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 -> UnifyT Check Value
-checkBinary op left right res | isEqualityTest op = do
- res ?= tyBoolean
- left'@(TypedValue _ _ t1) <- infer left
- right'@(TypedValue _ _ t2) <- infer right
- t1 ?= t2
- return $ Binary op left' right'
-checkBinary op left right res =
- case fromMaybe (error "Invalid operator") $ lookup op binaryOps of
- (valTy, resTy) -> do
- res ?= resTy
- left' <- check left valTy
- 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, (tyNumber, tyNumber))
- , (Subtract, (tyNumber, tyNumber))
- , (Multiply, (tyNumber, tyNumber))
- , (Divide, (tyNumber, tyNumber))
- , (Modulus, (tyNumber, tyNumber))
- , (BitwiseAnd, (tyNumber, tyNumber))
- , (BitwiseOr, (tyNumber, tyNumber))
- , (BitwiseXor, (tyNumber, tyNumber))
- , (ShiftRight, (tyNumber, tyNumber))
- , (ZeroFillShiftRight, (tyNumber, tyNumber))
- , (And, (tyBoolean, tyBoolean))
- , (Or, (tyBoolean, tyBoolean))
- , (Concat, (tyString, tyString))
- , (Modulus, (tyNumber, tyNumber))
- , (LessThan, (tyNumber, tyBoolean))
- , (LessThanOrEqualTo, (tyNumber, tyBoolean))
- , (GreaterThan, (tyNumber, tyBoolean))
- , (GreaterThanOrEqualTo, (tyNumber, tyBoolean))
- ]
-
--- |
-- Infer the types of variables brought into scope by a binder
--
-inferBinder :: Type -> Binder -> UnifyT Check (M.Map Ident Type)
+inferBinder :: Type -> Binder -> UnifyT Type Check (M.Map Ident Type)
inferBinder _ NullBinder = return M.empty
-inferBinder val (StringBinder _) = val ?= tyString >> return M.empty
-inferBinder val (NumberBinder _) = val ?= tyNumber >> return M.empty
-inferBinder val (BooleanBinder _) = val ?= tyBoolean >> return M.empty
+inferBinder val (StringBinder _) = val =?= tyString >> return M.empty
+inferBinder val (NumberBinder _) = val =?= tyNumber >> return M.empty
+inferBinder val (BooleanBinder _) = val =?= tyBoolean >> return M.empty
inferBinder val (VarBinder name) = return $ M.singleton name val
inferBinder val (NullaryBinder ctor) = do
env <- getEnv
@@ -621,11 +517,11 @@ inferBinder val (ObjectBinder props) = do
row <- fresh
rest <- fresh
m1 <- inferRowProperties row rest props
- val ?= Object row
+ val =?= Object row
return m1
where
- inferRowProperties :: Type -> Type -> [(String, Binder)] -> UnifyT Check (M.Map Ident Type)
- inferRowProperties nrow row [] = nrow ?= row >> return M.empty
+ inferRowProperties :: Type -> Type -> [(String, Binder)] -> UnifyT Type Check (M.Map Ident Type)
+ inferRowProperties nrow row [] = nrow =?= row >> return M.empty
inferRowProperties nrow row ((name, binder):binders) = do
propTy <- fresh
m1 <- inferBinder propTy binder
@@ -634,13 +530,13 @@ inferBinder val (ObjectBinder props) = do
inferBinder val (ArrayBinder binders) = do
el <- fresh
m1 <- M.unions <$> mapM (inferBinder el) binders
- val ?= TypeApp tyArray el
+ val =?= TypeApp tyArray el
return m1
inferBinder val (ConsBinder headBinder tailBinder) = do
el <- fresh
m1 <- inferBinder el headBinder
m2 <- inferBinder val tailBinder
- val ?= TypeApp tyArray el
+ val =?= TypeApp tyArray el
return $ m1 `M.union` m2
inferBinder val (NamedBinder name binder) = do
m <- inferBinder val binder
@@ -649,7 +545,7 @@ inferBinder val (NamedBinder name binder) = do
-- |
-- Check the types of the return values in a set of binders in a case statement
--
-checkBinders :: [Type] -> Type -> [([Binder], Maybe Guard, Value)] -> UnifyT Check [([Binder], Maybe Guard, Value)]
+checkBinders :: [Type] -> Type -> [([Binder], Maybe Guard, Value)] -> UnifyT Type Check [([Binder], Maybe Guard, Value)]
checkBinders _ _ [] = return []
checkBinders nvals ret ((binders, grd, val):bs) = do
Just moduleName <- checkCurrentModule <$> get
@@ -667,7 +563,7 @@ checkBinders nvals ret ((binders, grd, val):bs) = do
-- |
-- Check that a local variable name is not already used
--
-assignVariable :: Ident -> UnifyT Check ()
+assignVariable :: Ident -> UnifyT Type Check ()
assignVariable name = do
env <- checkEnv <$> get
Just moduleName <- checkCurrentModule <$> get
@@ -679,7 +575,7 @@ assignVariable name = do
-- Check the type of the return values of a statement, returning whether or not the statement returns on
-- all code paths
--
-checkStatement :: M.Map Ident Type -> Type -> Statement -> UnifyT Check (Bool, M.Map Ident Type, Statement)
+checkStatement :: M.Map Ident Type -> Type -> Statement -> UnifyT Type Check (Bool, M.Map Ident Type, Statement)
checkStatement mass _ (VariableIntroduction name val) = do
assignVariable name
val'@(TypedValue _ _ t) <- infer val
@@ -688,7 +584,7 @@ checkStatement mass _ (Assignment ident val) = do
val'@(TypedValue _ _ t) <- infer val
case M.lookup ident mass of
Nothing -> throwError $ "No local variable with name " ++ show ident
- Just ty -> do t ?= ty
+ Just ty -> do t =?= ty
return (False, mass, Assignment ident val')
checkStatement mass ret (While val inner) = do
val' <- check val tyBoolean
@@ -711,7 +607,7 @@ checkStatement mass ret (Return val) = do
-- |
-- Check the type of an if-then-else statement
--
-checkIfStatement :: M.Map Ident Type -> Type -> IfStatement -> UnifyT Check (Bool, IfStatement)
+checkIfStatement :: M.Map Ident Type -> Type -> IfStatement -> UnifyT Type Check (Bool, IfStatement)
checkIfStatement mass ret (IfStatement val thens Nothing) = do
val' <- check val tyBoolean
(_, _, thens') <- checkBlock mass ret thens
@@ -725,7 +621,7 @@ checkIfStatement mass ret (IfStatement val thens (Just elses)) = do
-- |
-- Check the type of an else statement
--
-checkElseStatement :: M.Map Ident Type -> Type -> ElseStatement -> UnifyT Check (Bool, ElseStatement)
+checkElseStatement :: M.Map Ident Type -> Type -> ElseStatement -> UnifyT Type Check (Bool, ElseStatement)
checkElseStatement mass ret (Else elses) = do
(allCodePathsReturn, _, elses') <- checkBlock mass ret elses
return (allCodePathsReturn, Else elses')
@@ -734,7 +630,7 @@ checkElseStatement mass ret (ElseIf ifst) = (id *** ElseIf) <$> checkIfStatement
-- |
-- Check the type of the return value of a block of statements
--
-checkBlock :: M.Map Ident Type -> Type -> [Statement] -> UnifyT Check (Bool, M.Map Ident Type, [Statement])
+checkBlock :: M.Map Ident Type -> Type -> [Statement] -> UnifyT Type Check (Bool, M.Map Ident Type, [Statement])
checkBlock mass _ [] = return (False, mass, [])
checkBlock mass ret (s:ss) = do
Just moduleName <- checkCurrentModule <$> get
@@ -749,7 +645,7 @@ checkBlock mass ret (s:ss) = do
-- |
-- Skolemize a type variable by replacing its instances with fresh skolem constants
--
-skolemize :: String -> Type -> UnifyT Check Type
+skolemize :: String -> Type -> UnifyT Type Check Type
skolemize ident ty = do
tsk <- Skolem . runUnknown <$> fresh'
return $ replaceTypeVars ident tsk ty
@@ -757,7 +653,7 @@ skolemize ident ty = do
-- |
-- Check the type of a value, rethrowing errors to provide a better error message
--
-check :: Value -> Type -> UnifyT Check Value
+check :: Value -> Type -> UnifyT Type Check Value
check val ty = rethrow errorMessage $ check' val ty
where
errorMessage msg =
@@ -771,7 +667,7 @@ check val ty = rethrow errorMessage $ check' val ty
-- |
-- Check the type of a value
--
-check' :: Value -> Type -> UnifyT Check Value
+check' :: Value -> Type -> UnifyT Type Check Value
check' val (ForAll idents ty) = do
sk <- skolemize idents ty
check val sk
@@ -790,18 +686,12 @@ check' val u@(TUnknown _) = do
val'@(TypedValue _ _ ty) <- infer val
-- Don't unify an unknown with an inferred polytype
ty' <- replaceAllVarsWithUnknowns ty
- ty' ?= u
+ ty' =?= u
return val'
check' v@(NumericLiteral _) t | t == tyNumber = return v
check' v@(StringLiteral _) t | t == tyString = return v
check' v@(BooleanLiteral _) t | t == tyBoolean = return v
-check' (Unary op val) ty = checkUnary op val ty
-check' (Binary op left right) ty = checkBinary op left right ty
check' (ArrayLiteral vals) (TypeApp a ty) | a == tyArray = ArrayLiteral <$> forM vals (\val -> check val ty)
-check' (Indexer index vals) ty = do
- index' <- check index tyNumber
- vals' <- check vals (TypeApp tyArray ty)
- return $ Indexer index' vals'
check' (Abs arg ret) (TypeApp (TypeApp t argTy) retTy) | t == tyFunction = do
Just moduleName <- checkCurrentModule <$> get
ret' <- bindLocalVariables moduleName [(arg, argTy)] $ check ret retTy
@@ -814,7 +704,8 @@ check' v@(Var var) ty = do
Just moduleName <- checkCurrentModule <$> get
ty1 <- lookupVariable moduleName var
repl <- replaceAllTypeSynonyms ty1
- v' <- subsumes (Just v) repl ty
+ ty' <- replaceAllTypeSynonyms ty
+ v' <- subsumes (Just v) repl ty'
case v' of
Nothing -> throwError "Unable to check type subsumption"
Just v'' -> return v''
@@ -878,10 +769,10 @@ check' val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ p
--
-- 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 -> UnifyT Check [(String, Value)]
+checkProperties :: [(String, Value)] -> Type -> Bool -> UnifyT Type Check [(String, Value)]
checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
go [] [] REmpty = return []
- go [] [] u@(TUnknown _) = do u ?= REmpty
+ go [] [] u@(TUnknown _) = do u =?= REmpty
return []
go [] [] (Skolem _) | lax = return []
go [] ((p, _): _) _ | lax = return []
@@ -890,7 +781,7 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
go ((p,v):ps') [] u@(TUnknown _) = do
v'@(TypedValue _ _ ty) <- infer v
rest <- fresh
- u ?= RCons p ty rest
+ u =?= RCons p ty rest
ps'' <- go ps' [] rest
return $ (p, v') : ps''
go ((p,v):ps') ts r =
@@ -898,7 +789,7 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
Nothing -> do
v'@(TypedValue _ _ ty) <- infer v
rest <- fresh
- r ?= RCons p ty rest
+ r =?= RCons p ty rest
ps'' <- go ps' ts rest
return $ (p, v') : ps''
Just ty -> do
@@ -910,7 +801,7 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
-- |
-- Check the type of a function application, rethrowing errors to provide a better error message
--
-checkFunctionApplication :: Value -> Type -> Value -> Type -> UnifyT Check Value
+checkFunctionApplication :: Value -> Type -> Value -> Type -> UnifyT Type Check Value
checkFunctionApplication fn fnTy arg ret = rethrow errorMessage $ checkFunctionApplication' fn fnTy arg ret
where
errorMessage msg = "Error applying function of type "
@@ -921,9 +812,9 @@ checkFunctionApplication fn fnTy arg ret = rethrow errorMessage $ checkFunctionA
-- |
-- Check the type of a function application
--
-checkFunctionApplication' :: Value -> Type -> Value -> Type -> UnifyT Check Value
+checkFunctionApplication' :: Value -> Type -> Value -> Type -> UnifyT Type Check Value
checkFunctionApplication' fn (TypeApp (TypeApp tyFunction' argTy) retTy) arg ret = do
- tyFunction' ?= tyFunction
+ tyFunction' =?= tyFunction
arg' <- check arg argTy
_ <- subsumes Nothing retTy ret
return $ App fn arg'
@@ -935,7 +826,7 @@ checkFunctionApplication' fn u@(TUnknown _) arg ret = do
TypedValue _ v t <- infer arg
TypedValue True v <$> replaceAllVarsWithUnknowns t
let ty = (\(TypedValue _ _ t) -> t) arg'
- u ?= function ty ret
+ u =?= function ty ret
return $ App fn arg'
checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg ret = do
ty <- expandTypeSynonym name tyArgs
@@ -953,7 +844,7 @@ checkFunctionApplication' _ fnTy arg ret = throwError $ "Applying a function of
-- |
-- Check whether one type subsumes another, rethrowing errors to provide a better error message
--
-subsumes :: Maybe Value -> Type -> Type -> UnifyT Check (Maybe Value)
+subsumes :: Maybe Value -> Type -> Type -> UnifyT Type Check (Maybe Value)
subsumes val ty1 ty2 = rethrow errorMessage $ subsumes' val ty1 ty2
where
errorMessage msg = "Error checking that type "
@@ -965,7 +856,7 @@ subsumes val ty1 ty2 = rethrow errorMessage $ subsumes' val ty1 ty2
-- |
-- Check whether one type subsumes another
--
-subsumes' :: Maybe Value -> Type -> Type -> UnifyT Check (Maybe Value)
+subsumes' :: Maybe Value -> Type -> Type -> UnifyT Type Check (Maybe Value)
subsumes' val (ForAll ident ty1) ty2 = do
replaced <- replaceVarWithUnknown ident ty1
subsumes val replaced ty2
@@ -973,6 +864,12 @@ subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2)
subsumes Nothing arg2 arg1
subsumes Nothing ret1 ret2
return val
+subsumes' val (SaturatedTypeSynonym name tyArgs) ty2 = do
+ ty1 <- expandTypeSynonym name tyArgs
+ subsumes val ty1 ty2
+subsumes' val ty1 (SaturatedTypeSynonym name tyArgs) = do
+ ty2 <- expandTypeSynonym name tyArgs
+ subsumes val ty1 ty2
subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do
env <- getEnv
dicts <- getTypeClassDictionaries
@@ -980,6 +877,6 @@ subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do
_ <- subsumes' Nothing ty1 ty2
return . Just $ foldl App val (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))
subsumes' val ty1 ty2 = do
- ty1 ?= ty2
+ ty1 =?= ty2
return val
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index 52b0b33..6ddf539 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -31,7 +31,7 @@ data Type
-- |
-- A unification variable of type Type
--
- = TUnknown (TypedUnknown Type)
+ = TUnknown Unknown
-- |
-- Javascript numbers
--
diff --git a/src/Language/PureScript/Values.hs b/src/Language/PureScript/Values.hs
index 8fb7e81..5433b1c 100644
--- a/src/Language/PureScript/Values.hs
+++ b/src/Language/PureScript/Values.hs
@@ -28,112 +28,6 @@ import Data.Data
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
@@ -150,14 +44,6 @@ data Value
--
| 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.
--
@@ -172,10 +58,6 @@ data Value
--
| ArrayLiteral [Value]
-- |
- -- An array indexing expression
- --
- | Indexer Value Value
- -- |
-- An object literal
--
| ObjectLiteral [(String, Value)]
diff --git a/tests/Main.hs b/tests/Main.hs
index 1897c99..0193fa7 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -66,7 +66,7 @@ assertCompiles :: FilePath -> IO ()
assertCompiles inputFile = do
putStrLn $ "assert " ++ inputFile ++ " compiles successfully"
prelude <- preludeFilename
- assert (P.defaultOptions { P.optionsRunMain = True }) [prelude, inputFile] $ either (return . Just) $ \js -> do
+ assert (P.defaultOptions { P.optionsRunMain = True, P.optionsNoOptimizations = True }) [prelude, inputFile] $ either (return . Just) $ \js -> do
args <- getArgs
if "--run-js" `elem` args
then do