diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,138 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + module Main where -import Language.ATS.Exec (exec) +import Control.Arrow +import Control.Monad (unless, (<=<)) +import Data.FileEmbed (embedStringFile) +import qualified Data.HashMap.Lazy as HM +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import qualified Data.Text.IO as TIO +import Data.Version +import Language.ATS +import Options.Applicative +import Paths_ats_format +import System.Directory (doesFileExist) +import System.Exit (exitFailure) +import System.IO (hPutStr, stderr) +import System.Process (readCreateProcess, shell) +import Text.PrettyPrint.ANSI.Leijen (pretty) +import Text.Toml +import Text.Toml.Types hiding (Parser) +data Program = Program { _path :: Maybe FilePath, _inplace :: Bool, _noConfig :: Bool, _defaultConfig :: Bool } + +takeBlock :: String -> (String, String) +takeBlock ('%':'}':ys) = ("", ('%':) . ('}':) $ ys) +takeBlock (y:ys) = first (y:) $ takeBlock ys +takeBlock [] = ([], []) + +rest :: String -> IO String +rest xs = (<> (snd $ takeBlock xs)) <$> printClang (fst $ takeBlock xs) + +printClang :: String -> IO String +printClang = readCreateProcess (shell "clang-format") + +processClang :: String -> IO String +processClang ('%':'{':'^':xs) = ('%':) . ('{':) . ('^':) <$> rest xs +processClang ('%':'{':'#':xs) = ('%':) . ('{':) . ('#':) <$> rest xs +processClang ('%':'{':'$':xs) = ('%':) . ('{':) . ('$':) <$> rest xs +processClang ('%':'{':xs) = ('%':) . ('{':) <$> rest xs +processClang (x:xs) = (x:) <$> processClang xs +processClang [] = pure [] + +file :: Parser Program +file = Program + <$> optional (argument str + (metavar "FILEPATH" + <> completer (bashCompleter "file -X '!*.*ats' -o plusdirs") + <> help "File path to ATS source.")) + <*> switch + (short 'i' + <> help "Modify file in-place") + <*> switch + (long "no-config" + <> short 'o' + <> help "Ignore configuration file") + <*> switch + (long "default-config" + <> help "Generate default configuration file in the current directory") + +versionInfo :: Parser (a -> a) +versionInfo = infoOption ("madlang version: " ++ showVersion version) (short 'V' <> long "version" <> help "Show version") + +wrapper :: ParserInfo Program +wrapper = info (helper <*> versionInfo <*> file) + (fullDesc + <> progDesc "ATS source code formater. For more detailed help, see 'man atsfmt'" + <> header "ats-format - a source code formatter written using happy/alex") + main :: IO () -main = exec +main = execParser wrapper >>= pick + +printFail :: String -> IO a +printFail = const exitFailure <=< hPutStr stderr + +defaultConfig :: FilePath -> IO () +defaultConfig = flip writeFile $(embedStringFile ".atsfmt.toml") + +asFloat :: Node -> Maybe Float +asFloat (VFloat d) = Just (realToFrac d) +asFloat _ = Nothing + +asInt :: Node -> Maybe Int +asInt (VInteger i) = Just (fromIntegral i) +asInt _ = Nothing + +asBool :: Node -> Maybe Bool +asBool (VBoolean True) = Just True +asBool (VBoolean False) = Just False +asBool _ = Nothing + +parseToml :: String -> IO (Float, Int, Bool) +parseToml p = do + f <- TIO.readFile p + case parseTomlDoc p f of + Right x -> pure . fromMaybe (0.6, 120, False) $ do + r <- asFloat =<< HM.lookup "ribbon" x + w <- asInt =<< HM.lookup "width" x + cf <- asBool =<< HM.lookup "clang-format" x + pure (r, w, cf) + Left e -> printFail $ parseErrorPretty e + +printCustom :: ATS -> IO String +printCustom ats = do + let p = ".atsfmt.toml" + config <- doesFileExist p + if config then do + (r, w, cf) <- parseToml p + let t = printATSCustom r w ats + if cf then + processClang t + else + pure t + else + pure $ printATS ats + +genErr :: Bool -> Either (ATSError String) ATS -> IO () +genErr b = either (printFail . show . pretty) (putStrLn <=< go) + where go = if not b then printCustom else pure . printATS + +inplace :: FilePath -> (String -> IO String) -> IO () +inplace p f = do + contents <- readFile p + newContents <- f contents + unless (null newContents) $ + writeFile p newContents + +fancyError :: Either (ATSError String) ATS -> IO ATS +fancyError = either (printFail . show . pretty) pure + +pick :: Program -> IO () +pick (Program (Just p) False nc _) = (genErr nc . parseATS . lexATS) =<< readFile p +pick (Program Nothing _ nc False) = (genErr nc . parseATS . lexATS) =<< getContents +pick (Program Nothing _ _ True) = defaultConfig ".atsfmt.toml" +pick (Program (Just p) True True _) = inplace p (fmap printATS . fancyError . parseATS . lexATS) +pick (Program (Just p) True _ _) = inplace p ((printCustom <=< fancyError) . parseATS . lexATS) diff --git a/ats-format.cabal b/ats-format.cabal --- a/ats-format.cabal +++ b/ats-format.cabal @@ -1,5 +1,5 @@ name: ats-format -version: 0.2.0.15 +version: 0.2.0.17 synopsis: A source-code formatter for ATS description: An opinionated source-code formatter for [ATS](http://www.ats-lang.org/). license: BSD3 @@ -15,7 +15,7 @@ extra-source-files: stack.yaml , .atsfmt.toml , man/atsfmt.1 -cabal-version: >=1.18 +cabal-version: 1.18 custom-setup setup-depends: base @@ -28,14 +28,9 @@ default: False } -Flag library { - Description: Do not build executable - default: False -} - -library - hs-source-dirs: src - exposed-modules: Language.ATS.Exec +executable atsfmt + hs-source-dirs: app + main-is: Main.hs other-modules: Paths_ats_format build-depends: base >= 4.10 && < 5 , language-ats >= 0.1.1.10 @@ -47,20 +42,6 @@ , unordered-containers , process , file-embed - default-language: Haskell2010 - if flag(development) - ghc-options: -Werror - if impl(ghc >= 8.0) - ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates -Wcompat - ghc-options: -Wall - -executable atsfmt - if flag(library) - buildable: False - hs-source-dirs: app - main-is: Main.hs - build-depends: base - , ats-format default-language: Haskell2010 if flag(development) ghc-options: -Werror diff --git a/src/Language/ATS/Exec.hs b/src/Language/ATS/Exec.hs deleted file mode 100644 --- a/src/Language/ATS/Exec.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -module Language.ATS.Exec ( exec - ) where - -import Control.Arrow -import Control.Monad (unless, (<=<)) -import Data.FileEmbed (embedStringFile) -import qualified Data.HashMap.Lazy as HM -import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) -import qualified Data.Text.IO as TIO -import Data.Version -import Language.ATS -import Options.Applicative -import Paths_ats_format -import System.Directory (doesFileExist) -import System.Exit (exitFailure) -import System.IO (hPutStr, stderr) -import System.Process (readCreateProcess, shell) -import Text.PrettyPrint.ANSI.Leijen (pretty) -import Text.Toml -import Text.Toml.Types hiding (Parser) - -data Program = Program { _path :: Maybe FilePath, _inplace :: Bool, _noConfig :: Bool, _defaultConfig :: Bool } - -takeBlock :: String -> (String, String) -takeBlock ('%':'}':ys) = ("", ('%':) . ('}':) $ ys) -takeBlock (y:ys) = first (y:) $ takeBlock ys -takeBlock [] = ([], []) - -rest :: String -> IO String -rest xs = (<> (snd $ takeBlock xs)) <$> printClang (fst $ takeBlock xs) - -printClang :: String -> IO String -printClang = readCreateProcess (shell "clang-format") - -processClang :: String -> IO String -processClang ('%':'{':'^':xs) = ('%':) . ('{':) . ('^':) <$> rest xs -processClang ('%':'{':'#':xs) = ('%':) . ('{':) . ('#':) <$> rest xs -processClang ('%':'{':'$':xs) = ('%':) . ('{':) . ('$':) <$> rest xs -processClang ('%':'{':xs) = ('%':) . ('{':) <$> rest xs -processClang (x:xs) = (x:) <$> processClang xs -processClang [] = pure [] - -file :: Parser Program -file = Program - <$> optional (argument str - (metavar "FILEPATH" - <> completer (bashCompleter "file -X '!*.*ats' -o plusdirs") - <> help "File path to ATS source.")) - <*> switch - (short 'i' - <> help "Modify file in-place") - <*> switch - (long "no-config" - <> short 'o' - <> help "Ignore configuration file") - <*> switch - (long "default-config" - <> help "Generate default configuration file in the current directory") - -versionInfo :: Parser (a -> a) -versionInfo = infoOption ("madlang version: " ++ showVersion version) (short 'V' <> long "version" <> help "Show version") - -wrapper :: ParserInfo Program -wrapper = info (helper <*> versionInfo <*> file) - (fullDesc - <> progDesc "ATS source code formater. For more detailed help, see 'man atsfmt'" - <> header "ats-format - a source code formatter written using happy/alex") - -exec :: IO () -exec = execParser wrapper >>= pick - -printFail :: String -> IO a -printFail = const exitFailure <=< hPutStr stderr - -defaultConfig :: FilePath -> IO () -defaultConfig = flip writeFile $(embedStringFile ".atsfmt.toml") - -asFloat :: Node -> Maybe Float -asFloat (VFloat d) = Just (realToFrac d) -asFloat _ = Nothing - -asInt :: Node -> Maybe Int -asInt (VInteger i) = Just (fromIntegral i) -asInt _ = Nothing - -asBool :: Node -> Maybe Bool -asBool (VBoolean True) = Just True -asBool (VBoolean False) = Just False -asBool _ = Nothing - -parseToml :: String -> IO (Float, Int, Bool) -parseToml p = do - f <- TIO.readFile p - case parseTomlDoc p f of - Right x -> pure . fromMaybe (0.6, 120, False) $ do - r <- asFloat =<< HM.lookup "ribbon" x - w <- asInt =<< HM.lookup "width" x - cf <- asBool =<< HM.lookup "clang-format" x - pure (r, w, cf) - Left e -> printFail $ parseErrorPretty e - -printCustom :: ATS -> IO String -printCustom ats = do - let p = ".atsfmt.toml" - config <- doesFileExist p - if config then do - (r, w, cf) <- parseToml p - let t = printATSCustom r w ats - if cf then - processClang t - else - pure t - else - pure $ printATS ats - -genErr :: Bool -> Either (ATSError String) ATS -> IO () -genErr b = either (printFail . show . pretty) (putStrLn <=< go) - where go = if not b then printCustom else pure . printATS - -inplace :: FilePath -> (String -> IO String) -> IO () -inplace p f = do - contents <- readFile p - newContents <- f contents - unless (null newContents) $ - writeFile p newContents - -fancyError :: Either (ATSError String) ATS -> IO ATS -fancyError = either (printFail . show . pretty) pure - -pick :: Program -> IO () -pick (Program (Just p) False nc _) = (genErr nc . parseATS . lexATS) =<< readFile p -pick (Program Nothing _ nc False) = (genErr nc . parseATS . lexATS) =<< getContents -pick (Program Nothing _ _ True) = defaultConfig ".atsfmt.toml" -pick (Program (Just p) True True _) = inplace p (fmap printATS . fancyError . parseATS . lexATS) -pick (Program (Just p) True _ _) = inplace p ((printCustom <=< fancyError) . parseATS . lexATS) diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -10,7 +10,6 @@ - hspec-dirstream-0.3.0.0 - cli-setup-0.1.0.3 - language-ats-0.2.0.5 - - ats-setup-0.3.0.2 flags: ats-format: development: false