diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,12 @@ ## WIP +## [0.2.11] - 2022-12-06 +- Changes for hnix-0.16 + +## [0.2.10] - 2022-03-20 +- Bump github-rest + ## [0.2.9] - 2021-07-21 - Fix dotgit / deepClone test sha256 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Joe Hermaszewski (c) 2016 +Copyright Ellie Hermaszewska (c) 2016 Copyright David Grayson (c) 2016 All rights reserved. @@ -14,7 +14,7 @@ disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Joe Hermaszewski nor the names of other + * Neither the name of Ellie Hermaszewska nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -62,9 +62,10 @@ , location :: w ::: [Position] "Source location to limit updates to, Combined using inclusive or" , attribute - :: w ::: [Regex] "Pattern (POSIX regex) to limit updates to expressions under matching names in attrsets and let bindings. Combined using inclusing or, if this isn't specified then no expressions will be filtered by attribute name" + :: w ::: [Regex] "Pattern (POSIX regex) to limit updates to expressions under matching names in attrsets and let bindings. Combined using inclusive or, if this isn't specified then no expressions will be filtered by attribute name" , dryRun :: w ::: Bool "False" "Don't modify the file" - , onlyCommented :: w ::: Bool "False" "Only update from Git sources which have a comment on the 'rev' (or 'url' for fetchTarball from GitHub) attribute" + , onlyCommented + :: w ::: Bool "False" "Only update from Git sources which have a comment on the 'rev' (or 'url' for fetchTarball from GitHub) attribute" } deriving stock Generic diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,14 +1,14 @@ name: update-nix-fetchgit -version: "0.2.9" +version: "0.2.11" synopsis: A program to update fetchgit values in Nix expressions description: | This command-line utility is meant to be used by people maintaining Nix expressions that fetch files from Git repositories. It automates the process of keeping such expressions up-to-date with the latest upstream sources. category: Nix -author: Joe Hermaszewski -maintainer: Joe Hermaszewski -copyright: 2020 Joe Hermaszewski +author: Ellie Hermaszewska +maintainer: Ellie Hermaszewska +copyright: 2020 Ellie Hermaszewska github: expipiplus1/update-nix-fetchgit extra-source-files: - package.yaml @@ -45,8 +45,8 @@ - async >= 2.1 - bytestring >= 0.10 - data-fix - - github-rest - - hnix >= 0.13.1 + - github-rest >= 1.1 + - hnix >= 0.16 && < 0.17 - monad-validate - mtl - process >= 1.2 @@ -62,8 +62,6 @@ update-nix-fetchgit-samples: source-dirs: tests main: Driver.hs - build-tools: - - tasty-discover dependencies: - base >= 4.7 && < 5 - directory diff --git a/src/Nix/Comments.hs b/src/Nix/Comments.hs --- a/src/Nix/Comments.hs +++ b/src/Nix/Comments.hs @@ -1,18 +1,20 @@ module Nix.Comments - ( annotateWithComments - , Comment - , NExprCommentsF - , NExprComments - ) where + ( annotateWithComments, + Comment, + NExprCommentsF, + NExprComments, + ) +where -import Data.Text ( Text ) -import Data.Vector ( (!?) - , Vector - ) -import Data.Fix -import Nix.Expr -import qualified Data.Text as T -import Data.Char ( isSpace ) +import Data.Char (isSpace) +import Data.Fix +import Data.Text (Text) +import qualified Data.Text as T +import Data.Vector + ( Vector, + (!?), + ) +import Nix.Expr type Comment = Text @@ -38,22 +40,23 @@ -- [(1 + { a = 2; },Just "baz"),(1,Just "foo"),({ a = 2; },Just "baz"),(2,Just "bar")] annotateWithComments :: Vector Text -> NExprLoc -> NExprComments annotateWithComments sourceLines = go - where - go :: NExprLoc -> NExprComments - go = Fix . go' . fmap go . unFix + where + go :: NExprLoc -> NExprComments + go = Fix . go' . fmap go . unFix - go' :: NExprLocF f -> NExprCommentsF f - go' e = - let - comment = case spanEnd . annotation . getCompose $ e of - SourcePos _ line col -> do - theLine <- sourceLines !? (unPos line - 1) - theLineAfterExpression <- dropMaybe (unPos col - 1) theLine - let theLineAfterCruft = T.dropWhile (\c -> isSpace c || (c == ';')) - theLineAfterExpression - ('#', theComment) <- T.uncons theLineAfterCruft - pure (T.strip theComment) - in Compose (Ann comment e) + go' :: NExprLocF f -> NExprCommentsF f + go' e = + let comment = case spanEnd . annotation . getCompose $ e of + SourcePos _ line col -> do + theLine <- sourceLines !? (unPos line - 1) + theLineAfterExpression <- dropMaybe (unPos col - 1) theLine + let theLineAfterCruft = + T.dropWhile + (\c -> isSpace c || (c == ';')) + theLineAfterExpression + ('#', theComment) <- T.uncons theLineAfterCruft + pure (T.strip theComment) + in Compose (AnnUnit comment e) ---------------------------------------------------------------- -- Utils diff --git a/src/Nix/Match.hs b/src/Nix/Match.hs --- a/src/Nix/Match.hs +++ b/src/Nix/Match.hs @@ -1,30 +1,32 @@ {-# LANGUAGE UndecidableInstances #-} + -- | A set of functions for matching on Nix expression trees and extracting the -- values of sub-trees. module Nix.Match - ( match - , findMatches - , Matchable(..) - , GMatchable(..) - , WithHoles(..) - , addHoles - , addHolesLoc - , isOptionalPath - ) where + ( match, + findMatches, + Matchable (..), + GMatchable (..), + WithHoles (..), + addHoles, + addHolesLoc, + isOptionalPath, + ) +where -import Control.Category ( (>>>) ) -import Control.Monad ( void ) -import Data.Data -import Data.Fix -import Data.Foldable -import Data.List.NonEmpty ( NonEmpty ) -import Data.Maybe -import Data.Monoid hiding ( All ) -import Data.Text ( Text ) -import qualified Data.Text as T -import GHC.Base ( NonEmpty((:|)) ) -import GHC.Generics -import Nix +import Control.Category ((>>>)) +import Control.Monad (void) +import Data.Data +import Data.Fix +import Data.Foldable +import Data.List.NonEmpty (NonEmpty) +import Data.Maybe +import Data.Monoid hiding (All) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Base (NonEmpty ((:|))) +import GHC.Generics +import Nix -- | Like 'Fix' but each layer could instead be a 'Hole' data WithHoles t v @@ -45,12 +47,12 @@ -- Just [("bar",Fix (NStr (DoubleQuoted [Plain "world"]))),("foo",Fix (NStr (DoubleQuoted [Plain "hello"])))] match :: Matchable t => WithHoles t v -> Fix t -> Maybe [(v, Fix t)] match = fmap (`appEndo` []) .: go - where - go = \case - Hole v -> \t -> Just (Endo ((v, t) :)) - Term s -> \(Fix t) -> do - m <- zipMatchLeft s t - fmap fold . traverse (uncurry go) . toList $ m + where + go = \case + Hole v -> \t -> Just (Endo ((v, t) :)) + Term s -> \(Fix t) -> do + m <- zipMatchLeft s t + fmap fold . traverse (uncurry go) . toList $ m -- | Find all the needles in a haystack, returning the matched expression as -- well as their filled holes. Results are returned productively in preorder. @@ -60,31 +62,33 @@ -- >>> pretty = prettyNix *** (fmap @[] (fmap @((,) Text) prettyNix)) -- >>> pretty <$> findMatches (addHoles [nix|{x=^x;}|]) [nix|{x=1;a={x=2;};}|] -- [({ x = 1; a = { x = 2; }; },[("x",1)]),({ x = 2; },[("x",2)])] -findMatches - :: Matchable t - => WithHoles t v - -- ^ Needle - -> Fix t - -- ^ Haystack - -> [(Fix t, [(v, Fix t)])] +findMatches :: + Matchable t => + -- | Needle + WithHoles t v -> + -- | Haystack + Fix t -> + [(Fix t, [(v, Fix t)])] findMatches needle haystack = - [ (s, r) | s <- fixUniverse haystack, Just r <- pure $ match needle s ] + [(s, r) | s <- fixUniverse haystack, Just r <- pure $ match needle s] -- | Get every @f@ in a @Fix f@ in preorder. fixUniverse :: Foldable f => Fix f -> [Fix f] fixUniverse e = e : (fixUniverse =<< toList (unFix e)) -- | Make syntactic holes into 'Hole's -addHoles :: NExpr -> WithHoles NExprF Text -addHoles = unFix >>> \case - NSynHole n -> Hole n - e -> Term . fmap addHoles $ e +addHoles :: NExpr -> WithHoles NExprF VarName +addHoles = + unFix >>> \case + NSynHole n -> Hole n + e -> Term . fmap addHoles $ e -- | Make syntactic holes into 'Hole's -addHolesLoc :: NExprLoc -> WithHoles NExprLocF Text -addHolesLoc = unFix >>> \case - Compose (Ann _ (NSynHole n)) -> Hole n - e -> Term . fmap addHolesLoc $ e +addHolesLoc :: NExprLoc -> WithHoles NExprLocF VarName +addHolesLoc = + unFix >>> \case + Compose (AnnUnit _ (NSynHole n)) -> Hole n + e -> Term . fmap addHolesLoc $ e ---------------------------------------------------------------- -- Matchable @@ -99,17 +103,17 @@ -- Unlike the @Unifiable@ class in the "unification-fd" package, this doesn't -- have to be a commutative operation, the needle will always be the first -- parameter and instances are free to treat if differently if appropriate. - zipMatchLeft :: t a -> t b -> Maybe (t (a,b)) - default zipMatchLeft - :: (Generic1 t, GMatchable (Rep1 t)) - => t a - -> t b - -> Maybe (t (a, b)) + zipMatchLeft :: t a -> t b -> Maybe (t (a, b)) + default zipMatchLeft :: + (Generic1 t, GMatchable (Rep1 t)) => + t a -> + t b -> + Maybe (t (a, b)) zipMatchLeft l r = to1 <$> gZipMatchLeft (from1 l) (from1 r) -- | Match a composition of 'Matchable' things -zipMatchLeft2 - :: (Matchable f, Matchable t) => t (f a) -> t (f b) -> Maybe (t (f (a, b))) +zipMatchLeft2 :: + (Matchable f, Matchable t) => t (f a) -> t (f b) -> Maybe (t (f (a, b))) zipMatchLeft2 a b = zipMatchLeft a b >>= traverse (uncurry zipMatchLeft) ---------------------------------------------------------------- @@ -131,19 +135,17 @@ -- - If a function in the needle has @_@ as its parameter, it matches -- everything, so @_@ acts as a wildcard pattern. instance Matchable NExprF where - zipMatchLeft (NSet _ bs1) (NSet _ bs2) = do (bs1', bs2') <- unzip <$> reduceBindings bs1 bs2 - to1 <$> gZipMatchLeft (from1 (NSet NNonRecursive bs1')) - (from1 (NSet NNonRecursive bs2')) - + to1 + <$> gZipMatchLeft + (from1 (NSet NonRecursive bs1')) + (from1 (NSet NonRecursive bs2')) zipMatchLeft (NLet bs1 e1) (NLet bs2 e2) = do (bs1', bs2') <- unzip <$> reduceBindings bs1 bs2 to1 <$> gZipMatchLeft (from1 (NLet bs1' e1)) (from1 (NLet bs2' e2)) - zipMatchLeft (NAbs (Param "_") e1) (NAbs _ e2) = do pure $ NAbs (Param "_") (e1, e2) - zipMatchLeft l r = to1 <$> gZipMatchLeft (from1 l) (from1 r) -- | Bindings are compared on top level structure only. @@ -159,9 +161,8 @@ -- match them up correctly. reduceBindings :: [Binding q] -> [Binding r] -> Maybe [(Binding q, Binding r)] reduceBindings needle matchee = - let - -- A binding is optional if the lhs starts with a '_', return the same - -- binding but without the '_' + let -- A binding is optional if the lhs starts with a '_', return the same + -- binding but without the '_' isOptional = \case NamedVar p e l | Just p' <- isOptionalPath p -> Just (NamedVar p' e l) _ -> Nothing @@ -169,51 +170,50 @@ -- Get a representation of the left hand side which has an Eq instance -- This will represent some things the samelike "${a}" and "${b}" getLHS = \case - NamedVar p _ _ -> Left (fmap void p) - Inherit r ps _ -> Right (void r, fmap void ps) - in sequence - [ (n', ) <$> m - | -- For each binding in the needle - n <- needle - , let opt = isOptional n - -- | Use the optional demangled version if present - n' = fromMaybe n opt - lhs = getLHS n' - -- Find the first matching binding in the matchee - m = find ((lhs ==) . getLHS) matchee - , -- Skip this element if it is not present in the matchee and is optional in the needle - isNothing opt || isJust m + NamedVar p _ _ -> Left (fmap void p) + Inherit r ps _ -> Right (void r, ps) + in sequence + [ (n',) <$> m + | -- For each binding in the needle + n <- needle, + let opt = isOptional n + -- \| Use the optional demangled version if present + n' = fromMaybe n opt + lhs = getLHS n' + -- Find the first matching binding in the matchee + m = find ((lhs ==) . getLHS) matchee, + -- Skip this element if it is not present in the matchee and is optional in the needle + isNothing opt || isJust m ] -- | Basically: does the path begin with an underscore, if so return it removed -- without the underscore. isOptionalPath :: NAttrPath r -> Maybe (NAttrPath r) isOptionalPath = \case - StaticKey n :| [] | Just ('_', t) <- T.uncons n -> Just (StaticKey t :| []) + StaticKey (VarName n) :| [] | Just ('_', t) <- T.uncons n -> Just (StaticKey (VarName t) :| []) DynamicKey (Plain (DoubleQuoted [Plain n])) :| rs - | Just ('_', t) <- T.uncons n -> Just - (DynamicKey (Plain (DoubleQuoted [Plain t])) :| rs) + | Just ('_', t) <- T.uncons n -> + Just + (DynamicKey (Plain (DoubleQuoted [Plain t])) :| rs) _ -> Nothing -- -- hnix types -- -instance Matchable NString where +instance Matchable NString -instance Matchable (Antiquoted Text) where +instance Matchable (Antiquoted Text) -- | The matched pair uses the source location of the first argument instance Matchable Binding where zipMatchLeft (NamedVar p1 v1 _) (NamedVar p2 v2 l) = do p <- zipMatchLeft2 p1 p2 pure (NamedVar p (v1, v2) l) - - zipMatchLeft (Inherit x1 ys1 l) (Inherit x2 ys2 _) = do - x <- zipMatchLeft x1 x2 - ys <- zipMatchLeft2 ys1 ys2 - pure (Inherit x ys l) - + zipMatchLeft (Inherit x1 ys1 l) (Inherit x2 ys2 _) + | ys1 == ys2 = do + x <- zipMatchLeft x1 x2 + pure (Inherit x ys1 l) zipMatchLeft _ _ = Nothing -- | No Generic1 instance @@ -228,26 +228,25 @@ pure $ DynamicKey (Antiquoted (k1, k2)) zipMatchLeft _ _ = Nothing -instance Matchable Params where +instance Matchable Params -- | Doesn't require the annotations to match, returns the second annotation. -instance Matchable (Ann ann) where - zipMatchLeft (Ann _ a1) (Ann ann2 a2) = Just $ Ann ann2 (a1, a2) +instance Matchable (AnnUnit ann) where + zipMatchLeft (AnnUnit _ a1) (AnnUnit ann2 a2) = Just $ AnnUnit ann2 (a1, a2) -- -- base types -- -instance Matchable [] where - -instance Matchable NonEmpty where +instance Matchable [] -instance Matchable Maybe where +instance Matchable NonEmpty -instance Eq a => Matchable ((,) a) where +instance Matchable Maybe -instance (Matchable f, Matchable g)=> Matchable (Compose f g) where +instance Eq a => Matchable ((,) a) +instance (Matchable f, Matchable g) => Matchable (Compose f g) ---------------------------------------------------------------- -- Generic Instance for Matchable @@ -255,7 +254,7 @@ -- | A class used in the @default@ definition for 'zipMatchLeft' class (Traversable t, Generic1 t) => GMatchable t where - gZipMatchLeft :: t a -> t b -> Maybe (t (a,b)) + gZipMatchLeft :: t a -> t b -> Maybe (t (a, b)) instance GMatchable t => GMatchable (M1 m i t) where gZipMatchLeft (M1 l) (M1 r) = M1 <$> gZipMatchLeft l r @@ -264,8 +263,9 @@ gZipMatchLeft _ _ = Just U1 instance Eq c => GMatchable (K1 m c) where - gZipMatchLeft (K1 l) (K1 r) | l == r = Just (K1 l) - | otherwise = Nothing + gZipMatchLeft (K1 l) (K1 r) + | l == r = Just (K1 l) + | otherwise = Nothing instance GMatchable Par1 where gZipMatchLeft (Par1 l) (Par1 r) = Just . Par1 $ (l, r) @@ -276,7 +276,7 @@ instance (GMatchable l, GMatchable r) => GMatchable (l :+: r) where gZipMatchLeft (L1 l) (L1 r) = L1 <$> gZipMatchLeft l r gZipMatchLeft (R1 l) (R1 r) = R1 <$> gZipMatchLeft l r - gZipMatchLeft _ _ = Nothing + gZipMatchLeft _ _ = Nothing instance (GMatchable l, GMatchable r) => GMatchable (l :*: r) where gZipMatchLeft (l1 :*: l2) (r1 :*: r2) = @@ -286,7 +286,6 @@ gZipMatchLeft (Comp1 l) (Comp1 r) = do x <- zipMatchLeft l r >>= traverse (uncurry gZipMatchLeft) pure (Comp1 x) - ---------------------------------------------------------------- -- Utils diff --git a/src/Nix/Match/Typed.hs b/src/Nix/Match/Typed.hs --- a/src/Nix/Match/Typed.hs +++ b/src/Nix/Match/Typed.hs @@ -1,60 +1,66 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + -- | A more strongly typed alternative to 'Nix.Match' module Nix.Match.Typed - ( matchNix - , matchNixLoc - , TypedMatcher(..) - , TypedMatch(..) - , get - , getOptional - , matchTyped - , findMatchesTyped - ) where + ( matchNix, + matchNixLoc, + TypedMatcher (..), + TypedMatch (..), + get, + getOptional, + matchTyped, + findMatchesTyped, + ) +where -import Control.Category ( (>>>) ) -import Data.Coerce ( coerce ) -import Data.Data -import Data.Fix -import Data.Generics.Aliases -import Data.Kind ( Constraint ) -import Data.Maybe -import qualified Data.Text as T -import Data.Type.Equality ( type (==) ) -import GHC.TypeLits ( ErrorMessage(..) - , KnownSymbol - , Symbol - , TypeError - , symbolVal - ) -import Language.Haskell.TH ( Exp(AppE, VarE) - , ExpQ - , Pat(..) - , PatQ - , Q - , TyLit(StrTyLit) - , Type(..) - , appTypeE - , litT - , mkName - , newName - , strTyLit - , tupE - , tupP - , varE - , varP - ) -import Language.Haskell.TH.Lib ( appE - , conE - ) -import Language.Haskell.TH.Quote ( QuasiQuoter(..) ) -import Language.Haskell.TH.Syntax ( dataToExpQ - , liftString - ) -import Nix hiding ( TypeError ) -import Nix.Match -import Nix.TH +import Control.Category ((>>>)) +import Data.Coerce (coerce) +import Data.Data +import Data.Fix +import Data.Generics.Aliases +import Data.Kind (Constraint) +import Data.Maybe +import qualified Data.Text as T +import Data.Type.Equality (type (==)) +import GHC.TypeLits + ( ErrorMessage (..), + KnownSymbol, + Symbol, + TypeError, + symbolVal, + ) +import Language.Haskell.TH + ( Exp (AppE, VarE), + ExpQ, + Pat (..), + PatQ, + Q, + TyLit (StrTyLit), + Type (..), + appTypeE, + litT, + mkName, + newName, + strTyLit, + tupE, + tupP, + varE, + varP, + ) +import Language.Haskell.TH.Lib + ( appE, + conE, + ) +import Language.Haskell.TH.Quote (QuasiQuoter (..)) +import Language.Haskell.TH.Syntax + ( dataToExpQ, + liftString, + ) +import Nix +import Nix.Match +import Nix.TH ---------------------------------------------------------------- -- Typed matching @@ -81,11 +87,13 @@ -- >>> :t (a, b) -- (a, b) :: (Fix NExprF, Maybe (Fix NExprF)) matchNix :: QuasiQuoter -matchNix = QuasiQuoter { quoteExp = typedMatcherExp - , quotePat = typedMatcherPat - , quoteDec = error "No dec quoter for typedMatcher" - , quoteType = error "No type quoter for typedMatcher" - } +matchNix = + QuasiQuoter + { quoteExp = typedMatcherExp, + quotePat = typedMatcherPat, + quoteDec = error "No dec quoter for typedMatcher", + quoteType = error "No type quoter for typedMatcher" + } -- | A QuasiQuoter for safely generating 'TypedMatcher's from nix source along -- with source location annotations @@ -100,17 +108,17 @@ -- the holes present in the expression. These will have type 'NExprLoc' if they -- are required, and @Maybe 'NExprLoc'@ if they are optional. matchNixLoc :: QuasiQuoter -matchNixLoc = QuasiQuoter - { quoteExp = typedMatcherLocExp - , quotePat = typedMatcherLocPat - , quoteDec = error "No dec quoter for typedMatcherLoc" - , quoteType = error "No type quoter for typedMatcherLoc" - } +matchNixLoc = + QuasiQuoter + { quoteExp = typedMatcherLocExp, + quotePat = typedMatcherLocPat, + quoteDec = error "No dec quoter for typedMatcherLoc", + quoteType = error "No type quoter for typedMatcherLoc" + } -- | A matcher with the names of the required and optional holes encoded at the -- type level. -newtype TypedMatcher (opts :: [Symbol]) (reqs :: [Symbol]) t - = TypedMatcher {unTypedMatcher :: WithHoles t T.Text} +newtype TypedMatcher (opts :: [Symbol]) (reqs :: [Symbol]) t = TypedMatcher {unTypedMatcher :: WithHoles t VarName} -- | The results of matching with a 'TypedMatcher'. The values in the required -- list are guaranteed to be present. The values in the optional list may be @@ -119,37 +127,37 @@ = TypedMatch [(T.Text, a)] -- | Extract a required key from a match -get - :: forall x opts reqs a - . (Elem "Required" x reqs, KnownSymbol x) - => TypedMatch opts reqs a - -> a +get :: + forall x opts reqs a. + (Elem "Required" x reqs, KnownSymbol x) => + TypedMatch opts reqs a -> + a get (TypedMatch ms) = - fromMaybe (error "Required key not present in TypedMatch") - $ lookup (T.pack (symbolVal (Proxy @x))) ms + fromMaybe (error "Required key not present in TypedMatch") $ + lookup (T.pack (symbolVal (Proxy @x))) ms -- | Maybe extract an optional key from a match -getOptional - :: forall x opts reqs a - . (Elem "Optional" x opts, KnownSymbol x) - => TypedMatch opts reqs a - -> Maybe a +getOptional :: + forall x opts reqs a. + (Elem "Optional" x opts, KnownSymbol x) => + TypedMatch opts reqs a -> + Maybe a getOptional (TypedMatch ms) = lookup (T.pack (symbolVal (Proxy @x))) ms -- | A typed version of 'match' -matchTyped - :: Matchable t - => TypedMatcher opts reqs t - -> Fix t - -> Maybe (TypedMatch opts reqs (Fix t)) +matchTyped :: + Matchable t => + TypedMatcher opts reqs t -> + Fix t -> + Maybe (TypedMatch opts reqs (Fix t)) matchTyped = coerce match -- | A typed version of 'findMatches' -findMatchesTyped - :: Matchable t - => TypedMatcher opts reqs t - -> Fix t - -> [(Fix t, TypedMatch opts reqs (Fix t))] +findMatchesTyped :: + Matchable t => + TypedMatcher opts reqs t -> + Fix t -> + [(Fix t, TypedMatch opts reqs (Fix t))] findMatchesTyped = coerce findMatches typedMatcherExp :: String -> ExpQ @@ -159,10 +167,11 @@ typedMatcherLocExp :: String -> ExpQ typedMatcherLocExp = fmap snd - . typedMatcherGen parseNixTextLoc - collectHolesLoc - addHolesLoc - stripAnnotation + . typedMatcherGen + parseNixTextLoc + collectHolesLoc + addHolesLoc + stripAnnotation typedMatcherPat :: String -> PatQ typedMatcherPat = typedMatcherPatGen parseNixText collectHoles addHoles id @@ -171,48 +180,53 @@ typedMatcherLocPat = typedMatcherPatGen parseNixTextLoc collectHolesLoc addHolesLoc stripAnnotation -typedMatcherPatGen - :: Data a - => (T.Text -> Result t) - -> (t -> ([T.Text], [T.Text])) - -> (t -> a) - -> (t -> NExpr) - -> String - -> Q Pat +typedMatcherPatGen :: + Data a => + (T.Text -> Result t) -> + (t -> ([VarName], [VarName])) -> + (t -> a) -> + (t -> NExpr) -> + String -> + Q Pat typedMatcherPatGen parseNix collect add strip s = do ((opt, req), matcher) <- typedMatcherGen parseNix collect add strip s -- e' <- [|fmap (\x -> $()) . matchTyped $(pure matcher)|] - x <- newName "x" - let pat = tupP (varP . mkName . T.unpack <$> (req <> opt)) - textSymbol = litT . strTyLit . T.unpack - getters = tupE - ( ((\r -> [|get @($r) $(varE x)|]) . textSymbol <$> req) - <> ((\o -> [|getOptional @($o) $(varE x)|]) . textSymbol <$> opt) - ) + x <- newName "x" + let pat = tupP (varP . mkName . T.unpack . unVarName <$> (req <> opt)) + textSymbol = litT . strTyLit . T.unpack . unVarName + getters = + tupE + ( ((\r -> [|get @($r) $(varE x)|]) . textSymbol <$> req) + <> ((\o -> [|getOptional @($o) $(varE x)|]) . textSymbol <$> opt) + ) [p|(fmap (\ $(varP x) -> $getters) . matchTyped $(pure matcher) -> Just $pat)|] -typedMatcherGen - :: Data a - => (T.Text -> Result t) - -> (t -> ([T.Text], [T.Text])) - -> (t -> a) - -> (t -> NExpr) - -> String - -> Q (([T.Text], [T.Text]), Exp) +unVarName :: VarName -> T.Text +unVarName (VarName x) = x + +typedMatcherGen :: + Data a => + (T.Text -> Result t) -> + (t -> ([VarName], [VarName])) -> + (t -> a) -> + (t -> NExpr) -> + String -> + Q (([VarName], [VarName]), Exp) typedMatcherGen parseNix collect add strip s = do expr <- case parseNix (T.pack s) of Left err -> fail $ show err - Right e -> pure e + Right e -> pure e let (opt, req) = collect expr - optT = symbolList opt - reqT = symbolList req - holed = add expr - exprExp = dataToExpQ - ( const Nothing - `extQ` metaExp (freeVars (strip expr)) - `extQ` (Just . liftText) - ) - holed + optT = symbolList opt + reqT = symbolList req + holed = add expr + exprExp = + dataToExpQ + ( const Nothing + `extQ` metaExp (getFreeVars (strip expr)) + `extQ` (Just . liftText) + ) + holed e <- conE 'TypedMatcher `appTypeE` pure optT `appTypeE` pure reqT `appE` exprExp pure ((opt, req), e) @@ -221,33 +235,37 @@ liftText txt = AppE (VarE 'T.pack) <$> liftString (T.unpack txt) -- | Make a list of promoted strings -symbolList :: [T.Text] -> Type -symbolList = foldr - (\n -> (PromotedConsT `AppT` LitT (StrTyLit (T.unpack n)) `AppT`)) - PromotedNilT +symbolList :: [VarName] -> Type +symbolList = + foldr + (\(VarName n) -> (PromotedConsT `AppT` LitT (StrTyLit (T.unpack n)) `AppT`)) + PromotedNilT -- | Collect optional and required holes -collectHoles :: NExpr -> ([T.Text], [T.Text]) -collectHoles = unFix >>> \case - NSynHole n -> ([], [n]) - NSet _ bs -> foldMap (bindingHoles collectHoles) bs - NLet bs e -> collectHoles e <> foldMap (bindingHoles collectHoles) bs - e -> foldMap collectHoles e +collectHoles :: NExpr -> ([VarName], [VarName]) +collectHoles = + unFix >>> \case + NSynHole n -> ([], [n]) + NSet _ bs -> foldMap (bindingHoles collectHoles) bs + NLet bs e -> collectHoles e <> foldMap (bindingHoles collectHoles) bs + e -> foldMap collectHoles e -- | Collect optional and required holes -collectHolesLoc :: NExprLoc -> ([T.Text], [T.Text]) -collectHolesLoc = unFix >>> \case - Compose (Ann _ (NSynHole n)) -> ([], [n]) - Compose (Ann _ (NSet _ bs )) -> foldMap (bindingHoles collectHolesLoc) bs - Compose (Ann _ (NLet bs e)) -> - collectHolesLoc e <> foldMap (bindingHoles collectHolesLoc) bs - e -> foldMap collectHolesLoc e +collectHolesLoc :: NExprLoc -> ([VarName], [VarName]) +collectHolesLoc = + unFix >>> \case + Compose (AnnUnit _ (NSynHole n)) -> ([], [n]) + Compose (AnnUnit _ (NSet _ bs)) -> foldMap (bindingHoles collectHolesLoc) bs + Compose (AnnUnit _ (NLet bs e)) -> + collectHolesLoc e <> foldMap (bindingHoles collectHolesLoc) bs + e -> foldMap collectHolesLoc e -- | Find the optional and required holees in a binding bindingHoles :: (r -> ([a], [a])) -> Binding r -> ([a], [a]) bindingHoles f = \case - b@(NamedVar p _ _) | isJust (isOptionalPath p) -> - let (opt, req) = foldMap f b in (opt <> req, []) + b@(NamedVar p _ _) + | isJust (isOptionalPath p) -> + let (opt, req) = foldMap f b in (opt <> req, []) b -> foldMap f b ---------------------------------------------------------------- @@ -260,4 +278,4 @@ type family Elem n x ys :: Constraint where Elem n x '[] = TypeError ('Text n ':<>: 'Text " key \"" ':<>: 'Text x ':<>: 'Text "\" not found in TypedMatch") - Elem n x (y:ys) = Bool' (Elem n x ys) (() :: Constraint) (x == y) + Elem n x (y : ys) = Bool' (Elem n x ys) (() :: Constraint) (x == y) diff --git a/src/Update/Nix/FetchGit.hs b/src/Update/Nix/FetchGit.hs --- a/src/Update/Nix/FetchGit.hs +++ b/src/Update/Nix/FetchGit.hs @@ -1,34 +1,36 @@ {-# LANGUAGE QuasiQuotes #-} module Update.Nix.FetchGit - ( processFile - , processText - , updatesFromText - ) where + ( processFile, + processText, + updatesFromText, + ) +where -import Control.Monad ( when ) -import Control.Monad.Reader ( MonadReader(ask) ) -import Control.Monad.Validate ( MonadValidate(tolerate) ) -import Data.Fix -import Data.Foldable -import Data.Functor -import Data.Maybe -import Data.Text ( Text - , pack - ) -import qualified Data.Text as T +import Control.Monad (when) +import Control.Monad.Reader (MonadReader (ask)) +import Control.Monad.Validate (MonadValidate (tolerate)) +import Data.Fix +import Data.Foldable +import Data.Functor +import Data.Maybe +import Data.Text + ( Text, + pack, + ) +import qualified Data.Text as T import qualified Data.Text.IO -import Data.Time ( Day ) -import qualified Data.Vector as V -import Nix.Comments -import Nix.Expr -import Nix.Match.Typed -import System.Exit -import Text.Regex.TDFA -import Update.Nix.FetchGit.Types -import Update.Nix.FetchGit.Utils -import Update.Nix.Updater -import Update.Span +import Data.Time (Day) +import qualified Data.Vector as V +import Nix.Comments +import Nix.Expr +import Nix.Match.Typed +import System.Exit +import Text.Regex.TDFA +import Update.Nix.FetchGit.Types +import Update.Nix.FetchGit.Utils +import Update.Nix.Updater +import Update.Span -------------------------------------------------------------------------------- -- Tying it all together @@ -37,7 +39,7 @@ -- | Provided FilePath, update Nix file in-place processFile :: Env -> FilePath -> IO () processFile env filename = do - t <- Data.Text.IO.readFile filename + t <- Data.Text.IO.readFile filename t' <- processText env t -- If updates are needed, write to the file. when (t /= t') $ Data.Text.IO.writeFile filename t' @@ -62,9 +64,9 @@ findUpdates (getComment nixLines) expr us <- evalUpdates =<< filterUpdates tree case us of - [] -> logVerbose "Made no updates" + [] -> logVerbose "Made no updates" [_] -> logVerbose "Made 1 update" - _ -> logVerbose ("Made " <> T.pack (show (length us)) <> " updates") + _ -> logVerbose ("Made " <> T.pack (show (length us)) <> " updates") pure us ---------------------------------------------------------------- @@ -80,27 +82,29 @@ if not (null updateLocations || any (containsPosition e) updateLocations) then pure $ Node Nothing [] else - let - updaters = ($ e) <$> fetchers onlyCommented getComment - bindingTrees = \case - NamedVar p e' _ | Just t <- pathText p -> - (: []) . (Just t, ) <$> findUpdates getComment e' - b -> - traverse (fmap (Nothing, ) . findUpdates getComment) . toList $ b - in - case asum updaters of - Just u -> UpdaterNode <$> u - Nothing -> case e of - [matchNixLoc|{ _version = ^version; }|] | NSet_ _ _ bs <- unFix e -> - Node version . concat <$> traverse bindingTrees bs - [matchNixLoc|let _version = ^version; in ^x|] - | NLet_ _ bs _ <- unFix e -> do - bs' <- concat <$> traverse bindingTrees bs - x' <- findUpdates getComment x - pure $ Node version ((Nothing, x') : bs') - _ -> Node Nothing <$> traverse - (fmap (Nothing, ) . findUpdates getComment) - (toList (unFix e)) + let updaters = ($ e) <$> fetchers onlyCommented getComment + bindingTrees = \case + NamedVar p e' _ + | Just t <- pathText p -> + (: []) . (Just t,) <$> findUpdates getComment e' + b -> + traverse (fmap (Nothing,) . findUpdates getComment) . toList $ b + in case asum updaters of + Just u -> UpdaterNode <$> u + Nothing -> case e of + [matchNixLoc|{ _version = ^version; }|] + | NSetAnnF _ _ bs <- unFix e -> + Node version . concat <$> traverse bindingTrees bs + [matchNixLoc|let _version = ^version; in ^x|] + | NLetAnnF _ bs _ <- unFix e -> do + bs' <- concat <$> traverse bindingTrees bs + x' <- findUpdates getComment x + pure $ Node version ((Nothing, x') : bs') + _ -> + Node Nothing + <$> traverse + (fmap (Nothing,) . findUpdates getComment) + (toList (unFix e)) filterUpdates :: FetchTree -> M FetchTree filterUpdates t = do @@ -111,37 +115,38 @@ -- If we reach a leaf, return empty because it hasn't been included by a -- binding yet let go = \case - Node v cs -> Node - v - [ (n, c') - | (n, c) <- cs - , let c' = if maybe False matches n then c else go c - ] + Node v cs -> + Node + v + [ (n, c') + | (n, c) <- cs, + let c' = if maybe False matches n then c else go c + ] UpdaterNode _ -> Node Nothing [] -- If there are no patterns, don't do any filtering pure $ if null attrPatterns then t else go t - evalUpdates :: FetchTree -> M [SpanUpdate] evalUpdates = fmap snd . go - where - go :: FetchTree -> M (Maybe Day, [SpanUpdate]) - go = \case - UpdaterNode (Updater u) -> u - Node versionExpr cs -> do - -- Run over all children - (ds, ss) <- unzip . catMaybes <$> traverse (tolerate . go . snd) cs - -- Update version string with the maximum of versions in the children - let latestDate = maximumMay (catMaybes ds) - pure - ( latestDate - , [ SpanUpdate (exprSpan v) - (quoteString . ("unstable-" <>) . pack . show $ d) - | Just d <- pure latestDate - , Just v <- pure versionExpr - ] - <> concat ss - ) + where + go :: FetchTree -> M (Maybe Day, [SpanUpdate]) + go = \case + UpdaterNode (Updater u) -> u + Node versionExpr cs -> do + -- Run over all children + (ds, ss) <- unzip . catMaybes <$> traverse (tolerate . go . snd) cs + -- Update version string with the maximum of versions in the children + let latestDate = maximumMay (catMaybes ds) + pure + ( latestDate, + [ SpanUpdate + (exprSpan v) + (quoteString . ("unstable-" <>) . pack . show $ d) + | Just d <- pure latestDate, + Just v <- pure versionExpr + ] + <> concat ss + ) ---------------------------------------------------------------- -- Utils diff --git a/src/Update/Nix/FetchGit/Prefetch.hs b/src/Update/Nix/FetchGit/Prefetch.hs --- a/src/Update/Nix/FetchGit/Prefetch.hs +++ b/src/Update/Nix/FetchGit/Prefetch.hs @@ -141,11 +141,11 @@ pure $ ref .: "commit" .: "committer" .: "date" fromEither $ parseISO8601DateToDay dateString -ghState :: GitHubState -ghState = GitHubState { token = Nothing - , userAgent = "expipiplus1/update-nix-fetchgit" - , apiVersion = "v3" - } +ghState :: GitHubSettings +ghState = GitHubSettings { token = Nothing + , userAgent = "expipiplus1/update-nix-fetchgit" + , apiVersion = "v3" + } ---------------------------------------------------------------- -- Utils diff --git a/src/Update/Nix/FetchGit/Utils.hs b/src/Update/Nix/FetchGit/Utils.hs --- a/src/Update/Nix/FetchGit/Utils.hs +++ b/src/Update/Nix/FetchGit/Utils.hs @@ -1,59 +1,64 @@ - 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 + ( 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 ( parseNixFileLoc - , parseNixTextLoc - ) -import Update.Nix.FetchGit.Types -import Update.Nix.FetchGit.Warning -import Update.Span +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 + ( parseNixFileLoc, + parseNixTextLoc, + ) +import Nix.Utils (Path (..)) +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 + Right expr -> pure expr ourParseNixFile :: FilePath -> M NExprLoc -ourParseNixFile f = liftIO (parseNixFileLoc f) >>= \case - Left parseError -> refute1 (CouldNotParseInput (tShow parseError)) - Right expr -> pure expr +ourParseNixFile f = + liftIO (parseNixFileLoc (Path 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. @@ -65,7 +70,7 @@ prettyRepoLocation :: RepoLocation -> Text prettyRepoLocation = \case - URL u -> u + URL u -> u GitHub o r -> o <> "/" <> r GitLab o r -> o <> "/" <> r @@ -80,57 +85,57 @@ -- TODO: Use 'evalExpr' here exprText :: NExprLoc -> Either Warning Text exprText = \case - (AnnE _ (NStr (DoubleQuoted [Plain t]))) -> pure t + (Ann _ (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) + (Ann _ (NConstant (NBool b))) -> pure b + e -> Left (NotABool e) -- | Get the 'SrcSpan' covering a particular expression. exprSpan :: NExprLoc -> SrcSpan -exprSpan (AnnE s _) = s +exprSpan (Ann s _) = s -- | 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 :: NExprLoc -> Maybe VarName +extractFuncName (Ann _ (NSym name)) = Just name +extractFuncName (Ann _ (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 - + where + e :: NKeyName r -> Maybe Text + e = \case + StaticKey (VarName 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) + in maybe + (Left $ InvalidDateString t) + Right + (parseTimeM False defaultTimeLocale "%Y-%m-%d" justDate) formatWarning :: Warning -> Text formatWarning (CouldNotParseInput doc) = doc @@ -179,9 +184,9 @@ ---------------------------------------------------------------- containsPosition :: NExprLoc -> (Int, Int) -> Bool -containsPosition (Fix (Compose (Ann (SrcSpan begin end) _))) p = +containsPosition (Fix (Compose (AnnUnit (SrcSpan begin end) _))) p = let unSourcePos (SourcePos _ l c) = (unPos l, unPos c) - in p >= unSourcePos begin && p < unSourcePos end + in p >= unSourcePos begin && p < unSourcePos end ---------------------------------------------------------------- -- Errors @@ -189,7 +194,7 @@ fromEither :: Either Warning a -> M a fromEither = \case - Left e -> refute1 e + Left e -> refute1 e Right a -> pure a note :: Warning -> Maybe a -> M a @@ -206,7 +211,7 @@ logVerbose :: Text -> M () logVerbose t = do - Env{..} <- ask + Env {..} <- ask liftIO $ sayLog Verbose t logNormal :: Text -> M () diff --git a/src/Update/Span.hs b/src/Update/Span.hs --- a/src/Update/Span.hs +++ b/src/Update/Span.hs @@ -14,38 +14,46 @@ , split ) where -import Control.Exception (assert) -import Data.Data (Data) -import Data.Int (Int64) -import Data.List (genericTake, sortOn) -import Data.Text (Text, length, lines, splitAt) -import Prelude hiding (length, lines, splitAt) -import Nix.Expr.Types.Annotated +import Control.Exception ( assert ) +import Data.Data ( Data ) +import Data.Int ( Int64 ) +import Data.List ( genericTake + , sortOn + ) +import Data.Text ( Text + , length + , lines + , splitAt + ) +import Nix.Expr.Types.Annotated +import Prelude hiding ( length + , lines + , splitAt + ) -- | A span and some text to replace it with. -- They don't have to be the same length. -data SpanUpdate = SpanUpdate{ spanUpdateSpan :: SrcSpan - , spanUpdateContents :: Text - } +data SpanUpdate = SpanUpdate + { spanUpdateSpan :: SrcSpan + , spanUpdateContents :: Text + } deriving (Show, Data) -- | Update many spans in a file. They must be non-overlapping. updateSpans :: [SpanUpdate] -> Text -> Text updateSpans us t = let sortedSpans = sortOn (spanBegin . spanUpdateSpan) us - anyOverlap = any (uncurry overlaps) - (zip <*> tail $ spanUpdateSpan <$> sortedSpans) - in - assert (not anyOverlap) - (foldr updateSpan t sortedSpans) + anyOverlap = + any (uncurry overlaps) (zip <*> tail $ spanUpdateSpan <$> sortedSpans) + in assert (not anyOverlap) (foldr updateSpan t sortedSpans) -- | Update a single span of characters inside a text value. If you're updating -- multiples spans it's best to use 'updateSpans'. updateSpan :: SpanUpdate -> Text -> Text updateSpan (SpanUpdate (SrcSpan b e) r) t = - let (before, _) = split b t - (_, end) = split e t - in before <> r <> end + let (before, _ ) = split b t + (_ , end) = split e t + in before <> r <> end -- | Do two spans overlap overlaps :: SrcSpan -> SrcSpan -> Bool @@ -56,7 +64,10 @@ split :: SourcePos -> Text -> (Text, Text) split (SourcePos _ row col) t = splitAt (fromIntegral - (linearizeSourcePos t (fromIntegral (unPos row - 1)) (fromIntegral (unPos col - 1))) + (linearizeSourcePos t + (fromIntegral (unPos row - 1)) + (fromIntegral (unPos col - 1)) + ) ) t @@ -64,13 +75,15 @@ -- the beginning of the text. -- -- This probably fails on crazy texts with multi character line breaks. -linearizeSourcePos :: Text -- ^ The string to linearize in - -> Int64 -- ^ The line offset - -> Int64 -- ^ The column offset - -> Int64 -- ^ The character offset +linearizeSourcePos + :: Text -- ^ The string to linearize in + -> Int64 -- ^ The line offset + -> Int64 -- ^ The column offset + -> Int64 -- ^ The character offset linearizeSourcePos t l c = fromIntegral lineCharOffset + c - where lineCharOffset = sum . fmap ((+1) . length) . genericTake l . lines $ t + where + lineCharOffset = sum . fmap ((+ 1) . length) . genericTake l . lines $ t prettyPrintSourcePos :: SourcePos -> String prettyPrintSourcePos (SourcePos _ row column) = - "line " <> show row <> " column " <> show column + show (unPos row) <> ":" <> show (unPos column) diff --git a/tests/Samples.hs b/tests/Samples.hs --- a/tests/Samples.hs +++ b/tests/Samples.hs @@ -42,24 +42,25 @@ inBase = System.FilePath.takeBaseName inFile System.Directory.copyFile inFile (dir inBase) - - System.Directory.copyFile "tests/fakeRepo.sh" (dir "fakeRepo.sh") + testScript <- System.Directory.makeAbsolute "tests/fakeRepo.sh" - _ <- System.Process.readCreateProcess - ((System.Process.shell (dir "fakeRepo.sh")) { System.Process.cwd = Just dir }) - mempty + _ <- System.Process.waitForProcess =<< System.Process.runProcess + "bash" + [testScript] (Just dir) + Nothing + Nothing Nothing Nothing replaceFile (dir inBase) "/tmp/nix-update-fetchgit-test" (Data.Text.pack dir) System.Environment.setEnv "NIX_STATE_DIR" $ storeDir "state" - System.Environment.setEnv "NIX_STORE_DIR" $ storeDir + System.Environment.setEnv "NIX_STORE_DIR" storeDir -- work around race condition https://github.com/NixOS/nix/issues/2706 System.Directory.createDirectoryIfMissing True $ storeDir "state/gcroots" -- and another - error: SQLite database storeDir 'state/db/db.sqlite' is busy _ <- System.Process.readCreateProcess - (System.Process.shell ("nix-store --init")) + (System.Process.shell "nix-store --init") mempty let env = Env (const (Data.Text.IO.hPutStrLn System.IO.stderr)) [] [] Wet False diff --git a/tests/fakeRepo.sh b/tests/fakeRepo.sh --- a/tests/fakeRepo.sh +++ b/tests/fakeRepo.sh @@ -1,9 +1,9 @@ -#!/bin/sh +#!/usr/bin/env bash # Prepares git repositories on the local machine that we will use for # testing. -set -ex +set -e # Make sure the commit hashes are predictable. export GIT_AUTHOR_DATE='1466974421 +0200' @@ -15,7 +15,7 @@ export XDG_CONFIG_DIRS= export HOME= -git init repo1 +git init repo1 --initial-branch=main cd repo1 echo hi > test.txt git add test.txt @@ -31,7 +31,7 @@ export GIT_AUTHOR_DATE='1468031426 -0700' export GIT_COMMITTER_DATE='1468031426 -0700' -git init repo2 +git init repo2 --initial-branch=main cd repo2 echo hi > test.txt git add test.txt diff --git a/update-nix-fetchgit.cabal b/update-nix-fetchgit.cabal --- a/update-nix-fetchgit.cabal +++ b/update-nix-fetchgit.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.34.7. -- -- see: https://github.com/sol/hpack name: update-nix-fetchgit -version: 0.2.9 +version: 0.2.11 synopsis: A program to update fetchgit values in Nix expressions description: This command-line utility is meant to be used by people maintaining Nix expressions that fetch files from Git repositories. It automates the process @@ -13,9 +13,9 @@ category: Nix homepage: https://github.com/expipiplus1/update-nix-fetchgit#readme bug-reports: https://github.com/expipiplus1/update-nix-fetchgit/issues -author: Joe Hermaszewski -maintainer: Joe Hermaszewski -copyright: 2020 Joe Hermaszewski +author: Ellie Hermaszewska +maintainer: Ellie Hermaszewska +copyright: 2020 Ellie Hermaszewska license: BSD3 license-file: LICENSE build-type: Simple @@ -107,8 +107,8 @@ , base >=4.7 && <5 , bytestring >=0.10 , data-fix - , github-rest - , hnix >=0.13.1 + , github-rest >=1.1 + , hnix ==0.16.* , monad-validate , mtl , process >=1.2 @@ -195,8 +195,6 @@ TypeOperators ViewPatterns ghc-options: -Wall - build-tool-depends: - tasty-discover:tasty-discover build-depends: base >=4.7 && <5 , directory