Merge pull request #827 from jacereda/cmdline-eval

Command line switches to evaluate code

CarpHask.cabal

@@ -63,7 +63,7 @@ library
                      , blaze-html
                      , blaze-markup
                      , text
-                     , ansi-terminal >= 0.9
+                     , ansi-terminal >= 0.10.3
                      , cmark
                      , edit-distance
 
@@ -80,6 +80,7 @@ executable carp
                      , filepath
                      , haskeline
                      , process
+                     , optparse-applicative
   default-language:    Haskell2010
 
 executable carp-header-parse
@@ -90,8 +91,8 @@ executable carp-header-parse
                      , CarpHask
                      , containers
                      , directory
-                     , cmdargs
                      , parsec
+                     , optparse-applicative
   default-language:    Haskell2010
 
 test-suite CarpHask-test

app/Main.hs

@@ -2,7 +2,9 @@ module Main where
 
 import qualified System.Environment as SystemEnvironment
 import System.Console.Haskeline (runInputT)
+import Control.Monad (foldM)
 import GHC.IO.Encoding
+import Data.Maybe
 
 import ColorText
 import Obj
@@ -14,12 +16,20 @@ import Util
 import Path
 import Info
 
+import Options.Applicative
+
 defaultProject :: Project
 defaultProject =
   Project { projectTitle = "Untitled"
           , projectIncludes = []
-          , projectCFlags = [""]
-          , projectLibFlags = [""]
+          , projectCFlags = case platform of
+              Windows -> ["-D_CRT_SECURE_NO_WARNINGS"]
+              _ -> [ "-fPIC"
+                   , "-g"
+                   ]
+          , projectLibFlags = case platform of
+              Windows -> []
+              _ -> [ "-lm" ]
           , projectFiles = []
           , projectAlreadyLoaded = []
           , projectEchoC = False
@@ -39,8 +49,8 @@ defaultProject =
           , projectCarpSearchPaths = []
           , projectPrintTypedAST = False
           , projectCompiler = case platform of
-                                Windows -> "clang-cl.exe -D _CRT_SECURE_NO_WARNINGS"
-                                _ ->       "clang -fPIC -lm -g"
+                                Windows -> "clang-cl.exe"
+                                _ ->       "clang"
           , projectCore = True
           , projectEchoCompilationCommand = False
           , projectCanExecute = False
@@ -54,94 +64,103 @@ main :: IO ()
 main = do setLocaleEncoding utf8
           args <- SystemEnvironment.getArgs
           sysEnv <- SystemEnvironment.getEnvironment
-          let (argFilesToLoad, execMode, otherOptions) = parseArgs args
-              logMemory = LogMemory `elem` otherOptions
-              noCore = NoCore `elem` otherOptions
-              noProfile = NoProfile `elem` otherOptions
-              optimize = Optimize `elem` otherOptions
-              generateOnly = GenerateOnly `elem` otherOptions
-              projectWithFiles = defaultProject { projectCFlags = ["-D LOG_MEMORY" | logMemory] ++
-                                                                  ["-O3 -D NDEBUG" | optimize] ++
-                                                                  projectCFlags defaultProject,
-                                                  projectCore = not noCore,
-                                                  projectGenerateOnly = generateOnly}
+          fullOpts <- execParser $ Options.Applicative.info (parseFull <**> helper) fullDesc
+          let execMode = optExecMode fullOpts
+              otherOptions = optOthers fullOpts
+              argFilesToLoad = optFiles fullOpts
+              logMemory = otherLogMemory otherOptions
+              core = not $ otherNoCore otherOptions
+              profile = not $ otherNoProfile otherOptions
+              optimize = otherOptimize otherOptions
+              generateOnly = otherGenerateOnly otherOptions
+              prompt = otherPrompt otherOptions
+              applySettings p = p { projectCFlags = ["-D LOG_MEMORY" | logMemory] ++
+                                                    ["-O3 -D NDEBUG" | optimize]
+                                                    ++ projectCFlags p
+                                  , projectCore = core
+                                  , projectGenerateOnly = generateOnly
+                                  , projectCarpDir = fromMaybe (projectCarpDir p) $ lookup "CARP_DIR" sysEnv
+                                  , projectPrompt = fromMaybe (projectPrompt p) prompt
+                                  }
+              project = applySettings defaultProject
               noArray = False
-              coreModulesToLoad = if noCore then [] else coreModules (projectCarpDir projectWithCarpDir)
-              projectWithCarpDir = case lookup "CARP_DIR" sysEnv of
-                                     Just carpDir -> projectWithFiles { projectCarpDir = carpDir }
-                                     Nothing -> projectWithFiles
-              projectWithCustomPrompt = setCustomPromptFromOptions projectWithCarpDir otherOptions
               startingContext = Context
-                                 (startingGlobalEnv noArray)
-                                 Nothing
-                                 (TypeEnv startingTypeEnv)
-                                 []
-                                 projectWithCustomPrompt
-                                 ""
-                                 execMode
-                                 []
-          context <- loadFilesOnce startingContext coreModulesToLoad
+                                (startingGlobalEnv noArray)
+                                Nothing
+                                (TypeEnv startingTypeEnv)
+                                []
+                                project
+                                ""
+                                execMode
+                                []
+              coreModulesToLoad = if core then coreModules (projectCarpDir project) else []
+              execStr :: String -> String -> Context -> IO Context
+              execStr info str ctx = executeString True False ctx str info
+              execStrs :: String -> [String] -> Context -> IO Context
+              execStrs info strs ctx = foldM (\ctx str -> execStr info str ctx) ctx strs
+              preloads = optPreload fullOpts
+              postloads = optPostload fullOpts
+              load = flip loadFiles
           carpProfile <- configPath "profile.carp"
           hasProfile <- doesFileExist carpProfile
-          context' <- if (not noProfile) && hasProfile
-                      then loadFiles context [carpProfile]
-                      else return context
-          finalContext <- loadFiles context' argFilesToLoad
-          case execMode of
-            Repl -> do putStrLn "Welcome to Carp 0.3.0"
-                       putStrLn "This is free software with ABSOLUTELY NO WARRANTY."
-                       putStrLn "Evaluate (help) for more information."
-                       _ <- runRepl finalContext
-                       return ()
-            Build -> do _ <- executeString True False finalContext "(build)" "Compiler (Build)"
-                        return ()
-            Install thing ->
-              do _ <- executeString True False finalContext
-                      ("(load \"" ++ thing ++ "\")")
-                      "Installation"
-                 return ()
-            BuildAndRun -> do _ <- executeString True False finalContext "(do (build) (run))" "Compiler (Build & Run)"
-                              -- TODO: Handle the return value from executeString and return that one to the shell
-                              return ()
-            Check -> return ()
-
+          _ <- loadFilesOnce startingContext coreModulesToLoad
+            >>= load [carpProfile | hasProfile]
+            >>= execStrs "Preload" preloads
+            >>= load argFilesToLoad
+            >>= execStrs "Postload" postloads
+            >>= \ctx -> case execMode of
+                          Repl -> do putStrLn "Welcome to Carp 0.3.0"
+                                     putStrLn "This is free software with ABSOLUTELY NO WARRANTY."
+                                     putStrLn "Evaluate (help) for more information."
+                                     snd <$> runRepl ctx
+                          Build -> execStr "Compiler (Build)" "(build)" ctx
+                          Install thing -> execStr "Installation" ("(load \"" ++ thing ++ "\")") ctx
+                          BuildAndRun -> execStr "Compiler (Build & Run)" "(do (build) (run))" ctx
+                          Check -> execStr "Check" "" ctx
+                          -- TODO: Handle the return value from executeString and return that one to the shell
+          pure ()
 -- | Options for how to run the compiler.
-data OtherOptions = NoCore
-                  | NoProfile
-                  | LogMemory
-                  | Optimize
-                  | GenerateOnly
-                  | SetPrompt String
-                  deriving (Show, Eq)
+data FullOptions = FullOptions
+  { optExecMode :: ExecutionMode
+  , optOthers :: OtherOptions
+  , optPreload :: [String]
+  , optPostload :: [String]
+  , optFiles :: [FilePath]
+  } deriving Show
 
--- | Parse the arguments sent to the compiler from the terminal.
--- | TODO: Switch to 'cmdargs' library for parsing these!
-parseArgs :: [String] -> ([FilePath], ExecutionMode, [OtherOptions])
-parseArgs args = parseArgsInternal [] Repl [] args
-  where parseArgsInternal filesToLoad execMode otherOptions [] =
-          (filesToLoad, execMode, otherOptions)
-        parseArgsInternal filesToLoad execMode otherOptions (arg:restArgs) =
-          case arg of
-            "-b" -> parseArgsInternal filesToLoad Build otherOptions restArgs
-            "-x" -> parseArgsInternal filesToLoad BuildAndRun otherOptions restArgs
-            "-i" -> parseArgsInternal filesToLoad (Install (head restArgs)) otherOptions (tail restArgs)
-            "--check" -> parseArgsInternal filesToLoad Check otherOptions restArgs
-            "--no-core" -> parseArgsInternal filesToLoad execMode (NoCore : otherOptions) restArgs
-            "--no-profile" -> parseArgsInternal filesToLoad execMode (NoProfile : otherOptions) restArgs
-            "--log-memory" -> parseArgsInternal filesToLoad execMode (LogMemory : otherOptions) restArgs
-            "--optimize" -> parseArgsInternal filesToLoad execMode (Optimize : otherOptions) restArgs
-            "--generate-only" -> parseArgsInternal filesToLoad execMode (GenerateOnly : otherOptions) restArgs
-            "--prompt" -> case restArgs of
-                             newPrompt : restRestArgs ->
-                               parseArgsInternal filesToLoad execMode (SetPrompt newPrompt : otherOptions) restRestArgs
-                             _ ->
-                               error "No prompt given after --prompt"
-            file -> parseArgsInternal (filesToLoad ++ [file]) execMode otherOptions restArgs
+parseFull :: Parser FullOptions
+parseFull = FullOptions
+  <$> parseExecMode
+  <*> parseOther
+  <*> many (strOption (long "eval-preload" <> metavar "CODE" <> help "Eval CODE after loading config and before FILES"))
+  <*> many (strOption (long "eval-postload" <> metavar "CODE" <> help "Eval CODE after loading FILES"))
+  <*> parseFiles
 
-setCustomPromptFromOptions :: Project -> [OtherOptions] -> Project
-setCustomPromptFromOptions project (o:os) =
-  case o of
-    SetPrompt newPrompt -> setCustomPromptFromOptions (project { projectPrompt = newPrompt }) os
-    _ -> setCustomPromptFromOptions project os
-setCustomPromptFromOptions project _ =
-  project
+data OtherOptions = OtherOptions
+  { otherNoCore :: Bool
+  , otherNoProfile :: Bool
+  , otherLogMemory :: Bool
+  , otherOptimize :: Bool
+  , otherGenerateOnly :: Bool
+  , otherPrompt :: Maybe String
+  } deriving Show
+
+parseOther :: Parser OtherOptions
+parseOther = OtherOptions
+  <$> switch (long "no-core" <> help "Don't load Core.carp")
+  <*> switch (long "no-profile" <> help "Don't load profile.carp")
+  <*> switch (long "log-memory" <> help "Log memory allocations")
+  <*> switch (long "optimize" <> help "Optimized build")
+  <*> switch (long "generate-only" <> help "Stop after generating the C code")
+  <*> optional (strOption (long "prompt" <> help "Set REPL prompt"))
+
+parseExecMode :: Parser ExecutionMode
+parseExecMode =
+  flag' Check (long "check" <> help "Check project")
+  <|> flag' Build (short 'b' <> help "Build project")
+  <|> flag' BuildAndRun (short 'x' <> help "Build an run project")
+  <|> Install <$> strOption (short 'i' <> help "Install built product")
+  <|> pure Repl
+
+parseFiles :: Parser [FilePath]
+parseFiles = many (argument str (metavar "FILES..."))

carp.sh

@@ -1,3 +1,4 @@
+#!/usr/bin/env bash
 if [ -z "$CARP" ]
 then
     if [ -z "$NIX_CC" ]
@@ -7,4 +8,4 @@ then
 	CARP="cabal -v0 run carp"
     fi
 fi
-$CARP $BUILD_OPTS $"--" $*
+$CARP $BUILD_OPTS -- $CARP_OPTS "$@"

core/SafeInt.carp

@@ -1,12 +1,10 @@
 (system-include "carp_safe_int.h")
 
 (defmodule Int
-  (not-on-windows ; this seems to generate invalid code on some windows machines
-    (doc safe-add "Performs an addition and checks whether it overflowed.")
-    (register safe-add (λ [Int Int (Ref Int)] Bool))
-    (doc safe-sub "Performs an substraction and checks whether it overflowed.")
-    (register safe-sub (λ [Int Int (Ref Int)] Bool))
-    (doc safe-mul "Performs an multiplication and checks whether it overflowed.")
-    (register safe-mul (λ [Int Int (Ref Int)] Bool))
-  )
+  (doc safe-add "Performs an addition and checks whether it overflowed.")
+  (register safe-add (λ [Int Int (Ref Int)] Bool))
+  (doc safe-sub "Performs an substraction and checks whether it overflowed.")
+  (register safe-sub (λ [Int Int (Ref Int)] Bool))
+  (doc safe-mul "Performs an multiplication and checks whether it overflowed.")
+  (register safe-mul (λ [Int Int (Ref Int)] Bool))
 )

core/carp_long.h

@@ -10,7 +10,7 @@ Long Long__MUL_(Long x, Long y) {
 Long Long__DIV_(Long x, Long y) {
     return x / y;
 }
-#ifndef _WIN32
+#if defined __GNUC__
 bool Long_safe_MINUS_add(Long x, Long y, Long* res) {
     return __builtin_add_overflow(x, y, res);
 }
@@ -20,6 +20,22 @@ bool Long_safe_MINUS_sub(Long x, Long y, Long* res) {
 bool Long_safe_MINUS_mul(Long x, Long y, Long* res) {
     return __builtin_mul_overflow(x, y, res);
 }
+#else
+bool Long_safe_MINUS_add(Long x, Long y, Long* res) {
+    Long r = x + y;
+    *res = r;
+    return (y > 0) && (x > (INT64_MAX - y)) || (y < 0) && (x < (INT64_MIN - y));
+}
+bool Long_safe_MINUS_sub(Long x, Long y, Long* res) {
+    Long r = x - y;
+    *res = r;
+    return (y > 0 && x < (INT64_MIN + y)) || (y < 0 && x > (INT64_MAX + y));
+}
+bool Long_safe_MINUS_mul(Long x, Long y, Long* res) {
+    Long r = x * y;
+    *res = r;
+    return y == 0 || (r / y) != x;
+}
 #endif
 bool Long__EQ_(Long x, Long y) {
     return x == y;

core/carp_safe_int.h

@@ -1,4 +1,4 @@
-#ifndef _WIN32
+#if defined __GNUC__
 bool Int_safe_MINUS_add(int x, int y, int* res) {
     return __builtin_add_overflow(x, y, res);
 }
@@ -8,4 +8,21 @@ bool Int_safe_MINUS_sub(int x, int y, int* res) {
 bool Int_safe_MINUS_mul(int x, int y, int* res) {
     return __builtin_mul_overflow(x, y, res);
 }
+#else
+bool Int_safe_MINUS_add(int x, int y, int* res) {
+    int r = x + y;
+    *res = r;
+    return (y > 0) && (x > (INT_MAX - y)) || (y < 0) && (x < (INT_MIN - y));
+}
+bool Int_safe_MINUS_sub(int x, int y, int* res) {
+    int r = x - y;
+    *res = r;
+    *res = x - y;
+    return (y > 0 && x < (INT_MIN + y)) || (y < 0 && x > (INT_MAX + y));
+}
+bool Int_safe_MINUS_mul(int x, int y, int* res) {
+    int r = x * y;
+    *res = r;
+    return y == 0 || (r / y) != x;
+}
 #endif

default.nix

@@ -11,9 +11,10 @@ let
   optionals = nixpkgs.stdenv.lib.optionals;
   linuxOnly = optionals nixpkgs.stdenv.isLinux;
 
-  f = { mkDerivation, ansi-terminal, base, blaze-html, blaze-markup
-      , cmark, cmdargs, containers, directory, edit-distance, filepath
-      , haskeline, HUnit, mtl, parsec, process, split, stdenv, text
+  f = { mkDerivation, stdenv
+      , ansi-terminal, base, blaze-html, blaze-markup
+      , cmark, containers, directory, edit-distance, filepath
+      , haskeline, HUnit, mtl, optparse-applicative, parsec, process, split, text
       , darwin, glfw3, SDL2, SDL2_image, SDL2_gfx, SDL2_mixer, SDL2_ttf
       , ghc-prof-flamegraph
       , clang , makeWrapper
@@ -39,7 +40,7 @@ let
           [ glfw3 SDL2 SDL2_image SDL2_gfx SDL2_mixer SDL2_ttf ]
           ++ linuxOnly [ libXext libXcursor libXinerama libXi libXrandr libXScrnSaver libXxf86vm libpthreadstubs libXdmcp libGL];
         executableHaskellDepends = [
-          base cmdargs containers directory haskeline parsec process
+          base containers directory haskeline optparse-applicative parsec process
           clang
         ];
         executableFrameworkDepends = with darwin.apple_sdk.frameworks; optionals stdenv.isDarwin [
@@ -73,6 +74,6 @@ in
   if pkgs.lib.inNixShell
   then drv.env.overrideAttrs (o: {
     buildInputs = with pkgs; o.buildInputs ++ [ haskellPackages.cabal-install clang gdb ]
-                  ++ linuxOnly [ flamegraph linuxPackages.perf ];
+                  ++ linuxOnly [ flamegraph linuxPackages.perf tinycc ];
   })
   else drv

examples/basics.carp

@@ -234,4 +234,5 @@
       (two-lengths-in-same-func)
       (changing-target-of-ref)
       (resolve-correctly)
+      0
       ))

headerparse/Main.hs

@@ -3,7 +3,7 @@
 
 module Main where
 
-import System.Console.CmdArgs
+import Options.Applicative hiding ((<|>))
 import Text.Parsec ((<|>))
 import qualified Text.Parsec as Parsec
 import Data.Char (toLower, isUpper)
@@ -12,16 +12,18 @@ import Types
 import Obj
 import Path
 
-data Args = Args { sourcePath :: String
-                 , prefixToRemove :: String
+data Args = Args { prefixToRemove :: String
                  , kebabCase :: Bool
-                 } deriving (Show, Data, Typeable)
+                 , sourcePath :: String
+                 } deriving Show
 
-main = do parsedArgs <- cmdArgs (Args { sourcePath = def &= argPos 0
-                                      , prefixToRemove = def
-                                      , kebabCase = False
-                                      }
-                                 &= summary "Carp Header Parse 0.0.1")
+parseArgs :: Parser Args
+parseArgs = Args
+  <$> strOption (long "prefixtoremove" <> short 'p' <> metavar "ITEM" <> value "")
+  <*> switch (long "kebabcase" <> short 'f')
+  <*> argument str (metavar "FILE")
+
+main = do parsedArgs <- execParser $ Options.Applicative.info (parseArgs <**> helper) fullDesc
           let path = sourcePath parsedArgs
           if path /= ""
             then do source <- slurp path

src/Emit.hs

@@ -702,10 +702,12 @@ memberToDecl indent (memberName, memberType) =
 
 defStructToDeclaration :: Ty -> SymPath -> [XObj] -> String
 defStructToDeclaration structTy@(StructTy typeName typeVariables) path rest =
-  let indent' = indentAmount
+  let indent = indentAmount
 
       typedefCaseToMemberDecl :: XObj -> State EmitterState [()]
-      typedefCaseToMemberDecl (XObj (Arr members) _ _) = mapM (memberToDecl indent') (pairwise members)
+      -- ANSI C doesn't allow empty structs, insert a dummy member to keep the compiler happy.
+      typedefCaseToMemberDecl (XObj (Arr []) _ _) = sequence $ pure $ appendToSrc (addIndent indent ++ "char __dummy;\n")
+      typedefCaseToMemberDecl (XObj (Arr members) _ _) = mapM (memberToDecl indent) (pairwise members)
       typedefCaseToMemberDecl _ = error "Invalid case in typedef."
 
       -- Note: the names of types are not namespaced

src/Eval.hs

@@ -814,18 +814,21 @@ printC xobj =
 
 buildMainFunction :: XObj -> XObj
 buildMainFunction xobj =
-  XObj (Lst [ XObj (Defn Nothing) (Just dummyInfo) Nothing
-            , XObj (Sym (SymPath [] "main") Symbol) (Just dummyInfo) Nothing
-            , XObj (Arr []) (Just dummyInfo) Nothing
-            , case ty xobj of
-                Just UnitTy -> xobj
-                Just (RefTy _ _) -> XObj (Lst [XObj (Sym (SymPath [] "println*") Symbol) (Just dummyInfo) Nothing, xobj])
-                                       (Just dummyInfo) (Just UnitTy)
-                Just _ -> XObj (Lst [XObj (Sym (SymPath [] "println*") Symbol) (Just dummyInfo) Nothing,
-                                     XObj (Lst [XObj Ref (Just dummyInfo) Nothing, xobj])
-                                           (Just dummyInfo) (Just UnitTy)])
-                               (Just dummyInfo) (Just UnitTy)
-            ]) (Just dummyInfo) (Just (FuncTy [] UnitTy StaticLifetimeTy))
+  XObj (Lst [ XObj (Defn Nothing) di Nothing
+            , XObj (Sym (SymPath [] "main") Symbol) di Nothing
+            , XObj (Arr []) di Nothing
+            , XObj (Lst [ XObj Do di Nothing
+                        , case ty xobj of
+                            Just UnitTy -> xobj
+                            Just (RefTy _ _) -> XObj (Lst [XObj (Sym (SymPath [] "println*") Symbol) di Nothing, xobj])
+                                                di (Just UnitTy)
+                            Just _ -> XObj (Lst [XObj (Sym (SymPath [] "println*") Symbol) di Nothing,
+                                                 XObj (Lst [XObj Ref di Nothing, xobj])
+                                                 di (Just UnitTy)])
+                                      di (Just UnitTy)
+                        , XObj (Num IntTy 0) di Nothing
+                        ]) di Nothing]) di (Just (FuncTy [] UnitTy StaticLifetimeTy))
+  where di = Just dummyInfo
 
 primitiveDefdynamic :: Primitive
 primitiveDefdynamic _ ctx [XObj (Sym (SymPath [] name) _) _ _, value] = do

src/Repl.hs

@@ -151,6 +151,7 @@ resetAlreadyLoadedFiles context =
       proj' = proj { projectAlreadyLoaded = [] }
   in  context { contextProj = proj' }
 
+runRepl :: Context -> IO ((), Context)
 runRepl context = do
   historyFile <- configPath "history"
   createDirectoryIfMissing True (takeDirectory historyFile)

stack.yaml

@@ -15,7 +15,7 @@
 # resolver:
 #  name: custom-snapshot
 #  location: "./custom-snapshot.yaml"
-resolver: lts-14.9
+resolver: lts-15.3
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.
@@ -39,7 +39,7 @@ packages:
 - '.'
 # Dependency packages to be pulled from upstream that are not in the resolver
 # (e.g., acme-missiles-0.3)
-extra-deps: [ansi-terminal-0.9]
+extra-deps: []
 
 # Override default flag values for local packages and extra-deps
 flags: {}

test/init_global.carp

@@ -6,4 +6,6 @@
 
 ;; The one allocation left after 'carp_init_globals' should be 'g' itself:
 (defn main []
-  (assert (= 1l (Debug.memory-balance))))
+  (do
+    (assert (= 1l (Debug.memory-balance)))
+    0))