]> Git — Sourcephile - comptalang.git/blob - cli/Hcompta/Lib/System/File/Path.hs
Adapte hcompta-cli.
[comptalang.git] / cli / Hcompta / Lib / System / File / Path.hs
1 {-# LANGUAGE DataKinds #-}
2 {-# LANGUAGE DeriveFunctor #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE GADTs #-}
5 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
6 {-# LANGUAGE MultiParamTypeClasses #-}
7 {-# LANGUAGE OverloadedStrings #-}
8 {-# LANGUAGE TypeFamilies #-}
9 {-# OPTIONS_GHC -fno-warn-tabs #-}
10 {-# OPTIONS_GHC -fno-warn-orphans #-}
11
12 module Hadmin.Lib.System.File.Path where
13
14 import Data.Foldable (foldMap)
15 import Data.Function (($), (.))
16 import Data.Functor (Functor(..), (<$>))
17 import qualified Data.List as List
18 import Data.Maybe (Maybe(..))
19 import Data.Monoid (Monoid(..), (<>))
20 import Data.String (IsString(..))
21 import Data.Text (Text)
22 import Data.Text.Buildable (Buildable(..))
23 import GHC.Exts (IsList(..))
24 import Prelude (undefined)
25 import qualified System.FilePath.Posix as FP
26
27 import Hadmin.Lib.Data.Text
28
29 -- * Type 'Path'
30 type Path pos a = InPos pos (InDir a)
31
32 -- * Type 'Position'
33 data Position = Absolute | Relative
34
35 -- ** Type 'SPos'
36 -- | Singleton type for 'Position'.
37 data SPos pos where
38 Abs :: SPos 'Absolute
39 Rel :: SPos 'Relative
40
41 -- ** Type 'IPos'
42
43 -- | Implicit class for 'Position'.
44 class IPos pos where
45 pos :: SPos pos
46 instance IPos 'Absolute where pos = Abs
47 instance IPos 'Relative where pos = Rel
48
49 -- ** Type 'InPos'
50 data InPos pos a = InPos (SPos pos) a
51 deriving (Functor)
52 instance Buildable a => Buildable (InPos pos a) where
53 build (InPos Abs a) = build FP.pathSeparator <> build a
54 build (InPos Rel a) = build a
55 instance (IsString a, IPos pos) => IsString (InPos pos a) where
56 fromString = InPos pos . fromString
57
58 -- ** Type 'PosOf'
59 type family PosOf x :: Position
60 type instance PosOf (InPos pos a) = pos
61
62 -- * Type 'Dir'
63
64 newtype Dir = Dir [Dir_Seg]
65 deriving (Monoid)
66 type Dir_Seg = Text
67 type AbsDir = InPos 'Absolute Dir
68 type RelDir = InPos 'Relative Dir
69 instance IsString Dir where
70 fromString = Dir . (fromString <$>) . splitOnChar FP.pathSeparator
71 instance IsList Dir where
72 type Item Dir = Dir_Seg
73 fromList = Dir . foldMap (splitOnChar FP.pathSeparator)
74 toList (Dir d) = toList d
75 instance Buildable Dir where
76 build (Dir []) = "."
77 build (Dir p) =
78 mconcat $
79 List.intersperse
80 (build FP.pathSeparator)
81 (build <$> p)
82
83 {-
84 absDir :: InPos pos a -> InPos 'Absolute a
85 absDir (InPos _p a) = InPos Abs a
86
87 relDir :: InPos pos a -> InPos 'Relative a
88 relDir (InPos _p a) = InPos Rel a
89 -}
90
91 -- ** Type 'InDir'
92 data InDir a = InDir Dir a
93 deriving (Functor)
94 instance IsString (a -> InDir a) where
95 fromString = InDir . fromString
96 instance IsString a => IsString (InDir a) where
97 fromString s =
98 case splitOnChar FP.pathSeparator s of
99 [] -> InDir (Dir []) $ fromString ""
100 l -> InDir (Dir $ fromString <$> List.init l) $ fromString (List.last l)
101 instance IsList (a -> InDir a) where
102 type Item (a -> InDir a) = Dir_Seg
103 fromList = InDir . fromList
104 toList = undefined
105 instance Buildable a => Buildable (InDir a) where
106 build (InDir d a) = build d <> build FP.pathSeparator <> build a
107
108 -- ** Class 'Dir_Parent'
109
110 -- | Return the parent 'Dir' of given 'Dir'
111 class Dir_Parent d where
112 type Dir_Parent_Dir d
113 dir_parent :: d -> Maybe (Dir_Parent_Dir d)
114
115 instance Dir_Parent Dir where
116 type Dir_Parent_Dir Dir = Dir
117 dir_parent (Dir p) =
118 case p of
119 [] -> Nothing
120 _ -> Just $ Dir (List.init p)
121 instance Dir_Parent a => Dir_Parent (InPos pos a) where
122 type Dir_Parent_Dir (InPos pos a) = InPos pos (Dir_Parent_Dir a)
123 dir_parent (InPos p a) = InPos p <$> dir_parent a
124 instance Dir_Parent (InDir a) where
125 type Dir_Parent_Dir (InDir a) = Dir
126 dir_parent (InDir d _a) = Just d
127 {-
128 instance Dir_Parent File where
129 type Dir_Parent_Dir File = Dir
130 dir_parent (File _f) = Just $ Dir []
131 -}
132
133 -- ** Class 'Dir_Ancestors'
134
135 -- | Return self and parents 'Dir' of given 'Dir', in topological order.
136 class Dir_Ancestors d where
137 type Dir_Ancestors_Dir d
138 dir_ancestors :: d -> [Dir_Parent_Dir d]
139
140 instance Dir_Ancestors Dir where
141 type Dir_Ancestors_Dir Dir = Dir
142 dir_ancestors (Dir p) =
143 List.reverse $
144 List.foldl' (\acc seg ->
145 case acc of
146 [] -> [Dir [seg]]
147 Dir d:_ -> Dir (d<>[seg]):acc
148 ) [Dir []] p
149 instance Dir_Ancestors a => Dir_Ancestors (InPos pos a) where
150 type Dir_Ancestors_Dir (InPos pos a) = InPos pos (Dir_Ancestors_Dir a)
151 dir_ancestors (InPos p a) = InPos p <$> dir_ancestors a
152 instance Dir_Ancestors (InDir a) where
153 type Dir_Ancestors_Dir (InDir a) = Dir
154 dir_ancestors (InDir d _a) = dir_ancestors d
155 {-
156 instance Dir_Ancestors File where
157 type Dir_Ancestors_Dir File = Dir
158 dir_ancestors (File _f) = [Dir []]
159 -}
160
161 -- ** Class 'Dir_Append'
162 class Dir_Append p q where
163 type Dir_Append_Dir p q
164 (</>) :: p -> q -> Dir_Append_Dir p q
165 instance Dir_Append (InPos p Dir) (InPos 'Relative Dir) where
166 type Dir_Append_Dir (InPos p Dir) (InPos 'Relative Dir) = InPos p Dir
167 (</>) (InPos p x) (InPos _q y) = InPos p (x <> y)
168 instance Dir_Append (InPos p Dir) File where
169 type Dir_Append_Dir (InPos p Dir) File = InPos p (InDir File)
170 (</>) (InPos p d) f = InPos p (InDir d f)
171 instance Dir_Append (InPos p Dir) (InPos 'Relative (InDir a)) where
172 type Dir_Append_Dir (InPos p Dir) (InPos 'Relative (InDir a)) = InPos p (InDir a)
173 (</>) (InPos p x) (InPos _q (InDir y a)) = InPos p (InDir (x <> y) a)
174
175 -- * Type 'File'
176 newtype File = File [Text]
177 instance IsString File where
178 fromString = File . (fromString <$>) . splitOnCharWithEmpty FP.extSeparator
179 instance Buildable File where
180 build (File p) =
181 mconcat $
182 List.intersperse
183 (build FP.extSeparator)
184 (build <$> p)
185
186 type RelFile = InPos 'Relative (InDir File)