ddc-tools 0.3.2.1 → 0.4.1.1
raw patch · 36 files changed
+1542/−633 lines, 36 filesdep +ddc-core-flowdep +ddc-source-tetradep −haskell-src-extsdep ~basedep ~ddc-basedep ~ddc-buildsetup-changednew-component:exe:ddci-tetra
Dependencies added: ddc-core-flow, ddc-source-tetra
Dependencies removed: haskell-src-exts
Dependency ranges changed: base, ddc-base, ddc-build, ddc-code, ddc-core, ddc-core-eval, ddc-core-llvm, ddc-core-salt, ddc-core-simpl, ddc-core-tetra, ddc-driver, ddc-interface, process
Files
- LICENSE +1/−15
- Setup.hs +2/−2
- ddc-tools.cabal +103/−32
- src/ddc-check/Main.hs +3/−3
- src/ddc-main/DDC/Main/Args.hs +36/−16
- src/ddc-main/DDC/Main/Config.hs +16/−3
- src/ddc-main/DDC/Main/Help.hs +63/−63
- src/ddc-main/DDC/Main/OptLevels.hs +33/−26
- src/ddc-main/Main.hs +87/−80
- src/ddci-core/DDCI/Core/Command.hs +99/−73
- src/ddci-core/DDCI/Core/Command/Eval.hs +72/−20
- src/ddci-core/DDCI/Core/Command/Help.hs +80/−71
- src/ddci-core/DDCI/Core/Command/Set.hs +2/−2
- src/ddci-core/DDCI/Core/Command/Trans.hs +0/−173
- src/ddci-core/DDCI/Core/Command/TransInteract.hs +16/−13
- src/ddci-core/DDCI/Core/Command/With.hs +12/−9
- src/ddci-core/DDCI/Core/Interface/Interactive.hs +2/−2
- src/ddci-core/DDCI/Core/Mode.hs +45/−11
- src/ddci-core/DDCI/Core/Rewrite.hs +2/−2
- src/ddci-core/DDCI/Core/State.hs +24/−10
- src/ddci-core/DDCI/Core/Stats/Trace.hs +5/−7
- src/ddci-tetra/DDCI/Tetra/Command.hs +123/−0
- src/ddci-tetra/DDCI/Tetra/Command/Desugar.hs +38/−0
- src/ddci-tetra/DDCI/Tetra/Command/Help.hs +36/−0
- src/ddci-tetra/DDCI/Tetra/Command/Infer.hs +46/−0
- src/ddci-tetra/DDCI/Tetra/Command/Parse.hs +36/−0
- src/ddci-tetra/DDCI/Tetra/Command/Set.hs +73/−0
- src/ddci-tetra/DDCI/Tetra/Command/ToCore.hs +28/−0
- src/ddci-tetra/DDCI/Tetra/Input.hs +34/−0
- src/ddci-tetra/DDCI/Tetra/Interface/Args.hs +49/−0
- src/ddci-tetra/DDCI/Tetra/Interface/Batch.hs +62/−0
- src/ddci-tetra/DDCI/Tetra/Interface/Interactive.hs +59/−0
- src/ddci-tetra/DDCI/Tetra/Mode.hs +50/−0
- src/ddci-tetra/DDCI/Tetra/Output.hs +41/−0
- src/ddci-tetra/DDCI/Tetra/State.hs +127/−0
- src/ddci-tetra/Main.hs +37/−0
LICENSE view
@@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- The Disciplined Disciple Compiler License (MIT style) -Copyrite (K) 2007-2013 The Disciplined Disciple Compiler Strike Force+Copyrite (K) 2007-2014 The Disciplined Disciple Compiler Strike Force All rights reversed. Permission is hereby granted, free of charge, to any person obtaining a copy@@ -13,18 +13,4 @@ The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.----------------------------------------------------------------------------------Under Australian law copyright is free and automatic.-By contributing to DDC authors grant all rights they have regarding their-contributions to the other members of the Disciplined Disciple Compiler Strike-Force, past, present and future, as well as placing their contributions under-the above license.--Use "darcs show authors" to get a list of Strike Force members.- ---------------------------------------------------------------------------------Redistributions of libraries in ./external are governed by their own licenses:-- - TinyPTC GNU Lesser General Public License-
Setup.hs view
@@ -3,8 +3,8 @@ import Distribution.Simple.LocalBuildInfo import Distribution.PackageDescription import System.FilePath+import System.Process import System.Exit-import System.Cmd main = defaultMainWithHooks hooks @@ -33,5 +33,5 @@ -- Run the basebuild command, which builds the library. code <- system $ ddcExe ++ " -basebuild -O" case code of- ExitFailure _ -> error "Failed!"+ ExitFailure _ -> error "ddc-tools.postHookInstall: Failed!" ExitSuccess -> return ()
ddc-tools.cabal view
@@ -1,5 +1,5 @@ Name: ddc-tools-Version: 0.3.2.1+Version: 0.4.1.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force@@ -17,8 +17,8 @@ src/ddc-check Build-depends:- base == 4.6.*,- ddc-core == 0.3.2.*+ base >= 4.6 && < 4.8,+ ddc-core == 0.4.1.* Main-is: Main.hs@@ -34,26 +34,25 @@ src/ddc-main Build-depends:- base == 4.6.*,+ base >= 4.6 && < 4.8,+ process >= 1.1 && < 1.3, containers == 0.5.*,- process == 1.1.*, filepath == 1.3.*, haskeline == 0.7.*,- haskell-src-exts== 1.13.*, directory == 1.2.*, mtl == 2.1.*, transformers == 0.3.*,- ddc-base == 0.3.2.*,- ddc-core == 0.3.2.*,- ddc-core-eval == 0.3.2.*,- ddc-core-simpl == 0.3.2.*,- ddc-core-salt == 0.3.2.*,- ddc-core-llvm == 0.3.2.*,- ddc-core-tetra == 0.3.2.*,- ddc-code == 0.3.2.*,- ddc-build == 0.3.2.*,- ddc-driver == 0.3.2.*,- ddc-interface == 0.3.2.*+ ddc-base == 0.4.1.*,+ ddc-core == 0.4.1.*,+ ddc-core-eval == 0.4.1.*,+ ddc-core-simpl == 0.4.1.*,+ ddc-core-salt == 0.4.1.*,+ ddc-core-llvm == 0.4.1.*,+ ddc-core-tetra == 0.4.1.*,+ ddc-code == 0.4.1.*,+ ddc-build == 0.4.1.*,+ ddc-driver == 0.4.1.*,+ ddc-interface == 0.4.1.* Main-is: Main.hs@@ -72,25 +71,25 @@ src/ddci-core Build-depends:- base == 4.6.*,+ base >= 4.6 && < 4.8,+ process >= 1.1 && < 1.3, containers == 0.5.*,- process == 1.1.*, filepath == 1.3.*, haskeline == 0.7.*,- haskell-src-exts== 1.*, directory == 1.2.*, mtl == 2.1.*,- ddc-base == 0.3.2.*,- ddc-core == 0.3.2.*,- ddc-core-eval == 0.3.2.*,- ddc-core-simpl == 0.3.2.*,- ddc-core-salt == 0.3.2.*,- ddc-core-llvm == 0.3.2.*,- ddc-core-tetra == 0.3.2.*,- ddc-code == 0.3.2.*,- ddc-build == 0.3.2.*,- ddc-driver == 0.3.2.*,- ddc-interface == 0.3.2.*+ ddc-base == 0.4.1.*,+ ddc-core == 0.4.1.*,+ ddc-core-eval == 0.4.1.*,+ ddc-core-simpl == 0.4.1.*,+ ddc-core-salt == 0.4.1.*,+ ddc-core-llvm == 0.4.1.*,+ ddc-core-flow == 0.4.1.*,+ ddc-core-tetra == 0.4.1.*,+ ddc-code == 0.4.1.*,+ ddc-build == 0.4.1.*,+ ddc-driver == 0.4.1.*,+ ddc-interface == 0.4.1.* Main-is: Main.hs@@ -99,13 +98,15 @@ DDCI.Core.Command.Eval DDCI.Core.Command.Help DDCI.Core.Command.Set- DDCI.Core.Command.Trans DDCI.Core.Command.TransInteract DDCI.Core.Command.With+ DDCI.Core.Interface.Args DDCI.Core.Interface.Batch DDCI.Core.Interface.Interactive+ DDCI.Core.Stats.Trace+ DDCI.Core.Command DDCI.Core.Input DDCI.Core.Mode@@ -131,4 +132,74 @@ ghc-options: -Wall -fno-warn-missing-signatures+ -fno-warn-missing-methods+ -fno-warn-unused-do-bind+++Executable ddci-tetra+ hs-source-dirs:+ src/ddci-tetra++ Build-depends:+ base >= 4.6 && < 4.8,+ process >= 1.1 && < 1.3,+ containers == 0.5.*,+ filepath == 1.3.*,+ haskeline == 0.7.*,+ directory == 1.2.*,+ mtl == 2.1.*,+ ddc-base == 0.4.1.*,+ ddc-core == 0.4.1.*,+ ddc-core-eval == 0.4.1.*,+ ddc-core-simpl == 0.4.1.*,+ ddc-core-salt == 0.4.1.*,+ ddc-core-llvm == 0.4.1.*,+ ddc-core-flow == 0.4.1.*,+ ddc-core-tetra == 0.4.1.*,+ ddc-source-tetra == 0.4.1.*,+ ddc-code == 0.4.1.*,+ ddc-build == 0.4.1.*,+ ddc-driver == 0.4.1.*,+ ddc-interface == 0.4.1.*++ Main-is:+ Main.hs+ + Other-modules:+ DDCI.Tetra.Command.Desugar+ DDCI.Tetra.Command.Help+ DDCI.Tetra.Command.Infer+ DDCI.Tetra.Command.Parse+ DDCI.Tetra.Command.Set+ DDCI.Tetra.Command.ToCore++ DDCI.Tetra.Interface.Args+ DDCI.Tetra.Interface.Batch+ DDCI.Tetra.Interface.Interactive++ DDCI.Tetra.Command+ DDCI.Tetra.Input+ DDCI.Tetra.Mode+ DDCI.Tetra.Output+ DDCI.Tetra.State++ Extensions:+ DoAndIfThenElse+ PatternGuards+ ParallelListComp+ FlexibleContexts+ ExistentialQuantification+ MultiParamTypeClasses+ FunctionalDependencies+ TypeSynonymInstances+ FlexibleInstances+ StandaloneDeriving+ KindSignatures+ RankNTypes+ ScopedTypeVariables++ ghc-options:+ -Wall+ -fno-warn-missing-signatures+ -fno-warn-missing-methods -fno-warn-unused-do-bind
src/ddc-check/Main.hs view
@@ -12,7 +12,7 @@ import DDC.Core.Pretty import System.IO import System.Environment-+import qualified DDC.Core.Check as C main :: IO () main @@ -47,8 +47,8 @@ -- Loading the core code automatically check it -- against the provided fragment. errs <- pipeText sourceName 1 source- $ PipeTextLoadCore fragment- [ PipeCoreOutput sink ]+ $ PipeTextLoadCore fragment C.Recon SinkDiscard+ [ PipeCoreOutput pprDefaultMode sink ] -- If the pipeline died with errors, -- then print them.
src/ddc-main/DDC/Main/Args.hs view
@@ -26,14 +26,15 @@ = return $ config { configMode = ModeHelp } - | flag : file : rest <- args- , elem flag ["-make", "--make" ]+ -- Language -----------------------------+ | "-infer" : rest <- args = parseArgs rest- $ setMode config $ ModeMake file+ $ config { configInferTypes = True } - | "-basebuild" : rest <- args+ | flag : rest <- args+ , elem flag ["-recon", "-no-infer"] = parseArgs rest- $ setMode config $ ModeBaseBuild+ $ config { configInferTypes = False } -- Compilation -------------------------- | flag : file : rest <- args@@ -41,14 +42,18 @@ = parseArgs rest $ setMode config $ ModeCompile file + | flag : file : rest <- args+ , elem flag ["-make", "--make" ]+ = parseArgs rest+ $ setMode config $ ModeMake file+ | "-basedir" : path : rest <- args = parseArgs rest $ config { configBaseDir = path } - | flag : file : rest <- args- , elem flag ["-o", "-output"]+ | "-basebuild" : rest <- args = parseArgs rest- $ config { configOutputFile = Just file }+ $ setMode config $ ModeBaseBuild | "-fvia-c" : rest <- args = parseArgs rest@@ -58,6 +63,11 @@ = parseArgs rest $ config { configViaBackend = ViaLLVM } + | flag : file : rest <- args+ , elem flag ["-o", "-output"]+ = parseArgs rest+ $ config { configOutputFile = Just file }+ | flag : dir : rest <- args , elem flag ["-output-dir"] = parseArgs rest@@ -129,18 +139,30 @@ = parseArgs rest $ setMode config $ ModeFlowLower file + | "-flow-lower-kernel" : file : rest <- args+ = parseArgs rest+ $ setMode config $ ModeFlowLowerKernel file++ | "-flow-lower-vector" : file : rest <- args+ = parseArgs rest+ $ setMode config $ ModeFlowLowerVector file+ | "-flow-concretize" : file : rest <- args = parseArgs rest $ setMode config $ ModeFlowConcretize file - | "-flow-thread" : file : rest <- args+ | "-flow-melt" : file : rest <- args = parseArgs rest- $ setMode config $ ModeFlowThread file+ $ setMode config $ ModeFlowMelt file | "-flow-wind" : file : rest <- args = parseArgs rest $ setMode config $ ModeFlowWind file + | "-flow-thread" : file : rest <- args+ = parseArgs rest+ $ setMode config $ ModeFlowThread file+ -- Conversion --------------------------- | "-to-salt" : file : rest <- args = parseArgs rest@@ -159,10 +181,6 @@ = parseArgs rest $ config { configDump = True } - | "-ast" : file : rest <- args- = parseArgs rest- $ setMode config $ ModeAST file- | "-print-builder" : rest <- args = parseArgs rest $ setMode config ModePrintBuilder@@ -208,7 +226,7 @@ | otherwise = case flagOfMode newMode of Nothing - -> error "DDC.Main.Args.setMode: not setting mode to ModeNone"+ -> error "ddc-main.setMode: not setting mode to ModeNone" Just newFlag -> case flagOfMode $ configMode config of@@ -228,13 +246,15 @@ ModeLoad{} -> Just "-load" ModeCompile{} -> Just "-compile" ModeMake{} -> Just "-make"- ModeAST{} -> Just "-ast" ModeToSalt{} -> Just "-to-salt" ModeToC{} -> Just "-to-c" ModeToLLVM{} -> Just "-to-llvm" ModeFlowPrep{} -> Just "-flow-prep" ModeFlowLower{} -> Just "-flow-lower"+ ModeFlowLowerKernel{} -> Just "-flow-lower-kernel"+ ModeFlowLowerVector{} -> Just "-flow-lower-vector" ModeFlowConcretize{} -> Just "-flow-concretize"+ ModeFlowMelt{} -> Just "-flow-melt" ModeFlowThread{} -> Just "-flow-thread" ModeFlowWind{} -> Just "-flow-wind" ModeBaseBuild{} -> Just "-basebuild"
src/ddc-main/DDC/Main/Config.hs view
@@ -42,9 +42,6 @@ -- | Compile a .dcl or .dce into an executable file. | ModeMake FilePath - -- | Pretty print a module's AST.- | ModeAST FilePath- -- | Convert a module to Salt. | ModeToSalt FilePath @@ -61,12 +58,21 @@ -- | Lower a Flow program. | ModeFlowLower FilePath + -- | Lower a Flow program, producing a vector kernel.+ | ModeFlowLowerKernel FilePath++ -- | Lower a Flow program using vector instructions.+ | ModeFlowLowerVector FilePath+ -- | Wind loop primops into tail recursive loops. | ModeFlowWind FilePath -- | Concretize rate type variables in a Flow program. | ModeFlowConcretize FilePath + -- | Melt compound data types in a Flow program.+ | ModeFlowMelt FilePath+ -- | Thread the World token through a Flow program. | ModeFlowThread FilePath @@ -97,6 +103,10 @@ { -- | The main compilation mode. configMode :: Mode + -- Language -----------------+ -- | Infer type annotations for Disciple Core files.+ , configInferTypes :: Bool+ -- Compilation -------------- -- | Directory holding the runtime and base library code. , configBaseDir :: FilePath@@ -155,6 +165,9 @@ return $ Config { configMode = ModeNone + -- Language -----------------+ , configInferTypes = True+ -- Compilation -------------- , configBaseDir = baseDir , configOutputFile = Nothing
src/ddc-main/DDC/Main/Help.hs view
@@ -3,7 +3,7 @@ -- | The version identifier string. version :: String-version = "The Disciplined Disciple Compiler, version 0.3.2"+version = "The Disciplined Disciple Compiler, version 0.4.1" -- | What to print when we have no input files.@@ -21,82 +21,82 @@ -- -taint-avoid-type-checks Avoid type checking if possible. -- Exactly how much checking is avoided depends -- on the compilation mode. --- help :: String help = unlines [ version , ""- , "General:"- , " -help Display this help."- , " -version Display the version string."- , ""- , "Compilation:"- , " -make FILE Compile a module into an executable file."- , " -c, -compile FILE Compile a module into an object file."+ , "General"+ , " -help Display this help."+ , " -version Display the version string." , ""- , " -o, -output FILE Redirect output to this file."- , " -output-dir DIR Redirect output to this directory."+ , "Language"+ , " -infer Infer types in core files. (default) (negates -recon)"+ , " -recon Reconstruct types in core files. (negates -infer)" , ""- , " -fvia-llvm Compile via the LLVM backend (default)"- , " -fvia-c Compile via the C backend."+ , "Compilation"+ , " -make FILE Compile a module into an executable file."+ , " -c, -compile FILE Compile a module into an object file." , ""- , " -keep-ll-files Keep intermediate .ll files."- , " -keep-c-files Keep intermediate .c files."- , " -keep-s-files Keep intermediate .s files."+ , " -o, -output FILE Redirect output to this file."+ , " -output-dir DIR Redirect output to this directory." , ""- , "Optimisation:"- , " -O0 No optimisations. (default)"- , " -O, -O1 Do standard optimisations."+ , " -fvia-llvm Compile via the LLVM backend (default)"+ , " -fvia-c Compile via the C backend." , ""- , "Runtime for compiled program:"- , " -run-heap BYTES Size of fixed heap (65536)"+ , "Checking and Loading"+ , " -parse FILE Parse a module."+ , " -check FILE Parse and type check a module."+ , " -load FILE Parse, type check and desugar a module to the Core IR." , ""- , "Parsing and Checking:"- , " -parse FILE Parse a module."- , " -check FILE Parse and type check a module."+ , "Conversion"+ , " -to-salt FILE Convert a module to Disciple Core Salt."+ , " -to-llvm FILE Convert a module to LLVM code."+ , " -to-c FILE Convert a module to C code." , ""- , "Conversion:"- , " -to-salt FILE Convert a module to Disciple Core Salt."- , " -to-c FILE Convert a module to C code."- , " -to-llvm FILE Convert a module to LLVM code."+ , "Configuration"+ , " -basedir DIR Path to the runtime and base library code."+ , " -print-basedir Print directory holding the runtime and base libraries."+ , " -print-builder Print external builder info for this platform."+ , " -run-heap BYTES Size of the fixed runtime heap. (65536)" , ""- , "Data Flow Fusion Transforms:"- , " These work on modules in the Disciple Core Flow (.dcf) fragment."- , " -flow-prep FILE Prepare a module for lowering."- , " -flow-lower FILE Lower functions to loop code."- , " -flow-wind FILE Wind loop primops into tail recursive loops."- , " -flow-concretize FILE Rewrite primops to use concrete series lengths."+ , "Optimisation and Transformation"+ , " -O0 No optimisations. (default)"+ , " -O, -O1 Do standard optimisations." , ""- , "Debugging:"- , " -dump Dump intermediate representations."- , " -ast FILE Pretty print the AST of a module."+ , " -trans TRANS Set the transformation to use with -load."+ , " -with FILE Use this module for inliner templates with -load." , ""- , "Configuration:"- , " -basedir DIR Path to the runtime and base library code."- , " -print-basedir Print directory holding the runtime and base libraries."- , " -print-builder Print external builder info for this platform."+ , " TRANS ::= "+ , " { TRANS } Parenthesis."+ , " fix N TRANS Transform to a fixpoint, or bail out after N iterations."+ , " TRANS; TRANS Sequence two transforms."+ , " Id Return the original program unharmed."+ , " Anonymize Anonymize names to deBruijn form."+ , " Namify Introduce fresh names for deBruijn binders."+ , " Snip Introduce let-bindings for nested applications."+ , " SnipOver ... and over-applications."+ , " Flatten Flatten nested let-bindings."+ , " Beta Perform beta-reduction for value arguments."+ , " BetaLets ... introducing new let-bindings for redex arguments."+ , " Bubble Float casts outwards, and combine similar ones."+ , " Prune Erase unused, ineffectual let-bindings."+ , " Forward Float let-bindings forward into their use sites."+ , " Rewrite Perform rule based rewriting."+ , " Elaborate Introduce default witnesses for unconstrained regions."+ , " Inline MODULE[NAME..] Perform inlining. Use '-with' to add source modules." , ""- , "Transformation:"- , " -load FILE Parse, type check and transform a module."- , " -trans TRANS Set the transformation to use with -load."- , " -with FILE Use this module for inliner templates with -load."+ , "Data Flow Fusion Transforms"+ , " These work on modules in the Disciple Core Flow (.dcf) fragment only."+ , " -flow-prep FILE Prepare a module for lowering."+ , " -flow-lower FILE Lower functions to loop code."+ , " -flow-concretize FILE Rewrite primops to use concrete series lengths."+ , " -flow-melt FILE Melt compound data structures."+ , " -flow-wind FILE Wind loop primops into tail recursive loops."+ , " -flow-thread FILE Thread state token through program." , ""- , " TRANS ::= "- , " { TRANS } Parenthesis."- , " fix N TRANS Transform to a fixpoint, or bail out after N iterations."- , " TRANS; TRANS Sequence two transforms."- , " Id Return the original program unharmed."- , " Anonymize Anonymize names to deBruijn form."- , " Namify Introduce fresh names for deBruijn binders."- , " Snip Introduce let-bindings for nested applications."- , " SnipOver ... and over-applications."- , " Flatten Flatten nested let-bindings."- , " Beta Perform beta-reduction for value arguments."- , " BetaLets ... introducing new let-bindings for redex arguments."- , " Bubble Float casts outwards, and combine similar ones."- , " Prune Erase unused, ineffectual let-bindings."- , " Forward Float let-bindings forward into their use sites."- , " Rewrite Perform rule based rewriting."- , " Elaborate Introduce default witnesses for unconstrained regions."- , " Inline MODULE[NAME..] Perform inlining. Use '-with' to add source modules." ]+ , "Debugging"+ , " -dump Dump intermediate representations."+ , " -keep-ll-files Keep intermediate .ll files."+ , " -keep-c-files Keep intermediate .c files."+ , " -keep-s-files Keep intermediate .s files." ]
src/ddc-main/DDC/Main/OptLevels.hs view
@@ -5,7 +5,7 @@ , getSimplSaltOfConfig) where import DDC.Main.Config-import DDC.Driver.Command.Load+import DDC.Driver.Command.Read import DDC.Driver.Command.RewriteRules import DDC.Build.Builder import DDC.Build.Platform@@ -19,6 +19,7 @@ import Data.List import Data.Monoid import Data.Maybe+import qualified DDC.Driver.Config as D import qualified DDC.Core.Fragment as C import qualified DDC.Core.Simplifier as S import qualified DDC.Core.Simplifier.Recipe as S@@ -39,28 +40,30 @@ -- as inliner templates, so we need to wait until they're all specified. -- getSimplLiteOfConfig - :: Config -> Builder + :: Config -> D.Config+ -> Builder -> Maybe FilePath -- ^ path of current module -> IO (Simplifier Int () Lite.Name) -getSimplLiteOfConfig config builder filePath+getSimplLiteOfConfig config dconfig builder filePath = case configOptLevelLite config of- OptLevel0 -> opt0_lite config- OptLevel1 -> opt1_lite config builder filePath+ OptLevel0 -> opt0_lite config + OptLevel1 -> opt1_lite config dconfig builder filePath -- | Get the simplifier for Salt code from the config. -- getSimplSaltOfConfig - :: Config -> Builder+ :: Config -> D.Config+ -> Builder -> Salt.Config -> Maybe FilePath -- ^ path of current module -> IO (Simplifier Int () Salt.Name) -getSimplSaltOfConfig config builder runtimeConfig filePath+getSimplSaltOfConfig config dconfig builder runtimeConfig filePath = case configOptLevelSalt config of- OptLevel0 -> opt0_salt config- OptLevel1 -> opt1_salt config builder runtimeConfig filePath+ OptLevel0 -> opt0_salt config + OptLevel1 -> opt1_salt config dconfig builder runtimeConfig filePath -- Level 0 --------------------------------------------------------------------@@ -83,11 +86,12 @@ -- | Level 1 optimiser for Core Lite code. opt1_lite - :: Config -> Builder+ :: Config -> D.Config+ -> Builder -> Maybe FilePath -- ^ path of current module -> IO (Simplifier Int () Lite.Name) -opt1_lite config _builder filePath+opt1_lite config dconfig _builder filePath = do -- Auto-inline basic numeric code. let inlineModulePaths@@ -100,7 +104,7 @@ -- will display the errors. minlineModules <- liftM sequence- $ mapM (cmdReadModule Lite.fragment)+ $ mapM (cmdReadModule dconfig Lite.fragment) inlineModulePaths let inlineModules@@ -118,7 +122,7 @@ $ inlineModules `zip` inlineModulePaths -- Load rules for target module as well- modrules <- loadLiteRules filePath+ modrules <- loadLiteRules dconfig filePath let rules' = concat rules ++ modrules @@ -141,12 +145,13 @@ -- | Level 1 optimiser for Core Salt code. opt1_salt - :: Config -> Builder+ :: Config -> D.Config+ -> Builder -> Salt.Config -> Maybe FilePath -- ^ path of current module -> IO (Simplifier Int () Salt.Name) -opt1_salt config builder runtimeConfig filePath+opt1_salt config dconfig builder runtimeConfig filePath = do -- Auto-inline the low-level code from the runtime system -- that constructs and destructs objects.@@ -165,7 +170,7 @@ -- will display the errors. minlineModules <- liftM sequence- $ mapM (cmdReadModule Salt.fragment)+ $ mapM (cmdReadModule dconfig Salt.fragment) inlineModulePaths let inlineModules@@ -182,7 +187,7 @@ $ inlineModules `zip` inlineModulePaths -- Load rules for target module as well- modrules <- loadSaltRules builder runtimeConfig filePath+ modrules <- loadSaltRules dconfig builder runtimeConfig filePath let rules' = concat rules ++ modrules @@ -205,33 +210,35 @@ -- | Load rules for main module loadLiteRules- :: Maybe FilePath+ :: D.Config+ -> Maybe FilePath -> IO (S.NamedRewriteRules () Lite.Name) -loadLiteRules (Just filePath)+loadLiteRules dconfig (Just filePath) | isSuffixOf ".dcl" filePath = do -- Parse module to get exported fn types- modu <- cmdReadModule' False Lite.fragment filePath+ modu <- cmdReadModule' False dconfig Lite.fragment filePath case modu of Just mod' -> cmdTryReadRules Lite.fragment (filePath ++ ".rules") (reannotate (const ()) mod') Nothing -> return [] -loadLiteRules _+loadLiteRules _ _ = return [] -- | Load rules for main module loadSaltRules- :: Builder+ :: D.Config+ -> Builder -> Salt.Config -> Maybe FilePath -> IO (S.NamedRewriteRules () Salt.Name) -loadSaltRules builder runtimeConfig (Just filePath)+loadSaltRules dconfig builder runtimeConfig (Just filePath) -- If the main module is a lite module, we need to load the lite then convert it to salt | isSuffixOf ".dcl" filePath- = do modu <- cmdReadModule' False Lite.fragment filePath+ = do modu <- cmdReadModule' False dconfig Lite.fragment filePath let path' = (reverse $ drop 3 $ reverse filePath) ++ "dcs.rules" case modu of Just mod' ->@@ -248,12 +255,12 @@ Nothing -> return [] | isSuffixOf ".dcs" filePath- = do modu <- cmdReadModule' False Salt.fragment filePath+ = do modu <- cmdReadModule' False dconfig Salt.fragment filePath case modu of Just mod' -> cmdTryReadRules Salt.fragment (filePath ++ ".rules") (reannotate (const ()) mod') Nothing -> return [] -loadSaltRules _ _ _+loadSaltRules _ _ _ _ = return []
src/ddc-main/Main.hs view
@@ -12,30 +12,30 @@ import DDC.Driver.Command.Load import DDC.Driver.Command.Compile import DDC.Driver.Command.Make-import DDC.Driver.Command.Ast import DDC.Driver.Command.BaseBuild import DDC.Driver.Command.Flow.Prep import DDC.Driver.Command.Flow.Lower import DDC.Driver.Command.Flow.Concretize-import DDC.Driver.Command.Flow.Thread+import DDC.Driver.Command.Flow.Melt import DDC.Driver.Command.Flow.Wind+import DDC.Driver.Command.Flow.Thread+import qualified DDC.Core.Flow as Flow import DDC.Driver.Command.ToSalt import DDC.Driver.Command.ToC import DDC.Driver.Command.ToLlvm import DDC.Interface.Source import DDC.Build.Builder-import DDC.Build.Language import DDC.Base.Pretty import System.Environment import System.IO import System.Exit-import System.FilePath import Control.Monad.Trans.Error-import qualified DDC.Driver.Stage as Driver-import qualified DDC.Core.Salt.Runtime as Runtime-+import qualified DDC.Driver.Stage as Driver+import qualified DDC.Driver.Config as Driver+import qualified DDC.Core.Salt.Runtime as Runtime+import qualified DDC.Core.Simplifier.Recipe as Simplifier main :: IO () main@@ -69,32 +69,29 @@ ModeHelp -> putStrLn help - -- Parser a module.+ -- Parse a module. ModeParse filePath -> do dconfig <- getDriverConfig config (Just filePath)- str <- readFile filePath- runError $ cmdParseModule dconfig (SourceFile filePath) str+ runError $ cmdParseFromFile dconfig filePath -- Parse and type check a module. ModeCheck filePath- -> do language <- languageFromFilePath filePath- case language of - Language bundle- -> do mm <- runErrorT - $ cmdCheckModuleFromFile (bundleFragment bundle) filePath- case mm of- Left err - -> do putStrLn err- exitWith $ ExitFailure 1+ -> do dconfig <- getDriverConfig config (Just filePath)+ result <- runErrorT $ cmdCheckFromFile dconfig filePath+ + case result of+ Left err + -> do putStrLn err+ exitWith $ ExitFailure 1 - Right _- -> return ()+ Right ()+ -> return () -- Parse, type check and transform a module. ModeLoad filePath- -> runError $ cmdLoadFromFile - (configTrans config) - (configWith config) + -> do dconfig <- getDriverConfig config (Just filePath)+ runError $ cmdLoadFromFile dconfig+ (configTrans config) (configWith config) filePath -- Compile a module to object code.@@ -107,35 +104,20 @@ -> do dconfig <- getDriverConfig config (Just filePath) runError $ cmdMake dconfig filePath - -- Pretty print the AST of a module.- ModeAST filePath- -> do language <- languageFromFilePath filePath- str <- readFile filePath- cmdAstModule - language- (SourceFile filePath) - str- -- Convert a module to Salt. ModeToSalt filePath- -> do language <- languageFromFilePath filePath- dconfig <- getDriverConfig config (Just filePath)- str <- readFile filePath- runError $ cmdToSalt dconfig language (SourceFile filePath) str+ -> do dconfig <- getDriverConfig config (Just filePath)+ runError $ cmdToSaltFromFile dconfig filePath -- Convert a module to C ModeToC filePath- -> do language <- languageFromFilePath filePath- dconfig <- getDriverConfig config (Just filePath)- str <- readFile filePath- runError $ cmdToC dconfig language (SourceFile filePath) str+ -> do dconfig <- getDriverConfig config (Just filePath)+ runError $ cmdToSeaFromFile dconfig filePath -- Convert a module to LLVM ModeToLLVM filePath- -> do language <- languageFromFilePath filePath- dconfig <- getDriverConfig config (Just filePath)- str <- readFile filePath- runError $ cmdToLlvm dconfig language (SourceFile filePath) str+ -> do dconfig <- getDriverConfig config (Just filePath)+ runError $ cmdToLlvmFromFile dconfig filePath -- Prepare a Disciple Core Flow program for lowering. ModeFlowPrep filePath@@ -145,21 +127,41 @@ -- Lower a Disciple Core Flow program to loops. ModeFlowLower filePath- -> do dconfig <- getDriverConfig config (Just filePath)+ -> do configDriver <- getDriverConfig config (Just filePath) str <- readFile filePath- runError $ cmdFlowLower dconfig (SourceFile filePath) str+ runError + $ cmdFlowLower+ configDriver Flow.defaultConfigScalar+ (SourceFile filePath) str + -- Lower a Disciple Core Flow program to loops.+ ModeFlowLowerKernel filePath+ -> do configDriver <- getDriverConfig config (Just filePath)+ str <- readFile filePath+ runError + $ cmdFlowLower+ configDriver Flow.defaultConfigKernel+ (SourceFile filePath) str++ -- Lower a Disciple Core Flow program to loops.+ ModeFlowLowerVector filePath+ -> do configDriver <- getDriverConfig config (Just filePath)+ str <- readFile filePath+ runError + $ cmdFlowLower configDriver Flow.defaultConfigVector + (SourceFile filePath) str+ -- Concretize rate type variables in a Disciple Core Flow program. ModeFlowConcretize filePath -> do dconfig <- getDriverConfig config (Just filePath) str <- readFile filePath runError $ cmdFlowConcretize dconfig (SourceFile filePath) str - -- Thread the world token through a Disciple Core Flow program.- ModeFlowThread filePath+ -- Melt compound data structures.+ ModeFlowMelt filePath -> do dconfig <- getDriverConfig config (Just filePath) str <- readFile filePath- runError $ cmdFlowThread dconfig (SourceFile filePath) str+ runError $ cmdFlowMelt dconfig (SourceFile filePath) str -- Wind loop primops into tail recursive loops. ModeFlowWind filePath@@ -167,6 +169,12 @@ str <- readFile filePath runError $ cmdFlowWind dconfig (SourceFile filePath) str + -- Thread the world token through a Disciple Core Flow program.+ ModeFlowThread filePath+ -> do dconfig <- getDriverConfig config (Just filePath)+ str <- readFile filePath+ runError $ cmdFlowThread dconfig (SourceFile filePath) str+ -- Build the runtime and base libraries. ModeBaseBuild -> do dconfig <- getDriverConfig config Nothing@@ -190,38 +198,37 @@ = Runtime.Config { Runtime.configHeapSize = configRuntimeHeapSize config } - simplLite <- getSimplLiteOfConfig config builder filePath- simplSalt <- getSimplSaltOfConfig config builder runtimeConfig filePath-- return $ Driver.Config- { Driver.configDump = configDump config- , Driver.configSimplLite = simplLite- , Driver.configSimplSalt = simplSalt- , Driver.configViaBackend = configViaBackend config-- , Driver.configRuntime = runtimeConfig- , Driver.configBuilder = builder- , Driver.configSuppressCoreImports = False- , Driver.configSuppressHashImports = False- , Driver.configOutputFile = configOutputFile config- , Driver.configOutputDir = configOutputDir config - , Driver.configKeepLlvmFiles = configKeepLlvmFiles config- , Driver.configKeepSeaFiles = configKeepSeaFiles config- , Driver.configKeepAsmFiles = configKeepAsmFiles config - , Driver.configTaintAvoidTypeChecks = configTaintAvoidTypeChecks config }-+ let dconfig+ = Driver.Config+ { Driver.configDump = configDump config+ , Driver.configInferTypes = configInferTypes config+ , Driver.configSimplLite = Simplifier.idsimp+ , Driver.configSimplSalt = Simplifier.idsimp+ , Driver.configViaBackend = configViaBackend config+ , Driver.configRuntime = runtimeConfig+ , Driver.configBuilder = builder+ , Driver.configPretty = Driver.defaultConfigPretty+ , Driver.configSuppressHashImports = False+ , Driver.configOutputFile = configOutputFile config+ , Driver.configOutputDir = configOutputDir config + , Driver.configKeepLlvmFiles = configKeepLlvmFiles config+ , Driver.configKeepSeaFiles = configKeepSeaFiles config+ , Driver.configKeepAsmFiles = configKeepAsmFiles config + , Driver.configTaintAvoidTypeChecks = configTaintAvoidTypeChecks config } --- | Determine the current language based on the file extension of this path, --- and slurp out a bundle of stuff specific to that language from the config.-languageFromFilePath :: FilePath -> IO Language-languageFromFilePath filePath- = case languageOfExtension (takeExtension filePath) of- Nothing - -> do hPutStrLn stderr "Unknown file extension."- exitWith $ ExitFailure 1+ simplLite <- getSimplLiteOfConfig config + dconfig + builder filePath+ + -- We need to force -infer on because the inliner templates may not+ -- have full type annotations.+ simplSalt <- getSimplSaltOfConfig config + dconfig { Driver.configInferTypes = True }+ builder runtimeConfig filePath - Just ext - -> return ext+ return $ dconfig + { Driver.configSimplLite = simplLite+ , Driver.configSimplSalt = simplSalt } -- | Print errors to stderr and set the exit code.
src/ddci-core/DDCI/Core/Command.hs view
@@ -8,14 +8,14 @@ import DDCI.Core.Command.Help import DDCI.Core.Command.Set import DDCI.Core.Command.Eval-import DDCI.Core.Command.Trans import DDCI.Core.Command.TransInteract import DDCI.Core.Command.With import DDCI.Core.State+import DDCI.Core.Mode as Mode -import DDC.Driver.Command.Ast import DDC.Driver.Command.Check import DDC.Driver.Command.Load+import DDC.Driver.Command.Trans import DDC.Driver.Command.Compile import DDC.Driver.Command.Make @@ -23,18 +23,26 @@ import DDC.Driver.Command.ToC import DDC.Driver.Command.ToLlvm +import DDC.Driver.Command.Tetra.Boxing+ import DDC.Driver.Command.Flow.Prep+import DDC.Driver.Command.Flow.Rate import DDC.Driver.Command.Flow.Lower import DDC.Driver.Command.Flow.Concretize-import DDC.Driver.Command.Flow.Thread import DDC.Driver.Command.Flow.Wind+import DDC.Driver.Command.Flow.Melt+import DDC.Driver.Command.Flow.Thread +import DDC.Type.Universe++import qualified DDC.Core.Flow as Flow+import qualified Data.Set as Set import System.IO import Control.Monad.Trans.Error import Data.List --- Command --------------------------------------------------------------------+-- Command ---------------------------------------------------------------------------------------- -- | The commands that the interpreter supports. data Command = CommandBlank -- ^ No command was entered.@@ -42,22 +50,18 @@ | CommandHelp -- ^ Display the interpreter help. | CommandSet -- ^ Set a mode. | CommandLoad -- ^ Load a module.- | CommandKind -- ^ Show the kind of a type.- | CommandUniverse -- ^ Show the universe of a type.- | CommandUniverse1 -- ^ Given a type, show the universe of the original thing.- | CommandUniverse2 -- ^ Given a kind, show the universe of the original thing.- | CommandUniverse3 -- ^ Given a sort, show the universe of the original thing.+ | CommandSort -- ^ Show the sort of a kind.+ | CommandKind -- ^ Show the kind of a spec. | CommandEquivType -- ^ Check if two types are equivalent. | CommandWitType -- ^ Show the type of a witness.- | CommandExpCheck -- ^ Check an expression.+ | CommandExpCheck -- ^ Check the type of an expression.+ | CommandExpSynth -- ^ Synthesize the type of an expression, including existentials. | CommandExpType -- ^ Check an expression, showing its type. | CommandExpEffect -- ^ Check an expression, showing its effect. | CommandExpClosure -- ^ Check an expression, showing its closure. | CommandExpRecon -- ^ Reconstruct type annotations on binders. | CommandEval -- ^ Evaluate an expression. - | CommandAst -- ^ Show the AST of an expression.- -- Generic transformations | CommandTrans -- ^ Transform an expression. | CommandTransEval -- ^ Transform then evaluate an expression.@@ -72,20 +76,26 @@ | CommandToC -- ^ Convert a module to C code. | CommandToLlvm -- ^ Convert a module to LLVM code. - -- Core Flow passes - | CommandFlowPrep -- ^ Prepare a Core Flow module for lowering.- | CommandFlowLower -- ^ Prepare and Lower a Core Flow module.- | CommandFlowConcretize -- ^ Convert operations on type level rates to concrete ones.- | CommandFlowThread -- ^ Thread a world token through lowered code.- | CommandFlowWind -- ^ Wind loop primops into tail recursive loops.+ -- Core Tetra specific passes.+ | CommandTetraBoxing -- ^ Manage boxing of numeric types. + -- Core Flow specific passes + | CommandFlowRate -- ^ Perform rate inference+ | CommandFlowPrep -- ^ Prepare a Core Flow module for lowering.+ | CommandFlowLower Flow.Config -- ^ Prepare and Lower a Core Flow module.+ | CommandFlowConcretize -- ^ Convert operations on type level rates to concrete ones.+ | CommandFlowMelt -- ^ Melt compound data structures.+ | CommandFlowWind -- ^ Wind loop primops into tail recursive loops.+ | CommandFlowThread -- ^ Thread a world token through lowered code.+ -- Inline control- | CommandWith -- ^ Add a module to the inliner table.+ | CommandWith -- ^ Add a module to the inliner table. | CommandWithLite | CommandWithSalt deriving (Eq, Show) +--------------------------------------------------------------------------------------------------- -- | Names used to invoke each command. -- Short names that form prefixes of other ones must come later -- in the list. Eg ':with-lite' after ':with'@@ -95,16 +105,12 @@ , (":?", CommandHelp) , (":set", CommandSet) , (":load", CommandLoad)+ , (":sort", CommandSort) , (":kind", CommandKind)-- , (":universe1", CommandUniverse1)- , (":universe2", CommandUniverse2)- , (":universe3", CommandUniverse3)- , (":universe", CommandUniverse)- , (":tequiv", CommandEquivType) , (":wtype", CommandWitType) , (":check", CommandExpCheck)+ , (":synth", CommandExpSynth) , (":recon", CommandExpRecon) , (":type", CommandExpType)@@ -113,8 +119,6 @@ , (":eval", CommandEval) - , (":ast", CommandAst) - -- Generic transformations , (":trun", CommandTransEval) , (":tinteract", CommandTransInteract)@@ -125,13 +129,20 @@ , (":to-c", CommandToC) , (":to-llvm", CommandToLlvm) - -- Core Flow passes- , (":flow-prep", CommandFlowPrep)- , (":flow-lower", CommandFlowLower)- , (":flow-concretize", CommandFlowConcretize)- , (":flow-thread", CommandFlowThread)- , (":flow-wind", CommandFlowWind)+ -- Core Tetra specific passes+ , (":tetra-boxing", CommandTetraBoxing) + -- Core Flow specific passes+ , (":flow-rate", CommandFlowRate)+ , (":flow-prep", CommandFlowPrep)+ , (":flow-lower-kernel", CommandFlowLower Flow.defaultConfigKernel)+ , (":flow-lower-vector", CommandFlowLower Flow.defaultConfigVector)+ , (":flow-lower", CommandFlowLower Flow.defaultConfigScalar)+ , (":flow-concretize", CommandFlowConcretize)+ , (":flow-melt", CommandFlowMelt)+ , (":flow-wind", CommandFlowWind)+ , (":flow-thread", CommandFlowThread)+ -- Make and Compile , (":compile", CommandCompile) , (":make", CommandMake)@@ -160,7 +171,7 @@ = Nothing --- Commands -------------------------------------------------------------------+-- Commands --------------------------------------------------------------------------------------- -- | Handle a single line of input. handleCmd :: State -> Command -> Source -> String -> IO State handleCmd state CommandBlank _ _@@ -171,7 +182,9 @@ return state' handleCmd1 state cmd source line- = case cmd of+ = let lang = stateLanguage state+ traceCheck = Set.member TraceCheck (stateModes state)+ in case cmd of CommandBlank -> return state @@ -191,68 +204,66 @@ return state' CommandLoad- -> do runError $ cmdLoadFromString (stateLanguage state) source line- return state-- CommandKind - -> do cmdShowKind (stateLanguage state) source line- return state-- CommandUniverse- -> do cmdUniverse (stateLanguage state) source line- return state-- CommandUniverse1- -> do cmdUniverse1 (stateLanguage state) source line+ -> do configDriver <- getDriverConfigOfState state+ runError + $ cmdLoadCoreFromString + configDriver+ (stateLanguage state) source line return state - CommandUniverse2- -> do cmdUniverse2 (stateLanguage state) source line+ CommandSort+ -> do cmdShowType lang UniverseKind source line return state - CommandUniverse3- -> do cmdUniverse3 (stateLanguage state) source line+ CommandKind + -> do cmdShowType lang UniverseSpec source line return state CommandEquivType- -> do cmdTypeEquiv (stateLanguage state) source line+ -> do cmdTypeEquiv lang source line return state CommandWitType - -> do cmdShowWType (stateLanguage state) source line+ -> do cmdShowWType lang source line return state CommandExpCheck - -> do cmdShowType (stateLanguage state) ShowTypeAll source line+ -> do cmdShowSpec lang ShowSpecAll False traceCheck source line return state CommandExpType - -> do cmdShowType (stateLanguage state) ShowTypeValue source line+ -> do cmdShowSpec lang ShowSpecData False traceCheck source line return state CommandExpEffect - -> do cmdShowType (stateLanguage state) ShowTypeEffect source line+ -> do cmdShowSpec lang ShowSpecEffect False traceCheck source line return state CommandExpClosure - -> do cmdShowType (stateLanguage state) ShowTypeClosure source line+ -> do cmdShowSpec lang ShowSpecClosure False traceCheck source line return state + CommandExpSynth+ -> do cmdShowSpec lang ShowSpecAll True traceCheck source line+ return state+ CommandExpRecon- -> do cmdExpRecon (stateLanguage state) source line+ -> do cmdExpRecon lang source line return state CommandEval -> do cmdEval state source line return state - CommandAst- -> do cmdAstExp (stateLanguage state) source line- return state- -- Generic transformations -------------- CommandTrans- -> do cmdTrans state source line+ -> do configDriver <- getDriverConfigOfState state+ runError+ $ cmdTransDetect+ configDriver+ (stateLanguage state)+ (Set.member Mode.TraceTrans $ stateModes state)+ source line return state CommandTransEval@@ -266,29 +277,39 @@ -- Conversion to machine code ----------- CommandToSalt -> do config <- getDriverConfigOfState state- runError $ cmdToSalt config (stateLanguage state) source line+ runError $ cmdToSaltCoreFromString config lang source line return state CommandToC -> do config <- getDriverConfigOfState state- runError $ cmdToC config (stateLanguage state) source line+ runError $ cmdToSeaCoreFromString config lang source line return state CommandToLlvm -> do config <- getDriverConfigOfState state- runError $ cmdToLlvm config (stateLanguage state) source line+ runError $ cmdToLlvmCoreFromString config lang source line return state + -- Core Tetra specific passes -----------+ CommandTetraBoxing+ -> do configDriver <- getDriverConfigOfState state+ runError $ cmdTetraBoxing configDriver source line+ return state - -- Core Flow passes ----------------------+ -- Core Flow specific passes ------------+ CommandFlowRate+ -> do configDriver <- getDriverConfigOfState state+ runError $ cmdFlowRate configDriver source line+ return state+ CommandFlowPrep -> do config <- getDriverConfigOfState state runError $ cmdFlowPrep config source line return state - CommandFlowLower- -> do config <- getDriverConfigOfState state- runError $ cmdFlowLower config source line+ CommandFlowLower configLower+ -> do configDriver <- getDriverConfigOfState state+ runError $ cmdFlowLower configDriver configLower source line return state CommandFlowConcretize@@ -296,14 +317,19 @@ runError $ cmdFlowConcretize config source line return state - CommandFlowThread+ CommandFlowMelt -> do config <- getDriverConfigOfState state- runError $ cmdFlowThread config source line+ runError $ cmdFlowMelt config source line return state CommandFlowWind -> do config <- getDriverConfigOfState state runError $ cmdFlowWind config source line+ return state++ CommandFlowThread+ -> do config <- getDriverConfigOfState state+ runError $ cmdFlowThread config source line return state -- Make and Compile ---------------------
src/ddci-core/DDCI/Core/Command/Eval.hs view
@@ -2,16 +2,19 @@ module DDCI.Core.Command.Eval ( cmdStep , cmdEval+ , cmdTransEval , evalExp) where import DDCI.Core.Stats.Trace import DDCI.Core.Output import DDCI.Core.State import DDC.Driver.Command.Check+import DDC.Driver.Command.Trans import DDC.Core.Eval.Env import DDC.Core.Eval.Step import DDC.Core.Eval.Name import DDC.Core.Transform.Reannotate+import DDC.Core.Fragment import DDC.Core.Exp import DDC.Core.Check import DDC.Core.Pretty@@ -30,22 +33,25 @@ import Data.Maybe (fromMaybe) +--------------------------------------------------------------------------------------------------- -- | Parse, check, and single step evaluate an expression. cmdStep :: State -> Source -> String -> IO () cmdStep state source str | Language bundle <- stateLanguage state- , modules0 <- bundleModules bundle+ = case profileName $ fragmentProfile $ bundleFragment bundle of+ "Eval" -> cmdStep_eval state source bundle str+ lang -> do putStrLn $ "Cannot step '" ++ lang ++ "' expressions."+ +cmdStep_eval state source bundle str+ | modules0 <- bundleModules bundle , (modules :: Maybe (ModuleMap (AnTEC () Name) Name)) <- gcast modules0 , modules' <- fromMaybe Map.empty modules- = cmdParseCheckExp Eval.fragment modules' False source str >>= goStore + = cmdParseCheckExp Eval.fragment modules' Recon False False source str + >>= goStore where- -- Expression had a parse or type error.- goStore Nothing- = return ()- -- Expression is well-typed.- goStore (Just x)+ goStore (Just x, _) = let -- The evaluator doesn't accept any annotations x_stripped = reannotate (const ()) x @@ -54,31 +60,76 @@ in goStep store x + -- Expression had a parse or type error.+ goStore _+ = return ()+ goStep store x = do _ <- forcePrint state store x return () +--------------------------------------------------------------------------------------------------- -- | Parse, check, and fully evaluate an expression. cmdEval :: State -> Source -> String -> IO () cmdEval state source str | Language bundle <- stateLanguage state- , modules0 <- bundleModules bundle+ = case profileName $ fragmentProfile $ bundleFragment bundle of+ "Eval" -> cmdEval_eval state source bundle str+ lang -> do putStrLn $ "Cannot evaluate '" ++ lang ++ "' expressions."+ +cmdEval_eval state source bundle str+ | modules0 <- bundleModules bundle , (modules :: Maybe (ModuleMap (AnTEC () Name) Name)) <- gcast modules0 , modules' <- fromMaybe Map.empty modules- = cmdParseCheckExp Eval.fragment modules' False source str >>= goEval+ = cmdParseCheckExp Eval.fragment modules' Recon False False source str + >>= goEval where- -- Expression had a parse or type error.- goEval Nothing- = return ()- -- Expression is well-typed.- goEval (Just expr)+ goEval (Just expr, _) = evalExp state $ reannotate (\a -> a { annotTail = ()} ) expr + -- Expression had a parse or type error.+ goEval _+ = return () ++cmdTransEval :: State -> Source -> String -> IO ()+cmdTransEval state source str+ = do config <- getDriverConfigOfState state+ cmdTransExpCont+ config+ (Set.member TraceTrans $ stateModes state)+ (stateLanguage state)+ (evalExpCast state)+ source+ str+++---------------------------------------------------------------------------------------------------+evalExpCast + :: Typeable n+ => State -> Exp (AnTEC () n) n -> IO ()+evalExpCast state xx++ | (Just (ExpBox xx') :: Maybe (ExpBox Name)) + <- gcast (ExpBox xx)+ = evalExp state xx'++ | otherwise+ = error "ddci-core: evalExpCast failed"+++-- Proxies to help with type casting.+-- The 'gcast' function will only cast the rightmost 'n' of a type,+-- But there is also an 'n' attached to the annotation type of+-- the simplifier. We use the proxy to cast both occurrences at once.+data ExpBox n+ = ExpBox (Exp (AnTEC () n) n)++ -- | Evaluate an already parsed and type-checked expression. -- Exported so transforms can test with it. evalExp :: State -> Exp (AnTEC () Name) Name -> IO ()@@ -151,18 +202,19 @@ forcePrint state store x = let -- Get the type, effect and closure of the original expression.- Just annot = takeAnnotOfExp x- tX = annotType annot- effX = annotEffect annot- cloX = annotClosure annot+ annot = annotOfExp x+ tX = annotType annot+ effX = annotEffect annot+ cloX = annotClosure annot -- The evaluator doesn't want any type annotations on the expresison. x_stripped = reannotate (const ()) x in case force store x_stripped of StepProgress store' x_stripped'- -> case checkExp (configOfProfile Eval.profile) - primKindEnv primTypeEnv x_stripped' of+ -> case fst $ checkExp (configOfProfile Eval.profile) + primKindEnv primTypeEnv + x_stripped' Recon of Left err -> do -- Print intermediate expression.
src/ddci-core/DDCI/Core/Command/Help.hs view
@@ -29,90 +29,99 @@ , "" , "----------------------------------------------------------------- Commands --" , "General"- , " :quit Exit DDCi-core." - , " :help Display this help page." + , " :quit Exit DDCi-core." + , " :help Display this help page." , ""- , "Modes"- , " :set Display active modes and program transform."- , " :set +MODE Enable a mode."- , " :set /MODE Disable a mode."- , " :set lang LANG Set the language fragment."- , " :set builder BUILDER Set the builder."- , " :set outputdir DIR Set the output directory."- , " :set output FILE Set the output file."- , " :set trans TRANS Set the program transform."+ , "Compilation"+ , " :compile PATH Compile the module at this path to an object file."+ , " :make PATH Make the module at this path into an executable." , ""- , " :set rule NAME [an : kn] ... (xn : tn) ... exp1 = exp2"- , " Add a rewrite rule to the database."+ , "Conversion"+ , " :load MODULE Load and type check a module."+ , " :to-salt MODULE Convert a module to Salt."+ , " :to-llvm MODULE Convert a module to LLVM."+ , " :to-c MODULE Convert a module to C."+ , " :trans MODULE/EXP Transform the given module or expression." , ""- , " :with PATH Use this module for 'set trans' inlining."- , " :with-lite PATH ... use Lite module during -compile or -make cmds."- , " :with-salt PATH ... use Salt module during -compile or -make cmds."+ , "Type Commands"+ , " :kind TYPE Show the kind of a type."+ , " :tequiv TYPE TYPE Check if two types are equivalent." , ""- , " MODE ::="- , " Indent Pretty print expressions with indenting."- , " TraceEval Show the expression at every step when evaluating."- , " TraceStore Show the store at every step when evaluating."- , " SuppressImports Suppress the import list when printing modules."+ , "Witness Commands"+ , " :wtype WITNESS Show the type of a witness expression." , ""- , " LANG ::="- , " Lite | Salt | Zero | Eval"+ , "Expression Commands"+ , " :check EXP Show the type, effect and closure of an exp."+ , " :type EXP Show the type of an expression."+ , " :effect EXP Show the effect of an expression."+ , " :closure EXP Show the closure of an expression." + , " :eval EXP Evaluate an expression."+ , " :ast EXP Show the abstract syntax tree of a exp." , ""- , " BUILDER ::= "- , " x86_32-darwin | x86_64-darwin | x86_32-linux | x86_64-linux"- , " x86_32-cygwin | ppc32-linux"+ , " :trun EXP Transform the given expression then evaluate it."+ , " :tinteract EXP Enter interactive transformation mode." , ""- , " TRANS ::= "- , " { TRANS } Parenthesis."- , " fix N TRANS Transform to a fixpoint, or bail out after N iters."- , " TRANS; TRANS Sequence two transforms."- , " Id Return the original program unharmed."- , " Anonymize Anonymize names to deBruijn form."- , " Namify Introduce fresh names for deBruijn binders."- , " Snip Introduce let-bindings for nested applications."- , " SnipOver ... and over-applications."- , " Flatten Flatten nested let-bindings."- , " Beta Perform beta-reduction for value arguments."- , " BetaLets ... introducing new let-bindings for redex arguments."- , " Bubble Float casts outwards, and combine similar ones."- , " Prune Erase unused, ineffectual let-bindings."- , " Forward Float let-bindings forward into their use sites."- , " Rewrite Perform rule based rewriting. Use 'set rule' to add rules."- , " Inline Perform inlining. Use 'with' to add source modules."- , " Elaborate Introduce default witnesses for unconstrained regions." , ""- , "Type Commands"- , " :kind TYPE Show the kind of a type."- , " :tequiv TYPE TYPE Check if two types are equivalent."+ , "Data Flow Fusion Transforms" + , " These work on modules in the Disciple Core Flow (.dcf) fragment only."+ , " :flow-prep MODULE Prepare a module for lowering."+ , " :flow-lower MODULE Lower a module to loop code."+ , " :flow-wind MODULE Wind loop primops into tail recursive loops."+ , " :flow-concretize MODULE Rewrite primops to use concrete series lengths."+ , " :flow-melt MODULE Melt compound data structures."+ , " :flow-wind MODULE Wind loop primops into tail recursive loops."+ , " :flow-thread MODULE Thread state token through program." + + , "Modes"+ , " :set Display active modes and program transform."+ , " :set +MODE Enable a mode."+ , " :set /MODE Disable a mode."+ , " :set lang LANG Set the language fragment."+ , " :set builder BUILDER Set the builder."+ , " :set outputdir DIR Set the output directory."+ , " :set output FILE Set the output file."+ , " :set trans TRANS Set the program transform." , ""- , "Witness Commands"- , " :wtype WITNESS Show the type of a witness expression."+ , " :set rule NAME [an : kn] ... (xn : tn) ... exp1 = exp2"+ , " Add a rewrite rule to the database." , ""- , "Expression Commands"- , " :check EXP Show the type, effect and closure of an exp."- , " :type EXP Show the type of an expression."- , " :effect EXP Show the effect of an expression."- , " :closure EXP Show the closure of an expression." - , " :eval EXP Evaluate an expression."- , " :ast EXP Show the abstract syntax tree of a exp." + , " :with PATH Use this module for 'set trans' inlining."+ , " :with-lite PATH ... use Lite module during -compile or -make cmds."+ , " :with-salt PATH ... use Salt module during -compile or -make cmds." , ""- , " :trans EXP Transform the given expression."- , " :trun EXP Transform the given expression then evaluate it."- , " :tinteract EXP Enter interactive transformation mode."+ , " MODE ::="+ , " Synth Use type synthesis when loading source."+ , " Indent Pretty print expressions with indenting."+ , " TraceEval Show the expression at every step when evaluating."+ , " TraceStore Show the store at every step when evaluating."+ , " PrettyUseLetCase Pretty print single-alt case expressions as 'letcase'."+ , " SuppressImports Suppress the import list when printing modules."+ , " SuppressLetTypes Suppress type annots on let-binders." , ""- , "Module Commands"- , " :compile PATH Compile the module at this path to an object file."- , " :make PATH Make the module at this path into an executable."+ , " LANG ::="+ , " Lite | Salt | Zero | Eval" , ""- , " :load MODULE Type check and desugar module source code."- , " :to-salt MODULE Convert module source code to Salt."- , " :to-c MODULE Convert module source code to C."- , " :to-llvm MODULE Convert module source code to LLVM."+ , " BUILDER ::= "+ , " x86_32-darwin | x86_64-darwin | x86_32-linux | x86_64-linux"+ , " x86_32-cygwin | ppc32-linux" , ""- , "Data Flow Fusion Transforms" - , " :flow-prep MODULE Prepare a module for lowering."- , " :flow-lower MODULE Lower a module to loop code."- , " :flow-wind MODULE Wind loop primops into tail recursive loops."- , " :flow-concretize MODULE Rewrite primops to use concrete series lengths."+ , " TRANS ::= "+ , " { TRANS } Parenthesis."+ , " fix N TRANS Transform to a fixpoint, or bail out after N iters."+ , " TRANS; TRANS Sequence two transforms."+ , " Id Return the original program unharmed."+ , " Anonymize Anonymize names to deBruijn form."+ , " Namify Introduce fresh names for deBruijn binders."+ , " Snip Introduce let-bindings for nested applications."+ , " SnipOver ... and over-applications."+ , " Flatten Flatten nested let-bindings."+ , " Beta Perform beta-reduction for value arguments."+ , " BetaLets ... introducing new let-bindings for redex arguments."+ , " Bubble Float casts outwards, and combine similar ones."+ , " Prune Erase unused, ineffectual let-bindings."+ , " Forward Float let-bindings forward into their use sites."+ , " Rewrite Perform rule based rewriting. Use 'set rule' to add rules."+ , " Inline Perform inlining. Use 'with' to add source modules."+ , " Elaborate Introduce default witnesses for unconstrained regions." , "" ]
src/ddci-core/DDCI/Core/Command/Set.hs view
@@ -12,11 +12,11 @@ import DDC.Core.Fragment import DDC.Core.Simplifier.Parser import DDC.Core.Transform.Reannotate-import DDC.Core.Check import DDC.Base.Pretty import Control.Monad import Data.Char import Data.List+import qualified DDC.Core.Check as Check import qualified DDCI.Core.Rewrite as R import qualified Data.Map as Map import qualified Data.Set as Set@@ -89,7 +89,7 @@ = case R.parseRewrite fragment modules rest of Right (R.SetAdd name rule) -> do chatStrLn state $ "ok, added " ++ name- let rule' = reannotate (\a -> a { annotTail = ()}) rule+ let rule' = reannotate (\a -> a { Check.annotTail = ()}) rule let rules' = Map.insert name rule' rules let bundle' = bundle { bundleRewriteRules = rules' } return $ state { stateLanguage = Language bundle' }
− src/ddci-core/DDCI/Core/Command/Trans.hs
@@ -1,173 +0,0 @@-{-# OPTIONS -Werror #-}--module DDCI.Core.Command.Trans- ( cmdTrans- , cmdTransEval- , applyTransAndCheck)-where-import DDCI.Core.Command.Eval-import DDCI.Core.Output-import DDCI.Core.State-import DDC.Driver.Command.Check-import DDC.Core.Fragment-import DDC.Core.Transform.Reannotate-import DDC.Core.Simplifier-import DDC.Core.Check-import DDC.Core.Exp-import DDC.Core.Compounds-import DDC.Type.Equiv-import DDC.Type.Subsumes-import DDC.Base.Pretty-import DDC.Type.Env as Env-import qualified Control.Monad.State.Strict as S-import qualified DDC.Build.Language.Eval as Eval-import qualified DDC.Core.Eval.Name as Eval-import qualified Data.Set as Set-import Data.Typeable-import Control.Monad-import DDC.Core.Module----- Trans ------------------------------------------------------------------------- | Apply the current transform to an expression.-cmdTrans :: State -> Source -> String -> IO ()-cmdTrans state source str- | Language bundle <- stateLanguage state- , fragment <- bundleFragment bundle- , modules <- bundleModules bundle- , simpl <- bundleSimplifier bundle- , zero <- bundleStateInit bundle- , profile <- fragmentProfile fragment- = cmdParseCheckExp fragment modules True source str - >>= goStore profile modules zero simpl- where- -- Expression had a parse or type error.- goStore _ _ _ _ Nothing- = do return ()-- -- Expression is well-typed.- goStore profile modules zero simpl (Just x)- = do let kenv = modulesExportKinds modules (profilePrimKinds profile)- let tenv = modulesExportTypes modules (profilePrimTypes profile)-- tr <- applyTransAndCheck state profile kenv tenv zero simpl - $ reannotate (\a -> a { annotTail = ()}) x- - case tr of- Nothing -> return ()- Just x' -> outDocLn state $ ppr x'----- TransEval --------------------------------------------------------------------- | Apply the current transform to an expression,--- then evaluate and display the result-cmdTransEval :: State -> Source -> String -> IO ()-cmdTransEval state source str- | Language bundle <- stateLanguage state- , fragment <- bundleFragment bundle- , modules0 <- bundleModules bundle- , zero <- bundleStateInit bundle- , simpl0 <- bundleSimplifier bundle- , profile0 <- fragmentProfile fragment-- -- The evaluator only works on expressions with Eval.Names, - -- The actual name type is an existential of Bundle, - -- so we use gcast to check whether the bundle is really- -- set to Eval.- , Just (profile :: Profile Eval.Name) <- gcast profile0 - , Just (SimplBox simpl) <- gcast (SimplBox simpl0)- , Just (modules :: ModuleMap (AnTEC () Eval.Name) Eval.Name)- <- gcast modules0- = do result' <- cmdParseCheckExp Eval.fragment modules False source str - case result' of- Nothing -> return ()- Just xx- -> do let kenv = modulesExportKinds modules (profilePrimKinds profile)- let tenv = modulesExportTypes modules (profilePrimTypes profile)-- -- Apply the current transform.- tr <- applyTransAndCheck state profile kenv tenv zero simpl - $ reannotate (\a -> a { annotTail = () }) xx-- case tr of- Nothing -> return ()- Just x'- -- Evaluate the transformed expression.- -> do outDocLn state $ ppr x'- evalExp state x'- return ()-- | otherwise- = outDocLn state $ text "Language must be set to Eval for :teval"----- Proxies to help with type casting.--- The 'gcast' function will only cast the rightmost 'n' of a type,--- But there is also an 'n' attached to the annotation type of--- the simplifier. We use the proxy to cast both occurrences at once.-data SimplBox s n- = SimplBox (Simplifier s (AnTEC () n) n)----- Trans ------------------------------------------------------------------------- | Transform an expression, or display errors-applyTransAndCheck - :: (Eq n, Ord n, Pretty n, Show n)- => State- -> Profile n- -> Env n -- Kind Environment.- -> Env n -- Type Environment.- -> s- -> Simplifier s (AnTEC () n) n- -> Exp (AnTEC () n) n- -> IO (Maybe (Exp (AnTEC () n) n))--applyTransAndCheck state profile kenv tenv zero simpl xx- = do- let Just annot = takeAnnotOfExp xx- let t1 = annotType annot- let eff1 = annotEffect annot- let clo1 = annotClosure annot-- -- Apply the simplifier.- let tx = flip S.evalState zero- $ applySimplifierX profile kenv tenv simpl xx- - let x' = reannotate (const ()) $ result tx-- when (Set.member TraceTrans $ stateModes state)- $ case (resultInfo tx) of- TransformInfo inf- -> outDocLn state - $ text "* TRANSFORM INFORMATION: " <$> indent 4 (ppr inf) <$> text ""-- -- Check that the simplifier perserved the type of the expression.- case checkExp (configOfProfile profile) kenv tenv x' of- Right (x2, t2, eff2, clo2)- | equivT t1 t2- , subsumesT kEffect eff1 eff2- , subsumesT kClosure clo1 clo2- -> do return (Just x2)-- | otherwise- -> do putStrLn $ renderIndent $ vcat- [ text "* CRASH AND BURN: Transform is not type preserving."- , ppr x'- , text ":: 1 " <+> ppr t1- , text ":: 2 " <+> ppr t2- , text ":!:1 " <+> ppr eff1- , text ":!:2 " <+> ppr eff2- , text ":$:1 " <+> ppr clo1- , text ":$:2 " <+> ppr clo2 ]- return Nothing-- Left err- -> do putStrLn $ renderIndent $ vcat- [ text "* CRASH AND BURN: Type error in transformed program."- , ppr err- , text "" ]-- outDocLn state $ text "Transformed expression:"- outDocLn state $ ppr x'- return Nothing-
src/ddci-core/DDCI/Core/Command/TransInteract.hs view
@@ -2,10 +2,10 @@ ( cmdTransInteract , cmdTransInteractLoop) where-import DDCI.Core.Command.Trans import DDCI.Core.Output import DDCI.Core.State import DDC.Driver.Command.Check+import DDC.Driver.Command.Trans import DDC.Build.Language import DDC.Core.Fragment import DDC.Core.Simplifier.Parser@@ -14,7 +14,8 @@ import DDC.Core.Check import DDC.Core.Module import DDC.Base.Pretty-import qualified Data.Map as Map+import qualified Data.Map as Map+import qualified Data.Set as Set -- TransInteract --------------------------------------------------------------@@ -24,18 +25,14 @@ | Language bundle <- stateLanguage state , fragment <- bundleFragment bundle , modules <- bundleModules bundle- = cmdParseCheckExp fragment modules True source str + = cmdParseCheckExp fragment modules Recon False False source str >>= goStore bundle where- -- Expression had a parse or type error.- goStore _ Nothing- = do return state- -- Expression is well-typed.- goStore bundle (Just xx)+ goStore bundle (Just xx, _) = do let xx' = reannotate (\a -> a { annotTail = () }) xx- let Just annot = takeAnnotOfExp xx'+ let annot = annotOfExp xx' let t1 = annotType annot let eff1 = annotEffect annot let clo1 = annotClosure annot@@ -47,6 +44,10 @@ return state { stateTransInteract = Just hist } + -- Expression had a parse or type error.+ goStore _ _+ = do return state+ cmdTransInteractLoop :: State -> String -> IO State cmdTransInteractLoop state str@@ -96,16 +97,18 @@ return state Right tr' -> do- let kenv = modulesExportKinds+ let kenv = modulesExportTypes (bundleModules bundle) (profilePrimKinds profile) - let tenv = modulesExportTypes+ let tenv = modulesExportValues (bundleModules bundle) (profilePrimTypes profile) - x_trans <- applyTransAndCheck state profile kenv tenv- (bundleStateInit bundle) tr' x'+ x_trans <- transExp+ (Set.member TraceTrans $ stateModes state)+ profile kenv tenv+ (bundleStateInit bundle) tr' x' case x_trans of Nothing -> return state
src/ddci-core/DDCI/Core/Command/With.hs view
@@ -13,9 +13,10 @@ import Control.Monad import Data.IORef import Data.Char-import qualified Data.Map as Map+import qualified DDC.Core.Check as C import qualified DDC.Build.Language.Lite as Lite import qualified DDC.Build.Language.Salt as Salt+import qualified Data.Map as Map -- | Add a module to the inliner table.@@ -39,18 +40,20 @@ = do res <- cmdWith_load Lite.fragment str case res of Nothing -> return state- Just mdl ->- return $ state- { stateWithLite = Map.insert (moduleName mdl) mdl (stateWithLite state) }+ Just mdl + -> return $ state+ { stateWithLite = Map.insert (moduleName mdl) mdl + (stateWithLite state) } cmdWithSalt :: State -> Source -> String -> IO State cmdWithSalt state _source str = do res <- cmdWith_load Salt.fragment str case res of Nothing -> return state- Just mdl ->- return $ state- { stateWithSalt = Map.insert (moduleName mdl) mdl (stateWithSalt state) }+ Just mdl + -> return $ state+ { stateWithSalt = Map.insert (moduleName mdl) mdl + (stateWithSalt state) } cmdWith_load frag str@@ -71,10 +74,10 @@ cmdWith_parse frag source src = do ref <- newIORef Nothing errs <- pipeText (nameOfSource source) (lineStartOfSource source) src- $ PipeTextLoadCore frag+ $ PipeTextLoadCore frag C.Recon SinkDiscard [ PipeCoreReannotate (\a -> a { annotTail = ()}) [ PipeCoreHacks (Canned (\m -> writeIORef ref (Just m) >> return m)) - [PipeCoreOutput SinkDiscard] ]]+ [ PipeCoreOutput pprDefaultMode SinkDiscard] ]] case errs of [] -> do
src/ddci-core/DDCI/Core/Interface/Interactive.hs view
@@ -1,6 +1,6 @@ module DDCI.Core.Interface.Interactive- ( runInteractive)+ (runInteractive) where import DDCI.Core.Input import DDCI.Core.State@@ -15,7 +15,7 @@ -- | Run an interactive session, reading commands from the console. runInteractive :: IO () runInteractive- = do putStrLn "DDCi-core, version 0.3.2: http://disciple.ouroborus.net."+ = do putStrLn "DDCi-core, version 0.4.1: http://disciple.ouroborus.net." putStrLn "Type :help for help." -- Setup terminal mode.
src/ddci-core/DDCI/Core/Mode.hs view
@@ -5,30 +5,57 @@ where --- | DDCI mode flags.+-- | ddci-core mode flags. data Mode+ -- | Use type synthesis / bidirectional type checking+ -- when loading source code.+ = Synth++ -- | Render expressions displayed to user using indenting.+ | Indent++ -- Tracing --------------------+ -- | Display type checker trace with check commands.+ | TraceCheck+ -- | Display the expression at each step in the evaluation.- = TraceEval+ | TraceEval -- | Display the store state at each step in the evaluation. | TraceStore - -- | Render expressions displayed to user using indenting.- | Indent+ -- | Display information about each transformation step+ | TraceTrans - -- | Suppress import lists when printing modules+ -- Pretty Printer Config ------+ -- There is one mode here for each field in Driver.Config.ConfigPretty++ -- | Use 'letcase' when pretty printing core modules.+ | PrettyUseLetCase++ -- | Display types on primitive variables.+ | PrettyVarTypes++ -- | Display types on primitive constructors.+ | PrettyConTypes++ -- | Suppress import lists when printing modules. | SuppressImports + -- | Suppress export lists when printing modules.+ | SuppressExports++ -- | Suppress type annotations on let-bindings.+ | SuppressLetTypes++ ------------------------------ -- | When pretty printing Salt modules as C code, -- include the #includes etc needed for compilation. | SaltPrelude -- | Dump all intermediate versions of the code during compilation. | Dump-- -- | Display information about each transformation step- | TraceTrans-+ -- | Avoid type checking if possible. -- Helpful when debugging program transformations to see invalid -- code instead of an error message.@@ -40,13 +67,20 @@ readMode :: String -> Maybe Mode readMode str = case str of+ "Synth" -> Just Synth+ "Indent" -> Just Indent+ "TraceCheck" -> Just TraceCheck "TraceEval" -> Just TraceEval "TraceStore" -> Just TraceStore- "Indent" -> Just Indent+ "TraceTrans" -> Just TraceTrans+ "PrettyUseLetCase" -> Just PrettyUseLetCase+ "PrettyVarTypes" -> Just PrettyVarTypes+ "PrettyConTypes" -> Just PrettyConTypes "SuppressImports" -> Just SuppressImports+ "SuppressExports" -> Just SuppressExports+ "SuppressLetTypes" -> Just SuppressLetTypes "SaltPrelude" -> Just SaltPrelude "Dump" -> Just Dump- "TraceTrans" -> Just TraceTrans "TaintAvoidTypeChecks" -> Just TaintAvoidTypeChecks _ -> Nothing
src/ddci-core/DDCI/Core/Rewrite.hs view
@@ -87,8 +87,8 @@ kinds = profilePrimKinds (fragmentProfile fragment) types = profilePrimTypes (fragmentProfile fragment) - kinds' = modulesExportKinds modules kinds- types' = modulesExportTypes modules types+ kinds' = modulesExportTypes modules kinds+ types' = modulesExportValues modules types -- | Display rule
src/ddci-core/DDCI/Core/State.hs view
@@ -3,7 +3,8 @@ ( State (..) , Bundle (..) , initState- , getDriverConfigOfState+ , Mode (..)+ , adjustMode , TransHistory (..) @@ -11,11 +12,11 @@ , Language (..) , languages- , getDefaultBuilderConfig- , getActiveBuilder - , Mode (..)- , adjustMode)+ -- Driver config.+ , getDriverConfigOfState+ , getDefaultBuilderConfig+ , getActiveBuilder) where import DDCI.Core.Mode import DDC.Code.Config@@ -23,7 +24,6 @@ import DDC.Interface.Source import DDC.Build.Builder import DDC.Build.Language-import DDC.Core.Check import DDC.Core.Exp import DDC.Core.Module import DDC.Core.Simplifier@@ -32,12 +32,14 @@ import System.FilePath import Data.Map (Map) import Data.Set (Set)+import DDC.Core.Check (AnTEC(..)) import qualified DDC.Build.Language.Eval as Eval import qualified DDC.Core.Salt as Salt import qualified DDC.Core.Lite as Lite import qualified DDC.Core.Simplifier as S import qualified DDC.Core.Salt.Runtime as Runtime import qualified DDC.Driver.Stage as D+import qualified DDC.Driver.Config as D import qualified Data.Map as Map import qualified Data.Set as Set @@ -129,8 +131,9 @@ = do builder <- getActiveBuilder state return $ D.Config- { D.configDump = Set.member Dump (stateModes state)- , D.configViaBackend = D.ViaLLVM+ { D.configDump = Set.member Dump (stateModes state)+ , D.configInferTypes = Set.member Synth (stateModes state)+ , D.configViaBackend = D.ViaLLVM -- ISSUE #300: Allow the default heap size to be set when -- compiling the program.@@ -143,7 +146,7 @@ , D.configSimplLite = stateSimplLite state , D.configSimplSalt = stateSimplSalt state , D.configBuilder = builder- , D.configSuppressCoreImports = Set.member SuppressImports (stateModes state)+ , D.configPretty = configPretty , D.configSuppressHashImports = not $ Set.member SaltPrelude (stateModes state) , D.configKeepLlvmFiles = False , D.configKeepSeaFiles = False@@ -152,7 +155,18 @@ , D.configTaintAvoidTypeChecks = Set.member TaintAvoidTypeChecks (stateModes state) } + where modes = stateModes state+ + configPretty + = D.ConfigPretty+ { D.configPrettyVarTypes = Set.member PrettyVarTypes modes+ , D.configPrettyConTypes = Set.member PrettyConTypes modes+ , D.configPrettyUseLetCase = Set.member PrettyUseLetCase modes + , D.configPrettySuppressImports = Set.member SuppressImports modes+ , D.configPrettySuppressExports = Set.member SuppressExports modes+ , D.configPrettySuppressLetTypes = Set.member SuppressLetTypes modes } + -- | Holds platform independent builder info. getDefaultBuilderConfig :: IO BuilderConfig getDefaultBuilderConfig@@ -174,7 +188,7 @@ -> do config <- getDefaultBuilderConfig mBuilder <- determineDefaultBuilder config case mBuilder of- Nothing -> error "getActiveBuilder unrecognised host platform"+ Nothing -> error "ddci-core.getActiveBuilder: unrecognised host platform" Just builder -> return builder
src/ddci-core/DDCI/Core/Stats/Trace.hs view
@@ -26,14 +26,12 @@ traceStoreX store entered xx = let down = traceStoreX store entered in case xx of- XVar{} -> xx-- XCon _ dc- | Just n@(NameLoc l) <- takeNameOfDaCon dc- , not $ Set.member n entered+ XVar _ (UPrim n@(NameLoc l) _)+ | not $ Set.member n entered , Just sbind <- lookupBind l store -> traceStoreX store (Set.insert n entered) (expOfSBind sbind) + XVar{} -> xx XCon{} -> xx XApp a x1 x2 -> XApp a (down x1) (down x2) XLAM a b x -> XLAM a b (down x)@@ -52,7 +50,7 @@ in case ls of LLet b x -> LLet b (down x) LRec bxs -> LRec [(b, down x) | (b, x) <- bxs]- LLetRegions{} -> ls+ LPrivate{} -> ls LWithRegion{} -> ls @@ -78,5 +76,5 @@ -- | Convert a store location to a constructor expression. expOfLoc :: Loc -> Exp () Name-expOfLoc l = XCon () (mkDaConSolid (NameLoc l) (tBot kData))+expOfLoc l = XVar () (UPrim (NameLoc l) (tBot kData))
+ src/ddci-tetra/DDCI/Tetra/Command.hs view
@@ -0,0 +1,123 @@++module DDCI.Tetra.Command+ ( Command (..)+ , commands+ , readCommand+ , handleCommand)+where+import DDCI.Tetra.State+import DDCI.Tetra.Command.Help+import DDCI.Tetra.Command.Set+import DDCI.Tetra.Command.Parse+import DDCI.Tetra.Command.Desugar+import DDCI.Tetra.Command.Infer+import DDCI.Tetra.Command.ToCore+import DDC.Interface.Source+import DDC.Driver.Command.ToSalt +import Control.Monad.Trans.Error+import Data.List+import System.IO+++-- | Commands accepted by ddci-tetra.+data Command+ = CommandBlank -- ^ No command was entered.+ | CommandUnknown -- ^ Some unknown (invalid) command.+ | CommandHelp -- ^ Display the interpreter help.+ | CommandSet -- ^ Set an interpreter mode.+ | CommandParse -- ^ Parse a Tetra source module.+ | CommandDesugar -- ^ Desugar a Tetra source module.+ | CommandInfer -- ^ Perform type inference.+ | CommandToCore -- ^ Convert to Core Tetra.+ | CommandToSalt -- ^ Convert to Core Salt.+ deriving (Eq, Show)+++-- | Names used to invoke each command.+commands :: [(String, Command)]+commands+ = [ (":help", CommandHelp)+ , (":?", CommandHelp) + , (":set", CommandSet)+ , (":parse", CommandParse) + , (":desugar", CommandDesugar)+ , (":infer", CommandInfer) + , (":to-core", CommandToCore) + , (":to-salt", CommandToSalt) ]+++-- | Read the command from the front of a string.+readCommand :: String -> Maybe (Command, String)+readCommand ss+ | null $ words ss+ = Just (CommandBlank, ss)++ | (cmd, rest) : _ + <- [ (cmd, drop (length str) ss) + | (str, cmd) <- commands+ , isPrefixOf str ss ]+ = Just (cmd, rest)++ | ':' : _ <- ss+ = Just (CommandUnknown, ss)++ | otherwise+ = Nothing+++handleCommand :: State -> Command -> Source -> String -> IO State+handleCommand state cmd source line+ = do state' <- handleCommand1 state cmd source line+ return state'++handleCommand1 state cmd source line+ = case cmd of+ CommandBlank+ -> return state++ CommandUnknown+ -> do putStr $ unlines+ [ "unknown command."+ , "use :? for help." ]++ return state++ CommandHelp+ -> do putStrLn help+ return state++ CommandSet+ -> do state' <- cmdSet state line+ return state'++ CommandParse+ -> do cmdParse state source line+ return state++ CommandDesugar+ -> do cmdDesugar state source line+ return state++ CommandInfer+ -> do cmdInfer state source line+ return state++ CommandToCore+ -> do config <- getDriverConfigOfState state+ cmdToCore state config source line+ return state++ CommandToSalt+ -> do config <- getDriverConfigOfState state+ runError $ cmdToSaltSourceTetraFromString config source line+ return state+++-- | Just print errors to stdout and continue the session.+runError :: ErrorT String IO () -> IO ()+runError m+ = do result <- runErrorT m+ case result of+ Left err -> hPutStrLn stdout err+ Right _ -> return ()+
+ src/ddci-tetra/DDCI/Tetra/Command/Desugar.hs view
@@ -0,0 +1,38 @@++module DDCI.Tetra.Command.Desugar+ (cmdDesugar)+where+import DDC.Interface.Source+import DDCI.Tetra.State+import DDC.Base.Pretty+import DDC.Source.Tetra.Lexer+import DDC.Source.Tetra.Parser+import DDC.Source.Tetra.Pretty ()+import DDC.Source.Tetra.Transform.Defix+import qualified DDC.Core.Lexer as C+import qualified DDC.Base.Parser as BP+++cmdDesugar :: State -> Source -> String -> IO ()+cmdDesugar _state source str+ = goLex+ where goLex + = let tokens = lexModuleString (nameOfSource source) 1 str+ in goParse tokens++ goParse tokens+ = let context = Context+ { contextTrackedEffects = True+ , contextTrackedClosures = True+ , contextFunctionalEffects = False+ , contextFunctionalClosures = False }++ in case BP.runTokenParser C.describeTok (nameOfSource source)+ (pModule context) tokens of+ Left err -> error $ show err+ Right mm -> goDesugar mm++ goDesugar mm+ = case defix defaultFixTable mm of+ Left err -> putStrLn (renderIndent $ ppr err)+ Right mm' -> putStrLn (renderIndent $ ppr mm')
+ src/ddci-tetra/DDCI/Tetra/Command/Help.hs view
@@ -0,0 +1,36 @@++module DDCI.Tetra.Command.Help+where++help :: String+help = unlines+ [ "-------------------------------------------------------------------- Usage --"+ , ""+ , " On the command line"+ , " Prefix commands with '-'"+ , " $ ddci-tetra -parse \"\\(x : Unit). x\""+ , ""+ , " Read input from a file with ':'"+ , " $ ddci-tetra -load: SomeFile.dst"+ , ""+ , " Interactively"+ , " Prefix commands with ':'"+ , " > :check \\(x : Unit). x"+ , ""+ , " Split commands over multiple lines with '..', terminating with ';;'"+ , " > :check.."+ , " \\(x : Unit). x;;"+ , ""+ , " Read input from a file with '<'"+ , " > :load< SomeFile.dst"+ , ""+ , "----------------------------------------------------------------- Commands --"+ , "General"+ , " :quit Exit DDCi-core." + , " :help Display this help page." + , " :parse MODULE Parse a module."+ , " :desugar MODULE Desugar a module." + , " :infer MODULE Prepare a module for type inference."+ , " :to-core MODULE Convert a module to Core Tetra."+ , " :to-salt MODULE Convert a module to Core Salt."+ ]
+ src/ddci-tetra/DDCI/Tetra/Command/Infer.hs view
@@ -0,0 +1,46 @@++module DDCI.Tetra.Command.Infer+ (cmdInfer)+where+import DDC.Interface.Source+import DDCI.Tetra.State+import DDC.Base.Pretty+import DDC.Source.Tetra.Env+import DDC.Source.Tetra.Lexer+import DDC.Source.Tetra.Parser+import DDC.Source.Tetra.Pretty ()+import DDC.Source.Tetra.Transform.Defix+import DDC.Source.Tetra.Transform.Expand as Expand+import qualified DDC.Core.Lexer as C+import qualified DDC.Base.Parser as BP+++cmdInfer :: State -> Source -> String -> IO ()+cmdInfer _state source str+ = goLex+ where goLex + = let tokens = lexModuleString (nameOfSource source) 1 str+ in goParse tokens++ goParse tokens+ = let context = Context+ { contextTrackedEffects = True+ , contextTrackedClosures = True+ , contextFunctionalEffects = False+ , contextFunctionalClosures = False }++ in case BP.runTokenParser C.describeTok (nameOfSource source)+ (pModule context) tokens of+ Left err -> error $ show err+ Right mm -> goDesugar mm++ goDesugar mm+ = case defix defaultFixTable mm of+ Left err -> putStrLn (renderIndent $ ppr err)+ Right mm' -> goExpand mm'++ goExpand mm+ = do let mm' = Expand.expand Expand.configDefault + primKindEnv primTypeEnv mm+ putStrLn (renderIndent $ ppr mm')+
+ src/ddci-tetra/DDCI/Tetra/Command/Parse.hs view
@@ -0,0 +1,36 @@++module DDCI.Tetra.Command.Parse+ (cmdParse)+where+import DDC.Interface.Source+import DDCI.Tetra.State+import DDC.Base.Pretty+import DDC.Source.Tetra.Lexer+import DDC.Source.Tetra.Parser+import DDC.Source.Tetra.Pretty ()+import qualified DDC.Core.Lexer as C+import qualified DDC.Base.Parser as BP+++cmdParse :: State -> Source -> String -> IO ()+cmdParse _state source str+ = goLex+ where goLex + = let tokens = lexModuleString (nameOfSource source) 1 str+ in goParse tokens++ goParse tokens+ = let context = Context+ { contextTrackedEffects = True+ , contextTrackedClosures = True+ , contextFunctionalEffects = False+ , contextFunctionalClosures = False }++ in case BP.runTokenParser + C.describeTok + (nameOfSource source)+ (pModule context)+ tokens of+ Left err -> error $ show err+ Right mm + -> do putStrLn (renderIndent $ ppr mm)
+ src/ddci-tetra/DDCI/Tetra/Command/Set.hs view
@@ -0,0 +1,73 @@++module DDCI.Tetra.Command.Set+ (cmdSet)+where+import DDCI.Tetra.State+import DDCI.Tetra.Mode+import DDC.Build.Builder+import DDC.Base.Pretty+import Data.Char+import Data.List+import qualified Data.Set as Set+++cmdSet :: State -> String -> IO State++cmdSet state []+ = do putDocLn RenderIndent+ $ vcat [ text "Modes: " + <> text (show $ Set.toList $ stateModes state) ]++ return state++cmdSet state cmd+ | "builder" : name : [] <- words cmd+ = do config <- getDefaultBuilderConfig+ case find (\b -> builderName b == name) (builders config) of+ Nothing+ -> do putStrLn "unknown builder"+ return state++ Just builder+ -> do putStrLn "ok"+ return state { stateBuilder = Just builder }++ | otherwise+ = case parseModeChanges cmd of+ Just changes+ -> do let state' = foldr (uncurry adjustMode) state changes+ putStrLn "ok"+ return state'++ Nothing+ -> do putStrLn "mode parse error"+ return state+++-- | Parse a string of mode changes.+parseModeChanges :: String -> Maybe [(Bool, Mode)]+parseModeChanges str+ = sequence $ map parseModeChange $ words str+++-- | Parse a mode change setting.+-- "Mode" or "+Mode" to enable. "-Mode" to disable.+parseModeChange :: String -> Maybe (Bool, Mode)+parseModeChange str+ = case str of+ ('+' : strMode)+ | Just mode <- readMode strMode+ -> Just (True, mode)+ + ('/' : strMode)+ | Just mode <- readMode strMode+ -> Just (False, mode)++ (c : strMode)+ | isUpper c + , Just mode <- readMode (c : strMode)+ -> Just (True, mode)++ _ -> Nothing++
+ src/ddci-tetra/DDCI/Tetra/Command/ToCore.hs view
@@ -0,0 +1,28 @@+module DDCI.Tetra.Command.ToCore+ (cmdToCore)+where+import DDCI.Tetra.State+import DDC.Interface.Source+import DDC.Driver.Stage+import DDC.Build.Pipeline +import DDC.Base.Pretty+import qualified DDC.Driver.Config as D+++-- Convert Disciple Source Tetra text into Disciple Core Tetra.+cmdToCore :: State -> D.Config -> Source -> String -> IO ()+cmdToCore _state config source str+ = let + pmode = D.prettyModeOfConfig $ D.configPretty config++ pipeLoad+ = pipeText (nameOfSource source) (lineStartOfSource source) str+ $ stageSourceTetraLoad config source+ [ PipeCoreOutput pmode SinkStdout ]++ in do+ errs <- pipeLoad+ case errs of+ [] -> return ()+ es -> putStrLn (renderIndent $ ppr es)+
+ src/ddci-tetra/DDCI/Tetra/Input.hs view
@@ -0,0 +1,34 @@++module DDCI.Tetra.Input+ ( InputState (..)+ , Input (..) + , readInput+ , eatLine)+where+import DDCI.Tetra.State+import DDCI.Tetra.Command+import DDC.Interface.Input+++-- Eating input lines.+eatLine :: State + -> InputState Command + -> String + -> IO (State, InputState Command)++eatLine state inputState chunk+ = do (inputState', mCmdLine) + <- inputLine (stateInterface state) inputState chunk+ + case mCmdLine of+ Nothing + -> return (state, inputState')++ Just (source, Nothing, line)+ -> do state' <- handleCommand state CommandHelp source line+ return (state', inputState')++ Just (source, Just cmd, line)+ -> do state' <- handleCommand state cmd source line+ return (state', inputState') +
+ src/ddci-tetra/DDCI/Tetra/Interface/Args.hs view
@@ -0,0 +1,49 @@++module DDCI.Tetra.Interface.Args+ (runArgs)+where+import DDCI.Tetra.Command.Help+import DDCI.Tetra.Command+import DDCI.Tetra.State+import DDC.Interface.Input+import DDC.Interface.Source+import DDC.Data.ListUtils+import Data.List+++-- | Run in unix command-line mode, reading commands from a list of arguments.+runArgs :: [String] -> IO ()+runArgs args+ = do let state = initState InputInterfaceArgs++ -- If the help command is one of the arguments then just+ -- display the help and don't do anything else.+ if elem "--help" args + then putStr help+ else loop state args++ where + -- No more args, we're done.+ loop _state []+ = do return ()++ loop state (('-':cmdColon) : filePath : rest)+ | isSuffixOf ":" cmdColon+ , Just cmdStr <- takeInit cmdColon+ , Just (cmd, []) <- readCommand (':' : cmdStr)+ = do contents <- readFile filePath+ state' <- handleCommand state cmd (SourceFile filePath) + contents+ loop state' rest++ loop state (('-':cmdStr) : rest)+ | Just (cmd, []) <- readCommand (':' : cmdStr)+ , (argss, more) <- break (isPrefixOf "-") rest+ = do state' <- handleCommand state cmd SourceArgs + (concat $ intersperse " " argss)+ loop state' more++ loop _state xs+ = error $ "Cannot parse arguments: "+ ++ intercalate " " xs+
+ src/ddci-tetra/DDCI/Tetra/Interface/Batch.hs view
@@ -0,0 +1,62 @@++module DDCI.Tetra.Interface.Batch+ (runBatch)+where+import DDCI.Tetra.State+import DDCI.Tetra.Input+import DDCI.Tetra.Command+import DDC.Interface.Input+import Data.List+++-- | Run in batch mode, reading commands from the given string.+runBatch :: FilePath -> String -> IO ()+runBatch filePath str+ = do let state = initState (InputInterfaceBatch filePath)+ + let inputState + = InputState + { inputParseCommand = readCommand+ , inputMode = InputLine+ , inputCommand = Nothing+ , inputLineNumber = 1+ , inputAcc = [] }+++ loop state inputState (lines str)+ where + -- No more lines, we're done.+ -- There might be a command in the buffer though.+ loop state inputState []+ = do eatLine state inputState []+ return ()++ loop state inputState (l:ls)+ -- Echo comment lines back.+ | isPrefixOf "--" l+ = do putStrLn l+ let inputState'+ = inputState + { inputLineNumber = inputLineNumber inputState + 1 }++ loop state inputState' ls++ -- Echo blank lines back if we're between commands.+ | Nothing <- inputCommand inputState+ , null l+ = do putStr "\n"+ let inputState'+ = inputState + { inputLineNumber = inputLineNumber inputState + 1 }++ loop state inputState' ls++ -- Quit the program.+ | isPrefixOf ":quit" l+ = do return ()++ -- Handle a line of input.+ | otherwise+ = do (state', inputState') <- eatLine state inputState l+ loop state' inputState' ls+
+ src/ddci-tetra/DDCI/Tetra/Interface/Interactive.hs view
@@ -0,0 +1,59 @@++module DDCI.Tetra.Interface.Interactive+ (runInteractive)+where+import DDCI.Tetra.Input+import DDCI.Tetra.State+import DDCI.Tetra.Command+import DDC.Interface.Input+import Data.List+import Data.Maybe+import qualified System.Console.Haskeline as HL+import qualified System.Console.Haskeline.IO as HL+++-- | Run an interactive session, reading commands from the console.+runInteractive :: IO ()+runInteractive+ = do putStrLn "DDCi-tetra, version 0.4.1: http://disciple.ouroborus.net."+ putStrLn "Type :help for help."++ -- Setup terminal mode.+ loopInteractive+++-- | The main REPL loop.+loopInteractive :: IO ()+loopInteractive + = do hlState <- HL.initializeInput HL.defaultSettings+ let state = initState InputInterfaceConsole+ + let inputState + = InputState + { inputParseCommand = readCommand+ , inputMode = InputLine+ , inputCommand = Nothing+ , inputLineNumber = 1+ , inputAcc = [] }+ + loop state inputState hlState+ where + loop state inputState hlState + = do -- Read a line from the user and echo it back.+ line <- getInput hlState "> "++ if isPrefixOf ":quit" line+ || isPrefixOf ":q" line+ then return ()+ else do+ (state', inputState')+ <- eatLine state inputState line++ loop state' inputState' hlState+++-- | Get an input line from the console, using given prompt+getInput :: HL.InputState -> String -> IO String+getInput hlState prompt+ = do line <- HL.queryInput hlState (HL.getInputLine prompt)+ return (fromMaybe ":quit" line)
+ src/ddci-tetra/DDCI/Tetra/Mode.hs view
@@ -0,0 +1,50 @@++module DDCI.Tetra.Mode+ ( Mode (..)+ , readMode)+where+++-- | ddci-tetra mode flags.+data Mode+ -- | Dump all intermediate versions of the code during compilation.+ = Dump++ -- Pretty Printer Config ------+ -- There is one mode here for each field in Driver.Config.ConfigPretty++ -- | Use 'letcase' when pretty printing core modules.+ | PrettyUseLetCase++ -- | Display types on primitive variables.+ | PrettyVarTypes++ -- | Display types on primitive constructors.+ | PrettyConTypes++ -- | Suppress import lists when printing modules.+ | SuppressImports++ -- | Suppress export lists when printing modules.+ | SuppressExports++ -- | Suppress type annotations on let-bindings.+ | SuppressLetTypes++ deriving (Eq, Ord, Show)+++-- Parse a mode from a string.+readMode :: String -> Maybe Mode+readMode str+ = case str of+ "Dump" -> Just Dump+ "PrettyUseLetCase" -> Just PrettyUseLetCase+ "PrettyVarTypes" -> Just PrettyVarTypes+ "PrettyConTypes" -> Just PrettyConTypes+ "SuppressImports" -> Just SuppressImports+ "SuppressExports" -> Just SuppressExports+ "SuppressLetTypes" -> Just SuppressLetTypes+ _ -> Nothing++
+ src/ddci-tetra/DDCI/Tetra/Output.hs view
@@ -0,0 +1,41 @@++module DDCI.Tetra.Output+ ( outDoc, outDocLn+ , outStr, outStrLn+ , chatStrLn)+where+import DDCI.Tetra.State+import DDC.Interface.Input+import DDC.Base.Pretty+++-- | Output a document to the console.+outDoc :: State -> Doc -> IO ()+outDoc _state doc+ = putDocLn RenderIndent doc+++outDocLn :: State -> Doc -> IO ()+outDocLn _state doc+ = putDocLn RenderIndent doc+++-- | Output a string to the console.+outStr :: State -> String -> IO ()+outStr _state str+ = putStr str+++outStrLn :: State -> String -> IO ()+outStrLn _state str+ = putStrLn str+++-- | Output chatty 'ok' type responses.+-- These are only displayed in the Interactive and Batch interfaces.+chatStrLn :: State -> String -> IO ()+chatStrLn state str+ = case stateInterface state of+ InputInterfaceConsole -> putStrLn str+ InputInterfaceBatch _ -> putStrLn str+ _ -> return ()
+ src/ddci-tetra/DDCI/Tetra/State.hs view
@@ -0,0 +1,127 @@++module DDCI.Tetra.State+ ( State (..)+ , initState + , adjustMode++ -- * Driver Config+ , getDriverConfigOfState+ , getDefaultBuilderConfig)+where+import DDCI.Tetra.Mode+import DDC.Code.Config+import DDC.Interface.Input+import DDC.Build.Builder+import System.FilePath+import Data.Set (Set)+import qualified DDC.Core.Simplifier as S+import qualified DDC.Driver.Stage as D+import qualified DDC.Driver.Config as D+import qualified DDC.Core.Salt.Runtime as Runtime+import qualified Data.Set as Set+++-------------------------------------------------------------------------------+data State+ = State+ { -- ddci interface state+ stateInterface :: InputInterface ++ -- ddci mode flags.+ , stateModes :: Set Mode ++ -- Force the builder to this one, which sets the address width etc.+ -- If `Nothing` then query the host system for the default builder.+ , stateBuilder :: Maybe Builder }+++-- | Initial ddci-tetra state.+initState :: InputInterface -> State+initState interface+ = State+ { stateInterface = interface + , stateModes = Set.empty + , stateBuilder = Nothing }+++-- | Adjust a mode setting in the state.+adjustMode + :: Bool -- ^ Whether to enable or disable the mode. + -> Mode -- ^ Mode to adjust.+ -> State -> State++adjustMode True mode state+ = state { stateModes = Set.insert mode (stateModes state) }++adjustMode False mode state+ = state { stateModes = Set.delete mode (stateModes state) }+++-- Driver Config --------------------------------------------------------------+-- | Slurp out the relevant parts of the ddci-tetra state into a driver config.+-- The driver config controls how the compiler treats core files.+--+getDriverConfigOfState :: State -> IO D.Config+getDriverConfigOfState state+ = do builder <- getActiveBuilder state+ return + $ D.Config+ { D.configDump = Set.member Dump (stateModes state)+ , D.configInferTypes = False+ , D.configViaBackend = D.ViaLLVM++ -- ISSUE #300: Allow the default heap size to be set when+ -- compiling the program.+ , D.configRuntime+ = Runtime.Config+ { Runtime.configHeapSize = 65536 }++ , D.configOutputFile = Nothing+ , D.configOutputDir = Nothing+ , D.configSimplLite = S.Trans S.Id+ , D.configSimplSalt = S.Trans S.Id+ , D.configBuilder = builder+ , D.configPretty = configPretty+ , D.configSuppressHashImports = False+ , D.configKeepLlvmFiles = False+ , D.configKeepSeaFiles = False+ , D.configKeepAsmFiles = False ++ , D.configTaintAvoidTypeChecks = False+ }++ where modes = stateModes state+ configPretty + = D.ConfigPretty+ { D.configPrettyVarTypes = Set.member PrettyVarTypes modes+ , D.configPrettyConTypes = Set.member PrettyConTypes modes+ , D.configPrettyUseLetCase = Set.member PrettyUseLetCase modes + , D.configPrettySuppressImports = Set.member SuppressImports modes+ , D.configPrettySuppressExports = Set.member SuppressExports modes+ , D.configPrettySuppressLetTypes = Set.member SuppressLetTypes modes }+++-- | Holds platform independent builder info.+getDefaultBuilderConfig :: IO BuilderConfig+getDefaultBuilderConfig+ = do baseLibraryPath <- locateBaseLibrary+ return $ BuilderConfig+ { builderConfigBaseSrcDir = baseLibraryPath+ , builderConfigBaseLibDir = baseLibraryPath </> "build" }+++-- | Get the active builder.+-- If one is set explicitly in the state then use that, +-- otherwise query the host system to determine the builder.+-- If that fails as well then 'error'.+getActiveBuilder :: State -> IO Builder +getActiveBuilder state + = case stateBuilder state of+ Just builder -> return builder+ Nothing + -> do config <- getDefaultBuilderConfig + mBuilder <- determineDefaultBuilder config+ case mBuilder of+ Nothing -> error "ddci-tetra.getActiveBuilder: unrecognised host platform"+ Just builder -> return builder+
+ src/ddci-tetra/Main.hs view
@@ -0,0 +1,37 @@++-- | Interactive interface to DDC for Tetra programs.+-- This also accepts interpreter commands as arguments on the command-line.+-- If you want a more unixy inferface then use the ddc-main interface instead.+module Main where+import DDCI.Tetra.Command.Help+import DDCI.Tetra.Interface.Args+import DDCI.Tetra.Interface.Batch+import DDCI.Tetra.Interface.Interactive+import System.Environment+import Data.List+++main :: IO ()+main + = do args <- getArgs+ case args of+ [] -> runInteractive++ -- Display the help.+ ["--help"]+ -> putStr help++ -- Run commands from a file in batch mode.+ ["--batch", filePath]+ -> do file <- readFile filePath+ runBatch filePath file++ -- Run a Disciple-Core-Exchange file.+ [filePath]+ | isSuffixOf ".dsx" filePath+ -> do file <- readFile filePath+ runBatch filePath file++ + _ -> runArgs args+