a year went byHEADmain

This does many meta-things, but changes no functionality:
 - get rid of stack, and use just cabal with a stackage snapshot instead
   (why did I ever think stack was a good idea?)
 - update the stackage snapshot to something halfway recent
 - thus making builds work on nixpkgs-23.05 (current stable)
 - separating out packages into their own cabal files
 - use the GHC2021 set of extensions as default
 - very slight code changes to make things build again
 - update readme accordingly
 - stylish-haskell run

1 files changed, 86 insertions, 0 deletions

diff --git a/walint/Paths.hs b/walint/Paths.hs
new file mode 100644
index 0000000..f4dc3ed
--- /dev/null
+++ b/walint/Paths.hs
@@ -0,0 +1,86 @@
+{-# 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