diff --git a/src/Purepur/Printer.hs b/src/Purepur/Printer.hs index 90a985e2..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 Purepur.PurescriptPrinter (prettyPrintValue) +import Purepur.PurescriptPrettyPrinter (prettyPrintValue) import Purepur.Types import Text.PrettyPrint.Boxes (Box, render) import Prelude diff --git a/src/Purepur/PurescriptPrinter.hs b/src/Purepur/PurescriptPrettyPrinter.hs similarity index 91% rename from src/Purepur/PurescriptPrinter.hs rename to src/Purepur/PurescriptPrettyPrinter.hs index 476a088a..d9d8bb2a 100644 --- a/src/Purepur/PurescriptPrinter.hs +++ b/src/Purepur/PurescriptPrettyPrinter.hs @@ -1,17 +1,20 @@ -- | -- 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 -- --- from module Language.PureScript.Pretty.Values -module Purepur.PurescriptPrinter +module Purepur.PurescriptPrettyPrinter ( prettyPrintValue , prettyPrintBinder , prettyPrintBinderAtom - , prettyPrintDeclaration ) where import Prelude.Compat hiding ((<>)) -import Control.Arrow (second, (>>>)) +import Control.Arrow (second) import Data.Maybe (maybe) import Data.Text (Text) @@ -69,6 +72,7 @@ prettyPrintValue d (ObjectUpdateNested o ps) = prettyPrintValueAtom (d - 1) o `b 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 @@ -84,15 +88,19 @@ prettyPrintValue d (Let FromLet ds val) = 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) + 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 " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) // + 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 ty) = prettyPrintValue d val <> " :: " <> typeAsBox d ty +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 @@ -104,21 +112,16 @@ 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 _ (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 _ name) = prettyPrintQualifiedName (runOpName >>> T.unpack >>> text) name + 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 @@ -235,4 +238,4 @@ 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 +prettyPrintBinder b = prettyPrintBinderAtom b \ No newline at end of file diff --git a/test/Spec.hs b/test/Spec.hs index 5e48a5ac..c4dcf060 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 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\n c" \ No newline at end of file