diff --git a/builder/src/AbsoluteSrcDir.hs b/builder/src/AbsoluteSrcDir.hs new file mode 100644 index 00000000..9e642083 --- /dev/null +++ b/builder/src/AbsoluteSrcDir.hs @@ -0,0 +1,25 @@ +module AbsoluteSrcDir + ( AbsoluteSrcDir (..), + mkAbsoluteSrcDir, + addRelative, + toFilePath, + ) +where + +import qualified System.Directory as Dir +import System.FilePath (()) + +newtype AbsoluteSrcDir + = AbsoluteSrcDir FilePath + +toFilePath :: AbsoluteSrcDir -> FilePath +toFilePath (AbsoluteSrcDir path) = path + +mkAbsoluteSrcDir :: FilePath -> IO AbsoluteSrcDir +mkAbsoluteSrcDir srcDir = + AbsoluteSrcDir + <$> Dir.canonicalizePath srcDir + +addRelative :: AbsoluteSrcDir -> FilePath -> FilePath +addRelative (AbsoluteSrcDir srcDir) path = + srcDir path diff --git a/builder/src/Build.hs b/builder/src/Build.hs index 95637994..c6cbc315 100644 --- a/builder/src/Build.hs +++ b/builder/src/Build.hs @@ -20,6 +20,8 @@ where import qualified AST.Canonical as Can import qualified AST.Optimized as Opt import qualified AST.Source as Src +import AbsoluteSrcDir (AbsoluteSrcDir (..)) +import qualified AbsoluteSrcDir import qualified Compile import Control.Concurrent (forkIO) import Control.Concurrent.MVar @@ -75,31 +77,13 @@ makeEnv key root (Details.Details _ validOutline buildID locals foreigns _) = case validOutline of Details.ValidApp givenSrcDirs -> do - srcDirs <- traverse (toAbsoluteSrcDir root) (NE.toList givenSrcDirs) + srcDirs <- traverse (Outline.toAbsoluteSrcDir root) (NE.toList givenSrcDirs) return $ Env key root Parse.Application srcDirs buildID locals foreigns Details.ValidPkg pkg _ _ -> do - srcDir <- toAbsoluteSrcDir root (Outline.RelativeSrcDir "src") + srcDir <- Outline.toAbsoluteSrcDir root (Outline.RelativeSrcDir "src") return $ Env key root (Parse.Package pkg) [srcDir] buildID locals foreigns --- SOURCE DIRECTORY - -newtype AbsoluteSrcDir - = AbsoluteSrcDir FilePath - -toAbsoluteSrcDir :: FilePath -> Outline.SrcDir -> IO AbsoluteSrcDir -toAbsoluteSrcDir root srcDir = - AbsoluteSrcDir - <$> Dir.canonicalizePath - ( case srcDir of - Outline.AbsoluteSrcDir dir -> dir - Outline.RelativeSrcDir dir -> root dir - ) - -addRelative :: AbsoluteSrcDir -> FilePath -> FilePath -addRelative (AbsoluteSrcDir srcDir) path = - srcDir path - -- FORK -- PERF try using IORef semephore on file crawl phase? @@ -242,7 +226,7 @@ crawlModule env@(Env _ root projectType srcDirs buildID locals foreigns) mvar do do let fileName = ModuleName.toFilePath name <.> "gren" - paths <- filterM File.exists (map (`addRelative` fileName) srcDirs) + paths <- filterM File.exists (map (`AbsoluteSrcDir.addRelative` fileName) srcDirs) case paths of [path] -> @@ -899,8 +883,8 @@ getRootInfoHelp (Env _ _ _ srcDirs _ _ _) path absolutePath = case matchingDirs of d1 : d2 : _ -> do - let p1 = addRelative d1 (FP.joinPath names <.> "gren") - let p2 = addRelative d2 (FP.joinPath names <.> "gren") + let p1 = AbsoluteSrcDir.addRelative d1 (FP.joinPath names <.> "gren") + let p2 = AbsoluteSrcDir.addRelative d2 (FP.joinPath names <.> "gren") return $ Left $ Exit.BP_RootNameDuplicate name p1 p2 _ -> return $ Right $ RootInfo absolutePath path (LInside name) @@ -911,7 +895,7 @@ getRootInfoHelp (Env _ _ _ srcDirs _ _ _) path absolutePath = isInsideSrcDirByName :: [String] -> AbsoluteSrcDir -> IO Bool isInsideSrcDirByName names srcDir = - File.exists (addRelative srcDir (FP.joinPath names <.> "gren")) + File.exists (AbsoluteSrcDir.addRelative srcDir (FP.joinPath names <.> "gren")) isInsideSrcDirByPath :: [String] -> AbsoluteSrcDir -> Maybe (FilePath, Either [String] [String]) isInsideSrcDirByPath segments (AbsoluteSrcDir srcDir) = diff --git a/builder/src/Gren/Outline.hs b/builder/src/Gren/Outline.hs index 89aec76a..d8148a42 100644 --- a/builder/src/Gren/Outline.hs +++ b/builder/src/Gren/Outline.hs @@ -14,9 +14,14 @@ module Gren.Outline decoder, defaultSummary, flattenExposed, + toAbsoluteSrcDir, + sourceDirs, + testDirs, ) where +import AbsoluteSrcDir (AbsoluteSrcDir) +import qualified AbsoluteSrcDir import Control.Monad (filterM, liftM) import Data.Binary (Binary, get, getWord8, put, putWord8) import qualified Data.Map as Map @@ -204,6 +209,10 @@ toAbsolute root srcDir = AbsoluteSrcDir dir -> dir RelativeSrcDir dir -> root dir +toAbsoluteSrcDir :: FilePath -> SrcDir -> IO AbsoluteSrcDir +toAbsoluteSrcDir root srcDir = + AbsoluteSrcDir.mkAbsoluteSrcDir (toAbsolute root srcDir) + detectDuplicates :: FilePath -> [SrcDir] -> IO (Maybe (FilePath, (FilePath, FilePath))) detectDuplicates root srcDirs = do @@ -225,6 +234,18 @@ isDup paths = OneOrMore.One _ -> Nothing OneOrMore.More a b -> Just (OneOrMore.getFirstTwo a b) +sourceDirs :: Outline -> NE.List SrcDir +sourceDirs outline = + case outline of + App (AppOutline _ srcDirs _ _ _ _) -> + srcDirs + Pkg _ -> + NE.singleton (RelativeSrcDir "src") + +testDirs :: Outline -> NE.List SrcDir +testDirs _ = + NE.singleton (RelativeSrcDir "tests") + -- JSON DECODE type Decoder a = diff --git a/gren.cabal b/gren.cabal index 8deb0da3..830ff1e1 100644 --- a/gren.cabal +++ b/gren.cabal @@ -68,6 +68,7 @@ Executable gren Terminal.Internal -- from builder/ + AbsoluteSrcDir Build BackgroundWriter Deps.Diff