{-# Language FlexibleContexts #-}
{-# Language OverloadedStrings #-}

module Render.Lib
    ( P(..)
    , renderBlockHead
    , showVersionRange
    , moduleDoc
    , rexpModuleDoc
    , filepath
    , renderTestedWith
    , exeDependencyAsDependency
    , renderDescription
    ) where

import Data.Char
import Data.List.Compat
import Distribution.Compiler
import Distribution.ModuleName
import Distribution.PackageDescription
import Distribution.Pretty
import Distribution.Types.ExeDependency
import Distribution.Types.PackageName
import Distribution.Types.UnqualComponentName
import Distribution.Version
import Prelude.Compat
import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))

import Render.Lib.Haddock (renderDescription)
import Render.Options
import Types.Block

newtype P = P
    { unP :: String
    } deriving (Eq)

instance Ord P where
    compare (P "base") (P "base") = EQ
    compare (P "base") _ = LT
    compare _ (P "base") = GT
    compare (P p1) (P p2) = compare p1 p2

renderTestedWith ts =
    fillSep . punctuate comma <$>
    mapM (\(compiler, vers) -> showVersioned (showCompiler compiler, vers)) ts
  where
    showCompiler (OtherCompiler x) = x
    showCompiler (HaskellSuite x) = x
    showCompiler x = show x

showVersioned :: (String, VersionRange) -> Render Doc
showVersioned (pn, v')
    | v' == anyVersion = pure $ string pn
    | otherwise = fmap (string pn <+>) (showVersionRange v')

showVersionRange r = do
    opts <- ask
    return $
        cataVersionRange fold' $
        (if simplifyVersions opts
             then simplifyVersionRange
             else id)
            r
  where
    fold' AnyVersionF = empty
    fold' (ThisVersionF v) = green "==" <+> dullyellow (string (prettyShow v))
    fold' (LaterVersionF v) = green ">" <+> dullyellow (string (prettyShow v))
    fold' (OrLaterVersionF v) = green ">=" <+> dullyellow (string (prettyShow v))
    fold' (EarlierVersionF v) = green "<" <+> dullyellow (string (prettyShow v))
    fold' (OrEarlierVersionF v) = green "<=" <+> dullyellow (string (prettyShow v))
    fold' (WildcardVersionF v) = green "==" <+> dullyellow (string (prettyShow v) <> ".*")
    fold' (MajorBoundVersionF v) = green "^>=" <+> dullyellow (string (prettyShow v))
    fold' (UnionVersionRangesF a b) = a <+> green "||" <+> b
    fold' (IntersectVersionRangesF a b) = a <+> green "&&" <+> b
    fold' (VersionRangeParensF a) = parens a


filepath :: String -> Doc
filepath x
    | null x = string "\"\""
    | any isSpace x = string $ show x
    | otherwise = string x

moduleDoc = string . intercalate "." . components

rexpModuleDoc (ModuleReexport pkg origname name) =
    maybe empty (\f -> string (unPackageName f) <> colon) pkg <>
    (if origname == name
         then moduleDoc origname
         else moduleDoc origname <+> "as" <+> moduleDoc name)

exeDependencyAsDependency (ExeDependency pkg comp vers) =
    (P $ unPackageName pkg ++ ":" ++ unUnqualComponentName comp, vers)

renderBlockHead (If c) = (dullblue "if" <+>) <$> showPredicate c
renderBlockHead x = pure $ r x
  where
    r CustomSetup = dullgreen "custom-setup"
    r (SourceRepo_ k) = dullgreen "source-repository" <+> showKind k
      where
        showKind RepoHead = "head"
        showKind RepoThis = "this"
        showKind (RepoKindUnknown y) = string y
    r (Library_ Nothing) = dullgreen "library"
    r (Library_ (Just l)) = dullgreen "library" <+> string l
    r (ForeignLib_ l) = dullgreen "foreign-library" <+> string l
    r (Exe_ e) = dullgreen "executable" <+> string e
    r (TestSuite_ t) = dullgreen "test-suite" <+> string t
    r (Benchmark_ b) = dullgreen "benchmark" <+> string b
    r (Flag_ s) = dullgreen "flag" <+> string s
    r Else = dullblue "else"
    r _ = error "unreachable"

showPredicate :: Condition ConfVar -> Render Doc
showPredicate (Var x) = showVar x
showPredicate (CNot p) = fmap (dullmagenta (string "!") <>) (maybeParens p)
showPredicate (CAnd a b) =
    liftM2 (\x y -> x <+> dullblue (string "&&") <+> y) (maybeParens a) (maybeParens b)
showPredicate (COr a b) =
    liftM2 (\x y -> x <+> dullblue (string "||") <+> y) (maybeParens a) (maybeParens b)
showPredicate (Lit b) = pure $ string $ show b

maybeParens p =
    case p of
        Lit {} -> showPredicate p
        Var {} -> showPredicate p
        CNot {} -> showPredicate p
        _ -> parens <$> showPredicate p

showVar :: ConfVar -> Render Doc
showVar (Impl compiler vers) = do
    v <- showVersioned (prettyShow compiler, vers)
    pure $ dullgreen $ string "impl" <> parens (dullblue v)
showVar (Flag f) =
    pure $ dullgreen $ string "flag" <> parens (dullblue $ string (unFlagName f))
showVar (OS w) =
    pure $ dullgreen $ string "os" <> parens (dullblue $ string $ map toLower $ show w)
showVar (Arch a) =
    pure $ dullgreen $ string "arch" <> parens (dullblue $ string $ map toLower $ show a)