Skip to content

Commit

Permalink
better handling of filenames vs module names when importing absolute …
Browse files Browse the repository at this point in the history
…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.
  • Loading branch information
daanx committed Jan 21, 2024

Verified

This commit was created on GitHub.com and signed with GitHub’s verified signature. The key has expired.
1 parent 311cf1f commit f58c61f
Showing 3 changed files with 65 additions and 29 deletions.
50 changes: 37 additions & 13 deletions src/Common/File.hs
Original file line number Diff line number Diff line change
@@ -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]
38 changes: 25 additions & 13 deletions src/Compiler/Compile.hs
Original file line number Diff line number Diff line change
@@ -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

6 changes: 3 additions & 3 deletions src/Core/Pretty.hs
Original file line number Diff line number Diff line change
@@ -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)

0 comments on commit f58c61f

Please sign in to comment.