From 705fa21d674a5a799712346e01033db98b16e71d Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Sun, 10 Mar 2019 17:36:32 +0000 Subject: 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. --- hadrian/src/Hadrian/Utilities.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) (limited to 'hadrian/src/Hadrian') 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 == "../../" - 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 == "../../" + error $ "Impossible to find relatieve path from " ++ a ++ " to " ++ b - else".." <$ baseToA + _ -> ".." <$ baseToA aToB = aToBase ++ baseToB -- removePrefix "pre123" "prefix456" == ("123", "fix456") -- cgit v1.2.1