{-# LANGUAGE FlexibleInstances #-}
-- | Reducing a Cartel AST to flat Cabal text; essentially a
-- pretty-printer.
module Cartel.Render where

import Data.Word
import Cartel.Betsy
import Cartel.Ast
import Data.List (intersperse)

-- | Separate two strings with a space, but only if both strings are
-- not empty.
(<+>) :: String -> String -> String
l <+> r
  | null l = r
  | null r = l
  | otherwise = l ++ " " ++ r

-- | Concatenate several vertically.  Unlike 'unlines', does not add a
-- newline when an item is 'null' or when the accumulator is 'null'.
vsep :: [String] -> String
vsep = foldr f ""
  where
    f s acc
      | null acc = s
      | null s = acc
      | otherwise = s ++ "\n" ++ acc

indentAmt :: Int
indentAmt = 2

-- | Indents a line of text; adds a newline at the end.
indent :: Int -> String -> String
indent i s = replicate (i * indentAmt) ' ' ++ s ++ "\n"

-- | Creates a comma-separated indented representation for a list of
-- items, such as a list of filenames or modules.  Each line ends with
-- a newline.
indentList
  :: Renderable a
  => Int
  -- ^ Indentation level.
  -> [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
  -- ^ Indentation
  -> String
  -- ^ Label
  -> a
  -- ^ Text
  -> String
  -- ^ Result, with a newline.  Empty if the text to show is also
  -- empty.
labeled i l t
  | null txt = ""
  | otherwise = indent i (l ++ ": " ++ txt)
  where
    txt = render t

labeledList
  :: Renderable a
  => Int
  -- ^ Indentation
  -> String
  -- ^ Label
  -> [a]
  -- ^ 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

-- | Render an item.  The rendered text shall contain no newlines.
class Renderable a where
  render :: a -> String

instance Renderable String where
  render = id

instance Renderable a => Renderable (Maybe a) where
  render = maybe "" render

-- | Render an item.  The rendered text must contain a newline at the
-- end of each line and must end with a newline.  The leftmost line of
-- the rendered text shall be indented by the given number of
-- indentation levels (the number of spaces in each level is set by
-- 'indentAmt').
--
-- If there are no lines to indent, return an empty string.
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
      -- don't do @lst = labeledList i@ - monomorphism restriction
      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