Merge remote-tracking branch 'origin/trunk' into pg/name-lookups-hasql

.github/workflows/ci.yaml

@@ -20,6 +20,10 @@ jobs:
 
   ormolu:
     runs-on: ubuntu-20.04
+    # Only run formatting on trunk commits
+    # This is because the job won't have permission to push back to
+    # contributor forks on contributor PRs.
+    if: github.ref_name == 'trunk'
     steps:
       - uses: actions/checkout@v2
       - name: Get changed files
@@ -45,6 +49,8 @@ jobs:
   build:
     name: ${{ matrix.os }}
     runs-on: ${{ matrix.os }}
+    # The 'always()' causes this to build even if the ormolu job is skipped.
+    if: ${{ always() }}
     needs: ormolu
     defaults:
       run:

parser-typechecker/src/Unison/PrintError.hs

@@ -281,7 +281,7 @@ renderTypeError e env src curPath = case e of
         debugSummary note
       ]
   FunctionApplication {..} ->
-    let fte = Type.removePureEffects ft
+    let fte = Type.removePureEffects False ft
         fteFreeVars = Set.map TypeVar.underlying $ ABT.freeVars fte
         showVar (v, _t) = Set.member v fteFreeVars
         solvedVars' = filter showVar solvedVars
@@ -1092,8 +1092,9 @@ renderType ::
   (loc -> Pretty (AnnotatedText a) -> Pretty (AnnotatedText a)) ->
   Type v loc ->
   Pretty (AnnotatedText a)
-renderType env f t = renderType0 env f (0 :: Int) (Type.removePureEffects t)
+renderType env f t = renderType0 env f (0 :: Int) (cleanup t)
   where
+    cleanup t = Type.removeEmptyEffects (Type.removePureEffects False t)
     wrap :: (IsString a, Semigroup a) => a -> a -> Bool -> a -> a
     wrap start end test s = if test then start <> s <> end else s
     paren = wrap "(" ")"

parser-typechecker/src/Unison/Syntax/DeclPrinter.hs

@@ -117,7 +117,7 @@ prettyDataDecl (PrettyPrintEnvDecl unsuffixifiedPPE suffixifiedPPE) r name dd =
       Nothing -> prettyPattern unsuffixifiedPPE CT.Data name (ConstructorReference r n)
       Just ts -> case fieldNames unsuffixifiedPPE r name dd of
         Nothing ->
-          P.group . P.hang' (prettyPattern suffixifiedPPE CT.Data name (ConstructorReference r n)) "      " $
+          P.group . P.hang' (prettyPattern unsuffixifiedPPE CT.Data name (ConstructorReference r n)) "      " $
             P.spaced (runPretty suffixifiedPPE (traverse (TypePrinter.prettyRaw Map.empty 10) (init ts)))
         Just fs ->
           P.group $
@@ -180,7 +180,11 @@ fieldNames env r name dd = do
     for accessors \(v, _a, trm) ->
       case Result.result (Typechecker.synthesize env Typechecker.PatternMatchCoverageCheckSwitch'Disabled typecheckingEnv trm) of
         Nothing -> Nothing
-        Just typ -> Just (v, trm, typ)
+        -- Note: Typechecker.synthesize doesn't normalize the output
+        -- type. We do so here using `Type.cleanup`, mirroring what's
+        -- done when typechecking a whole file and ensuring we get the
+        -- same inferred type.
+        Just typ -> Just (v, trm, Type.cleanup typ)
   let hashes = Hashing.hashTermComponents (Map.fromList . fmap (\(v, trm, typ) -> (v, (trm, typ, ()))) $ accessorsWithTypes)
   let names =
         [ (r, HQ.toString . PPE.termName env . Referent.Ref $ DerivedId r)

parser-typechecker/src/Unison/Syntax/TermPrinter.hs

@@ -1002,6 +1002,12 @@ prettyBinding0' a@AmbientContext {imports = im, docContext = doc} v term =
                     styleHashQualified'' (fmt $ S.HashQualifier v) $ elideFQN im v,
                     fmt S.Var $ PP.text (Var.name y)
                   ]
+              [x] ->
+                PP.sep
+                  " "
+                  [ renderName v,
+                    fmt S.Var $ PP.text (Var.name x)
+                  ]
               _ -> l "error"
           | null vs = renderName v
           | otherwise = renderName v `PP.hang` args vs

parser-typechecker/src/Unison/Syntax/TypePrinter.hs

@@ -28,6 +28,7 @@ import Unison.PrettyPrintEnv.FQN (Imports, elideFQN)
 import Unison.PrettyPrintEnv.MonadPretty (MonadPretty, getPPE, runPretty, willCapture)
 import Unison.Reference (Reference, pattern Builtin)
 import Unison.Referent (Referent)
+import Unison.Settings qualified as Settings
 import Unison.Syntax.NamePrinter (styleHashQualified'')
 import Unison.Type
 import Unison.Util.ColorText (toPlain)
@@ -80,7 +81,7 @@ pretty0 ::
   Int ->
   Type v a ->
   m (Pretty SyntaxText)
-pretty0 im p tp = prettyRaw im p (cleanup (removePureEffects tp))
+pretty0 im p tp = prettyRaw im p (removeEmptyEffects $ cleanup tp)
 
 prettyRaw ::
   forall v a m.
@@ -123,7 +124,7 @@ prettyRaw im p tp = go im p tp
          in -- if we're printing a type signature, and all the type variables
             -- are universally quantified, then we can omit the `forall` keyword
             -- only if the type variables are not bound in an outer scope
-            if p < 0 && all Var.universallyQuantifyIfFree vs
+            if p < 0 && not Settings.debugRevealForalls && all Var.universallyQuantifyIfFree vs
               then ifM (willCapture vs) (prettyForall p) (go im p body)
               else paren (p >= 0) <$> prettyForall (-1)
       t@(Arrow' _ _) -> case t of

parser-typechecker/src/Unison/Typechecker/Context.hs

@@ -544,6 +544,23 @@ debugShow :: (Show a) => a -> Bool
 debugShow e | debugEnabled = traceShow e False
 debugShow _ = False
 
+debugTrace :: String -> Bool
+debugTrace e | debugEnabled = trace e False
+debugTrace _ = False
+
+showType :: Var v => Type.Type v a -> String
+showType ty = TP.prettyStr (Just 120) PPE.empty ty
+
+debugType :: Var v => String -> Type.Type v a -> Bool
+debugType tag ty
+  | debugEnabled = debugTrace $ "(" <> show tag <> "," <> showType ty <> ")"
+  | otherwise = False
+
+debugTypes :: Var v => String -> Type.Type v a -> Type.Type v a -> Bool
+debugTypes tag t1 t2
+  | debugEnabled = debugTrace $ "(" <> show tag <> ",\n  " <> showType t1 <> ",\n  " <> showType t2 <> ")"
+  | otherwise = False
+
 debugPatternsEnabled :: Bool
 debugPatternsEnabled = False
 
@@ -987,6 +1004,7 @@ vectorConstructorOfArity loc arity = do
   pure vt
 
 generalizeAndUnTypeVar :: (Var v) => Type v a -> Type.Type v a
+generalizeAndUnTypeVar t | debugType "generalizeAndUnTypeVar" t = undefined
 generalizeAndUnTypeVar t =
   Type.cleanup . ABT.vmap TypeVar.underlying . Type.generalize (Set.toList $ ABT.freeVars t) $ t
 
@@ -2156,7 +2174,7 @@ defaultAbility _ = pure False
 -- Expects a fully substituted type, so that it is unnecessary to
 -- check if an existential in the type has been solved.
 discardCovariant :: (Var v) => Set v -> Type v loc -> Type v loc
-discardCovariant _ ty | debugShow ("discardCovariant" :: Text, ty) = undefined
+discardCovariant _ ty | debugType "discardCovariant" ty = undefined
 discardCovariant gens ty =
   ABT.rewriteDown (strip $ keepVarsT True ty) ty
   where
@@ -2350,7 +2368,7 @@ check m0 t0 = scope (InCheck m0 t0) $ do
 -- | `subtype ctx t1 t2` returns successfully if `t1` is a subtype of `t2`.
 -- This may have the effect of altering the context.
 subtype :: forall v loc. (Var v, Ord loc) => Type v loc -> Type v loc -> M v loc ()
-subtype tx ty | debugEnabled && traceShow ("subtype" :: String, tx, ty) False = undefined
+subtype tx ty | debugTypes "subtype" tx ty = undefined
 subtype tx ty = scope (InSubtype tx ty) $ do
   ctx <- getContext
   go (ctx :: Context v loc) (Type.stripIntroOuters tx) (Type.stripIntroOuters ty)

parser-typechecker/src/Unison/Typechecker/Extractor.hs

@@ -278,7 +278,7 @@ unknownTerm =
   cause >>= \case
     C.UnknownTerm loc v suggestions expectedType -> do
       let k = Var.Inference Var.Ability
-          cleanup = Type.cleanup . Type.removePureEffects . Type.generalize' k
+          cleanup = Type.cleanup . Type.removePureEffects False . Type.generalize' k
       pure (loc, v, suggestions, cleanup expectedType)
     _ -> mzero
 

scheme-libs/racket/unison/io-handles.rkt

@@ -45,17 +45,16 @@
     getArgs.impl.v1
     getEnv.impl.v1
     getChar.impl.v1
+    isFileOpen.impl.v3
     process.call
     getCurrentDirectory.impl.v3
+    ready.impl.v1
     ))
 
 ; Still to implement:
 ;    handlePosition.impl.v3
 ;    isSeekable.impl.v3
 ;    getChar.impl.v1
-;    ready.impl.v1
-;    isFileOpen.impl.v3
-;    isFileEOF.impl.v3
    )
 
 ; typeLink msg any
@@ -64,6 +63,17 @@
            [x8 (unison-failure-failure typeLink message x7)])
     (unison-either-left x8)))
 
+(define-unison (isFileOpen.impl.v3 port)
+    (unison-either-right
+        (if (port-closed? port) unison-boolean-false unison-boolean-true)))
+
+(define-unison (ready.impl.v1 port)
+    (if (byte-ready? port)
+        (unison-either-right unison-boolean-true)
+        (if (port-eof? port)
+            (Exception 'IO "EOF" port)
+            (unison-either-right unison-boolean-false))))
+
 (define-unison (getCurrentDirectory.impl.v3 unit)
     (unison-either-right
       (string->chunked-string (path->string (current-directory)))))

scheme-libs/racket/unison/io.rkt

@@ -2,10 +2,14 @@
 (require unison/data
          unison/chunked-seq
          unison/core
+         unison/data-info
+         racket/file
          racket/flonum
+         (only-in unison/boot data-case define-unison)
          (only-in
            rnrs/arithmetic/flonums-6
            flmod))
+(require racket/file)
 
 (provide
  (prefix-out
@@ -24,7 +28,14 @@
    getFileTimestamp.impl.v3
    getTempDirectory.impl.v3
    removeFile.impl.v3
-   getFileSize.impl.v3)))
+   getFileSize.impl.v3))
+  (prefix-out
+    builtin-IO.
+    (combine-out
+        renameFile.impl.v3
+        createDirectory.impl.v3
+        removeDirectory.impl.v3
+        createTempDirectory.impl.v3)))
 
 (define (getFileSize.impl.v3 path)
     (with-handlers
@@ -36,8 +47,13 @@
         [[exn:fail:filesystem? (lambda (e) (exception "IOFailure" (exception->string e) '()))]]
         (right (file-or-directory-modify-seconds (chunked-string->string path)))))
 
+; in haskell, it's not just file but also directory
 (define (fileExists.impl.v3 path)
-    (right (bool (file-exists? (chunked-string->string path)))))
+    (let ([path-string (chunked-string->string path)])
+    (right (bool
+        (or
+        (file-exists? path-string)
+        (directory-exists? path-string))))))
 
 (define (removeFile.impl.v3 path)
     (delete-file (chunked-string->string path))
@@ -46,6 +62,27 @@
 (define (getTempDirectory.impl.v3)
     (right (string->chunked-string (path->string (find-system-path 'temp-dir)))))
 
+(define-unison (createTempDirectory.impl.v3 prefix)
+    (unison-either-right
+        (string->chunked-string
+            (path->string
+                (make-temporary-directory*
+                    (string->bytes/utf-8
+                        (chunked-string->string prefix)) #"")))))
+
+(define-unison (createDirectory.impl.v3 file)
+    (make-directory (chunked-string->string file))
+    (unison-either-right none))
+
+(define-unison (removeDirectory.impl.v3 file)
+    (delete-directory (chunked-string->string file))
+    (unison-either-right none))
+
+(define-unison (renameFile.impl.v3 old new)
+    (rename-file-or-directory (chunked-string->string old)
+        (chunked-string->string new))
+    (unison-either-right none))
+
 (define (threadCPUTime.v1)
     (right (current-process-milliseconds (current-thread))))
 (define (processCPUTime.v1)
@@ -55,7 +92,7 @@
 (define (monotonic.v1)
     (right (current-inexact-monotonic-milliseconds)))
 
-; 
+;
 (define (flt f) (fl->exact-integer (fltruncate f)))
 
 (define (sec.v1 ts) (flt (/ ts 1000)))

scheme-libs/racket/unison/primops.ss

@@ -72,12 +72,19 @@
     builtin-IO.setBuffering.impl.v3
     builtin-IO.getBuffering.impl.v3
     builtin-IO.setEcho.impl.v1
+    builtin-IO.isFileOpen.impl.v3
+    builtin-IO.ready.impl.v1
     builtin-IO.process.call
     builtin-IO.getEcho.impl.v1
     builtin-IO.getArgs.impl.v1
     builtin-IO.getEnv.impl.v1
     builtin-IO.getChar.impl.v1
+    builtin-IO.ready.impl.v1
     builtin-IO.getCurrentDirectory.impl.v3
+    builtin-IO.removeDirectory.impl.v3
+    builtin-IO.renameFile.impl.v3
+    builtin-IO.createTempDirectory.impl.v3
+    builtin-IO.createDirectory.impl.v3
     unison-FOp-IO.getFileSize.impl.v3
     unison-FOp-IO.getFileTimestamp.impl.v3
     unison-FOp-IO.fileExists.impl.v3

unison-core/src/Unison/ABT.hs

@@ -33,6 +33,7 @@ module Unison.ABT
     visitPure,
     changeVars,
     allVars,
+    numberedFreeVars,
     subterms,
     annotateBound,
     rebuildUp,
@@ -356,6 +357,18 @@ allVars t = case out t of
   Abs v body -> v : allVars body
   Tm v -> Foldable.toList v >>= allVars
 
+-- Numbers the free vars by the position where they're first
+-- used within the term. See usage in `Type.normalizeForallOrder`
+numberedFreeVars :: (Ord v, Foldable f) => Term f v a -> Map v Int
+numberedFreeVars t =
+  Map.fromList $ reverse (go mempty t `zip` [0 ..])
+  where
+    go bound t = case out t of
+      Var v -> if v `elem` bound then [] else [v]
+      Cycle body -> go bound body
+      Abs v body -> go (v : bound) body
+      Tm v -> Foldable.toList v >>= go bound
+
 -- | Freshens the given variable wrt. the set of used variables
 -- tracked by state. Adds the result to the set of used variables.
 freshenS :: (Var v, MonadState (Set v) m) => v -> m v