diff --git a/app/Commands/Dev/ImportTree/ScanFile.hs b/app/Commands/Dev/ImportTree/ScanFile.hs index c57cee0672..9536227d61 100644 --- a/app/Commands/Dev/ImportTree/ScanFile.hs +++ b/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 diff --git a/app/Commands/Dev/ImportTree/ScanFile/Options.hs b/app/Commands/Dev/ImportTree/ScanFile/Options.hs index 4abd43fa4a..c5b072b55f 100644 --- a/app/Commands/Dev/ImportTree/ScanFile/Options.hs +++ b/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 {..} diff --git a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped/Source.hs b/src/Juvix/Compiler/Backend/Html/Translation/FromTyped/Source.hs index e551065436..5768f8a668 100644 --- a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped/Source.hs +++ b/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 diff --git a/src/Juvix/Compiler/Backend/Latex/Translation/FromScoped/Source.hs b/src/Juvix/Compiler/Backend/Latex/Translation/FromScoped/Source.hs index 779b124885..f4299c2d2e 100644 --- a/src/Juvix/Compiler/Backend/Latex/Translation/FromScoped/Source.hs +++ b/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 diff --git a/src/Juvix/Compiler/Concrete/Data/Highlight.hs b/src/Juvix/Compiler/Concrete/Data/Highlight.hs index 4efe6443d0..6c4ed25a71 100644 --- a/src/Juvix/Compiler/Concrete/Data/Highlight.hs +++ b/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) diff --git a/src/Juvix/Compiler/Concrete/Translation/ImportScanner.hs b/src/Juvix/Compiler/Concrete/Translation/ImportScanner.hs index faf8d1045d..4f926a4d91 100644 --- a/src/Juvix/Compiler/Concrete/Translation/ImportScanner.hs +++ b/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 diff --git a/src/Juvix/Data/CodeAnn.hs b/src/Juvix/Data/CodeAnn.hs index 63f8fa7cb3..76a78e2ca3 100644 --- a/src/Juvix/Data/CodeAnn.hs +++ b/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 diff --git a/src/Juvix/Data/Effect/Logger.hs b/src/Juvix/Data/Effect/Logger.hs index 4a7723abbc..6da4652c39 100644 --- a/src/Juvix/Data/Effect/Logger.hs +++ b/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 diff --git a/src/Juvix/Data/ImportScan.hs b/src/Juvix/Data/ImportScan.hs index 7b223d94b7..6ffbc1e5a3 100644 --- a/src/Juvix/Data/ImportScan.hs +++ b/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) diff --git a/src/Juvix/Data/Loc.hs b/src/Juvix/Data/Loc.hs index ad9d527dbf..88c0122870 100644 --- a/src/Juvix/Data/Loc.hs +++ b/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 diff --git a/src/Juvix/Data/TopModulePathKey.hs b/src/Juvix/Data/TopModulePathKey.hs index 8abea99cab..abd543b500 100644 --- a/src/Juvix/Data/TopModulePathKey.hs +++ b/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))) diff --git a/src/Juvix/Emacs/Render.hs b/src/Juvix/Emacs/Render.hs index e53d22a5ed..d23609dc71 100644 --- a/src/Juvix/Emacs/Render.hs +++ b/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,