carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-09-17 08:27:45 +03:00
Code Issues Projects Releases Wiki Activity

Path module.

Browse Source
This commit is contained in:
Jorge Acereda 2019-09-23 23:47:26 +02:00
parent 1b8656cd4f
commit 28104b0fb2
10 changed files with 91 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
CarpHask.cabal
View File

@ -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

19
app/Main.hs
View File

@ -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.")

3
headerparse/Main.hs
View File

@ -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))))

21
src/Commands.hs
View File

@ -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)))

38
src/Eval.hs
View File

@ -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)

2
src/Obj.hs
View File

@ -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?

48
src/Path.hs Normal file
View File

@ -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

7
src/RenderDocs.hs
View File

@ -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

7
src/Repl.hs
View File

@ -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
}

6
src/Util.hs
View File

@ -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 [] =