summaryrefslogtreecommitdiff
path: root/lib/Paths.hs
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Paths.hs')
-rw-r--r--lib/Paths.hs86
1 files changed, 0 insertions, 86 deletions
diff --git a/lib/Paths.hs b/lib/Paths.hs
deleted file mode 100644
index f4dc3ed..0000000
--- a/lib/Paths.hs
+++ /dev/null
@@ -1,86 +0,0 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE OverloadedStrings #-}
-
--- | Paths are horrible, so they have their own module now.
--- I just hope you are running this on some kind of Unix
-module Paths where
-
-import Universum
-import qualified Universum.Unsafe as Unsafe
-
-import qualified Data.Text as T
-import System.FilePath (splitPath)
-import System.FilePath.Posix ((</>))
-import Text.Regex.TDFA
-import Util (PrettyPrint (prettyprint))
-
-
--- | a normalised path: a number of "upwards" steps, and
--- a path without any . or .. in it. Also possibly a
--- fragment, mostly for map links.
-data RelPath = Path Int Text (Maybe Text)
- deriving (Show, Eq, Ord, NFData, Generic)
-
-
-
-data PathResult = OkRelPath RelPath
- | AbsolutePath
- | NotAPath
- | UnderscoreMapLink
- | AtMapLink
- | PathVarsDisallowed
-
--- | horrible regex parsing for filepaths that is hopefully kinda safe
-parsePath :: Text -> PathResult
-parsePath text =
- if | T.isInfixOf "{{" text || T.isInfixOf "}}" text -> PathVarsDisallowed
- | rest =~ ("^([^/]*[^\\./]/)*[^/]*[^\\./]$" :: Text) -> OkRelPath (Path up path fragment)
- | "/_/" `T.isPrefixOf` text -> UnderscoreMapLink
- | "/@/" `T.isPrefixOf` text -> AtMapLink
- | "/" `T.isPrefixOf` text -> AbsolutePath
- | otherwise -> NotAPath
- where
- (_, prefix, rest, _) =
- text =~ ("^((\\.|\\.\\.)/)*" :: Text) :: (Text, Text, Text, [Text])
- -- how many steps upwards in the tree?
- up = length . filter (".." ==) . T.splitOn "/" $ prefix
- parts = T.splitOn "#" rest
- -- `head` is unsafe, but splitOn will always produce lists with at least one element
- path = Unsafe.head parts
- fragment = case nonEmpty parts of
- Nothing -> Nothing
- Just p -> Just $ T.concat $ tail p
-
-instance PrettyPrint RelPath where
- prettyprint (Path up rest frag) = ups <> rest <> fragment
- where ups = T.concat $ replicate up "../"
- fragment = maybe mempty ("#" <>) frag
-
--- | Normalises a path.
---
--- It takes a `prefix`, and will "truncate" the .. operator
--- at the end of the prefix, i.e. it will never return paths
--- that lie (naïvely) outside of the prefix.
-normalise :: FilePath -> RelPath -> FilePath
-normalise prefix (Path 0 path _) = prefix </> toString path
-normalise prefix (Path i path _) =
- concat (take (length dirs - i) dirs) </> toString path
- where dirs = splitPath prefix
-
-normaliseWithFrag :: FilePath -> RelPath -> FilePath
-normaliseWithFrag prefix (Path i path frag) =
- normalise prefix (Path (i+1) path frag) <> toString (maybe mempty ("#" <>) frag)
-
--- | does this path contain an old-style pattern for inter-repository
--- links as was used at rc3 in 2020?
-isOldStyle :: RelPath -> Bool
-isOldStyle (Path _ text frag) = path =~ ("{<.+>*}" :: Text)
- where path = case frag of
- Just f -> text <> f
- _ -> text
-
-getExtension :: RelPath -> Text
-getExtension (Path _ text _) = maybe "" last (nonEmpty splitted)
- where splitted = T.splitOn "." text