language-puppet-1.5.1: src/Puppet/Parser/PrettyPrinter.hs

{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

{-# HLINT ignore "Functor law" #-}
module Puppet.Parser.PrettyPrinter
  ( ppStatements,
  )
where

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 Puppet.Language
import Puppet.Parser.Types
import Text.PrettyPrint.ANSI.Leijen ((<$>))
import XPrelude.Extra hiding ((<$>))
import XPrelude.PP

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
    UDTDeferred -> "Deferred"
    UDTSensitive o -> "Sensitive" <> brackets (pretty o)
    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 attributeLength vx)
    attributeLength ad = case ad of
      AttributeDecl k _ _ -> Text.length k
      AttributeWildcard _ -> 0
    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)) = case V.toList conds of
    [] -> mempty
    (firstcond :!: firststts) : xs ->
      let rendernexts (Terminal (UBoolean True) :!: st) = "else" <+> braceStatements st
          rendernexts (c :!: st)
            | V.null st = mempty
            | otherwise = "elsif" <+> pretty c <+> braceStatements st
       in "if" <+> pretty firstcond <+> showPPos p <+> braceStatements firststts <$> vcat (map rendernexts xs)
  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