{-# #-}

{- |
  Module      :  Lighttpd.Conf.Ppr
  Copyright   :  (c) Matt Morrow 2008
  License     :  BSD3

  Maintainer  :  Matt Morrow <mjm2002@gmail.com>
  Stability   :  unstable
  Portability :  portable
-}

module Lighttpd.Conf.Ppr (
    Ppr(..)
  , pprField
  , PprMode(..)
  , pprWithMode
  , module Text.PrettyPrint.HughesPJ
) where

import Lighttpd.Conf.Syntax
import Text.PrettyPrint.HughesPJ
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B


-----------------------------------------------------------------------------

class Ppr a where
  ppr  :: a -> Doc
  pprs :: [a] -> Doc
  pprs = vcat . fmap ppr


data PprMode
  = Compact
  | Spaced
  deriving (Eq,Ord,Show,Read)

pprWithMode :: PprMode -> Config -> Doc
pprWithMode Compact c = ppr c
pprWithMode Spaced (Config es) =
  vcat . punctuate (text "\n")
    . fmap ppr $ es

-----------------------------------------------------------------------------

instance Ppr Config where
  ppr (Config es) = vcat . fmap ppr $ es


instance Ppr String where ppr = dQText
instance Ppr ByteString where ppr = dQText . B.unpack
instance Ppr Int where ppr = int

instance Ppr Name where
  ppr (Name a) = text (B.unpack a)

instance Ppr QName where
  ppr (QName a b) = ppr a <> dot <> ppr b


instance Ppr Exp where
  ppr (CommentE s)    = text "#" <> text (B.unpack s)
  ppr (GlobalCxtE es) = text "global" <+> text "{"
                          $+$ nest 2 (pprs es)
                            $+$ text "}"
  ppr (OptionE qn v)  = ppr qn <+> text "=" <+> ppr v
  ppr (MergeE qn v)   = ppr qn <+> text "+=" <+> ppr v
  ppr (IncludeE i)    = ppr i
  ppr (CondE c es elses)    = ppr c <+> text "{"
                                $+$ nest 2 (pprs es)
                                  $+$ text "}"
                                    $+$ pprs elses

instance Ppr CondElse where
  ppr (CondElse c es) = text "else"
                          <+> ppr c <+> text "{"
                            $+$ nest 2 (pprs es)
                              $+$ text "}"

instance Ppr Val where
  ppr (VarV qn) = ppr qn
  ppr (StringV a) = ppr a
  ppr (IntegerV a) = ppr a
  ppr (BooleanV a) = ppr a
  ppr (SpliceV a) =
    text "$" <>
      text (B.unpack a)
  ppr (ArrayV es) =
    parens . vcat
      . punctuate comma
         . fmap ppr $ es
  ppr (ManyV vs) =
    foldr (<+>) empty
      . punctuate (space<>plus)
        . fmap ppr $ vs

instance Ppr Enabled where
  ppr Enable  = dQText "enable"
  ppr Disable = dQText "disable"

instance Ppr ArrayElem where
  ppr (ArrayElem Nothing v) = ppr v
  ppr (ArrayElem (Just n) v) = doubleQuotes (ppr n)
                                <+> text "=>"
                                  <+> ppr v

instance Ppr Include where
  ppr (ValueI v) = text "include" <+> ppr v
  ppr (ShellI s) = text "include_shell" <+> ppr s

instance Ppr Cond where
  ppr (Cond f op p) = ppr f <+> ppr op <+> ppr p

instance Ppr Op where
  ppr Equal    = text "=="
  ppr NotEqual = text "!="
  ppr Match    = text "=~"
  ppr NotMatch = text "!~"

instance Ppr Pat where
  ppr (StringP s) = ppr s
  ppr (RegexP s) = ppr s

instance Ppr Field where
  ppr (Field n v) = pprField (ppr n) (ppr v)
{-
  ppr (HttpF v)     = pprField (text "HTTP") (ppr v)
  ppr (ServerF v)   = pprField (text "SERVER") (ppr v)
  ppr (PhysicalF v) = pprField (text "PHYSICAL") (ppr v)
-}

pprField :: Doc -> Doc -> Doc
pprField n v = text "$" <> n <> brackets v

{-
instance Ppr HttpVar where
  ppr Cookie      = ppr "cookie"
  ppr Host        = ppr "host"
  ppr Referer     = ppr "referer"
  ppr URL         = ppr "url"
  ppr QueryString = ppr "querystring"
  ppr RemoteIP    = ppr "remoteip"
  ppr Scheme      = ppr "scheme"

instance Ppr ServerVar where
  ppr Socket      = ppr "socket"

instance Ppr PhysicalVar where
  ppr Path         = ppr "path"
  ppr ExistingPath = ppr "existingpath"
-}

-----------------------------------------------------------------------------

dQText :: String -> Doc
dQText = doubleQuotes . text

dot = text "."
plus = text "+"

chunk :: Int -> [a] -> [[a]]
chunk = (takeWhile (not . null) .) . go . splitAt
  where go f xs = let (y,ys) = f xs in y : go f ys

-----------------------------------------------------------------------------