continue refactor

anoma · Sep 9, 2022 · dd3b1d0 · dd3b1d0
1 parent 6a36eef
commit dd3b1d0
Show file tree

Hide file tree

Showing 4 changed files with 145 additions and 136 deletions.
diff --git a/app/Command.hs b/app/Command.hs
@@ -3,13 +3,13 @@ module Command
     module Commands.Extra,
     module Commands.Html.Options,
     module Commands.Compile.Options,
-    module Commands.Dev,
+    module Commands.Dev.Options,
     module Commands.Doctor,
   )
 where
 
 import Commands.Compile.Options
-import Commands.Dev
+import Commands.Dev.Options
 import Commands.Doctor
 import Commands.Extra
 import Commands.Html.Options
@@ -74,10 +74,6 @@ commandDev =
       (addGlobalOptions (Dev <$> parseDevCommand))
       (progDesc "Commands for the developers")
 
---------------------------------------------------------------------------------
--- Misc
---------------------------------------------------------------------------------
-
 cmdDefaultOptions :: Command -> CommandGlobalOptions
 cmdDefaultOptions _cliCommand =
   CommandGlobalOptions {_cliGlobalOptions = mempty, ..}

diff --git a/app/Commands/Dev.hs b/app/Commands/Dev.hs
@@ -1,111 +1,35 @@
 module Commands.Dev
   ( module Commands.Dev,
-    module Commands.Dev.Core.Options,
-    module Commands.Dev.Internal,
-    module Commands.Dev.Parse.Options,
-    module Commands.Dev.Highlight.Options,
-    module Commands.Dev.Scope.Options,
-    module Commands.Dev.Doc.Options,
-    module Commands.Dev.Termination.Options,
+    module Commands.Dev.Options,
   )
 where
 
-import Commands.Dev.Core.Options
-import Commands.Dev.Doc.Options
-import Commands.Dev.Highlight.Options
-import Commands.Dev.Internal
-import Commands.Dev.Parse.Options
-import Commands.Dev.Scope.Options
-import Commands.Dev.Termination.Options
-import Juvix.Prelude
-import Options.Applicative
-
-data DevCommand
-  = DisplayRoot
-  | Highlight HighlightOptions
-  | Internal MicroCommand
-  | Core CoreCommand
-  | MiniC
-  | Parse ParseOptions
-  | Scope ScopeOptions
-  | Termination TerminationCommand
-  | Doc DocOptions
-
-parseDevCommand :: Parser DevCommand
-parseDevCommand =
-  hsubparser
-    ( mconcat
-        [ commandHighlight,
-          commandInternal,
-          commandCore,
-          commandMiniC,
-          commandParse,
-          commandDoc,
-          commandScope,
-          commandShowRoot,
-          commandTermination
-        ]
-    )
-
-commandDoc :: Mod CommandFields DevCommand
-commandDoc =
-  command "doc" $
-    info
-      (Doc <$> parseDoc)
-      (progDesc "Generate documentation")
-
-commandHighlight :: Mod CommandFields DevCommand
-commandHighlight =
-  command "highlight" $
-    info
-      (Highlight <$> parseHighlight)
-      (progDesc "Highlight a Juvix file")
-
-commandMiniC :: Mod CommandFields DevCommand
-commandMiniC =
-  command "minic" $
-    info
-      (pure MiniC)
-      (progDesc "Translate a Juvix file to MiniC")
-
-commandInternal :: Mod CommandFields DevCommand
-commandInternal =
-  command "internal" $
-    info
-      (Internal <$> parseMicroCommand)
-      (progDesc "Subcommands related to Internal")
-
-commandCore :: Mod CommandFields DevCommand
-commandCore =
-  command "core" $
-    info
-      (Core <$> parseCoreCommand)
-      (progDesc "Subcommands related to JuvixCore")
-
-commandParse :: Mod CommandFields DevCommand
-commandParse =
-  command "parse" $
-    info
-      (Parse <$> parseParse)
-      (progDesc "Parse a Juvix file")
-
-commandScope :: Mod CommandFields DevCommand
-commandScope =
-  command "scope" $
-    info
-      (Scope <$> parseScope)
-      (progDesc "Parse and scope a Juvix file")
-
-commandShowRoot :: Mod CommandFields DevCommand
-commandShowRoot =
-  command "root" $
-    info
-      (pure DisplayRoot)
-      (progDesc "Show the root path for a Juvix project")
-
-commandTermination :: Mod CommandFields DevCommand
-commandTermination =
-  command "termination" $
-    info
-      (Termination <$> parseTerminationCommand)
-      (progDesc "Subcommands related to termination checking")
+import Commands.Base
+import Commands.Dev.Doc qualified as Doc
+import Commands.Dev.Highlight qualified as Highlight
+import Commands.Dev.Internal.Arity qualified as Arity
+import Commands.Dev.Internal.Pretty qualified as InternalPretty
+import Commands.Dev.Internal.Typecheck qualified as InternalTypecheck
+import Commands.Dev.MiniC qualified as MiniC
+import Commands.Dev.Options
+import Commands.Dev.Parse qualified as Parse
+import Commands.Dev.Scope qualified as Scope
+import Commands.Dev.Termination.CallGraph qualified as TerminationCallGraph
+import Commands.Dev.Termination.Calls qualified as TerminationCalls
+
+runCommand :: Members '[Embed IO, App] r => EntryPoint -> DevCommand -> Sem r ()
+runCommand entryPoint cmd = do
+  case cmd of
+    Highlight localOpts -> Highlight.runCommand entryPoint localOpts
+    Parse localOpts -> Parse.runCommand entryPoint localOpts
+    Scope localOpts -> Scope.runCommand entryPoint localOpts
+    Doc localOpts -> Doc.runCommand entryPoint localOpts
+    Internal i -> case i of
+      Pretty -> InternalPretty.runCommand entryPoint
+      Arity -> Arity.runCommand entryPoint
+      TypeCheck localOpts -> InternalTypecheck.runCommand entryPoint localOpts
+    MiniC -> MiniC.runCommand entryPoint
+    Termination t -> case t of
+      Calls localOpts -> TerminationCalls.runCommand entryPoint localOpts
+      CallGraph localOpts -> TerminationCallGraph.runCommand entryPoint localOpts
+    _ -> impossible -- do not require entrypoint
diff --git a/app/Commands/Dev/Options.hs b/app/Commands/Dev/Options.hs
@@ -0,0 +1,111 @@
+module Commands.Dev.Options
+  ( module Commands.Dev.Options,
+    module Commands.Dev.Core.Options,
+    module Commands.Dev.Internal,
+    module Commands.Dev.Parse.Options,
+    module Commands.Dev.Highlight.Options,
+    module Commands.Dev.Scope.Options,
+    module Commands.Dev.Doc.Options,
+    module Commands.Dev.Termination.Options,
+  )
+where
+
+import Commands.Dev.Core.Options
+import Commands.Dev.Doc.Options
+import Commands.Dev.Highlight.Options
+import Commands.Dev.Internal
+import Commands.Dev.Parse.Options
+import Commands.Dev.Scope.Options
+import Commands.Dev.Termination.Options
+import Juvix.Prelude
+import Options.Applicative
+
+data DevCommand
+  = DisplayRoot
+  | Highlight HighlightOptions
+  | Internal MicroCommand
+  | Core CoreCommand
+  | MiniC
+  | Parse ParseOptions
+  | Scope ScopeOptions
+  | Termination TerminationCommand
+  | Doc DocOptions
+
+parseDevCommand :: Parser DevCommand
+parseDevCommand =
+  hsubparser
+    ( mconcat
+        [ commandHighlight,
+          commandInternal,
+          commandCore,
+          commandMiniC,
+          commandParse,
+          commandDoc,
+          commandScope,
+          commandShowRoot,
+          commandTermination
+        ]
+    )
+
+commandDoc :: Mod CommandFields DevCommand
+commandDoc =
+  command "doc" $
+    info
+      (Doc <$> parseDoc)
+      (progDesc "Generate documentation")
+
+commandHighlight :: Mod CommandFields DevCommand
+commandHighlight =
+  command "highlight" $
+    info
+      (Highlight <$> parseHighlight)
+      (progDesc "Highlight a Juvix file")
+
+commandMiniC :: Mod CommandFields DevCommand
+commandMiniC =
+  command "minic" $
+    info
+      (pure MiniC)
+      (progDesc "Translate a Juvix file to MiniC")
+
+commandInternal :: Mod CommandFields DevCommand
+commandInternal =
+  command "internal" $
+    info
+      (Internal <$> parseMicroCommand)
+      (progDesc "Subcommands related to Internal")
+
+commandCore :: Mod CommandFields DevCommand
+commandCore =
+  command "core" $
+    info
+      (Core <$> parseCoreCommand)
+      (progDesc "Subcommands related to JuvixCore")
+
+commandParse :: Mod CommandFields DevCommand
+commandParse =
+  command "parse" $
+    info
+      (Parse <$> parseParse)
+      (progDesc "Parse a Juvix file")
+
+commandScope :: Mod CommandFields DevCommand
+commandScope =
+  command "scope" $
+    info
+      (Scope <$> parseScope)
+      (progDesc "Parse and scope a Juvix file")
+
+commandShowRoot :: Mod CommandFields DevCommand
+commandShowRoot =
+  command "root" $
+    info
+      (pure DisplayRoot)
+      (progDesc "Show the root path for a Juvix project")
+
+commandTermination :: Mod CommandFields DevCommand
+commandTermination =
+  command "termination" $
+    info
+      (Termination <$> parseTerminationCommand)
+      (progDesc "Subcommands related to termination checking")
diff --git a/app/Main.hs b/app/Main.hs
@@ -3,17 +3,8 @@ module Main (main) where
 import App
 import CLI
 import Commands.Compile qualified as Compile
+import Commands.Dev qualified as Dev
 import Commands.Dev.Core qualified as Core
-import Commands.Dev.Doc qualified as Doc
-import Commands.Dev.Highlight qualified as Highlight
-import Commands.Dev.Internal.Arity qualified as Arity
-import Commands.Dev.Internal.Pretty qualified as InternalPretty
-import Commands.Dev.Internal.Typecheck qualified as InternalTypecheck
-import Commands.Dev.MiniC qualified as MiniC
-import Commands.Dev.Parse qualified as Parse
-import Commands.Dev.Scope qualified as Scope
-import Commands.Dev.Termination.CallGraph qualified as TerminationCallGraph
-import Commands.Dev.Termination.Calls qualified as TerminationCalls
 import Commands.Html qualified as Html
 import Commands.Init qualified as Init
 import Control.Exception qualified as IO
@@ -101,20 +92,7 @@ runCommand cmdWithOpts = do
               Check -> commandHelper entryPoint (Dev (Internal (TypeCheck mempty)))
               Compile localOpts -> Compile.runCommand entryPoint localOpts
               Html localOpts -> Html.runCommand entryPoint localOpts
-              Dev cmd' -> case cmd' of
-                Highlight localOpts -> Highlight.runCommand entryPoint localOpts
-                Parse localOpts -> Parse.runCommand entryPoint localOpts
-                Scope localOpts -> Scope.runCommand entryPoint localOpts
-                Doc localOpts -> Doc.runCommand entryPoint localOpts
-                Internal i -> case i of
-                  Pretty -> InternalPretty.runCommand entryPoint
-                  Arity -> Arity.runCommand entryPoint
-                  TypeCheck localOpts -> InternalTypecheck.runCommand entryPoint localOpts
-                MiniC -> MiniC.runCommand entryPoint
-                Termination t -> case t of
-                  Calls localOpts -> TerminationCalls.runCommand entryPoint localOpts
-                  CallGraph localOpts -> TerminationCallGraph.runCommand entryPoint localOpts
-                _ -> impossible
+              Dev dev -> Dev.runCommand entryPoint dev
 
 showHelpText :: ParserPrefs -> IO ()
 showHelpText p = do