Compiling with table layout

2024-11-10 20:00:27 +03:00 · 2021-11-10 13:18:25 -06:00 · 2021-11-10 13:18:25 -06:00 · d4d4a444ef
commit d4d4a444ef
parent de0f942970
8 changed files with 165 additions and 118 deletions
--- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs
+++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs
@ -127,7 +127,6 @@ import Unison.UnisonFile (TypecheckedUnisonFile)
 import qualified Unison.UnisonFile as UF
 import qualified Unison.UnisonFile.Names as UF
 import qualified Unison.Util.Find as Find
-import qualified Unison.Util.Free as Free
 import Unison.Util.List (uniqueBy)
 import Unison.Util.Monoid (intercalateMap)
 import qualified Unison.Util.Monoid as Monoid
@ -141,7 +140,7 @@ import Unison.Var (Var)
 import qualified Unison.Var as Var
 import qualified Unison.WatchKind as WK
 import qualified Unison.Codebase.Editor.HandleInput.Action as Action
-import Unison.Codebase.Editor.HandleInput.Action (Action, Action')
+import Unison.Codebase.Editor.HandleInput.Action (Action, Action', eval)
 import qualified Unison.Codebase.Editor.HandleInput.NamespaceDependencies as NamespaceDependencies

 defaultPatchNameSegment :: NameSegment
@ -1723,9 +1722,9 @@ loop = do
              case (Branch.getAt (Path.unabsolute path) root') of
                Nothing -> respond $ BranchEmpty (Right (Path.absoluteToPath' path))
                Just b -> do
-                  (externalTerms, externalTypes) <- NamespaceDependencies.namespaceDependencies (Branch.head b)
+                  externalDependencies <- NamespaceDependencies.namespaceDependencies (Branch.head b)
                  ppe <- suffixifiedPPE (NamesWithHistory.NamesWithHistory basicPrettyPrintNames mempty)
-                  respond $ ListNamespaceDependencies ppe externalTerms externalTypes
+                  respond $ ListNamespaceDependencies ppe externalDependencies
            DebugNumberedArgsI -> use Action.numberedArgs >>= respond . DumpNumberedArgs
            DebugTypecheckedUnisonFileI -> case uf of
              Nothing -> respond NoUnisonFile
@ -1843,7 +1842,7 @@ loop = do
        gitUrlKey = configKey "GitUrl"

  case e of
-    Right input -> lastInput .= Just input
+    Right input -> Action.lastInput .= Just input
    _ -> pure ()

 -- | Handle a @ShowDefinitionI@ input command, i.e. `view` or `edit`.
@ -2134,12 +2133,9 @@ computeFrontier getDependents patch names =
        -- Dirty is everything that `dependsOn` Frontier, minus already edited defns
        pure $ R.filterDom (not . flip Set.member edited) dependsOn

-eval :: Command m i v a -> Action m i v a
-eval = lift . lift . Free.eval
-
 confirmedCommand :: Input -> Action m i v Bool
 confirmedCommand i = do
-  i0 <- use lastInput
+  i0 <- use Action.lastInput
  pure $ Just i == i0

 listBranch :: Branch0 m -> [SearchResult]
@ -2382,7 +2378,7 @@ updateAtM ::
  (Branch m -> Action m i v (Branch m)) ->
  Action m i v Bool
 updateAtM reason (Path.Absolute p) f = do
-  b <- use lastSavedRoot
+  b <- use Action.lastSavedRoot
  b' <- Branch.modifyAtM p f b
  updateRoot b' reason
  pure $ b /= b'
@ -2487,12 +2483,12 @@ stepManyAtMNoSync' actions = do

 updateRoot :: Branch m -> Action.InputDescription -> Action m i v ()
 updateRoot new reason = do
-  old <- use lastSavedRoot
+  old <- use Action.lastSavedRoot
  when (old /= new) $ do
    Action.root .= new
    eval $ SyncLocalRootBranch new
    eval $ AppendToReflog reason old new
-    lastSavedRoot .= new
+    Action.lastSavedRoot .= new

 -- cata for 0, 1, or more elements of a Foldable
 -- tries to match as lazily as possible
--- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Action.hs
+++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Action.hs
@ -16,6 +16,7 @@ import qualified Unison.UnisonFile as UF
 import Unison.Util.Free (Free)
 import Unison.Codebase.Editor.Command
 import qualified Data.List.NonEmpty as Nel
+import qualified Unison.Util.Free as Free

 type F m i v = Free (Command m i v)

@ -60,3 +61,6 @@ currentPath = currentPathStack . to Nel.head

 loopState0 :: Branch m -> Path.Absolute -> LoopState m v
 loopState0 b p = LoopState b b (pure p) Nothing Nothing Nothing []
+
+eval :: Command m i v a -> Action m i v a
+eval = lift . lift . Free.eval
--- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs
+++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs
@ -1,27 +1,22 @@
 module Unison.Codebase.Editor.HandleInput.NamespaceDependencies
-  ( namespaceDependencies
-  ) where
-import Unison.Reference (Reference)
-import Unison.Type (Type)
-import Unison.Parser.Ann (Ann (..))
-import Unison.Referent (Referent)
-import Unison.Codebase.Branch (Branch0)
-import Unison.Prelude
-import qualified Unison.Reference as Reference
-import qualified Data.Set as Set
+  ( namespaceDependencies,
+  )
+where
+
 import qualified Data.Map as Map
-import qualified Unison.Util.Relation as Relation
-import qualified Unison.Referent as Referent
-import Unison.Codebase.Editor.HandleInput.Action (Action)
+import qualified Data.Set as Set
+import Unison.Codebase.Branch (Branch0)
+import qualified Unison.Codebase.Branch as Branch
+import Unison.Codebase.Editor.Command
+import Unison.Codebase.Editor.HandleInput.Action (Action, eval)
 import Unison.LabeledDependency (LabeledDependency)
-import Unison.Util.Free
-
-
-- data ReferenceType v
--   = TypeRef Reference
--   | TermRef Reference (Type v Ann)
--   | ConstructorRef Referent
--   deriving (Eq, Ord)
+import qualified Unison.LabeledDependency as LD
+import Unison.Prelude
+import Unison.Reference (Reference)
+import qualified Unison.Reference as Reference
+import Unison.Referent (Referent)
+import qualified Unison.Referent as Referent
+import qualified Unison.Util.Relation as Relation

 -- | Check the dependencies of all types, terms, and metadata in the current namespace,
 -- returns dependencies which do not have a name within the current namespace, alongside their
@ -34,32 +29,59 @@ import Unison.Util.Free
 -- on .base.Bag.map directly.
 namespaceDependencies :: forall m i v. Branch0 m -> Action m i v (Map LabeledDependency (Set Reference))
 namespaceDependencies branch = do
-  dependenciesToDependants :: Map Reference (Set Reference)
-    <- fold <$> traverse (eval . GetDependencies) (mapMaybe Reference.toId $ Set.toList refsInCurrentBranch)
-  externalConstructors  :: Map Reference (Set Referent)
-    <- Map.unions <$> (for (Set.toList dependenciesToDependants) $ \ref -> do
-                    constructors <- eval (ConstructorsOfType ref)
-                    let externalConstrs = constructors `Set.difference` currentBranchReferents
-                    pure $ Map.singleton ref externalConstrs
-              )
-  let externalDependenciesToDependants :: Map Reference (Set Reference)
-      externalDependenciesToDependants = Map.filterWithKey (\k _ -> k `Set.notMember` refsInCurrentBranch) dependenciesToDependants
-  termsTypesAndConstructors :: (Map Reference (Type v Ann), Map Reference (Set Referent))
-       <- fold <$> for (Set.toList externalDependencies) \ref -> do
-            typeOfTerm <- eval (LoadTypeOfTerm ref)
-            pure $ case typeOfTerm of
-              -- If we got a type, this must be a term reference
-              Just typ -> (Map.singleton ref typ, mempty)
-              -- If we didn't, it must be a type declaration, so we include its constructors.
-              Nothing -> (mempty, Map.singleton ref (fold $ Map.lookup ref externalConstructors))
-  pure termsTypesAndConstructors
+  let allDependenciesOf :: Set Reference -> Action m i v (Map Reference (Set Reference))
+      allDependenciesOf refs =
+        Map.fromListWith (<>)
+          <$> for
+            (mapMaybe Reference.toId $ Set.toList refs)
+            (\ref -> (Reference.fromId ref,) <$> eval (GetDependencies ref))
+  dependenciesToDependants :: Map LabeledDependency (Set Reference) <-
+    Map.unionsWith (<>)
+      <$> sequenceA
+        [ Map.mapKeys LD.typeRef <$> allDependenciesOf currentBranchTypes,
+          Map.mapKeys LD.termRef <$> allDependenciesOf currentBranchTerms
+        ]
+  let onlyExternalDeps :: Map LabeledDependency (Set Reference)
+      onlyExternalDeps =
+        Map.filterWithKey
+          (\k _ -> either id id (LD.toReference k) `Set.notMember` refsInCurrentBranch)
+          dependenciesToDependants
+  externalConstructors :: Map LabeledDependency (Set Reference) <-
+    Map.unions . concat
+      <$> ( for (Map.toList onlyExternalDeps) $ \case
+              (LD.toReference -> Left typeRef, deps) -> do
+                constructors <- eval (ConstructorsOfType typeRef)
+                let externalConstrs = constructors `Set.difference` currentBranchReferents
+                pure $
+                  [ Map.singleton (LD.typeRef typeRef) deps,
+                    Map.fromListWith (<>) ((,deps) . LD.referent <$> Set.toList externalConstrs)
+                  ]
+              _ -> pure []
+          )
+  let allDependenciesToDependants = Map.unionWith (<>) externalConstructors onlyExternalDeps
+  pure allDependenciesToDependants
  where
+    -- termsTypesAndConstructors :: (Map Reference (Type v Ann), Map Reference (Set Referent))
+    --      <- _ <$> for (Set.toList externalDependencies) \ref -> do
+    --           typeOfTerm <- eval (LoadTypeOfTerm ref)
+    --           pure $ case typeOfTerm of
+    --             -- If we got a type, this must be a term reference
+    --             Just typ -> (Map.singleton ref typ, mempty)
+    --             -- If we didn't, it must be a type declaration, so we include its constructors.
+    --             Nothing -> (mempty, Map.singleton ref (_ $ Map.lookup ref externalConstructors))
+    -- pure termsTypesAndConstructors
+
    currentBranchReferents :: Set Referent
-    currentBranchReferents = Relation.dom (deepTerms branch)
+    currentBranchReferents = Relation.dom (Branch.deepTerms branch)
+    currentBranchTerms :: Set Reference
+    currentBranchTerms = Set.map Referent.toReference currentBranchReferents
+    currentBranchTypes :: Set Reference
+    currentBranchTypes = Relation.dom (Branch.deepTypes branch)
    refsInCurrentBranch :: Set Reference
    refsInCurrentBranch =
-         Relation.dom (deepTypes branch)
-      <> Set.map Referent.toReference currentBranchReferents
-      -- TODO:
-      -- <> _termMetadata
-      -- <> _typeMetadata
+      Relation.dom (Branch.deepTypes branch)
+        <> Set.map Referent.toReference currentBranchReferents
+
+-- TODO:
+-- <> _termMetadata
+-- <> _typeMetadata
--- a/unison-cli/src/Unison/Codebase/Editor/Output.hs
+++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs
@ -214,10 +214,7 @@ data Output v
    -- The first map is all missing terms and their types
    -- The second map is all types and any missing constructors.
    -- A type is still included if it has a name, but one of its constructors does not.
-    ListNamespaceDependencies PPE.PrettyPrintEnv
-      (Map Reference (Set Reference))
-      (Map Reference (Set Reference))
-    -- (NamespaceDependencies.ReferenceType v) (Set Reference))
+    ListNamespaceDependencies PPE.PrettyPrintEnv (Map LabeledDependency (Set Reference))
  | DumpNumberedArgs NumberedArgs
  | DumpBitBooster Branch.Hash (Map Branch.Hash [Branch.Hash])
  | DumpUnisonFileHashes Int [(Name, Reference.Id)] [(Name, Reference.Id)] [(Name, Reference.Id)]
--- a/unison-cli/src/Unison/Codebase/TranscriptParser.hs
+++ b/unison-cli/src/Unison/Codebase/TranscriptParser.hs
@ -48,7 +48,7 @@ import qualified Text.Megaparsec as P
 import qualified Unison.Codebase as Codebase
 import qualified Unison.Codebase.Branch as Branch
 import qualified Unison.Codebase.Editor.HandleCommand as HandleCommand
-import qualified Unison.Codebase.Editor.HandleInput as HandleInput
+import qualified Unison.Codebase.Editor.HandleInput.Action as Action
 import qualified Unison.Codebase.Path as Path
 import qualified Unison.Codebase.Path.Parse as Path
 import qualified Unison.Codebase.Runtime as Runtime
@ -58,6 +58,7 @@ import qualified Unison.Util.TQueue as Q
 import qualified Unison.Codebase.Editor.Output as Output
 import Control.Lens (view)
 import Control.Error (rightMay)
+import qualified Unison.Codebase.Editor.HandleInput as HandleInput

 -- | Render transcript errors at a width of 65 chars.
 terminalWidth :: P.Width
@ -305,7 +306,7 @@ run version dir configFile stanzas codebase = do
            "Run `" <> Text.pack executable <> " --codebase " <> Text.pack dir <> "` " <> "to do more work with it."]

      loop state = do
-        writeIORef pathRef (view HandleInput.currentPath state)
+        writeIORef pathRef (view Action.currentPath state)
        let free = runStateT (runMaybeT HandleInput.loop) state
            rng i = pure $ Random.drgNewSeed (Random.seedFromInteger (fromIntegral i))
        (o, state') <- HandleCommand.commandLine config awaitInput
@ -323,11 +324,11 @@ run version dir configFile stanzas codebase = do
            texts <- readIORef out
            pure $ Text.concat (Text.pack <$> toList (texts :: Seq String))
          Just () -> do
-            writeIORef numberedArgsRef (HandleInput._numberedArgs state')
-            writeIORef rootBranchRef (HandleInput._root state')
+            writeIORef numberedArgsRef (Action._numberedArgs state')
+            writeIORef rootBranchRef (Action._root state')
            loop state'
    (`finally` cleanup)
-      $ loop (HandleInput.loopState0 root initialPath)
+      $ loop (Action.loopState0 root initialPath)

 transcriptFailure :: IORef (Seq String) -> Text -> IO b
 transcriptFailure out msg = do
--- a/unison-cli/src/Unison/CommandLine/Main.hs
+++ b/unison-cli/src/Unison/CommandLine/Main.hs
@ -2,7 +2,7 @@
 {-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ViewPatterns        #-}

-module Unison.CommandLine.Main 
+module Unison.CommandLine.Main
  ( main
  ) where

@ -19,7 +19,6 @@ import Unison.Codebase.Branch (Branch)
 import qualified Unison.Codebase.Branch as Branch
 import Unison.Codebase.Editor.Input (Input (..), Event)
 import qualified Unison.Server.CodebaseServer as Server
-import qualified Unison.Codebase.Editor.HandleInput as HandleInput
 import qualified Unison.Codebase.Editor.HandleCommand as HandleCommand
 import Unison.Codebase.Editor.Command (LoadSourceResult(..))
 import Unison.Codebase (Codebase)
@ -48,6 +47,8 @@ import Control.Error (rightMay)
 import UnliftIO (catchSyncOrAsync, throwIO, withException)
 import System.IO (hPutStrLn, stderr)
 import Unison.Codebase.Editor.Output (Output)
+import qualified Unison.Codebase.Editor.HandleInput.Action as Action
+import qualified Unison.Codebase.Editor.HandleInput as HandleInput

 getUserInput
  :: forall m v a
@ -180,9 +181,9 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba
                  writeIORef pageOutput True
                  pure x) `catchSyncOrAsync` interruptHandler

-    let loop :: HandleInput.LoopState IO Symbol -> IO ()
+    let loop :: Action.LoopState IO Symbol -> IO ()
        loop state = do
-          writeIORef pathRef (view HandleInput.currentPath state)
+          writeIORef pathRef (view Action.currentPath state)
          let free = runStateT (runMaybeT HandleInput.loop) state
          (o, state') <- HandleCommand.commandLine config awaitInput
                                       (writeIORef rootRef)
@ -198,10 +199,10 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba
          case o of
            Nothing -> pure ()
            Just () -> do
-              writeIORef numberedArgsRef (HandleInput._numberedArgs state')
+              writeIORef numberedArgsRef (Action._numberedArgs state')
              loop state'
-    -- Run the main program loop, always run cleanup, 
+    -- Run the main program loop, always run cleanup,
    -- If an exception occurred, print it before exiting.
-    (loop (HandleInput.loopState0 root initialPath)
+    (loop (Action.loopState0 root initialPath)
      `withException` \e -> hPutStrLn stderr ("Exception: " <> show (e :: SomeException)))
      `finally` cleanup
--- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs
+++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs
@ -25,7 +25,6 @@ import System.Directory
    getHomeDirectory,
  )
 import U.Codebase.Sqlite.DbId (SchemaVersion (SchemaVersion))
-import qualified U.Util.Monoid as Monoid
 import qualified Unison.ABT as ABT
 import qualified Unison.Builtin.Decls as DD
 import qualified Unison.Codebase as Codebase
@ -124,6 +123,7 @@ import Unison.Var (Var)
 import qualified Unison.Var as Var
 import qualified Unison.WatchKind as WK
 import Prelude hiding (readFile, writeFile)
+import qualified Unison.ConstructorType as CT

 type Pretty = P.Pretty P.ColorText

@ -1349,50 +1349,71 @@ notifyUser dir o = case o of
        )
      p = prettyShortHash . SH.take hqLength
      c = P.syntaxToColor
-  ListNamespaceDependencies _ppe Empty Empty -> pure $ "This namespace has no external dependencies."
-  ListNamespaceDependencies ppe externalTerms externalTypes ->
-    pure . P.lines $
-      Monoid.whenM
-        (not . null $ externalTerms)
-        [ P.bold "This namespace depends on the following external terms:"
-            <> P.newline
-            <> P.indent "  " (prettyTerms externalTerms)
-        ]
-        <> Monoid.whenM
-          (not . null $ externalTypes)
-          [ P.newline <> P.bold "This namespace depends on the following external types declarations and constructors:"
-              <> P.newline
-              <> P.indent "  " (prettyTypes externalTypes)
-          ]
-    where
-      prettyTerms :: Map Reference (Type v Ann) -> P.Pretty P.ColorText
-      prettyTerms m =
-        m
-          & Map.toList
-          & fmap (first Referent.fromReference)
-          & fmap (\(r, typ) -> TypePrinter.prettySignaturesCTCollapsed ppe [(r, PPE.typeOrTermName ppe r, typ)])
-          & P.lines
+  ListNamespaceDependencies _ppe Empty -> pure $ "This namespace has no external dependencies."
+  ListNamespaceDependencies ppe externalDependencies ->
+    pure . P.column2Header "dependency" "dependants" $ externalDepsTable externalDependencies

-      prettyTypes :: Map Reference (Set Referent) -> P.Pretty P.ColorText
-      prettyTypes m =
-        m
-          & Map.toList
-          & fmap (first Referent.fromReference)
-          & fmap
-            ( \(r, constructors) ->
-                P.text (HQ.toText $ PPE.typeOrTermName ppe r)
-                  <> Monoid.whenM
-                    (not . null $ constructors)
-                    ( P.newline
-                        <> ( P.indent (P.hiBlack "  constructor ")
-                               . P.lines
-                               . fmap (P.text . HQ.toText . PPE.typeOrTermName ppe)
-                               . Set.toList
-                               $ constructors
-                           )
-                    )
-            )
-          & P.lines
+    -- pure . P.lines $
+    --   Monoid.whenM
+    --     (not . null $ externalTerms)
+    --     [ P.bold "This namespace depends on the following external terms:"
+    --         <> P.newline
+    --         <> P.indent "  " (prettyTerms externalTerms)
+    --     ]
+    --     <> Monoid.whenM
+    --       (not . null $ externalTypes)
+    --       [ P.newline <> P.bold "This namespace depends on the following external types declarations and constructors:"
+    --           <> P.newline
+    --           <> P.indent "  " (prettyTypes externalTypes)
+    --       ]
+    where
+      prettyLabelledDep :: LD.LabeledDependency -> P.Pretty P.ColorText
+      prettyLabelledDep ld = case LD.toEither ld of
+        Left ref ->
+          P.hiBlack "type " <> (P.text . HQ.toText $ PPE.typeName ppe ref)
+        Right (Referent.Ref ref) ->
+          P.text . HQ.toText $ PPE.typeName ppe ref
+        Right (Referent.Con ref _conID CT.Data) ->
+          P.hiBlack "constructor " <> (P.text . HQ.toText $ PPE.typeName ppe ref)
+        Right (Referent.Con ref _conID CT.Effect) ->
+          P.text . HQ.toText $ PPE.typeName ppe ref
+      externalDepsTable :: Map LabeledDependency (Set Reference) -> [(P.Pretty P.ColorText, P.Pretty P.ColorText)]
+      externalDepsTable = ifoldMap $ \ld dependants ->
+        [(prettyLabelledDep ld, prettyDependants dependants)]
+      prettyDependants :: Set Reference -> P.Pretty P.ColorText
+      prettyDependants refs = refs
+                            & Set.toList
+                            & fmap (P.text . HQ.toText . PPE.termName ppe . Referent.fromReference)
+                            & P.commas
+
+      -- prettyTerms :: Map Reference (Type v Ann) -> P.Pretty P.ColorText
+      -- prettyTerms m =
+      --   m
+      --     & Map.toList
+      --     & fmap (first Referent.fromReference)
+      --     & fmap (\(r, typ) -> TypePrinter.prettySignaturesCTCollapsed ppe [(r, PPE.typeOrTermName ppe r, typ)])
+      --     & P.lines
+
+      -- prettyTypes :: Map Reference (Set Referent) -> P.Pretty P.ColorText
+      -- prettyTypes m =
+      --   m
+      --     & Map.toList
+      --     & fmap (first Referent.fromReference)
+      --     & fmap
+      --       ( \(r, constructors) ->
+      --           P.text (HQ.toText $ PPE.typeOrTermName ppe r)
+      --             <> Monoid.whenM
+      --               (not . null $ constructors)
+      --               ( P.newline
+      --                   <> ( P.indent (P.hiBlack "  constructor ")
+      --                          . P.lines
+      --                          . fmap (P.text . HQ.toText . PPE.typeOrTermName ppe)
+      --                          . Set.toList
+      --                          $ constructors
+      --                      )
+      --               )
+      --       )
+      --     & P.lines
  DumpUnisonFileHashes hqLength datas effects terms ->
    pure . P.syntaxToColor . P.lines $
      ( effects <&> \(n, r) ->
--- a/unison-core/src/Unison/LabeledDependency.hs
+++ b/unison-core/src/Unison/LabeledDependency.hs
@ -13,6 +13,7 @@ module Unison.LabeledDependency
  , toReference
  , LabeledDependency
  , partition
+  , toEither
  ) where

 import Unison.Prelude hiding (fold)
@ -48,6 +49,10 @@ fold f g (X e) = either f g e
 partition :: Foldable t => t LabeledDependency -> ([Reference], [Referent])
 partition = partitionEithers . map (\(X e) -> e) . toList

+toEither :: LabeledDependency -> (Either Reference Referent)
+toEither (X e) = e
+
+
 -- | Left TypeRef | Right TermRef
 toReference :: LabeledDependency -> Either Reference Reference
 toReference = \case