From f58c61ffa53dac7555816daf0311a016144be7d5 Mon Sep 17 00:00:00 2001 From: daanx Date: Sat, 20 Jan 2024 21:02:01 -0800 Subject: [PATCH] better handling of filenames vs module names when importing absolute paths or path with chararcters that are not allowed in a module name. If there is no valid module path up-to the include path roots we only keep the module name as declared. --- src/Common/File.hs | 50 ++++++++++++++++++++++++++++++----------- src/Compiler/Compile.hs | 38 ++++++++++++++++++++----------- src/Core/Pretty.hs | 6 ++--- 3 files changed, 65 insertions(+), 29 deletions(-) diff --git a/src/Common/File.hs b/src/Common/File.hs index e92a61eae..aa88dba6c 100644 --- a/src/Common/File.hs +++ b/src/Common/File.hs @@ -25,7 +25,7 @@ module Common.File( , basename, notdir, notext, joinPath, joinPaths, extname, dirname, noexts , splitPath, undelimPaths , isPathSep, isPathDelimiter - , findMaximalPrefix + , findMaximalPrefixPath , isAbsolute , commonPathPrefix , normalizeWith, normalize @@ -47,7 +47,7 @@ module Common.File( , relativeToPath ) where -import Data.List ( intersperse, isPrefixOf ) +import Data.List ( intersperse, isPrefixOf, maximumBy ) import Data.Char ( toLower, isSpace ) import Platform.Config ( pathSep, pathDelimiter, sourceExtension, exeExtension ) import qualified Platform.Runtime as B ( {- copyBinaryFile, -} exCatch ) @@ -312,7 +312,7 @@ readTextFile :: FilePath -> IO (Maybe String) readTextFile fpath = B.exCatch (do content <- readFile fpath return (if null content then Just content else (seq (last content) $ Just content))) - (\exn -> -- trace ("reading file " ++ fpath ++ " exception: " ++ exn) + (\exn -> -- trace ("reading file " ++ fpath ++ " exception: " ++ exn) return Nothing) writeTextFile :: FilePath -> String -> IO () @@ -398,11 +398,20 @@ commonPathPrefix s1 s2 relativeToPath :: FilePath -> FilePath -> FilePath -relativeToPath "" path = path relativeToPath prefix path + = case mbRelativeToPath prefix path of + Just relpath -> relpath + Nothing -> path + +mbRelativeToPath :: FilePath -> FilePath -> Maybe FilePath +mbRelativeToPath "" path = Just path +mbRelativeToPath prefix path = let prefixes = splitPath prefix paths = splitPath path - in if isPrefixOf prefixes paths then joinPaths (drop (length prefixes) paths) else path + in if isPrefixOf prefixes paths then Just (joinPaths (drop (length prefixes) paths)) else Nothing + + + -- | Is a path absolute? isAbsolute :: FilePath -> Bool @@ -412,6 +421,19 @@ isAbsolute fpath ('/':_) -> True _ -> False + +-- | Find a maximal prefix path given a path and list of root paths. Returns the root path and relative path. +findMaximalPrefixPath :: [FilePath] -> FilePath -> Maybe (FilePath,FilePath) +findMaximalPrefixPath roots p + = let rels = concatMap (\r -> case mbRelativeToPath r p of + Just rel -> [(r,rel)] + _ -> []) roots + in case rels of + [] -> Nothing + xs -> Just (maximumBy (\(root1,_) (root2,_) -> compare root1 root2) xs) + +{- + -- | Find a maximal prefix given a string and list of prefixes. Returns the prefix and its length. findMaximalPrefix :: [String] -> String -> Maybe (Int,String) findMaximalPrefix xs s @@ -428,6 +450,8 @@ findMaximal f xs _ -> normalize (Just (n,x)) xs Nothing -> normalize res xs +-} + --------------------------------------------------------------- -- file searching ---------------------------------------------------------------- @@ -453,9 +477,10 @@ searchPathsCanonical paths exts suffixes name ; if exist then do rpath <- realPath fullName -- trace ("search found: " ++ fullName ++ ", in (" ++ dir ++ "," ++ fname ++ ") ,real path: " ++ rpath) $ - case findMaximalPrefix paths rpath of - Just (n,root) -> return (Just (root,drop n rpath)) - Nothing -> return (Just ("",rpath)) + case (findMaximalPrefixPath paths rpath) of + Nothing -> -- absolute path outside the paths + return (Just ("",rpath)) + just -> return just else search xs } @@ -490,11 +515,10 @@ searchPathsEx path exts suffixes name -- if it is not relative to the paths, return dirname/notdir makeRelativeToPaths :: [FilePath] -> FilePath -> (FilePath,FilePath) makeRelativeToPaths paths fname - = let (root,stem) = case findMaximalPrefix paths fname of - Just (n,root) -> (root,drop n fname) - _ -> ("", fname) - in -- trace ("relative path of " ++ fname ++ " with paths " ++ show paths ++ " = " ++ show (root,stem)) $ - (root,stem) + = case findMaximalPrefixPath paths fname of + Just (root,rpath) -> (root,rpath) + _ -> (dirname fname, notdir fname) + getEnvPaths :: String -> IO [FilePath] diff --git a/src/Compiler/Compile.hs b/src/Compiler/Compile.hs index 29990a985..811828259 100644 --- a/src/Compiler/Compile.hs +++ b/src/Compiler/Compile.hs @@ -31,7 +31,7 @@ module Compiler.Compile( -- * Compile ) where import Debug.Trace ( trace ) -import Data.Char ( isAlphaNum, toLower, isSpace ) +import Data.Char ( isAlphaNum, toLower, isSpace, isLower ) import System.Directory ( createDirectoryIfMissing, canonicalizePath, getCurrentDirectory, doesDirectoryExist ) import Data.Maybe ( catMaybes, fromJust ) @@ -354,15 +354,19 @@ compileProgramFromFile maybeContents contents term flags modules compileTarget i liftIO $ termPhase term ("parsing " ++ fname) exist <- liftIO $ doesFileExist fname if (exist) then return () else liftError $ errorMsg (errorFileNotFound flags fname) - let allowAt = stem `elem` ["/std/core/types.kk","/std/core/hnd.kk"] {- allow @ in identifiers? -} + let allowAt = stem `elem` ["std/core/types.kk","std/core/hnd.kk"] {- allow @ in identifiers? -} program <- lift $ case contents of Just x -> return $ parseProgramFromString allowAt (semiInsert flags) x fname _ -> parseProgramFromFile allowAt (semiInsert flags) fname - let isSuffix = -- asciiEncode True (noexts stem) `endsWith` asciiEncode True (show (programName program)) - -- map (\c -> if isPathSep c then '/' else c) (noexts stem) - show (pathToModuleName (noexts stem)) `endsWith` show (programName program) - -- map (\c -> if isPathSep c then '/' else c) (noexts stem) - -- `endsWith` moduleNameToPath (programName program) + let stemParts = splitPath (noexts stem) + mnameParts = splitPath (show (programName program)) + isSuffix = reverse mnameParts `isPrefixOf` reverse stemParts + -- asciiEncode True (noexts stem) `endsWith` asciiEncode True (show (programName program)) + -- map (\c -> if isPathSep c then '/' else c) (noexts stem) + -- show (pathToModuleName (noexts stem)) `endsWith` show (programName program) + -- map (\c -> if isPathSep c then '/' else c) (noexts stem) + -- `endsWith` moduleNameToPath (programName program) + ppcolor c doc = color (c (colors (prettyEnvFromFlags flags))) doc if (isExecutable compileTarget || isSuffix) then return () else liftError $ errorMsg (ErrorGeneral (programNameRange program) @@ -371,13 +375,19 @@ compileProgramFromFile maybeContents contents term flags modules compileTarget i text "is not a suffix of the file path" <+> parens (ppcolor colorSource $ text $ dquote $ stem) )) - let stemName = nameFromFile stem - -- let flags2 = flags{forceModule = fname} + let stemName = -- nameFromFile stem + if isAbsolute stem || any (not . isValidId) stemParts + then programName program -- we may not be able to find this source from the module name alone + else newModuleName (noexts stem) + where + isValidId :: String -> Bool + isValidId "" = False + isValidId (c:cs) = isLower c && all (\c -> isAlphaNum c || c `elem` "_-") cs + + -- let flags2 = flags{forceModule = fname} + -- trace ("compile: (root,stem)=" ++ show (rootPath,stem) ++ ", modname:" ++ show (programName program) ++ ", stemName: " ++ show stemName) $ compileProgram' maybeContents term flags modules compileTarget fname program{ programName = stemName } importPath -nameFromFile :: FilePath -> Name -nameFromFile fname - = pathToModuleName $ dropWhile isPathSep $ noexts fname data CompileTarget a = Object @@ -808,11 +818,13 @@ searchSource flags currentDir name searchSourceFile :: Flags -> FilePath -> FilePath -> IO (Maybe (FilePath,FilePath)) searchSourceFile flags currentDir fname = do -- trace ("search source: " ++ fname ++ " from " ++ concat (intersperse ", " (currentDir:includePath flags))) $ return () + -- currentDir is set when importing from a module so a module name is first resolved relative to + -- the current module extra <- if null currentDir then return [] else do{ d <- realPath currentDir; return [d] } mbP <- searchPathsCanonical (extra ++ includePath flags) [sourceExtension,sourceExtension++".md"] [] fname case mbP of - Just (root,stem) | root == currentDir + Just (root,stem) | root == currentDir -- make a relative module now relative to the include path -> return $ Just (makeRelativeToPaths (includePath flags) (joinPath root stem)) _ -> return mbP diff --git a/src/Core/Pretty.hs b/src/Core/Pretty.hs index ac02c7799..3114df9d4 100644 --- a/src/Core/Pretty.hs +++ b/src/Core/Pretty.hs @@ -59,11 +59,11 @@ instance Show Pattern where show = show . snd . prettyPattern defaultEnv --------------------------------------------------------------------------} prettyCore :: Env -> Target -> [InlineDef] -> Core -> Doc -prettyCore env0 target inlineDefs core@(Core name imports fixDefs typeDefGroups defGroups externals doc) +prettyCore env0 target inlineDefs core@(Core modName imports fixDefs typeDefGroups defGroups externals doc) = prettyComment env doc $ keyword env "module" <+> - (if (coreIface env) then text "interface " else empty) <.> - prettyModuleName env name <-> + (if (coreIface env) then text "interface" <+> prettyModuleName env modName -- text (moduleNameToPath modName) + else prettyModuleName env modName) <-> (vcat $ concat $ [ separator "import declarations" , map (prettyImport envX) (imports)