check

app/Commands/Dev/ImportTree/ScanFile.hs

@@ -1,21 +1,56 @@
-module Commands.Dev.ImportTree.ScanFile where
+module Commands.Dev.ImportTree.ScanFile (runCommand) where
 
 import Commands.Base
 import Commands.Dev.ImportTree.ScanFile.Options
+import Data.Yaml qualified as Yaml
 import Juvix.Compiler.Concrete.Print
 import Juvix.Compiler.Concrete.Translation.ImportScanner
 
 runCommand :: (Members AppEffects r) => ScanFileOptions -> Sem r ()
-runCommand ScanFileOptions {..} =
+runCommand opts@ScanFileOptions {..} =
   runFilesIO
     . runAppError @ParserError
     . runReader _scanFileStrategy
     $ do
-      scanRes <- fromAppPathFile _scanFileFile >>= scanFileImports
-      forM_ (scanRes ^. scanResultImports) $ \impor -> do
-        opts <- askGenericOptions
-        renderStdOut (ppOutNoComments opts impor)
-        when _scanFilePrintLoc $ do
-          renderStdOut @Text " "
-          renderStdOut (ppOutNoComments opts (getLoc impor))
-        newline
+      p <- fromAppPathFile _scanFileFile
+      scanRes <- scanFileImports p
+      printRes opts scanRes
+      when _scanFileCheck (check p scanRes)
+
+printRes :: (Members (AppEffects) r) => ScanFileOptions -> ScanResult -> Sem r ()
+printRes ScanFileOptions {..} scanRes = do
+  forM_ (scanRes ^. scanResultImports) $ \impor -> do
+    opts <- askGenericOptions
+    renderStdOut (ppOutNoComments opts impor)
+    when _scanFilePrintLoc $ do
+      renderStdOut @Text " "
+      renderStdOut (ppOutNoComments opts (getLoc impor))
+    newline
+
+check :: (Members (Reader ImportScanStrategy ': AppEffects) r) => Path Abs File -> ScanResult -> Sem r ()
+check file reference = runAppError @ParserError $ do
+  refStrat :: ImportScanStrategy <- ask
+  forM_ allElements $ \strat -> when (refStrat /= strat) . local (const strat) $ do
+    res <- scanFileImports file
+    let yamlFile :: ImportScanStrategy -> Path Abs File
+        yamlFile s = replaceExtensions' ["." <> show s, ".yaml"] file
+    let err :: AnsiText
+        err =
+          mkAnsiText @Text $
+            prettyText refStrat
+              <> " and "
+              <> prettyText strat
+              <> " don't match"
+              <> "\n"
+              <> prettyText refStrat
+              <> " written to:\n"
+              <> toFilePath (yamlFile refStrat)
+              <> "\n"
+              <> prettyText strat
+              <> " written to:\n"
+              <> toFilePath (yamlFile strat)
+              <> "\n"
+    unless (res == reference) $ do
+      liftIO (Yaml.encodeFile (toFilePath (yamlFile refStrat)) reference)
+      liftIO (Yaml.encodeFile (toFilePath (yamlFile strat)) res)
+      logErrorWithTag err

app/Commands/Dev/ImportTree/ScanFile/Options.hs

@@ -6,6 +6,7 @@ import Juvix.Compiler.Concrete.Translation.ImportScanner
 data ScanFileOptions = ScanFileOptions
   { _scanFileFile :: AppPath File,
     _scanFilePrintLoc :: Bool,
+    _scanFileCheck :: Bool,
     _scanFileStrategy :: ImportScanStrategy
   }
   deriving stock (Data)
@@ -21,4 +22,9 @@ parseScanFile = do
       ( long "print-loc"
           <> help "Print the location of each import"
       )
+  _scanFileCheck <-
+    switch
+      ( long "check"
+          <> help "Checks that the rest of the backends coincide"
+      )
   pure ScanFileOptions {..}

src/Juvix/Compiler/Backend/Html/Translation/FromTyped/Source.hs

@@ -325,6 +325,7 @@ putTag ann x = case ann of
   AnnUnkindedSym -> return (Html.span ! juClass JuVar $ x)
   AnnComment -> return (Html.span ! juClass JuComment $ x)
   AnnPragma -> return (Html.span ! juClass JuComment $ x)
+  AnnError -> return (Html.span ! juClass JuAxiom $ x)
   AnnJudoc -> return (Html.span ! juClass JuJudoc $ x)
   AnnDelimiter -> return (Html.span ! juClass JuDelimiter $ x)
   AnnDef r -> boldDefine <*> tagDef r

src/Juvix/Compiler/Backend/Latex/Translation/FromScoped/Source.hs

@@ -109,6 +109,7 @@ putTag ann x = case ann of
   AnnJudoc -> juColor JuJudoc x
   AnnDelimiter -> juColor JuDelimiter x
   AnnPragma -> juColor JuComment x
+  AnnError -> juColor JuAxiom x
   AnnDef {} -> x
   AnnRef {} -> x
   AnnCode -> x

src/Juvix/Compiler/Concrete/Data/Highlight.hs

@@ -62,23 +62,7 @@ goDefProperty n = do
       }
 
 goFaceSemanticItem :: SemanticItem -> Maybe (WithLoc PropertyFace)
-goFaceSemanticItem i = WithLoc (getLoc i) . PropertyFace <$> f
-  where
-    f :: Maybe Face
-    f = case i ^. withLocParam of
-      AnnKind k -> nameKindFace k
-      AnnKeyword -> Just FaceKeyword
-      AnnComment -> Just FaceComment
-      AnnPragma -> Just FacePragma
-      AnnJudoc -> Just FaceJudoc
-      AnnDelimiter -> Just FaceDelimiter
-      AnnLiteralString -> Just FaceString
-      AnnLiteralInteger -> Just FaceNumber
-      AnnCode -> Nothing
-      AnnImportant -> Nothing
-      AnnUnkindedSym -> Nothing
-      AnnDef {} -> Nothing
-      AnnRef {} -> Nothing
+goFaceSemanticItem i = fmap PropertyFace <$> mapM codeAnnFace i
 
 goFaceParsedItem :: ParsedItem -> WithLoc PropertyFace
 goFaceParsedItem i = WithLoc (i ^. parsedLoc) (PropertyFace f)

src/Juvix/Compiler/Concrete/Translation/ImportScanner.hs

@@ -18,6 +18,9 @@ data ImportScanStrategy
   | ImportScanStrategyMegaparsec
   deriving stock (Eq, Data, Ord, Enum, Bounded)
 
+instance Pretty ImportScanStrategy where
+  pretty = Juvix.Prelude.show
+
 instance Show ImportScanStrategy where
   show :: ImportScanStrategy -> String
   show = \case

src/Juvix/Data/CodeAnn.hs

@@ -38,6 +38,7 @@ data CodeAnn
   | AnnJudoc
   | AnnImportant
   | AnnDelimiter
+  | AnnError
   | AnnLiteralString
   | AnnLiteralInteger
   | AnnUnkindedSym
@@ -70,6 +71,7 @@ stylize a = case a of
   AnnJudoc -> colorDull Cyan
   AnnDelimiter -> colorDull White
   AnnLiteralString -> colorDull Red
+  AnnError -> colorDull Red
   AnnLiteralInteger -> colorDull Green
   AnnDef {} -> mempty
   AnnRef {} -> mempty

src/Juvix/Data/Effect/Logger.hs

@@ -7,6 +7,7 @@ module Juvix.Data.Effect.Logger
     LogLevel (..),
     logMessage,
     logError,
+    logErrorWithTag,
     logVerbose,
     logProgress,
     logInfo,
@@ -21,10 +22,10 @@ module Juvix.Data.Effect.Logger
   )
 where
 
+import Juvix.Data.CodeAnn
 import Juvix.Prelude.Base.Foundation
 import Juvix.Prelude.Effects.Base
 import Juvix.Prelude.Effects.Output
-import Juvix.Prelude.Pretty
 import Prelude (show)
 
 data LogLevel
@@ -77,6 +78,18 @@ defaultLoggerOptions =
 makeSem ''Logger
 makeLenses ''LoggerOptions
 
+logTag :: LogLevel -> Doc CodeAnn
+logTag = \case
+  LogLevelError -> annotate AnnError "[Error]"
+  LogLevelWarn -> "[Warn]"
+  LogLevelInfo -> "[Info]"
+  LogLevelProgress -> "[Progress]"
+  LogLevelVerbose -> "[Verbose]"
+  LogLevelDebug -> "[Debug]"
+
+logErrorWithTag :: (Members '[Logger] r) => AnsiText -> Sem r ()
+logErrorWithTag msg = logError (mkAnsiText (logTag LogLevelError <> " ") <> msg)
+
 logError :: (Members '[Logger] r) => AnsiText -> Sem r ()
 logError = logMessage LogLevelError
 

src/Juvix/Data/ImportScan.hs

@@ -1,11 +1,13 @@
 module Juvix.Data.ImportScan where
 
+import Data.HashSet qualified as HashSet
 import FlatParse.Basic
 import Juvix.Compiler.Concrete.Data.Name
 import Juvix.Data.CodeAnn
 import Juvix.Data.Loc
 import Juvix.Data.TopModulePathKey
 import Juvix.Extra.Strings qualified as Str
+import Juvix.Prelude.Aeson qualified as Aeson
 import Juvix.Prelude.Base
 
 data ImportScan' a = ImportScan
@@ -25,11 +27,19 @@ type ImportScan = ImportScan' Interval
 newtype ScanResult = ScanResult
   { _scanResultImports :: HashSet ImportScan
   }
-  deriving stock (Eq)
+
+$(Aeson.deriveToJSON Aeson.defaultOptions ''ImportScan')
+$(Aeson.deriveToJSON Aeson.defaultOptions ''ScanResult)
 
 makeLenses ''ImportScan'
 makeLenses ''ScanResult
 
+instance Eq ScanResult where
+  (==) = (==) `on` f
+    where
+      f :: ScanResult -> [ImportScan]
+      f = sortOn (^. importScanLoc) . HashSet.toList . (^. scanResultImports)
+
 instance (Hashable a) => Hashable (ImportScan' a)
 
 instance (Serialize a) => Serialize (ImportScan' a)

src/Juvix/Data/Loc.hs

@@ -1,6 +1,7 @@
 module Juvix.Data.Loc where
 
 import Juvix.Extra.Serialize
+import Juvix.Prelude.Aeson qualified as Aeson
 import Juvix.Prelude.Base
 import Juvix.Prelude.Path
 import Prettyprinter
@@ -112,6 +113,10 @@ getLocSpan' gl l = gl (head l) <> gl (last l)
 instance Semigroup Interval where
   Interval f s e <> Interval _f s' e' = Interval f (min s s') (max e e')
 
+$(Aeson.deriveToJSON Aeson.defaultOptions ''Pos)
+$(Aeson.deriveToJSON Aeson.defaultOptions ''FileLoc)
+$(Aeson.deriveToJSON Aeson.defaultOptions ''Interval)
+
 makeLenses ''Interval
 makeLenses ''FileLoc
 makeLenses ''Loc

src/Juvix/Data/TopModulePathKey.hs

@@ -2,6 +2,7 @@ module Juvix.Data.TopModulePathKey where
 
 import Data.List.NonEmpty qualified as NonEmpty
 import Juvix.Extra.Serialize
+import Juvix.Prelude.Aeson qualified as Aeson
 import Juvix.Prelude.Base
 import Juvix.Prelude.Path
 import Juvix.Prelude.Pretty as Pretty
@@ -20,6 +21,8 @@ instance Hashable TopModulePathKey
 
 makeLenses ''TopModulePathKey
 
+$(Aeson.deriveToJSON Aeson.defaultOptions ''TopModulePathKey)
+
 instance Pretty TopModulePathKey where
   pretty (TopModulePathKey path name) =
     mconcat (punctuate Pretty.dot (map pretty (snoc path name)))

src/Juvix/Emacs/Render.hs

@@ -1,6 +1,7 @@
 module Juvix.Emacs.Render
   ( renderEmacs,
     nameKindFace,
+    codeAnnFace,
   )
 where
 
@@ -23,23 +24,42 @@ nameKindFace = \case
   KNameAlias -> Nothing
   KNameFixity -> Just FaceFixity
 
+codeAnnFace :: CodeAnn -> Maybe Face
+codeAnnFace = \case
+  AnnKind k -> nameKindFace k
+  AnnKeyword -> Just FaceKeyword
+  AnnComment -> Just FaceComment
+  AnnPragma -> Just FacePragma
+  AnnJudoc -> Just FaceJudoc
+  AnnDelimiter -> Just FaceDelimiter
+  AnnLiteralString -> Just FaceString
+  AnnLiteralInteger -> Just FaceNumber
+  AnnError -> Just FaceError
+  AnnCode -> Nothing
+  AnnImportant -> Nothing
+  AnnUnkindedSym -> Nothing
+  AnnDef {} -> Nothing
+  AnnRef {} -> Nothing
+
 fromCodeAnn :: CodeAnn -> Maybe EmacsProperty
 fromCodeAnn = \case
-  AnnKind k -> do
-    f <- nameKindFace k
-    return (EPropertyFace (PropertyFace f))
-  AnnKeyword -> Just (EPropertyFace (PropertyFace FaceKeyword))
-  AnnDelimiter -> Just (EPropertyFace (PropertyFace FaceDelimiter))
-  AnnComment -> Just (EPropertyFace (PropertyFace FaceComment))
-  AnnPragma -> Just (EPropertyFace (PropertyFace FacePragma))
-  AnnJudoc -> Just (EPropertyFace (PropertyFace FaceJudoc))
-  AnnLiteralString -> Just (EPropertyFace (PropertyFace FaceString))
-  AnnLiteralInteger -> Just (EPropertyFace (PropertyFace FaceNumber))
+  AnnKind k -> face <$> nameKindFace k
+  AnnKeyword -> Just (face FaceKeyword)
+  AnnDelimiter -> Just (face FaceDelimiter)
+  AnnComment -> Just (face FaceComment)
+  AnnPragma -> Just (face FacePragma)
+  AnnJudoc -> Just (face FaceJudoc)
+  AnnLiteralString -> Just (face FaceString)
+  AnnLiteralInteger -> Just (face FaceNumber)
+  AnnError -> Just (face FaceError)
   AnnCode -> Nothing
   AnnImportant -> Nothing
   AnnUnkindedSym -> Nothing
   AnnDef {} -> Nothing
   AnnRef {} -> Nothing
+  where
+    face :: Face -> EmacsProperty
+    face f = EPropertyFace (PropertyFace f)
 
 data RenderState = RenderState
   { _statePoint :: Point,