-- Copyright (c) Facebook, Inc. and its affiliates.
--
-- This source code is licensed under the MIT license found in the
-- LICENSE file in the root directory of this source tree.
--
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
module Retrie.Options
  ( -- * Options
    Options
  , Options_(..)
  , ExecutionMode(..)
  , defaultOptions
  , parseOptions
    -- * Internal
  , buildGrepChain
  , forFn
  , getOptionsParser
  , getTargetFiles
  , parseRewritesInternal
  , parseVerbosity
  , ProtoOptions
  , resolveOptions
  , GrepCommands(..)
  ) where

import Control.Concurrent.Async (mapConcurrently)
import Control.Monad (when, foldM)
import Data.Bool
import Data.Char (isAlphaNum, isSpace)
import Data.Default as D
import Data.Foldable (toList)
import Data.Functor.Identity
import Data.List
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.Traversable
import Options.Applicative
import System.Directory
import System.FilePath
import System.Process
import System.Random.Shuffle

import Retrie.CPP
import Retrie.Debug
import Retrie.Elaborate
import Retrie.ExactPrint
import Retrie.Fixity
import Retrie.GroundTerms
import Retrie.GHC
import Retrie.Pretty
import Retrie.Rewrites
import Retrie.Types
import Retrie.Universe
import Retrie.Util

-- | Command-line options.
type Options = Options_ [Rewrite Universe] AnnotatedImports

-- | Parse options using the given 'FixityEnv'.
parseOptions :: LibDir -> FixityEnv -> IO Options
parseOptions :: FilePath -> FixityEnv -> IO Options
parseOptions FilePath
libdir FixityEnv
fixityEnv = do
  Parser ProtoOptions
p <- FixityEnv -> IO (Parser ProtoOptions)
getOptionsParser FixityEnv
fixityEnv
  ProtoOptions
opts <- ParserInfo ProtoOptions -> IO ProtoOptions
forall a. ParserInfo a -> IO a
execParser (Parser ProtoOptions
-> InfoMod ProtoOptions -> ParserInfo ProtoOptions
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser ProtoOptions
p Parser ProtoOptions
-> Parser (ProtoOptions -> ProtoOptions) -> Parser ProtoOptions
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (ProtoOptions -> ProtoOptions)
forall a. Parser (a -> a)
helper) InfoMod ProtoOptions
forall a. InfoMod a
fullDesc)
  FilePath -> ProtoOptions -> IO Options
resolveOptions FilePath
libdir ProtoOptions
opts

-- | Create 'Rewrite's from string specifications of rewrites.
-- We expose this from "Retrie" with a nicer type signature as
-- 'Retrie.Options.parseRewrites'. We have it here so we can use it with
-- 'ProtoOptions'.
parseRewritesInternal :: LibDir -> Options_ a b -> [RewriteSpec] -> IO [Rewrite Universe]
parseRewritesInternal :: forall a b.
FilePath
-> Options_ a b
-> [RewriteSpec]
-> IO
     [Query
        Universe
        (Template Universe,
         Context -> MatchResult Universe -> IO (MatchResult Universe))]
parseRewritesInternal FilePath
libdir Options{a
b
Bool
Int
FilePath
[FilePath]
[RoundTrip]
FixityEnv
Verbosity
ExecutionMode
ColoriseFun
additionalImports :: b
colorise :: ColoriseFun
elaborations :: a
executionMode :: ExecutionMode
extraIgnores :: [FilePath]
fixityEnv :: FixityEnv
iterateN :: Int
noDefaultElaborations :: Bool
randomOrder :: Bool
rewrites :: a
roundtrips :: [RoundTrip]
singleThreaded :: Bool
targetDir :: FilePath
targetFiles :: [FilePath]
verbosity :: Verbosity
additionalImports :: forall rewrites imports. Options_ rewrites imports -> imports
colorise :: forall rewrites imports. Options_ rewrites imports -> ColoriseFun
elaborations :: forall rewrites imports. Options_ rewrites imports -> rewrites
executionMode :: forall rewrites imports. Options_ rewrites imports -> ExecutionMode
extraIgnores :: forall rewrites imports. Options_ rewrites imports -> [FilePath]
fixityEnv :: forall rewrites imports. Options_ rewrites imports -> FixityEnv
iterateN :: forall rewrites imports. Options_ rewrites imports -> Int
noDefaultElaborations :: forall rewrites imports. Options_ rewrites imports -> Bool
randomOrder :: forall rewrites imports. Options_ rewrites imports -> Bool
rewrites :: forall rewrites imports. Options_ rewrites imports -> rewrites
roundtrips :: forall rewrites imports. Options_ rewrites imports -> [RoundTrip]
singleThreaded :: forall rewrites imports. Options_ rewrites imports -> Bool
targetDir :: forall rewrites imports. Options_ rewrites imports -> FilePath
targetFiles :: forall rewrites imports. Options_ rewrites imports -> [FilePath]
verbosity :: forall rewrites imports. Options_ rewrites imports -> Verbosity
..} = FilePath
-> (FilePath -> IO (CPP AnnotatedModule))
-> FixityEnv
-> [RewriteSpec]
-> IO
     [Query
        Universe
        (Template Universe,
         Context -> MatchResult Universe -> IO (MatchResult Universe))]
parseRewriteSpecs FilePath
libdir FilePath -> IO (CPP AnnotatedModule)
parser FixityEnv
fixityEnv
  where
    parser :: FilePath -> IO (CPP AnnotatedModule)
parser FilePath
fp = (FilePath -> FilePath -> IO AnnotatedModule)
-> FilePath -> IO (CPP AnnotatedModule)
parseCPPFile (FilePath -> FixityEnv -> FilePath -> FilePath -> IO AnnotatedModule
parseContent FilePath
libdir FixityEnv
fixityEnv) (FilePath
targetDir FilePath -> FilePath -> FilePath
</> FilePath
fp)

-- | Controls the ultimate action taken by 'apply'. The default action is
-- 'ExecRewrite'.
data ExecutionMode
  = ExecDryRun -- ^ Pretend to do rewrites, show diff.
  | ExecRewrite -- ^ Perform rewrites.
  | ExecExtract -- ^ Print the resulting expression for each match.
  | ExecSearch -- ^ Print the matched expressions.
  deriving (Int -> ExecutionMode -> FilePath -> FilePath
[ExecutionMode] -> FilePath -> FilePath
ExecutionMode -> FilePath
(Int -> ExecutionMode -> FilePath -> FilePath)
-> (ExecutionMode -> FilePath)
-> ([ExecutionMode] -> FilePath -> FilePath)
-> Show ExecutionMode
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> ExecutionMode -> FilePath -> FilePath
showsPrec :: Int -> ExecutionMode -> FilePath -> FilePath
$cshow :: ExecutionMode -> FilePath
show :: ExecutionMode -> FilePath
$cshowList :: [ExecutionMode] -> FilePath -> FilePath
showList :: [ExecutionMode] -> FilePath -> FilePath
Show)

data Options_ rewrites imports = Options
  { forall rewrites imports. Options_ rewrites imports -> imports
additionalImports :: imports
    -- ^ Imports specified by the command-line flag '--import'.
  , forall rewrites imports. Options_ rewrites imports -> ColoriseFun
colorise :: ColoriseFun
    -- ^ Function used to colorize results of certain execution modes.
  , forall rewrites imports. Options_ rewrites imports -> rewrites
elaborations :: rewrites
    -- ^ Rewrites which are applied to the left-hand side of the actual rewrites.
  , forall rewrites imports. Options_ rewrites imports -> ExecutionMode
executionMode :: ExecutionMode
    -- ^ Controls behavior of 'apply'. See 'ExecutionMode'.
  , forall rewrites imports. Options_ rewrites imports -> [FilePath]
extraIgnores :: [FilePath]
    -- ^ Specific files that should be ignored. Paths should be relative to
    -- 'targetDir'.
  , forall rewrites imports. Options_ rewrites imports -> FixityEnv
fixityEnv :: FixityEnv
    -- ^ Fixity information for operators used during parsing (of rewrites and
    -- target modules). Defaults to base fixities.
  , forall rewrites imports. Options_ rewrites imports -> Int
iterateN :: Int
    -- ^ Iterate the given rewrites or 'Retrie' computation up to this many
    -- times. Iteration may stop before the limit if no changes are made during
    -- a given iteration.
  , forall rewrites imports. Options_ rewrites imports -> Bool
noDefaultElaborations :: Bool
    -- ^ Do not apply any of the built in elaborations in 'defaultElaborations'.
  , forall rewrites imports. Options_ rewrites imports -> Bool
randomOrder :: Bool
    -- ^ Whether to randomize the order of target modules before rewriting them.
  , forall rewrites imports. Options_ rewrites imports -> rewrites
rewrites :: rewrites
    -- ^ Rewrites specified by command-line flags such as '--adhoc'.
  , forall rewrites imports. Options_ rewrites imports -> [RoundTrip]
roundtrips :: [RoundTrip]
    -- ^ Paths that should be roundtripped through ghc-exactprint to debug.
    -- Specified by the '--roundtrip' command-line flag.
  , forall rewrites imports. Options_ rewrites imports -> Bool
singleThreaded :: Bool
    -- ^ Whether to concurrently rewrite target modules.
    -- Mostly useful for viewing debugging output without interleaving it.
  , forall rewrites imports. Options_ rewrites imports -> FilePath
targetDir :: FilePath
    -- ^ Directory that contains the code being targeted for rewriting.
  , forall rewrites imports. Options_ rewrites imports -> [FilePath]
targetFiles :: [FilePath]
    -- ^ Instead of targeting all Haskell files in 'targetDir', only target
    -- specific files. Paths should be relative to 'targetDir'.
  , forall rewrites imports. Options_ rewrites imports -> Verbosity
verbosity :: Verbosity
    -- ^ How much should be output on 'stdout'.
  }

-- | Construct default options for the given target directory.
defaultOptions
  :: (Default rewrites, Default imports)
  => FilePath -> Options_ rewrites imports
defaultOptions :: forall rewrites imports.
(Default rewrites, Default imports) =>
FilePath -> Options_ rewrites imports
defaultOptions FilePath
fp = Options
  { additionalImports :: imports
additionalImports = imports
forall a. Default a => a
D.def
  , colorise :: ColoriseFun
colorise = ColoriseFun
noColor
  , elaborations :: rewrites
elaborations = rewrites
forall a. Default a => a
D.def
  , executionMode :: ExecutionMode
executionMode = ExecutionMode
ExecRewrite
  , extraIgnores :: [FilePath]
extraIgnores = []
  , fixityEnv :: FixityEnv
fixityEnv = FixityEnv
forall a. Monoid a => a
mempty
  , iterateN :: Int
iterateN = Int
1
  , noDefaultElaborations :: Bool
noDefaultElaborations = Bool
False
  , randomOrder :: Bool
randomOrder = Bool
False
  , rewrites :: rewrites
rewrites = rewrites
forall a. Default a => a
D.def
  , roundtrips :: [RoundTrip]
roundtrips = []
  , singleThreaded :: Bool
singleThreaded = Bool
False
  , targetDir :: FilePath
targetDir = FilePath
fp
  , targetFiles :: [FilePath]
targetFiles = []
  , verbosity :: Verbosity
verbosity = Verbosity
Normal
  }

-- | Get the options parser. The returned 'ProtoOptions' should be passed
-- to 'resolveOptions' to get final 'Options'.
getOptionsParser :: FixityEnv -> IO (Parser ProtoOptions)
getOptionsParser :: FixityEnv -> IO (Parser ProtoOptions)
getOptionsParser FixityEnv
fEnv = do
  ProtoOptions
dOpts <- FilePath -> ProtoOptions
forall rewrites imports.
(Default rewrites, Default imports) =>
FilePath -> Options_ rewrites imports
defaultOptions (FilePath -> ProtoOptions) -> IO FilePath -> IO ProtoOptions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FilePath
getCurrentDirectory
  return $ ProtoOptions -> Parser ProtoOptions
buildParser ProtoOptions
dOpts { fixityEnv = fEnv }

buildParser :: ProtoOptions -> Parser ProtoOptions
buildParser :: ProtoOptions -> Parser ProtoOptions
buildParser ProtoOptions
dOpts = do
  Bool
singleThreaded <- Mod FlagFields Bool -> Parser Bool
switch (Mod FlagFields Bool -> Parser Bool)
-> Mod FlagFields Bool -> Parser Bool
forall a b. (a -> b) -> a -> b
$ [Mod FlagFields Bool] -> Mod FlagFields Bool
forall a. Monoid a => [a] -> a
mconcat
    [ FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"single-threaded"
    , Mod FlagFields Bool
forall a (f :: * -> *). Show a => Mod f a
showDefault
    , FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Don't try to parallelize things (for debugging)."
    ]
  FilePath
targetDir <- ReadM FilePath -> Mod OptionFields FilePath -> Parser FilePath
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM FilePath
forall s. IsString s => ReadM s
str (Mod OptionFields FilePath -> Parser FilePath)
-> Mod OptionFields FilePath -> Parser FilePath
forall a b. (a -> b) -> a -> b
$ [Mod OptionFields FilePath] -> Mod OptionFields FilePath
forall a. Monoid a => [a] -> a
mconcat
    [ FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"target"
    , Char -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
't'
    , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"PATH"
    , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasCompleter f => FilePath -> Mod f a
action FilePath
"directory" -- complete with directory
    , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value (ProtoOptions -> FilePath
forall rewrites imports. Options_ rewrites imports -> FilePath
targetDir ProtoOptions
dOpts)
    , Mod OptionFields FilePath
forall a (f :: * -> *). Show a => Mod f a
showDefault
    , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Path to target with rewrites."
    ]
  [FilePath]
targetFiles <- Parser FilePath -> Parser [FilePath]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser FilePath -> Parser [FilePath])
-> Parser FilePath -> Parser [FilePath]
forall a b. (a -> b) -> a -> b
$ ReadM FilePath -> Mod OptionFields FilePath -> Parser FilePath
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM FilePath
forall s. IsString s => ReadM s
str (Mod OptionFields FilePath -> Parser FilePath)
-> Mod OptionFields FilePath -> Parser FilePath
forall a b. (a -> b) -> a -> b
$ [Mod OptionFields FilePath] -> Mod OptionFields FilePath
forall a. Monoid a => [a] -> a
mconcat
    [ FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"target-file"
    , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"PATH"
    , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasCompleter f => FilePath -> Mod f a
action FilePath
"file" -- complete with filenames
    , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Target specific file for rewriting."
    ]
  Verbosity
verbosity <- Verbosity -> Parser Verbosity
parseVerbosity (ProtoOptions -> Verbosity
forall rewrites imports. Options_ rewrites imports -> Verbosity
verbosity ProtoOptions
dOpts)
  [FilePath]
additionalImports <- Parser FilePath -> Parser [FilePath]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser FilePath -> Parser [FilePath])
-> Parser FilePath -> Parser [FilePath]
forall a b. (a -> b) -> a -> b
$ ReadM FilePath -> Mod OptionFields FilePath -> Parser FilePath
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM FilePath
forall s. IsString s => ReadM s
str (Mod OptionFields FilePath -> Parser FilePath)
-> Mod OptionFields FilePath -> Parser FilePath
forall a b. (a -> b) -> a -> b
$ [Mod OptionFields FilePath] -> Mod OptionFields FilePath
forall a. Monoid a => [a] -> a
mconcat
    [ FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"import"
    , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"IMPORT"
    , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help
        FilePath
"Add given import statement to modules that are modified by a rewrite."
    ]
  [FilePath]
extraIgnores <- Parser FilePath -> Parser [FilePath]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser FilePath -> Parser [FilePath])
-> Parser FilePath -> Parser [FilePath]
forall a b. (a -> b) -> a -> b
$ ReadM FilePath -> Mod OptionFields FilePath -> Parser FilePath
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM FilePath
forall s. IsString s => ReadM s
str (Mod OptionFields FilePath -> Parser FilePath)
-> Mod OptionFields FilePath -> Parser FilePath
forall a b. (a -> b) -> a -> b
$ [Mod OptionFields FilePath] -> Mod OptionFields FilePath
forall a. Monoid a => [a] -> a
mconcat
    [ FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"ignore"
    , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"PATH"
    , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasCompleter f => FilePath -> Mod f a
action FilePath
"file" -- complete with filenames
    , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Ignore specific file while rewriting."
    ]
  ColoriseFun
colorise <- (Bool -> ColoriseFun) -> Parser Bool -> Parser ColoriseFun
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ColoriseFun -> ColoriseFun -> Bool -> ColoriseFun
forall a. a -> a -> Bool -> a
bool ColoriseFun
noColor ColoriseFun
addColor) (Parser Bool -> Parser ColoriseFun)
-> Parser Bool -> Parser ColoriseFun
forall a b. (a -> b) -> a -> b
$ Mod FlagFields Bool -> Parser Bool
switch (Mod FlagFields Bool -> Parser Bool)
-> Mod FlagFields Bool -> Parser Bool
forall a b. (a -> b) -> a -> b
$ [Mod FlagFields Bool] -> Mod FlagFields Bool
forall a. Monoid a => [a] -> a
mconcat
    [ FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"color"
    , FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Highlight matches with color."
    ]
  Bool
noDefaultElaborations <- Mod FlagFields Bool -> Parser Bool
switch (Mod FlagFields Bool -> Parser Bool)
-> Mod FlagFields Bool -> Parser Bool
forall a b. (a -> b) -> a -> b
$ [Mod FlagFields Bool] -> Mod FlagFields Bool
forall a. Monoid a => [a] -> a
mconcat
    [ FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"no-default-elaborations"
    , Mod FlagFields Bool
forall a (f :: * -> *). Show a => Mod f a
showDefault
    , FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Don't apply any of the default elaborations to rewrites."
    ]
  Bool
randomOrder <- Mod FlagFields Bool -> Parser Bool
switch (Mod FlagFields Bool -> Parser Bool)
-> Mod FlagFields Bool -> Parser Bool
forall a b. (a -> b) -> a -> b
$ [Mod FlagFields Bool] -> Mod FlagFields Bool
forall a. Monoid a => [a] -> a
mconcat
    [ FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"random-order"
    , FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Randomize the order of targeted modules."
    ]
  Int
iterateN <- ReadM Int -> Mod OptionFields Int -> Parser Int
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Int
forall a. Read a => ReadM a
auto (Mod OptionFields Int -> Parser Int)
-> Mod OptionFields Int -> Parser Int
forall a b. (a -> b) -> a -> b
$ [Mod OptionFields Int] -> Mod OptionFields Int
forall a. Monoid a => [a] -> a
mconcat
    [ FilePath -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"iterate"
    , Char -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'i'
    , FilePath -> Mod OptionFields Int
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"N"
    , Int -> Mod OptionFields Int
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Int
1
    , FilePath -> Mod OptionFields Int
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Iterate rewrites up to N times."
    ]

  ExecutionMode
executionMode <- Parser ExecutionMode
parseMode
  [RewriteSpec]
rewrites <- Parser [RewriteSpec]
parseRewriteSpecOptions
  [RewriteSpec]
elaborations <- Parser [RewriteSpec]
parseElaborations
  [RoundTrip]
roundtrips <- Parser [RoundTrip]
parseRoundtrips
  return Options{ fixityEnv :: FixityEnv
fixityEnv = ProtoOptions -> FixityEnv
forall rewrites imports. Options_ rewrites imports -> FixityEnv
fixityEnv ProtoOptions
dOpts, Bool
Int
FilePath
[FilePath]
[RewriteSpec]
[RoundTrip]
Verbosity
ExecutionMode
ColoriseFun
additionalImports :: [FilePath]
colorise :: ColoriseFun
elaborations :: [RewriteSpec]
executionMode :: ExecutionMode
extraIgnores :: [FilePath]
iterateN :: Int
noDefaultElaborations :: Bool
randomOrder :: Bool
rewrites :: [RewriteSpec]
roundtrips :: [RoundTrip]
singleThreaded :: Bool
targetDir :: FilePath
targetFiles :: [FilePath]
verbosity :: Verbosity
singleThreaded :: Bool
targetDir :: FilePath
targetFiles :: [FilePath]
verbosity :: Verbosity
additionalImports :: [FilePath]
extraIgnores :: [FilePath]
colorise :: ColoriseFun
noDefaultElaborations :: Bool
randomOrder :: Bool
iterateN :: Int
executionMode :: ExecutionMode
rewrites :: [RewriteSpec]
elaborations :: [RewriteSpec]
roundtrips :: [RoundTrip]
..}

parseElaborations :: Parser [RewriteSpec]
parseElaborations :: Parser [RewriteSpec]
parseElaborations = [[RewriteSpec]] -> [RewriteSpec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[RewriteSpec]] -> [RewriteSpec])
-> Parser [[RewriteSpec]] -> Parser [RewriteSpec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser RewriteSpec -> Parser [RewriteSpec])
-> [Parser RewriteSpec] -> Parser [[RewriteSpec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Parser RewriteSpec -> Parser [RewriteSpec]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many
  [ (FilePath -> RewriteSpec) -> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> RewriteSpec
Adhoc (Parser FilePath -> Parser RewriteSpec)
-> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> a -> b
$ ReadM FilePath -> Mod OptionFields FilePath -> Parser FilePath
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM FilePath
forall s. IsString s => ReadM s
str (Mod OptionFields FilePath -> Parser FilePath)
-> Mod OptionFields FilePath -> Parser FilePath
forall a b. (a -> b) -> a -> b
$ [Mod OptionFields FilePath] -> Mod OptionFields FilePath
forall a. Monoid a => [a] -> a
mconcat
    [ FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"elaborate"
    , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"EQUATION"
    , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Elaborate the left-hand side of rewrites using the given equation."
    ]
  , (FilePath -> RewriteSpec) -> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> RewriteSpec
AdhocType (Parser FilePath -> Parser RewriteSpec)
-> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> a -> b
$ ReadM FilePath -> Mod OptionFields FilePath -> Parser FilePath
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM FilePath
forall s. IsString s => ReadM s
str (Mod OptionFields FilePath -> Parser FilePath)
-> Mod OptionFields FilePath -> Parser FilePath
forall a b. (a -> b) -> a -> b
$ [Mod OptionFields FilePath] -> Mod OptionFields FilePath
forall a. Monoid a => [a] -> a
mconcat
    [ FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"elaborate-type"
    , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"EQUATION"
    , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Elaborate the left-hand side of rewrites using the given equation."
    ]
  , (FilePath -> RewriteSpec) -> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> RewriteSpec
AdhocPattern (Parser FilePath -> Parser RewriteSpec)
-> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> a -> b
$ ReadM FilePath -> Mod OptionFields FilePath -> Parser FilePath
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM FilePath
forall s. IsString s => ReadM s
str (Mod OptionFields FilePath -> Parser FilePath)
-> Mod OptionFields FilePath -> Parser FilePath
forall a b. (a -> b) -> a -> b
$ [Mod OptionFields FilePath] -> Mod OptionFields FilePath
forall a. Monoid a => [a] -> a
mconcat
    [ FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"elaborate-pattern"
    , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"EQUATION"
    , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Elaborate the left-hand side of rewrites using the given equation."
    ]
  ]

parseRewriteSpecOptions :: Parser [RewriteSpec]
parseRewriteSpecOptions :: Parser [RewriteSpec]
parseRewriteSpecOptions = [[RewriteSpec]] -> [RewriteSpec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[RewriteSpec]] -> [RewriteSpec])
-> Parser [[RewriteSpec]] -> Parser [RewriteSpec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser RewriteSpec -> Parser [RewriteSpec])
-> [Parser RewriteSpec] -> Parser [[RewriteSpec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Parser RewriteSpec -> Parser [RewriteSpec]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many
  [ (FilePath -> RewriteSpec) -> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> RewriteSpec
Unfold (Parser FilePath -> Parser RewriteSpec)
-> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> a -> b
$ ReadM FilePath -> Mod OptionFields FilePath -> Parser FilePath
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM FilePath
forall s. IsString s => ReadM s
str (Mod OptionFields FilePath -> Parser FilePath)
-> Mod OptionFields FilePath -> Parser FilePath
forall a b. (a -> b) -> a -> b
$ [Mod OptionFields FilePath] -> Mod OptionFields FilePath
forall a. Monoid a => [a] -> a
mconcat
      [ FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"unfold"
      , Char -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'u'
      , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"NAME"
      , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Unfold given fully-qualified name."
      ]
  , (FilePath -> RewriteSpec) -> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> RewriteSpec
Fold (Parser FilePath -> Parser RewriteSpec)
-> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> a -> b
$ ReadM FilePath -> Mod OptionFields FilePath -> Parser FilePath
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM FilePath
forall s. IsString s => ReadM s
str (Mod OptionFields FilePath -> Parser FilePath)
-> Mod OptionFields FilePath -> Parser FilePath
forall a b. (a -> b) -> a -> b
$ [Mod OptionFields FilePath] -> Mod OptionFields FilePath
forall a. Monoid a => [a] -> a
mconcat
      [ FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"fold"
      , Char -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'f'
      , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"NAME"
      , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Fold given fully-qualified name."
      ]
  , (FilePath -> RewriteSpec) -> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> RewriteSpec
RuleForward (Parser FilePath -> Parser RewriteSpec)
-> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> a -> b
$ ReadM FilePath -> Mod OptionFields FilePath -> Parser FilePath
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM FilePath
forall s. IsString s => ReadM s
str (Mod OptionFields FilePath -> Parser FilePath)
-> Mod OptionFields FilePath -> Parser FilePath
forall a b. (a -> b) -> a -> b
$ [Mod OptionFields FilePath] -> Mod OptionFields FilePath
forall a. Monoid a => [a] -> a
mconcat
      [ FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"rule-forward"
      , Char -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'l'
      , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"NAME"
      , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Apply fully-qualified RULE name left-to-right."
      ]
  , (FilePath -> RewriteSpec) -> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> RewriteSpec
RuleBackward (Parser FilePath -> Parser RewriteSpec)
-> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> a -> b
$ ReadM FilePath -> Mod OptionFields FilePath -> Parser FilePath
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM FilePath
forall s. IsString s => ReadM s
str (Mod OptionFields FilePath -> Parser FilePath)
-> Mod OptionFields FilePath -> Parser FilePath
forall a b. (a -> b) -> a -> b
$ [Mod OptionFields FilePath] -> Mod OptionFields FilePath
forall a. Monoid a => [a] -> a
mconcat
      [ FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"rule-backward"
      , Char -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'r'
      , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"NAME"
      , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Apply fully-qualified RULE name right-to-left."
      ]
  , (FilePath -> RewriteSpec) -> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> RewriteSpec
TypeForward (Parser FilePath -> Parser RewriteSpec)
-> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> a -> b
$ ReadM FilePath -> Mod OptionFields FilePath -> Parser FilePath
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM FilePath
forall s. IsString s => ReadM s
str (Mod OptionFields FilePath -> Parser FilePath)
-> Mod OptionFields FilePath -> Parser FilePath
forall a b. (a -> b) -> a -> b
$ [Mod OptionFields FilePath] -> Mod OptionFields FilePath
forall a. Monoid a => [a] -> a
mconcat
      [ FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"type-forward"
      , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"NAME"
      , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Apply fully-qualified type synonym name left-to-right."
      ]
  , (FilePath -> RewriteSpec) -> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> RewriteSpec
TypeBackward (Parser FilePath -> Parser RewriteSpec)
-> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> a -> b
$ ReadM FilePath -> Mod OptionFields FilePath -> Parser FilePath
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM FilePath
forall s. IsString s => ReadM s
str (Mod OptionFields FilePath -> Parser FilePath)
-> Mod OptionFields FilePath -> Parser FilePath
forall a b. (a -> b) -> a -> b
$ [Mod OptionFields FilePath] -> Mod OptionFields FilePath
forall a. Monoid a => [a] -> a
mconcat
      [ FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"type-backward"
      , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"NAME"
      , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Apply fully-qualified type synonym name right-to-left."
      ]
  , (FilePath -> RewriteSpec) -> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> RewriteSpec
Adhoc (Parser FilePath -> Parser RewriteSpec)
-> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> a -> b
$ ReadM FilePath -> Mod OptionFields FilePath -> Parser FilePath
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM FilePath
forall s. IsString s => ReadM s
str (Mod OptionFields FilePath -> Parser FilePath)
-> Mod OptionFields FilePath -> Parser FilePath
forall a b. (a -> b) -> a -> b
$ [Mod OptionFields FilePath] -> Mod OptionFields FilePath
forall a. Monoid a => [a] -> a
mconcat
      [ FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"adhoc"
      , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"EQUATION"
      , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Apply an adhoc equation of the form: forall vs. lhs = rhs"
      ]
  , (FilePath -> RewriteSpec) -> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> RewriteSpec
AdhocType (Parser FilePath -> Parser RewriteSpec)
-> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> a -> b
$ ReadM FilePath -> Mod OptionFields FilePath -> Parser FilePath
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM FilePath
forall s. IsString s => ReadM s
str (Mod OptionFields FilePath -> Parser FilePath)
-> Mod OptionFields FilePath -> Parser FilePath
forall a b. (a -> b) -> a -> b
$ [Mod OptionFields FilePath] -> Mod OptionFields FilePath
forall a. Monoid a => [a] -> a
mconcat
      [ FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"adhoc-type"
      , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"EQUATION"
      , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Apply an adhoc type equation of the form: lhs = rhs"
      ]
  , (FilePath -> RewriteSpec) -> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> RewriteSpec
PatternForward (Parser FilePath -> Parser RewriteSpec)
-> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> a -> b
$ ReadM FilePath -> Mod OptionFields FilePath -> Parser FilePath
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM FilePath
forall s. IsString s => ReadM s
str (Mod OptionFields FilePath -> Parser FilePath)
-> Mod OptionFields FilePath -> Parser FilePath
forall a b. (a -> b) -> a -> b
$ [Mod OptionFields FilePath] -> Mod OptionFields FilePath
forall a. Monoid a => [a] -> a
mconcat
      [ FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"pattern-forward"
      , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"NAME"
      , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Apply fully-qualified pattern synonym name left-to-right."
      ]
  , (FilePath -> RewriteSpec) -> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> RewriteSpec
PatternBackward (Parser FilePath -> Parser RewriteSpec)
-> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> a -> b
$ ReadM FilePath -> Mod OptionFields FilePath -> Parser FilePath
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM FilePath
forall s. IsString s => ReadM s
str (Mod OptionFields FilePath -> Parser FilePath)
-> Mod OptionFields FilePath -> Parser FilePath
forall a b. (a -> b) -> a -> b
$ [Mod OptionFields FilePath] -> Mod OptionFields FilePath
forall a. Monoid a => [a] -> a
mconcat
      [ FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"pattern-backward"
      , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"NAME"
      , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Apply fully-qualified pattern synonym name right-to-left."
      ]
  , (FilePath -> RewriteSpec) -> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> RewriteSpec
AdhocPattern (Parser FilePath -> Parser RewriteSpec)
-> Parser FilePath -> Parser RewriteSpec
forall a b. (a -> b) -> a -> b
$ ReadM FilePath -> Mod OptionFields FilePath -> Parser FilePath
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM FilePath
forall s. IsString s => ReadM s
str (Mod OptionFields FilePath -> Parser FilePath)
-> Mod OptionFields FilePath -> Parser FilePath
forall a b. (a -> b) -> a -> b
$ [Mod OptionFields FilePath] -> Mod OptionFields FilePath
forall a. Monoid a => [a] -> a
mconcat
      [ FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"adhoc-pattern"
      , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"EQUATION"
      , FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Apply an adhoc pattern equation of the form: lhs = rhs"
      ]
  ]

parseMode :: Parser ExecutionMode
parseMode :: Parser ExecutionMode
parseMode =
  Parser ExecutionMode
parseDryRun Parser ExecutionMode
-> Parser ExecutionMode -> Parser ExecutionMode
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  Parser ExecutionMode
parseExtract Parser ExecutionMode
-> Parser ExecutionMode -> Parser ExecutionMode
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  Parser ExecutionMode
parseSearch Parser ExecutionMode
-> Parser ExecutionMode -> Parser ExecutionMode
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  ExecutionMode -> Parser ExecutionMode
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExecutionMode
ExecRewrite

parseDryRun :: Parser ExecutionMode
parseDryRun :: Parser ExecutionMode
parseDryRun = ExecutionMode
-> Mod FlagFields ExecutionMode -> Parser ExecutionMode
forall a. a -> Mod FlagFields a -> Parser a
flag' ExecutionMode
ExecDryRun (Mod FlagFields ExecutionMode -> Parser ExecutionMode)
-> Mod FlagFields ExecutionMode -> Parser ExecutionMode
forall a b. (a -> b) -> a -> b
$ [Mod FlagFields ExecutionMode] -> Mod FlagFields ExecutionMode
forall a. Monoid a => [a] -> a
mconcat
  [ FilePath -> Mod FlagFields ExecutionMode
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"dry-run"
  , FilePath -> Mod FlagFields ExecutionMode
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Don't overwrite files. Print rewrite results."
  ]

parseExtract :: Parser ExecutionMode
parseExtract :: Parser ExecutionMode
parseExtract = ExecutionMode
-> Mod FlagFields ExecutionMode -> Parser ExecutionMode
forall a. a -> Mod FlagFields a -> Parser a
flag' ExecutionMode
ExecExtract (Mod FlagFields ExecutionMode -> Parser ExecutionMode)
-> Mod FlagFields ExecutionMode -> Parser ExecutionMode
forall a b. (a -> b) -> a -> b
$ [Mod FlagFields ExecutionMode] -> Mod FlagFields ExecutionMode
forall a. Monoid a => [a] -> a
mconcat
  [ FilePath -> Mod FlagFields ExecutionMode
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"extract"
  , FilePath -> Mod FlagFields ExecutionMode
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Find the left-hand side, display the instantiated right-hand side."
  ]

parseSearch :: Parser ExecutionMode
parseSearch :: Parser ExecutionMode
parseSearch = ExecutionMode
-> Mod FlagFields ExecutionMode -> Parser ExecutionMode
forall a. a -> Mod FlagFields a -> Parser a
flag' ExecutionMode
ExecSearch (Mod FlagFields ExecutionMode -> Parser ExecutionMode)
-> Mod FlagFields ExecutionMode -> Parser ExecutionMode
forall a b. (a -> b) -> a -> b
$ [Mod FlagFields ExecutionMode] -> Mod FlagFields ExecutionMode
forall a. Monoid a => [a] -> a
mconcat
  [ FilePath -> Mod FlagFields ExecutionMode
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"search"
  , FilePath -> Mod FlagFields ExecutionMode
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Search for left-hand side of the rewrite and show matches."
  ]

-- | Parser for 'Verbosity'.
parseVerbosity :: Verbosity -> Parser Verbosity
parseVerbosity :: Verbosity -> Parser Verbosity
parseVerbosity Verbosity
defaultV = ReadM Verbosity -> Mod OptionFields Verbosity -> Parser Verbosity
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ((FilePath -> Either FilePath Verbosity) -> ReadM Verbosity
forall a. (FilePath -> Either FilePath a) -> ReadM a
eitherReader FilePath -> Either FilePath Verbosity
verbosityReader) (Mod OptionFields Verbosity -> Parser Verbosity)
-> Mod OptionFields Verbosity -> Parser Verbosity
forall a b. (a -> b) -> a -> b
$ [Mod OptionFields Verbosity] -> Mod OptionFields Verbosity
forall a. Monoid a => [a] -> a
mconcat
  [ FilePath -> Mod OptionFields Verbosity
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"verbosity"
  , Char -> Mod OptionFields Verbosity
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'v'
  , Verbosity -> Mod OptionFields Verbosity
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Verbosity
defaultV
  , Mod OptionFields Verbosity
forall a (f :: * -> *). Show a => Mod f a
showDefault
  , FilePath -> Mod OptionFields Verbosity
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
verbosityHelp
  ]

verbosityReader :: String -> Either String Verbosity
verbosityReader :: FilePath -> Either FilePath Verbosity
verbosityReader FilePath
"0" = Verbosity -> Either FilePath Verbosity
forall a b. b -> Either a b
Right Verbosity
Silent
verbosityReader FilePath
"1" = Verbosity -> Either FilePath Verbosity
forall a b. b -> Either a b
Right Verbosity
Normal
verbosityReader FilePath
"2" = Verbosity -> Either FilePath Verbosity
forall a b. b -> Either a b
Right Verbosity
Loud
verbosityReader FilePath
_ =
  FilePath -> Either FilePath Verbosity
forall a b. a -> Either a b
Left (FilePath -> Either FilePath Verbosity)
-> FilePath -> Either FilePath Verbosity
forall a b. (a -> b) -> a -> b
$ FilePath
"invalid verbosity. Valid values: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
verbosityHelp

verbosityHelp :: String
verbosityHelp :: FilePath
verbosityHelp = FilePath
"0: silent, 1: normal, 2: loud (implies --single-threaded)"

-------------------------------------------------------------------------------

-- | Options that have been parsed, but not fully resolved.
type ProtoOptions = Options_ [RewriteSpec] [String]

-- | Resolve 'ProtoOptions' into 'Options'. Parses rewrites into 'Rewrite's,
-- parses imports, validates options, and extends 'fixityEnv' with any
-- declared fixities in the target directory.
resolveOptions :: LibDir -> ProtoOptions -> IO Options
resolveOptions :: FilePath -> ProtoOptions -> IO Options
resolveOptions FilePath
libdir ProtoOptions
protoOpts = do
  FilePath
absoluteTargetDir <- FilePath -> IO FilePath
makeAbsolute (ProtoOptions -> FilePath
forall rewrites imports. Options_ rewrites imports -> FilePath
targetDir ProtoOptions
protoOpts)
  opts :: ProtoOptions
opts@Options{Bool
Int
FilePath
[FilePath]
[RewriteSpec]
[RoundTrip]
FixityEnv
Verbosity
ExecutionMode
ColoriseFun
additionalImports :: forall rewrites imports. Options_ rewrites imports -> imports
colorise :: forall rewrites imports. Options_ rewrites imports -> ColoriseFun
elaborations :: forall rewrites imports. Options_ rewrites imports -> rewrites
executionMode :: forall rewrites imports. Options_ rewrites imports -> ExecutionMode
extraIgnores :: forall rewrites imports. Options_ rewrites imports -> [FilePath]
fixityEnv :: forall rewrites imports. Options_ rewrites imports -> FixityEnv
iterateN :: forall rewrites imports. Options_ rewrites imports -> Int
noDefaultElaborations :: forall rewrites imports. Options_ rewrites imports -> Bool
randomOrder :: forall rewrites imports. Options_ rewrites imports -> Bool
rewrites :: forall rewrites imports. Options_ rewrites imports -> rewrites
roundtrips :: forall rewrites imports. Options_ rewrites imports -> [RoundTrip]
singleThreaded :: forall rewrites imports. Options_ rewrites imports -> Bool
targetDir :: forall rewrites imports. Options_ rewrites imports -> FilePath
targetFiles :: forall rewrites imports. Options_ rewrites imports -> [FilePath]
verbosity :: forall rewrites imports. Options_ rewrites imports -> Verbosity
additionalImports :: [FilePath]
colorise :: ColoriseFun
elaborations :: [RewriteSpec]
executionMode :: ExecutionMode
extraIgnores :: [FilePath]
fixityEnv :: FixityEnv
iterateN :: Int
noDefaultElaborations :: Bool
randomOrder :: Bool
rewrites :: [RewriteSpec]
roundtrips :: [RoundTrip]
singleThreaded :: Bool
targetDir :: FilePath
targetFiles :: [FilePath]
verbosity :: Verbosity
..} <-
    FilePath -> ProtoOptions -> IO ProtoOptions
forall a b. FilePath -> Options_ a b -> IO (Options_ a b)
addLocalFixities FilePath
libdir ProtoOptions
protoOpts { targetDir = absoluteTargetDir }
  Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
parsedImports <- FilePath -> [FilePath] -> IO AnnotatedImports
parseImports FilePath
libdir [FilePath]
additionalImports
  Verbosity -> FilePath -> [FilePath] -> IO ()
debugPrint Verbosity
verbosity FilePath
"Imports:" ([FilePath] -> IO ()) -> [FilePath] -> IO ()
forall a b. (a -> b) -> a -> b
$
    Identity [FilePath] -> [FilePath]
forall a. Identity a -> a
runIdentity (Identity [FilePath] -> [FilePath])
-> Identity [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (Annotated [FilePath] -> [FilePath])
-> Identity (Annotated [FilePath]) -> Identity [FilePath]
forall a b. (a -> b) -> Identity a -> Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Annotated [FilePath] -> [FilePath]
forall ast. Annotated ast -> ast
astA (Identity (Annotated [FilePath]) -> Identity [FilePath])
-> Identity (Annotated [FilePath]) -> Identity [FilePath]
forall a b. (a -> b) -> a -> b
$ Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
    -> TransformT Identity [FilePath])
-> Identity (Annotated [FilePath])
forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
parsedImports (([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
  -> TransformT Identity [FilePath])
 -> Identity (Annotated [FilePath]))
-> ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
    -> TransformT Identity [FilePath])
-> Identity (Annotated [FilePath])
forall a b. (a -> b) -> a -> b
$ \ [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
imps -> do
      -- anns <- getAnnsT
      [FilePath] -> TransformT Identity [FilePath]
forall a. a -> TransformT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
return ([FilePath] -> TransformT Identity [FilePath])
-> [FilePath] -> TransformT Identity [FilePath]
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> FilePath)
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> FilePath
forall ast. ExactPrint ast => ast -> FilePath
exactPrint [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
imps
  [Query
   Universe
   (Template Universe,
    Context -> MatchResult Universe -> IO (MatchResult Universe))]
rrs <- FilePath
-> ProtoOptions
-> [RewriteSpec]
-> IO
     [Query
        Universe
        (Template Universe,
         Context -> MatchResult Universe -> IO (MatchResult Universe))]
forall a b.
FilePath
-> Options_ a b
-> [RewriteSpec]
-> IO
     [Query
        Universe
        (Template Universe,
         Context -> MatchResult Universe -> IO (MatchResult Universe))]
parseRewritesInternal FilePath
libdir ProtoOptions
opts [RewriteSpec]
rewrites
  [Query
   Universe
   (Template Universe,
    Context -> MatchResult Universe -> IO (MatchResult Universe))]
es <- FilePath
-> ProtoOptions
-> [RewriteSpec]
-> IO
     [Query
        Universe
        (Template Universe,
         Context -> MatchResult Universe -> IO (MatchResult Universe))]
forall a b.
FilePath
-> Options_ a b
-> [RewriteSpec]
-> IO
     [Query
        Universe
        (Template Universe,
         Context -> MatchResult Universe -> IO (MatchResult Universe))]
parseRewritesInternal FilePath
libdir ProtoOptions
opts ([RewriteSpec]
 -> IO
      [Query
         Universe
         (Template Universe,
          Context -> MatchResult Universe -> IO (MatchResult Universe))])
-> [RewriteSpec]
-> IO
     [Query
        Universe
        (Template Universe,
         Context -> MatchResult Universe -> IO (MatchResult Universe))]
forall a b. (a -> b) -> a -> b
$
    (if Bool
noDefaultElaborations then [] else [RewriteSpec]
defaultElaborations) [RewriteSpec] -> [RewriteSpec] -> [RewriteSpec]
forall a. [a] -> [a] -> [a]
++
    [RewriteSpec]
elaborations
  [Query
   Universe
   (Template Universe,
    Context -> MatchResult Universe -> IO (MatchResult Universe))]
elaborated <- FixityEnv
-> [Query
      Universe
      (Template Universe,
       Context -> MatchResult Universe -> IO (MatchResult Universe))]
-> [Query
      Universe
      (Template Universe,
       Context -> MatchResult Universe -> IO (MatchResult Universe))]
-> IO
     [Query
        Universe
        (Template Universe,
         Context -> MatchResult Universe -> IO (MatchResult Universe))]
elaborateRewritesInternal FixityEnv
fixityEnv [Query
   Universe
   (Template Universe,
    Context -> MatchResult Universe -> IO (MatchResult Universe))]
es [Query
   Universe
   (Template Universe,
    Context -> MatchResult Universe -> IO (MatchResult Universe))]
rrs
  return Options
    { additionalImports :: Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
additionalImports = Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
parsedImports
    , elaborations :: [Query
   Universe
   (Template Universe,
    Context -> MatchResult Universe -> IO (MatchResult Universe))]
elaborations = [Query
   Universe
   (Template Universe,
    Context -> MatchResult Universe -> IO (MatchResult Universe))]
es
    , rewrites :: [Query
   Universe
   (Template Universe,
    Context -> MatchResult Universe -> IO (MatchResult Universe))]
rewrites = [Query
   Universe
   (Template Universe,
    Context -> MatchResult Universe -> IO (MatchResult Universe))]
elaborated
    , singleThreaded :: Bool
singleThreaded = Bool
singleThreaded Bool -> Bool -> Bool
|| Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
Loud
    , Bool
Int
FilePath
[FilePath]
[RoundTrip]
FixityEnv
Verbosity
ExecutionMode
ColoriseFun
colorise :: ColoriseFun
executionMode :: ExecutionMode
extraIgnores :: [FilePath]
fixityEnv :: FixityEnv
iterateN :: Int
noDefaultElaborations :: Bool
randomOrder :: Bool
roundtrips :: [RoundTrip]
targetDir :: FilePath
targetFiles :: [FilePath]
verbosity :: Verbosity
colorise :: ColoriseFun
executionMode :: ExecutionMode
extraIgnores :: [FilePath]
fixityEnv :: FixityEnv
iterateN :: Int
noDefaultElaborations :: Bool
randomOrder :: Bool
roundtrips :: [RoundTrip]
targetDir :: FilePath
targetFiles :: [FilePath]
verbosity :: Verbosity
..
    }

-- | Find all fixity declarations in targetDir and add them to fixity env.
addLocalFixities :: LibDir -> Options_ a b -> IO (Options_ a b)
addLocalFixities :: forall a b. FilePath -> Options_ a b -> IO (Options_ a b)
addLocalFixities FilePath
libdir Options_ a b
opts = do
  -- do not limit search for infix decls to only targetFiles
  let opts' :: Options_ a b
opts' = Options_ a b
opts { targetFiles = [] }
  -- "infix" will find infixl and infixr as well
  [FilePath]
files <- Options_ a b -> [GroundTerms] -> IO [FilePath]
forall a b. Options_ a b -> [GroundTerms] -> IO [FilePath]
getTargetFiles Options_ a b
opts' [FilePath -> GroundTerms
forall a. Hashable a => a -> HashSet a
HashSet.singleton FilePath
"infix"]

  [FixityEnv -> FixityEnv]
fixFns <- Options_ a b
-> [FilePath]
-> (FilePath -> IO (FixityEnv -> FixityEnv))
-> IO [FixityEnv -> FixityEnv]
forall x y a b. Options_ x y -> [a] -> (a -> IO b) -> IO [b]
forFn Options_ a b
opts [FilePath]
files ((FilePath -> IO (FixityEnv -> FixityEnv))
 -> IO [FixityEnv -> FixityEnv])
-> (FilePath -> IO (FixityEnv -> FixityEnv))
-> IO [FixityEnv -> FixityEnv]
forall a b. (a -> b) -> a -> b
$ \ FilePath
fp -> do
    [AnnotatedModule]
ms <- CPP AnnotatedModule -> [AnnotatedModule]
forall a. CPP a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (CPP AnnotatedModule -> [AnnotatedModule])
-> IO (CPP AnnotatedModule) -> IO [AnnotatedModule]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> FilePath -> IO AnnotatedModule)
-> FilePath -> IO (CPP AnnotatedModule)
parseCPPFile (FilePath -> FilePath -> FilePath -> IO AnnotatedModule
parseContentNoFixity FilePath
libdir) FilePath
fp
    return $ [(FastString, Fixity)] -> FixityEnv -> FixityEnv
extendFixityEnv
      [ (RdrName -> FastString
rdrFS RdrName
nm, Fixity
fixity)
      | AnnotatedModule
m <- [AnnotatedModule]
ms
      , (L SrcSpanAnnN
_ RdrName
nm, Fixity
fixity) <- HsModule GhcPs -> [(LocatedN RdrName, Fixity)]
fixityDecls (GenLocated SrcSpan (HsModule GhcPs) -> HsModule GhcPs
forall l e. GenLocated l e -> e
unLoc (AnnotatedModule -> GenLocated SrcSpan (HsModule GhcPs)
forall ast. Annotated ast -> ast
astA AnnotatedModule
m))
      ]

  return Options_ a b
opts { fixityEnv = foldr ($) (fixityEnv opts) fixFns }

-- | 'forM', but concurrency and input order controled by 'Options'.
forFn :: Options_ x y -> [a] -> (a -> IO b) -> IO [b]
forFn :: forall x y a b. Options_ x y -> [a] -> (a -> IO b) -> IO [b]
forFn Options{x
y
Bool
Int
FilePath
[FilePath]
[RoundTrip]
FixityEnv
Verbosity
ExecutionMode
ColoriseFun
additionalImports :: forall rewrites imports. Options_ rewrites imports -> imports
colorise :: forall rewrites imports. Options_ rewrites imports -> ColoriseFun
elaborations :: forall rewrites imports. Options_ rewrites imports -> rewrites
executionMode :: forall rewrites imports. Options_ rewrites imports -> ExecutionMode
extraIgnores :: forall rewrites imports. Options_ rewrites imports -> [FilePath]
fixityEnv :: forall rewrites imports. Options_ rewrites imports -> FixityEnv
iterateN :: forall rewrites imports. Options_ rewrites imports -> Int
noDefaultElaborations :: forall rewrites imports. Options_ rewrites imports -> Bool
randomOrder :: forall rewrites imports. Options_ rewrites imports -> Bool
rewrites :: forall rewrites imports. Options_ rewrites imports -> rewrites
roundtrips :: forall rewrites imports. Options_ rewrites imports -> [RoundTrip]
singleThreaded :: forall rewrites imports. Options_ rewrites imports -> Bool
targetDir :: forall rewrites imports. Options_ rewrites imports -> FilePath
targetFiles :: forall rewrites imports. Options_ rewrites imports -> [FilePath]
verbosity :: forall rewrites imports. Options_ rewrites imports -> Verbosity
additionalImports :: y
colorise :: ColoriseFun
elaborations :: x
executionMode :: ExecutionMode
extraIgnores :: [FilePath]
fixityEnv :: FixityEnv
iterateN :: Int
noDefaultElaborations :: Bool
randomOrder :: Bool
rewrites :: x
roundtrips :: [RoundTrip]
singleThreaded :: Bool
targetDir :: FilePath
targetFiles :: [FilePath]
verbosity :: Verbosity
..} [a]
c a -> IO b
f
  | Bool
randomOrder = (a -> IO b) -> [a] -> IO [b]
forall {a} {b}. (a -> IO b) -> [a] -> IO [b]
fn a -> IO b
f ([a] -> IO [b]) -> IO [a] -> IO [b]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [a] -> IO [a]
forall (m :: * -> *) a. MonadRandom m => [a] -> m [a]
shuffleM [a]
c
  | Bool
otherwise = (a -> IO b) -> [a] -> IO [b]
forall {a} {b}. (a -> IO b) -> [a] -> IO [b]
fn a -> IO b
f [a]
c
  where
    fn :: (a -> IO b) -> [a] -> IO [b]
fn
      | Bool
singleThreaded = (a -> IO b) -> [a] -> IO [b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM
      | Bool
otherwise = (a -> IO b) -> [a] -> IO [b]
forall (t :: * -> *) a b.
Traversable t =>
(a -> IO b) -> t a -> IO (t b)
mapConcurrently

-- | Find all files to target for rewriting.
getTargetFiles :: Options_ a b -> [GroundTerms] -> IO [FilePath]
-- Always include at least one set of ground terms
-- This selects all files if the list of rewrites is empty
getTargetFiles :: forall a b. Options_ a b -> [GroundTerms] -> IO [FilePath]
getTargetFiles Options_ a b
opts [] = Options_ a b -> [GroundTerms] -> IO [FilePath]
forall a b. Options_ a b -> [GroundTerms] -> IO [FilePath]
getTargetFiles Options_ a b
opts [GroundTerms
forall a. Monoid a => a
mempty]
getTargetFiles Options{a
b
Bool
Int
FilePath
[FilePath]
[RoundTrip]
FixityEnv
Verbosity
ExecutionMode
ColoriseFun
additionalImports :: forall rewrites imports. Options_ rewrites imports -> imports
colorise :: forall rewrites imports. Options_ rewrites imports -> ColoriseFun
elaborations :: forall rewrites imports. Options_ rewrites imports -> rewrites
executionMode :: forall rewrites imports. Options_ rewrites imports -> ExecutionMode
extraIgnores :: forall rewrites imports. Options_ rewrites imports -> [FilePath]
fixityEnv :: forall rewrites imports. Options_ rewrites imports -> FixityEnv
iterateN :: forall rewrites imports. Options_ rewrites imports -> Int
noDefaultElaborations :: forall rewrites imports. Options_ rewrites imports -> Bool
randomOrder :: forall rewrites imports. Options_ rewrites imports -> Bool
rewrites :: forall rewrites imports. Options_ rewrites imports -> rewrites
roundtrips :: forall rewrites imports. Options_ rewrites imports -> [RoundTrip]
singleThreaded :: forall rewrites imports. Options_ rewrites imports -> Bool
targetDir :: forall rewrites imports. Options_ rewrites imports -> FilePath
targetFiles :: forall rewrites imports. Options_ rewrites imports -> [FilePath]
verbosity :: forall rewrites imports. Options_ rewrites imports -> Verbosity
additionalImports :: b
colorise :: ColoriseFun
elaborations :: a
executionMode :: ExecutionMode
extraIgnores :: [FilePath]
fixityEnv :: FixityEnv
iterateN :: Int
noDefaultElaborations :: Bool
randomOrder :: Bool
rewrites :: a
roundtrips :: [RoundTrip]
singleThreaded :: Bool
targetDir :: FilePath
targetFiles :: [FilePath]
verbosity :: Verbosity
..} [GroundTerms]
gtss = do
  FilePath -> Bool
ignorePred <- IO (FilePath -> Bool)
-> ((FilePath -> Bool) -> IO (FilePath -> Bool))
-> Maybe (FilePath -> Bool)
-> IO (FilePath -> Bool)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO (FilePath -> Bool)
forall {b}. IO (b -> Bool)
onIgnoreErr (FilePath -> Bool) -> IO (FilePath -> Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (FilePath -> Bool) -> IO (FilePath -> Bool))
-> IO (Maybe (FilePath -> Bool)) -> IO (FilePath -> Bool)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Verbosity -> FilePath -> IO (Maybe (FilePath -> Bool))
vcsIgnorePred Verbosity
verbosity FilePath
targetDir
  let ignore :: FilePath -> Bool
ignore FilePath
fp = FilePath -> Bool
ignorePred FilePath
fp Bool -> Bool -> Bool
|| FilePath -> Bool
extraIgnorePred FilePath
fp
  [GroundTerms]
fpSets <- [GroundTerms]
-> (GroundTerms -> IO GroundTerms) -> IO [GroundTerms]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([GroundTerms] -> [GroundTerms]
dedup [GroundTerms]
gtss) ((GroundTerms -> IO GroundTerms) -> IO [GroundTerms])
-> (GroundTerms -> IO GroundTerms) -> IO [GroundTerms]
forall a b. (a -> b) -> a -> b
$ \ GroundTerms
gts -> do
    -- See Note [Ground Terms]
    [FilePath]
fps <- FilePath -> Verbosity -> GrepCommands -> IO [FilePath]
runGrepChain FilePath
targetDir Verbosity
verbosity (FilePath -> GroundTerms -> [FilePath] -> GrepCommands
buildGrepChain FilePath
targetDir GroundTerms
gts [FilePath]
targetFiles)

    let
      r :: [FilePath]
r = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (FilePath -> Bool) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Bool
ignore)
        ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath
normalise (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
targetDir FilePath -> FilePath -> FilePath
</>)) [FilePath]
fps
    Verbosity -> FilePath -> [FilePath] -> IO ()
debugPrint Verbosity
verbosity FilePath
"Files:" [FilePath]
r
    return $ [FilePath] -> GroundTerms
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList [FilePath]
r

  return $ GroundTerms -> [FilePath]
forall a. HashSet a -> [a]
HashSet.toList (GroundTerms -> [FilePath]) -> GroundTerms -> [FilePath]
forall a b. (a -> b) -> a -> b
$ [GroundTerms] -> GroundTerms
forall a. Monoid a => [a] -> a
mconcat [GroundTerms]
fpSets
  where
    dedup :: [GroundTerms] -> [GroundTerms]
dedup = HashSet GroundTerms -> [GroundTerms]
forall a. HashSet a -> [a]
HashSet.toList (HashSet GroundTerms -> [GroundTerms])
-> ([GroundTerms] -> HashSet GroundTerms)
-> [GroundTerms]
-> [GroundTerms]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GroundTerms] -> HashSet GroundTerms
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList
    extraIgnorePred :: FilePath -> Bool
extraIgnorePred =
      let fps :: [FilePath]
fps = [ FilePath -> FilePath
normalise (FilePath
targetDir FilePath -> FilePath -> FilePath
</> FilePath
f) | FilePath
f <- [FilePath]
extraIgnores ]
      in \FilePath
fp -> (FilePath -> Bool) -> [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
fp) [FilePath]
fps
    onIgnoreErr :: IO (b -> Bool)
onIgnoreErr = do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
> Verbosity
Silent) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        FilePath -> IO ()
putStrLn FilePath
"Reading VCS ignore failed! Continuing without ignoring."
      return $ Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
False

-- | Return a chain of grep commands to find files with relevant groundTerms
-- If filesGiven is empty, use all *.hs files under targetDir
buildGrepChain
  :: FilePath
  -> HashSet String
  -> [FilePath]
  -> GrepCommands
buildGrepChain :: FilePath -> GroundTerms -> [FilePath] -> GrepCommands
buildGrepChain FilePath
targetDir GroundTerms
gts [FilePath]
filesGiven = GrepCommands {initialFileSet :: [FilePath]
initialFileSet=[FilePath]
filesGiven, commandChain :: [FilePath]
commandChain=[FilePath]
commands}
  where
    commands :: [FilePath]
commands = if [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
filesGiven
               then [FilePath]
commandsWithoutFiles
               else [FilePath]
commandsWithFiles

    commandsWithFiles :: [FilePath]
commandsWithFiles = case [FilePath]
terms of
        [] -> [] -- no processing
        [FilePath]
gs -> (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
normalGrep [FilePath]
gs
    commandsWithoutFiles :: [FilePath]
commandsWithoutFiles = case [FilePath]
terms of
        [] -> [FilePath
findCmd] -- all .hs files
        FilePath
g:[FilePath]
gs -> FilePath -> FilePath
recursiveGrep FilePath
g FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
normalGrep [FilePath]
gs -- start with recursive grep

    findCmd :: FilePath
findCmd = [FilePath] -> FilePath
unwords [FilePath
"find", FilePath -> FilePath
quotePath (FilePath -> FilePath
addTrailingPathSeparator FilePath
targetDir), FilePath
"-iname", FilePath
hsExtension]
    recursiveGrep :: FilePath -> FilePath
recursiveGrep FilePath
g = [FilePath] -> FilePath
unwords [FilePath
"grep", FilePath
"-R", FilePath
"--include=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
hsExtension, FilePath
"-l", FilePath -> FilePath
esc FilePath
g, FilePath -> FilePath
quotePath FilePath
targetDir]
    normalGrep :: FilePath -> FilePath
normalGrep FilePath
gt = [FilePath] -> FilePath
unwords [FilePath
"grep", FilePath
"-l", FilePath -> FilePath
esc FilePath
gt]

   -- Limit the number of the shell command we build by only selecting
   -- up to 10 ground terms. The goal is to filter file list down to
   -- a manageable size. It doesn't have to be exact.
    terms :: [FilePath]
terms = Int -> [FilePath] -> [FilePath]
forall a. Int -> [a] -> [a]
take Int
10 ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
p ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ GroundTerms -> [FilePath]
forall a. HashSet a -> [a]
HashSet.toList GroundTerms
gts
    p :: FilePath -> Bool
p [] = Bool
False
    p (Char
c:FilePath
cs)
      | Char -> Bool
isSpace Char
c = FilePath -> Bool
p FilePath
cs
      | Bool
otherwise = Char -> Bool
isAlphaNum Char
c

    hsExtension :: FilePath
hsExtension = FilePath
"\"*.hs\""

    esc :: FilePath -> FilePath
esc FilePath
s = FilePath -> FilePath
forall {t :: * -> *}. Foldable t => t Char -> FilePath
osquote (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"[[:space:]]\\+" (FilePath -> [FilePath]
words (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
escChars FilePath
s)
    escChars :: FilePath -> FilePath
escChars = (Char -> FilePath) -> FilePath -> FilePath
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> FilePath
escChar
    escChar :: Char -> FilePath
escChar Char
c
      | Char
c Char -> FilePath -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FilePath
magicChars = FilePath
"\\" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [Char
c]
      | Bool
otherwise  = [Char
c]
    magicChars :: [Char]
    magicChars :: FilePath
magicChars = FilePath
"*?[#˜=%\\"

    osquote :: t Char -> FilePath
osquote t Char
s = FilePath
"'" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Char -> FilePath) -> t Char -> FilePath
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> FilePath
escapeQuote t Char
s FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'"
      where escapeQuote :: Char -> FilePath
escapeQuote Char
'\'' = FilePath
"'\"'\"'"
            escapeQuote Char
c = [Char
c]


type CommandLine = String
data GrepCommands = GrepCommands { GrepCommands -> [FilePath]
initialFileSet :: [FilePath], GrepCommands -> [FilePath]
commandChain :: [CommandLine] }
  deriving (GrepCommands -> GrepCommands -> Bool
(GrepCommands -> GrepCommands -> Bool)
-> (GrepCommands -> GrepCommands -> Bool) -> Eq GrepCommands
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GrepCommands -> GrepCommands -> Bool
== :: GrepCommands -> GrepCommands -> Bool
$c/= :: GrepCommands -> GrepCommands -> Bool
/= :: GrepCommands -> GrepCommands -> Bool
Eq, Int -> GrepCommands -> FilePath -> FilePath
[GrepCommands] -> FilePath -> FilePath
GrepCommands -> FilePath
(Int -> GrepCommands -> FilePath -> FilePath)
-> (GrepCommands -> FilePath)
-> ([GrepCommands] -> FilePath -> FilePath)
-> Show GrepCommands
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> GrepCommands -> FilePath -> FilePath
showsPrec :: Int -> GrepCommands -> FilePath -> FilePath
$cshow :: GrepCommands -> FilePath
show :: GrepCommands -> FilePath
$cshowList :: [GrepCommands] -> FilePath -> FilePath
showList :: [GrepCommands] -> FilePath -> FilePath
Show)

runGrepChain :: FilePath -> Verbosity -> GrepCommands -> IO [FilePath]
runGrepChain :: FilePath -> Verbosity -> GrepCommands -> IO [FilePath]
runGrepChain FilePath
targetDir Verbosity
verbosity GrepCommands{[FilePath]
initialFileSet :: GrepCommands -> [FilePath]
commandChain :: GrepCommands -> [FilePath]
initialFileSet :: [FilePath]
commandChain :: [FilePath]
..} = ([FilePath] -> FilePath -> IO [FilePath])
-> [FilePath] -> [FilePath] -> IO [FilePath]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (FilePath -> Verbosity -> [FilePath] -> FilePath -> IO [FilePath]
commandStep FilePath
targetDir Verbosity
verbosity)  [FilePath]
initialFileSet [FilePath]
commandChain

-- | run a command with a list of files as quoted arguments
commandStep :: FilePath -> Verbosity -> [FilePath]-> CommandLine -> IO [FilePath]
commandStep :: FilePath -> Verbosity -> [FilePath] -> FilePath -> IO [FilePath]
commandStep FilePath
targetDir Verbosity
verbosity [FilePath]
files FilePath
cmd = FilePath -> Verbosity -> FilePath -> IO [FilePath]
doCmd FilePath
targetDir Verbosity
verbosity (FilePath
cmd FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
formatPaths [FilePath]
files)
 where
    formatPaths :: [FilePath] -> FilePath
formatPaths [] = FilePath
""
    formatPaths [FilePath]
xs = FilePath
" " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
unwords ((FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
quotePath [FilePath]
xs)
quotePath :: FilePath -> FilePath
quotePath :: FilePath -> FilePath
quotePath FilePath
x = FilePath
"'" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
x FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"'"


doCmd :: FilePath -> Verbosity -> String -> IO [FilePath]
doCmd :: FilePath -> Verbosity -> FilePath -> IO [FilePath]
doCmd FilePath
targetDir Verbosity
verbosity FilePath
shellCmd = do
  Verbosity -> FilePath -> [FilePath] -> IO ()
debugPrint Verbosity
verbosity FilePath
"shellCmd:" [FilePath
shellCmd]
  let cmd :: CreateProcess
cmd = (FilePath -> CreateProcess
shell FilePath
shellCmd) { cwd = Just targetDir }
  (ExitCode
_ec, FilePath
fps, FilePath
_) <- CreateProcess -> FilePath -> IO (ExitCode, FilePath, FilePath)
readCreateProcessWithExitCode CreateProcess
cmd FilePath
""
  return $ FilePath -> [FilePath]
lines FilePath
fps