module Cartel.Render where
import Data.Word
import Cartel.Betsy
import Cartel.Ast
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
:: Renderable a
=> Int
-> [a]
-> 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) ' ' ++ render s ++ "\n"
lineRest s = replicate (i * indentAmt) ' '
++ ", " ++ render s ++ "\n"
labeled
:: Renderable a
=> Int
-> String
-> a
-> String
labeled i l t
| null txt = ""
| otherwise = indent i (l ++ ": " ++ txt)
where
txt = render t
labeledList
:: Renderable a
=> Int
-> String
-> [a]
-> String
labeledList i l ts
| null ts = ""
| otherwise = indent i (l ++ ":") ++ indentList (i + 1) ts
class Renderable a where
render :: a -> String
instance Renderable String where
render = id
instance Renderable a => Renderable (Maybe a) where
render = maybe "" render
class RenderableIndented a where
renderIndented :: Int -> a -> String
instance RenderableIndented Error where
renderIndented i e = concatMap (indent i) $
"Error while attempting to generate Cabal file from Cartel source."
: case e of
DuplicateFlag nm ->
["Duplicated flag: " ++ (flagNameHead nm : flagNameTail nm)]
Failed s -> ["The \"fail\" function was invoked: " ++ s]
EmptyFlagName -> ["Empty flag name"]
instance Renderable BuildType where
render = show
instance Renderable License where
render = show
instance Renderable Compiler where
render = show
instance Renderable Ordering where
render LT = "<"
render GT = ">"
render EQ = "=="
instance Renderable Version where
render = concat . intersperse "." . map show
instance Renderable Constraint where
render AnyVersion = ""
render (Constrained t) = render t
instance Renderable Logical where
render Or = "||"
render And = "&&"
instance Renderable ConstrTree where
render (Leaf o v) = render o <+> render v
render (Branch c l r) = "(" ++ render l
<+> render c <+> render r ++ ")"
instance Renderable (Word, Word) where
render (a, b) = ">= " ++ show a ++ "." ++ show b
newtype Description = Description [String]
deriving (Eq, Ord, Show)
instance RenderableIndented Description where
renderIndented i (Description ls)
| null ls = ""
| otherwise = concatMap f ls
where
f s
| null s = indent i "."
| otherwise = indent i s
instance Renderable (Compiler, Constraint) where
render (cmp, cst) = render cmp <+> render cst
instance Renderable FlagName where
render nm = flagNameHead nm : flagNameTail nm
instance RenderableIndented (FlagName, FlagOpts) where
renderIndented i (nm, (FlagOpts desc df man)) =
indent i ("Flag " ++ render nm)
++ labeled next "description" desc
++ labeled next "default" df
++ labeled next "manual" man
where
next = i + 1
instance RenderableIndented [(FlagName, FlagOpts)] where
renderIndented i = vsep . map (renderIndented i)
instance Renderable CondLeaf where
render a = case a of
OS s -> "os(" ++ s ++ ")"
Arch s -> "arch(" ++ s ++ ")"
Impl cmp constr -> "impl(" ++ s ++ ")"
where
s = render cmp <+> render constr
CFlag f -> "flag(" ++ render f ++ ")"
CTrue -> "true"
CFalse -> "false"
instance Renderable RepoKind where
render Head = "head"
render This = "this"
instance Renderable Vcs where
render x = case x of
Darcs -> "darcs"
Git -> "git"
Svn -> "svn"
Cvs _ -> "cvs"
Mercurial -> "mercurial"
Bazaar -> "bazaar"
ArchVcs -> "arch"
Monotone -> "monotone"
instance RenderableIndented Repository where
renderIndented i r =
indent i ("source-repository " ++ render (repoKind r))
++ lbl "type" (repoVcs r)
++ lbl "location" (repoLocation r)
++ lbl "module" mdle
++ lbl "branch" (repoBranch r)
++ lbl "tag" (repoTag r)
++ lbl "subdir" (repoSubdir r)
where
mdle = case repoVcs r of
Just (Cvs s) -> s
_ -> ""
lbl x = labeled (i + 1) x
instance Renderable Package where
render (Package nm cs)
= nm <+> render cs
instance Renderable Bool where
render = show
instance Renderable DefaultLanguage where
render = show
instance RenderableIndented BuildInfoField where
renderIndented i fld = case fld of
BuildDepends ls -> lst "build-depends" ls
OtherModules ls -> lst "other-modules" ls
HsSourceDirs ls -> lst "hs-source-dirs" ls
Extensions ls -> lst "extensions" ls
BuildTools ls -> lst "build-tools" ls
Buildable b -> lbl "buildable" b
GHCOptions ls -> lst "ghc-options" ls
GHCProfOptions ls -> lst "ghc-prof-options" ls
GHCSharedOptions ls -> lst "ghc-shared-options" ls
HugsOptions ls -> lst "hugs-options" ls
Nhc98Options ls -> lst "nhc98-options" ls
Includes ls -> lst "includes" ls
InstallIncludes ls -> lst "install-includes" ls
IncludeDirs ls -> lst "include-dirs" ls
CSources ls -> lst "c-sources" ls
ExtraLibraries ls -> lst "extra-libraries" ls
ExtraLibDirs ls -> lst "extra-lib-dirs" ls
CCOptions ls -> lst "cc-options" ls
CPPOptions ls -> lst "cpp-options" ls
LDOptions ls -> lst "ld-options" ls
PkgConfigDepends ls -> lst "pkgconfig-depends" ls
Frameworks ls -> lst "frameworks" ls
DefaultLanguage df -> lbl "default-language" df
where
lst l = labeledList i l
lbl l = labeled i l
instance RenderableIndented LibraryField where
renderIndented i fld = case fld of
ExposedModules ls -> lst "exposed-modules" ls
Exposed b -> lbl "exposed" b
LibConditional b -> renderIndented i b
LibInfo b -> renderIndented i b
where
lst l = labeledList i l
lbl l = labeled i l
instance Renderable Condition where
render tree = case tree of
CLeaf c -> render c
CBranch c l r -> ("(" ++ render l)
<+> render c <+> (render r ++ ")")
CNegate t -> "!(" ++ render t ++ ")"
instance RenderableIndented a => RenderableIndented (CondBlock a) where
renderIndented i (CondBlock cond (y1, ys) nos) =
indent i ("if" <+> render cond)
++ renderIndented (i + 1) y1
++ concatMap (renderIndented (i + 1)) ys
++ elses
where
elses | null nos = ""
| otherwise = indent i "else"
++ concatMap (renderIndented (i + 1)) nos
instance RenderableIndented ExecutableField where
renderIndented i fld = case fld of
ExeConditional b -> renderIndented i b
ExeInfo b -> renderIndented i b
ExeMainIs m -> labeled i "main-is" m
instance RenderableIndented Executable where
renderIndented i (Executable nm flds) =
indent i ("Executable " ++ nm)
++ concatMap (renderIndented next) flds
where
next = i + 1
instance Renderable TestSuiteType where
render ExitcodeStdio = "exitcode-stdio-1.0"
render Detailed = "detailed-0.9"
instance RenderableIndented TestSuiteField where
renderIndented i fld = case fld of
TestConditional c -> renderIndented i c
TestInfo b -> renderIndented i b
TestMainIs m -> labeled i "main-is" m
TestSuiteType t -> labeled i "type" t
TestModule m -> labeled i "test-module" m
instance RenderableIndented TestSuite where
renderIndented i (TestSuite n flds) =
indent i ("Test-Suite " ++ n)
++ concatMap (renderIndented next) flds
where
next = i + 1
instance Renderable BenchmarkType where
render BenchExitCode = "exitcode-stdio-1.0"
instance RenderableIndented BenchmarkField where
renderIndented i (BenchmarkConditional b) = renderIndented i b
renderIndented i (BenchmarkInfo b) = renderIndented i b
renderIndented i (BenchmarkMainIs b) = labeled i "main-is" b
renderIndented i (BenchmarkType b) = labeled i "type" b
instance RenderableIndented Benchmark where
renderIndented i (Benchmark nm flds) =
indent i ("Benchmark " ++ nm)
++ concatMap (renderIndented next) flds
where
next = i + 1
instance RenderableIndented Properties where
renderIndented i c =
lbl "name" (name c)
++ lbl "version" (version c)
++ lbl "cabal-version" (maybe "" render . cabalVersion $ c)
++ lbl "license" (maybe "" render . license $ c)
++ lbl "license-file" (licenseFile c)
++ lst "license-files" (licenseFiles c)
++ lbl "build-type" (maybe "" render . buildType $ c)
++ lbl "copyright" (copyright c)
++ lbl "author" (author c)
++ lbl "maintainer" (maintainer c)
++ lbl "stability" (stability c)
++ lbl "homepage" (homepage c)
++ lbl "bug-reports" (bugReports c)
++ lbl "package-url" (packageUrl c)
++ lbl "synopsis" (synopsis c)
++ indent i "description:"
++ renderIndented (i + 1) (Description . description $ c)
++ lbl "category" (category c)
++ labeledList i "tested-with" (testedWith c)
++ lst "data-files" (dataFiles c)
++ lbl "data-dir" (dataDir c)
++ lst "extra-source-files" (extraSourceFiles c)
++ lst "extra-doc-files" (extraDocFiles c)
++ lst "extra-tmp-files" (extraTmpFiles c)
where
lbl l = labeled i l
lst l = labeledList i l
renLibrary :: Int -> [LibraryField] -> String
renLibrary _ [] = ""
renLibrary lvl xs = indent lvl "Library"
++ concatMap (renderIndented (lvl + 1)) xs
instance RenderableIndented Section where
renderIndented i s = case s of
SecRepo x -> ren x
SecExe x -> ren x
SecTest x -> ren x
SecBench x -> ren x
where
ren x = renderIndented i x
instance RenderableIndented Cabal where
renderIndented i (Cabal prop lib secs)
= vsep $ ren prop
: renLibrary 0 lib
: map ren secs
where
ren x = renderIndented i x