From 28104b0fb267da1ea2115ffbf4d9d86dd1157da8 Mon Sep 17 00:00:00 2001 From: Jorge Acereda Date: Mon, 23 Sep 2019 23:47:26 +0200 Subject: [PATCH] Path module. --- CarpHask.cabal | 2 ++ app/Main.hs | 19 +++++++----------- headerparse/Main.hs | 3 ++- src/Commands.hs | 21 ++++++++++---------- src/Eval.hs | 38 ++++++++++++++--------------------- src/Obj.hs | 2 +- src/Path.hs | 48 +++++++++++++++++++++++++++++++++++++++++++++ src/RenderDocs.hs | 7 +++---- src/Repl.hs | 7 +++---- src/Util.hs | 6 ------ 10 files changed, 91 insertions(+), 62 deletions(-) create mode 100644 src/Path.hs diff --git a/CarpHask.cabal b/CarpHask.cabal index ccb8e087..d7514704 100644 --- a/CarpHask.cabal +++ b/CarpHask.cabal @@ -45,6 +45,7 @@ library StartingEnv, RenderDocs, StructUtils, + Path, Validate build-depends: base >= 4.7 && < 5 @@ -73,6 +74,7 @@ executable carp , CarpHask , containers , directory + , filepath , haskeline , process default-language: Haskell2010 diff --git a/app/Main.hs b/app/Main.hs index a863a4ab..11c0a597 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,10 +1,7 @@ module Main where -import Control.Monad import qualified System.Environment as SystemEnvironment -import System.IO (stdout) import System.Console.Haskeline (runInputT) -import System.Directory (doesPathExist, getHomeDirectory) import GHC.IO.Encoding import ColorText @@ -15,6 +12,7 @@ import StartingEnv import Eval import Util import Lookup +import Path defaultProject :: Project defaultProject = @@ -25,12 +23,10 @@ defaultProject = , projectFiles = [] , projectAlreadyLoaded = [] , projectEchoC = False - , projectLibDir = ".carp/libs/" - , projectCarpDir = "./" - , projectOutDir = case platform of - Windows -> ".\\out" - _ -> "./out" - , projectDocsDir = "./docs/" + , projectLibDir = "libs" + , projectCarpDir = "." + , projectOutDir = "out" + , projectDocsDir = "docs" , projectDocsLogo = "" , projectDocsPrelude = "" , projectDocsURL = "" @@ -80,9 +76,8 @@ main = do setLocaleEncoding utf8 "" execMode) context <- loadFiles startingContext coreModulesToLoad - home <- getHomeDirectory - let carpProfile = home ++ "/.carp/profile.carp" - hasProfile <- doesPathExist carpProfile + carpProfile <- configPath "profile.carp" + hasProfile <- doesFileExist carpProfile context' <- if hasProfile then loadFiles context [carpProfile] else do --putStrLn ("No '" ++ carpProfile ++ "' found.") diff --git a/headerparse/Main.hs b/headerparse/Main.hs index 85436349..4b534044 100644 --- a/headerparse/Main.hs +++ b/headerparse/Main.hs @@ -10,6 +10,7 @@ import Data.Char (toLower, isUpper) import Util import Types import Obj +import Path data Args = Args { sourcePath :: String , prefixToRemove :: String @@ -23,7 +24,7 @@ main = do parsedArgs <- cmdArgs (Args { sourcePath = def &= argPos 0 &= summary "Carp Header Parse 0.0.1") let path = sourcePath parsedArgs if path /= "" - then do source <- readFile path + then do source <- slurp path putStrLn (joinWith "\n" (map pretty (parseHeaderFile path source (prefixToRemove parsedArgs) (kebabCase parsedArgs)))) diff --git a/src/Commands.hs b/src/Commands.hs index bdb913ec..c6d9da72 100644 --- a/src/Commands.hs +++ b/src/Commands.hs @@ -1,14 +1,11 @@ module Commands where -import System.Directory import System.Info (os) import Control.Monad.State import Control.Monad.State.Lazy (StateT(..), runStateT, liftIO, modify, get, put) import Data.Maybe (fromMaybe) import Data.List (elemIndex) import System.Exit (exitSuccess, exitFailure, exitWith, ExitCode(..)) -import System.FilePath (takeDirectory) -import System.IO import System.Process (callCommand, spawnCommand, waitForProcess) import Control.Exception import qualified Data.Map as Map @@ -25,6 +22,7 @@ import Util import Lookup import RenderDocs import TypeError +import Path type CommandCallback = [XObj] -> StateT Context IO (Either (FilePathPrintLength -> EvalError) XObj) @@ -183,7 +181,7 @@ commandCat :: CommandCallback commandCat args = do ctx <- get let outDir = projectOutDir (contextProj ctx) - outMain = outDir ++ "/" ++ "main.c" + outMain = outDir "main.c" liftIO $ do callCommand ("cat -n " ++ outMain) return dynamicNil @@ -193,7 +191,8 @@ commandRunExe args = do ctx <- get let proj = contextProj ctx outDir = projectOutDir proj - outExe = "\"" ++ outDir ++ pathSeparator ++ projectTitle (contextProj ctx) ++ "\"" + quoted x = "\"" ++ x ++ "\"" + outExe = quoted $ outDir projectTitle (contextProj ctx) if projectCanExecute proj then liftIO $ do handle <- spawnCommand outExe exitCode <- waitForProcess handle @@ -232,10 +231,10 @@ commandBuild shutUp args = incl = projectIncludesToC proj includeCorePath = " -I" ++ projectCarpDir proj ++ "/core/ " flags = includeCorePath ++ projectFlags proj - outDir = projectOutDir proj ++ pathSeparator - outMain = outDir ++ "main.c" - outExe = outDir ++ projectTitle proj - outLib = outDir ++ projectTitle proj + outDir = projectOutDir proj + outMain = outDir "main.c" + outExe = outDir projectTitle proj + outLib = outDir projectTitle proj generateOnly = projectGenerateOnly proj liftIO $ createDirectoryIfMissing False outDir liftIO $ writeFile outMain (incl ++ okSrc) @@ -486,7 +485,7 @@ commandAddRelativeInclude [x] = XObj (Str file) i@(Just info) t -> let compiledFile = infoFile info in commandAddInclude RelativeInclude [ - XObj (Str $ (takeDirectory compiledFile) ++ "/" ++ file) i t + XObj (Str $ takeDirectory compiledFile file) i t ] _ -> return (Left (EvalError ("Argument to 'include' must be a string, but was `" ++ pretty x ++ "`") (info x))) @@ -806,7 +805,7 @@ commandReadFile :: CommandCallback commandReadFile [filename] = case filename of XObj (Str fname) _ _ -> do - exceptional <- liftIO $ ((try $ readFile fname) :: (IO (Either IOException String))) + exceptional <- liftIO $ ((try $ slurp fname) :: (IO (Either IOException String))) case exceptional of Right contents -> return (Right (XObj (Str contents) (Just dummyInfo) (Just StringTy))) diff --git a/src/Eval.hs b/src/Eval.hs index de17809d..164ca686 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -5,10 +5,7 @@ import Data.List.Split (splitOn, splitWhen) import Control.Monad.State import Control.Monad.State.Lazy (StateT(..), runStateT, liftIO, modify, get, put) import System.Exit (exitSuccess, exitFailure, exitWith, ExitCode(..)) -import qualified System.IO as SysIO -import System.Directory (doesFileExist, canonicalizePath, createDirectoryIfMissing, getCurrentDirectory, getHomeDirectory, setCurrentDirectory) -import System.FilePath (takeDirectory) -import System.Process (readProcess, readProcessWithExitCode) +import System.Process (readProcessWithExitCode) import Control.Concurrent (forkIO) import qualified Data.Map as Map import Data.Maybe (fromJust, mapMaybe, isJust, Maybe(..)) @@ -33,6 +30,7 @@ import Lookup import Qualify import TypeError import Concretize +import Path -- | Dynamic (REPL) evaluation of XObj:s (s-expressions) eval :: Env -> XObj -> StateT Context IO (Either EvalError XObj) @@ -1069,22 +1067,21 @@ specialCommandMetaGet path key = commandLoad :: CommandCallback commandLoad [xobj@(XObj (Str path) i _)] = do ctx <- get - home <- liftIO getHomeDirectory + let proj = contextProj ctx + libDir <- liftIO $ cachePath $ projectLibDir proj let relativeTo = case i of Just ii -> case infoFile ii of "REPL" -> "." file -> takeDirectory file Nothing -> "." - proj = contextProj ctx - libDir = home ++ "/" ++ projectLibDir proj carpDir = projectCarpDir proj fullSearchPaths = path : - (relativeTo ++ "/" ++ path) : -- the path from the file that contains the '(load)', or the current directory if not loading from a file (e.g. the repl) - map (++ "/" ++ path) (projectCarpSearchPaths proj) ++ -- user defined search paths - [carpDir ++ "/core/" ++ path] ++ - [libDir ++ "/" ++ path] + (relativeTo path) : -- the path from the file that contains the '(load)', or the current directory if not loading from a file (e.g. the repl) + map ( path) (projectCarpSearchPaths proj) ++ -- user defined search paths + [carpDir "core" path] ++ + [libDir path] firstM _ [] = return Nothing firstM p (x:xs) = do q <- p x @@ -1108,10 +1105,7 @@ commandLoad [xobj@(XObj (Str path) i _)] = if canonicalPath `elem` alreadyLoaded then return () - else do contents <- liftIO $ do - handle <- SysIO.openFile canonicalPath SysIO.ReadMode - SysIO.hSetEncoding handle SysIO.utf8 - SysIO.hGetContents handle + else do contents <- liftIO $ slurp canonicalPath let files = projectFiles proj files' = if canonicalPath `elem` files then files @@ -1152,19 +1146,17 @@ commandLoad [xobj@(XObj (Str path) i _)] = let split = splitOn "/" (replaceC ':' "_COLON_" url) fst = head split in if fst `elem` ["https:", "http:"] - then joinWith "/" (tail split) + then joinWith "/" $ tail $ tail split else if '@' `elem` fst then joinWith "/" (joinWith "@" (tail (splitOn "@" fst)) : tail split) else url tryInstallWithCheckout path toCheckout = do ctx <- get - home <- liftIO getHomeDirectory let proj = contextProj ctx - let libDir = home ++ "/" ++ projectLibDir proj - let fpath = libDir ++ "/" ++ fromURL path ++ "/" ++ toCheckout + fpath <- liftIO $ cachePath $ projectLibDir proj fromURL path toCheckout cur <- liftIO getCurrentDirectory - _ <- liftIO $ createDirectoryIfMissing True fpath + _ <- liftIO $ createDirectoryIfMissing True $ fpath _ <- liftIO $ setCurrentDirectory fpath (_, txt, _) <- liftIO $ readProcessWithExitCode "git" ["rev-parse", "--abbrev-ref=loose", "HEAD"] "" if txt == "HEAD\n" @@ -1192,8 +1184,8 @@ commandLoad [xobj@(XObj (Str path) i _)] = realName = if ".carp" `isSuffixOf` realName' then realName' else realName' ++ ".carp" - fileToLoad = fpath ++ "/" ++ realName - mainToLoad = fpath ++ "/main.carp" + fileToLoad = fpath realName + mainToLoad = fpath "main.carp" in do res <- commandLoad [XObj (Str fileToLoad) Nothing Nothing] case res of @@ -1222,7 +1214,7 @@ commandReload args = then return context else do - contents <- readFile filepath + contents <- slurp filepath let proj' = proj { projectAlreadyLoaded = filepath : alreadyLoaded } executeString False (context { contextProj = proj' }) contents filepath newCtx <- liftIO (foldM f ctx paths) diff --git a/src/Obj.hs b/src/Obj.hs index 7ad51d1a..f751a00e 100644 --- a/src/Obj.hs +++ b/src/Obj.hs @@ -1,6 +1,5 @@ module Obj where -import System.FilePath (takeFileName) import qualified Data.Map as Map import qualified Data.Set as Set import Data.List (intercalate, foldl') @@ -9,6 +8,7 @@ import Control.Monad.State import Data.Char import Types import Util +import Path (takeFileName) import Debug.Trace -- | Will the lookup look at other Carp code or at C code. This matters when calling functions, should they assume it's a lambda or a normal C function? diff --git a/src/Path.hs b/src/Path.hs new file mode 100644 index 00000000..fe8e16c3 --- /dev/null +++ b/src/Path.hs @@ -0,0 +1,48 @@ +module Path where +import Debug.Trace +import qualified System.Directory as D +import qualified System.FilePath.Posix as FP +import qualified System.IO as IO +import Util + +() :: FilePath -> FilePath -> FilePath +() = (FP.) + +cachePath :: FilePath -> IO FilePath +cachePath = xdgPath D.XdgCache + +canonicalizePath :: FilePath -> IO FilePath +canonicalizePath = fmap toStandard . D.canonicalizePath . toNative + +configPath :: FilePath -> IO FilePath +configPath = xdgPath D.XdgConfig + +createDirectoryIfMissing :: Bool -> FilePath -> IO () +createDirectoryIfMissing b = D.createDirectoryIfMissing b . toNative + +doesFileExist :: FilePath -> IO Bool +doesFileExist = D.doesFileExist . toNative + +getCurrentDirectory :: IO FilePath +getCurrentDirectory = toStandard <$> D.getCurrentDirectory + +slurp :: FilePath -> IO String +slurp = IO.readFile . toNative + +setCurrentDirectory :: FilePath -> IO () +setCurrentDirectory = D.setCurrentDirectory . toNative + +takeDirectory :: FilePath -> FilePath +takeDirectory = FP.takeDirectory + +takeFileName :: FilePath -> FilePath +takeFileName = FP.takeFileName + +toNative :: FilePath -> FilePath +toNative = if platform == Windows then map (\x -> if x == '/' then '\\' else x) else id + +toStandard :: FilePath -> FilePath +toStandard = if platform == Windows then map (\x -> if x == '\\' then '/' else x) else id + +xdgPath :: D.XdgDirectory -> FilePath -> IO FilePath +xdgPath t = fmap toStandard . D.getXdgDirectory t . () "carp" . toNative diff --git a/src/RenderDocs.hs b/src/RenderDocs.hs index ca6e667e..0351cffb 100644 --- a/src/RenderDocs.hs +++ b/src/RenderDocs.hs @@ -10,15 +10,14 @@ import Text.Blaze.Html.Renderer.Pretty (renderHtml) import Text.Blaze.Internal (stringValue) import Data.Maybe (fromMaybe) import Data.Text.Lazy as T -import Data.Text.Lazy.Encoding as E import Data.Text as Text -import System.Directory import qualified Data.Map as Map import Debug.Trace import Obj import Types import Util +import Path saveDocsForEnvs :: Project -> [(SymPath, Binder)] -> IO () saveDocsForEnvs ctx pathsAndEnvBinders = @@ -27,7 +26,7 @@ saveDocsForEnvs ctx pathsAndEnvBinders = generateIndex = projectDocsGenerateIndex ctx allEnvNames = fmap (getModuleName . fst . getEnvAndMetaFromBinder . snd) pathsAndEnvBinders in do mapM_ (saveDocsForEnvBinder ctx allEnvNames) pathsAndEnvBinders - when generateIndex (writeFile (dir ++ "/" ++ title ++ "_index.html") + when generateIndex (writeFile (dir title ++ "_index.html") (projectIndexPage ctx allEnvNames)) putStrLn ("Generated docs to '" ++ dir ++ "'") @@ -72,7 +71,7 @@ saveDocsForEnvBinder :: Project -> [String] -> (SymPath, Binder) -> IO () saveDocsForEnvBinder ctx moduleNames (pathToEnv, envBinder) = do let SymPath _ moduleName = pathToEnv dir = projectDocsDir ctx - fullPath = dir ++ "/" ++ moduleName ++ ".html" + fullPath = dir moduleName ++ ".html" string = renderHtml (envBinderToHtml envBinder ctx (show pathToEnv) moduleNames) createDirectoryIfMissing False dir writeFile fullPath string diff --git a/src/Repl.hs b/src/Repl.hs index 27ffe2a9..d602c00d 100644 --- a/src/Repl.hs +++ b/src/Repl.hs @@ -9,8 +9,6 @@ import System.Console.Haskeline ( getInputLine , completeWordWithPrev ) import Data.List (isPrefixOf) -import System.Info (os) -import System.Directory (getHomeDirectory) import Control.Monad.IO.Class (liftIO) import Types @@ -18,6 +16,7 @@ import Obj import Util import ColorText import Eval +import Path import Parsing (balance) completeKeywordsAnd :: Monad m => [String ] -> String -> String -> m [Completion] @@ -69,10 +68,10 @@ completeKeywordsAnd words _ word = return $ findKeywords word (words ++ keywords readlineSettings :: Monad m => [String] -> IO (Settings m) readlineSettings words = do - home <- getHomeDirectory + historyFile <- configPath "history" return $ Settings { complete = completeWordWithPrev Nothing ['(', ')', '[', ']', ' ', '\t', '\n'] (completeKeywordsAnd words), - historyFile = Just $ home ++ "/.carp/history", + historyFile = Just historyFile, autoAddHistory = True } diff --git a/src/Util.hs b/src/Util.hs index b1e2f1fd..83e4482b 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -70,12 +70,6 @@ platform = "darwin" -> MacOS "mingw32" -> Windows -pathSeparator :: String -pathSeparator = - case platform of - Windows -> "\\" - _ -> "/" - unionOfSetsInList (x:xs) = foldl' Set.union x xs unionOfSetsInList [] =