diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,35 @@ + + + +# Revision history for nixfmt + +## 0.3.0 -- 2019-08-29 + +* Added check flag for use in CI. +* Added quiet flag to disable all output on stderr. +* Further improved indentation. +* Fixed bugs where Nix code with different semantics was emitted in some cases. + +## 0.2.1 -- 2019-07-29 + +* Fixed missing linebreaks in set abstractions. + +## 0.2.0 -- 2019-07-25 + +* Fixed indentation of binders and some other expressions. +* Use atomic writes to avoid data loss. +* Made idempotent. +* Pinned nixpkgs. +* Simplified some code. +* Many other formatting improvements. + +## 0.1.0 -- 2019-05-11 + +* The first released version of nixfmt. This project aims to provide a + consistent formatter for Nix code. This release is capable of parsing all of + nixpkgs and formatting it in a consistent way. The generated code is not yet + pretty in all places though and there are still some other issues as well. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,373 @@ +Mozilla Public License Version 2.0 +================================== + +1. Definitions +-------------- + +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. + +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,58 @@ + + +# `nixfmt` + +`nixfmt` is a formatter for Nix code, intended to easily apply a uniform style. + +You are encouraged to test this out on your code and submit any undesirable formatting you find as an issue + +[![Build Status](https://badge.buildkite.com/b37f73adea391439e63288e8fd3b47f4b98fb9640bb864ccfa.svg)](https://buildkite.com/serokell/nixfmt) +[![Cachix](https://img.shields.io/badge/cachix-nixfmt-blue.svg)](https://nixfmt.cachix.org) + +## Installation + +* Optional: `cachix use nixfmt` +* `nix-env -f https://github.com/serokell/nixfmt/archive/master.tar.gz -i` + + +## Development + +### With Nix + +Haskell dependencies will be built by Nix. + +* Enter `nix-shell` +* Build with `cabal new-build` + +### Without Nix + +Haskell dependencies will be bulit by Cabal. + +* Build with `cabal new-build` + + +## Usage + +* `nixfmt < input.nix` – reads Nix code form `stdin`, formats it, and outputs to `stdout` +* `nixfmt file.nix` – format the file in place + + +## For Contributors + +We welcome issues and pull requests on GitHub. + + +## About Serokell + +`nixfmt` is maintained and funded with :heart: by +[Serokell](https://serokell.io/). The names and logo for Serokell are trademark +of Serokell OÜ. + +We love open source software! See +[our other projects](https://serokell.io/community?utm_source=github) or +[hire us](https://serokell.io/hire-us?utm_source=github) to design, develop and +grow your idea! diff --git a/js/JSInterface.hs b/js/JSInterface.hs new file mode 100644 --- /dev/null +++ b/js/JSInterface.hs @@ -0,0 +1,37 @@ +{- © 2019 Serokell + - + - SPDX-License-Identifier: MPL-2.0 + -} + +{-# LANGUAGE OverloadedStrings #-} +import GHCJS.Marshal +import GHCJS.Foreign +import GHCJS.Foreign.Callback +import GHCJS.Types +import JavaScript.Object +import qualified JavaScript.Object.Internal as O +import Data.JSString.Text +import qualified Data.JSString as S + +import Nixfmt + +foreign import javascript unsafe "window.nixfmt_ = $1" + js_set_logic :: JSVal -> IO () + +main :: IO () +main = do + callback <- syncCallback2 ThrowWouldBlock $ \text_ o -> do + let obj = O.Object o + Just width <- getProp (textToJSString "width") obj >>= fromJSVal + Just filename_ <- getProp (textToJSString "filename") obj >>= fromJSVal + let filename = S.unpack filename_ + let text = textFromJSVal text_ + out <- case format width filename text of + Left err -> do + setProp "err" (toJSBool True) obj + toJSVal $ S.pack $ errorBundlePretty err + Right out_ -> do + setProp "err" (toJSBool False) obj + toJSVal out_ + setProp "ret" out obj + js_set_logic $ jsval callback diff --git a/js/js-interface-wrapper.js b/js/js-interface-wrapper.js new file mode 100644 --- /dev/null +++ b/js/js-interface-wrapper.js @@ -0,0 +1,10 @@ +/* © 2019 Serokell + * + * SPDX-License-Identifier: MPL-2.0 + */ + +function nixfmt(text, width=80, filename="") { + const param = {width, filename} + nixfmt_(text, param) + return {text: param.ret, err: param.err} +} diff --git a/main/Main.hs b/main/Main.hs new file mode 100644 --- /dev/null +++ b/main/Main.hs @@ -0,0 +1,138 @@ +{- © 2019 Serokell + - © 2019 Lars Jellema + - + - SPDX-License-Identifier: MPL-2.0 + -} + +{-# LANGUAGE DeriveDataTypeable, NamedFieldPuns #-} + +module Main where + +import Control.Concurrent (Chan, forkIO, newChan, readChan, writeChan) +import Data.Bifunctor (first) +import Data.Either (lefts) +import Data.Text (Text) +import GHC.IO.Encoding (utf8) +import System.Console.CmdArgs + (Data, Typeable, args, cmdArgs, help, summary, typ, (&=)) +import System.Exit (ExitCode(..), exitFailure, exitSuccess) +import System.IO (hPutStr, hSetEncoding, stderr) +import System.Posix.Process (exitImmediately) +import System.Posix.Signals (Handler(..), installHandler, keyboardSignal) + +import qualified Data.Text.IO as TextIO (getContents, hPutStr, putStr) + +import Nixfmt +import System.IO.Atomic (withOutputFile) +import System.IO.Utf8 (readFileUtf8, withUtf8StdHandles) + +type Result = Either String () +type Width = Int + +data Nixfmt = Nixfmt + { files :: [FilePath] + , width :: Width + , check :: Bool + , quiet :: Bool + } deriving (Show, Data, Typeable) + +options :: Nixfmt +options = Nixfmt + { files = [] &= args &= typ "FILES" + , width = 80 &= help "Maximum width in characters" + , check = False &= help "Check whether files are formatted" + , quiet = False &= help "Do not report errors" + } &= summary "Format Nix source code" + +format' :: Width -> FilePath -> Text -> Either String Text +format' w path = first errorBundlePretty . format w path + +data Target = Target + { tDoRead :: IO Text + , tPath :: FilePath + , tDoWrite :: Text -> IO () + } + +formatTarget :: Width -> Target -> IO Result +formatTarget w Target{tDoRead, tPath, tDoWrite} = do + contents <- tDoRead + let formatted = format' w tPath contents + mapM tDoWrite formatted + +-- | Return an error if target could not be parsed or was not formatted +-- correctly. +checkTarget :: Width -> Target -> IO Result +checkTarget w Target{tDoRead, tPath} = do + contents <- tDoRead + return $ case format' w tPath contents of + Left err -> Left err + Right formatted + | formatted == contents -> Right () + | otherwise -> Left $ tPath ++ ":\nnot formatted" + +stdioTarget :: Target +stdioTarget = Target TextIO.getContents "" TextIO.putStr + +fileTarget :: FilePath -> Target +fileTarget path = Target (readFileUtf8 path) path atomicWriteFile + where + atomicWriteFile t = withOutputFile path $ \h -> do + hSetEncoding h utf8 + TextIO.hPutStr h t + +toTargets :: Nixfmt -> [Target] +toTargets Nixfmt{ files = [] } = [stdioTarget] +toTargets Nixfmt{ files = paths } = map fileTarget paths + +toOperation :: Nixfmt -> Target -> IO Result +toOperation Nixfmt{ width = w, check = True } = checkTarget w +toOperation Nixfmt{ width = w } = formatTarget w + +toWriteError :: Nixfmt -> String -> IO () +toWriteError Nixfmt{ quiet = False } = hPutStr stderr +toWriteError Nixfmt{ quiet = True } = const $ return () + +toJobs :: Nixfmt -> [IO Result] +toJobs opts = map (toOperation opts) $ toTargets opts + +-- TODO: Efficient parallel implementation. This is just a sequential stub. +-- This was originally implemented using parallel-io, but it gave a factor two +-- overhead. +doParallel :: [IO a] -> IO [a] +doParallel = sequence + +errorWriter :: (String -> IO ()) -> Chan (Maybe String) -> Chan () -> IO () +errorWriter doWrite chan done = do + item <- readChan chan + case item of + Nothing -> return () + Just msg -> doWrite msg >> errorWriter doWrite chan done + writeChan done () + +writeErrorBundle :: Chan (Maybe String) -> Result -> IO Result +writeErrorBundle chan result = do + case result of + Right () -> return () + Left err -> writeChan chan $ Just err + return result + +-- | Run a list of jobs and write errors to stderr without interleaving them. +runJobs :: (String -> IO ()) -> [IO Result] -> IO [Result] +runJobs writeError jobs = do + errChan <- newChan + doneChan <- newChan + _ <- forkIO $ errorWriter writeError errChan doneChan + results <- doParallel $ map (>>= writeErrorBundle errChan) jobs + writeChan errChan Nothing + _ <- readChan doneChan + return results + +main :: IO () +main = withUtf8StdHandles $ do + _ <- installHandler keyboardSignal + (Catch (exitImmediately $ ExitFailure 2)) Nothing + opts <- cmdArgs options + results <- runJobs (toWriteError opts) (toJobs opts) + case lefts results of + [] -> exitSuccess + _ -> exitFailure diff --git a/main/System/IO/Atomic.hs b/main/System/IO/Atomic.hs new file mode 100644 --- /dev/null +++ b/main/System/IO/Atomic.hs @@ -0,0 +1,90 @@ +{- © 2019 Serokell + - + - SPDX-License-Identifier: MPL-2.0 + -} + +-- | Atomic file IO. +-- +-- This modules allows one to replace the contents of a file atomically by +-- leveraging the atomicity of the @rename@ operation. +-- +-- This module is a crossover of the `atomic-write` and `safeio` libraries +-- with the fs-related behaviour of the first and interface of the second. +module System.IO.Atomic + ( withOutputFile + ) where + +import Control.Exception.Safe (mask, onException) +import Control.Monad (when) +import System.Directory (doesFileExist, removeFile, renameFile) +import System.FilePath (takeDirectory, takeFileName) +import System.IO (Handle, hClose, openTempFileWithDefaultPermissions) +import System.Posix.Files (fileMode, getFileStatus, setFileMode) + + +-- | Like @withFile@ but replaces the contents atomically. +-- +-- This function allocates a temporary file and provides its handle to the +-- IO action. After the action finishes, it /atomically/ replaces the original +-- target file with the temporary one. If the action fails with an exception, +-- the temporary file is cleaned up. +-- +-- Since the procedure involves creation of an entirely new file, preserving +-- the attributes is a challenge. This function tries its best, but currently +-- it is Unix-specific and there is definitely room for improvement even on Unix. +withOutputFile :: + FilePath -- ^ Final file path + -> (Handle -> IO a) -- ^ IO action that writes to the file + -> IO a +withOutputFile path act = transact begin commit rollback $ \(tpath, th) -> do + copyAttributes (tpath, th) + act th + where + tmpDir = takeDirectory path + tmpTemplate = "." <> takeFileName path <> ".atomic" + + begin :: IO (FilePath, Handle) + begin = openTempFileWithDefaultPermissions tmpDir tmpTemplate + + -- TODO: Support for non-unix platofrms. + -- TODO: Preserve ctime? + -- TODO: Preserve extended attributes (ACLs, ...)? + copyAttributes :: (FilePath, Handle) -> IO () + copyAttributes (tpath, _th) = do + exists <- doesFileExist path + when exists $ do + getFileStatus path >>= setFileMode tpath . fileMode + + commit :: (FilePath, Handle) -> IO () + commit (tpath, th) = hClose th *> renameFile tpath path + + rollback :: (FilePath, Handle) -> IO () + rollback (tpath, th) = hClose th *> removeFile tpath + + + +--- +-- Helpers +-- + +-- | A variant of @bracket@ with two different finalisation actions. +-- +-- Semantically, the following is /almost/ true: +-- +-- > bracket acquire release = transact acquire release release +-- +-- except that @bracket@ always runs the cleanup action exactly once, while +-- here, if the action completes but commit fails, we will still run rollback, +-- so there exists an execution in which both finalisation actions are run. +transact :: + IO a -- ^ computation to run first (\"begin transaction\") + -> (a -> IO b) -- ^ computation to run on success (\"commit transaction\") + -> (a -> IO c) -- ^ computation to run on failure (\"rollback transaction\") + -> (a -> IO d) -- ^ computation to run in-between + -> IO d -- returns the value from the in-between computation +transact begin commit rollback act = + mask $ \restore -> do + a <- begin + res <- restore (act a) `onException` rollback a + _ <- commit a `onException` rollback a + pure res diff --git a/main/System/IO/Utf8.hs b/main/System/IO/Utf8.hs new file mode 100644 --- /dev/null +++ b/main/System/IO/Utf8.hs @@ -0,0 +1,88 @@ +{- © 2019 Serokell + - + - SPDX-License-Identifier: MPL-2.0 + -} + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Helpers for implementing tools that process UTF-8 encoded data. +-- +-- Standard IO functions assume that the character encoding of the data +-- they read or write is the same as the one used by current locale. In many +-- situtations this assumption is wrong, as tools work with files, and +-- the files nowadays are mostly UTF-8 encoded, regardless of the locale. +-- Therefore, it is almost always a good idea to switch the encoding of +-- file handles to UTF-8. +-- +-- The same applies to standard input, output, and error handles. However, +-- there is an edge-case: if they are attached to a terminal, and the +-- encoding is not UTF-8, using UTF-8 might actually be unsafe. +-- +-- Functions in this module help deal with all these issues. +module System.IO.Utf8 + ( withUtf8StdHandles + + , openFileUtf8 + , readFileUtf8 + ) where + +import Control.Exception (bracket) +import Data.Text (Text) +import GHC.IO.Encoding (mkTextEncoding, textEncodingName, utf8) +import System.IO (stderr, stdin, stdout) + +import qualified Data.Text.IO as T +import qualified System.IO as IO + + +type EncRestoreAction = IO.Handle -> IO () + +-- | Sets the best available UTF-8-compatible encoding for the handle. +-- Returns the action that will restore the previous one. +-- +-- If the handle is in binary mode, does nothing. +-- If the handle is not attached to a terminal, sets UTF-8. +-- Otherwise, keeps its current encoding, but augments it to transliterate +-- unsupported characters. +hSetBestUtf8Enc :: IO.Handle -> IO EncRestoreAction +hSetBestUtf8Enc h = IO.hGetEncoding h >>= \case + Nothing -> pure (\_ -> pure ()) + Just enc -> do + isTerm <- IO.hIsTerminalDevice h + enc' <- chooseBestEnc isTerm enc + IO.hSetEncoding h enc' + pure $ flip IO.hSetEncoding enc + where + chooseBestEnc False _ = pure utf8 + chooseBestEnc True enc@(textEncodingName -> name) + | '/' `notElem` name = mkTextEncoding (name ++ "//TRANSLIT") + | otherwise = pure enc + +-- | Configures the encodings of the three standard handles (stdin, stdout, stderr) +-- to work with UTF-8 encoded data and runs the specified IO action. +-- After the action finishes, restores the original encodings. +withUtf8StdHandles :: IO a -> IO a +withUtf8StdHandles action = + withConfiguredHandle stdin $ + withConfiguredHandle stdout $ + withConfiguredHandle stderr $ + action + where + withConfiguredHandle :: IO.Handle -> IO a -> IO a + withConfiguredHandle h = bracket (hSetBestUtf8Enc h) ($ h) . const + + + +-- | Like @openFile@, but sets the file encoding to UTF-8, regardless +-- of the current locale. +openFileUtf8 :: IO.FilePath -> IO.IOMode -> IO IO.Handle +openFileUtf8 path mode = do + h <- IO.openFile path mode + IO.hSetEncoding h utf8 + pure h + +-- | Like @readFile@, but assumes the file is encoded in UTF-8, regardless +-- of the current locale. +readFileUtf8 :: IO.FilePath -> IO Text +readFileUtf8 path = openFileUtf8 path IO.ReadMode >>= T.hGetContents diff --git a/nixfmt.cabal b/nixfmt.cabal new file mode 100644 --- /dev/null +++ b/nixfmt.cabal @@ -0,0 +1,106 @@ +cabal-version: 2.0 + +-- © 2019 Serokell +-- © 2019 Lars Jellema +-- +-- SPDX-License-Identifier: MPL-2.0 + +name: nixfmt +version: 0.3.0 +synopsis: An opinionated formatter for Nix +description: + A formatter for Nix that ensures consistent and clear formatting by forgetting + all existing formatting during parsing. +homepage: https://github.com/serokell/nixfmt +bug-reports: https://github.com/serokell/nixfmt/issues +license: MPL-2.0 +license-file: LICENSE +author: Lars Jellema +maintainer: lars.jellema@gmail.com +copyright: 2019 Serokell, 2019 Lars Jellema +category: Development +build-type: Simple +extra-source-files: README.md, CHANGELOG.md + +source-repository head + type: git + location: git://github.com/serokell/nixfmt.git + +executable nixfmt + main-is: Main.hs + other-modules: + System.IO.Utf8 + System.IO.Atomic + other-extensions: DeriveDataTypeable + hs-source-dirs: main + if impl(ghcjs) + buildable: False + else + buildable: True + build-depends: + base >= 4.12.0 && < 4.13 + , cmdargs >= 0.10.20 && < 0.11 + , nixfmt + , unix >= 2.7.2 && < 2.8 + , text >= 1.2.3 && < 1.3 + + -- for System.IO.Atomic + , directory >= 1.3.3 && < 1.4 + , filepath >= 1.4.2 && < 1.5 + , safe-exceptions >= 0.1.7 && < 0.2 + default-language: Haskell2010 + ghc-options: + -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -threaded + +library + exposed-modules: + Nixfmt + Nixfmt.Lexer + Nixfmt.Parser + Nixfmt.Predoc + Nixfmt.Pretty + Nixfmt.Types + Nixfmt.Util + other-extensions: OverloadedStrings, LambdaCase, FlexibleInstances, DeriveFoldable, DeriveFunctor, StandaloneDeriving + hs-source-dirs: src + build-depends: + base >= 4.12.0 && < 4.13 + , megaparsec >= 7.0.5 && < 7.1 + , parser-combinators >= 1.0.3 && < 1.3 + , text >= 1.2.3 && < 1.3 + default-language: Haskell2010 + ghc-options: + -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -Wno-orphans + +executable js-interface + main-is: JSInterface.hs + + if impl(ghcjs) + buildable: True + ghc-options: + -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -Wno-orphans + build-depends: + base >= 4.12.0 && < 4.13 + , ghcjs-base >= 0.2.0 && < 0.3 + , nixfmt + js-sources: js/js-interface-wrapper.js + hs-source-dirs: js/ + else + buildable: False + + default-language: Haskell2010 diff --git a/src/Nixfmt.hs b/src/Nixfmt.hs new file mode 100644 --- /dev/null +++ b/src/Nixfmt.hs @@ -0,0 +1,26 @@ +{- © 2019 Serokell + - © 2019 Lars Jellema + - + - SPDX-License-Identifier: MPL-2.0 + -} + +module Nixfmt + ( errorBundlePretty + , ParseErrorBundle + , format + ) where + +import Data.Text (Text) +import Text.Megaparsec (parse) +import Text.Megaparsec.Error (errorBundlePretty) + +import Nixfmt.Parser (file) +import Nixfmt.Predoc (layout) +import Nixfmt.Pretty () +import Nixfmt.Types (ParseErrorBundle) + +-- | @format w filename source@ returns either a parsing error specifying a +-- failure in @filename@ or a formatted version of @source@ with a maximum width +-- of @w@ columns where possible. +format :: Int -> FilePath -> Text -> Either ParseErrorBundle Text +format width filename = fmap (layout width) . parse file filename diff --git a/src/Nixfmt/Lexer.hs b/src/Nixfmt/Lexer.hs new file mode 100644 --- /dev/null +++ b/src/Nixfmt/Lexer.hs @@ -0,0 +1,99 @@ +{- © 2019 Serokell + - © 2019 Lars Jellema + - + - SPDX-License-Identifier: MPL-2.0 + -} + +{-# LANGUAGE LambdaCase, OverloadedStrings #-} + +module Nixfmt.Lexer (lexeme) where + +import Data.Char (isSpace) +import Data.List (dropWhileEnd) +import Data.Maybe (fromMaybe) +import Data.Text as Text + (Text, intercalate, length, lines, null, pack, replace, replicate, strip, + stripEnd, stripPrefix, stripStart, takeWhile) +import Text.Megaparsec + (SourcePos(..), anySingle, chunk, getSourcePos, hidden, many, manyTill, some, + try, unPos, (<|>)) +import Text.Megaparsec.Char (eol) + +import Nixfmt.Types (Ann(..), Parser, TrailingComment(..), Trivia, Trivium(..)) +import Nixfmt.Util (manyP) + +data ParseTrivium + = PTNewlines Int + | PTLineComment Text + | PTBlockComment [Text] + deriving (Show) + +preLexeme :: Parser a -> Parser a +preLexeme p = p <* manyP (\x -> isSpace x && x /= '\n' && x /= '\r') + +newlines :: Parser ParseTrivium +newlines = PTNewlines <$> Prelude.length <$> some (preLexeme eol) + +splitLines :: Text -> [Text] +splitLines = dropWhile Text.null . dropWhileEnd Text.null + . map Text.stripEnd . Text.lines . replace "\r\n" "\n" + +stripIndentation :: Int -> Text -> Text +stripIndentation n t = fromMaybe (stripStart t) $ stripPrefix (Text.replicate n " ") t + +commonIndentationLength :: Int -> [Text] -> Int +commonIndentationLength def = foldr min def . map (Text.length . Text.takeWhile (==' ')) + +fixLines :: Int -> [Text] -> [Text] +fixLines _ [] = [] +fixLines n (h : t) = strip h + : map (stripIndentation $ commonIndentationLength n $ filter (/="") t) t + +lineComment :: Parser ParseTrivium +lineComment = preLexeme $ chunk "#" *> + (PTLineComment <$> manyP (\x -> x /= '\n' && x /= '\r')) + +blockComment :: Parser ParseTrivium +blockComment = try $ preLexeme $ do + _ <- chunk "/*" + SourcePos{sourceColumn = pos} <- getSourcePos + chars <- manyTill anySingle $ chunk "*/" + return $ PTBlockComment $ fixLines (unPos pos) $ splitLines $ pack chars + +convertTrailing :: [ParseTrivium] -> Maybe TrailingComment +convertTrailing = toMaybe . join . map toText + where toText (PTLineComment c) = strip c + toText (PTBlockComment [c]) = strip c + toText _ = "" + join = intercalate " " . filter (/="") + toMaybe "" = Nothing + toMaybe c = Just $ TrailingComment c + +convertLeading :: [ParseTrivium] -> Trivia +convertLeading = concatMap (\case + PTNewlines 1 -> [] + PTNewlines _ -> [EmptyLine] + PTLineComment c -> [LineComment c] + PTBlockComment [] -> [] + PTBlockComment [c] -> [LineComment $ " " <> strip c] + PTBlockComment cs -> [BlockComment cs]) + +isTrailing :: ParseTrivium -> Bool +isTrailing (PTLineComment _) = True +isTrailing (PTBlockComment []) = True +isTrailing (PTBlockComment [_]) = True +isTrailing _ = False + +convertTrivia :: [ParseTrivium] -> (Maybe TrailingComment, Trivia) +convertTrivia pts = + let (trailing, leading) = span isTrailing pts + in (convertTrailing trailing, convertLeading leading) + +trivia :: Parser [ParseTrivium] +trivia = many $ hidden $ lineComment <|> blockComment <|> newlines + +lexeme :: Parser a -> Parser (Ann a) +lexeme p = do + token <- preLexeme p + (trailing, leading) <- convertTrivia <$> trivia + return $ Ann token trailing leading diff --git a/src/Nixfmt/Parser.hs b/src/Nixfmt/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Nixfmt/Parser.hs @@ -0,0 +1,330 @@ +{- © 2019 Serokell + - © 2019 Lars Jellema + - + - SPDX-License-Identifier: MPL-2.0 + -} + +{-# LANGUAGE LambdaCase, OverloadedStrings #-} + +module Nixfmt.Parser where + +import Prelude hiding (String) + +import Control.Monad (guard, liftM2) +import Control.Monad.Combinators (sepBy) +import qualified Control.Monad.Combinators.Expr as MPExpr + (Operator(..), makeExprParser) +import Data.Char (isAlpha) +import Data.Foldable (toList) +import Data.Maybe (fromMaybe) +import Data.Text as Text + (Text, cons, empty, null, singleton, split, strip, stripPrefix) +import Text.Megaparsec + (anySingle, chunk, eof, label, lookAhead, many, notFollowedBy, oneOf, + optional, satisfy, try, (<|>)) +import Text.Megaparsec.Char (char) +import qualified Text.Megaparsec.Char.Lexer as L (decimal, float) + +import Nixfmt.Lexer (lexeme) +import Nixfmt.Types + (Ann, Binder(..), Expression(..), File(..), Fixity(..), Leaf, Operator(..), + ParamAttr(..), Parameter(..), Parser, Selector(..), SimpleSelector(..), + String, StringPart(..), Term(..), Token(..), operators, tokenText) +import Nixfmt.Util + (commonIndentation, identChar, manyP, manyText, pathChar, schemeChar, someP, + someText, uriChar) + +-- HELPER FUNCTIONS + +ann :: (a -> b) -> Parser a -> Parser (Ann b) +ann f p = try $ lexeme $ f <$> p + +-- | parses a token without parsing trivia after it +rawSymbol :: Token -> Parser Token +rawSymbol t = chunk (tokenText t) *> return t + +symbol :: Token -> Parser (Ann Token) +symbol = lexeme . rawSymbol + +reservedNames :: [Text] +reservedNames = + [ "let", "in" + , "if", "then", "else" + , "assert" + , "with" + , "rec" + , "inherit" + ] + +reserved :: Token -> Parser (Ann Token) +reserved t = try $ lexeme $ rawSymbol t + <* lookAhead (satisfy (\x -> not $ identChar x || pathChar x)) + +-- VALUES + +integer :: Parser (Ann Token) +integer = ann Integer L.decimal + +float :: Parser (Ann Token) +float = ann Float L.float + +identifier :: Parser (Ann Token) +identifier = ann Identifier $ do + ident <- Text.cons <$> satisfy (\x -> isAlpha x || x == '_') + <*> manyP identChar + guard $ not $ ident `elem` reservedNames + return ident + +slash :: Parser Text +slash = chunk "/" <* notFollowedBy (char '/') + +envPath :: Parser (Ann Token) +envPath = ann EnvPath $ char '<' *> + someP pathChar <> manyText (slash <> someP pathChar) + <* char '>' + +path :: Parser (Ann Token) +path = ann Path $ manyP pathChar <> someText (slash <> someP pathChar) + +uri :: Parser [[StringPart]] +uri = fmap (pure . pure . TextPart) $ try $ + someP schemeChar <> chunk ":" <> someP uriChar + +-- STRINGS + +interpolation :: Parser StringPart +interpolation = Interpolation <$> + symbol TInterOpen <*> expression <*> rawSymbol TInterClose + +simpleStringPart :: Parser StringPart +simpleStringPart = TextPart <$> someText ( + chunk "\\n" *> pure "\n" <|> + chunk "\\r" *> pure "\r" <|> + chunk "\\t" *> pure "\t" <|> + chunk "\\" *> (Text.singleton <$> anySingle) <|> + chunk "$$" <|> + try (chunk "$" <* notFollowedBy (char '{')) <|> + someP (\t -> t /= '"' && t /= '\\' && t /= '$')) + +indentedStringPart :: Parser StringPart +indentedStringPart = TextPart <$> someText ( + chunk "''\\n" *> pure "\n" <|> + chunk "''\\r" *> pure "\r" <|> + chunk "''\\t" *> pure "\t" <|> + chunk "''\\" *> (Text.singleton <$> anySingle) <|> + chunk "''$" *> pure "$" <|> + chunk "'''" *> pure "''" <|> + chunk "$$" <|> + try (chunk "$" <* notFollowedBy (char '{')) <|> + try (chunk "'" <* notFollowedBy (char '\'')) <|> + someP (\t -> t /= '\'' && t /= '$' && t /= '\n')) + +indentedLine :: Parser [StringPart] +indentedLine = many (indentedStringPart <|> interpolation) + +isEmptyLine :: [StringPart] -> Bool +isEmptyLine [] = True +isEmptyLine [TextPart t] = Text.null (Text.strip t) +isEmptyLine _ = False + +-- | Strip the first line of a string if it is empty. +stripFirstLine :: [[StringPart]] -> [[StringPart]] +stripFirstLine [] = [] +stripFirstLine (x : xs) + | isEmptyLine x = xs + | otherwise = x : xs + +textHeads :: [StringPart] -> [Text] +textHeads line@(TextPart t : _) + | isEmptyLine line = [] + | otherwise = [t] +textHeads (Interpolation _ _ _ : _) = [""] +textHeads [] = [] + +stripParts :: Text -> [StringPart] -> [StringPart] +stripParts indentation (TextPart t : xs) = + TextPart (fromMaybe Text.empty $ Text.stripPrefix indentation t) : xs +stripParts _ xs = xs + +-- | Split a list of StringParts on the newlines in their TextParts. +-- Invariant: result is never empty. +splitLines :: [StringPart] -> [[StringPart]] +splitLines [] = [[]] +splitLines (TextPart t : xs) = + let ts = map (pure . TextPart) $ Text.split (=='\n') t + in case splitLines xs of + (xs' : xss) -> init ts ++ ((last ts ++ xs') : xss) + _ -> error "unreachable" + +splitLines (x : xs) = + case splitLines xs of + (xs' : xss) -> ((x : xs') : xss) + _ -> error "unreachable" + +stripIndentation :: [[StringPart]] -> [[StringPart]] +stripIndentation parts = case commonIndentation (concatMap textHeads parts) of + Nothing -> map (const []) parts + Just indentation -> map (stripParts indentation) parts + +dropEmptyParts :: [[StringPart]] -> [[StringPart]] +dropEmptyParts = map $ filter (\case + TextPart t | Text.null t -> False + _ -> True) + +fixSimpleString :: [StringPart] -> [[StringPart]] +fixSimpleString parts = case splitLines parts of + [] -> [] + [line] -> [line] + parts' -> dropEmptyParts (stripIndentation parts') + +simpleString :: Parser [[StringPart]] +simpleString = rawSymbol TDoubleQuote *> + fmap splitLines (many (simpleStringPart <|> interpolation)) <* + rawSymbol TDoubleQuote + +fixIndentedString :: [[StringPart]] -> [[StringPart]] +fixIndentedString = dropEmptyParts . concatMap splitLines . stripIndentation . stripFirstLine + +indentedString :: Parser [[StringPart]] +indentedString = rawSymbol TDoubleSingleQuote *> + fmap fixIndentedString (sepBy indentedLine (chunk "\n")) <* + rawSymbol TDoubleSingleQuote + +string :: Parser String +string = lexeme $ simpleString <|> indentedString <|> uri + +-- TERMS + +parens :: Parser Term +parens = Parenthesized <$> + symbol TParenOpen <*> expression <*> symbol TParenClose + +selector :: Maybe (Parser Leaf) -> Parser Selector +selector parseDot = Selector <$> + sequence parseDot <* notFollowedBy path <*> + ((IDSelector <$> identifier) <|> + (InterpolSelector <$> lexeme interpolation) <|> + (StringSelector <$> lexeme simpleString)) <*> + optional (liftM2 (,) (reserved KOr) term) + +selectorPath :: Parser [Selector] +selectorPath = (pure <$> selector Nothing) <> + many (selector $ Just $ symbol TDot) + +simpleTerm :: Parser Term +simpleTerm = (String <$> string) <|> + (Token <$> (path <|> envPath <|> float <|> integer <|> identifier)) <|> + parens <|> set <|> list + +term :: Parser Term +term = label "term" $ do + t <- simpleTerm + s <- many $ try $ selector $ Just $ symbol TDot + return $ case s of [] -> t + _ -> Selection t s + +-- ABSTRACTIONS + +attrParameter :: Maybe (Parser Leaf) -> Parser ParamAttr +attrParameter parseComma = ParamAttr <$> + identifier <*> optional (liftM2 (,) (symbol TQuestion) expression) <*> + sequence parseComma + +idParameter :: Parser Parameter +idParameter = IDParameter <$> identifier + +setParameter :: Parser Parameter +setParameter = SetParameter <$> bopen <*> attrs <*> bclose + where bopen = symbol TBraceOpen + bclose = symbol TBraceClose + commaAttrs = many $ try $ attrParameter $ Just $ symbol TComma + ellipsis = ParamEllipsis <$> symbol TEllipsis + lastAttr = attrParameter Nothing <|> ellipsis + attrs = commaAttrs <> (toList <$> optional (lastAttr)) + +contextParameter :: Parser Parameter +contextParameter = + try (ContextParameter <$> setParameter <*> symbol TAt <*> idParameter) <|> + try (ContextParameter <$> idParameter <*> symbol TAt <*> setParameter) + +abstraction :: Parser Expression +abstraction = try (Abstraction <$> + (contextParameter <|> setParameter <|> idParameter) <*> + symbol TColon) <*> expression + +-- SETS AND LISTS + +inherit :: Parser Binder +inherit = Inherit <$> reserved KInherit <*> optional parens <*> + many identifier <*> symbol TSemicolon + +assignment :: Parser Binder +assignment = Assignment <$> + selectorPath <*> symbol TAssign <*> expression <*> symbol TSemicolon + +binders :: Parser [Binder] +binders = many (assignment <|> inherit) + +set :: Parser Term +set = Set <$> optional (reserved KRec <|> reserved KLet) <*> + symbol TBraceOpen <*> binders <*> symbol TBraceClose + +list :: Parser Term +list = List <$> symbol TBrackOpen <*> many term <*> symbol TBrackClose + +-- OPERATORS + +opChars :: [Char] +opChars = "<>=+*/." + +operator :: Token -> Parser Leaf +operator t = label "operator" $ try $ lexeme $ + rawSymbol t <* notFollowedBy (oneOf opChars) + +opCombiner :: Operator -> MPExpr.Operator Parser Expression +opCombiner Apply = MPExpr.InfixL $ return Application + +opCombiner (Op Prefix TMinus) = MPExpr.Prefix $ Negation <$> operator TMinus +opCombiner (Op Prefix TNot) = MPExpr.Prefix $ Inversion <$> operator TNot +opCombiner (Op Prefix _) = undefined + +opCombiner (Op Postfix TQuestion) = MPExpr.Postfix $ + (\question sel expr -> MemberCheck expr question sel) <$> + operator TQuestion <*> selectorPath + +opCombiner (Op Postfix _) = undefined + +opCombiner (Op InfixL tok) = MPExpr.InfixL $ flip Operation <$> operator tok +opCombiner (Op InfixN tok) = MPExpr.InfixN $ flip Operation <$> operator tok +opCombiner (Op InfixR tok) = MPExpr.InfixR $ flip Operation <$> operator tok + +operation :: Parser Expression +operation = MPExpr.makeExprParser + (Term <$> term <* notFollowedBy (oneOf (":@" :: [Char]))) + (map (map opCombiner) operators) + +-- EXPRESSIONS + +with :: Parser Expression +with = With <$> + reserved KWith <*> expression <*> symbol TSemicolon <*> expression + +letIn :: Parser Expression +letIn = Let <$> reserved KLet <*> binders <*> reserved KIn <*> expression + +ifThenElse :: Parser Expression +ifThenElse = If <$> + reserved KIf <*> expression <*> + reserved KThen <*> expression <*> + reserved KElse <*> expression + +assert :: Parser Expression +assert = Assert <$> reserved KAssert <*> expression <*> + symbol TSemicolon <*> expression + +expression :: Parser Expression +expression = label "expression" $ try operation <|> abstraction <|> + with <|> letIn <|> ifThenElse <|> assert + +file :: Parser File +file = File <$> lexeme (return SOF) <*> expression <* eof diff --git a/src/Nixfmt/Predoc.hs b/src/Nixfmt/Predoc.hs new file mode 100644 --- /dev/null +++ b/src/Nixfmt/Predoc.hs @@ -0,0 +1,290 @@ +{- © 2019 Serokell + - © 2019 Lars Jellema + - + - SPDX-License-Identifier: MPL-2.0 + -} + +{-# LANGUAGE DeriveFoldable, DeriveFunctor, FlexibleInstances, + OverloadedStrings, StandaloneDeriving #-} + +-- | This module implements a layer around the prettyprinter package, making it +-- easier to use. +module Nixfmt.Predoc + ( text + , sepBy + , hcat + , base + , group + , nest + , softline' + , line' + , softline + , line + , hardspace + , hardline + , emptyline + , newline + , Doc + , Pretty + , pretty + , fixup + , layout + , textWidth + ) where + +import Data.List (intersperse) +import Data.Text as Text (Text, concat, length, pack, replicate) + +-- | Sequential Spacings are reduced to a single Spacing by taking the maximum. +-- This means that e.g. a Space followed by an Emptyline results in just an +-- Emptyline. +data Spacing + = Softbreak + | Break + | Hardspace + | Softspace + | Space + | Hardline + | Emptyline + | Newlines Int + deriving (Show, Eq, Ord) + +data DocAnn + -- | Node Group docs indicates either all or none of the Spaces and Breaks + -- in docs should be converted to line breaks. + = Group + -- | Node (Nest n) doc indicates all line starts in doc should be indented + -- by n more spaces than the surrounding Base. + | Nest Int + -- | Node Base doc sets the base indentation that Nests should be relative + -- to to the indentation of the line where the Base starts. + | Base + deriving (Show, Eq) + +-- | Single document element. Documents are modeled as lists of these elements +-- in order to make concatenation simple. +data DocE + = Text Text + | Spacing Spacing + | Node DocAnn Doc + deriving (Show, Eq) + +type Doc = [DocE] + +class Pretty a where + pretty :: a -> Doc + +instance Pretty Text where + pretty = pure . Text + +instance Pretty String where + pretty = pure . Text . pack + +instance Pretty Doc where + pretty = id + +instance Pretty a => Pretty (Maybe a) where + pretty Nothing = mempty + pretty (Just x) = pretty x + +text :: Text -> Doc +text "" = [] +text t = [Text t] + +group :: Pretty a => a -> Doc +group = pure . Node Group . pretty + +-- | @nest n doc@ sets the indentation for lines in @doc@ to @n@ more than the +-- indentation of the part before it. This is based on the actual indentation of +-- the line, rather than the indentation it should have used: If multiple +-- indentation levels start on the same line, only the last indentation level +-- will be applied on the next line. This prevents unnecessary nesting. +nest :: Int -> Doc -> Doc +nest level = pure . Node (Nest level) + +base :: Doc -> Doc +base = pure . Node Base + +softline' :: Doc +softline' = [Spacing Softbreak] + +line' :: Doc +line' = [Spacing Break] + +softline :: Doc +softline = [Spacing Softspace] + +line :: Doc +line = [Spacing Space] + +hardspace :: Doc +hardspace = [Spacing Hardspace] + +hardline :: Doc +hardline = [Spacing Hardline] + +emptyline :: Doc +emptyline = [Spacing Emptyline] + +newline :: Doc +newline = [Spacing (Newlines 1)] + +sepBy :: Pretty a => Doc -> [a] -> Doc +sepBy separator = mconcat . intersperse separator . map pretty + +-- | Concatenate documents horizontally without spacing. +hcat :: Pretty a => [a] -> Doc +hcat = mconcat . map pretty + +isSpacing :: DocE -> Bool +isSpacing (Spacing _) = True +isSpacing _ = False + +spanEnd :: (a -> Bool) -> [a] -> ([a], [a]) +spanEnd p = fmap reverse . span p . reverse + +-- | Fix up a Doc in multiple stages: +-- - First, all spacings are moved out of Groups and Nests and empty Groups and +-- Nests are removed. +-- - Now, all consecutive Spacings are ensured to be in the same list, so each +-- sequence of Spacings can be merged into a single one. +-- - Finally, Spacings right before a Nest should be moved inside in order to +-- get the right indentation. +fixup :: Doc -> Doc +fixup = moveLinesIn . mergeLines . concatMap moveLinesOut + +moveLinesOut :: DocE -> Doc +moveLinesOut (Node ann xs) = + let movedOut = concatMap moveLinesOut xs + (pre, rest) = span isSpacing movedOut + (post, body) = spanEnd isSpacing rest + in case body of + [] -> pre ++ post + _ -> pre ++ (Node ann body : post) + +moveLinesOut x = [x] + +mergeSpacings :: Spacing -> Spacing -> Spacing +mergeSpacings x y | x > y = mergeSpacings y x +mergeSpacings Break Softspace = Space +mergeSpacings Break Hardspace = Space +mergeSpacings Softbreak Hardspace = Softspace +mergeSpacings (Newlines x) (Newlines y) = Newlines (x + y) +mergeSpacings Emptyline (Newlines x) = Newlines (x + 2) +mergeSpacings Hardspace (Newlines x) = Newlines x +mergeSpacings _ (Newlines x) = Newlines (x + 1) +mergeSpacings _ y = y + +mergeLines :: Doc -> Doc +mergeLines [] = [] +mergeLines (Spacing a : Spacing b : xs) = mergeLines $ Spacing (mergeSpacings a b) : xs +mergeLines (Text a : Text b : xs) = mergeLines $ Text (a <> b) : xs +mergeLines (Node ann xs : ys) = Node ann (mergeLines xs) : mergeLines ys +mergeLines (x : xs) = x : mergeLines xs + +moveLinesIn :: Doc -> Doc +moveLinesIn [] = [] +moveLinesIn (Spacing l : Node (Nest level) xs : ys) = + Node (Nest level) (Spacing l : moveLinesIn xs) : moveLinesIn ys + +moveLinesIn (Node ann xs : ys) = + Node ann (moveLinesIn xs) : moveLinesIn ys + +moveLinesIn (x : xs) = x : moveLinesIn xs + +layout :: Pretty a => Int -> a -> Text +layout w = layoutGreedy w . fixup . pretty + +-- 1. Move and merge Spacings. +-- 2. Convert Softlines to Grouped Lines and Hardspaces to Texts. +-- 3. For each Text or Group, try to fit as much as possible on a line +-- 4. For each Group, if it fits on a single line, render it that way. +-- 5. If not, convert lines to hardlines and unwrap the group + +-- | To support i18n, this function needs to be patched. +textWidth :: Text -> Int +textWidth = Text.length + +-- | Attempt to fit a list of documents in a single line of a specific width. +fits :: Int -> Doc -> Maybe Text +fits c _ | c < 0 = Nothing +fits _ [] = Just "" +fits c (x:xs) = case x of + Text t -> (t<>) <$> fits (c - textWidth t) xs + Spacing Softbreak -> fits c xs + Spacing Break -> fits c xs + Spacing Softspace -> (" "<>) <$> fits (c - 1) xs + Spacing Space -> (" "<>) <$> fits (c - 1) xs + Spacing Hardspace -> (" "<>) <$> fits (c - 1) xs + Spacing Hardline -> Nothing + Spacing Emptyline -> Nothing + Spacing (Newlines _) -> Nothing + Node _ ys -> fits c $ ys ++ xs + +-- | Find the width of the first line in a list of documents, using target +-- width 0, which always forces line breaks when possible. +firstLineWidth :: Doc -> Int +firstLineWidth [] = 0 +firstLineWidth (Text t : xs) = textWidth t + firstLineWidth xs +firstLineWidth (Spacing Hardspace : xs) = 1 + firstLineWidth xs +firstLineWidth (Spacing _ : _) = 0 +firstLineWidth (Node _ xs : ys) = firstLineWidth (xs ++ ys) + +-- | Check if the first line in a list of documents fits a target width given +-- a maximum width, without breaking up groups. +firstLineFits :: Int -> Int -> Doc -> Bool +firstLineFits targetWidth maxWidth docs = go maxWidth docs + where go c _ | c < 0 = False + go c [] = maxWidth - c <= targetWidth + go c (Text t : xs) = go (c - textWidth t) xs + go c (Spacing Hardspace : xs) = go (c - 1) xs + go c (Spacing _ : _) = maxWidth - c <= targetWidth + go c (Node Group ys : xs) = + case fits (c - firstLineWidth xs) ys of + Nothing -> go c (ys ++ xs) + Just t -> go (c - textWidth t) xs + + go c (Node _ ys : xs) = go c (ys ++ xs) + +-- | +data Chunk = Chunk Int DocE + +indent :: Int -> Int -> Text +indent n i = Text.replicate n "\n" <> Text.replicate i " " + +unChunk :: Chunk -> DocE +unChunk (Chunk _ doc) = doc + +-- tw Target Width +-- cc Current Column +-- ci Current Indentation +-- ti Target Indentation +layoutGreedy :: Int -> Doc -> Text +layoutGreedy tw doc = Text.concat $ go 0 0 [Chunk 0 $ Node Group doc] + where go _ _ [] = [] + go cc ci (Chunk ti x : xs) = case x of + Text t -> t : go (cc + textWidth t) ci xs + + Spacing Break -> indent 1 ti : go ti ti xs + Spacing Space -> indent 1 ti : go ti ti xs + Spacing Hardspace -> " " : go (cc + 1) ci xs + Spacing Hardline -> indent 1 ti : go ti ti xs + Spacing Emptyline -> indent 2 ti : go ti ti xs + Spacing (Newlines n) -> indent n ti : go ti ti xs + + Spacing Softbreak + | firstLineFits (tw - cc) (tw - ti) (map unChunk xs) + -> go cc ci xs + | otherwise -> indent 1 ti : go ti ti xs + + Spacing Softspace + | firstLineFits (tw - cc - 1) (tw - ti) (map unChunk xs) + -> " " : go (cc + 1) ci xs + | otherwise -> indent 1 ti : go ti ti xs + + Node (Nest l) ys -> go cc ci $ map (Chunk (ti + l)) ys ++ xs + Node Base ys -> go cc ci $ map (Chunk ci) ys ++ xs + Node Group ys -> + case fits (tw - cc - firstLineWidth (map unChunk xs)) ys of + Nothing -> go cc ci $ map (Chunk ti) ys ++ xs + Just t -> t : go (cc + textWidth t) ci xs diff --git a/src/Nixfmt/Pretty.hs b/src/Nixfmt/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Nixfmt/Pretty.hs @@ -0,0 +1,404 @@ +{- © 2019 Serokell + - © 2019 Lars Jellema + - + - SPDX-License-Identifier: MPL-2.0 + -} + +{-# LANGUAGE FlexibleInstances, LambdaCase, OverloadedStrings #-} + +module Nixfmt.Pretty where + +import Prelude hiding (String) + +import Data.Char (isSpace) +import Data.Maybe (fromMaybe) +import Data.Text (Text, isPrefixOf, isSuffixOf, stripPrefix) +import qualified Data.Text as Text + (dropEnd, empty, init, isInfixOf, last, null, replace, strip, takeWhile) + +import Nixfmt.Predoc + (Doc, Pretty, base, emptyline, group, hardline, hardspace, hcat, line, line', + nest, newline, pretty, sepBy, softline, softline', text, textWidth) +import Nixfmt.Types + (Ann(..), Binder(..), Expression(..), File(..), Leaf, ParamAttr(..), + Parameter(..), Selector(..), SimpleSelector(..), StringPart(..), Term(..), + Token(..), TrailingComment(..), Trivia, Trivium(..), tokenText) +import Nixfmt.Util (commonIndentation) + +prettyCommentLine :: Text -> Doc +prettyCommentLine l + | Text.null l = emptyline + | otherwise = text l <> hardline + +toLineComment :: Text -> Trivium +toLineComment c = LineComment $ fromMaybe (" " <> c) $ stripPrefix "*" c + +instance Pretty TrailingComment where + pretty (TrailingComment c) + = hardspace <> text "#" <> hardspace <> text c <> hardline + +instance Pretty Trivium where + pretty EmptyLine = emptyline + pretty (LineComment c) = text "#" <> pretty c <> hardline + pretty (BlockComment c) + | all ("*" `isPrefixOf`) (tail c) = hcat (map toLineComment c) + | otherwise + = base $ text "/*" <> hardspace + <> nest 3 (hcat (map prettyCommentLine c)) + <> text "*/" <> hardline + +instance Pretty [Trivium] where + pretty [] = mempty + pretty trivia = hardline <> hcat trivia + +instance Pretty a => Pretty (Ann a) where + pretty (Ann x trailing leading) + = pretty x <> pretty trailing <> pretty leading + +instance Pretty SimpleSelector where + pretty (IDSelector i) = pretty i + pretty (InterpolSelector interpol) = pretty interpol + pretty (StringSelector (Ann s trailing leading)) + = prettySimpleString s <> pretty trailing <> pretty leading + +instance Pretty Selector where + pretty (Selector dot sel Nothing) + = pretty dot <> pretty sel + + pretty (Selector dot sel (Just (kw, def))) + = pretty dot <> pretty sel + <> hardspace <> pretty kw <> hardspace <> pretty def + +instance Pretty Binder where + pretty (Inherit inherit Nothing ids semicolon) + = base $ group (pretty inherit <> softline + <> nest 2 (sepBy softline ids)) <> pretty semicolon + + pretty (Inherit inherit source ids semicolon) + = base $ group (pretty inherit <> hardspace + <> pretty source <> line + <> nest 2 (sepBy softline ids)) <> pretty semicolon + + pretty (Assignment selectors assign expr semicolon) + = base $ group (hcat selectors <> hardspace + <> nest 2 (pretty assign <> softline <> pretty expr)) + <> pretty semicolon + +-- | Pretty print a term without wrapping it in a group. +prettyTerm :: Term -> Doc +prettyTerm (Token t) = pretty t +prettyTerm (String s) = pretty s +prettyTerm (Selection term selectors) = pretty term <> hcat selectors + +prettyTerm (List (Ann paropen Nothing []) [] parclose) + = pretty paropen <> hardspace <> pretty parclose + +prettyTerm (List (Ann paropen Nothing []) [item] parclose) + | isAbsorbable item + = pretty paropen <> pretty item <> pretty parclose + +prettyTerm (List (Ann paropen trailing leading) items parclose) + = base $ pretty paropen <> pretty trailing <> line + <> nest 2 (pretty leading <> sepBy line (map group items)) <> line + <> pretty parclose + +prettyTerm (Set Nothing (Ann paropen Nothing []) [] parclose) + = pretty paropen <> hardspace <> pretty parclose + +prettyTerm (Set krec (Ann paropen trailing leading) binders parclose) + = base $ pretty (fmap ((<>hardspace) . pretty) krec) + <> pretty paropen <> pretty trailing <> line + <> nest 2 (pretty leading <> sepBy hardline binders) <> line + <> pretty parclose + +prettyTerm (Parenthesized paropen expr parclose) + = base $ pretty paropen <> nest 2 (group expr) <> pretty parclose + +instance Pretty Term where + pretty l@(List _ _ _) = group $ prettyTerm l + pretty x = prettyTerm x + +toLeading :: Maybe TrailingComment -> Trivia +toLeading Nothing = [] +toLeading (Just (TrailingComment c)) = [LineComment (" " <> c)] + +prettyComma :: Maybe Leaf -> Doc +prettyComma Nothing = mempty +prettyComma (Just comma) = softline' <> pretty comma <> hardspace + +instance Pretty ParamAttr where + pretty (ParamAttr name Nothing comma) + = pretty name <> prettyComma comma + + pretty (ParamAttr name (Just (qmark, def)) comma) + = group (pretty name <> hardspace <> pretty qmark + <> absorb softline mempty (Just 2) def) + <> prettyComma comma + + pretty (ParamEllipsis ellipsis) + = pretty ellipsis + +instance Pretty Parameter where + pretty (IDParameter i) = pretty i + pretty (SetParameter bopen attrs bclose) + = group $ pretty bopen <> hardspace + <> hcat attrs <> softline + <> pretty bclose + + pretty (ContextParameter param1 at param2) + = pretty param1 <> pretty at <> pretty param2 + +isAbsorbable :: Term -> Bool +isAbsorbable (String (Ann parts@(_:_:_) _ _)) + = not $ isSimpleString parts +isAbsorbable (Set _ _ (_:_) _) = True +isAbsorbable (List (Ann _ Nothing []) [item] _) = isAbsorbable item +isAbsorbable (Parenthesized (Ann _ Nothing []) (Term t) _) = isAbsorbable t +isAbsorbable (List _ (_:_:_) _) = True +isAbsorbable _ = False + +absorb :: Doc -> Doc -> Maybe Int -> Expression -> Doc +absorb left right _ (Term t) + | isAbsorbable t = toHardspace left <> prettyTerm t <> toHardspace right + where toHardspace x | x == mempty = mempty + | x == softline' = mempty + | x == line' = mempty + | otherwise = hardspace + +absorb left right Nothing x = left <> pretty x <> right +absorb left right (Just level) x + = left <> nest level (pretty x) <> right + +absorbSet :: Expression -> Doc +absorbSet = absorb line mempty Nothing + +absorbThen :: Expression -> Doc +absorbThen (Term t) | isAbsorbable t = hardspace <> prettyTerm t <> hardspace +absorbThen x = line <> nest 2 (group x) <> line + +absorbElse :: Expression -> Doc +absorbElse (If if_ cond then_ expr0 else_ expr1) + = hardspace <> pretty if_ <> hardspace <> group cond <> hardspace + <> pretty then_ <> absorbThen expr0 + <> pretty else_ <> absorbElse expr1 + +absorbElse (Term t) | isAbsorbable t = hardspace <> prettyTerm t +absorbElse x = line <> nest 2 (group x) + +absorbApp :: Expression -> Doc +absorbApp (Application f x) = softline <> pretty f <> absorbApp x +absorbApp (Term t) | isAbsorbable t = hardspace <> group (prettyTerm t) +absorbApp x = softline <> pretty x + +instance Pretty Expression where + pretty (Term t) = pretty t + + pretty (With with expr0 semicolon expr1) + = base (pretty with <> hardspace + <> nest 2 (group expr0) <> pretty semicolon) + <> absorbSet expr1 + + pretty (Let (Ann let_ letTrailing letLeading) binders + (Ann in_ inTrailing inLeading) expr) + = base $ group letPart <> line <> group inPart + where letPart = pretty let_ <> pretty letTrailing <> line <> letBody + inPart = pretty in_ <> hardspace <> pretty expr + letBody = nest 2 $ + pretty letLeading + <> sepBy hardline binders + <> pretty (toLeading inTrailing) + <> pretty inLeading + + pretty (Assert assert cond semicolon expr) + = base (pretty assert <> hardspace + <> nest 2 (group cond) <> pretty semicolon) + <> absorbSet expr + + pretty (If if_ cond then_ expr0 else_ expr1) + = base $ group $ + pretty if_ <> hardspace <> group cond <> hardspace + <> pretty then_ <> absorbThen expr0 + <> pretty else_ <> absorbElse expr1 + + pretty (Abstraction (IDParameter param) colon body) + = pretty param <> pretty colon <> absorbAbs body + where absorbAbs (Abstraction (IDParameter param0) colon0 body0) = + hardspace <> pretty param0 <> pretty colon0 <> absorbAbs body0 + absorbAbs x = absorbSet x + + pretty (Abstraction param colon body) + = pretty param <> pretty colon <> absorbSet body + + pretty (Application f x) = group $ pretty f <> absorbApp x + + pretty (Operation a op b) + = pretty a <> softline + <> pretty op <> hardspace <> pretty b + + pretty (MemberCheck expr qmark sel) + = pretty expr <> softline + <> pretty qmark <> hardspace <> hcat sel + + pretty (Negation minus expr) + = pretty minus <> pretty expr + + pretty (Inversion bang expr) + = pretty bang <> pretty expr + +instance Pretty File where + pretty (File (Ann _ Nothing leading) expr) + = group $ hcat leading <> pretty expr <> hardline + + pretty (File (Ann _ (Just (TrailingComment trailing)) leading) expr) + = group $ text "# " <> pretty trailing <> hardline + <> hcat leading <> pretty expr <> hardline + +instance Pretty Token where + pretty = text . tokenText + +instance Pretty [Token] where + pretty = hcat + +-- STRINGS + +isSimpleSelector :: Selector -> Bool +isSimpleSelector (Selector _ (IDSelector _) Nothing) = True +isSimpleSelector _ = False + +isSimple :: Expression -> Bool +isSimple (Term (Token (Ann (Identifier _) Nothing []))) = True +isSimple (Term (Selection t selectors)) + = isSimple (Term t) && all isSimpleSelector selectors +isSimple _ = False + +hasQuotes :: [StringPart] -> Bool +hasQuotes [] = False +hasQuotes (TextPart x : xs) = Text.isInfixOf "\"" x || hasQuotes xs +hasQuotes (_ : xs) = hasQuotes xs + +hasDualQuotes :: [StringPart] -> Bool +hasDualQuotes [] = False +hasDualQuotes (TextPart x : xs) = Text.isInfixOf "''" x || hasDualQuotes xs +hasDualQuotes (_ : xs) = hasDualQuotes xs + +endsInSingleQuote :: [StringPart] -> Bool +endsInSingleQuote [] = False +endsInSingleQuote xs = + case last xs of + (TextPart x) -> x /= Text.empty && Text.last x == '\'' + _ -> False + +isIndented :: [[StringPart]] -> Bool +isIndented parts = + case commonIndentation inits of + Just "" -> False + _ -> True + where textInit (TextPart t : xs) = t <> textInit xs + textInit _ = "" + nonEmpty (TextPart "" : xs) = nonEmpty xs + nonEmpty [] = False + nonEmpty _ = True + inits = map textInit $ filter nonEmpty parts + +isEmptyLine :: [StringPart] -> Bool +isEmptyLine [] = True +isEmptyLine [TextPart t] = Text.null $ Text.strip t +isEmptyLine _ = False + +isSimpleString :: [[StringPart]] -> Bool +isSimpleString [parts] + | hasDualQuotes parts = True + | endsInSingleQuote parts = True + | isIndented [parts] = True + | hasQuotes parts = False + | otherwise = True + +isSimpleString parts + | all isEmptyLine parts = True + | isIndented parts = True + | otherwise = False + +instance Pretty StringPart where + pretty (TextPart t) = text t + pretty (Interpolation paropen (Term t) parclose) + | isAbsorbable t + = group $ pretty paropen <> prettyTerm t <> pretty parclose + + pretty (Interpolation paropen expr parclose) + | isSimple expr + = pretty paropen <> pretty expr <> pretty parclose + | otherwise + = group $ pretty paropen <> line' + <> nest 2 (pretty expr) <> line' + <> pretty parclose + +instance Pretty [StringPart] where + pretty [Interpolation paropen expr parclose] + = group $ pretty paropen <> pretty expr <> pretty parclose + + pretty (TextPart t : parts) + = text t <> nest indentation (hcat parts) + where indentation = textWidth $ Text.takeWhile isSpace t + + pretty parts = hcat parts + +instance Pretty [[StringPart]] where + pretty parts + | isSimpleString parts = prettySimpleString parts + | otherwise = prettyIndentedString parts + +type UnescapeInterpol = Text -> Text +type EscapeText = Text -> Text + +prettyLine :: EscapeText -> UnescapeInterpol -> [StringPart] -> Doc +prettyLine escapeText unescapeInterpol + = pretty . unescapeInterpols . map escape + where escape (TextPart t) = TextPart (escapeText t) + escape x = x + + unescapeInterpols [] = [] + unescapeInterpols (TextPart t : TextPart u : xs) + = unescapeInterpols (TextPart (t <> u) : xs) + unescapeInterpols (TextPart t : xs@(Interpolation _ _ _ : _)) + = TextPart (unescapeInterpol t) : unescapeInterpols xs + unescapeInterpols (x : xs) = x : unescapeInterpols xs + +prettySimpleString :: [[StringPart]] -> Doc +prettySimpleString parts = group $ + text "\"" + <> (sepBy (text "\\n") (map (prettyLine escape unescapeInterpol) parts)) + <> text "\"" + where escape + = Text.replace "$\\${" "$${" + . Text.replace "${" "\\${" + . Text.replace "\"" "\\\"" + . Text.replace "\r" "\\r" + . Text.replace "\\" "\\\\" + + unescapeInterpol t + | "$" `isSuffixOf` t = Text.init t <> "\\$" + | otherwise = t + +prettyIndentedString :: [[StringPart]] -> Doc +prettyIndentedString parts = group $ base $ + text "''" <> line' + <> nest 2 (sepBy newline (map (prettyLine escape unescapeInterpol) parts)) + <> text "''" + where escape + = Text.replace "$''${" "$${" + . Text.replace "${" "''${" + . Text.replace "''" "'''" + + unescapeInterpol t + | Text.null t = t + | Text.last t /= '$' = t + | trailingQuotes (Text.init t) `mod` 3 == 0 + = Text.init t <> "''$" + | trailingQuotes (Text.init t) `mod` 3 == 1 + = Text.dropEnd 2 t <> "''\\'''$" + | otherwise + = error "should never happen after escape" + + trailingQuotes t + | "'" `isSuffixOf` t = 1 + trailingQuotes (Text.init t) + | otherwise = 0 :: Int diff --git a/src/Nixfmt/Types.hs b/src/Nixfmt/Types.hs new file mode 100644 --- /dev/null +++ b/src/Nixfmt/Types.hs @@ -0,0 +1,257 @@ +{- © 2019 Serokell + - © 2019 Lars Jellema + - + - SPDX-License-Identifier: MPL-2.0 + -} + +{-# LANGUAGE OverloadedStrings #-} + +module Nixfmt.Types where + +import Prelude hiding (String) + +import Data.Text (Text, pack) +import Data.Void (Void) +import qualified Text.Megaparsec as MP (ParseErrorBundle, Parsec) + +-- | A @megaparsec@ @ParsecT@ specified for use with @nixfmt@. +type Parser = MP.Parsec Void Text + +-- | A @megaparsec@ @ParseErrorBundle@ specified for use with @nixfmt@. +type ParseErrorBundle = MP.ParseErrorBundle Text Void + +data Trivium + = EmptyLine + | LineComment Text + | BlockComment [Text] + deriving (Show) + +type Trivia = [Trivium] + +newtype TrailingComment = TrailingComment Text deriving (Show) + +data Ann a + = Ann a (Maybe TrailingComment) Trivia + deriving (Show) + +type Leaf = Ann Token + +data StringPart + = TextPart Text + | Interpolation Leaf Expression Token + deriving (Show) + +type String = Ann [[StringPart]] + +data SimpleSelector + = IDSelector Leaf + | InterpolSelector (Ann StringPart) + | StringSelector String + deriving (Show) + +data Selector + = Selector (Maybe Leaf) SimpleSelector (Maybe (Leaf, Term)) + deriving (Show) + +data Binder + = Inherit Leaf (Maybe Term) [Leaf] Leaf + | Assignment [Selector] Leaf Expression Leaf + deriving (Show) + +data Term + = Token Leaf + | String String + | List Leaf [Term] Leaf + | Set (Maybe Leaf) Leaf [Binder] Leaf + | Selection Term [Selector] + | Parenthesized Leaf Expression Leaf + deriving (Show) + +data ParamAttr + = ParamAttr Leaf (Maybe (Leaf, Expression)) (Maybe Leaf) + | ParamEllipsis Leaf + deriving (Show) + +data Parameter + = IDParameter Leaf + | SetParameter Leaf [ParamAttr] Leaf + | ContextParameter Parameter Leaf Parameter + deriving (Show) + +data Expression + = Term Term + | With Leaf Expression Leaf Expression + | Let Leaf [Binder] Leaf Expression + | Assert Leaf Expression Leaf Expression + | If Leaf Expression Leaf Expression Leaf Expression + | Abstraction Parameter Leaf Expression + + | Application Expression Expression + | Operation Expression Leaf Expression + | MemberCheck Expression Leaf [Selector] + | Negation Leaf Expression + | Inversion Leaf Expression + deriving (Show) + +data File + = File Leaf Expression + deriving (Show) + +data Token + = Integer Int + | Float Double + | Identifier Text + | Path Text + | EnvPath Text + + | KAssert + | KElse + | KIf + | KIn + | KInherit + | KLet + | KOr + | KRec + | KThen + | KWith + + | TBraceOpen + | TBraceClose + | TBrackOpen + | TBrackClose + | TInterOpen + | TInterClose + | TParenOpen + | TParenClose + + | TAssign + | TAt + | TColon + | TComma + | TDot + | TDoubleQuote + | TDoubleSingleQuote + | TEllipsis + | TQuestion + | TSemicolon + + | TConcat + | TNegate + | TUpdate + + | TPlus + | TMinus + | TMul + | TDiv + + | TAnd + | TOr + | TEqual + | TGreater + | TGreaterEqual + | TImplies + | TLess + | TLessEqual + | TNot + | TUnequal + + | SOF + deriving (Eq, Show) + + +data Fixity + = Prefix + | InfixL + | InfixN + | InfixR + | Postfix + deriving (Show) + +data Operator + = Op Fixity Token + | Apply + deriving (Show) + +-- | A list of lists of operators where lists that come first contain operators +-- that bind more strongly. +operators :: [[Operator]] +operators = + [ [ Apply ] + , [ Op Prefix TMinus ] + , [ Op Postfix TQuestion ] + , [ Op InfixR TConcat ] + , [ Op InfixL TMul + , Op InfixL TDiv ] + , [ Op InfixL TPlus + , Op InfixL TMinus ] + , [ Op Prefix TNot ] + , [ Op InfixR TUpdate ] + , [ Op InfixN TLess + , Op InfixN TGreater + , Op InfixN TLessEqual + , Op InfixN TGreaterEqual ] + , [ Op InfixN TEqual + , Op InfixN TUnequal ] + , [ Op InfixL TAnd ] + , [ Op InfixL TOr ] + , [ Op InfixL TImplies ] + ] + +tokenText :: Token -> Text +tokenText (Identifier i) = i +tokenText (Integer i) = pack (show i) +tokenText (Float f) = pack (show f) +tokenText (Path p) = p +tokenText (EnvPath p) = "<" <> p <> ">" + +tokenText KAssert = "assert" +tokenText KElse = "else" +tokenText KIf = "if" +tokenText KIn = "in" +tokenText KInherit = "inherit" +tokenText KLet = "let" +tokenText KOr = "or" +tokenText KRec = "rec" +tokenText KThen = "then" +tokenText KWith = "with" + +tokenText TBraceOpen = "{" +tokenText TBraceClose = "}" +tokenText TBrackOpen = "[" +tokenText TBrackClose = "]" +tokenText TInterOpen = "${" +tokenText TInterClose = "}" +tokenText TParenOpen = "(" +tokenText TParenClose = ")" + +tokenText TAssign = "=" +tokenText TAt = "@" +tokenText TColon = ":" +tokenText TComma = "," +tokenText TDot = "." +tokenText TDoubleQuote = "\"" +tokenText TDoubleSingleQuote = "''" +tokenText TEllipsis = "..." +tokenText TQuestion = "?" +tokenText TSemicolon = ";" + +tokenText TPlus = "+" +tokenText TMinus = "-" +tokenText TMul = "*" +tokenText TDiv = "/" +tokenText TConcat = "++" +tokenText TNegate = "-" +tokenText TUpdate = "//" + +tokenText TAnd = "&&" +tokenText TOr = "||" +tokenText TEqual = "==" +tokenText TGreater = ">" +tokenText TGreaterEqual = ">=" +tokenText TImplies = "->" +tokenText TLess = "<" +tokenText TLessEqual = "<=" +tokenText TNot = "!" +tokenText TUnequal = "!=" + +tokenText SOF = "" diff --git a/src/Nixfmt/Util.hs b/src/Nixfmt/Util.hs new file mode 100644 --- /dev/null +++ b/src/Nixfmt/Util.hs @@ -0,0 +1,80 @@ +{- © 2019 Serokell + - © 2019 Lars Jellema + - + - SPDX-License-Identifier: MPL-2.0 + -} + +module Nixfmt.Util + ( manyP + , someP + , manyText + , someText + , commonPrefix + , commonIndentation + , dropCommonIndentation + , identChar + , pathChar + , schemeChar + , uriChar + ) where + +import Data.Char (isAlpha, isDigit, isSpace) +import Data.Maybe (fromMaybe) +import Data.Text as Text + (Text, commonPrefixes, concat, empty, stripEnd, stripPrefix, takeWhile) +import Text.Megaparsec + (ParsecT, Stream, Token, Tokens, many, some, takeWhile1P, takeWhileP) + +charClass :: [Char] -> Char -> Bool +charClass s c = isAlpha c || isDigit c || elem c s + +identChar :: Char -> Bool +identChar = charClass "_'-" + +pathChar :: Char -> Bool +pathChar = charClass "._-+~" + +schemeChar :: Char -> Bool +schemeChar = charClass "-.+" + +uriChar :: Char -> Bool +uriChar = charClass "~!@$%&*-=_+:',./?" + +-- | Match one or more characters that match a predicate. +someP :: (Stream s, Ord e) => (Token s -> Bool) -> ParsecT e s m (Tokens s) +someP = takeWhile1P Nothing + +-- | Match zero or more characters that match a predicate. +manyP :: (Stream s, Ord e) => (Token s -> Bool) -> ParsecT e s m (Tokens s) +manyP = takeWhileP Nothing + +-- | Match one or more texts and return the concatenation. +someText :: (Stream s, Ord e) => ParsecT e s m Text -> ParsecT e s m Text +someText p = Text.concat <$> some p + +-- | Match zero or more texts and return the concatenation. +manyText :: (Stream s, Ord e) => ParsecT e s m Text -> ParsecT e s m Text +manyText p = Text.concat <$> many p + +-- | The longest common prefix of the arguments. +commonPrefix :: Text -> Text -> Text +commonPrefix a b = + case commonPrefixes a b of + Nothing -> empty + Just (prefix, _, _) -> prefix + +-- | The longest common prefix consisting of only whitespace. The longest common +-- prefix of zero texts is infinite, represented as Nothing. +commonIndentation :: [Text] -> Maybe Text +commonIndentation [] = Nothing +commonIndentation [x] = Just $ Text.takeWhile isSpace x +commonIndentation (x:y:xs) = commonIndentation (commonPrefix x y : xs) + +-- | Strip the longest common indentation from a list of lines. Empty lines do +-- not count towards the common indentation. +dropCommonIndentation :: [Text] -> [Text] +dropCommonIndentation unstrippedLines = + let strippedLines = map stripEnd unstrippedLines + in case commonIndentation (filter (/=empty) strippedLines) of + Nothing -> map (const empty) strippedLines + Just indentation -> map (fromMaybe empty . stripPrefix indentation) strippedLines