From 5ffec38c972bcfafd47bf0899a06492bebf2bd85 Mon Sep 17 00:00:00 2001 From: csicar Date: Thu, 18 Mar 2021 18:40:49 +0100 Subject: [PATCH 1/2] Use Purescript's buildin pretty printer - previously we used a copy of Purescripts' Pretty Printer Code, as the necessary funktion was not exposed --- src/Purepur/Printer.hs | 2 +- src/Purepur/PurescriptPrinter.hs | 238 ------------------------------- test/Spec.hs | 13 +- 3 files changed, 10 insertions(+), 243 deletions(-) delete mode 100644 src/Purepur/PurescriptPrinter.hs diff --git a/src/Purepur/Printer.hs b/src/Purepur/Printer.hs index 90a985e2..d7b07af3 100644 --- a/src/Purepur/Printer.hs +++ b/src/Purepur/Printer.hs @@ -14,7 +14,7 @@ import Language.PureScript.Docs.RenderedCode.Types (outputWith) import Language.PureScript.Interactive.Module (importDecl) import Language.PureScript.Interactive.Types (Command (..), ImportedModule) import Purepur.Parser -import Purepur.PurescriptPrinter (prettyPrintValue) +import Language.PureScript.Pretty.Values (prettyPrintValue) import Purepur.Types import Text.PrettyPrint.Boxes (Box, render) import Prelude diff --git a/src/Purepur/PurescriptPrinter.hs b/src/Purepur/PurescriptPrinter.hs deleted file mode 100644 index 476a088a..00000000 --- a/src/Purepur/PurescriptPrinter.hs +++ /dev/null @@ -1,238 +0,0 @@ --- | --- Pretty printer for values --- --- from module Language.PureScript.Pretty.Values -module Purepur.PurescriptPrinter - ( prettyPrintValue - , prettyPrintBinder - , prettyPrintBinderAtom - , prettyPrintDeclaration - ) where - -import Prelude.Compat hiding ((<>)) - -import Control.Arrow (second, (>>>)) - -import Data.Maybe (maybe) -import Data.Text (Text) -import qualified Data.List.NonEmpty as NEL -import qualified Data.Monoid as Monoid ((<>)) -import qualified Data.Text as T - -import Language.PureScript.AST -import Language.PureScript.Crash -import Language.PureScript.Names -import Language.PureScript.Pretty.Common -import Language.PureScript.Pretty.Types (typeAsBox, typeAtomAsBox, prettyPrintObjectKey) -import Language.PureScript.Types (Constraint(..)) -import Language.PureScript.PSString (PSString, prettyPrintString) - -import Text.PrettyPrint.Boxes - --- TODO(Christoph): remove T.unpack s - -textT :: Text -> Box -textT = text . T.unpack - --- | Render an aligned list of items separated with commas -list :: Char -> Char -> (a -> Box) -> [a] -> Box -list open close _ [] = text [open, close] -list open close f xs = vcat left (zipWith toLine [0 :: Int ..] xs ++ [ text [ close ] ]) - where - toLine i a = text [ if i == 0 then open else ',', ' ' ] <> f a - -ellipsis :: Box -ellipsis = text "..." - -prettyPrintObject :: Int -> [(PSString, Maybe Expr)] -> Box -prettyPrintObject d = list '{' '}' prettyPrintObjectProperty - where - prettyPrintObjectProperty :: (PSString, Maybe Expr) -> Box - prettyPrintObjectProperty (key, value) = textT (prettyPrintObjectKey key Monoid.<> ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value - -prettyPrintUpdateEntry :: Int -> PSString -> Expr -> Box -prettyPrintUpdateEntry d key val = textT (prettyPrintObjectKey key) <> text " = " <> prettyPrintValue (d - 1) val - --- | Pretty-print an expression -prettyPrintValue :: Int -> Expr -> Box -prettyPrintValue d _ | d < 0 = text "..." -prettyPrintValue d (IfThenElse cond th el) = - (text "if " <> prettyPrintValueAtom (d - 1) cond) - // moveRight 2 (vcat left [ text "then " <> prettyPrintValueAtom (d - 1) th - , text "else " <> prettyPrintValueAtom (d - 1) el - ]) -prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val `before` textT ("." Monoid.<> prettyPrintObjectKey prop) -prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' (uncurry (prettyPrintUpdateEntry d)) ps -prettyPrintValue d (ObjectUpdateNested o ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` prettyPrintUpdate ps - where - prettyPrintUpdate (PathTree tree) = list '{' '}' printNode (runAssocList tree) - printNode (key, Leaf val) = prettyPrintUpdateEntry d key val - printNode (key, Branch val) = textT (prettyPrintObjectKey key) `beforeWithSpace` prettyPrintUpdate val -prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg -prettyPrintValue d (Abs arg val) = text ('\\' : T.unpack (prettyPrintBinder arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) -prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) = - text (T.unpack (runProperName (disqualify className)) ++ " ") <> prettyPrintValueAtom (d - 1) ps -prettyPrintValue d (Case values binders) = - (text "case " <> foldr beforeWithSpace (text "of") (map (prettyPrintValueAtom (d - 1)) values)) // - moveRight 2 (vcat left (map (prettyPrintCaseAlternative (d - 1)) binders)) -prettyPrintValue d (Let FromWhere ds val) = - prettyPrintValue (d - 1) val // - moveRight 2 (text "where" // - vcat left (map (prettyPrintDeclaration (d - 1)) ds)) -prettyPrintValue d (Let FromLet ds val) = - text "let" // - moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds)) // - (text "in " <> prettyPrintValue (d - 1) val) -prettyPrintValue d (Do m els) = - textT (maybe "" ((Monoid.<> ".") . runModuleName) m) <> text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) -prettyPrintValue d (Ado m els yield) = - textT (maybe "" ((Monoid.<> ".") . runModuleName) m) <> text "ado " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) // - (text "in " <> prettyPrintValue (d - 1) yield) -prettyPrintValue d (TypeClassDictionary (Constraint _ name _ tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ T.unpack (runProperName (disqualify name))) : map (typeAtomAsBox d) tys -prettyPrintValue _ (DeferredDictionary name _) = text $ "#dict " ++ T.unpack (runProperName (disqualify name)) -prettyPrintValue _ (TypeClassDictionaryAccessor className ident) = - text "#dict-accessor " <> text (T.unpack (runProperName (disqualify className))) <> text "." <> text (T.unpack (showIdent ident)) <> text ">" -prettyPrintValue d (TypedValue _ val ty) = prettyPrintValue d val <> " :: " <> typeAsBox d ty -prettyPrintValue d (PositionedValue _ _ val) = prettyPrintValue d val -prettyPrintValue d (Literal _ l) = prettyPrintLiteralValue d l -prettyPrintValue _ (Hole name) = text "?" <> textT name -prettyPrintValue d expr@AnonymousArgument{} = prettyPrintValueAtom d expr -prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr -prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr -prettyPrintValue d expr@Op{} = prettyPrintValueAtom d expr -prettyPrintValue d expr@BinaryNoParens{} = prettyPrintValueAtom d expr -prettyPrintValue d expr@Parens{} = prettyPrintValueAtom d expr -prettyPrintValue d expr@UnaryMinus{} = prettyPrintValueAtom d expr - -prettyPrintQualifiedName :: (a -> Box) -> Qualified a -> Box -prettyPrintQualifiedName f (Qualified Nothing ident) = f ident -prettyPrintQualifiedName f (Qualified (Just mod) ident) = text (T.unpack $ runModuleName mod) <> text "." <> f ident - - --- | Pretty-print an atomic expression, adding parentheses if necessary. -prettyPrintValueAtom :: Int -> Expr -> Box -prettyPrintValueAtom d (Literal _ l) = prettyPrintLiteralValue d l -prettyPrintValueAtom _ AnonymousArgument = text "_" -prettyPrintValueAtom _ (Constructor _ name) = prettyPrintQualifiedName (runProperName >>> T.unpack >>> text) name -prettyPrintValueAtom _ (Var _ ident) = prettyPrintQualifiedName (showIdent >>> T.unpack >>> text) ident -prettyPrintValueAtom d (BinaryNoParens op lhs rhs) = - prettyPrintValue (d - 1) lhs `beforeWithSpace` printOp op `beforeWithSpace` prettyPrintValue (d - 1) rhs - where - printOp (Op _ name) = prettyPrintQualifiedName (runOpName >>> T.unpack >>> text) name - printOp expr = text "`" <> prettyPrintValue (d - 1) expr `before` text "`" -prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val -prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val -prettyPrintValueAtom d (Parens expr) = (text "(" <> prettyPrintValue d expr) `before` text ")" -prettyPrintValueAtom d (UnaryMinus _ expr) = text "(-" <> prettyPrintValue d expr <> text ")" -prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` text ")" - -prettyPrintLiteralValue :: Int -> Literal Expr -> Box -prettyPrintLiteralValue _ (NumericLiteral n) = text $ either show show n -prettyPrintLiteralValue _ (StringLiteral s) = text $ T.unpack $ prettyPrintString s -prettyPrintLiteralValue _ (CharLiteral c) = text $ show c -prettyPrintLiteralValue _ (BooleanLiteral True) = text "true" -prettyPrintLiteralValue _ (BooleanLiteral False) = text "false" -prettyPrintLiteralValue d (ArrayLiteral xs) = list '[' ']' (prettyPrintValue (d - 1)) xs -prettyPrintLiteralValue d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ second Just `map` ps - -prettyPrintDeclaration :: Int -> Declaration -> Box -prettyPrintDeclaration d _ | d < 0 = ellipsis -prettyPrintDeclaration d (TypeDeclaration td) = - text (T.unpack (showIdent (tydeclIdent td)) ++ " :: ") <> typeAsBox d (tydeclType td) -prettyPrintDeclaration d (ValueDecl _ ident _ [] [GuardedExpr [] val]) = - text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d - 1) val -prettyPrintDeclaration d (BindingGroupDeclaration ds) = - vsep 1 left (NEL.toList (fmap (prettyPrintDeclaration (d - 1) . toDecl) ds)) - where - toDecl ((sa, nm), t, e) = ValueDecl sa nm t [] [GuardedExpr [] e] -prettyPrintDeclaration _ _ = internalError "Invalid argument to prettyPrintDeclaration" - -prettyPrintCaseAlternative :: Int -> CaseAlternative -> Box -prettyPrintCaseAlternative d _ | d < 0 = ellipsis -prettyPrintCaseAlternative d (CaseAlternative binders result) = - text (T.unpack (T.unwords (map prettyPrintBinderAtom binders))) <> prettyPrintResult result - where - prettyPrintResult :: [GuardedExpr] -> Box - prettyPrintResult [GuardedExpr [] v] = text " -> " <> prettyPrintValue (d - 1) v - prettyPrintResult gs = - vcat left (map (prettyPrintGuardedValueSep (text " | ")) gs) - - prettyPrintGuardedValueSep :: Box -> GuardedExpr -> Box - prettyPrintGuardedValueSep _ (GuardedExpr [] val) = - text " -> " <> prettyPrintValue (d - 1) val - - prettyPrintGuardedValueSep sep (GuardedExpr [guard] val) = - foldl1 before [ sep - , prettyPrintGuard guard - , prettyPrintGuardedValueSep sep (GuardedExpr [] val) - ] - - prettyPrintGuardedValueSep sep (GuardedExpr (guard : guards) val) = - vcat left [ foldl1 before - [ sep - , prettyPrintGuard guard - ] - , prettyPrintGuardedValueSep (text " , ") (GuardedExpr guards val) - ] - - prettyPrintGuard (ConditionGuard cond) = - prettyPrintValue (d - 1) cond - prettyPrintGuard (PatternGuard binder val) = - foldl1 before - [ text (T.unpack (prettyPrintBinder binder)) - , text " <- " - , prettyPrintValue (d - 1) val - ] - -prettyPrintDoNotationElement :: Int -> DoNotationElement -> Box -prettyPrintDoNotationElement d _ | d < 0 = ellipsis -prettyPrintDoNotationElement d (DoNotationValue val) = - prettyPrintValue d val -prettyPrintDoNotationElement d (DoNotationBind binder val) = - textT (prettyPrintBinder binder Monoid.<> " <- ") <> prettyPrintValue d val -prettyPrintDoNotationElement d (DoNotationLet ds) = - text "let" // - moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds)) -prettyPrintDoNotationElement d (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement d el - -prettyPrintBinderAtom :: Binder -> Text -prettyPrintBinderAtom NullBinder = "_" -prettyPrintBinderAtom (LiteralBinder _ l) = prettyPrintLiteralBinder l -prettyPrintBinderAtom (VarBinder _ ident) = showIdent ident -prettyPrintBinderAtom (ConstructorBinder _ ctor []) = runProperName (disqualify ctor) -prettyPrintBinderAtom b@ConstructorBinder{} = parensT (prettyPrintBinder b) -prettyPrintBinderAtom (NamedBinder _ ident binder) = showIdent ident Monoid.<> "@" Monoid.<> prettyPrintBinder binder -prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder -prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder -prettyPrintBinderAtom (OpBinder _ op) = runOpName (disqualify op) -prettyPrintBinderAtom (BinaryNoParensBinder op b1 b2) = - prettyPrintBinderAtom b1 Monoid.<> " " Monoid.<> prettyPrintBinderAtom op Monoid.<> " " Monoid.<> prettyPrintBinderAtom b2 -prettyPrintBinderAtom (ParensInBinder b) = parensT (prettyPrintBinder b) - -prettyPrintLiteralBinder :: Literal Binder -> Text -prettyPrintLiteralBinder (StringLiteral str) = prettyPrintString str -prettyPrintLiteralBinder (CharLiteral c) = T.pack (show c) -prettyPrintLiteralBinder (NumericLiteral num) = either (T.pack . show) (T.pack . show) num -prettyPrintLiteralBinder (BooleanLiteral True) = "true" -prettyPrintLiteralBinder (BooleanLiteral False) = "false" -prettyPrintLiteralBinder (ObjectLiteral bs) = - "{ " - Monoid.<> T.intercalate ", " (map prettyPrintObjectPropertyBinder bs) - Monoid.<> " }" - where - prettyPrintObjectPropertyBinder :: (PSString, Binder) -> Text - prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key Monoid.<> ": " Monoid.<> prettyPrintBinder binder -prettyPrintLiteralBinder (ArrayLiteral bs) = - "[ " - Monoid.<> T.intercalate ", " (map prettyPrintBinder bs) - Monoid.<> " ]" - --- | --- Generate a pretty-printed string representing a Binder --- -prettyPrintBinder :: Binder -> Text -prettyPrintBinder (ConstructorBinder _ ctor []) = runProperName (disqualify ctor) -prettyPrintBinder (ConstructorBinder _ ctor args) = (runProperName (disqualify ctor)) Monoid.<> " " Monoid.<> T.unwords (map prettyPrintBinderAtom args) -prettyPrintBinder (PositionedBinder _ _ binder) = prettyPrintBinder binder -prettyPrintBinder (TypedBinder _ binder) = prettyPrintBinder binder -prettyPrintBinder b = prettyPrintBinderAtom b diff --git a/test/Spec.hs b/test/Spec.hs index 5e48a5ac..199acff5 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,6 +2,7 @@ import Test.Hspec import Purepur.Parser +import qualified Purepur.Printer as Printer import Data.Text as T import qualified Language.PureScript.Names as Purs import qualified Language.PureScript.AST as AST @@ -10,7 +11,7 @@ import qualified Language.PureScript.Interactive.Types as Psci main :: IO () -main = hspec $ +main = hspec $ do describe "Parse Comment" $ do let importT = Command $ Psci.Import (Purs.moduleNameFromString "T", AST.Implicit, Nothing) @@ -25,6 +26,10 @@ main = hspec $ it "multi-statement" $ parseInfoBlock "> import\n T\n123" `shouldBe` Right [importT, ExpectedOutput "123"] - -- describe "Pretty Print" $ do - -- it "print qualified op" $ - -- pretty \ No newline at end of file + + describe "Pretty Print" $ do + it "print qualified op" $ do + let Right [doBlock, expectedOutput] = parseInfoBlock "> do\n a\n b\nunit" + case doBlock of + Command (Psci.Expression e) -> + Printer.printExpression e `shouldBe` "do\n a\n b" \ No newline at end of file From b97d812b93a8e7dfa4695934c5e02936034bd96e Mon Sep 17 00:00:00 2001 From: csicar Date: Thu, 18 Mar 2021 19:06:27 +0100 Subject: [PATCH 2/2] PoC implementation --- src/Purepur/Printer.hs | 2 +- src/Purepur/PurescriptPrettyPrinter.hs | 241 +++++++++++++++++++++++++ test/Spec.hs | 6 +- 3 files changed, 245 insertions(+), 4 deletions(-) create mode 100644 src/Purepur/PurescriptPrettyPrinter.hs diff --git a/src/Purepur/Printer.hs b/src/Purepur/Printer.hs index d7b07af3..e7d9baf8 100644 --- a/src/Purepur/Printer.hs +++ b/src/Purepur/Printer.hs @@ -14,7 +14,7 @@ import Language.PureScript.Docs.RenderedCode.Types (outputWith) import Language.PureScript.Interactive.Module (importDecl) import Language.PureScript.Interactive.Types (Command (..), ImportedModule) import Purepur.Parser -import Language.PureScript.Pretty.Values (prettyPrintValue) +import Purepur.PurescriptPrettyPrinter (prettyPrintValue) import Purepur.Types import Text.PrettyPrint.Boxes (Box, render) import Prelude diff --git a/src/Purepur/PurescriptPrettyPrinter.hs b/src/Purepur/PurescriptPrettyPrinter.hs new file mode 100644 index 00000000..d9d8bb2a --- /dev/null +++ b/src/Purepur/PurescriptPrettyPrinter.hs @@ -0,0 +1,241 @@ +-- | +-- Pretty printer for values +-- Copied from https://github.com/purescript/purescript/blob/master/src/Language/PureScript/Pretty/Values.hs +-- +-- In theory, this module can be replaced by purescript's own pretty printer +-- Changes to the building: +-- - fix do notation pretty printing +-- +module Purepur.PurescriptPrettyPrinter + ( prettyPrintValue + , prettyPrintBinder + , prettyPrintBinderAtom + ) where + +import Prelude.Compat hiding ((<>)) + +import Control.Arrow (second) + +import Data.Maybe (maybe) +import Data.Text (Text) +import qualified Data.List.NonEmpty as NEL +import qualified Data.Monoid as Monoid ((<>)) +import qualified Data.Text as T + +import Language.PureScript.AST +import Language.PureScript.Crash +import Language.PureScript.Names +import Language.PureScript.Pretty.Common +import Language.PureScript.Pretty.Types (typeAsBox, typeAtomAsBox, prettyPrintObjectKey) +import Language.PureScript.Types (Constraint(..)) +import Language.PureScript.PSString (PSString, prettyPrintString) + +import Text.PrettyPrint.Boxes + +-- TODO(Christoph): remove T.unpack s + +textT :: Text -> Box +textT = text . T.unpack + +-- | Render an aligned list of items separated with commas +list :: Char -> Char -> (a -> Box) -> [a] -> Box +list open close _ [] = text [open, close] +list open close f xs = vcat left (zipWith toLine [0 :: Int ..] xs ++ [ text [ close ] ]) + where + toLine i a = text [ if i == 0 then open else ',', ' ' ] <> f a + +ellipsis :: Box +ellipsis = text "..." + +prettyPrintObject :: Int -> [(PSString, Maybe Expr)] -> Box +prettyPrintObject d = list '{' '}' prettyPrintObjectProperty + where + prettyPrintObjectProperty :: (PSString, Maybe Expr) -> Box + prettyPrintObjectProperty (key, value) = textT (prettyPrintObjectKey key Monoid.<> ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value + +prettyPrintUpdateEntry :: Int -> PSString -> Expr -> Box +prettyPrintUpdateEntry d key val = textT (prettyPrintObjectKey key) <> text " = " <> prettyPrintValue (d - 1) val + +-- | Pretty-print an expression +prettyPrintValue :: Int -> Expr -> Box +prettyPrintValue d _ | d < 0 = text "..." +prettyPrintValue d (IfThenElse cond th el) = + (text "if " <> prettyPrintValueAtom (d - 1) cond) + // moveRight 2 (vcat left [ text "then " <> prettyPrintValueAtom (d - 1) th + , text "else " <> prettyPrintValueAtom (d - 1) el + ]) +prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val `before` textT ("." Monoid.<> prettyPrintObjectKey prop) +prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' (uncurry (prettyPrintUpdateEntry d)) ps +prettyPrintValue d (ObjectUpdateNested o ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` prettyPrintUpdate ps + where + prettyPrintUpdate (PathTree tree) = list '{' '}' printNode (runAssocList tree) + printNode (key, Leaf val) = prettyPrintUpdateEntry d key val + printNode (key, Branch val) = textT (prettyPrintObjectKey key) `beforeWithSpace` prettyPrintUpdate val +prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg +prettyPrintValue d (Unused val) = prettyPrintValue d val +prettyPrintValue d (Abs arg val) = text ('\\' : T.unpack (prettyPrintBinder arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) +prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) = + text (T.unpack (runProperName (disqualify className)) ++ " ") <> prettyPrintValueAtom (d - 1) ps +prettyPrintValue d (Case values binders) = + (text "case " <> foldr beforeWithSpace (text "of") (map (prettyPrintValueAtom (d - 1)) values)) // + moveRight 2 (vcat left (map (prettyPrintCaseAlternative (d - 1)) binders)) +prettyPrintValue d (Let FromWhere ds val) = + prettyPrintValue (d - 1) val // + moveRight 2 (text "where" // + vcat left (map (prettyPrintDeclaration (d - 1)) ds)) +prettyPrintValue d (Let FromLet ds val) = + text "let" // + moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds)) // + (text "in " <> prettyPrintValue (d - 1) val) +prettyPrintValue d (Do m els) = + vcat left + [textT (maybe "" ((Monoid.<> ".") . runModuleName) m) <> text "do" + , vcat left $ map (" "<>) $ map (prettyPrintDoNotationElement (d - 1)) els + ] +prettyPrintValue d (Ado m els yield) = + textT (maybe "" ((Monoid.<> ".") . runModuleName) m) <> text "ado\n" <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) // + (text "in " <> prettyPrintValue (d - 1) yield) +-- TODO: constraint kind args +prettyPrintValue d (TypeClassDictionary (Constraint _ name _ tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ T.unpack (runProperName (disqualify name))) : map (typeAtomAsBox d) tys +prettyPrintValue _ (DeferredDictionary name _) = text $ "#dict " ++ T.unpack (runProperName (disqualify name)) +prettyPrintValue _ (TypeClassDictionaryAccessor className ident) = + text "#dict-accessor " <> text (T.unpack (runProperName (disqualify className))) <> text "." <> text (T.unpack (showIdent ident)) <> text ">" +prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val +prettyPrintValue d (PositionedValue _ _ val) = prettyPrintValue d val +prettyPrintValue d (Literal _ l) = prettyPrintLiteralValue d l +prettyPrintValue _ (Hole name) = text "?" <> textT name +prettyPrintValue d expr@AnonymousArgument{} = prettyPrintValueAtom d expr +prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr +prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr +prettyPrintValue d expr@Op{} = prettyPrintValueAtom d expr +prettyPrintValue d expr@BinaryNoParens{} = prettyPrintValueAtom d expr +prettyPrintValue d expr@Parens{} = prettyPrintValueAtom d expr +prettyPrintValue d expr@UnaryMinus{} = prettyPrintValueAtom d expr + +-- | Pretty-print an atomic expression, adding parentheses if necessary. +prettyPrintValueAtom :: Int -> Expr -> Box +prettyPrintValueAtom d (Literal _ l) = prettyPrintLiteralValue d l +prettyPrintValueAtom _ AnonymousArgument = text "_" +prettyPrintValueAtom _ (Constructor _ name) = text $ T.unpack $ runProperName (disqualify name) +prettyPrintValueAtom _ (Var _ ident) = text $ T.unpack $ showIdent (disqualify ident) +prettyPrintValueAtom d (BinaryNoParens op lhs rhs) = + prettyPrintValue (d - 1) lhs `beforeWithSpace` printOp op `beforeWithSpace` prettyPrintValue (d - 1) rhs + where + printOp (Op _ (Qualified _ name)) = text $ T.unpack $ runOpName name + printOp expr = text "`" <> prettyPrintValue (d - 1) expr `before` text "`" +prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val +prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val +prettyPrintValueAtom d (Parens expr) = (text "(" <> prettyPrintValue d expr) `before` text ")" +prettyPrintValueAtom d (UnaryMinus _ expr) = text "(-" <> prettyPrintValue d expr <> text ")" +prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` text ")" + +prettyPrintLiteralValue :: Int -> Literal Expr -> Box +prettyPrintLiteralValue _ (NumericLiteral n) = text $ either show show n +prettyPrintLiteralValue _ (StringLiteral s) = text $ T.unpack $ prettyPrintString s +prettyPrintLiteralValue _ (CharLiteral c) = text $ show c +prettyPrintLiteralValue _ (BooleanLiteral True) = text "true" +prettyPrintLiteralValue _ (BooleanLiteral False) = text "false" +prettyPrintLiteralValue d (ArrayLiteral xs) = list '[' ']' (prettyPrintValue (d - 1)) xs +prettyPrintLiteralValue d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ second Just `map` ps + +prettyPrintDeclaration :: Int -> Declaration -> Box +prettyPrintDeclaration d _ | d < 0 = ellipsis +prettyPrintDeclaration d (TypeDeclaration td) = + text (T.unpack (showIdent (tydeclIdent td)) ++ " :: ") <> typeAsBox d (tydeclType td) +prettyPrintDeclaration d (ValueDecl _ ident _ [] [GuardedExpr [] val]) = + text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d - 1) val +prettyPrintDeclaration d (BindingGroupDeclaration ds) = + vsep 1 left (NEL.toList (fmap (prettyPrintDeclaration (d - 1) . toDecl) ds)) + where + toDecl ((sa, nm), t, e) = ValueDecl sa nm t [] [GuardedExpr [] e] +prettyPrintDeclaration _ _ = internalError "Invalid argument to prettyPrintDeclaration" + +prettyPrintCaseAlternative :: Int -> CaseAlternative -> Box +prettyPrintCaseAlternative d _ | d < 0 = ellipsis +prettyPrintCaseAlternative d (CaseAlternative binders result) = + text (T.unpack (T.unwords (map prettyPrintBinderAtom binders))) <> prettyPrintResult result + where + prettyPrintResult :: [GuardedExpr] -> Box + prettyPrintResult [GuardedExpr [] v] = text " -> " <> prettyPrintValue (d - 1) v + prettyPrintResult gs = + vcat left (map (prettyPrintGuardedValueSep (text " | ")) gs) + + prettyPrintGuardedValueSep :: Box -> GuardedExpr -> Box + prettyPrintGuardedValueSep _ (GuardedExpr [] val) = + text " -> " <> prettyPrintValue (d - 1) val + + prettyPrintGuardedValueSep sep (GuardedExpr [guard] val) = + foldl1 before [ sep + , prettyPrintGuard guard + , prettyPrintGuardedValueSep sep (GuardedExpr [] val) + ] + + prettyPrintGuardedValueSep sep (GuardedExpr (guard : guards) val) = + vcat left [ foldl1 before + [ sep + , prettyPrintGuard guard + ] + , prettyPrintGuardedValueSep (text " , ") (GuardedExpr guards val) + ] + + prettyPrintGuard (ConditionGuard cond) = + prettyPrintValue (d - 1) cond + prettyPrintGuard (PatternGuard binder val) = + foldl1 before + [ text (T.unpack (prettyPrintBinder binder)) + , text " <- " + , prettyPrintValue (d - 1) val + ] + +prettyPrintDoNotationElement :: Int -> DoNotationElement -> Box +prettyPrintDoNotationElement d _ | d < 0 = ellipsis +prettyPrintDoNotationElement d (DoNotationValue val) = + prettyPrintValue d val +prettyPrintDoNotationElement d (DoNotationBind binder val) = + textT (prettyPrintBinder binder Monoid.<> " <- ") <> prettyPrintValue d val +prettyPrintDoNotationElement d (DoNotationLet ds) = + text "let" // + moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds)) +prettyPrintDoNotationElement d (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement d el + +prettyPrintBinderAtom :: Binder -> Text +prettyPrintBinderAtom NullBinder = "_" +prettyPrintBinderAtom (LiteralBinder _ l) = prettyPrintLiteralBinder l +prettyPrintBinderAtom (VarBinder _ ident) = showIdent ident +prettyPrintBinderAtom (ConstructorBinder _ ctor []) = runProperName (disqualify ctor) +prettyPrintBinderAtom b@ConstructorBinder{} = parensT (prettyPrintBinder b) +prettyPrintBinderAtom (NamedBinder _ ident binder) = showIdent ident Monoid.<> "@" Monoid.<> prettyPrintBinder binder +prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder +prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder +prettyPrintBinderAtom (OpBinder _ op) = runOpName (disqualify op) +prettyPrintBinderAtom (BinaryNoParensBinder op b1 b2) = + prettyPrintBinderAtom b1 Monoid.<> " " Monoid.<> prettyPrintBinderAtom op Monoid.<> " " Monoid.<> prettyPrintBinderAtom b2 +prettyPrintBinderAtom (ParensInBinder b) = parensT (prettyPrintBinder b) + +prettyPrintLiteralBinder :: Literal Binder -> Text +prettyPrintLiteralBinder (StringLiteral str) = prettyPrintString str +prettyPrintLiteralBinder (CharLiteral c) = T.pack (show c) +prettyPrintLiteralBinder (NumericLiteral num) = either (T.pack . show) (T.pack . show) num +prettyPrintLiteralBinder (BooleanLiteral True) = "true" +prettyPrintLiteralBinder (BooleanLiteral False) = "false" +prettyPrintLiteralBinder (ObjectLiteral bs) = + "{ " + Monoid.<> T.intercalate ", " (map prettyPrintObjectPropertyBinder bs) + Monoid.<> " }" + where + prettyPrintObjectPropertyBinder :: (PSString, Binder) -> Text + prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key Monoid.<> ": " Monoid.<> prettyPrintBinder binder +prettyPrintLiteralBinder (ArrayLiteral bs) = + "[ " + Monoid.<> T.intercalate ", " (map prettyPrintBinder bs) + Monoid.<> " ]" + +-- | +-- Generate a pretty-printed string representing a Binder +-- +prettyPrintBinder :: Binder -> Text +prettyPrintBinder (ConstructorBinder _ ctor []) = runProperName (disqualify ctor) +prettyPrintBinder (ConstructorBinder _ ctor args) = (runProperName (disqualify ctor)) Monoid.<> " " Monoid.<> T.unwords (map prettyPrintBinderAtom args) +prettyPrintBinder (PositionedBinder _ _ binder) = prettyPrintBinder binder +prettyPrintBinder (TypedBinder _ binder) = prettyPrintBinder binder +prettyPrintBinder b = prettyPrintBinderAtom b \ No newline at end of file diff --git a/test/Spec.hs b/test/Spec.hs index 199acff5..c4dcf060 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -28,8 +28,8 @@ main = hspec $ do parseInfoBlock "> import\n T\n123" `shouldBe` Right [importT, ExpectedOutput "123"] describe "Pretty Print" $ do - it "print qualified op" $ do - let Right [doBlock, expectedOutput] = parseInfoBlock "> do\n a\n b\nunit" + it "print do block" $ do + let Right [doBlock, expectedOutput] = parseInfoBlock "> do\n a\n b\n c\nunit" case doBlock of Command (Psci.Expression e) -> - Printer.printExpression e `shouldBe` "do\n a\n b" \ No newline at end of file + Printer.printExpression e `shouldBe` "do \n a\n b\n c" \ No newline at end of file