content: {-# LANGUAGE TemplateHaskell #-}
  
  module Axel.Test.Eff.FileSystemMock where
  
  import Axel.Prelude
  
  import Axel.Eff.FileSystem as Effs
  import Axel.Utils.FilePath
  
  import Control.Lens hiding (children)
  
  import Data.List.Split
  import Data.Maybe
  import qualified Data.Text as T
  
  import Effectful ((:>))
  import qualified Effectful as Eff
  import qualified Effectful.Dispatch.Dynamic as Eff
  import qualified Effectful.Error.Static as Eff
  import qualified Effectful.State.Static.Local as Eff
  
  import TestUtils
  
  data FSNode
    = Directory FilePath [FSNode]
    | File FilePath Text
    deriving (Eq, Show)
  
  fsPath :: Lens' FSNode FilePath
  fsPath =
    lens
      (\case
         Directory path _ -> path
         File path _ -> path)
      (\node newPath ->
         case node of
           Directory _ children -> Directory newPath children
           File _ contents -> File newPath contents)
  
  data FileSystemState =
    FileSystemState
      { _fsCurrentDirectory :: FilePath
      , _fsRoot :: FSNode
      , _fsTempCounter :: Int
      }
    deriving (Eq, Show)
  
  makeFieldsNoPrefix ''FileSystemState
  
  mkFileSystemState :: [FSNode] -> FileSystemState
  mkFileSystemState rootContents =
    FileSystemState
      { _fsCurrentDirectory = FilePath "/"
      , _fsRoot = Directory (FilePath "/") rootContents
      , _fsTempCounter = 0
      }
  
  lookupNode :: [FilePath] -> FSNode -> Maybe FSNode
  lookupNode _ (File _ _) = Nothing
  lookupNode [] _ = Nothing
  lookupNode [FilePath "."] rootNode = pure rootNode
  lookupNode [segment] (Directory _ rootChildren) =
    let matchingChildren =
          filter (\child -> child ^. fsPath == segment) rootChildren
     in case matchingChildren of
          [child] -> pure child
          _ -> Nothing
  lookupNode (segment:xs) rootNode@(Directory _ _) = do
    child@(Directory _ _) <- lookupNode [segment] rootNode
    lookupNode xs child
  
  deleteNode :: [FilePath] -> FSNode -> Maybe FSNode
  deleteNode _ (File _ _) = Nothing
  deleteNode [] _ = Nothing
  deleteNode [segment] rootNode@(Directory rootPath rootChildren) = do
    child <- lookupNode [segment] rootNode
    let rootChildren' = filter (/= child) rootChildren
    pure $ Directory rootPath rootChildren'
  deleteNode (segment:xs) rootNode@(Directory rootPath rootChildren) = do
    needle <- lookupNode [segment] rootNode
    rootChildren' <-
      mapM
        (\child ->
           case child of
             File _ _ -> pure child
             _ ->
               if child == needle
                 then deleteNode xs child
                 else pure child)
        rootChildren
    pure $ Directory rootPath rootChildren'
  
  insertNode :: [FilePath] -> FSNode -> FSNode -> Maybe FSNode
  insertNode _ _ (File _ _) = Nothing
  insertNode [] _ _ = Nothing
  insertNode [segment] newNode (Directory rootPath rootChildren) =
    if newNode ^. fsPath == segment
      then let rootChildren' =
                 filter
                   (\child -> child ^. fsPath /= newNode ^. fsPath)
                   rootChildren
            in pure $ Directory rootPath (newNode : rootChildren')
      else Nothing
  insertNode (segment:xs) newNode rootNode@(Directory rootPath rootChildren) = do
    needle <- lookupNode [segment] rootNode
    rootChildren' <-
      mapM
        (\child ->
           case child of
             File _ _ -> pure child
             _ ->
               if child == needle
                 then insertNode xs newNode child
                 else pure child)
        rootChildren
    pure $ Directory rootPath rootChildren'
  
  type instance Index FSNode = FilePath
  
  type instance IxValue FSNode = FSNode
  
  instance Ixed FSNode where
    ix :: FilePath -> Traversal' FSNode FSNode
    ix path f root =
      case lookupNode pathSegments root of
        Just node ->
          f node <&> \newNode -> fromJust $ insertNode pathSegments newNode root
        Nothing -> pure root
      where
        pathSegments :: [FilePath]
        pathSegments = splitDirectories path
  
  instance At FSNode where
    at :: FilePath -> Lens' FSNode (Maybe FSNode)
    at path =
      let setter :: FSNode -> Maybe FSNode -> FSNode
          setter root =
            fromMaybe root . \case
              Just newNode -> insertNode pathSegments newNode root
              Nothing -> deleteNode pathSegments root
       in lens (lookupNode pathSegments) setter
      where
        pathSegments :: [FilePath]
        pathSegments = splitDirectories path
  
  absifyPath :: FilePath -> FilePath -> FilePath
  absifyPath relativePath currentDirectory =
    let absolutePath =
          case T.unpack $ op FilePath relativePath of
            '/':_ -> relativePath
            _ -> FilePath "/" </> currentDirectory </> relativePath
        normalizedSegments =
          concatMap
            (\case
               [_, FilePath ".."] -> []
               [FilePath "."] -> []
               xs -> xs) $
          chunksOf 2 $
          dropLeadingSlash $
          splitDirectories absolutePath
     in case joinPath normalizedSegments of
          FilePath "" -> FilePath "/"
          path -> path
    where
      dropLeadingSlash (FilePath "/":xs) = xs
      dropLeadingSlash x = x
  
  absify ::
       (Eff.State FileSystemState :> effs) => FilePath -> Eff.Eff effs FilePath
  absify relativePath =
    absifyPath relativePath <$> Eff.gets (^. fsCurrentDirectory)
  
  runFileSystem ::
       forall effs a. (Eff.Error Text :> effs)
    => FileSystemState
    -> Eff.Eff (Effs.FileSystem ': effs) a
    -> Eff.Eff effs (a, FileSystemState)
  runFileSystem origState = Eff.reinterpret (Eff.runState origState) (const go)
    where
      go :: FileSystem m a' -> Eff.Eff (Eff.State FileSystemState ': effs) a'
      go (AppendFile relativePath addedContents) = do
        oldContents <- go $ ReadFile relativePath
        let newContents = oldContents <> addedContents
        go $ WriteFile relativePath newContents
      go (CopyFile src dest) = do
        contents <- go $ ReadFile src
        go $ WriteFile dest contents
      go (CreateDirectoryIfMissing createParents relativePath) = do
        path <- absify relativePath
        parentNode <- Eff.gets (^. fsRoot . at (takeDirectory path))
        case parentNode of
          Just _ ->
            Eff.modify $ fsRoot . at path ?~ Directory (takeFileName path) []
          Nothing ->
            if createParents
              then Eff.modify $ fsRoot %~ \origRoot ->
                     fst
                       (foldl
                          (\(root, segments) pathSegment ->
                             let newSegments = segments <> [pathSegment]
                                 newRoot =
                                   case root ^. at (joinPath newSegments) of
                                     Just _ -> root
                                     Nothing ->
                                       root & at (joinPath newSegments) ?~
                                       Directory pathSegment []
                              in (newRoot, newSegments))
                          (origRoot, [])
                          (splitDirectories path))
              else throwInterpretError
                     @FileSystemState
                     "createDirectoryIfMissing"
                     ("Missing parents for directory: " <> op FilePath path)
      go (DoesDirectoryExist relativePath) = do
        path <- absify relativePath
        directoryNode <- Eff.gets (^. fsRoot . at path)
        pure $
          case directoryNode of
            Just (Directory _ _) -> True
            _ -> False
      go GetCurrentDirectory = Eff.gets (^. fsCurrentDirectory)
      go (GetDirectoryContents relativePath) = do
        path <- absify relativePath
        directoryNode <- Eff.gets (^. fsRoot . at path)
        case directoryNode of
          Just (Directory _ children) -> pure $ map (^. fsPath) children
          _ ->
            throwInterpretError
              @FileSystemState
              "getDirectoryContents"
              ("No such directory: " <> op FilePath path)
      go GetTemporaryDirectory = do
        tempCounter <- Eff.gets (^. fsTempCounter)
        Eff.modify $ fsTempCounter %~ (+ 1)
        let tempDirName = FilePath "/tmp" </> FilePath (showText tempCounter)
        go $ CreateDirectoryIfMissing True tempDirName
        pure tempDirName
      go (ReadFile relativePath) = do
        path <- absify relativePath
        fileNode <- Eff.gets (^. fsRoot . at path)
        case fileNode of
          Just (File _ contents) -> pure contents
          _ ->
            throwInterpretError
              @FileSystemState
              "readFile"
              ("No such file: " <> op FilePath path)
      go (RemoveFile relativePath) = do
        path <- absify relativePath
        Eff.gets (deleteNode (splitDirectories path) . (^. fsRoot)) >>= \case
          Just newRoot -> Eff.modify $ fsRoot .~ newRoot
          Nothing ->
            throwInterpretError
              @FileSystemState
              "removeFile"
              ("No such file: " <> op FilePath path)
      go (SetCurrentDirectory relativePath) = do
        path <- absify relativePath
        Eff.modify $ fsCurrentDirectory .~ path
      go (WriteFile relativePath contents) = do
        path <- absify relativePath
        Eff.modify $ fsRoot . at path ?~ File (takeFileName path) contents
  