refactors

app/Main.hs

@@ -8,6 +8,7 @@ module Main (
 import Control.Lens
 import Elara.AST.Module
 import Elara.AST.Select
+import Elara.Data.Pretty
 import Elara.Desugar (desugar, runDesugar)
 import Elara.Error
 import Elara.Error.Codes qualified as Codes (fileReadError)
@@ -20,23 +21,25 @@ import Elara.Rename (ModulePath, rename, runRenamer)
 import Elara.Shunt
 import Elara.TypeInfer qualified as Infer
 import Elara.TypeInfer.Infer (initialStatus)
-import Error.Diagnose (Diagnostic, Report (Err), defaultStyle, printDiagnostic)
+import Error.Diagnose (Diagnostic, Report (Err), defaultStyle, prettyDiagnostic)
 import Polysemy (Embed, Member, Sem, runM, subsume_)
+import Polysemy.Embed
 import Polysemy.Error
 import Polysemy.Maybe (MaybeE, justE, nothingE, runMaybe)
 import Polysemy.Reader
 import Polysemy.State
 import Polysemy.Writer (runWriter)
 import Prettyprinter.Render.Text
-import Elara.Data.Pretty
-import Polysemy.Embed
 
 main :: IO ()
 main = do
   s <- runElara
-  printDiagnostic stdout True True 4 defaultStyle s
+  putDoc (prettyDiagnostic True 4 s)
+  putStrLn ""
+
+
 
-runElara :: IO (Diagnostic Text)
+runElara :: IO (Diagnostic (Doc ann))
 runElara = runM $ execDiagnosticWriter $ runMaybe $ do
   source <- loadModule "source.elr"
   prelude <- loadModule "prelude.elr"
@@ -48,17 +51,17 @@ runElara = runM $ execDiagnosticWriter $ runMaybe $ do
   putStrLn ""
   pass
 
-readFileString :: (Member (Embed IO) r, Member (DiagnosticWriter Text) r, Member MaybeE r) => FilePath -> Sem r String
+readFileString :: (Member (Embed IO) r, Member (DiagnosticWriter (Doc ann)) r, Member MaybeE r) => FilePath -> Sem r String
 readFileString path = do
   contentsBS <- readFileBS path
   case decodeUtf8Strict contentsBS of
     Left err -> do
-      writeReport (Err (Just Codes.fileReadError) ("Could not read " <> toText path <> ": " <> show err) [] []) *> nothingE
+      writeReport (Err (Just Codes.fileReadError) ("Could not read " <> pretty path <> ": " <> show err) [] []) *> nothingE
     Right contents -> do
       addFile path contents
       justE contents
 
-lexFile :: (Member (Embed IO) r, Member (DiagnosticWriter Text) r, Member MaybeE r) => FilePath -> Sem r (String, [Lexeme])
+lexFile :: (Member (Embed IO) r, Member (DiagnosticWriter (Doc ann)) r, Member MaybeE r) => FilePath -> Sem r (String, [Lexeme])
 lexFile path = do
   contents <- readFileString path
   case evalLexMonad path contents readTokens of
@@ -67,22 +70,22 @@ lexFile path = do
       -- embed (printColored (fmap (view unlocated) lexemes)) -- DEBUG
       justE (contents, lexemes)
 
-parseModule :: (Member (DiagnosticWriter Text) r, Member MaybeE r) => FilePath -> (String, [Lexeme]) -> Sem r (Module Frontend)
+parseModule :: (Member (DiagnosticWriter (Doc ann)) r, Member MaybeE r) => FilePath -> (String, [Lexeme]) -> Sem r (Module Frontend)
 parseModule path (contents, lexemes) = do
   let tokenStream = TokenStream contents lexemes
   case parse path tokenStream of
     Left parseError -> do
       report parseError *> nothingE
     Right m -> justE m
 
-desugarModule :: (Member (DiagnosticWriter Text) r, Member MaybeE r) => Module Frontend -> Sem r (Module Desugared)
+desugarModule :: (Member (DiagnosticWriter (Doc ann)) r, Member MaybeE r) => Module Frontend -> Sem r (Module Desugared)
 desugarModule m = do
   case runDesugar (desugar m) of
     Left err -> report err *> nothingE
     Right desugared -> justE desugared
 
 renameModule ::
-  (Member (DiagnosticWriter Text) r, Member MaybeE r, Member (Embed IO) r) =>
+  (Member (DiagnosticWriter (Doc ann)) r, Member MaybeE r, Member (Embed IO) r) =>
   ModulePath ->
   Module Desugared ->
   Sem r (Module Renamed)
@@ -92,7 +95,7 @@ renameModule mp m = do
     Left err -> report err *> nothingE
     Right renamed -> justE renamed
 
-shuntModule :: (Member (DiagnosticWriter Text) r, Member MaybeE r) => Module Renamed -> Sem r (Module Shunted)
+shuntModule :: (Member (DiagnosticWriter (Doc ann)) r, Member MaybeE r) => Module Renamed -> Sem r (Module Shunted)
 shuntModule m = do
   x <-
     runError $
@@ -104,16 +107,18 @@ shuntModule m = do
       traverse_ report warnings
       justE shunted
 
-inferModule :: (Member (DiagnosticWriter Text) r, Member MaybeE r, Member (Embed IO) r) => Module Shunted -> Sem r (Module _)
+inferModule ::
+  (Member (DiagnosticWriter (Doc ann)) r, Member MaybeE r) =>
+  Module Shunted ->
+  Sem r (Module Typed)
 inferModule m = do
   runErrorOrReport (evalState initialStatus (Infer.inferModule m))
 
-loadModule :: (Member (DiagnosticWriter Text) r, Member (Embed IO) r, Member MaybeE r) => FilePath -> Sem r (Module Desugared)
+loadModule :: (Member (DiagnosticWriter (Doc ann)) r, Member (Embed IO) r, Member MaybeE r) => FilePath -> Sem r (Module Desugared)
 loadModule fp = (lexFile >=> parseModule fp >=> desugarModule) fp
 
 runErrorOrReport ::
-  forall e r a.
-  (Member (DiagnosticWriter Text) r, Member MaybeE r, ReportableError e) =>
+  (Member (DiagnosticWriter (Doc ann)) r, Member MaybeE r, ReportableError e) =>
   Sem (Error e ': r) a ->
   Sem r a
 runErrorOrReport e = do

elara.cabal

@@ -41,6 +41,7 @@ library
       Elara.AST.Unlocated.Typed
       Elara.Data.Pretty
       Elara.Data.Unique
+      Elara.Data.Unwrap
       Elara.Desugar
       Elara.Error
       Elara.Error.Codes

src/Elara/AST/Shunted.hs

@@ -5,8 +5,10 @@ module Elara.AST.Shunted where
 
 import Control.Lens (makeLenses, makePrisms)
 import Elara.AST.Name
-import Elara.AST.Region (IgnoreLocation (..), Located (..), SourceRegion)
+import Elara.AST.Region (IgnoreLocation (..), Located (..))
+import Elara.Data.Pretty
 import Elara.Data.Unique
+import Elara.Data.Unwrap (Unwrap (unwrap))
 import Prelude hiding (Op)
 
 {- | Shunted AST Type
@@ -122,9 +124,14 @@ data DeclarationBody'
 
 makePrisms ''Declaration
 makeLenses ''Declaration'
+makePrisms ''Declaration'
 makePrisms ''DeclarationBody
 makePrisms ''DeclarationBody'
 makeLenses ''DeclarationBody
 makeLenses ''DeclarationBody'
 makePrisms ''Expr
 makePrisms ''Pattern
+
+instance (Unwrap c, Pretty n) => Pretty (VarRef' c n) where
+    pretty (Global n) = pretty (unwrap n)
+    pretty (Local n) = pretty (unwrap n)

src/Elara/AST/Typed.hs

@@ -6,8 +6,8 @@ module Elara.AST.Typed where
 import Control.Lens hiding (List)
 import Control.Lens.Extras (uniplate)
 import Data.Data (Data)
-import Elara.AST.Name (LowerAlphaName, ModuleName, Name, Qualified, TypeName, VarName)
-import Elara.AST.Region (Located (Located), SourceRegion, generatedSourceRegion, unlocated)
+import Elara.AST.Name (ModuleName, Name, Qualified, TypeName, VarName)
+import Elara.AST.Region (Located (Located), generatedSourceRegion, unlocated)
 import Elara.AST.StripLocation (StripLocation (stripLocation))
 import Elara.AST.Unlocated.Typed qualified as Unlocated
 import Elara.Data.Pretty

src/Elara/Data/Pretty.hs

@@ -6,10 +6,12 @@ module Elara.Data.Pretty (
     parensIf,
     PrettyPrec (..),
     module Prettyprinter,
+    module Prettyprinter.Render.Terminal,
 ) where
 
 import Data.Map qualified as Map (toList)
 import Prettyprinter
+import Prettyprinter.Render.Terminal (AnsiStyle)
 
 indentDepth :: Int
 indentDepth = 4
@@ -40,4 +42,7 @@ instance (Pretty k, Pretty v) => Pretty (Map k v) where
     pretty m = pretty (Map.toList m)
 
 instance (Pretty s) => Pretty (Set s) where
-    pretty s = "{" <> hsep (punctuate "," (pretty <$> toList s)) <> "}"
+    pretty s = "{" <> hsep (punctuate "," (pretty <$> toList s)) <> "}"
+
+instance Pretty (Doc ann) where
+    pretty = unAnnotate -- TODO: make this good

src/Elara/Data/Unwrap.hs

@@ -0,0 +1,15 @@
+module Elara.Data.Unwrap where
+
+import Elara.AST.Region (IgnoreLocation (IgnoreLocation), Located (Located))
+
+class Unwrap c where
+    unwrap :: c a -> a
+
+instance Unwrap Identity where
+    unwrap (Identity a) = a
+
+instance Unwrap Located where
+    unwrap (Located _ a) = a
+
+instance Unwrap IgnoreLocation where
+    unwrap (IgnoreLocation a) = unwrap a

src/Elara/Desugar.hs

@@ -10,6 +10,7 @@ import Elara.AST.Module
 import Elara.AST.Name hiding (name)
 import Elara.AST.Region
 import Elara.AST.Select
+import Elara.Data.Pretty
 import Elara.Error (ReportableError (report), writeReport)
 import Elara.Error.Codes qualified as Codes
 import Error.Diagnose (Report (Err))

src/Elara/Error.hs

@@ -5,10 +5,12 @@ module Elara.Error (ReportableError (..), addPosition, concatDiagnostics, module
 import Elara.Error.Effect
 import Error.Diagnose
 import Polysemy
+import Prettyprinter (Doc)
+import Prettyprinter.Render.Terminal (AnsiStyle)
 import Prelude hiding (asks, readFile)
 
 class ReportableError e where
-    report :: (Member (DiagnosticWriter Text) r) => e -> Sem r ()
+    report :: (Member (DiagnosticWriter (Doc ann)) r) => e -> Sem r ()
 
 addPosition :: (Position, Marker msg) -> Report msg -> Report msg
 addPosition marker (Err code m markers notes) = Err code m (marker : markers) notes

src/Elara/Error/Codes.hs

@@ -1,5 +1,7 @@
 module Elara.Error.Codes where
 
+import Elara.Data.Pretty
+
 {- | A type for error codes.
 While not enforced, error codes should follow a standard format consisting of the following components
 
@@ -16,7 +18,7 @@ The first digit signals the stage in which the error was thrown:
 The remaining digits are arbitrary and should be incremented for each new error or warning.
 They should be unique overall, but don't have to be unique within a stage or category. For example @E1001@, @E0001@, and @W1001@ can all exist at once.
 -}
-type ErrorCode = Text
+type ErrorCode = forall ann. Doc ann
 
 fileReadError :: ErrorCode
 fileReadError = "E0001"

src/Elara/Error/Effect.hs

@@ -7,7 +7,7 @@ import Error.Diagnose.Diagnostic as Diagnostic (Diagnostic, addFile, addReport)
 import Error.Diagnose.Report (Report)
 import Polysemy
 import Polysemy.State
-import Prelude hiding (modify', runState)
+import Prelude hiding (modify')
 
 {- | Essentially a very specialised Writer effect for Diagnostics, but safer
 | Because the Semigroup instance for Diagnostics is a little funky, there's a chance of accidentally overwriting the

src/Elara/Parse/Error.hs

@@ -6,20 +6,21 @@
 
 module Elara.Parse.Error where
 
+import Elara.Lexer.Token (Lexeme)
 import Error.Diagnose
 import Error.Diagnose.Compat.Megaparsec (HasHints (..))
 import Text.Megaparsec qualified as MP
 import Text.Megaparsec.Error
 import Prelude hiding (error, lines)
-import Elara.Lexer.Token (Lexeme)
 
 import Control.Lens (to, view)
 import Data.Foldable (Foldable (foldl))
 import Data.List (lines)
 import Data.Set qualified as Set (toList)
+import Elara.AST.Name (MaybeQualified, NameLike (nameText), VarName)
 import Elara.AST.Region (Located, SourceRegion, sourceRegion, sourceRegionToDiagnosePosition, unlocated)
+import Elara.Data.Pretty
 import Elara.Error
-import Elara.AST.Name (MaybeQualified, NameLike (nameText), VarName)
 import Elara.Parse.Stream (TokenStream)
 import Prelude hiding (error, lines)
 
@@ -32,9 +33,9 @@ parseErrorSources :: ElaraParseError -> [SourceRegion]
 parseErrorSources (KeywordUsedAsName l) = [view sourceRegion l]
 parseErrorSources (EmptyRecord sr) = [sr]
 
-instance HasHints ElaraParseError Text where
+instance HasHints ElaraParseError (Doc ann) where
     hints (KeywordUsedAsName kw) =
-        [ Note (view (unlocated . to nameText) kw <> " is a keyword which can only be used in certain contexts. However, it was used as a name here.")
+        [ Note (view (unlocated . to pretty) kw <+> "is a keyword which can only be used in certain contexts. However, it was used as a name here.")
         , Hint "Try using a different name"
         ]
     hints (EmptyRecord _) =

src/Elara/Rename.hs

@@ -27,6 +27,7 @@ import Elara.AST.Region (Located (Located), enclosingRegion', sourceRegion, sour
 import Elara.AST.Renamed (VarRef (..))
 import Elara.AST.Renamed qualified as Renamed
 import Elara.AST.Select (Desugared, HasModuleName (..), HasName (..), Renamed)
+import Elara.Data.Pretty
 import Elara.Data.Unique (Unique, UniqueGen, makeUnique, uniqueGenToIO)
 import Elara.Error (ReportableError (report), writeReport)
 import Elara.Error.Codes qualified as Codes (nonExistentModuleDeclaration, unknownModule)
@@ -57,15 +58,15 @@ instance ReportableError RenameError where
         writeReport $
             Err
                 Nothing
-                ("Qualified name in wrong module: " <> show m1 <> " in " <> show m2)
+                ("Qualified name in wrong module:" <+> show m1 <+> "in" <+> show m2)
                 []
                 []
     report (NonExistentModuleDeclaration m n) =
         let nPos = sourceRegionToDiagnosePosition (n ^. sourceRegion)
          in writeReport $
                 Err
                     (Just Codes.nonExistentModuleDeclaration)
-                    ("Element " <> (n ^. unlocated . to nameText) <> " does not exist in in module " <> nameText m)
+                    ("Element" <+> (n ^. unlocated . to pretty) <+> "does not exist in in module" <+> pretty m)
                     [(nPos, This "referenced here")]
                     []
     report (UnknownName n) =

src/Elara/Shunt.hs

@@ -14,6 +14,7 @@ import Elara.AST.Region qualified as Located
 import Elara.AST.Renamed qualified as Renamed
 import Elara.AST.Select
 import Elara.AST.Shunted qualified as Shunted
+import Elara.Data.Pretty
 import Elara.Error (ReportableError (..))
 import Elara.Error.Codes qualified as Codes
 import Elara.Error.Effect (writeReport)
@@ -77,7 +78,7 @@ instance ReportableError ShuntWarning where
         writeReport $
             Warn
                 (Just Codes.unknownPrecedence)
-                ("Unknown precedence/associativity for operator " <> operatorName (lOperator ^. unlocated) <> ". The system will assume it has the highest precedence (9) and left associativity, but you should specify it manually. ")
+                ("Unknown precedence/associativity for operator" <+> pretty (operatorName (lOperator ^. unlocated)) <> ". The system will assume it has the highest precedence (9) and left associativity, but you should specify it manually. ")
                 [(opSrc, This "operator")]
                 [Hint "Define the precedence and associativity of the operator explicitly"]