From c9b0193fb456d2bf6bba397472f4c5c1a72ee525 Mon Sep 17 00:00:00 2001
From: Paul Cadman <git@paulcadman.dev>
Date: Fri, 1 Apr 2022 10:04:48 +0100
Subject: [PATCH] [typecheck] Add the definition loc to microjuvix names

This is used in type errors
---
 src/MiniJuvix/Syntax/MicroJuvix/Error/Pretty/Base.hs | 11 +++++++++--
 src/MiniJuvix/Syntax/MicroJuvix/Language.hs          |  5 +++--
 src/MiniJuvix/Translation/AbstractToMicroJuvix.hs    |  5 +++--
 3 files changed, 15 insertions(+), 6 deletions(-)

diff --git a/src/MiniJuvix/Syntax/MicroJuvix/Error/Pretty/Base.hs b/src/MiniJuvix/Syntax/MicroJuvix/Error/Pretty/Base.hs
index 856cad993..27c06e8fe 100644
--- a/src/MiniJuvix/Syntax/MicroJuvix/Error/Pretty/Base.hs
+++ b/src/MiniJuvix/Syntax/MicroJuvix/Error/Pretty/Base.hs
@@ -18,6 +18,9 @@ indent' = indent 2
 prettyT :: Text -> Doc Eann
 prettyT = pretty
 
+highlight :: Doc Eann -> Doc Eann
+highlight = annotate Highlight
+
 class PrettyError e where
   ppError :: e -> Doc Eann
 
@@ -58,8 +61,12 @@ instance PrettyError ExpectedFunctionType where
     <> line <> indent' (ppCode (e ^. expectedFunctionTypeType))
 
 instance PrettyError TooManyPatterns where
-  ppError e = "Type error in the definition of" <+> ppCode (e ^. tooManyPatternsClause . clauseName) <> "."
-    <> line <> "The function clause:"
+  ppError e = "Type error near" <+> highlight (pretty (name ^. nameDefined))
+    <> line <> "In in the definition of" <+> ppCode name <+> "the function clause:"
     <> line <> indent' (ppCode (e ^. tooManyPatternsClause))
     <> line <> "matches too many patterns. It should match the following types:"
     <> line <> indent' (hsep (ppCode <$> (e ^. tooManyPatternsTypes)))
+
+    where
+      name :: Name
+      name =  (e ^. tooManyPatternsClause . clauseName)
diff --git a/src/MiniJuvix/Syntax/MicroJuvix/Language.hs b/src/MiniJuvix/Syntax/MicroJuvix/Language.hs
index c340e7460..2af7c1a22 100644
--- a/src/MiniJuvix/Syntax/MicroJuvix/Language.hs
+++ b/src/MiniJuvix/Syntax/MicroJuvix/Language.hs
@@ -11,6 +11,7 @@ import MiniJuvix.Syntax.ForeignBlock
 import MiniJuvix.Syntax.Backends
 import MiniJuvix.Syntax.Concrete.Scoped.Name (NameId (..))
 import MiniJuvix.Syntax.Concrete.Scoped.Name.NameKind
+import qualified MiniJuvix.Syntax.Concrete.Language as C
 import MiniJuvix.Syntax.Concrete.Literal
 import MiniJuvix.Syntax.Fixity
 import Prettyprinter
@@ -28,8 +29,8 @@ type InductiveName = Name
 data Name = Name
   { _nameText :: Text,
     _nameId :: NameId,
-    _nameKind :: NameKind
-    -- TODO: Add Location here so we can print out line numbers
+    _nameKind :: NameKind,
+    _nameDefined :: C.Interval
   }
   deriving stock (Show)
 
diff --git a/src/MiniJuvix/Translation/AbstractToMicroJuvix.hs b/src/MiniJuvix/Translation/AbstractToMicroJuvix.hs
index 0021f9516..0621c7e77 100644
--- a/src/MiniJuvix/Translation/AbstractToMicroJuvix.hs
+++ b/src/MiniJuvix/Translation/AbstractToMicroJuvix.hs
@@ -24,8 +24,9 @@ goSymbol :: S.Symbol -> Name
 goSymbol s =
   Name
     { _nameText = S.symbolText s,
-      _nameId = S._nameId s,
-      _nameKind = getNameKind s }
+      _nameId = s ^. S.nameId,
+      _nameKind = getNameKind s,
+      _nameDefined = s ^. S.nameDefined}
 
 unsupported :: Text -> a
 unsupported thing = error ("Abstract to MicroJuvix: Not yet supported: " <> thing)