pretty-types 0.1.1.0 → 0.2.0.0

raw patch · 4 files changed

+249/−36 lines, 4 filesdep +mtlPVP ok

version bump matches the API change (PVP)

Dependencies added: mtl

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−0
• pretty-types.cabal +3/−1
• spec/PrettyTypesSpec.hs +74/−1
• src/Data/Type/Pretty.hs +164/−34

@@ -0,0 +1,8 @@+## Version 0.2.0.0++* Added indentation support+* Added `<:>` combinator++## Version 0.1.0.0++* Initial Version

@@ -1,5 +1,5 @@ name:                pretty-types-version:             0.1.1.0+version:             0.2.0.0 synopsis:            A small pretty printing DSL for complex types. description:         Please see README.md homepage:            https://github.com/sheyll/pretty-types#readme@@ -14,12 +14,14 @@                     , stack.yaml                     , .travis.yml                     , .gitignore+                    , ChangeLog.md cabal-version:       >=1.10  library   hs-source-dirs:      src   exposed-modules:     Data.Type.Pretty   build-depends:       base >= 4.9 && < 5+                     , mtl >= 2.2 && < 3   default-language:    Haskell2010   ghc-options:         -Wall -funbox-strict-fields -fno-warn-unused-do-bind   default-extensions:  BangPatterns

@@ -40,7 +40,7 @@       showPretty (PX :: PX ('PrettySymbol ('PrettyPadded 10) ('PrettyPrecision 2) "hello"))         `shouldBe` "        he" -  describe "PrettySeperated" $ do+  describe "PrettyInfix" $ do     it "renders (PutNat 0 <++> PutNat 1) as \"01\"" $       showPretty (PX :: PX (PutNat 0 <++> PutNat 1)) `shouldBe` "01"     it "renders (PutNat 0 <+> PutNat 1) as \"0 1\"" $@@ -66,6 +66,79 @@       showPretty (PX :: PX (PrettyMany (PutNat 777) '[PutStr "."])) `shouldBe` "."     it "renders (PrettyMany (PutNat 777) '[PutStr \".\", PutNat 3, PutNat 4]) as \".77737774\"" $       showPretty (PX :: PX (PrettyMany (PutNat 777) '[PutStr ".", PutNat 3, PutNat 4])) `shouldBe` ".77737774"++  describe "PrettyInfix" $ do+    it "renders the seperator if nested docs contain text" $+      showPretty (PX :: PX ('PrettyInfix 'PrettySpace (PutStr "foo") (PutStr "bar"))) `shouldBe` "foo bar"+    it "renders only the the first document of the second is empty, and no seperator" $+      showPretty (PX :: PX ('PrettyInfix 'PrettySpace (PutStr "foo") (PutStr ""))) `shouldBe` "foo"+    it "renders only the the second document of the first is empty, and no seperator" $+      showPretty (PX :: PX ('PrettyInfix 'PrettySpace (PutStr "") (PutStr "bar"))) `shouldBe` "bar"++  describe "PrettyAlternative" $ do+    it "renders the first document if is not empty" $+      showPretty (PX :: PX ('PrettyAlternative (PutStr "foo") (PutStr "bar"))) `shouldBe` "foo"+    it "renders the second document if the first is empty" $+      showPretty (PX :: PX ('PrettyAlternative (PutStr "") (PutStr "bar"))) `shouldBe` "bar"++  describe "PrettyPrefix" $ do+    it "renders the first and second document if the second is not empty" $+      showPretty (PX :: PX ('PrettyPrefix (PutStr "foo") (PutStr "bar"))) `shouldBe` "foobar"+    it "renders nothing if the second document is empty" $+      showPretty (PX :: PX ('PrettyPrefix (PutStr "foo") (PutStr ""))) `shouldBe` ""++  describe "PrettySuffix" $ do+    it "renders the second and first document if the second is not empty" $+      showPretty (PX :: PX ('PrettySuffix (PutStr "foo") (PutStr "bar"))) `shouldBe` "barfoo"+    it "renders nothing if the second document is empty" $+      showPretty (PX :: PX ('PrettySuffix (PutStr "foo") (PutStr ""))) `shouldBe` ""++  describe "<||>" $ do+    it "is the type alias for 'PrettyAlternative " $+      showPretty (PX :: PX (PutStr "foo" <||> PutStr "bar")) `shouldBe` "foo"+    it "has a lower precedence than <++>" $+      showPretty (PX :: PX (PutStr "foo" <++> PutStr "" <||> PutStr "baz")) `shouldBe` "foo"+    it "has a higher precedence than <$$>" $+      showPretty (PX :: PX (PutStr "foo" <$$> PutStr "" <||> PutStr "baz")) `shouldBe` "foo\nbaz"++  describe "<:>" $ do+    it "renders no label if the label is empty" $+      showPretty (PX :: PX ("" <:> PutStr "bar")) `shouldBe` "bar"+    it "renders a label, a colon followed by a space and the body" $+      showPretty (PX :: PX ("foo" <:> PutStr "bar")) `shouldBe` "foo: bar"+    it "renders a label followed by a colon if the body is empty" $+      showPretty (PX :: PX ("foo" <:> 'PrettyEmpty)) `shouldBe` "foo:"++  describe "<:$$>" $ do+    it "renders no label if the label is empty" $+      showPretty (PX :: PX ("" <:$$> PutStr "bar")) `shouldBe` "bar"+    it "renders a label, a colon followed by the body on the next line" $+      showPretty (PX :: PX ("foo" <:$$> PutStr "bar")) `shouldBe` "foo:\nbar"+    it "renders a label followed by a colon if the body is empty" $+      showPretty (PX :: PX ("foo" <:$$> 'PrettyEmpty)) `shouldBe` "foo:"++  describe "<:$$-->" $ do+    it "renders no label if the label is empty" $+      showPretty (PX :: PX ("" <:$$--> PutStr "bar")) `shouldBe` "  bar"+    it "renders a label, a colon followed by indented the body" $+      showPretty (PX :: PX ("foo" <:$$--> PutStr "bar")) `shouldBe` "foo:\n  bar"+    it "renders a label followed by a colon if the body is empty" $+      showPretty (PX :: PX ("foo" <:$$--> 'PrettyEmpty)) `shouldBe` "foo:"++  describe "PrettyIndent" $ do+    it "renders the indentation" $+      showPretty (PX :: PX (PutStr "foo" <$$--> PutStr "bar")) `shouldBe` "foo\n  bar"+    it "renders the indentation only once per line" $+      showPretty (PX :: PX (PutStr "foo" <$$--> PutStr "bar1" <+> PutStr "bar2" )) `shouldBe` "foo\n  bar1 bar2"+    it "renders the indentation of multi lines and the operator precedence is such that no parens are needed." $+      showPretty (PX :: PX (PutStr "foo" <$$--> PutStr "bar1" <$$> PutStr "bar2")) `shouldBe` "foo\n  bar1\n  bar2"+    it "renders the nested indentation." $+      showPretty (PX :: PX (PutStr "foo" <$$-->+                           (PutStr "bar1" <$$>+                            PutStr "bar2" <$$-->+                            PutStr "bar3" <$$>+                            PutStr "bar4")))+      `shouldBe` "foo\n  bar1\n  bar2\n    bar3\n    bar4"    describe "ToPretty" $ do     it "renders a custom type" $ do

@@ -11,7 +11,7 @@ -- for your types by combining the promoted constructors of 'PrettyType'. -- -- If `UndecidableInstances` isn't holding you back, use the type aliases like--- 'PutStr', 'PutNat', 'PrettySeperated', etc in these instance definitions.+-- 'PutStr', 'PutNat', 'PrettyInfix', etc in these instance definitions. -- -- 'ToPretty' is an open type family, that converts a custom type to a -- `PrettyType`.@@ -104,6 +104,8 @@ -- @ module Data.Type.Pretty where +import Control.Monad.RWS hiding (tell)+import qualified Control.Monad.RWS import GHC.TypeLits import Data.Proxy import Text.Printf@@ -116,7 +118,7 @@   :: forall proxy (t :: k) . PrettyTypeShow (ToPretty t)   => proxy t  -- ^ A proxy to the type to print. A 'ToPretty' instance for t must exists.   -> String-showPretty _ = ptShow (Proxy :: Proxy (ToPretty t))+showPretty _ = snd $ evalRWS (ptShow (Proxy :: Proxy (ToPretty t))) 0 AtBeginningOfLine  -- | Create a 'PrettyType' from a type. --@@ -210,18 +212,54 @@  -- ** Composing Pretty Printers +-- | A label followed by a colon and space @: @ followed by another element.+--+-- >>> showPretty (Proxy :: Proxy ("foo" <:> PutStr "bar"))+-- @+-- foo: bar+-- @+type (<:>) label body = 'PrettySuffix (PutStr ":") (PutStr label) <+> body+infixl 5 <:>+-- | Like '<:>' but begin the body on a new line.+--+-- >>> showPretty (Proxy :: Proxy (PutStr "foo" <:$$> PutStr "bar"))+-- @+-- foo:+-- bar+-- @+type (<:$$>) label body = 'PrettySuffix (PutStr ":") (PutStr label) <$$> body+infixl 5 <:$$>++-- | Like '<:$$__>' but indent the body with two spaces.+--+-- >>> showPretty (Proxy :: Proxy (PutStr "foo" <:$$--> PutStr "bar"))+-- @+-- foo:+--   bar+-- @+type (<:$$-->) label body = 'PrettySuffix (PutStr ":") (PutStr label) <$$--> body+infixl 3 <:$$-->+ -- | Concatenate two 'PrettyType'.-type (<++>) l r = 'PrettySeperated 'PrettyEmpty l r+type (<++>) l r = 'PrettyInfix 'PrettyEmpty l r infixl 6 <++>  -- | Concatenate two 'PrettyType' using a 'PrettySpace'.-type (<+>) l r = 'PrettySeperated 'PrettySpace l r+type (<+>) l r = 'PrettyInfix 'PrettySpace l r infixl 5 <+> +-- | Choose the first non-empty from two 'PrettyType's.+type (<||>) l r = 'PrettyAlternative l r+infixl 5 <||>+ -- | Concatenate two 'PrettyType' using a 'PrettyNewline'.-type (<$$>) l r = 'PrettySeperated 'PrettyNewline l r+type (<$$>) l r = 'PrettyInfix 'PrettyNewline l r infixl 4 <$$> +-- | Concatenate two 'PrettyType' using a 'PrettyNewline' and indent the second.+type (<$$-->) l r = 'PrettyInfix 'PrettyNewline l ('PrettyIndent 2 r)+infixl 3 <$$-->+ -- | Surround a pretty with parens type PrettyParens doc = PrettySurrounded (PutStr "(") (PutStr ")") doc @@ -271,10 +309,20 @@ data PrettyType where   PrettyEmpty :: PrettyType   PrettySpace :: PrettyType+  -- | Begin a newline. Always use this otherwise indentation will not work!   PrettyNewline :: PrettyType   PrettySymbol :: PrettyPadded -> PrettyPrecision -> Symbol -> PrettyType   PrettyNat :: PrettyPadded -> PrettyPrecision -> PrettyNatFormat -> Nat -> PrettyType-  PrettySeperated :: PrettyType -> PrettyType -> PrettyType -> PrettyType+  -- | Prefix the second with the first argument, but only if it (the second) has content.+  PrettyPrefix :: PrettyType -> PrettyType -> PrettyType+  -- | Combine the last to arguments with the first in between them, but only if both have content.+  PrettyInfix :: PrettyType -> PrettyType -> PrettyType -> PrettyType+  -- | Add a the first argument as suffix to the second argument, but only if the second has content.+  PrettySuffix :: PrettyType -> PrettyType -> PrettyType+  -- | Indentation. Prefix any line using the given number of 'PrettySpace'.+  PrettyIndent :: Nat -> PrettyType -> PrettyType+  -- | Alternative rendering, if the first document ist empty the second will be rendered.+  PrettyAlternative :: PrettyType -> PrettyType -> PrettyType  -- | Padding for 'PrettyType's 'PrettySymbol' and 'PrettyNat'. data PrettyPadded where@@ -325,45 +373,127 @@ class PrettyTypeShow (p :: PrettyType) where   -- | Given any proxy to a promoted constructor of 'PrettyType', generate a   -- String.-  ptShow :: proxy p -> String+  ptShow :: proxy p -> PTM ()+  -- | Return 'True' if contents would be writting to the output of rendered via 'ptShow'+  ptHasContent :: proxy p -> PTM Bool+  ptHasContent _ = return True +-- | Internal monad used by 'ptShow', the state is a 'Bool' indicating+type PTM a = RWS Indentation String PTRenderState a++-- | Internal; write a possibly indented string, and update the 'PTRenderState' accordingly.+writeIndented :: String -> PTM ()+writeIndented s = do+    st <- get+    case st of+        AtBeginningOfLine -> do+            i <- ask+            Control.Monad.RWS.tell (replicate i ' ')+            put AlreadyIndented+        AlreadyIndented -> return ()+    Control.Monad.RWS.tell s++-- | Internal type of the indentation used by 'ptShow' in 'PTM'+type Indentation = Int++-- | Internal state used by 'ptShow' in 'PTM'+data PTRenderState = AtBeginningOfLine | AlreadyIndented+ -- | Print nothing.-instance PrettyTypeShow 'PrettyEmpty where ptShow _ = ""+instance PrettyTypeShow 'PrettyEmpty where+  ptShow _ = return ()+  ptHasContent _ = return False+ -- | Print a single space character.-instance PrettyTypeShow 'PrettySpace where ptShow _ = " "+instance PrettyTypeShow 'PrettySpace where+  ptShow _ = writeIndented " "+ -- | Print a single newline character.-instance PrettyTypeShow 'PrettyNewline where ptShow _ = "\n"+instance PrettyTypeShow 'PrettyNewline where+    ptShow _ = do+        put AtBeginningOfLine+        Control.Monad.RWS.tell "\n"  -- | Print a 'Symbol' using the 'printf' and the given format parameters.-instance forall t pad prec.-    (KnownSymbol t, PrintfArgModifier pad, PrintfArgModifier prec)-  => PrettyTypeShow ('PrettySymbol pad prec t) where-  ptShow _ = printf ("%" ++ toPrintfArgModifier (Proxy :: Proxy pad)-                         ++ toPrintfArgModifier (Proxy :: Proxy prec)-                         ++ "s")-                    (symbolVal (Proxy :: Proxy t))+instance forall t pad prec . (KnownSymbol t, PrintfArgModifier pad, PrintfArgModifier prec) =>+         PrettyTypeShow ('PrettySymbol pad prec t) where+    ptShow _ = writeIndented $+        printf ("%" +++                    toPrintfArgModifier (Proxy :: Proxy pad)+                        ++ toPrintfArgModifier (Proxy :: Proxy prec)+                            ++ "s")+               (symbolVal (Proxy :: Proxy t))+    ptHasContent _ = return (symbolVal (Proxy :: Proxy t) /= "")  -- | Print a 'Nat' using the 'printf' and the given format parameters.-instance forall fmt x pad prec.-  (KnownNat x, PrintfArgModifier fmt, PrintfArgModifier pad, PrintfArgModifier prec)-  => PrettyTypeShow ('PrettyNat pad prec fmt x) where-  ptShow _ = printf ("%" ++ toPrintfArgModifier (Proxy :: Proxy pad)-                         ++ toPrintfArgModifier (Proxy :: Proxy prec)-                         ++ toPrintfArgModifier (Proxy :: Proxy fmt))-                    (natVal (Proxy :: Proxy x))+instance forall fmt x pad prec . (KnownNat x, PrintfArgModifier fmt, PrintfArgModifier pad, PrintfArgModifier prec) =>+         PrettyTypeShow ('PrettyNat pad prec fmt x) where+    ptShow _ = writeIndented $+        printf ("%" +++                    toPrintfArgModifier (Proxy :: Proxy pad)+                        ++ toPrintfArgModifier (Proxy :: Proxy prec)+                            ++ toPrintfArgModifier (Proxy :: Proxy fmt))+               (natVal (Proxy :: Proxy x))  -- | Concatenate two 'PrettyType's. If one of them is empty print the other -- without any seperation character.-instance forall l r sep .-  (PrettyTypeShow sep, PrettyTypeShow l, PrettyTypeShow r)-  => PrettyTypeShow ('PrettySeperated sep l r) where-  ptShow _ =-    let rstr = ptShow (Proxy :: Proxy r)-        lstr = ptShow (Proxy :: Proxy l)-        sepStr = ptShow (Proxy :: Proxy sep)-    in if lstr == "" then rstr-        else if rstr == "" then lstr-          else lstr ++ sepStr ++ rstr+instance forall l r sep . (PrettyTypeShow sep, PrettyTypeShow l, PrettyTypeShow r) =>+         PrettyTypeShow ('PrettyInfix sep l r) where+    ptShow _ = do+        leftHasContent <- ptHasContent (Proxy :: Proxy l)+        rightHasContent <- ptHasContent (Proxy :: Proxy r)+        when leftHasContent (ptShow (Proxy :: Proxy l))+        when (leftHasContent && rightHasContent) (ptShow (Proxy :: Proxy sep))+        when rightHasContent (ptShow (Proxy :: Proxy r))++    ptHasContent _ =+      (||) <$> ptHasContent (Proxy :: Proxy l)+          <*> ptHasContent (Proxy :: Proxy r)++-- | Prefix a 'PrettyType' to x, but only if 'ptHasContent' of 'x' holds.+instance forall x sep . (PrettyTypeShow sep, PrettyTypeShow x) =>+         PrettyTypeShow ('PrettyPrefix sep x) where+    ptShow _ = do+        hasContent <- ptHasContent (Proxy :: Proxy x)+        when hasContent $ do+          ptShow (Proxy :: Proxy sep)+          ptShow (Proxy :: Proxy x)++    ptHasContent _ = ptHasContent (Proxy :: Proxy x)++-- | Add a 'PrettyType' suffix to x, but only if 'ptHasContent' holds.+instance forall x sep . (PrettyTypeShow sep, PrettyTypeShow x) =>+         PrettyTypeShow ('PrettySuffix sep x) where+    ptShow _ = do+        hasContent <- ptHasContent (Proxy :: Proxy x)+        when hasContent $ do+          ptShow (Proxy :: Proxy x)+          ptShow (Proxy :: Proxy sep)++    ptHasContent _ = ptHasContent (Proxy :: Proxy x)++-- | Render the first document, and if it is empty, the second+instance forall l r . (PrettyTypeShow l, PrettyTypeShow r) =>+         PrettyTypeShow ('PrettyAlternative l r) where+    ptShow _ = do+        leftHasContent <- ptHasContent (Proxy :: Proxy l)+        if leftHasContent+          then ptShow (Proxy :: Proxy l)+          else ptShow (Proxy :: Proxy r)++    ptHasContent _ =+      (||) <$> ptHasContent (Proxy :: Proxy l)+          <*> ptHasContent (Proxy :: Proxy r)+++-- | Render an indented, nested type.+instance forall n r . (PrettyTypeShow r, KnownNat n) =>+         PrettyTypeShow ('PrettyIndent n r) where++    ptShow _ = local (+ (fromIntegral (natVal (Proxy :: Proxy n))))+                     (ptShow (Proxy :: Proxy r))++    ptHasContent _ =  ptHasContent (Proxy :: Proxy r)  -- | Internal 'printf' format generation. Used internally by 'PrettyTypeShow' -- instances to generate the format string piece by piece with the values for