{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedStrings #-}
module Cryptol.Project.Config where

import           Data.Maybe                       (fromMaybe)
import qualified Data.Text.IO                     as Text
import           Toml
import           Toml.Schema
import           Data.Bifunctor (first)
import           System.Directory
import           System.FilePath                  as FP
import           System.IO.Error

import           Cryptol.Utils.PP                 as PP

data Config = Config
  { Config -> FilePath
root    :: FilePath
    -- ^ The root of the project.

  , Config -> [FilePath]
modules :: [String]
    -- ^ Git-style patterns describing the files for the project.
  }

data LoadProjectMode
  = RefreshMode  -- load all files
  | ModifiedMode -- load modified files
  | UntestedMode -- load files without a successful test result
  deriving Int -> LoadProjectMode -> ShowS
[LoadProjectMode] -> ShowS
LoadProjectMode -> FilePath
(Int -> LoadProjectMode -> ShowS)
-> (LoadProjectMode -> FilePath)
-> ([LoadProjectMode] -> ShowS)
-> Show LoadProjectMode
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LoadProjectMode -> ShowS
showsPrec :: Int -> LoadProjectMode -> ShowS
$cshow :: LoadProjectMode -> FilePath
show :: LoadProjectMode -> FilePath
$cshowList :: [LoadProjectMode] -> ShowS
showList :: [LoadProjectMode] -> ShowS
Show

instance FromValue Config where
  fromValue :: forall l. Value' l -> Matcher l Config
fromValue =
    ParseTable l Config -> Value' l -> Matcher l Config
forall l a. ParseTable l a -> Value' l -> Matcher l a
parseTableFromValue
    do Maybe FilePath
mbRoot <- Text -> ParseTable l (Maybe FilePath)
forall a l. FromValue a => Text -> ParseTable l (Maybe a)
optKey Text
"root"
       [FilePath]
mods <- Text -> ParseTable l [FilePath]
forall a l. FromValue a => Text -> ParseTable l a
reqKey Text
"modules"
       Config -> ParseTable l Config
forall a. a -> ParseTable l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Config
         { root :: FilePath
root = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"." Maybe FilePath
mbRoot
         , modules :: [FilePath]
modules = [FilePath]
mods
         }

data ConfigLoadError = ConfigLoadError FilePath ConfigLoadErrorInfo
  deriving Int -> ConfigLoadError -> ShowS
[ConfigLoadError] -> ShowS
ConfigLoadError -> FilePath
(Int -> ConfigLoadError -> ShowS)
-> (ConfigLoadError -> FilePath)
-> ([ConfigLoadError] -> ShowS)
-> Show ConfigLoadError
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConfigLoadError -> ShowS
showsPrec :: Int -> ConfigLoadError -> ShowS
$cshow :: ConfigLoadError -> FilePath
show :: ConfigLoadError -> FilePath
$cshowList :: [ConfigLoadError] -> ShowS
showList :: [ConfigLoadError] -> ShowS
Show

data ConfigLoadErrorInfo
  = ConfigParseError [String]
  | SetRootFailed IOError
  deriving Int -> ConfigLoadErrorInfo -> ShowS
[ConfigLoadErrorInfo] -> ShowS
ConfigLoadErrorInfo -> FilePath
(Int -> ConfigLoadErrorInfo -> ShowS)
-> (ConfigLoadErrorInfo -> FilePath)
-> ([ConfigLoadErrorInfo] -> ShowS)
-> Show ConfigLoadErrorInfo
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConfigLoadErrorInfo -> ShowS
showsPrec :: Int -> ConfigLoadErrorInfo -> ShowS
$cshow :: ConfigLoadErrorInfo -> FilePath
show :: ConfigLoadErrorInfo -> FilePath
$cshowList :: [ConfigLoadErrorInfo] -> ShowS
showList :: [ConfigLoadErrorInfo] -> ShowS
Show

instance PP ConfigLoadError where
  ppPrec :: Int -> ConfigLoadError -> Doc
ppPrec Int
_ (ConfigLoadError FilePath
path ConfigLoadErrorInfo
info) =
    case ConfigLoadErrorInfo
info of
      ConfigParseError [FilePath]
errs -> FilePath -> Doc
text ([FilePath] -> FilePath
unlines [FilePath]
errs)
      SetRootFailed IOError
ioe ->
        Doc -> Int -> Doc -> Doc
hang Doc
topMsg
           Int
4 (Doc -> Int -> Doc -> Doc
hang Doc
"Failed to set project root:"
                 Int
4 (FilePath -> Doc
text (IOError -> FilePath
forall a. Show a => a -> FilePath
show IOError
ioe)))
    where
    topMsg :: Doc
topMsg = Doc
"Error loading project configuration" Doc -> Doc -> Doc
<+> FilePath -> Doc
text FilePath
path Doc -> Doc -> Doc
PP.<.> Doc
":"

-- | Parse project configuration.
loadConfig :: FilePath -> IO (Either ConfigLoadError Config)
loadConfig :: FilePath -> IO (Either ConfigLoadError Config)
loadConfig FilePath
path =
  do Bool
isDir <- FilePath -> IO Bool
doesDirectoryExist FilePath
path
     let filePath :: FilePath
filePath = if Bool
isDir then FilePath
path FilePath -> ShowS
FP.</> FilePath
"cryproject.toml" else FilePath
path
     -- Use strict IO since we are writing to the same file later
     Text
file <- FilePath -> IO Text
Text.readFile FilePath
filePath
     (ConfigLoadErrorInfo -> ConfigLoadError)
-> Either ConfigLoadErrorInfo Config
-> Either ConfigLoadError Config
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (FilePath -> ConfigLoadErrorInfo -> ConfigLoadError
ConfigLoadError FilePath
filePath) (Either ConfigLoadErrorInfo Config
 -> Either ConfigLoadError Config)
-> IO (Either ConfigLoadErrorInfo Config)
-> IO (Either ConfigLoadError Config)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
       case Text -> Result FilePath Config
forall a. FromValue a => Text -> Result FilePath a
decode Text
file of
         Failure [FilePath]
errs  -> Either ConfigLoadErrorInfo Config
-> IO (Either ConfigLoadErrorInfo Config)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConfigLoadErrorInfo -> Either ConfigLoadErrorInfo Config
forall a b. a -> Either a b
Left ([FilePath] -> ConfigLoadErrorInfo
ConfigParseError [FilePath]
errs))
         Success [FilePath]
_warns Config
config ->
           (IOError -> ConfigLoadErrorInfo)
-> Either IOError Config -> Either ConfigLoadErrorInfo Config
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first IOError -> ConfigLoadErrorInfo
SetRootFailed (Either IOError Config -> Either ConfigLoadErrorInfo Config)
-> IO (Either IOError Config)
-> IO (Either ConfigLoadErrorInfo Config)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
           IO Config -> IO (Either IOError Config)
forall a. IO a -> IO (Either IOError a)
tryIOError
             do FilePath
dir <- FilePath -> IO FilePath
canonicalizePath
                                    (ShowS
takeDirectory FilePath
filePath FilePath -> ShowS
FP.</> Config -> FilePath
root Config
config)
                FilePath -> IO ()
setCurrentDirectory FilePath
dir
                Config -> IO Config
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Config
config { root = dir }