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.6 +Version: 1.1.7 Cabal-Version: >=1.8.0.2 Build-Type: Simple Tested-With: GHC == 8.0.1 @@ -28,11 +28,10 @@ Hs-Source-Dirs: src Build-Depends: base >= 4.8.0.0 && < 5 , - containers < 0.6 , + containers < 0.7 , data-fix < 0.3 , - dhall >= 1.15 && < 1.18, - hnix >= 0.5 && < 0.6 , - insert-ordered-containers >= 0.1.0.1 && < 0.3 , + dhall >= 1.25 && < 1.26, + hnix >= 0.6.1 && < 0.7 , neat-interpolation < 0.4 , text >= 0.8.0.0 && < 1.3 Exposed-Modules: diff --git a/src/Dhall/Nix.hs b/src/Dhall/Nix.hs --- a/src/Dhall/Nix.hs +++ b/src/Dhall/Nix.hs @@ -45,10 +45,10 @@ `Optional` values translate to @null@ if missing or the unwrapped value if present: -> $ dhall-to-nix <<< "[] : Optional Integer" +> $ dhall-to-nix <<< "None Natural" > null -> $ dhall-to-nix <<< "[1] : Optional Integer" +> $ dhall-to-nix <<< "Some 1" > 1 Unions are Church-encoded: @@ -56,9 +56,6 @@ > $ dhall-to-nix <<< "< Left = True | Right : Natural >" > { Left, Right }: Left true - `Dhall.Core.Double`s cannot be translated to Nix at all since Nix does not - support floating point values. - Also, all Dhall expressions are normalized before translation to Nix: > $ dhall-to-nix <<< "True == False" @@ -93,10 +90,10 @@ , CompileError(..) ) where -import Control.Applicative (empty) import Control.Exception (Exception) import Data.Foldable (toList) import Data.Fix (Fix(..)) +import Data.Traversable (for) import Data.Typeable (Typeable) import Dhall.Core (Chunks(..), Const(..), Expr(..), Var(..)) import Dhall.TypeCheck (X(..)) @@ -109,11 +106,14 @@ , NKeyName(..) , NString(..) , Params(..) + , (@@) + , (==>) + , ($+) ) -import qualified Data.HashMap.Strict.InsOrd import qualified Data.Text import qualified Dhall.Core +import qualified Dhall.Map import qualified NeatInterpolation import qualified Nix @@ -123,8 +123,8 @@ data CompileError = CannotReferenceShadowedVariable Var -- ^ Nix does not provide a way to reference a shadowed variable - | UnexpectedConstructorsKeyword - -- ^ The @constructors@ keyword is not yet supported + | CannotProjectByType + -- ^ We currently do not support threading around type information deriving (Typeable) instance Show CompileError where @@ -180,19 +180,14 @@ where txt = Dhall.Core.pretty v - show UnexpectedConstructorsKeyword = + show CannotProjectByType = Data.Text.unpack [NeatInterpolation.text| -$_ERROR: Unexpected ❰constructors❱ keyword +$_ERROR: Cannot project by type -Explanation: The dhallToNix Haskell API function has a precondition that the -Dhall expression to translate to Nix must have already been type-checked. This -precondition ensures that the normalized expression will have no remaining -❰constructors❱ keywords. +The ❰dhall-to-nix❱ compiler does not support projecting out a subset of a record +by the expected type (i.e. ❰someRecord.(someType)❱ + |] -However, the dhallToNix Haskell API function was called with a Dhall expression -that still had a ❰constructors❱ keyword, which indicates that the expression had -not yet been type-checked. -|] _ERROR :: Data.Text.Text _ERROR = "\ESC[1;31mError\ESC[0m" @@ -220,14 +215,26 @@ c' <- loop c return (Fix (NAbs (Param a) c')) loop (Pi _ _ _) = return (Fix (NSet [])) + -- None needs a type to convert to an Optional + loop (App None _) = do + return (Fix (NConstant NNull)) + loop (App (Field (Union kts) k) v) = do + v' <- loop v + let e0 = do + k' <- Dhall.Map.keys kts + return (k', Nothing) + let e2 = Fix (NBinary NApp (Fix (NSym k)) v') + return (Fix (NAbs (ParamSet e0 False Nothing) e2)) loop (App a b) = do a' <- loop a b' <- loop b return (Fix (NBinary NApp a' b')) - loop (Let a _ c d) = do - c' <- loop c - d' <- loop d - return (Fix (NLet [NamedVar [StaticKey a] c' Nix.nullPos] d')) + loop (Let as b) = do + as' <- for as $ \a -> do + val <- loop $ Dhall.Core.value a + pure $ NamedVar [StaticKey $ Dhall.Core.variable a] val Nix.nullPos + b' <- loop b + return (Fix (NLet (toList as') b')) loop (Annot a _) = loop a loop Bool = return (Fix (NSet [])) loop (BoolLit b) = return (Fix (NConstant (NBool b))) @@ -330,6 +337,37 @@ a' <- loop a b' <- loop b return (Fix (NBinary NPlus a' b')) + loop TextShow = do + let from = + Nix.mkList + [ Nix.mkStr "\"" + , Nix.mkStr "$" + , Nix.mkStr "\\" + -- Nix doesn't support \b and \f + -- , Nix.mkStr "\b" + -- , Nix.mkStr "\f" + , Nix.mkStr "\n" + , Nix.mkStr "\r" + , Nix.mkStr "\t" + ] + + let to = + Nix.mkList + [ Nix.mkStr "\\\"" + , Nix.mkStr "\\u0024" + , Nix.mkStr "\\\\" + -- , Nix.mkStr "\\b" + -- , Nix.mkStr "\\f" + , Nix.mkStr "\\n" + , Nix.mkStr "\\r" + , Nix.mkStr "\\t" + ] + + let replaced = "builtins.replaceStrings" @@ from @@ to @@ "t" + + let quoted = Nix.mkStr "\"" $+ replaced $+ Nix.mkStr "\"" + + return ("t" ==> quoted) loop List = return (Fix (NAbs "t" (Fix (NSet [])))) loop (ListAppend a b) = do a' <- loop a @@ -383,10 +421,8 @@ let e6 = Fix (NAbs "xs" (Fix (NLet [NamedVar ["n"] e5 Nix.nullPos] e4))) return (Fix (NAbs "t" e6)) loop Optional = return (Fix (NAbs "t" (Fix (NSet [])))) - loop (OptionalLit _ b) = - case b of - Nothing -> return (Fix (NConstant NNull)) - Just c -> loop c + loop (Some a) = loop a + loop None = return (Fix (NConstant NNull)) loop OptionalFold = do let e0 = Fix (NBinary NEq "x" (Fix (NConstant NNull))) let e1 = Fix (NIf e0 "nothing" (Fix (NBinary NApp "just" "x"))) @@ -396,22 +432,22 @@ let e0 = Pi "nothing" "optional" "optional" let e1 = Pi "just" (Pi "_" "a" "optional") e0 let e2 = Pi "optional" (Const Type) e1 - let e3 = OptionalLit "a" empty - let e4 = Lam "x" "a" (OptionalLit "a" (pure "x")) + let e3 = App None "a" + let e4 = Lam "x" "a" (Some "x") let e5 = App (App (App "f" (App Optional "a")) e4) e3 loop (Lam "a" (Const Type) (Lam "f" e2 e5)) loop (Record _) = return (Fix (NSet [])) loop (RecordLit a) = do a' <- traverse loop a let a'' = do - (k, v) <- Data.HashMap.Strict.InsOrd.toList a' + (k, v) <- Dhall.Map.toList a' return (NamedVar [StaticKey k] v Nix.nullPos) return (Fix (NSet a'')) loop (Union _) = return (Fix (NSet [])) loop (UnionLit k v kts) = do v' <- loop v let e0 = do - k' <- k : Data.HashMap.Strict.InsOrd.keys kts + k' <- k : Dhall.Map.keys kts return (k', Nothing) let e2 = Fix (NBinary NApp (Fix (NSym k)) v') return (Fix (NAbs (ParamSet e0 False Nothing) e2)) @@ -461,19 +497,39 @@ a' <- loop a b' <- loop b return (Fix (NBinary NApp b' a')) - loop (Constructors _) = do - Left UnexpectedConstructorsKeyword loop (Prefer a b) = do a' <- loop a b' <- loop b return (Fix (NBinary NUpdate a' b')) + loop (Field (Union kts) k) = + case Dhall.Map.lookup k kts of + -- If the selected alternative has an associated payload, then we + -- need introduce the partial application through an extra abstraction + -- (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) + let e2 = Fix (NBinary NApp (Fix (NSym k)) (Fix (NSym "x"))) + return (Fix (NAbs (Param "x") (Fix (NAbs (ParamSet e0 False Nothing) e2)))) + + _ -> do + let e0 = do + k' <- Dhall.Map.keys kts + return (k', Nothing) + let e2 = Fix (NSym k) + return (Fix (NAbs (ParamSet e0 False Nothing) e2)) loop (Field a b) = do a' <- loop a return (Fix (NSelect a' [StaticKey b] Nothing)) - loop (Project a b) = do + loop (Project a (Left b)) = do a' <- loop a let b' = fmap StaticKey (toList b) return (Fix (NSet [Inherit (Just a') b' Nix.nullPos])) + loop (Project _ (Right _)) = do + Left CannotProjectByType loop (ImportAlt a _) = loop a loop (Note _ b) = loop b loop (Embed (X x)) = x