use new {split,join}Name for alterExtension and extention definitions

Author: safareli

src/Pathy/Gen.purs

@@ -5,6 +5,7 @@ module Pathy.Gen
   , genRelDirPath
   , genRelFilePath
   , genRelAnyPath
+  , genName
   ) where
 
 import Prelude
@@ -18,27 +19,27 @@ import Data.Foldable (foldr)
 import Data.List as L
 import Data.NonEmpty ((:|))
 import Data.String.Gen as SG
-import Data.String.NonEmpty (NonEmptyString, cons)
-import Pathy (AbsPath, AbsFile, AbsDir, RelDir, RelFile, RelPath, (</>))
+import Data.String.NonEmpty (cons)
+import Pathy (AbsDir, AbsFile, AbsPath, Dir, RelDir, RelFile, RelPath, (</>))
 import Pathy as P
 
-genName ∷ ∀ m. MonadGen m ⇒ MonadRec m ⇒ m NonEmptyString
-genName = cons <$> genChar <*> SG.genString genChar
+genName ∷ ∀ m a. MonadGen m ⇒ MonadRec m ⇒ m (P.Name a)
+genName = map P.Name $ cons <$> genChar <*> SG.genString genChar
   where
   genChar = Gen.oneOf $ CG.genDigitChar :| [CG.genAlpha]
 
 genAbsDirPath :: forall m. MonadGen m => MonadRec m => m AbsDir
 genAbsDirPath = Gen.sized \size → do
   newSize ← Gen.chooseInt 0 size
   Gen.resize (const newSize) do
-    parts ∷ L.List NonEmptyString ← Gen.unfoldable genName
-    pure $ foldr (flip P.appendPath <<< P.dir' <<< P.Name) P.rootDir parts
+    parts ∷ L.List (P.Name Dir) ← Gen.unfoldable genName
+    pure $ foldr (flip P.appendPath <<< P.dir') P.rootDir parts
 
 genAbsFilePath :: forall m. MonadGen m => MonadRec m => m AbsFile
 genAbsFilePath = do
   dir ← genAbsDirPath
   file ← genName
-  pure $ dir </> P.file' (P.Name file)
+  pure $ dir </> P.file' file
 
 genAbsAnyPath :: forall m. MonadGen m => MonadRec m => m AbsPath
 genAbsAnyPath = Gen.oneOf $ (Left <$> genAbsDirPath) :| [Right <$> genAbsFilePath]
@@ -47,14 +48,14 @@ genRelDirPath :: forall m. MonadGen m => MonadRec m => m RelDir
 genRelDirPath = Gen.sized \size → do
   newSize ← Gen.chooseInt 0 size
   Gen.resize (const newSize) do
-    parts ∷ L.List NonEmptyString ← Gen.unfoldable genName
-    pure $ foldr (flip P.appendPath <<< P.dir' <<< P.Name) P.currentDir parts
+    parts ∷ L.List (P.Name Dir) ← Gen.unfoldable genName
+    pure $ foldr (flip P.appendPath <<< P.dir') P.currentDir parts
 
 genRelFilePath :: forall m. MonadGen m => MonadRec m => m RelFile
 genRelFilePath = do
   dir ← genRelDirPath
   file ← genName
-  pure $ dir </> P.file' (P.Name file)
+  pure $ dir </> P.file' file
 
 genRelAnyPath :: forall m. MonadGen m => MonadRec m => m RelPath
 genRelAnyPath = Gen.oneOf $ (Left <$> genRelDirPath) :| [Right <$> genRelFilePath]

src/Pathy/Name.purs

@@ -2,7 +2,7 @@ module Pathy.Name where
 
 import Prelude
 
-import Data.Maybe (Maybe(..), maybe)
+import Data.Maybe (Maybe(..), fromMaybe)
 import Data.Newtype (class Newtype)
 import Data.String as S
 import Data.String.NonEmpty (NonEmptyString)
@@ -24,32 +24,72 @@ derive newtype instance ordName :: Ord (Name a)
 instance showName :: Show (Name a) where
   show (Name name) = "(Name " <> show name <> ")"
 
--- | Retrieves the extension of a name.
+-- | Splits `Name` in name and extension part.
+-- |
+-- | ```purescript
+-- | splitName (Name ".foo")    == { name: ".foo", extension: Nothing }
+-- | splitName (Name "foo.")    == { name: "foo.", extension: Nothing }
+-- | splitName (Name "foo")     == { name: "foo",  extension: Nothing }
+-- | splitName (Name ".")       == { name: ".",    extension: Nothing }
+-- | splitName (Name "foo.baz") == { name: "foo",  extension: Just "baz" }
+-- | ```
+-- | _Note, in real code all strings from this examples would be `NonEmptyString`._
+-- | 
+-- | Also for any `Name` this property holds:
+-- | ```purescript
+-- | joinName <<< splitName = id
+-- | ````
+-- | see [`joinName`](#v:joinName).
+splitName :: forall n. Name n -> { name :: NonEmptyString, ext :: Maybe NonEmptyString }
+splitName (Name nameIn) =
+  fromMaybe { name: nameIn, ext: Nothing } do
+    idx <- NES.lastIndexOf (S.Pattern ".") nameIn
+    name <- NES.take idx nameIn
+    ext <- NES.drop (idx + 1) nameIn
+    pure $ { name, ext: Just ext }
+
+-- | Joins name and extension part into one `Name`.
+-- |
+-- | Also for any `Name` this property holds:
+-- | ```purescript
+-- | joinName <<< splitName = id
+-- | ````
+-- | see [`splitName`](#v:splitName).
+joinName :: forall n. { name :: NonEmptyString, ext :: Maybe NonEmptyString } -> Name n
+joinName { name, ext } = Name $ case ext of
+  Nothing -> name
+  Just ext -> name <> NES.singleton '.' <> ext
+
+-- | Retrieves the extension of a name. also see [`splitName`](#v:splitName)
+-- | 
+-- | ```purescript
+-- | extension (Name ".foo")    == Nothing
+-- | extension (Name "foo.")    == Nothing
+-- | extension (Name ".")       == Nothing
+-- | extension (Name "foo.baz") == Just "baz"
+-- | ````
+-- | _Note, in real code all strings from this examples would be `NonEmptyString`._
 extension :: forall n. Name n -> Maybe NonEmptyString
-extension (Name name) =
-  flip NES.drop name <<< (_ + 1) =<< NES.lastIndexOf (S.Pattern ".") name
+extension = splitName >>> _.ext
 
 -- | Alters an extension of a name. This allows extensions to be added, removed,
--- | or modified.
+-- | or modified. see [`splitName`](#v:splitName) and [`joinName`](#v:joinName)
+-- | for how a `Name` is split into name and extention part and joined back
+-- | into a `Name`.
+-- | 
+-- | Also for any `Name` this property holds:
+-- | ```purescript
+-- | alterExtension id = id
+-- | ````
 alterExtension
   :: forall n
    . (Maybe NonEmptyString -> Maybe NonEmptyString)
   -> Name n
   -> Name n
-alterExtension f (Name name) =
-  case NES.lastIndexOf (S.Pattern ".") name of
-    Nothing -> extend name Nothing
-    Just i ->
-      case NES.splitAt i name of
-        Just { before: Just n, after } -> extend n (NES.drop 1 =<< after)
-        _ -> extend name Nothing
-  where
-    extend name' ext =
-      maybe
-        (Name name')
-        (\ext' -> Name (name' <> NES.singleton '.' <> ext'))
-        (f ext)
-
+alterExtension f n =
+  let spn = splitName n
+  in joinName spn{ext = f spn.ext}
+  
 -- | A class for creating `Name` values from type-level strings. This allows us
 -- | to guarantee that a name is not empty at compile-time.
 class IsName sym where

test/Main.purs

@@ -6,11 +6,15 @@ import Control.Monad.Eff (Eff)
 import Control.Monad.Eff.Console (CONSOLE, info)
 import Control.Monad.Eff.Exception (EXCEPTION, throw)
 import Data.Maybe (Maybe(..))
+import Data.Newtype (un)
+import Data.NonEmpty ((:|))
 import Data.String as Str
 import Data.String.NonEmpty (NonEmptyString)
+import Data.String.NonEmpty as NES
 import Data.Symbol (SProxy(..))
-import Pathy (class IsDirOrFile, class IsRelOrAbs, Abs, Dir, Path, Rel, alterExtension, canonicalize, currentDir, dir, file, parentOf, parseAbsDir, parseAbsFile, parseRelDir, parseRelFile, posixParser, posixPrinter, printPath, relativeTo, rename, rootDir, sandbox, debugPrintPath, unsandbox, (<..>), (<.>), (</>))
+import Pathy (class IsDirOrFile, class IsRelOrAbs, Abs, Dir, Name(..), Path, Rel, alterExtension, canonicalize, currentDir, debugPrintPath, dir, extension, file, parentOf, parseAbsDir, parseAbsFile, parseRelDir, parseRelFile, posixParser, posixPrinter, printPath, relativeTo, rename, rootDir, sandbox, unsandbox, (<..>), (<.>), (</>), joinName, reflectName, splitName)
 import Pathy.Gen as PG
+import Test.QuickCheck ((===))
 import Test.QuickCheck as QC
 import Test.QuickCheck.Gen as Gen
 import Unsafe.Coerce (unsafeCoerce)
@@ -65,6 +69,31 @@ parsePrintRelFilePath :: Gen.Gen QC.Result
 parsePrintRelFilePath = PG.genRelFilePath <#> \path ->
   parsePrintCheck path (parseRelFile posixParser $ printTestPath path)
 
+genAmbigiousName :: forall a. Gen.Gen (Name a)
+genAmbigiousName = 
+  let
+    genNES = PG.genName <#> un Name
+  in
+    map Name $ Gen.oneOf $ genNES :|
+      [ genNES <#> \a -> a <> (NES.singleton '.')
+      , genNES <#> \a -> (NES.singleton '.') <> a
+      , pure (NES.singleton '.')
+      , do
+          a <- genNES
+          b <- genNES
+          pure $ a <> (NES.singleton '.') <> b
+      ]
+  
+checkAlterExtensionId :: Gen.Gen QC.Result
+checkAlterExtensionId = do
+  n <- genAmbigiousName
+  pure $ alterExtension id n === id n
+
+checkJoinSplitNameId :: Gen.Gen QC.Result
+checkJoinSplitNameId = do
+  n <- genAmbigiousName
+  pure $ joinName (splitName n) === id n
+
 checkRelative :: forall b. IsDirOrFile b => Gen.Gen (Path Abs b) -> Gen.Gen QC.Result
 checkRelative gen = do
   p1 <- gen
@@ -92,6 +121,8 @@ main = do
   info "checking `parse <<< print` for `RelFile`" *> QC.quickCheck parsePrintRelFilePath
   info "checking `relativeTo` for `AbsDir`" *> QC.quickCheck (checkRelative PG.genAbsDirPath)
   info "checking `relativeTo` for `AbsFile`" *> QC.quickCheck (checkRelative PG.genAbsFilePath)
+  info "checking `joinName <<< splitName === id`" *> QC.quickCheck 100 checkJoinSplitNameId
+  info "checking `alterExtension id === id`" *> QC.quickCheck 100 checkAlterExtensionId
 
   -- Should not compile:
   -- test
@@ -231,6 +262,22 @@ main = do
     (rename (alterExtension (const Nothing)) (file (SProxy :: SProxy "image.png")))
     (file $ SProxy :: SProxy "image")
 
+  test """extension (Name ".foo")    == Nothing"""
+    (extension (reflectName $ SProxy :: SProxy ".foo"))
+    (Nothing)
+  test """extension (Name "foo.")    == Nothing"""
+    (extension (reflectName $ SProxy :: SProxy "foo."))
+    (Nothing)
+  test """extension (Name "foo")    == Nothing"""
+    (extension (reflectName $ SProxy :: SProxy "foo"))
+    (Nothing)
+  test """extension (Name ".")       == Nothing"""
+    (extension (reflectName $ SProxy :: SProxy "."))
+    (Nothing)
+  test """extension (Name "foo.baz") == (Just "baz")"""
+    (extension (reflectName $ SProxy :: SProxy "foo.baz"))
+    (NES.fromString "baz")
+
   test "sandbox - fail when relative path lies outside sandbox (above)"
     (sandbox (rootDir </> dirBar) (parentOf currentDir))
     Nothing