path-extra 0.1.2 → 0.2.0

raw patch · 3 files changed

+122/−284 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• path-extra.cabal +3/−3
• src/Path/Extended.hs +92/−182
• test/Spec.hs +27/−99

@@ -2,11 +2,11 @@ -- -- see: https://github.com/sol/hpack ----- hash: ef6199423093f720df1ad58097710e484ee8d805792c0f83655265f54fd65ded+-- hash: 4604482be921c24c141cd64233a1fb7ef12012a76e45a51aacdfb5726aef5367  name:           path-extra-version:        0.1.2-synopsis:       Some extensions to Chris Done's path library, for use with urlpath and attoparsec-uri.+version:        0.2.0+synopsis:       URLs without host information description:    Please see the README on Github at <https://github.com/githubuser/localcooking-db#readme> category:       System, Filesystem, Web homepage:       https://github.com/athanclark/path-extra#readme

@@ -4,6 +4,8 @@   , NamedFieldPuns   , ScopedTypeVariables   , OverloadedStrings+  , QuasiQuotes+  , DeriveGeneric   #-}  module Path.Extended@@ -16,18 +18,10 @@   , FromPath (..)   , FromLocation (..)   , -- * Combinators-    -- ** Append-    PathAppend (..)-  , -- ** Parent Accessors-    addParent-  , delParent-  , -- ** Path-    fromPath-  , -- ** File Extensions-    setFileExt-  , addFileExt-  , delFileExt-  , getFileExt+    -- ** Path+    fromAbsDir+  , fromAbsFile+  , prepend   , -- ** Query Parameters     setQuery   , addQuery@@ -41,28 +35,26 @@   , (<#>)   , delFragment   , getFragment-  , -- ** Parsers-    locationAbsDirParser-  , locationAbsFileParser+  , -- ** Parser & Printer+    locationParser+  , printLocation   ) where -import Path as P hiding ((</>))-import qualified Path as P ((</>))+-- import Path as P hiding ((</>))+import Path (Path, Abs, Dir, File, (</>), toFilePath, parseAbsFile, parseAbsDir, stripProperPrefix, absdir)  import Prelude hiding (takeWhile) import Data.List (intercalate)-import Data.Attoparsec.Text (Parser, char, takeWhile, takeWhile1, sepBy, sepBy1)+import Data.Attoparsec.Text (Parser, char, takeWhile, takeWhile1, sepBy, sepBy1, many1) import qualified Data.Text as T import Data.Monoid ((<>))-import Control.Applicative (Alternative (many), optional)+import Control.Applicative (Alternative (many), (<|>), optional) import Control.Exception (SomeException) import Control.Monad (void)+import GHC.Generics (Generic)  -class PathAppend right base type' where-  (</>) :: Path base Dir -> right Rel type' -> right base type' - -- | Convenience typeclass for symbolic, stringless routes - make an instance -- for your own data type to use your constructors as route-referencing symbols. class ToPath sym base type' | sym -> base type' where@@ -70,75 +62,59 @@  -- | Convenience typeclass for symbolic, stringless routes - make an instance -- for your own data type to use your constructors as route-referencing symbols.-class ToLocation sym base type' | sym -> base type' where-  toLocation :: sym -> Location base type'+class ToLocation sym where+  toLocation :: sym -> Location  class FromPath sym base type' | sym -> base type' where   parsePath :: Path base type' -> Either String sym -class FromLocation sym base type' | sym -> base type' where-  parseLocation :: Location base type' -> Either String sym+class FromLocation sym where+  parseLocation :: Location -> Either String sym    -- | A location for some base and type - internally uses @Path@.-data Location b t = Location-  { locParentJumps :: Int -- ^ only when b ~ Rel-  , locPath        :: Path b t-  , locFileExt     :: Maybe String -- ^ only when t ~ File+data Location = Location+  { locPath        :: Either (Path Abs Dir) (Path Abs File)   , locQueryParams :: [QueryParam]   , locFragment    :: Maybe String-  } deriving (Eq, Ord)+  } deriving (Eq, Ord, Generic)   +fromAbsDir :: Path Abs Dir -> Location+fromAbsDir path = Location+  { locPath = Left path+  , locQueryParams = []+  , locFragment = Nothing+  } -locationAbsDirParser :: Parser (Location Abs Dir)-locationAbsDirParser = do-  locPath <- absDir-  locQueryParams <- do-    xs <- optional $ do-      let val = T.unpack <$> takeWhile (`notElem` ['=','&','#'])-      void (char '?')-      let kv = do-            k <- val-            mV <- optional $ do-              void (char '=')-              val-            pure (k,mV)-      kv `sepBy` void (char '&')-    case xs of-      Nothing -> pure []-      Just xs' -> pure xs'-  locFragment <- optional $ do-    void (char '#')-    xs <- takeWhile (const True)-    pure (T.unpack xs)-  pure Location-    { locParentJumps = 0-    , locPath-    , locFileExt = Nothing-    , locQueryParams-    , locFragment-    }-  where-    divider = void (char '/')-    chunk = takeWhile1 (`notElem` ['?','&','/','#'])-    absDir :: Parser (Path Abs Dir)-    absDir = do-      divider-      xs <- many (chunk <* divider)-      case parseAbsDir ( case xs of-                           [] -> "/"-                           _  -> T.unpack ("/" <> T.intercalate "/" xs <> "/")-                       ) of-        Left (e :: SomeException) -> fail (show e)-        Right x -> pure x+fromAbsFile :: Path Abs File -> Location+fromAbsFile path = Location+  { locPath = Right path+  , locQueryParams = []+  , locFragment = Nothing+  }  -locationAbsFileParser :: Parser (Location Abs File)-locationAbsFileParser = do-  (locPath, locFileExt) <- absFile+locationParser :: Parser Location+locationParser = do+  divider+  locPath <- do+    xs <- chunk `sepBy` divider+    case xs of+      [] -> pure (Left [absdir|/|])+      _ -> do+        let dir = do+              divider+              case parseAbsDir (T.unpack ("/" <> T.intercalate "/" xs <> "/")) of+                Left (e :: SomeException) -> fail (show e)+                Right x -> pure (Left x)+            file =+              case parseAbsFile (T.unpack ("/" <> T.intercalate "/" xs)) of+                Left (e :: SomeException) -> fail (show e)+                Right x -> pure (Right x)+        dir <|> file   locQueryParams <- do     xs <- optional $ do       let val = T.unpack <$> takeWhile (`notElem` ['=','&','#'])@@ -158,148 +134,82 @@     xs <- takeWhile (const True)     pure (T.unpack xs)   pure Location-    { locParentJumps = 0-    , locPath-    , locFileExt+    { locPath     , locQueryParams     , locFragment     }   where     divider = void (char '/')     chunk = takeWhile1 (`notElem` ['?','&','/','#'])-    absFile :: Parser (Path Abs File, Maybe String)-    absFile = do-      divider-      xs <- chunk `sepBy1` divider-      let (withoutFE,withFE) = T.breakOn "." (last xs)-          xs' = init xs <> [withoutFE]-      path <- case parseAbsFile (T.unpack ("/" <> T.intercalate "/" xs')) of-        Left (e :: SomeException) -> fail (show e)-        Right x -> pure x-      pure-        ( path-        , if T.null withFE-          then Nothing-          else Just $ T.unpack $ T.drop 1 withFE-        )  -instance PathAppend Path Abs Dir where-  (</>) = (P.</>)+prepend :: Path Abs Dir -> Location -> Location+prepend path l@Location{locPath} = l+  { locPath = case locPath of+      Left d -> case stripProperPrefix [absdir|/|] d of+        Nothing -> error "impossible state"+        Just d' -> Left (path </> d')+      Right f -> case stripProperPrefix [absdir|/|] f of+        Nothing -> error "impossible state"+        Just f' -> Right (path </> f')+  } -instance PathAppend Path Abs File where-  (</>) = (P.</>) -instance PathAppend Path Rel Dir where-  (</>) = (P.</>) -instance PathAppend Path Rel File where-  (</>) = (P.</>)--instance PathAppend Location Abs Dir where-  l </> (Location ps pa fe qp fr) =-    Location ps ((P.</>) l pa) fe qp fr--instance PathAppend Location Abs File where-  l </> (Location ps pa fe qp fr) =-    Location ps ((P.</>) l pa) fe qp fr--instance PathAppend Location Rel Dir where-  l </> (Location ps pa fe qp fr) =-    Location ps ((P.</>) l pa) fe qp fr--instance PathAppend Location Rel File where-  l </> (Location ps pa fe qp fr) =-    Location ps ((P.</>) l pa) fe qp fr---instance Show (Location b t) where-  show (Location js pa fe qp fr) =-    let loc = concat (replicate js "../")-           ++ toFilePath pa-           ++ maybe "" (\f -> "." ++ f) fe-        query = case qp of-                  [] -> ""-                  qs -> "?" ++ intercalate "&" (map go qs)-          where-            go (k,mv) = k ++ maybe "" (\v -> "=" ++ v) mv-    in loc ++ query ++ maybe "" (\f -> "#" ++ f) fr+printLocation :: Location -> T.Text+printLocation (Location pa qp fr) =+  let loc = either toFilePath toFilePath pa+      query = case qp of+                [] -> ""+                qs -> "?" <> T.intercalate "&" (go <$> qs)+        where+          go (k,mv) = T.pack k <> maybe "" (\v -> "=" <> T.pack v) mv+  in T.pack loc <> query <> maybe "" (\f -> "#" <> T.pack f) fr  type QueryParam = (String, Maybe String)   --- | Prepend a parental accessor path - @../@-addParent :: Location Rel t -> Location Rel t-addParent (Location j pa fe qp fr) =-  Location (j+1) pa fe qp fr--delParent :: Location Rel t -> Location Rel t-delParent l@(Location j pa fe qp fr)-  | j <= 0    = l-  | otherwise = Location (j-1) pa fe qp fr----- | This should be your entry point for creating a @Location@.-fromPath :: Path b t -> Location b t-fromPath pa = Location 0 pa Nothing [] Nothing---setFileExt :: Maybe String -> Location b File -> Location b File-setFileExt fe (Location js pa _ qp fr) =-  Location js pa fe qp fr--addFileExt :: String -> Location b File -> Location b File-addFileExt fe = setFileExt (Just fe)--delFileExt :: Location b File -> Location b File-delFileExt = setFileExt Nothing--getFileExt :: Location b File -> Maybe String-getFileExt (Location _ _ fe _ _) =-  fe---setQuery :: [QueryParam] -> Location b t -> Location b t-setQuery qp (Location js pa fe _ fr) =-  Location js pa fe qp fr+setQuery :: [QueryParam] -> Location -> Location+setQuery qp (Location pa _ fr) =+  Location pa qp fr  -- | Appends a query parameter-addQuery :: QueryParam -> Location b t -> Location b t-addQuery q (Location js pa fe qp fr) =-  Location js pa fe (qp ++ [q]) fr+addQuery :: QueryParam -> Location -> Location+addQuery q (Location pa qp fr) =+  Location pa (qp ++ [q]) fr -(<&>) :: Location b t -> QueryParam -> Location b t+(<&>) :: Location -> QueryParam -> Location (<&>) = flip addQuery  infixl 7 <&> -addQueries :: [QueryParam] -> Location b t -> Location b t-addQueries qs (Location js pa fe qs' fr) =-  Location js pa fe (qs' ++ qs) fr+addQueries :: [QueryParam] -> Location -> Location+addQueries qs (Location pa qs' fr) =+  Location pa (qs' ++ qs) fr -delQuery :: Location b t -> Location b t+delQuery :: Location -> Location delQuery = setQuery [] -getQuery :: Location b t -> [QueryParam]-getQuery (Location _ _ _ qp _) =+getQuery :: Location -> [QueryParam]+getQuery (Location _ qp _) =   qp  -setFragment :: Maybe String -> Location b t -> Location b t-setFragment fr (Location js pa fe qp _) =-  Location js pa fe qp fr+setFragment :: Maybe String -> Location -> Location+setFragment fr (Location pa qp _) =+  Location pa qp fr -addFragment :: String -> Location b t -> Location b t+addFragment :: String -> Location -> Location addFragment fr = setFragment (Just fr) -(<#>) :: Location b t -> String -> Location b t+(<#>) :: Location -> String -> Location (<#>) = flip addFragment  infixl 8 <#> -delFragment :: Location b t -> Location b t+delFragment :: Location -> Location delFragment = setFragment Nothing -getFragment :: Location b t -> Maybe String-getFragment (Location _ _ _ _ x) = x+getFragment :: Location -> Maybe String+getFragment (Location _ _ x) = x

@@ -2,12 +2,13 @@     NamedFieldPuns   , OverloadedStrings   , ScopedTypeVariables+  , StandaloneDeriving   #-}  module Main where  import Path (parseAbsDir, parseAbsFile, Path, Abs, Dir, File)-import Path.Extended (Location (..), QueryParam, locationAbsDirParser, locationAbsFileParser)+import Path.Extended (Location (..), QueryParam, locationParser, printLocation)  import qualified Data.Text as T import Data.Monoid ((<>))@@ -18,35 +19,35 @@ import Test.Tasty (defaultMain, testGroup) import qualified Test.Tasty.QuickCheck as QC import Test.QuickCheck (Arbitrary (..), suchThat)-import Test.QuickCheck.Gen (Gen, choose, elements, listOf)+import Test.QuickCheck.Gen (Gen, choose, elements, listOf, oneof) import Test.QuickCheck.Instances ()   -newtype ArbitraryLocationAbsDir = ArbitraryLocationAbsDir-  { getArbitraryLocationAbsDir :: Location Abs Dir+newtype ArbitraryLocation = ArbitraryLocation+  { getArbitraryLocation :: Location   } deriving (Eq, Show) -instance Arbitrary ArbitraryLocationAbsDir where+instance Arbitrary ArbitraryLocation where   arbitrary = do-    locPath <- arbitraryPath+    locPath <- oneof [Left <$> arbitraryAbsDir, Right <$> arbitraryAbsFile]     locQueryParams <- arbitraryQueryParams     locFragment <- arbitraryFragment-    pure $ ArbitraryLocationAbsDir Location-      { locParentJumps = 0-      , locPath-      , locFileExt = Nothing+    pure $ ArbitraryLocation Location+      { locPath       , locQueryParams       , locFragment       }     where+      arbitraryWord :: Gen String+      arbitraryWord = listOf (elements (['A'..'Z']++['a'..'z'])) `suchThat` (not . null)+       arbitraryFragment :: Gen (Maybe String)       arbitraryFragment = do         build <- arbitrary         if not build           then pure Nothing-          else-            fmap Just $ listOf (elements (['A'..'Z'] <> ['a'..'z'])) `suchThat` (not . null)+          else fmap Just arbitraryWord        arbitraryQueryParams :: Gen [QueryParam]       arbitraryQueryParams = do@@ -54,25 +55,22 @@         if not build           then pure []           else do-            let arbitraryVal :: Gen String-                arbitraryVal =-                  listOf (elements (['A'..'Z'] <> ['a'..'z'])) `suchThat` (not . null)             n <- choose (1,4)             let arbitraryKV :: Gen QueryParam                 arbitraryKV = do-                  k <- arbitraryVal+                  k <- arbitraryWord                   buildVal <- arbitrary                   mV <-                     if buildVal-                    then Just <$> arbitraryVal+                    then Just <$> arbitraryWord                     else pure Nothing                   pure (k,mV)             replicateM n arbitraryKV -      arbitraryPath :: Gen (Path Abs Dir)-      arbitraryPath = do+      arbitraryAbsDir :: Gen (Path Abs Dir)+      arbitraryAbsDir = do         n <- choose (0,5)-        xs <- replicateM n arbitraryChunk+        xs <- replicateM n (T.pack <$> arbitraryWord)         pure $ case parseAbsDir ( case xs of                                     [] -> "/"                                     _ -> T.unpack ("/" <> T.intercalate "/" xs <> "/")@@ -81,97 +79,27 @@                    error $ "Can't parse abs dir! " <> show e                  Right path -> path -      arbitraryChunk :: Gen T.Text-      arbitraryChunk = fmap T.pack $-        listOf (elements (['A'..'Z'] <> ['a'..'z'])) `suchThat` (not . null)---newtype ArbitraryLocationAbsFile = ArbitraryLocationAbsFile-  { getArbitraryLocationAbsFile :: Location Abs File-  } deriving (Eq, Show)--instance Arbitrary ArbitraryLocationAbsFile where-  arbitrary = do-    locPath <- arbitraryPath-    locFileExt <- arbitraryFileExt-    locQueryParams <- arbitraryQueryParams-    locFragment <- arbitraryFragment-    pure $ ArbitraryLocationAbsFile Location-      { locParentJumps = 0-      , locPath-      , locFileExt-      , locQueryParams-      , locFragment-      }-    where-      arbitraryFragment :: Gen (Maybe String)-      arbitraryFragment = do-        build <- arbitrary-        if not build-          then pure Nothing-          else-            fmap Just $ listOf (elements (['A'..'Z'] <> ['a'..'z'])) `suchThat` (not . null)--      arbitraryQueryParams :: Gen [QueryParam]-      arbitraryQueryParams = do-        build <- arbitrary-        if not build-          then pure []-          else do-            let arbitraryVal :: Gen String-                arbitraryVal =-                  listOf (elements (['A'..'Z'] <> ['a'..'z'])) `suchThat` (not . null)-            n <- choose (1,4)-            let arbitraryKV :: Gen QueryParam-                arbitraryKV = do-                  k <- arbitraryVal-                  buildVal <- arbitrary-                  mV <--                    if buildVal-                    then Just <$> arbitraryVal-                    else pure Nothing-                  pure (k,mV)-            replicateM n arbitraryKV--      arbitraryPath :: Gen (Path Abs File)-      arbitraryPath = do+      arbitraryAbsFile :: Gen (Path Abs File)+      arbitraryAbsFile = do         n <- choose (1,5)-        xs <- replicateM n arbitraryChunk-        pure $ case parseAbsFile ( case xs of-                                    [] -> "/"-                                    _ -> T.unpack ("/" <> T.intercalate "/" xs)-                                 ) of+        xs <- replicateM n (T.pack <$> arbitraryWord)+        pure $ case parseAbsFile (T.unpack ("/" <> T.intercalate "/" xs)) of                  Left (e :: SomeException) ->                    error $ "Can't parse abs file! " <> show e                  Right path -> path -      arbitraryFileExt :: Gen (Maybe String)-      arbitraryFileExt = do-        build <- arbitrary-        if not build-          then pure Nothing-          else-            Just <$> listOf (elements (['A'..'Z'] <> ['a'..'z'])) `suchThat` (not . null) -      arbitraryChunk :: Gen T.Text-      arbitraryChunk = fmap T.pack $-        listOf (elements (['A'..'Z'] <> ['a'..'z'])) `suchThat` (not . null)-+deriving instance Show Location  -printParseIsoAbsDir :: ArbitraryLocationAbsDir -> Bool-printParseIsoAbsDir (ArbitraryLocationAbsDir loc) =-  Right loc == parseOnly locationAbsDirParser (T.pack (show loc))--printParseIsoAbsFile :: ArbitraryLocationAbsFile -> Bool-printParseIsoAbsFile (ArbitraryLocationAbsFile loc) =-  Right loc == parseOnly locationAbsFileParser (T.pack (show loc))+printParseIso :: ArbitraryLocation -> Bool+printParseIso (ArbitraryLocation loc) =+  Right loc == parseOnly locationParser (printLocation loc)    main :: IO () main = defaultMain $   testGroup "Path.Extended"-    [ QC.testProperty "Print / Parse AbsDir Iso" printParseIsoAbsDir-    , QC.testProperty "Print / Parse AbsFile Iso" printParseIsoAbsFile+    [ QC.testProperty "Print / Parse Iso" printParseIso     ]