FileSystem.hs

{-# 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 ()