purenix (empty) → 1.0

raw patch · 11 files changed

+954/−0 lines, 11 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, containers, directory, filepath, microlens-platform, mtl, pretty-simple, purenix, purescript, purescript-cst, text

Files

• CHANGELOG.md +9/−0
• LICENSE +29/−0
• README.md +115/−0
• app/Main.hs +4/−0
• purenix.cabal +60/−0
• src/PureNix/Convert.hs +225/−0
• src/PureNix/Expr.hs +123/−0
• src/PureNix/Identifiers.hs +118/−0
• src/PureNix/Main.hs +48/−0
• src/PureNix/Prelude.hs +19/−0
• src/PureNix/Print.hs +204/−0

@@ -0,0 +1,9 @@+# Changelog++Versioning is `MAJOR.MINOR`.+Major changes are generally backwards-incompatible changes to the interface, minor changes are incremental improvements.++## 1.0++### [Added]+- Initial release

@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2021, Dennis Gosnell, Jonas Carpay+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the documentation+   and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+   contributors may be used to endorse or promote products derived from+   this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,115 @@+<p align="center">+  <img src="img/purenix-icon.svg" width="150" height="150" />+</ p>+<h1 align="center">PureNix</h1>++PureNix is a Nix backend for PureScript.++Sometimes, you find yourself having to write Nix code that's more complicated than what the language was designed for.+PureNix allows you to write that code in a fully-featured, strongly-typed language instead, and then compile to Nix.+A typical example is parsing of configuration files, like [the port of cabal2nix that inspired PureNix](https://github.com/cdepillabout/cabal2nixWithoutIFD).++PureNix has full support for all of PureScript's features, including data types, type classes, and calling back into Nix using the FFI.++On the [organization page for PureNix](https://github.com/purenix-org) you will find a number of packages intended to be used with PureNix, including ports of libraries like [purescript-prelude](https://github.com/purenix-org/purescript-prelude).++## Code sample++PureScript source, `Main.purs`:++```purescript+module Main where++import Data.A as A+import Data.B as B++greeting :: String+greeting = "Hello, world!"++data Maybe a = Nothing | Just a++fromMaybe :: forall a. a -> Maybe a -> a+fromMaybe a Nothing = a+fromMaybe _ (Just a) = a++foreign import add :: Int -> Int -> Int++foo :: Int+foo = add A.bar B.baz+```++Nix FFI file, `Main.nix`:++```nix+{ add = a: b: a + b; }+```++Generated Nix:++```nix+let+  module = +    { "Data.A" = import ../Data.A;+      "Data.B" = import ../Data.B;+    };+  foreign = import ./foreign.nix;+  add = foreign.add;+  Nothing = {__tag = "Nothing";};+  Just = value0: +    { __tag = "Just";+      __field0 = value0;+    };+  greeting = "Hello, world!";+  fromMaybe = v: v1: +    let+      __pattern0 = __fail: if v1.__tag == "Nothing" then let a = v; in a else __fail;+      __pattern1 = __fail: if v1.__tag == "Just" then let a = v1.__field0; in a else __fail;+      __patternFail = builtins.throw "Pattern match failure in src/Main.purs at 11:1 - 11:41";+    in+      __pattern0 (__pattern1 __patternFail);+  foo = add module."Data.A".bar module."Data.B".baz;+in+  {inherit greeting Nothing Just fromMaybe add foo;}+```++There are a couple things to notice here:++- PureScript built-in types like `String`, `Int`, objects, and lists are converted to their corresponding Nix types, as in `greeting`.+- Data constructors from sum types are available to easily work with in the output Nix file, like `Just` and `Nothing`, although you might want to define named field accessors.+- Foreign imports are straightforward to define and use, like in `add` and `foo`. The FFI file gets copied into the module's output directory as `foreign.nix`.++## Usage++The easiest way to use PureNix is through Spago.+Simply set `backend = "purenix"`, make sure `purenix` is available in the `PATH`, and build as normal.++When you run `purenix`, manually or through Spago, it will look for the Purescript output directory `./output` in the current working directory.+It then traverses this directory structure, looks for Purescript's intermediate `corefn.json` files, transpiles the `corefn.json` files to the equivalent Nix code, and writes the output Nix code to `default.nix`.++## Warnings++### What PureNix is and is not++PureNix allows you to write code in PureScript, and then compile to Nix.+The degree to which you can replace existing Nix code depends on how well you can express that code in PureScript.+For some things, that's pretty easy, but there are many things in Nix and nixpkgs that are much harder to provide (useful) types for.+As such, PureNix is _not_ a complete typed replacement for Nix.+The goal for now is simply to allow you to take code that's tricky to write in an untyped language, and write it in a typed language instead.++[The ecosystem around PureNix](https://github.com/purenix-org) is currently focused on providing PureNix ports of existing PureScript libraries.+Over time, we hope to expand in the other direction as well, with libraries that provide typed versions of Nix-only constructs, thereby expanding the amount of Nix you can feasibly replace with PureNix, but there's still a lot to be done.+Any help is welcome!++### Laziness and memory management++PureScript generally assumes that its backends perform strict evaluation, and some degree of memory management.+Nix is a lazy language however, and is happy to leak memory.+For most use cases this doesn't cause any issues, and in fact the laziness allows you to write more Haskell-like code than you usually would in PureScript.++Still, it's good to keep these things in mind:++- Like in every lazy language, you need to watch out for space leaks caused by accidentally building up large thunks.+  PureScript does not natively have tools to deal with laziness, like bang patterns or `seq`, but you can define them yourself by e.g. pulling in `builtins.seq` through the FFI.++- Long-running programs may run out of memory due to the lack of garbage collection and tail recursion.+  If you end up writing long-running programs, like a parser that needs to process very large files, you might have to rewrite it in a way that minimizes recursion and allocation.

@@ -0,0 +1,4 @@+import PureNix.Main++main :: IO ()+main = defaultMain

@@ -0,0 +1,60 @@+cabal-version:   2.4+name:            purenix+version:         1.0+license:         BSD-3-Clause+build-type:      Simple+license-file:    LICENSE+-- category:+-- description:     description+synopsis:        Nix backend for PureScript.  Transpile PureScript code to Nix.+author:          Dennis Gosnell, Jonas Carpay+maintainer:      Dennis Gosnell <cdep.illabout@gmail.com>+copyright:       2021 Dennis Gosnell, Jonas Carpay+homepage:        https://github.com/purenix-org/purenix+tested-with:     GHC ==8.10.4+extra-doc-files:+  CHANGELOG.md+  README.md++source-repository head+  type:     git+  location: git://github.com/purenix-org/purenix++common common-options+  build-depends:    base >=4.9 && <5+  default-language: Haskell2010+  ghc-options:+    -Wall -Wcompat -Widentities -Wincomplete-uni-patterns+    -Wincomplete-record-updates -Wredundant-constraints+    -fhide-source-paths -Wpartial-fields++library+  import:          common-options+  hs-source-dirs:  src+  exposed-modules:+    PureNix.Convert+    PureNix.Expr+    PureNix.Identifiers+    PureNix.Main+    PureNix.Prelude+    PureNix.Print++  build-depends:+    , aeson+    , bytestring+    , containers+    , directory+    , filepath+    , microlens-platform+    , mtl+    , pretty-simple+    , purescript          ==0.14.4+    , purescript-cst+    , text++executable purenix+  import:         common-options+  hs-source-dirs: app+  main-is:        Main.hs+  build-depends:  purenix+  ghc-options:    -threaded -rtsopts -with-rtsopts=-N

@@ -0,0 +1,225 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}++module PureNix.Convert (convert, ModuleInfo (..)) where++import Data.Bitraversable+import qualified Data.Map as M+import Data.Set (Set)+import qualified Data.Set as S+import qualified Data.Text as T+import Data.Text.Internal.Search (indices)+import Language.PureScript (Ident (..))+import qualified Language.PureScript as P+import Language.PureScript.CoreFn+import Language.PureScript.Errors (SourceSpan)+import Language.PureScript.PSString (PSString (toUTF16CodeUnits))+import qualified PureNix.Expr as N+import qualified PureNix.Identifiers as N+import PureNix.Prelude++-- | The monad conversion runs in.+-- Conversion is per-module, which means that only the SourceSpan part of the ReaderT ever changes during conversion.+-- The StateT actually fuffills the role of a CPS'd WriterT.+type Convert = ReaderT (FilePath, P.ModuleName, SourceSpan) (State ModuleInfo)++-- | Represents the information collected about a module during conversion.+-- It is intended to be used in a WriterT-style fashion, which is why it has a 'Monoid' instance.+data ModuleInfo = ModuleInfo+  { -- | Whether the module has any FFI declarations.+    -- In the 'Monoid' instance, this behaves like an 'Data.Monoid.Any'.+    usesFFI :: Bool,+    -- | Locations of strings that appear to perform string interpolation.+    interpolatedStrings :: Set SourceSpan+  }+  deriving (Eq, Show)++instance Semigroup ModuleInfo where ModuleInfo fa ia <> ModuleInfo fb ib = ModuleInfo (fa || fb) (ia <> ib)++instance Monoid ModuleInfo where mempty = ModuleInfo False mempty++tell :: ModuleInfo -> Convert ()+tell m = modify (mappend m)++-- | The central PureScript-to-Nix conversion function for a single PureScript module.+convert :: Module Ann -> (N.Expr, ModuleInfo)+convert (Module spn _comments name path imports exports reexports foreign' decls) =+  flip runState mempty $+    flip runReaderT (path, name, spn) $+      module' name imports exports reexports foreign' decls++localSpan :: SourceSpan -> Convert a -> Convert a+localSpan spn = local (fmap $ const spn)++localAnn :: Ann -> Convert a -> Convert a+localAnn (spn, _, _, _) = localSpan spn++{-# ANN module' ("hlint: ignore Use list comprehension" :: String) #-}+module' ::+  P.ModuleName ->+  [(Ann, P.ModuleName)] ->+  [Ident] ->+  Map P.ModuleName [Ident] ->+  [Ident] ->+  [Bind Ann] ->+  Convert N.Expr+module' thisModule imports exports reexports foreign' decls = do+  let importBinding =+        let attrs =+              [ (N.moduleKey mdl, N.app (N.var "import") (N.path ("../" <> P.runModuleName mdl)))+                | (_, mdl) <- imports,+                  mdl /= thisModule,+                  mdl /= P.ModuleName "Prim"+              ]+         in ("module", N.attrs [] [] attrs)+      ffiBinds = foreignBinding <$> foreign'+      expts = N.mkVar <$> exports+      reexpts = uncurry inheritFrom <$> M.toList reexports+  ffiFileBinding <-+    if null foreign'+      then pure []+      else [("foreign", N.app (N.var "import") (N.path "./foreign.nix"))] <$ tell mempty {usesFFI = True}+  binds <- bindings decls+  pure $+    N.let'+      (importBinding : ffiFileBinding <> ffiBinds <> binds)+      (N.attrs expts reexpts mempty)+  where+    inheritFrom :: P.ModuleName -> [Ident] -> (N.Expr, [N.Key])+    inheritFrom m exps = (N.sel (N.var "module") (N.moduleKey m), N.identKey <$> exps)++    foreignBinding :: Ident -> (N.Var, N.Expr)+    foreignBinding ffiIdent = (N.mkVar ffiIdent, N.sel (N.var "foreign") (N.identKey ffiIdent))++bindings :: [Bind Ann] -> Convert [(N.Var, N.Expr)]+bindings = traverse binding . (>>= flatten)+  where+    binding :: (Ann, Ident, Expr Ann) -> Convert (N.Var, N.Expr)+    binding (ann, i, e) = localAnn ann $ fmap (N.mkVar i,) (expr e)+    flatten :: Bind a -> [(a, Ident, Expr a)]+    flatten (NonRec a i e) = [(a, i, e)]+    flatten (Rec bs) = (\((a, i), e) -> (a, i, e)) <$> bs++expr :: Expr Ann -> Convert N.Expr+expr (Abs ann arg body) = localAnn ann $ fmap (N.lam (N.mkVar arg)) (expr body)+expr (Literal ann lit) = localAnn ann $ literal lit+-- Newtype wrappers can always be removed.+expr (App ann (Var (_, _, _, Just IsNewtype) _) x) = localAnn ann (expr x)+expr (App ann f x) = localAnn ann $ liftA2 N.app (expr f) (expr x)+expr (Var ann (P.Qualified mqual name)) = localAnn ann $ do+  (_, thisModule, _) <- ask+  pure $ case mqual of+    Just qual+      | qual /= thisModule -> N.sel (N.sel (N.var "module") (N.moduleKey qual)) (N.identKey name)+    _ -> N.var (N.mkVar name)+expr (Accessor ann sel body) = localAnn ann $ flip N.sel (N.stringKey sel) <$> expr body+expr (Let ann binds body) = localAnn ann $ liftA2 N.let' (bindings binds) (expr body)+expr (ObjectUpdate ann a b) = localAnn ann $ liftA2 (N.bin N.Update) (expr a) (attrs b)+expr (Constructor _ _ (P.ProperName dataName) fields) = pure $ N.constructor dataName (N.mkVar <$> fields)+expr (Case ann exprs cases) =+  localAnn ann $ do+    exprs' <- traverse expr exprs+    cases' <- traverse (alternative exprs') cases+    (fp, _, spn) <- ask+    let patternCases = zip (N.numberedVars "__pattern") cases'+        patternFail =+          ( "__patternFail",+            N.app+              (N.builtin "throw")+              (N.string $ T.concat ["Pattern match failure in ", T.pack fp, " at ", P.displayStartEndPosShort spn])+          )+        patterns = patternCases <> [patternFail]+    pure $+      N.let'+        patterns+        (foldr1 N.app (N.var . fst <$> patterns))++-- | Generates a matcher for a given case alternative, against the given list of scrutinees.+-- A matcher takes a failure continuation, and either calls the expression body with the matched names in scope, or if the matcher fails, the failure continutation.+alternative :: [N.Expr] -> CaseAlternative Ann -> Convert N.Expr+alternative scrutinees = go+  where+    go (CaseAlternative binders body) = do+      (patternChecks, patternBinds) <- zipBinders scrutinees binders+      body' <- unguard body (N.var "__fail")+      pure $+        N.lam "__fail" $+          case patternChecks of+            [] -> N.let' patternBinds body'+            _ ->+              N.cond+                (foldr1 (N.bin N.And) patternChecks)+                (N.let' patternBinds body')+                (N.var "__fail")++-- | Generates a matcher (see 'alternative') for a potentially guarded 'CaseAlternative' body.+-- For guards, we test every guard in order with the failure continuation as the final case.+unguard :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> N.Expr -> Convert N.Expr+unguard (Right body) _ = expr body+unguard (Left guardedBodies) failCase = do+  guardedBodies' <- traverse (bitraverse expr expr) guardedBodies+  pure $ foldr (uncurry N.cond) failCase guardedBodies'++zipBinders :: [N.Expr] -> [Binder Ann] -> Convert ([N.Expr], [(N.Var, N.Expr)])+zipBinders exprs binds = mconcat <$> zipWithM unbinder binds exprs++-- | Turns a binder(/pattern) and a scrutinee into a pair of+--   - boolean expressions, that all return true iff the pattern applies+--   - the bindings produced by the pattern+unbinder :: Binder Ann -> N.Expr -> Convert ([N.Expr], [(N.Var, N.Expr)])+unbinder (NullBinder _) _ = pure mempty+unbinder (VarBinder _ name) scrut = pure $ (\name' -> ([], [(name', scrut)])) $ N.mkVar name+unbinder (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [field]) scrut = unbinder field scrut+unbinder (ConstructorBinder ann _ (P.Qualified _ (P.ProperName tag)) fields) scrut =+  localAnn ann $+    mappend ([N.bin N.Equals (N.sel scrut "__tag") (N.string tag)], []) . mconcat <$> zipWithM (\binder field -> unbinder binder (N.sel scrut field)) fields (N.numberedKeys "__field")+unbinder (NamedBinder ann name binder) scrut = localAnn ann $ do+  mappend ([], [(N.mkVar name, scrut)]) <$> unbinder binder scrut+unbinder (LiteralBinder ann lit) scrut' = localAnn ann $ litBinder lit scrut'+  where+    litBinder :: Literal (Binder Ann) -> N.Expr -> Convert ([N.Expr], [(N.Var, N.Expr)])+    litBinder (NumericLiteral (Left n)) scrut = pure ([N.bin N.Equals scrut (N.int n)], [])+    litBinder (NumericLiteral (Right x)) scrut = pure ([N.bin N.Equals scrut (N.double x)], [])+    litBinder (StringLiteral str) scrut = (\str' -> ([N.bin N.Equals scrut (N.string str')], [])) <$> string str+    litBinder (CharLiteral char) scrut = pure ([N.bin N.Equals scrut (N.string (T.singleton char))], [])+    litBinder (BooleanLiteral True) scrut = pure ([scrut], [])+    litBinder (BooleanLiteral False) scrut = pure ([N.not' scrut], [])+    litBinder (ArrayLiteral as) scrut =+      mappend ([N.bin N.Equals (N.app (N.builtin "length") scrut) (N.int (fromIntegral n))], []) . mconcat+        <$> zipWithM (\binder ix -> unbinder binder (elemAt scrut ix)) as [0 :: Integer ..]+      where+        n = length as+        elemAt list ix = N.app (N.app (N.builtin "elemAt") list) (N.int ix)+    litBinder (ObjectLiteral fields) scrut = mconcat <$> traverse (\(field, binder) -> unbinder binder (N.sel scrut (N.stringKey field))) fields++attrs :: [(PSString, Expr Ann)] -> Convert N.Expr+attrs = fmap (N.attrs [] []) . traverse attr+  where+    attr (string, body) = (N.stringKey string,) <$> expr body++string :: PSString -> Convert Text+string str = do+  let decoded = T.pack . map (toEnum . fromIntegral) . toUTF16CodeUnits $ str+  when (mightContainInterpolation decoded) $ do+    (_, _, spn) <- ask+    tell mempty {interpolatedStrings = S.singleton spn}+  pure decoded+  where+    -- Performs a _very_ rudimentary check for interpolation:+    -- Simply checks if "${" occurs in the string, and if so, there's a "}" occurring later in the string.+    -- This does not account for any possible escaping/quoting.+    mightContainInterpolation :: Text -> Bool+    mightContainInterpolation t = case indices "${" t of+      [] -> False+      (ixOpen : _) -> any (> ixOpen) $ indices "}" t++literal :: Literal (Expr Ann) -> Convert N.Expr+literal (NumericLiteral (Left n)) = pure $ N.int n+literal (NumericLiteral (Right n)) = pure $ N.double n+literal (StringLiteral str) = N.string <$> string str+literal (CharLiteral chr) = pure $ N.string $ T.singleton chr+literal (BooleanLiteral b) = pure $ bool (N.var "false") (N.var "true") b+literal (ArrayLiteral arr) = N.list <$> traverse expr arr+literal (ObjectLiteral obj) = attrs obj

@@ -0,0 +1,123 @@+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | Nix expression types and auxiliary functions.+-- Since 'Expr' is actually a fixpoint over the 'ExprF' base functor, this+-- module also exposes auxiliary functions that serve as constructors.+module PureNix.Expr where++import Data.List.NonEmpty (NonEmpty (..))+import PureNix.Identifiers+import PureNix.Prelude++-- | The fixpoint over 'ExprF', see haddocks there for more information.+newtype Expr = Expr {unExpr :: ExprF Expr}+  -- Explicitly using the @newtype@ strategy here makes the 'Show' instance+  -- much nicer, since it makes it so you don't get all the @Expr@+  -- constructors.+  deriving newtype (Show)++-- | Base functor for a Nix expression.+-- We don't aim to be able to represent every valid Nix expression, just the+-- ones that are relevant for PureNix.+--+-- 'ExprF' is the base functor for the 'Expr' fixpoint.+-- This allows us to easily annotate and consume it during pretty-printing.+--+-- Note that 'String', unlike 'Key' and 'Var', is a raw representation of the intended string, completely unquoted and unescaped.+-- That means that it might consist of, for example, a single '"'.+-- It is the job of the printer to figure out how to correctly escape those.+data ExprF f+  = Var Var+  | Lam Var f+  | App f f+  | Attrs [Var] [(f, [Key])] [(Key, f)]+  | Cond f f f+  | List [f]+  | Bin Op f f+  | Not f+  | Sel f Key+  | Let (NonEmpty (Var, f)) f+  | Int Integer+  | Double Double+  | String Text+  | Path Text+  deriving stock (Functor, Foldable, Traversable, Show)++data Op = Update | Equals | And+  deriving (Eq, Show)++foldExpr :: (ExprF r -> r) -> Expr -> r+foldExpr f = go where go = f . fmap go . unExpr++var :: Var -> Expr+var = Expr . Var++lam :: Var -> Expr -> Expr+lam arg body = Expr $ Lam arg body++app :: Expr -> Expr -> Expr+app f x = Expr $ App f x++cond :: Expr -> Expr -> Expr -> Expr+cond c true false = Expr $ Cond c true false++attrs ::+  [Var] ->+  [(Expr, [Key])] ->+  [(Key, Expr)] ->+  Expr+attrs inherits inheritFroms binds = Expr $ Attrs inherits inheritFroms binds++sel :: Expr -> Key -> Expr+sel e s = Expr $ Sel e s++let' :: [(Var, Expr)] -> Expr -> Expr+let' [] body = body+let' (h : t) body = Expr $ Let (h :| t) body++int :: Integer -> Expr+int = Expr . Int++double :: Double -> Expr+double = Expr . Double++string :: Text -> Expr+string = Expr . String++list :: [Expr] -> Expr+list = Expr . List++bin :: Op -> Expr -> Expr -> Expr+bin op a b = Expr $ Bin op a b++path :: Text -> Expr+path = Expr . Path++constructorFieldNames :: [Var]+constructorFieldNames = numberedVars "__field"++not' :: Expr -> Expr+not' = Expr . Not++-- | Convenience constructor for builtins.+-- Takes a Key, and gives you @builtins.key@+builtin :: Key -> Expr+builtin = sel (var "builtins")++--   Just+-- becomes+--   (a: { __tag = "Just"; __field0 = a; })+constructor :: Text -> [Var] -> Expr+constructor conName fields =+  foldr+    lam+    ( attrs+        []+        []+        (("__tag", string conName) : zipWith (\arg (UnsafeVar name) -> (UnsafeKey name, var arg)) fields constructorFieldNames)+    )+    fields

@@ -0,0 +1,118 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++-- | This module defines the types and conversions from PureScript/CoreFn identifiers to Nix identifiers.+-- This can be a tricky problem, since all three languages have different rules for what is and isn't allowed in certain kinds of identifiers.+-- The goal of this module is to provide an API that takes care of all those concerns.+-- In other words, the types in this module are as close to ready-to-print as possible.+--+-- The reasoning is that 'Key' and 'Var' are intended to be used in 'Expr'.+-- 'Expr' should represent a _valid_ Nix expression, and therefore 'Key' and 'Var' need to represent valid keys and binders, respectively.+-- We don't have to care about rejecting nonsensical values during printing.+--+-- Nix's rules for naked (non-quoted) identifiers are strictly more lenient than PureScripts (see links to specifications below), since nix allows '-' in identifiers (they cannot start with a '-' though).+-- Unfortunately, that doesn't mean we can just naively convert identifiers, for example:+--  - generated identifiers such as dictionary names in CoreFn can contain '$'+--  - module names can contain '.'+--  - keys might be quoted+--  - we shouldn't shadow Nix keywords, especially those that aren't also PureScript keywords+--  - we reserve any identifier starting with two leading underscores+--+-- Purescript identifiers:+-- https://github.com/purescript/purescript/blob/master/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs#L689+-- Nix identifiers:+-- https://github.com/cstrahan/tree-sitter-nix/blob/master/src/grammar.json#L19+module PureNix.Identifiers+  ( Var (..),+    mkVar,+    numberedVars,+    Key (..),+    identKey,+    stringKey,+    moduleKey,+    binderKey,+    numberedKeys,+  )+where++import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as Set+import Data.String+import Data.Text (Text)+import qualified Data.Text as T+import qualified Language.PureScript as PS+import qualified Language.PureScript.PSString as PS++-- TODO rename to Binder, since this can occur in the LHS of a let-binding++-- | A valid (i.e. containing no illegal characters) variable binder.+-- Primarily constructed using 'mkVar'.+newtype Var = UnsafeVar {unVar :: Text}+  deriving newtype (IsString, Eq, Show)++identToText :: PS.Ident -> Text+identToText (PS.Ident t) = t+-- GenIdent is only used in PureScript for "unnamed" instances.+-- Originally, in PureScript, all instances needed to be named:+-- https://github.com/purescript/documentation/blob/master/language/Differences-from-Haskell.md#named-instances+-- This was relaxed in 0.14.2:+-- https://github.com/purescript/purescript/pull/4096+identToText (PS.GenIdent mvar n) = fromMaybe "__instance" mvar <> T.pack (show n)+identToText PS.UnusedIdent = error "impossible"++-- | Make a Nix variable binder from a CoreFn binder.+--+-- If a binder is a Nix keyword, we tick the binder with a hyphen.+-- Since PureScript does not allow binders to contain hyphens, this should be safe.+--+-- Additionally, CoreFn can put dollar signs in generated names.+-- We simply drop leading dollar signs, and the rest we convert to hyphens.+mkVar :: PS.Ident -> Var+mkVar = UnsafeVar . removeDollarSigns . tickKeywords . identToText+  where+    tickKeywords w+      | Set.member w keywords || T.isPrefixOf "__" w = w <> "-"+      | otherwise = w+    removeDollarSigns w =+      T.map (\c -> if c == '$' then '-' else c) $+        if T.isPrefixOf "$" w then T.tail w else w++keywords :: Set Text+keywords = Set.fromList (purenixIdents <> nixPrimops <> nixKeywords)+  where+    purenixIdents = ["module", "foreign"]+    -- These are not keywords in the sense that they can be shadowed+    -- For example, let true = false; in true is valid Nix.+    nixPrimops = ["builtins", "import", "false", "true"]+    -- keywords in nix:+    -- https://github.com/NixOS/nix/blob/90b2dd570cbd8313a8cf45b3cf66ddef2bb06e07/src/libexpr/lexer.l#L115-L124+    nixKeywords :: [Text]+    nixKeywords =+      ["if", "then", "else", "assert", "with", "let", "in", "rec", "inherit", "or"]++-- | A valid Nix attribute key+newtype Key = UnsafeKey {unKey :: Text}+  deriving newtype (IsString, Eq, Show)++moduleKey :: PS.ModuleName -> Key+moduleKey (PS.ModuleName mdl) = UnsafeKey $ "\"" <> mdl <> "\""++identKey :: PS.Ident -> Key+identKey = UnsafeKey . unVar . mkVar++stringKey :: PS.PSString -> Key+stringKey = UnsafeKey . PS.prettyPrintObjectKey++binderKey :: Var -> Key+binderKey = UnsafeKey . unVar++numberedText :: Text -> [Text]+numberedText prefix = fmap (\n -> prefix <> T.pack (show n)) [0 :: Int ..]++numberedVars :: Text -> [Var]+numberedVars = fmap UnsafeVar . numberedText++numberedKeys :: Text -> [Key]+numberedKeys = fmap UnsafeKey . numberedText

@@ -0,0 +1,48 @@+{-# LANGUAGE NoImplicitPrelude #-}++module PureNix.Main where++import qualified Data.Aeson as Aeson+import Data.Aeson.Types (parseEither)+import Data.Foldable (toList)+import Data.List (intercalate)+import qualified Data.Text.Lazy.IO as TL+import qualified Language.PureScript.CoreFn as P+import Language.PureScript.CoreFn.FromJSON (moduleFromJSON)+import PureNix.Convert (ModuleInfo (ModuleInfo), convert)+import PureNix.Prelude+import PureNix.Print (renderExpr)+import qualified System.Directory as Dir+import qualified System.Exit as Sys+import System.FilePath ((</>))+import qualified System.FilePath as FP+import System.IO++defaultMain :: IO ()+defaultMain = do+  let workdir = "."+  let moduleRoot = workdir </> "output"+  moduleDirs <- filter (/= "cache-db.json") <$> Dir.listDirectory moduleRoot+  forM_ moduleDirs $ \rel -> do+    let dir = moduleRoot </> rel+    let file = dir </> "corefn.json"+    value <- Aeson.eitherDecodeFileStrict file >>= either Sys.die pure+    (_version, module') <- either Sys.die pure $ parseEither moduleFromJSON value+    let (nix, ModuleInfo usesFFI interpolations) = convert module'+    TL.writeFile (dir </> "default.nix") (renderExpr nix)+    let modulePath = P.modulePath module'+        foreignSrc = workdir </> FP.replaceExtension modulePath "nix"+        foreignTrg = dir </> "foreign.nix"+    hasForeign <- Dir.doesFileExist foreignSrc+    case (hasForeign, usesFFI) of+      (True, True) -> Dir.copyFile foreignSrc foreignTrg+      (True, False) -> hPutStrLn stderr $ "Warning: " <> modulePath <> " has an FFI file, but does not use FFI!"+      (False, True) -> hPutStrLn stderr $ "Warning: " <> modulePath <> " calls foreign functions, but has no associated FFI file!"+      (False, False) -> pure ()+    unless (null interpolations) $ do+      hPutStrLn stderr $+        unlines+          [ "Warning: " <> modulePath <> " appears to perform Nix string interpolation in the following locations:",+            "  " <> intercalate ", " (show <$> toList interpolations),+            "Nix string interpolations are currently not officially supported and may cause unexpected behavior."+          ]

@@ -0,0 +1,19 @@+module PureNix.Prelude+  ( module X,+    LText,+  )+where++import Control.Applicative as X+import Control.Monad.Except as X+import Control.Monad.Reader as X+import Control.Monad.State as X+import Data.Bool as X (bool)+import Data.Map as X (Map)+import Data.Maybe as X (fromMaybe)+import Data.String as X (IsString (..))+import Data.Text as X (Text)+import qualified Data.Text.Lazy as LT+import Prelude as X++type LText = LT.Text

@@ -0,0 +1,204 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}++module PureNix.Print (renderExpr) where++import Data.Foldable (toList)+import Data.List (intersperse)+import Data.Semigroup (mtimesDefault)+import Data.Text.Lazy.Builder (Builder)+import qualified Data.Text.Lazy.Builder as TB+import Lens.Micro.Platform+import PureNix.Expr hiding (string)+import PureNix.Identifiers+import PureNix.Prelude++newtype PrintContext = PrintContext {pcIndent :: Int}++newtype PrintState = PrintState {psBuilder :: Builder}++newtype Printer = Printer {_unPrinter :: ReaderT PrintContext (State PrintState) ()}++runPrinter :: Printer -> LText+runPrinter (Printer p) = TB.toLazyText $ psBuilder $ execState (runReaderT p pc0) ps0+  where+    pc0 = PrintContext 0+    ps0 = PrintState mempty++instance Semigroup Printer where Printer a <> Printer b = Printer (a >> b)++instance Monoid Printer where mempty = Printer (pure ())++instance IsString Printer where fromString = Printer . emit . fromString++delimit :: Style -> Char -> Char -> Printer -> Printer+delimit = style delimitSingle delimitMulti+  where+    delimitSingle :: Char -> Char -> Printer -> Printer+    delimitSingle open close body = mconcat [char open, body, char close]+    delimitMulti :: Char -> Char -> Printer -> Printer+    delimitMulti open close body = mconcat [newline, char open, space, indent body, newline, char close]++space :: Printer+space = char ' '++indent :: Printer -> Printer+indent (Printer p) = Printer $ local (\(PrintContext n) -> PrintContext (n + 2)) p++char :: Char -> Printer+char = Printer . emit . TB.singleton++emit :: Builder -> ReaderT PrintContext (State PrintState) ()+emit t = modify (\(PrintState s) -> PrintState $ s <> t)++text :: Text -> Printer+text = Printer . emit . TB.fromText++string :: String -> Printer+string = Printer . emit . TB.fromString++newline :: Printer+newline = Printer $ do+  i <- asks pcIndent+  emit ("\n" <> mtimesDefault i " ")++-- | Turn a Nix 'Expr' into an actual piece of text.+renderExpr :: Expr -> LText+renderExpr = runPrinter . view _1 . foldExpr render+  where+    render :: ExprF (Printer, Style, Associativity, Precedence) -> (Printer, Style, Associativity, Precedence)+    render expr = (ppExpr sty parenthesized, sty, exprAssoc expr, exprPrec expr)+      where+        sty = exprStyle (view _2 <$> expr)+        parenthesized =+          parenthesize+            (view _3)+            (view _4)+            (view _1)+            (\inner -> delimit (inner ^. _2) '(' ')' (inner ^. _1))+            expr++-- | Expressions can be printed in two styles; single-line or multi-line.+data Style = Single | Multi deriving (Eq, Ord)++style :: r -> r -> Style -> r+style a _ Single = a+style _ b Multi = b++exprStyle :: ExprF Style -> Style+exprStyle (Attrs _ [] []) = Single+exprStyle (Attrs [] [(sty, _)] []) = sty+exprStyle (Attrs [] [] [(_, sty)]) = sty+exprStyle Attrs {} = Multi+exprStyle Let {} = Multi+exprStyle v = bool Single Multi $ elem Multi v++newtype Precedence = Precedence Int deriving newtype (Num, Eq, Ord)++data Associativity = AssocLeft | AssocRight | AssocNone | Associative+  deriving (Eq, Show)++exprAssoc :: ExprF a -> Associativity+exprAssoc Sel {} = AssocLeft+exprAssoc App {} = AssocLeft+exprAssoc (Bin op _ _) = opAssoc op+  where+    opAssoc Equals = AssocNone+    opAssoc Update = Associative+    opAssoc And = Associative+exprAssoc _ = AssocNone++-- | Expression precedence.+-- See: https://nixos.org/manual/nix/stable/#sec-language-operators+-- Operators listed in the above table have a precedence of (15 - <listed precedence>)+exprPrec :: ExprF a -> Precedence+exprPrec Var {} = 15+exprPrec Int {} = 15+exprPrec Double {} = 15+exprPrec String {} = 15+exprPrec Attrs {} = 15+exprPrec List {} = 15+exprPrec Path {} = 15+exprPrec Sel {} = 14+exprPrec App {} = 13+exprPrec Not {} = 8+exprPrec (Bin op _ _) = opPrec op+  where+    opPrec :: Op -> Precedence+    opPrec Update = 6+    opPrec Equals = 4+    opPrec And = 3+exprPrec Cond {} = 0+exprPrec Lam {} = 0+exprPrec Let {} = 0++-- | Define whether a subexpression needs to be parenthesized, based on its associativity and precedence.+parenthesize :: forall a b. (a -> Associativity) -> (a -> Precedence) -> (a -> b) -> (a -> b) -> ExprF a -> ExprF b+parenthesize assoc prec no yes = go+  where+    below :: Precedence -> a -> b+    below p a = if prec a < p then yes a else no a+    bin :: (forall c. c -> c -> ExprF c) -> a -> a -> ExprF b+    bin op l r = op (f l AssocLeft) (f r AssocRight)+      where+        f x a = case compare (prec x) (exprPrec $ op () ()) of+          GT -> no x+          EQ | assoc x `elem` [a, Associative] -> no x+          _ -> yes x+    go :: ExprF a -> ExprF b+    go (Attrs ih ihf f) = Attrs ih (ihf & traverse . _1 %~ yes) (f & traverse . _2 %~ no)+    go (Let binds body) = Let (binds & traverse . _2 %~ no) (body & no)+    go (List elems) = List (below 14 <$> elems)+    go (App f x) = bin App f x+    go (Bin op l r) = bin (Bin op) l r+    go e = fmap (below (exprPrec e)) e++sepBy :: Foldable t => Printer -> t Printer -> Printer+sepBy sep ps = mconcat $ intersperse sep (toList ps)++binding :: (k -> Printer) -> (k, Printer) -> Printer+binding f (v, body) = f v <> " = " <> indent body <> ";"++binder :: Var -> Printer+binder = text . unVar++key :: Key -> Printer+key = text . unKey++ppExpr :: Style -> ExprF Printer -> Printer+ppExpr _ (Var v) = binder v+ppExpr _ (Lam arg body) = text (unVar arg) <> ": " <> body+ppExpr _ (App f x) = f <> space <> x+ppExpr _ (Attrs [] [] []) = "{ }"+ppExpr sty (Attrs ih ihf b) = delimit sty '{' '}' $ sepBy newline $ inherits <> inheritFroms <> binds+  where+    inherits = [sepBy space ("inherit" : (binder <$> ih)) <> ";" | not (null ih)]+    inheritFroms = (\(from, idents) -> sepBy space ("inherit" : from : (key <$> idents)) <> ";") <$> ihf+    binds = binding key <$> b+ppExpr _ (List []) = "[]"+ppExpr sty (List l) = delimit sty '[' ']' $ sepBy newline l+ppExpr _ (Sel a b) = a <> "." <> key b+ppExpr _ (Path t) = text t+ppExpr _ (String str) = char '"' <> text str <> char '"'+ppExpr _ (Int n) = string (show n)+ppExpr _ (Double x) = string (show x)+ppExpr Single (Cond c t f) = sepBy space ["if", c, "then", t, "else", f]+ppExpr Multi (Cond c t f) = newline <> "if " <> c <> indent (newline <> "then " <> indent t <> newline <> "else " <> indent f)+ppExpr _ (Not e) = "!" <> e+ppExpr _ (Let binds body) =+  mconcat+    [ newline,+      "let",+      indent $ newline <> sepBy newline (binding binder <$> binds),+      newline,+      "in",+      indent $ newline <> body+    ]+ppExpr _ (Bin Update l r) = l <> " // " <> r+ppExpr _ (Bin Equals l r) = l <> " == " <> r+ppExpr _ (Bin And l r) = l <> " && " <> r