diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,3 +7,7 @@ * Fix needless parentheses around nullary function applications. * Improve Haddock documentation. * Improve the package description and synopsis. + +# 0.1.0.2 + +* Update to portray-0.2.0 diff --git a/portray-pretty.cabal b/portray-pretty.cabal --- a/portray-pretty.cabal +++ b/portray-pretty.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 93aaf5ac8b3c548a84614877b51df32bc719f8111b0fd163f33fee8d6c7daf48 +-- hash: 2f09ba9b37e58400c49ded58a06b338f5b6aab89cb1b20f9b4461e347d4a9a00 name: portray-pretty -version: 0.1.0.1 +version: 0.1.0.2 synopsis: A portray backend using the pretty package. description: This provides a backend for , along with @@ -42,7 +42,7 @@ src build-depends: base >=4.12 && <4.16 - , portray >=0.1 && <0.2 + , portray >=0.2 && <0.3 , portray-diff >=0.1 && <0.2 , pretty >=1.1.3 && <1.2 , text >=0.1 && <1.3 diff --git a/src/Data/Portray/Pretty.hs b/src/Data/Portray/Pretty.hs --- a/src/Data/Portray/Pretty.hs +++ b/src/Data/Portray/Pretty.hs @@ -106,6 +106,7 @@ import Data.Portray ( Assoc(..), Infixity(..), FactorPortrayal(..) + , Ident(..), IdentKind(..) , Portray, Portrayal(..), PortrayalF(..) , cata, portray ) @@ -145,13 +146,33 @@ portrayalToDoc :: Portrayal -> Doc portrayalToDoc t = portrayalToDocPrec t prettyNormal (-1) +ppInfix :: Ident -> Doc +ppInfix (Ident k nm) = case k of + OpConIdent -> nmDoc + OpIdent -> nmDoc + VarIdent -> wrappedNm + ConIdent -> wrappedNm + where + nmDoc = P.text $ T.unpack nm + wrappedNm = P.char '`' <> nmDoc <> P.char '`' + +ppPrefix :: Ident -> Doc +ppPrefix (Ident k nm) = case k of + OpConIdent -> wrappedNm + OpIdent -> wrappedNm + VarIdent -> nmDoc + ConIdent -> nmDoc + where + nmDoc = P.text $ T.unpack nm + wrappedNm = P.parens nmDoc + ppBinop - :: String + :: Ident -> Infixity -> DocAssocPrec -> DocAssocPrec -> DocAssocPrec ppBinop nm fx@(Infixity assoc opPrec) x y lr p = P.maybeParens (not $ fixityCompatible fx lr p) $ P.sep - [ x (matchCtx AssocL assoc) opPrec P.<+> P.text nm + [ x (matchCtx AssocL assoc) opPrec P.<+> ppInfix nm , P.nest 2 $ y (matchCtx AssocR assoc) opPrec ] @@ -171,7 +192,12 @@ -- | Render one layer of 'PortrayalF' to 'DocAssocPrec'. toDocAssocPrecF :: PortrayalF DocAssocPrec -> DocAssocPrec toDocAssocPrecF = \case - AtomF txt -> \_ _ -> P.text (T.unpack txt) + NameF nm -> \_ _ -> ppPrefix nm + LitIntF x -> \_ _ -> P.text (show x) + LitRatF x -> \_ _ -> P.text (show (fromRational x :: Double)) + LitStrF x -> \_ _ -> P.text (show x) + LitCharF x -> \_ _ -> P.text (show x) + OpaqueF txt -> \_ _ -> P.text (T.unpack txt) ApplyF fn [] -> \_ _ -> fn AssocL 10 ApplyF fn xs -> \lr p -> P.maybeParens (not $ fixityCompatible (Infixity AssocL 10) lr p) $ @@ -179,7 +205,7 @@ [ fn AssocL 10 , P.nest 2 $ P.sep $ xs <&> \docprec -> docprec AssocR 10 ] - BinopF nm fx x y -> ppBinop (T.unpack nm) fx x y + BinopF nm fx x y -> ppBinop nm fx x y TupleF xs -> \_ _ -> ppBulletList "(" "," ")" $ xs <&> \x -> x AssocNope (-1) ListF xs -> \_ _ -> ppBulletList "[" "," "]" $ xs <&> \x -> x AssocNope (-1) LambdaCaseF xs -> \_ p -> @@ -200,7 +226,7 @@ [ con AssocNope 10 , P.nest 2 $ ppBulletList "{" "," "}" [ P.sep - [ P.text (T.unpack sel) P.<+> "=" + [ ppPrefix sel P.<+> "=" , P.nest 2 $ val AssocNope 0 ] | FactorPortrayal sel val <- sels diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -30,65 +30,93 @@ main :: IO () main = defaultMain [ testGroup "Atom" - [ testCase "()" $ prettyShowPortrayal "()" @?= "()" - , testCase "2" $ prettyShowPortrayal "2" @?= "2" + [ testCase "()" $ prettyShowPortrayal (Tuple []) @?= "()" + , testCase "2" $ prettyShowPortrayal (LitInt 2) @?= "2" ] , testGroup "Apply" [ testCase "nullary" $ - prettyShowPortrayal (Apply "Nothing" []) @?= "Nothing" + prettyShowPortrayal (Apply (Name "Nothing") []) @?= "Nothing" , testCase "nullary 2" $ - prettyShowPortrayal (Apply "id" [Apply "Nothing" []]) @?= "id Nothing" + prettyShowPortrayal + (Apply (Name "id") [Apply (Name "Nothing") []]) @?= + "id Nothing" , testCase "unary" $ - prettyShowPortrayal (Apply "Just" ["2"]) @?= "Just 2" + prettyShowPortrayal (Apply (Name "Just") [LitInt 2]) @?= "Just 2" , testCase "parens" $ - prettyShowPortrayal (Apply "Just" [Apply "Just" ["2"]]) @?= + prettyShowPortrayal + (Apply (Name "Just") [Apply (Name "Just") [LitInt 2]]) @?= "Just (Just 2)" , testCase "binary" $ - prettyShowPortrayal (Apply "These" ["2", "4"]) @?= + prettyShowPortrayal (Apply (Name "These") [LitInt 2, LitInt 4]) @?= "These 2 4" , testCase "nested" $ - prettyShowPortrayal (Apply (Apply "These" ["2"]) ["4"]) @?= + prettyShowPortrayal + (Apply (Apply (Name "These") [LitInt 2]) [LitInt 4]) @?= "These 2 4" ] , testGroup "Binop" [ testCase "operator" $ - prettyShowPortrayal (Binop ":|" (infixr_ 5) "5" (List [])) @?= + prettyShowPortrayal + (Binop ":|" (infixr_ 5) (LitInt 5) (List [])) @?= "5 :| []" , testCase "con" $ - prettyShowPortrayal (Binop "`InfixCon`" (infixl_ 9) "2" "True") @?= + prettyShowPortrayal + (Binop + (Ident ConIdent "InfixCon") + (infixl_ 9) + (LitInt 2) + (Name "True")) @?= "2 `InfixCon` True" , testCase "nest prec" $ prettyShowPortrayal - (Binop "+" (infixl_ 6) (Binop "*" (infixl_ 7) "2" "4") "6") @?= + (Binop + "+" + (infixl_ 6) + (Binop "*" (infixl_ 7) (LitInt 2) (LitInt 4)) + (LitInt 6)) @?= "2 * 4 + 6" , testCase "nest anti-prec" $ prettyShowPortrayal - (Binop "*" (infixl_ 7) (Binop "+" (infixl_ 6) "2" "4") "6") @?= + (Binop + "*" + (infixl_ 7) + (Binop "+" (infixl_ 6) (LitInt 2) (LitInt 4)) + (LitInt 6)) @?= "(2 + 4) * 6" , testCase "nest assoc" $ prettyShowPortrayal - (Binop "+" (infixl_ 6) (Binop "+" (infixl_ 6) "2" "4") "6") @?= + (Binop + "+" + (infixl_ 6) + (Binop "+" (infixl_ 6) (LitInt 2) (LitInt 4)) + (LitInt 6)) @?= "2 + 4 + 6" , testCase "nest anti-assoc" $ prettyShowPortrayal - (Binop "+" (infixl_ 6) "2" (Binop "+" (infixl_ 6) "4" "6")) @?= + (Binop + "+" + (infixl_ 6) + (LitInt 2) + (Binop "+" (infixl_ 6) (LitInt 4) (LitInt 6))) @?= "2 + (4 + 6)" ] , testGroup "Tuple" [ testCase "pair" $ - prettyShowPortrayal (Tuple ["2", "4"]) @?= "( 2, 4 )" + prettyShowPortrayal (Tuple [LitInt 2, LitInt 4]) @?= "( 2, 4 )" , testCase "triple" $ - prettyShowPortrayal (Tuple ["2", "4", "6"]) @?= "( 2, 4, 6 )" + prettyShowPortrayal (Tuple [LitInt 2, LitInt 4, LitInt 6]) @?= + "( 2, 4, 6 )" , testCase "line-break" $ - prettyShowPortrayal (Tuple ["222", strAtom (replicate 61 '2')]) @?= + prettyShowPortrayal + (Tuple [strAtom "222", strAtom (replicate 61 '2')]) @?= "( 222\n\ \, 2222222222222222222222222222222222222222222222222222222222222\n\ \)" @@ -96,22 +124,25 @@ , testGroup "List" [ testCase "empty" $ prettyShowPortrayal (List []) @?= "[]" - , testCase "singleton" $ prettyShowPortrayal (List ["2"]) @?= "[ 2 ]" + , testCase "singleton" $ prettyShowPortrayal (List [LitInt 2]) @?= + "[ 2 ]" ] , testGroup "LambdaCase" [ testCase "empty" $ prettyShowPortrayal (LambdaCase []) @?= "\\case {}" , testCase "singleton" $ - prettyShowPortrayal (LambdaCase [("()", "2")]) @?= + prettyShowPortrayal (LambdaCase [(Tuple [], LitInt 2)]) @?= "\\case { () -> 2 }" , testCase "two" $ - prettyShowPortrayal (LambdaCase [("True", "2"), ("False", "4")]) @?= + prettyShowPortrayal + (LambdaCase + [(Name "True", LitInt 2), (Name "False", LitInt 4)]) @?= "\\case { True -> 2; False -> 4 }" , testCase "line-break" $ prettyShowPortrayal (LambdaCase - [ ("True", strAtom (replicate 25 '2')) - , ("False", strAtom (replicate 25 '4')) + [ (Name "True", strAtom (replicate 25 '2')) + , (Name "False", strAtom (replicate 25 '4')) ]) @?= "\\case\n\ \ { True -> 2222222222222222222222222\n\ @@ -119,38 +150,57 @@ \ }" , testCase "no-parens" $ prettyShowPortrayal - (LambdaCase [(Apply "Just" ["2"], Apply "Just" ["4"])]) @?= + (LambdaCase + [( Apply (Name "Just") [LitInt 2] + , Apply (Name "Just") [LitInt 4] + )]) @?= "\\case { Just 2 -> Just 4 }" ] , testGroup "Record" - [ testCase "empty" $ prettyShowPortrayal (Record "Nothing" []) @?= + [ testCase "empty" $ prettyShowPortrayal (Record (Name "Nothing") []) @?= "Nothing" , testCase "singleton" $ - prettyShowPortrayal (Record "Just" [FactorPortrayal "it" "2"]) @?= - "Just { it = 2 }" + prettyShowPortrayal + (Record (Name "Just") [FactorPortrayal "it" (LitInt 2)]) @?= + "Just { it = 2 }" , testCase "two" $ - prettyShowPortrayal - (Record "These" - [FactorPortrayal "l" "2", FactorPortrayal "r" "4"]) @?= - "These { l = 2, r = 4 }" + prettyShowPortrayal + (Record (Name "These") + [ FactorPortrayal "l" (LitInt 2) + , FactorPortrayal "r" (LitInt 4) + ]) @?= + "These { l = 2, r = 4 }" , testCase "line-break" $ - prettyShowPortrayal - (Record "These" + prettyShowPortrayal + (Record (Name "These") [ FactorPortrayal "l" (portray @[Int] [0..10]) , FactorPortrayal "r" (portray @[Int] [0..10]) ]) @?= - "These\n\ - \ { l = [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10 ]\n\ - \ , r = [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10 ]\n\ - \ }" + "These\n\ + \ { l = [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10 ]\n\ + \ , r = [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10 ]\n\ + \ }" + , testCase "break-equals" $ + prettyShowPortrayal + (Record (Name "These") + [ FactorPortrayal + "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" + (Name "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa") + ]) @?= + "These\n\ + \ { aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa =\n\ + \ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\n\ + \ }" ] , testGroup "TyApp" [ testCase "con" $ - prettyShowPortrayal (TyApp "typeRep" "Int") @?= "typeRep @Int" + prettyShowPortrayal (TyApp (Name "typeRep") (Name "Int")) @?= + "typeRep @Int" , testCase "parens" $ - prettyShowPortrayal (TyApp "typeRep" (Apply "Maybe" ["Int"])) @?= + prettyShowPortrayal + (TyApp (Name "typeRep") (Apply (Name "Maybe") [Name "Int"])) @?= "typeRep @(Maybe Int)" , testCase "line-break" $ prettyShowPortrayal @@ -162,10 +212,13 @@ ] , testGroup "TySig" - [ testCase "con" $ prettyShowPortrayal (TySig "2" "Int") @?= "2 :: Int" + [ testCase "con" $ prettyShowPortrayal (TySig (LitInt 2) (Name "Int")) @?= + "2 :: Int" , testCase "no-parens" $ prettyShowPortrayal - (TySig (Apply "Just" ["2"]) (Apply "Maybe" ["Int"])) @?= + (TySig + (Apply (Name "Just") [LitInt 2]) + (Apply (Name "Maybe") [Name "Int"])) @?= "Just 2 :: Maybe Int" , testCase "line-break" $ prettyShowPortrayal @@ -175,7 +228,8 @@ "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\n\ \ :: aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" , testCase "parens" $ - prettyShowPortrayal (Apply "Just" [TySig "2" "Int"]) @?= + prettyShowPortrayal + (Apply (Name "Just") [TySig (LitInt 2) (Name "Int")]) @?= "Just (2 :: Int)" ] ]