├── .gitignore ├── zifter ├── src │ ├── Zifter │ │ ├── Types.hs │ │ ├── Setup.hs │ │ ├── Setup │ │ │ └── Types.hs │ │ ├── Script.hs │ │ ├── Script │ │ │ └── Types.hs │ │ ├── OptParse │ │ │ └── Types.hs │ │ ├── Recurse.hs │ │ ├── Zift │ │ │ └── Types.hs │ │ ├── Zift.hs │ │ └── OptParse.hs │ └── Zifter.hs ├── test │ ├── Spec.hs │ ├── Zifter │ │ ├── Gen.hs │ │ ├── OptParse │ │ │ └── Gen.hs │ │ ├── RecurseSpec.hs │ │ ├── Zift │ │ │ └── Gen.hs │ │ └── ZiftSpec.hs │ ├── TestImport.hs │ └── ZifterSpec.hs ├── Setup.hs ├── LICENSE └── package.yaml ├── zifter-stack ├── test │ ├── Spec.hs │ ├── TestImport.hs │ └── Zifter │ │ └── StackSpec.hs ├── Setup.hs ├── package.yaml ├── LICENSE └── src │ └── Zifter │ └── Stack.hs ├── zifter-git ├── Setup.hs ├── package.yaml ├── src │ └── Zifter │ │ └── Git.hs └── LICENSE ├── zifter-cabal ├── Setup.hs ├── package.yaml ├── LICENSE └── src │ └── Zifter │ └── Cabal.hs ├── zifter-hindent ├── Setup.hs ├── package.yaml ├── LICENSE └── src │ └── Zifter │ └── Hindent.hs ├── zifter-hlint ├── Setup.hs ├── package.yaml ├── src │ └── Zifter │ │ └── Hlint.hs └── LICENSE ├── zifter-google-java-format ├── Setup.hs ├── package.yaml ├── LICENSE └── src │ └── Zifter │ └── GoogleJavaFormat.hs ├── stack.yaml ├── lts-8.yaml ├── lts-7.yaml ├── old-validity.yaml ├── zift.hs ├── .travis.yml └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *.cabal 3 | *.css 4 | *.js 5 | -------------------------------------------------------------------------------- /zifter/src/Zifter/Types.hs: -------------------------------------------------------------------------------- 1 | module Zifter.Types where 2 | -------------------------------------------------------------------------------- /zifter/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /zifter-stack/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /zifter-git/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /zifter/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /zifter-cabal/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /zifter-hindent/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /zifter-hlint/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /zifter-stack/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /zifter-google-java-format/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /zifter/src/Zifter/Setup.hs: -------------------------------------------------------------------------------- 1 | module Zifter.Setup 2 | ( module Zifter.Setup.Types 3 | ) where 4 | 5 | import Zifter.Setup.Types 6 | -------------------------------------------------------------------------------- /zifter/test/Zifter/Gen.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module Zifter.Gen where 4 | 5 | import TestImport 6 | 7 | import Zifter 8 | import Zifter.Zift.Gen () 9 | 10 | instance GenUnchecked LinearState 11 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | extra-package-dbs: [] 3 | packages: 4 | - zifter 5 | - zifter-cabal 6 | - zifter-git 7 | - zifter-google-java-format 8 | - zifter-hindent 9 | - zifter-hlint 10 | - zifter-stack 11 | resolver: lts-10.0 12 | -------------------------------------------------------------------------------- /zifter-stack/test/TestImport.hs: -------------------------------------------------------------------------------- 1 | module TestImport 2 | ( module X 3 | ) where 4 | 5 | import Data.Maybe as X 6 | import Data.Monoid as X 7 | 8 | import Test.Hspec as X 9 | 10 | import Path as X 11 | import Path.IO as X 12 | -------------------------------------------------------------------------------- /zifter/test/Zifter/OptParse/Gen.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module Zifter.OptParse.Gen where 4 | 5 | import TestImport 6 | 7 | import Zifter.OptParse.Types 8 | 9 | instance GenUnchecked OutputMode 10 | 11 | instance GenUnchecked Settings 12 | -------------------------------------------------------------------------------- /zifter/test/TestImport.hs: -------------------------------------------------------------------------------- 1 | module TestImport 2 | ( module X 3 | ) where 4 | 5 | import Data.Maybe as X 6 | import Data.Monoid as X 7 | 8 | import Test.Hspec as X 9 | import Test.QuickCheck as X 10 | import Test.Validity as X 11 | 12 | import Path as X 13 | import Path.IO as X 14 | 15 | import Data.GenValidity.Path () 16 | -------------------------------------------------------------------------------- /lts-8.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | extra-package-dbs: [] 3 | packages: 4 | - zifter 5 | - zifter-cabal 6 | - zifter-git 7 | - zifter-google-java-format 8 | - zifter-hindent 9 | - zifter-hlint 10 | - zifter-stack 11 | 12 | extra-deps: 13 | - genvalidity-0.4.0.0 14 | - genvalidity-hspec-0.5.0.0 15 | - genvalidity-path-0.2.0.0 16 | - genvalidity-property-0.1.0.0 17 | - validity-0.4.0.0 18 | - validity-path-0.2.0.0 19 | resolver: lts-8.5 20 | -------------------------------------------------------------------------------- /lts-7.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | extra-package-dbs: [] 3 | packages: 4 | - zifter 5 | - zifter-cabal 6 | - zifter-git 7 | - zifter-google-java-format 8 | - zifter-hindent 9 | - zifter-hlint 10 | - zifter-stack 11 | 12 | extra-deps: 13 | - genvalidity-0.4.0.0 14 | - genvalidity-hspec-0.4.0.0 15 | - genvalidity-path-0.2.0.0 16 | - validity-0.4.0.0 17 | - validity-path-0.2.0.0 18 | - optparse-applicative-0.13.2.0 19 | resolver: lts-7.20 20 | -------------------------------------------------------------------------------- /old-validity.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | extra-package-dbs: [] 3 | packages: 4 | - zifter 5 | - zifter-cabal 6 | - zifter-git 7 | - zifter-google-java-format 8 | - zifter-hindent 9 | - zifter-hlint 10 | - zifter-stack 11 | 12 | extra-deps: 13 | - genvalidity-0.3.1.0 14 | - genvalidity-hspec-0.3.0.0 15 | - genvalidity-path-0.1.0.2 16 | - validity-0.3.2.0 17 | - validity-path-0.1.0.0 18 | - optparse-applicative-0.13.2.0 19 | resolver: lts-8.5 20 | -------------------------------------------------------------------------------- /zifter-git/package.yaml: -------------------------------------------------------------------------------- 1 | name: zifter-git 2 | version: '0.0.0.1' 3 | synopsis: zifter-git 4 | description: zifter-git 5 | category: Zift 6 | author: Tom Sydney Kerckhove 7 | maintainer: syd.kerckhove@gmail.com 8 | copyright: ! 'Copyright: (c) 2017 Tom Sydney Kerckhove' 9 | license: MIT 10 | homepage: http://cs-syd.eu 11 | dependencies: 12 | - base >=4.9 && <=5 13 | - zifter >=0.0 && <0.1 14 | - process 15 | - path 16 | library: 17 | source-dirs: src/ 18 | ghc-options: -Wall 19 | exposed-modules: 20 | - Zifter.Git 21 | -------------------------------------------------------------------------------- /zifter-git/src/Zifter/Git.hs: -------------------------------------------------------------------------------- 1 | module Zifter.Git where 2 | 3 | import Path 4 | import System.Exit 5 | import System.Process 6 | 7 | import Zifter.Zift 8 | 9 | gitAddAllZift :: Zift () 10 | gitAddAllZift = do 11 | rd <- getRootDir 12 | let cmd = "git add ." 13 | ec <- 14 | liftIO $ 15 | createProcess ((shell cmd) {cwd = Just $ toFilePath rd}) >>= 16 | (waitForProcess . (\(_, _, _, ph) -> ph)) 17 | case ec of 18 | ExitFailure c -> fail $ unwords [cmd, "failed with exit code", show c] 19 | ExitSuccess -> pure () 20 | -------------------------------------------------------------------------------- /zift.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env stack 2 | {- stack 3 | --install-ghc 4 | runghc 5 | --package zifter 6 | --package zifter-git 7 | --package zifter-hindent 8 | --package zifter-hlint 9 | --package zifter-stack 10 | -} 11 | import Zifter 12 | import Zifter.Git 13 | import Zifter.Hindent 14 | import Zifter.Hlint 15 | import Zifter.Stack 16 | 17 | main :: IO () 18 | main = 19 | ziftWith $ do 20 | recursiveZift 21 | preprocessor hindentZift 22 | prechecker gitAddAllZift 23 | checker $ do 24 | hlintZift 25 | stackBuildZift 26 | -------------------------------------------------------------------------------- /zifter-hlint/package.yaml: -------------------------------------------------------------------------------- 1 | name: zifter-hlint 2 | version: '0.0.0.1' 3 | synopsis: zifter-hlint 4 | description: zifter-hlint 5 | category: Zift 6 | author: Tom Sydney Kerckhove 7 | maintainer: syd.kerckhove@gmail.com 8 | copyright: ! 'Copyright: (c) 2017 Tom Sydney Kerckhove' 9 | license: MIT 10 | homepage: http://cs-syd.eu 11 | dependencies: 12 | - base >=4.9 && <=5 13 | - filepath >=1.4 && <1.5 14 | - hlint >=1.9.35 && <2.1 15 | - path 16 | - path-io 17 | - safe >=0.3 && <0.4 18 | - zifter >=0.0 && <0.1 19 | library: 20 | source-dirs: src/ 21 | ghc-options: -Wall 22 | exposed-modules: 23 | - Zifter.Hlint 24 | -------------------------------------------------------------------------------- /zifter-cabal/package.yaml: -------------------------------------------------------------------------------- 1 | name: zifter-cabal 2 | version: '0.0.0.3' 3 | synopsis: zifter-cabal 4 | description: zifter-cabal 5 | category: Zift 6 | author: Tom Sydney Kerckhove 7 | maintainer: syd.kerckhove@gmail.com 8 | copyright: ! 'Copyright: (c) 2017 Tom Sydney Kerckhove' 9 | license: MIT 10 | homepage: http://cs-syd.eu 11 | dependencies: 12 | - base >=4.9 && <=5 13 | - process 14 | - filepath >=1.4 && <1.5 15 | - directory 16 | - zifter >=0.0.1.2 && <0.1 17 | - path 18 | - path-io 19 | - safe >=0.3 && <0.4 20 | library: 21 | source-dirs: src/ 22 | ghc-options: -Wall 23 | exposed-modules: 24 | - Zifter.Cabal 25 | -------------------------------------------------------------------------------- /zifter-hindent/package.yaml: -------------------------------------------------------------------------------- 1 | name: zifter-hindent 2 | version: '0.0.0.2' 3 | synopsis: zifter-hindent 4 | description: zifter-hindent 5 | category: Zift 6 | author: Tom Sydney Kerckhove 7 | maintainer: syd.kerckhove@gmail.com 8 | copyright: ! 'Copyright: (c) 2017 Tom Sydney Kerckhove' 9 | license: MIT 10 | homepage: http://cs-syd.eu 11 | dependencies: 12 | - base >=4.9 && <=5 13 | - process 14 | - filepath >=1.4 && <1.5 15 | - directory 16 | - zifter >=0.0.1.2 && <0.1 17 | - path 18 | - path-io 19 | - safe >=0.3 && <0.4 20 | library: 21 | source-dirs: src/ 22 | ghc-options: -Wall 23 | exposed-modules: 24 | - Zifter.Hindent 25 | -------------------------------------------------------------------------------- /zifter-google-java-format/package.yaml: -------------------------------------------------------------------------------- 1 | name: zifter-google-java-format 2 | version: '0.0.0.1' 3 | synopsis: zifter-google-java-format 4 | description: zifter-google-java-format 5 | category: Zift 6 | author: Tom Sydney Kerckhove 7 | maintainer: syd.kerckhove@gmail.com 8 | copyright: ! 'Copyright: (c) 2017 Tom Sydney Kerckhove' 9 | license: MIT 10 | homepage: http://cs-syd.eu 11 | dependencies: 12 | - base >=4.9 && <=5 13 | - zifter >=0.0.1.2 && <0.1 14 | - path 15 | - path-io 16 | - process 17 | - safe >=0.3 && <0.4 18 | - filepath >=1.4 && <1.5 19 | library: 20 | source-dirs: src/ 21 | ghc-options: -Wall 22 | exposed-modules: 23 | - Zifter.GoogleJavaFormat 24 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | sudo: false 3 | 4 | addons: 5 | apt: 6 | packages: 7 | - libgmp-dev 8 | 9 | cache: 10 | directories: 11 | - $HOME/.stack 12 | 13 | before_install: 14 | - mkdir -p ~/.local/bin 15 | - export PATH=$HOME/.local/bin:$PATH 16 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 17 | - chmod a+x ~/.local/bin/stack 18 | 19 | 20 | install: 21 | - stack +RTS -N2 -RTS setup 22 | - stack +RTS -N2 -RTS build --only-snapshot 23 | - stack +RTS -N2 -RTS install hindent 24 | - stack +RTS -N2 -RTS install cabal-install 25 | 26 | script: 27 | - git --version 28 | - stack --version 29 | - travis_wait 60 ./zift.hs run 30 | -------------------------------------------------------------------------------- /zifter/test/Zifter/RecurseSpec.hs: -------------------------------------------------------------------------------- 1 | module Zifter.RecurseSpec 2 | ( spec 3 | ) where 4 | 5 | import TestImport 6 | 7 | import Zifter.Recurse 8 | 9 | spec :: Spec 10 | spec = 11 | describe "hiddenIn" $ do 12 | it "correctly identifies a subdirectory of .stack-work as hidden" $ do 13 | rp <- parseAbsDir "/home/user/project/" 14 | af <- 15 | parseAbsFile 16 | "/home/user/project/.stack-work/downloaded/abcxyz/zift.hs" 17 | af `shouldSatisfy` hiddenIn rp 18 | it "correctly identifies a regular subdirectory as not hidden" $ do 19 | rp <- parseAbsDir "/home/user/project/" 20 | af <- parseAbsFile "/home/user/project/subdir/zift.hs" 21 | af `shouldNotSatisfy` hiddenIn rp 22 | -------------------------------------------------------------------------------- /zifter/src/Zifter/Setup/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | module Zifter.Setup.Types where 4 | 5 | import GHC.Generics 6 | 7 | import Zifter.Zift.Types 8 | 9 | data ZiftSetup = ZiftSetup 10 | { ziftPreprocessor :: Zift () 11 | , ziftPreChecker :: Zift () 12 | , ziftChecker :: Zift () 13 | } deriving (Generic) 14 | 15 | instance Monoid ZiftSetup where 16 | mempty = 17 | ZiftSetup 18 | { ziftPreprocessor = pure () 19 | , ziftPreChecker = pure () 20 | , ziftChecker = pure () 21 | } 22 | mappend z1 z2 = 23 | ZiftSetup 24 | { ziftPreprocessor = ziftPreprocessor z1 `mappend` ziftPreprocessor z2 25 | , ziftPreChecker = ziftPreChecker z1 `mappend` ziftPreChecker z2 26 | , ziftChecker = ziftChecker z1 `mappend` ziftChecker z2 27 | } 28 | -------------------------------------------------------------------------------- /zifter/src/Zifter/Script.hs: -------------------------------------------------------------------------------- 1 | module Zifter.Script 2 | ( preprocessor 3 | , prechecker 4 | , checker 5 | , module Zifter.Script.Types 6 | ) where 7 | 8 | import Zifter.Script.Types 9 | import Zifter.Setup 10 | import Zifter.Zift 11 | 12 | -- | Add a given zift action as a preprocessor. 13 | preprocessor :: Zift () -> ZiftScript () 14 | preprocessor prep = 15 | ZiftScript {renderZiftScript = pure ((), mempty {ziftPreprocessor = prep})} 16 | 17 | -- | Add a given zift action as a prechecker. 18 | prechecker :: Zift () -> ZiftScript () 19 | prechecker func = 20 | ZiftScript {renderZiftScript = pure ((), mempty {ziftPreChecker = func})} 21 | 22 | -- | Add a given zift action as a checker. 23 | checker :: Zift () -> ZiftScript () 24 | checker ch = 25 | ZiftScript {renderZiftScript = pure ((), mempty {ziftChecker = ch})} 26 | -------------------------------------------------------------------------------- /zifter-stack/package.yaml: -------------------------------------------------------------------------------- 1 | name: zifter-stack 2 | version: '0.0.0.10' 3 | synopsis: zifter-stack 4 | description: zifter-stack 5 | category: Zift 6 | author: Tom Sydney Kerckhove 7 | maintainer: syd.kerckhove@gmail.com 8 | copyright: ! 'Copyright: (c) 2017 Tom Sydney Kerckhove' 9 | license: MIT 10 | homepage: http://cs-syd.eu 11 | dependencies: 12 | - base >=4.9 && <=5 13 | - Cabal >=1.24 && <2.1 14 | - process 15 | - filepath >=1.4 && <1.5 16 | - directory 17 | - zifter >=0.0 && <0.1 18 | - path 19 | - path-io 20 | - safe >=0.3 && <0.4 21 | library: 22 | source-dirs: src/ 23 | ghc-options: -Wall 24 | exposed-modules: 25 | - Zifter.Stack 26 | 27 | tests: 28 | zifter-stack-test: 29 | main: Spec.hs 30 | source-dirs: test/ 31 | ghc-options: 32 | - -threaded 33 | - -rtsopts 34 | - -with-rtsopts=-N 35 | - -Wall 36 | dependencies: 37 | - zifter-stack 38 | - hspec 39 | - stm 40 | -------------------------------------------------------------------------------- /zifter/test/ZifterSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module ZifterSpec 4 | ( spec 5 | ) where 6 | 7 | import TestImport 8 | 9 | import Control.Concurrent.STM 10 | 11 | import Zifter 12 | import Zifter.OptParse.Gen () 13 | import Zifter.Zift 14 | import Zifter.Zift.Gen () 15 | 16 | spec :: Spec 17 | spec = 18 | describe "ziftWith" $ 19 | it "does nothing with an empty zift action" $ 20 | forAll genUnchecked $ \sets -> 21 | forAll genValid $ \rd -> do 22 | pchan <- newTChanIO 23 | td <- resolveDir rd ".zifter" 24 | let ctx = 25 | ZiftContext 26 | { rootdir = rd 27 | , tmpdir = td 28 | , settings = sets 29 | , printChan = pchan 30 | , recursionList = [] 31 | } 32 | runZift ctx (pure ()) `shouldReturn` ZiftSuccess () 33 | -------------------------------------------------------------------------------- /zifter-hlint/src/Zifter/Hlint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Zifter.Hlint where 4 | 5 | import Language.Haskell.HLint3 (hlint) 6 | import Path 7 | import Path.IO 8 | import Safe 9 | import qualified System.FilePath as FP 10 | 11 | import Zifter.Zift 12 | 13 | hlintZift :: Zift () 14 | hlintZift = do 15 | rd <- getRootDir 16 | fs <- liftIO $ snd <$> listDirRecur rd 17 | let sources = filter (not . hidden) $ filter ((== ".hs") . fileExtension) fs 18 | hints <- liftIO $ hlint ("--quiet" : map toFilePath sources) 19 | case hints of 20 | [] -> printPreprocessingDone "Hlint checks done." 21 | _ -> do 22 | printPreprocessingError $ 23 | unlines $ "Hlint has suggestions." : map show hints 24 | fail $ unwords ["Hlint had", show $ length hints, "suggestions."] 25 | 26 | hidden :: Path Abs t -> Bool 27 | hidden = any ((Just '.' ==) . headMay) . FP.splitPath . toFilePath 28 | -------------------------------------------------------------------------------- /zifter/src/Zifter/Script/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | module Zifter.Script.Types where 4 | 5 | import GHC.Generics 6 | import Zifter.Setup.Types 7 | 8 | newtype ZiftScript a = ZiftScript 9 | { renderZiftScript :: IO (a, ZiftSetup) 10 | } deriving (Generic) 11 | 12 | renderZiftSetup :: ZiftScript a -> IO ZiftSetup 13 | renderZiftSetup = fmap snd . renderZiftScript 14 | 15 | instance Functor ZiftScript where 16 | fmap f (ZiftScript func) = 17 | ZiftScript $ do 18 | (a, zs) <- func 19 | pure (f a, zs) 20 | 21 | instance Applicative ZiftScript where 22 | pure a = ZiftScript $ pure (a, mempty) 23 | (ZiftScript funcf) <*> (ZiftScript funca) = 24 | ZiftScript $ do 25 | (f, z1) <- funcf 26 | (a, z2) <- funca 27 | pure (f a, z1 `mappend` z2) 28 | 29 | instance Monad ZiftScript where 30 | (ZiftScript afunc) >>= func = 31 | ZiftScript $ do 32 | (a, z1) <- afunc 33 | let (ZiftScript bfunc) = func a 34 | (b, z2) <- bfunc 35 | pure (b, z1 `mappend` z2) 36 | -------------------------------------------------------------------------------- /zifter/src/Zifter/OptParse/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | module Zifter.OptParse.Types where 4 | 5 | import GHC.Generics 6 | 7 | type Arguments = (Command, Flags) 8 | 9 | type Instructions = (Dispatch, Settings) 10 | 11 | data Command 12 | = CommandRun 13 | | CommandInstall Bool -- | Recursive? 14 | | CommandPreProcess 15 | | CommandPreCheck 16 | | CommandCheck 17 | deriving (Show, Eq) 18 | 19 | data Flags = Flags 20 | { flagsOutputColor :: Bool 21 | , flagsOutputMode :: Maybe OutputMode 22 | } deriving (Show, Eq) 23 | 24 | data Configuration = 25 | Configuration 26 | deriving (Show, Eq) 27 | 28 | data Dispatch 29 | = DispatchRun 30 | | DispatchInstall Bool -- | recursive ? 31 | | DispatchPreProcess 32 | | DispatchPreCheck 33 | | DispatchCheck 34 | deriving (Show, Eq, Generic) 35 | 36 | data Settings = Settings 37 | { setsOutputColor :: Bool 38 | , setsOutputMode :: OutputMode 39 | } deriving (Show, Eq, Generic) 40 | 41 | data OutputMode 42 | = OutputLinear 43 | | OutputFast 44 | deriving (Show, Eq, Generic) 45 | -------------------------------------------------------------------------------- /zifter/LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Tom Sydney Kerckhove 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 | -------------------------------------------------------------------------------- /zifter-cabal/LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Tom Sydney Kerckhove 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 | -------------------------------------------------------------------------------- /zifter-git/LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Tom Sydney Kerckhove 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 | -------------------------------------------------------------------------------- /zifter-hlint/LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Tom Sydney Kerckhove 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 | -------------------------------------------------------------------------------- /zifter-stack/LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Tom Sydney Kerckhove 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 | -------------------------------------------------------------------------------- /zifter-hindent/LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Tom Sydney Kerckhove 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 | -------------------------------------------------------------------------------- /zifter-google-java-format/LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Tom Sydney Kerckhove 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 | -------------------------------------------------------------------------------- /zifter/package.yaml: -------------------------------------------------------------------------------- 1 | name: zifter 2 | version: '0.0.1.6' 3 | synopsis: zifter 4 | description: zifter 5 | category: Zift 6 | author: Tom Sydney Kerckhove 7 | maintainer: syd.kerckhove@gmail.com 8 | copyright: ! 'Copyright: (c) 2017 Tom Sydney Kerckhove' 9 | license: MIT 10 | homepage: http://cs-syd.eu 11 | dependencies: 12 | - base >=4.9 && <=5 13 | library: 14 | source-dirs: src/ 15 | ghc-options: -Wall 16 | exposed-modules: 17 | - Zifter 18 | - Zifter.OptParse 19 | - Zifter.OptParse.Types 20 | - Zifter.Recurse 21 | - Zifter.Script 22 | - Zifter.Script.Types 23 | - Zifter.Setup 24 | - Zifter.Setup.Types 25 | - Zifter.Types 26 | - Zifter.Zift 27 | - Zifter.Zift.Types 28 | dependencies: 29 | - ansi-terminal >=0.6 && <0.8 30 | - async >=2.1 && <2.2 31 | - directory >=1.2 && <1.4 32 | - exceptions >=0.8 && <0.9 33 | - filepath >=1.4 && <1.5 34 | - optparse-applicative >=0.13 && <0.15 35 | - path >=0.6 && <0.7 36 | - path-io >1.3 && <1.4 37 | - process >=1.4 && <1.7 38 | - safe >=0.3 && <0.4 39 | - stm >=2.4 && <2.5 40 | - validity >=0.3 && <0.5 41 | - validity-path >=0.1 && <0.3 42 | tests: 43 | zifter-test: 44 | main: Spec.hs 45 | source-dirs: test/ 46 | ghc-options: 47 | - -threaded 48 | - -rtsopts 49 | - -with-rtsopts=-N 50 | - -Wall 51 | dependencies: 52 | - zifter 53 | - QuickCheck >=2.9 && <2.11 54 | - colour >=2.3 && <2.4 55 | - genvalidity >=0.3 && <0.5 56 | - genvalidity-hspec >=0.3 && <0.6 57 | - genvalidity-path >=0.1 && <0.3 58 | - hspec 59 | - path 60 | - path-io 61 | - stm 62 | - ansi-terminal 63 | - directory 64 | -------------------------------------------------------------------------------- /zifter-stack/test/Zifter/StackSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module Zifter.StackSpec 4 | ( spec 5 | ) where 6 | 7 | import TestImport 8 | 9 | import Control.Concurrent.STM 10 | 11 | import Zifter 12 | import Zifter.OptParse 13 | import Zifter.Stack 14 | import Zifter.Zift 15 | 16 | spec :: Spec 17 | spec = 18 | describe "stackGetPackageTargetTuples" $ 19 | it "finds the right packages for this repository" $ do 20 | tups <- runZiftInRepo stackGetPackages 21 | tups `shouldBe` 22 | [ Pkg "zifter" [Lib "zifter:lib", Test "zifter:test:zifter-test"] 23 | , Pkg "zifter-cabal" [Lib "zifter-cabal:lib"] 24 | , Pkg "zifter-git" [Lib "zifter-git:lib"] 25 | , Pkg "zifter-google-java-format" 26 | [Lib "zifter-google-java-format:lib"] 27 | , Pkg "zifter-hindent" [Lib "zifter-hindent:lib"] 28 | , Pkg "zifter-hlint" [Lib "zifter-hlint:lib"] 29 | , Pkg "zifter-stack" 30 | [ Lib "zifter-stack:lib" 31 | , Test "zifter-stack:test:zifter-stack-test" 32 | ] 33 | ] 34 | 35 | runZiftInRepo :: Zift a -> IO a 36 | runZiftInRepo func = do 37 | rd <- resolveDir' ".." 38 | pchan <- newTChanIO 39 | td <- resolveDir rd "/tmp/zifter-tmp" 40 | let ctx = 41 | ZiftContext 42 | { rootdir = rd 43 | , tmpdir = td 44 | , settings = 45 | Settings 46 | {setsOutputColor = False, setsOutputMode = OutputFast} 47 | , printChan = pchan 48 | , recursionList = [] 49 | } 50 | zr <- runZift ctx func 51 | case zr of 52 | ZiftSuccess a -> pure a 53 | ZiftFailed r -> do 54 | expectationFailure $ "zift failed: " ++ show r 55 | undefined -- won't get here anyway 56 | -------------------------------------------------------------------------------- /zifter-cabal/src/Zifter/Cabal.hs: -------------------------------------------------------------------------------- 1 | module Zifter.Cabal where 2 | 3 | import Control.Monad.IO.Class 4 | import Path 5 | import Path.IO 6 | import Safe 7 | import System.Exit (ExitCode(..)) 8 | import qualified System.FilePath as FP (splitPath) 9 | import System.IO (hGetContents) 10 | import System.Process 11 | 12 | import Zifter.Zift 13 | 14 | cabalFormatZift :: Zift () 15 | cabalFormatZift = do 16 | () <- cabalCheckAndPrintVersion 17 | cabalFormat 18 | 19 | cabalCheckAndPrintVersion :: Zift () 20 | cabalCheckAndPrintVersion = do 21 | let cmd = "cabal --version" 22 | (_, mouth, _, ph) <- 23 | liftIO $ createProcess ((shell cmd) {std_out = CreatePipe}) 24 | ec <- liftIO $ waitForProcess ph 25 | case mouth of 26 | Nothing -> pure () 27 | Just outh -> liftIO (hGetContents outh) >>= printZift 28 | case ec of 29 | ExitFailure c -> fail $ unwords [cmd, "failed with exit code", show c] 30 | ExitSuccess -> pure () 31 | 32 | cabalFormat :: Zift () 33 | cabalFormat = do 34 | rd <- getRootDir 35 | cabalFiles <- 36 | liftIO $ 37 | (filter (not . hidden) . filter ((".cabal" ==) . fileExtension) . snd) <$> 38 | listDirRecur rd 39 | forZ_ cabalFiles formatSingleCabalFile 40 | 41 | formatSingleCabalFile :: Path Abs File -> Zift () 42 | formatSingleCabalFile cabalFile = do 43 | let formatCmd = "cabal format" 44 | cec <- liftIO $ system $ unwords [formatCmd, toFilePath cabalFile] 45 | case cec of 46 | ExitFailure c -> do 47 | printPreprocessingError $ 48 | unwords ["Failed to format cabal file:", toFilePath cabalFile] 49 | fail $ unwords [formatCmd, "failed with exit code", show c] 50 | ExitSuccess -> 51 | printPreprocessingDone $ 52 | unwords ["Formatted cabal file:", toFilePath cabalFile] 53 | 54 | hidden :: Path Abs t -> Bool 55 | hidden = any ((Just '.' ==) . headMay) . FP.splitPath . toFilePath 56 | -------------------------------------------------------------------------------- /zifter/test/Zifter/Zift/Gen.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | module Zifter.Zift.Gen where 7 | 8 | import GHC.Generics 9 | 10 | import Data.Colour.SRGB 11 | import Data.GenValidity 12 | import Data.Monoid 13 | 14 | import System.Console.ANSI 15 | 16 | import Zifter.Zift.Types 17 | 18 | deriving instance Generic Underlining 19 | 20 | instance GenUnchecked Underlining 21 | 22 | deriving instance Generic BlinkSpeed 23 | 24 | instance GenUnchecked BlinkSpeed 25 | 26 | deriving instance Generic ConsoleLayer 27 | 28 | instance GenUnchecked ConsoleLayer 29 | 30 | deriving instance Generic Color 31 | 32 | instance GenUnchecked Color 33 | 34 | deriving instance Generic ConsoleIntensity 35 | 36 | instance GenUnchecked ConsoleIntensity 37 | 38 | deriving instance Generic ColorIntensity 39 | 40 | instance GenUnchecked ColorIntensity 41 | 42 | deriving instance Generic SGR 43 | 44 | instance GenUnchecked SGR 45 | 46 | instance GenUnchecked LR 47 | 48 | instance GenUnchecked ZiftToken 49 | 50 | instance GenUnchecked ZiftOutput 51 | 52 | instance (Validity a) => Validity (RGB a) where 53 | validate RGB {..} = 54 | (channelRed "channelRed") <> (channelGreen "channelGreen") <> 55 | (channelBlue "channelBlue") 56 | isValid = isValidByValidating 57 | 58 | instance (Ord a, Floating a, GenUnchecked a) => GenUnchecked (Colour a) where 59 | genUnchecked = sRGB24 <$> genUnchecked <*> genUnchecked <*> genUnchecked 60 | shrinkUnchecked _ = [] 61 | 62 | instance (Floating a, RealFrac a, Validity a) => Validity (Colour a) where 63 | isValid = isValid . toSRGB24 64 | validate = validateByChecking "Colour" 65 | 66 | instance (Ord a, Floating a, RealFrac a, GenValid a) => 67 | GenValid (Colour a) where 68 | genValid = sRGB24 <$> genValid <*> genValid <*> genValid 69 | 70 | instance GenUnchecked a => GenUnchecked (ZiftResult a) where 71 | genUnchecked = ZiftSuccess <$> genUnchecked 72 | 73 | instance GenValid a => GenValid (ZiftResult a) where 74 | genValid = ZiftSuccess <$> genValid 75 | 76 | instance GenInvalid a => GenInvalid (ZiftResult a) where 77 | genInvalid = ZiftSuccess <$> genInvalid 78 | -------------------------------------------------------------------------------- /zifter-hindent/src/Zifter/Hindent.hs: -------------------------------------------------------------------------------- 1 | module Zifter.Hindent where 2 | 3 | import Control.Monad.IO.Class 4 | import Path 5 | import Path.IO 6 | import Safe 7 | import System.Exit (ExitCode(..)) 8 | import qualified System.FilePath as FP (splitPath) 9 | import System.IO 10 | import System.Process 11 | 12 | import Zifter.Zift 13 | 14 | newtype HindentBin = 15 | HindentBin (Path Abs File) 16 | deriving (Show, Eq) 17 | 18 | hindentZift :: Zift () 19 | hindentZift = hindentZiftExcept [] 20 | 21 | hindentZiftExcept :: [FilePath] -> Zift () 22 | hindentZiftExcept ps = do 23 | hindentBin <- getHindent 24 | () <- hindentCheckAndPrintVersion hindentBin 25 | rd <- getRootDir 26 | fs <- liftIO $ snd <$> listDirRecur rd 27 | exclusions <- mapM (resolveFile rd) ps 28 | let sources = 29 | filter (not . (`elem` exclusions)) . filter (not . hidden) $ 30 | filter ((== ".hs") . fileExtension) fs 31 | forZ_ sources $ hindentSingleSource hindentBin 32 | 33 | getHindent :: Zift HindentBin 34 | getHindent = do 35 | home <- liftIO getHomeDir 36 | file <- liftIO $ parseRelFile ".local/bin/hindent" 37 | pure $ HindentBin $ home file 38 | 39 | hindentCmd :: HindentBin -> [String] -> String 40 | hindentCmd (HindentBin ap) args = unwords $ toFilePath ap : args 41 | 42 | hindentCheckAndPrintVersion :: HindentBin -> Zift () 43 | hindentCheckAndPrintVersion hb = do 44 | let cmd = hindentCmd hb ["--version"] 45 | (_, mouth, _, ph) <- 46 | liftIO $ createProcess ((shell cmd) {std_out = CreatePipe}) 47 | ec <- liftIO $ waitForProcess ph 48 | case mouth of 49 | Nothing -> pure () 50 | Just outh -> liftIO (hGetContents outh) >>= printZift 51 | case ec of 52 | ExitFailure c -> fail $ unwords [cmd, "failed with exit code", show c] 53 | ExitSuccess -> pure () 54 | 55 | hindentSingleSource :: HindentBin -> Path Abs File -> Zift () 56 | hindentSingleSource hb file = do 57 | let cmd = 58 | hindentCmd 59 | hb 60 | ["--indent-size", "4", "--line-length", "80", toFilePath file] 61 | let cp = shell cmd 62 | ec <- 63 | liftIO $ do 64 | (_, _, _, ph) <- createProcess cp 65 | waitForProcess ph 66 | case ec of 67 | ExitSuccess -> 68 | printPreprocessingDone $ 69 | unwords 70 | ["Formatted Haskell source file with hindent:", toFilePath file] 71 | ExitFailure c -> do 72 | printPreprocessingError $ 73 | unwords 74 | ["Failed to format Haskell source file:", toFilePath file] 75 | fail $ unwords [cmd, "failed", "with exit code", show c] 76 | 77 | hidden :: Path Abs t -> Bool 78 | hidden = any ((Just '.' ==) . headMay) . FP.splitPath . toFilePath 79 | -------------------------------------------------------------------------------- /zifter-google-java-format/src/Zifter/GoogleJavaFormat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Zifter.GoogleJavaFormat where 4 | 5 | import Control.Monad 6 | 7 | import System.Exit 8 | import qualified System.FilePath as FP 9 | import System.IO 10 | import System.Process 11 | 12 | import Safe 13 | 14 | import Path 15 | import Path.IO 16 | 17 | import Zifter.Zift 18 | 19 | googleJavaFormatZift :: Zift () 20 | googleJavaFormatZift = do 21 | format <- getJavaFormatter 22 | rd <- getRootDir 23 | fs <- liftIO $ snd <$> listDirRecur rd 24 | let sources = 25 | filter (not . hidden) $ filter ((== ".java") . fileExtension) fs 26 | forZ_ sources format 27 | 28 | getJavaFormatter :: Zift (Path Abs File -> Zift ()) 29 | getJavaFormatter = do 30 | downloadJavaFormatIfMissing 31 | jarFile <- javaFormatterJarFile 32 | pure $ \abspath -> 33 | runZiftCommand $ 34 | unwords 35 | [ "java" 36 | , "-jar" 37 | , toFilePath jarFile 38 | , "--replace" 39 | , toFilePath abspath 40 | ] 41 | 42 | downloadJavaFormatIfMissing :: Zift () 43 | downloadJavaFormatIfMissing = do 44 | jarFile <- javaFormatterJarFile 45 | exists <- doesFileExist jarFile 46 | unless exists $ do 47 | ensureDir $ parent jarFile 48 | runZiftCommand $ 49 | unwords 50 | [ wgetCmd 51 | , javaFormatterUrl 52 | , "--output-document" 53 | , toFilePath jarFile 54 | ] 55 | 56 | javaFormatDir :: Zift (Path Abs Dir) 57 | javaFormatDir = ( $(mkRelDir "google-java-format")) <$> getTempDir 58 | 59 | javaFormatterJarFile :: Zift (Path Abs File) 60 | javaFormatterJarFile = 61 | ( $(mkRelFile "google-java-format-1.0-all-deps.jar")) <$> javaFormatDir 62 | 63 | wgetCmd :: String 64 | wgetCmd = "wget" 65 | 66 | javaFormatterUrl :: FilePath 67 | javaFormatterUrl = 68 | "https://github.com/google/google-java-format/releases/download/google-java-format-1.0/google-java-format-1.0-all-deps.jar" 69 | 70 | hidden :: Path Abs t -> Bool 71 | hidden = any ((Just '.' ==) . headMay) . FP.splitPath . toFilePath 72 | 73 | runZiftCommand :: String -> Zift () 74 | runZiftCommand command = do 75 | let cp = shell command 76 | (_, mouth, merrh, ph) <- liftIO $ createProcess cp 77 | ec <- liftIO $ waitForProcess ph 78 | case mouth of 79 | Nothing -> pure () 80 | Just outh -> liftIO (hGetContents outh) >>= printZift 81 | case merrh of 82 | Nothing -> pure () 83 | Just errh -> liftIO (hGetContents errh) >>= printPreprocessingError 84 | case ec of 85 | ExitFailure c -> 86 | fail $ unwords [command, "failed with exit code", show c] 87 | ExitSuccess -> printPreprocessingDone $ unwords [command, "succeeded."] 88 | -------------------------------------------------------------------------------- /zifter/src/Zifter/Recurse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Zifter.Recurse 4 | ( recursiveZift 5 | , recursively 6 | , hiddenIn 7 | ) where 8 | 9 | import Control.Monad 10 | import Control.Monad.IO.Class 11 | import Data.List 12 | import Path 13 | import Path.IO 14 | import System.Exit 15 | import qualified System.FilePath as FP 16 | import System.IO 17 | import System.Process 18 | 19 | import Zifter.Script 20 | import Zifter.Zift 21 | 22 | -- | Recursively call each @zift.hs@ script in the directories below the 23 | -- directory of the currently executing @zift.hs@ script. 24 | -- 25 | -- Only the topmost @zift.hs@ script in each directory is executed. 26 | -- This means that, to execute all @zift.hs@ scripts recursively, each of those 27 | -- @zift.hs@ scripts must also have a 'recursiveZift' declaration. 28 | recursiveZift :: ZiftScript () 29 | recursiveZift = do 30 | preprocessor $ do 31 | rd <- getRootDir 32 | printRecursionMsg $ 33 | unwords ["RECURSIVE PREPROCESSING STARTING FROM", toFilePath rd] 34 | recursively $ \ziftFile -> runZiftScript ziftFile "preprocess" 35 | printRecursionMsg $ 36 | unwords ["RECURSIVE PREPROCESSING FROM", toFilePath rd, "DONE."] 37 | prechecker $ do 38 | rd <- getRootDir 39 | printRecursionMsg $ 40 | unwords ["RECURSIVE PRECHECKING STARTING FROM", toFilePath rd] 41 | recursively $ \ziftFile -> runZiftScript ziftFile "precheck" 42 | printRecursionMsg $ 43 | unwords ["RECURSIVE PRECHECKING FROM", toFilePath rd, "DONE."] 44 | checker $ do 45 | rd <- getRootDir 46 | printRecursionMsg $ 47 | unwords ["RECURSIVE CHECKING STARTING FROM", toFilePath rd] 48 | recursively $ \ziftFile -> runZiftScript ziftFile "check" 49 | printRecursionMsg $ 50 | unwords ["RECURSIVE CHECKING FROM", toFilePath rd, "DONE"] 51 | 52 | recursively :: (Path Abs File -> Zift ()) -> Zift () 53 | recursively func = do 54 | fs <- findZiftFilesRecursively 55 | -- In serial on purpose. 56 | forM_ fs func 57 | 58 | halfIndent :: String -> String 59 | halfIndent = (" " ++) 60 | 61 | indent :: String -> String 62 | indent = halfIndent . ("| " ++) 63 | 64 | printRecursionMsg :: String -> Zift () 65 | printRecursionMsg = printZiftMessage . halfIndent 66 | 67 | runZiftScript :: Path Abs File -> String -> Zift () 68 | runZiftScript scriptPath command = do 69 | rd <- getRootDir 70 | printRecursionMsg $ 71 | unwords 72 | [ "ZIFTING" 73 | , toFilePath scriptPath 74 | , "AS PART OF RECURSIVE ZIFT FROM" 75 | , toFilePath rd 76 | ] 77 | let cmd = unwords [toFilePath scriptPath, command] 78 | let cp = 79 | (shell cmd) 80 | {cwd = Just $ toFilePath $ parent scriptPath, std_out = CreatePipe} 81 | (_, mouth, merrh, ph) <- liftIO $ createProcess cp 82 | ec <- liftIO $ waitForProcess ph 83 | case mouth of 84 | Nothing -> pure () 85 | Just outh -> do 86 | cts <- liftIO (hGetContents outh) 87 | forM_ (lines cts) $ printZift . indent 88 | case merrh of 89 | Nothing -> pure () 90 | Just errh -> liftIO (hGetContents errh) >>= printZift 91 | case ec of 92 | ExitSuccess -> 93 | printRecursionMsg $ 94 | unwords 95 | [ "ZIFTING" 96 | , toFilePath scriptPath 97 | , "AS PART OF RECURSIVE ZIFT FROM" 98 | , toFilePath rd 99 | , "DONE" 100 | ] 101 | ExitFailure c -> do 102 | printPreprocessingError $ halfIndent "RECURSIVE ZIFT FAILED" 103 | fail $ 104 | unwords 105 | [ show cmd 106 | , "failed with exit code" 107 | , show c 108 | , "while recursively zifting with" 109 | , toFilePath scriptPath 110 | ] 111 | 112 | findZiftFilesRecursively :: Zift [Path Abs File] 113 | findZiftFilesRecursively = do 114 | rd <- getRootDir 115 | fs <- findFiles [rd] $(mkRelFile "zift.hs") 116 | pure $ filter (not . hiddenIn rd) fs 117 | 118 | hiddenIn :: Path Abs Dir -> Path Abs File -> Bool 119 | hiddenIn rp af = 120 | case stripProperPrefix rp af of 121 | Nothing -> True 122 | Just rf -> any (isPrefixOf ".") $ FP.splitDirectories $ fromRelFile rf 123 | -------------------------------------------------------------------------------- /zifter/src/Zifter/Zift/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE GADTs #-} 4 | 5 | module Zifter.Zift.Types where 6 | 7 | import Prelude 8 | 9 | import Control.Concurrent.STM 10 | import Control.Monad.Catch (MonadThrow(..)) 11 | import Control.Monad.Fail as Fail 12 | import Control.Monad.IO.Class 13 | import Data.Validity 14 | import Data.Validity.Path () 15 | import GHC.Generics 16 | import Path 17 | import System.Console.ANSI (SGR) 18 | 19 | import Zifter.OptParse.Types 20 | 21 | data ZiftToken = 22 | ZiftToken [LR] 23 | (Maybe ZiftOutput) 24 | deriving (Show, Eq, Generic) 25 | 26 | data ZiftOutput = ZiftOutput 27 | { outputColors :: [SGR] 28 | , outputMessage :: String 29 | } deriving (Show, Eq, Generic) 30 | 31 | data ZiftContext = ZiftContext 32 | { rootdir :: Path Abs Dir 33 | , tmpdir :: Path Abs Dir 34 | , settings :: Settings 35 | , printChan :: TChan ZiftToken 36 | , recursionList :: [LR] -- In reverse order 37 | } deriving (Generic) 38 | 39 | data LR 40 | = L 41 | | R 42 | deriving (Show, Eq, Generic) 43 | 44 | instance Validity ZiftContext where 45 | isValid = isValid . rootdir 46 | #if MIN_VERSION_validity(0,4,0) 47 | validate zc = rootdir zc "rootdir" 48 | #endif 49 | data Zift a where 50 | ZiftPure :: a -> Zift a 51 | ZiftCtx :: Zift ZiftContext 52 | ZiftPrint :: ZiftOutput -> Zift () 53 | ZiftFail :: String -> Zift a 54 | ZiftIO :: IO a -> Zift a 55 | ZiftFmap :: (a -> b) -> Zift a -> Zift b 56 | ZiftApp :: Zift (a -> b) -> Zift a -> Zift b 57 | ZiftBind :: Zift a -> (a -> Zift b) -> Zift b 58 | 59 | instance Monoid a => Monoid (Zift a) where 60 | mempty = ZiftPure mempty 61 | mappend z1 z2 = mappend <$> z1 <*> z2 62 | 63 | instance Functor Zift where 64 | fmap = ZiftFmap 65 | 66 | -- | 'Zift' actions can be sequenced. 67 | -- 68 | -- The implementation automatically parallelises the arguments of the 69 | -- @(<*>)@ function. If any of the actions fails, the other is cancelled 70 | -- and the result fails. 71 | instance Applicative Zift where 72 | pure = ZiftPure 73 | (<*>) = ZiftApp 74 | 75 | -- | 'Zift' actions can be composed. 76 | instance Monad Zift where 77 | (>>=) = ZiftBind 78 | fail = Fail.fail 79 | 80 | -- | A 'Zift' action can fail. 81 | -- 82 | -- To make a Zift action fail, you can use the @fail :: String -> Zift a@ 83 | -- function. 84 | -- 85 | -- The implementation uses the given string as the message that is shown at 86 | -- the very end of the run. 87 | instance MonadFail Zift where 88 | fail = ZiftFail 89 | -- fail s = Zift $ \_ -> pure $ ZiftFailed s 90 | 91 | -- | Any IO action can be part of a 'Zift' action. 92 | -- 93 | -- This is the most important instance for the end user. 94 | -- 95 | -- > liftIO :: IO a -> Zift a 96 | -- allows embedding arbitrary IO actions inside a 'Zift' action. 97 | -- 98 | -- The implementation also ensures that exceptions are caught. 99 | instance MonadIO Zift where 100 | liftIO = ZiftIO 101 | 102 | instance MonadThrow Zift where 103 | throwM = ZiftIO . throwM 104 | 105 | data ZiftResult a 106 | = ZiftSuccess a 107 | | ZiftFailed String 108 | deriving (Show, Eq, Generic) 109 | 110 | instance Validity a => Validity (ZiftResult a) where 111 | isValid (ZiftSuccess a) = isValid a 112 | isValid _ = True 113 | 114 | instance Monoid a => Monoid (ZiftResult a) where 115 | mempty = ZiftSuccess mempty 116 | mappend z1 z2 = mappend <$> z1 <*> z2 117 | 118 | instance Functor ZiftResult where 119 | fmap f (ZiftSuccess a) = ZiftSuccess $ f a 120 | fmap _ (ZiftFailed s) = ZiftFailed s 121 | 122 | instance Applicative ZiftResult where 123 | pure = ZiftSuccess 124 | (ZiftSuccess f) <*> (ZiftSuccess a) = ZiftSuccess $ f a 125 | (ZiftFailed e) <*> (ZiftSuccess _) = ZiftFailed e 126 | (ZiftSuccess _) <*> (ZiftFailed e) = ZiftFailed e 127 | (ZiftFailed e1) <*> (ZiftFailed e2) = ZiftFailed $ unwords [e1, e2] 128 | 129 | instance Monad ZiftResult where 130 | (ZiftSuccess a) >>= fb = fb a 131 | (ZiftFailed e) >>= _ = ZiftFailed e 132 | 133 | instance MonadFail ZiftResult where 134 | fail = ZiftFailed 135 | -- -- | Internal: do not use yourself. 136 | -- tryFlushZiftBuffer :: ZiftContext -> ZiftState -> IO ZiftState 137 | -- tryFlushZiftBuffer ctx st = 138 | -- if flushable $ recursionList ctx 139 | -- then do 140 | -- let zos = reverse $ bufferedOutput st 141 | -- st' = st {bufferedOutput = []} 142 | -- atomically $ mapM_ (writeTChan $ printChan ctx) zos 143 | -- pure st' 144 | -- else pure st 145 | -- 146 | -- -- The buffer is flushable when it's guaranteed to be the first in the in-order 147 | -- -- of the evaluation tree. 148 | -- flushable :: [LR] -> Bool 149 | -- flushable = all (== L) 150 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Zifter 2 | ====== 3 | 4 | 5 | - Write your own pre-commit tests for any project with a simple EDSL 6 | - Automatic parallelisation 7 | - Output that looks as if everything was run sequentially. 8 | - Only one dependency: [`stack`](https://haskellstack.org/) 9 | 10 | 11 | ### What to do with a `zift.hs` script when it's in a repository 12 | 13 | A `zift.hs` script is a code quality tool. 14 | It can be used to define and enforce code quality standards in a repository. 15 | 16 | To run a `zift.hs` script, execute `./zift.hs run`. 17 | This will run the preprocessor, the prechecker and the checker. 18 | If at any point something fails, the entire execution will fail and the exit code will be nonzero. 19 | 20 | To start using a `zift.hs` script automatically, you need to install it as a pre-commit script with `zift.hs install`. 21 | This ensures that `zift.hs run` will be run before every `git commit`, and that you will not be able to commit unless `zift.hs run` exits successfully. 22 | (There is still a way around this with `git commit --no-verify` for emergencies.) 23 | 24 | You can also run individual parts of the `zift.hs` script with `zift.hs preprocess`, `zift.hs precheck` and `zift.hs check`. 25 | 26 | ### How to write a `zift.hs` script 27 | 28 | Zifter is intended to be a composable (and extensible) code quality tool. 29 | You can write your own `zift.hs` scripts to define the code quality standards that you want to uphold in your project. 30 | 31 | A `zift.hs` has three main sections: 32 | 33 | - `preprocessor` 34 | - `prechecker` 35 | - `checker` 36 | 37 | In the `preprocess` section, you define what needs to happen with your code before you start checking anything. 38 | For example, this is where you put code formatters. 39 | 40 | In the `prechecker` section, you define what needs to happen with the repository after the preprocessor check. 41 | For example, after you have reformatted all the source files, you will probably want to run `git add .`, so that these changes are also in the commit. 42 | 43 | In the `checker` section, you define all the checks that need to succeed in order to allow a commit. 44 | For example, you probably want to ensure that the project builds successfully, that the tests pass, etc... 45 | 46 | To find predefined functions that you can put in these sections, have a look at the `zifter-*` packages. 47 | 48 | #### Example 49 | 50 | The following is an example of a `zift.hs` script for a Haskell project. 51 | 52 | [`zift.hs`](/zift.hs) 53 | 54 | The following `zift.hs` script first runs `hindent` and `cabal format` on all relevant files, in parallel. 55 | Then it runs `git add .`. 56 | Lastly, it runs `hlint` on the entire project and then it runs `stack` to ensure that everything compiles without warnings and the tests succeed. 57 | 58 | ``` 59 | #!/usr/bin/env stack 60 | {- stack 61 | --install-ghc 62 | runghc 63 | --package zifter 64 | --package zifter-cabal 65 | --package zifter-git 66 | --package zifter-hindent 67 | --package zifter-hlint 68 | --package zifter-stack 69 | -} 70 | 71 | import Zifter 72 | import Zifter.Cabal 73 | import Zifter.Git 74 | import Zifter.Hindent 75 | import Zifter.Hlint 76 | import Zifter.Stack 77 | 78 | main :: IO () 79 | main = 80 | ziftWith $ do 81 | preprocessor $ ziftP [hindentZift, cabalFormatZift] 82 | prechecker gitAddAllZift 83 | checker $ do 84 | hlintZift 85 | stackBuildZift 86 | ``` 87 | 88 | ### How to write your own `Zift` functions 89 | 90 | The functions in the `preprocess`, `precheck` and `checker` sections are of type `Zift ()`. 91 | 92 | All the relevant documentation is in [the `Zifter` module](https://hackage.haskell.org/package/zifter/docs/Zifter.html). 93 | 94 | It is important to note that `Zift` has a `MonadIO` instance, so that you can embed any `IO` action in a `Zift` action. 95 | 96 | ### How to use a `zift.hs` script to define your continuous integration setup 97 | 98 | The most important parts here are the following: 99 | 100 | - Make sure you get `stack`: 101 | 102 | ``` 103 | addons: 104 | apt: 105 | packages: 106 | - libgmp-dev 107 | 108 | before_install: 109 | - mkdir -p ~/.local/bin 110 | - export PATH=$HOME/.local/bin:$PATH 111 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 112 | - chmod a+x ~/.local/bin/stack 113 | ``` 114 | 115 | Install all dependencies with stack: 116 | 117 | ``` 118 | install: 119 | - stack setup 120 | - stack build --only-snapshot 121 | ``` 122 | 123 | Run the `zift.hs` script on travis. 124 | 125 | ``` 126 | script: 127 | - ./zift.hs run 128 | ``` 129 | 130 | The [`.travis.yml`](/.travis.yml) file in this repository can serve as an example. 131 | 132 | ### The name 133 | 134 | The name 'Zifter' comes from the dutch word 'muggenzifter', which means 'nitpicker'. 135 | -------------------------------------------------------------------------------- /zifter/src/Zifter/Zift.hs: -------------------------------------------------------------------------------- 1 | module Zifter.Zift 2 | ( getRootDir 3 | , getTmpDir 4 | , getSettings 5 | , getSetting 6 | , ziftP 7 | , mapZ 8 | , mapZ_ 9 | , forZ 10 | , forZ_ 11 | , printZift 12 | , printZiftMessage 13 | , printPreprocessingDone 14 | , printPreprocessingError 15 | , printWithColors 16 | , addZiftOutput 17 | , liftIO 18 | , module Zifter.Zift.Types 19 | ) where 20 | 21 | import Control.Monad 22 | import Control.Monad.IO.Class (liftIO) 23 | 24 | import System.Console.ANSI 25 | 26 | import Path 27 | 28 | import Zifter.OptParse.Types 29 | import Zifter.Zift.Types 30 | 31 | getContext :: Zift ZiftContext 32 | getContext = ZiftCtx 33 | 34 | -- | Get the root directory of the @zift.hs@ script that is being executed. 35 | getRootDir :: Zift (Path Abs Dir) 36 | getRootDir = fmap rootdir getContext 37 | 38 | -- | Get the temporary directory of the @zift.hs@ script that is being executed. 39 | -- 40 | -- To persist any state between runs, use this directory. 41 | getTmpDir :: Zift (Path Abs Dir) 42 | getTmpDir = fmap tmpdir getContext 43 | 44 | -- | Get all the 'Settings' 45 | getSettings :: Zift Settings 46 | getSettings = fmap settings getContext 47 | 48 | -- | Get a single setting 49 | getSetting :: (Settings -> a) -> Zift a 50 | getSetting func = func <$> getSettings 51 | 52 | -- | Declare a given list of 'Zift' actions to be execute in parallel. 53 | ziftP :: [Zift ()] -> Zift () 54 | ziftP = mconcat 55 | 56 | -- | Like 'mapA', but specialised to 'Zift' and '[]', and ensures that the 57 | -- output of actions is printed in the right order, even if they are 58 | -- executed in an arbitrary order. 59 | mapZ :: (a -> Zift b) -> [a] -> Zift [b] 60 | mapZ func as = forZ as func 61 | 62 | -- | Like 'mapA_', but specialised to 'Zift' and '[]', and ensures that the 63 | -- output of actions is printed in the right order, even if they are 64 | -- executed in an arbitrary order. 65 | mapZ_ :: (a -> Zift b) -> [a] -> Zift () 66 | mapZ_ func as = forZ_ as func 67 | 68 | -- | Like 'for', but specialised to 'Zift' and '[]', and ensures that the 69 | -- output of actions is printed in the right order, even if they are 70 | -- executed in an arbitrary order. 71 | forZ :: [a] -> (a -> Zift b) -> Zift [b] 72 | forZ [] _ = pure [] 73 | forZ (a:as) func = (:) <$> func a <*> forZ as func 74 | 75 | -- | Like 'for_', but specialised to 'Zift' and '[]', and ensures that the output of 76 | -- actions is printed in the right order. 77 | forZ_ :: [a] -> (a -> Zift b) -> Zift () 78 | forZ_ as func = void $ forZ as func 79 | 80 | -- | Print a message (with a newline appended to the end). 81 | printZift :: String -> Zift () 82 | printZift = printWithColors [] 83 | 84 | -- | Print a message (with a newline appended to the end), in the standard 85 | -- zift script color. This is the function that the zift script uses to output 86 | -- information about the stages of the zift script run. 87 | printZiftMessage :: String -> Zift () 88 | printZiftMessage = printWithColors [SetColor Foreground Dull Blue] 89 | 90 | -- | Print a message (with a newline appended to the end) that signifies that 91 | -- a part of the processing is now done. 92 | -- 93 | -- Example: 94 | -- 95 | -- > doThingZift :: Zift () 96 | -- > doThingZift = do 97 | -- > doThing 98 | -- > printProcessingDone "doThing completed successfully." 99 | printPreprocessingDone :: String -> Zift () 100 | printPreprocessingDone = printWithColors [SetColor Foreground Dull Green] 101 | 102 | -- | Print a message (with a newline appended to the end) that signifies that 103 | -- a part of the processing failed. This message will not cause the zift script 104 | -- run to fail. 105 | -- 106 | -- Example: 107 | -- 108 | -- > doDangerousThing :: Zift () 109 | -- > doDangerousThing = do 110 | -- > errOrResult <- doThing 111 | -- > case errOrResult of 112 | -- > Left err -> 113 | -- > printPreprocessingError $ 114 | -- > unwords ["doThing failed with error:", err] 115 | -- > fail "doThing failed." 116 | -- > Right result -> do 117 | -- > printPreprocessingDone 118 | -- > unwords ["doThing succeeded with result:", result] 119 | printPreprocessingError :: String -> Zift () 120 | printPreprocessingError = printWithColors [SetColor Foreground Dull Red] 121 | 122 | -- | Print a message (with a newline appended to the end) with custom colors. 123 | -- 124 | -- See the [ansi-terminal](https://hackage.haskell.org/package/ansi-terminal) 125 | -- package for more details. 126 | printWithColors :: [SGR] -> String -> Zift () 127 | printWithColors commands str = addZiftOutput $ ZiftOutput commands str 128 | 129 | addZiftOutput :: ZiftOutput -> Zift () 130 | addZiftOutput = ZiftPrint 131 | -- Zift $ \ctx -> do 132 | -- atomically $ 133 | -- writeTChan (printChan ctx) $ TokenOutput (recursionList ctx) zo 134 | -- pure $ ZiftSuccess () 135 | -------------------------------------------------------------------------------- /zifter/src/Zifter/OptParse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Zifter.OptParse 4 | ( module Zifter.OptParse 5 | , Instructions 6 | , Dispatch(..) 7 | , Settings(..) 8 | , OutputMode(..) 9 | ) where 10 | 11 | import Data.Maybe 12 | import Data.Monoid 13 | import Options.Applicative 14 | import System.Environment (getArgs) 15 | 16 | import Zifter.OptParse.Types 17 | 18 | getInstructions :: IO Instructions 19 | getInstructions = do 20 | (cmd, flags) <- getArguments 21 | config <- getConfiguration cmd flags 22 | combineToInstructions cmd flags config 23 | 24 | combineToInstructions :: Command -> Flags -> Configuration -> IO Instructions 25 | combineToInstructions cmd Flags {..} Configuration = pure (d, sets) 26 | where 27 | sets = 28 | Settings 29 | { setsOutputColor = flagsOutputColor 30 | , setsOutputMode = fromMaybe OutputLinear flagsOutputMode 31 | } 32 | d = 33 | case cmd of 34 | CommandRun -> DispatchRun 35 | CommandInstall r -> DispatchInstall r 36 | CommandPreProcess -> DispatchPreProcess 37 | CommandPreCheck -> DispatchPreCheck 38 | CommandCheck -> DispatchCheck 39 | 40 | getConfiguration :: Command -> Flags -> IO Configuration 41 | getConfiguration _ _ = pure Configuration 42 | 43 | getArguments :: IO Arguments 44 | getArguments = do 45 | args <- getArgs 46 | let result = runArgumentsParser args 47 | handleParseResult result 48 | 49 | runArgumentsParser :: [String] -> ParserResult Arguments 50 | runArgumentsParser = execParserPure pfs argParser 51 | where 52 | pfs = 53 | ParserPrefs 54 | { prefMultiSuffix = "" 55 | , prefDisambiguate = True 56 | , prefShowHelpOnError = True 57 | , prefShowHelpOnEmpty = True 58 | , prefBacktrack = True 59 | , prefColumns = 80 60 | } 61 | 62 | argParser :: ParserInfo Arguments 63 | argParser = info (helper <*> parseArgs) hlp 64 | where 65 | hlp = fullDesc <> progDesc description 66 | description = "Zifter" 67 | 68 | parseArgs :: Parser Arguments 69 | parseArgs = (,) <$> parseCommand <*> parseFlags 70 | 71 | parseCommand :: Parser Command 72 | parseCommand = 73 | hsubparser $ 74 | mconcat 75 | [ command "run" parseCommandRun 76 | , command "preprocess" parseCommandPreProcess 77 | , command "precheck" parseCommandPreCheck 78 | , command "check" parseCommandCheck 79 | , command "install" parseCommandInstall 80 | ] 81 | 82 | parseCommandRun :: ParserInfo Command 83 | parseCommandRun = info parser modifier 84 | where 85 | parser = pure CommandRun 86 | modifier = fullDesc <> progDesc "Run the zift script." 87 | 88 | parseCommandPreProcess :: ParserInfo Command 89 | parseCommandPreProcess = info parser modifier 90 | where 91 | parser = pure CommandPreProcess 92 | modifier = fullDesc <> progDesc "PreProcess according to the zift script." 93 | 94 | parseCommandPreCheck :: ParserInfo Command 95 | parseCommandPreCheck = info parser modifier 96 | where 97 | parser = pure CommandPreCheck 98 | modifier = fullDesc <> progDesc "PreCheck according to the zift script." 99 | 100 | parseCommandCheck :: ParserInfo Command 101 | parseCommandCheck = info parser modifier 102 | where 103 | parser = pure CommandCheck 104 | modifier = fullDesc <> progDesc "Check according to the zift script." 105 | 106 | parseCommandInstall :: ParserInfo Command 107 | parseCommandInstall = info parser modifier 108 | where 109 | parser = 110 | CommandInstall <$> doubleSwitch "recursive" "Install recursively" mempty 111 | modifier = fullDesc <> progDesc "Install the zift script." 112 | 113 | parseFlags :: Parser Flags 114 | parseFlags = 115 | Flags <$> doubleSwitch "color" "color in output." mempty <*> outputModeFlag 116 | 117 | doubleSwitch :: String -> String -> Mod FlagFields Bool -> Parser Bool 118 | doubleSwitch name helpText mods = 119 | let enabledValue = True 120 | disabledValue = False 121 | defaultValue = True 122 | in (last <$> 123 | some 124 | ((flag' 125 | enabledValue 126 | (hidden <> internal <> long name <> help helpText <> mods) <|> 127 | flag' 128 | disabledValue 129 | (hidden <> internal <> long ("no-" ++ name) <> help helpText <> 130 | mods)) <|> 131 | flag' 132 | disabledValue 133 | (long ("[no-]" ++ name) <> 134 | help 135 | ("Enable/disable " ++ 136 | helpText ++ " (default: " ++ show defaultValue ++ ")") <> 137 | mods))) <|> 138 | pure defaultValue 139 | 140 | outputModeFlag :: Parser (Maybe OutputMode) 141 | outputModeFlag = 142 | (flag' 143 | (Just OutputLinear) 144 | (mconcat [long "linear", help "output linearly, reorder as necessary."]) <|> 145 | flag' 146 | (Just OutputFast) 147 | (mconcat 148 | [ long "fast" 149 | , help "output as soon as possible, this is likely faster" 150 | ])) <|> 151 | pure Nothing 152 | -------------------------------------------------------------------------------- /zifter-stack/src/Zifter/Stack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Zifter.Stack where 4 | 5 | import Control.Monad 6 | import Control.Monad.IO.Class 7 | import Data.Function (on) 8 | import Data.List 9 | (groupBy, intersect, isInfixOf, isPrefixOf, isSuffixOf, sortOn) 10 | import Data.Maybe (mapMaybe) 11 | import Path 12 | import Path.IO 13 | import Safe 14 | import System.Exit (ExitCode(..)) 15 | import qualified System.FilePath as FP (splitPath) 16 | import System.IO 17 | import System.Process 18 | 19 | import Distribution.Package 20 | import Distribution.PackageDescription 21 | import Distribution.PackageDescription.Configuration 22 | import Distribution.PackageDescription.Parse 23 | import Distribution.Verbosity 24 | #if MIN_VERSION_Cabal(2,0,0) 25 | import Distribution.Types.UnqualComponentName 26 | #endif 27 | import Zifter.Zift 28 | 29 | stackBuildZift :: Zift () 30 | stackBuildZift = do 31 | () <- stackCheckAndPrintVersion 32 | stackBuild 33 | 34 | stackCheckAndPrintVersion :: Zift () 35 | stackCheckAndPrintVersion = do 36 | rd <- getRootDir 37 | let cmd = "stack --version" 38 | (_, mouth, _, ph) <- 39 | liftIO $ 40 | createProcess 41 | ((shell cmd) {cwd = Just $ toFilePath rd, std_out = CreatePipe}) 42 | ec <- liftIO $ waitForProcess ph 43 | case mouth of 44 | Nothing -> pure () 45 | Just outh -> liftIO (hGetContents outh) >>= printZift 46 | case ec of 47 | ExitFailure c -> fail $ unwords [cmd, "failed with exit code", show c] 48 | ExitSuccess -> pure () 49 | 50 | data Pkg = 51 | Pkg String 52 | [Target] 53 | deriving (Show, Eq, Ord) 54 | 55 | data Target 56 | = Lib String 57 | | Test String 58 | | Bench String 59 | deriving (Show, Eq, Ord) 60 | 61 | stackGetPackages :: Zift [Pkg] 62 | stackGetPackages = 63 | combinePkgs <$> stackGetPackageTargetTuplesAccordingToStackIDE <*> 64 | stackGetPackageTargetTuplesAccordingToCabalFiles 65 | 66 | combinePkgs :: [Pkg] -> [Pkg] -> [Pkg] 67 | combinePkgs ps1 ps2 = unTups $ intersect (toTups ps1) (toTups ps2) 68 | where 69 | toTups :: [Pkg] -> [(String, Target)] 70 | toTups = concatMap (\(Pkg p ts) -> map ((,) p) ts) 71 | unTups :: [(String, Target)] -> [Pkg] 72 | unTups = 73 | mapMaybe 74 | (\tups -> Pkg <$> (fst <$> headMay tups) <*> pure (map snd tups)) . 75 | groupBy ((==) `on` fst) . sortOn fst 76 | 77 | stackGetPackageTargetTuplesAccordingToStackIDE :: Zift [Pkg] 78 | stackGetPackageTargetTuplesAccordingToStackIDE = do 79 | rd <- getRootDir 80 | let getErrFrom cmd = do 81 | (_, _, merrh, ph) <- 82 | liftIO $ 83 | createProcess 84 | ((shell cmd) 85 | {cwd = Just $ toFilePath rd, std_err = CreatePipe}) 86 | ec <- liftIO $ waitForProcess ph 87 | case ec of 88 | ExitFailure c -> 89 | fail $ unwords [show cmd, "failed with exit code", show c] 90 | ExitSuccess -> pure () 91 | case merrh of 92 | Nothing -> 93 | fail $ unwords ["Failed to capture output of", show cmd] 94 | Just outh -> liftIO (hGetContents outh) 95 | outt <- getErrFrom "stack ide targets" 96 | outp <- getErrFrom "stack ide packages" 97 | let targets = lines outt 98 | let packages = lines outp 99 | let isLib = isSuffixOf ":lib" 100 | let isTest = isInfixOf ":test:" 101 | let isBench = isInfixOf ":bench:" 102 | pure $ 103 | flip map packages $ \p -> 104 | let relevantTargets = filter (isPrefixOf p) targets 105 | in Pkg p $ 106 | map Lib (filter isLib relevantTargets) ++ 107 | map Test (filter isTest relevantTargets) ++ 108 | map Bench (filter isBench relevantTargets) 109 | 110 | stackGetPackageTargetTuplesAccordingToCabalFiles :: Zift [Pkg] 111 | stackGetPackageTargetTuplesAccordingToCabalFiles = do 112 | rd <- getRootDir 113 | (_, fs) <- liftIO $ listDirRecur rd 114 | let cabalFiles = 115 | filter (not . isInfixOf ".stack-work" . toFilePath) $ 116 | filter (not . hidden) $ filter ((== ".cabal") . fileExtension) fs 117 | forM cabalFiles $ \cabalFile -> do 118 | pd <- liftIO $ readPackage deafening $ toFilePath cabalFile 119 | let packageDesc = flattenPackageDescription pd 120 | name = unPackageName $ pkgName $ package packageDesc 121 | libname = name ++ ":lib" 122 | lib = 123 | case library packageDesc of 124 | Nothing -> [] 125 | Just _ -> [Lib libname] 126 | testnames = 127 | map (((name ++ ":test:") ++) . testComponentName) $ 128 | testSuites packageDesc 129 | benchnames = 130 | map (((name ++ ":bench:") ++) . benchComponentName) $ 131 | benchmarks packageDesc 132 | pure $ Pkg name $ lib ++ map Test testnames ++ map Bench benchnames 133 | #if MIN_VERSION_Cabal(2,0,0) 134 | readPackage :: Verbosity -> FilePath -> IO GenericPackageDescription 135 | readPackage = readGenericPackageDescription 136 | #else 137 | readPackage = readPackageDescription 138 | #endif 139 | 140 | #if MIN_VERSION_Cabal(2,0,0) 141 | testComponentName :: TestSuite -> String 142 | testComponentName = unUnqualComponentName . testName 143 | #else 144 | testComponentName = testName 145 | #endif 146 | 147 | #if MIN_VERSION_Cabal(2,0,0) 148 | benchComponentName :: Benchmark -> String 149 | benchComponentName = unUnqualComponentName . benchmarkName 150 | #else 151 | benchComponentName = benchmarkName 152 | #endif 153 | stackBuild :: Zift () 154 | stackBuild = do 155 | tups <- stackGetPackages 156 | stack "build" -- To get the dependencies done first 157 | mapM_ bePedanticAboutPackage tups 158 | 159 | stack :: String -> Zift () 160 | stack args = do 161 | rd <- getRootDir 162 | let buildCmd = unwords ["stack", args] 163 | (_, mouth, merrh, bph) <- 164 | liftIO $ 165 | createProcess 166 | ((shell buildCmd) 167 | { cwd = Just $ toFilePath rd 168 | , std_out = CreatePipe 169 | , std_err = CreatePipe 170 | }) 171 | bec <- liftIO $ waitForProcess bph 172 | case mouth of 173 | Nothing -> pure () 174 | Just outh -> liftIO (hGetContents outh) >>= printZift 175 | case merrh of 176 | Nothing -> pure () 177 | Just errh -> liftIO (hGetContents errh) >>= printZift 178 | case bec of 179 | ExitFailure c -> 180 | fail $ unwords [buildCmd, "failed with exit code", show c] 181 | ExitSuccess -> printPreprocessingDone $ unwords [buildCmd, "succeeded."] 182 | 183 | hidden :: Path Abs t -> Bool 184 | hidden = any ((Just '.' ==) . headMay) . FP.splitPath . toFilePath 185 | 186 | bePedanticAboutPackage :: Pkg -> Zift () 187 | bePedanticAboutPackage (Pkg package_ targets) = do 188 | stack $ unwords ["clean", package_] 189 | mapM_ bePedanticAboutTarget targets 190 | 191 | bePedanticAboutTarget :: Target -> Zift () 192 | bePedanticAboutTarget (Lib target) = do 193 | stack $ unwords ["build", target, "--pedantic"] 194 | stack $ unwords ["build", target, "--pedantic", "--haddock"] 195 | bePedanticAboutTarget (Test target) = do 196 | stack $ unwords ["build", target, "--pedantic", "--no-run-tests"] 197 | stack $ 198 | unwords ["build", target, "--pedantic", "--haddock", "--no-run-tests"] 199 | stack $ 200 | unwords 201 | [ "build" 202 | , target 203 | , "--pedantic" 204 | , "--test" 205 | , "--test-arguments='--fail-fast --seed=42'" 206 | ] 207 | bePedanticAboutTarget (Bench target) = do 208 | stack $ unwords ["build", target, "--pedantic", "--no-run-benchmarks"] 209 | stack $ 210 | unwords 211 | ["build", target, "--pedantic", "--haddock", "--no-run-benchmarks"] 212 | stack $ unwords ["build", target, "--pedantic", "--bench"] 213 | -------------------------------------------------------------------------------- /zifter/test/Zifter/ZiftSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | 4 | module Zifter.ZiftSpec 5 | ( spec 6 | ) where 7 | 8 | import TestImport 9 | 10 | import Control.Concurrent.STM 11 | 12 | import Zifter 13 | import Zifter.OptParse 14 | import Zifter.Zift 15 | 16 | import Zifter.Gen () 17 | import Zifter.OptParse.Gen () 18 | import Zifter.Zift.Gen () 19 | 20 | spec :: Spec 21 | spec = do 22 | describe "ZiftOutput" $ eqSpec @ZiftOutput 23 | describe "ZiftResult" $ do 24 | eqSpec @(ZiftResult Int) 25 | genValiditySpec @(ZiftResult Double) 26 | functorSpec @ZiftResult 27 | applicativeSpec @ZiftResult 28 | monoidSpec @(ZiftResult String) 29 | monadSpec @ZiftResult 30 | describe "ziftRunner" $ do 31 | it "pure () outputs nothing" $ 32 | pure () `outputShouldBe` [ZiftToken [] Nothing] 33 | it "pure () twice outputs two tokens" $ 34 | let func = do 35 | pure () 36 | pure () 37 | in func `outputShouldBe` 38 | [ZiftToken [L] Nothing, ZiftToken [R] Nothing] 39 | it "printZift outputs one message" $ 40 | printZift "hello" `outputShouldBe` 41 | [ ZiftToken 42 | [] 43 | (Just ZiftOutput {outputColors = [], outputMessage = "hello"}) 44 | ] 45 | it "printZift twice outputs two messages and two tokens" $ 46 | let func = do 47 | printZift "hello" 48 | printZift "world" 49 | in func `outputShouldBe` 50 | [ ZiftToken 51 | [L] 52 | (Just 53 | ZiftOutput 54 | {outputColors = [], outputMessage = "hello"}) 55 | , ZiftToken 56 | [R] 57 | (Just 58 | ZiftOutput 59 | {outputColors = [], outputMessage = "world"}) 60 | ] 61 | describe "addState" $ do 62 | it "stores the first output on the left for [L]" $ 63 | forAllUnchecked $ \mzo -> 64 | addState LinearUnknown (ZiftToken [L] mzo) `shouldBe` 65 | Just (LinearBranch (LinearLeaf mzo) LinearUnknown) 66 | it "stores the first output on the Right for [R]" $ 67 | forAllUnchecked $ \mzo -> 68 | addState LinearUnknown (ZiftToken [R] mzo) `shouldBe` 69 | Just (LinearBranch LinearUnknown (LinearLeaf mzo)) 70 | describe "flushState" $ do 71 | let l = LinearLeaf 72 | u = LinearUnknown 73 | d = LinearDone 74 | b = LinearBranch 75 | ln = l Nothing 76 | t bs es eb = 77 | let (as, ab) = flushState bs 78 | in do as `shouldBe` es 79 | ab `shouldBe` eb 80 | it "flushes a simple branch at the top level" $ 81 | forAllUnchecked $ \(hello, world) -> 82 | t 83 | (b (l (Just hello)) (l (Just world))) 84 | (b d d) 85 | (BufReady [hello, world]) 86 | it 87 | "flushes and prunes the left side of a branch if the right side is unknown" $ 88 | forAllUnchecked $ \msg -> 89 | t (b (l (Just msg)) u) (b d u) (BufReady [msg]) 90 | it 91 | "does not flush the right side of a branch if the left side is unknown" $ 92 | forAllUnchecked $ \msg -> 93 | let s = b u (l (Just msg)) 94 | in t s s BufNotReady 95 | it "flushes a branch with two leaves" $ 96 | forAllUnchecked $ \(hello, world) -> 97 | t 98 | (b (l (Just hello)) (l (Just world))) 99 | (b d d) 100 | (BufReady [hello, world]) 101 | it 102 | "flushes the entire state when the left side is done and the right side is one level deep" $ 103 | forAllUnchecked $ \(hello, world) -> 104 | t 105 | (b ln (b (l (Just hello)) (l (Just world)))) 106 | (b d (b d d)) 107 | (BufReady [hello, world]) 108 | it 109 | "flushes the entire state when the left side is done and the right side is two levels deep" $ 110 | forAllUnchecked $ \(hello, big, beautiful, world) -> 111 | t 112 | (b (l Nothing) 113 | (b (b (l (Just hello)) (l (Just big))) 114 | (b (l (Just beautiful)) (l (Just world))))) 115 | (b d (b (b d d) (b d d))) 116 | (BufReady [hello, big, beautiful, world]) 117 | it 118 | "flushes the entire left half of a complete binary tree of size two if the entire left part is done" $ 119 | forAllUnchecked $ \(hello, world) -> 120 | t 121 | (b (b (l (Just hello)) (l (Just world))) (b u u)) 122 | (b (b d d) (b u u)) 123 | (BufReady [hello, world]) 124 | it 125 | "flushes the correct part of the right half of the state when the left part is done and the right side isn't" $ 126 | forAllUnchecked $ \(hello, world) -> 127 | t 128 | (b (l (Just hello)) (b (l (Just world)) u)) 129 | (b d (b d u)) 130 | (BufReady [hello, world]) 131 | it 132 | "flushes and the entire left half of a complete binary tree of size two if the entire left part is done" $ 133 | forAllUnchecked $ \(hello, beautiful, world) -> 134 | t 135 | (b (b (l (Just hello)) (l (Just beautiful))) 136 | (b (l (Just world)) u)) 137 | (b (b d d) (b d u)) 138 | (BufReady [hello, beautiful, world]) 139 | it "flushes the entire tree for any done tree" $ 140 | forAll doneTree $ \st -> 141 | let (s', _) = flushState st 142 | in s' `shouldBe` makeForceFlushed st 143 | it "flushes the entire left tree for any tree whose left part is done" $ 144 | forAllShrink doneTree (map makeForceFlushed . shrinkUnchecked) $ \dt -> 145 | forAllUnchecked $ \ut -> 146 | let s = b dt ut 147 | (rs', b2) = flushState ut 148 | in t s 149 | (b (makeForceFlushed dt) rs') 150 | (flushStateAll dt <> b2) 151 | it "can only grow the depth of the state" $ 152 | forAll 153 | (genUnchecked `suchThat` 154 | (\(st, token) -> isJust $ processToken st token)) $ \(st, token) -> 155 | case processToken st token of 156 | Nothing -> pure () -- fine 157 | Just (t', _) -> depth t' `shouldSatisfy` (>= depth st) 158 | 159 | depth :: LinearState -> Int 160 | depth LinearUnknown = 1 161 | depth LinearDone = 1 162 | depth (LinearLeaf _) = 1 163 | depth (LinearBranch t1 t2) = max (depth t1) (depth t2) 164 | 165 | doneTree :: Gen LinearState 166 | doneTree = 167 | sized $ \s -> 168 | oneof 169 | [ LinearLeaf <$> genUnchecked 170 | , pure LinearDone 171 | , do (ls, rs) <- genSplit s 172 | LinearBranch <$> resize ls doneTree <*> resize rs doneTree 173 | ] 174 | 175 | makeForceFlushed :: LinearState -> LinearState 176 | makeForceFlushed LinearUnknown = LinearUnknown 177 | makeForceFlushed LinearDone = LinearDone 178 | makeForceFlushed (LinearLeaf _) = LinearDone 179 | makeForceFlushed (LinearBranch s1 s2) = 180 | LinearBranch (makeForceFlushed s1) (makeForceFlushed s2) 181 | 182 | outputShouldBe :: Zift () -> [ZiftToken] -> Expectation 183 | outputShouldBe func ls = outputShouldSatisfy func (== ls) 184 | 185 | outputShouldSatisfy :: Zift () -> ([ZiftToken] -> Bool) -> Expectation 186 | outputShouldSatisfy func predicate = do 187 | rd <- resolveDir' "/tmp/zifter" 188 | td <- resolveDir rd ".zifter" 189 | pchan <- newTChanIO 190 | let ctx = 191 | ZiftContext 192 | { rootdir = rd 193 | , tmpdir = td 194 | , settings = 195 | Settings 196 | {setsOutputColor = False, setsOutputMode = OutputFast} 197 | , printChan = pchan 198 | , recursionList = [] 199 | } 200 | fmvar <- newEmptyTMVarIO 201 | ec <- ziftRunner ctx fmvar func 202 | ec `shouldBe` ZiftSuccess () 203 | atomically (takeTMVar fmvar) `shouldReturn` () 204 | outs <- readAllFrom pchan 205 | outs `shouldSatisfy` predicate 206 | 207 | readAllFrom :: TChan a -> IO [a] 208 | readAllFrom chan = do 209 | mr <- atomically $ tryReadTChan chan 210 | case mr of 211 | Nothing -> pure [] 212 | Just r -> do 213 | rest <- readAllFrom chan 214 | pure (r : rest) 215 | -------------------------------------------------------------------------------- /zifter/src/Zifter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | 7 | -- | The main 'Zifter' module. 8 | -- 9 | -- In most cases this should be the only module you import to start writing a 10 | -- @zift.hs@ script. You will most likely want to import the appropriate 11 | -- modules from the 'zifter-*' companion packages. 12 | module Zifter 13 | ( ziftWith 14 | , ziftWithSetup 15 | -- * Defining your own zift scripts 16 | , preprocessor 17 | , prechecker 18 | , checker 19 | , ziftP 20 | , mapZ 21 | , mapZ_ 22 | , forZ 23 | , forZ_ 24 | , recursiveZift 25 | , ZiftScript 26 | , renderZiftSetup 27 | -- * Defining your own zift actions 28 | , Zift 29 | , getRootDir 30 | , getTmpDir 31 | , getSettings 32 | , getSetting 33 | , Settings(..) 34 | -- ** Console outputs of a zift action 35 | -- 36 | -- | Because 'Zift' actions are automatically parallelised, it is important 37 | -- that they do not arbitrarily output data to the console. 38 | -- Instead, you should use these functions to output to the console. 39 | -- 40 | -- The 'ziftWith' and 'ziftWithSetup' functions will take care of ensuring 41 | -- that the output appears linear. 42 | , printZift 43 | , printZiftMessage 44 | , printPreprocessingDone 45 | , printPreprocessingError 46 | , printWithColors 47 | -- * Utilities 48 | -- 49 | -- | You will most likely not need these 50 | , runZiftAuto 51 | , runZift 52 | , ziftRunner 53 | , outputPrinter 54 | , LinearState(..) -- TODO Split this into an other module 55 | , prettyToken 56 | , prettyState 57 | , processToken 58 | , addState 59 | , flushState 60 | , Buf(..) 61 | , pruneState 62 | , flushStateAll 63 | ) where 64 | 65 | import Control.Concurrent.Async 66 | import Control.Concurrent.STM 67 | import Control.Exception (SomeException, catch, displayException) 68 | import Control.Monad 69 | import Data.Maybe 70 | import Data.Monoid 71 | import GHC.Generics (Generic) 72 | import Path 73 | import Path.IO 74 | import Safe 75 | import System.Console.ANSI 76 | import qualified System.Directory as D 77 | (canonicalizePath, getPermissions, setOwnerExecutable, 78 | setPermissions) 79 | import System.Environment (getProgName) 80 | import System.Exit 81 | import qualified System.FilePath as FP (joinPath, splitPath) 82 | import System.IO 83 | (BufferMode(NoBuffering), hFlush, hSetBuffering, stderr, stdout) 84 | 85 | import Zifter.OptParse 86 | import Zifter.Recurse 87 | import Zifter.Script 88 | import Zifter.Setup 89 | import Zifter.Zift 90 | 91 | -- | Run a 'ZiftScript' to create the 'ZiftSetup', and then use 'ziftWithSetup' 92 | -- 93 | -- > ziftWith = renderZiftSetup >=> ziftWithSetup 94 | ziftWith :: ZiftScript () -> IO () 95 | ziftWith = renderZiftSetup >=> ziftWithSetup 96 | 97 | -- | Build a zifter using a 'ZiftSetup'. 98 | -- 99 | -- A zifter has the capabilities that you would expect from a 'zift.hs' file: 100 | -- 101 | -- * @zift.hs run@: Run the @zift.hs@ script as a pre-commit hook. 102 | -- * @zift.hs preprocess@: Run the preprocessor 103 | -- * @zift.hs precheck@: Run the prechecker 104 | -- * @zift.hs check@: Run the checker 105 | -- * @zift.hs install@: Install the @zift.hs@ script as a pre-commit hook. 106 | ziftWithSetup :: ZiftSetup -> IO () 107 | ziftWithSetup setup = do 108 | hSetBuffering stdout NoBuffering 109 | hSetBuffering stderr NoBuffering 110 | (d, sets) <- getInstructions 111 | case d of 112 | DispatchRun -> run setup sets 113 | DispatchPreProcess -> runPreProcessor setup sets 114 | DispatchPreCheck -> runPreChecker setup sets 115 | DispatchCheck -> runChecker setup sets 116 | DispatchInstall r -> install r sets 117 | 118 | run :: ZiftSetup -> Settings -> IO () 119 | run ZiftSetup {..} = 120 | runZiftAuto $ \_ -> do 121 | runAsPreProcessor ziftPreprocessor 122 | runAsPreChecker ziftPreChecker 123 | runAsChecker ziftChecker 124 | 125 | runPreProcessor :: ZiftSetup -> Settings -> IO () 126 | runPreProcessor ZiftSetup {..} = 127 | runZiftAuto $ \_ -> runAsPreProcessor ziftPreprocessor 128 | 129 | runPreChecker :: ZiftSetup -> Settings -> IO () 130 | runPreChecker ZiftSetup {..} = 131 | runZiftAuto $ \_ -> runAsPreChecker ziftPreChecker 132 | 133 | runChecker :: ZiftSetup -> Settings -> IO () 134 | runChecker ZiftSetup {..} = runZiftAuto $ \_ -> runAsChecker ziftChecker 135 | 136 | runZiftAuto :: (ZiftContext -> Zift ()) -> Settings -> IO () 137 | runZiftAuto func sets = do 138 | rd <- autoRootDir 139 | td <- resolveDir rd ".zifter" 140 | pchan <- newTChanIO 141 | let ctx = 142 | ZiftContext 143 | { rootdir = rd 144 | , tmpdir = td 145 | , settings = sets 146 | , printChan = pchan 147 | , recursionList = [] 148 | } 149 | result <- runZift ctx (func ctx) 150 | code <- 151 | case result of 152 | ZiftFailed err -> do 153 | outputOne (setsOutputColor sets) $ 154 | ZiftOutput [SetColor Foreground Dull Red] err 155 | pure $ ExitFailure 1 156 | ZiftSuccess () -> pure ExitSuccess 157 | exitWith code 158 | 159 | runZift :: ZiftContext -> Zift a -> IO (ZiftResult a) 160 | runZift ctx zfunc = do 161 | fmvar <- atomically newEmptyTMVar 162 | printerAsync <- 163 | async $ 164 | outputPrinter (deriveOutputSets $ settings ctx) (printChan ctx) fmvar 165 | runnerAsync <- async $ ziftRunner ctx fmvar zfunc 166 | result <- wait runnerAsync 167 | wait printerAsync 168 | pure result 169 | 170 | ziftRunner :: ZiftContext -> TMVar () -> Zift a -> IO (ZiftResult a) 171 | ziftRunner ctx fmvar zfunc = 172 | withSystemTempDir "zifter" $ \d -> 173 | withCurrentDir d $ do 174 | r <- interpretZift ctx zfunc 175 | atomically $ putTMVar fmvar () 176 | pure r 177 | 178 | interpretZift :: forall a. ZiftContext -> Zift a -> IO (ZiftResult a) 179 | interpretZift = go 180 | where 181 | sendEmpty :: ZiftContext -> IO () 182 | sendEmpty ctx = 183 | atomically $ 184 | writeTChan (printChan ctx) $ ZiftToken (recursionList ctx) Nothing 185 | go :: forall b. ZiftContext -> Zift b -> IO (ZiftResult b) 186 | go ctx (ZiftPure a) = do 187 | sendEmpty ctx 188 | pure $ pure a 189 | go ctx ZiftCtx = do 190 | sendEmpty ctx 191 | pure $ pure ctx 192 | go ctx (ZiftPrint zo) = do 193 | atomically $ 194 | writeTChan (printChan ctx) $ ZiftToken (recursionList ctx) $ Just zo 195 | pure $ pure () 196 | go ctx (ZiftFail s) = do 197 | sendEmpty ctx 198 | pure $ ZiftFailed s 199 | go ctx (ZiftIO act) = do 200 | sendEmpty ctx 201 | (ZiftSuccess <$> act) `catch` handler 202 | where 203 | handler :: SomeException -> IO (ZiftResult b) 204 | handler ex = pure (ZiftFailed $ displayException ex) 205 | go ctx (ZiftFmap f za) = do 206 | zr <- go ctx za 207 | pure $ f <$> zr 208 | go zc (ZiftApp faf af) = do 209 | afaf <- async $ go (zc {recursionList = L : recursionList zc}) faf 210 | aaf <- async $ go (zc {recursionList = R : recursionList zc}) af 211 | efaa <- waitEither afaf aaf 212 | let complete fa a = pure $ fa <*> a 213 | case efaa of 214 | Left far -> do 215 | r <- 216 | case far of 217 | ZiftFailed s -> do 218 | cancel aaf 219 | pure $ ZiftFailed s 220 | _ -> do 221 | t2 <- wait aaf 222 | complete far t2 223 | pure r 224 | Right ar -> do 225 | r <- 226 | case ar of 227 | ZiftFailed s -> do 228 | cancel afaf 229 | pure $ ZiftFailed s 230 | _ -> do 231 | t1 <- wait afaf 232 | complete t1 ar 233 | pure r 234 | go rd (ZiftBind fa mb) = do 235 | ra <- go (rd {recursionList = L : recursionList rd}) fa 236 | case ra of 237 | ZiftSuccess a -> 238 | go (rd {recursionList = R : recursionList rd}) $ mb a 239 | ZiftFailed e -> pure $ ZiftFailed e 240 | 241 | deriveOutputSets :: Settings -> OutputSets 242 | deriveOutputSets Settings {..} = 243 | OutputSets {outputColor = setsOutputColor, outputMode = setsOutputMode} 244 | 245 | data OutputSets = OutputSets 246 | { outputColor :: Bool 247 | , outputMode :: OutputMode 248 | } deriving (Show, Eq) 249 | 250 | outputPrinter :: OutputSets -> TChan ZiftToken -> TMVar () -> IO () 251 | outputPrinter OutputSets {..} = 252 | (case outputMode of 253 | OutputLinear -> outputLinear 254 | OutputFast -> outputFast) 255 | outputColor 256 | 257 | outputFast :: Bool -> TChan ZiftToken -> TMVar () -> IO () 258 | outputFast color pchan fmvar = 259 | let printer = do 260 | mdone <- 261 | atomically $ 262 | (Left <$> takeTMVar fmvar) `orElse` (Right <$> readTChan pchan) 263 | case mdone of 264 | Left () -> outputAll 265 | Right output -> do 266 | outputOneToken output 267 | printer 268 | in printer 269 | where 270 | outputOneToken :: ZiftToken -> IO () 271 | outputOneToken (ZiftToken _ Nothing) = pure () 272 | outputOneToken (ZiftToken _ (Just zo)) = outputOne color zo 273 | outputAll = do 274 | mout <- atomically $ tryReadTChan pchan 275 | case mout of 276 | Nothing -> pure () 277 | Just output -> do 278 | outputOneToken output 279 | outputAll 280 | 281 | outputLinear :: Bool -> TChan ZiftToken -> TMVar () -> IO () 282 | outputLinear color pchan fmvar = 283 | let printer st = do 284 | mdone <- 285 | atomically $ 286 | (Left <$> takeTMVar fmvar) `orElse` (Right <$> readTChan pchan) 287 | case mdone of 288 | Left () -> outputAll st 289 | Right token -> 290 | case processToken st token of 291 | Nothing -> do 292 | putStrLn $ prettyToken token 293 | putStrLn $ prettyState st 294 | error 295 | "something went horribly wrong, the above should help" 296 | Just (st', buf) -> do 297 | outputBuf buf 298 | printer st' 299 | in printer LinearUnknown 300 | where 301 | outputBuf :: Buf -> IO () 302 | outputBuf BufNotReady = pure () 303 | outputBuf (BufReady os) = mapM_ (outputOne color) os 304 | outputAll st = do 305 | mout <- atomically $ tryReadTChan pchan 306 | case mout of 307 | Nothing -> outputBuf $ flushStateAll st 308 | Just token -> 309 | case processToken st token of 310 | Nothing -> error "something went horribly wrong" 311 | Just (st', buf) -> do 312 | outputBuf buf 313 | outputAll st' 314 | 315 | data LinearState 316 | = LinearUnknown 317 | | LinearLeaf (Maybe ZiftOutput) 318 | | LinearDone 319 | | LinearBranch LinearState 320 | LinearState 321 | deriving (Show, Eq, Generic) 322 | 323 | prettyToken :: ZiftToken -> String 324 | prettyToken (ZiftToken lr _) = concatMap show $ reverse lr 325 | 326 | prettyState :: LinearState -> String 327 | prettyState LinearUnknown = "u" 328 | prettyState LinearDone = "d" 329 | prettyState (LinearLeaf Nothing) = "n" 330 | prettyState (LinearLeaf (Just _)) = "m" 331 | prettyState (LinearBranch l1 l2) = 332 | concat ["(", "b", " ", prettyState l1, " ", prettyState l2, ")"] 333 | 334 | processToken :: LinearState -> ZiftToken -> Maybe (LinearState, Buf) 335 | processToken ls zt = do 336 | ls' <- addState ls zt 337 | let (ls'', buf) = flushState ls' 338 | ls''' = pruneState ls'' 339 | pure (ls''', buf) 340 | 341 | addState :: LinearState -> ZiftToken -> Maybe LinearState 342 | addState s (ZiftToken ls mzo) = go s $ reverse ls -- FIXME this is probably slow 343 | where 344 | u = LinearUnknown 345 | go :: LinearState -> [LR] -> Maybe LinearState 346 | go LinearUnknown (L:rest) = LinearBranch <$> go u rest <*> pure u 347 | go LinearUnknown (R:rest) = LinearBranch u <$> go u rest 348 | go LinearUnknown [] = Just $ LinearLeaf mzo 349 | go (LinearBranch l r) (L:rest) = LinearBranch <$> go l rest <*> pure r 350 | go (LinearBranch l r) (R:rest) = LinearBranch l <$> go r rest 351 | go LinearDone _ = Nothing 352 | go (LinearLeaf _) _ = Nothing 353 | -- error $ unlines ["should never happen (1)", show zt, prettyState s] 354 | go (LinearBranch _ _) [] = Nothing -- error $ "should never happen (2)" ++ show zt 355 | 356 | flushState :: LinearState -> (LinearState, Buf) 357 | flushState = go 358 | where 359 | go LinearUnknown = (LinearUnknown, BufNotReady) 360 | go LinearDone = (LinearDone, BufReady []) 361 | go (LinearLeaf Nothing) = (LinearDone, BufReady []) 362 | go (LinearLeaf (Just zo)) = (LinearDone, BufReady [zo]) 363 | go (LinearBranch ls rs) = 364 | let (ls', lbuf) = go ls 365 | (rs', rbuf) = go rs 366 | in case lbuf of 367 | BufNotReady -> (LinearBranch ls' rs, lbuf) 368 | BufReady _ -> (LinearBranch ls' rs', lbuf <> rbuf) 369 | 370 | data Buf 371 | = BufNotReady 372 | | BufReady [ZiftOutput] 373 | deriving (Show, Eq, Generic) 374 | 375 | instance Monoid Buf where 376 | mempty = BufReady [] 377 | BufNotReady `mappend` _ = BufNotReady 378 | BufReady zos1 `mappend` BufReady zos2 = BufReady $ zos1 ++ zos2 379 | BufReady zos1 `mappend` BufNotReady = BufReady zos1 380 | 381 | pruneState :: LinearState -> LinearState 382 | pruneState LinearDone = LinearDone 383 | pruneState (LinearLeaf Nothing) = LinearDone 384 | pruneState (LinearLeaf mzo) = LinearLeaf mzo 385 | pruneState LinearUnknown = LinearUnknown 386 | pruneState (LinearBranch ls rs) = 387 | case (pruneState ls, pruneState rs) of 388 | (LinearDone, LinearDone) -> LinearDone 389 | (ls', rs') -> LinearBranch ls' rs' 390 | 391 | flushStateAll :: LinearState -> Buf 392 | flushStateAll LinearUnknown = mempty 393 | flushStateAll LinearDone = mempty 394 | flushStateAll (LinearLeaf mzo) = BufReady $ maybeToList mzo 395 | flushStateAll (LinearBranch lsl lsr) = flushStateAll lsl <> flushStateAll lsr 396 | 397 | outputOne :: Bool -> ZiftOutput -> IO () 398 | outputOne color (ZiftOutput commands str) = do 399 | when color $ setSGR commands 400 | putStr str 401 | when color $ setSGR [Reset] 402 | putStr "\n" -- Because otherwise it doesn't work? 403 | hFlush stdout 404 | 405 | runAsPreProcessor :: Zift () -> Zift () 406 | runAsPreProcessor func = do 407 | printZiftMessage "PREPROCESSOR STARTING" 408 | func 409 | printZiftMessage "PREPROCESSOR DONE" 410 | 411 | runAsPreChecker :: Zift () -> Zift () 412 | runAsPreChecker func = do 413 | printZiftMessage "PRECHECKER STARTING" 414 | func 415 | printZiftMessage "PRECHECKER DONE" 416 | 417 | runAsChecker :: Zift () -> Zift () 418 | runAsChecker func = do 419 | printZiftMessage "CHECKER STARTING" 420 | func 421 | printZiftMessage "CHECKER DONE" 422 | 423 | autoRootDir :: IO (Path Abs Dir) 424 | autoRootDir = do 425 | pn <- getProgName 426 | here <- getCurrentDir 427 | (_, fs) <- listDir here 428 | unless (pn `elem` map (toFilePath . filename) fs) $ 429 | die $ 430 | unwords 431 | [ pn 432 | , "not found at" 433 | , toFilePath here 434 | , "the zift script must be run in the right directory." 435 | ] 436 | pure here 437 | 438 | install :: Bool -> Settings -> IO () 439 | install recursive sets = do 440 | autoRootDir >>= installIn 441 | if recursive 442 | then flip runZiftAuto sets $ \_ -> 443 | recursively $ \ziftFile -> liftIO $ installIn $ parent ziftFile 444 | else pure () 445 | 446 | installIn :: Path Abs Dir -> IO () 447 | installIn rootdir = do 448 | let gitdir = rootdir dotGitDir 449 | gd <- doesDirExist gitdir 450 | let gitfile = rootdir dotGitFile 451 | gf <- doesFileExist gitfile 452 | ghd <- 453 | case (gd, gf) of 454 | (True, True) -> die "The .git dir is both a file and a directory?" 455 | (False, False) -> 456 | die 457 | "The .git dir is nor a file nor a directory, I don't know what to do." 458 | (True, False) -> pure $ gitdir hooksDir 459 | (False, True) -> do 460 | contents <- readFile $ toFilePath gitfile 461 | case splitAt (length "gitdir: ") contents of 462 | ("gitdir: ", rest) -> 463 | case initMay rest of 464 | Just gitdirref -> do 465 | sp <- 466 | D.canonicalizePath $ 467 | toFilePath rootdir ++ gitdirref 468 | let figureOutDoubleDots = 469 | FP.joinPath . go [] . FP.splitPath 470 | where 471 | go acc [] = reverse acc 472 | go (_:acc) ("../":xs) = go acc xs 473 | go acc (x:xs) = go (x : acc) xs 474 | realgitdir <- 475 | parseAbsDir $ figureOutDoubleDots sp 476 | pure $ realgitdir hooksDir 477 | Nothing -> 478 | die "no gitdir reference found in .git file." 479 | _ -> 480 | die 481 | "Found weird contents of the .git file. It is a file but does not start with 'gitdir: '. I don't know what to do." 482 | let preComitFile = ghd $(mkRelFile "pre-commit") 483 | mc <- forgivingAbsence $ readFile $ toFilePath preComitFile 484 | let hookContents = "./zift.hs run\n" 485 | let justDoIt = do 486 | writeFile (toFilePath preComitFile) hookContents 487 | pcf <- D.getPermissions (toFilePath preComitFile) 488 | D.setPermissions (toFilePath preComitFile) $ 489 | D.setOwnerExecutable True pcf 490 | putStrLn $ 491 | unwords 492 | ["Installed pre-commit script in", toFilePath preComitFile] 493 | case mc of 494 | Nothing -> justDoIt 495 | Just "" -> justDoIt 496 | Just c -> 497 | if c == hookContents 498 | then putStrLn $ 499 | unwords ["Hook already installed for", toFilePath rootdir] 500 | else die $ 501 | unlines 502 | [ "Not installing, a pre-commit hook already exists:" 503 | , show c 504 | ] 505 | 506 | dotGitDir :: Path Rel Dir 507 | dotGitDir = $(mkRelDir ".git") 508 | 509 | dotGitFile :: Path Rel File 510 | dotGitFile = $(mkRelFile ".git") 511 | 512 | hooksDir :: Path Rel Dir 513 | hooksDir = $(mkRelDir "hooks") 514 | --------------------------------------------------------------------------------