Merge pull request #422 from kmicklas/xml-string-context

Accumulate string context in builtins.toXML

main/Main.hs

@@ -140,7 +140,7 @@ main = do
             | finder opts =
               fromValue @(AttrSet (NThunk m)) >=> findAttrs
             | xml opts =
-              liftIO . putStrLn . toXML <=< normalForm
+              liftIO . putStrLn . Text.unpack . principledStringIgnoreContext . toXML <=< normalForm
             | json opts =
               liftIO . TL.putStrLn
                      . TL.decodeUtf8

src/Nix/Builtins.hs

@@ -1039,8 +1039,7 @@ prim_toJSON x = do
   pure $ nvStr $ principledMakeNixString t ctx
 
 toXML_ :: MonadNix e m => m (NValue m) -> m (NValue m)
-toXML_ v = v >>= normalForm >>= \x ->
-    pure $ nvStr $ hackyMakeNixStringWithoutContext $ Text.pack (toXML x)
+toXML_ v = v >>= normalForm >>= pure . nvStr . toXML
 
 typeOf :: MonadNix e m => m (NValue m) -> m (NValue m)
 typeOf v = v >>= toNix . principledMakeNixStringWithoutContext . \case

src/Nix/String.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
 module Nix.String (
@@ -21,8 +22,12 @@ module Nix.String (
   , principledStringMappend
   , principledStringMempty
   , principledStringMConcat
+  , WithStringContext
+  , extractNixString
+  , runWithStringContext
 ) where
 
+import           Control.Monad.Writer
 import qualified Data.HashSet as S
 import           Data.Hashable
 import           Data.Text (Text)
@@ -138,3 +143,15 @@ principledMakeNixStringWithSingletonContext s c = NixString s (S.singleton c)
 -- | Create a NixString from a Text and context
 principledMakeNixString :: Text -> S.HashSet StringContext -> NixString
 principledMakeNixString s c = NixString s c
+
+-- | A monad for accumulating string context while producing a result string.
+newtype WithStringContext a = WithStringContext (Writer (S.HashSet StringContext) a)
+  deriving (Functor, Applicative, Monad, MonadWriter (S.HashSet StringContext))
+
+-- | Get the contents of a 'NixString' and write its context into the resulting set.
+extractNixString :: NixString -> WithStringContext Text
+extractNixString (NixString s c) = WithStringContext $ tell c >> return s
+
+-- | Run an action producing a string with a context and put those into a 'NixString'.
+runWithStringContext :: WithStringContext Text -> NixString
+runWithStringContext (WithStringContext m) = uncurry NixString $ runWriter m

src/Nix/XML.hs

@@ -1,6 +1,9 @@
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
-module Nix.XML where
+module Nix.XML (toXML) where
 
 import           Control.Monad.Free
 import qualified Data.HashMap.Lazy as M
@@ -13,38 +16,41 @@ import           Nix.String
 import           Nix.Value
 import           Text.XML.Light
 
-toXML :: Functor m => NValueNF m -> String
-toXML = ("<?xml version='1.0' encoding='utf-8'?>\n" ++)
-      . (++ "\n")
+toXML :: Functor m => NValueNF m -> NixString
+toXML = runWithStringContext . fmap pp . iterM phi . check
+  where
+    pp = ("<?xml version='1.0' encoding='utf-8'?>\n" <>)
+      . (<> "\n")
+      . Text.pack
       . ppElement
       . (\e -> Element (unqual "expr") [] [Elem e] Nothing)
-      . iter phi
-      . check
-  where
-    check :: NValueNF m -> Free (NValueF m) Element
-    check = fmap (const (mkElem "cycle" "value" ""))
 
-    phi :: NValueF m Element -> Element
+    check :: NValueNF f -> Free (NValueF f) Element
+    check = fmap $ const $ mkElem "cycle" "value" ""
+
+    phi :: NValueF f (WithStringContext Element) -> WithStringContext Element
     phi = \case
         NVConstantF a -> case a of
-            NInt n   -> mkElem "int" "value" (show n)
-            NFloat f -> mkElem "float" "value" (show f)
-            NBool b  -> mkElem "bool" "value" (if b then "true" else "false")
-            NNull    -> Element (unqual "null") [] [] Nothing
+            NInt n   -> return $ mkElem "int" "value" (show n)
+            NFloat f -> return $ mkElem "float" "value" (show f)
+            NBool b  -> return $ mkElem "bool" "value" (if b then "true" else "false")
+            NNull    -> return $ Element (unqual "null") [] [] Nothing
 
-        NVStrF ns -> mkElem "string" "value" (Text.unpack $ hackyStringIgnoreContext ns)
-        NVListF l  -> Element (unqual "list") [] (Elem <$> l) Nothing
+        NVStrF str -> mkElem "string" "value" . Text.unpack <$> extractNixString str
+        NVListF l  -> sequence l >>= \els ->
+          return $ Element (unqual "list") [] (Elem <$> els) Nothing
 
-        NVSetF s _ -> Element (unqual "attrs") []
+        NVSetF s _ -> sequence s >>= \kvs ->
+          return $ Element (unqual "attrs") []
             (map (\(k, v) ->
                       Elem (Element (unqual "attr")
                                [Attr (unqual "name") (Text.unpack k)]
                                [Elem v] Nothing))
-                 (sortBy (comparing fst) $ M.toList s)) Nothing
+                 (sortBy (comparing fst) $ M.toList kvs)) Nothing
 
-        NVClosureF p _    -> Element (unqual "function") [] (paramsXML p) Nothing
-        NVPathF fp        -> mkElem "path" "value" fp
-        NVBuiltinF name _ -> mkElem "function" "name" name
+        NVClosureF p _    -> return $ Element (unqual "function") [] (paramsXML p) Nothing
+        NVPathF fp        -> return $ mkElem "path" "value" fp
+        NVBuiltinF name _ -> return $ mkElem "function" "name" name
 
 mkElem :: String -> String -> String -> Element
 mkElem n a v = Element (unqual n) [Attr (unqual a) v] [] Nothing
@@ -53,7 +59,7 @@ paramsXML :: Params r -> [Content]
 paramsXML (Param name) =
     [Elem $ mkElem "varpat" "name" (Text.unpack name)]
 paramsXML (ParamSet s b mname) =
-    [Elem $ Element (unqual "attrspat") (battr ++ nattr) (paramSetXML s) Nothing]
+    [Elem $ Element (unqual "attrspat") (battr <> nattr) (paramSetXML s) Nothing]
   where
     battr = [ Attr (unqual "ellipsis") "1" | b ]
     nattr = maybe [] ((:[]) . Attr (unqual "name") . Text.unpack) mname

tests/NixLanguageTests.hs

@@ -22,6 +22,7 @@ import           Nix.Options
 import           Nix.Options.Parser
 import           Nix.Parser
 import           Nix.Pretty
+import           Nix.String
 import           Nix.Utils
 import           Nix.XML
 import qualified Options.Applicative as Opts
@@ -108,9 +109,9 @@ assertLangOk opts file = do
 
 assertLangOkXml :: Options -> FilePath -> Assertion
 assertLangOkXml opts file = do
-  actual <- toXML <$> hnixEvalFile opts (file ++ ".nix")
+  actual <- principledStringIgnoreContext . toXML <$> hnixEvalFile opts (file ++ ".nix")
   expected <- Text.readFile $ file ++ ".exp.xml"
-  assertEqual "" expected $ Text.pack actual
+  assertEqual "" expected actual
 
 assertEval :: Options -> [FilePath] -> Assertion
 assertEval _opts files = do