update-nix-fetchgit-0.2.7: src/Update/Nix/FetchGit/Utils.hs
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 t = case parseNixTextLoc t of
Left parseError -> Left (CouldNotParseInput (tShow parseError))
Right expr -> pure expr
ourParseNixFile :: FilePath -> M NExprLoc
ourParseNixFile f = liftIO (parseNixFileLoc f) >>= \case
Left parseError -> refute1 (CouldNotParseInput (tShow parseError))
Right expr -> pure expr
-- | Get the url from either a nix expression for the url or a repo and owner
-- expression.
extractUrlString :: RepoLocation -> Text
extractUrlString = \case
URL u -> u
GitHub o r -> "https://github.com/" <> o <> "/" <> r <> ".git"
GitLab o r -> "https://gitlab.com/" <> o <> "/" <> r <> ".git"
prettyRepoLocation :: RepoLocation -> Text
prettyRepoLocation = \case
URL u -> u
GitHub o r -> o <> "/" <> r
GitLab o r -> o <> "/" <> r
-- Add double quotes around a string so it can be inserted into a Nix
-- file as a string literal.
quoteString :: Text -> Text
quoteString t = "\"" <> t <> "\""
-- | 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 = \case
(AnnE _ (NStr (DoubleQuoted [Plain t]))) -> pure t
e -> Left (NotAString e)
exprBool :: NExprLoc -> Either Warning Bool
exprBool = \case
(AnnE _ (NConstant (NBool b))) -> pure b
e -> Left (NotABool e)
-- | Get the 'SrcSpan' covering a particular expression.
exprSpan :: NExprLoc -> SrcSpan
exprSpan (AnnE s _) = s
exprSpan _ = 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 (AnnE _ (NSym name)) = Just name
extractFuncName (AnnE _ (NSelect _ (NE.last -> StaticKey name) _)) = Just name
extractFuncName _ = Nothing
pathText :: NAttrPath r -> Maybe Text
pathText = fmap (T.concat . toList) . traverse e
where
e :: NKeyName r -> Maybe Text
e = \case
StaticKey s -> Just s
DynamicKey (Plain s) -> t s
DynamicKey EscapedNewline -> Just "\n"
DynamicKey (Antiquoted _) -> Nothing
t :: NString r -> Maybe Text
t =
fmap T.concat
. traverse a
. (\case
DoubleQuoted as -> as
Indented _ as -> as
)
a :: Antiquoted Text r -> Maybe Text
a = \case
Plain s -> pure s
EscapedNewline -> pure "\n"
Antiquoted _ -> Nothing
-- Takes an ISO 8601 date and returns just the day portion.
parseISO8601DateToDay :: Text -> Either Warning Day
parseISO8601DateToDay t =
let justDate = (unpack . Prelude.head . splitOn "T") t
in maybe (Left $ InvalidDateString t)
Right
(parseTimeM False defaultTimeLocale "%Y-%m-%d" justDate)
formatWarning :: Warning -> Text
formatWarning (CouldNotParseInput doc) = doc
formatWarning (MissingAttr attrName) =
"Error: The \"" <> attrName <> "\" attribute is missing."
formatWarning (DuplicateAttrs attrName) =
"Error: The \"" <> attrName <> "\" attribute appears twice in a set."
formatWarning (NotAString expr) =
"Error: The expression at "
<> (T.pack . prettyPrintSourcePos . spanBegin . exprSpan) expr
<> " is not a string literal."
formatWarning (NotABool expr) =
"Error: The expression at "
<> (T.pack . prettyPrintSourcePos . spanBegin . exprSpan) expr
<> " is not a boolean literal."
formatWarning (NixPrefetchGitFailed exitCode errorOutput) =
"Error: nix-prefetch-git failed with exit code "
<> tShow exitCode
<> " and error output:\n"
<> errorOutput
formatWarning (InvalidPrefetchGitOutput output) =
"Error: Output from nix-prefetch-git is invalid:\n" <> tShow output
formatWarning (NixPrefetchUrlFailed exitCode errorOutput) =
"Error: nix-prefetch-url failed with exit code "
<> tShow exitCode
<> " and error output:\n"
<> errorOutput
formatWarning (InvalidPrefetchUrlOutput output) =
"Error: Output from nix-prefetch-url is invalid:\n" <> tShow output
formatWarning (InvalidDateString text) =
"Error: Date string is invalid: " <> tShow text
formatWarning (GitLsRemoteFailed exitCode errorOutput) =
"Error: git ls-remote failed with exit code "
<> tShow exitCode
<> " and error output:\n"
<> errorOutput
formatWarning (NoSuchRef text) = "Error: No such ref: " <> tShow text
formatWarning (InvalidGitLsRemoteOutput output) =
"Error: Output from git ls-remote is invalid:\n" <> tShow output
tShow :: Show a => a -> Text
tShow = T.pack . show
----------------------------------------------------------------
-- Locations
----------------------------------------------------------------
containsPosition :: NExprLoc -> (Int, Int) -> Bool
containsPosition (Fix (Compose (Ann (SrcSpan begin end) _))) p =
let unSourcePos (SourcePos _ l c) = (unPos l, unPos c)
in p >= unSourcePos begin && p < unSourcePos end
----------------------------------------------------------------
-- Errors
----------------------------------------------------------------
fromEither :: Either Warning a -> M a
fromEither = \case
Left e -> refute1 e
Right a -> pure a
note :: Warning -> Maybe a -> M a
note e = \case
Nothing -> refute1 e
Just a -> pure a
refute1 :: Warning -> M a
refute1 = refute . Dual . pure
----------------------------------------------------------------
-- Logging
----------------------------------------------------------------
logVerbose :: Text -> M ()
logVerbose t = do
Env{..} <- ask
liftIO $ sayLog Verbose t
logNormal :: Text -> M ()
logNormal t = do
Env {..} <- ask
liftIO $ sayLog Normal t