From d1ada448174066347b724b8e26155c441fe541c2 Mon Sep 17 00:00:00 2001 From: John Wiegley Date: Mon, 18 Mar 2019 21:47:43 -0700 Subject: [PATCH] Run brittany --- main/Main.hs | 22 +++++----- src/Nix.hs | 2 +- src/Nix/Convert.hs | 31 ++++++-------- src/Nix/Eval.hs | 5 +-- src/Nix/Exec.hs | 87 +++++++++++++++++++++++---------------- src/Nix/Json.hs | 3 +- src/Nix/Lint.hs | 21 +++++++--- src/Nix/Normal.hs | 29 ++++++------- src/Nix/Pretty.hs | 7 ++-- src/Nix/Render/Frame.hs | 16 ++----- src/Nix/Thunk/Basic.hs | 8 ++-- src/Nix/Thunk/Standard.hs | 4 +- src/Nix/Type/Infer.hs | 6 ++- src/Nix/Utils.hs | 19 ++++----- src/Nix/Value/Equal.hs | 11 ++--- src/Nix/XML.hs | 12 +++--- 16 files changed, 144 insertions(+), 139 deletions(-) diff --git a/main/Main.hs b/main/Main.hs index 34b8556..4153d67 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -158,18 +158,16 @@ main = do findAttrs = go "" where go prefix s = do - xs <- - forM (sortOn fst (M.toList s)) - $ \(k, nv) -> case nv of - Free v -> pure (k, Just (Free v)) - Pure (StdThunk (extract -> Thunk _ _ ref)) -> do - let path = prefix ++ Text.unpack k - (_, descend) = filterEntry path k - val <- readVar @(StandardT IO) ref - case val of - Computed _ -> pure (k, Nothing) - _ | descend -> (k, ) <$> forceEntry path nv - | otherwise -> pure (k, Nothing) + xs <- forM (sortOn fst (M.toList s)) $ \(k, nv) -> case nv of + Free v -> pure (k, Just (Free v)) + Pure (StdThunk (extract -> Thunk _ _ ref)) -> do + let path = prefix ++ Text.unpack k + (_, descend) = filterEntry path k + val <- readVar @(StandardT IO) ref + case val of + Computed _ -> pure (k, Nothing) + _ | descend -> (k, ) <$> forceEntry path nv + | otherwise -> pure (k, Nothing) forM_ xs $ \(k, mv) -> do let path = prefix ++ Text.unpack k diff --git a/src/Nix.hs b/src/Nix.hs index bb3ebb6..b3468e4 100644 --- a/src/Nix.hs +++ b/src/Nix.hs @@ -135,7 +135,7 @@ processResult processResult h val = do opts :: Options <- asks (view hasLens) case attr opts of - Nothing -> h val + Nothing -> h val Just (Text.splitOn "." -> keys) -> go keys val where go :: [Text.Text] -> NValue t f m -> m a diff --git a/src/Nix/Convert.hs b/src/Nix/Convert.hs index bb9973a..eff67c7 100644 --- a/src/Nix/Convert.hs +++ b/src/Nix/Convert.hs @@ -75,10 +75,7 @@ class FromValue a m v where fromValueMay :: v -> m (Maybe a) type Convertible e t f m - = ( Framed e m - , MonadDataErrorContext t f m - , MonadThunk t m (NValue t f m) - ) + = (Framed e m, MonadDataErrorContext t f m, MonadThunk t m (NValue t f m)) instance ( Convertible e t f m , MonadValue (NValueNF t f m) m @@ -86,7 +83,7 @@ instance ( Convertible e t f m ) => FromValue a m (NValueNF t f m) where fromValueMay (Fix v) = fromValueMay v - fromValue (Fix v) = fromValue v + fromValue (Fix v) = fromValue v instance ( Convertible e t f m , MonadValue (NValue t f m) m @@ -96,7 +93,7 @@ instance ( Convertible e t f m fromValueMay = flip demand $ \case Pure t -> force t fromValueMay Free v -> fromValueMay v - fromValue = flip demand $ \case + fromValue = flip demand $ \case Pure t -> force t fromValue Free v -> fromValue v @@ -106,7 +103,7 @@ instance ( Convertible e t f m ) => FromValue a m (Deeper (NValueNF t f m)) where fromValueMay (Deeper (Fix v)) = fromValueMay (Deeper v) - fromValue (Deeper (Fix v)) = fromValue (Deeper v) + fromValue (Deeper (Fix v)) = fromValue (Deeper v) instance ( Convertible e t f m , MonadValue (NValue t f m) m @@ -116,7 +113,7 @@ instance ( Convertible e t f m fromValueMay (Deeper v) = demand v $ \case Pure t -> force t (fromValueMay . Deeper) Free v -> fromValueMay (Deeper v) - fromValue (Deeper v) = demand v $ \case + fromValue (Deeper v) = demand v $ \case Pure t -> force t (fromValue . Deeper) Free v -> fromValue (Deeper v) @@ -196,7 +193,7 @@ instance (Convertible e t f m _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b - _ -> throwError $ Expectation @t @f @m (TString NoContext) (embedValue v) + _ -> throwError $ Expectation @t @f @m (TString NoContext) (embedValue v) instance ( Convertible e t f m , EmbedValue t f m r @@ -204,10 +201,10 @@ instance ( Convertible e t f m => FromValue ByteString m (NValue' t f m r) where fromValueMay = \case NVStr' ns -> pure $ encodeUtf8 <$> hackyGetStringNoContext ns - _ -> pure Nothing + _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b - _ -> throwError $ Expectation @t @f @m (TString NoContext) (embedValue v) + _ -> throwError $ Expectation @t @f @m (TString NoContext) (embedValue v) newtype Path = Path { getPath :: FilePath } deriving Show @@ -291,7 +288,7 @@ instance ( Convertible e t f m ) => FromValue (AttrSet a, AttrSet SourcePos) m (Deeper (NValue' t f m r)) where fromValueMay = \case - Deeper (NVSet' s p) -> fmap (,p) <$> sequence <$> traverse fromValueMay s + Deeper (NVSet' s p) -> fmap (, p) <$> sequence <$> traverse fromValueMay s _ -> pure Nothing fromValue v = fromValueMay v >>= \case Just b -> pure b @@ -368,11 +365,7 @@ instance ( Convertible e t f m f' <- toValue (principledMakeNixStringWithoutContext (Text.pack f)) l' <- toValue (unPos l) c' <- toValue (unPos c) - let pos = M.fromList - [ ("file" :: Text, f') - , ("line" , l') - , ("column" , c') - ] + let pos = M.fromList [("file" :: Text, f'), ("line", l'), ("column", c')] pure $ nvSet' pos mempty -- | With 'ToValue', we can always act recursively @@ -420,9 +413,9 @@ instance ( MonadValue (NValue t f m) m [] -> return Nothing _ -> Just <$> toValue ts pure $ flip nvSet' M.empty $ M.fromList $ catMaybes - [ (\p -> ("path", p)) <$> path + [ (\p -> ("path", p)) <$> path , (\ao -> ("allOutputs", ao)) <$> allOutputs - , (\os -> ("outputs", os)) <$> outputs + , (\os -> ("outputs", os)) <$> outputs ] instance Convertible e t f m => ToValue () m (NExprF r) where diff --git a/src/Nix/Eval.hs b/src/Nix/Eval.hs index ab0919c..6b6e5a8 100644 --- a/src/Nix/Eval.hs +++ b/src/Nix/Eval.hs @@ -212,10 +212,7 @@ attrSetAlter (k : ks) pos m p val = case M.lookup k m of recurse st sp = attrSetAlter ks pos st sp val <&> \(st', _) -> ( M.insert k - ( toValue @(AttrSet v, AttrSet SourcePos) - =<< (, mempty) - <$> sequence st' - ) + (toValue @(AttrSet v, AttrSet SourcePos) =<< (, mempty) <$> sequence st') st , M.insert k pos sp ) diff --git a/src/Nix/Exec.hs b/src/Nix/Exec.hs index 89f8cfb..3d4a2bc 100644 --- a/src/Nix/Exec.hs +++ b/src/Nix/Exec.hs @@ -88,9 +88,9 @@ import GHC.DataSize type MonadCited t f m = ( HasCitations m (NValue t f m) t - , HasCitations1 m (NValue t f m) f - , MonadDataContext f m - ) + , HasCitations1 m (NValue t f m) f + , MonadDataContext f m + ) nvConstantP :: MonadCited t f m => Provenance m (NValue t f m) -> NAtom -> NValue t f m @@ -104,14 +104,14 @@ nvStrP nvStrP p ns = addProvenance p (nvStr ns) nvPathP - :: MonadCited t f m - => Provenance m (NValue t f m) - -> FilePath - -> NValue t f m + :: MonadCited t f m => Provenance m (NValue t f m) -> FilePath -> NValue t f m nvPathP p x = addProvenance p (nvPath x) -nvListP :: MonadCited t f m - => Provenance m (NValue t f m) -> [NValue t f m] -> NValue t f m +nvListP + :: MonadCited t f m + => Provenance m (NValue t f m) + -> [NValue t f m] + -> NValue t f m nvListP p l = addProvenance p (nvList l) nvSetP @@ -299,10 +299,9 @@ instance MonadNix e t f m => MonadEval (NValue t f m) m where evalAbs p k = do scope <- currentScopes span <- currentPos - pure $ nvClosureP - (Provenance scope (NAbs_ span (Nothing <$ p) Nothing)) - (void p) - (\arg -> snd <$> k (pure arg) (\_ b -> ((), ) <$> b)) + pure $ nvClosureP (Provenance scope (NAbs_ span (Nothing <$ p) Nothing)) + (void p) + (\arg -> snd <$> k (pure arg) (\_ b -> ((), ) <$> b)) evalError = throwError @@ -706,18 +705,27 @@ instance ( MonadFix m Lazy $ ReaderT $ const $ modify (M.insert path expr) pure expr - derivationStrict = fromValue @(AttrSet (NValue t f (Lazy t f m))) >=> \s -> do - nn <- maybe (pure False) (demand ?? fromValue) (M.lookup "__ignoreNulls" s) - s' <- M.fromList <$> mapMaybeM (handleEntry nn) (M.toList s) - v' <- normalForm =<< toValue @(AttrSet (NValue t f (Lazy t f m))) @_ @(NValue t f (Lazy t f m)) s' - nixInstantiateExpr $ "derivationStrict " ++ show (prettyNValueNF v') + derivationStrict = fromValue @(AttrSet (NValue t f (Lazy t f m))) >=> \s -> + do + nn <- maybe (pure False) + (demand ?? fromValue) + (M.lookup "__ignoreNulls" s) + s' <- M.fromList <$> mapMaybeM (handleEntry nn) (M.toList s) + v' <- + normalForm + =<< toValue @(AttrSet (NValue t f (Lazy t f m))) @_ + @(NValue t f (Lazy t f m)) + s' + nixInstantiateExpr $ "derivationStrict " ++ show (prettyNValueNF v') where mapMaybeM :: (a -> Lazy t f m (Maybe b)) -> [a] -> Lazy t f m [b] mapMaybeM op = foldr f (return []) where f x xs = op x >>= (<$> xs) . (++) . maybeToList - handleEntry :: Bool -> (Text, NValue t f (Lazy t f m)) - -> Lazy t f m (Maybe (Text, NValue t f (Lazy t f m))) + handleEntry + :: Bool + -> (Text, NValue t f (Lazy t f m)) + -> Lazy t f m (Maybe (Text, NValue t f (Lazy t f m))) handleEntry ignoreNulls (k, v) = fmap (k, ) <$> case k of -- The `args' attribute is special: it supplies the command-line -- arguments to the builder. @@ -729,10 +737,12 @@ instance ( MonadFix m NVConstant NNull | ignoreNulls -> pure Nothing v' -> Just <$> coerceNix v' where - coerceNix :: NValue t f (Lazy t f m) -> Lazy t f m (NValue t f (Lazy t f m)) + coerceNix + :: NValue t f (Lazy t f m) -> Lazy t f m (NValue t f (Lazy t f m)) coerceNix = toValue <=< coerceToString CopyToStore CoerceAny - coerceNixList :: NValue t f (Lazy t f m) -> Lazy t f m (NValue t f (Lazy t f m)) + coerceNixList + :: NValue t f (Lazy t f m) -> Lazy t f m (NValue t f (Lazy t f m)) coerceNixList v = do xs <- fromValue @[NValue t f (Lazy t f m)] v ys <- traverse (\x -> demand x coerceNix) xs @@ -798,17 +808,18 @@ findPathBy finder l name = do where go :: Maybe FilePath -> NValue t f m -> m (Maybe FilePath) go p@(Just _) _ = pure p - go Nothing l = demand l $ fromValue >=> \(s :: HashMap Text (NValue t f m)) -> do - p <- resolvePath s - demand p $ fromValue >=> \(Path path) -> case M.lookup "prefix" s of - Nothing -> tryPath path Nothing - Just pf -> demand pf $ fromValueMay >=> \case - Just (nsPfx :: NixString) -> - let pfx = hackyStringIgnoreContext nsPfx - in if not (Text.null pfx) - then tryPath path (Just (Text.unpack pfx)) - else tryPath path Nothing - _ -> tryPath path Nothing + go Nothing l = + demand l $ fromValue >=> \(s :: HashMap Text (NValue t f m)) -> do + p <- resolvePath s + demand p $ fromValue >=> \(Path path) -> case M.lookup "prefix" s of + Nothing -> tryPath path Nothing + Just pf -> demand pf $ fromValueMay >=> \case + Just (nsPfx :: NixString) -> + let pfx = hackyStringIgnoreContext nsPfx + in if not (Text.null pfx) + then tryPath path (Just (Text.unpack pfx)) + else tryPath path Nothing + _ -> tryPath path Nothing tryPath p (Just n) | n' : ns <- splitDirectories name, n == n' = finder $ p joinPath ns @@ -825,8 +836,12 @@ findPathBy finder l name = do ++ " with 'path' elements, but saw: " ++ show s -findPathM :: forall e t f m . MonadNix e t f m - => [NValue t f m] -> FilePath -> m FilePath +findPathM + :: forall e t f m + . MonadNix e t f m + => [NValue t f m] + -> FilePath + -> m FilePath findPathM l name = findPathBy path l name where path :: MonadEffects t f m => FilePath -> m (Maybe FilePath) @@ -840,7 +855,7 @@ findEnvPathM name = do mres <- lookupVar "__nixPath" case mres of Nothing -> error "impossible" - Just x -> demand x $ fromValue >=> \(l :: [NValue t f m]) -> + Just x -> demand x $ fromValue >=> \(l :: [NValue t f m]) -> findPathBy nixFilePath l name where nixFilePath :: MonadEffects t f m => FilePath -> m (Maybe FilePath) diff --git a/src/Nix/Json.hs b/src/Nix/Json.hs index 29f407b..25e0b01 100644 --- a/src/Nix/Json.hs +++ b/src/Nix/Json.hs @@ -46,7 +46,8 @@ nvalueToJSON = \case <$> traverse (join . lift . flip demand (return . nvalueToJSON)) l NVSet m _ -> case HM.lookup "outPath" m of Nothing -> - A.Object <$> traverse (join . lift . flip demand (return . nvalueToJSON)) m + A.Object + <$> traverse (join . lift . flip demand (return . nvalueToJSON)) m Just outPath -> join $ lift $ demand outPath (return . nvalueToJSON) NVPath p -> do fp <- lift $ unStorePath <$> addPath p diff --git a/src/Nix/Lint.hs b/src/Nix/Lint.hs index 5ce0c11..9791417 100644 --- a/src/Nix/Lint.hs +++ b/src/Nix/Lint.hs @@ -112,16 +112,23 @@ everyPossible = packSymbolic NAny mkSymbolic :: MonadVar m => [NTypeF m (Symbolic m)] -> m (Symbolic m) mkSymbolic xs = packSymbolic (NMany xs) -packSymbolic :: MonadVar m - => NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m) +packSymbolic + :: MonadVar m => NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m) packSymbolic = fmap SV . newVar -unpackSymbolic :: (MonadVar m, MonadThunkId m, MonadCatch m) - => Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m))) +unpackSymbolic + :: (MonadVar m, MonadThunkId m, MonadCatch m) + => Symbolic m + -> m (NSymbolicF (NTypeF m (Symbolic m))) unpackSymbolic = flip demand $ readVar . getSV type MonadLint e m - = (Scoped (Symbolic m) m, Framed e m, MonadVar m, MonadCatch m, MonadThunkId m) + = ( Scoped (Symbolic m) m + , Framed e m + , MonadVar m + , MonadCatch m + , MonadThunkId m + ) symerr :: forall e m a . MonadLint e m => String -> m a symerr = evalError @(Symbolic m) . ErrorCall @@ -164,7 +171,9 @@ merge merge context = go where go - :: [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)] + :: [NTypeF m (Symbolic m)] + -> [NTypeF m (Symbolic m)] + -> m [NTypeF m (Symbolic m)] go [] _ = return [] go _ [] = return [] go (x : xs) (y : ys) = case (x, y) of diff --git a/src/Nix/Normal.hs b/src/Nix/Normal.hs index a34cfbb..b9b05a0 100644 --- a/src/Nix/Normal.hs +++ b/src/Nix/Normal.hs @@ -75,20 +75,21 @@ normalize f = run . iterNValueM run go (fmap Free . sequenceNValue' run) stubCycles :: forall t f m - . ( Applicative f - , Functor m - , HasCitations m (NValue t f m) t - , HasCitations1 m (NValue t f m) f - ) - => NValue t f m -> NValueNF t f m -stubCycles = freeToFix $ \t -> Fix - $ NValue - $ Prelude.foldr (addProvenance1 @m @(NValue t f m)) cyc - $ reverse - $ citations @m @(NValue t f m) t - where - Fix (NValue cyc) = - nvStrNF (principledMakeNixStringWithoutContext "") + . ( Applicative f + , Functor m + , HasCitations m (NValue t f m) t + , HasCitations1 m (NValue t f m) f + ) + => NValue t f m + -> NValueNF t f m +stubCycles = freeToFix $ \t -> + Fix + $ NValue + $ Prelude.foldr (addProvenance1 @m @(NValue t f m)) cyc + $ reverse + $ citations @m @(NValue t f m) t + where + Fix (NValue cyc) = nvStrNF (principledMakeNixStringWithoutContext "") normalForm :: ( Framed e m diff --git a/src/Nix/Pretty.hs b/src/Nix/Pretty.hs index a36777f..f8d7438 100644 --- a/src/Nix/Pretty.hs +++ b/src/Nix/Pretty.hs @@ -339,11 +339,12 @@ valueToExpr = iterNValueNF phi phi (NVClosure' _ _ ) = Fix . NSym . pack $ "" phi (NVPath' p ) = Fix $ NLiteralPath p phi (NVBuiltin' name _) = Fix . NSym . pack $ "builtins." ++ name - phi _ = error "Pattern synonyms foil completeness check" + phi _ = error "Pattern synonyms foil completeness check" mkStr ns = Fix $ NStr $ DoubleQuoted [Plain (hackyStringIgnoreContext ns)] -prettyNValueNF :: forall t f m ann. MonadDataContext f m => NValueNF t f m -> Doc ann +prettyNValueNF + :: forall t f m ann . MonadDataContext f m => NValueNF t f m -> Doc ann prettyNValueNF = prettyNix . valueToExpr -- | This function is used only by the testing code. @@ -371,7 +372,7 @@ printNix = iterNValueNF phi phi NVClosure'{} = "<>" phi (NVPath' fp ) = fp phi (NVBuiltin' name _) = "<>" - phi _ = error "Pattern synonyms foil completeness check" + phi _ = error "Pattern synonyms foil completeness check" prettyNValue :: (MonadThunk t m (NValue t f m), MonadDataContext f m) diff --git a/src/Nix/Render/Frame.hs b/src/Nix/Render/Frame.hs index bbf9b9c..3a8155a 100644 --- a/src/Nix/Render/Frame.hs +++ b/src/Nix/Render/Frame.hs @@ -159,16 +159,12 @@ renderExpr _level longLabel shortLabel e@(Fix (Compose (Ann _ x))) = do renderValueFrame :: forall e t f m ann - . ( MonadReader e m - , Has e Options - , MonadFile m - , MonadCitedThunks t f m - ) + . (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m) => NixLevel -> ValueFrame t f m -> m [Doc ann] renderValueFrame level = fmap (: []) . \case - ForcingThunk _t -> pure "ForcingThunk" -- jww (2019-03-18): NYI + ForcingThunk _t -> pure "ForcingThunk" -- jww (2019-03-18): NYI ConcerningValue _v -> pure "ConcerningValue" Comparison _ _ -> pure "Comparing" Addition _ _ -> pure "Adding" @@ -185,7 +181,7 @@ renderValueFrame level = fmap (: []) . \case v' <- renderValue level "" "" v pure $ "CoercionToJson " <> v' CoercionFromJson _j -> pure "CoercionFromJson" - Expectation t r -> case getEitherOr r of + Expectation t r -> case getEitherOr r of Left nf -> do let v' = prettyNValueNF @t @f @m nf pure $ "Saw " <> v' <> " but expected " <> pretty (describeValue t) @@ -195,11 +191,7 @@ renderValueFrame level = fmap (: []) . \case renderValue :: forall e t f m ann - . ( MonadReader e m - , Has e Options - , MonadFile m - , MonadCitedThunks t f m - ) + . (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m) => NixLevel -> String -> String diff --git a/src/Nix/Thunk/Basic.hs b/src/Nix/Thunk/Basic.hs index bb044bb..df3671b 100644 --- a/src/Nix/Thunk/Basic.hs +++ b/src/Nix/Thunk/Basic.hs @@ -39,11 +39,11 @@ type MonadBasicThunk m = (MonadThunkId m, MonadVar m) instance (MonadBasicThunk m, MonadCatch m) => MonadThunk (NThunkF m v) m v where - thunk = buildThunk + thunk = buildThunk thunkId (Thunk n _ _) = n - queryM = queryThunk - force = forceThunk - forceEff = forceEffects + queryM = queryThunk + force = forceThunk + forceEff = forceEffects buildThunk :: MonadBasicThunk m => m v -> m (NThunkF m v) buildThunk action = do diff --git a/src/Nix/Thunk/Standard.hs b/src/Nix/Thunk/Standard.hs index 453b2cb..8cb9235 100644 --- a/src/Nix/Thunk/Standard.hs +++ b/src/Nix/Thunk/Standard.hs @@ -78,8 +78,8 @@ instance ( MonadStdThunk (u m) thunk = fmap (StdThunk . StdCited) . thunk thunkId = thunkId . _stdCited . _stdThunk queryM x b f = queryM (_stdCited (_stdThunk x)) b f - force = force . _stdCited . _stdThunk - forceEff = forceEff . _stdCited . _stdThunk + force = force . _stdCited . _stdThunk + forceEff = forceEff . _stdCited . _stdThunk -- query x b f = query (_stdCited (_stdThunk x)) b f -- wrapValue = StdThunk . StdCited . wrapValue -- getValue = getValue . _stdCited . _stdThunk diff --git a/src/Nix/Type/Infer.hs b/src/Nix/Type/Infer.hs index 85034c8..3dddb50 100644 --- a/src/Nix/Type/Infer.hs +++ b/src/Nix/Type/Infer.hs @@ -403,10 +403,12 @@ instance Monad m => MonadCatch (InferT s m) where (fromException (toException e)) err -> error $ "Unexpected error: " ++ show err -type MonadInfer m = ({- MonadThunkId m,-} MonadVar m, MonadFix m) +type MonadInfer m + = ({- MonadThunkId m,-} + MonadVar m, MonadFix m) instance MonadValue (Judgment s) (InferT s m) where - defer = id + defer = id demand = flip ($) {- diff --git a/src/Nix/Utils.hs b/src/Nix/Utils.hs index d72d62b..fd8ccb0 100644 --- a/src/Nix/Utils.hs +++ b/src/Nix/Utils.hs @@ -95,23 +95,20 @@ transport :: Functor g => (forall x . f x -> g x) -> Fix f -> Fix g transport f (Fix x) = Fix $ fmap (transport f) (f x) lifted - :: ( MonadTransControl u - , Monad (u m) - , Monad m - ) - => ((a -> m (StT u b)) -> m (StT u b)) -> (a -> u m b) -> u m b + :: (MonadTransControl u, Monad (u m), Monad m) + => ((a -> m (StT u b)) -> m (StT u b)) + -> (a -> u m b) + -> u m b lifted f k = liftWith (\run -> f (run . k)) >>= restoreT . return freeToFix :: Functor f => (a -> Fix f) -> Free f a -> Fix f freeToFix f = go - where - go (Pure a) = f a - go (Free v) = Fix (fmap go v) + where + go (Pure a) = f a + go (Free v) = Fix (fmap go v) fixToFree :: Functor f => Fix f -> Free f Void -fixToFree = Free . go - where - go (Fix f) = fmap (Free . go) f +fixToFree = Free . go where go (Fix f) = fmap (Free . go) f -- | adi is Abstracting Definitional Interpreters: -- diff --git a/src/Nix/Value/Equal.hs b/src/Nix/Value/Equal.hs index 6fed8b3..939036f 100644 --- a/src/Nix/Value/Equal.hs +++ b/src/Nix/Value/Equal.hs @@ -154,16 +154,17 @@ compareAttrSets f eq lm rm = runIdentity $ compareAttrSetsM (\t -> Identity (f t)) (\x y -> Identity (eq x y)) lm rm valueEqM - :: forall t f m. (MonadThunk t m (NValue t f m), Comonad f) + :: forall t f m + . (MonadThunk t m (NValue t f m), Comonad f) => NValue t f m -> NValue t f m -> m Bool -valueEqM (Pure x) (Pure y) = thunkEqM x y -valueEqM (Pure x) y@(Free _) = thunkEqM x =<< thunk (pure y) -valueEqM x@(Free _) (Pure y) = thunkEqM ?? y =<< thunk (pure x) +valueEqM ( Pure x) ( Pure y) = thunkEqM x y +valueEqM ( Pure x) y@(Free _) = thunkEqM x =<< thunk (pure y) +valueEqM x@(Free _) ( Pure y) = thunkEqM ?? y =<< thunk (pure x) valueEqM (Free (NValue (extract -> x))) (Free (NValue (extract -> y))) = valueFEqM (compareAttrSetsM f valueEqM) valueEqM x y - where + where f (Pure t) = force t $ \case NVStr s -> pure $ Just s _ -> pure Nothing diff --git a/src/Nix/XML.hs b/src/Nix/XML.hs index 30c6981..0da4220 100644 --- a/src/Nix/XML.hs +++ b/src/Nix/XML.hs @@ -16,10 +16,7 @@ import Nix.Value import Text.XML.Light toXML :: forall t f m . MonadDataContext f m => NValueNF t f m -> NixString -toXML = - runWithStringContext - . fmap pp - . iterNValueNF phi +toXML = runWithStringContext . fmap pp . iterNValueNF phi where pp = ("\n" <>) @@ -36,8 +33,9 @@ toXML = NBool b -> return $ mkElem "bool" "value" (if b then "true" else "false") NNull -> return $ Element (unqual "null") [] [] Nothing - NVStr' str -> mkElem "string" "value" . Text.unpack <$> extractNixString str - NVList' l -> sequence l + NVStr' str -> + mkElem "string" "value" . Text.unpack <$> extractNixString str + NVList' l -> sequence l >>= \els -> return $ Element (unqual "list") [] (Elem <$> els) Nothing NVSet' s _ -> sequence s >>= \kvs -> return $ Element @@ -59,7 +57,7 @@ toXML = return $ Element (unqual "function") [] (paramsXML p) Nothing NVPath' fp -> return $ mkElem "path" "value" fp NVBuiltin' name _ -> return $ mkElem "function" "name" name - _ -> error "Pattern synonyms mask coverage" + _ -> error "Pattern synonyms mask coverage" mkElem :: String -> String -> String -> Element mkElem n a v = Element (unqual n) [Attr (unqual a) v] [] Nothing