{-# 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
import qualified Config as GHC
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 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"
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
when (null args) $
(putStrLn "missing arguments") >> (exitWith $ ExitFailure 1)
let inplace = hasAny ["-i", "--inplace"] args
file = last $ filter (not . isPrefixOf "-") args
verbose = elem "--verbose" args
-- FIXME a --check-rule flag that just parses a rule
content <- T.readFile file
-- TODO all parsec errors should be formatted as path/to/file.hs:line:col:
-- 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
[] -> error "no rules"
[ruleFile] -> do
cached <- readIORef rulesCache
case M.lookup ruleFile cached of
Nothing -> do
parsed <- parseFromFile ruleParser ruleFile
case parsed of
Left err -> error $ 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 -> error $ "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 -> error $ "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 -> (putStrLn $ T.unpack err) >> (exitWith $ ExitFailure 1)
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)