packages feed

algebraic-path (empty) → 0.1

raw patch · 11 files changed

+1209/−0 lines, 11 filesdep +QuickCheckdep +algebraic-pathdep +attoparsec

Dependencies added: QuickCheck, algebraic-path, attoparsec, base, hashable, hspec, natural-sort, quickcheck-classes, rerebase, text, text-builder

Files

+ LICENSE view
@@ -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.
+ algebraic-path.cabal view
@@ -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 <nikita.y.volkov@mail.ru>+maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>+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,
+ src/ast/AlgebraicPath/Ast/Component.hs view
@@ -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 -> ".."
+ src/ast/AlgebraicPath/Ast/Name.hs view
@@ -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
+ src/ast/AlgebraicPath/Ast/Name/NameSegment.hs view
@@ -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
+ src/ast/AlgebraicPath/Ast/Path.hs view
@@ -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
+ src/library/AlgebraicPath.hs view
@@ -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
+ src/tests/Main.hs view
@@ -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)
+ src/util/AlgebraicPath/Util/List.hs view
@@ -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
+ src/util/AlgebraicPath/Util/MonadPlus.hs view
@@ -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)
+ src/util/AlgebraicPath/Util/Prelude.hs view
@@ -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)