ddc-tools (empty) → 0.3.1.1

raw patch · 27 files changed

+3186/−0 lines, 27 filesdep +basedep +containersdep +ddc-basebuild-type:Customsetup-changed

Dependencies added: base, containers, ddc-base, ddc-build, ddc-code, ddc-core, ddc-core-eval, ddc-core-llvm, ddc-core-salt, ddc-core-simpl, ddc-driver, directory, filepath, haskeline, haskell-src-exts, mtl, process, transformers

Files

• LICENSE +30/−0
• Setup.hs +37/−0
• ddc-tools.cabal +130/−0
• src/ddc-check/Config.hs +87/−0
• src/ddc-check/Main.hs +56/−0
• src/ddc-main/DDC/Main/Args.hs +207/−0
• src/ddc-main/DDC/Main/Config.hs +168/−0
• src/ddc-main/DDC/Main/Help.hs +87/−0
• src/ddc-main/DDC/Main/OptLevels.hs +188/−0
• src/ddc-main/Main.hs +198/−0
• src/ddci-core/DDCI/Core/Command.hs +265/−0
• src/ddci-core/DDCI/Core/Command/Eval.hs +244/−0
• src/ddci-core/DDCI/Core/Command/Help.hs +112/−0
• src/ddci-core/DDCI/Core/Command/Set.hs +164/−0
• src/ddci-core/DDCI/Core/Command/Trans.hs +170/−0
• src/ddci-core/DDCI/Core/Command/TransInteract.hs +116/−0
• src/ddci-core/DDCI/Core/Command/With.hs +85/−0
• src/ddci-core/DDCI/Core/Input.hs +161/−0
• src/ddci-core/DDCI/Core/Interface/Args.hs +47/−0
• src/ddci-core/DDCI/Core/Interface/Batch.hs +51/−0
• src/ddci-core/DDCI/Core/Interface/Interactive.hs +58/−0
• src/ddci-core/DDCI/Core/Mode.hs +46/−0
• src/ddci-core/DDCI/Core/Output.hs +49/−0
• src/ddci-core/DDCI/Core/Rewrite.hs +100/−0
• src/ddci-core/DDCI/Core/State.hs +190/−0
• src/ddci-core/DDCI/Core/Stats/Trace.hs +82/−0
• src/ddci-core/Main.hs +58/−0

@@ -0,0 +1,30 @@+--------------------------------------------------------------------------------+The Disciplined Disciple Compiler License (MIT style)++Copyrite (K) 2007-2012 The Disciplined Disciple Compiler Strike Force+All rights reversed.++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++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+  

@@ -0,0 +1,37 @@+import Distribution.Simple+import Distribution.Simple.Setup+import Distribution.Simple.LocalBuildInfo+import Distribution.PackageDescription+import System.FilePath+import System.Exit+import System.Cmd++main    = defaultMainWithHooks hooks++hooks   = simpleUserHooks+        { postInst      = hookPostInstall }+++-- Build the base library from the ddc-code package after we've installed ddc.+hookPostInstall +        :: Args+        -> InstallFlags+        -> PackageDescription+        -> LocalBuildInfo+        -> IO ()++hookPostInstall _args _flags desc buildInfo+ = do   putStrLn "Building base libraries..."++        -- Find out where Cabal has put the DDC executable.+        let installDirs = absoluteInstallDirs desc buildInfo NoCopyDest+        let ddcExe      =   (bindir $ installDirs)+                        </> (fromPathTemplate $ progPrefix buildInfo)+                        ++  "ddc" +                        <.> (fromPathTemplate $ progSuffix buildInfo)++        -- Run the basebuild command, which builds the library.+        code            <- system $ ddcExe ++ " -basebuild -O"+        case code of+         ExitFailure _  -> error "Failed!"+         ExitSuccess    -> return ()

@@ -0,0 +1,130 @@+Name:           ddc-tools+Version:        0.3.1.1+License:        MIT+License-file:   LICENSE+Author:         The Disciplined Disciple Compiler Strike Force+Maintainer:     Ben Lippmeier <benl@ouroborus.net>+Build-Type:     Custom+Cabal-Version:  >=1.6+Stability:      experimental+Category:       Compilers/Interpreters+Homepage:       http://disciple.ouroborus.net+Bug-reports:    disciple@ouroborus.net+Synopsis:       Disciplined Disciple Compiler command line tools.+Description:    Disciplined Disciple Compiler command line tools.++Executable ddc-check+    hs-source-dirs:+        src/ddc-check++    Build-depends:+        base            == 4.6.*,+        ddc-core        == 0.3.1.*++    Main-is:+        Main.hs++    Other-modules: +        Config++    Extensions:+        PatternGuards++Executable ddc+    hs-source-dirs:+        src/ddc-main++    Build-depends:+        base            == 4.6.*,+        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.1.*,+        ddc-core        == 0.3.1.*,+        ddc-core-eval   == 0.3.1.*,+        ddc-core-simpl  == 0.3.1.*,+        ddc-core-salt   == 0.3.1.*,+        ddc-core-llvm   == 0.3.1.*,+        ddc-build       == 0.3.1.*,+        ddc-driver      == 0.3.1.*,+        ddc-code        == 0.3.1.*++    Main-is:+        Main.hs++    Other-modules:+        DDC.Main.Args+        DDC.Main.Config+        DDC.Main.Help+        DDC.Main.OptLevels++    Extensions:+        PatternGuards++Executable ddci-core+    hs-source-dirs:+        src/ddci-core++    Build-depends:+        base            == 4.6.*,+        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.1.*,+        ddc-core        == 0.3.1.*,+        ddc-core-eval   == 0.3.1.*,+        ddc-core-simpl  == 0.3.1.*,+        ddc-core-salt   == 0.3.1.*,+        ddc-core-llvm   == 0.3.1.*,+        ddc-build       == 0.3.1.*,+        ddc-driver      == 0.3.1.*++    Main-is:+        Main.hs+  +    Other-modules:+        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+        DDCI.Core.Output+        DDCI.Core.Rewrite+        DDCI.Core.State++    Extensions:+        DoAndIfThenElse+        PatternGuards+        ParallelListComp+        FlexibleContexts+        ExistentialQuantification+        MultiParamTypeClasses+        FunctionalDependencies+        TypeSynonymInstances+        FlexibleInstances+        StandaloneDeriving+        KindSignatures+        RankNTypes+        ScopedTypeVariables++    ghc-options:+        -Wall+        -fno-warn-missing-signatures+        -fno-warn-unused-do-bind

@@ -0,0 +1,87 @@++module Config where+import DDC.Build.Language+import qualified DDC.Build.Language.Lite        as Lite+import System.FilePath+import System.Exit+++-- | DDC type checker command line interface config.+data Config+        = Config+        { -- | Source file to load, or Nothing to read source from stdin.+          configSourceFile      :: Maybe String++          -- | Language fragment to check.+        , configLanguage        :: Language ++          -- | If true then don't print checked source file to stdout.+        , configQuiet           :: Bool }+++-- | Default command line configuration.+defaultConfig :: Config+defaultConfig+        = Config+        { configSourceFile      = Nothing+        , configLanguage        = Language Lite.bundle+        , configQuiet           = False }+++-- | Parse command line arguments.+parseArgs :: [String] -> Config -> IO Config+parseArgs [] config     +        = return config++parseArgs args@(arg : more) config+        -- Display usage help.+        | arg == "-help" || arg == "--help"+        = do    putStr usage+                exitWith ExitSuccess++        -- Set quiet mode.+        | arg == "-quiet"+        = do    parseArgs more $ config { configQuiet   = True }++        -- Set the language fragment manually.+        | "-language" : lang : rest     <- args+        = case lookup lang languages of+           Just l  -> parseArgs rest $ config { configLanguage = l }+           Nothing -> error $ unlines+                        [ "unknown language " ++ lang+                        , "  options are: " ++ (show $ map fst languages) ]++        -- Try to guess the language fragment based on the file name extension.+        | fileName : [] <- args+        , extension     <- takeExtension fileName+        = case languageOfExtension extension of+           Just language+            -> return+            $  config { configSourceFile   = Just fileName+                      , configLanguage     = language }++           Nothing +            ->  error $ "unrecognised extension " ++ show extension++        | otherwise+        = do    putStr usage+                error  $ "unknown argument " ++ show arg+++-- | Command line usage information.+usage :: String+usage +        = unlines+        [ "Disciplined Disciple Compiler type checker."+        , ""+        , " Usage:"+        , "  ddc-check [flags]           Read input from stdin."+        , "  ddc-check [flags] <file>    Read input from file."+        , ""+        , " Flags:"+        , "  -help                       Display this help."+        , "  -quiet                      Don't print checked module to stdout."+        , "  -language <fragment>        Set the language fragment.  (default Lite)"+        , "     fragment one of " ++ (show $ map fst languages)+        , "" ]+

@@ -0,0 +1,56 @@++-- | Command-line interface to the DDC type checker, which is also +--   possible via the plain 'ddc' command.+--+--   This code is provided as an example of how to drive the DDC+--   compiler framework.+--+module Main where+import Config+import DDC.Build.Language+import DDC.Build.Pipeline+import DDC.Core.Pretty+import System.IO+import System.Environment+++main :: IO ()+main + = do   args    <- getArgs+        config  <- parseArgs args defaultConfig++        -- Get the source text.+        --  either from a file or stdin+        (source, sourceName)+          <- case configSourceFile config of+                Just fileName   +                 -> do  src     <- readFile fileName+                        return  (src, fileName)++                Nothing +                 -> do  src     <- hGetContents stdin+                        return  (src, "<stdin>")++        -- Check with the configured language fragment.+        runLanguage config source sourceName (configLanguage config)+++runLanguage config source sourceName language+ | Language bundle      <- language+ , fragment             <- bundleFragment bundle+ = do   +        -- In quiet mode just drop the checked module on the floor.+        let sink+                | configQuiet config    = SinkDiscard+                | otherwise             = SinkStdout++        -- Loading the core code automatically check it+        -- against the provided fragment.+        errs    <- pipeText sourceName 1 source+                $  PipeTextLoadCore  fragment+                [  PipeCoreOutput    sink ]++        -- If the pipeline died with errors, +        --  then print them.+        mapM_ (putStrLn . renderIndent . ppr) errs+

@@ -0,0 +1,207 @@++-- | Parsing of command line configuation arguments.+module DDC.Main.Args +        ( parseArgs+        , help)+where+import DDC.Main.Config+import DDC.Main.Help+import Data.Char+++-- | Parse command line arguments.+parseArgs :: [String] -> Config -> IO Config+parseArgs [] config+        = return config++parseArgs args config+        -- General ------------------------------+        | flag : _              <- args+        , elem flag ["-version", "--version"]+        = return+        $ config { configMode   = ModeVersion }++        | flag : _              <- args+        , elem flag ["-h", "-help", "--help"]+        = return +        $ config { configMode   = ModeHelp }++        | flag : file : rest    <- args+        , elem flag ["-make", "--make" ]+        = parseArgs rest+        $ setMode config $ ModeMake file++        | "-basebuild" : rest   <- args+        = parseArgs rest+        $ setMode config $ ModeBaseBuild++        -- Compilation --------------------------+        | flag : file : rest <- args+        , elem flag ["-c", "-compile", "--compile"]+        = parseArgs rest+        $ setMode config $ ModeCompile file++        | "-basedir" : path : rest <- args+        = parseArgs rest+        $ config { configBaseDir = path }++        | flag         : file : rest     <- args+        , elem flag    ["-o", "-output"]+        = parseArgs rest+        $ config { configOutputFile = Just file }++        | "-fvia-c"    : rest      <- args+        = parseArgs rest+        $ config { configViaBackend = ViaC }++        | "-fvia-llvm" : rest   <- args+        = parseArgs rest+        $ config { configViaBackend = ViaLLVM }++        | flag : dir : rest     <- args+        , elem flag    ["-output-dir"]+        = parseArgs rest+        $ config { configOutputDir  = Just dir }++        -- Optimisation -------------------------+        | "-O0" : rest          <- args+        = parseArgs rest+        $ config { configOptLevelLite   = OptLevel0 +                 , configOptLevelSalt   = OptLevel0 }++        | flag : rest          <- args+        , elem flag     [ "-O", "-O1" ]+        = parseArgs rest+        $ config { configOptLevelLite   = OptLevel1+                 , configOptLevelSalt   = OptLevel1 }++        -- Intermediates ------------------------+        | flag : rest   <- args+        , elem flag ["-keep-ll-files", "-keep-llvm-files" ]+        = parseArgs rest+        $ config { configKeepLlvmFiles = True }++        | flag : rest      <- args+        , elem flag ["-keep-c-files",  "-keep-sea-files" ]+        = parseArgs rest+        $ config { configKeepSeaFiles = True }++        | flag : rest      <- args+        , elem flag ["-keep-s-files", "-keep-asm-files" ]+        = parseArgs rest+        $ config { configKeepAsmFiles = True }++        -- Runtime ------------------------------+        | "-run-heap" : bytes : rest    <- args+        , all isDigit bytes+        = parseArgs rest+        $ config  { configRuntimeHeapSize = read bytes }++        -- Checking -----------------------------+        | "-check" : file : rest    <- args+        = parseArgs rest+        $ config { configMode  = ModeCheck file }++        -- Transformation -----------------------+        | "-load"   : file : rest <- args+        = parseArgs rest+        $ setMode config $ ModeLoad file++        | "-trans" : trans : rest   <- args+        = parseArgs rest+        $ config { configTrans = Just trans }++        | "-with"  : file  : rest   <- args+        = parseArgs rest+        $ config { configWith  = configWith config ++ [file] }++        -- Conversion ---------------------------+        | "-to-salt" : file : rest  <- args+        = parseArgs rest+        $ setMode config $ ModeToSalt file++        | "-to-c"    : file : rest  <- args+        = parseArgs rest+        $ setMode config $ ModeToC file++        | "-to-llvm" : file : rest  <- args+        = parseArgs rest+        $ setMode config $ ModeToLLVM file++        -- Debugging ----------------------------+        | "-dump"   : rest        <- args+        = parseArgs rest+        $ config { configDump   = True }++        | "-ast"   : file : rest  <- args+        = parseArgs rest+        $ setMode config $ ModeAST file++        | "-print-builder" : rest <- args+        = parseArgs rest+        $ setMode config ModePrintBuilder++        | "-print-basedir" : rest <- args+        = parseArgs rest+        $ setMode config ModePrintBaseDir++        -- If we get some other argument starting with '-' then assume it's+        -- a flag we don't support.+        | arg : _               <- args+        , '-' : _               <- arg+        = error $ "Cannot parse arguments " ++ show args++        -- Otherwise, treat the argument as a source file to make.+        | arg : rest            <- args+        = parseArgs rest+        $ setMode config (ModeMake arg)++        | otherwise+        = error $ "Cannot parse arguments " ++ show args+++-- | Set the major mode of DDC.+-- +--   We can't have two major modes like '-make' and '-compile' set at the same time.+--   If this happens then `error`.+setMode :: Config -> Mode -> Config+setMode config newMode+ | ModeMake{}    <- configMode config+ , ModeMake{}    <- newMode+ = error "Multi-module compilation is not supported yet."++ | ModeCompile{} <- configMode config+ , ModeCompile{} <- newMode+ = error "Multi-module compilation is not supported yet."++ | otherwise+ = case flagOfMode newMode of+    Nothing     +     -> error "DDC.Main.Args.setMode: not setting mode to ModeNone"++    Just newFlag+     -> case flagOfMode $ configMode config of+         Nothing        -> config { configMode = newMode }+         Just oldFlag   -> error $ "Cannot use " ++ newFlag ++ " with " ++ oldFlag+++-- | Get the flag used to set DDC to this mode.+flagOfMode :: Mode -> Maybe String+flagOfMode mode+ = case mode of+        ModeNone{}              -> Nothing+        ModeVersion{}           -> Just "-version"+        ModeHelp{}              -> Just "-help"+        ModeCheck{}             -> Just "-check"+        ModeLoad{}              -> Just "-load"+        ModeCompile{}           -> Just "-compile"+        ModeMake{}              -> Just "-make"+        ModeAST{}               -> Just "-ast"+        ModeToSalt{}            -> Just "-to-salt"+        ModeToC{}               -> Just "-to-c"+        ModeToLLVM{}            -> Just "-to-llvm"+        ModeBaseBuild{}         -> Just "-basebuild"+        ModePrintBuilder{}      -> Just "-print-builder"+        ModePrintBaseDir{}      -> Just "-print-basedir"++

@@ -0,0 +1,168 @@+{-# LANGUAGE CPP #-}++-- | Define the command line configuation arguments.+module DDC.Main.Config+        ( Mode         (..)+        , OptLevel     (..)+        , D.ViaBackend (..)+        , Config       (..)++        , getDefaultConfig+        , defaultBuilderConfig)+where+import DDC.Code.Config+import DDC.Build.Builder+import System.FilePath+import qualified DDC.Driver.Stage               as D+++-- | The main command that we're running.+data Mode+        -- | Don't do anything+        = ModeNone++        -- | Display the version string.+        | ModeVersion++        -- | Display the help page.+        | ModeHelp++        -- | Parse and type-check a module.+        | ModeCheck     FilePath++        -- | Parse, type-check and transform a module.+        | ModeLoad      FilePath++        -- | Compile a .dcl or .dce into an object file.+        | ModeCompile   FilePath++        -- | 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++        -- | Convert a module to C.+        | ModeToC       FilePath++        -- | Convert a module to LLVM.+        | ModeToLLVM    FilePath++        -- | Build the base libraries and runtime.+        | ModeBaseBuild++        -- | Print the builder info for this platform.+        | ModePrintBuilder++        -- | Print where the runtime and base libraries are intalled.+        | ModePrintBaseDir+        deriving (Eq, Show)+++data OptLevel+        -- | Don't do any optimisations.+        = OptLevel0++        -- | Do standard optimisations.+        | OptLevel1+        deriving Show+++-- | DDC config.+data Config+        = Config+        { -- | The main compilation mode.+          configMode            :: Mode ++          -- Compilation --------------+          -- | Directory holding the runtime and base library code.+        , configBaseDir         :: FilePath++          -- | Redirect output to this file.+        , configOutputFile      :: Maybe FilePath++          -- | Redirect output to this directory.+        , configOutputDir       :: Maybe FilePath ++          -- | What backend to use for compilation+        , configViaBackend      :: D.ViaBackend++          -- Optimisation -------------+          -- | What optimisation levels to use+        , configOptLevelLite    :: OptLevel+        , configOptLevelSalt    :: OptLevel++          -- | Paths to modules to use as inliner templates.+        , configWithLite        :: [FilePath]+        , configWithSalt        :: [FilePath]++          -- Runtime -------------------+          -- | Default size of heap for compiled program.+        , configRuntimeHeapSize :: Integer++          -- Intermediates -------------+        , configKeepLlvmFiles   :: Bool+        , configKeepSeaFiles    :: Bool+        , configKeepAsmFiles    :: Bool++          -- Transformation ------------+          -- | String containing the transform definition to apply with+          --   the -load command. We can't parse this definition until+          --   we know what language we're dealing with.+        , configTrans           :: Maybe String++          -- | Other modules to use for inliner templates.+        , configWith            :: [FilePath]++          -- Debugging -----------------+          -- | Dump intermediate representations.+        , configDump            :: Bool }+        deriving (Show)+++-- | Default configuation.+getDefaultConfig :: IO Config+getDefaultConfig+ = do   baseDir <- locateBaseLibrary++        return $ Config+          { configMode            = ModeNone + +            -- Compilation --------------+          , configBaseDir         = baseDir+          , configOutputFile      = Nothing+          , configOutputDir       = Nothing+          , configViaBackend      = D.ViaLLVM+ +            -- Optimisation -------------+          , configOptLevelLite    = OptLevel0+          , configOptLevelSalt    = OptLevel0+          , configWithLite        = []+          , configWithSalt        = []+ +            -- Runtime ------------------+          , configRuntimeHeapSize = 65536+ +            -- Intermediates ------------+          , configKeepLlvmFiles   = False+          , configKeepSeaFiles    = False+          , configKeepAsmFiles    = False+ +            -- Transformation -----------+          , configTrans           = Nothing+          , configWith            = []+ +            -- Debugging ----------------+         , configDump            = False }+++-- | Get the builder configuation from the ddc configuration.+defaultBuilderConfig :: Config -> BuilderConfig+defaultBuilderConfig config+        = BuilderConfig+        { builderConfigBaseSrcDir = configBaseDir config +        , builderConfigBaseLibDir = configBaseDir config </> "build" }+

@@ -0,0 +1,87 @@++module DDC.Main.Help where++-- | The version identifier string.+version :: String+version = "The Disciplined Disciple Compiler, version 0.3.0"+++-- | What to print when we have no input files.+hello :: String+hello   = unlines+        [ "ddc: no input files"+        , "For usage information, try the -help option." ]+++-- | The command-line help page.+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."+        , ""+        , " -o, -output   FILE     Redirect output to this file."+        , "     -output-dir DIR    Redirect output to this directory."+        , ""+        , "     -fvia-llvm         Compile via the LLVM backend  (default)"+        , "     -fvia-c            Compile via the C backend."+        , ""+        , "     -keep-ll-files     Keep intermediate .ll files."+        , "     -keep-c-files      Keep intermediate .c files."+        , "     -keep-s-files      Keep intermediate .s files."+        , ""+        , "Optimisation:"+        , "     -O0                No optimisations.             (default)"+        , " -O, -O1                Do standard optimisations."+        , ""+        , "Runtime for compiled program:"+        , "     -run-heap BYTES    Size of fixed heap            (65536)"+        , ""+        , "Checking:"+        , "     -check    FILE     Parse and type check a core module."+        , ""+        , "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."+        , ""+        , "Debugging:"+        , "     -dump              Dump intermediate representations."+        , "     -ast      FILE     Pretty print the AST of a module."+        , ""+        , "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."+        , ""+        , "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."+        , ""+        , "    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." ]++        

@@ -0,0 +1,188 @@++-- | Define the default optimisation levels.+module DDC.Main.OptLevels +        ( getSimplLiteOfConfig+        , getSimplSaltOfConfig)+where+import DDC.Main.Config+import DDC.Driver.Command.Load+import DDC.Driver.Command.RewriteRules+import DDC.Build.Builder+import DDC.Build.Platform+import DDC.Core.Module+import DDC.Core.Transform.Inline+import DDC.Core.Transform.Namify+import DDC.Core.Transform.Reannotate+import DDC.Core.Simplifier                      (Simplifier)+import System.FilePath+import Control.Monad+import Data.Monoid+import Data.Maybe+import qualified DDC.Core.Simplifier            as S+import qualified DDC.Core.Simplifier.Recipe     as S+import qualified DDC.Core.Lite                  as Lite+import qualified DDC.Core.Salt                  as Salt+import qualified DDC.Build.Language.Salt        as Salt+import qualified DDC.Build.Language.Lite        as Lite+import qualified Data.Map                       as Map+import qualified Data.Set                       as Set+++-- | Get the simplifier for Lite code from the config.+--   This also reads up all the modules we use for inliner templates.+--+--   We don't want to delay this until all arguments are parsed, +--   because the simplifier spec also contains the list of modules used+--   as inliner templates, so we need to wait until they're all specified.+--+getSimplLiteOfConfig +        :: Config -> Builder +        -> IO (Simplifier Int () Lite.Name)++getSimplLiteOfConfig config builder+ = case configOptLevelLite config of+        OptLevel0       -> opt0_lite config+        OptLevel1       -> opt1_lite config builder+++-- | Get the simplifier for Salt code from the config.+--+getSimplSaltOfConfig +        :: Config -> Builder+        -> IO (Simplifier Int () Salt.Name)++getSimplSaltOfConfig config builder+ = case configOptLevelSalt config of+        OptLevel0       -> opt0_salt config+        OptLevel1       -> opt1_salt config builder+++-- Level 0 --------------------------------------------------------------------+-- This just passes the code through unharmed.++-- | Level 0 optimiser for Core Lite code.+opt0_lite :: Config -> IO (Simplifier Int () Lite.Name)+opt0_lite _+        = return $ S.Trans S.Id+++-- | Level 0 optimiser for Core Salt code.+opt0_salt :: Config -> IO (Simplifier Int () Salt.Name)+opt0_salt _+        = return $ S.Trans S.Id+++-- Level 1 --------------------------------------------------------------------+-- Do full optimsiations.++-- | Level 1 optimiser for Core Lite code.+opt1_lite +        :: Config -> Builder+        -> IO (Simplifier Int () Lite.Name)++opt1_lite config _builder+ = do+        -- Auto-inline basic numeric code.+        let inlineModulePaths+                =  [ configBaseDir config </> "lite/base/Data/Numeric/Int.dcl"+                   , configBaseDir config </> "lite/base/Data/Numeric/Nat.dcl" ]+                ++ (configWithLite config)++        -- Load all the modules that we're using for inliner templates.+        --  If any of these don't load then the 'cmdReadModule' function +        --  will display the errors.+        minlineModules+                <- liftM sequence+                $  mapM (cmdReadModule Lite.fragment)+                        inlineModulePaths++        let inlineModules+                = map (reannotate (const ()))+                $ fromMaybe (error "Imported modules do not parse.")+                            minlineModules++        let inlineSpec+                = Map.fromList+                [ (ModuleName ["Int"], InlineSpecAll (ModuleName ["Int"]) Set.empty)+                , (ModuleName ["Nat"], InlineSpecAll (ModuleName ["Nat"]) Set.empty) ]++        -- Optionally load the rewrite rules for each 'with' module+        rules <- mapM (\(m,file) -> cmdTryReadRules Lite.fragment (file ++ ".rules") m)+              $  inlineModules `zip` inlineModulePaths++        let rules' = concat rules++        -- Simplifier to convert to a-normal form.+        let normalizeLite+                = S.anormalize+                        (makeNamifier Lite.freshT)      +                        (makeNamifier Lite.freshX)+++        -- Perform rewrites before inlining+        return  $  (S.Trans $ S.Rewrite rules')+                <> (S.Trans $ S.Inline+                            $ lookupTemplateFromModules inlineSpec inlineModules)+                <> S.Fix 5 (S.beta +                                <> S.bubble      <> S.flatten +                                <> normalizeLite <> S.forward+                                <> (S.Trans $ S.Rewrite rules'))+++-- | Level 1 optimiser for Core Salt code.+opt1_salt +        :: Config -> Builder+        -> IO (Simplifier Int () Salt.Name)++opt1_salt config builder+ = do   +        -- Auto-inline the low-level code from the runtime system+        --   that constructs and destructs objects.+        let targetWidth+                = archPointerWidth $ platformArch $ buildTarget builder++        -- The runtime system code comes in different versions, +        --  depending on the pointer width of the target architecture.+        let inlineModulePaths+                =  [ configBaseDir config +                        </> "salt/runtime" ++ show targetWidth </> "Object.dcs"]+                ++ configWithSalt config++        -- Load all the modues that we're using for inliner templates.+        --  If any of these don't load then the 'cmdReadModule' function +        --  will display the errors.+        minlineModules+                <- liftM sequence+                $  mapM (cmdReadModule Salt.fragment)+                        inlineModulePaths++        let inlineModules+                = map (reannotate (const ()))+                $ fromMaybe (error "Imported modules do not parse.")+                            minlineModules++        let inlineSpec+                = Map.fromList+                [ (ModuleName ["Object"], InlineSpecAll (ModuleName ["Int"]) Set.empty) ]++        -- Optionally load the rewrite rules for each 'with' module+        rules <- mapM (\(m,file) -> cmdTryReadRules Salt.fragment (file ++ ".rules") m)+              $  inlineModules `zip` inlineModulePaths+        let rules' = concat rules+++        -- Simplifier to convert to a-normal form.+        let normalizeSalt+                = S.anormalize+                        (makeNamifier Salt.freshT)      +                        (makeNamifier Salt.freshX)+        +        -- Perform rewrites before inlining+        return  $  (S.Trans $ S.Rewrite rules')+                <> (S.Trans $ S.Inline +                            $ lookupTemplateFromModules inlineSpec inlineModules)+                <> S.Fix 5 (S.beta +                                <> S.bubble      <> S.flatten +                                <> normalizeSalt <> S.forward+                                <> (S.Trans $ S.Rewrite rules'))+

@@ -0,0 +1,198 @@++-- | Unix-style command line interface to DDC.+--    This interface exports commands that work on whole modules at a time,+--    and does unix-style command line argument parsing.+--+import DDC.Main.Config+import DDC.Main.Help+import DDC.Main.Args+import DDC.Main.OptLevels+import DDC.Driver.Command.Load+import DDC.Driver.Command.Check+import DDC.Driver.Command.Compile+import DDC.Driver.Command.Make+import DDC.Driver.Command.Ast+import DDC.Driver.Command.BaseBuild+import DDC.Driver.Command.ToSalt+import DDC.Driver.Command.ToC+import DDC.Driver.Command.ToLlvm+import DDC.Driver.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+++main :: IO ()+main+ = do   args    <- getArgs++        -- Get the default configuration.+        --  This contains static information such as where the code+        --  for the base libraries and runtime system is installed.+        config0 <- getDefaultConfig++        -- Update the static config with dynamic config read from+        --   the command-line arguments.+        config  <- parseArgs args config0++        -- Run the main compiler.+        run config+++run :: Config -> IO ()+run config+ = case configMode config of+        -- We didn't get any arguments on the command line.+        ModeNone+         ->     putStr hello++        -- Display the version string.+        ModeVersion+         ->     putStrLn version++        -- Display the help page.+        ModeHelp+         ->     putStrLn help++        -- 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++                          Right _+                           -> return ()+++        -- Parse, type check and transform a module.+        ModeLoad filePath+         ->     runError $ cmdLoadFromFile +                                (configTrans config) +                                (configWith config) +                                filePath++        -- Compile a module to object code.+        ModeCompile filePath+         -> do  dconfig  <- getDriverConfig config+                runError $ cmdCompile dconfig filePath+++        -- Compile a module into an executable.+        ModeMake filePath+         -> do  dconfig  <- getDriverConfig config+                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+                str             <- readFile filePath+                runError $ cmdToSalt dconfig language (SourceFile filePath) str+++        -- Convert a module to C+        ModeToC filePath+         -> do  language        <- languageFromFilePath filePath+                dconfig         <- getDriverConfig config+                str             <- readFile filePath+                runError $ cmdToC dconfig language (SourceFile filePath) str+++        -- Convert a module to LLVM+        ModeToLLVM filePath+         -> do  language        <- languageFromFilePath filePath+                dconfig         <- getDriverConfig config+                str             <- readFile filePath+                runError $ cmdToLlvm dconfig language (SourceFile filePath) str++        -- Build the runtime and base libraries.+        ModeBaseBuild+         -> do  dconfig         <- getDriverConfig config+                runError $ cmdBaseBuild dconfig++        -- Print the external builder info for this platform.+        ModePrintBuilder+         -> do  dconfig         <- getDriverConfig config+                putStrLn $ renderIndent $ ppr (Driver.configBuilder dconfig)++        -- Print where the runtime and base libraries are installed.+        ModePrintBaseDir+         ->     putStrLn $ configBaseDir config+++-- | Get the compile driver from the config.+getDriverConfig :: Config -> IO Driver.Config+getDriverConfig config+ = do   Just builder    <- determineDefaultBuilder (defaultBuilderConfig config)+        simplLite       <- getSimplLiteOfConfig config builder+        simplSalt       <- getSimplSaltOfConfig config builder++        return  $ Driver.Config+                { Driver.configDump                     = configDump config+                , Driver.configSimplLite                = simplLite+                , Driver.configSimplSalt                = simplSalt+                , Driver.configViaBackend               = configViaBackend config++                , Driver.configRuntime               +                        = Runtime.Config+                        { Runtime.configHeapSize        = configRuntimeHeapSize config }++                , 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 }+++-- | 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++        Just ext +         -> return ext+++-- | Print errors to stderr and set the exit code.+runError :: ErrorT String IO () -> IO ()+runError m+ = do   result  <- runErrorT m+        case result of+         Left err       +          -> do hPutStrLn stderr err+                exitWith $ ExitFailure 1++         Right _+          -> return ()+

@@ -0,0 +1,265 @@++module DDCI.Core.Command+        ( Command(..)+        , commands+        , readCommand+        , handleCmd)+where+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 DDC.Driver.Command.Ast+import DDC.Driver.Command.Check+import DDC.Driver.Command.Load+import DDC.Driver.Command.Compile+import DDC.Driver.Command.Make+import DDC.Driver.Command.ToSalt+import DDC.Driver.Command.ToC+import DDC.Driver.Command.ToLlvm+import System.IO+import Control.Monad.Trans.Error+import Data.List+++-- Command --------------------------------------------------------------------+-- | The commands that the interpreter supports.+data Command+        = CommandBlank          -- ^ No command was entered.+        | CommandUnknown        -- ^ Some unknown (invalid) command.+        | 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.+        | CommandEquivType      -- ^ Check if two types are equivalent.+        | CommandWitType        -- ^ Show the type of a witness.+        | CommandExpCheck       -- ^ Check an expression.+        | 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.+        | CommandTrans          -- ^ Transform an expression.+        | CommandTransEval      -- ^ Transform then evaluate an expression.+        | CommandTransInteract  -- ^ Interactively transform an expression.++        | CommandAst            -- ^ Show the AST of an expression.++        | CommandCompile        -- ^ Compile a file.+        | CommandMake           -- ^ Compile and link and executable.++        | CommandToSalt         -- ^ Convert a module to Disciple Salt.+        | CommandToC            -- ^ Convert a module to C code.+        | CommandToLlvm         -- ^ Convert a module to LLVM code.++        | 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'+commands :: [(String, Command)]+commands + =      [ (":help",             CommandHelp)+        , (":?",                CommandHelp)+        , (":set",              CommandSet)+        , (":load",             CommandLoad)+        , (":kind",             CommandKind)+        , (":universe1",        CommandUniverse1)+        , (":universe2",        CommandUniverse2)+        , (":universe3",        CommandUniverse3)+        , (":universe",         CommandUniverse)+        , (":tequiv",           CommandEquivType)+        , (":wtype",            CommandWitType)+        , (":check",            CommandExpCheck)+        , (":recon",            CommandExpRecon)+        , (":type",             CommandExpType)+        , (":effect",           CommandExpEffect)+        , (":closure",          CommandExpClosure)+        , (":eval",             CommandEval)+        , (":trun",             CommandTransEval)+        , (":tinteract",        CommandTransInteract)+        , (":trans",            CommandTrans)+        , (":ast",              CommandAst) +        , (":compile",          CommandCompile)+        , (":make",             CommandMake)+        , (":to-salt",          CommandToSalt)+        , (":to-c",             CommandToC)+        , (":to-llvm",          CommandToLlvm) +        , (":with-lite",        CommandWithLite)+        , (":with-salt",        CommandWithSalt) +        , (":with",             CommandWith) ]+++-- | 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+++-- Commands -------------------------------------------------------------------+-- | Handle a single line of input.+handleCmd :: State -> Command -> Source -> String -> IO State+handleCmd state CommandBlank _ _+ = return state++handleCmd state cmd source line+ = do   state'  <- handleCmd1 state cmd source line+        return state'++handleCmd1 state cmd source line+ = case cmd of+        CommandBlank+         -> return state++        CommandUnknown+         -> do  putStr $ unlines+                 [ "unknown command."+                 , "use :? for help." ]++                return state++        CommandHelp+         -> do  putStr help+                return state++        CommandSet+         -> do  state'  <- cmdSet state line+                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+                return state++        CommandUniverse2+         -> do  cmdUniverse2 (stateLanguage state) source line+                return state++        CommandUniverse3+         -> do  cmdUniverse3 (stateLanguage state) source line+                return state++        CommandEquivType+         -> do  cmdTypeEquiv (stateLanguage state) source line+                return state++        CommandWitType    +         -> do  cmdShowWType (stateLanguage state) source line+                return state++        CommandExpCheck   +         -> do  cmdShowType  (stateLanguage state) ShowTypeAll source line+                return state++        CommandExpType  +         -> do  cmdShowType  (stateLanguage state) ShowTypeValue source line+                return state++        CommandExpEffect  +         -> do  cmdShowType  (stateLanguage state) ShowTypeEffect source line+                return state++        CommandExpClosure +         -> do  cmdShowType  (stateLanguage state) ShowTypeClosure source line+                return state++        CommandExpRecon+         -> do  cmdExpRecon  (stateLanguage state) source line+                return state++        CommandEval       +         -> do  cmdEval state source line+                return state++        CommandTrans+         -> do  cmdTrans state source line+                return state+        +        CommandTransEval+         -> do  cmdTransEval state source line+                return state+        +        CommandTransInteract+         -> do  cmdTransInteract state source line+        +        CommandAst+         -> do  cmdAstExp (stateLanguage state) source line+                return state++        CommandToSalt+         -> do  config  <- getDriverConfigOfState state+                runError $ cmdToSalt config (stateLanguage state) source line+                return    state++        CommandToC+         -> do  config  <- getDriverConfigOfState state+                runError $ cmdToC    config (stateLanguage state) source line+                return state++        CommandToLlvm+         -> do  config  <- getDriverConfigOfState state+                runError $ cmdToLlvm config (stateLanguage state) source line+                return state++        CommandCompile+         -> do  config  <- getDriverConfigOfState state+                runError $ cmdCompile config line+                return state++        CommandMake+         -> do  config  <- getDriverConfigOfState state+                runError $ cmdMake config line+                return state++        CommandWith+         ->     cmdWith state source line++        CommandWithLite+         ->     cmdWithLite state source line++        CommandWithSalt+         ->     cmdWithSalt state source line+++-- | 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 ()+

@@ -0,0 +1,244 @@++module DDCI.Core.Command.Eval+        ( cmdStep+        , cmdEval+        , evalExp)+where+import DDCI.Core.Stats.Trace+import DDCI.Core.Output+import DDCI.Core.State+import DDC.Driver.Command.Check+import DDC.Core.Eval.Env+import DDC.Core.Eval.Step+import DDC.Core.Eval.Name+import DDC.Core.Transform.Reannotate+import DDC.Core.Exp+import DDC.Core.Check+import DDC.Core.Pretty+import DDC.Core.Collect+import DDC.Core.Compounds+import DDC.Type.Equiv+import DDC.Type.Subsumes+import Control.Monad+import DDC.Core.Eval.Store                      (Store)+import qualified DDC.Core.Eval.Store            as Store+import qualified Data.Set                       as Set+import qualified DDC.Build.Language.Eval        as Eval+import qualified Data.Map		     as Map+import Data.Typeable+import DDC.Core.Module (ModuleMap)+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+ , (modules :: Maybe (ModuleMap (AnTEC () Name) Name))+			<- gcast modules0+ , modules'		<- fromMaybe Map.empty modules+ = cmdParseCheckExp Eval.fragment modules' False source str >>= goStore + where+        -- Expression had a parse or type error.+        goStore Nothing+         = return ()++        -- Expression is well-typed.+        goStore (Just x)+         = let  -- The evaluator doesn't accept any annotations+                x_stripped = reannotate (const ()) x++                -- Create the initial store.+                store      = startingStoreForExp x_stripped++           in   goStep store x++        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+ , (modules :: Maybe (ModuleMap (AnTEC () Name) Name))+			<- gcast modules0+ , modules'		<- fromMaybe Map.empty modules+ = cmdParseCheckExp Eval.fragment modules' False source str >>= goEval+ where+    -- Expression had a parse or type error.+    goEval Nothing+     =	return ()++    -- Expression is well-typed.+    goEval (Just expr)+     =	evalExp state expr+++-- | Evaluate an already parsed and type-checked expression.+--   Exported so transforms can test with it.+evalExp :: State -> Exp (AnTEC () Name) Name -> IO ()+evalExp state x0+ = do   +        -- The evaluator doesn't want any annotations+        let x0_stripped = reannotate (const ()) x0++        -- Create the initial store.+	let store = startingStoreForExp x0_stripped++	-- Print starting expression.+	when (Set.member TraceEval  $ stateModes state)+	 $ outDocLn state (text "* STEP: " <> ppr x0_stripped)++	-- Print starting store.+	when (Set.member TraceStore $ stateModes state)+	 $ do   putStrLn $ renderIndent $ ppr store+		outStr   state "\n"++	goStep store x0++    where+	goStep store x+	 = do mResult <- forcePrint state store x+	      case mResult of+	       Nothing            +                -> return ()++	       Just (store', x') +                -> goStep store' x'+ ++-- | Create a starting store for the given expression.+--   We pre-allocate any region handles in the expression, +--   and ensure that the next region to be allocated is higher+--   than all of these.+startingStoreForExp :: Exp () Name -> Store+startingStoreForExp xx+ =  let+        -- Gather up all the region handles already in the expression.+        rs      = [ r | UPrim (NameRgn r) _ <- Set.toList $ collectBound xx]++        -- Decide what new region should be allocated first.+        -- Region 0 is reserved for thunks.+        iAllocBump+         | _ : _         <- rs+         , Rgn iR        <- maximum rs+         = iR++         | otherwise+         = 0++        store  = Store.initial++    in  store+        { Store.storeNextRgn = Store.storeNextRgn store + iAllocBump+        , Store.storeRegions = Store.storeRegions store `Set.union` Set.fromList rs+        , Store.storeGlobal  = Store.storeGlobal  store `Set.union` Set.fromList rs }+++-- | Perform a single step of evaluation and print what happened.+forcePrint +        :: State+        -> Store +        -> Exp (AnTEC a Name) Name +        -> IO (Maybe (Store, Exp (AnTEC () Name) Name))++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++        -- 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+             Left err+              -> do +                    -- Print intermediate expression.+                    when (Set.member TraceEval  $ stateModes state)+                     $ do outDocLn state $ text "* STEP: " <> ppr x_stripped'++                    -- Print intermediate store+                    when (Set.member TraceStore $ stateModes state)+                     $ do putStrLn $ renderIndent $ ppr store'+                          outStr   state "\n"+                +                    putStrLn $ renderIndent+                     $ vcat [ text "* OFF THE RAILS!"+                            , ppr err+                            , empty ]++                    return $ Nothing+                      +             Right (x', tX', effX', cloX')+              -> do +                    -- Print intermediate expression.+                    when (Set.member TraceEval  $ stateModes state)+                     $ do outDocLn state $ text "* STEP: " <> ppr x'++                    -- Print intermediate store+                    when (Set.member TraceStore $ stateModes state)+                     $ do putStrLn $ renderIndent $ ppr store'+                          putStr "\n"+                +                    -- Check expression has the same type as before,+                    -- and that the effect and closure are no greater.+                    let deathT = not $ equivT    tX tX'+                    let deathE = not $ subsumesT kEffect  effX effX'++                    -- ISSUE #290: locations don't reveal closure information.+--                  let deathC = not $ subsumesT kClosure cloX cloX'+                    let death  = deathT || deathE -- deathC+++                    when death+                     $ putStrLn $ renderIndent+                     $ vcat [ empty+                            , text "* OFF THE RAILS! ************************"+                            , text "Starting expression:" +                            , indent 4 $ ppr x+                            , empty+                            , text "Has type:",    indent 4 $ ppr tX+                            , text "Has efect:",   indent 4 $ ppr effX+                            , text "Has closure:", indent 4 $ ppr cloX+                            , empty+                            , text "Reduced expression:"+                            , indent 4 $ ppr x'+                            , empty+                            , text "Has type:",    indent 4 $ ppr tX'+                            , text "Has effect:",  indent 4 $ ppr effX'+                            , text "Has closure:", indent 4 $ ppr cloX' ]++                    if death +                     then return Nothing+                     else return $ Just (store', x')+    +        StepDone+         -> do  -- Load the final expression back from the store to display.+                outDocLn state $ ppr $ traceStore store x_stripped+                return Nothing+        +        StepStuck+         -> do  outDocLn state +                 $ vcat [ text "* STUCK!"+                        , empty]++                return Nothing++        StepMistyped err+         -> do  putStrLn $ renderIndent+                 $ vcat [ text "* OFF THE RAILS!"+                        , ppr err+                        , empty]++                return Nothing+

@@ -0,0 +1,112 @@++module DDCI.Core.Command.Help where++help :: String+help    = unlines+        [ "-------------------------------------------------------------------- Usage --"+        , ""+        , " On the command line"+        , "   Prefix commands with '-'"+        , "      $ ddci-core -check \"\\(x : Unit). x\""+        , ""+        , "   Read input from a file with ':'"+        , "      $ ddci-core -set lang Salt -load: SomeFile.dcs"+        , ""+        , " 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.dcs"+        , ""+        , "   Expressions in the Eval fragment can be evaluated at the prompt."+        , "      > addInt [:R0# R0# R0#:] (2 [R0#] ()) (3 [R0#] ())"+        , "      5"+        , ""+        , "----------------------------------------------------------------- Commands --"+        , "General"+        , "    :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."+        , ""+        , "    :set rule NAME [an : kn] ... (xn : tn) ... exp1 = exp2"+        , "                        Add a rewrite rule to the database."+        , ""+        , "    :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."+        , ""+        , "   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."+        , ""+        , "   LANG    ::="+        , "    Lite | Salt | Zero | Eval"+        , ""+        , "   BUILDER ::= "+        , "    x86_32-darwin | x86_64-darwin | x86_32-linux  | x86_64-linux"+        , "    x86_32-cygwin | ppc32-linux"+        , ""+        , "   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."+        , ""+        , "Witness Commands"+        , "    :wtype    WITNESS   Show the type of a witness expression."+        , ""+        , "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." +        , ""+        , "    :trans     EXP      Transform the given expression."+        , "    :trun      EXP      Transform the given expression then evaluate it."+        , "    :tinteract EXP      Enter interactive transformation mode."+        , ""+        , "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."+        , ""+        , "    :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."+        , ""+        ]

@@ -0,0 +1,164 @@++-- | Display and toggle active interpreter modes.+module DDCI.Core.Command.Set+        ( Mode(..)+        , cmdSet)+where+import DDCI.Core.State+import DDCI.Core.Mode+import DDCI.Core.Output+import DDC.Build.Builder+import DDC.Build.Language+import DDC.Core.Fragment+import DDC.Core.Simplifier.Parser+import DDC.Base.Pretty+import Control.Monad+import Data.Char+import Data.List+import qualified DDCI.Core.Rewrite		as R+import qualified Data.Map			as Map+import qualified Data.Set                       as Set+++cmdSet ::  State -> String -> IO State++-- Display the active modes.+cmdSet state []+ | Language bundle      <- stateLanguage state+ , fragment             <- bundleFragment   bundle+ , modules              <- bundleModules    bundle+ , simpl                <- bundleSimplifier bundle+ = do+        let langName    = profileName (fragmentProfile fragment)++        putStrLn $ renderIndent+         $ vcat  [ text "Modes:      " <> text (show $ Set.toList $ stateModes state)+                 , text "Language:   " <> text langName+                 , text "Simplifier: " <> ppr  simpl+                 , text "Builder:    " <> text (show $ liftM builderName $ stateBuilder state) ]+         <$> vcat (text "With:       " : map ppr (Map.keys modules))+         <$> vcat (text "With Lite:  " : map ppr (Map.keys (stateWithLite state)))+         <$> vcat (text "With Salt:  " : map ppr (Map.keys (stateWithSalt state)))++        return state++-- Toggle active modes.+cmdSet state cmd+ | ["lang", name]       <- words cmd+ = do   case lookup name languages of+         Just language+          -> do putStrLn "ok"+                return $ state { stateLanguage = language }++         Nothing+          -> do putStrLn "unknown language"+                return state++ | "trans" : rest       <- words cmd+ , Language bundle      <- stateLanguage state+ , modules              <- bundleModules       bundle+ , rules                <- bundleRewriteRules  bundle + , mkNamT               <- bundleMakeNamifierT bundle+ , mkNamX               <- bundleMakeNamifierX bundle+ , fragment             <- bundleFragment      bundle+ = do   case parseSimplifier +                (fragmentReadName fragment)+                (SimplifierDetails+                        mkNamT mkNamX +                        (Map.assocs rules) +                        (Map.elems  modules))+                (concat $ intersperse " " rest) of++         Left _err+          -> do putStrLn $ "transform spec parse error"+                return state++         Right simpl+          -> do chatStrLn state "ok"+                let bundle'     = bundle { bundleSimplifier = simpl }+                return $ state { stateLanguage = Language bundle' }+++ | ("rule", rest)       <- R.parseFirstWord cmd+ , Language bundle      <- stateLanguage state+ , fragment             <- bundleFragment      bundle+ , modules              <- bundleModules       bundle+ , rules                <- bundleRewriteRules  bundle + = case R.parseRewrite fragment modules rest of+	Right (R.SetAdd name rule)+	 -> do	chatStrLn state $ "ok, added " ++ name+		let rules'  = Map.insert name rule rules+                let bundle' = bundle { bundleRewriteRules = rules' }+		return $ state { stateLanguage = Language bundle' }++	Right (R.SetRemove name)+	 -> do	chatStrLn state $ "ok, removed " ++ name+		let rules'  = Map.delete name rules+                let bundle' = bundle { bundleRewriteRules = rules' }+                return $ state { stateLanguage = Language bundle' }++	Right R.SetList+	 -> do	let rules' = Map.toList rules+		mapM_ (uncurry $ R.showRule state 0) rules'+		return state+	+	Left e+	 -> do	chatStrLn state e+		return state++ | "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  chatStrLn state "ok"+                 return state { stateBuilder = Just builder }++ | "outputdir" : dir : []    <- words cmd+ = return $ state { stateOutputDir  = Just dir }++ | "output" : file : []      <- words cmd+ = return $ state { stateOutputFile = Just file }++ | otherwise+ = case parseModeChanges cmd of+        Just changes+         -> do  let state'  = foldr (uncurry adjustMode) state changes+                chatStrLn state "ok"+                return state'+        +        Nothing+         -> do  chatStrLn state "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++

@@ -0,0 +1,170 @@+{-# 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 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 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, Show a)+        => State+        -> Profile n+        -> Env n                        -- Kind Environment.+        -> Env n                        -- Type Environment.+        -> s+        -> Simplifier s (AnTEC a n) n+        -> Exp (AnTEC a 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+

@@ -0,0 +1,116 @@+module DDCI.Core.Command.TransInteract+        ( cmdTransInteract+	, cmdTransInteractLoop)+where+import DDCI.Core.Command.Trans+import DDCI.Core.Output+import DDCI.Core.State+import DDC.Driver.Command.Check+import DDC.Build.Language+import DDC.Core.Fragment+import DDC.Core.Simplifier.Parser+import DDC.Core.Compounds+import DDC.Core.Check+import DDC.Core.Module+import DDC.Base.Pretty+import qualified Data.Map                       as Map+++-- TransInteract --------------------------------------------------------------+-- | Apply the current transform to an expression.+cmdTransInteract :: State -> Source -> String -> IO State+cmdTransInteract state source str+ | Language bundle      <- stateLanguage state+ , fragment             <- bundleFragment   bundle+ , modules              <- bundleModules    bundle+ =   cmdParseCheckExp fragment modules True 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)+         = do   +                let Just annot  = takeAnnotOfExp xx+                let t1          = annotType annot+                let eff1        = annotEffect annot+                let clo1        = annotClosure annot++                let hist   = TransHistory+			     { historyExp	    = (xx, t1, eff1, clo1)+			     , historySteps	    = []+                             , historyBundle        = bundle }++		return state { stateTransInteract = Just hist }+++cmdTransInteractLoop :: State -> String -> IO State+cmdTransInteractLoop state str+ | Just hist    <- stateTransInteract state+ , TransHistory (x,t,e,c) steps bundle <- hist+ , fragment     <- bundleFragment bundle+ , profile      <- fragmentProfile fragment+ = case str of+    ":back" -> do+	let steps' = case steps of+		      []     -> []+		      (_:ss) -> ss++	putStrLn "Going back: "+	let x' = case steps' of+		   []    -> x+		   ((xz,_):_) -> xz+	outDocLn state $ ppr x'++	let hist'      = TransHistory (x,t,e,c) steps' bundle+	return state { stateTransInteract = Just hist' }++    ":done" -> do+	let simps = reverse $ map (indent 4 . ppr . snd) steps+	outStrLn state "* TRANSFORM SEQUENCE:"+	mapM_ (outDocLn state) simps+	return state { stateTransInteract = Nothing }++    _	    -> do++ 	let tr = parseSimplifier +                    (fragmentReadName fragment)+		    (SimplifierDetails+                        (bundleMakeNamifierT bundle) +                        (bundleMakeNamifierX bundle)+        		(Map.assocs $ bundleRewriteRules bundle) +                        (Map.elems  $ bundleModules      bundle))+		    str++	let x' = case steps of+		[]    -> x+		((xz,_):_) -> xz++	case tr of+            Left _err -> do+                putStrLn "Error parsing simplifier"+                return state++	    Right tr' -> do+                let kenv    = modulesExportKinds+                                (bundleModules bundle) +                                (profilePrimKinds profile)++                let tenv    = modulesExportTypes+                                (bundleModules bundle) +                                (profilePrimTypes profile)++		x_trans <- applyTransAndCheck state profile kenv tenv+			    (bundleStateInit bundle) tr' x'++		case x_trans of+		    Nothing -> return state+		    Just x_trans' -> do+			outDocLn state $ ppr x_trans'+			let steps' = (x_trans', tr') : steps+		        let hist'  = TransHistory (x,t,e,c) steps' bundle+			return state { stateTransInteract = Just hist' }++ | otherwise = error "No transformation history!"

@@ -0,0 +1,85 @@++module DDCI.Core.Command.With+        (cmdWith, cmdWithLite, cmdWithSalt)+where+import DDCI.Core.State+import DDC.Driver.Source+import DDC.Core.Pretty+import DDC.Build.Pipeline+import DDC.Core.Module+import DDC.Data.Canned+import System.Directory+import Control.Monad+import Data.IORef+import Data.Char+import qualified Data.Map                       as Map+import qualified DDC.Build.Language.Lite        as Lite+import qualified DDC.Build.Language.Salt        as Salt+++-- | Add a module to the inliner table.+cmdWith :: State -> Source -> String -> IO State+cmdWith state _source str+ | Language bundle      <- stateLanguage  state+ , modules              <- bundleModules  bundle+ , fragment             <- bundleFragment bundle+ = do   res <- cmdWith_load fragment str+	case res of+	  Nothing  -> return state+	  Just mdl +           -> do+		let modules' = Map.insert (moduleName mdl) mdl modules +                let bundle'  = bundle { bundleModules = modules' }+		return $ state { stateLanguage = Language bundle' }+++cmdWithLite :: State -> Source -> String -> IO State+cmdWithLite state _source str+ = 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) }++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) }+++cmdWith_load frag str+ = do	-- Always treat the string as a filename+        let source   = SourceFile str++        -- Read in the source file.+        let filePath = dropWhile isSpace str+        exists  <- doesFileExist filePath+        when (not exists)+         $      error $ "No such file " ++ show filePath++        src     <- readFile filePath++	cmdWith_parse frag source src+++cmdWith_parse frag source src+ = do   ref     <- newIORef Nothing+        errs    <- pipeText (nameOfSource source) (lineStartOfSource source) src+                $  PipeTextLoadCore frag+                   [ PipeCoreHacks (Canned (\m -> writeIORef ref (Just m) >> return m)) +                     [PipeCoreOutput SinkDiscard] ]++        case errs of+         [] -> do+                putStrLn "ok"+                readIORef ref++         _ -> do+                mapM_ (putStrLn . renderIndent . ppr) errs+                return Nothing+

@@ -0,0 +1,161 @@++module DDCI.Core.Input+        ( InputState    (..)+        , Input         (..) +        , readInput+        , eatLine)+where+import DDCI.Core.State+import DDCI.Core.Command+import DDCI.Core.Command.TransInteract+import DDC.Data.ListUtils+import System.Directory+import Data.List+import Data.Char+++-- InputState ----------------------------------------------------------------------+-- Interpreter input state+data InputState+        = InputState+        { -- Command that we're still receiving input for,+          -- along with the line number it started on.+          inputCommand     :: Maybe (Command, Int)++          -- Input mode.+        , _inputMode        :: Input++          -- The current line number in the command stream.+        , inputLineNumber   :: Int++          -- Accumulation of current input buffer.+        , _inputAcc         :: String }+++-- | How we're reading the input expression.+data Input+        -- | Read input line-by-line, using a backslash at the end of the+        --   line to continue to the next.+        = InputLine++        -- | Read input as a block terminated by a double semicolon (;;)+        | InputBlock++        -- | Read input from a file specified on the prompt+        | InputFile     FilePath+        deriving (Eq, Show)+++-- | Read the input mode from the front of a string.+readInput :: String -> (Input, String)+readInput ss+        | isPrefixOf ".." ss+        = (InputBlock, drop 2 ss)++        | isPrefixOf "<" ss+        , filePath      <- dropWhile isSpace (drop 1 ss)+        = (InputFile filePath, drop (length filePath) ss)++        | otherwise+        = (InputLine, ss)+++-- Eat ------------------------------------------------------------------------+-- Eating input lines.+eatLine :: State -> InputState -> String -> IO (State, InputState)+eatLine state (InputState mCommand inputMode lineNumber acc) line+ | Just _ <- stateTransInteract state+ = do+	state' <- cmdTransInteractLoop state line+	return (state', InputState mCommand inputMode (lineNumber+1) acc)++ | otherwise+ = do   +        -- If this is the first line then try to read the command and+        --  input mode from the front so we know how to continue.+        -- If we can't read an explicit command then assume this is +        --  an expression to evaluate.+        let (cmd, lineStart, (input, rest))+             = case mCommand of+                -- We haven't started a command yet.+                Nothing+                 -> case readCommand line of+                     Just (cmd', rest') -> (cmd',        lineNumber, readInput rest')+                     Nothing            -> (CommandEval, lineNumber, (InputLine, line))+                +                -- We've already started a command, and this is more input for it.+                Just (cmd', lineStart')+                 -> (cmd', lineStart', (inputMode, line))++        let source +                -- We were instructed to read the program from a file.+                -- Report this file as the source location, independent+                -- of how we were instructed to read it.+                | InputFile filePath    <- input+                = SourceFile filePath++                -- The program was embedded in the command stream.+                | otherwise+                = case stateInterface state of+                        InterfaceArgs           -> SourceArgs+                        InterfaceConsole        -> SourceConsole lineStart+                        InterfaceBatch file     -> SourceBatch   file lineStart+++        case input of+         -- For line-by-line mode, if the line ends with backslash then keep+         -- reading, otherwise run the command.+         -- We also convert the backslash to a newline so the source+         -- position comes out right in parser error messages.+         InputLine+          | not $ null rest+          , last rest == '\\'+          , Just initRest       <- takeInit rest+          -> do return ( state+                       , InputState (Just (cmd, lineStart)) input+                                (lineNumber + 1)+                                (acc ++ initRest ++ "\n"))++          | otherwise+          -> do state'  <- handleCmd state cmd source (acc ++ rest)+                return ( state'+                       , InputState Nothing InputLine+                                (lineNumber + 1)+                                [])+++         -- For block mode, if the line ends with ';;' then run the command,+         -- otherwise keep reading.+         InputBlock+          | isSuffixOf ";;" rest+          -> do let rest' = take (length rest - 2) rest+                state'  <- handleCmd state cmd source (acc ++ rest')+                return ( state'+                       , InputState Nothing InputLine+                                (lineNumber + 1)+                                [])++          | otherwise+          ->    return ( state+                       , InputState (Just (cmd, lineStart)) input+                                (lineNumber + 1)+                                (acc ++ rest ++ "\n"))++         -- Read input from a file+         InputFile filePath+          -> do exists          <- doesFileExist filePath+                if exists +                 then do        +                        contents  <- readFile filePath+                        state'    <- handleCmd state cmd source contents+                        return  ( state'+                                , InputState Nothing InputLine+                                        (lineNumber + 1)+                                        [])+                 else do+                        putStrLn "No such file."+                        return  ( state+                                , InputState Nothing InputLine+                                        (lineNumber + 1)+                                        [])+

@@ -0,0 +1,47 @@++module DDCI.Core.Interface.Args+        (runArgs)+where+import DDCI.Core.Command.Help+import DDCI.Core.Command+import DDCI.Core.State+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 InterfaceArgs++        -- 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'          <- handleCmd state cmd (SourceFile filePath) +                                        contents+                loop state' rest++        loop state (('-':cmdStr) : rest)+         | Just (cmd, [])       <- readCommand (':' : cmdStr)+         , (argss, more)        <- break (isPrefixOf "-") rest+         = do   state'          <- handleCmd state cmd SourceArgs +                                        (concat $ intersperse " " argss)+                loop state' more++        loop _state xs+         = error $  "Cannot parse arguments: "+                 ++ intercalate " " xs+

@@ -0,0 +1,51 @@++module DDCI.Core.Interface.Batch+        (runBatch)+where+import DDCI.Core.State+import DDCI.Core.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 (InterfaceBatch filePath)+        let inputState  = InputState Nothing InputLine 1 []+        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+

@@ -0,0 +1,58 @@++module DDCI.Core.Interface.Interactive+        ( runInteractive)+where+import DDCI.Core.Input+import DDCI.Core.State+import Data.List+import Data.Maybe+import qualified System.Console.Haskeline       as HL+import qualified System.Console.Haskeline.IO    as HL+++-- Interactive ----------------------------------------------------------------+-- | Run an interactive session, reading commands from the console.+runInteractive :: IO ()+runInteractive+ = do   putStrLn "DDCi-core, version 0.3.0: 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 InterfaceConsole+        let inputState  = InputState Nothing InputLine 1 []+        loop state inputState hlState+ where  +        loop state inputState hlState +         = do   -- If this isn't the first line then print the prompt.+                let prompt = if isJust (inputCommand inputState)+                             then ""+			     else if isJust (stateTransInteract state)+			     then "trans> "+                             else "> "+         +                -- Read a line from the user and echo it back.+                line    <- getInput hlState prompt++                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)+

@@ -0,0 +1,46 @@++module DDCI.Core.Mode+        ( Mode(..)+        , readMode)+where+++-- | DDCI mode flags.+data Mode+        -- | Display the expression at each step in the evaluation.+        =  TraceEval++        -- | Display the store state at each step in the evaluation.+        |  TraceStore++        -- | Render expressions displayed to user using indenting.+        |  Indent++        -- | Suppress import lists when printing modules+        |  SuppressImports++        -- | 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+        deriving (Eq, Ord, Show)+++-- | Parse a mode from a string.+readMode :: String -> Maybe Mode+readMode str+ = case str of+        "TraceEval"             -> Just TraceEval+        "TraceStore"            -> Just TraceStore+        "Indent"                -> Just Indent+        "SuppressImports"       -> Just SuppressImports+        "SaltPrelude"           -> Just SaltPrelude+        "Dump"                  -> Just Dump+        "TraceTrans"            -> Just TraceTrans+        _                       -> Nothing+

@@ -0,0 +1,49 @@++module DDCI.Core.Output+        ( outDoc, outDocLn+        , outStr, outStrLn+        , chatStrLn)+where+import DDCI.Core.State+import DDC.Base.Pretty+import qualified Data.Set       as Set+++-- | Output a document to the console.+outDoc :: State -> Doc -> IO ()+outDoc state doc+        | Set.member Indent $ stateModes state+        = putDocLn RenderIndent doc++        | otherwise+        = putDocLn RenderPlain doc+++outDocLn :: State -> Doc -> IO ()+outDocLn state doc+        | Set.member Indent $ stateModes state+        = putDocLn RenderIndent doc++        | otherwise+        = putDocLn RenderPlain 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+        InterfaceConsole        -> putStrLn str+        InterfaceBatch _        -> putStrLn str+        _                       -> return ()

@@ -0,0 +1,100 @@++module DDCI.Core.Rewrite+        ( SetRuleCommand(..)+        , parseFirstWord+	, parseRewrite+	, showRule )+where+import DDC.Base.Pretty+import DDC.Build.Language+import DDC.Core.Lexer+import DDC.Core.Fragment                hiding (Error)+import DDC.Core.Transform.Rewrite.Rule  hiding (Error)+import DDC.Core.Transform.Rewrite.Parser+import DDCI.Core.State+import DDCI.Core.Output+import Data.Char+import qualified DDC.Core.Check         as C+import qualified DDC.Base.Parser        as BP++import DDC.Core.Module+import Data.Map                         (Map)+++-- | :set rule command+data SetRuleCommand a n+        = SetAdd    +                { setRuleName   :: String +                , setRuleRule   :: RewriteRule a n }++        | SetRemove +                { setRuleName   :: String }++	| SetList+        deriving (Eq, Show)++type Error = String+++-- | Return first word and remainder of string+parseFirstWord :: String -> (String,String)+parseFirstWord s = break isSpace $ dropWhile isSpace s+++-- | Parse a :set rule command+--   +name rule, name rule:  add rewrite rule+--   -name                   remove rule+parseRewrite +        :: (Ord n, Show n, Pretty n)+        => Fragment n err +	-> Map ModuleName (Module (C.AnTEC () n) n)+        -> String +        -> Either Error (SetRuleCommand (C.AnTEC () n) n)++parseRewrite fragment modules str+ = case dropWhile isSpace str of+	[]		-> Right SetList+	('+':rest)	-> parseAdd fragment modules rest++	('-':rest)	+         -> let (name,_) = parseFirstWord rest +            in Right $ SetRemove name++	rest            -> parseAdd fragment modules rest+++-- | Parse add rule+parseAdd+        :: (Ord n, Show n, Pretty n)+        => Fragment n err+	-> Map ModuleName (Module (C.AnTEC () n) n)+        -> String +        -> Either Error (SetRuleCommand (C.AnTEC () n) n)++parseAdd fragment modules str+ | (name, rest) <- parseFirstWord str+ = case BP.runTokenParser describeTok "<interactive>" pRule+          (fragmentLexExp fragment "interactive" 0 rest) of+                Left err -> Left $ renderIndent $ ppr err+                Right rule ->+                  case checkRewriteRule config kinds' types' rule of+                    Left err    -> Left  $ renderIndent $ ppr err+                    Right rule' -> Right $ SetAdd name rule'+ where+        config   = C.configOfProfile (fragmentProfile fragment)+	kinds	 = profilePrimKinds  (fragmentProfile fragment)+	types	 = profilePrimTypes  (fragmentProfile fragment)++	kinds'	 = modulesExportKinds modules kinds+	types'	 = modulesExportTypes modules types+++-- | Display rule+showRule :: (Eq n, Pretty n)+         => State -> Int -> String -> RewriteRule a n -> IO ()++showRule state indentBy name rule+ = do	putStr $ (take indentBy $ repeat '\t') ++ name ++ " "+	outDocLn state+	 $  ppr rule+

@@ -0,0 +1,190 @@++module DDCI.Core.State+        ( State         (..)+        , Bundle        (..)+        , initState+        , getDriverConfigOfState++        , TransHistory	(..)++        , Interface     (..)+        , Source        (..)++        , Language      (..)+        , languages+        , getDefaultBuilderConfig+        , getActiveBuilder++        , Mode          (..)+        , adjustMode)+where+import DDCI.Core.Mode+import DDC.Code.Config+import DDC.Driver.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+import DDC.Base.Pretty                          hiding ((</>))+import Data.Typeable+import System.FilePath+import Data.Map                                 (Map)+import Data.Set                                 (Set)+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 Data.Map                       as Map+import qualified Data.Set                       as Set+++-- | Interpreter state.+--   This is adjusted by interpreter commands.+data State+        = State+        { -- | ddci interface state.+          stateInterface        :: Interface++          -- | ddci mode flags.+        , stateModes            :: Set Mode ++          -- | Source language to accept.+        , stateLanguage         :: Language++          -- | Maps of modules we can use as inliner templates.+        , stateWithLite         :: Map ModuleName (Module (AnTEC () Lite.Name) Lite.Name)+        , stateWithSalt         :: Map ModuleName (Module (AnTEC () Salt.Name) Salt.Name)++          -- | Simplifier to apply to core program.+        , stateSimplLite        :: Simplifier Int () Lite.Name+        , stateSimplSalt        :: Simplifier Int () Salt.Name++          -- | Force the builder to this one, this sets the address width etc.+          --   If Nothing then query the host system for the default builder.+        , stateBuilder          :: Maybe Builder++          -- | Output file for @compile@ and @make@ commands.+        , stateOutputFile       :: Maybe FilePath ++          -- | Output dir for @compile@ and @make@ commands+        , stateOutputDir        :: Maybe FilePath++	  -- | Interactive transform mode+	, stateTransInteract	:: Maybe TransHistory}++++data TransHistory+	= forall s n err+        .  (Typeable n, Ord n, Show n, Pretty n)+	=> TransHistory+	{ -- | Original expression and its types+	  historyExp		:: (Exp (AnTEC () n) n, Type n, Effect n, Closure n) ++	  -- | Keep history of steps so we can go back and construct final sequence+	, historySteps		:: [(Exp (AnTEC () n) n, Simplifier s (AnTEC () n) n)]++          -- | Bundle for the language that we're transforming.+        , historyBundle         :: Bundle s n err }+++-- | What interface is being used.+data Interface+        -- | Read commands from unix command-line args.+        = InterfaceArgs++        -- | Read commands interactively from the console.+        | InterfaceConsole++        -- | Read commands from the file with this name.+        | InterfaceBatch        FilePath+        deriving (Eq, Show)+++-- | 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) }+++-- | The initial state.+initState :: Interface -> State+initState interface+        = State+        { stateInterface        = interface+        , stateModes            = Set.empty +        , stateLanguage         = Eval.language+        , stateWithLite         = Map.empty+        , stateWithSalt         = Map.empty+        , stateSimplLite        = S.Trans S.Id+        , stateSimplSalt        = S.Trans S.Id+        , stateBuilder          = Nothing  +        , stateOutputFile       = Nothing+        , stateOutputDir        = Nothing+	, stateTransInteract	= Nothing }+++-- | Slurp out the relevant parts of the DDCI stage into a driver config.+getDriverConfigOfState :: State -> IO D.Config+getDriverConfigOfState state+ = do   builder <- getActiveBuilder state+        return +         $ D.Config+         { D.configDump                  = Set.member Dump (stateModes state)+         , 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            = stateOutputFile state+         , D.configOutputDir             = stateOutputDir  state+         , D.configSimplLite             = stateSimplLite  state+         , D.configSimplSalt             = stateSimplSalt  state+         , D.configBuilder               = builder+         , D.configSuppressCoreImports   = Set.member SuppressImports (stateModes state)+         , D.configSuppressHashImports   = not $ Set.member SaltPrelude (stateModes state) +         , D.configKeepLlvmFiles         = False+         , D.configKeepSeaFiles          = False+         , D.configKeepAsmFiles          = False }+++-- | 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 "getActiveBuilder unrecognised host platform"+                 Just builder -> return builder++

@@ -0,0 +1,82 @@++module DDCI.Core.Stats.Trace+        (traceStore)+where+import DDC.Core.Eval.Store+import DDC.Core.Eval.Name+import DDC.Type.Compounds+import DDC.Core.Compounds+import DDC.Core.Exp+import qualified Data.Set       as Set+import Data.Set                 (Set)+++-- | Replace non-recursive store locations in an expression by their values.+--  +--   * If the value is recursive then we just leave the original store location.+--   * Constructors in the result just have *0 for their type annotation.+--+traceStore :: Store -> Exp () Name -> Exp () Name+traceStore store xx+        = traceStoreX store Set.empty xx+++-- | Trace an expression.+traceStoreX :: Store -> Set Name -> Exp () Name -> Exp () Name+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+         , Just sbind           <- lookupBind l store+         -> traceStoreX store (Set.insert n entered) (expOfSBind sbind)++        XCon{}          -> xx+        XApp  a x1 x2   -> XApp  a (down x1) (down x2)+        XLAM  a b x     -> XLAM  a b (down x)+        XLam  a b  x    -> XLam  a b (down x)+        XLet  a ls x    -> XLet  a (traceStoreLs store entered ls) (down x)+        XCase a x alts  -> XCase a (down x) (map (traceStoreA store entered) alts)+        XCast a c x     -> XCast a c (down x)+        XType{}         -> xx+        XWitness{}      -> xx+++-- | Trace lets.+traceStoreLs :: Store -> Set Name -> Lets () Name -> Lets () Name+traceStoreLs store entered ls+ = let down = traceStoreX store entered +   in case ls of+        LLet m b x      -> LLet m b (down x)+        LRec bxs        -> LRec [(b, down x) | (b, x) <- bxs]+        LLetRegions{}   -> ls+        LWithRegion{}   -> ls+++-- | Trace case alts.+traceStoreA  :: Store -> Set Name -> Alt () Name  -> Alt () Name+traceStoreA store entered (AAlt p x)+        = AAlt p (traceStoreX store entered x)+++-- | Convert a store binding to an expression.+expOfSBind :: SBind -> Exp () Name+expOfSBind sbind+ = case sbind of+        SObj dcTag lsArgs+         -> xApps () (XCon () dcTag) (map expOfLoc lsArgs)++        SLams fbs x+         -> makeXLamFlags () fbs x++        SThunk x+         -> x+++-- | Convert a store location to a constructor expression.+expOfLoc :: Loc -> Exp () Name+expOfLoc l = XCon () (mkDaConSolid (NameLoc l) (tBot kData))+

@@ -0,0 +1,58 @@++-- | Interactive interface to DDC.+--      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.Core.Command.Help+import DDCI.Core.Interface.Args+import DDCI.Core.Interface.Batch+import DDCI.Core.Interface.Interactive+import DDCI.Core.State+import DDC.Driver.Command.Make+import System.Environment+import System.IO+import Control.Monad.Trans.Error+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++         -- Make a file, depending on what the extension is.+         -- This gets us  --make on the command line as well as -make+         -- so we behave more like GHC.+         ["--make",  filePath]+          -> do let state       = initState (InterfaceBatch filePath)+                config          <- getDriverConfigOfState state+                runError $ cmdMake config filePath++         -- Run a Disciple-Core-Exchange file.+         [filePath]+          | isSuffixOf ".dcx" filePath+          -> do file    <- readFile filePath+                runBatch filePath file++        +         _       -> runArgs args+++-- | 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 ()+