Basic Path type with parsers and test suite

This commit is contained in:
Chris Done 2015-05-08 12:21:12 +02:00
parent accc5c3794
commit 1e5b6675c2
5 changed files with 335 additions and 8 deletions

2
.ghci Executable file
View File

@ -0,0 +1,2 @@
:set -package HUnit -package hspec
:set -package template-haskell

View File

@ -14,11 +14,18 @@ cabal-version: >=1.8
library
hs-source-dirs: src/
ghc-options: -Wall -O2
exposed-modules:
exposed-modules: Path, Path.Internal
build-depends: base >= 4 && <5
, exceptions
, filepath
, template-haskell
executable paths
hs-source-dirs: src/
ghc-options: -Wall -O2
test-suite test
type: exitcode-stdio-1.0
main-is: Main.hs
build-depends: base >= 4 && < 5
hs-source-dirs: test
build-depends: HUnit
, base
, hspec
, mtl
, paths

View File

@ -1,3 +1,192 @@
-- |
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE EmptyDataDecls #-}
module Path where
-- | A normalizing well-typed path type.
module Path
(-- * Types
Path
,Abs
,Rel
,File
,Dir
-- * Parsing
,parseAbsDir
,parseRelDir
,parseAbsFile
,parseRelFile
,PathParseException
-- * Constructors
,mkAbsDir
,mkRelDir
,mkAbsFile
,mkRelFile
-- * Conversion
,toFilePath
)
where
import Control.Exception (Exception)
import Control.Monad.Catch (MonadThrow(..))
import Data.Data
import Data.List
import Language.Haskell.TH
import Path.Internal
import qualified System.FilePath as FilePath
--------------------------------------------------------------------------------
-- Types
-- | An absolute path.
data Abs
-- | A relative path; one without a root.
data Rel
-- | A file path.
data File
-- | A directory path.
data Dir
-- | Exception when parsing a location.
data PathParseException
= InvalidAbsDir FilePath
| InvalidRelDir FilePath
| InvalidAbsFile FilePath
| InvalidRelFile FilePath
deriving (Show,Typeable)
instance Exception PathParseException
--------------------------------------------------------------------------------
-- Parsers
-- | Get a location for an absolute directory. Produces a normalized
-- path which always ends in a path separator.
--
-- Throws: 'PathParseException'
--
parseAbsDir :: MonadThrow m
=> FilePath -> m (Path Abs Dir)
parseAbsDir filepath =
if FilePath.isAbsolute filepath &&
not (null (normalizeDir filepath)) &&
not (isPrefixOf "~/" filepath)
then return (Path (normalizeDir filepath))
else throwM (InvalidAbsDir filepath)
-- | Get a location for a relative directory. Produces a normalized
-- path which always ends in a path separator.
--
-- Throws: 'PathParseException'
--
parseRelDir :: MonadThrow m
=> FilePath -> m (Path Rel Dir)
parseRelDir filepath =
if not (FilePath.isAbsolute filepath) &&
not (null filepath) &&
not (isPrefixOf "~/" filepath) &&
not (null (normalizeDir filepath))
then return (Path (normalizeDir filepath))
else throwM (InvalidRelDir filepath)
-- | Get a location for an absolute file. Produces a normalized
-- path which always ends in a path separator.
--
-- Throws: 'PathParseException'
--
parseAbsFile :: MonadThrow m
=> FilePath -> m (Path Abs File)
parseAbsFile filepath =
if FilePath.isAbsolute filepath &&
not (FilePath.hasTrailingPathSeparator filepath) &&
not (isPrefixOf "~/" filepath) &&
not (null (normalizeFile filepath))
then return (Path (normalizeFile filepath))
else throwM (InvalidAbsFile filepath)
-- | Get a location for a relative file. Produces a normalized
-- path which always ends in a path separator.
--
-- Throws: 'PathParseException'
--
parseRelFile :: MonadThrow m
=> FilePath -> m (Path Rel File)
parseRelFile filepath =
if not (FilePath.isAbsolute filepath || FilePath.hasTrailingPathSeparator filepath) &&
not (null filepath) &&
not (isPrefixOf "~/" filepath) &&
not (null (normalizeFile filepath))
then return (Path (normalizeFile filepath))
else throwM (InvalidRelFile filepath)
--------------------------------------------------------------------------------
-- Constructors
-- | Make a 'Path Abs Dir'.
--
-- Remember: due to the nature of absolute paths this (e.g. @\/home\/foo@)
-- may compile on your platform, but it may not compile on another
-- platform (Windows).
mkAbsDir :: FilePath -> Q Exp
mkAbsDir s =
case parseAbsDir s of
Left err -> error (show err)
Right (Path str) ->
[|Path $(return (LitE (StringL str))) :: Path Abs Dir|]
-- | Make a 'Path Rel Dir'.
mkRelDir :: FilePath -> Q Exp
mkRelDir s =
case parseRelDir s of
Left err -> error (show err)
Right (Path str) ->
[|Path $(return (LitE (StringL str))) :: Path Rel Dir|]
-- | Make a 'Path Abs File'.
--
-- Remember: due to the nature of absolute paths this (e.g. @\/home\/foo@)
-- may compile on your platform, but it may not compile on another
-- platform (Windows).
mkAbsFile :: FilePath -> Q Exp
mkAbsFile s =
case parseAbsFile s of
Left err -> error (show err)
Right (Path str) ->
[|Path $(return (LitE (StringL str))) :: Path Abs File|]
-- | Make a 'Path Rel File'.
mkRelFile :: FilePath -> Q Exp
mkRelFile s =
case parseRelFile s of
Left err -> error (show err)
Right (Path str) ->
[|Path $(return (LitE (StringL str))) :: Path Rel File|]
--------------------------------------------------------------------------------
-- Conversion
-- | Convert to a 'FilePath' type.
toFilePath :: Path b t -> FilePath
toFilePath (Path l) = l
--------------------------------------------------------------------------------
-- Internal functions
-- | Internal use for normalizing a directory.
normalizeDir :: FilePath -> FilePath
normalizeDir =
clean . FilePath.addTrailingPathSeparator . FilePath.normalise
where clean "./" = ""
clean ('/':'/':xs) = clean ('/':xs)
clean x = x
-- | Internal use for normalizing a fileectory.
normalizeFile :: FilePath -> FilePath
normalizeFile =
clean . FilePath.normalise
where clean "./" = ""
clean ('/':'/':xs) = clean ('/':xs)
clean x = x

19
src/Path/Internal.hs Normal file
View File

@ -0,0 +1,19 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | Internal types and functions.
module Path.Internal
(Path(..))
where
import Data.Data
import GHC.Generics
-- | Path of some base and type.
newtype Path b t = Path FilePath
deriving (Eq,Ord,Typeable,Data,Generic)
instance Show (Path b t) where
show (Path x) = show x

110
test/Main.hs Normal file
View File

@ -0,0 +1,110 @@
-- | Test suite.
module Main where
import Path
import Path.Internal
import Data.Monoid
import Test.Hspec
-- | Test suite entry point, returns exit failure if any test fails.
main :: IO ()
main = hspec spec
-- | Test suite.
spec :: Spec
spec = do
describe "Parsing: Path Abs Dir" parseAbsDirSpec
describe "Parsing: Path Rel Dir" parseRelDirSpec
describe "Parsing: Path Abs File" parseAbsFileSpec
describe "Parsing: Path Rel File" parseRelFileSpec
-- | Tests for the tokenizer.
parseAbsDirSpec :: Spec
parseAbsDirSpec =
do failing ""
failing "./"
failing "~/"
failing "foo.txt"
succeeding "/" (Path "/")
succeeding "//" (Path "/")
succeeding "///foo//bar//mu/" (Path "/foo/bar/mu/")
succeeding "///foo//bar////mu" (Path "/foo/bar/mu/")
succeeding "///foo//bar/.//mu" (Path "/foo/bar/mu/")
where failing x = parserTest parseAbsDir x Nothing
succeeding x with = parserTest parseAbsDir x (Just with)
-- | Tests for the tokenizer.
parseRelDirSpec :: Spec
parseRelDirSpec =
do failing ""
failing "/"
failing "//"
failing "~/"
failing "/"
failing "./"
failing "//"
failing "///foo//bar//mu/"
failing "///foo//bar////mu"
failing "///foo//bar/.//mu"
succeeding "foo.bak" (Path "foo.bak/")
succeeding "./foo" (Path "foo/")
succeeding "foo//bar//mu//" (Path "foo/bar/mu/")
succeeding "foo//bar////mu" (Path "foo/bar/mu/")
succeeding "foo//bar/.//mu" (Path "foo/bar/mu/")
where failing x = parserTest parseRelDir x Nothing
succeeding x with = parserTest parseRelDir x (Just with)
-- | Tests for the tokenizer.
parseAbsFileSpec :: Spec
parseAbsFileSpec =
do failing ""
failing "./"
failing "~/"
failing "./foo.txt"
failing "/"
failing "//"
failing "///foo//bar//mu/"
succeeding "/foo.txt" (Path "/foo.txt")
succeeding "///foo//bar////mu.txt" (Path "/foo/bar/mu.txt")
succeeding "///foo//bar/.//mu.txt" (Path "/foo/bar/mu.txt")
where failing x = parserTest parseAbsFile x Nothing
succeeding x with = parserTest parseAbsFile x (Just with)
-- | Tests for the tokenizer.
parseRelFileSpec :: Spec
parseRelFileSpec =
do failing ""
failing "/"
failing "//"
failing "~/"
failing "/"
failing "./"
failing "//"
failing "///foo//bar//mu/"
failing "///foo//bar////mu"
failing "///foo//bar/.//mu"
succeeding "foo.txt" (Path "foo.txt")
succeeding "./foo.txt" (Path "foo.txt")
succeeding "foo//bar//mu.txt" (Path "foo/bar/mu.txt")
succeeding "foo//bar////mu.txt" (Path "foo/bar/mu.txt")
succeeding "foo//bar/.//mu.txt" (Path "foo/bar/mu.txt")
where failing x = parserTest parseRelFile x Nothing
succeeding x with = parserTest parseRelFile x (Just with)
-- | Parser test.
parserTest :: (Show a1,Show a,Eq a1)
=> (a -> Maybe a1) -> a -> Maybe a1 -> SpecWith ()
parserTest parser input expected =
it ((case expected of
Nothing -> "Failing: "
Just{} -> "Succeeding: ") <>
"Parsing " <>
show input <>
" " <>
case expected of
Nothing -> "should fail."
Just x -> "should succeed with: " <> show x)
(actual == expected)
where actual = parser input