diff options
| author | Matthew Pickering <matthewtpickering@gmail.com> | 2019-03-10 17:36:32 +0000 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2019-03-12 09:04:52 -0400 |
| commit | 705fa21d674a5a799712346e01033db98b16e71d (patch) | |
| tree | d8ba5f033336c62968c81c1b71e5180cb8b232db | |
| parent | 61264556d5c817b55332a199b03fa1f559e92ee2 (diff) | |
| download | haskell-705fa21d674a5a799712346e01033db98b16e71d.tar.gz | |
Hadrian: Make makeRelativeNoSysLink total
makeRelativeNoSysLink would previously crash for no reason if the first
argument as `./` due to the call to `head`. This refactoring keeps the
behaviour the same but doesn't crash in this corner case.
| -rw-r--r-- | hadrian/src/Hadrian/Utilities.hs | 15 |
1 files changed, 8 insertions, 7 deletions
diff --git a/hadrian/src/Hadrian/Utilities.hs b/hadrian/src/Hadrian/Utilities.hs index e5fc712512..42a6fffe1d 100644 --- a/hadrian/src/Hadrian/Utilities.hs +++ b/hadrian/src/Hadrian/Utilities.hs @@ -166,14 +166,15 @@ makeRelativeNoSysLink a b -- Use removePrefix to get the relative paths relative to a new -- base directory as high in the directory tree as possible. (baseToA, baseToB) = removePrefix aRelSplit bRelSplit - aToBase = if isDirUp (head baseToA) - -- if baseToA contains any '..' then there is no way to get - -- a path from a to the base directory. - -- E.g. if baseToA == "../u/v" - -- then aToBase == "../../<UnknownDir>" - then error $ "Impossible to find relatieve path from " + aToBase = case baseToA of + (p: _) | isDirUp p -> + -- if baseToA contains any '..' then there is no way to get + -- a path from a to the base directory. + -- E.g. if baseToA == "../u/v" + -- then aToBase == "../../<UnknownDir>" + error $ "Impossible to find relatieve path from " ++ a ++ " to " ++ b - else".." <$ baseToA + _ -> ".." <$ baseToA aToB = aToBase ++ baseToB -- removePrefix "pre123" "prefix456" == ("123", "fix456") |