module Cartel.Tools
(
LogicTree(..)
, lt
, gt
, eq
, ltEq
, gtEq
, closedOpen
, apiVersion
, nextBreaking
, nextMajor
, exactly
, Field(..)
, cif
, system
, arch
, impl
, flag
, true
, false
, buildDepends
, otherModules
, hsSourceDirs
, extensions
, buildTools
, buildable
, ghcOptions
, ghcProfOptions
, ghcSharedOptions
, hugsOptions
, nhc98Options
, includes
, installIncludes
, includeDirs
, cSources
, extraLibraries
, extraLibDirs
, ccOptions
, cppOptions
, ldOptions
, pkgConfigDepends
, frameworks
, defaultLanguage
, 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
class LogicTree a where
(&&&) :: a -> a -> a
(|||) :: a -> a -> a
infixr 3 &&&
infixr 2 |||
instance LogicTree A.ConstrTree where
l &&& r = A.Branch A.And l r
l ||| r = A.Branch A.Or l r
instance LogicTree A.CondTree where
l &&& r = A.CBranch A.And l r
l ||| r = A.CBranch A.Or l r
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 []
class Field a where
conditional :: A.CondBlock a -> a
buildInfo :: A.BuildInfoField -> a
instance Field A.LibraryField where
conditional = A.LibConditional
buildInfo = A.LibInfo
instance Field A.ExecutableField where
conditional = A.ExeConditional
buildInfo = A.ExeInfo
instance Field A.TestSuiteField where
conditional = A.TestConditional
buildInfo = A.TestInfo
instance Field A.BenchmarkField where
conditional = A.BenchmarkConditional
buildInfo = A.BenchmarkInfo
buildDepends :: Field a => [A.Package] -> a
buildDepends = buildInfo . A.BuildDepends
otherModules :: Field a => [String] -> a
otherModules = buildInfo . A.OtherModules
hsSourceDirs :: Field a => [String] -> a
hsSourceDirs = buildInfo . A.HsSourceDirs
extensions :: Field a => [String] -> a
extensions = buildInfo . A.Extensions
buildTools :: Field a => [A.Package] -> a
buildTools = buildInfo . A.BuildTools
buildable :: Field a => Bool -> a
buildable = buildInfo . A.Buildable
ghcOptions :: Field a => [String] -> a
ghcOptions = buildInfo . A.GHCOptions
ghcProfOptions :: Field a => [String] -> a
ghcProfOptions = buildInfo . A.GHCProfOptions
ghcSharedOptions :: Field a => [String] -> a
ghcSharedOptions = buildInfo . A.GHCSharedOptions
hugsOptions :: Field a => [String] -> a
hugsOptions = buildInfo . A.HugsOptions
nhc98Options :: Field a => [String] -> a
nhc98Options = buildInfo . A.Nhc98Options
includes :: Field a => [String] -> a
includes = buildInfo . A.Includes
installIncludes :: Field a => [String] -> a
installIncludes = buildInfo . A.InstallIncludes
includeDirs :: Field a => [String] -> a
includeDirs = buildInfo . A.IncludeDirs
cSources :: Field a => [String] -> a
cSources = buildInfo . A.CSources
extraLibraries :: Field a => [String] -> a
extraLibraries = buildInfo . A.ExtraLibraries
extraLibDirs :: Field a => [String] -> a
extraLibDirs = buildInfo . A.ExtraLibDirs
ccOptions :: Field a => [String] -> a
ccOptions = buildInfo . A.CCOptions
cppOptions :: Field a => [String] -> a
cppOptions = buildInfo . A.CPPOptions
ldOptions :: Field a => [String] -> a
ldOptions = buildInfo . A.LDOptions
pkgConfigDepends :: Field a => [A.Package] -> a
pkgConfigDepends = buildInfo . A.PkgConfigDepends
frameworks :: Field a => [String] -> a
frameworks = buildInfo . A.Frameworks
defaultLanguage :: Field a => A.Language -> a
defaultLanguage = buildInfo . A.DefaultLanguage
cif
:: Field a
=> A.CondTree
-> [a]
-> [a]
-> a
cif tree ifTrue ifFalse =
conditional $ A.CondBlock tree ifTrue ifFalse
system :: String -> A.CondTree
system = A.CLeaf . A.OS
arch :: String -> A.CondTree
arch = A.CLeaf . A.Arch
impl :: A.Compiler -> Maybe A.ConstrTree -> A.CondTree
impl cm cn = A.CLeaf $ A.Impl (cm, cn)
flag :: String -> A.CondTree
flag = A.CLeaf . A.CFlag
true :: A.CondTree
true = A.CLeaf A.CTrue
false :: A.CondTree
false = A.CLeaf A.CFalse
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