{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Main where
import Boilerplate.ConfigParser
import Boilerplate.Doc
import Boilerplate.GhcParser
import Boilerplate.Interpreter
import Boilerplate.RuleFinder
import Boilerplate.RuleParser
import Boilerplate.Types
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
import qualified GHC.Version as GHC
#else
import qualified Config as GHC
#endif
import Control.Monad (when)
import Data.IORef (modifyIORef')
import Data.IORef (readIORef)
import Data.IORef (newIORef)
import Data.List (isPrefixOf)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (mapMaybe)
import Data.Maybe (catMaybes)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import HsInspect.Types (Comment(..), Pos(..), Type(..))
import System.Environment (getArgs)
import System.Exit (ExitCode(..), exitWith)
import System.IO (stderr)
import System.IO (hPutStrLn)
import Text.Parsec (parse, setPosition)
import Text.Parsec.Pos (newPos)
import Text.Parsec.Text (parseFromFile)
version :: String
#ifdef CURRENT_PACKAGE_VERSION
version = CURRENT_PACKAGE_VERSION
#else
version = "unknown"
#endif
help :: String
help =
"boilerplate [GLOBAL FLAGS] FILE\n\n" ++
"Global flags:\n\n" ++
" -h,--help Show this help text\n" ++
" -v,--version Print version information\n" ++
" --ghc-version Print ghc version information\n" ++
" -i,--inplace Overwrite FILE in place\n" ++
" --verbose Print debugging information to stderr\n" ++
" --check-rule Parse FILE as a rule file and display errors\n"
-- TODO automatic imports
--
-- rules could declare imports they probably need quite easily, but figuring out
-- if an import is necessary (especially considering reexports) and making a
-- diff to the import section is very difficult and probably warrants its own
-- tool. Nevertheless, this would be an excellent feature.
main :: IO ()
main = do
args <- getArgs
let hasAny :: Eq a => [a] -> [a] -> Bool
hasAny [] _ = False
hasAny _ [] = False
hasAny as (x : xs) | elem x as = True
| otherwise = hasAny as xs
when (hasAny ["-h", "--help"] args) $
(putStrLn help) >> exitWith ExitSuccess
when (hasAny ["-v", "--version"] args) $
(putStrLn version) >> exitWith ExitSuccess
when (elem "--ghc-version" args) $
(putStrLn GHC.cProjectVersion) >> exitWith ExitSuccess
let exit1 msg = (hPutStrLn stderr msg) >> (exitWith $ ExitFailure 1)
when (null args) $ exit1 "missing arguments"
let inplace = hasAny ["-i", "--inplace"] args
file = last $ filter (not . isPrefixOf "-") args
verbose = elem "--verbose" args
-- TODO all parsec errors should be formatted as path/to/file.hs:line:col:
when (elem "--check-rule" args) $ do
parsed <- parseFromFile ruleParser file
case parsed of
Left err -> exit1 $ show err
Right _ -> exitWith ExitSuccess
content <- T.readFile file
-- early exit when there is no work to do
when (not $ T.isInfixOf "BOILERPLATE" content) $
if inplace
then exitWith ExitSuccess
else (T.putStr content) >> exitWith ExitSuccess
(types, comments) <- parseHaskell file
let parseComment (Comment txt (Pos line col) end) =
case parse (setPosition (newPos file line col) *> configCommentParser) file txt of
Left msg -> do
when (verbose && T.isInfixOf "BOILERPLATE" txt) $ do
hPutStrLn stderr $ show msg
pure $ Nothing
Right c -> pure $ Just (c, end)
configs <- catMaybes <$> traverse parseComment comments
let targets = flip mapMaybe (threes configs) $ \case
(One ((Config t r c), s)) -> Just $ Action t r c s Nothing
(Two ((Config t r c), s) _) -> Just $ Action t r c s Nothing
-- the ConfigStart is irrelevant for position detection, it is
-- to make it easier for text editors to hide expansions.
(Three ((Config t r c), s) (ConfigStart, _) (ConfigEnd, e)) -> Just $ Action t r c s (Just e)
(Three ((Config t r c), s) _ _) -> Just $ Action t r c s Nothing
_ -> Nothing
ruleFiles <- findRules file
when verbose $ do
hPutStrLn stderr $ show types
hPutStrLn stderr $ show targets
hPutStrLn stderr $ show ruleFiles
rulesCache <- newIORef M.empty
let
findRule :: Text -> IO Rule
findRule rulename = do
let pickRule (fqn, short, path) =
if fqn == rulename || short == rulename
then Just path
else Nothing
case mapMaybe pickRule ruleFiles of
[] -> exit1 "no rules"
[ruleFile] -> do
cached <- readIORef rulesCache
case M.lookup ruleFile cached of
Nothing -> do
parsed <- parseFromFile ruleParser ruleFile
case parsed of
Left err -> exit1 $ show err
Right r -> r <$ modifyIORef' rulesCache (M.insert ruleFile r)
Just hit -> do
when verbose $
hPutStrLn stderr $ "hit cache for " <> ruleFile
pure hit
many -> exit1 $ "ambiguous rules" <> show many
tpes :: Map Text Type
tpes = M.fromList $ (\t -> (tycon t, t)) <$> types
where
tycon = \case
ProductType tc _ _ _ _ -> tc
RecordType tc _ _ _ _ -> tc
SumType tc _ _ -> tc
resolve (Action tycon rulenames custom start end) = do
tpe <- case M.lookup tycon tpes of
Nothing -> exit1 $ "could not find the type definition for " <> show tycon
Just a -> pure a
rules' <- traverse findRule rulenames
pure $ Action tpe rules' custom start end
resolved <- traverse resolve targets
when verbose $ do
hPutStrLn stderr $ show resolved
let
interpret (Action tpe rules cus start end) =
(\txt -> (start, end, prepare $ T.unlines txt)) <$>
(traverse (\r -> interpretRule r tpe (M.fromList cus)) rules)
interpreted = traverse interpret resolved
prepare snippet = start_comment <> T.strip snippet <> end_comment
start_comment = "\n{- BOILERPLATE START -}\n"
end_comment = "\n{- BOILERPLATE END -}"
replacement <- unDoc <$> case interpreted of
Left err -> exit1 $ T.unpack err
Right good -> pure $ upsertMany (mkDoc content) good
if inplace
then T.writeFile file replacement
else T.putStr replacement
data Three a = One a | Two a a | Three a a a
threes :: [a] -> [Three a]
threes = \case
[] -> []
[a] -> [One a]
a1 : a2 : [] -> Two a1 a2 : (threes [a2])
a1 : a2 : a3 : as -> Three a1 a2 a3 : (threes $ a2 : a3 : as)
type Target = Action Text Text
type Resolved = Action Type Rule
data Action tpe rule = Action tpe [rule] [(Text, Custom)] Pos (Maybe Pos)
deriving (Eq, Show)