From 8b689708532ac46f21fddcc761c399fc0a594931 Mon Sep 17 00:00:00 2001
From: Jan Mas Rovira <janmasrovira@gmail.com>
Date: Tue, 6 Sep 2022 12:28:39 +0200
Subject: [PATCH 1/7] add core read command
---
app/App.hs | 18 ++++-
app/Commands/Dev/Core.hs | 70 ++++++++++++++-----
app/Main.hs | 67 +++++++++---------
.../Analysis/Scoping/Data/Context.hs | 2 +-
.../Compiler/Core/Data/TransformationId.hs | 4 ++
.../Core/Data/TransformationId/Parser.hs | 31 ++++++++
src/Juvix/Compiler/Core/Pretty/Base.hs | 46 ++++++++----
src/Juvix/Compiler/Core/Pretty/Options.hs | 10 ++-
src/Juvix/Compiler/Core/Transformation.hs | 10 +++
.../Core/Transformation/LambdaLifting.hs | 10 ++-
.../Analysis/ArityChecking/Data/Context.hs | 2 +-
.../Analysis/TypeChecking/Data/Context.hs | 2 +-
src/Juvix/Compiler/Pipeline/EntryPoint.hs | 2 +-
src/Juvix/Prelude/Base.hs | 2 +-
src/Juvix/Prelude/Lens.hs | 4 +-
src/Juvix/Prelude/Trace.hs | 11 ++-
test/Core.hs | 6 +-
test/Core/Transformation.hs | 7 ++
test/Core/Transformation/Base.hs | 39 +++++++++++
test/Core/Transformation/Lifting.hs | 33 +++++++++
test/Reachability/Positive.hs | 2 +-
test/Scope/Positive.hs | 10 +--
test/Termination/Positive.hs | 4 +-
test/TypeCheck/Positive.hs | 4 +-
24 files changed, 304 insertions(+), 92 deletions(-)
create mode 100644 src/Juvix/Compiler/Core/Data/TransformationId.hs
create mode 100644 src/Juvix/Compiler/Core/Data/TransformationId/Parser.hs
create mode 100644 test/Core/Transformation.hs
create mode 100644 test/Core/Transformation/Base.hs
create mode 100644 test/Core/Transformation/Lifting.hs
diff --git a/app/App.hs b/app/App.hs
index 5ad70380f2..16f7aa14d1 100644
--- a/app/App.hs
+++ b/app/App.hs
@@ -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
diff --git a/app/Commands/Dev/Core.hs b/app/Commands/Dev/Core.hs
index e907b0c3ac..358736265e 100644
--- a/app/Commands/Dev/Core.hs
+++ b/app/Commands/Dev/Core.hs
@@ -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 {..}
diff --git a/app/Main.hs b/app/Main.hs
index fce1020abc..7cf950afbd 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -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 ->
diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Data/Context.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Data/Context.hs
index b1e89a4fbb..83dbccc750 100644
--- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Data/Context.hs
+++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Data/Context.hs
@@ -17,4 +17,4 @@ data ScoperResult = ScoperResult
makeLenses ''ScoperResult
mainModule :: Lens' ScoperResult (Module 'Scoped 'ModuleTop)
-mainModule = resultModules . _head
+mainModule = resultModules . _head1
diff --git a/src/Juvix/Compiler/Core/Data/TransformationId.hs b/src/Juvix/Compiler/Core/Data/TransformationId.hs
new file mode 100644
index 0000000000..cd7402e2d7
--- /dev/null
+++ b/src/Juvix/Compiler/Core/Data/TransformationId.hs
@@ -0,0 +1,4 @@
+module Juvix.Compiler.Core.Data.TransformationId where
+
+data TransformationId
+ = LambdaLifting
diff --git a/src/Juvix/Compiler/Core/Data/TransformationId/Parser.hs b/src/Juvix/Compiler/Core/Data/TransformationId/Parser.hs
new file mode 100644
index 0000000000..dac7d81b62
--- /dev/null
+++ b/src/Juvix/Compiler/Core/Data/TransformationId/Parser.hs
@@ -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
diff --git a/src/Juvix/Compiler/Core/Pretty/Base.hs b/src/Juvix/Compiler/Core/Pretty/Base.hs
index a1d15949e3..cedd6bfbbd 100644
--- a/src/Juvix/Compiler/Core/Pretty/Base.hs
+++ b/src/Juvix/Compiler/Core/Pretty/Base.hs
@@ -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_
diff --git a/src/Juvix/Compiler/Core/Pretty/Options.hs b/src/Juvix/Compiler/Core/Pretty/Options.hs
index 51967f113e..63c7242e4d 100644
--- a/src/Juvix/Compiler/Core/Pretty/Options.hs
+++ b/src/Juvix/Compiler/Core/Pretty/Options.hs
@@ -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
diff --git a/src/Juvix/Compiler/Core/Transformation.hs b/src/Juvix/Compiler/Core/Transformation.hs
index 0da169b0b2..69fb993abf 100644
--- a/src/Juvix/Compiler/Core/Transformation.hs
+++ b/src/Juvix/Compiler/Core/Transformation.hs
@@ -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
diff --git a/src/Juvix/Compiler/Core/Transformation/LambdaLifting.hs b/src/Juvix/Compiler/Core/Transformation/LambdaLifting.hs
index 21592a1a5a..eec594f133 100644
--- a/src/Juvix/Compiler/Core/Transformation/LambdaLifting.hs
+++ b/src/Juvix/Compiler/Core/Transformation/LambdaLifting.hs
@@ -4,13 +4,11 @@ module Juvix.Compiler.Core.Transformation.LambdaLifting
)
where
-import Juvix.Compiler.Core.Data.InfoTableBuilder
+import Juvix.Compiler.Core.Pretty
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
diff --git a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/ArityChecking/Data/Context.hs b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/ArityChecking/Data/Context.hs
index e4246435e1..559708e66c 100644
--- a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/ArityChecking/Data/Context.hs
+++ b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/ArityChecking/Data/Context.hs
@@ -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
diff --git a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/Context.hs b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/Context.hs
index 471f3a1b0d..1e0b55e8a1 100644
--- a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/Context.hs
+++ b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/Context.hs
@@ -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
diff --git a/src/Juvix/Compiler/Pipeline/EntryPoint.hs b/src/Juvix/Compiler/Pipeline/EntryPoint.hs
index 71bda99383..075c28c202 100644
--- a/src/Juvix/Compiler/Pipeline/EntryPoint.hs
+++ b/src/Juvix/Compiler/Pipeline/EntryPoint.hs
@@ -36,4 +36,4 @@ defaultEntryPoint mainFile =
makeLenses ''EntryPoint
mainModulePath :: Lens' EntryPoint FilePath
-mainModulePath = entryPointModulePaths . _head
+mainModulePath = entryPointModulePaths . _head1
diff --git a/src/Juvix/Prelude/Base.hs b/src/Juvix/Prelude/Base.hs
index 3ddb789433..ce0163a566 100644
--- a/src/Juvix/Prelude/Base.hs
+++ b/src/Juvix/Prelude/Base.hs
@@ -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)
diff --git a/src/Juvix/Prelude/Lens.hs b/src/Juvix/Prelude/Lens.hs
index 9dcacb7954..bd8561d78e 100644
--- a/src/Juvix/Prelude/Lens.hs
+++ b/src/Juvix/Prelude/Lens.hs
@@ -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
diff --git a/src/Juvix/Prelude/Trace.hs b/src/Juvix/Prelude/Trace.hs
index 01b7d565f1..a0938b8e89 100644
--- a/src/Juvix/Prelude/Trace.hs
+++ b/src/Juvix/Prelude/Trace.hs
@@ -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" #-}
diff --git a/test/Core.hs b/test/Core.hs
index 52a22ed4b5..6d6c26ea04 100644
--- a/test/Core.hs
+++ b/test/Core.hs
@@ -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]
diff --git a/test/Core/Transformation.hs b/test/Core/Transformation.hs
new file mode 100644
index 0000000000..8d20dddcfa
--- /dev/null
+++ b/test/Core/Transformation.hs
@@ -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]
diff --git a/test/Core/Transformation/Base.hs b/test/Core/Transformation/Base.hs
new file mode 100644
index 0000000000..1d68ef0b25
--- /dev/null
+++ b/test/Core/Transformation/Base.hs
@@ -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)
diff --git a/test/Core/Transformation/Lifting.hs b/test/Core/Transformation/Lifting.hs
new file mode 100644
index 0000000000..8708eb4aef
--- /dev/null
+++ b/test/Core/Transformation/Lifting.hs
@@ -0,0 +1,33 @@
+module Core.Transformation.Lifting (allTests) where
+
+import Base
+import Core.Transformation.Base
+import Juvix.Compiler.Core.Transformation
+
+allTests :: TestTree
+allTests = testGroup "Lambda lifting" tests
+
+pipe :: [TransformationId]
+pipe = [LambdaLifting]
+
+dir :: FilePath
+dir = "lambda-lifting"
+
+liftTest :: String -> FilePath -> FilePath -> TestTree
+liftTest _testName _testCoreFile _testExpectedFile =
+ fromTest
+ Test
+ { _testTransformations = pipe,
+ _testCoreFile = dir </> _testCoreFile,
+ _testName,
+ _testExpectedFile = dir </> _testExpectedFile
+ }
+
+tests :: [TestTree]
+tests =
+ [ liftTest
+ ("Lambda lifting without let rec " <> i)
+ ("test" <> i <> ".jvc")
+ ("test" <> i <> ".out")
+ | i <- map show [1 :: Int .. 3]
+ ]
diff --git a/test/Reachability/Positive.hs b/test/Reachability/Positive.hs
index 51d175ca72..373fbf903f 100644
--- a/test/Reachability/Positive.hs
+++ b/test/Reachability/Positive.hs
@@ -36,7 +36,7 @@ testDescr PosTest {..} =
}
step "Pipeline up to reachability"
- p :: Micro.InternalTypedResult <- runIO' (upToInternalReachability entryPoint)
+ p :: Micro.InternalTypedResult <- runIO (upToInternalReachability entryPoint)
step "Check reachability results"
let names = concatMap getNames (p ^. Micro.resultModules)
diff --git a/test/Scope/Positive.hs b/test/Scope/Positive.hs
index 89f0f14e67..549dafffb2 100644
--- a/test/Scope/Positive.hs
+++ b/test/Scope/Positive.hs
@@ -49,13 +49,13 @@ testDescr PosTest {..} =
| otherwise = HashMap.union fs stdlibMap
step "Parsing"
- p :: Parser.ParserResult <- runIO' (upToParsing entryPoint)
+ p :: Parser.ParserResult <- runIO (upToParsing entryPoint)
let p2 = head (p ^. Parser.resultModules)
step "Scoping"
s :: Scoper.ScoperResult <-
- runIO'
+ runIO
( do
void (entrySetup entryPoint)
Concrete.fromParsed p
@@ -78,18 +78,18 @@ testDescr PosTest {..} =
step "Parsing pretty scoped"
let fs2 = unionStdlib (HashMap.singleton entryFile scopedPretty)
p' :: Parser.ParserResult <-
- (runM . runErrorIO' @JuvixError . runNameIdGen . runFilesPure fs2)
+ (runM . runErrorIO @JuvixError . runNameIdGen . runFilesPure fs2)
(upToParsing entryPoint)
step "Parsing pretty parsed"
let fs3 = unionStdlib (HashMap.singleton entryFile parsedPretty)
parsedPretty' :: Parser.ParserResult <-
- (runM . runErrorIO' @JuvixError . runNameIdGen . runFilesPure fs3)
+ (runM . runErrorIO @JuvixError . runNameIdGen . runFilesPure fs3)
(upToParsing entryPoint)
step "Scoping the scoped"
s' :: Scoper.ScoperResult <-
- (runM . runErrorIO' @JuvixError . runNameIdGen . runFilesPure fs)
+ (runM . runErrorIO @JuvixError . runNameIdGen . runFilesPure fs)
(upToScoping entryPoint)
step "Checks"
diff --git a/test/Termination/Positive.hs b/test/Termination/Positive.hs
index 1ffa1183d4..22de643edf 100644
--- a/test/Termination/Positive.hs
+++ b/test/Termination/Positive.hs
@@ -21,7 +21,7 @@ testDescr PosTest {..} =
_testRoot = tRoot,
_testAssertion = Single $ do
let entryPoint = (defaultEntryPoint _file) {_entryPointNoStdlib = True}
- (void . runIO') (upToInternal entryPoint)
+ (void . runIO) (upToInternal entryPoint)
}
--------------------------------------------------------------------------------
@@ -45,7 +45,7 @@ testDescrFlag N.NegTest {..} =
_entryPointNoStdlib = True
}
- (void . runIO') (upToInternal entryPoint)
+ (void . runIO) (upToInternal entryPoint)
}
--------------------------------------------------------------------------------
diff --git a/test/TypeCheck/Positive.hs b/test/TypeCheck/Positive.hs
index e5e5ed01e3..535522abaa 100644
--- a/test/TypeCheck/Positive.hs
+++ b/test/TypeCheck/Positive.hs
@@ -21,7 +21,7 @@ testDescr PosTest {..} =
_testRoot = tRoot,
_testAssertion = Single $ do
let entryPoint = defaultEntryPoint _file
- (void . runIO') (upToInternalTyped entryPoint)
+ (void . runIO) (upToInternalTyped entryPoint)
}
--------------------------------------------------------------------------------
@@ -43,7 +43,7 @@ testNoPositivityFlag N.NegTest {..} =
{ _entryPointNoPositivity = True
}
- (void . runIO') (upToInternal entryPoint)
+ (void . runIO) (upToInternal entryPoint)
}
negPositivityTests :: [N.NegTest]
From 827eb30524ca2f7b68505705e23b59913749c029 Mon Sep 17 00:00:00 2001
From: Jan Mas Rovira <janmasrovira@gmail.com>
Date: Tue, 6 Sep 2022 12:36:23 +0200
Subject: [PATCH 2/7] format
---
src/Juvix/Compiler/Core/Pretty/Base.hs | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/src/Juvix/Compiler/Core/Pretty/Base.hs b/src/Juvix/Compiler/Core/Pretty/Base.hs
index cedd6bfbbd..2a828fe5c6 100644
--- a/src/Juvix/Compiler/Core/Pretty/Base.hs
+++ b/src/Juvix/Compiler/Core/Pretty/Base.hs
@@ -151,7 +151,7 @@ instance PrettyCode Node where
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'
+ in return $ kwLetRec <> nss <> line <> bss <> line <> kwIn <> line <> b'
where
getName :: Info -> Sem r (Doc Ann)
getName i =
From d0a786e9e58eced72738541d97fececa63e3a845 Mon Sep 17 00:00:00 2001
From: Jan Mas Rovira <janmasrovira@gmail.com>
Date: Tue, 6 Sep 2022 12:46:39 +0200
Subject: [PATCH 3/7] recover core eval tests
---
test/Core/Eval.hs | 8 ++
test/Core/Eval/Base.hs | 82 +++++++++++++
test/Core/Eval/Negative.hs | 68 +++++++++++
test/Core/Eval/Positive.hs | 228 +++++++++++++++++++++++++++++++++++++
4 files changed, 386 insertions(+)
create mode 100644 test/Core/Eval.hs
create mode 100644 test/Core/Eval/Base.hs
create mode 100644 test/Core/Eval/Negative.hs
create mode 100644 test/Core/Eval/Positive.hs
diff --git a/test/Core/Eval.hs b/test/Core/Eval.hs
new file mode 100644
index 0000000000..3d4ac85da4
--- /dev/null
+++ b/test/Core/Eval.hs
@@ -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]
diff --git a/test/Core/Eval/Base.hs b/test/Core/Eval/Base.hs
new file mode 100644
index 0000000000..69f1a79a60
--- /dev/null
+++ b/test/Core/Eval/Base.hs
@@ -0,0 +1,82 @@
+module Core.Eval.Base where
+
+import Base
+import Data.Text.IO qualified as TIO
+import Juvix.Compiler.Core.Data.InfoTable
+import Juvix.Compiler.Core.Error
+import Juvix.Compiler.Core.Evaluator
+import Juvix.Compiler.Core.Extra
+import Juvix.Compiler.Core.Info qualified as Info
+import Juvix.Compiler.Core.Info.NoDisplayInfo
+import Juvix.Compiler.Core.Language
+import Juvix.Compiler.Core.Pretty
+import Juvix.Compiler.Core.Translation.FromSource
+import System.IO.Extra (withTempDir)
+import Text.Megaparsec.Pos qualified as M
+
+coreEvalAssertion :: FilePath -> FilePath -> (String -> IO ()) -> Assertion
+coreEvalAssertion mainFile expectedFile step = do
+ step "Parse"
+ r <- parseFile mainFile
+ case r of
+ Left err -> assertFailure (show (pretty err))
+ Right (_, Nothing) -> do
+ step "Compare expected and actual program output"
+ expected <- TIO.readFile expectedFile
+ assertEqDiff ("Check: EVAL output = " <> expectedFile) "" expected
+ Right (tab, Just node) -> do
+ withTempDir
+ ( \dirPath -> do
+ let outputFile = dirPath </> "out.out"
+ hout <- openFile outputFile WriteMode
+ step "Evaluate"
+ r' <- doEval mainFile hout tab node
+ case r' of
+ Left err -> do
+ hClose hout
+ assertFailure (show (pretty err))
+ Right value -> do
+ unless
+ (Info.member kNoDisplayInfo (getInfo value))
+ (hPutStrLn hout (ppPrint value))
+ hClose hout
+ actualOutput <- TIO.readFile outputFile
+ step "Compare expected and actual program output"
+ expected <- TIO.readFile expectedFile
+ assertEqDiff ("Check: EVAL output = " <> expectedFile) actualOutput expected
+ )
+
+coreEvalErrorAssertion :: FilePath -> (String -> IO ()) -> Assertion
+coreEvalErrorAssertion mainFile step = do
+ step "Parse"
+ r <- parseFile mainFile
+ case r of
+ Left _ -> assertBool "" True
+ Right (_, Nothing) -> assertFailure "no error"
+ Right (tab, Just node) -> do
+ withTempDir
+ ( \dirPath -> do
+ let outputFile = dirPath </> "out.out"
+ hout <- openFile outputFile WriteMode
+ step "Evaluate"
+ r' <- doEval mainFile hout tab node
+ case r' of
+ Left _ -> assertBool "" True
+ Right _ -> assertFailure "no error"
+ )
+
+parseFile :: FilePath -> IO (Either ParserError (InfoTable, Maybe Node))
+parseFile f = do
+ s <- readFile f
+ return $ runParser "" f emptyInfoTable s
+
+doEval ::
+ FilePath ->
+ Handle ->
+ InfoTable ->
+ Node ->
+ IO (Either CoreError Node)
+doEval f hout tab node =
+ catchEvalErrorIO defaultLoc (hEvalIO stdin hout (tab ^. identContext) [] node)
+ where
+ defaultLoc = singletonInterval (mkLoc f 0 (M.initialPos f))
diff --git a/test/Core/Eval/Negative.hs b/test/Core/Eval/Negative.hs
new file mode 100644
index 0000000000..28b3d87ed0
--- /dev/null
+++ b/test/Core/Eval/Negative.hs
@@ -0,0 +1,68 @@
+module Core.Eval.Negative where
+
+import Base
+import Core.Eval.Base
+
+data NegTest = NegTest
+ { _name :: String,
+ _relDir :: FilePath,
+ _file :: FilePath
+ }
+
+root :: FilePath
+root = "tests/Core/negative"
+
+testDescr :: NegTest -> TestDescr
+testDescr NegTest {..} =
+ let tRoot = root </> _relDir
+ in TestDescr
+ { _testName = _name,
+ _testRoot = tRoot,
+ _testAssertion = Steps $ coreEvalErrorAssertion _file
+ }
+
+allTests :: TestTree
+allTests =
+ testGroup
+ "JuvixCore negative tests"
+ (map (mkTest . testDescr) tests)
+
+tests :: [NegTest]
+tests =
+ [ NegTest
+ "Division by zero"
+ "."
+ "test001.jvc",
+ NegTest
+ "Arithmetic operations on non-numbers"
+ "."
+ "test002.jvc",
+ NegTest
+ "Matching on non-data"
+ "."
+ "test003.jvc",
+ NegTest
+ "If on non-boolean"
+ "."
+ "test004.jvc",
+ NegTest
+ "No matching case branch"
+ "."
+ "test005.jvc",
+ NegTest
+ "Invalid application"
+ "."
+ "test006.jvc",
+ NegTest
+ "Invalid builtin application"
+ "."
+ "test007.jvc",
+ NegTest
+ "Undefined symbol"
+ "."
+ "test008.jvc",
+ NegTest
+ "Erroneous Church numerals"
+ "."
+ "test009.jvc"
+ ]
diff --git a/test/Core/Eval/Positive.hs b/test/Core/Eval/Positive.hs
new file mode 100644
index 0000000000..ebf8c54e91
--- /dev/null
+++ b/test/Core/Eval/Positive.hs
@@ -0,0 +1,228 @@
+module Core.Eval.Positive where
+
+import Base
+import Core.Eval.Base
+
+data PosTest = PosTest
+ { _name :: String,
+ _relDir :: FilePath,
+ _file :: FilePath,
+ _expectedFile :: FilePath
+ }
+
+root :: FilePath
+root = "tests/Core/positive"
+
+testDescr :: PosTest -> TestDescr
+testDescr PosTest {..} =
+ let tRoot = root </> _relDir
+ in TestDescr
+ { _testName = _name,
+ _testRoot = tRoot,
+ _testAssertion = Steps $ coreEvalAssertion _file _expectedFile
+ }
+
+allTests :: TestTree
+allTests =
+ testGroup
+ "JuvixCore positive tests"
+ (map (mkTest . testDescr) tests)
+
+tests :: [PosTest]
+tests =
+ [ PosTest
+ "Arithmetic operators"
+ "."
+ "test001.jvc"
+ "out/test001.out",
+ PosTest
+ "Arithmetic operators inside lambdas"
+ "."
+ "test002.jvc"
+ "out/test002.out",
+ PosTest
+ "Empty program with comments"
+ "."
+ "test003.jvc"
+ "out/test003.out",
+ PosTest
+ "IO builtins"
+ "."
+ "test004.jvc"
+ "out/test004.out",
+ PosTest
+ "Higher-order functions"
+ "."
+ "test005.jvc"
+ "out/test005.out",
+ PosTest
+ "If-then-else"
+ "."
+ "test006.jvc"
+ "out/test006.out",
+ PosTest
+ "Case"
+ "."
+ "test007.jvc"
+ "out/test007.out",
+ PosTest
+ "Recursion"
+ "."
+ "test008.jvc"
+ "out/test008.out",
+ PosTest
+ "Tail recursion"
+ "."
+ "test009.jvc"
+ "out/test009.out",
+ PosTest
+ "Let"
+ "."
+ "test010.jvc"
+ "out/test010.out",
+ PosTest
+ "Tail recursion: Fibonacci numbers in linear time"
+ "."
+ "test011.jvc"
+ "out/test011.out",
+ PosTest
+ "Trees"
+ "."
+ "test012.jvc"
+ "out/test012.out",
+ PosTest
+ "Functions returning functions with variable capture"
+ "."
+ "test013.jvc"
+ "out/test013.out",
+ PosTest
+ "Arithmetic"
+ "."
+ "test014.jvc"
+ "out/test014.out",
+ PosTest
+ "Local functions with free variables"
+ "."
+ "test015.jvc"
+ "out/test015.out",
+ PosTest
+ "Recursion through higher-order functions"
+ "."
+ "test016.jvc"
+ "out/test016.out",
+ PosTest
+ "Tail recursion through higher-order functions"
+ "."
+ "test017.jvc"
+ "out/test017.out",
+ PosTest
+ "Higher-order functions and recursion"
+ "."
+ "test018.jvc"
+ "out/test018.out",
+ PosTest
+ "Self-application"
+ "."
+ "test019.jvc"
+ "out/test019.out",
+ PosTest
+ "Recursive functions: McCarthy's 91 function, subtraction by increments"
+ "."
+ "test020.jvc"
+ "out/test020.out",
+ PosTest
+ "Higher-order recursive functions"
+ "."
+ "test021.jvc"
+ "out/test021.out",
+ PosTest
+ "Fast exponentiation"
+ "."
+ "test022.jvc"
+ "out/test022.out",
+ PosTest
+ "Lists"
+ "."
+ "test023.jvc"
+ "out/test023.out",
+ PosTest
+ "Structural equality"
+ "."
+ "test024.jvc"
+ "out/test024.out",
+ PosTest
+ "Mutual recursion"
+ "."
+ "test025.jvc"
+ "out/test025.out",
+ PosTest
+ "Nested 'case', 'let' and 'if' with variable capture"
+ "."
+ "test026.jvc"
+ "out/test026.out",
+ PosTest
+ "Euclid's algorithm"
+ "."
+ "test027.jvc"
+ "out/test027.out",
+ PosTest
+ "Functional queues"
+ "."
+ "test028.jvc"
+ "out/test028.out",
+ PosTest
+ "Church numerals"
+ "."
+ "test029.jvc"
+ "out/test029.out",
+ PosTest
+ "Streams without memoization"
+ "."
+ "test030.jvc"
+ "out/test030.out",
+ PosTest
+ "Ackermann function"
+ "."
+ "test031.jvc"
+ "out/test031.out",
+ PosTest
+ "Ackermann function (higher-order definition)"
+ "."
+ "test032.jvc"
+ "out/test032.out",
+ PosTest
+ "Nested lists"
+ "."
+ "test033.jvc"
+ "out/test033.out",
+ {- PosTest
+ "Evaluation order"
+ "."
+ "test034.jvc"
+ "out/test034.out", -}
+ PosTest
+ "Merge sort"
+ "."
+ "test035.jvc"
+ "out/test035.out",
+ PosTest
+ "Big numbers"
+ "."
+ "test036.jvc"
+ "out/test036.out",
+ PosTest
+ "Global variables"
+ "."
+ "test037.jvc"
+ "out/test037.out",
+ PosTest
+ "Global variables and forward declarations"
+ "."
+ "test038.jvc"
+ "out/test038.out",
+ PosTest
+ "Eta-expansion of builtins and constructors"
+ "."
+ "test039.jvc"
+ "out/test039.out"
+ ]
From 0a0df7bc87bb2301c26e437400957de2ef494ed9 Mon Sep 17 00:00:00 2001
From: Jan Mas Rovira <janmasrovira@gmail.com>
Date: Tue, 6 Sep 2022 12:53:32 +0200
Subject: [PATCH 4/7] reset tests
---
test/Core/Transformation/Lifting.hs | 26 +-------------------------
test/Reachability/Positive.hs | 2 +-
test/Scope/Positive.hs | 10 +++++-----
test/Termination/Positive.hs | 4 ++--
test/TypeCheck/Positive.hs | 4 ++--
5 files changed, 11 insertions(+), 35 deletions(-)
diff --git a/test/Core/Transformation/Lifting.hs b/test/Core/Transformation/Lifting.hs
index 8708eb4aef..b6d41efe31 100644
--- a/test/Core/Transformation/Lifting.hs
+++ b/test/Core/Transformation/Lifting.hs
@@ -1,33 +1,9 @@
module Core.Transformation.Lifting (allTests) where
import Base
-import Core.Transformation.Base
-import Juvix.Compiler.Core.Transformation
allTests :: TestTree
allTests = testGroup "Lambda lifting" tests
-pipe :: [TransformationId]
-pipe = [LambdaLifting]
-
-dir :: FilePath
-dir = "lambda-lifting"
-
-liftTest :: String -> FilePath -> FilePath -> TestTree
-liftTest _testName _testCoreFile _testExpectedFile =
- fromTest
- Test
- { _testTransformations = pipe,
- _testCoreFile = dir </> _testCoreFile,
- _testName,
- _testExpectedFile = dir </> _testExpectedFile
- }
-
tests :: [TestTree]
-tests =
- [ liftTest
- ("Lambda lifting without let rec " <> i)
- ("test" <> i <> ".jvc")
- ("test" <> i <> ".out")
- | i <- map show [1 :: Int .. 3]
- ]
+tests = []
diff --git a/test/Reachability/Positive.hs b/test/Reachability/Positive.hs
index 373fbf903f..51d175ca72 100644
--- a/test/Reachability/Positive.hs
+++ b/test/Reachability/Positive.hs
@@ -36,7 +36,7 @@ testDescr PosTest {..} =
}
step "Pipeline up to reachability"
- p :: Micro.InternalTypedResult <- runIO (upToInternalReachability entryPoint)
+ p :: Micro.InternalTypedResult <- runIO' (upToInternalReachability entryPoint)
step "Check reachability results"
let names = concatMap getNames (p ^. Micro.resultModules)
diff --git a/test/Scope/Positive.hs b/test/Scope/Positive.hs
index 549dafffb2..89f0f14e67 100644
--- a/test/Scope/Positive.hs
+++ b/test/Scope/Positive.hs
@@ -49,13 +49,13 @@ testDescr PosTest {..} =
| otherwise = HashMap.union fs stdlibMap
step "Parsing"
- p :: Parser.ParserResult <- runIO (upToParsing entryPoint)
+ p :: Parser.ParserResult <- runIO' (upToParsing entryPoint)
let p2 = head (p ^. Parser.resultModules)
step "Scoping"
s :: Scoper.ScoperResult <-
- runIO
+ runIO'
( do
void (entrySetup entryPoint)
Concrete.fromParsed p
@@ -78,18 +78,18 @@ testDescr PosTest {..} =
step "Parsing pretty scoped"
let fs2 = unionStdlib (HashMap.singleton entryFile scopedPretty)
p' :: Parser.ParserResult <-
- (runM . runErrorIO @JuvixError . runNameIdGen . runFilesPure fs2)
+ (runM . runErrorIO' @JuvixError . runNameIdGen . runFilesPure fs2)
(upToParsing entryPoint)
step "Parsing pretty parsed"
let fs3 = unionStdlib (HashMap.singleton entryFile parsedPretty)
parsedPretty' :: Parser.ParserResult <-
- (runM . runErrorIO @JuvixError . runNameIdGen . runFilesPure fs3)
+ (runM . runErrorIO' @JuvixError . runNameIdGen . runFilesPure fs3)
(upToParsing entryPoint)
step "Scoping the scoped"
s' :: Scoper.ScoperResult <-
- (runM . runErrorIO @JuvixError . runNameIdGen . runFilesPure fs)
+ (runM . runErrorIO' @JuvixError . runNameIdGen . runFilesPure fs)
(upToScoping entryPoint)
step "Checks"
diff --git a/test/Termination/Positive.hs b/test/Termination/Positive.hs
index 22de643edf..1ffa1183d4 100644
--- a/test/Termination/Positive.hs
+++ b/test/Termination/Positive.hs
@@ -21,7 +21,7 @@ testDescr PosTest {..} =
_testRoot = tRoot,
_testAssertion = Single $ do
let entryPoint = (defaultEntryPoint _file) {_entryPointNoStdlib = True}
- (void . runIO) (upToInternal entryPoint)
+ (void . runIO') (upToInternal entryPoint)
}
--------------------------------------------------------------------------------
@@ -45,7 +45,7 @@ testDescrFlag N.NegTest {..} =
_entryPointNoStdlib = True
}
- (void . runIO) (upToInternal entryPoint)
+ (void . runIO') (upToInternal entryPoint)
}
--------------------------------------------------------------------------------
diff --git a/test/TypeCheck/Positive.hs b/test/TypeCheck/Positive.hs
index 535522abaa..e5e5ed01e3 100644
--- a/test/TypeCheck/Positive.hs
+++ b/test/TypeCheck/Positive.hs
@@ -21,7 +21,7 @@ testDescr PosTest {..} =
_testRoot = tRoot,
_testAssertion = Single $ do
let entryPoint = defaultEntryPoint _file
- (void . runIO) (upToInternalTyped entryPoint)
+ (void . runIO') (upToInternalTyped entryPoint)
}
--------------------------------------------------------------------------------
@@ -43,7 +43,7 @@ testNoPositivityFlag N.NegTest {..} =
{ _entryPointNoPositivity = True
}
- (void . runIO) (upToInternal entryPoint)
+ (void . runIO') (upToInternal entryPoint)
}
negPositivityTests :: [N.NegTest]
From 6b10f7c9b2cb6aadde61598da23336b1e0a168e4 Mon Sep 17 00:00:00 2001
From: Jan Mas Rovira <janmasrovira@gmail.com>
Date: Tue, 6 Sep 2022 13:18:51 +0200
Subject: [PATCH 5/7] remove old files
---
test/Core/Base.hs | 82 ---------------
test/Core/Negative.hs | 72 -------------
test/Core/Positive.hs | 233 ------------------------------------------
3 files changed, 387 deletions(-)
delete mode 100644 test/Core/Base.hs
delete mode 100644 test/Core/Negative.hs
delete mode 100644 test/Core/Positive.hs
diff --git a/test/Core/Base.hs b/test/Core/Base.hs
deleted file mode 100644
index afd23810c3..0000000000
--- a/test/Core/Base.hs
+++ /dev/null
@@ -1,82 +0,0 @@
-module Core.Base where
-
-import Base
-import Data.Text.IO qualified as TIO
-import Juvix.Compiler.Core.Data.InfoTable
-import Juvix.Compiler.Core.Error
-import Juvix.Compiler.Core.Evaluator
-import Juvix.Compiler.Core.Extra
-import Juvix.Compiler.Core.Info qualified as Info
-import Juvix.Compiler.Core.Info.NoDisplayInfo
-import Juvix.Compiler.Core.Language
-import Juvix.Compiler.Core.Pretty
-import Juvix.Compiler.Core.Translation.FromSource
-import System.IO.Extra (withTempDir)
-import Text.Megaparsec.Pos qualified as M
-
-coreEvalAssertion :: FilePath -> FilePath -> (String -> IO ()) -> Assertion
-coreEvalAssertion mainFile expectedFile step = do
- step "Parse"
- r <- parseFile mainFile
- case r of
- Left err -> assertFailure (show (pretty err))
- Right (_, Nothing) -> do
- step "Compare expected and actual program output"
- expected <- TIO.readFile expectedFile
- assertEqDiff ("Check: EVAL output = " <> expectedFile) "" expected
- Right (tab, Just node) -> do
- withTempDir
- ( \dirPath -> do
- let outputFile = dirPath </> "out.out"
- hout <- openFile outputFile WriteMode
- step "Evaluate"
- r' <- doEval mainFile hout tab node
- case r' of
- Left err -> do
- hClose hout
- assertFailure (show (pretty err))
- Right value -> do
- unless
- (Info.member kNoDisplayInfo (getInfo value))
- (hPutStrLn hout (ppPrint value))
- hClose hout
- actualOutput <- TIO.readFile outputFile
- step "Compare expected and actual program output"
- expected <- TIO.readFile expectedFile
- assertEqDiff ("Check: EVAL output = " <> expectedFile) actualOutput expected
- )
-
-coreEvalErrorAssertion :: FilePath -> (String -> IO ()) -> Assertion
-coreEvalErrorAssertion mainFile step = do
- step "Parse"
- r <- parseFile mainFile
- case r of
- Left _ -> assertBool "" True
- Right (_, Nothing) -> assertFailure "no error"
- Right (tab, Just node) -> do
- withTempDir
- ( \dirPath -> do
- let outputFile = dirPath </> "out.out"
- hout <- openFile outputFile WriteMode
- step "Evaluate"
- r' <- doEval mainFile hout tab node
- case r' of
- Left _ -> assertBool "" True
- Right _ -> assertFailure "no error"
- )
-
-parseFile :: FilePath -> IO (Either ParserError (InfoTable, Maybe Node))
-parseFile f = do
- s <- readFile f
- return $ runParser "" f emptyInfoTable s
-
-doEval ::
- FilePath ->
- Handle ->
- InfoTable ->
- Node ->
- IO (Either CoreError Node)
-doEval f hout tab node =
- catchEvalErrorIO defaultLoc (hEvalIO stdin hout (tab ^. identContext) [] node)
- where
- defaultLoc = singletonInterval (mkLoc f 0 (M.initialPos f))
diff --git a/test/Core/Negative.hs b/test/Core/Negative.hs
deleted file mode 100644
index 219725adb2..0000000000
--- a/test/Core/Negative.hs
+++ /dev/null
@@ -1,72 +0,0 @@
-module Core.Negative where
-
-import Base
-import Core.Base
-
-data NegTest = NegTest
- { _name :: String,
- _relDir :: FilePath,
- _file :: FilePath
- }
-
-root :: FilePath
-root = "tests/Core/negative"
-
-testDescr :: NegTest -> TestDescr
-testDescr NegTest {..} =
- let tRoot = root </> _relDir
- in TestDescr
- { _testName = _name,
- _testRoot = tRoot,
- _testAssertion = Steps $ coreEvalErrorAssertion _file
- }
-
-allTests :: TestTree
-allTests =
- testGroup
- "JuvixCore negative tests"
- (map (mkTest . testDescr) tests)
-
-tests :: [NegTest]
-tests =
- [ NegTest
- "Division by zero"
- "."
- "test001.jvc",
- NegTest
- "Arithmetic operations on non-numbers"
- "."
- "test002.jvc",
- NegTest
- "Matching on non-data"
- "."
- "test003.jvc",
- NegTest
- "If on non-boolean"
- "."
- "test004.jvc",
- NegTest
- "No matching case branch"
- "."
- "test005.jvc",
- NegTest
- "Invalid application"
- "."
- "test006.jvc",
- NegTest
- "Invalid builtin application"
- "."
- "test007.jvc",
- NegTest
- "Undefined symbol"
- "."
- "test008.jvc",
- NegTest
- "Erroneous Church numerals"
- "."
- "test009.jvc",
- NegTest
- "Empty letrec"
- "."
- "test010.jvc"
- ]
diff --git a/test/Core/Positive.hs b/test/Core/Positive.hs
deleted file mode 100644
index dda2582349..0000000000
--- a/test/Core/Positive.hs
+++ /dev/null
@@ -1,233 +0,0 @@
-module Core.Positive where
-
-import Base
-import Core.Base
-
-data PosTest = PosTest
- { _name :: String,
- _relDir :: FilePath,
- _file :: FilePath,
- _expectedFile :: FilePath
- }
-
-root :: FilePath
-root = "tests/Core/positive"
-
-testDescr :: PosTest -> TestDescr
-testDescr PosTest {..} =
- let tRoot = root </> _relDir
- in TestDescr
- { _testName = _name,
- _testRoot = tRoot,
- _testAssertion = Steps $ coreEvalAssertion _file _expectedFile
- }
-
-allTests :: TestTree
-allTests =
- testGroup
- "JuvixCore positive tests"
- (map (mkTest . testDescr) tests)
-
-tests :: [PosTest]
-tests =
- [ PosTest
- "Arithmetic operators"
- "."
- "test001.jvc"
- "out/test001.out",
- PosTest
- "Arithmetic operators inside lambdas"
- "."
- "test002.jvc"
- "out/test002.out",
- PosTest
- "Empty program with comments"
- "."
- "test003.jvc"
- "out/test003.out",
- PosTest
- "IO builtins"
- "."
- "test004.jvc"
- "out/test004.out",
- PosTest
- "Higher-order functions"
- "."
- "test005.jvc"
- "out/test005.out",
- PosTest
- "If-then-else"
- "."
- "test006.jvc"
- "out/test006.out",
- PosTest
- "Case"
- "."
- "test007.jvc"
- "out/test007.out",
- PosTest
- "Recursion"
- "."
- "test008.jvc"
- "out/test008.out",
- PosTest
- "Tail recursion"
- "."
- "test009.jvc"
- "out/test009.out",
- PosTest
- "Let"
- "."
- "test010.jvc"
- "out/test010.out",
- PosTest
- "Tail recursion: Fibonacci numbers in linear time"
- "."
- "test011.jvc"
- "out/test011.out",
- PosTest
- "Trees"
- "."
- "test012.jvc"
- "out/test012.out",
- PosTest
- "Functions returning functions with variable capture"
- "."
- "test013.jvc"
- "out/test013.out",
- PosTest
- "Arithmetic"
- "."
- "test014.jvc"
- "out/test014.out",
- PosTest
- "Local functions with free variables"
- "."
- "test015.jvc"
- "out/test015.out",
- PosTest
- "Recursion through higher-order functions"
- "."
- "test016.jvc"
- "out/test016.out",
- PosTest
- "Tail recursion through higher-order functions"
- "."
- "test017.jvc"
- "out/test017.out",
- PosTest
- "Higher-order functions and recursion"
- "."
- "test018.jvc"
- "out/test018.out",
- PosTest
- "Self-application"
- "."
- "test019.jvc"
- "out/test019.out",
- PosTest
- "Recursive functions: McCarthy's 91 function, subtraction by increments"
- "."
- "test020.jvc"
- "out/test020.out",
- PosTest
- "Higher-order recursive functions"
- "."
- "test021.jvc"
- "out/test021.out",
- PosTest
- "Fast exponentiation"
- "."
- "test022.jvc"
- "out/test022.out",
- PosTest
- "Lists"
- "."
- "test023.jvc"
- "out/test023.out",
- PosTest
- "Structural equality"
- "."
- "test024.jvc"
- "out/test024.out",
- PosTest
- "Mutual recursion"
- "."
- "test025.jvc"
- "out/test025.out",
- PosTest
- "Nested 'case', 'let' and 'if' with variable capture"
- "."
- "test026.jvc"
- "out/test026.out",
- PosTest
- "Euclid's algorithm"
- "."
- "test027.jvc"
- "out/test027.out",
- PosTest
- "Functional queues"
- "."
- "test028.jvc"
- "out/test028.out",
- PosTest
- "Church numerals"
- "."
- "test029.jvc"
- "out/test029.out",
- PosTest
- "Streams without memoization"
- "."
- "test030.jvc"
- "out/test030.out",
- PosTest
- "Ackermann function"
- "."
- "test031.jvc"
- "out/test031.out",
- PosTest
- "Ackermann function (higher-order definition)"
- "."
- "test032.jvc"
- "out/test032.out",
- PosTest
- "Nested lists"
- "."
- "test033.jvc"
- "out/test033.out",
- {- PosTest
- "Evaluation order"
- "."
- "test034.jvc"
- "out/test034.out", -}
- PosTest
- "Merge sort"
- "."
- "test035.jvc"
- "out/test035.out",
- PosTest
- "Big numbers"
- "."
- "test036.jvc"
- "out/test036.out",
- PosTest
- "Global variables"
- "."
- "test037.jvc"
- "out/test037.out",
- PosTest
- "Global variables and forward declarations"
- "."
- "test038.jvc"
- "out/test038.out",
- PosTest
- "Eta-expansion of builtins and constructors"
- "."
- "test039.jvc"
- "out/test039.out",
- PosTest
- "Letrec"
- "."
- "test040.jvc"
- "out/test040.out"
- ]
From 8c62a0de03582e05a088f6d58638df618c834ce9 Mon Sep 17 00:00:00 2001
From: Jan Mas Rovira <janmasrovira@gmail.com>
Date: Tue, 6 Sep 2022 13:22:15 +0200
Subject: [PATCH 6/7] fix tests
---
test/Core/Eval/Negative.hs | 6 +++++-
test/Core/Eval/Positive.hs | 7 ++++++-
2 files changed, 11 insertions(+), 2 deletions(-)
diff --git a/test/Core/Eval/Negative.hs b/test/Core/Eval/Negative.hs
index 28b3d87ed0..6fcb414bbc 100644
--- a/test/Core/Eval/Negative.hs
+++ b/test/Core/Eval/Negative.hs
@@ -64,5 +64,9 @@ tests =
NegTest
"Erroneous Church numerals"
"."
- "test009.jvc"
+ "test009.jvc",
+ NegTest
+ "Empty letrec"
+ "."
+ "test010.jvc"
]
diff --git a/test/Core/Eval/Positive.hs b/test/Core/Eval/Positive.hs
index ebf8c54e91..8d6f1aad21 100644
--- a/test/Core/Eval/Positive.hs
+++ b/test/Core/Eval/Positive.hs
@@ -224,5 +224,10 @@ tests =
"Eta-expansion of builtins and constructors"
"."
"test039.jvc"
- "out/test039.out"
+ "out/test039.out",
+ PosTest
+ "LetRec"
+ "."
+ "test040.jvc"
+ "out/test040.out"
]
From 8efcca761a8589ad65819b4ccd904b4cf2bf6f00 Mon Sep 17 00:00:00 2001
From: Jan Mas Rovira <janmasrovira@gmail.com>
Date: Tue, 6 Sep 2022 14:55:40 +0200
Subject: [PATCH 7/7] remove unused import
---
src/Juvix/Compiler/Core/Transformation/LambdaLifting.hs | 1 -
1 file changed, 1 deletion(-)
diff --git a/src/Juvix/Compiler/Core/Transformation/LambdaLifting.hs b/src/Juvix/Compiler/Core/Transformation/LambdaLifting.hs
index eec594f133..bf2c9386a8 100644
--- a/src/Juvix/Compiler/Core/Transformation/LambdaLifting.hs
+++ b/src/Juvix/Compiler/Core/Transformation/LambdaLifting.hs
@@ -4,7 +4,6 @@ module Juvix.Compiler.Core.Transformation.LambdaLifting
)
where
-import Juvix.Compiler.Core.Pretty
import Juvix.Compiler.Core.Transformation.Base
lambdaLiftNode :: Node -> Sem r Node