Permalink
Browse files

Refactor PrettyPrint to remove useless types

  • Loading branch information...
bartavelle committed May 15, 2014
1 parent 0bdcf97 commit 654f0f4e179b78ca345edc5ca65627a4887e1c68
Showing with 57 additions and 59 deletions.
  1. +57 −59 Startups/PrettyPrint.hs
View
@@ -1,5 +1,3 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Some pretty printing, with specific constructors for the game
module Startups.PrettyPrint where
@@ -11,45 +9,46 @@ import Data.Monoid
import Data.Maybe (fromMaybe)
import Data.String
import Control.Monad.Error
import qualified Data.Sequence as Seq
import Data.Sequence (Seq)
import qualified Data.Text as T
import qualified Data.Foldable as F
import Data.List (intersperse)
import Control.Lens
import qualified Text.PrettyPrint.ANSI.Leijen as PP
newtype PrettyDoc = PrettyDoc { getDoc :: Seq PrettyElement }
deriving (Eq, Monoid)
data PrettyElement = RawText T.Text
| NewLine
| Space
| Emph PrettyDoc
| Colorize PColor PrettyDoc
| Indent Int PrettyDoc
| PDirection EffectDirection
| PNeighbor Neighbor
| PFund Funding
| PPoach Poacher
| PVictory VictoryPoint
| PPlayerCount PlayerCount
| PTurn Turn
| PResource Resource
| PAge Age
| PCompanyStage CompanyStage
| PConflict PoachingOutcome
| PCompany CompanyProfile
| PResearch ResearchType
| PCardType CardType
deriving Eq
data PrettyDoc = RawText T.Text
| NewLine
| Space
| Emph PrettyDoc
| Colorize PColor PrettyDoc
| Indent Int PrettyDoc
| PDirection EffectDirection
| PNeighbor Neighbor
| PFund Funding
| PPoach Poacher
| PVictory VictoryPoint
| PPlayerCount PlayerCount
| PTurn Turn
| PResource Resource
| PAge Age
| PCompanyStage CompanyStage
| PConflict PoachingOutcome
| PCompany CompanyProfile
| PResearch ResearchType
| PCardType CardType
| PEmpty
| PCat PrettyDoc PrettyDoc
deriving Eq
instance Monoid PrettyDoc where
mappend = PCat
mempty = PEmpty
data PColor = PColorCard CardType
| PColorVictory VictoryType
deriving Eq
instance IsString PrettyDoc where
fromString = PrettyDoc . Seq.singleton . RawText . T.pack
fromString = RawText . T.pack
instance Error PrettyDoc where
noMsg = mempty
@@ -61,38 +60,38 @@ class PrettyE a where
instance PrettyE PrettyDoc where
pe = id
instance PrettyE T.Text where
pe = PrettyDoc . Seq.singleton . RawText
pe = RawText
instance PrettyE EffectDirection where
pe = PrettyDoc . Seq.singleton . PDirection
pe = PDirection
instance PrettyE Neighbor where
pe = PrettyDoc . Seq.singleton . PNeighbor
pe = PNeighbor
instance PrettyE Funding where
pe = PrettyDoc . Seq.singleton . PFund
pe = PFund
instance PrettyE Poacher where
pe = PrettyDoc . Seq.singleton . PPoach
pe = PPoach
instance PrettyE VictoryPoint where
pe = PrettyDoc . Seq.singleton . PVictory
pe = PVictory
instance PrettyE PlayerCount where
pe = PrettyDoc . Seq.singleton . PPlayerCount
pe = PPlayerCount
instance PrettyE Turn where
pe = PrettyDoc . Seq.singleton . PTurn
pe = PTurn
instance PrettyE Resource where
pe = PrettyDoc . Seq.singleton . PResource
pe = PResource
instance PrettyE Age where
pe = PrettyDoc . Seq.singleton . PAge
pe = PAge
instance PrettyE CompanyStage where
pe = PrettyDoc . Seq.singleton . PCompanyStage
pe = PCompanyStage
instance PrettyE PoachingOutcome where
pe = PrettyDoc . Seq.singleton . PConflict
pe = PConflict
instance PrettyE CompanyProfile where
pe = PrettyDoc . Seq.singleton . PCompany
pe = PCompany
instance PrettyE ResearchType where
pe = PrettyDoc . Seq.singleton . PResearch
pe = PResearch
instance PrettyE CardType where
pe = PrettyDoc . Seq.singleton . PCardType
pe = PCardType
instance (PrettyE a, F.Foldable f) => PrettyE (f a) where
pe l = brackets $ sepBy (pchar ',') (map pe (F.toList l))
foldPretty :: (PrettyE a, F.Foldable f) => f a -> PrettyDoc
foldPretty l = brackets $ sepBy (pchar ',') (map pe (F.toList l))
victory :: VictoryPoint -> VictoryType -> PrettyDoc
victory v vc = withVictoryColor vc (pe v)
@@ -101,7 +100,7 @@ brackets :: PrettyDoc -> PrettyDoc
brackets e = pchar '[' <> e <> pchar ']'
space :: PrettyDoc
space = PrettyDoc (Seq.singleton Space)
space = Space
sepBy :: F.Foldable f => PrettyDoc -> f PrettyDoc -> PrettyDoc
sepBy sep = mconcat . intersperse sep . F.toList
@@ -110,31 +109,31 @@ pchar :: Char -> PrettyDoc
pchar = pe . T.singleton
withCardColor :: CardType -> PrettyDoc -> PrettyDoc
withCardColor c = PrettyDoc . Seq.singleton . Colorize (PColorCard c)
withCardColor c = Colorize (PColorCard c)
withVictoryColor :: VictoryType -> PrettyDoc -> PrettyDoc
withVictoryColor v = PrettyDoc . Seq.singleton . Colorize (PColorVictory v)
withVictoryColor v = Colorize (PColorVictory v)
numerical :: Integral n => n -> PrettyDoc
numerical = fromString . (show :: Integer -> String) . fromIntegral
emph :: PrettyDoc -> PrettyDoc
emph = PrettyDoc . Seq.singleton . Emph
emph = Emph
pcost :: Cost -> PrettyDoc
pcost (Cost r m) = F.foldMap pe r <> pe m
indent :: Int -> PrettyDoc -> PrettyDoc
indent d = PrettyDoc . Seq.singleton . Indent d
indent = Indent
(<+>) :: PrettyDoc -> PrettyDoc -> PrettyDoc
a <+> b = a <> PrettyDoc (Seq.singleton Space) <> b
a <+> b = a <> space <> b
(</>) :: PrettyDoc -> PrettyDoc -> PrettyDoc
a </> b = a <> newline <> b
newline :: PrettyDoc
newline = PrettyDoc (Seq.singleton NewLine)
newline = NewLine
vcat :: [PrettyDoc] -> PrettyDoc
vcat = mconcat . intersperse newline
@@ -167,20 +166,17 @@ cardName card = case card of
CompanyCard c s _ _ -> pe c <+> pe s
shortCard :: Card -> PrettyDoc
shortCard card = cardName card <+> pcost (card ^. cCost) <+> pe (map cardEffectShort (card ^. cEffect))
shortCard card = cardName card <+> pcost (card ^. cCost) <+> foldPretty (map cardEffectShort (card ^. cEffect))
longCard :: Card -> PrettyDoc
longCard c = shortCard c <> page
<> if null grt
then mempty
else mempty <+> "- Free:" <+> pe grt
else mempty <+> "- Free:" <+> foldPretty grt
where
grt = c ^.. cFree . traverse . to pe
page = fromMaybe mempty (c ^? cAge . to pe . to brackets)
instance PP.Pretty PrettyDoc where
pretty = F.foldMap PP.pretty . getDoc
prettyColor :: PColor -> PP.Doc -> PP.Doc
prettyColor (PColorCard c) = case c of
BaseResource -> id
@@ -199,8 +195,10 @@ prettyColor (PColorVictory v) = case v of
CommercialVictory -> PP.dullred
CommunityVictory -> PP.magenta
instance PP.Pretty PrettyElement where
instance PP.Pretty PrettyDoc where
pretty e = case e of
PEmpty -> PP.empty
PCat a b -> PP.pretty a <> PP.pretty b
RawText t -> PP.string (T.unpack t)
NewLine -> PP.linebreak
Space -> PP.space

0 comments on commit 654f0f4

Please sign in to comment.