reduce (principled->) from NixString functions, use NixString monoid

Author: Anton-Latukha

main/Main.hs

@@ -143,13 +143,13 @@ main = do
       = liftIO
         .   putStrLn
         .   Text.unpack
-        .   principledStringIgnoreContext
+        .   stringIgnoreContext
         .   toXML
         <=< normalForm
       | json opts
       = liftIO
         .   Text.putStrLn
-        .   principledStringIgnoreContext
+        .   stringIgnoreContext
         <=< nvalueToJSONNixString
       | strict opts
       = liftIO . print . prettyNValue <=< normalForm

src/Nix/Builtins.hs

@@ -151,7 +151,7 @@ instance ( Convertible e t f m
     NVStr' ns -> pure $ Just ns
     NVPath' p ->
       Just
-        .   (\s -> principledMakeNixStringWithSingletonContext s (StringContext s DirectPath))
+        .   (\s -> makeNixStringWithSingletonContext s (StringContext s DirectPath))
         .   Text.pack
         .   unStorePath
         <$> addPath p
@@ -166,7 +166,7 @@ instance ( Convertible e t f m
 instance Convertible e t f m
   => FromValue ByteString m (NValue' t f m (NValue t f m)) where
   fromValueMay = \case
-    NVStr' ns -> pure $ encodeUtf8 <$> principledGetStringNoContext  ns
+    NVStr' ns -> pure $ encodeUtf8 <$> getStringNoContext  ns
     _         -> pure Nothing
   fromValue v = fromValueMay v >>= \case
     Just b -> pure b
@@ -181,7 +181,7 @@ instance ( Convertible e t f m
   => FromValue Path m (NValue' t f m (NValue t f m)) where
   fromValueMay = \case
     NVPath' p  -> pure $ Just (Path p)
-    NVStr'  ns -> pure $ Path . Text.unpack <$> principledGetStringNoContext  ns
+    NVStr'  ns -> pure $ Path . Text.unpack <$> getStringNoContext  ns
     NVSet' s _ -> case M.lookup "outPath" s of
       Nothing -> pure Nothing
       Just p  -> fromValueMay @Path p
@@ -303,7 +303,7 @@ instance Convertible e t f m
 
 instance Convertible e t f m
   => ToValue ByteString m (NValue' t f m (NValue t f m)) where
-  toValue = pure . nvStr' . principledMakeNixStringWithoutContext . decodeUtf8
+  toValue = pure . nvStr' . makeNixStringWithoutContext . decodeUtf8
 
 instance Convertible e t f m
   => ToValue Path m (NValue' t f m (NValue t f m)) where
@@ -317,7 +317,7 @@ instance ( Convertible e t f m
          )
   => ToValue SourcePos m (NValue' t f m (NValue t f m)) where
   toValue (SourcePos f l c) = do
-    f' <- toValue (principledMakeNixStringWithoutContext (Text.pack f))
+    f' <- toValue (makeNixStringWithoutContext (Text.pack f))
     l' <- toValue (unPos l)
     c' <- toValue (unPos c)
     let pos = M.fromList [("file" :: Text, f'), ("line", l'), ("column", c')]
@@ -359,7 +359,7 @@ instance Convertible e t f m
       else pure Nothing
     outputs <- do
       let outputs =
-            principledMakeNixStringWithoutContext <$> nlcvOutputs nlcv
+            makeNixStringWithoutContext <$> nlcvOutputs nlcv
       ts :: [NValue t f m] <- traverse toValue outputs
       case ts of
         [] -> pure Nothing

src/Nix/Convert.hs

@@ -137,7 +137,7 @@ findPathBy finder ls name = do
         Nothing -> tryPath path Nothing
         Just pf -> demand pf $ fromValueMay >=> \case
           Just (nsPfx :: NixString) ->
-            let pfx = principledStringIgnoreContext nsPfx
+            let pfx = stringIgnoreContext nsPfx
             in  if not (Text.null pfx)
                   then tryPath path (Just (Text.unpack pfx))
                   else tryPath path Nothing
@@ -174,7 +174,7 @@ fetchTarball = flip demand $ \case
  where
   go :: Maybe (NValue t f m) -> NValue t f m -> m (NValue t f m)
   go msha = \case
-    NVStr ns -> fetch (principledStringIgnoreContext ns) msha
+    NVStr ns -> fetch (stringIgnoreContext ns) msha
     v ->
       throwError
         $  ErrorCall
@@ -197,7 +197,7 @@ fetchTarball = flip demand $ \case
   fetch uri Nothing =
     nixInstantiateExpr $ "builtins.fetchTarball \"" ++ Text.unpack uri ++ "\""
   fetch url (Just t) = demand t $ fromValue >=> \nsSha ->
-    let sha = principledStringIgnoreContext nsSha
+    let sha = stringIgnoreContext nsSha
     in  nixInstantiateExpr
           $  "builtins.fetchTarball { "
           ++ "url    = \""

src/Nix/Effects/Basic.hs

@@ -260,8 +260,8 @@ defaultDerivationStrict = fromValue @(AttrSet (NValue t f m)) >=> \s -> do
     drvHash <- Store.encodeInBase Store.Base16 <$> hashDerivationModulo drv'
     modify (\(a, b) -> (a, MS.insert drvPath drvHash b))
 
-    let outputsWithContext = Map.mapWithKey (\out path -> principledMakeNixStringWithSingletonContext path (StringContext drvPath (DerivationOutput out))) (outputs drv')
-        drvPathWithContext = principledMakeNixStringWithSingletonContext drvPath (StringContext drvPath AllOutputs)
+    let outputsWithContext = Map.mapWithKey (\out path -> makeNixStringWithSingletonContext path (StringContext drvPath (DerivationOutput out))) (outputs drv')
+        drvPathWithContext = makeNixStringWithSingletonContext drvPath (StringContext drvPath AllOutputs)
         attrSet = M.map nvStr $ M.fromList $ ("drvPath", drvPathWithContext): Map.toList outputsWithContext
     -- TODO: Add location information for all the entries.
     --              here --v
@@ -373,7 +373,7 @@ buildDerivationWithContext drvAttrs = do
       return name
 
     extractNoCtx :: MonadNix e t f m => NixString -> WithStringContextT m Text
-    extractNoCtx ns = case principledGetStringNoContext ns of
+    extractNoCtx ns = case getStringNoContext ns of
       Nothing -> lift $ throwError $ ErrorCall $ "The string " ++ show ns ++ " is not allowed to have a context."
       Just v -> return v
 

src/Nix/Effects/Derivation.hs

@@ -355,7 +355,7 @@ evalSetterKeyName = \case
   StaticKey k -> pure (Just k)
   DynamicKey k ->
     runAntiquoted "\n" assembleString (>>= fromValueMay) k <&> \case
-      Just ns -> Just (principledStringIgnoreContext ns)
+      Just ns -> Just (stringIgnoreContext ns)
       _       -> Nothing
 
 assembleString
@@ -367,10 +367,10 @@ assembleString = \case
   Indented _ parts   -> fromParts parts
   DoubleQuoted parts -> fromParts parts
  where
-  fromParts = fmap (fmap principledStringMConcat . sequence) . traverse go
+  fromParts = fmap (fmap stringMConcat . sequence) . traverse go
 
   go = runAntiquoted "\n"
-                     (pure . Just . principledMakeNixStringWithoutContext)
+                     (pure . Just . makeNixStringWithoutContext)
                      (>>= fromValueMay)
 
 buildArgument

src/Nix/Eval.hs

@@ -210,7 +210,7 @@ instance MonadNix e t f m => MonadEval (NValue t f m) m where
       pure $ nvStrP
         (Provenance
           scope
-          (NStr_ span (DoubleQuoted [Plain (principledStringIgnoreContext ns)]))
+          (NStr_ span (DoubleQuoted [Plain (stringIgnoreContext ns)]))
         )
         ns
     Nothing -> nverr $ ErrorCall "Failed to assemble string"
@@ -400,22 +400,22 @@ execBinaryOpForced scope span op lval rval = case op of
   NPlus -> case (lval, rval) of
     (NVConstant _, NVConstant _) -> numBinOp (+)
 
-    (NVStr ls, NVStr rs) -> pure $ nvStrP prov (ls `principledStringMappend` rs)
+    (NVStr ls, NVStr rs) -> pure $ nvStrP prov (ls `mappend` rs)
     (NVStr ls, rs@NVPath{}) ->
-      (\rs2 -> nvStrP prov (ls `principledStringMappend` rs2))
+      (\rs2 -> nvStrP prov (ls `mappend` rs2))
         <$> coerceToString callFunc CopyToStore CoerceStringy rs
-    (NVPath ls, NVStr rs) -> case principledGetStringNoContext rs of
+    (NVPath ls, NVStr rs) -> case getStringNoContext rs of
       Just rs2 -> nvPathP prov <$> makeAbsolutePath @t @f (ls `mappend` Text.unpack rs2)
       Nothing -> throwError $ ErrorCall $
         -- data/nix/src/libexpr/eval.cc:1412
         "A string that refers to a store path cannot be appended to a path."
     (NVPath ls, NVPath rs) -> nvPathP prov <$> makeAbsolutePath @t @f (ls ++ rs)
 
     (ls@NVSet{}, NVStr rs) ->
-      (\ls2 -> nvStrP prov (ls2 `principledStringMappend` rs))
+      (\ls2 -> nvStrP prov (ls2 `mappend` rs))
         <$> coerceToString callFunc DontCopyToStore CoerceStringy ls
     (NVStr ls, rs@NVSet{}) ->
-      (\rs2 -> nvStrP prov (ls `principledStringMappend` rs2))
+      (\rs2 -> nvStrP prov (ls `mappend` rs2))
         <$> coerceToString callFunc DontCopyToStore CoerceStringy rs
     _ -> unsupportedTypes
 
@@ -473,7 +473,7 @@ execBinaryOpForced scope span op lval rval = case op of
 -- This function is here, rather than in 'Nix.String', because of the need to
 -- use 'throwError'.
 fromStringNoContext :: Framed e m => NixString -> m Text
-fromStringNoContext ns = case principledGetStringNoContext ns of
+fromStringNoContext ns = case getStringNoContext ns of
   Just str -> pure str
   Nothing  -> throwError $ ErrorCall $ "expected string with no context, but got " ++ show ns
 

src/Nix/Exec.hs

@@ -124,7 +124,7 @@ removeEffects =
     (fmap Free . sequenceNValue' id)
 
 opaque :: Applicative f => NValue t f m
-opaque = nvStr $ principledMakeNixStringWithoutContext "<CYCLE>"
+opaque = nvStr $ makeNixStringWithoutContext "<CYCLE>"
 
 dethunk
   :: (MonadThunk t m (NValue t f m), MonadDataContext f m)

src/Nix/Normal.hs

@@ -330,7 +330,7 @@ valueToExpr = iterNValue (\_ _ -> thk) phi
   phi (NVBuiltin' name _) = Fix . NSym . pack $ "builtins." ++ name
   phi _                   = error "Pattern synonyms foil completeness check"
 
-  mkStr ns = Fix $ NStr $ DoubleQuoted [Plain (principledStringIgnoreContext ns)]
+  mkStr ns = Fix $ NStr $ DoubleQuoted [Plain (stringIgnoreContext ns)]
 
 prettyNValue
   :: forall t f m ann . MonadDataContext f m => NValue t f m -> Doc ann
@@ -390,7 +390,7 @@ printNix = iterNValue (\_ _ -> thk) phi
 
   phi :: NValue' t f m String -> String
   phi (NVConstant' a ) = unpack $ atomText a
-  phi (NVStr'      ns) = show $ principledStringIgnoreContext ns
+  phi (NVStr'      ns) = show $ stringIgnoreContext ns
   phi (NVList'     l ) = "[ " ++ unwords l ++ " ]"
   phi (NVSet' s _) =
     "{ "

src/Nix/Pretty.hs

@@ -4,25 +4,22 @@
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
 module Nix.String
   ( NixString
-  , principledGetContext
-  , principledMakeNixString
-  , principledMempty
+  , getContext
+  , makeNixString
   , StringContext(..)
   , ContextFlavor(..)
   , NixLikeContext(..)
   , NixLikeContextValue(..)
   , toNixLikeContext
   , fromNixLikeContext
   , stringHasContext
-  , principledIntercalateNixString
-  , principledGetStringNoContext
-  , principledStringIgnoreContext
-  , principledMakeNixStringWithoutContext
-  , principledMakeNixStringWithSingletonContext
-  , principledModifyNixContents
-  , principledStringMappend
-  , principledStringMempty
-  , principledStringMConcat
+  , intercalateNixString
+  , getStringNoContext
+  , stringIgnoreContext
+  , makeNixStringWithoutContext
+  , makeNixStringWithSingletonContext
+  , modifyNixContents
+  , stringMConcat
   , WithStringContext
   , WithStringContextT(..)
   , extractNixString
@@ -69,6 +66,12 @@ data NixString = NixString
   , nsContext :: !(S.HashSet StringContext)
   } deriving (Eq, Ord, Show, Generic)
 
+instance Semigroup NixString where
+  NixString s1 t1 <> NixString s2 t2 = NixString (s1 <> s2) (t1 <> t2)
+
+instance Monoid NixString where
+ mempty = NixString mempty mempty
+
 instance Hashable NixString
 
 newtype NixLikeContext = NixLikeContext
@@ -118,72 +121,52 @@ fromNixLikeContext :: NixLikeContext -> S.HashSet StringContext
 fromNixLikeContext =
   S.fromList . join . map toStringContexts . M.toList . getNixLikeContext
 
-principledGetContext :: NixString -> S.HashSet StringContext
-principledGetContext = nsContext
-
--- | Combine two NixStrings using mappend
-principledMempty :: NixString
-principledMempty = NixString "" mempty
-
--- | Combine two NixStrings using mappend
-principledStringMappend :: NixString -> NixString -> NixString
-principledStringMappend (NixString s1 t1) (NixString s2 t2) =
-  NixString (s1 <> s2) (t1 <> t2)
+getContext :: NixString -> S.HashSet StringContext
+getContext = nsContext
 
 -- | Combine NixStrings with a separator
-principledIntercalateNixString :: NixString -> [NixString] -> NixString
-principledIntercalateNixString _   []   = principledMempty
-principledIntercalateNixString _   [ns] = ns
-principledIntercalateNixString sep nss  = NixString contents ctx
+intercalateNixString :: NixString -> [NixString] -> NixString
+intercalateNixString _   []   = mempty
+intercalateNixString _   [ns] = ns
+intercalateNixString sep nss  = NixString contents ctx
  where
   contents = Text.intercalate (nsContents sep) (map nsContents nss)
   ctx      = S.unions (nsContext sep : map nsContext nss)
 
--- | Empty string with empty context.
-principledStringMempty :: NixString
-principledStringMempty = NixString mempty mempty
-
 -- | Combine NixStrings using mconcat
-principledStringMConcat :: [NixString] -> NixString
-principledStringMConcat =
-  foldr principledStringMappend (NixString mempty mempty)
-
---instance Semigroup NixString where
-  --NixString s1 t1 <> NixString s2 t2 = NixString (s1 <> s2) (t1 <> t2)
-
---instance Monoid NixString where
---  mempty = NixString mempty mempty
---  mappend = (<>)
+stringMConcat :: [NixString] -> NixString
+stringMConcat =
+  foldr mappend (NixString mempty mempty)
 
 -- | Extract the string contents from a NixString that has no context
-principledGetStringNoContext :: NixString -> Maybe Text
-principledGetStringNoContext (NixString s c) | null c    = Just s
+getStringNoContext :: NixString -> Maybe Text
+getStringNoContext (NixString s c) | null c    = Just s
                                              | otherwise = Nothing
 
 -- | Extract the string contents from a NixString even if the NixString has an associated context
-principledStringIgnoreContext :: NixString -> Text
-principledStringIgnoreContext (NixString s _) = s
+stringIgnoreContext :: NixString -> Text
+stringIgnoreContext (NixString s _) = s
 
 -- | Returns True if the NixString has an associated context
 stringHasContext :: NixString -> Bool
 stringHasContext (NixString _ c) = not (null c)
 
 -- | Constructs a NixString without a context
-principledMakeNixStringWithoutContext :: Text -> NixString
-principledMakeNixStringWithoutContext = flip NixString mempty
+makeNixStringWithoutContext :: Text -> NixString
+makeNixStringWithoutContext = flip NixString mempty
 
 -- | Modify the string part of the NixString, leaving the context unchanged
-principledModifyNixContents :: (Text -> Text) -> NixString -> NixString
-principledModifyNixContents f (NixString s c) = NixString (f s) c
+modifyNixContents :: (Text -> Text) -> NixString -> NixString
+modifyNixContents f (NixString s c) = NixString (f s) c
 
 -- | Create a NixString using a singleton context
-principledMakeNixStringWithSingletonContext
+makeNixStringWithSingletonContext
   :: Text -> StringContext -> NixString
-principledMakeNixStringWithSingletonContext s c = NixString s (S.singleton c)
+makeNixStringWithSingletonContext s c = NixString s (S.singleton c)
 
 -- | Create a NixString from a Text and context
-principledMakeNixString :: Text -> S.HashSet StringContext -> NixString
-principledMakeNixString = NixString
+makeNixString :: Text -> S.HashSet StringContext -> NixString
+makeNixString = NixString
 
 -- | A monad for accumulating string context while producing a result string.
 newtype WithStringContextT m a = WithStringContextT (WriterT (S.HashSet StringContext) m a)
@@ -232,21 +215,21 @@ runWithStringContext' = runIdentity . runWithStringContextT'
 
 -- | Combine two NixStrings using mappend
 hackyStringMappend :: NixString -> NixString -> NixString
-hackyStringMappend = principledStringMappend
+hackyStringMappend = mappend
 
 -- | Combine NixStrings using mconcat
 hackyStringMConcat :: [NixString] -> NixString
-hackyStringMConcat = principledStringMConcat
+hackyStringMConcat = stringMConcat
 
 -- | Constructs a NixString without a context
 hackyMakeNixStringWithoutContext :: Text -> NixString
-hackyMakeNixStringWithoutContext = principledMakeNixStringWithoutContext
+hackyMakeNixStringWithoutContext = makeNixStringWithoutContext
 
 -- | Extract the string contents from a NixString even if the NixString has an associated context
 hackyStringIgnoreContext :: NixString -> Text
-hackyStringIgnoreContext = principledStringIgnoreContext
+hackyStringIgnoreContext = stringIgnoreContext
 
 -- | Extract the string contents from a NixString that has no context
 hackyGetStringNoContext :: NixString -> Maybe Text
-hackyGetStringNoContext = principledGetStringNoContext
+hackyGetStringNoContext = getStringNoContext