path-extra 0.1.1 → 0.1.2
raw patch · 3 files changed
+309/−4 lines, 3 filesdep +QuickCheckdep +attoparsecdep +path-extra
Dependencies added: QuickCheck, attoparsec, path-extra, quickcheck-instances, tasty, tasty-quickcheck, text
Files
- path-extra.cabal +26/−4
- src/Path/Extended.hs +106/−0
- test/Spec.hs +177/−0
path-extra.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 373b686527cf454dee43b179ea2c6733f768eb0bd0e1a6701bc6fddbe12fccc0+-- hash: ef6199423093f720df1ad58097710e484ee8d805792c0f83655265f54fd65ded name: path-extra-version: 0.1.1+version: 0.1.2 synopsis: Some extensions to Chris Done's path library, for use with urlpath and attoparsec-uri. description: Please see the README on Github at <https://github.com/githubuser/localcooking-db#readme> category: System, Filesystem, Web@@ -13,7 +13,7 @@ bug-reports: https://github.com/athanclark/path-extra/issues author: Athan Clark maintainer: athan.clark@localcooking.com-copyright: Copyright (c) 2018 Local Cooking Inc.+copyright: Copyright (c) 2018 Athan Clark license: BSD3 license-file: LICENSE build-type: Simple@@ -35,6 +35,28 @@ src ghc-options: -Wall build-depends:- base >=4.8 && <5+ attoparsec+ , base >=4.8 && <5 , path+ , text+ default-language: Haskell2010++test-suite path-extra-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_path_extra+ hs-source-dirs:+ test+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ QuickCheck+ , attoparsec+ , base >=4.8 && <5+ , path+ , path-extra+ , quickcheck-instances+ , tasty+ , tasty-quickcheck+ , text default-language: Haskell2010
src/Path/Extended.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE MultiParamTypeClasses , FunctionalDependencies+ , NamedFieldPuns+ , ScopedTypeVariables+ , OverloadedStrings #-} module Path.Extended@@ -38,12 +41,22 @@ , (<#>) , delFragment , getFragment+ , -- ** Parsers+ locationAbsDirParser+ , locationAbsFileParser ) where import Path as P hiding ((</>)) import qualified Path as P ((</>)) +import Prelude hiding (takeWhile) import Data.List (intercalate)+import Data.Attoparsec.Text (Parser, char, takeWhile, takeWhile1, sepBy, sepBy1)+import qualified Data.Text as T+import Data.Monoid ((<>))+import Control.Applicative (Alternative (many), optional)+import Control.Exception (SomeException)+import Control.Monad (void) class PathAppend right base type' where@@ -76,6 +89,99 @@ , locQueryParams :: [QueryParam] , locFragment :: Maybe String } deriving (Eq, Ord)+++++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+++locationAbsFileParser :: Parser (Location Abs File)+locationAbsFileParser = do+ (locPath, locFileExt) <- absFile+ 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+ , 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
+ test/Spec.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE+ NamedFieldPuns+ , OverloadedStrings+ , ScopedTypeVariables+ #-}++module Main where++import Path (parseAbsDir, parseAbsFile, Path, Abs, Dir, File)+import Path.Extended (Location (..), QueryParam, locationAbsDirParser, locationAbsFileParser)++import qualified Data.Text as T+import Data.Monoid ((<>))+import Data.Attoparsec.Text (parseOnly)+import Control.Exception (SomeException)+import Control.Monad (replicateM)++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.Instances ()++++newtype ArbitraryLocationAbsDir = ArbitraryLocationAbsDir+ { getArbitraryLocationAbsDir :: Location Abs Dir+ } deriving (Eq, Show)++instance Arbitrary ArbitraryLocationAbsDir where+ arbitrary = do+ locPath <- arbitraryPath+ locQueryParams <- arbitraryQueryParams+ locFragment <- arbitraryFragment+ pure $ ArbitraryLocationAbsDir Location+ { locParentJumps = 0+ , locPath+ , locFileExt = Nothing+ , 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 Dir)+ arbitraryPath = do+ n <- choose (0,5)+ xs <- replicateM n arbitraryChunk+ pure $ case parseAbsDir ( case xs of+ [] -> "/"+ _ -> T.unpack ("/" <> T.intercalate "/" xs <> "/")+ ) of+ Left (e :: SomeException) ->+ 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+ n <- choose (1,5)+ xs <- replicateM n arbitraryChunk+ pure $ case parseAbsFile ( case xs of+ [] -> "/"+ _ -> 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)++++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))++++main :: IO ()+main = defaultMain $+ testGroup "Path.Extended"+ [ QC.testProperty "Print / Parse AbsDir Iso" printParseIsoAbsDir+ , QC.testProperty "Print / Parse AbsFile Iso" printParseIsoAbsFile+ ]