{-# OPTIONS_GHC -fno-warn-orphans #-}
module Puppet.Parser.PrettyPrinter
  ( ppStatements
  ) where

import           XPrelude.Extra               hiding ((<$>))
import           XPrelude.PP

import qualified Data.Maybe.Strict            as S
import qualified Data.Text                    as Text
import qualified Data.Tuple.Strict            as Tuple
import qualified Data.Vector                  as V
import           Text.PrettyPrint.ANSI.Leijen ((<$>))

import           Puppet.Language
import           Puppet.Parser.Types


parensList :: Pretty a => Vector a -> Doc
parensList = tupled . fmap pretty . V.toList

hashComma :: (Pretty a, Pretty b) => Vector (Pair a b) -> Doc
hashComma = encloseSep lbrace rbrace comma . fmap showC . V.toList
  where
    showC (a :!: b) = pretty a <+> "=>" <+> pretty b


instance Pretty UDataType where
  pretty t = case t of
    UDTType              -> "Type"
    UDTString ma mb      -> bounded "String" ma mb
    UDTInteger ma mb     -> bounded "Integer" ma mb
    UDTFloat ma mb       -> bounded "Float" ma mb
    UDTBoolean           -> "Boolean"
    UDTArray dt mi mmx   -> "Array" <> list (pretty dt : pretty mi : maybe [] (pure . pretty) mmx)
    UDTHash kt dt mi mmx -> "Hash" <> list (pretty kt : pretty dt : pretty mi : maybe [] (pure . pretty) mmx)
    UDTUndef             -> "Undef"
    UDTScalar            -> "Scalar"
    UDTData              -> "Data"
    UDTOptional o        -> "Optional" <> brackets (pretty o)
    UNotUndef            -> "NotUndef"
    UDTVariant vs        -> "Variant" <> list (foldMap (pure . pretty) vs)
    UDTPattern vs        -> "Pattern" <> list (foldMap (pure . pretty) vs)
    UDTEnum tx           -> "Enum" <> list (foldMap (pure . pretty) tx)
    UDTAny               -> "Any"
    UDTCollection        -> "Collection"
    UDTRegexp mr         -> "Regexp" <> foldMap (brackets . pretty) mr
    where
      bounded :: (Pretty a, Pretty b) => Doc -> Maybe a -> Maybe b -> Doc
      bounded s ma mb = s <> case (ma, mb) of
        (Just a, Nothing) -> list [pretty a]
        (Just a, Just b)  -> list [pretty a, pretty b]
        _                 -> mempty

instance Pretty Expression where
  pretty (Equal a b) = parens (pretty a <+> "==" <+> pretty b)
  pretty (Different a b) = parens (pretty a <+>"!=" <+> pretty b)
  pretty (And a b) = parens (pretty a <+> "and" <+> pretty b)
  pretty (Or a b) = parens (pretty a <+> "or" <+> pretty b)
  pretty (LessThan a b) = parens (pretty a <+> pretty '<' <+> pretty b)
  pretty (MoreThan a b) = parens (pretty a <+> pretty '>' <+> pretty b)
  pretty (LessEqualThan a b) = parens (pretty a <+> "<=" <+> pretty b)
  pretty (MoreEqualThan a b) = parens (pretty a <+> ">=" <+> pretty b)
  pretty (RegexMatch a b) = parens (pretty a <+> "=~" <+> pretty b)
  pretty (NotRegexMatch a b) = parens (pretty a <+> "!~" <+> pretty b)
  pretty (Contains a b) = parens (pretty a <+> "in" <+> pretty b)
  pretty (Addition a b) = parens (pretty a <+> pretty '+' <+> pretty b)
  pretty (Substraction a b) = parens (pretty a <+> pretty '-' <+> pretty b)
  pretty (Division a b) = parens (pretty a <+> pretty '/' <+> pretty b)
  pretty (Multiplication a b) = parens (pretty a <+> pretty '*' <+> pretty b)
  pretty (Modulo a b) = parens (pretty a <+> pretty '%' <+> pretty b)
  pretty (RightShift a b) = parens (pretty a <+> ">>" <+> pretty b)
  pretty (LeftShift a b) = parens (pretty a <+> "<<" <+> pretty b)
  pretty (Lookup a b) = pretty a <> brackets (pretty b)
  pretty (ConditionalValue a b) = parens (pretty a <+> pretty '?' <+> hashComma b)
  pretty (Negate a) = pretty '-' <+> parens (pretty a)
  pretty (Not a) = pretty '!' <+> parens (pretty a)
  pretty (Terminal a) = pretty a
  pretty (FunctionApplication e1 e2) = parens (pretty e1) <> "." <> pretty e2

instance Pretty LambdaFunc where
  pretty (LambdaFunc nm) = bold $ red (ppline nm)

instance Pretty LambdaParameters where
  pretty b = encloseSep (magenta (pretty '|')) (magenta (pretty '|')) comma (V.toList (fmap mkv b))
    where
      pmspace = foldMap ((<> " ") . pretty)
      mkv (LambdaParam mt v) = pmspace mt <> pretty (UVariableReference v)

instance Pretty SearchExpression where
  pretty (EqualitySearch t e) = ppline t <+> "==" <+> pretty e
  pretty (NonEqualitySearch t e) = ppline t <+> "!=" <+> pretty e
  pretty AlwaysTrue = mempty
  pretty (AndSearch s1 s2) = parens (pretty s1) <+> "and" <+> parens (pretty s2)
  pretty (OrSearch s1 s2) = parens (pretty s1) <+> "and" <+> parens (pretty s2)

instance Pretty UnresolvedValue where
  pretty (UBoolean True) = dullmagenta "true"
  pretty (UBoolean False) = dullmagenta "false"
  pretty (UString s) = pretty '"' <> dullcyan (ppline (stringEscape s)) <> pretty '"'
  pretty (UNumber n) = cyan (ppline (scientific2text n))
  pretty (UInterpolable v) = pretty '"' <> hcat (map specific (V.toList v)) <> pretty '"'
    where
      specific (Terminal (UString s)) = dullcyan (ppline (stringEscape s))
      specific (Terminal (UVariableReference vr)) = dullblue ("${" <> ppline vr <> "}")
      specific (Lookup (Terminal (UVariableReference vr)) (Terminal x)) =
        dullblue ("${" <> ppline vr <> "[" <> pretty x <> "]}")
      specific x = bold (red (pretty x))
  pretty UUndef = dullmagenta (ppline "undef")
  pretty (UResourceReference t n) = capitalizeR t <> brackets (pretty n)
  pretty (UArray v) = list (map pretty (V.toList v))
  pretty (UHash g) = hashComma g
  pretty (URegexp r) = pretty r
  pretty (UVariableReference v) = dullblue (pretty '$' <> ppline v)
  pretty (UFunctionCall f args) = showFunc f args
  pretty (UHOLambdaCall c) = pretty c
  pretty (UDataType dt) = pretty dt


instance Pretty HOLambdaCall where
  pretty (HOLambdaCall hf me bp stts mee) =
    pretty hf <> parensList me <+> pretty bp <+> nest 2 (pretty '{' <> line <> ppStatements stts <> mmee) <$> pretty '}'
    where
      mmee =
        case mee of
          S.Just x -> mempty </> pretty x
          S.Nothing -> mempty
instance Pretty SelectorCase where
  pretty SelectorDefault = dullmagenta "default"
  pretty (SelectorType t) = pretty t
  pretty (SelectorValue v) = pretty v

instance Pretty ArrowOp where
  pretty AssignArrow = "=>"
  pretty AppendArrow = "+>"


showAss :: Vector AttributeDecl -> Doc
showAss vx = folddoc (\a b -> a <> pretty ',' <$> b) prettyDecl (V.toList vx)
  where
    folddoc _ _ [] = mempty
    folddoc acc docGen (x:xs) = foldl acc (docGen x) (map docGen xs)
    maxlen = maximum (fmap (\(AttributeDecl k _ _) -> Text.length k) vx)
    prettyDecl (AttributeDecl k op v) = dullblue (fill maxlen (ppline k)) <+> pretty op <+> pretty v
    prettyDecl (AttributeWildcard v) = dullblue "*" <+> pretty AssignArrow <+> pretty v

showArgs :: Vector (Pair (Pair Text (S.Maybe UDataType)) (S.Maybe Expression)) -> Doc
showArgs vec = tupled (map ra lst)
  where
    lst = V.toList vec
    maxlen = maximum (map (Text.length . Tuple.fst . Tuple.fst) lst)
    ra (argname :!: mtype :!: rval) =
      dullblue (pretty '$' <> foldMap (\t -> pretty t <+> mempty) mtype
                           <> fill maxlen (ppline argname))
                           <> foldMap (\v -> mempty <+> pretty '=' <+> pretty v) rval

showFunc :: Text -> Vector Expression -> Doc
showFunc funcname args = bold (red (ppline funcname)) <> parensList args

braceStatements :: Vector Statement -> Doc
braceStatements stts = nest 2 (pretty '{' <$> ppStatements stts) <$> pretty '}'

instance Pretty NodeDesc where
  pretty NodeDefault = dullmagenta "default"
  pretty (NodeName n) = pretty (UString n)
  pretty (NodeMatch r) = pretty (URegexp r)

instance Pretty VarAssignDecl where
  pretty (VarAssignDecl mt vs expr p) =
    foldMap (\t -> pretty t <+> mempty) mt <> dullblue (foldMap (\v -> pretty '$' <> ppline v) vs) <+> pretty '=' <+> pretty expr <+> showPPos p

instance Pretty Statement where
    pretty (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl c p)) = pretty c <+> showPPos p
    pretty (ConditionalDeclaration (ConditionalDecl conds p))
        | V.null conds = mempty
        | otherwise = "if" <+> pretty firstcond <+> showPPos p <+> braceStatements firststts <$> vcat (map rendernexts xs)
        where
            ( (firstcond :!: firststts) : xs ) = V.toList conds
            rendernexts (Terminal (UBoolean True) :!: st) = "else" <+> braceStatements st
            rendernexts (c :!: st) | V.null st = mempty
                                   | otherwise = "elsif" <+> pretty c <+> braceStatements st
    pretty (MainFunctionDeclaration (MainFuncDecl funcname args p)) = showFunc funcname args <+> showPPos p
    pretty (ResourceDefaultDeclaration (ResDefaultDecl rtype defaults p)) = capitalizeR rtype <+> nest 2 (pretty '{' <+> showPPos p <$> showAss defaults) <$> pretty '}'
    pretty (ResourceOverrideDeclaration (ResOverrideDecl rtype rnames overs p)) = pretty (UResourceReference rtype rnames) <+> nest 2 (pretty '{' <+> showPPos p <$> showAss overs) <$> pretty '}'
    pretty (ResourceDeclaration (ResDecl rtype rname args virt p)) = nest 2 (red vrt <> dullgreen (ppline rtype) <+> pretty '{' <+> showPPos p
                                                                           <$> nest 2 (pretty rname <> pretty ':' <$> showAss args))
                                                                           <$> pretty '}'
        where
            vrt = case virt of
                      Normal           -> mempty
                      Virtual          -> pretty '@'
                      Exported         -> "@@"
                      ExportedRealized -> "!!"
    pretty (DefineDeclaration (DefineDecl cname args stts p)) = dullyellow "define" <+> dullgreen (ppline cname) <> showArgs args <+> showPPos p <$> braceStatements stts
    pretty (ClassDeclaration (ClassDecl cname args inherit stts p)) = dullyellow "class" <+> dullgreen (ppline cname) <> showArgs args <> inheritance <+> showPPos p
                                                               <$> braceStatements stts
        where
          inheritance = case inherit of
            S.Nothing -> mempty
            S.Just x -> mempty <+> "inherits" <+> ppline x
    pretty (VarAssignmentDeclaration decl) = pretty decl
    pretty (NodeDeclaration (NodeDecl nodename stmts i p)) = dullyellow "node" <+> pretty nodename <> inheritance <+> showPPos p <$> braceStatements stmts
        where
          inheritance = case i of
            S.Nothing -> mempty
            S.Just n -> mempty <+> ppline "inherits" <+> pretty n
    pretty (DependencyDeclaration (DepDecl (st :!: sn) (dt :!: dn) lt p)) = pretty (UResourceReference st sn) <+> pretty lt <+> pretty (UResourceReference dt dn) <+> showPPos p
    pretty (TopContainer a b) = "TopContainer:" <+> braces ( nest 2 ("TOP" <$> braceStatements a <$> "STATEMENT" <$> pretty b))
    pretty (ResourceCollectionDeclaration (ResCollDecl coltype restype search overrides p)) = capitalizeR restype <> enc (pretty search) <+> overs
        where
            overs | V.null overrides = showPPos p
                  | otherwise = nest 2 (pretty '{' <+> showPPos p <$> showAss overrides) <$> pretty '}'
            enc = case coltype of
                      Collector         -> enclose "<|" "|>"
                      ExportedCollector -> enclose "<<|" "|>>"

-- | Pretty print a series of statements.
ppStatements :: Vector Statement -> Doc
ppStatements = vcat . map pretty . V.toList