Package.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase   #-}
{-# LANGUAGE MultiWayIf   #-}

-- | Create a package.dhall from files and directory contents.

module Dhall.Package
    ( Options
    , defaultOptions
    , characterSet
    , packageFileName
    , packagingMode
    , PackagingMode(..)
    , writePackage
    , getPackagePathAndContent
    , PackageError(..)
    ) where

import           Control.Exception  (Exception, throwIO)
import           Control.Monad
import           Data.List.NonEmpty (NonEmpty (..))
import           Data.Text          (Text)
import qualified Data.Text          as Text
import           Data.Traversable   (for)
import           Dhall.Core
    ( Directory (..)
    , Expr (..)
    , File (..)
    , FilePrefix (..)
    , Import (..)
    , ImportHashed (..)
    , ImportMode (..)
    , ImportType (..)
    , RecordField (..)
    , makeRecordField
    )
import           Dhall.Map          (Map)
import qualified Dhall.Map          as Map
import           Dhall.Pretty       (CharacterSet (..))
import qualified Dhall.Pretty
import           Dhall.Util         (_ERROR, renderExpression)
import           Lens.Micro         (Lens', lens)
import           System.Directory
import           System.FilePath

-- | Options for package creation.
data Options = Options
    { optionsCharacterSet :: CharacterSet
    , optionsPackageFileName :: String
    , optionsPackagingMode :: PackagingMode
    }

-- | The default options used for packaging.
--
-- The default values for the different settings are:
--
--  * The character set used is the one given by 'Dhall.Pretty.defaultCharacterSet'.
--  * The package file name is @package.dhall@.
--  * The packaging mode is 'OnlyThisPackage'.
defaultOptions :: Options
defaultOptions = Options
    { optionsCharacterSet = Dhall.Pretty.defaultCharacterSet
    , optionsPackageFileName = "package.dhall"
    , optionsPackagingMode = OnlyThisPackage
    }

-- | Access the character set used to render the package content.
characterSet :: Lens' Options CharacterSet
characterSet = lens optionsCharacterSet (\s x -> s { optionsCharacterSet = x })

-- | Access the file name used for the package file.
packageFileName :: Lens' Options String
packageFileName =
    lens optionsPackageFileName (\s x -> s { optionsPackageFileName = x })

-- | Access the packaging mode.
-- See the documentation of 'getPackagePathAndContent'.
packagingMode :: Lens' Options PackagingMode
packagingMode =
    lens optionsPackagingMode (\s x -> s { optionsPackagingMode = x })

-- | Whether to recursively create a package for each subdirectory or not.
-- See the documentation of 'getPackagePathAndContent'.
data PackagingMode
    = OnlyThisPackage
    | RecursiveSubpackages

-- | Create a package.dhall from files and directory contents.
-- For a description of how the package file is constructed see
-- 'getPackagePathAndContent'.
writePackage :: Options -> NonEmpty FilePath -> IO ()
writePackage options inputs = do
    (outputPath, expr) <- getPackagePathAndContent options inputs
    renderExpression (optionsCharacterSet options) True (Just outputPath) expr

-- | Get the path and the Dhall expression for a package file.
--
-- The location of the resulting package file is determined by the first path of the second argument:
--
--   * If it is a directory, it is also the output directory and the package
--     file will be placed there.
--
--   * If it is a file, then the directory that file resides in is the output
--     directory and the package file will be placed there.
--
-- All inputs provided as the second argument must be either in the output
-- directory or below it. They are processed depending on whether
-- the path points to a directory or a file:
--
--   * If the path points to a directory, all files with a @.dhall@ extensions
--     in that directory are included in the package.
--
--     If you passed `Recurse` to the this function, then in addition to these
--     files all subdirectories are traversed and a sub-package created for each
--     one. That sub-package will be included in the package too.
--
--   * If the path points to a regular file, it is included in the package
--     unless it is the path of the package file itself.
--
getPackagePathAndContent
    :: Options
    -> NonEmpty FilePath
    -> IO (FilePath, Expr s Import)
getPackagePathAndContent options (path :| paths) = do
    outputDir <- do
        isDirectory <- doesDirectoryExist path
        return $ if isDirectory then path else takeDirectory path
    outputDir' <- addTrailingPathSeparator <$> makeAbsolute (normalise outputDir)

    -- Check if the supplied @dir@ argument points to a filesystem entry below
    -- the output directory and return the path relative to the output directory.
    let checkOutputDir dir = do
            absoluteDir <- addTrailingPathSeparator <$> makeAbsolute (normalise dir)
            let relativeDir = makeRelative outputDir' absoluteDir
            unless (isRelative relativeDir) $
                throwIO $ AmbiguousOutputDirectory outputDir dir
            return relativeDir

    resultMap <- go Map.empty checkOutputDir (path:paths)
    return (outputDir </> outputFn, RecordLit $ Map.sort resultMap)
    where
        go
            :: Map Text (RecordField s Import)
            -> (FilePath -> IO FilePath)
            -> [FilePath]
            -> IO (Map Text (RecordField s Import))
        go !acc _checkOutputDir [] = return acc
        go !acc checkOutputDir (p:ps) = do
            isDirectory <- doesDirectoryExist p
            isFile <- doesFileExist p
            if | isDirectory -> do
                    void $ checkOutputDir p
                    entries <- listDirectory p
                    (dhallFiles, subdirectories) <- foldMap
                        ( \entry -> do
                            let entry' = p </> entry
                            isDirectoryEntry <- doesDirectoryExist entry'
                            return $ if isDirectoryEntry
                                then (mempty, [entry'])
                                else if hasDhallExtension entry
                                    then ([entry'], mempty)
                                    else mempty
                        ) entries
                    subpackages <- case optionsPackagingMode options of
                        RecursiveSubpackages ->
                            for subdirectories $ \subdirectory -> do
                                writePackage options (subdirectory :| [])
                                return (subdirectory </> outputFn)
                        OnlyThisPackage -> return []
                    go acc checkOutputDir (dhallFiles <> subpackages <> ps)
               | isFile -> do
                    dir <- checkOutputDir $ takeDirectory p

                    let p' = normalise $ dir </> takeFileName p

                    let resultMap = if p' == outputFn
                            then Map.empty
                            else filepathToMap outputFn p'

                    acc' <- mergeMaps acc resultMap
                    go acc' checkOutputDir ps
                | otherwise -> throwIO $ InvalidPath p

        hasDhallExtension :: FilePath -> Bool
        hasDhallExtension entry = takeExtension entry == ".dhall"

        outputFn :: String
        outputFn = optionsPackageFileName options

-- | Construct a nested 'Map' from a 'FilePath'.
-- For example, the filepath @some/file/path.dhall@ will result in something
-- similar to the following:
--
-- fromList
--   [ ("some", fromList
--     [ ("file", fromList
--       [ ("path", ./some/file/path.dhall)
--       ])
--     ])
--   ])
--
-- ... where ./some/file/path.dhall is a Dhall import. If the last component
-- equals the value passed in the @outputFn@ argument we produce a slightly
-- different result. Consider for example the Dhall Prelude: We have some
-- sub-packages there like @List/package.dhall@. If we want to construct the
-- top-level @package.dhall@ we want an entry like
--
-- > List = ./List/package.dhall
--
-- in there and not:
--
-- > List = { package = ./List/package.dhall }
--
filepathToMap :: FilePath -> FilePath -> Map Text (RecordField s Import)
filepathToMap outputFn = go [] . splitDirectories
    where
        go acc [] = go acc ["."]
        go !acc [x] =
                    let import_ = Import
                            { importHashed = ImportHashed
                                { hash = Nothing
                                , importType = Local Here File
                                    { directory = Directory acc
                                    , file = Text.pack x
                                    }
                                }
                            , importMode = Code
                            }
            in Map.singleton (Text.pack $ dropExtension x) $ makeRecordField $ Embed import_
        go !acc [x, y] | y == outputFn =
                    let import_ = Import
                            { importHashed = ImportHashed
                                { hash = Nothing
                                , importType = Local Here File
                                    { directory = Directory (Text.pack x : acc)
                                    , file = Text.pack y
                                    }
                                }
                            , importMode = Code
                            }
            in Map.singleton (Text.pack x) $ makeRecordField $ Embed import_
        go !acc (x:xs) = Map.singleton (Text.pack x) $ makeRecordField $ RecordLit $ go (Text.pack x : acc) xs

-- | Merge two 'Map's constructed with 'filepathToMap'.
-- It will throw an error if the arguments are not compatible with each other, e.g.
-- we cannot merge the following two maps:
--
-- > fromList [ ("file", ./file.dhall) ]
-- > fromList [ ("file", fromList [("nested", ./file/nested.dhall)]) ]
--
mergeMaps :: Map Text (RecordField s Import) -> Map Text (RecordField s Import) -> IO (Map Text (RecordField s Import))
mergeMaps x y = do
    let x' = fmap (:| []) x
        y' = fmap (:| []) y
        z = Map.unionWith (<>) x' y'
    for z $ \case
        v@RecordField{recordFieldValue = Embed{}} :| [] -> return v
        vs | Just rs <- traverse extractRecordLit vs -> makeRecordField . RecordLit . Map.sort <$> foldM mergeMaps Map.empty rs
           | otherwise -> throwIO $ IncompatiblePaths $ foldMap extractEmbeds vs
    where
        extractEmbeds :: RecordField s Import -> [Import]
        extractEmbeds RecordField{recordFieldValue = Embed import_} = [import_]
        extractEmbeds RecordField{recordFieldValue = RecordLit xs} = foldMap extractEmbeds xs
        extractEmbeds _ = mempty

        extractRecordLit :: RecordField s Import -> Maybe (Map Text (RecordField s Import))
        extractRecordLit RecordField{recordFieldValue = RecordLit xs} = Just xs
        extractRecordLit _ = Nothing

-- | Exception thrown when creating a package file.
data PackageError
    = AmbiguousOutputDirectory FilePath FilePath
    | IncompatiblePaths [Import]
    | InvalidPath FilePath

instance Exception PackageError

instance Show PackageError where
    show (AmbiguousOutputDirectory dir1 dir2) =
        _ERROR <> ": ❰dhall package❱ failed because the inputs make it impossible to\n\
        \determine the output directory of the package file. You asked to include files\n\
        \from the following directories in the package:\n\
        \\n" <> dir1 <>
        "\n" <> dir2 <>
        "\n\n\
        \Although those paths might point to the same location they are not lexically the\n\
        \same."

    show (IncompatiblePaths imports) =
        _ERROR <> ": ❰dhall package❱ failed because some inputs are not compatible with\n\
        \each other:\n\
        \\n" <> unlines (map (show . Dhall.Pretty.prettyExpr . Embed) imports)

    show (InvalidPath fp) =
        _ERROR <> ": ❰dhall package❱ failed because the input does not exist or is\n\
        \neither a directory nor a regular file:\n\
        \\n" <> fp