purescript 0.3.7 → 0.3.8.1

raw patch · 29 files changed

+795/−651 lines, 29 files

Files

• libraries/prelude/prelude.purs +312/−34
• psc/Main.hs +5/−1
• psci/Main.hs +1/−1
• purescript.cabal +2/−1
• src/Language/PureScript.hs +1/−1
• src/Language/PureScript/CodeGen/Common.hs +56/−0
• src/Language/PureScript/CodeGen/JS.hs +48/−47
• src/Language/PureScript/CodeGen/JS/AST.hs +109/−21
• src/Language/PureScript/CodeGen/Monad.hs +3/−3
• src/Language/PureScript/CodeGen/Optimize.hs +115/−39
• src/Language/PureScript/Kinds.hs +2/−2
• src/Language/PureScript/Options.hs +5/−1
• src/Language/PureScript/Parser/Common.hs +3/−16
• src/Language/PureScript/Parser/JS.hs +7/−13
• src/Language/PureScript/Parser/Values.hs +1/−5
• src/Language/PureScript/Pretty/Common.hs +0/−48
• src/Language/PureScript/Pretty/JS.hs +9/−14
• src/Language/PureScript/Pretty/Kinds.hs +1/−1
• src/Language/PureScript/Pretty/Types.hs +2/−2
• src/Language/PureScript/Pretty/Values.hs +0/−49
• src/Language/PureScript/Scope.hs +5/−5
• src/Language/PureScript/Sugar/Operators.hs +1/−25
• src/Language/PureScript/Sugar/TypeClasses.hs +2/−2
• src/Language/PureScript/TypeChecker/Kinds.hs +28/−22
• src/Language/PureScript/TypeChecker/Monad.hs +4/−4
• src/Language/PureScript/TypeChecker/Types.hs +71/−174
• src/Language/PureScript/Types.hs +1/−1
• src/Language/PureScript/Values.hs +0/−118
• tests/Main.hs +1/−1

@@ -6,29 +6,33 @@   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 @@     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 @@   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 @@    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 @@    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 @@    empty :: forall a. [a] -> Boolean   empty [] = true-  empty _ = false +  empty _ = false    range :: Number -> Number -> [Number]   range lo hi = {@@ -223,6 +507,7 @@  module Tuple where +  import Prelude   import Arrays    type Tuple a b = { fst :: a, snd :: b }@@ -234,7 +519,7 @@   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 @@                              \  };\                              \}" :: 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 @@    foreign import decodeURI :: String -> String -  instance Prelude.Show Number where-    show = numberToString+  foreign import isNaN :: Number -> Boolean  module Math where @@ -493,7 +771,7 @@                          \      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 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 @@    import Prelude   import Eff-  +   foreign import data Trace :: !-  +   foreign import trace "function trace(s) { \                        \  return function() { \                        \    console.log(s); \@@ -593,7 +871,7 @@                        \}" :: 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 @@                             \    };\                             \  };\                             \}" :: 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

@@ -90,8 +90,12 @@ 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

@@ -35,7 +35,7 @@ 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

@@ -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 @@                      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

@@ -65,6 +65,6 @@               _ | 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)

@@ -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)

@@ -41,6 +41,7 @@ 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,79 +49,77 @@ -- 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 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 @@   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 @@   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 @@       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 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 @@     )) 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 @@   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

@@ -17,12 +17,113 @@  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 -- data JS@@ -65,7 +166,7 @@   -- |   -- A function introduction (optional name, arguments, body)   ---  | JSFunction (Maybe Ident) [Ident] JS+  | JSFunction (Maybe String) [String] JS   -- |   -- Function application   --@@ -73,7 +174,7 @@   -- |   -- Variable   ---  | JSVar Ident+  | JSVar String   -- |   -- Conditional expression   --@@ -85,11 +186,11 @@   -- |   -- 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 @@   -- |   -- For loop   ---  | JSFor Ident JS JS JS+  | JSFor String JS JS JS   -- |   -- If-then-else statement   --@@ -130,16 +231,3 @@   -- 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)

@@ -26,18 +26,18 @@ -- | -- 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

@@ -27,8 +27,10 @@ -- --  * Inlining variables -----  * Inline Prelude.($)+--  * Inline Prelude.($), Prelude.(#), Prelude.(++), Prelude.(!!) --+--  * Inlining primitive Javascript operators+-- -----------------------------------------------------------------------------  module Language.PureScript.CodeGen.Optimize (@@ -42,16 +44,17 @@ 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 @@   , 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 @@   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 @@   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 @@   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 @@   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 @@               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 @@   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 @@     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 @@         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' :: 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 @@     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 @@   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

@@ -18,7 +18,7 @@  import Data.Data -import Control.Monad.Unify (TypedUnknown(..))+import Control.Monad.Unify (Unknown)  -- | -- The data type of kinds@@ -27,7 +27,7 @@   -- |   -- Unification variable of type Kind   ---  = KUnknown (TypedUnknown Kind)+  = KUnknown Unknown   -- |   -- The kind of types   --

@@ -35,10 +35,14 @@     -- 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

@@ -83,17 +83,10 @@                 , "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 @@                   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 @@ -- 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

@@ -52,8 +52,8 @@ 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 = 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 @@             , parseBlock             , P.try parseVar             , parseVariableIntroduction-            , P.try parseAssignment             , parseWhile             , parseIf             , parseReturn@@ -110,7 +109,7 @@    $ 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 @@               , [ 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 @@ 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,16 +147,12 @@     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)

@@ -155,11 +155,7 @@   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 ]               ] 

@@ -13,55 +13,7 @@ -- ----------------------------------------------------------------------------- -{-# 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

@@ -89,14 +89,14 @@     , 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 @@     , 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 @@   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 @@   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 @@                   , [ 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 @@                   , [ binary    Multiply             "*" ]                   , [ binary    Divide               "/" ]                   , [ binary    Modulus              "%" ]-                  , [ binary    Concat               "+" ]                   , [ binary    Add                  "+" ]                   , [ binary    Subtract             "-" ]                   , [ binary    ShiftLeft            "<<" ]

@@ -31,7 +31,7 @@   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)

@@ -35,7 +35,7 @@   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 @@   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"

@@ -62,12 +62,6 @@   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 @@   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 @@                   , [ 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

@@ -44,11 +44,11 @@   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 _ = []  -- |

@@ -60,7 +60,7 @@   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@@ -110,28 +110,4 @@  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)-           ] 

@@ -34,7 +34,7 @@ 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 @@ 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" 

@@ -38,37 +38,43 @@  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 @@           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 @@ -- | -- 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 @@   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 (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"

@@ -210,7 +210,7 @@ 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 @@ -- | -- 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 @@     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

@@ -67,22 +67,24 @@ 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 @@     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 @@ -- 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 @@     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 @@ -- 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 @@           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 @@     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 @@ -- | -- 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 @@       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 @@ -- | -- 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 @@ -- | -- 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 @@ -- | -- 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 @@   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 @@   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 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 _ _ = 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 @@   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 (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 @@ -- | -- 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 @@ -- | -- 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 @@ -- 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 @@   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 @@ -- | -- 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 @@ -- | -- 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 @@ -- | -- 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 @@ -- | -- 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 @@ -- | -- 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 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 @@   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 @@   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 @@ -- -- 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 @@   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 @@       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 @@ -- | -- 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 @@ -- | -- 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 @@     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 @@ -- | -- 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 @@ -- | -- 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 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' 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 

@@ -31,7 +31,7 @@   -- |   -- A unification variable of type Type   ---  = TUnknown (TypedUnknown Type)+  = TUnknown Unknown   -- |   -- Javascript numbers   --

@@ -28,112 +28,6 @@ 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 @@   --   | 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.   --@@ -171,10 +57,6 @@   -- An array literal   --   | ArrayLiteral [Value]-  -- |-  -- An array indexing expression-  ---  | Indexer Value Value   -- |   -- An object literal   --

@@ -66,7 +66,7 @@ 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