module Puppet.Interpreter.PrettyPrinter(containerComma) where
import Puppet.PP
import Puppet.Parser.Types
import Puppet.Interpreter.Types
import Puppet.Parser.PrettyPrinter
import Data.Monoid
import qualified Data.Vector as V
import qualified Data.Text as T
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import Control.Arrow (first,second)
import Control.Lens
import Data.List
import GHC.Exts
containerComma'' :: Pretty a => [(Doc, a)] -> Doc
containerComma'' x = indent 2 ins
where
ins = mconcat $ intersperse (comma <$> empty) (map showC x)
showC (a,b) = a <+> text "=>" <+> pretty b
containerComma' :: Pretty a => [(Doc, a)] -> Doc
containerComma' = braces . containerComma''
containerComma :: Pretty a => Container a -> Doc
containerComma hm = containerComma' (map (\(a,b) -> (fill maxalign (ttext a), b)) hml)
where
hml = HM.toList hm
maxalign = maximum (map (T.length . fst) hml)
instance Pretty PValue where
pretty (PBoolean True) = dullmagenta $ text "true"
pretty (PBoolean False) = dullmagenta $ text "false"
pretty (PString s) = dullcyan (ttext (stringEscape s))
pretty PUndef = dullmagenta (text "undef")
pretty (PResourceReference t n) = capitalize t <> brackets (text (T.unpack n))
pretty (PArray v) = list (map pretty (V.toList v))
pretty (PHash g) = containerComma g
instance Pretty TopLevelType where
pretty TopNode = dullyellow (text "node")
pretty TopDefine = dullyellow (text "define")
pretty TopClass = dullyellow (text "class")
pretty TopSpurious = dullyellow (text "spurious")
instance Pretty RIdentifier where
pretty (RIdentifier t n) = pretty (PResourceReference t n)
meta :: Resource -> Doc
meta r = showPPos (r ^. rpos) <+> (green (node <+> brackets scp) )
where
node = red (ttext (r ^. rnode))
scp = "Scope" <+> pretty (r ^.. rscope . folded . filtered (/=ContRoot) . to pretty)
resourceBody :: Resource -> Doc
resourceBody r = virtuality <> blue (ttext (r ^. rid . iname)) <> ":" <+> meta r <$> containerComma'' insde <> ";"
where
virtuality = case r ^. rvirtuality of
Normal -> empty
Virtual -> dullred "@"
Exported -> dullred "@@"
ExportedRealized -> dullred "<@@>"
insde = alignlst dullblue attriblist1 ++ alignlst dullmagenta attriblist2
alignlst col = map (first (fill maxalign . col . ttext))
attriblist1 = sortWith fst $ HM.toList (r ^. rattributes) ++ aliasdiff
aliasWithoutTitle = r ^. ralias & contains (r ^. rid . iname) .~ False
aliasPValue = aliasWithoutTitle & PArray . V.fromList . map PString . HS.toList
aliasdiff | HS.null aliasWithoutTitle = []
| otherwise = [("alias", aliasPValue)]
attriblist2 = map totext (resourceRelations r)
totext (RIdentifier t n, lt) = (rel2text lt , PResourceReference t n)
maxalign = max (maxalign' attriblist1) (maxalign' attriblist2)
maxalign' [] = 0
maxalign' x = maximum . map (T.length . fst) $ x
instance Pretty Resource where
prettyList lst =
let grouped = HM.toList $ HM.fromListWith (++) [ (r ^. rid . itype, [r]) | r <- lst ] :: [ (T.Text, [Resource]) ]
sorted = sortWith fst (map (second (sortWith (_iname . _rid) )) grouped)
showGroup :: (T.Text, [Resource]) -> Doc
showGroup (rt, res) = dullyellow (ttext rt) <+> lbrace <$> indent 2 (vcat (map resourceBody res)) <$> rbrace
in vcat (map showGroup sorted)
pretty r = dullyellow (ttext (r ^. rid . itype)) <+> lbrace <$> indent 2 (resourceBody r) <$> rbrace
instance Pretty CurContainerDesc where
pretty (ContImport p x) = magenta "import" <> braces (ttext p) <> braces (pretty x)
pretty (ContImported x) = magenta "imported" <> braces (pretty x)
pretty ContRoot = dullyellow (text "::")
pretty (ContClass cname) = dullyellow (text "class") <+> dullgreen (text (T.unpack cname))
pretty (ContDefine dtype dname _) = pretty (PResourceReference dtype dname)
instance Pretty ResDefaults where
pretty (ResDefaults t _ v p) = capitalize t <+> showPPos p <$> containerComma v
instance Pretty ResourceModifier where
pretty (ResourceModifier rt ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString x)) _ p) = "realize" <> parens (pretty (PResourceReference rt x)) <+> showPPos p
pretty _ = "TODO pretty ResourceModifier"
instance Pretty RSearchExpression where
pretty (REqualitySearch a v) = ttext a <+> "==" <+> pretty v
pretty (RNonEqualitySearch a v) = ttext a <+> "!=" <+> pretty v
pretty (RAndSearch a b) = parens (pretty a) <+> "&&" <+> parens (pretty b)
pretty (ROrSearch a b) = parens (pretty a) <+> "||" <+> parens (pretty b)
pretty RAlwaysTrue = mempty