1module Command.Graph (command) where
2
3import Prelude
4
5import           Control.Applicative (many)
6import           Control.Monad (unless, when)
7import qualified Data.Aeson as Json
8import           Data.Bool (bool)
9import qualified Data.ByteString.Lazy as LB
10import qualified Data.ByteString.Lazy.UTF8 as LBU8
11import qualified Language.PureScript as P
12import           Language.PureScript.Errors.JSON
13import qualified Options.Applicative as Opts
14import qualified System.Console.ANSI as ANSI
15import           System.Exit (exitFailure)
16import           System.Directory (getCurrentDirectory)
17import           System.FilePath.Glob (glob)
18import           System.IO (hPutStr, hPutStrLn, stderr)
19
20data GraphOptions = GraphOptions
21  { graphInput      :: [FilePath]
22  , graphJSONErrors :: Bool
23  }
24
25graph :: GraphOptions -> IO ()
26graph GraphOptions{..} = do
27  input <- globWarningOnMisses (unless graphJSONErrors . warnFileTypeNotFound) graphInput
28  when (null input && not graphJSONErrors) $ do
29    hPutStr stderr $ unlines
30      [ "purs graph: No input files."
31      , "Usage: For basic information, try the `--help' option."
32      ]
33    exitFailure
34
35  (makeResult, makeWarnings) <- P.graph input
36
37  printWarningsAndErrors graphJSONErrors makeWarnings makeResult
38    >>= (LB.putStr . Json.encode)
39
40  where
41  warnFileTypeNotFound :: String -> IO ()
42  warnFileTypeNotFound =
43    hPutStrLn stderr . ("purs graph: No files found using pattern: " <>)
44
45
46command :: Opts.Parser (IO ())
47command = graph <$> (Opts.helper <*> graphOptions)
48  where
49  graphOptions :: Opts.Parser GraphOptions
50  graphOptions =
51    GraphOptions <$> many inputFile
52                 <*> jsonErrors
53
54  inputFile :: Opts.Parser FilePath
55  inputFile =
56    Opts.strArgument $
57      Opts.metavar "FILE" <>
58      Opts.help "The input .purs file(s)."
59
60  jsonErrors :: Opts.Parser Bool
61  jsonErrors =
62    Opts.switch $
63      Opts.long "json-errors" <>
64      Opts.help "Print errors to stderr as JSON"
65
66-- | Arguments: use JSON, warnings, errors
67printWarningsAndErrors :: Bool -> P.MultipleErrors -> Either P.MultipleErrors a -> IO a
68printWarningsAndErrors False warnings errors = do
69  pwd <- getCurrentDirectory
70  cc <- bool Nothing (Just P.defaultCodeColor) <$> ANSI.hSupportsANSI stderr
71  let ppeOpts = P.defaultPPEOptions { P.ppeCodeColor = cc, P.ppeFull = True, P.ppeRelativeDirectory = pwd }
72  when (P.nonEmpty warnings) $
73    hPutStrLn stderr (P.prettyPrintMultipleWarnings ppeOpts warnings)
74  case errors of
75    Left errs -> do
76      hPutStrLn stderr (P.prettyPrintMultipleErrors ppeOpts errs)
77      exitFailure
78    Right res -> pure res
79printWarningsAndErrors True warnings errors = do
80  let verbose = True
81  hPutStrLn stderr . LBU8.toString . Json.encode $
82    JSONResult (toJSONErrors verbose P.Warning warnings)
83               (either (toJSONErrors verbose P.Error) (const []) errors)
84  case errors of
85    Left _errs -> exitFailure
86    Right res -> pure res
87
88
89globWarningOnMisses :: (String -> IO ()) -> [FilePath] -> IO [FilePath]
90globWarningOnMisses warn = concatMapM globWithWarning
91  where
92  globWithWarning :: String -> IO [FilePath]
93  globWithWarning pattern' = do
94    paths <- glob pattern'
95    when (null paths) $ warn pattern'
96    return paths
97
98  concatMapM :: (a -> IO [b]) -> [a] -> IO [b]
99  concatMapM f = fmap concat . mapM f
100