module Update.Nix.FetchGit.Utils
  ( RepoLocation(..)
  , ourParseNixText
  , ourParseNixFile
  , extractUrlString
  , prettyRepoLocation
  , quoteString
  , extractFuncName
  , pathText
  , exprText
  , exprBool
  , exprSpan
  , containsPosition
  , parseISO8601DateToDay
  , formatWarning
  , fromEither
  , note
  , refute1
  , logVerbose
  , logNormal
  ) where

import           Control.Monad.IO.Class         ( MonadIO(liftIO) )
import           Control.Monad.Reader           ( MonadReader(ask) )
import           Control.Monad.Validate
import           Data.Fix
import           Data.List.NonEmpty            as NE
import           Data.Monoid
import           Data.Text                      ( Text
                                                , splitOn
                                                , unpack
                                                )
import qualified Data.Text                     as T
import           Data.Time                      ( Day
                                                , defaultTimeLocale
                                                , parseTimeM
                                                )
import           Nix.Atoms                      ( NAtom(NBool) )
import           Nix.Expr                hiding ( SourcePos )
import           Nix.Parser                     ( Result(..)
                                                , parseNixFileLoc
                                                , parseNixTextLoc
                                                )
import           Update.Nix.FetchGit.Types
import           Update.Nix.FetchGit.Warning
import           Update.Span

ourParseNixText :: Text -> Either Warning NExprLoc
ourParseNixText :: Text -> Either Warning NExprLoc
ourParseNixText t :: Text
t = case Text -> Result NExprLoc
parseNixTextLoc Text
t of
  Failure parseError :: Doc Void
parseError -> Warning -> Either Warning NExprLoc
forall a b. a -> Either a b
Left (Text -> Warning
CouldNotParseInput (Doc Void -> Text
forall a. Show a => a -> Text
tShow Doc Void
parseError))
  Success expr :: NExprLoc
expr       -> NExprLoc -> Either Warning NExprLoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure NExprLoc
expr

ourParseNixFile :: FilePath -> M NExprLoc
ourParseNixFile :: FilePath -> M NExprLoc
ourParseNixFile f :: FilePath
f = IO (Result NExprLoc)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Result NExprLoc)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO (Result NExprLoc)
forall (m :: * -> *).
MonadFile m =>
FilePath -> m (Result NExprLoc)
parseNixFileLoc FilePath
f) ReaderT Env (ValidateT (Dual [Warning]) IO) (Result NExprLoc)
-> (Result NExprLoc -> M NExprLoc) -> M NExprLoc
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Failure parseError :: Doc Void
parseError -> Warning -> M NExprLoc
forall a. Warning -> M a
refute1 (Text -> Warning
CouldNotParseInput (Doc Void -> Text
forall a. Show a => a -> Text
tShow Doc Void
parseError))
  Success expr :: NExprLoc
expr       -> NExprLoc -> M NExprLoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure NExprLoc
expr

-- | Get the url from either a nix expression for the url or a repo and owner
-- expression.
extractUrlString :: RepoLocation -> Text
extractUrlString :: RepoLocation -> Text
extractUrlString = \case
  URL u :: Text
u -> Text
u
  GitHub o :: Text
o r :: Text
r -> "https://github.com/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
o Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ".git"
  GitLab o :: Text
o r :: Text
r -> "https://gitlab.com/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
o Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ".git"

prettyRepoLocation :: RepoLocation -> Text
prettyRepoLocation :: RepoLocation -> Text
prettyRepoLocation = \case
  URL u :: Text
u      -> Text
u
  GitHub o :: Text
o r :: Text
r -> Text
o Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r
  GitLab o :: Text
o r :: Text
r -> Text
o Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r

-- Add double quotes around a string so it can be inserted into a Nix
-- file as a string literal.
quoteString :: Text -> Text
quoteString :: Text -> Text
quoteString t :: Text
t = "\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\""

-- | Get the string value of a particular expression, returns a 'Warning' if
-- the expression is not a string value.
--
-- TODO: Use 'evalExpr' here
exprText :: NExprLoc -> Either Warning Text
exprText :: NExprLoc -> Either Warning Text
exprText = \case
  (AnnE _ (NStr (DoubleQuoted [Plain t :: Text
t]))) -> Text -> Either Warning Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
t
  e :: NExprLoc
e -> Warning -> Either Warning Text
forall a b. a -> Either a b
Left (NExprLoc -> Warning
NotAString NExprLoc
e)

exprBool :: NExprLoc -> Either Warning Bool
exprBool :: NExprLoc -> Either Warning Bool
exprBool = \case
  (AnnE _ (NConstant (NBool b :: Bool
b))) -> Bool -> Either Warning Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
b
  e :: NExprLoc
e                              -> Warning -> Either Warning Bool
forall a b. a -> Either a b
Left (NExprLoc -> Warning
NotABool NExprLoc
e)

-- | Get the 'SrcSpan' covering a particular expression.
exprSpan :: NExprLoc -> SrcSpan
exprSpan :: NExprLoc -> SrcSpan
exprSpan (AnnE s :: SrcSpan
s _) = SrcSpan
s
exprSpan _ = FilePath -> SrcSpan
forall a. HasCallStack => FilePath -> a
error "unreachable" -- TODO: Add pattern completeness to hnix

-- | Given an expression that is supposed to represent a function,
-- extracts the name of the function.  If we cannot figure out the
-- function name, returns Nothing.
extractFuncName :: NExprLoc -> Maybe Text
extractFuncName :: NExprLoc -> Maybe Text
extractFuncName (AnnE _ (NSym name :: Text
name)) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name
extractFuncName (AnnE _ (NSelect _ (NAttrPath NExprLoc -> NKeyName NExprLoc
forall a. NonEmpty a -> a
NE.last -> StaticKey name :: Text
name) _)) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name
extractFuncName _ = Maybe Text
forall a. Maybe a
Nothing

pathText :: NAttrPath r -> Maybe Text
pathText :: NAttrPath r -> Maybe Text
pathText = (NonEmpty Text -> Text) -> Maybe (NonEmpty Text) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Text] -> Text
T.concat ([Text] -> Text)
-> (NonEmpty Text -> [Text]) -> NonEmpty Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
toList) (Maybe (NonEmpty Text) -> Maybe Text)
-> (NAttrPath r -> Maybe (NonEmpty Text))
-> NAttrPath r
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NKeyName r -> Maybe Text) -> NAttrPath r -> Maybe (NonEmpty Text)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse NKeyName r -> Maybe Text
forall r. NKeyName r -> Maybe Text
e
 where
  e :: NKeyName r -> Maybe Text
  e :: NKeyName r -> Maybe Text
e = \case
    StaticKey  s :: Text
s              -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
s
    DynamicKey (Plain s :: NString r
s)      -> NString r -> Maybe Text
forall r. NString r -> Maybe Text
t NString r
s
    DynamicKey EscapedNewline -> Text -> Maybe Text
forall a. a -> Maybe a
Just "\n"
    DynamicKey (Antiquoted _) -> Maybe Text
forall a. Maybe a
Nothing
  t :: NString r -> Maybe Text
  t :: NString r -> Maybe Text
t =
    ([Text] -> Text) -> Maybe [Text] -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Text] -> Text
T.concat
      (Maybe [Text] -> Maybe Text)
-> (NString r -> Maybe [Text]) -> NString r -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Antiquoted Text r -> Maybe Text)
-> [Antiquoted Text r] -> Maybe [Text]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Antiquoted Text r -> Maybe Text
forall r. Antiquoted Text r -> Maybe Text
a
      ([Antiquoted Text r] -> Maybe [Text])
-> (NString r -> [Antiquoted Text r]) -> NString r -> Maybe [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\case
          DoubleQuoted as :: [Antiquoted Text r]
as -> [Antiquoted Text r]
as
          Indented _ as :: [Antiquoted Text r]
as   -> [Antiquoted Text r]
as
        )
  a :: Antiquoted Text r -> Maybe Text
  a :: Antiquoted Text r -> Maybe Text
a = \case
    Plain s :: Text
s        -> Text -> Maybe Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
s
    EscapedNewline -> Text -> Maybe Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure "\n"
    Antiquoted _   -> Maybe Text
forall a. Maybe a
Nothing


-- Takes an ISO 8601 date and returns just the day portion.
parseISO8601DateToDay :: Text -> Either Warning Day
parseISO8601DateToDay :: Text -> Either Warning Day
parseISO8601DateToDay t :: Text
t =
  let justDate :: FilePath
justDate = (Text -> FilePath
unpack (Text -> FilePath) -> (Text -> Text) -> Text -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall a. [a] -> a
Prelude.head ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
splitOn "T") Text
t
  in  Either Warning Day
-> (Day -> Either Warning Day) -> Maybe Day -> Either Warning Day
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Warning -> Either Warning Day
forall a b. a -> Either a b
Left (Warning -> Either Warning Day) -> Warning -> Either Warning Day
forall a b. (a -> b) -> a -> b
$ Text -> Warning
InvalidDateString Text
t)
            Day -> Either Warning Day
forall a b. b -> Either a b
Right
            (Bool -> TimeLocale -> FilePath -> FilePath -> Maybe Day
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> FilePath -> FilePath -> m t
parseTimeM Bool
False TimeLocale
defaultTimeLocale "%Y-%m-%d" FilePath
justDate)

formatWarning :: Warning -> Text
formatWarning :: Warning -> Text
formatWarning (CouldNotParseInput doc :: Text
doc) = Text
doc
formatWarning (MissingAttr attrName :: Text
attrName) =
  "Error: The \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attrName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" attribute is missing."
formatWarning (DuplicateAttrs attrName :: Text
attrName) =
  "Error: The \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attrName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" attribute appears twice in a set."
formatWarning (NotAString expr :: NExprLoc
expr) =
  "Error: The expression at "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (FilePath -> Text
T.pack (FilePath -> Text) -> (NExprLoc -> FilePath) -> NExprLoc -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePos -> FilePath
prettyPrintSourcePos (SourcePos -> FilePath)
-> (NExprLoc -> SourcePos) -> NExprLoc -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> SourcePos
spanBegin (SrcSpan -> SourcePos)
-> (NExprLoc -> SrcSpan) -> NExprLoc -> SourcePos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NExprLoc -> SrcSpan
exprSpan) NExprLoc
expr
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " is not a string literal."
formatWarning (NotABool expr :: NExprLoc
expr) =
  "Error: The expression at "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (FilePath -> Text
T.pack (FilePath -> Text) -> (NExprLoc -> FilePath) -> NExprLoc -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePos -> FilePath
prettyPrintSourcePos (SourcePos -> FilePath)
-> (NExprLoc -> SourcePos) -> NExprLoc -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> SourcePos
spanBegin (SrcSpan -> SourcePos)
-> (NExprLoc -> SrcSpan) -> NExprLoc -> SourcePos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NExprLoc -> SrcSpan
exprSpan) NExprLoc
expr
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " is not a boolean literal."
formatWarning (NixPrefetchGitFailed exitCode :: Int
exitCode errorOutput :: Text
errorOutput) =
  "Error: nix-prefetch-git failed with exit code "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tShow Int
exitCode
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " and error output:\n"
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
errorOutput
formatWarning (InvalidPrefetchGitOutput output :: Text
output) =
  "Error: Output from nix-prefetch-git is invalid:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
tShow Text
output
formatWarning (NixPrefetchUrlFailed exitCode :: Int
exitCode errorOutput :: Text
errorOutput) =
  "Error: nix-prefetch-url failed with exit code "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tShow Int
exitCode
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " and error output:\n"
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
errorOutput
formatWarning (InvalidPrefetchUrlOutput output :: Text
output) =
  "Error: Output from nix-prefetch-url is invalid:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
tShow Text
output
formatWarning (InvalidDateString text :: Text
text) =
  "Error: Date string is invalid: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
tShow Text
text
formatWarning (GitLsRemoteFailed exitCode :: Int
exitCode errorOutput :: Text
errorOutput) =
  "Error: git ls-remote failed with exit code "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tShow Int
exitCode
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " and error output:\n"
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
errorOutput
formatWarning (NoSuchRef text :: Text
text) = "Error: No such ref: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
tShow Text
text
formatWarning (InvalidGitLsRemoteOutput output :: Text
output) =
  "Error: Output from git ls-remote is invalid:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
tShow Text
output

tShow :: Show a => a -> Text
tShow :: a -> Text
tShow = FilePath -> Text
T.pack (FilePath -> Text) -> (a -> FilePath) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FilePath
forall a. Show a => a -> FilePath
show

----------------------------------------------------------------
-- Locations
----------------------------------------------------------------

containsPosition :: NExprLoc -> (Int, Int) -> Bool
containsPosition :: NExprLoc -> (Int, Int) -> Bool
containsPosition (Fix (Compose (Ann (SrcSpan begin :: SourcePos
begin end :: SourcePos
end) _))) p :: (Int, Int)
p =
  let unSourcePos :: SourcePos -> (Int, Int)
unSourcePos (SourcePos _ l :: Pos
l c :: Pos
c) = (Pos -> Int
unPos Pos
l, Pos -> Int
unPos Pos
c)
  in  (Int, Int)
p (Int, Int) -> (Int, Int) -> Bool
forall a. Ord a => a -> a -> Bool
>= SourcePos -> (Int, Int)
unSourcePos SourcePos
begin Bool -> Bool -> Bool
&& (Int, Int)
p (Int, Int) -> (Int, Int) -> Bool
forall a. Ord a => a -> a -> Bool
< SourcePos -> (Int, Int)
unSourcePos SourcePos
end

----------------------------------------------------------------
-- Errors
----------------------------------------------------------------

fromEither :: Either Warning a -> M a
fromEither :: Either Warning a -> M a
fromEither = \case
  Left  e :: Warning
e -> Warning -> M a
forall a. Warning -> M a
refute1 Warning
e
  Right a :: a
a -> a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

note :: Warning -> Maybe a -> M a
note :: Warning -> Maybe a -> M a
note e :: Warning
e = \case
  Nothing -> Warning -> M a
forall a. Warning -> M a
refute1 Warning
e
  Just a :: a
a -> a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

refute1 :: Warning -> M a
refute1 :: Warning -> M a
refute1 = Dual [Warning] -> M a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute (Dual [Warning] -> M a)
-> (Warning -> Dual [Warning]) -> Warning -> M a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Warning] -> Dual [Warning]
forall a. a -> Dual a
Dual ([Warning] -> Dual [Warning])
-> (Warning -> [Warning]) -> Warning -> Dual [Warning]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Warning -> [Warning]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

----------------------------------------------------------------
-- Logging
----------------------------------------------------------------

logVerbose :: Text -> M ()
logVerbose :: Text -> M ()
logVerbose t :: Text
t = do
  Env{..} <- ReaderT Env (ValidateT (Dual [Warning]) IO) Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO () -> M ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ()) -> IO () -> M ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> Text -> IO ()
sayLog Verbosity
Verbose Text
t

logNormal :: Text -> M ()
logNormal :: Text -> M ()
logNormal t :: Text
t = do
  Env {..} <- ReaderT Env (ValidateT (Dual [Warning]) IO) Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO () -> M ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ()) -> IO () -> M ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> Text -> IO ()
sayLog Verbosity
Normal Text
t