diff --git a/dhall-nix.cabal b/dhall-nix.cabal --- a/dhall-nix.cabal +++ b/dhall-nix.cabal @@ -1,5 +1,5 @@ Name: dhall-nix -Version: 1.1.26 +Version: 1.1.27 Cabal-Version: >=1.10 Build-Type: Simple License: BSD3 @@ -27,20 +27,20 @@ Hs-Source-Dirs: src Build-Depends: base >= 4.11.0.0 && < 5 , - containers < 0.7 , + containers < 0.8 , data-fix < 0.4 , dhall >= 1.42 && < 1.43, - hnix >= 0.16 && < 0.17, + hnix >= 0.16 && < 0.18, lens-family-core >= 1.0.0 && < 2.2 , neat-interpolation < 0.6 , - text >= 0.8.0.0 && < 2.1 + text >= 0.8.0.0 && < 2.2 Exposed-Modules: Dhall.Nix GHC-Options: -Wall Default-Language: Haskell2010 if os(windows) Buildable: False - + Executable dhall-to-nix if os(windows) Buildable: False @@ -49,11 +49,11 @@ Other-Modules: Paths_dhall_nix Build-Depends: - base , + base >= 4.11.0.0 && < 5 , dhall , dhall-nix , hnix , - optparse-generic >= 1.1.1 && < 1.5, + optparse-generic >= 1.1.1 && < 1.6, text GHC-Options: -Wall Default-Language: Haskell2010 diff --git a/src/Dhall/Nix.hs b/src/Dhall/Nix.hs --- a/src/Dhall/Nix.hs +++ b/src/Dhall/Nix.hs @@ -99,10 +99,13 @@ import Data.Foldable (toList) import Data.List.NonEmpty (NonEmpty(..)) import Data.Text (Text) +import qualified Data.Text as Text import Data.Traversable (for) import Data.Typeable (Typeable) import Data.Void (Void, absurd) import Lens.Family (toListOf) +import Numeric (showHex) +import Data.Char (ord, isDigit, isAsciiLower, isAsciiUpper) import Dhall.Core ( Binding (..) @@ -226,7 +229,7 @@ $_ERROR: Cannot project by type The ❰dhall-to-nix❱ compiler does not support projecting out a subset of a record -by the expected type (i.e. ❰someRecord.(someType)❱ +by the expected type (i.e. ❰someRecord.(someType)❱ |] show CannotShowConstructor = @@ -255,7 +258,7 @@ {-| Convert a Dhall expression to the equivalent Nix expression >>> :set -XOverloadedStrings ->>> dhallToNix (Lam "x" Natural (Lam "y" Natural (NaturalPlus "x" "y"))) +>>> dhallToNix (Lam "x" Natural (Lam "y" Natural (NaturalPlus "x" "y"))) Right (NAbs (Param "x") (NAbs (Param "y") (NBinary NPlus (NSym "x") (NSym "y")))) >>> fmap Nix.Pretty.prettyNix it Right x: y: x + y @@ -336,21 +339,17 @@ Dhall.Optics.rewriteOf Dhall.Core.subExpressions renameShadowed loop (Const _) = return untranslatable - loop (Var (V a 0)) = return (Nix.mkSym a) + loop (Var (V a 0)) = return (Nix.mkSym (zEncodeSymbol a)) loop (Var a ) = Left (CannotReferenceShadowedVariable a) loop (Lam _ FunctionBinding { functionBindingVariable = a } c) = do c' <- loop c - return (Param (VarName a) ==> c') + return (Param (VarName $ zEncodeSymbol a) ==> c') loop (Pi _ _ _ _) = return untranslatable loop (App None _) = return Nix.mkNull - loop (App (Field (Union kts) (Dhall.Core.fieldSelectionLabel -> k)) v) = do + loop (App (Field (Union _kts) (Dhall.Core.fieldSelectionLabel -> k)) v) = do v' <- loop v - let e0 = do - k' <- Dhall.Map.keys kts - return (k', Nothing) - let e2 = Nix.mkSym k @@ v' - return (Nix.mkParamset e0 False ==> e2) + return (unionChoice (VarName k) (Just v')) loop (App a b) = do a' <- loop a b' <- loop b @@ -359,7 +358,7 @@ let MultiLet bindings b = Dhall.Core.multiLet a0 b0 bindings' <- for bindings $ \Binding{ variable, value } -> do value' <- loop value - pure (variable, value') + pure (zEncodeSymbol variable, value') b' <- loop b return (Nix.letsE (toList bindings') b') loop (Annot a _) = loop a @@ -626,7 +625,7 @@ -- see https://github.com/dhall-lang/dhall-haskell/issues/2414 nixAttrs pairs = Fix $ NSet NonRecursive $ - (\(key, val) -> NamedVar (DynamicKey (Plain (DoubleQuoted [Plain key])) :| []) val Nix.nullPos) + (\(key, val) -> NamedVar ((mkDoubleQuotedIfNecessary (VarName key)) :| []) val Nix.nullPos) <$> pairs loop (Union _) = return untranslatable loop (Combine _ _ a b) = do @@ -715,20 +714,11 @@ -- (here "x"). -- -- This translates `< Foo : T >.Foo` to `x: { Foo }: Foo x` - Just (Just _) -> do - let e0 = do - k' <- Dhall.Map.keys kts - return (k', Nothing) - return ("x" ==> Nix.mkParamset e0 False ==> (Nix.mkSym k @@ "x")) - - _ -> do - let e0 = do - k' <- Dhall.Map.keys kts - return (k', Nothing) - return (Nix.mkParamset e0 False ==> Nix.mkSym k) + Just (Just _) -> return ("x" ==> (unionChoice (VarName k) (Just "x"))) + _ -> return (unionChoice (VarName k) Nothing) loop (Field a (Dhall.Core.fieldSelectionLabel -> b)) = do a' <- loop a - return (a' @. b) + return (Fix (Nix.NSelect Nothing a' (mkDoubleQuotedIfNecessary (VarName b) :| []))) loop (Project a (Left b)) = do a' <- loop a return (Nix.mkNonRecSet [ Nix.inheritFrom a' (fmap VarName b) ]) @@ -759,3 +749,129 @@ loop (ImportAlt a _) = loop a loop (Note _ b) = loop b loop (Embed x) = absurd x + +-- | Previously we turned @.Foo@ into @{ Foo, Bar }: Foo@, +-- but this would not work with .Frob/Baz (cause the slash is not a valid symbol char in nix) +-- so we generate @union: union."Frob/Baz"@ instead. +-- +-- If passArgument is @Just@, pass the argument to the union selector. +unionChoice :: VarName -> Maybe NExpr -> NExpr +unionChoice chosenKey passArgument = + let selector = Fix (Nix.NSelect Nothing (Nix.mkSym "u") (mkDoubleQuotedIfNecessary chosenKey :| [])) + in Nix.Param "u" ==> + case passArgument of + Nothing -> selector + Just arg -> selector @@ arg + + +-- | Double-quote a field name (record or union). This makes sure it’s recognized as a valid name by nix, e.g. in +-- +-- @{ "foo/bar" = 42; }."foo/bar" }@ +-- +-- where +-- +-- @{ foo/bar = 42; }.foo/bar@ is not syntactically valid nix. +-- +-- This is only done if necessary (where “necessary” is not super defined right now). +mkDoubleQuotedIfNecessary :: VarName -> NKeyName r +mkDoubleQuotedIfNecessary key@(VarName keyName) = + if Text.all simpleChar keyName + then StaticKey key + else DynamicKey (Plain (DoubleQuoted [Plain keyName])) + where + simpleChar c = isAsciiLower c || isAsciiUpper c + + +-- | Nix does not support symbols like @foo/bar@, but they are allowed in dhall. +-- So if they happen, we need to encode them with an ASCII escaping scheme. +-- +-- This is copied/inspired by the Z-Encoding scheme from GHC, see +-- https://hackage.haskell.org/package/zenc-0.1.2/docs/Text-Encoding-Z.html +-- +-- Original Source is BSD-3-Clause, Copyright (c)2011, Jason Dagit +zEncodeSymbol :: Text -> Text +zEncodeSymbol = zEncodeString + +-- | The basic encoding scheme is this: + +-- * Alphabetic characters (upper and lower) and digits +-- all translate to themselves; +-- except 'Z', which translates to 'ZZ' +-- and 'z', which translates to 'zz' +-- +-- * Most other printable characters translate to 'zx' or 'Zx' for some +-- alphabetic character x +-- +-- * The others translate as 'znnnU' where 'nnn' is the decimal number +-- of the character +-- +-- @ +-- Before After +-- -------------------------- +-- Trak Trak +-- foo-wib foozmwib +-- \> zg +-- \>1 zg1 +-- foo\# foozh +-- foo\#\# foozhzh +-- foo\#\#1 foozhzh1 +-- fooZ fooZZ +-- :+ ZCzp +-- @ +zEncodeString :: Text -> Text +zEncodeString cs = case Text.uncons cs of + Nothing -> Text.empty + Just (c, cs') -> + encodeDigitChar c + <> Text.concatMap encodeChar cs' + +-- | Whether the given characters needs to be z-encoded. +needsEncoding :: Char -> Bool +needsEncoding 'Z' = True +needsEncoding 'z' = True +needsEncoding c = not + ( isAsciiLower c + || isAsciiUpper c + || isDigit c ) + +-- If a digit is at the start of a symbol then we need to encode it. +encodeDigitChar :: Char -> Text +encodeDigitChar c | isDigit c = encodeAsUnicodeChar c +encodeDigitChar c = encodeChar c + +encodeChar :: Char -> Text +encodeChar c | not (needsEncoding c) = [c] -- Common case first + +encodeChar '(' = "ZL" +encodeChar ')' = "ZR" +encodeChar '[' = "ZM" +encodeChar ']' = "ZN" +encodeChar ':' = "ZC" +encodeChar 'Z' = "ZZ" +encodeChar 'z' = "zz" +encodeChar '&' = "za" +encodeChar '|' = "zb" +encodeChar '^' = "zc" +encodeChar '$' = "zd" +encodeChar '=' = "ze" +encodeChar '>' = "zg" +encodeChar '#' = "zh" +encodeChar '.' = "zi" +encodeChar '<' = "zl" +-- we can’t allow @-@, because it is not valid at the start of a symbol +encodeChar '-' = "zm" +encodeChar '!' = "zn" +encodeChar '+' = "zp" +encodeChar '\'' = "zq" +encodeChar '\\' = "zr" +encodeChar '/' = "zs" +encodeChar '*' = "zt" +-- We can allow @_@ because it can appear anywhere in a symbol +-- encodeChar '_' = "zu" +encodeChar '%' = "zv" +encodeChar c = encodeAsUnicodeChar c + +encodeAsUnicodeChar :: Char -> Text +encodeAsUnicodeChar c = 'z' `Text.cons` if isDigit (Text.head hex_str) then hex_str + else '0' `Text.cons` hex_str + where hex_str = Text.pack $ showHex (ord c) "U"