purescript · kozak · Feb 6, 2020 · Feb 6, 2020 · Feb 6, 2020 · Feb 6, 2020
diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml
@@ -2,9 +2,9 @@ name: "CI"
 
 on:
   push:
-    branches: [ "master" ]
+    branches: ["master", "restaumatic"]
   pull_request:
-    branches: [ "master" ]
+    branches: ["master", "restaumatic"]
     paths:
       - .github/workflows/**/*.yml
       - app/**/*
@@ -24,7 +24,7 @@ on:
       - update-changelog.hs
       - weeder.dhall
   release:
-    types: [ "published" ]
+    types: ["published"]
 
 defaults:
   run:

diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs
@@ -73,7 +73,7 @@ compile PSCMakeOptions{..} = do
     let filePathMap = M.fromList $ map (\(fp, pm) -> (P.getModuleName $ CST.resPartial pm, Right fp)) ms
     foreigns <- inferForeignModules filePathMap
     let makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix
-    P.make makeActions (map snd ms)
+    P.make_ makeActions (map snd ms)
   printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors moduleFiles makeWarnings makeErrors
   exitSuccess
 

diff --git a/app/static/index.js b/app/static/index.js
@@ -0,0 +1,74 @@
+var get = function get(uri, callback, onError) {
+    var request = new XMLHttpRequest();
+    request.addEventListener('load', function() {
+        callback(request.responseText);
+    });
+    request.addEventListener('error', onError);
+    request.open('GET', uri);
+    request.send();
+};
+var evaluate = function evaluate(js) {
+    var buffer = [];
+    // Save the old console.log function
+    var oldLog = console.log;
+    console.log = function(s) {
+        // Push log output into a temporary buffer
+        // which will be returned to PSCi.
+        buffer.push(s);
+    };
+    // Replace any require and import statements with lookups on the PSCI object
+    // and export statements with assignments to module.exports.
+    var replaced = js.replace(/require\("[^"]*"\)/g, function(s) {
+        return "PSCI['" + s.split('/')[1] + "']";
+    }).replace(/import \* as ([^\s]+) from "([^"]*)"/g, function (_, as, from) {
+        return "var " + as + " = PSCI['" + from.split('/')[1] + "']";
+    }).replace(/export \{([^}]+)\} from "\.\/foreign\.js";?/g, function (_, exports) {
+        return exports.replace(/^\s*([^,\s]+),?\s*$/gm, function (_, exported) {
+            return "module.exports." + exported + " = $foreign." + exported + ";";
+        });
+    }).replace(/export \{([^}]+)\};?/g, function (_, exports) {
+        return exports.replace(/^\s*([^,\s]+)(?: as ([^\s]+))?,?\s*$/gm, function (_, exported, as) {
+            return "module.exports." + (as || exported) + " = " + exported + ";";
+        });
+    });
+    // Wrap the module and evaluate it.
+    var wrapped =
+      [ 'var module = { exports: {} };'
+      , '(function(module) {'
+      , replaced
+      , '})(module);'
+      , 'return module.exports["$main"] && module.exports["$main"]();'
+    ].join('\n');
+    new Function(wrapped)();
+    // Restore console.log
+    console.log = oldLog;
+    return buffer.join('\n');
+};
+window.onload = function() {
+    var socket = new WebSocket('ws://localhost:' + location.port);
+    var evalNext = function reload() {
+        get('js/latest.js', function(response) {
+            try {
+                var result = evaluate(response);
+                socket.send(result);
+            } catch (ex) {
+                socket.send(ex.stack);
+            }
+        }, function(err) {
+            socket.send('Error sending JavaScript');
+        });
+    };
+    socket.onopen = function() {
+        console.log('Connected');
+        socket.onmessage = function(event) {
+            switch (event.data) {
+                case 'eval':
+                    evalNext();
+                    break;
+                case 'reload':
+                    location.reload();
+                    break;
+            }
+        };
+    };
+};
diff --git a/hie.yaml b/hie.yaml
@@ -0,0 +1,2 @@
+cradle:
+  stack: {}
diff --git a/purescript.cabal b/purescript.cabal
@@ -167,6 +167,8 @@ common defaults
     cheapskate >=0.1.1.2 && <0.2,
     clock >=0.8.3 && <0.9,
     containers >=0.6.5.1 && <0.7,
+    -- unordered-containers,
+    -- hashable,
     cryptonite ==0.30.*,
     data-ordlist >=0.4.7.0 && <0.5,
     deepseq >=1.4.6.1 && <1.5,
@@ -336,6 +338,7 @@ library
     Language.PureScript.Make.Actions
     Language.PureScript.Make.BuildPlan
     Language.PureScript.Make.Cache
+    Language.PureScript.Make.ExternsDiff
     Language.PureScript.Make.Monad
     Language.PureScript.ModuleDependencies
     Language.PureScript.Names
@@ -353,6 +356,7 @@ library
     Language.PureScript.Renamer
     Language.PureScript.Roles
     Language.PureScript.Sugar
+    Language.PureScript.Sugar.Accessor
     Language.PureScript.Sugar.AdoNotation
     Language.PureScript.Sugar.BindingGroups
     Language.PureScript.Sugar.CaseDeclarations

diff --git a/src/Control/Monad/Supply.hs b/src/Control/Monad/Supply.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE UndecidableInstances #-}
 -- |
 -- Fresh variable supply
 --
@@ -9,21 +10,29 @@ import Control.Applicative (Alternative)
 import Control.Monad.Error.Class (MonadError(..))
 import Control.Monad.Reader (MonadReader, MonadTrans)
 import Control.Monad (MonadPlus)
-import Control.Monad.State (StateT(..))
+import Control.Monad.State (MonadState(..))
+import Control.Monad.State.Strict (StateT(..))
 import Control.Monad.Writer (MonadWriter)
+import Data.Int (Int64)
 
 import Data.Functor.Identity (Identity(..))
+import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.Trans (lift)
 
-newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a }
-  deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r, Alternative, MonadPlus)
+newtype SupplyT m a = SupplyT { unSupplyT :: StateT Int64 m a }
+  deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r, Alternative, MonadPlus, MonadIO)
 
-runSupplyT :: Integer -> SupplyT m a -> m (a, Integer)
+runSupplyT :: Int64 -> SupplyT m a -> m (a, Int64)
 runSupplyT n = flip runStateT n . unSupplyT
 
-evalSupplyT :: (Functor m) => Integer -> SupplyT m a -> m a
+evalSupplyT :: (Functor m) => Int64 -> SupplyT m a -> m a
 evalSupplyT n = fmap fst . runSupplyT n
 
 type Supply = SupplyT Identity
 
-runSupply :: Integer -> Supply a -> (a, Integer)
+runSupply :: Int64 -> Supply a -> (a, Int64)
 runSupply n = runIdentity . runSupplyT n
+
+instance MonadState s m => MonadState s (SupplyT m) where
+  get = lift get
+  put = lift . put
diff --git a/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs
@@ -13,25 +13,33 @@ import Control.Monad.State (StateT)
 import Control.Monad.Supply (SupplyT(..))
 import Control.Monad.Writer (WriterT)
 import Data.Text (Text, pack)
+import Data.Int (Int64)
 
 class Monad m => MonadSupply m where
-  fresh :: m Integer
-  peek :: m Integer
-  default fresh :: (MonadTrans t, MonadSupply n, m ~ t n) => m Integer
+  fresh :: m Int64
+  peek :: m Int64
+  consumeUpTo :: Int64 -> m ()
+  default fresh :: (MonadTrans t, MonadSupply n, m ~ t n) => m Int64
   fresh = lift fresh
-  default peek :: (MonadTrans t, MonadSupply n, m ~ t n) => m Integer
+  default peek :: (MonadTrans t, MonadSupply n, m ~ t n) => m Int64
   peek = lift peek
+  default consumeUpTo :: (MonadTrans t, MonadSupply n, m ~ t n) => Int64 -> m ()
+  consumeUpTo n = lift (consumeUpTo n)
 
 instance Monad m => MonadSupply (SupplyT m) where
   fresh = SupplyT $ do
     n <- get
     put (n + 1)
     return n
   peek = SupplyT get
+  consumeUpTo n = SupplyT $ do
+    m <- get
+    put $ max n m
 
 instance MonadSupply m => MonadSupply (StateT s m)
 instance (Monoid w, MonadSupply m) => MonadSupply (WriterT w m)
 instance (Monoid w, MonadSupply m) => MonadSupply (RWST r w s m)
 
 freshName :: MonadSupply m => m Text
 freshName = fmap (("$" <> ) . pack . show) fresh
+
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
@@ -165,7 +165,7 @@ importPrim =
       . addDefaultImport (Qualified ByNullSourcePos primModName)
 
 data NameSource = UserNamed | CompilerNamed
-  deriving (Show, Generic, NFData, Serialise)
+  deriving (Eq, Show, Generic, NFData, Serialise)
 
 -- |
 -- An item in a list of explicit imports or exports

diff --git a/src/Language/PureScript/AST/Declarations/ChainId.hs b/src/Language/PureScript/AST/Declarations/ChainId.hs
@@ -1,5 +1,5 @@
 module Language.PureScript.AST.Declarations.ChainId
-  ( ChainId
+  ( ChainId(..)
   , mkChainId
   ) where
 

diff --git a/src/Language/PureScript/Constants/Libs.hs b/src/Language/PureScript/Constants/Libs.hs
@@ -1,13 +1,15 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE TemplateHaskell #-}
+
 -- | Various constants which refer to things in the Prelude and other core libraries
 module Language.PureScript.Constants.Libs where
 
 import Protolude qualified as P
 
 import Data.String (IsString)
-import Language.PureScript.PSString (PSString)
 import Language.PureScript.Constants.TH qualified as TH
+import Language.PureScript.PSString (PSString)
+import Language.PureScript.Names (Ident (..), Qualified (..), QualifiedBy (..))
 
 -- Core lib values
 
@@ -166,6 +168,7 @@ $(TH.declare do
 
   TH.mod "Data.Symbol" do
     TH.cls "IsSymbol"
+    TH.asIdent do TH.var "IsSymbol"
 
   -- purescript-arrays
 
@@ -261,4 +264,16 @@ $(TH.declare do
   TH.mod "Unsafe.Coerce" do
     TH.asPair do TH.var "unsafeCoerce"
 
+  TH.mod "Type.Proxy" do
+    TH.dty "Proxy" ["Proxy"]
+    TH.asIdent do
+      TH.var "Proxy"
+  TH.mod "Data.Record" do
+    TH.asIdent do
+      TH.var "getField"
+      TH.var "hasFieldRecord"
+
   )
+
+pattern IsSymbolDict :: Qualified Ident
+pattern IsSymbolDict = Qualified (ByModuleName M_Data_Symbol) (Ident "IsSymbol$Dict")
diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs
@@ -9,7 +9,8 @@ import Language.PureScript.CoreFn.Expr (Bind, Expr(..))
 import Language.PureScript.CoreFn.Module (Module(..))
 import Language.PureScript.CoreFn.Traversals (everywhereOnValues)
 import Language.PureScript.Constants.Libs qualified as C
-
+-- import Language.PureScript.CoreImp.AST (AST(StringLiteral, ObjectLiteral))
+import Language.PureScript.AST.Literals (Literal(..))
 -- |
 -- CoreFn optimization pass.
 --
@@ -22,6 +23,32 @@ optimizeModuleDecls = map transformBinds
   (transformBinds, _, _) = everywhereOnValues identity transformExprs identity
   transformExprs
     = optimizeDataFunctionApply
+    . optimizeRecordGetField
+
+-- | Optimize
+-- `Data_Record.getField(Data_Record.hasFieldRecord(new Data_Symbol.IsSymbol(function() { return "f"; }))())(Type_Proxy.Proxy.value)(x)`
+-- into
+-- `x.f`
+optimizeRecordGetField :: Expr a -> Expr a
+optimizeRecordGetField
+  (App ann
+    (App _
+      (App _
+        (Var _ C.I_getField)
+        (App _
+          (App _
+            (Var _ C.I_hasFieldRecord)
+            (App _
+              (Var _ C.IsSymbolDict)
+              (Literal _ (ObjectLiteral
+                [ ("reflectSymbol", Abs _ _
+                    (Literal _ (StringLiteral label)))
+                ]))))
+          _))
+      (Var _ C.I_Proxy))
+    object) =
+  Accessor ann label object
+optimizeRecordGetField e = e
 
 optimizeDataFunctionApply :: Expr a -> Expr a
 optimizeDataFunctionApply e = case e of

diff --git a/src/Language/PureScript/CoreImp/AST.hs b/src/Language/PureScript/CoreImp/AST.hs
@@ -108,6 +108,10 @@ data AST
   -- ^ instanceof check
   | Comment CIComments AST
   -- ^ Commented JavaScript
+  -- | Import (Maybe SourceSpan) Text PSString
+  -- -- ^ Imported identifier and path to its module
+  -- | Export (Maybe SourceSpan) (NEL.NonEmpty Text) (Maybe PSString)
+  -- -- ^ Exported identifiers and optional path to their module (for re-exports)
   deriving (Show, Eq)
 
 withSourceSpan :: SourceSpan -> AST -> AST
@@ -140,6 +144,8 @@ withSourceSpan withSpan = go where
   go (Throw _ js) = Throw ss js
   go (InstanceOf _ j1 j2) = InstanceOf ss j1 j2
   go c@Comment{} = c
+  -- go (Import _ ident from)           = Import ss ident from
+  -- go (Export _ idents from)          = Export ss idents from
 
 getSourceSpan :: AST -> Maybe SourceSpan
 getSourceSpan = go where
@@ -168,6 +174,8 @@ getSourceSpan = go where
   go (Throw ss _) = ss
   go (InstanceOf ss _ _) = ss
   go (Comment _ _) = Nothing
+  -- go (Import ss _ _)               = ss
+  -- go (Export ss _ _)               = ss
 
 everywhere :: (AST -> AST) -> AST -> AST
 everywhere f = go where

diff --git a/src/Language/PureScript/Docs/Collect.hs b/src/Language/PureScript/Docs/Collect.hs
@@ -96,7 +96,7 @@ compileForDocs outputDir inputFiles = do
       foreigns <- P.inferForeignModules filePathMap
       let makeActions =
             (P.buildMakeActions outputDir filePathMap foreigns False)
-              { P.progress = liftIO . TIO.hPutStr stdout . (<> "\n") . P.renderProgressMessage "Compiling documentation for "
+              { P.progress = liftIO . TIO.hPutStr stdout . (<> "\n") . P.renderProgressMessage "documentation for "
               }
       P.make makeActions (map snd ms)
   either throwError return result

diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
@@ -82,7 +82,7 @@ data FunctionalDependency = FunctionalDependency
   -- ^ the type arguments which determine the determined type arguments
   , fdDetermined  :: [Int]
   -- ^ the determined type arguments
-  } deriving (Show, Generic)
+  } deriving (Eq, Show, Generic)
 
 instance NFData FunctionalDependency
 instance Serialise FunctionalDependency

diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
@@ -28,7 +28,7 @@ import Data.List (transpose, nubBy, partition, dropWhileEnd, sortOn, uncons)
 import Data.List.NonEmpty qualified as NEL
 import Data.List.NonEmpty (NonEmpty((:|)))
 import Data.Maybe (maybeToList, fromMaybe, isJust, mapMaybe)
-import Data.Map qualified as M
+import Data.IntMap.Strict qualified as M
 import Data.Ord (Down(..))
 import Data.Set qualified as S
 import Data.Text qualified as T
@@ -418,9 +418,9 @@ addHints hints = onErrorMessages $ \(ErrorMessage hints' se) -> ErrorMessage (hi
 
 -- | A map from rigid type variable name/unknown variable pairs to new variables.
 data TypeMap = TypeMap
-  { umSkolemMap   :: M.Map Int (String, Int, Maybe SourceSpan)
+  { umSkolemMap   :: M.IntMap (String, Int, Maybe SourceSpan)
   -- ^ a map from skolems to their new names, including source and naming info
-  , umUnknownMap  :: M.Map Int Int
+  , umUnknownMap  :: M.IntMap Int
   -- ^ a map from unification variables to their new names
   , umNextIndex   :: Int
   -- ^ unknowns and skolems share a source of names during renaming, to