module Cartel.Tools
(
(&&&)
, (|||)
, lt
, gt
, eq
, ltEq
, gtEq
, closedOpen
, apiVersion
, nextBreaking
, nextMajor
, exactly
, render
, renderString
, modules
, fileExtensions
, modulesWithExtensions
) where
import qualified Cartel.Ast as A
import qualified Cartel.Render as R
import qualified System.Directory as D
import qualified System.FilePath as P
import System.FilePath ((</>))
import qualified Data.Char as C
import Data.List (intersperse, sortBy)
import Data.Monoid
import qualified Data.Version as V
import Data.Time
import qualified Paths_cartel
import qualified System.IO as IO
(&&&) :: A.ConstrTree -> A.ConstrTree -> A.ConstrTree
l &&& r = A.Branch A.And l r
infixr 3 &&&
(|||) :: A.ConstrTree -> A.ConstrTree -> A.ConstrTree
l ||| r = A.Branch A.Or l r
infixr 2 |||
lt :: [Int] -> A.ConstrTree
lt = A.Leaf . A.Constraint LT . A.Version
gt :: [Int] -> A.ConstrTree
gt = A.Leaf . A.Constraint GT . A.Version
eq :: [Int] -> A.ConstrTree
eq = A.Leaf . A.Constraint EQ . A.Version
ltEq :: [Int] -> A.ConstrTree
ltEq v = lt v ||| eq v
gtEq :: [Int] -> A.ConstrTree
gtEq v = gt v ||| eq v
closedOpen
:: String
-> [Int]
-> [Int]
-> A.Package
closedOpen n l u = A.Package n $ Just (gtEq l &&& lt u)
apiVersion :: String -> [Int] -> A.Package
apiVersion n v = closedOpen n v u
where
u = case v of
[] -> error "apiVersion: requires a non-empty list argument"
_ -> init v ++ [succ (last v)]
nextBreaking
:: String
-> [Int]
-> A.Package
nextBreaking n v = closedOpen n v u
where
u = case v of
[] -> error "nextBreaking: requires a non-empty list argument"
x:[] -> [x, 1]
x:y:_ -> x : succ y : []
nextMajor
:: String
-> [Int]
-> A.Package
nextMajor n v = closedOpen n v u
where
u = case v of
[] -> error "nextMajor: requires a non-empty list argument"
x:_ -> succ x : []
exactly :: String -> [Int] -> A.Package
exactly n v = A.Package n (Just $ eq v)
fileExtensions :: [String]
fileExtensions =
[ "hs"
, "lhs"
, "gc"
, "chs"
, "hsc"
, "y"
, "ly"
, "x"
, "cpphs"
]
interestingFile
:: [String]
-> FilePath
-> Bool
interestingFile xs s = case s of
"" -> False
x:_
| not (C.isUpper x) -> False
| otherwise -> let mayExt = P.takeExtension s
in case mayExt of
[] -> False
_ : ext -> ext `elem` xs
interestingDir :: FilePath -> Bool
interestingDir p = case p of
[] -> False
x:_
| not (C.isUpper x) -> False
| otherwise -> not $ '.' `elem` p
modules
:: FilePath
-> IO [String]
modules = modulesWithExtensions fileExtensions
modulesWithExtensions
:: [String]
-> FilePath
-> IO [String]
modulesWithExtensions exts start
= fmap (map modName . sortBy sorter . map reverse)
$ modulesInDir exts start []
where
modName = concat . intersperse "."
sorter :: [String] -> [String] -> Ordering
sorter x y = mconcat (zipWith compare x y) <> compare lenX lenY
where
(lenX, lenY) = (length x, length y)
modulesInDir
:: [String]
-> FilePath
-> [FilePath]
-> IO [[String]]
modulesInDir exts start dirs = do
cs <- D.getDirectoryContents (start </> P.joinPath (reverse dirs))
fmap concat . mapM (processFile exts start dirs) $ cs
processFile
:: [String]
-> FilePath
-> [FilePath]
-> FilePath
-> IO [[String]]
processFile exts start dirs this = do
isDir <- D.doesDirectoryExist
(start </> (P.joinPath . reverse $ this : dirs))
if isDir
then if interestingDir this
then modulesInDir exts start (this : dirs)
else return []
else return $ if interestingFile exts this
then [(P.dropExtension this : dirs)]
else []
renderString
:: String
-> ZonedTime
-> V.Version
-> A.Cabal
-> String
renderString nm zt ver cbl = hdr ++ R.cabal cbl
where
hdr = unlines $
[ "-- This Cabal file generated using the Cartel library."
, "-- Cartel is available at:"
, "-- http://www.github.com/massysett/cartel"
, "--"
] ++ case nm of
[] -> []
_ -> ["-- Script name used to generate: " ++ nm]
++
[ "-- Generated on: " ++ show zt
, "-- Cartel library version: " ++ showVer
]
showVer = concat
. intersperse "."
. map show
. V.versionBranch
$ ver
render
:: String
-> A.Cabal
-> IO ()
render nm cbl = do
zt <- getZonedTime
IO.hSetBinaryMode IO.stdout False
IO.hSetEncoding IO.stdout IO.utf8
putStr $ renderString nm zt Paths_cartel.version cbl