Basic Path type with parsers and test suite

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