module Cartel.Render where
import Cartel.Ast
import Cartel.Betsy
import Control.Monad.Trans.Reader
import Data.Char (isLetter, isDigit)
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
labeled
:: String
-> String
-> String
labeled lbl val
| null val = ""
| otherwise = lbl ++ ": " ++ val
labeledIndented
:: String
-> String
-> Reader Level String
labeledIndented lbl val
| null val = return ""
| otherwise = indent (lbl ++ ": " ++ val ++ "\n")
type Level = Int
addLevel :: Reader Level a -> Reader Level a
addLevel = withReader succ
indent :: String -> Reader Level String
indent s = fmap fmt ask
where
fmt lvl = replicate (lvl * indentAmt) ' ' ++ s
commaSeparated :: [String] -> [String]
commaSeparated [] = []
commaSeparated (x:xs)
= (replicate 2 ' ' ++ x) : map (", " ++) xs
indentConcat
:: [String]
-> Reader Level String
indentConcat ss = do
ss' <- mapM indent ss
return $ concatMap (++ "\n") ss'
labeledList
:: String
-> [String]
-> Reader Level String
labeledList _ [] = return ""
labeledList lbl xs
= (++)
<$> indent (lbl ++ ":\n")
<*> addLevel (indentConcat xs)
escaper :: String -> String
escaper s
| null s = s
| any ((> 0x7f) . fromEnum) s = show s
| all good s = s
| otherwise = show s
where
good x = any ($ x)
[ isLetter, isDigit, (== '-'), (== '_'), (== '.') ]
class RenderableIndented a where
renderIndented :: a -> Reader Level String
renderNoIndent :: RenderableIndented a => a -> String
renderNoIndent = flip runReader 0 . renderIndented
class Renderable a where
render :: a -> String
instance Renderable a => Renderable (Maybe a) where
render = maybe "" render
instance RenderableIndented Error where
renderIndented e = fmap concat . mapM indent $
"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 VersionComp where
render c = case c of
LessThan (OrEqualTo True) -> "<="
GreaterThan (OrEqualTo True) -> ">="
LessThan (OrEqualTo False) -> "<"
GreaterThan (OrEqualTo False) -> ">"
EqualTo -> "=="
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 = go (0 :: Int)
where
go lvl tree = case tree of
Leaf o v -> render o <+> render v
Branch c l r -> parens $ next l <+> render c <+> next r
where
next = go (succ lvl)
parens x | lvl == 0 = x
| otherwise = '(' : x ++ ")"
data CabalVersion = CabalVersion Word Word
deriving (Eq, Ord, Show)
instance Renderable CabalVersion where
render (CabalVersion a b) = ">= " ++ show a ++ "." ++ show b
instance Renderable (Compiler, Constraint) where
render (cmp, cst) = render cmp <+> render cst
instance Renderable FlagName where
render nm = flagNameHead nm : flagNameTail nm
instance RenderableIndented FlagOpts where
renderIndented (FlagOpts desc df man) =
fmap concat . mapM (uncurry labeledIndented)
$ [ ("description", desc)
, ("default", render df)
, ("manual", render man)
]
instance RenderableIndented Flag where
renderIndented (Flag nm opts) =
(++)
<$> indent ("Flag " ++ render nm ++ "\n")
<*> addLevel (renderIndented opts)
newtype Flags = Flags [Flag]
deriving (Eq, Ord, Show)
instance RenderableIndented Flags where
renderIndented (Flags fs) = fmap vsep . mapM renderIndented $ fs
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 r =
(++)
<$> indent ("source-repository " ++ render (repoKind r) ++ "\n")
<*> addLevel (fmap concat . mapM (uncurry labeledIndented) $ fields)
where
fields =
[ ("type", (render $ repoVcs r))
, ("location", (repoLocation r))
, ("module", mdle)
, ("branch", (repoBranch r))
, ("tag", (repoTag r))
, ("subdir", (repoSubdir r))
]
mdle = case repoVcs r of
Just (Cvs s) -> s
_ -> ""
instance Renderable Package where
render (Package nm cs)
= escaper nm <+> render cs
instance Renderable Bool where
render = show
instance Renderable DefaultLanguage where
render = show
instance RenderableIndented BuildInfoField where
renderIndented fld = case fld of
BuildDepends ls -> renCommas "build-depends" ls
OtherModules ls -> labeledList "other-modules" ls
HsSourceDirs ls -> labeledList "hs-source-dirs" (fmap escaper ls)
Extensions ls -> labeledList "extensions" ls
DefaultExtensions ls -> labeledList "default-extensions" ls
OtherExtensions ls -> labeledList "other-extensions" ls
BuildTools ls -> renCommas "build-tools" ls
Buildable b -> labeledIndented "buildable" (render b)
GHCOptions ls -> labeledList "ghc-options" ls
GHCProfOptions ls -> labeledList "ghc-prof-options" ls
GHCSharedOptions ls -> labeledList "ghc-shared-options" ls
HugsOptions ls -> labeledList "hugs-options" ls
Nhc98Options ls -> labeledList "nhc98-options" ls
Includes ls -> labeledList "includes" (fmap escaper ls)
InstallIncludes ls -> labeledList "install-includes" (fmap escaper ls)
IncludeDirs ls -> labeledList "include-dirs" (fmap escaper ls)
CSources ls -> labeledList "c-sources" (fmap escaper ls)
ExtraLibraries ls -> labeledList "extra-libraries" (fmap escaper ls)
ExtraLibDirs ls -> labeledList "extra-lib-dirs" (fmap escaper ls)
CCOptions ls -> labeledList "cc-options" ls
CPPOptions ls -> labeledList "cpp-options" ls
LDOptions ls -> labeledList "ld-options" ls
PkgConfigDepends ls -> renCommas "pkgconfig-depends" ls
Frameworks ls -> labeledList "frameworks" (fmap escaper ls)
DefaultLanguage df -> labeledIndented "default-language" (render df)
where
renCommas lbl ls
| null ls = return ""
| otherwise = (++) <$> indent (lbl ++ ":\n")
<*> addLevel ( indentConcat . commaSeparated
. fmap render $ ls)
instance Renderable Condition where
render = go (0 :: Int)
where
go lvl tree = case tree of
CLeaf c -> render c
CBranch c l r -> parens $ next l
<+> render c <+> next r
CNegate t -> "!(" ++ render t ++ ")"
where
next = go (succ lvl)
parens x | lvl == 0 = x
| otherwise = '(' : x ++ ")"
instance RenderableIndented a => RenderableIndented (CondBlock a) where
renderIndented (CondBlock cond (y1, ys) nos) = fmap concat . sequence $
[ indent ("if " ++ render cond ++ "\n")
, addLevel (renderIndented y1)
, fmap concat (addLevel (mapM renderIndented ys))
, if null nos
then return ""
else (++) <$> indent "else\n"
<*> addLevel (fmap concat (mapM renderIndented nos))
]
instance RenderableIndented LibraryField where
renderIndented fld = case fld of
ExposedModules ls -> labeledList "exposed-modules" ls
Exposed b -> labeledIndented "exposed" (render b)
LibConditional b -> renderIndented b
LibInfo b -> renderIndented b
instance RenderableIndented ExecutableField where
renderIndented fld = case fld of
ExeConditional b -> renderIndented b
ExeInfo b -> renderIndented b
ExeMainIs m -> labeledIndented "main-is" (escaper m)
instance RenderableIndented Executable where
renderIndented (Executable nm flds) = (++)
<$> indent ("Executable " ++ nm ++ "\n")
<*> addLevel (fmap concat . mapM renderIndented $ flds)
instance Renderable TestSuiteType where
render ExitcodeStdio = "exitcode-stdio-1.0"
render Detailed = "detailed-0.9"
instance RenderableIndented TestSuiteField where
renderIndented fld = case fld of
TestConditional c -> renderIndented c
TestInfo b -> renderIndented b
TestMainIs m -> labeledIndented "main-is" (escaper m)
TestSuiteType t -> labeledIndented "type" (render t)
TestModule m -> labeledIndented "test-module" (escaper m)
instance RenderableIndented TestSuite where
renderIndented (TestSuite n flds) = (++)
<$> indent ("Test-Suite " ++ n ++ "\n")
<*> addLevel (fmap concat . mapM renderIndented $ flds)
instance Renderable BenchmarkType where
render BenchExitCode = "exitcode-stdio-1.0"
instance RenderableIndented BenchmarkField where
renderIndented (BenchmarkConditional b) = renderIndented b
renderIndented (BenchmarkInfo b) = renderIndented b
renderIndented (BenchmarkMainIs b) = labeledIndented "main-is" (escaper b)
renderIndented (BenchmarkType b) = labeledIndented "type" (render b)
instance RenderableIndented Benchmark where
renderIndented (Benchmark nm flds) = (++)
<$> indent ("Benchmark " ++ nm ++ "\n")
<*> addLevel (fmap concat . mapM renderIndented $ flds)
instance RenderableIndented Properties where
renderIndented c = fmap concat . sequence $
[ labeledIndented "name" (name c)
, labeledIndented "version" (render (version c))
, labeledIndented "cabal-version"
(maybe "" (render . uncurry CabalVersion) . cabalVersion $ c)
, labeledIndented "license" (maybe "" render . license $ c)
, labeledIndented "license-file" (escaper $ licenseFile c)
, labeledList "license-files" . fmap escaper . licenseFiles $ c
, labeledIndented "build-type" (maybe "" render . buildType $ c)
, labeledIndented "copyright" (copyright c)
, labeledIndented "author" (author c)
, labeledIndented "maintainer" (maintainer c)
, labeledIndented "stability" (stability c)
, labeledIndented "homepage" (homepage c)
, labeledIndented "bug-reports" (bugReports c)
, labeledIndented "package-url" (packageUrl c)
, labeledIndented "synopsis" (synopsis c)
, labeledList "description"
. fmap (\x -> if null x then "." else x)
. description $ c
, labeledIndented "category" (category c)
, labeledList "tested-with" (fmap render . testedWith $ c)
, labeledList "data-files" (map escaper . dataFiles $ c)
, labeledIndented "data-dir" (escaper $ dataDir c)
, labeledList "extra-source-files" (fmap escaper $ extraSourceFiles c)
, labeledList "extra-doc-files" (fmap escaper $ extraDocFiles c)
, labeledList "extra-tmp-files" (fmap escaper $ extraTmpFiles c)
]
renLibrary :: [LibraryField] -> Reader Level String
renLibrary [] = return ""
renLibrary xs = (++) <$> indent "Library\n"
<*> addLevel (fmap concat . mapM renderIndented $ xs)
instance RenderableIndented Section where
renderIndented s = case s of
SecRepo x -> renderIndented x
SecExe x -> renderIndented x
SecTest x -> renderIndented x
SecBench x -> renderIndented x
instance RenderableIndented Cabal where
renderIndented (Cabal prop lib secs fls)
= fmap vsep . sequence
$ renderIndented prop
: renLibrary lib
: map renderIndented secs
++ map renderIndented fls