Skip to content

Instantly share code, notes, and snippets.

@friedbrice
Last active December 13, 2022 14:15
Show Gist options
  • Save friedbrice/dacf22c31d91035b82f428fbb27189ef to your computer and use it in GitHub Desktop.
Save friedbrice/dacf22c31d91035b82f428fbb27189ef to your computer and use it in GitHub Desktop.
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# OPTIONS_GHC -Wall #-}
module FileSystem where
import Control.Applicative
import Control.Monad
import Control.Monad.State
import Data.Bifunctor
import Data.Bool
import Data.Map (Map)
import Data.Map qualified as Map
import Prelude hiding (lookup)
class Dict k v a | a -> k v where
lookup :: k -> a -> Maybe v
insert :: k -> v -> a -> a
delete :: k -> a -> a
assocs :: a -> [(k, v)]
instance Ord k => Dict k v (Map k v) where
lookup = Map.lookup
insert = Map.insert
delete = Map.delete
assocs = Map.assocs
data File a = Dir (Dir a) | File a
deriving (Functor, Foldable, Traversable)
eitherFile :: (Dir a -> b) -> (a -> b) -> File a -> b
eitherFile f g x = case x of
Dir dir -> f dir
File file -> g file
isDir :: File a -> Bool
isDir = eitherFile (const True) (const False)
newtype Dir a = Directory (Map String (File a))
deriving (Functor, Foldable, Traversable)
deriving
( Dict String (File a)
, Semigroup
, Monoid
)
via Map String (File a)
data Cwd a = Root | Cwd String (Cwd a) (Dir a)
deriving (Functor, Foldable, Traversable)
newtype FileSystem a b = FileSystem (State (Cwd a, Dir a) b)
deriving
( Functor
, Applicative
, Monad
, MonadState (Cwd a, Dir a)
)
via State (Cwd a, Dir a)
find :: String -> (File a -> Maybe b) -> FileSystem a (Maybe b)
find name f = do
(_, dir) <- get
pure $ f =<< lookup name dir
findf :: String -> FileSystem a (Maybe a)
findf name = find name $ eitherFile (const Nothing) Just
findd :: String -> FileSystem a (Maybe (Dir a))
findd name = find name $ eitherFile Just (const Nothing)
test :: String -> FileSystem a Bool
test name = not . null <$> find name pure
testf :: String -> FileSystem a Bool
testf name = not . null <$> findf name
testd :: String -> FileSystem a Bool
testd name = not . null <$> findd name
mkdir :: String -> FileSystem a ()
mkdir name = do
exists <- test name
unless exists $ modify $ second $ insert name $ Dir mempty
touch :: Monoid a => String -> FileSystem a ()
touch name = do
exists <- test name
unless exists $ modify $ second $ insert name $ File mempty
rmrf :: String -> FileSystem a ()
rmrf name = modify $ second $ delete name
ls :: FileSystem a [(String, Bool)]
ls = do
(_, dir) <- get
pure $ second isDir <$> assocs dir
pwd :: FileSystem a [String]
pwd = do
(cwd, _) <- get
pure $ reverse $ go cwd
where
go Root = []
go (Cwd name parent _) = name : go parent
cd :: String -> FileSystem a ()
cd name =
case name of
"." -> pure ()
".." -> goUp
_ -> goDown
where
goUp = do
(cwd, dir) <- get
case cwd of
Root -> pure ()
Cwd self parentMeta siblings ->
let parentContents = insert self (Dir dir) siblings
in put (parentMeta, parentContents)
goDown = do
(cwd, dir) <- get
case lookup name dir of
Just (Dir subdirContents) ->
let subdirMeta = Cwd name cwd subdirSiblings
subdirSiblings = delete name dir
in put (subdirMeta, subdirContents)
_ -> pure ()
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment