1
1
mirror of https://github.com/anoma/juvix.git synced 2024-12-15 10:03:22 +03:00
juvix/app/Main.hs

280 lines
8.8 KiB
Haskell
Raw Normal View History

2022-01-18 14:25:42 +03:00
{-# LANGUAGE ApplicativeDo #-}
module Main (main) where
2022-01-21 11:50:37 +03:00
import Control.Monad.Extra
2022-01-20 14:50:01 +03:00
import qualified MiniJuvix.Syntax.Concrete.Language as M
2022-01-21 11:50:37 +03:00
import qualified MiniJuvix.Syntax.Concrete.Parser as M
import qualified MiniJuvix.Syntax.Concrete.Scoped.Pretty.Ansi as M
import qualified MiniJuvix.Syntax.MicroJuvix.Pretty.Ansi as Micro
2022-03-04 01:31:45 +03:00
import qualified MiniJuvix.Termination as T
import qualified MiniJuvix.Translation.ScopedToAbstract as A
import qualified MiniJuvix.Translation.AbstractToMicroJuvix as Micro
import qualified MiniJuvix.Syntax.Concrete.Scoped.Pretty.Base as M
import qualified MiniJuvix.Termination.CallGraph as A
import qualified MiniJuvix.Syntax.Abstract.Pretty.Base as A
2022-01-21 11:50:37 +03:00
import qualified MiniJuvix.Syntax.Concrete.Scoped.Scoper as M
import MiniJuvix.Prelude hiding (Doc)
2022-01-18 14:25:42 +03:00
import Options.Applicative
import Options.Applicative.Help.Pretty
import Text.Show.Pretty hiding (Html)
import MiniJuvix.Syntax.Concrete.Scoped.Pretty.Html
import MiniJuvix.Syntax.Concrete.Scoped.Pretty.Base (defaultOptions)
import qualified MiniJuvix.Syntax.Abstract.Pretty.Ansi as A
import Commands.Extra
import Commands.Termination as T
2022-03-15 20:01:28 +03:00
import Commands.MiniHaskell
import Commands.MicroJuvix
2022-01-18 14:25:42 +03:00
2022-01-21 11:50:37 +03:00
data Command
= Scope ScopeOptions
2022-01-18 14:25:42 +03:00
| Parse ParseOptions
| Html HtmlOptions
| Termination TerminationCommand
2022-03-15 20:01:28 +03:00
| MiniHaskell MiniHaskellOptions
| MicroJuvix MicroJuvixOptions
2022-01-18 14:25:42 +03:00
2022-01-21 11:50:37 +03:00
data ScopeOptions = ScopeOptions
{ _scopeRootDir :: FilePath,
_scopeInputFiles :: [FilePath],
2022-02-03 12:24:43 +03:00
_scopeShowIds :: Bool,
_scopeInlineImports :: Bool
2022-01-18 14:25:42 +03:00
}
2022-01-21 11:50:37 +03:00
data ParseOptions = ParseOptions
{ _parseInputFile :: FilePath,
_parseNoPrettyShow :: Bool
2022-01-20 14:50:01 +03:00
}
data HtmlOptions = HtmlOptions
{ _htmlInputFile :: FilePath,
_htmlRecursive :: Bool,
_htmlTheme :: Theme
}
parseHtml :: Parser HtmlOptions
parseHtml = do
_htmlInputFile <- parseInputFile
_htmlRecursive <-
switch
( long "recursive"
<> help "export imported modules recursively"
)
_htmlTheme <- option (eitherReader parseTheme)
( long "theme"
<> metavar "THEME"
<> value Nord
<> showDefault
<> help "selects a theme: ayu (light); nord (dark)"
)
pure HtmlOptions {..}
where
parseTheme :: String -> Either String Theme
parseTheme s = case s of
"nord" -> Right Nord
"ayu" -> Right Ayu
_ -> Left $ "unrecognised theme: " <> s
parseParse :: Parser ParseOptions
parseParse = do
_parseInputFile <- parseInputFile
2022-01-21 11:50:37 +03:00
_parseNoPrettyShow <-
switch
( long "no-pretty-show"
<> help "Disable formatting of the Haskell AST"
)
2022-01-20 14:50:01 +03:00
pure ParseOptions {..}
2022-01-18 14:25:42 +03:00
parseScope :: Parser ScopeOptions
parseScope = do
2022-01-21 11:50:37 +03:00
_scopeRootDir <-
strOption
( long "rootDir"
<> short 'd'
<> metavar "DIR"
<> value "."
<> showDefault
<> help "Root directory"
)
_scopeInputFiles <-
some $ argument
2022-01-21 11:50:37 +03:00
str
( metavar "MINIJUVIX_FILE(s)"
<> help "Path to one ore more .mjuvix files"
2022-01-21 11:50:37 +03:00
)
_scopeShowIds <-
switch
( long "show-name-ids"
<> help "Show the unique number of each identifier"
)
2022-02-03 12:24:43 +03:00
_scopeInlineImports <-
switch
( long "inline-imports"
<> help "Show the code of imported modules next to the import statement"
)
2022-01-18 14:25:42 +03:00
pure ScopeOptions {..}
descr :: ParserInfo Command
2022-01-21 11:50:37 +03:00
descr =
info
(parseCommand <**> helper)
( fullDesc
2022-01-18 14:25:42 +03:00
<> progDesc "The MiniJuvix compiler."
2022-01-20 14:50:01 +03:00
<> headerDoc (Just headDoc)
2022-01-18 14:25:42 +03:00
<> footerDoc (Just foot)
2022-01-21 11:50:37 +03:00
)
2022-01-18 14:25:42 +03:00
where
2022-01-21 11:50:37 +03:00
headDoc :: Doc
headDoc = dullblue $ bold $ underline "MiniJuvix help"
foot :: Doc
foot = bold "maintainers: " <> "jan@heliax.dev; jonathan@heliax.dev"
2022-01-18 14:25:42 +03:00
parseCommand :: Parser Command
2022-01-21 11:50:37 +03:00
parseCommand =
hsubparser $
mconcat
[ commandParse,
commandScope,
commandHtml,
2022-03-15 20:01:28 +03:00
commandTermination,
commandMicroJuvix,
2022-03-15 20:01:28 +03:00
commandMiniHaskell
2022-01-21 11:50:37 +03:00
]
2022-01-20 14:50:01 +03:00
where
commandMicroJuvix :: Mod CommandFields Command
commandMicroJuvix = command "microjuvix" minfo
where
minfo :: ParserInfo Command
minfo =
info
(MicroJuvix <$> parseMicroJuvix)
(progDesc "Translate a .mjuvix file to MicroJuvix")
2022-03-15 20:01:28 +03:00
commandMiniHaskell :: Mod CommandFields Command
commandMiniHaskell = command "minihaskell" minfo
where
minfo :: ParserInfo Command
minfo =
info
(MiniHaskell <$> parseMiniHaskell)
(progDesc "Translate a .mjuvix file to MiniHaskell")
2022-01-21 11:50:37 +03:00
commandParse :: Mod CommandFields Command
commandParse = command "parse" minfo
where
minfo :: ParserInfo Command
minfo =
info
(Parse <$> parseParse)
(progDesc "Parse a .mjuvix file")
commandHtml :: Mod CommandFields Command
commandHtml = command "html" minfo
where
minfo :: ParserInfo Command
minfo =
info
(Html <$> parseHtml)
(progDesc "Generate html for a .mjuvix file")
2022-01-21 11:50:37 +03:00
commandScope :: Mod CommandFields Command
commandScope = command "scope" minfo
where
minfo :: ParserInfo Command
minfo =
info
(Scope <$> parseScope)
(progDesc "Parse and scope a .mjuvix file")
commandTermination :: Mod CommandFields Command
commandTermination = command "termination" minfo
where
minfo :: ParserInfo Command
minfo =
info
(Termination <$> parseTerminationCommand)
(progDesc "Subcommands related to termination checking")
2022-01-18 14:25:42 +03:00
mkScopePrettyOptions :: ScopeOptions -> M.Options
mkScopePrettyOptions ScopeOptions {..} =
2022-01-21 11:50:37 +03:00
M.defaultOptions
{ M._optShowNameId = _scopeShowIds,
M._optInlineImports = _scopeInlineImports
2022-01-21 11:50:37 +03:00
}
2022-01-20 14:50:01 +03:00
parseModuleIO :: FilePath -> IO (M.Module 'M.Parsed 'M.ModuleTop)
parseModuleIO = fromRightIO id . M.runModuleParserIO
fromRightIO' :: (e -> IO ()) -> IO (Either e r) -> IO r
fromRightIO' pp = do
eitherM ifLeft return
where
ifLeft e = pp e >> exitFailure
2022-01-20 14:50:01 +03:00
fromRightIO :: (e -> Text) -> IO (Either e r) -> IO r
fromRightIO pp = fromRightIO' (putStrLn . pp)
2022-01-20 14:50:01 +03:00
2022-01-18 14:25:42 +03:00
go :: Command -> IO ()
go c = do
root <- getCurrentDirectory
case c of
Scope opts@ScopeOptions {..} -> do
forM_ _scopeInputFiles $ \scopeInputFile -> do
m <- parseModuleIO scopeInputFile
s <- fromRightIO' printErrorAnsi $ M.scopeCheck1IO root m
M.printPrettyCode (mkScopePrettyOptions opts) s
Parse ParseOptions {..} -> do
m <- parseModuleIO _parseInputFile
if _parseNoPrettyShow then print m else pPrint m
Html HtmlOptions {..} -> do
m <- parseModuleIO _htmlInputFile
s <- fromRightIO' printErrorAnsi $ M.scopeCheck1IO root m
genHtml defaultOptions _htmlRecursive _htmlTheme s
MicroJuvix MicroJuvixOptions {..} -> do
m <- parseModuleIO _mjuvixInputFile
s <- fromRightIO' printErrorAnsi $ M.scopeCheck1IO root m
a <- fromRightIO' putStrLn (return $ A.translateModule s)
let mini = Micro.translateModule a
Micro.printPrettyCodeDefault mini
2022-03-15 20:01:28 +03:00
MiniHaskell MiniHaskellOptions {..} -> do
m <- parseModuleIO _mhaskellInputFile
s <- fromRightIO' printErrorAnsi $ M.scopeCheck1IO root m
-- a <- fromRightIO' putStrLn (return $ A.translateModule s)
fromRightIO' putStrLn (return $ A.translateModule s)
-- let mini = Micro.translateModule a
-- Micro.printPrettyCodeDefault mini
-- TODO
error "todo"
Termination (Calls opts@CallsOptions {..}) -> do
m <- parseModuleIO _callsInputFile
s <- fromRightIO' printErrorAnsi $ M.scopeCheck1IO root m
a <- fromRightIO' putStrLn (return $ A.translateModule s)
let callMap0 = T.buildCallMap a
callMap = case _callsFunctionNameFilter of
Nothing -> callMap0
Just f -> T.filterCallMap f callMap0
opts' = T.callsPrettyOptions opts
A.printPrettyCode opts' callMap
putStrLn ""
Termination (CallGraph CallGraphOptions {..}) -> do
m <- parseModuleIO _graphInputFile
s <- fromRightIO' printErrorAnsi $ M.scopeCheck1IO root m
a <- fromRightIO' putStrLn (return $ A.translateModule s)
2022-03-07 19:14:16 +03:00
let callMap = T.buildCallMap a
opts' = A.defaultOptions
2022-03-04 01:31:45 +03:00
completeGraph = T.completeCallGraph callMap
2022-03-07 19:14:16 +03:00
filteredGraph = maybe completeGraph (`T.unsafeFilterGraph` completeGraph) _graphFunctionNameFilter
recBehav = map T.recursiveBehaviour (T.reflexiveEdges filteredGraph)
A.printPrettyCode opts' filteredGraph
putStrLn ""
forM_ recBehav $ \r -> do
let n = M.renderPrettyCode M.defaultOptions $ A._recBehaviourFunction r
A.printPrettyCode A.defaultOptions r
putStrLn ""
case T.findOrder r of
Nothing -> putStrLn (n <> " Fails the termination checking")
2022-03-07 19:14:16 +03:00
Just (T.LexOrder k) -> putStrLn (n <> " Terminates with order " <> show (toList k))
putStrLn ""
2022-01-18 14:25:42 +03:00
main :: IO ()
main = execParser descr >>= go