-- 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 <- forall a. ParserInfo a -> IO a
execParser (forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser ProtoOptions
p forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> forall a. Parser (a -> a)
helper) 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 [Rewrite Universe]
parseRewritesInternal FilePath
libdir Options{a
b
Bool
Int
FilePath
[FilePath]
[RoundTrip]
FixityEnv
Verbosity
ExecutionMode
ColoriseFun
verbosity :: forall rewrites imports. Options_ rewrites imports -> Verbosity
targetFiles :: forall rewrites imports. Options_ rewrites imports -> [FilePath]
targetDir :: forall rewrites imports. Options_ rewrites imports -> FilePath
singleThreaded :: forall rewrites imports. Options_ rewrites imports -> Bool
roundtrips :: forall rewrites imports. Options_ rewrites imports -> [RoundTrip]
rewrites :: forall rewrites imports. Options_ rewrites imports -> rewrites
randomOrder :: forall rewrites imports. Options_ rewrites imports -> Bool
noDefaultElaborations :: forall rewrites imports. Options_ rewrites imports -> Bool
iterateN :: forall rewrites imports. Options_ rewrites imports -> Int
fixityEnv :: forall rewrites imports. Options_ rewrites imports -> FixityEnv
extraIgnores :: forall rewrites imports. Options_ rewrites imports -> [FilePath]
executionMode :: forall rewrites imports. Options_ rewrites imports -> ExecutionMode
elaborations :: forall rewrites imports. Options_ rewrites imports -> rewrites
colorise :: forall rewrites imports. Options_ rewrites imports -> ColoriseFun
additionalImports :: forall rewrites imports. Options_ rewrites imports -> imports
verbosity :: Verbosity
targetFiles :: [FilePath]
targetDir :: FilePath
singleThreaded :: Bool
roundtrips :: [RoundTrip]
rewrites :: a
randomOrder :: Bool
noDefaultElaborations :: Bool
iterateN :: Int
fixityEnv :: FixityEnv
extraIgnores :: [FilePath]
executionMode :: ExecutionMode
elaborations :: a
colorise :: ColoriseFun
additionalImports :: b
..} = FilePath
-> (FilePath -> IO (CPP AnnotatedModule))
-> FixityEnv
-> [RewriteSpec]
-> IO [Rewrite 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
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [ExecutionMode] -> FilePath -> FilePath
$cshowList :: [ExecutionMode] -> FilePath -> FilePath
show :: ExecutionMode -> FilePath
$cshow :: ExecutionMode -> FilePath
showsPrec :: Int -> ExecutionMode -> FilePath -> FilePath
$cshowsPrec :: Int -> 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 = forall a. Default a => a
D.def
  , colorise :: ColoriseFun
colorise = ColoriseFun
noColor
  , elaborations :: rewrites
elaborations = forall a. Default a => a
D.def
  , executionMode :: ExecutionMode
executionMode = ExecutionMode
ExecRewrite
  , extraIgnores :: [FilePath]
extraIgnores = []
  , 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 = 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 <- forall rewrites imports.
(Default rewrites, Default imports) =>
FilePath -> Options_ rewrites imports
defaultOptions forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FilePath
getCurrentDirectory
  return $ ProtoOptions -> Parser ProtoOptions
buildParser ProtoOptions
dOpts { fixityEnv :: FixityEnv
fixityEnv = FixityEnv
fEnv }

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

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

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

parseExtract :: Parser ExecutionMode
parseExtract :: Parser ExecutionMode
parseExtract = forall a. a -> Mod FlagFields a -> Parser a
flag' ExecutionMode
ExecExtract forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
  [ forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"extract"
  , 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 = forall a. a -> Mod FlagFields a -> Parser a
flag' ExecutionMode
ExecSearch forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
  [ forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"search"
  , 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 = forall a. ReadM a -> Mod OptionFields a -> Parser a
option (forall a. (FilePath -> Either FilePath a) -> ReadM a
eitherReader FilePath -> Either FilePath Verbosity
verbosityReader) forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
  [ forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"verbosity"
  , forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'v'
  , forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Verbosity
defaultV
  , forall a (f :: * -> *). Show a => Mod f a
showDefault
  , forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
verbosityHelp
  ]

verbosityReader :: String -> Either String Verbosity
verbosityReader :: FilePath -> Either FilePath Verbosity
verbosityReader FilePath
"0" = forall a b. b -> Either a b
Right Verbosity
Silent
verbosityReader FilePath
"1" = forall a b. b -> Either a b
Right Verbosity
Normal
verbosityReader FilePath
"2" = forall a b. b -> Either a b
Right Verbosity
Loud
verbosityReader FilePath
_ =
  forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ FilePath
"invalid verbosity. Valid values: " 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 (forall rewrites imports. Options_ rewrites imports -> FilePath
targetDir ProtoOptions
protoOpts)
  opts :: ProtoOptions
opts@Options{Bool
Int
FilePath
[FilePath]
[RewriteSpec]
[RoundTrip]
FixityEnv
Verbosity
ExecutionMode
ColoriseFun
verbosity :: Verbosity
targetFiles :: [FilePath]
targetDir :: FilePath
singleThreaded :: Bool
roundtrips :: [RoundTrip]
rewrites :: [RewriteSpec]
randomOrder :: Bool
noDefaultElaborations :: Bool
iterateN :: Int
fixityEnv :: FixityEnv
extraIgnores :: [FilePath]
executionMode :: ExecutionMode
elaborations :: [RewriteSpec]
colorise :: ColoriseFun
additionalImports :: [FilePath]
verbosity :: forall rewrites imports. Options_ rewrites imports -> Verbosity
targetFiles :: forall rewrites imports. Options_ rewrites imports -> [FilePath]
targetDir :: forall rewrites imports. Options_ rewrites imports -> FilePath
singleThreaded :: forall rewrites imports. Options_ rewrites imports -> Bool
roundtrips :: forall rewrites imports. Options_ rewrites imports -> [RoundTrip]
rewrites :: forall rewrites imports. Options_ rewrites imports -> rewrites
randomOrder :: forall rewrites imports. Options_ rewrites imports -> Bool
noDefaultElaborations :: forall rewrites imports. Options_ rewrites imports -> Bool
iterateN :: forall rewrites imports. Options_ rewrites imports -> Int
fixityEnv :: forall rewrites imports. Options_ rewrites imports -> FixityEnv
extraIgnores :: forall rewrites imports. Options_ rewrites imports -> [FilePath]
executionMode :: forall rewrites imports. Options_ rewrites imports -> ExecutionMode
elaborations :: forall rewrites imports. Options_ rewrites imports -> rewrites
colorise :: forall rewrites imports. Options_ rewrites imports -> ColoriseFun
additionalImports :: forall rewrites imports. Options_ rewrites imports -> imports
..} <-
    forall a b. FilePath -> Options_ a b -> IO (Options_ a b)
addLocalFixities FilePath
libdir ProtoOptions
protoOpts { targetDir :: FilePath
targetDir = FilePath
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:" forall a b. (a -> b) -> a -> b
$
    forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall ast. Annotated ast -> ast
astA forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
parsedImports forall a b. (a -> b) -> a -> b
$ \ [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
imps -> do
      -- anns <- getAnnsT
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall ast. ExactPrint ast => ast -> FilePath
exactPrint [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
imps
  [Rewrite Universe]
rrs <- forall a b.
FilePath -> Options_ a b -> [RewriteSpec] -> IO [Rewrite Universe]
parseRewritesInternal FilePath
libdir ProtoOptions
opts [RewriteSpec]
rewrites
  [Rewrite Universe]
es <- forall a b.
FilePath -> Options_ a b -> [RewriteSpec] -> IO [Rewrite Universe]
parseRewritesInternal FilePath
libdir ProtoOptions
opts forall a b. (a -> b) -> a -> b
$
    (if Bool
noDefaultElaborations then [] else [RewriteSpec]
defaultElaborations) forall a. [a] -> [a] -> [a]
++
    [RewriteSpec]
elaborations
  [Rewrite Universe]
elaborated <- FixityEnv
-> [Rewrite Universe]
-> [Rewrite Universe]
-> IO [Rewrite Universe]
elaborateRewritesInternal FixityEnv
fixityEnv [Rewrite Universe]
es [Rewrite Universe]
rrs
  return Options
    { additionalImports :: Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
additionalImports = Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
parsedImports
    , elaborations :: [Rewrite Universe]
elaborations = [Rewrite Universe]
es
    , rewrites :: [Rewrite Universe]
rewrites = [Rewrite Universe]
elaborated
    , singleThreaded :: Bool
singleThreaded = Bool
singleThreaded Bool -> Bool -> Bool
|| Verbosity
verbosity forall a. Eq a => a -> a -> Bool
== Verbosity
Loud
    , Bool
Int
FilePath
[FilePath]
[RoundTrip]
FixityEnv
Verbosity
ExecutionMode
ColoriseFun
verbosity :: Verbosity
targetFiles :: [FilePath]
targetDir :: FilePath
roundtrips :: [RoundTrip]
randomOrder :: Bool
noDefaultElaborations :: Bool
iterateN :: Int
fixityEnv :: FixityEnv
extraIgnores :: [FilePath]
executionMode :: ExecutionMode
colorise :: ColoriseFun
verbosity :: Verbosity
targetFiles :: [FilePath]
targetDir :: FilePath
roundtrips :: [RoundTrip]
randomOrder :: Bool
noDefaultElaborations :: Bool
iterateN :: Int
fixityEnv :: FixityEnv
extraIgnores :: [FilePath]
executionMode :: ExecutionMode
colorise :: ColoriseFun
..
    }

-- | 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 :: [FilePath]
targetFiles = [] }
  -- "infix" will find infixl and infixr as well
  [FilePath]
files <- forall a b. Options_ a b -> [GroundTerms] -> IO [FilePath]
getTargetFiles Options_ a b
opts' [forall a. Hashable a => a -> HashSet a
HashSet.singleton FilePath
"infix"]

  [FixityEnv -> FixityEnv]
fixFns <- forall x y a b. Options_ x y -> [a] -> (a -> IO b) -> IO [b]
forFn Options_ a b
opts [FilePath]
files forall a b. (a -> b) -> a -> b
$ \ FilePath
fp -> do
    [AnnotatedModule]
ms <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList 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 -> [(LocatedN RdrName, Fixity)]
fixityDecls (forall l e. GenLocated l e -> e
unLoc (forall ast. Annotated ast -> ast
astA AnnotatedModule
m))
      ]

  return Options_ a b
opts { fixityEnv :: FixityEnv
fixityEnv = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a b. (a -> b) -> a -> b
($) (forall rewrites imports. Options_ rewrites imports -> FixityEnv
fixityEnv Options_ a b
opts) [FixityEnv -> FixityEnv]
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
verbosity :: Verbosity
targetFiles :: [FilePath]
targetDir :: FilePath
singleThreaded :: Bool
roundtrips :: [RoundTrip]
rewrites :: x
randomOrder :: Bool
noDefaultElaborations :: Bool
iterateN :: Int
fixityEnv :: FixityEnv
extraIgnores :: [FilePath]
executionMode :: ExecutionMode
elaborations :: x
colorise :: ColoriseFun
additionalImports :: y
verbosity :: forall rewrites imports. Options_ rewrites imports -> Verbosity
targetFiles :: forall rewrites imports. Options_ rewrites imports -> [FilePath]
targetDir :: forall rewrites imports. Options_ rewrites imports -> FilePath
singleThreaded :: forall rewrites imports. Options_ rewrites imports -> Bool
roundtrips :: forall rewrites imports. Options_ rewrites imports -> [RoundTrip]
rewrites :: forall rewrites imports. Options_ rewrites imports -> rewrites
randomOrder :: forall rewrites imports. Options_ rewrites imports -> Bool
noDefaultElaborations :: forall rewrites imports. Options_ rewrites imports -> Bool
iterateN :: forall rewrites imports. Options_ rewrites imports -> Int
fixityEnv :: forall rewrites imports. Options_ rewrites imports -> FixityEnv
extraIgnores :: forall rewrites imports. Options_ rewrites imports -> [FilePath]
executionMode :: forall rewrites imports. Options_ rewrites imports -> ExecutionMode
elaborations :: forall rewrites imports. Options_ rewrites imports -> rewrites
colorise :: forall rewrites imports. Options_ rewrites imports -> ColoriseFun
additionalImports :: forall rewrites imports. Options_ rewrites imports -> imports
..} [a]
c a -> IO b
f
  | Bool
randomOrder = forall {a} {b}. (a -> IO b) -> [a] -> IO [b]
fn a -> IO b
f forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadRandom m => [a] -> m [a]
shuffleM [a]
c
  | Bool
otherwise = 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 = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
      | Bool
otherwise = 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 [] = forall a b. Options_ a b -> [GroundTerms] -> IO [FilePath]
getTargetFiles Options_ a b
opts [forall a. Monoid a => a
mempty]
getTargetFiles Options{a
b
Bool
Int
FilePath
[FilePath]
[RoundTrip]
FixityEnv
Verbosity
ExecutionMode
ColoriseFun
verbosity :: Verbosity
targetFiles :: [FilePath]
targetDir :: FilePath
singleThreaded :: Bool
roundtrips :: [RoundTrip]
rewrites :: a
randomOrder :: Bool
noDefaultElaborations :: Bool
iterateN :: Int
fixityEnv :: FixityEnv
extraIgnores :: [FilePath]
executionMode :: ExecutionMode
elaborations :: a
colorise :: ColoriseFun
additionalImports :: b
verbosity :: forall rewrites imports. Options_ rewrites imports -> Verbosity
targetFiles :: forall rewrites imports. Options_ rewrites imports -> [FilePath]
targetDir :: forall rewrites imports. Options_ rewrites imports -> FilePath
singleThreaded :: forall rewrites imports. Options_ rewrites imports -> Bool
roundtrips :: forall rewrites imports. Options_ rewrites imports -> [RoundTrip]
rewrites :: forall rewrites imports. Options_ rewrites imports -> rewrites
randomOrder :: forall rewrites imports. Options_ rewrites imports -> Bool
noDefaultElaborations :: forall rewrites imports. Options_ rewrites imports -> Bool
iterateN :: forall rewrites imports. Options_ rewrites imports -> Int
fixityEnv :: forall rewrites imports. Options_ rewrites imports -> FixityEnv
extraIgnores :: forall rewrites imports. Options_ rewrites imports -> [FilePath]
executionMode :: forall rewrites imports. Options_ rewrites imports -> ExecutionMode
elaborations :: forall rewrites imports. Options_ rewrites imports -> rewrites
colorise :: forall rewrites imports. Options_ rewrites imports -> ColoriseFun
additionalImports :: forall rewrites imports. Options_ rewrites imports -> imports
..} [GroundTerms]
gtss = do
  FilePath -> Bool
ignorePred <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {b}. IO (b -> Bool)
onIgnoreErr forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([GroundTerms] -> [GroundTerms]
dedup [GroundTerms]
gtss) 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 = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Bool
ignore)
        forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath
normalise 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 $ forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList [FilePath]
r

  return $ forall a. HashSet a -> [a]
HashSet.toList forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [GroundTerms]
fpSets
  where
    dedup :: [GroundTerms] -> [GroundTerms]
dedup = forall a. HashSet a -> [a]
HashSet.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
fp) [FilePath]
fps
    onIgnoreErr :: IO (b -> Bool)
onIgnoreErr = do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity forall a. Ord a => a -> a -> Bool
> Verbosity
Silent) forall a b. (a -> b) -> a -> b
$
        FilePath -> IO ()
putStrLn FilePath
"Reading VCS ignore failed! Continuing without ignoring."
      return $ 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 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 -> 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 forall a. a -> [a] -> [a]
: 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=" 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 = forall a. Int -> [a] -> [a]
take Int
10 forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
p forall a b. (a -> b) -> a -> b
$ 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 = forall {t :: * -> *}. Foldable t => t Char -> FilePath
osquote forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"[[:space:]]\\+" (FilePath -> [FilePath]
words forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
escChars FilePath
s)
    escChars :: FilePath -> FilePath
escChars = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> FilePath
escChar
    escChar :: Char -> FilePath
escChar Char
c
      | Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FilePath
magicChars = 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
"'" forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> FilePath
escapeQuote t Char
s 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GrepCommands -> GrepCommands -> Bool
$c/= :: GrepCommands -> GrepCommands -> Bool
== :: GrepCommands -> GrepCommands -> Bool
$c== :: GrepCommands -> GrepCommands -> Bool
Eq, Int -> GrepCommands -> FilePath -> FilePath
[GrepCommands] -> FilePath -> FilePath
GrepCommands -> FilePath
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [GrepCommands] -> FilePath -> FilePath
$cshowList :: [GrepCommands] -> FilePath -> FilePath
show :: GrepCommands -> FilePath
$cshow :: GrepCommands -> FilePath
showsPrec :: Int -> GrepCommands -> FilePath -> FilePath
$cshowsPrec :: Int -> GrepCommands -> FilePath -> FilePath
Show)

runGrepChain :: FilePath -> Verbosity -> GrepCommands -> IO [FilePath]
runGrepChain :: FilePath -> Verbosity -> GrepCommands -> IO [FilePath]
runGrepChain FilePath
targetDir Verbosity
verbosity GrepCommands{[FilePath]
commandChain :: [FilePath]
initialFileSet :: [FilePath]
commandChain :: GrepCommands -> [FilePath]
initialFileSet :: GrepCommands -> [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 forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
formatPaths [FilePath]
files)
 where
    formatPaths :: [FilePath] -> FilePath
formatPaths [] = FilePath
""
    formatPaths [FilePath]
xs = FilePath
" " forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
unwords (forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
quotePath [FilePath]
xs)
quotePath :: FilePath -> FilePath
quotePath :: FilePath -> FilePath
quotePath FilePath
x = FilePath
"'" forall a. Semigroup a => a -> a -> a
<> FilePath
x 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 :: Maybe FilePath
cwd = forall a. a -> Maybe a
Just FilePath
targetDir }
  (ExitCode
_ec, FilePath
fps, FilePath
_) <- CreateProcess -> FilePath -> IO (ExitCode, FilePath, FilePath)
readCreateProcessWithExitCode CreateProcess
cmd FilePath
""
  return $ FilePath -> [FilePath]
lines FilePath
fps