{-# LANGUAGE OverloadedStrings #-}
module Test.Hls.FileSystem
  ( FileSystem(..)
  , VirtualFileTree(..)
  , FileTree
  , Content
  -- * init
  , materialise
  , materialiseVFT
  -- * Interaction
  , readFileFS
  , writeFileFS
  -- * Test helpers
  , mkVirtualFileTree
  , toNfp
  , toAbsFp
  -- * Builders
  , file
  , copy
  , directory
  , text
  , ref
  -- * Cradle helpers
  , directCradle
  , simpleCabalCradle
  -- * Full project setups
  , directProject
  , directProjectMulti
  , simpleCabalProject
  , simpleCabalProject'
  ) where

import           Data.Foldable               (traverse_)
import qualified Data.Text                   as T
import qualified Data.Text.IO                as T
import           Development.IDE             (NormalizedFilePath)
import           Language.LSP.Protocol.Types (toNormalizedFilePath)
import           System.Directory
import           System.FilePath             as FP

-- ----------------------------------------------------------------------------
-- Top Level definitions
-- ----------------------------------------------------------------------------

-- | Representation of a 'VirtualFileTree' that has been 'materialise'd to disk.
--
data FileSystem =
  FileSystem
    { FileSystem -> FilePath
fsRoot         :: FilePath
    , FileSystem -> [FileTree]
fsTree         :: [FileTree]
    , FileSystem -> FilePath
fsOriginalRoot :: FilePath
    } deriving (FileSystem -> FileSystem -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FileSystem -> FileSystem -> Bool
$c/= :: FileSystem -> FileSystem -> Bool
== :: FileSystem -> FileSystem -> Bool
$c== :: FileSystem -> FileSystem -> Bool
Eq, Eq FileSystem
FileSystem -> FileSystem -> Bool
FileSystem -> FileSystem -> Ordering
FileSystem -> FileSystem -> FileSystem
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FileSystem -> FileSystem -> FileSystem
$cmin :: FileSystem -> FileSystem -> FileSystem
max :: FileSystem -> FileSystem -> FileSystem
$cmax :: FileSystem -> FileSystem -> FileSystem
>= :: FileSystem -> FileSystem -> Bool
$c>= :: FileSystem -> FileSystem -> Bool
> :: FileSystem -> FileSystem -> Bool
$c> :: FileSystem -> FileSystem -> Bool
<= :: FileSystem -> FileSystem -> Bool
$c<= :: FileSystem -> FileSystem -> Bool
< :: FileSystem -> FileSystem -> Bool
$c< :: FileSystem -> FileSystem -> Bool
compare :: FileSystem -> FileSystem -> Ordering
$ccompare :: FileSystem -> FileSystem -> Ordering
Ord, Int -> FileSystem -> ShowS
[FileSystem] -> ShowS
FileSystem -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [FileSystem] -> ShowS
$cshowList :: [FileSystem] -> ShowS
show :: FileSystem -> FilePath
$cshow :: FileSystem -> FilePath
showsPrec :: Int -> FileSystem -> ShowS
$cshowsPrec :: Int -> FileSystem -> ShowS
Show)

-- | Virtual representation of a filesystem tree.
--
-- Operations of 'vftTree' are relative to 'vftOriginalRoot'.
-- In particular, any 'copy' etc. operation looks for the sources in 'vftOriginalRoot'.
--
-- To persist a 'VirtualFileTree', look at 'materialise' and 'materialiseVFT'.
data VirtualFileTree =
  VirtualFileTree
    { VirtualFileTree -> [FileTree]
vftTree         :: [FileTree]
    , VirtualFileTree -> FilePath
vftOriginalRoot :: FilePath
    } deriving (VirtualFileTree -> VirtualFileTree -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VirtualFileTree -> VirtualFileTree -> Bool
$c/= :: VirtualFileTree -> VirtualFileTree -> Bool
== :: VirtualFileTree -> VirtualFileTree -> Bool
$c== :: VirtualFileTree -> VirtualFileTree -> Bool
Eq, Eq VirtualFileTree
VirtualFileTree -> VirtualFileTree -> Bool
VirtualFileTree -> VirtualFileTree -> Ordering
VirtualFileTree -> VirtualFileTree -> VirtualFileTree
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: VirtualFileTree -> VirtualFileTree -> VirtualFileTree
$cmin :: VirtualFileTree -> VirtualFileTree -> VirtualFileTree
max :: VirtualFileTree -> VirtualFileTree -> VirtualFileTree
$cmax :: VirtualFileTree -> VirtualFileTree -> VirtualFileTree
>= :: VirtualFileTree -> VirtualFileTree -> Bool
$c>= :: VirtualFileTree -> VirtualFileTree -> Bool
> :: VirtualFileTree -> VirtualFileTree -> Bool
$c> :: VirtualFileTree -> VirtualFileTree -> Bool
<= :: VirtualFileTree -> VirtualFileTree -> Bool
$c<= :: VirtualFileTree -> VirtualFileTree -> Bool
< :: VirtualFileTree -> VirtualFileTree -> Bool
$c< :: VirtualFileTree -> VirtualFileTree -> Bool
compare :: VirtualFileTree -> VirtualFileTree -> Ordering
$ccompare :: VirtualFileTree -> VirtualFileTree -> Ordering
Ord, Int -> VirtualFileTree -> ShowS
[VirtualFileTree] -> ShowS
VirtualFileTree -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [VirtualFileTree] -> ShowS
$cshowList :: [VirtualFileTree] -> ShowS
show :: VirtualFileTree -> FilePath
$cshow :: VirtualFileTree -> FilePath
showsPrec :: Int -> VirtualFileTree -> ShowS
$cshowsPrec :: Int -> VirtualFileTree -> ShowS
Show)

data FileTree
  = File FilePath Content
  | Directory FilePath [FileTree]
  deriving (Int -> FileTree -> ShowS
[FileTree] -> ShowS
FileTree -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [FileTree] -> ShowS
$cshowList :: [FileTree] -> ShowS
show :: FileTree -> FilePath
$cshow :: FileTree -> FilePath
showsPrec :: Int -> FileTree -> ShowS
$cshowsPrec :: Int -> FileTree -> ShowS
Show, FileTree -> FileTree -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FileTree -> FileTree -> Bool
$c/= :: FileTree -> FileTree -> Bool
== :: FileTree -> FileTree -> Bool
$c== :: FileTree -> FileTree -> Bool
Eq, Eq FileTree
FileTree -> FileTree -> Bool
FileTree -> FileTree -> Ordering
FileTree -> FileTree -> FileTree
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FileTree -> FileTree -> FileTree
$cmin :: FileTree -> FileTree -> FileTree
max :: FileTree -> FileTree -> FileTree
$cmax :: FileTree -> FileTree -> FileTree
>= :: FileTree -> FileTree -> Bool
$c>= :: FileTree -> FileTree -> Bool
> :: FileTree -> FileTree -> Bool
$c> :: FileTree -> FileTree -> Bool
<= :: FileTree -> FileTree -> Bool
$c<= :: FileTree -> FileTree -> Bool
< :: FileTree -> FileTree -> Bool
$c< :: FileTree -> FileTree -> Bool
compare :: FileTree -> FileTree -> Ordering
$ccompare :: FileTree -> FileTree -> Ordering
Ord)

data Content
  = Inline T.Text
  | Ref FilePath
  deriving (Int -> Content -> ShowS
[Content] -> ShowS
Content -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Content] -> ShowS
$cshowList :: [Content] -> ShowS
show :: Content -> FilePath
$cshow :: Content -> FilePath
showsPrec :: Int -> Content -> ShowS
$cshowsPrec :: Int -> Content -> ShowS
Show, Content -> Content -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Content -> Content -> Bool
$c/= :: Content -> Content -> Bool
== :: Content -> Content -> Bool
$c== :: Content -> Content -> Bool
Eq, Eq Content
Content -> Content -> Bool
Content -> Content -> Ordering
Content -> Content -> Content
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Content -> Content -> Content
$cmin :: Content -> Content -> Content
max :: Content -> Content -> Content
$cmax :: Content -> Content -> Content
>= :: Content -> Content -> Bool
$c>= :: Content -> Content -> Bool
> :: Content -> Content -> Bool
$c> :: Content -> Content -> Bool
<= :: Content -> Content -> Bool
$c<= :: Content -> Content -> Bool
< :: Content -> Content -> Bool
$c< :: Content -> Content -> Bool
compare :: Content -> Content -> Ordering
$ccompare :: Content -> Content -> Ordering
Ord)

-- ----------------------------------------------------------------------------
-- API with side effects
-- ----------------------------------------------------------------------------

readFileFS :: FileSystem -> FilePath -> IO T.Text
readFileFS :: FileSystem -> FilePath -> IO Text
readFileFS FileSystem
fs FilePath
fp = do
  FilePath -> IO Text
T.readFile (FileSystem -> FilePath
fsRoot FileSystem
fs FilePath -> ShowS
</> ShowS
FP.normalise FilePath
fp)

writeFileFS :: FileSystem -> FilePath -> Content -> IO ()
writeFileFS :: FileSystem -> FilePath -> Content -> IO ()
writeFileFS FileSystem
fs FilePath
fp Content
content = do
  Text
contents <- case Content
content of
    Inline Text
txt -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
txt
    Ref FilePath
path   -> FilePath -> IO Text
T.readFile (FileSystem -> FilePath
fsOriginalRoot FileSystem
fs FilePath -> ShowS
</> ShowS
FP.normalise FilePath
path)
  FilePath -> Text -> IO ()
T.writeFile (FileSystem -> FilePath
fsRoot FileSystem
fs FilePath -> ShowS
</> ShowS
FP.normalise FilePath
fp) Text
contents

-- | Materialise a virtual file tree in the 'rootDir' directory.
--
-- Synopsis: @'materialise' rootDir fileTree testDataDir@
--
-- File references in '[FileTree]' are resolved relative to the @testDataDir@.
materialise :: FilePath -> [FileTree] -> FilePath -> IO FileSystem
materialise :: FilePath -> [FileTree] -> FilePath -> IO FileSystem
materialise FilePath
rootDir' [FileTree]
fileTree FilePath
testDataDir' = do
  let testDataDir :: FilePath
testDataDir = ShowS
FP.normalise FilePath
testDataDir'
      rootDir :: FilePath
rootDir = ShowS
FP.normalise FilePath
rootDir'

      persist :: FilePath -> FileTree -> IO ()
      persist :: FilePath -> FileTree -> IO ()
persist FilePath
fp (File FilePath
name Content
cts) = case Content
cts of
        Inline Text
txt -> FilePath -> Text -> IO ()
T.writeFile (FilePath
fp FilePath -> ShowS
</> FilePath
name) Text
txt
        Ref FilePath
path -> FilePath -> FilePath -> IO ()
copyFile (FilePath
testDataDir FilePath -> ShowS
</> ShowS
FP.normalise FilePath
path) (FilePath
fp FilePath -> ShowS
</> ShowS
takeFileName FilePath
name)
      persist FilePath
fp (Directory FilePath
name [FileTree]
nodes) = do
        FilePath -> IO ()
createDirectory (FilePath
fp FilePath -> ShowS
</> FilePath
name)
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FilePath -> FileTree -> IO ()
persist (FilePath
fp FilePath -> ShowS
</> FilePath
name)) [FileTree]
nodes

  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (FilePath -> FileTree -> IO ()
persist FilePath
rootDir) [FileTree]
fileTree
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FilePath -> [FileTree] -> FilePath -> FileSystem
FileSystem FilePath
rootDir [FileTree]
fileTree FilePath
testDataDir

-- | Materialise a virtual file tree in the 'rootDir' directory.
--
-- Synopsis: @'materialiseVFT' rootDir virtualFileTree@
--
-- File references in 'virtualFileTree' are resolved relative to the @vftOriginalRoot@.
materialiseVFT :: FilePath -> VirtualFileTree -> IO FileSystem
materialiseVFT :: FilePath -> VirtualFileTree -> IO FileSystem
materialiseVFT FilePath
root VirtualFileTree
fs =
  FilePath -> [FileTree] -> FilePath -> IO FileSystem
materialise FilePath
root (VirtualFileTree -> [FileTree]
vftTree VirtualFileTree
fs) (VirtualFileTree -> FilePath
vftOriginalRoot VirtualFileTree
fs)

-- ----------------------------------------------------------------------------
-- Test definition helpers
-- ----------------------------------------------------------------------------

mkVirtualFileTree :: FilePath -> [FileTree] -> VirtualFileTree
mkVirtualFileTree :: FilePath -> [FileTree] -> VirtualFileTree
mkVirtualFileTree FilePath
testDataDir [FileTree]
tree =
  VirtualFileTree
    { vftTree :: [FileTree]
vftTree = [FileTree]
tree
    , vftOriginalRoot :: FilePath
vftOriginalRoot = FilePath
testDataDir
    }

toAbsFp :: FileSystem -> FilePath -> FilePath
toAbsFp :: FileSystem -> ShowS
toAbsFp FileSystem
fs FilePath
fp = FileSystem -> FilePath
fsRoot FileSystem
fs FilePath -> ShowS
</> ShowS
FP.normalise FilePath
fp

toNfp :: FileSystem -> FilePath -> NormalizedFilePath
toNfp :: FileSystem -> FilePath -> NormalizedFilePath
toNfp FileSystem
fs FilePath
fp =
  FilePath -> NormalizedFilePath
toNormalizedFilePath forall a b. (a -> b) -> a -> b
$ FileSystem -> ShowS
toAbsFp FileSystem
fs FilePath
fp

-- ----------------------------------------------------------------------------
-- Builders
-- ----------------------------------------------------------------------------

-- | Create a file in the test project with some content.
--
-- Only the filename will be used, and any directory components are *not*
-- reflected in the test project.
file :: FilePath -> Content -> FileTree
file :: FilePath -> Content -> FileTree
file FilePath
fp Content
cts = FilePath -> Content -> FileTree
File FilePath
fp Content
cts

-- | Copy a filepath into a test project. The name of the file is also used
-- in the test project.
--
-- The filepath is always resolved to the root of the test data dir.
copy :: FilePath -> FileTree
copy :: FilePath -> FileTree
copy FilePath
fp = FilePath -> Content -> FileTree
File FilePath
fp (FilePath -> Content
Ref FilePath
fp)

directory :: FilePath -> [FileTree] -> FileTree
directory :: FilePath -> [FileTree] -> FileTree
directory FilePath
name [FileTree]
nodes = FilePath -> [FileTree] -> FileTree
Directory FilePath
name [FileTree]
nodes

-- | Write the given test directly into a file.
text :: T.Text -> Content
text :: Text -> Content
text = Text -> Content
Inline

-- | Read the contents of the given file
-- The filepath is always resolved to the root of the test data dir.
ref :: FilePath -> Content
ref :: FilePath -> Content
ref = FilePath -> Content
Ref

-- ----------------------------------------------------------------------------
-- Cradle Helpers
-- ----------------------------------------------------------------------------

-- | Set up a simple direct cradle.
--
-- All arguments are added to the direct cradle file.
-- Arguments will not be escaped.
directCradle :: [T.Text] -> FileTree
directCradle :: [Text] -> FileTree
directCradle [Text]
args =
  FilePath -> Content -> FileTree
file FilePath
"hie.yaml"
    ( Text -> Content
Inline forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$
      [ Text
"cradle:"
      , Text
"  direct:"
      , Text
"    arguments:"
      ] forall a. Semigroup a => a -> a -> a
<>
      [ Text
"    - " forall a. Semigroup a => a -> a -> a
<> Text
arg | Text
arg <- [Text]
args]
    )

-- | Set up a simple cabal cradle.
--
-- Prefer simple cabal cradle, over custom multi cabal cradles if possible.
simpleCabalCradle :: FileTree
simpleCabalCradle :: FileTree
simpleCabalCradle =
  FilePath -> Content -> FileTree
file FilePath
"hie.yaml"
    (Text -> Content
Inline forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines
      [ Text
"cradle:"
      , Text
"  cabal:"
      ]
    )


-- ----------------------------------------------------------------------------
-- Project setup builders
-- ----------------------------------------------------------------------------

-- | Set up a test project with a single haskell file.
directProject :: FilePath -> [FileTree]
directProject :: FilePath -> [FileTree]
directProject FilePath
fp =
  [ [Text] -> FileTree
directCradle [FilePath -> Text
T.pack FilePath
fp]
  , FilePath -> Content -> FileTree
file FilePath
fp (FilePath -> Content
Ref FilePath
fp)
  ]

-- | Set up a test project with multiple haskell files.
--
directProjectMulti :: [FilePath] -> [FileTree]
directProjectMulti :: [FilePath] -> [FileTree]
directProjectMulti [FilePath]
fps =
  [ [Text] -> FileTree
directCradle forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Text
T.pack [FilePath]
fps
  ] forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> FileTree
copy [FilePath]
fps

-- | Set up a simple cabal cradle  project and copy all the given filepaths
-- into the test directory.
simpleCabalProject :: [FilePath] -> [FileTree]
simpleCabalProject :: [FilePath] -> [FileTree]
simpleCabalProject [FilePath]
fps =
  [ FileTree
simpleCabalCradle
  ] forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> FileTree
copy [FilePath]
fps

-- | Set up a simple cabal cradle project.
simpleCabalProject' :: [FileTree] -> [FileTree]
simpleCabalProject' :: [FileTree] -> [FileTree]
simpleCabalProject' [FileTree]
fps =
  [ FileTree
simpleCabalCradle
  ] forall a. Semigroup a => a -> a -> a
<> [FileTree]
fps