{-# OPTIONS_GHC -cpp -fglasgow-exts #-}

module PIL.Native.Pretty (Pretty(..), pretty, prettyM) where
import PIL.Native.Types
import PIL.Native.Coerce
import Text.PrettyPrint

{-| 

PIL.Native.Pretty

This is a pretty printer for the core runtime mini-language.

See Also:

  PIL.Native.Parser
  PIL.Native.Eval

-}

pretty :: (Pretty a) => a -> String
pretty = render' . format

prettyM :: (MonadSTM m, Pretty a) => a -> m String
prettyM a = fmap render' $ formatM a

render' :: Doc -> String
render' = renderStyle Style
    { mode           = OneLineMode 
    , lineLength     = 0
    , ribbonsPerLine = 0
    }

defaultIndent :: Int
defaultIndent = 2

class (Show a) => Pretty a where
    format :: a -> Doc
    format = text . show
    formatM :: MonadSTM m => a -> m Doc
    formatM = return . format

instance Pretty (SeqOf NativeLangExpression) where
    format = format . elems

instance Pretty [NativeLangExpression] where
    format = sepBy semi . filter (/= ESaveContinuation)

instance Pretty NativeLangExpression where
    format ESaveContinuation = Text.PrettyPrint.empty --  "<save-cc>"
    format (ELit x) = format x
    format (EVar x) = format x
    format (ECall ctyp obj meth args) = hcat
        [ maybeParens obj                   -- obj
        , char (sugarDot ctyp), format meth        -- `method
        , parens (commaSep $ elems args)    -- (arg1, arg2)
        ]
        where
        sugarDot CPrim    = '`'
        sugarDot CPublic  = '.'
        sugarDot CPrivate = '!'
        maybeParens (ELit (NSub {})) = parens (format obj)
        maybeParens obj = format obj

instance Pretty NativeLangSym where
    format = text . toString

instance Pretty NativeSub where
    format (MkSub { s_params = params, s_exps = exps }) = hang
        (text "->" <+> commaSep (elems params)) defaultIndent
        (braces . format . elems $ exps)

instance Pretty Native where
    format (NError {})  = text "nil"
    format (NBit True)  = text "true"
    format (NBit False) = text "false"
    format (NInt x)     = int x
    format (NNum x)     = float x
    format (NStr x)     = format (toString x)
    format (NSeq x)     = brackets (commaSep $ elems x)
    format (NMap x)     = braces (commaSep $ assocs x)
    format (NSub x)     = format x
    format (NObj x)     = format x
    formatM (NObj x)    = formatM x
    formatM (NSeq x)    = formatM x
    formatM (NMap x)    = formatM x
    formatM x           = return (format x)

instance Pretty NativeObj where
    format o = text $ "<obj:#" ++ show (o_id o) ++ "|cls:#" ++ show (o_id (o_class o)) ++ ">"
    {-
    formatM o = do
        keys <- liftSTM (o_keys o)
        -- $ readTVar (o_attrs o)
        --formatM attrs
        formatM (NNum 1)
    -}

instance Pretty NativeSeq where
    format x = brackets (nest defaultIndent (commaSep $ elems x))
    formatM x = do
        items <- commaSepM $ elems x
        return $ brackets (nest defaultIndent items)

instance Pretty NativeMap where
    format x = braces (nest defaultIndent (commaSep $ assocs x))
    formatM x = do
        pairs <- commaSepM $ assocs x
        return $ braces (nest defaultIndent pairs)

instance Pretty Doc where
    format = id

instance Pretty String where
    format = ptext . show

instance Pretty (NativeStr, Native) where
    format (x, y) = sep [format (toString x), text "=>", format y]

sepBy :: (Pretty a) => Doc -> [a] -> Doc
sepBy x = sep . punctuate x . map format

sepByM :: (MonadSTM m, Pretty a) => Doc -> [a] -> m Doc
sepByM x = fmap (sep . punctuate x) . mapM formatM

commaSep :: Pretty a => [a] -> Doc
commaSep = sepBy comma

commaSepM :: (MonadSTM m, Pretty a) => [a] -> m Doc
commaSepM = sepByM comma