--
-- Copyright (c) 2005 Don Stewart - http://www.cse.unsw.edu.au/~dons
-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)
--

module Pretty (

    Pretty(..), {- instances -}

    -- our own combinators
    (<:>), ($\$), ($/$),

    showPpr,

    module Text.PrettyPrint

  ) where

import Syntax
import Data.List

import Text.PrettyPrint

{-
printDoc :: Mode -> Handle -> Doc -> IO ()
printDoc m hdl doc = do 
    fullRender m cols 1.5 put done doc
    hFlush hdl
  where
    put (Chr c) next  = hPutChar hdl c >> next 
    put (Str s) next  = hPutStr  hdl s >> next 
    put (PStr s) next = hPutStr  hdl s >> next 

    done = hPutChar hdl '\n'
    cols = 80
-}

-- ---------------------------------------------------------------------
-- some stuff we use

infixl 6 <:>
infixl 5 $/$
infixl 5 $\$

(<:>), ($/$), ($\$) :: Doc -> Doc -> Doc

p <:> q = p <> text ": "  <> q

p $/$ q = p <> text "/\n"  <> q
p $\$ q = p <> text "\\\n" <> q

eol :: Doc
eol = char '\n'

showPpr :: Pretty p => p -> String
showPpr p = render (ppr p)

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

class Pretty a where 
        ppr :: a -> Doc

-- ---------------------------------------------------------------------
-- Pretty printing the message types that we need to write to the server
--

------------------------------------------------------------------------
-- A register message
--
instance Pretty Register where
        ppr (Register bot ptype) = 
                text "reg" <:> ppr bot <+> ppr ptype <> eol

instance Pretty PlayerType where
        ppr CopFoot = text "cop-foot"
        ppr CopCar  = text "cop-car"
        ppr Robber  = text "robber"

------------------------------------------------------------------------
-- A move message
--
instance Pretty Move where
        ppr (Move loc ptype nm) = 
                text "mov" <:> ppr loc <+> ppr ptype <+> ppr nm

----------------------------------------------------------------------
-- Generic function for printing multi-line message
-- 

pprMulti :: String -> (a -> Doc) -> [a] -> Doc
pprMulti header pprFun [] = 
    text header $\$ text header $/$ empty
pprMulti header pprFun is = 
    text header $\$
    hcat (intersperse (text "\n") (map pprFun is))
    <> eol <> text header $/$ empty

pprMulti_ :: String -> [Doc] -> Doc
pprMulti_ header [] = text header $\$ text header <> char '/'
pprMulti_ header is = text header $\$ hcat (intersperse (text "\n") is) 
                        <> eol <> text header <> char '/'

------------------------------------------------------------------------
-- An Inform message
--
instance Pretty InformMsg where
    ppr (InformMsg is) = pprMulti "inf" ppr is


instance Pretty Inform where
        ppr (Inform bot loc ptype world certainty) =
                text "inf" <:> hsep [ ppr bot, ppr loc, ppr ptype
                                    , ppr world, ppr certainty]

------------------------------------------------------------------------
-- A Plan message
--
instance Pretty PlanMsg where
    ppr (PlanMsg ps) = pprMulti "plan" ppr ps

instance Pretty Plan where
        ppr (Plan bot loc ptype world) =
                text "plan" <:> hsep [ppr bot,ppr loc,ppr ptype,ppr world]


------------------------------------------------------------------------
-- A Vote message
--
instance Pretty VoteMsg where
    ppr (VoteMsg vs) = pprMulti "vote" pprVote vs
        where pprVote v = text "vote" <:> ppr v

------------------------------------------------------------------------
-- A Cop Move message
--
instance Pretty CopMove where
    ppr (CopMove offer moveblock accusations) = 
        pprMulti "cmov" id [ppr offer <> ppr moveblock <> ppr accusations]

instance Pretty Offer where
    ppr TurnCoat = text "turncoat"       <> char ':' <> eol
    ppr Straight = text "straight-arrow" <> char ':' <> eol

instance Pretty MoveBlock where
    ppr (MoveBlock moves) = pprMulti "mov" ppr moves

instance Pretty AccuseBlock where
    ppr (AccuseBlock accs) = pprMulti_ "acc" (map pprAcc accs) {- inside a cmov -}
        where
            pprAcc nm = text "acc" <:> ppr nm

-- ---------------------------------------------------------------------
-- A Robber Move message
--
instance Pretty RobberMove where
    ppr (RobberMove moves briberesult) = 
        pprMulti "rmov" id [ppr moves, ppr briberesult]

instance Pretty BribeResult where
    ppr (NoBribe)     = text "nobribe" <> char ':'
    ppr (Push nm loc) = text "psh" <:> ppr nm <+> ppr loc
    ppr (Choose cs)   = ppr cs

instance Pretty ChooseBlock where
    ppr (ChooseBlock cs) = pprMulti_ "chc" (map pprChoice cs)
        where pprChoice nm = text "chc" <:> ppr nm

-- ---------------------------------------------------------------------
-- A Robber bribe message
--
instance Pretty BribeMsg where
    ppr RobberBribe   = text "bribe"   <> char ':' <> eol
    ppr RobberNoBribe = text "nobribe" <> char ':' <> eol

-- ---------------------------------------------------------------------
-- Pretty printing the message types that we get from the server
--

------------------------------------------------------------------------
-- A world skeleton message
--
instance Pretty WorldSkeleton where ppr = text . show
            
------------------------------------------------------------------------
-- A world message
--
instance Pretty World where ppr = text . show

------------------------------------------------------------------------
-- A game over message
--
instance Pretty GameOver where ppr = text . show

------------------------------------------------------------------------
-- A vote result message
--
instance Pretty VoteResult where ppr = text . show

------------------------------------------------------------------------
-- A from-inform
instance Pretty FromInform      where ppr = text . show

------------------------------------------------------------------------
-- A from-plan
instance Pretty FromPlan        where ppr = text . show

-- ---------------------------------------------------------------------
-- Pretty printing the general message types
--

instance Pretty Message where
    ppr (SendMessage m) = ppr m
    ppr (RecvMessage m) = ppr m

instance Pretty RecvMessage where
    ppr (MsgWorldSkel m) = ppr m
    ppr (MsgWorld m) = ppr m
    ppr (MsgGameOver m) = ppr m
    ppr (MsgVoteRes m) = ppr m
    ppr (MsgFromInf  m) = ppr m
    ppr (MsgFromPlan m) = ppr m

instance Pretty SendMessage where
    ppr (MsgRegister m)   = ppr m
    ppr (MsgCopMove m)    = ppr m
    ppr (MsgRobberMove m) = ppr m
    ppr (MsgInform m)     = ppr m
    ppr (MsgPlan m)       = ppr m
    ppr (MsgVote m)       = ppr m
    ppr (MsgBribe m)      = ppr m


instance Pretty String where ppr = text
instance Pretty Int    where ppr = text . show
instance Pretty Doc where ppr = id