Add CanonicalProjection

app/Commands/Dev/Core.hs

@@ -1,6 +1,7 @@
 module Commands.Dev.Core where
 
 import Juvix.Compiler.Core.Data.TransformationId.Parser
+import Juvix.Compiler.Core.Pretty.Options qualified as Core
 import Juvix.Prelude hiding (Doc)
 import Options.Applicative
 
@@ -26,6 +27,18 @@ makeLenses ''CoreReplOptions
 makeLenses ''CoreEvalOptions
 makeLenses ''CoreReadOptions
 
+instance CanonicalProjection CoreReplOptions Core.Options where
+  project c =
+    Core.defaultOptions
+      { Core._optShowDeBruijnIndices = c ^. coreReplShowDeBruijn
+      }
+
+instance CanonicalProjection CoreReadOptions Core.Options where
+  project c =
+    Core.defaultOptions
+      { Core._optShowDeBruijnIndices = c ^. coreReadShowDeBruijn
+      }
+
 defaultCoreEvalOptions :: CoreEvalOptions
 defaultCoreEvalOptions =
   CoreEvalOptions

app/Commands/Dev/Scope.hs

@@ -20,9 +20,9 @@ parseScope = do
       )
   pure ScopeOptions {..}
 
-mkScopePrettyOptions :: GlobalOptions -> ScopeOptions -> Scoper.Options
-mkScopePrettyOptions g ScopeOptions {..} =
-  Scoper.defaultOptions
-    { Scoper._optShowNameIds = g ^. globalShowNameIds,
-      Scoper._optInlineImports = _scopeInlineImports
-    }
+instance CanonicalProjection (GlobalOptions, ScopeOptions) Scoper.Options where
+  project (g, ScopeOptions {..}) =
+    Scoper.defaultOptions
+      { Scoper._optShowNameIds = g ^. globalShowNameIds,
+        Scoper._optInlineImports = _scopeInlineImports
+      }

app/Commands/Dev/Termination.hs

@@ -3,7 +3,7 @@ module Commands.Dev.Termination where
 import Control.Monad.Extra
 import Data.Text qualified as Text
 import GlobalOptions
-import Juvix.Compiler.Abstract.Pretty.Base qualified as A
+import Juvix.Compiler.Abstract.Pretty.Base qualified as Abstract
 import Juvix.Prelude hiding (Doc)
 import Options.Applicative
 
@@ -13,7 +13,7 @@ data TerminationCommand
 
 data CallsOptions = CallsOptions
   { _callsFunctionNameFilter :: Maybe (NonEmpty Text),
-    _callsShowDecreasingArgs :: A.ShowDecrArgs
+    _callsShowDecreasingArgs :: Abstract.ShowDecrArgs
   }
 
 newtype CallGraphOptions = CallGraphOptions
@@ -40,17 +40,17 @@ parseCalls = do
       decrArgsParser
       ( long "show-decreasing-args"
           <> short 'd'
-          <> value A.ArgRel
+          <> value Abstract.ArgRel
           <> help "possible values: argument, relation, both"
       )
   pure CallsOptions {..}
   where
-    decrArgsParser :: ReadM A.ShowDecrArgs
+    decrArgsParser :: ReadM Abstract.ShowDecrArgs
     decrArgsParser = eitherReader $ \s ->
       case map toLower s of
-        "argument" -> return A.OnlyArg
-        "relation" -> return A.OnlyRel
-        "both" -> return A.ArgRel
+        "argument" -> return Abstract.OnlyArg
+        "relation" -> return Abstract.OnlyRel
+        "both" -> return Abstract.ArgRel
         _ -> Left "bad argument"
 
 parseCallGraph :: Parser CallGraphOptions
@@ -91,9 +91,9 @@ parseTerminationCommand =
             (CallGraph <$> parseCallGraph)
             (progDesc "Compute the complete call graph of a .juvix file")
 
-callsPrettyOptions :: GlobalOptions -> CallsOptions -> A.Options
-callsPrettyOptions GlobalOptions {..} CallsOptions {..} =
-  A.defaultOptions
-    { A._optShowNameIds = _globalShowNameIds,
-      A._optShowDecreasingArgs = _callsShowDecreasingArgs
-    }
+instance CanonicalProjection (GlobalOptions, CallsOptions) Abstract.Options where
+  project (GlobalOptions {..}, CallsOptions {..}) =
+    Abstract.defaultOptions
+      { Abstract._optShowNameIds = _globalShowNameIds,
+        Abstract._optShowDecreasingArgs = _callsShowDecreasingArgs
+      }

app/GlobalOptions.hs

@@ -4,6 +4,8 @@ module GlobalOptions
 where
 
 import Commands.Extra
+import Juvix.Compiler.Abstract.Pretty.Options qualified as Abstract
+import Juvix.Compiler.Internal.Pretty.Options qualified as Internal
 import Juvix.Data.Error.GenericError qualified as E
 import Juvix.Prelude
 import Options.Applicative hiding (hidden)
@@ -22,6 +24,18 @@ data GlobalOptions = GlobalOptions
 
 makeLenses ''GlobalOptions
 
+instance CanonicalProjection GlobalOptions Internal.Options where
+  project g =
+    Internal.Options
+      { Internal._optShowNameIds = g ^. globalShowNameIds
+      }
+
+instance CanonicalProjection GlobalOptions Abstract.Options where
+  project g =
+    Abstract.defaultOptions
+      { Abstract._optShowNameIds = g ^. globalShowNameIds
+      }
+
 defaultGlobalOptions :: GlobalOptions
 defaultGlobalOptions =
   GlobalOptions

app/Main.hs

@@ -2,7 +2,6 @@ module Main (main) where
 
 import App
 import CLI
-import Commands.Dev.Termination as Termination
 import Commands.Init qualified as Init
 import Control.Exception qualified as IO
 import Data.ByteString qualified as ByteString
@@ -161,7 +160,7 @@ runCommand cmdWithOpts = do
                     (^. Scoper.resultModules)
                       <$> runPipeline (upToScoping entryPoint)
                   forM_ l $ \s -> do
-                    renderStdOut (Scoper.ppOut (mkScopePrettyOptions globalOpts localOpts) s)
+                    renderStdOut (Scoper.ppOut (globalOpts, localOpts) s)
                 Doc localOpts -> do
                   ctx :: InternalTyped.InternalTypedResult <-
                     runPipeline (upToInternalTyped entryPoint)
@@ -174,24 +173,16 @@ runCommand cmdWithOpts = do
                   micro <-
                     head . (^. Internal.resultModules)
                       <$> runPipeline (upToInternal entryPoint)
-                  let ppOpts =
-                        Internal.defaultOptions
-                          { Internal._optShowNameIds = globalOpts ^. globalShowNameIds
-                          }
-                  App.renderStdOut (Internal.ppOut ppOpts micro)
+                  App.renderStdOut (Internal.ppOut globalOpts micro)
                 Internal Arity -> do
                   micro <- head . (^. InternalArity.resultModules) <$> runPipeline (upToInternalArity entryPoint)
-                  App.renderStdOut (Internal.ppOut Internal.defaultOptions micro)
+                  App.renderStdOut (Internal.ppOut globalOpts micro)
                 Internal (TypeCheck localOpts) -> do
                   res <- runPipeline (upToInternalTyped entryPoint)
                   say "Well done! It type checks"
                   when (localOpts ^. microJuvixTypePrint) $ do
-                    let ppOpts =
-                          Internal.defaultOptions
-                            { Internal._optShowNameIds = globalOpts ^. globalShowNameIds
-                            }
-                        checkedModule = head (res ^. InternalTyped.resultModules)
-                    renderStdOut (Internal.ppOut ppOpts checkedModule)
+                    let checkedModule = head (res ^. InternalTyped.resultModules)
+                    renderStdOut (Internal.ppOut globalOpts checkedModule)
                 MiniC -> do
                   miniC <- (^. MiniC.resultCCode) <$> runPipeline (upToMiniC entryPoint)
                   say miniC
@@ -203,18 +194,13 @@ runCommand cmdWithOpts = do
                       callMap = case _callsFunctionNameFilter of
                         Nothing -> callMap0
                         Just f -> Termination.filterCallMap f callMap0
-                      localOpts' = Termination.callsPrettyOptions globalOpts localOpts
-                  renderStdOut (Abstract.ppOut localOpts' callMap)
+                  renderStdOut (Abstract.ppOut (globalOpts, localOpts) callMap)
                   newline
                 Termination (CallGraph CallGraphOptions {..}) -> do
                   results <- runPipeline (upToAbstract entryPoint)
                   let topModule = head (results ^. Abstract.resultModules)
                       infotable = results ^. Abstract.resultTable
                       callMap = Termination.buildCallMap infotable topModule
-                      localOpts' =
-                        Abstract.defaultOptions
-                          { Abstract._optShowNameIds = globalOpts ^. globalShowNameIds
-                          }
                       completeGraph = Termination.completeCallGraph callMap
                       filteredGraph =
                         maybe
@@ -223,7 +209,7 @@ runCommand cmdWithOpts = do
                           _graphFunctionNameFilter
                       rEdges = Termination.reflexiveEdges filteredGraph
                       recBehav = map Termination.recursiveBehaviour rEdges
-                  App.renderStdOut (Abstract.ppOut localOpts' filteredGraph)
+                  App.renderStdOut (Abstract.ppOut globalOpts filteredGraph)
                   newline
                   forM_ recBehav $ \r -> do
                     let funName = r ^. Termination.recursiveBehaviourFun
@@ -234,12 +220,8 @@ runCommand cmdWithOpts = do
                             funRef
                             (infotable ^. Abstract.infoFunctions)
                         markedTerminating = funInfo ^. (Abstract.functionInfoDef . Abstract.funDefTerminating)
-                        ppOpts =
-                          Abstract.defaultOptions
-                            { Abstract._optShowNameIds = globalOpts ^. globalShowNameIds
-                            }
-                        n = toAnsiText' (Abstract.ppOut ppOpts funName)
-                    App.renderStdOut (Abstract.ppOut localOpts' r)
+                        n = toAnsiText' (Abstract.ppOut globalOpts funName)
+                    App.renderStdOut (Abstract.ppOut globalOpts r)
                     newline
                     if
                         | markedTerminating ->
@@ -270,10 +252,7 @@ runCoreCommand globalOpts = \case
       s' <- embed (readFile f)
       tab <- getRight (fst <$> mapLeft JuvixError (Core.runParser "" f Core.emptyInfoTable s'))
       let tab' = Core.applyTransformations (opts ^. coreReadTransformations) tab
-      renderStdOut (Core.ppOut docOpts tab')
-      where
-        docOpts :: Core.Options
-        docOpts = set Core.optShowDeBruijnIndices (opts ^. coreReadShowDeBruijn) Core.defaultOptions
+      renderStdOut (Core.ppOut opts tab')
 
     runRepl :: CoreReplOptions -> Core.InfoTable -> Sem r ()
     runRepl opts tab = do
@@ -293,7 +272,7 @@ runCoreCommand globalOpts = \case
                 printJuvixError (JuvixError err)
                 runRepl opts tab
               Right (tab', Just node) -> do
-                renderStdOut (Core.ppOut docOpts node)
+                renderStdOut (Core.ppOut opts node)
                 embed (putStrLn "")
                 runRepl opts tab'
               Right (tab', Nothing) ->
@@ -328,8 +307,6 @@ runCoreCommand globalOpts = \case
               Right (tab', Nothing) ->
                 runRepl opts tab'
       where
-        docOpts :: Core.Options
-        docOpts = set Core.optShowDeBruijnIndices (opts ^. coreReplShowDeBruijn) Core.defaultOptions
         replEval :: Bool -> Core.InfoTable -> Core.Node -> Sem r ()
         replEval noIO tab' node = do
           r <- doEval noIO defaultLoc tab' node
@@ -340,7 +317,7 @@ runCoreCommand globalOpts = \case
             Right node'
               | Info.member Info.kNoDisplayInfo (Core.getInfo node') -> runRepl opts tab'
               | otherwise -> do
-                  renderStdOut (Core.ppOut docOpts node')
+                  renderStdOut (Core.ppOut opts node')
                   embed (putStrLn "")
                   runRepl opts tab'
           where

src/Juvix/Compiler/Abstract/Pretty.hs

@@ -12,8 +12,8 @@ import Juvix.Prelude
 ppOutDefault :: PrettyCode c => c -> AnsiText
 ppOutDefault = AnsiText . PPOutput . doc defaultOptions
 
-ppOut :: PrettyCode c => Options -> c -> AnsiText
-ppOut o = AnsiText . PPOutput . doc o
+ppOut :: (CanonicalProjection a Options, PrettyCode c) => a -> c -> AnsiText
+ppOut o = AnsiText . PPOutput . doc (project o)
 
 ppTrace :: PrettyCode c => c -> Text
 ppTrace = toAnsiText True . ppOutDefault

src/Juvix/Compiler/Concrete/Pretty.hs

@@ -13,5 +13,5 @@ import Juvix.Prelude
 ppOutDefault :: PrettyCode c => c -> AnsiText
 ppOutDefault = AnsiText . PPOutput . doc defaultOptions
 
-ppOut :: PrettyCode c => Options -> c -> AnsiText
-ppOut o = AnsiText . PPOutput . doc o
+ppOut :: (CanonicalProjection a Options, PrettyCode c) => a -> c -> AnsiText
+ppOut o = AnsiText . PPOutput . doc (project o)

src/Juvix/Compiler/Core/Pretty.hs

@@ -15,11 +15,11 @@ import Prettyprinter.Render.Terminal qualified as Ansi
 ppOutDefault :: PrettyCode c => c -> AnsiText
 ppOutDefault = AnsiText . PPOutput . doc defaultOptions
 
-ppOut :: PrettyCode c => Options -> c -> AnsiText
-ppOut o = AnsiText . PPOutput . doc o
+ppOut :: (CanonicalProjection a Options, PrettyCode c) => a -> c -> AnsiText
+ppOut o = AnsiText . PPOutput . doc (project o)
 
-ppTrace' :: PrettyCode c => Options -> c -> Text
-ppTrace' opts = Ansi.renderStrict . reAnnotateS stylize . layoutPretty defaultLayoutOptions . doc opts
+ppTrace' :: (CanonicalProjection a Options, PrettyCode c) => a -> c -> Text
+ppTrace' opts = Ansi.renderStrict . reAnnotateS stylize . layoutPretty defaultLayoutOptions . doc (project opts)
 
 ppTrace :: PrettyCode c => c -> Text
 ppTrace = ppTrace' defaultOptions

src/Juvix/Compiler/Internal/Pretty.hs

@@ -15,8 +15,8 @@ import Prettyprinter.Render.Terminal qualified as Ansi
 ppOutDefault :: PrettyCode c => c -> AnsiText
 ppOutDefault = AnsiText . PPOutput . doc defaultOptions
 
-ppOut :: PrettyCode c => Options -> c -> AnsiText
-ppOut o = AnsiText . PPOutput . doc o
+ppOut :: (CanonicalProjection a Options, PrettyCode c) => a -> c -> AnsiText
+ppOut o = AnsiText . PPOutput . doc (project o)
 
 ppTrace :: PrettyCode c => c -> Text
 ppTrace = Ansi.renderStrict . reAnnotateS stylize . layoutPretty defaultLayoutOptions . doc defaultOptions

src/Juvix/Prelude/Base.hs

@@ -330,3 +330,9 @@ allElements = [minBound .. maxBound]
 
 readerState :: forall a r x. (Member (State a) r) => Sem (Reader a ': r) x -> Sem r x
 readerState m = get >>= (`runReader` m)
+
+class CanonicalProjection a b where
+  project :: a -> b
+
+instance CanonicalProjection a a where
+  project = id