diff --git a/.ghci b/.ghci new file mode 100755 index 0000000..01c3587 --- /dev/null +++ b/.ghci @@ -0,0 +1,2 @@ +:set -package HUnit -package hspec +:set -package template-haskell diff --git a/paths.cabal b/paths.cabal index 61a0bce..ebf43a9 100644 --- a/paths.cabal +++ b/paths.cabal @@ -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 diff --git a/src/Path.hs b/src/Path.hs index 4f5e9e0..cea8d7f 100644 --- a/src/Path.hs +++ b/src/Path.hs @@ -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 diff --git a/src/Path/Internal.hs b/src/Path/Internal.hs new file mode 100644 index 0000000..b537581 --- /dev/null +++ b/src/Path/Internal.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..7be72b1 --- /dev/null +++ b/test/Main.hs @@ -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