Keep qualified names (#1392)

* keep qualified names

* add comment

* add pretty field to Abstract Name

* add test

* Add shell test

* Add another test

* fix shell test

Co-authored-by: Jonathan Cubides <jonathan.cubides@uib.no>

src/Juvix/Syntax/Abstract/Language/Extra.hs

@@ -272,5 +272,6 @@ freshVar n = do
       { _nameId = uid,
         _nameText = n,
         _nameKind = KNameLocal,
+        _namePretty = n,
         _nameLoc = error "freshVar with no location"
       }

src/Juvix/Syntax/Abstract/Name.hs

@@ -16,6 +16,7 @@ data Name = Name
   { _nameText :: Text,
     _nameId :: NameId,
     _nameKind :: NameKind,
+    _namePretty :: Text, -- How to print this name in error messages
     _nameLoc :: Interval
   }
   deriving stock (Show)
@@ -42,10 +43,20 @@ instance HasNameKind Name where
 
 instance Pretty Name where
   pretty n =
-    pretty (n ^. nameText)
+    pretty (n ^. namePretty)
       <> "@"
       <> pretty (n ^. nameId)
 
+prettyName :: HasNameKindAnn a => Bool -> Name -> Doc a
+prettyName showNameId n =
+  annotate
+    (annNameKind (n ^. nameKind))
+    (pretty (n ^. namePretty) <?> uid)
+  where
+    uid
+      | showNameId = Just ("@" <> pretty (n ^. nameId))
+      | otherwise = Nothing
+
 type FunctionName = Name
 
 type ConstructorName = Name

src/Juvix/Syntax/Abstract/Pretty/Ann.hs

@@ -1,11 +1,11 @@
 module Juvix.Syntax.Abstract.Pretty.Ann where
 
 import Juvix.Prelude
-import Juvix.Syntax.Concrete.Scoped.Name qualified as S
+import Juvix.Syntax.Concrete.Scoped.Name.NameKind
 import Juvix.Syntax.Concrete.Scoped.Pretty.Base qualified as S
 
 data Ann
-  = AnnKind S.NameKind
+  = AnnKind NameKind
   | AnnKeyword
   | AnnImportant
   | AnnLiteralString
@@ -21,3 +21,6 @@ fromScopedAnn s = case s of
   S.AnnRef {} -> Nothing
   S.AnnLiteralString -> Just AnnLiteralInteger
   S.AnnLiteralInteger -> Just AnnLiteralString
+
+instance HasNameKindAnn Ann where
+  annNameKind = AnnKind

src/Juvix/Syntax/Abstract/Pretty/Base.hs

@@ -159,14 +159,7 @@ instance PrettyCode NameId where
 instance PrettyCode Name where
   ppCode n = do
     showNameId <- asks (^. optShowNameIds)
-    uid <-
-      if
-          | showNameId -> Just . ("@" <>) <$> ppCode (n ^. nameId)
-          | otherwise -> return Nothing
-    return
-      $ annotate (AnnKind (n ^. nameKind))
-      $ pretty (n ^. nameText)
-      <?> uid
+    return (prettyName showNameId n)
 
 instance PrettyCode Function where
   ppCode Function {..} = do

src/Juvix/Syntax/Concrete/Name.hs

@@ -2,6 +2,7 @@ module Juvix.Syntax.Concrete.Name where
 
 import Data.List.NonEmpty.Extra qualified as NonEmpty
 import Juvix.Prelude
+import Juvix.Prelude.Pretty
 import Juvix.Syntax.Loc
 
 type Symbol = WithLoc Text
@@ -18,10 +19,23 @@ data Name
   deriving stock (Show, Eq, Ord)
 
 instance HasLoc Name where
-  getLoc n = case n of
+  getLoc = \case
     NameQualified q -> getLoc q
     NameUnqualified s -> getLoc s
 
+instance Pretty QualifiedName where
+  pretty (QualifiedName (Path path) s) =
+    let symbols = snoc (toList path) s
+     in dotted (map pretty symbols)
+    where
+      dotted :: Foldable f => f (Doc a) -> Doc a
+      dotted = concatWith (surround ".")
+
+instance Pretty Name where
+  pretty = \case
+    NameQualified q -> pretty q
+    NameUnqualified s -> pretty s
+
 newtype Path = Path
   { _pathParts :: NonEmpty Symbol
   }

src/Juvix/Syntax/Concrete/Scoped/Name.hs

@@ -6,6 +6,7 @@ module Juvix.Syntax.Concrete.Scoped.Name
 where
 
 import Juvix.Prelude
+import Juvix.Prelude.Pretty
 import Juvix.Syntax.Concrete.Name qualified as C
 import Juvix.Syntax.Concrete.Scoped.Name.NameKind
 import Juvix.Syntax.Concrete.Scoped.VisibilityAnn
@@ -90,6 +91,9 @@ instance HasNameKind (Name' n) where
 instance HasLoc n => HasLoc (Name' n) where
   getLoc = getLoc . (^. nameConcrete)
 
+instance Pretty a => Pretty (Name' a) where
+  pretty = pretty . (^. nameConcrete)
+
 data AName = forall c.
   HasLoc c =>
   AName

src/Juvix/Syntax/Concrete/Scoped/Name/NameKind.hs

@@ -24,6 +24,9 @@ data NameKind
 class HasNameKind a where
   getNameKind :: a -> NameKind
 
+class HasNameKindAnn a where
+  annNameKind :: NameKind -> a
+
 instance HasNameKind NameKind where
   getNameKind = id
 

src/Juvix/Syntax/MicroJuvix/Pretty/Ann.hs

@@ -7,3 +7,6 @@ data Ann
   | AnnKeyword
   | AnnLiteralString
   | AnnLiteralInteger
+
+instance HasNameKindAnn Ann where
+  annNameKind = AnnKind

src/Juvix/Syntax/MicroJuvix/Pretty/Base.hs

@@ -34,14 +34,7 @@ instance PrettyCode NameId where
 instance PrettyCode Name where
   ppCode n = do
     showNameId <- asks (^. optShowNameIds)
-    uid <-
-      if
-          | showNameId -> Just . ("@" <>) <$> ppCode (n ^. nameId)
-          | otherwise -> return Nothing
-    return
-      $ annotate (AnnKind (n ^. nameKind))
-      $ pretty (n ^. nameText)
-      <?> uid
+    return (prettyName showNameId n)
 
 instance PrettyCode Iden where
   ppCode :: Member (Reader Options) r => Iden -> Sem r (Doc Ann)

src/Juvix/Syntax/MicroJuvix/TypeChecker.hs

@@ -349,10 +349,13 @@ freshHole l = do
 literalType :: Members '[NameIdGen] r => LiteralLoc -> Sem r TypedExpression
 literalType l = do
   uid <- freshNameId
-  let typeVar =
+  let strA :: Text
+      strA = "A"
+      typeVar =
         Name
-          { _nameText = "A",
+          { _nameText = strA,
             _nameId = uid,
+            _namePretty = strA,
             _nameKind = KNameLocal,
             _nameLoc = getLoc l
           }

src/Juvix/Translation/MicroJuvixToMonoJuvix.hs

@@ -67,7 +67,7 @@ cloneName' n = do
   return (set Micro.nameId fresh n)
 
 cloneName :: Members '[NameIdGen] r => Micro.Name -> Sem r Name
-cloneName n = goName <$> cloneName' n
+cloneName n = cloneName' n
 
 addConcreteInfo :: NonEmpty Micro.ConcreteType -> ConcreteIdenInfo -> Maybe PolyIdenInfo -> PolyIdenInfo
 addConcreteInfo t c = \case
@@ -164,7 +164,7 @@ goModule Micro.Module {..} = do
   _moduleBody' <- goModuleBody _moduleBody
   return
     Module
-      { _moduleName = goName _moduleName,
+      { _moduleName = _moduleName,
         _moduleBody = _moduleBody'
       }
 
@@ -199,20 +199,11 @@ goAxiomDef Micro.AxiomDef {..} = do
   let _axiomBuiltin' = _axiomBuiltin
   return
     AxiomDef
-      { _axiomName = goName _axiomName,
+      { _axiomName = _axiomName,
         _axiomBuiltin = _axiomBuiltin',
         _axiomType = _axiomType'
       }
 
-goName :: Micro.Name -> Name
-goName n =
-  Name
-    { _nameText = n ^. Micro.nameText,
-      _nameId = n ^. Micro.nameId,
-      _nameLoc = n ^. Micro.nameLoc,
-      _nameKind = n ^. Micro.nameKind
-    }
-
 lookupPolyConstructor ::
   Members '[Reader ConcreteTable] r =>
   Micro.ConstructorName ->
@@ -267,7 +258,7 @@ goInductiveDefConcrete def = do
   constructors' <- mapM goConstructor (def ^. Micro.inductiveConstructors)
   return
     InductiveDef
-      { _inductiveName = goName (def ^. Micro.inductiveName),
+      { _inductiveName = def ^. Micro.inductiveName,
         _inductiveBuiltin = def ^. Micro.inductiveBuiltin,
         _inductiveConstructors = constructors'
       }
@@ -277,7 +268,7 @@ goInductiveDefConcrete def = do
       params' <- mapM (goType . Micro.mkConcreteType') (c ^. Micro.constructorParameters)
       return
         InductiveConstructorDef
-          { _constructorName = goName (c ^. Micro.constructorName),
+          { _constructorName = c ^. Micro.constructorName,
             _constructorParameters = params'
           }
 
@@ -327,10 +318,10 @@ goExpression = go
               return (foldApplication fun' tailArgs')
     goIden :: Micro.Iden -> Iden
     goIden = \case
-      Micro.IdenFunction f -> IdenFunction (goName f)
-      Micro.IdenVar v -> IdenVar (goName v)
-      Micro.IdenAxiom a -> IdenAxiom (goName a)
-      Micro.IdenConstructor c -> IdenConstructor (goName c)
+      Micro.IdenFunction f -> IdenFunction f
+      Micro.IdenVar v -> IdenVar v
+      Micro.IdenAxiom a -> IdenAxiom a
+      Micro.IdenConstructor c -> IdenConstructor c
       Micro.IdenInductive {} -> impossible
 
 goFunctionDefConcrete ::
@@ -351,7 +342,7 @@ goFunctionDefConcrete n d = do
       }
   where
     funName :: Name
-    funName = fromMaybe (goName (d ^. Micro.funDefName)) n
+    funName = fromMaybe (d ^. Micro.funDefName) n
     concreteTy :: Micro.ConcreteType
     concreteTy = Micro.mkConcreteType' (d ^. Micro.funDefType)
     patternTys :: [Micro.ConcreteType]
@@ -460,7 +451,7 @@ goPatternArg ty = goPattern ty . (^. Micro.patternArgPattern)
 
 goPattern :: forall r. Members '[Reader ConcreteTable, Reader Micro.InfoTable] r => Micro.ConcreteType -> Micro.Pattern -> Sem r Pattern
 goPattern ty = \case
-  Micro.PatternVariable v -> return (PatternVariable (goName v))
+  Micro.PatternVariable v -> return (PatternVariable v)
   Micro.PatternConstructorApp capp -> PatternConstructorApp <$> goApp capp
   Micro.PatternWildcard {} -> return PatternWildcard
   where
@@ -468,7 +459,7 @@ goPattern ty = \case
     goApp capp = case ty ^. Micro.unconcreteType of
       Micro.ExpressionIden Micro.IdenInductive {} -> do
         let c' :: Name
-            c' = goName (capp ^. Micro.constrAppConstructor)
+            c' = capp ^. Micro.constrAppConstructor
         cInfo <- Micro.lookupConstructor (capp ^. Micro.constrAppConstructor)
         let psTysConcrete = map Micro.mkConcreteType' (cInfo ^. Micro.constructorInfoArgs)
         ps' <- zipWithM goPatternArg psTysConcrete (capp ^. Micro.constrAppParameters)
@@ -535,8 +526,8 @@ goType = go . (^. Micro.unconcreteType)
       return (Function l' r')
     goIden :: Micro.Iden -> TypeIden
     goIden = \case
-      Micro.IdenAxiom a -> TypeIdenAxiom (goName a)
-      Micro.IdenInductive i -> TypeIdenInductive (goName i)
+      Micro.IdenAxiom a -> TypeIdenAxiom a
+      Micro.IdenInductive i -> TypeIdenInductive i
       Micro.IdenVar {} -> impossible
       Micro.IdenFunction {} -> impossible
       Micro.IdenConstructor {} -> impossible

src/Juvix/Translation/ScopedToAbstract.hs

@@ -8,6 +8,7 @@ import Data.HashMap.Strict qualified as HashMap
 import Juvix.Builtins
 import Juvix.Internal.NameIdGen
 import Juvix.Prelude
+import Juvix.Prelude.Pretty
 import Juvix.Syntax.Abstract.AbstractResult
 import Juvix.Syntax.Abstract.InfoTableBuilder
 import Juvix.Syntax.Abstract.Language qualified as Abstract
@@ -73,7 +74,11 @@ goModule m = case sing :: SModuleIsTop t of
           SModuleLocal -> goSymbol n
 
 goName :: S.Name -> Abstract.Name
-goName = goSymbol . S.nameUnqualify
+goName name =
+  set Abstract.namePretty prettyStr (goSymbol (S.nameUnqualify name))
+  where
+    prettyStr :: Text
+    prettyStr = prettyText name
 
 goSymbol :: S.Symbol -> Abstract.Name
 goSymbol s =
@@ -81,6 +86,7 @@ goSymbol s =
     { _nameText = S.symbolText s,
       _nameId = s ^. S.nameId,
       _nameKind = getNameKind s,
+      _namePretty = S.symbolText s,
       _nameLoc = s ^. S.nameConcrete . symbolLoc
     }
 

tests/negative/issue1344/D.juvix

@@ -0,0 +1,8 @@
+module D;
+  import Other;
+  import U;
+
+  u : Other.Unit;
+  u ≔ U.t;
+
+end;

tests/negative/issue1344/M.juvix

@@ -0,0 +1,11 @@
+module M;
+  import Other;
+
+  inductive Unit {
+  t : Unit;
+  };
+
+  u : Other.Unit;
+  u ≔ t;
+
+end;

tests/negative/issue1344/Other.juvix

@@ -0,0 +1,7 @@
+module Other;
+
+  inductive Unit {
+  t : Unit;
+  };
+
+end;

tests/negative/issue1344/U.juvix

@@ -0,0 +1,6 @@
+module U;
+  inductive Unit {
+    t : Unit;
+  };
+  
+end;

tests/negative/issue1344/errorD.test

@@ -0,0 +1,8 @@
+$ juvix typecheck tests/negative/issue1344/D.juvix --no-colors
+>2 /.*\.juvix\:[0-9]+\:[0-9]+\-[0-9]+\: error\:
+The expression U.t has type:
+  Unit
+but is expected to have type:
+  Other.Unit
+/
+>= 1

tests/negative/issue1344/errorM.test

@@ -0,0 +1,8 @@
+$ juvix typecheck tests/negative/issue1344/M.juvix --no-colors
+>2 /.*\.juvix\:[0-9]+\:[0-9]+\-[0-9]+\: error\:
+The expression t has type:
+  Unit
+but is expected to have type:
+  Other.Unit
+/
+>= 1