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:
parent
1fdc3674ba
commit
4f05ba2531
18
app/App.hs
18
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
|
||||
|
@ -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 {..}
|
||||
|
67
app/Main.hs
67
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 ->
|
||||
|
@ -17,4 +17,4 @@ data ScoperResult = ScoperResult
|
||||
makeLenses ''ScoperResult
|
||||
|
||||
mainModule :: Lens' ScoperResult (Module 'Scoped 'ModuleTop)
|
||||
mainModule = resultModules . _head
|
||||
mainModule = resultModules . _head1
|
||||
|
4
src/Juvix/Compiler/Core/Data/TransformationId.hs
Normal file
4
src/Juvix/Compiler/Core/Data/TransformationId.hs
Normal file
@ -0,0 +1,4 @@
|
||||
module Juvix.Compiler.Core.Data.TransformationId where
|
||||
|
||||
data TransformationId
|
||||
= LambdaLifting
|
31
src/Juvix/Compiler/Core/Data/TransformationId/Parser.hs
Normal file
31
src/Juvix/Compiler/Core/Data/TransformationId/Parser.hs
Normal 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
|
@ -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_
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -36,4 +36,4 @@ defaultEntryPoint mainFile =
|
||||
makeLenses ''EntryPoint
|
||||
|
||||
mainModulePath :: Lens' EntryPoint FilePath
|
||||
mainModulePath = entryPointModulePaths . _head
|
||||
mainModulePath = entryPointModulePaths . _head1
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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" #-}
|
||||
|
@ -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
8
test/Core/Eval.hs
Normal 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]
|
@ -1,4 +1,4 @@
|
||||
module Core.Base where
|
||||
module Core.Eval.Base where
|
||||
|
||||
import Base
|
||||
import Data.Text.IO qualified as TIO
|
@ -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,
|
@ -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"
|
7
test/Core/Transformation.hs
Normal file
7
test/Core/Transformation.hs
Normal 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]
|
39
test/Core/Transformation/Base.hs
Normal file
39
test/Core/Transformation/Base.hs
Normal 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)
|
9
test/Core/Transformation/Lifting.hs
Normal file
9
test/Core/Transformation/Lifting.hs
Normal file
@ -0,0 +1,9 @@
|
||||
module Core.Transformation.Lifting (allTests) where
|
||||
|
||||
import Base
|
||||
|
||||
allTests :: TestTree
|
||||
allTests = testGroup "Lambda lifting" tests
|
||||
|
||||
tests :: [TestTree]
|
||||
tests = []
|
Loading…
Reference in New Issue
Block a user