Merge branch 'master' into patch-2

Author: razzeee

builder/src/Build.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE BangPatterns, OverloadedStrings #-}
 module Elm.Details
   ( Details(..)
+  , BuildID
   , ValidOutline(..)
   , Local(..)
   , Foreign(..)
@@ -15,7 +16,7 @@ module Elm.Details
 
 import Control.Concurrent (forkIO)
 import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar)
-import Control.Monad (liftM, liftM2, liftM3, liftM4)
+import Control.Monad (liftM, liftM2, liftM3)
 import Data.Binary (Binary, get, put, getWord8, putWord8)
 import qualified Data.Either as Either
 import qualified Data.Map as Map
@@ -27,6 +28,7 @@ import qualified Data.NonEmptyList as NE
 import qualified Data.OneOrMore as OneOrMore
 import qualified Data.Set as Set
 import qualified Data.Utf8 as Utf8
+import Data.Word (Word64)
 import qualified System.Directory as Dir
 import System.FilePath ((</>), (<.>))
 
@@ -66,23 +68,42 @@ data Details =
   Details
     { _outlineTime :: File.Time
     , _outline :: ValidOutline
+    , _buildID :: BuildID
     , _locals :: Map.Map ModuleName.Raw Local
     , _foreigns :: Map.Map ModuleName.Raw Foreign
     , _extras :: Extras
     }
 
 
+type BuildID = Word64
+
+
 data ValidOutline
   = ValidApp (NE.List FilePath)
   | ValidPkg Pkg.Name [ModuleName.Raw] (Map.Map Pkg.Name V.Version {- for docs in reactor -})
 
 
+-- NOTE: we need two ways to detect if a file must be recompiled:
+--
+-- (1) _time is the modification time from the last time we compiled the file.
+-- By checking EQUALITY with the current modification time, we can detect file
+-- saves and `git checkout` of previous versions. Both need a recompile.
+--
+-- (2) _lastChange is the BuildID from the last time a new interface file was
+-- generated, and _lastCompile is the BuildID from the last time the file was
+-- compiled. These may be different if a file is recompiled but the interface
+-- stayed the same. When the _lastCompile is LESS THAN the _lastChange of any
+-- imports, we need to recompile. This can happen when a project has multiple
+-- entrypoints and some modules are compiled less often than their imports.
+--
 data Local =
   Local
     { _path :: FilePath
     , _time :: File.Time
     , _deps :: [ModuleName.Raw]
     , _main :: Bool
+    , _lastChange :: BuildID
+    , _lastCompile :: BuildID
     }
 
 
@@ -104,14 +125,14 @@ type Interfaces =
 
 
 loadObjects :: FilePath -> Details -> IO (MVar (Maybe Opt.GlobalGraph))
-loadObjects root (Details _ _ _ _ extras) =
+loadObjects root (Details _ _ _ _ _ extras) =
   case extras of
     ArtifactsFresh _ o -> newMVar (Just o)
     ArtifactsCached    -> fork (File.readBinary (Stuff.objects root))
 
 
 loadInterfaces :: FilePath -> Details -> IO (MVar (Maybe Interfaces))
-loadInterfaces root (Details _ _ _ _ extras) =
+loadInterfaces root (Details _ _ _ _ _ extras) =
   case extras of
     ArtifactsFresh i _ -> newMVar (Just i)
     ArtifactsCached    -> fork (File.readBinary (Stuff.interfaces root))
@@ -143,9 +164,9 @@ load style scope root =
         Nothing ->
           generate style scope root newTime
 
-        Just details@(Details oldTime _ _ _ _) ->
+        Just details@(Details oldTime _ buildID _ _ _) ->
           if oldTime == newTime
-          then return (Right details)
+          then return (Right details { _buildID = buildID + 1 })
           else generate style scope root newTime
 
 
@@ -309,8 +330,8 @@ verifyDependencies env@(Env key scope root cache _ _ _) time outline solution di
           let
             objs = Map.foldr addObjects Opt.empty artifacts
             ifaces = Map.foldrWithKey (addInterfaces directDeps) Map.empty artifacts
-            foreigns = Map.map (OneOrMore.destruct Foreign) $ Map.foldrWithKey gatherForeigns Map.empty artifacts
-            details = Details time outline Map.empty foreigns (ArtifactsFresh ifaces objs)
+            foreigns = Map.map (OneOrMore.destruct Foreign) $ Map.foldrWithKey gatherForeigns Map.empty $ Map.intersection artifacts directDeps
+            details = Details time outline 0 Map.empty foreigns (ArtifactsFresh ifaces objs)
           in
           do  BW.writeBinary scope (Stuff.objects    root) objs
               BW.writeBinary scope (Stuff.interfaces root) ifaces
@@ -574,7 +595,7 @@ crawlModule foreignDeps mvar pkg src docsStatus name =
 crawlFile :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> DocsStatus -> ModuleName.Raw -> FilePath -> IO (Maybe Status)
 crawlFile foreignDeps mvar pkg src docsStatus expectedName path =
   do  bytes <- File.readUtf8 path
-      case Parse.fromByteString pkg bytes of
+      case Parse.fromByteString (Parse.Package pkg) bytes of
         Right modul@(Src.Module (Just (A.At _ actualName)) _ _ imports _ _ _ _ _) | expectedName == actualName ->
           do  deps <- crawlImports foreignDeps mvar pkg src imports
               return (Just (SLocal docsStatus deps modul))
@@ -761,8 +782,14 @@ endpointDecoder =
 
 
 instance Binary Details where
-  get = do { a <- get; b <- get; c <- get; d <- get; return (Details a b c d ArtifactsCached) }
-  put (Details a b c d _) = put a >> put b >> put c >> put d
+  put (Details a b c d e _) = put a >> put b >> put c >> put d >> put e
+  get =
+    do  a <- get
+        b <- get
+        c <- get
+        d <- get
+        e <- get
+        return (Details a b c d e ArtifactsCached)
 
 
 instance Binary ValidOutline where
@@ -780,8 +807,15 @@ instance Binary ValidOutline where
 
 
 instance Binary Local where
-  get = liftM4 Local get get get get
-  put (Local a b c d) = put a >> put b >> put c >> put d
+  put (Local a b c d e f) = put a >> put b >> put c >> put d >> put e >> put f
+  get =
+    do  a <- get
+        b <- get
+        c <- get
+        d <- get
+        e <- get
+        f <- get
+        return (Local a b c d e f)
 
 
 instance Binary Foreign where

builder/src/Elm/Details.hs

@@ -190,7 +190,11 @@ writeEntry destination root entry =
   let
     path = drop root (Zip.eRelativePath entry)
   in
-  if path == "LICENSE" || List.isPrefixOf "src/" path then
+  if List.isPrefixOf "src/" path
+    || path == "LICENSE"
+    || path == "README.md"
+    || path == "elm.json"
+  then
       if not (null path) && last path == '/'
       then Dir.createDirectoryIfMissing True (destination </> path)
       else LBS.writeFile (destination </> path) (Zip.fromEntry entry)

builder/src/File.hs

@@ -31,9 +31,6 @@ module Reporting.Exit
 
 
 import qualified Data.ByteString as BS
-import qualified Data.ByteString.Builder as B
-import qualified Data.ByteString.Char8 as BSC
-import qualified Data.ByteString.Lazy as LBS
 import qualified Data.ByteString.UTF8 as BS_UTF8
 import qualified Data.List as List
 import qualified Data.Map as Map
@@ -178,7 +175,7 @@ diffToReport diff =
         \ with packages. That way there are previously published versions of the API to\
         \ diff against!"
         [ D.reflow $ "If you are just curious to see a diff, try running this command:"
-        , D.indent 4 $ D.dullyellow $ "elm diff elm/http 1.0.0 2.0.0"
+        , D.indent 4 $ D.dullyellow $ "elm diff elm/json 1.0.0 1.1.2"
         ]
 
     DiffNoExposed ->
@@ -751,7 +748,7 @@ data Install
   | InstallHadSolverTrouble Solver
   | InstallUnknownPackageOnline Pkg.Name [Pkg.Name]
   | InstallUnknownPackageOffline Pkg.Name [Pkg.Name]
-  | InstallHasBadDetails Pkg.Name Encode.Value
+  | InstallBadDetails Details
 
 
 installToReport :: Install -> Help.Report
@@ -895,20 +892,8 @@ installToReport exit =
         , D.reflow $ "Maybe you want one of these instead?"
         ]
 
-    InstallHasBadDetails pkg outline ->
-      Help.report "INSTALL PROBLEM" Nothing
-        (
-          "I found a version of " ++ Pkg.toChars pkg ++ " that claims to be compatible with\
-          \ your existing dependencies, but I ran into an error when I tried to build it locally."
-        )
-        [ D.reflow $
-            "Here is an elm.json that should reproduce the error with a bit more information:"
-        , D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromChars $
-            map BS_UTF8.toString $ BSC.lines $ LBS.toStrict $ B.toLazyByteString $
-              Encode.encode outline
-        , D.reflow $
-            "Maybe that can help figure out what is going on here."
-        ]
+    InstallBadDetails details ->
+      toDetailsReport details
 
 
 
@@ -1168,10 +1153,16 @@ toOutlineProblemReport path source _ region problem =
       toSnippet "HEADER TOO LONG" Nothing
         ( D.reflow $
             "I got stuck while reading your elm.json file. This section header is too long:"
-        , D.fillSep
-            ["I","need","it","to","be"
-            ,D.green "under",D.green "20",D.green "characters"
-            ,"so","it","renders","nicely","on","the","package","website!"
+        , D.stack
+            [ D.fillSep
+                ["I","need","it","to","be"
+                ,D.green "under",D.green "20",D.green "bytes"
+                ,"so","it","renders","nicely","on","the","package","website!"
+                ]
+            , D.toSimpleNote
+                "I count the length in bytes, so using non-ASCII characters costs extra.\
+                \ Please report your case at https://github.com/elm/compiler/issues if this seems\
+                \ overly restrictive for your needs."
             ]
         )
 
@@ -1216,10 +1207,16 @@ toOutlineProblemReport path source _ region problem =
       toSnippet "SUMMARY TOO LONG" Nothing
         ( D.reflow $
             "I got stuck while reading your elm.json file. Your \"summary\" is too long:"
-        , D.fillSep
-            ["I","need","it","to","be"
-            ,D.green "under",D.green "80",D.green "characters"
-            ,"so","it","renders","nicely","on","the","package","website!"
+        , D.stack
+            [ D.fillSep
+                ["I","need","it","to","be"
+                ,D.green "under",D.green "80",D.green "bytes"
+                ,"so","it","renders","nicely","on","the","package","website!"
+                ]
+            , D.toSimpleNote
+                "I count the length in bytes, so using non-ASCII characters costs extra.\
+                \ Please report your case at https://github.com/elm/compiler/issues if this seems\
+                \ overly restrictive for your needs."
             ]
         )
 
@@ -1334,7 +1331,7 @@ toDetailsReport details =
         "I need the list of published packages to verify your dependencies"
 
     DetailsBadDeps cacheDir deps ->
-      case deps of
+      case List.sortOn toBadDepRank deps of
         [] ->
           Help.report "PROBLEM BUILDING DEPENDENCIES" Nothing
             "I am not sure what is going wrong though."
@@ -1374,6 +1371,13 @@ toDetailsReport details =
                 ]
 
 
+toBadDepRank :: DetailsBadDep -> Int -- lower is better
+toBadDepRank badDep =
+  case badDep of
+    BD_BadDownload _ _ _ -> 0
+    BD_BadBuild _ _ _ -> 1
+
+
 
 -- PACKAGE PROBLEM
 

builder/src/Reporting/Exit.hs

@@ -62,7 +62,7 @@ prepublishDir root =
 
 compilerVersion :: FilePath
 compilerVersion =
-  V.toChars V.compiler ++ "-alpha-1"
+  V.toChars V.compiler ++ "-alpha-4"
 
 
 

builder/src/Stuff.hs

@@ -74,9 +74,11 @@ escape chars =
       []
 
     c:cs
+      | c == '\r' -> escape cs
       | c == '\n' -> '\\' : 'n'  : escape cs
       | c == '\"' -> '\\' : '"'  : escape cs
       | c == '\'' -> '\\' : '\'' : escape cs
+      | c == '\\' -> '\\' : '\\' : escape cs
       | otherwise -> c : escape cs
 
 

compiler/src/AST/Utils/Shader.hs

@@ -288,42 +288,51 @@ fromTypeVariableScheme scheme =
 
 
 -- FROM MANY NAMES
+--
+-- Creating a unique name by combining all the subnames can create names
+-- longer than 256 bytes relatively easily. So instead, the first given name
+-- (e.g. foo) is prefixed chars that are valid in JS but not Elm (e.g. _M$foo)
+--
+-- This should be a unique name since 0.19 disallows shadowing. It would not
+-- be possible for multiple top-level cycles to include values with the same
+-- name, so the important thing is to make the cycle name distinct from the
+-- normal name. Same logic for destructuring patterns like (x,y)
 
 
 fromManyNames :: [Name] -> Name
 fromManyNames names =
-  let
-    !(I# size#) = sum (map (\(Utf8.Utf8 ba#) -> I# (sizeofByteArray# ba# +# 1#)) names)
-  in
-  runST
-  (
-    ST $ \s ->
-      case newByteArray# size# s of
-        (# s, mba# #) ->
-          case writeNames mba# 0# names s of
-            s ->
-              case unsafeFreezeByteArray# mba# s of
-                (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
-  )
-
-
-writeNames :: MutableByteArray# s -> Int# -> [Name] -> State# s -> State# s
-writeNames mba# !offset# names s =
   case names of
     [] ->
-      s
-
-    (Utf8.Utf8 ba#) : names ->
-      case writeWord8Array# mba# offset# 0x24## {- $ -} s of
-        s ->
-          let
-            !offset1# = offset# +# 1#
-            !len# = sizeofByteArray# ba#
-            !newOffset# = offset1# +# len#
-          in
-          case copyByteArray# ba# 0# mba# offset1# len# s of
-            s ->
-              writeNames mba# newOffset# names s
+      blank
+      -- this case is needed for (let _ = Debug.log "x" x in ...)
+      -- but maybe unused patterns should be stripped out instead
+
+    Utf8.Utf8 ba# : _ ->
+      let
+        len# = sizeofByteArray# ba#
+      in
+      runST
+      (
+        ST $ \s ->
+          case newByteArray# (len# +# 3#) s of
+            (# s, mba# #) ->
+              case writeWord8Array# mba# 0# 0x5F## {-_-} s of
+                s ->
+                  case writeWord8Array# mba# 1# 0x4D## {-M-} s of
+                    s ->
+                      case writeWord8Array# mba# 2# 0x24## {-$-} s of
+                        s ->
+                          case copyByteArray# ba# 0# mba# 3# len# s of
+                            s ->
+                              case unsafeFreezeByteArray# mba# s of
+                                (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
+      )
+
+
+{-# NOINLINE blank #-}
+blank :: Name
+blank =
+  fromWords [0x5F,0x4D,0x24] {-_M$-}