module Cartel.Render where
import qualified Cartel.Ast as A
import Data.List (intersperse)
(<+>) :: String -> String -> String
l <+> r
| null l = r
| null r = l
| otherwise = l ++ " " ++ r
vsep :: [String] -> String
vsep = foldr f ""
where
f s acc
| null acc = s
| null s = acc
| otherwise = s ++ "\n" ++ acc
indentAmt :: Int
indentAmt = 2
indent :: Int -> String -> String
indent i s = replicate (i * indentAmt) ' ' ++ s ++ "\n"
indentList :: Int -> [String] -> String
indentList i ls = case ls of
[] -> ""
x:[] -> line1 x
x:xs -> concat $ line1 x : map lineRest xs
where
line1 s = replicate (i * indentAmt + 2) ' ' ++ s ++ "\n"
lineRest s = replicate (i * indentAmt) ' ' ++ ", " ++ s ++ "\n"
labeled
:: Int
-> String
-> String
-> String
labeled i l t
| null t = ""
| otherwise = indent i (l ++ ": " ++ t)
labeledList
:: Int
-> String
-> [String]
-> String
labeledList i l ts
| null ts = ""
| otherwise = indent i (l ++ ":") ++ indentList (i + 1) ts
version :: A.Version -> String
version = concat . intersperse "." . map show . A.unVersion
license :: A.License -> String
license = show
buildType :: A.BuildType -> String
buildType = show
compiler :: A.Compiler -> String
compiler = show
comparison :: Ordering -> String
comparison a = case a of
LT -> "<"
GT -> ">"
EQ -> "=="
constraint :: A.Constraint -> String
constraint a = comparison (A.csComparison a) <+>
version (A.csVersion a)
logical :: A.Logical -> String
logical a = case a of
A.Or -> "||"
A.And -> "&&"
constrTree :: A.ConstrTree -> String
constrTree a = case a of
A.Leaf c -> constraint c
A.Branch c l r -> "(" ++ constrTree l
<+> logical c <+> constrTree r ++ ")"
cabalVersion :: (Int, Int) -> String
cabalVersion (a, b) = ">= " ++ show a ++ "." ++ show b
description :: [String] -> String
description ls
| null ls = ""
| otherwise = concatMap f ls
where
f s
| null s = " .\n"
| otherwise = " " ++ s ++ "\n"
testedWith :: [(A.Compiler, A.ConstrTree)] -> String
testedWith = concat . intersperse ", " . map f
where
f (cmp, cst) = compiler cmp <+> constrTree cst
properties :: A.Properties -> String
properties p
= lbl "name" (A.prName p)
++ lbl "version" (version . A.prVersion $ p)
++ lbl "cabal-version" (cabalVersion . A.prCabalVersion $ p)
++ lbl "build-type" (buildType . A.prBuildType $ p)
++ lbl "license" (license . A.prLicense $ p)
++ lbl "license-file" (A.prLicenseFile p)
++ lst "license-files" (A.prLicenseFiles p)
++ lbl "copyright" (A.prCopyright p)
++ lbl "author" (A.prAuthor p)
++ lbl "maintainer" (A.prMaintainer p)
++ lbl "stability" (A.prStability p)
++ lbl "homepage" (A.prHomepage p)
++ lbl "bug-reports" (A.prBugReports p)
++ lbl "package-url" (A.prPackageUrl p)
++ lbl "synopsis" (A.prSynopsis p)
++ let desc = description . A.prDescription $ p
lbld | null desc = ""
| otherwise = "description:\n" ++ desc
in lbld
++ lbl "category" (A.prCategory p)
++ lbl "tested-with" (testedWith . A.prTestedWith $ p)
++ lst "data-files" (A.prDataFiles p)
++ lbl "data-dir" (A.prDataDir p)
++ lst "extra-source-files" (A.prExtraSourceFiles p)
++ lst "extra-doc-files" (A.prExtraDocFiles p)
++ lst "extra-tmp-files" (A.prExtraTmpFiles p)
where
lbl = labeled 0
lst = labeledList 0
class Field a where
field :: Int -> a -> String
instance Field A.LibraryField where
field i f = case f of
A.LibExposedModules xs -> labeledList i "exposed-modules" xs
A.LibExposed b -> labeled i "exposed" (show b)
A.LibConditional b -> condBlock i b
A.LibInfo b -> field i b
library :: A.Library -> String
library (A.Library l) = "Library\n"
++ concatMap (field 1) l
instance Field A.ExecutableField where
field i f = case f of
A.ExeMainIs s -> labeled i "main-is" s
A.ExeConditional b -> condBlock i b
A.ExeInfo b -> field i b
executable :: A.Executable -> String
executable (A.Executable n fs) =
"Executable " ++ n ++ "\n"
++ concatMap (field 1) fs
testSuiteType :: A.TestSuiteType -> String
testSuiteType t = case t of
A.ExitcodeStdio -> "exitcode-stdio-1.0"
A.Detailed -> "detailed-1.0"
instance Field A.TestSuiteField where
field i t = case t of
A.TestType a -> labeled i "type" (testSuiteType a)
A.TestMainIs s -> labeled i "main-is" s
A.TestModule s -> labeled i "test-module" s
A.TestConditional b -> condBlock i b
A.TestInfo b -> field i b
testSuite :: A.TestSuite -> String
testSuite (A.TestSuite n fs) =
"Test-Suite " ++ n ++ "\n"
++ concatMap (field 1) fs
instance Field A.BenchmarkField where
field i b = case b of
A.BenchmarkConditional s -> condBlock i s
A.BenchmarkInfo a -> field i a
benchmark :: A.Benchmark -> String
benchmark (A.Benchmark n mi fs) =
"Benchmark " ++ n ++ "\n"
++ labeled 1 "main-is" mi
++ labeled 1 "interface" "exitcode-stdio-1.0"
++ concatMap (field 1) fs
condBlock :: Field a => Int -> A.CondBlock a -> String
condBlock i b =
indent i ("if " ++ condTree (A.condIf b))
++ concatMap (field (i + 1)) (A.ifTrue b)
++ elses
where
elses | null (A.ifElse b) = ""
| otherwise = indent i "else"
++ concatMap (field (i + 1)) (A.ifElse b)
package :: A.Package -> String
package p =
A.packName p <+> maybe "" constrTree (A.packConstraints p)
language :: A.Language -> String
language = show
instance Field A.BuildInfoField where
field i fld = case fld of
A.BuildDepends ps ->
labeledList i "build-depends" . map package $ ps
A.OtherModules ls ->
labeledList i "other-modules" ls
A.HsSourceDirs ls ->
labeledList i "hs-source-dirs" ls
A.Extensions ls ->
labeledList i "extensions" ls
A.BuildTools ps ->
labeledList i "build-tools" . map package $ ps
A.Buildable b ->
labeled i "buildable" . show $ b
A.GHCOptions ps ->
labeledList i "ghc-options" ps
A.GHCProfOptions ps ->
labeledList i "ghc-prof-options" ps
A.GHCSharedOptions ps ->
labeledList i "ghc-shared-options" ps
A.HugsOptions ps ->
labeledList i "hugs-options" ps
A.Nhc98Options ps ->
labeledList i "nhc98-options" ps
A.Includes ps ->
labeledList i "includes" ps
A.InstallIncludes ps ->
labeledList i "install-includes" ps
A.IncludeDirs ps ->
labeledList i "include-dirs" ps
A.CSources ps ->
labeledList i "c-sources" ps
A.ExtraLibraries ps ->
labeledList i "extra-libraries" ps
A.ExtraLibDirs ps ->
labeledList i "extra-lib-dirs" ps
A.CCOptions ps ->
labeledList i "cc-options" ps
A.CPPOptions ps ->
labeledList i "cpp-options" ps
A.LDOptions ps ->
labeledList i "ld-options" ps
A.PkgConfigDepends ps ->
labeledList i "pkgconfig-depends" . map package $ ps
A.Frameworks ps ->
labeledList i "frameworks" ps
A.DefaultLanguage l
-> labeled i "default-language" . language $ l
condition :: A.Condition -> String
condition a = case a of
A.OS s -> "os(" ++ s ++ ")"
A.Arch s -> "arch(" ++ s ++ ")"
A.Impl (cmp, mayC) -> "impl(" ++ s ++ ")"
where
s = compiler cmp <+> cond
cond = maybe "" constrTree mayC
A.CFlag f -> "flag(" ++ f ++ ")"
A.CTrue -> "true"
A.CFalse -> "false"
condTree :: A.CondTree -> String
condTree a = case a of
A.CLeaf c -> condition c
A.CBranch b l r -> "(" ++ condTree l <+> logical b <+> condTree r
++ ")"
A.CNegate t -> "!(" ++ condTree t ++ ")"
flag :: A.Flag -> String
flag (A.Flag nm desc dflt man) = concat (line1:lineRest)
where
line1 = "Flag " ++ nm ++ "\n"
lineRest = map (indent 1)
[ "Description: " ++ desc
, "Default: " ++ show dflt
, "Manual: " ++ show man
]
vcs :: A.Vcs -> String
vcs a = case a of
A.Darcs -> "darcs"
A.Git -> "git"
A.Svn -> "svn"
A.Cvs _ -> "cvs"
A.Mercurial -> "mercurial"
A.Bazaar -> "bazaar"
A.ArchVcs -> "arch"
A.Monotone -> "monotone"
repoKind :: A.RepoKind -> String
repoKind a = case a of
A.Head -> "head"
A.This -> "this"
repository :: A.Repository -> String
repository r =
"source-repository " ++ repoKind (A.repoKind r) ++ "\n"
++ lbl "type" (vcs . A.repoVcs $ r)
++ lbl "location" (A.repoLocation r)
++ lbl "module" mdle
++ lbl "branch" (A.repoBranch r)
++ lbl "tag" (A.repoTag r)
++ lbl "subdir" (A.repoSubdir r)
where
mdle = case A.repoVcs r of
A.Cvs s -> s
_ -> ""
lbl = labeled 1
cabal :: A.Cabal -> String
cabal d = vsep
[ properties . A.cProperties $ d
, vsep . map repository . A.cRepositories $ d
, vsep . map flag . A.cFlags $ d
, maybe "" library . A.cLibrary $ d
, vsep . map executable . A.cExecutables $ d
, vsep . map testSuite . A.cTestSuites $ d
, vsep . map benchmark . A.cBenchmarks $ d
]