Basic Path type with parsers and test suite

.ghci

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

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
+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

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

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

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