Browse Source

Basic Path type with parsers and test suite

Chris Done 4 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 @@
1
+:set -package HUnit -package hspec
2
+:set -package template-haskell

+ 13
- 6
paths.cabal View File

@@ -14,11 +14,18 @@ cabal-version:       >=1.8
14 14
 library
15 15
   hs-source-dirs:    src/
16 16
   ghc-options:       -Wall -O2
17
-  exposed-modules:   
17
+  exposed-modules:   Path, Path.Internal
18 18
   build-depends:     base >= 4 && <5
19
+                   , exceptions
20
+                   , filepath
21
+                   , template-haskell
19 22
 
20
-executable paths
21
-  hs-source-dirs:    src/
22
-  ghc-options:       -Wall -O2
23
-  main-is:           Main.hs
24
-  build-depends:     base >= 4 && < 5
23
+test-suite test
24
+    type: exitcode-stdio-1.0
25
+    main-is: Main.hs
26
+    hs-source-dirs: test
27
+    build-depends: HUnit
28
+                 , base
29
+                 , hspec
30
+                 , mtl
31
+                 , paths

+ 191
- 1
src/Path.hs View File

@@ -1,3 +1,192 @@
1
+{-# LANGUAGE TemplateHaskell #-}
2
+{-# LANGUAGE DeriveGeneric #-}
3
+{-# LANGUAGE DeriveDataTypeable #-}
4
+{-# LANGUAGE EmptyDataDecls #-}
1 5
 
2
-module Path where
6
+-- | A normalizing well-typed path type.
7
+
8
+module Path
9
+  (-- * Types
10
+   Path
11
+  ,Abs
12
+  ,Rel
13
+  ,File
14
+  ,Dir
15
+   -- * Parsing
16
+  ,parseAbsDir
17
+  ,parseRelDir
18
+  ,parseAbsFile
19
+  ,parseRelFile
20
+  ,PathParseException
21
+  -- * Constructors
22
+  ,mkAbsDir
23
+  ,mkRelDir
24
+  ,mkAbsFile
25
+  ,mkRelFile
26
+  -- * Conversion
27
+  ,toFilePath
28
+  )
29
+  where
30
+
31
+import           Control.Exception (Exception)
32
+import           Control.Monad.Catch (MonadThrow(..))
33
+import           Data.Data
34
+import           Data.List
35
+import           Language.Haskell.TH
36
+import           Path.Internal
37
+import qualified System.FilePath as FilePath
38
+
39
+--------------------------------------------------------------------------------
40
+-- Types
41
+
42
+-- | An absolute path.
43
+data Abs
44
+
45
+-- | A relative path; one without a root.
46
+data Rel
47
+
48
+-- | A file path.
49
+data File
50
+
51
+-- | A directory path.
52
+data Dir
53
+
54
+-- | Exception when parsing a location.
55
+data PathParseException
56
+  = InvalidAbsDir FilePath
57
+  | InvalidRelDir FilePath
58
+  | InvalidAbsFile FilePath
59
+  | InvalidRelFile FilePath
60
+  deriving (Show,Typeable)
61
+instance Exception PathParseException
62
+
63
+--------------------------------------------------------------------------------
64
+-- Parsers
65
+
66
+-- | Get a location for an absolute directory. Produces a normalized
67
+--  path which always ends in a path separator.
68
+--
69
+-- Throws: 'PathParseException'
70
+--
71
+parseAbsDir :: MonadThrow m
72
+            => FilePath -> m (Path Abs Dir)
73
+parseAbsDir filepath =
74
+  if FilePath.isAbsolute filepath &&
75
+     not (null (normalizeDir filepath)) &&
76
+     not (isPrefixOf "~/" filepath)
77
+     then return (Path (normalizeDir filepath))
78
+     else throwM (InvalidAbsDir filepath)
79
+
80
+-- | Get a location for a relative directory. Produces a normalized
81
+-- path which always ends in a path separator.
82
+--
83
+-- Throws: 'PathParseException'
84
+--
85
+parseRelDir :: MonadThrow m
86
+            => FilePath -> m (Path Rel Dir)
87
+parseRelDir filepath =
88
+  if not (FilePath.isAbsolute filepath) &&
89
+     not (null filepath) &&
90
+     not (isPrefixOf "~/" filepath) &&
91
+     not (null (normalizeDir filepath))
92
+     then return (Path (normalizeDir filepath))
93
+     else throwM (InvalidRelDir filepath)
94
+
95
+-- | Get a location for an absolute file. Produces a normalized
96
+--  path which always ends in a path separator.
97
+--
98
+-- Throws: 'PathParseException'
99
+--
100
+parseAbsFile :: MonadThrow m
101
+             => FilePath -> m (Path Abs File)
102
+parseAbsFile filepath =
103
+  if FilePath.isAbsolute filepath &&
104
+     not (FilePath.hasTrailingPathSeparator filepath) &&
105
+     not (isPrefixOf "~/" filepath) &&
106
+     not (null (normalizeFile filepath))
107
+     then return (Path (normalizeFile filepath))
108
+     else throwM (InvalidAbsFile filepath)
109
+
110
+-- | Get a location for a relative file. Produces a normalized
111
+-- path which always ends in a path separator.
112
+--
113
+-- Throws: 'PathParseException'
114
+--
115
+parseRelFile :: MonadThrow m
116
+             => FilePath -> m (Path Rel File)
117
+parseRelFile filepath =
118
+  if not (FilePath.isAbsolute filepath || FilePath.hasTrailingPathSeparator filepath) &&
119
+     not (null filepath) &&
120
+     not (isPrefixOf "~/" filepath) &&
121
+     not (null (normalizeFile filepath))
122
+     then return (Path (normalizeFile filepath))
123
+     else throwM (InvalidRelFile filepath)
124
+
125
+--------------------------------------------------------------------------------
126
+-- Constructors
127
+
128
+-- | Make a 'Path Abs Dir'.
129
+--
130
+-- Remember: due to the nature of absolute paths this (e.g. @\/home\/foo@)
131
+-- may compile on your platform, but it may not compile on another
132
+-- platform (Windows).
133
+mkAbsDir :: FilePath -> Q Exp
134
+mkAbsDir s =
135
+  case parseAbsDir s of
136
+    Left err -> error (show err)
137
+    Right (Path str) ->
138
+      [|Path $(return (LitE (StringL str))) :: Path Abs Dir|]
139
+
140
+-- | Make a 'Path Rel Dir'.
141
+mkRelDir :: FilePath -> Q Exp
142
+mkRelDir s =
143
+  case parseRelDir s of
144
+    Left err -> error (show err)
145
+    Right (Path str) ->
146
+      [|Path $(return (LitE (StringL str))) :: Path Rel Dir|]
147
+
148
+-- | Make a 'Path Abs File'.
149
+--
150
+-- Remember: due to the nature of absolute paths this (e.g. @\/home\/foo@)
151
+-- may compile on your platform, but it may not compile on another
152
+-- platform (Windows).
153
+mkAbsFile :: FilePath -> Q Exp
154
+mkAbsFile s =
155
+  case parseAbsFile s of
156
+    Left err -> error (show err)
157
+    Right (Path str) ->
158
+      [|Path $(return (LitE (StringL str))) :: Path Abs File|]
159
+
160
+-- | Make a 'Path Rel File'.
161
+mkRelFile :: FilePath -> Q Exp
162
+mkRelFile s =
163
+  case parseRelFile s of
164
+    Left err -> error (show err)
165
+    Right (Path str) ->
166
+      [|Path $(return (LitE (StringL str))) :: Path Rel File|]
167
+
168
+--------------------------------------------------------------------------------
169
+-- Conversion
170
+
171
+-- | Convert to a 'FilePath' type.
172
+toFilePath :: Path b t -> FilePath
173
+toFilePath (Path l) = l
174
+
175
+--------------------------------------------------------------------------------
176
+-- Internal functions
177
+
178
+-- | Internal use for normalizing a directory.
179
+normalizeDir :: FilePath -> FilePath
180
+normalizeDir =
181
+  clean . FilePath.addTrailingPathSeparator . FilePath.normalise
182
+  where clean "./" = ""
183
+        clean ('/':'/':xs) = clean ('/':xs)
184
+        clean x = x
185
+
186
+-- | Internal use for normalizing a fileectory.
187
+normalizeFile :: FilePath -> FilePath
188
+normalizeFile =
189
+  clean . FilePath.normalise
190
+  where clean "./" = ""
191
+        clean ('/':'/':xs) = clean ('/':xs)
192
+        clean x = x

+ 19
- 0
src/Path/Internal.hs View File

@@ -0,0 +1,19 @@
1
+{-# LANGUAGE DeriveGeneric #-}
2
+{-# LANGUAGE DeriveDataTypeable #-}
3
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4
+
5
+-- | Internal types and functions.
6
+
7
+module Path.Internal
8
+  (Path(..))
9
+  where
10
+
11
+import Data.Data
12
+import GHC.Generics
13
+
14
+-- | Path of some base and type.
15
+newtype Path b t = Path FilePath
16
+  deriving (Eq,Ord,Typeable,Data,Generic)
17
+
18
+instance Show (Path b t) where
19
+  show (Path x) = show x

+ 110
- 0
test/Main.hs View File

@@ -0,0 +1,110 @@
1
+-- | Test suite.
2
+
3
+module Main where
4
+
5
+import Path
6
+import Path.Internal
7
+
8
+import Data.Monoid
9
+import Test.Hspec
10
+
11
+-- | Test suite entry point, returns exit failure if any test fails.
12
+main :: IO ()
13
+main = hspec spec
14
+
15
+-- | Test suite.
16
+spec :: Spec
17
+spec = do
18
+  describe "Parsing: Path Abs Dir" parseAbsDirSpec
19
+  describe "Parsing: Path Rel Dir" parseRelDirSpec
20
+  describe "Parsing: Path Abs File" parseAbsFileSpec
21
+  describe "Parsing: Path Rel File" parseRelFileSpec
22
+
23
+-- | Tests for the tokenizer.
24
+parseAbsDirSpec :: Spec
25
+parseAbsDirSpec =
26
+  do failing ""
27
+     failing "./"
28
+     failing "~/"
29
+     failing "foo.txt"
30
+     succeeding "/" (Path "/")
31
+     succeeding "//" (Path "/")
32
+     succeeding "///foo//bar//mu/" (Path "/foo/bar/mu/")
33
+     succeeding "///foo//bar////mu" (Path "/foo/bar/mu/")
34
+     succeeding "///foo//bar/.//mu" (Path "/foo/bar/mu/")
35
+  where failing x = parserTest parseAbsDir x Nothing
36
+        succeeding x with = parserTest parseAbsDir x (Just with)
37
+
38
+-- | Tests for the tokenizer.
39
+parseRelDirSpec :: Spec
40
+parseRelDirSpec =
41
+  do failing ""
42
+     failing "/"
43
+     failing "//"
44
+     failing "~/"
45
+     failing "/"
46
+     failing "./"
47
+     failing "//"
48
+     failing "///foo//bar//mu/"
49
+     failing "///foo//bar////mu"
50
+     failing "///foo//bar/.//mu"
51
+     succeeding "foo.bak" (Path "foo.bak/")
52
+     succeeding "./foo" (Path "foo/")
53
+     succeeding "foo//bar//mu//" (Path "foo/bar/mu/")
54
+     succeeding "foo//bar////mu" (Path "foo/bar/mu/")
55
+     succeeding "foo//bar/.//mu" (Path "foo/bar/mu/")
56
+  where failing x = parserTest parseRelDir x Nothing
57
+        succeeding x with = parserTest parseRelDir x (Just with)
58
+
59
+-- | Tests for the tokenizer.
60
+parseAbsFileSpec :: Spec
61
+parseAbsFileSpec =
62
+  do failing ""
63
+     failing "./"
64
+     failing "~/"
65
+     failing "./foo.txt"
66
+     failing "/"
67
+     failing "//"
68
+     failing "///foo//bar//mu/"
69
+     succeeding "/foo.txt" (Path "/foo.txt")
70
+     succeeding "///foo//bar////mu.txt" (Path "/foo/bar/mu.txt")
71
+     succeeding "///foo//bar/.//mu.txt" (Path "/foo/bar/mu.txt")
72
+  where failing x = parserTest parseAbsFile x Nothing
73
+        succeeding x with = parserTest parseAbsFile x (Just with)
74
+
75
+-- | Tests for the tokenizer.
76
+parseRelFileSpec :: Spec
77
+parseRelFileSpec =
78
+  do failing ""
79
+     failing "/"
80
+     failing "//"
81
+     failing "~/"
82
+     failing "/"
83
+     failing "./"
84
+     failing "//"
85
+     failing "///foo//bar//mu/"
86
+     failing "///foo//bar////mu"
87
+     failing "///foo//bar/.//mu"
88
+     succeeding "foo.txt" (Path "foo.txt")
89
+     succeeding "./foo.txt" (Path "foo.txt")
90
+     succeeding "foo//bar//mu.txt" (Path "foo/bar/mu.txt")
91
+     succeeding "foo//bar////mu.txt" (Path "foo/bar/mu.txt")
92
+     succeeding "foo//bar/.//mu.txt" (Path "foo/bar/mu.txt")
93
+  where failing x = parserTest parseRelFile x Nothing
94
+        succeeding x with = parserTest parseRelFile x (Just with)
95
+
96
+-- | Parser test.
97
+parserTest :: (Show a1,Show a,Eq a1)
98
+           => (a -> Maybe a1) -> a -> Maybe a1 -> SpecWith ()
99
+parserTest parser input expected =
100
+  it ((case expected of
101
+         Nothing -> "Failing: "
102
+         Just{} -> "Succeeding: ") <>
103
+      "Parsing " <>
104
+      show input <>
105
+      " " <>
106
+      case expected of
107
+        Nothing -> "should fail."
108
+        Just x -> "should succeed with: " <> show x)
109
+     (actual == expected)
110
+  where actual = parser input