Pretty: refactor

Foreign module functions which are text literals...

Lets stop spawning a String to serialize it into Text, which then serializes
into String that serializes then into Doc. If I would compute O to it - it would
explain the snails speed.

Author: Anton-Latukha

src/Nix/Pretty.hs

@@ -15,7 +15,8 @@ module Nix.Pretty where
 
 import           Control.Applicative            ( (<|>) )
 import           Control.Monad.Free
-import           Data.Fix                       ( Fix(..), foldFix )
+import           Data.Fix                       ( Fix(..)
+                                                , foldFix )
 import           Data.HashMap.Lazy              ( toList )
 import qualified Data.HashMap.Lazy             as M
 import qualified Data.HashSet                  as HashSet
@@ -97,7 +98,7 @@ hasAttrOp = getSpecialOperator NHasAttrOp
 wrapParens :: OperatorInfo -> NixDoc ann -> Doc ann
 wrapParens op sub =
   bool
-    parens
+    (\ a -> "(" <> a <> ")")
     id
     (precedence (rootOp sub)       < precedence op
     || (precedence (rootOp sub)   == precedence op
@@ -112,80 +113,81 @@ wrapPath :: OperatorInfo -> NixDoc ann -> Doc ann
 wrapPath op sub =
   bool
     (wrapParens op sub)
-    (dquotes $ "$" <> braces (withoutParens sub))
+    ("\"${" <> withoutParens sub <> "}\"")
     (wasPath sub)
 
 prettyString :: NString (NixDoc ann) -> Doc ann
-prettyString (DoubleQuoted parts) = dquotes . hcat . fmap prettyPart $ parts
+prettyString (DoubleQuoted parts) = "\"" <> (mconcat . fmap prettyPart $ parts) <> "\""
  where
+  -- It serializes (@unpack@) Text -> String, because the helper code is done for String,
+  -- please, can someone break that code.
   prettyPart (Plain t)      = pretty . concatMap escape . unpack $ t
   prettyPart EscapedNewline = "''\\n"
-  prettyPart (Antiquoted r) = "$" <> braces (withoutParens r)
+  prettyPart (Antiquoted r) = "${" <> withoutParens r <> "}"
   escape '"' = "\\\""
   escape x   =
     maybe
       [x]
       (('\\' :) . (: mempty))
       (toEscapeCode x)
 prettyString (Indented _ parts) = group $ nest 2 $ vcat
-  [dsquote, content, dsquote]
+  ["''", content, "''"]
  where
-  dsquote = squote <> squote
   content = vsep . fmap prettyLine . stripLastIfEmpty . splitLines $ parts
   stripLastIfEmpty = reverse . f . reverse   where
     f ([Plain t] : xs) | Text.null (strip t) = xs
     f xs = xs
   prettyLine = hcat . fmap prettyPart
   prettyPart (Plain t) =
-    pretty . unpack . replace "${" "''${" . replace "''" "'''" $ t
+    pretty . replace "${" "''${" . replace "''" "'''" $ t
   prettyPart EscapedNewline = "\\n"
-  prettyPart (Antiquoted r) = "$" <> braces (withoutParens r)
+  prettyPart (Antiquoted r) = "${" <> withoutParens r <> "}"
 
 prettyParams :: Params (NixDoc ann) -> Doc ann
-prettyParams (Param n           ) = pretty $ unpack n
+prettyParams (Param n           ) = pretty n
 prettyParams (ParamSet s v mname) = prettyParamSet s v <>
-    (\ name -> ("@" <> pretty (unpack name)) `ifTrue` not (Text.null name)) `ifJust` mname
+    (\ name -> ("@" <> pretty name) `ifTrue` not (Text.null name)) `ifJust` mname
 
 prettyParamSet :: ParamSet (NixDoc ann) -> Bool -> Doc ann
 prettyParamSet args var =
   encloseSep
-    (lbrace <> space)
-    (align (space <> rbrace))
+    "{ "
+    (align " }")
     sep
     (fmap prettySetArg args <> prettyVariadic)
  where
   prettySetArg (n, maybeDef) =
     maybe
-      (pretty (unpack n))
-      (\x -> pretty (unpack n) <> " ? " <> withoutParens x)
+      (pretty n)
+      (\x -> pretty n <> " ? " <> withoutParens x)
       maybeDef
   prettyVariadic = [ "..." | var ]
-  sep            = align (comma <> space)
+  sep            = align ", "
 
 prettyBind :: Binding (NixDoc ann) -> Doc ann
 prettyBind (NamedVar n v _p) =
-  prettySelector n <> space <> equals <> space <> withoutParens v <> semi
+  prettySelector n <> " = " <> withoutParens v <> ";"
 prettyBind (Inherit s ns _p) =
-  "inherit " <>scope <> align (fillSep (fmap prettyKeyName ns)) <> semi
+  "inherit " <> scope <> align (fillSep (fmap prettyKeyName ns)) <> ";"
   where
-    scope = ((<> space) . parens . withoutParens) `ifJust` s
+    scope = ((<> " ") . parens . withoutParens) `ifJust` s
 
 prettyKeyName :: NKeyName (NixDoc ann) -> Doc ann
-prettyKeyName (StaticKey "") = dquotes ""
-prettyKeyName (StaticKey key) | HashSet.member key reservedNames =
-  dquotes $ pretty $ unpack key
-prettyKeyName (StaticKey  key) = pretty . unpack $ key
-prettyKeyName (DynamicKey key) = runAntiquoted
-  (DoubleQuoted [Plain "\n"])
-  prettyString
-  (("$" <>) . braces . withoutParens)
-  key
+prettyKeyName (StaticKey "") = "\"\""
+prettyKeyName (StaticKey key) | HashSet.member key reservedNames = "\"" <> pretty key <> "\""
+prettyKeyName (StaticKey  key) = pretty key
+prettyKeyName (DynamicKey key) =
+  runAntiquoted
+      (DoubleQuoted [Plain "\n"])
+      prettyString
+      (\ x -> "${" <> withoutParens x <> "}")
+      key
 
 prettySelector :: NAttrPath (NixDoc ann) -> Doc ann
-prettySelector = hcat . punctuate dot . fmap prettyKeyName . NE.toList
+prettySelector = hcat . punctuate "." . fmap prettyKeyName . NE.toList
 
 prettyAtom :: NAtom -> NixDoc ann
-prettyAtom atom = simpleExpr $ pretty $ unpack $ atomText atom
+prettyAtom atom = simpleExpr $ pretty $ atomText atom
 
 prettyNix :: NExpr -> Doc ann
 prettyNix = withoutParens . foldFix exprFNixDoc
@@ -259,7 +261,7 @@ exprFNixDoc = \case
     mkNixDoc opInfo $
       hsep
         [ wrapParens (f NAssocLeft) r1
-        , pretty $ unpack $ operatorName opInfo
+        , pretty $ operatorName opInfo
         , wrapParens (f NAssocRight) r2
         ]
    where
@@ -269,17 +271,17 @@ exprFNixDoc = \case
   NUnary op r1 ->
     mkNixDoc
       opInfo
-      (pretty (unpack (operatorName opInfo)) <> wrapParens opInfo r1)
+      (pretty (operatorName opInfo) <> wrapParens opInfo r1)
     where opInfo = getUnaryOperator op
   NSelect r' attr o ->
     (if isJust o then leastPrecedence else mkNixDoc selectOp)
       $  wrapPath selectOp r
-      <> dot
+      <> "."
       <> prettySelector attr
       <> ordoc
    where
     r     = mkNixDoc selectOp (wrapParens appOpNonAssoc r')
-    ordoc = maybe mempty (((space <> "or ") <>) . wrapParens appOpNonAssoc) o
+    ordoc = maybe mempty ((" or " <>) . wrapParens appOpNonAssoc) o
   NHasAttr r attr ->
     mkNixDoc hasAttrOp (wrapParens hasAttrOp r <> " ? " <> prettySelector attr)
   NEnvPath     p -> simpleExpr $ pretty ("<" <> p <> ">")
@@ -295,7 +297,7 @@ exprFNixDoc = \case
               ("./" <> _txt)
               _txt
               (any (`isPrefixOf` _txt) ["/", "~/", "./", "../"])
-  NSym name -> simpleExpr $ pretty (unpack name)
+  NSym name -> simpleExpr $ pretty name
   NLet binds body ->
     leastPrecedence $
       group $
@@ -316,17 +318,17 @@ exprFNixDoc = \case
   NWith scope body ->
     leastPrecedence $
       vsep
-        ["with " <> withoutParens scope <> semi, align $ withoutParens body]
+        ["with " <> withoutParens scope <> ";", align $ withoutParens body]
   NAssert cond body ->
     leastPrecedence $
       vsep
-        ["assert " <> withoutParens cond <> semi, align $ withoutParens body]
-  NSynHole name -> simpleExpr $ pretty ("^" <> unpack name)
+        ["assert " <> withoutParens cond <> ";", align $ withoutParens body]
+  NSynHole name -> simpleExpr $ pretty ("^" <> name)
 
 valueToExpr :: forall t f m . MonadDataContext f m => NValue t f m -> NExpr
 valueToExpr = iterNValue (\_ _ -> thk) phi
  where
-  thk = Fix . NSym . pack $ "<expr>"
+  thk = Fix . NSym $ "<expr>"
 
   phi :: NValue' t f m NExpr -> NExpr
   phi (NVConstant' a ) = Fix $ NConstant a
@@ -336,9 +338,9 @@ valueToExpr = iterNValue (\_ _ -> thk) phi
     [ NamedVar (StaticKey k :| mempty) v (fromMaybe nullPos (M.lookup k p))
     | (k, v) <- toList s
     ]
-  phi (NVClosure' _ _   ) = Fix . NSym . pack $ "<closure>"
+  phi (NVClosure' _ _   ) = Fix . NSym $ "<closure>"
   phi (NVPath' p        ) = Fix $ NLiteralPath p
-  phi (NVBuiltin' name _) = Fix . NSym . pack $ "builtins." <> name
+  phi (NVBuiltin' name _) = Fix . NSym $ "builtins." <> pack name
   phi _                   = error "Pattern synonyms foil completeness check"
 
   mkStr ns = Fix $ NStr $ DoubleQuoted [Plain (stringIgnoreContext ns)]
@@ -356,20 +358,24 @@ prettyNValueProv
      )
   => NValue t f m
   -> Doc ann
-prettyNValueProv v = do
-  let ps = citations @m @(NValue t f m) v
-  case ps of
-    [] -> prettyNValue v
+prettyNValueProv v =
+  case citations @m @(NValue t f m) v of
+    [] -> prettyNVal
     ps ->
-      let v' = prettyNValue v in
       fillSep
-        [ v'
-        , indent 2
-        $ parens
-        $ mconcat
-        $ "from: "
-        : fmap (prettyOriginExpr . _originExpr) ps
+        [ prettyNVal
+        , indent 2 $
+          "(" <>
+            mconcat (
+              "from: "
+              :
+                fmap
+                  (prettyOriginExpr . _originExpr)
+                  ps
+            ) <> ")"
         ]
+ where
+  prettyNVal = prettyNValue v
 
 prettyNThunk
   :: forall t f m ann
@@ -388,8 +394,7 @@ prettyNThunk t =
       $ fillSep
           [ v'
           , indent 2 $
-              parens $
-                mconcat $ "thunk from: " : fmap (prettyOriginExpr . _originExpr) ps
+              "("<> mconcat ( "thunk from: " : fmap (prettyOriginExpr . _originExpr) ps) <> ")"
           ]
 
 -- | This function is used only by the testing code.