Lib.hs

{-# 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           Data.Monoid.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)