diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2023 Nikita Volkov + +Permission is hereby granted, free of charge, to any person +obtaining a copy of this software and associated documentation +files (the "Software"), to deal in the Software without +restriction, including without limitation the rights to use, +copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. diff --git a/algebraic-path.cabal b/algebraic-path.cabal new file mode 100644 --- /dev/null +++ b/algebraic-path.cabal @@ -0,0 +1,147 @@ +cabal-version: 3.0 +name: algebraic-path +version: 0.1 +synopsis: Flexible and simple path manipulation library +description: + Path library that: + + - Models paths in canonical form + - Makes paths monoidally composable and provides a rich algebra + - Avoids type-level wizardry + - Doesn't target Windows thus maintaining focus and avoiding quirks + +category: Path, FilePath, Filesystem +author: Nikita Volkov +maintainer: Nikita Volkov +copyright: (c) 2023 Nikita Volkov +license: MIT +license-file: LICENSE + +source-repository head + type: git + location: https://github.com/nikita-volkov/algebraic-path + +common base + default-language: Haskell2010 + default-extensions: + ApplicativeDo + Arrows + BangPatterns + BinaryLiterals + BlockArguments + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingVia + DuplicateRecordFields + EmptyCase + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + HexFloatLiterals + ImportQualifiedPost + LambdaCase + LiberalTypeSynonyms + MultiParamTypeClasses + MultiWayIf + NoImplicitPrelude + NoMonomorphismRestriction + NumericUnderscores + OverloadedStrings + ParallelListComp + PatternGuards + PatternSynonyms + QuasiQuotes + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + StrictData + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + UndecidableInstances + ViewPatterns + +common executable + import: base + ghc-options: + -O2 + -threaded + -with-rtsopts=-N + -rtsopts + -funbox-strict-fields + +common test + import: base + ghc-options: + -threaded + -with-rtsopts=-N + +library + import: base + hs-source-dirs: src/library + exposed-modules: AlgebraicPath + other-modules: + build-depends: + QuickCheck >=2.14 && <3, + algebraic-path:ast, + algebraic-path:util, + attoparsec >=0.13 && <0.15, + base >=4.14 && <5, + text-builder ^>=1.0, + +library ast + import: base + hs-source-dirs: src/ast + exposed-modules: + AlgebraicPath.Ast.Component + AlgebraicPath.Ast.Name + AlgebraicPath.Ast.Path + + other-modules: + AlgebraicPath.Ast.Name.NameSegment + + build-depends: + QuickCheck >=2.14 && <3, + algebraic-path:util, + attoparsec >=0.13 && <0.15, + natural-sort ^>=0.1.2, + rerebase >=1.21 && <2, + text-builder ^>=1.0, + +library util + import: base + hs-source-dirs: src/util + exposed-modules: + AlgebraicPath.Util.List + AlgebraicPath.Util.MonadPlus + AlgebraicPath.Util.Prelude + + build-depends: + QuickCheck >=2.14 && <3, + base >=4.14 && <5, + hashable >=1.3 && <2, + text >=1.2 && <3, + +test-suite tests + import: test + type: exitcode-stdio-1.0 + hs-source-dirs: src/tests + main-is: Main.hs + build-depends: + algebraic-path, + hspec ^>=2.11.12, + quickcheck-classes ^>=0.6.5.0, + rerebase >=1.21 && <2, diff --git a/src/ast/AlgebraicPath/Ast/Component.hs b/src/ast/AlgebraicPath/Ast/Component.hs new file mode 100644 --- /dev/null +++ b/src/ast/AlgebraicPath/Ast/Component.hs @@ -0,0 +1,37 @@ +module AlgebraicPath.Ast.Component + ( Component (..), + attoparsecParserOf, + toTextBuilder, + ) +where + +import AlgebraicPath.Ast.Name qualified as Name +import Data.Attoparsec.Text qualified as Attoparsec +import TextBuilder qualified +import Prelude + +data Component + = NameComponent Name.Name + | DotComponent + | DotDotComponent + +attoparsecParserOf :: Attoparsec.Parser Component +attoparsecParserOf = do + name <- Name.attoparsecParserOf + if Name.null name + then do + mplus + ( do + _ <- Attoparsec.char '.' + mplus + (Attoparsec.char '.' $> DotDotComponent) + (pure DotComponent) + ) + (pure (NameComponent name)) + else pure (NameComponent name) + +toTextBuilder :: Component -> TextBuilder.TextBuilder +toTextBuilder = \case + NameComponent name -> Name.toTextBuilder name + DotComponent -> "." + DotDotComponent -> ".." diff --git a/src/ast/AlgebraicPath/Ast/Name.hs b/src/ast/AlgebraicPath/Ast/Name.hs new file mode 100644 --- /dev/null +++ b/src/ast/AlgebraicPath/Ast/Name.hs @@ -0,0 +1,155 @@ +module AlgebraicPath.Ast.Name + ( Name, + + -- * Constructors + empty, + mapExtensions, + + -- * Functors + traverseExtensions, + attoparsecParserOf, + + -- * Destructors + null, + toTextBuilder, + toText, + toBase, + toExtensions, + ) +where + +import AlgebraicPath.Ast.Name.NameSegment qualified as NameSegment +import AlgebraicPath.Util.MonadPlus +import AlgebraicPath.Util.Prelude hiding (empty, null) +import Algorithms.NaturalSort qualified as NaturalSort +import Data.Attoparsec.Text qualified as Attoparsec +import Data.List qualified as List +import Data.Text qualified as Text +import Test.QuickCheck qualified as QuickCheck +import TextBuilder qualified + +-- | +-- Structured base of a single component of a path. +data Name = Name + { -- | Name. + base :: Text, + -- | Extensions in reverse order. + extensions :: [Text] + } + deriving (Eq, Show) + +instance QuickCheck.Arbitrary Name where + arbitrary = do + base <- + QuickCheck.oneof + [ NameSegment.toText <$> arbitrary, + pure "" + ] + extensions <- fmap NameSegment.toText <$> arbitrary + pure (Name base extensions) + shrink (Name base extensions) = + QuickCheck.shrink + ( Text.unpack base, + Text.unpack <$> extensions + ) + <&> \(base, extensions) -> + Name + (Text.pack base) + (List.filter (not . Text.null) (Text.pack <$> extensions)) + +instance Ord Name where + compare l r = + if la == ra + then + if lb < rb + then LT + else + if lb == rb + then EQ + else GT + else + if la < ra + then LT + else GT + where + la = toBaseSortKey l + lb = toExtensionsSortKey l + ra = toBaseSortKey r + rb = toExtensionsSortKey r + +instance Hashable Name where + hashWithSalt salt Name {..} = + salt + & extendHash base + & extendHash extensions + where + extendHash = flip hashWithSalt + +-- * Constructors + +empty :: Name +empty = + Name mempty mempty + +mapExtensions :: ([Text] -> [Text]) -> Name -> Name +mapExtensions f = runIdentity . traverseExtensions (Identity . f) + +maybeFromText :: Text -> Maybe Name +maybeFromText text = + Attoparsec.parseOnly (attoparsecParserOf <* Attoparsec.endOfInput) text + & either (const Nothing) Just + +-- * Functors + +traverseExtensions :: (Functor f) => ([Text] -> f [Text]) -> Name -> f Name +traverseExtensions f (Name base extensions) = + f extensions + & fmap + ( \list -> + list + & concatMap + ( \extension -> + case maybeFromText extension of + Just (Name base' extensions') -> + (extensions' <> [base']) + & filter (not . Text.null) + Nothing -> [] + ) + & Name base + ) + +attoparsecParserOf :: Attoparsec.Parser Name +attoparsecParserOf = do + base <- NameSegment.attoparsecParserOf <|> pure "" + extensions <- reverseMany (Attoparsec.char '.' *> NameSegment.attoparsecParserOf) + return (Name base extensions) + +-- * Destructors + +toBase :: Name -> Text +toBase (Name base _) = + base + +toExtensions :: Name -> [Text] +toExtensions (Name _ extensions) = + extensions + +toTextBuilder :: Name -> TextBuilder.TextBuilder +toTextBuilder (Name base extensions) = + foldr + (\extension next -> next <> "." <> TextBuilder.text extension) + (TextBuilder.text base) + extensions + +toText :: Name -> Text +toText = TextBuilder.toText . toTextBuilder + +toBaseSortKey :: Name -> NaturalSort.SortKey +toBaseSortKey = NaturalSort.sortKey . toBase + +toExtensionsSortKey :: Name -> [NaturalSort.SortKey] +toExtensionsSortKey = reverse . fmap NaturalSort.sortKey . toExtensions + +null :: Name -> Bool +null (Name name extensions) = + Text.null name && List.null extensions diff --git a/src/ast/AlgebraicPath/Ast/Name/NameSegment.hs b/src/ast/AlgebraicPath/Ast/Name/NameSegment.hs new file mode 100644 --- /dev/null +++ b/src/ast/AlgebraicPath/Ast/Name/NameSegment.hs @@ -0,0 +1,43 @@ +module AlgebraicPath.Ast.Name.NameSegment + ( NameSegment, + attoparsecParserOf, + toText, + ) +where + +import AlgebraicPath.Util.Prelude +import Algorithms.NaturalSort qualified +import Data.Attoparsec.Text qualified as Attoparsec +import Data.List qualified as List +import Data.Text qualified as Text +import Test.QuickCheck qualified as QuickCheck + +newtype NameSegment = NameSegment Text + deriving (Eq, Show) + +instance Ord NameSegment where + compare (NameSegment text1) (NameSegment text2) = + on compare Algorithms.NaturalSort.sortKey text1 text2 + +instance Arbitrary NameSegment where + arbitrary = do + maxSize <- QuickCheck.getSize + textLength <- QuickCheck.chooseInt (1, min maxSize 1) + chars <- replicateM textLength do + QuickCheck.suchThat arbitrary (not . flip List.elem unsupportedChars) + pure (NameSegment (Text.pack chars)) + shrink (NameSegment text) = do + text <- QuickCheck.shrink (Text.unpack text) + if List.null text + then [] + else pure (NameSegment (Text.pack text)) + +-- https://stackoverflow.com/a/35352640/485115 +unsupportedChars :: [Char] +unsupportedChars = "./\\:\NUL*?\"<>|" + +attoparsecParserOf :: Attoparsec.Parser Text +attoparsecParserOf = Attoparsec.takeWhile1 (not . flip List.elem unsupportedChars) + +toText :: NameSegment -> Text +toText (NameSegment text) = text diff --git a/src/ast/AlgebraicPath/Ast/Path.hs b/src/ast/AlgebraicPath/Ast/Path.hs new file mode 100644 --- /dev/null +++ b/src/ast/AlgebraicPath/Ast/Path.hs @@ -0,0 +1,30 @@ +module AlgebraicPath.Ast.Path + ( Path (..), + attoparsecParserOf, + toTextBuilder, + ) +where + +import AlgebraicPath.Ast.Component qualified as Component +import AlgebraicPath.Util.MonadPlus +import Data.Attoparsec.Text qualified as Attoparsec +import TextBuilder qualified as TextBuilder +import Prelude + +data Path + = Path Bool [Component.Component] + +attoparsecParserOf :: Attoparsec.Parser Path +attoparsecParserOf = do + abs <- Attoparsec.char '/' $> True <|> pure False + components <- reverseSepBy Component.attoparsecParserOf (Attoparsec.char '/') + return $ Path abs components + +toTextBuilder :: Path -> TextBuilder.TextBuilder +toTextBuilder (Path abs components) = + if abs + then "/" <> relative + else relative + where + relative = + TextBuilder.intercalate "/" . fmap Component.toTextBuilder . reverse $ components diff --git a/src/library/AlgebraicPath.hs b/src/library/AlgebraicPath.hs new file mode 100644 --- /dev/null +++ b/src/library/AlgebraicPath.hs @@ -0,0 +1,555 @@ +module AlgebraicPath + ( Path, + + -- * Accessors + toFilePath, + toText, + toBasename, + toExtensions, + toSegments, + isAbsolute, + + -- * Partial constructors + maybeFromText, + maybeFromFilePath, + + -- * Parsers + attoparsecParserOf, + + -- * Constructors + root, + dropParent, + dropLastSegment, + addExtension, + dropExtension, + dropExtensions, + deabsolutize, + + -- * Idioms + + -- | Getting the parent directory + -- + -- >>> "a/b" <> ".." :: Path + -- "./a" + + -- | Isolating to just the file name + -- + -- >>> (dropParent . dropExtensions) "/a/b.c.d" :: Path + -- "./b" + ) +where + +import AlgebraicPath.Ast.Component qualified as Ast.Component +import AlgebraicPath.Ast.Name qualified as Ast.Name +import AlgebraicPath.Ast.Path qualified as Ast.Path +import AlgebraicPath.Util.List qualified as List +import AlgebraicPath.Util.Prelude hiding (null) +import Data.Attoparsec.Text qualified as Attoparsec +import Data.List qualified as List +import Test.QuickCheck qualified as QuickCheck +import TextBuilder qualified + +-- | +-- Composable normalized path with a powerful algebra and consistent behaviour. +-- +-- - It has 'toFilePath' and 'maybeFromFilePath' conversions, +-- which let you easily integrate it with any 'FilePath'-oriented libs. +-- - It has an instance of 'IsString', +-- so you can use string literals to define it. +-- - It provides a 'Monoid' instance replacing the `()` operator of other libs with a standard lawful abstraction. +-- - It is automatically normalized, ensuring that various representations of the same path are equal, produce equal hashes and get ordered the same. +-- - It implements [natural sorting](https://en.wikipedia.org/wiki/Natural_sort_order). +-- - It integrates with 'Text' using 'toText' and 'maybeFromText'. +-- - It integrates with \"attoparsec\" via 'attoparsecParserOf'. +-- +-- === Normalization +-- +-- Internally 'Path' models a normalized form, +-- removing many ambiguities and allowing to achieve the following behaviour. +-- +-- The trailing slash gets ignored: +-- +-- >>> "a/" :: Path +-- "./a" +-- +-- Multislash gets squashed: +-- +-- >>> "a//b" :: Path +-- "./a/b" +-- +-- Dot-dot gets immediately applied: +-- +-- >>> "a/../c" :: Path +-- "./c" +-- +-- Same does the single dot: +-- +-- >>> "a/./c" :: Path +-- "./a/c" +-- +-- Attempts to move out of root in absolute paths are ignored: +-- +-- >>> "/../a" :: Path +-- "/a" +-- +-- Attempts to move out of the beginning of a relative path on the other hand are preserved: +-- +-- >>> "a/../../.." :: Path +-- "../.." +-- +-- Dot as the first component of the path is the same as if there's none: +-- +-- >>> "./a" :: Path +-- "./a" +-- +-- >>> "a" :: Path +-- "./a" +-- +-- Empty path is the same as dot: +-- +-- >>> "" :: Path +-- "." +-- +-- === Composition +-- +-- The 'Monoid' instance makes paths composable and provides the following behaviour. +-- +-- Empty path is the same as dot: +-- +-- >>> mempty :: Path +-- "." +-- +-- Appending a relative path nests it: +-- +-- >>> "/a/b" <> "c.d" :: Path +-- "/a/b/c.d" +-- +-- Appending a path with dot-dot, immediately applies it: +-- +-- >>> "/a/b" <> "../c" :: Path +-- "/a/c" +-- +-- Appending an absolute path replaces the whole thing: +-- +-- >>> "/a/b" <> "/c" :: Path +-- "/c" +-- +-- === Consistent equality, order and hashing +-- +-- Thanks to 'Path' being in normalized form, the equality is consistent: +-- +-- >>> ("./a/b" :: Path) == "a/b" +-- True +-- +-- >>> ("./a/b" :: Path) == "a/b/" +-- True +-- +-- >>> ("./a/b" :: Path) == "a//b/" +-- True +-- +-- >>> ("./a/b" :: Path) == "a/../a/b/" +-- True +-- +-- None of the above would hold for 'FilePath'. +-- +-- Same logic applies to ordering and hashing. +-- +-- === Natural sorting +-- +-- The path is sorted [naturally](https://en.wikipedia.org/wiki/Natural_sort_order), meaning that the segments are compared as numbers if they are all digits. +-- This is useful for sorting paths with version numbers: +-- +-- >>> import Data.List (sort) +-- >>> sort ["a/1", "a/11", "a/20", "a/2", "a/10"] :: [Path] +-- ["./a/1","./a/2","./a/10","./a/11","./a/20"] +-- +-- where with 'FilePath' you would get: +-- +-- >>> sort ["a/1", "a/11", "a/20", "a/2", "a/10"] :: [FilePath] +-- ["a/1","a/10","a/11","a/2","a/20"] +data Path + = -- | Absolute path. + AbsNormalizedPath + -- | Ast.Components in reverse order. + [Ast.Name.Name] + | RelNormalizedPath + -- | Preceding go up commands. + Int + -- | Ast.Components in reverse order. + [Ast.Name.Name] + deriving (Eq) + +instance Ord Path where + compare = \case + AbsNormalizedPath lNames -> \case + AbsNormalizedPath rNames -> compare lNames rNames + _ -> GT + RelNormalizedPath lMovesUp lNames -> \case + AbsNormalizedPath _ -> LT + RelNormalizedPath rMovesUp rNames -> case compare lMovesUp rMovesUp of + EQ -> compare lNames rNames + res -> res + +instance IsString Path where + fromString = + either error id + . Attoparsec.parseOnly (attoparsecParserOf <* Attoparsec.endOfInput) + . fromString + +-- | Renders as a string literal. +instance Show Path where + show = show . toText + +instance Semigroup Path where + lPath <> rPath = case rPath of + AbsNormalizedPath _ -> rPath + RelNormalizedPath rMovesUp rNames -> + case lPath of + RelNormalizedPath lMovesUp lNames -> + case List.dropPedantically rMovesUp lNames of + Left rMovesUp -> RelNormalizedPath (rMovesUp + lMovesUp) rNames + Right lNames -> RelNormalizedPath lMovesUp (rNames <> lNames) + AbsNormalizedPath lNames -> + AbsNormalizedPath (rNames <> drop rMovesUp lNames) + +instance Monoid Path where + mempty = + RelNormalizedPath 0 [] + +instance QuickCheck.Arbitrary Path where + arbitrary = + QuickCheck.oneof [abs, rel] + where + abs = + AbsNormalizedPath <$> names + rel = + RelNormalizedPath <$> movesUp <*> names + where + movesUp = + QuickCheck.chooseInt (0, 3) + names = do + size <- QuickCheck.chooseInt (0, 20) + QuickCheck.vectorOf size do + QuickCheck.suchThat QuickCheck.arbitrary (not . Ast.Name.null) + shrink = \case + AbsNormalizedPath names -> + AbsNormalizedPath <$> QuickCheck.shrink names + RelNormalizedPath movesUp names -> + QuickCheck.shrink (movesUp, names) <&> \(movesUp, names) -> + RelNormalizedPath movesUp names + +instance Hashable Path where + hashWithSalt salt = \case + AbsNormalizedPath names -> + salt + & extendHash @Int 0 + & extendHash names + RelNormalizedPath movesUp names -> + salt + & extendHash @Int 1 + & extendHash movesUp + & extendHash names + where + extendHash :: (Hashable a) => a -> Int -> Int + extendHash = flip hashWithSalt + +-- * Partial constructors + +-- | Attempt to parse a path from text. +maybeFromText :: Text -> Maybe Path +maybeFromText = + either (const Nothing) Just . Attoparsec.parseOnly (attoparsecParserOf <* Attoparsec.endOfInput) + +-- | Attempt to parse the standard file path which is an alias to 'String'. +maybeFromFilePath :: FilePath -> Maybe Path +maybeFromFilePath = maybeFromText . fromString + +-- | Attoparsec parser of 'Path'. +attoparsecParserOf :: Attoparsec.Parser Path +attoparsecParserOf = + fromAst <$> Ast.Path.attoparsecParserOf + +-- | Construct from AST. +fromAst :: Ast.Path.Path -> Path +fromAst (Ast.Path.Path root components) = + foldr step finish components 0 [] + where + step component next !collectedMovesUp !collectedNames = + case component of + Ast.Component.NameComponent name -> + if collectedMovesUp > 0 + then next (pred collectedMovesUp) collectedNames + else + if Ast.Name.null name + then next collectedMovesUp collectedNames + else next collectedMovesUp (name : collectedNames) + Ast.Component.DotComponent -> + next collectedMovesUp collectedNames + Ast.Component.DotDotComponent -> + next (succ collectedMovesUp) collectedNames + finish collectedMovesUp collectedNames = + if root + then AbsNormalizedPath (reverse collectedNames) + else RelNormalizedPath collectedMovesUp (reverse collectedNames) + +-- | +-- >>> root +-- "/" +-- +-- Prepending it to a relative path will make it absolute. +-- +-- >>> root <> "a/b" +-- "/a/b" +root :: Path +root = + AbsNormalizedPath [] + +-- * Traversers (aka Van Laarhoven lenses) + +traverseNames :: (Functor f) => ([Ast.Name.Name] -> f [Ast.Name.Name]) -> Path -> f Path +traverseNames f = \case + AbsNormalizedPath names -> + AbsNormalizedPath <$> f names + RelNormalizedPath movesUp names -> + RelNormalizedPath movesUp <$> f names + +traverseLastName :: (Functor f) => (Ast.Name.Name -> f Ast.Name.Name) -> Path -> f Path +traverseLastName = + traverseNames . List.traverseHeadWithDefault Ast.Name.empty + +traverseExtensions :: (Functor f) => ([Text] -> f [Text]) -> Path -> f Path +traverseExtensions = + traverseLastName . Ast.Name.traverseExtensions + +-- * Mappers + +mapNames :: ([Ast.Name.Name] -> [Ast.Name.Name]) -> Path -> Path +mapNames f = \case + AbsNormalizedPath names -> + AbsNormalizedPath (f names) + RelNormalizedPath movesUp names -> + RelNormalizedPath movesUp (f names) + +mapHeadName :: (Ast.Name.Name -> Ast.Name.Name) -> Path -> Path +mapHeadName f = mapNames $ \case + head : tail -> f head : tail + [] -> [] + +mapExtensions :: ([Text] -> [Text]) -> Path -> Path +mapExtensions mapper = + runIdentity . traverseExtensions (Identity . mapper) + +-- | Add file extension to the last segment of the path. +-- +-- >>> addExtension "tar" "/a/b" +-- "/a/b.tar" +-- +-- >>> addExtension "gz" "/a/b.tar" +-- "/a/b.tar.gz" +-- +-- >>> addExtension "gitignore" "" +-- "./.gitignore" +-- +-- Dots in the prefix are ignored: +-- +-- >>> addExtension ".gitignore" "" +-- "./.gitignore" +-- +-- In fact dots are interpreted as extension delimiters, meaning that the following two are equivalent: +-- +-- >>> addExtension "tar.gz" "" +-- "./.tar.gz" +-- +-- >>> (addExtension "gz" . addExtension "tar") "" +-- "./.tar.gz" +addExtension :: Text -> Path -> Path +addExtension ext = mapExtensions (ext :) + +-- | Make the path non-absolute. +-- +-- >>> deabsolutize "/a/b" +-- "./a/b" +-- +-- >>> deabsolutize "a/b" +-- "./a/b" +deabsolutize :: Path -> Path +deabsolutize = \case + AbsNormalizedPath names -> RelNormalizedPath 0 names + relPath -> relPath + +-- | Drop path to the parent directory. +-- +-- >>> dropParent "/a/b" +-- "./b" +-- +-- >>> dropParent "a/b" +-- "./b" +-- +-- >>> dropParent "../a/b" +-- "./b" +-- +-- >>> dropParent ".." +-- "." +-- +-- >>> dropParent "." +-- "." +-- +-- >>> dropParent "/" +-- "." +dropParent :: Path -> Path +dropParent = fromNames . toNames + where + fromNames = \case + head : _ -> RelNormalizedPath 0 [head] + _ -> RelNormalizedPath 0 [] + +-- | Drop the last segment of the path. +-- +-- >>> dropLastSegment "./a/b.c.d" +-- "./a" +-- +-- >>> dropLastSegment "./a" +-- "." +-- +-- >>> dropLastSegment "." +-- "." +-- +-- >>> dropLastSegment "/" +-- "/" +-- +-- >>> dropLastSegment ".." +-- ".." +dropLastSegment :: Path -> Path +dropLastSegment = + mapNames \case + [] -> [] + _ : tail -> tail + +-- | Drop last extension if there is one. +-- +-- >>> dropExtension "/a/b.c.d" +-- "/a/b.c" +-- +-- >>> dropExtension "/a/b.c" +-- "/a/b" +-- +-- >>> dropExtension "/a/b" +-- "/a/b" +-- +-- >>> dropExtension "/" +-- "/" +dropExtension :: Path -> Path +dropExtension = mapHeadName $ Ast.Name.mapExtensions $ List.drop 1 + +-- | Drop all extensions. +-- +-- >>> dropExtensions "/a/b.c.d" +-- "/a/b" +-- +-- >>> dropExtensions "a" +-- "./a" +dropExtensions :: Path -> Path +dropExtensions = mapHeadName $ Ast.Name.mapExtensions $ const [] + +-- * Accessors + +-- | Compile to strict text builder. +toTextBuilder :: Path -> TextBuilder.TextBuilder +toTextBuilder = Ast.Path.toTextBuilder . toAst + +-- | Compile to standard file path string. +toFilePath :: Path -> FilePath +toFilePath = toList . toText + +-- | Compile to text. +toText :: Path -> Text +toText = TextBuilder.toText . toTextBuilder + +toAst :: Path -> Ast.Path.Path +toAst = \case + AbsNormalizedPath names -> + Ast.Path.Path True (fmap Ast.Component.NameComponent names) + RelNormalizedPath movesUp names -> + Ast.Path.Path False + $ if movesUp == 0 + then + fmap Ast.Component.NameComponent names + <> pure Ast.Component.DotComponent + else + fmap Ast.Component.NameComponent names + <> replicate movesUp Ast.Component.DotDotComponent + +-- | +-- Decompose into individual segments as texts. I.e., the parts separated by slashes. +-- +-- >>> toSegments "a/b.c.d" +-- ["a","b.c.d"] +-- +-- >>> toSegments "/a/b.c.d" +-- ["a","b.c.d"] +-- +-- >>> toSegments "." +-- [] +-- +-- >>> toSegments "/" +-- [] +-- +-- If you also want to retain the information on the path being absolute, use this in combination with 'isAbsolute': +-- +-- >>> let path = "/a/b.c.d" :: Path +-- >>> toSegments path +-- ["a","b.c.d"] +-- >>> isAbsolute path +-- True +toSegments :: Path -> [Text] +toSegments = fmap Ast.Name.toText . reverse . toNames + +toNames :: Path -> [Ast.Name.Name] +toNames = \case + AbsNormalizedPath names -> names + RelNormalizedPath _ names -> names + +-- | Get the last segment sans extensions. +-- +-- >>> toBasename "/a/b.c.d" +-- "b" +-- +-- >>> toBasename "/a/b" +-- "b" +-- +-- >>> toBasename "/a/.gitignore" +-- "" +toBasename :: Path -> Text +toBasename path = + case toNames path of + head : _ -> Ast.Name.toBase head + _ -> mempty + +-- | Convert to a list of extensions. +-- +-- >>> toExtensions "/a/b.c.d" +-- ["c","d"] +-- +-- >>> toExtensions "/a/b" +-- [] +toExtensions :: Path -> [Text] +toExtensions = + reverse . Ast.Name.toExtensions . List.headOr Ast.Name.empty . toNames + +-- | Check if the path is absolute. +-- +-- >>> isAbsolute "/a/b" +-- True +-- +-- >>> isAbsolute "a/b" +-- False +-- +-- >>> isAbsolute "/" +-- True +-- +-- >>> isAbsolute "." +-- False +isAbsolute :: Path -> Bool +isAbsolute = \case + AbsNormalizedPath _ -> True + RelNormalizedPath _ _ -> False diff --git a/src/tests/Main.hs b/src/tests/Main.hs new file mode 100644 --- /dev/null +++ b/src/tests/Main.hs @@ -0,0 +1,127 @@ +module Main where + +import AlgebraicPath +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck.Classes qualified +import Prelude + +main :: IO () +main = hspec do + describe "Laws" do + itFollowsLaws (Test.QuickCheck.Classes.semigroupLaws (Proxy @Path)) + itFollowsLaws (Test.QuickCheck.Classes.monoidLaws (Proxy @Path)) + + describe "Essentials" do + itEquals + "Component decomposition works and keeps order" + ["src", "main", "java"] + (toSegments "src/main/java") + + describe "Empty" do + itEquals @Path + "equals empty" + mempty + "" + itEquals @Path + "equals dot" + "." + "" + + describe "Dot" do + itEquals @Path + "equals empty" + mempty + "." + itEquals @Path + "acts as a normal component" + "src/main" + "src/./main" + + describe "Trailing slash" do + itEquals @Path + "Same as without it" + "src/main/java" + "src/main/java/" + itEquals + "Doesn't produce a trailing segment" + ["src", "main", "java"] + (toSegments "src/main/java/") + + describe "Multislash" do + itEquals @Path + "Double" + "src/main" + "src//main" + itEquals @Path + "Triple" + "src/main" + "src///main" + + describe "toFilePath" do + itEquals + "Empty renders as dot" + "." + (toFilePath mempty) + itEquals + "Relative is prefixed with dot" + "./a" + (toFilePath "a") + itEquals + "Absolute is prefixed with slash" + "/a" + (toFilePath "/a") + + describe "fromString" do + itEquals @Path + "Intermediate ones get squashed" + "a/c/f" + "a/b/../c/d/e/../../f" + itEquals @Path + "Absolute followed by dot-dot" + "/a" + "/../a" + + describe "mappend" do + itEquals @Path + "Dot-dot" + "a/d" + ("a/b/c" <> "../../d") + itEquals @Path + "Second absolute" + "/d" + ("a/b/c" <> "/d") + itEquals @Path + "First absolute and dot-dot too high" + "/a" + ("/" <> "../a") + itEquals @Path + "Absolute is prefixed with slash" + "/a" + (root <> "a") + + describe "toText" do + itEquals "Trailing slash" "./a" (toText "a/") + itEquals "Multislash" "./a/b" (toText "a//b") + itEquals "Empty" "." (toText "") + itEquals "Move up" ".." (toText "..") + +-- TODO: Restore when implemented +-- describe "relativeTo" do +-- itEquals "" (Just "..") (relativeTo "a/b" "a/b/c") +-- itEquals "" (Just "../b") (relativeTo "a/b" "a/c") +-- itEquals "" (Just "../a") (relativeTo "a" "b") +-- itEquals "" (Just "..") (relativeTo "." "b") +-- itEquals "" (Just "a") (relativeTo "a" ".") +-- itEquals "" (Just "/a") (relativeTo "/a" "b") +-- itEquals "" Nothing (relativeTo "a" "/b") +-- itEquals "" Nothing (relativeTo "a" "..") + +itEquals :: (Show a, Eq a) => String -> a -> a -> Spec +itEquals name a b = + it name (shouldBe a b) + +itFollowsLaws :: (HasCallStack) => Test.QuickCheck.Classes.Laws -> Spec +itFollowsLaws Test.QuickCheck.Classes.Laws {..} = + describe lawsTypeclass do + forM_ lawsProperties (uncurry prop) diff --git a/src/util/AlgebraicPath/Util/List.hs b/src/util/AlgebraicPath/Util/List.hs new file mode 100644 --- /dev/null +++ b/src/util/AlgebraicPath/Util/List.hs @@ -0,0 +1,24 @@ +module AlgebraicPath.Util.List where + +import Prelude + +dropPedantically :: Int -> [a] -> Either Int [a] +dropPedantically amount = + if amount > 0 + then \case + _head : tail -> dropPedantically (pred amount) tail + _ -> Left amount + else + if amount == 0 + then Right + else const (Left amount) + +traverseHeadWithDefault :: (Functor f) => a -> (a -> f a) -> [a] -> f [a] +traverseHeadWithDefault def f = \case + head : tail -> (: tail) <$> f head + _ -> pure <$> f def + +headOr :: a -> [a] -> a +headOr def = \case + head : _ -> head + _ -> def diff --git a/src/util/AlgebraicPath/Util/MonadPlus.hs b/src/util/AlgebraicPath/Util/MonadPlus.hs new file mode 100644 --- /dev/null +++ b/src/util/AlgebraicPath/Util/MonadPlus.hs @@ -0,0 +1,27 @@ +module AlgebraicPath.Util.MonadPlus where + +import Control.Monad +import Prelude + +reverseMany :: (MonadPlus m) => m a -> m [a] +reverseMany element = go [] + where + go !acc = + mplus + (element >>= go . (: acc)) + (return acc) + +reverseSepBy :: (MonadPlus m) => m a -> m b -> m [a] +reverseSepBy element sep = + mplus + (reverseSepBy1 element sep) + (pure []) + +reverseSepBy1 :: (MonadPlus m) => m a -> m b -> m [a] +reverseSepBy1 element sep = + element >>= go . pure + where + go !acc = + mplus + (sep >> element >>= go . (: acc)) + (return acc) diff --git a/src/util/AlgebraicPath/Util/Prelude.hs b/src/util/AlgebraicPath/Util/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/util/AlgebraicPath/Util/Prelude.hs @@ -0,0 +1,42 @@ +module AlgebraicPath.Util.Prelude + ( module X, + ) +where + +import Control.Applicative as X +import Control.Monad as X +import Data.Bifunctor as X +import Data.Bool as X +import Data.Char as X +import Data.Coerce as X +import Data.Either as X +import Data.Eq as X +import Data.Foldable as X hiding (toList) +import Data.Function as X +import Data.Functor as X +import Data.Functor.Classes as X +import Data.Functor.Identity as X +import Data.Hashable as X (Hashable (..)) +import Data.Int as X +import Data.List.NonEmpty as X (NonEmpty (..), nonEmpty) +import Data.Maybe as X +import Data.Monoid as X hiding (First (..), Last (..)) +import Data.Ord as X +import Data.Proxy as X +import Data.Ratio as X +import Data.Semigroup as X +import Data.String as X (IsString (..)) +import Data.Text as X (Text) +import Data.Traversable as X +import Data.Tuple as X +import Data.Void as X +import Data.Word as X +import Debug.Trace as X +import GHC.Enum as X +import GHC.Exts as X (IsList (..)) +import GHC.Generics as X (Generic) +import GHC.Num as X +import GHC.Stack as X (HasCallStack) +import Test.QuickCheck as X (Arbitrary (..)) +import Text.Show as X +import Prelude as X hiding (null, unzip)