It compiles!!!

2024-09-22 15:58:34 +03:00 · 2021-07-13 21:59:49 -04:00 · 2021-07-13 21:59:49 -04:00 · 8967923713
commit 8967923713
parent 26031f5f14
8 changed files with 54 additions and 43 deletions
--- a/parser-typechecker/src/Unison/Builtin.hs
+++ b/parser-typechecker/src/Unison/Builtin.hs
@ -16,6 +16,7 @@ module Unison.Builtin
  ,intrinsicTermReferences
  ,intrinsicTypeReferences
  ,isBuiltinType
+  ,typeOf
  ,typeLookup
  ,termRefTypes
  ) where
@ -247,6 +248,9 @@ termRefTypes = foldl' go mempty builtinsSrc where
    D r t -> Map.insert (R.Builtin r) t m
    _ -> m

+typeOf :: Var v => a -> (Type v -> a) -> R.Reference -> a
+typeOf a f r = maybe a f (Map.lookup r termRefTypes)
+
 builtinsSrc :: Var v => [BuiltinDSL v]
 builtinsSrc =
  [ B "Int.+" $ int --> int --> int
--- a/parser-typechecker/src/Unison/Codebase/Editor/DisplayObject.hs
+++ b/parser-typechecker/src/Unison/Codebase/Editor/DisplayObject.hs
@ -4,10 +4,16 @@ module Unison.Codebase.Editor.DisplayObject where

 import Unison.Prelude
 import Unison.ShortHash
+import Data.Bifunctor

 data DisplayObject b a = BuiltinObject b | MissingObject ShortHash | UserObject a
  deriving (Eq, Ord, Show, Functor, Generic)

+instance Bifunctor DisplayObject where
+  bimap _ _ (MissingObject sh) = MissingObject sh
+  bimap f _ (BuiltinObject b) = BuiltinObject (f b)
+  bimap _ f (UserObject a) = UserObject (f a)
+
 toMaybe :: DisplayObject b a -> Maybe a
 toMaybe = \case
  UserObject a -> Just a
--- a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs
+++ b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs
@ -1357,7 +1357,7 @@ loop = do
              in  case t of
                    HQ.HashOnly h ->
                      hashConflicted h rs'
-                    (Path.parseHQSplit' . HQ.toString -> Right n) -> 
+                    (Path.parseHQSplit' . HQ.toString -> Right n) ->
                      termConflicted n rs'
                    _ -> respond . BadName $ HQ.toString t

@ -2666,7 +2666,7 @@ doSlurpUpdates typeEdits termEdits deprecated b0 =

 loadDisplayInfo ::
  Set Reference -> Action m i v ([(Reference, Maybe (Type v Ann))]
-                                ,[(Reference, DisplayObject (DD.Decl v Ann))])
+                                ,[(Reference, DisplayObject () (DD.Decl v Ann))])
 loadDisplayInfo refs = do
  termRefs <- filterM (eval . IsTerm) (toList refs)
  typeRefs <- filterM (eval . IsType) (toList refs)
@ -2698,9 +2698,9 @@ makeHistoricalParsingNames lexedHQs = do
                 fixupNamesRelative currentPath rawHistoricalNames)

 loadTypeDisplayObject
-  :: Reference -> Action m i v (DisplayObject (DD.Decl v Ann))
+  :: Reference -> Action m i v (DisplayObject () (DD.Decl v Ann))
 loadTypeDisplayObject = \case
-  Reference.Builtin _ -> pure BuiltinObject
+  Reference.Builtin _ -> pure (BuiltinObject ())
  Reference.DerivedId id ->
    maybe (MissingObject $ Reference.idToShortHash id) UserObject
      <$> eval (LoadType id)
--- a/parser-typechecker/src/Unison/Codebase/Editor/Output.hs
+++ b/parser-typechecker/src/Unison/Codebase/Editor/Output.hs
@ -158,8 +158,8 @@ data Output v
  -- "display" definitions, possibly to a FilePath on disk (e.g. editing)
  | DisplayDefinitions (Maybe FilePath)
                       PPE.PrettyPrintEnvDecl
-                       (Map Reference (DisplayObject (Decl v Ann)))
-                       (Map Reference (DisplayObject (Term v Ann)))
+                       (Map Reference (DisplayObject () (Decl v Ann)))
+                       (Map Reference (DisplayObject (Type v Ann) (Term v Ann)))
  -- | Invariant: there's at least one conflict or edit in the TodoOutput.
  | TodoOutput PPE.PrettyPrintEnvDecl (TO.TodoOutput v Ann)
  | TestIncrementalOutputStart PPE.PrettyPrintEnv (Int,Int) Reference (Term v Ann)
@ -181,8 +181,8 @@ data Output v
  | ConfiguredGitUrlParseError PushPull Path' Text String
  | ConfiguredGitUrlIncludesShortBranchHash PushPull RemoteRepo ShortBranchHash Path
  | DisplayLinks PPE.PrettyPrintEnvDecl Metadata.Metadata
-               (Map Reference (DisplayObject (Decl v Ann)))
-               (Map Reference (DisplayObject (Term v Ann)))
+               (Map Reference (DisplayObject () (Decl v Ann)))
+               (Map Reference (DisplayObject (Type v Ann) (Term v Ann)))
  | MetadataMissingType PPE.PrettyPrintEnv Referent
  | TermMissingType Reference
  | MetadataAmbiguous (HQ.HashQualified Name) PPE.PrettyPrintEnv [Referent]
--- a/parser-typechecker/src/Unison/CommandLine/DisplayValues.hs
+++ b/parser-typechecker/src/Unison/CommandLine/DisplayValues.hs
@ -30,6 +30,7 @@ import qualified Unison.Util.SyntaxText as S
 import qualified Unison.Codebase.Editor.DisplayObject as DO
 import qualified Unison.CommandLine.OutputMessages as OutputMessages
 import qualified Unison.ConstructorType as CT
+import qualified Unison.Builtin as Builtin

 type Pretty = P.Pretty P.ColorText

@ -132,19 +133,18 @@ displayPretty pped terms typeOf eval types tm = go tm
        tms = [ ref | DD.TupleTerm' [DD.EitherRight' (DD.Doc2Term (toRef -> Just ref)),_anns] <- toList es ]
    typeMap <- let
      -- todo: populate the variable names / kind once BuiltinObject supports that
-      go ref@(Reference.Builtin _) = pure (ref, DO.BuiltinObject)
+      go ref@(Reference.Builtin _) = pure (ref, DO.BuiltinObject ())
      go ref = (ref,) <$> do
        decl <- types ref
        let missing = DO.MissingObject (SH.unsafeFromText $ Reference.toText ref)
        pure $ maybe missing DO.UserObject decl
      in Map.fromList <$> traverse go tys
    termMap <- let
-      -- todo: populate the type signature once BuiltinObject supports that
-      go ref@(Reference.Builtin _) = pure (ref, DO.BuiltinObject)
-      go ref = (ref,) <$> do
-        tm <- terms ref
-        let missing = DO.MissingObject (SH.unsafeFromText $ Reference.toText ref)
-        pure $ maybe missing DO.UserObject tm
+      go ref = (ref,) <$> case ref of
+        Reference.Builtin _ -> pure $ Builtin.typeOf missing DO.BuiltinObject ref
+        _ -> maybe missing DO.UserObject <$> terms ref
+        where
+          missing = DO.MissingObject (SH.unsafeFromText $ Reference.toText ref)
      in Map.fromList <$> traverse go tms
    -- in docs, we use suffixed names everywhere
    let pped' = pped { PPE.unsuffixifiedPPE = PPE.suffixifiedPPE pped }
--- a/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs
+++ b/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs
@ -1141,8 +1141,8 @@ formatMissingStuff terms types =

 displayDefinitions' :: Var v => Ord a1
  => PPE.PrettyPrintEnvDecl
-  -> Map Reference.Reference (DisplayObject (DD.Decl v a1))
-  -> Map Reference.Reference (DisplayObject (Term v a1))
+  -> Map Reference.Reference (DisplayObject () (DD.Decl v a1))
+  -> Map Reference.Reference (DisplayObject (Type v a1) (Term v a1))
  -> Pretty
 displayDefinitions' ppe0 types terms = P.syntaxToColor $ P.sep "\n\n" (prettyTypes <> prettyTerms)
  where
@ -1156,12 +1156,14 @@ displayDefinitions' ppe0 types terms = P.syntaxToColor $ P.sep "\n\n" (prettyTyp
  go ((n, r), dt) =
    case dt of
      MissingObject r -> missing n r
-      BuiltinObject -> builtin n
+      BuiltinObject typ ->
+        P.hang ("builtin " <> prettyHashQualified n <> " :")
+               (TypePrinter.prettySyntax (ppeBody r) typ)
      UserObject tm -> TermPrinter.prettyBinding (ppeBody r) n tm
  go2 ((n, r), dt) =
    case dt of
      MissingObject r -> missing n r
-      BuiltinObject -> builtin n
+      BuiltinObject _ -> builtin n
      UserObject decl -> case decl of
        Left d  -> DeclPrinter.prettyEffectDecl (ppeBody r) r n d
        Right d -> DeclPrinter.prettyDataDecl (ppeBody r) r n d
@ -1199,8 +1201,8 @@ displayRendered outputLoc pp =
 displayDefinitions :: Var v => Ord a1 =>
  Maybe FilePath
  -> PPE.PrettyPrintEnvDecl
-  -> Map Reference.Reference (DisplayObject (DD.Decl v a1))
-  -> Map Reference.Reference (DisplayObject (Term v a1))
+  -> Map Reference.Reference (DisplayObject () (DD.Decl v a1))
+  -> Map Reference.Reference (DisplayObject (Type v a1) (Term v a1))
  -> IO Pretty
 displayDefinitions _outputLoc _ppe types terms | Map.null types && Map.null terms =
  pure $ P.callout "😶" "No results to display."
@ -1307,17 +1309,17 @@ prettyTypeResultHeaderFull' (SR'.TypeResult' (HQ'.toHQ -> name) dt r (Set.map HQ
    where greyHash = styleHashQualified' id P.hiBlack

 prettyDeclTriple :: Var v =>
-  (HQ.HashQualified Name, Reference.Reference, DisplayObject (DD.Decl v a))
+  (HQ.HashQualified Name, Reference.Reference, DisplayObject () (DD.Decl v a))
  -> Pretty
 prettyDeclTriple (name, _, displayDecl) = case displayDecl of
-   BuiltinObject -> P.hiBlack "builtin " <> P.hiBlue "type " <> P.blue (P.syntaxToColor $ prettyHashQualified name)
+   BuiltinObject _ -> P.hiBlack "builtin " <> P.hiBlue "type " <> P.blue (P.syntaxToColor $ prettyHashQualified name)
   MissingObject _ -> mempty -- these need to be handled elsewhere
   UserObject decl -> case decl of
     Left ed -> P.syntaxToColor $ DeclPrinter.prettyEffectHeader name ed
     Right dd   -> P.syntaxToColor $ DeclPrinter.prettyDataHeader name dd

 prettyDeclPair :: Var v =>
-  PPE.PrettyPrintEnv -> (Reference, DisplayObject (DD.Decl v a))
+  PPE.PrettyPrintEnv -> (Reference, DisplayObject () (DD.Decl v a))
  -> Pretty
 prettyDeclPair ppe (r, dt) = prettyDeclTriple (PPE.typeName ppe r, r, dt)

--- a/parser-typechecker/src/Unison/Server/Backend.hs
+++ b/parser-typechecker/src/Unison/Server/Backend.hs
@ -14,7 +14,7 @@ import Control.Monad.Except
  ( ExceptT (..),
    throwError,
  )
-import Data.Bifunctor (first)
+import Data.Bifunctor (first,bimap)
 import Data.List.Extra (nubOrd)
 import qualified Data.List as List
 import qualified Data.Map as Map
@ -262,7 +262,8 @@ typeListEntry codebase r n = do
  pure $ TypeEntry r n tag

 typeDeclHeader
-  :: Monad m
+  :: forall v m
+   . Monad m
  => Var v
  => Codebase m v Ann
  -> PPE.PrettyPrintEnv
@ -281,9 +282,12 @@ typeDeclHeader code ppe r = case Reference.toId r of
  where
    name = PPE.typeName ppe r

-formatTypeName :: Var v => PPE.PrettyPrintEnv -> Reference -> Syntax.SyntaxText
-formatTypeName ppe r =
-  fmap Syntax.convertElement .
+formatTypeName :: PPE.PrettyPrintEnv -> Reference -> Syntax.SyntaxText
+formatTypeName ppe =
+  fmap Syntax.convertElement . formatTypeName' ppe
+
+formatTypeName' :: PPE.PrettyPrintEnv -> Reference -> UST.SyntaxText
+formatTypeName' ppe r =
  Pretty.renderUnbroken .
  NP.styleHashQualified id $
  PPE.typeName ppe r
@ -672,7 +676,7 @@ prettyDefinitionsBySuffixes relativeTo root renderWidth suffixifyBindings rt cod
            TermDefinition (flatten $ Map.lookup r termFqns)
                             bn
                             tag
-                             (fmap mungeSyntaxText tm)
+                             (bimap mungeSyntaxText mungeSyntaxText tm)
                             (prettyType width ppe typeSig)
                             docs
      mkTypeDefinition r tp = do
@ -685,7 +689,7 @@ prettyDefinitionsBySuffixes relativeTo root renderWidth suffixifyBindings rt cod
        pure $ TypeDefinition (flatten $ Map.lookup r typeFqns)
                              bn
                              tag
-                              (fmap mungeSyntaxText tp)
+                              (bimap mungeSyntaxText mungeSyntaxText tp)
                              docs
    typeDefinitions <- Map.traverseWithKey mkTypeDefinition
      $ typesToSyntax suffixifyBindings width ppe types
@ -810,7 +814,7 @@ typesToSyntax
  -> Width
  -> PPE.PrettyPrintEnvDecl
  -> Map Reference.Reference (DisplayObject () (DD.Decl v a))
-  -> Map Reference.Reference (DisplayObject () UST.SyntaxText)
+  -> Map Reference.Reference (DisplayObject UST.SyntaxText UST.SyntaxText)
 typesToSyntax suff width ppe0 types =
  Map.fromList $ map go . Map.toList $ Map.mapKeys
    (first (PPE.typeName ppeDecl) . dupe)
@ -822,16 +826,11 @@ typesToSyntax suff width ppe0 types =
  ppeDecl = if suffixified suff
    then PPE.suffixifiedPPE ppe0
    else PPE.unsuffixifiedPPE ppe0
-  go ((n, r), dt) =
-    ( r
-    , (\case
-        Left d ->
-          Pretty.render width $ DeclPrinter.prettyEffectDecl (ppeBody r) r n d
-        Right d ->
-          Pretty.render width $ DeclPrinter.prettyDataDecl (ppeBody r) r n d
-      )
-      <$> dt
-    )
+  go ((n, r), dt) = (r,) $ case dt of
+    BuiltinObject _ -> BuiltinObject (formatTypeName' ppeDecl r)
+    MissingObject sh -> MissingObject sh
+    UserObject d -> UserObject . Pretty.render width $
+      DeclPrinter.prettyDecl (ppeBody r) r n d

 loadSearchResults
  :: (Var v, Applicative m)
--- a/parser-typechecker/src/Unison/Server/Endpoints/FuzzyFind.hs
+++ b/parser-typechecker/src/Unison/Server/Endpoints/FuzzyFind.hs
@ -106,7 +106,7 @@ data FoundTerm = FoundTerm

 data FoundType = FoundType
  { bestFoundTypeName :: HashQualifiedName
-  , typeDef :: DisplayObject SyntaxText
+  , typeDef :: DisplayObject SyntaxText SyntaxText
  , namedType :: NamedType
  } deriving (Generic, Show)