1
1
mirror of https://github.com/anoma/juvix.git synced 2025-01-05 14:34:03 +03:00

Add internal core read command (#1517)

This commit is contained in:
janmasrovira 2022-09-06 15:26:48 +02:00 committed by GitHub
parent 1fdc3674ba
commit 4f05ba2531
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
24 changed files with 283 additions and 88 deletions

View File

@ -9,7 +9,7 @@ import Juvix.Prelude.Pretty hiding (Doc)
import System.Console.ANSI qualified as Ansi
data App m a where
ExitMsg :: ExitCode -> Text -> App m ()
ExitMsg :: ExitCode -> Text -> App m a
ExitJuvixError :: JuvixError -> App m a
PrintJuvixError :: JuvixError -> App m ()
ReadGlobalOptions :: App m GlobalOptions
@ -53,8 +53,20 @@ runPipeline p = do
newline :: Member App r => Sem r ()
newline = say ""
printSuccessExit :: Member App r => Text -> Sem r ()
printSuccessExit :: Member App r => Text -> Sem r a
printSuccessExit = exitMsg ExitSuccess
printFailureExit :: Member App r => Text -> Sem r ()
printFailureExit :: Member App r => Text -> Sem r a
printFailureExit = exitMsg (ExitFailure 1)
getRight :: (Members '[App] r, AppError e) => Either e a -> Sem r a
getRight = either appError return
instance AppError Text where
appError = printFailureExit
instance AppError JuvixError where
appError = exitJuvixError
class AppError e where
appError :: Members '[App] r => e -> Sem r a

View File

@ -1,29 +1,42 @@
module Commands.Dev.Core where
import Juvix.Compiler.Core.Data.TransformationId.Parser
import Juvix.Prelude hiding (Doc)
import Options.Applicative
data CoreCommand
= Repl CoreReplOptions
| Eval CoreEvalOptions
| Read CoreReadOptions
newtype CoreReplOptions = CoreReplOptions
{ _coreReplShowDeBruijn :: Bool
}
data CoreEvalOptions = CoreEvalOptions
{ _coreEvalShowDeBruijn :: Bool,
_coreEvalNoIO :: Bool
newtype CoreEvalOptions = CoreEvalOptions
{ _coreEvalNoIO :: Bool
}
data CoreReadOptions = CoreReadOptions
{ _coreReadTransformations :: [TransformationId],
_coreReadShowDeBruijn :: Bool
}
makeLenses ''CoreReplOptions
makeLenses ''CoreEvalOptions
makeLenses ''CoreReadOptions
defaultCoreEvalOptions :: CoreEvalOptions
defaultCoreEvalOptions =
CoreEvalOptions
{ _coreEvalShowDeBruijn = False,
_coreEvalNoIO = False
{ _coreEvalNoIO = False
}
defaultCoreReadOptions :: CoreReadOptions
defaultCoreReadOptions =
CoreReadOptions
{ _coreReadTransformations = mempty,
_coreReadShowDeBruijn = False
}
parseCoreCommand :: Parser CoreCommand
@ -31,7 +44,8 @@ parseCoreCommand =
hsubparser $
mconcat
[ commandRepl,
commandEval
commandEval,
commandRead
]
where
commandRepl :: Mod CommandFields CoreCommand
@ -40,6 +54,9 @@ parseCoreCommand =
commandEval :: Mod CommandFields CoreCommand
commandEval = command "eval" evalInfo
commandRead :: Mod CommandFields CoreCommand
commandRead = command "read" readInfo
replInfo :: ParserInfo CoreCommand
replInfo =
info
@ -52,13 +69,31 @@ parseCoreCommand =
(Eval <$> parseCoreEvalOptions)
(progDesc "Evaluate a JuvixCore file and pretty print the result")
readInfo :: ParserInfo CoreCommand
readInfo =
info
(Read <$> parseCoreReadOptions)
(progDesc "Read a JuvixCore file, transform it, and pretty print it")
parseCoreReadOptions :: Parser CoreReadOptions
parseCoreReadOptions = do
_coreReadShowDeBruijn <- deBruijnOpt
_coreReadTransformations <-
option
(eitherReader parseTransf)
( long "transforms"
<> short 't'
<> value mempty
<> metavar "[Transform]"
<> help "comma sep list of transformations. Available: lifting"
)
pure CoreReadOptions {..}
where
parseTransf :: String -> Either String [TransformationId]
parseTransf = mapLeft unpack . parseTransformations . pack
parseCoreEvalOptions :: Parser CoreEvalOptions
parseCoreEvalOptions = do
_coreEvalShowDeBruijn <-
switch
( long "show-de-bruijn"
<> help "Show variable de Bruijn indices"
)
_coreEvalNoIO <-
switch
( long "no-io"
@ -66,11 +101,14 @@ parseCoreEvalOptions = do
)
pure CoreEvalOptions {..}
deBruijnOpt :: Parser Bool
deBruijnOpt =
switch
( long "show-de-bruijn"
<> help "Show variable de Bruijn indices"
)
parseCoreReplOptions :: Parser CoreReplOptions
parseCoreReplOptions = do
_coreReplShowDeBruijn <-
switch
( long "show-de-bruijn"
<> help "Show variable de Bruijn indices"
)
_coreReplShowDeBruijn <- deBruijnOpt
pure CoreReplOptions {..}

View File

@ -5,7 +5,6 @@ import CLI
import Commands.Dev.Termination as Termination
import Commands.Init qualified as Init
import Control.Exception qualified as IO
import Control.Monad.Extra
import Data.ByteString qualified as ByteString
import Data.HashMap.Strict qualified as HashMap
import Data.Yaml
@ -29,6 +28,7 @@ import Juvix.Compiler.Core.Info qualified as Info
import Juvix.Compiler.Core.Info.NoDisplayInfo qualified as Info
import Juvix.Compiler.Core.Language qualified as Core
import Juvix.Compiler.Core.Pretty qualified as Core
import Juvix.Compiler.Core.Transformation qualified as Core
import Juvix.Compiler.Core.Translation.FromSource qualified as Core
import Juvix.Compiler.Internal.Pretty qualified as Internal
import Juvix.Compiler.Internal.Translation.FromAbstract qualified as Internal
@ -39,7 +39,7 @@ import Juvix.Compiler.Pipeline
import Juvix.Extra.Paths qualified as Paths
import Juvix.Extra.Process
import Juvix.Extra.Version (runDisplayVersion)
import Juvix.Prelude hiding (Doc)
import Juvix.Prelude
import Juvix.Prelude.Pretty hiding (Doc)
import Options.Applicative
import System.Environment (getProgName)
@ -252,28 +252,30 @@ runCommand cmdWithOpts = do
printSuccessExit (n <> " Terminates with order " <> show (toList k))
_ -> impossible
runCoreCommand :: Members '[Embed IO, App] r => GlobalOptions -> CoreCommand -> Sem r ()
runCoreCommand :: forall r. Members '[Embed IO, App] r => GlobalOptions -> CoreCommand -> Sem r ()
runCoreCommand globalOpts = \case
Repl opts -> do
embed showReplWelcome
runRepl opts Core.emptyInfoTable
Eval opts ->
case globalOpts ^. globalInputFiles of
[] -> printFailureExit "Provide a JuvixCore file to run this command\nUse --help to see all the options"
files -> mapM_ (evalFile opts) files
Eval opts -> getFile >>= evalFile opts
Read opts -> getFile >>= runRead opts
where
genericOpts :: GenericOptions
genericOpts = genericFromGlobalOptions globalOpts
getFile :: Sem r FilePath
getFile = case globalOpts ^? globalInputFiles . _head of
Nothing -> printFailureExit "Provide a JuvixCore file to run this command\nUse --help to see all the options"
Just f -> return f
docOpts :: Bool -> Core.Options
docOpts showDeBruijn = set Core.optShowNameIds (genericOpts ^. showNameIds) (set Core.optShowDeBruijnIndices showDeBruijn Core.defaultOptions)
runRead :: CoreReadOptions -> FilePath -> Sem r ()
runRead opts f = do
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
runRepl ::
forall r.
Members '[Embed IO, App] r =>
CoreReplOptions ->
Core.InfoTable ->
Sem r ()
runRepl :: CoreReplOptions -> Core.InfoTable -> Sem r ()
runRepl opts tab = do
embed (putStr "> ")
embed (hFlush stdout)
@ -291,7 +293,7 @@ runCoreCommand globalOpts = \case
printJuvixError (JuvixError err)
runRepl opts tab
Right (tab', Just node) -> do
renderStdOut (Core.ppOut (docOpts (opts ^. coreReplShowDeBruijn)) node)
renderStdOut (Core.ppOut docOpts node)
embed (putStrLn "")
runRepl opts tab'
Right (tab', Nothing) ->
@ -311,10 +313,9 @@ runCoreCommand globalOpts = \case
Left err -> do
printJuvixError (JuvixError err)
runRepl opts tab
Right (tab', Just node) ->
replEval False tab' node
Right (tab', Nothing) ->
runRepl opts tab'
Right (tab', mnode) -> case mnode of
Nothing -> runRepl opts tab'
Just node -> replEval False tab' node
":r" ->
runRepl opts Core.emptyInfoTable
_ ->
@ -327,8 +328,8 @@ runCoreCommand globalOpts = \case
Right (tab', Nothing) ->
runRepl opts tab'
where
defaultLoc = singletonInterval (mkLoc "stdin" 0 (M.initialPos "stdin"))
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
@ -337,12 +338,13 @@ runCoreCommand globalOpts = \case
printJuvixError (JuvixError err)
runRepl opts tab'
Right node'
| Info.member Info.kNoDisplayInfo (Core.getInfo node') ->
| Info.member Info.kNoDisplayInfo (Core.getInfo node') -> runRepl opts tab'
| otherwise -> do
renderStdOut (Core.ppOut docOpts node')
embed (putStrLn "")
runRepl opts tab'
Right node' -> do
renderStdOut (Core.ppOut (docOpts (opts ^. coreReplShowDeBruijn)) node')
embed (putStrLn "")
runRepl opts tab'
where
defaultLoc = singletonInterval (mkLoc "stdin" 0 (M.initialPos "stdin"))
showReplWelcome :: IO ()
showReplWelcome = do
@ -367,7 +369,7 @@ runCoreCommand globalOpts = \case
putStrLn ":h Display this help message."
putStrLn ""
evalFile :: Members '[Embed IO, App] r => CoreEvalOptions -> FilePath -> Sem r ()
evalFile :: CoreEvalOptions -> FilePath -> Sem r ()
evalFile opts f = do
s <- embed (readFile f)
case Core.runParser "" f Core.emptyInfoTable s of
@ -380,14 +382,15 @@ runCoreCommand globalOpts = \case
| Info.member Info.kNoDisplayInfo (Core.getInfo node') ->
return ()
Right node' -> do
renderStdOut (Core.ppOut (docOpts (opts ^. coreEvalShowDeBruijn)) node')
renderStdOut (Core.ppOut docOpts node')
embed (putStrLn "")
Right (_, Nothing) -> return ()
where
docOpts :: Core.Options
docOpts = Core.defaultOptions
defaultLoc = singletonInterval (mkLoc f 0 (M.initialPos f))
doEval ::
Members '[Embed IO, App] r =>
Bool ->
Interval ->
Core.InfoTable ->

View File

@ -17,4 +17,4 @@ data ScoperResult = ScoperResult
makeLenses ''ScoperResult
mainModule :: Lens' ScoperResult (Module 'Scoped 'ModuleTop)
mainModule = resultModules . _head
mainModule = resultModules . _head1

View File

@ -0,0 +1,4 @@
module Juvix.Compiler.Core.Data.TransformationId where
data TransformationId
= LambdaLifting

View File

@ -0,0 +1,31 @@
module Juvix.Compiler.Core.Data.TransformationId.Parser (parseTransformations, TransformationId (..)) where
import Juvix.Compiler.Core.Data.TransformationId
import Juvix.Prelude
import Juvix.Prelude.Pretty hiding (comma)
import Text.Megaparsec
import Text.Megaparsec.Char qualified as L
import Text.Megaparsec.Char.Lexer qualified as L
parseTransformations :: Text -> Either Text [TransformationId]
parseTransformations t = case runParser transformations "<input>" t of
Left (err :: ParseErrorBundle Text Void) -> Left (prettyText (errorBundlePretty err))
Right r -> return r
transformations :: MonadParsec e Text m => m [TransformationId]
transformations = do
L.hspace
sepEndBy transformation comma <* eof
lexeme :: MonadParsec e Text m => m a -> m a
lexeme = L.lexeme L.hspace
comma :: MonadParsec e Text m => m ()
comma = symbol ","
symbol :: MonadParsec e Text m => Text -> m ()
symbol = void . lexeme . chunk
transformation :: MonadParsec e Text m => m TransformationId
transformation =
symbol "lifting" $> LambdaLifting

View File

@ -5,10 +5,11 @@ module Juvix.Compiler.Core.Pretty.Base
)
where
import Data.List qualified as List
import Data.HashMap.Strict qualified as HashMap
import Juvix.Compiler.Core.Data.InfoTable
import Juvix.Compiler.Core.Extra
import Juvix.Compiler.Core.Info qualified as Info
import Juvix.Compiler.Core.Info.BinderInfo as BinderInfo
import Juvix.Compiler.Core.Info.BinderInfo
import Juvix.Compiler.Core.Info.BranchInfo as BranchInfo
import Juvix.Compiler.Core.Info.NameInfo as NameInfo
import Juvix.Compiler.Core.Language
@ -63,6 +64,23 @@ instance PrettyCode Tag where
BuiltinTag tag -> ppCode tag
UserTag tag -> return $ kwUnnamedConstr <> pretty tag
instance PrettyCode InfoTable where
ppCode :: forall r. Member (Reader Options) r => InfoTable -> Sem r (Doc Ann)
ppCode tbl = do
ctx' <- ppContext (tbl ^. identContext)
return ("-- IdentContext" <> line <> ctx' <> line)
where
ppContext :: IdentContext -> Sem r (Doc Ann)
ppContext ctx = do
defs <- mapM (uncurry ppDef) (HashMap.toList ctx)
return (vsep defs)
where
ppDef :: Symbol -> Node -> Sem r (Doc Ann)
ppDef s n = do
sym' <- maybe (return (pretty s)) ppCode (tbl ^? infoIdentifiers . at s . _Just . identifierName)
body' <- ppCode n
return (kwDef <+> sym' <+> kwAssign <+> body')
instance PrettyCode Node where
ppCode :: forall r. Member (Reader Options) r => Node -> Sem r (Doc Ann)
ppCode node = case node of
@ -124,17 +142,16 @@ instance PrettyCode Node where
ns <- mapM getName (getInfoBinders n _letRecInfo)
vs <- mapM ppCode _letRecValues
b' <- ppCode _letRecBody
if
| length ns == 1 ->
return $ kwLetRec <+> List.head ns <+> kwAssign <+> head vs <+> kwIn <+> b'
| otherwise ->
let bss =
indent' $
align $
concatWith (\a b -> a <> kwSemicolon <> line <> b) $
zipWithExact (\name val -> name <+> kwAssign <+> val) ns (toList vs)
nss = enclose kwSquareL kwSquareR (concatWith (<+>) ns)
in return $ kwLetRec <> nss <> line <> bss <> line <> kwIn <> line <> b'
case listToMaybe ns of
Just hns -> return $ kwLetRec <+> hns <+> kwAssign <+> head vs <+> kwIn <+> b'
Nothing ->
let bss =
indent' $
align $
concatWith (\a b -> a <> kwSemicolon <> line <> b) $
zipWithExact (\name val -> name <+> kwAssign <+> val) ns (toList vs)
nss = enclose kwSquareL kwSquareR (concatWith (<+>) ns)
in return $ kwLetRec <> nss <> line <> bss <> line <> kwIn <> line <> b'
where
getName :: Info -> Sem r (Doc Ann)
getName i =
@ -282,6 +299,9 @@ kwDefault = keyword Str.underscore
kwPi :: Doc Ann
kwPi = keyword Str.pi_
kwDef :: Doc Ann
kwDef = keyword Str.def
kwTrace :: Doc Ann
kwTrace = keyword Str.trace_

View File

@ -8,6 +8,8 @@ data Options = Options
_optShowDeBruijnIndices :: Bool
}
makeLenses ''Options
defaultOptions :: Options
defaultOptions =
Options
@ -16,7 +18,13 @@ defaultOptions =
_optShowDeBruijnIndices = False
}
makeLenses ''Options
traceOptions :: Options
traceOptions =
Options
{ _optIndent = 2,
_optShowNameIds = False,
_optShowDeBruijnIndices = True
}
fromGenericOptions :: GenericOptions -> Options
fromGenericOptions GenericOptions {..} = set optShowNameIds _showNameIds defaultOptions

View File

@ -1,10 +1,20 @@
module Juvix.Compiler.Core.Transformation
( module Juvix.Compiler.Core.Transformation.Base,
module Juvix.Compiler.Core.Transformation,
module Juvix.Compiler.Core.Transformation.Eta,
module Juvix.Compiler.Core.Transformation.LambdaLifting,
module Juvix.Compiler.Core.Data.TransformationId,
)
where
import Juvix.Compiler.Core.Data.TransformationId
import Juvix.Compiler.Core.Transformation.Base
import Juvix.Compiler.Core.Transformation.Eta
import Juvix.Compiler.Core.Transformation.LambdaLifting
applyTransformations :: [TransformationId] -> InfoTable -> InfoTable
applyTransformations ts tbl = foldl' (flip appTrans) tbl ts
where
appTrans :: TransformationId -> InfoTable -> InfoTable
appTrans = \case
LambdaLifting -> lambdaLifting

View File

@ -4,13 +4,10 @@ module Juvix.Compiler.Core.Transformation.LambdaLifting
)
where
import Juvix.Compiler.Core.Data.InfoTableBuilder
import Juvix.Compiler.Core.Transformation.Base
lambdaLiftNode :: Member InfoTableBuilder r => Node -> Sem r Node
lambdaLiftNode _ = do
void freshSymbol
error "not yet implemented"
lambdaLiftNode :: Node -> Sem r Node
lambdaLiftNode = return
lambdaLifting :: Transformation
lambdaLifting :: InfoTable -> InfoTable
lambdaLifting = run . mapT' lambdaLiftNode

View File

@ -13,7 +13,7 @@ data InternalArityResult = InternalArityResult
makeLenses ''InternalArityResult
mainModule :: Lens' InternalArityResult Module
mainModule = resultModules . _head
mainModule = resultModules . _head1
internalArityResultEntryPoint :: Lens' InternalArityResult E.EntryPoint
internalArityResultEntryPoint = resultInternalResult . M.microJuvixResultEntryPoint

View File

@ -25,7 +25,7 @@ data InternalTypedResult = InternalTypedResult
makeLenses ''InternalTypedResult
mainModule :: Lens' InternalTypedResult Module
mainModule = resultModules . _head
mainModule = resultModules . _head1
internalTypedResultEntryPoint :: Lens' InternalTypedResult E.EntryPoint
internalTypedResultEntryPoint = resultInternalArityResult . Arity.internalArityResultEntryPoint

View File

@ -36,4 +36,4 @@ defaultEntryPoint mainFile =
makeLenses ''EntryPoint
mainModulePath :: Lens' EntryPoint FilePath
mainModulePath = entryPointModulePaths . _head
mainModulePath = entryPointModulePaths . _head1

View File

@ -132,7 +132,7 @@ import GHC.Num
import GHC.Real
import GHC.Stack.Types
import Language.Haskell.TH.Syntax (Lift)
import Lens.Micro.Platform hiding (both, _head)
import Lens.Micro.Platform hiding (both)
import Polysemy
import Polysemy.Embed
import Polysemy.Error hiding (fromEither)

View File

@ -3,5 +3,5 @@ module Juvix.Prelude.Lens where
import Juvix.Prelude.Base
-- | points to the first element of a non-empty list.
_head :: Lens' (NonEmpty a) a
_head = singular each
_head1 :: Lens' (NonEmpty a) a
_head1 = singular each

View File

@ -1,6 +1,11 @@
module Juvix.Prelude.Trace where
module Juvix.Prelude.Trace
( module Juvix.Prelude.Trace,
module Debug.Trace,
)
where
import Data.Text qualified as Text
import Debug.Trace hiding (trace, traceM, traceShow)
import Debug.Trace qualified as T
import GHC.IO (unsafePerformIO)
import Juvix.Prelude.Base
@ -20,6 +25,10 @@ trace :: Text -> a -> a
trace = traceLabel ""
{-# WARNING trace "Using trace" #-}
traceM :: Applicative f => Text -> f ()
traceM t = traceLabel "" t (pure ())
{-# WARNING traceM "Using traceM" #-}
traceShow :: Show b => b -> b
traceShow b = traceLabel "" (pack . show $ b) b
{-# WARNING traceShow "Using traceShow" #-}

View File

@ -1,8 +1,8 @@
module Core where
import Base
import Core.Negative qualified as N
import Core.Positive qualified as P
import Core.Eval qualified as Eval
import Core.Transformation qualified as Transformation
allTests :: TestTree
allTests = testGroup "JuvixCore tests" [P.allTests, N.allTests]
allTests = testGroup "JuvixCore tests" [Eval.allTests, Transformation.allTests]

8
test/Core/Eval.hs Normal file
View File

@ -0,0 +1,8 @@
module Core.Eval where
import Base
import Core.Eval.Negative qualified as EvalN
import Core.Eval.Positive qualified as EvalP
allTests :: TestTree
allTests = testGroup "JuvixCore eval" [EvalP.allTests, EvalN.allTests]

View File

@ -1,4 +1,4 @@
module Core.Base where
module Core.Eval.Base where
import Base
import Data.Text.IO qualified as TIO

View File

@ -1,7 +1,7 @@
module Core.Negative where
module Core.Eval.Negative where
import Base
import Core.Base
import Core.Eval.Base
data NegTest = NegTest
{ _name :: String,

View File

@ -1,7 +1,7 @@
module Core.Positive where
module Core.Eval.Positive where
import Base
import Core.Base
import Core.Eval.Base
data PosTest = PosTest
{ _name :: String,
@ -226,7 +226,7 @@ tests =
"test039.jvc"
"out/test039.out",
PosTest
"Letrec"
"LetRec"
"."
"test040.jvc"
"out/test040.out"

View File

@ -0,0 +1,7 @@
module Core.Transformation where
import Base
import Core.Transformation.Lifting qualified as Lifting
allTests :: TestTree
allTests = testGroup "JuvixCore transformations" [Lifting.allTests]

View File

@ -0,0 +1,39 @@
module Core.Transformation.Base where
import Base
import Juvix.Compiler.Core.Data.InfoTable
import Juvix.Compiler.Core.Pretty
import Juvix.Compiler.Core.Transformation
import Juvix.Compiler.Core.Translation.FromSource
import Prettyprinter.Render.Text qualified as Text
data Test = Test
{ _testName :: String,
_testCoreFile :: FilePath,
_testExpectedFile :: FilePath,
_testTransformations :: [TransformationId]
}
fromTest :: Test -> TestTree
fromTest = mkTest . toTestDescr
troot :: FilePath
troot = "tests/Core/positive/"
toTestDescr :: Test -> TestDescr
toTestDescr t@Test {..} =
TestDescr
{ _testName,
_testRoot = troot,
_testAssertion = Single (coreTransAssertion t)
}
coreTransAssertion :: Test -> Assertion
coreTransAssertion Test {..} = do
r <- applyTransformations [LambdaLifting] <$> parseFile _testCoreFile
expected <- readFile _testExpectedFile
let actualOutput = Text.renderStrict (toTextStream (ppOutDefault r))
assertEqDiff ("Check: EVAL output = " <> _testExpectedFile) actualOutput expected
parseFile :: FilePath -> IO InfoTable
parseFile f = fst <$> fromRightIO show (runParser "" f emptyInfoTable <$> readFile f)

View File

@ -0,0 +1,9 @@
module Core.Transformation.Lifting (allTests) where
import Base
allTests :: TestTree
allTests = testGroup "Lambda lifting" tests
tests :: [TestTree]
tests = []