Browse Source

Basic Path type with parsers and test suite

tags/0.2.0
Chris Done 5 years ago
parent
commit
1e5b6675c2
5 changed files with 335 additions and 7 deletions
  1. +2
    -0
      .ghci
  2. +13
    -6
      paths.cabal
  3. +191
    -1
      src/Path.hs
  4. +19
    -0
      src/Path/Internal.hs
  5. +110
    -0
      test/Main.hs

+ 2
- 0
.ghci View File

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

+ 13
- 6
paths.cabal 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
main-is: Main.hs
build-depends: base >= 4 && < 5
test-suite test
type: exitcode-stdio-1.0
main-is: Main.hs
hs-source-dirs: test
build-depends: HUnit
, base
, hspec
, mtl
, paths

+ 191
- 1
src/Path.hs 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
- 0
src/Path/Internal.hs 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
- 0
test/Main.hs 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

Loading…
Cancel
Save