-- | Functions to render the data types in "Cartel.Ast".  You
-- shouldn't need anything from this module; the main rendering
-- function is also exported from "Cartel".
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
  -- ^ Indentation
  -> String
  -- ^ Label
  -> String
  -- ^ Text
  -> String
  -- ^ Result, with a newline.  Empty if the text to show is also
  -- empty.
labeled i l t
  | null t = ""
  | otherwise = indent i (l ++ ": " ++ t)

labeledList
  :: Int
  -- ^ Indentation
  -> String
  -- ^ Label
  -> [String]
  -- ^ List
  -> String
  -- ^ Result, with newlines.  Empty if the list is empty.
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
  ]