├── .gitignore ├── .travis.yml ├── .travis ├── attach-binary.sh ├── install-ghr.sh └── install-stack.sh ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── TAGS ├── app └── Main.hs ├── azure-pipelines.yml ├── mkrelease.sh ├── package.yaml ├── psfmt.cabal ├── src ├── Lib.hs └── Psfmt │ ├── Imports.hs │ ├── RecordAliases.hs │ ├── Traversals │ ├── TraverseSource.hs │ └── TraverseStyle.hs │ └── Utils.hs ├── stack.yaml └── test ├── Spec.hs └── data ├── Imports.out.purs ├── Imports.purs ├── Rave.out.purs ├── Rave.purs ├── Types.out.purs └── Types.purs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | cabal.project.local~ 21 | .HTF/ 22 | .ghc.environment.* 23 | .idea 24 | /psfmt.iml 25 | release -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Adapted from https://github.com/commercialhaskell/stack 2 | language: nix 3 | sudo: false 4 | 5 | cache: 6 | directories: 7 | - $HOME/.ghc 8 | - $HOME/.cabal 9 | - $HOME/.stack 10 | - .stack-work 11 | 12 | matrix: 13 | fast_finish: true 14 | include: 15 | # Add build targets here 16 | - env: GHCVER=8.6.3 CACHE_NAME=8.6.3 BUILD_BINARY=1 17 | compiler: ": #stack 8.6.3" 18 | addons: {apt: {packages: [ghc-8.6.3], sources: [hvr-ghc]}} 19 | 20 | - env: GHCVER=8.6.3 CACHE_NAME=8.6.3-osx BUILD_BINARY=1 21 | os: osx 22 | compiler: ": #stack 8.6.3" 23 | addons: {apt: {packages: [ghc-8.6.3], sources: [hvr-ghc]}} 24 | 25 | install: 26 | - unset CC 27 | - export PATH=$HOME/.local/bin:/opt/ghc/$GHCVER/bin:$PATH 28 | - ./.travis/install-ghr.sh 29 | - ./.travis/install-stack.sh 30 | 31 | script: 32 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 33 | - GHC_OPTIONS="-Werror" 34 | - | 35 | set -ex 36 | # Run tests 37 | stack --no-terminal test --ghc-options="$GHC_OPTIONS" 38 | set +ex 39 | 40 | after_success: 41 | - | 42 | # Build and ship binary 43 | ./.travis/attach-binary.sh 44 | -------------------------------------------------------------------------------- /.travis/attach-binary.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | set -o errexit -o verbose 3 | 4 | if test ! "$BUILD_BINARY" || test ! "$TRAVIS_TAG" 5 | then 6 | echo 'This is not a release build.' 7 | elif test ! "$GITHUB_TOKEN" 8 | then 9 | echo 'The GITHUB_TOKEN environment variable is not set!' 10 | exit 1 11 | else 12 | echo "Building binary for $TRAVIS_OS_NAME to $TRAVIS_TAG..." 13 | stack build --ghc-options -O2 --pedantic 14 | echo "Attaching binary for $TRAVIS_OS_NAME to $TRAVIS_TAG..." 15 | OWNER="$(echo "$TRAVIS_REPO_SLUG" | cut -f1 -d/)" 16 | REPO="$(echo "$TRAVIS_REPO_SLUG" | cut -f2 -d/)" 17 | BIN="$(stack path --local-install-root)/bin/$REPO" 18 | BUNDLE_NAME="$REPO-$TRAVIS_TAG-$TRAVIS_OS_NAME.tar.gz" 19 | cp "$BIN" "./$REPO" 20 | chmod +x "./$REPO" 21 | tar -czf "$BUNDLE_NAME" "$REPO" 22 | echo "SHA256:" 23 | shasum -a 256 "$BUNDLE_NAME" 24 | ghr -t "$GITHUB_TOKEN" -u "$OWNER" -r "$REPO" --replace "$(git describe --tags)" "$BUNDLE_NAME" 25 | fi 26 | -------------------------------------------------------------------------------- /.travis/install-ghr.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | set -o errexit -o verbose 3 | 4 | if test ! "$BUILD_BINARY" || test ! "$TRAVIS_TAG" 5 | then 6 | echo 'This is not a release build.' 7 | else 8 | if [ "$TRAVIS_OS_NAME" = "linux" ] 9 | then 10 | ARCH="linux" 11 | else 12 | ARCH="darwin" 13 | fi 14 | echo "Installing ghr" 15 | URL="https://github.com/tcnksm/ghr/releases/download/v0.5.4/ghr_v0.5.4_${ARCH}_386.zip" 16 | curl -L ${URL} > ghr.zip 17 | mkdir -p "$HOME/bin" 18 | export PATH="$HOME/bin:$PATH" 19 | unzip ghr.zip -d "$HOME/bin" 20 | rm ghr.zip 21 | fi 22 | -------------------------------------------------------------------------------- /.travis/install-stack.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # Adapted from https://github.com/commercialhaskell/stack 4 | 5 | set -eux 6 | 7 | travis_retry() { 8 | cmd=$* 9 | $cmd || (sleep 2 && $cmd) || (sleep 10 && $cmd) 10 | } 11 | 12 | fetch_stack_osx() { 13 | curl -skL https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin; 14 | } 15 | 16 | fetch_stack_linux() { 17 | curl -sL https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'; 18 | } 19 | 20 | # We need stack to generate cabal files with precise bounds, even for cabal 21 | # builds. 22 | mkdir -p ~/.local/bin; 23 | if [ "$(uname)" = "Darwin" ]; then 24 | travis_retry fetch_stack_osx 25 | else 26 | travis_retry fetch_stack_linux 27 | fi 28 | 29 | travis_retry stack --no-terminal setup; 30 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for psfmt 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2019 Simon Hafner 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # psfmt 2 | PureScript formatter 3 | 4 | # Usage 5 | 6 | For formatting every `.purs` file in the current directory: 7 | 8 | ``` 9 | psfmt 10 | ``` 11 | 12 | For formatting every `.purs` file in specific directories: 13 | 14 | ``` 15 | psfmt src test 16 | ``` 17 | 18 | For formatting a specific file: 19 | 20 | ``` 21 | psfmt File.purs 22 | ``` 23 | 24 | # Philosophy 25 | ## No configuration 26 | 27 | The formatter shouldn't have configuration options. One standard for all, no 28 | bikeshedding. 29 | 30 | ## Reduce diffs 31 | 32 | Make formatting such that a code change changes the minimal lines of code in a 33 | git diff. 34 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /TAGS: -------------------------------------------------------------------------------- 1 | 2 | ./Setup.hs,15 3 | main main1,2 4 | 5 | ./app/Main.hs,37 6 | module Main Main0,1 7 | main main7,8 8 | 9 | ./src/Lib.hs,38 10 | module LibLib0,1 11 | format format8,9 12 | 13 | ./test/Spec.hs,155 14 | module Spec Spec0,1 15 | main main12,13 16 | tests tests15,16 17 | goldenTests goldenTests20,21 18 | runGoldenTest runGoldenTest25,26 19 | processText processText32,33 20 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Lib 4 | import System.Environment 5 | import qualified Data.Text.IO as T 6 | import qualified Data.Text as T 7 | import Language.PureScript.CST.Errors 8 | import System.Directory 9 | import System.Directory.PathWalk 10 | import Data.List (isSuffixOf) 11 | import System.FilePath 12 | 13 | import Relude 14 | 15 | main :: IO () 16 | main = do 17 | args <- getArgs 18 | let 19 | dirsOrFiles = if length args > 0 then args else ["."] 20 | findMoreFiles directory = do 21 | pathWalkAccumulate directory $ \dir subdirs files -> 22 | pure $ fmap (\f -> dir f) $ filter (isSuffixOf ".purs") files 23 | files <- filterM doesFileExist dirsOrFiles 24 | dirs <- filterM doesDirectoryExist dirsOrFiles 25 | filesInDirs <- fmap join $ traverse findMoreFiles dirs 26 | let toFormat = files <> filesInDirs 27 | traverse_ formatFile toFormat 28 | T.hPutStr stdout $ "Formatted " <> (show $ length toFormat) <> " files\n" 29 | 30 | formatFile :: FilePath -> IO () 31 | formatFile filename = do 32 | content <- T.readFile filename 33 | case format content of 34 | Left e -> 35 | T.hPutStr stderr $ 36 | "Errors while formatting file " <> (T.pack filename) <> ": " <> (T.pack $ show e) 37 | Right output -> 38 | T.writeFile filename output 39 | -------------------------------------------------------------------------------- /azure-pipelines.yml: -------------------------------------------------------------------------------- 1 | # Starter pipeline 2 | # Start with a minimal pipeline that you can customize to build and deploy your code. 3 | # Add steps that build, run tests, deploy, and more: 4 | # https://aka.ms/yaml 5 | 6 | trigger: 7 | - master 8 | 9 | pool: 10 | vmImage: 'Ubuntu-16.04' 11 | 12 | steps: 13 | - bash: | 14 | mkdir -p ~/.local/bin 15 | curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 16 | displayName: Install Stack 17 | - bash: | 18 | export PATH=$HOME/.local/bin:$PATH 19 | stack --no-terminal --install-ghc test --only-dependencies 20 | displayName: Build Dependencies 21 | - bash: | 22 | export PATH=$HOME/.local/bin:$PATH 23 | # Build the package, its tests, and its docs and run the tests 24 | stack test 25 | displayName: Test Package 26 | - bash: | 27 | export PATH=$HOME/.local/bin:$PATH 28 | stack install --local-bin-path $(Build_BinariesDirectory) 29 | - task: ArchiveFiles@2 30 | inputs: 31 | rootFolderOrFile: '$(Build.BinariesDirectory)' 32 | archiveType: 'tar' 33 | -------------------------------------------------------------------------------- /mkrelease.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/bash 2 | 3 | GIT_VERSION=$(git describe --tags) 4 | VERSION=${GIT_VERSION:1} 5 | OS=${uname -s} 6 | DIR=psfmt-$VERSION-$OS 7 | BIN_DIR=release/$DIR/bin 8 | RELEASE_DIR=release/$DIR 9 | 10 | stack install --local-bin-path $BIN_DIR 11 | cp README.md $RELEASE_DIR 12 | pushd release 13 | tar --create --file=$DIR.tar.gz $DIR 14 | popd -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: psfmt 2 | version: 0.2.1 3 | github: "reactormonk/psfmt" 4 | license: BSD3 5 | author: "Simon Hafner" 6 | maintainer: "hafnersimon@gmail.com" 7 | copyright: "LGPLv3" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on GitHub at 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | - text 25 | - filepath 26 | - generic-lens 27 | - relude 28 | - lens 29 | - directory 30 | - pathwalk 31 | - purescript 32 | 33 | default-extensions: 34 | - ApplicativeDo 35 | - BangPatterns 36 | - ConstraintKinds 37 | - DataKinds 38 | - DefaultSignatures 39 | - DeriveFoldable 40 | - DeriveFunctor 41 | - DeriveGeneric 42 | - DeriveLift 43 | - DeriveTraversable 44 | - DerivingStrategies 45 | - EmptyCase 46 | - ExistentialQuantification 47 | - FlexibleContexts 48 | - FlexibleInstances 49 | - FunctionalDependencies 50 | - GADTs 51 | - GeneralizedNewtypeDeriving 52 | - InstanceSigs 53 | - KindSignatures 54 | - LambdaCase 55 | - MultiParamTypeClasses 56 | - MultiWayIf 57 | - NamedFieldPuns 58 | - OverloadedStrings 59 | - PatternSynonyms 60 | - RankNTypes 61 | - ScopedTypeVariables 62 | - StandaloneDeriving 63 | - TupleSections 64 | - TypeApplications 65 | - TypeFamilies 66 | - TypeFamilyDependencies 67 | - TypeOperators 68 | - NoImplicitPrelude 69 | 70 | library: 71 | source-dirs: src 72 | 73 | executables: 74 | psfmt: 75 | main: Main.hs 76 | source-dirs: app 77 | ghc-options: 78 | - -threaded 79 | - -rtsopts 80 | - -with-rtsopts=-N 81 | - -j4 +RTS -A32m -RTS 82 | - -optl=-pthread 83 | - -optc-Os 84 | - -fPIC 85 | - -optP-Wno-nonportable-include-path 86 | dependencies: 87 | - psfmt 88 | 89 | tests: 90 | psfmt-test: 91 | main: Spec.hs 92 | source-dirs: test 93 | ghc-options: 94 | - -threaded 95 | - -rtsopts 96 | - -with-rtsopts=-N 97 | - -j4 +RTS -A32m -RTS 98 | - -optP-Wno-nonportable-include-path 99 | dependencies: 100 | - psfmt 101 | - tasty 102 | - tasty-golden 103 | - pretty-simple 104 | -------------------------------------------------------------------------------- /psfmt.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.31.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 39102d835cb696a5aadc754c278046879cd1046ecfb58770190d36f392ac2bbb 8 | 9 | name: psfmt 10 | version: 0.2.1 11 | description: Please see the README on GitHub at 12 | homepage: https://github.com/reactormonk/psfmt#readme 13 | bug-reports: https://github.com/reactormonk/psfmt/issues 14 | author: Simon Hafner 15 | maintainer: hafnersimon@gmail.com 16 | copyright: LGPLv3 17 | license: BSD3 18 | license-file: LICENSE 19 | build-type: Simple 20 | extra-source-files: 21 | README.md 22 | ChangeLog.md 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/reactormonk/psfmt 27 | 28 | library 29 | exposed-modules: 30 | Lib 31 | Psfmt.Imports 32 | Psfmt.RecordAliases 33 | Psfmt.Traversals.TraverseSource 34 | Psfmt.Traversals.TraverseStyle 35 | Psfmt.Utils 36 | other-modules: 37 | Paths_psfmt 38 | hs-source-dirs: 39 | src 40 | default-extensions: ApplicativeDo BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies EmptyCase ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings PatternSynonyms RankNTypes ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators NoImplicitPrelude 41 | build-depends: 42 | base >=4.7 && <5 43 | , directory 44 | , filepath 45 | , generic-lens 46 | , lens 47 | , pathwalk 48 | , purescript 49 | , relude 50 | , text 51 | default-language: Haskell2010 52 | 53 | executable psfmt 54 | main-is: Main.hs 55 | other-modules: 56 | Paths_psfmt 57 | hs-source-dirs: 58 | app 59 | default-extensions: ApplicativeDo BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies EmptyCase ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings PatternSynonyms RankNTypes ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators NoImplicitPrelude 60 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -j4 +RTS -A32m -RTS -optl=-pthread -optc-Os -fPIC -optP-Wno-nonportable-include-path 61 | build-depends: 62 | base >=4.7 && <5 63 | , directory 64 | , filepath 65 | , generic-lens 66 | , lens 67 | , pathwalk 68 | , psfmt 69 | , purescript 70 | , relude 71 | , text 72 | default-language: Haskell2010 73 | 74 | test-suite psfmt-test 75 | type: exitcode-stdio-1.0 76 | main-is: Spec.hs 77 | other-modules: 78 | Paths_psfmt 79 | hs-source-dirs: 80 | test 81 | default-extensions: ApplicativeDo BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies EmptyCase ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings PatternSynonyms RankNTypes ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators NoImplicitPrelude 82 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -j4 +RTS -A32m -RTS -optP-Wno-nonportable-include-path 83 | build-depends: 84 | base >=4.7 && <5 85 | , directory 86 | , filepath 87 | , generic-lens 88 | , lens 89 | , pathwalk 90 | , pretty-simple 91 | , psfmt 92 | , purescript 93 | , relude 94 | , tasty 95 | , tasty-golden 96 | , text 97 | default-language: Haskell2010 98 | -------------------------------------------------------------------------------- /src/Lib.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | module Lib 3 | ( format 4 | ) where 5 | 6 | import Relude 7 | 8 | import Language.PureScript.CST.Errors 9 | import Language.PureScript.CST.Print 10 | import Language.PureScript.CST as CST 11 | import Data.Generics.Product 12 | import Control.Lens 13 | import qualified Data.Text as T 14 | 15 | import Psfmt.Imports 16 | import Psfmt.RecordAliases 17 | import Psfmt.Utils 18 | import Psfmt.Traversals.TraverseSource 19 | import Psfmt.Traversals.TraverseStyle 20 | 21 | format :: Text -> Either (NonEmpty ParserError) Text 22 | format input = do 23 | parsed <- parse input 24 | let 25 | extractSource = toListOf traverseSourceToken 26 | tokens = printTokens $ unicodePass $ trailingWhitespacePass $ extractSource $ formatModule parsed 27 | pure $ tokens <> foldMap ppLc (modTrailingComments parsed) 28 | 29 | ppLc :: Comment LineFeed -> Text 30 | ppLc = \case 31 | Comment raw -> raw 32 | Space n -> T.replicate n " " 33 | Line LF -> "\n" 34 | Line CRLF -> "\r\n" 35 | 36 | formatModule :: Module () -> Module () 37 | formatModule Module {..} = 38 | Module 39 | { modAnn = modAnn 40 | , modKeyword = modKeyword 41 | , modNamespace = modNamespace 42 | , modExports = modExports 43 | , modWhere = modWhere 44 | , modImports = sortImports modImports 45 | , modDecls = void . reformatDecl . fmap (\_ -> IndentLevel 0) <$> modDecls 46 | , modTrailingComments = modTrailingComments 47 | } 48 | 49 | reformatDecl :: Declaration IndentLevel -> Declaration IndentLevel 50 | reformatDecl (DeclType a b c d) = reformatTypeDecl a b c d 51 | reformatDecl decl = decl 52 | 53 | trailingWhitespacePass :: [SourceToken] -> [SourceToken] 54 | trailingWhitespacePass tokens = 55 | fmap fun zippedList 56 | where 57 | zippedList = zip tokens (map Just (drop 1 tokens) ++ [Nothing]) 58 | fun :: (SourceToken, Maybe SourceToken) -> SourceToken 59 | fun (current, next) = 60 | if maybe True (any isNewline . tokLeadingComments . tokAnn) next 61 | then 62 | trailWith removeWhiteSpace current 63 | else 64 | current 65 | 66 | unicodePass :: [SourceToken] -> [SourceToken] 67 | unicodePass = fmap (over (field @"tokValue") fun) 68 | where 69 | fun (TokDoubleColon _) = TokDoubleColon ASCII 70 | fun (TokLeftArrow _) = TokLeftArrow ASCII 71 | fun (TokRightArrow _) = TokRightArrow ASCII 72 | fun (TokRightFatArrow _) = TokRightFatArrow ASCII 73 | fun (TokForall _) = TokForall ASCII 74 | fun x = x 75 | -------------------------------------------------------------------------------- /src/Psfmt/Imports.hs: -------------------------------------------------------------------------------- 1 | module Psfmt.Imports where 2 | 3 | import Relude 4 | 5 | import Data.List 6 | import Language.PureScript.CST 7 | import Data.Generics.Product 8 | import Control.Lens 9 | import Psfmt.Utils 10 | 11 | sortImports :: [ImportDecl a] -> [ImportDecl a] 12 | sortImports decls = 13 | let 14 | (specific, unspecific) = partition fun decls 15 | fun imp = isJust (impNames imp) || isJust (impQual imp) 16 | sorter = sortWith (\imp -> (nameValue $ impModule imp)) 17 | cleanWhitespace decl = 18 | if leadingWhitespaceOnly $ impKeyword decl 19 | then set ((field @"impKeyword") . (field @"tokAnn") . (field @"tokLeadingComments")) [Line LF] decl 20 | else decl 21 | addLineFeed decl = 22 | over ((field @"impKeyword") . (field @"tokAnn") . (field @"tokLeadingComments")) (\l -> l ++ [Line LF]) decl 23 | oneLinePre decls' = 24 | over (ix 0) addLineFeed $ map cleanWhitespace decls' 25 | in 26 | (oneLinePre $ sorter unspecific) ++ (oneLinePre $ sorter specific) 27 | 28 | leadingWhitespaceOnly :: SourceToken -> Bool 29 | leadingWhitespaceOnly st = all isWhitespace $ tokLeadingComments $ tokAnn st 30 | -------------------------------------------------------------------------------- /src/Psfmt/RecordAliases.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | module Psfmt.RecordAliases where 3 | 4 | import Relude 5 | 6 | import Data.List 7 | import Language.PureScript.CST as CST 8 | import Language.PureScript.CST.Types as CST 9 | import Data.Generics.Product 10 | import Control.Lens 11 | import Psfmt.Utils 12 | 13 | reformatTypeDecl :: IndentLevel -> DataHead IndentLevel -> SourceToken -> CST.Type IndentLevel -> Declaration IndentLevel 14 | reformatTypeDecl i h st t = 15 | DeclType 16 | i 17 | (reformatHead h) 18 | (trimWhiteSpace st) 19 | (reformatType t) 20 | 21 | reformatType :: CST.Type IndentLevel -> CST.Type IndentLevel 22 | reformatType (TypeRecord a' w) = reformatRecord (a' + 1) (fmap (fmap (+1)) w) 23 | reformatType t = t 24 | 25 | reformatHead :: DataHead a -> DataHead a 26 | reformatHead DataHead {..} = 27 | DataHead 28 | { dataHdKeyword = leadWith replaceWith2LF $ trimWhiteSpace dataHdKeyword 29 | , dataHdName = over (field @"nameTok") trimWhiteSpace dataHdName 30 | , dataHdVars = dataHdVars -- TODO 31 | } 32 | 33 | reformatRecord :: IndentLevel -> (CST.Wrapped (Row IndentLevel)) -> CST.Type IndentLevel 34 | reformatRecord i w = 35 | TypeRecord i 36 | ( indentWrapped i $ 37 | over (field @"wrpValue") (reformatRow i) $ w 38 | ) 39 | 40 | reformatRow :: IndentLevel -> Row IndentLevel -> Row IndentLevel 41 | reformatRow i Row {..} = Row 42 | { rowLabels = fmap (reformatRowLabels i) rowLabels 43 | , rowTail = fmap reformatRowTail rowTail 44 | } 45 | 46 | reformatRowLabels :: IndentLevel -> Separated (Labeled CST.Label (CST.Type IndentLevel)) -> Separated (Labeled CST.Label (CST.Type IndentLevel)) 47 | reformatRowLabels i Separated {..} = Separated 48 | { sepHead = reformatRowLabel sepHead 49 | , sepTail = fmap (reformatTail i) sepTail 50 | } 51 | 52 | reformatTail :: IndentLevel -> (SourceToken, (Labeled CST.Label (CST.Type IndentLevel))) -> (SourceToken, (Labeled CST.Label (CST.Type IndentLevel))) 53 | reformatTail i (token, label) = 54 | ( indentWith i $ trimWhiteSpace token 55 | , reformatRowLabel label) 56 | 57 | reformatRowLabel :: Labeled CST.Label (CST.Type IndentLevel) -> Labeled CST.Label (CST.Type IndentLevel) 58 | reformatRowLabel Labeled {..} = Labeled 59 | { lblLabel = over (field @"lblTok") trimWhiteSpace lblLabel 60 | , lblSep = trimWhiteSpace lblSep 61 | , lblValue = reformatType lblValue 62 | } 63 | 64 | reformatRowTail :: (SourceToken, CST.Type a) -> (SourceToken, CST.Type a) 65 | reformatRowTail = identity -- TODO 66 | -------------------------------------------------------------------------------- /src/Psfmt/Traversals/TraverseSource.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# OPTIONS_GHC -freduction-depth=0 #-} 3 | 4 | module Psfmt.Traversals.TraverseSource where 5 | 6 | import Relude 7 | 8 | import Language.PureScript.CST 9 | 10 | import Data.Generics.Product 11 | import Control.Lens 12 | 13 | -- takes about 2 minutes to compile, so it's in a separate file. 14 | traverseSourceToken :: Traversal' (Module ()) SourceToken 15 | traverseSourceToken = typesUsing @Custom @SourceToken @(Module ()) 16 | 17 | data Custom 18 | type instance Children Custom a = ChildrenCustom a 19 | 20 | type family ChildrenCustom (a :: Relude.Type) where 21 | ChildrenCustom Text = '[] 22 | ChildrenCustom a = Children ChGeneric a 23 | -------------------------------------------------------------------------------- /src/Psfmt/Traversals/TraverseStyle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# OPTIONS_GHC -freduction-depth=0 #-} 3 | 4 | module Psfmt.Traversals.TraverseStyle where 5 | 6 | import Relude 7 | 8 | import Language.PureScript.CST 9 | 10 | import Data.Generics.Product 11 | import Control.Lens 12 | 13 | data Custom 14 | type instance Children Custom a = ChildrenCustom a 15 | 16 | type family ChildrenCustom (a :: Relude.Type) where 17 | ChildrenCustom Text = '[] 18 | ChildrenCustom a = Children ChGeneric a 19 | 20 | traverseSourceStyle :: Traversal' (SourceToken) SourceStyle 21 | traverseSourceStyle = typesUsing @Custom @SourceStyle @SourceToken 22 | -------------------------------------------------------------------------------- /src/Psfmt/Utils.hs: -------------------------------------------------------------------------------- 1 | module Psfmt.Utils where 2 | 3 | import Relude 4 | 5 | import Language.PureScript.CST as CST 6 | 7 | import Data.Generics.Product 8 | import Control.Lens 9 | 10 | isWhitespace :: Comment a -> Bool 11 | isWhitespace (Comment _) = False 12 | isWhitespace (Space _) = True 13 | isWhitespace (Line _) = True 14 | 15 | isNewline :: Comment a -> Bool 16 | isNewline (Comment _) = False 17 | isNewline (Space _) = False 18 | isNewline (Line _) = True 19 | 20 | replaceWhitespaceWith :: [Comment l] -> [Comment l] -> [Comment l] 21 | replaceWhitespaceWith replacement target = 22 | if all isWhitespace target then 23 | replacement 24 | else 25 | target 26 | 27 | replaceWith1Space :: [Comment l] -> [Comment l] 28 | replaceWith1Space = replaceWhitespaceWith [Space 1] 29 | 30 | replaceWithLF :: [Comment LineFeed] -> [Comment LineFeed] 31 | replaceWithLF = replaceWhitespaceWith [Line LF] 32 | 33 | replaceWith2LF :: [Comment LineFeed] -> [Comment LineFeed] 34 | replaceWith2LF = replaceWhitespaceWith [Line LF, Line LF] 35 | 36 | removeWhiteSpace :: [Comment l] -> [Comment l] 37 | removeWhiteSpace = replaceWhitespaceWith [] 38 | 39 | trimWhiteSpace :: SourceToken -> SourceToken 40 | trimWhiteSpace s = 41 | over (field @"tokAnn" . field @"tokLeadingComments") removeWhiteSpace $ 42 | over (field @"tokAnn" . field @"tokTrailingComments") replaceWith1Space $ 43 | s 44 | 45 | newtype IndentLevel = IndentLevel Int -- *2 for distance 46 | deriving (Show, Num) 47 | 48 | indentWith :: IndentLevel -> SourceToken -> SourceToken 49 | indentWith (IndentLevel i) = leadWith (replaceWhitespaceWith [Line LF, Space (i*2)]) 50 | 51 | leadWith :: ([Comment LineFeed] -> [Comment LineFeed]) -> SourceToken -> SourceToken 52 | leadWith fun = over (field @"tokAnn" . field @"tokLeadingComments") fun 53 | 54 | trailWith :: ([Comment Void] -> [Comment Void]) -> SourceToken -> SourceToken 55 | trailWith fun = over (field @"tokAnn" . field @"tokTrailingComments") fun 56 | 57 | indentWrapped :: IndentLevel -> CST.Wrapped a -> CST.Wrapped a 58 | indentWrapped i = 59 | over (field @"wrpOpen") (indentWith i) . 60 | over (field @"wrpClose") (indentWith i) . 61 | trimWrapped 62 | 63 | trimWrapped :: CST.Wrapped a -> CST.Wrapped a 64 | trimWrapped w = 65 | over (field @"wrpOpen") trimWhiteSpace $ 66 | over (field @"wrpClose") trimWhiteSpace $ 67 | w 68 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-13.12 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # - location: 29 | # git: https://github.com/commercialhaskell/stack.git 30 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 31 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # subdirs: 33 | # - auto-update 34 | # - wai 35 | packages: 36 | - . 37 | # Dependency packages to be pulled from upstream that are not in the resolver 38 | # using the same syntax as the packages field. 39 | # (e.g., acme-missiles-0.3) 40 | extra-deps: 41 | - purescript-0.13.0 42 | - network-3.0.1.1 43 | - git: https://github.com/kcsongor/generic-lens.git 44 | commit: cf20ae3a0f27d25edf97c79b6635f7c79c9bc941 45 | 46 | # Override default flag values for local packages and extra-deps 47 | # flags: {} 48 | 49 | # Extra package databases containing global packages 50 | # extra-package-dbs: [] 51 | 52 | # Control whether we use the GHC we find on the path 53 | # system-ghc: true 54 | # 55 | # Require a specific version of stack, using version ranges 56 | # require-stack-version: -any # Default 57 | # require-stack-version: ">=1.9" 58 | # 59 | # Override the architecture used by stack, especially useful on Windows 60 | # arch: i386 61 | # arch: x86_64 62 | # 63 | # Extra directories used by stack for building 64 | # extra-include-dirs: [/path/to/dir] 65 | # extra-lib-dirs: [/path/to/dir] 66 | # 67 | # Allow a newer minor version of GHC than the snapshot specifies 68 | # compiler-check: newer-minor 69 | # 70 | # build: 71 | # split-objs: true 72 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Relude 4 | 5 | import Test.Tasty 6 | import Test.Tasty.Golden 7 | 8 | import qualified Data.Text.IO as T 9 | import qualified Data.Text as T 10 | import qualified Data.Text.Lazy as LT 11 | import Language.PureScript.CST 12 | import Language.PureScript.CST.Errors 13 | import Language.PureScript.CST.Print 14 | 15 | import Data.Generics.Product 16 | import Control.Lens 17 | import System.FilePath 18 | import Control.Exception 19 | import Text.Pretty.Simple 20 | 21 | import Lib 22 | 23 | main :: IO () 24 | main = do 25 | t <- tests 26 | defaultMain t 27 | 28 | tests :: IO TestTree 29 | tests = do 30 | goldens <- goldenTests 31 | pure $ testGroup "Golden Tests" goldens 32 | 33 | goldenTests :: IO [TestTree] 34 | goldenTests = do 35 | allFiles <- liftIO $ findByExtension [".purs"] "test/data" 36 | let files = filter (\e -> ".out" /= (takeExtension $ dropExtension e)) allFiles 37 | traverse createGoldenTest files 38 | 39 | instance Exception (NonEmpty ParserError) 40 | 41 | createGoldenTest :: FilePath -> IO TestTree 42 | createGoldenTest inputPath = do 43 | let goldenPath = addExtension (dropExtension inputPath) ".out.purs" 44 | input <- T.readFile inputPath 45 | pure $ goldenVsStringDiff goldenPath (\ref new -> ["diff", "-u", ref, new]) goldenPath $ 46 | case format input of 47 | Left e -> throw e 48 | Right out -> pure $ toLazy $ (encodeUtf8 :: Text -> ByteString) out 49 | 50 | -- tracePShowId :: Show a => a -> a 51 | -- tracePShowId a = trace (LT.unpack $ pShow a) a 52 | -------------------------------------------------------------------------------- /test/data/Imports.out.purs: -------------------------------------------------------------------------------- 1 | module Imports where 2 | 3 | import Prelude 4 | 5 | import Control.Alt ((<|>)) 6 | import Control.Monad.Except (ExceptT(..), runExcept, runExceptT, withExcept) 7 | import Data.Bifunctor (lmap) 8 | import Data.Either (Either(..), hush) 9 | import Data.Identity (Identity(..)) 10 | import Data.Maybe (Maybe(..), maybe) 11 | -------------------------------------------------------------------------------- /test/data/Imports.purs: -------------------------------------------------------------------------------- 1 | module Imports where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Except (ExceptT(..), runExcept, runExceptT, withExcept) 6 | import Data.Bifunctor (lmap) 7 | 8 | import Data.Identity (Identity(..)) 9 | import Data.Either (Either(..), hush) 10 | import Control.Alt ((<|>)) 11 | 12 | import Data.Maybe (Maybe(..), maybe) 13 | -------------------------------------------------------------------------------- /test/data/Rave.out.purs: -------------------------------------------------------------------------------- 1 | module Rave where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, try) 6 | import Control.Monad.Except (runExceptT) 7 | import Control.Monad.Except.Checked (ExceptV) 8 | import Control.Monad.Reader (ReaderT, runReaderT) 9 | import Control.Monad.Trans.Class (lift) 10 | import Data.Either (Either(..)) 11 | import Data.Symbol (class IsSymbol, SProxy(..)) 12 | import Data.Variant (class VariantShows, Variant, inj) 13 | import Data.Variant.Internal (class VariantTags) 14 | import Effect.Aff (Aff, error) 15 | import Effect.Aff.Class (class MonadAff, liftAff) 16 | import Effect.Class (class MonadEffect) 17 | import Effect.Exception (Error) 18 | import Prim.Row as R 19 | import Prim.RowList (class RowToList) 20 | import Prim.RowList as RL 21 | import Record (get) 22 | import Type.Row (RProxy) 23 | 24 | -- | Short for "Reader, Aff, Variant." 25 | newtype Rave r v a = Rave (ReaderT r (ExceptV v Aff) a) 26 | 27 | derive newtype instance raveMonadAff :: MonadAff (Rave r v) 28 | derive newtype instance raveMonadEffect :: MonadEffect (Rave r v) 29 | derive newtype instance raveMonad :: Monad (Rave r v) 30 | derive newtype instance raveApplicative :: Applicative (Rave r v) 31 | derive newtype instance raveApply :: Apply (Rave r v) 32 | derive newtype instance raveFunctor :: Functor (Rave r v) 33 | derive newtype instance raveBind :: Bind (Rave r v) 34 | derive newtype instance raveMonadError :: MonadThrow (Variant v) (Rave r v) 35 | 36 | class VariantInjTagged a b | a -> b where 37 | injTagged :: Record a -> Variant b 38 | 39 | instance variantInjTagged :: 40 | ( RowToList r1 (RL.Cons sym a RL.Nil) 41 | , R.Cons sym a () r1 42 | , R.Cons sym a rx r2 43 | , IsSymbol sym 44 | ) => 45 | VariantInjTagged r1 r2 where 46 | injTagged = inj (SProxy :: SProxy sym) <<< get (SProxy :: SProxy sym) 47 | 48 | throw :: forall m r1 r2 a. 49 | VariantInjTagged r1 r2 => 50 | MonadThrow (Variant r2) m => 51 | Record r1 -> 52 | m a 53 | throw = throwError <<< injTagged 54 | 55 | runRave :: forall v r rl a. 56 | RowToList v rl => 57 | VariantTags rl => 58 | VariantShows rl => 59 | RProxy v -> 60 | Rave r v a -> 61 | r -> 62 | Aff a 63 | runRave _ (Rave rave) r = do 64 | ran <- runExceptT $ runReaderT rave r 65 | case ran of 66 | Right res -> pure res 67 | Left l -> throwError $ error $ show l 68 | 69 | liftRave :: forall m a r. MonadError Error m => m a -> ExceptV (liftedError :: Error | r) m a 70 | liftRave e = do 71 | run <- lift $ try e 72 | case run of 73 | Right r -> pure r 74 | Left l -> throw { liftedError: l } 75 | 76 | liftAffV :: forall r m a. MonadAff m => Aff a -> ExceptV (liftedError :: Error | r) m a 77 | liftAffV e = do 78 | run <- liftAff $ try e 79 | case run of 80 | Right r -> pure r 81 | Left l -> throw { liftedError: l } 82 | 83 | -- itV :: forall r. 84 | -- RProxy r 85 | -- String -> 86 | -- ExceptV r Aff Unit -> 87 | -- Spec Unit 88 | -- itV name toRun = it name $ runAffV RProxy toRun 89 | -------------------------------------------------------------------------------- /test/data/Rave.purs: -------------------------------------------------------------------------------- 1 | module Rave where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, try) 6 | import Control.Monad.Except (runExceptT) 7 | import Control.Monad.Except.Checked (ExceptV) 8 | import Control.Monad.Reader (ReaderT, runReaderT) 9 | import Control.Monad.Trans.Class (lift) 10 | import Data.Either (Either(..)) 11 | import Data.Symbol (class IsSymbol, SProxy(..)) 12 | import Data.Variant (class VariantShows, Variant, inj) 13 | import Data.Variant.Internal (class VariantTags) 14 | import Effect.Aff (Aff, error) 15 | import Effect.Aff.Class (class MonadAff, liftAff) 16 | import Effect.Class (class MonadEffect) 17 | import Effect.Exception (Error) 18 | import Prim.Row as R 19 | import Prim.RowList (class RowToList) 20 | import Prim.RowList as RL 21 | import Record (get) 22 | import Type.Row (RProxy) 23 | 24 | -- | Short for "Reader, Aff, Variant." 25 | newtype Rave r v a = Rave (ReaderT r (ExceptV v Aff) a) 26 | 27 | derive newtype instance raveMonadAff :: MonadAff (Rave r v) 28 | derive newtype instance raveMonadEffect :: MonadEffect (Rave r v) 29 | derive newtype instance raveMonad :: Monad (Rave r v) 30 | derive newtype instance raveApplicative :: Applicative (Rave r v) 31 | derive newtype instance raveApply :: Apply (Rave r v) 32 | derive newtype instance raveFunctor :: Functor (Rave r v) 33 | derive newtype instance raveBind :: Bind (Rave r v) 34 | derive newtype instance raveMonadError :: MonadThrow (Variant v) (Rave r v) 35 | 36 | class VariantInjTagged a b | a -> b where 37 | injTagged :: Record a -> Variant b 38 | 39 | instance variantInjTagged :: 40 | ( RowToList r1 (RL.Cons sym a RL.Nil) 41 | , R.Cons sym a () r1 42 | , R.Cons sym a rx r2 43 | , IsSymbol sym 44 | ) => 45 | VariantInjTagged r1 r2 where 46 | injTagged = inj (SProxy :: SProxy sym) <<< get (SProxy :: SProxy sym) 47 | 48 | throw :: forall m r1 r2 a. 49 | VariantInjTagged r1 r2 => 50 | MonadThrow (Variant r2) m => 51 | Record r1 -> 52 | m a 53 | throw = throwError <<< injTagged 54 | 55 | runRave :: forall v r rl a. 56 | RowToList v rl => 57 | VariantTags rl => 58 | VariantShows rl => 59 | RProxy v -> 60 | Rave r v a -> 61 | r -> 62 | Aff a 63 | runRave _ (Rave rave) r = do 64 | ran <- runExceptT $ runReaderT rave r 65 | case ran of 66 | Right res -> pure res 67 | Left l -> throwError $ error $ show l 68 | 69 | liftRave :: forall m a r. MonadError Error m => m a -> ExceptV (liftedError :: Error | r) m a 70 | liftRave e = do 71 | run <- lift $ try e 72 | case run of 73 | Right r -> pure r 74 | Left l -> throw { liftedError: l } 75 | 76 | liftAffV :: forall r m a. MonadAff m => Aff a -> ExceptV (liftedError :: Error | r) m a 77 | liftAffV e = do 78 | run <- liftAff $ try e 79 | case run of 80 | Right r -> pure r 81 | Left l -> throw { liftedError: l } 82 | 83 | -- itV :: forall r. 84 | -- RProxy r 85 | -- String -> 86 | -- ExceptV r Aff Unit -> 87 | -- Spec Unit 88 | -- itV name toRun = it name $ runAffV RProxy toRun 89 | -------------------------------------------------------------------------------- /test/data/Types.out.purs: -------------------------------------------------------------------------------- 1 | module Types where 2 | 3 | import Prelude 4 | 5 | type Person = 6 | { name :: String 7 | , id :: Int 8 | , address :: 9 | { street :: String 10 | , city :: String 11 | } 12 | } 13 | -------------------------------------------------------------------------------- /test/data/Types.purs: -------------------------------------------------------------------------------- 1 | module Types where 2 | 3 | import Prelude 4 | 5 | type Person = { name :: String , id :: Int , address :: { street :: String , city :: String}} 6 | --------------------------------------------------------------------------------