-
Notifications
You must be signed in to change notification settings - Fork 54
/
Pure.hs
221 lines (194 loc) · 6.79 KB
/
Pure.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
module Juvix.Data.Effect.Files.Pure where
import Data.HashMap.Strict qualified as HashMap
import Data.Tree
import Data.Unique
import Juvix.Data.Effect.Files.Base
import Juvix.Prelude.Base
import Juvix.Prelude.Path
import Polysemy.ConstraintAbsorber.MonadCatch
import Polysemy.Fresh
import Prelude qualified
data FS = FS
{ _fsRoot :: Path Abs Dir,
_fsNode :: FSNode
}
data FSNode = FSNode
{ _dirFiles :: HashMap (Path Rel File) Text,
_dirDirs :: HashMap (Path Rel Dir) FSNode
}
emptyFS :: FS
emptyFS =
FS
{ _fsRoot = $(mkAbsDir "/"),
_fsNode = emptyNode
}
emptyNode :: FSNode
emptyNode =
FSNode
{ _dirFiles = mempty,
_dirDirs = mempty
}
makeLenses ''FS
makeLenses ''FSNode
mkFS :: HashMap (Path Abs File) Text -> FS
mkFS tbl = run (execState emptyFS go)
where
go :: Sem '[State FS] ()
go = forM_ (HashMap.toList tbl) $ \(p, txt) -> do
ensureDirHelper (parent p)
writeFileHelper p txt
toTree :: FS -> Tree FilePath
toTree fs = Node (toFilePath (fs ^. fsRoot)) (go (fs ^. fsNode))
where
go :: FSNode -> [Tree FilePath]
go (FSNode files dirs) =
map goFile (HashMap.keys files)
<> map (uncurry goNode) (HashMap.toList dirs)
goFile :: Path Rel File -> Tree FilePath
goFile f = Node (toFilePath f) []
goNode :: Path Rel Dir -> FSNode -> Tree FilePath
goNode p = Node (toFilePath p) . go
instance Show FS where
show = drawTree . toTree
runFilesEmpty :: Sem (Files ': r) a -> Sem r a
runFilesEmpty = runFilesPure mempty $(mkAbsDir "/")
runFilesPure :: HashMap (Path Abs File) Text -> Path Abs Dir -> Sem (Files ': r) a -> Sem r a
runFilesPure ini cwd a = evalState (mkFS ini) (re cwd a)
re :: Path Abs Dir -> Sem (Files ': r) a -> Sem (State FS ': r) a
re cwd = reinterpret $ \case
ReadFile' f -> lookupFile' f
FileExists' f -> isJust <$> lookupFile f
PathUid p -> return (Uid (toFilePath p))
ReadFileBS' f -> encodeUtf8 <$> lookupFile' f
GetDirAbsPath p -> return (absDir (cwd' </> toFilePath p))
EnsureDir' p -> ensureDirHelper p
DirectoryExists' p -> isJust <$> lookupDir p
WriteFile' p t -> writeFileHelper p t
WriteFileBS p t -> writeFileHelper p (decodeUtf8 t)
RemoveDirectoryRecursive' p -> removeDirRecurHelper p
ListDirRel p -> do
n <- lookupDir' p
return (HashMap.keys (n ^. dirDirs), HashMap.keys (n ^. dirFiles))
RemoveFile' p -> removeFileHelper p
RenameFile' p1 p2 -> renameFileHelper p1 p2
CopyFile' p1 p2 -> copyFileHelper p1 p2
where
cwd' :: FilePath
cwd' = toFilePath cwd
runTempFilePure ::
Members '[Files, Fresh Unique, Error SomeException] r =>
Sem (TempFile ': r) a ->
Sem r a
runTempFilePure = interpret $ \case
TempFilePath -> do
tmpDir <- absorbMonadThrow (parseAbsDir "/tmp")
uid <- show . hashUnique <$> fresh
tmpFile <- absorbMonadThrow (parseRelFile uid)
let p = tmpDir <//> tmpFile
writeFile' p ""
return p
RemoveTempFile p -> removeFile' p
missingErr :: (Members '[State FS] r) => FilePath -> Sem r a
missingErr f = do
root <- get @FS
error $
pack $
"file "
<> f
<> " does not exist."
<> "\nThe contents of the mocked file system are:\n"
<> Prelude.show root
checkRoot :: (Members '[State FS] r) => Path Abs Dir -> Sem r ()
checkRoot r = do
root <- gets (^. fsRoot)
unless True (error ("roots do not match: " <> pack (toFilePath root) <> "\n" <> pack (toFilePath r)))
removeDirRecurHelper :: (Members '[State FS] r) => Path Abs Dir -> Sem r ()
removeDirRecurHelper p = do
checkRoot r
modify (over fsNode (fromMaybe emptyNode . go dirs))
where
(r, dirs) = destructAbsDir p
go :: [Path Rel Dir] -> FSNode -> Maybe FSNode
go = \case
[] -> const Nothing
(d : ds) -> Just . over dirDirs (HashMap.alter helper d)
where
helper :: Maybe FSNode -> Maybe FSNode
helper = go ds . fromMaybe emptyNode
ensureDirHelper :: (Members '[State FS] r) => Path Abs Dir -> Sem r ()
ensureDirHelper p = do
checkRoot r
modify (over fsNode (go dirs))
where
(r, dirs) = destructAbsDir p
go :: [Path Rel Dir] -> FSNode -> FSNode
go = \case
[] -> id
(d : ds) -> over dirDirs (HashMap.alter (Just . helper) d)
where
helper :: Maybe FSNode -> FSNode
helper = go ds . fromMaybe emptyNode
writeFileHelper :: (Members '[State FS] r) => Path Abs File -> Text -> Sem r ()
writeFileHelper p contents = do
checkRoot r
modify (over fsNode (go dirs))
where
(r, dirs, f) = destructAbsFile p
go :: [Path Rel Dir] -> FSNode -> FSNode
go = \case
[] -> set (dirFiles . at f) (Just contents)
(d : ds) -> over dirDirs (HashMap.alter (Just . helper) d)
where
helper :: Maybe FSNode -> FSNode
helper = maybe (error "directory does not exist") (go ds)
removeFileHelper :: (Members '[State FS] r) => Path Abs File -> Sem r ()
removeFileHelper p = do
checkRoot r
modify (over fsNode (go dirs))
where
(r, dirs, f) = destructAbsFile p
go :: [Path Rel Dir] -> FSNode -> FSNode
go = \case
[] -> set (dirFiles . at f) Nothing
(d : ds) -> over dirDirs (HashMap.alter (Just . helper) d)
where
helper :: Maybe FSNode -> FSNode
helper = maybe (error "directory does not exist") (go ds)
renameFileHelper :: (Members '[State FS] r) => Path Abs File -> Path Abs File -> Sem r ()
renameFileHelper fromPath toPath = do
copyFileHelper fromPath toPath
removeFileHelper fromPath
copyFileHelper :: (Members '[State FS] r) => Path Abs File -> Path Abs File -> Sem r ()
copyFileHelper fromPath toPath = do
fromContents <- lookupFile' fromPath
writeFileHelper toPath fromContents
lookupDir :: (Members '[State FS] r) => Path Abs Dir -> Sem r (Maybe FSNode)
lookupDir p = do
checkRoot p
r <- gets (^. fsNode)
return (go r (snd (destructAbsDir p)))
where
go :: FSNode -> [Path Rel Dir] -> Maybe FSNode
go d = \case
[] -> return d
(h : hs) -> do
d' <- HashMap.lookup h (d ^. dirDirs)
go d' hs
lookupDir' :: forall r. (Members '[State FS] r) => Path Abs Dir -> Sem r FSNode
lookupDir' p = fromMaybeM err (lookupDir p)
where
err :: Sem r FSNode
err = missingErr (toFilePath p)
lookupFile :: (Members '[State FS] r) => Path Abs File -> Sem r (Maybe Text)
lookupFile p = do
node <- lookupDir (parent p)
return (node >>= HashMap.lookup (filename p) . (^. dirFiles))
lookupFile' :: (Members '[State FS] r) => Path Abs File -> Sem r Text
lookupFile' p =
fromMaybeM err (lookupFile p)
where
err = missingErr (toFilePath p)
parseAbsDirError :: forall r. Members '[Error SomeException] r => FilePath -> Sem r (Path Abs Dir)
parseAbsDirError fp = absorbMonadThrow (parseAbsDir fp)
parseRelFileError :: forall r. Members '[Error SomeException] r => FilePath -> Sem r (Path Rel File)
parseRelFileError fp = absorbMonadThrow (parseRelFile fp)