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

import Cartel.Ast
import Cartel.Betsy
import Control.Monad.Trans.Reader
import Data.Char (isLetter, isDigit)
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

labeled
  :: String
  -- ^ Label
  -> String
  -- ^ Value
  -> String
  -- ^ Empty if value is empty; otherwise, the label with a colon and
  -- space appended, and the value
labeled lbl val
  | null val = ""
  | otherwise = lbl ++ ": " ++ val

labeledIndented
  :: String
  -- ^ Label
  -> String
  -- ^ Value
  -> Reader Level String
  -- ^ Empty if value is empty; otherwise, the label with a colon and
  -- space appended, and the value, and a newline
labeledIndented lbl val
  | null val = return ""
  | otherwise = indent (lbl ++ ": " ++ val ++ "\n")

-- | Indentation level
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

-- Rendering Lists
--
-- General steps to render lists of items (e.g. build depends,
-- ghc-options, etc):
--
-- 1. Transform list of items into list of String (simply use fmap)
--
-- 2. Prepend comma separators, if applicable
--
-- 3. Prepend indentation, append newlines, concat
--
-- 4. Prepend indented label if result is not empty

-- | Adds comma separators to a list.
commaSeparated :: [String] -> [String]
commaSeparated [] = []
commaSeparated (x:xs)
  = (replicate 2 ' ' ++ x) : map (", " ++) xs

-- | Indents list, adds newlines, and concats.
indentConcat
  :: [String]
  -> Reader Level String
indentConcat ss = do
  ss' <- mapM indent ss
  return $ concatMap (++ "\n") ss'

labeledList
  :: String
  -- ^ Label
  -> [String]
  -- ^ List of items to show; if empty, return an empty string
  -> Reader Level String
labeledList _ [] = return ""
labeledList lbl xs
  = (++)
  <$> indent (lbl ++ ":\n")
  <*> addLevel (indentConcat xs)

-- | Renders a string using 'show', but only if it is both non-empty
-- and contains characters that might be problematic.  For now,
-- \"might be problematic\" simply means any character that is either
-- above Unicode code point 7F or is not a letter, digit, hyphen,
-- period, or underscore.
--
-- If the string is empty, or if it contains only non-problematic
-- characters, returns the string as-is.
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, (== '-'), (== '_'), (== '.') ]

-- | 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 :: a -> Reader Level String

renderNoIndent :: RenderableIndented a => a -> String
renderNoIndent = flip runReader 0 . renderIndented


-- | Render an item.  The rendered text shall contain no newlines.
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

-- | Contains many lists of items.  Items that might contain spaces or
-- other troublesome characters are rendered quoted.  In particular,
-- this includes filenames.  Items that are highly unlikely to contain
-- troublesome characters (such as compiler options) are not quoted.
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