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)