0c35b83 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Use boxes library to print types and values.

0c35b83Phil Freeman11 years ago

src/Language/PureScript/Errors.hs+92−55

compare with golang

unifiedsplit

@@ -427,7 +427,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

427 ]

428 goSimple (ErrorParsingExterns err) =

429 paras [ lineWithLevel "parsing externs files: "

430− , indent . prettyPrintParseError $ err

430+ , prettyPrintParseError err

431 ]

432 goSimple (ErrorParsingFFIModule path) =

433 paras [ line "Unable to parse module from FFI file: "

@@ -435,7 +435,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

435 ]

436 goSimple (ErrorParsingModule err) =

437 paras [ line "Unable to parse module: "

438− , indent . prettyPrintParseError $ err

438+ , prettyPrintParseError err

439 ]

440 goSimple (MissingFFIModule mn) =

441 line $ "Missing FFI implementations for module " ++ runModuleName mn

@@ -444,8 +444,9 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

444 , indent . line $ path

445 ]

446 goSimple (MultipleFFIModules mn paths) =

447− paras $ [ line $ "Multiple FFI implementations have been provided for module " ++ runModuleName mn ++ ": " ]

447+ paras [ line $ "Multiple FFI implementations have been provided for module " ++ runModuleName mn ++ ": "

448− ++ map (indent . line) paths

448+ , indent . paras $ map line paths

449+ ]

449 goSimple (InvalidExternsFile path) =

450 goSimple (InvalidExternsFile path) =

450 paras [ line "Externs file is invalid: "

451 paras [ line "Externs file is invalid: "

451 , indent . line $ path

452 , indent . line $ path

@@ -462,11 +463,11 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

462 line "Overlapping names in let binding."

463 line "Overlapping names in let binding."

463 goSimple (InfiniteType ty) =

464 goSimple (InfiniteType ty) =

464 paras [ line "An infinite type was inferred for an expression: "

465 paras [ line "An infinite type was inferred for an expression: "

465− , indent $ line $ prettyPrintType ty

466+ , indent $ typeAsBox ty

466 ]

467 ]

467 goSimple (InfiniteKind ki) =

468 goSimple (InfiniteKind ki) =

468 paras [ line "An infinite kind was inferred for a type: "

469 paras [ line "An infinite kind was inferred for a type: "

469− , indent $ line $ prettyPrintKind ki

470+ , indent $ kindAsBox ki

470 ]

471 ]

471 goSimple (MultipleFixities name) =

472 goSimple (MultipleFixities name) =

472 line $ "Multiple fixity declarations for " ++ showIdent name

473 line $ "Multiple fixity declarations for " ++ showIdent name

@@ -475,8 +476,9 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

475 goSimple (OrphanFixityDeclaration op) =

476 goSimple (OrphanFixityDeclaration op) =

476 line $ "Orphan fixity declaration for " ++ show op

477 line $ "Orphan fixity declaration for " ++ show op

477 goSimple (RedefinedModule name filenames) =

478 goSimple (RedefinedModule name filenames) =

478− paras $ line ("Module " ++ runModuleName name ++ " has been defined multiple times:")

479+ paras [ line ("Module " ++ runModuleName name ++ " has been defined multiple times:")

479− : map (indent . line . displaySourceSpan) filenames

480+ , indent . paras $ map (line . displaySourceSpan) filenames

481+ ]

480 goSimple (RedefinedIdent name) =

482 goSimple (RedefinedIdent name) =

481 line $ "Name " ++ showIdent name ++ " has been defined multiple times"

483 line $ "Name " ++ showIdent name ++ " has been defined multiple times"

482 goSimple (UnknownModule mn) =

484 goSimple (UnknownModule mn) =

@@ -548,43 +550,60 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

548 goSimple (EscapedSkolem binding) =

550 goSimple (EscapedSkolem binding) =

549 paras $ [ line "A type variable has escaped its scope." ]

551 paras $ [ line "A type variable has escaped its scope." ]

550 <> foldMap (\expr -> [ line "Relevant expression: "

552 <> foldMap (\expr -> [ line "Relevant expression: "

551− , indent $ line $ prettyPrintValue expr

553+ , indent $ prettyPrintValue expr

552 ]) binding

554 ]) binding

553 goSimple (TypesDoNotUnify t1 t2)

555 goSimple (TypesDoNotUnify t1 t2)

554 = paras [ line "Cannot unify type"

556 = paras [ line "Cannot unify type"

555− , indent $ line $ prettyPrintType t1

557+ , indent $ typeAsBox t1

556 , line "with type"

558 , line "with type"

557− , indent $ line $ prettyPrintType t2

559+ , indent $ typeAsBox t2

558 ]

560 ]

559 goSimple (KindsDoNotUnify k1 k2) =

561 goSimple (KindsDoNotUnify k1 k2) =

560 paras [ line "Cannot unify kind"

562 paras [ line "Cannot unify kind"

561− , indent $ line $ prettyPrintKind k1

563+ , indent $ kindAsBox k1

562 , line "with kind"

564 , line "with kind"

563− , indent $ line $ prettyPrintKind k2

565+ , indent $ kindAsBox k2

564 ]

566 ]

565 goSimple (ConstrainedTypeUnified t1 t2) =

567 goSimple (ConstrainedTypeUnified t1 t2) =

566 paras [ line "Cannot unify constrained type"

568 paras [ line "Cannot unify constrained type"

567− , indent $ line $ prettyPrintType t1

569+ , indent $ typeAsBox t1

568 , line "with type"

570 , line "with type"

569− , indent $ line $ prettyPrintType t2

571+ , indent $ typeAsBox t2

570 ]

572 ]

571 goSimple (OverlappingInstances nm ts (d : ds)) =

573 goSimple (OverlappingInstances nm ts (d : ds)) =

572− paras [ line $ "Overlapping instances found for " ++ showQualified runProperName nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"

574+ paras [ line "Overlapping instances found for"

575+ , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

576+ , Box.vcat Box.left (map typeAtomAsBox ts)

577+ ]

578+ , line "The following instances were found:"

573 , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds)

579 , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds)

574 ]

580 ]

575 goSimple OverlappingInstances{} = error "OverlappingInstances: empty instance list"

581 goSimple OverlappingInstances{} = error "OverlappingInstances: empty instance list"

576 goSimple (NoInstanceFound nm ts) =

582 goSimple (NoInstanceFound nm ts) =

583+ paras [ line "No instance found for"

577− line $ "No instance found for " ++ showQualified runProperName nm ++ " " ++ unwords (map prettyPrintTypeAtom ts)

584+ , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

585+ , Box.vcat Box.left (map typeAtomAsBox ts)

586+ ]

587+ ]

578 goSimple (PossiblyInfiniteInstance nm ts) =

588 goSimple (PossiblyInfiniteInstance nm ts) =

579− line $ "Instance for " ++ showQualified runProperName nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ " is possibly infinite."

589+ paras [ line "Instance for"

590+ , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

591+ , Box.vcat Box.left (map typeAtomAsBox ts)

592+ ]

593+ , line "is possibly infinite."

594+ ]

580 goSimple (CannotDerive nm ts) =

595 goSimple (CannotDerive nm ts) =

596+ paras [ line "Cannot derive an instance for"

581− line $ "Cannot derive " ++ showQualified runProperName nm ++ " instance for " ++ unwords (map prettyPrintTypeAtom ts)

597+ , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

598+ , Box.vcat Box.left (map typeAtomAsBox ts)

599+ ]

600+ ]

582 goSimple (CannotFindDerivingType nm) =

601 goSimple (CannotFindDerivingType nm) =

583 line $ "Cannot derive instance, because the type declaration for " ++ runProperName nm ++ " could not be found."

602 line $ "Cannot derive instance, because the type declaration for " ++ runProperName nm ++ " could not be found."

584 goSimple (DuplicateLabel l expr) =

603 goSimple (DuplicateLabel l expr) =

585 paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ]

604 paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ]

586 <> foldMap (\expr' -> [ line "Relevant expression: "

605 <> foldMap (\expr' -> [ line "Relevant expression: "

587− , indent $ line $ prettyPrintValue expr'

606+ , indent $ prettyPrintValue expr'

588 ]) expr

607 ]) expr

589 goSimple (DuplicateTypeArgument name) =

608 goSimple (DuplicateTypeArgument name) =

590 line $ "Duplicate type argument " ++ show name

609 line $ "Duplicate type argument " ++ show name

@@ -600,29 +619,40 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

600 line $ "Member " ++ showIdent ident ++ " is not a member of the class being instantiated"

619 line $ "Member " ++ showIdent ident ++ " is not a member of the class being instantiated"

601 goSimple (ExpectedType ty kind) =

620 goSimple (ExpectedType ty kind) =

602 paras [ line "In a type-annotated expression x :: t, the type t must have kind *."

621 paras [ line "In a type-annotated expression x :: t, the type t must have kind *."

603− , line $ "The error arises from the type " ++ prettyPrintType ty ++ " having the kind " ++ prettyPrintKind kind ++ " instead."

622+ , line "The error arises from the type"

623+ , indent $ typeAsBox ty

624+ , line "having the kind"

625+ , indent $ kindAsBox kind

626+ , line "instead."

604 ]

627 ]

605 goSimple (IncorrectConstructorArity nm) =

628 goSimple (IncorrectConstructorArity nm) =

606 line $ "Wrong number of arguments to constructor " ++ showQualified runProperName nm

629 line $ "Wrong number of arguments to constructor " ++ showQualified runProperName nm

607 goSimple SubsumptionCheckFailed = line "Unable to check type subsumption"

630 goSimple SubsumptionCheckFailed = line "Unable to check type subsumption"

608 goSimple (ExprDoesNotHaveType expr ty) =

631 goSimple (ExprDoesNotHaveType expr ty) =

609 paras [ line "Expression"

632 paras [ line "Expression"

610− , indent $ line $ prettyPrintValue expr

633+ , indent $ prettyPrintValue expr

611 , line "does not have type"

634 , line "does not have type"

612− , indent $ line $ prettyPrintType ty

635+ , indent $ typeAsBox ty

613 ]

636 ]

614 goSimple (PropertyIsMissing prop row) =

637 goSimple (PropertyIsMissing prop row) =

638+ paras [ line "Row"

639+ , indent $ prettyPrintRowWith '(' ')' row

615− line $ "Row " ++ prettyPrintRow row ++ " lacks required property " ++ show prop

640+ , line $ "lacks required property " ++ show prop

641+ ]

616 goSimple (CannotApplyFunction fn arg) =

642 goSimple (CannotApplyFunction fn arg) =

617 paras [ line "Cannot apply function of type"

643 paras [ line "Cannot apply function of type"

618− , indent $ line $ prettyPrintType fn

644+ , indent $ typeAsBox fn

619 , line "to argument"

645 , line "to argument"

620− , indent $ line $ prettyPrintValue arg

646+ , indent $ prettyPrintValue arg

621 ]

647 ]

622 goSimple TypeSynonymInstance =

648 goSimple TypeSynonymInstance =

623 line "Type synonym instances are disallowed"

649 line "Type synonym instances are disallowed"

624 goSimple (OrphanInstance nm cnm ts) =

650 goSimple (OrphanInstance nm cnm ts) =

625− paras [ line $ "Instance " ++ showIdent nm ++ " for " ++ showQualified runProperName cnm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ " is an orphan instance."

651+ paras [ line $ "Instance " ++ showIdent nm ++ " for "

652+ , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cnm)

653+ , Box.vcat Box.left (map typeAtomAsBox ts)

654+ ]

655+ , line "is an orphan instance."

626 , line "An orphan instance is an instance which is defined in neither the class module nor the data type module."

656 , line "An orphan instance is an instance which is defined in neither the class module nor the data type module."

627 , line "Consider moving the instance, if possible, or using a newtype wrapper."

657 , line "Consider moving the instance, if possible, or using a newtype wrapper."

628 ]

658 ]

@@ -630,7 +660,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

630 line "Newtypes must define a single constructor with a single argument"

660 line "Newtypes must define a single constructor with a single argument"

631 goSimple (InvalidInstanceHead ty) =

661 goSimple (InvalidInstanceHead ty) =

632 paras [ line "Invalid type in class instance head:"

662 paras [ line "Invalid type in class instance head:"

633− , indent $ line $ prettyPrintType ty

663+ , indent $ typeAsBox ty

634 ]

664 ]

635 goSimple (TransitiveExportError x ys) =

665 goSimple (TransitiveExportError x ys) =

636 paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")

666 paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")

@@ -643,15 +673,17 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

643 line $ "Type variable '" ++ tv ++ "' was declared but not used"

673 line $ "Type variable '" ++ tv ++ "' was declared but not used"

644 goSimple (ClassOperator className opName) =

674 goSimple (ClassOperator className opName) =

645 paras [ line $ "Class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "."

675 paras [ line $ "Class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "."

646− , indent $ line "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:"

676+ , line "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:"

647− , indent $ line $ showIdent opName ++ " = someMember"

677+ , indent . line $ showIdent opName ++ " = someMember"

648 ]

678 ]

649 goSimple (MisleadingEmptyTypeImport mn name) =

679 goSimple (MisleadingEmptyTypeImport mn name) =

650 line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors"

680 line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors"

651 goSimple (ImportHidingModule name) =

681 goSimple (ImportHidingModule name) =

652 line $ "Attempted to hide module " ++ runModuleName name ++ " in import expression, this is not permitted"

682 line $ "Attempted to hide module " ++ runModuleName name ++ " in import expression, this is not permitted"

653 goSimple (WildcardInferredType ty) =

683 goSimple (WildcardInferredType ty) =

654− line $ "The wildcard type definition has the inferred type " ++ prettyPrintType ty

684+ paras [ line "The wildcard type definition has the inferred type "

685+ , indent $ typeAsBox ty

686+ ]

655 goSimple (NotExhaustivePattern bs b) =

687 goSimple (NotExhaustivePattern bs b) =

656 paras $ [ line "A case expression could not be determined to cover all inputs."

688 paras $ [ line "A case expression could not be determined to cover all inputs."

657 , line "The following additional cases are required to cover all inputs:\n"

689 , line "The following additional cases are required to cover all inputs:\n"

@@ -669,18 +701,18 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

669 ]

701 ]

670 go (NotYetDefined names err) =

702 go (NotYetDefined names err) =

671 paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":"

703 paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":"

672− , indent $ go err

704+ , go err

673 ]

705 ]

674 go (ErrorUnifyingTypes t1 t2 err) =

706 go (ErrorUnifyingTypes t1 t2 err) =

675 paras [ lineWithLevel "unifying type "

707 paras [ lineWithLevel "unifying type "

676− , indent $ line $ prettyPrintType t1

708+ , indent $ typeAsBox t1

677 , line "with type"

709 , line "with type"

678− , indent $ line $ prettyPrintType t2

710+ , indent $ typeAsBox t2

679 , go err

711 , go err

680 ]

712 ]

681 go (ErrorInExpression expr err) =

713 go (ErrorInExpression expr err) =

682 paras [ lineWithLevel "in expression:"

714 paras [ lineWithLevel "in expression:"

683− , indent $ line $ prettyPrintValue expr

715+ , indent $ prettyPrintValue expr

684 , go err

716 , go err

685 ]

717 ]

686 go (ErrorInModule mn err) =

718 go (ErrorInModule mn err) =

@@ -689,39 +721,42 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

689 ]

721 ]

690 go (ErrorInSubsumption t1 t2 err) =

722 go (ErrorInSubsumption t1 t2 err) =

691 paras [ lineWithLevel "checking that type "

723 paras [ lineWithLevel "checking that type "

692− , indent $ line $ prettyPrintType t1

724+ , indent $ typeAsBox t1

693 , line "subsumes type"

725 , line "subsumes type"

694− , indent $ line $ prettyPrintType t2

726+ , indent $ typeAsBox t2

695 , go err

727 , go err

696 ]

728 ]

697− go (ErrorInInstance name ts err) =

729+ go (ErrorInInstance nm ts err) =

698− paras [ lineWithLevel $ "in type class instance " ++ showQualified runProperName name ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"

730+ paras [ lineWithLevel "in type class instance"

731+ , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

732+ , Box.vcat Box.left (map typeAtomAsBox ts)

733+ ]

699 , go err

734 , go err

700 ]

735 ]

701 go (ErrorCheckingKind ty err) =

736 go (ErrorCheckingKind ty err) =

702 paras [ lineWithLevel "checking kind of type "

737 paras [ lineWithLevel "checking kind of type "

703− , indent $ line $ prettyPrintType ty

738+ , indent $ typeAsBox ty

704 , go err

739 , go err

705 ]

740 ]

706 go (ErrorInferringType expr err) =

741 go (ErrorInferringType expr err) =

707 paras [ lineWithLevel "inferring type of value "

742 paras [ lineWithLevel "inferring type of value "

708− , indent $ line $ prettyPrintValue expr

743+ , indent $ prettyPrintValue expr

709 , go err

744 , go err

710 ]

745 ]

711 go (ErrorCheckingType expr ty err) =

746 go (ErrorCheckingType expr ty err) =

712 paras [ lineWithLevel "checking that value "

747 paras [ lineWithLevel "checking that value "

713− , indent $ line $ prettyPrintValue expr

748+ , indent $ prettyPrintValue expr

714 , line "has type"

749 , line "has type"

715− , indent $ line $ prettyPrintType ty

750+ , indent $ typeAsBox ty

716 , go err

751 , go err

717 ]

752 ]

718 go (ErrorInApplication f t a err) =

753 go (ErrorInApplication f t a err) =

719 paras [ lineWithLevel "applying function"

754 paras [ lineWithLevel "applying function"

720− , indent $ line $ prettyPrintValue f

755+ , indent $ prettyPrintValue f

721 , line "of type"

756 , line "of type"

722− , indent $ line $ prettyPrintType t

757+ , indent $ typeAsBox t

723 , line "to argument"

758 , line "to argument"

724− , indent $ line $ prettyPrintValue a

759+ , indent $ prettyPrintValue a

725 , go err

760 , go err

726 ]

761 ]

727 go (ErrorInDataConstructor nm err) =

762 go (ErrorInDataConstructor nm err) =

@@ -758,7 +793,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

758 ]

793 ]

759 go (PositionedError srcSpan err) =

794 go (PositionedError srcSpan err) =

760 paras [ lineWithLevel $ "at " ++ displaySourceSpan srcSpan ++ ":"

795 paras [ lineWithLevel $ "at " ++ displaySourceSpan srcSpan ++ ":"

761− , indent $ go err

796+ , go err

762 ]

797 ]

763 go (SimpleErrorWrapper sem) = goSimple sem

798 go (SimpleErrorWrapper sem) = goSimple sem

764

799

@@ -842,11 +877,11 @@ prettyPrintMultipleWarnings full = renderBox . prettyPrintMultipleWarningsBox fu

842

877

843-- | Pretty print warnings as a Box

878-- | Pretty print warnings as a Box

844prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> Box.Box

879prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> Box.Box

845−prettyPrintMultipleWarningsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Warning "Warning found:" "Multiple warnings found:" full

880+prettyPrintMultipleWarningsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" full

846

881

847-- | Pretty print errors as a Box

882-- | Pretty print errors as a Box

848prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> Box.Box

883prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> Box.Box

849−prettyPrintMultipleErrorsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Error "Error found:" "Multiple errors found:" full

884+prettyPrintMultipleErrorsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Error "Error found:" "Error" full

850

885

851prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> State UnknownMap Box.Box

886prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> State UnknownMap Box.Box

852prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do

887prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do

@@ -856,11 +891,12 @@ prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do

856 , result

891 , result

857 ]

892 ]

858prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = do

893prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = do

859− result <- forM es $ liftM (Box.moveRight 2) . prettyPrintSingleError full level

894+ result <- forM es $ prettyPrintSingleError full level

860− return $

895+ return $ Box.vsep 1 Box.left $ concat $ zipWith withIntro [1 :: Int ..] result

861− Box.vcat Box.left [ Box.text intro

896+ where

862− , Box.vsep 1 Box.left result

897+ withIntro i err = [ Box.text (intro ++ " " ++ show i ++ " of " ++ show (length es) ++ ":")

898+ , Box.moveRight 2 err

863− ]

899+ ]

864

900

865-- | Pretty print a Parsec ParseError as a Box

901-- | Pretty print a Parsec ParseError as a Box

866prettyPrintParseError :: P.ParseError -> Box.Box

902prettyPrintParseError :: P.ParseError -> Box.Box

@@ -910,8 +946,9 @@ prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEnd

910

946

911 clean = nub . filter (not . null)

947 clean = nub . filter (not . null)

912

948

949+-- | Indent to the right, and pad on top and bottom.

913indent :: Box.Box -> Box.Box

950indent :: Box.Box -> Box.Box

914−indent = Box.moveRight 2

951+indent = Box.moveUp 1 . Box.moveDown 1 . Box.moveRight 2

915

952

916line :: String -> Box.Box

953line :: String -> Box.Box

917line = Box.text

954line = Box.text

src/Language/PureScript/Names.hs+4

@@ -104,6 +104,10 @@ qualify _ (Qualified (Just m) a) = (m, a)

104mkQualified :: a -> ModuleName -> Qualified a

105mkQualified name mn = Qualified (Just mn) name

106

107+-- | Remove the module name from a qualified name

108+disqualify :: Qualified a -> a

109+disqualify (Qualified _ a) = a

110+

107-- |

111-- |

108-- Checks whether a qualified value is actually qualified with a module reference

112-- Checks whether a qualified value is actually qualified with a module reference

109--

113--

src/Language/PureScript/Pretty/Common.hs+11

@@ -17,8 +17,11 @@ module Language.PureScript.Pretty.Common where

18import Control.Monad.State

19import Data.List (intercalate)

20+

20import Language.PureScript.Parser.Lexer (reservedPsNames, opChars)

21import Language.PureScript.Parser.Lexer (reservedPsNames, opChars)

23+import Text.PrettyPrint.Boxes

24+

22-- |

25-- |

23-- Wrap a string in parentheses

26-- Wrap a string in parentheses

24--

27--

@@ -67,3 +70,11 @@ prettyPrintObjectKey :: String -> String

67prettyPrintObjectKey s | s `elem` reservedPsNames = show s

70prettyPrintObjectKey s | s `elem` reservedPsNames = show s

68 | any (`elem` opChars) s = show s

71 | any (`elem` opChars) s = show s

69 | otherwise = s

72 | otherwise = s

73+

74+-- | Place a box before another, vertically when the first box takes up multiple lines.

75+before :: Box -> Box -> Box

76+before b1 b2 | rows b1 > 1 = b1 // b2

77+ | otherwise = b1 <> b2

78+

79+beforeWithSpace :: Box -> Box -> Box

80+beforeWithSpace b1 = before (b1 <> text " ")

src/Language/PureScript/Pretty/Kinds.hs+19−15

@@ -14,7 +14,8 @@

14-----------------------------------------------------------------------------

16module Language.PureScript.Pretty.Kinds (

17− prettyPrintKind

17+ prettyPrintKind,

18+ kindAsBox

18) where

19) where

20import Data.Maybe (fromMaybe)

21import Data.Maybe (fromMaybe)

@@ -23,14 +24,15 @@ import Control.Arrow (ArrowPlus(..))

23import Control.PatternArrows

24import Control.PatternArrows

25import Language.PureScript.Kinds

26import Language.PureScript.Kinds

26−import Language.PureScript.Pretty.Common

28+import Text.PrettyPrint.Boxes (Box(), text, render, (<>))

29+

28−typeLiterals :: Pattern () Kind String

30+typeLiterals :: Pattern () Kind Box

29typeLiterals = mkPattern match

31typeLiterals = mkPattern match

30 where

32 where

31− match Star = Just "*"

33+ match Star = Just $ text "*"

32− match Bang = Just "!"

34+ match Bang = Just $ text "!"

33− match (KUnknown u) = Just $ 'u' : show u

35+ match (KUnknown u) = Just $ text $ 'u' : show u

34 match _ = Nothing

36 match _ = Nothing

36matchRow :: Pattern () Kind ((), Kind)

38matchRow :: Pattern () Kind ((), Kind)

@@ -45,15 +47,17 @@ funKind = mkPattern match

45 match (FunKind arg ret) = Just (arg, ret)

47 match (FunKind arg ret) = Just (arg, ret)

46 match _ = Nothing

48 match _ = Nothing

48−-- |

49−-- Generate a pretty-printed string representing a Kind

50+-- | Generate a pretty-printed string representing a Kind

50−--

51prettyPrintKind :: Kind -> String

52+prettyPrintKind = render . kindAsBox

53+

54+kindAsBox :: Kind -> Box

52−prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind ()

55+kindAsBox = fromMaybe (error "Incomplete pattern") . pattern matchKind ()

53 where

56 where

54− matchKind :: Pattern () Kind String

57+ matchKind :: Pattern () Kind Box

55− matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)

58+ matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap ((text "(" <>) . (<> text ")")) matchKind)

59+

56− operators :: OperatorTable () Kind String

60+ operators :: OperatorTable () Kind Box

57 operators =

61 operators =

58− OperatorTable [ [ Wrap matchRow $ \_ k -> "# " ++ k]

62+ OperatorTable [ [ Wrap matchRow $ \_ k -> text "# " <> k]

59− , [ AssocR funKind $ \arg ret -> arg ++ " -> " ++ ret ] ]

63+ , [ AssocR funKind $ \arg ret -> arg <> text " -> " <> ret ] ]

src/Language/PureScript/Pretty/Types.hs+56−35

@@ -14,13 +14,15 @@

14-----------------------------------------------------------------------------

16module Language.PureScript.Pretty.Types (

17+ typeAsBox,

17 prettyPrintType,

18 prettyPrintType,

19+ typeAtomAsBox,

18 prettyPrintTypeAtom,

20 prettyPrintTypeAtom,

21+ prettyPrintRowWith,

19 prettyPrintRow

22 prettyPrintRow

20) where

23) where

22import Data.Maybe (fromMaybe)

25import Data.Maybe (fromMaybe)

23−import Data.List (intercalate)

25import Control.Arrow ((<+>))

27import Control.Arrow ((<+>))

26import Control.PatternArrows

28import Control.PatternArrows

@@ -32,36 +34,54 @@ import Language.PureScript.Pretty.Common

32import Language.PureScript.Pretty.Kinds

34import Language.PureScript.Pretty.Kinds

33import Language.PureScript.Environment

35import Language.PureScript.Environment

37+import Text.PrettyPrint.Boxes hiding ((<+>))

38+

35−typeLiterals :: Pattern () Type String

39+typeLiterals :: Pattern () Type Box

36typeLiterals = mkPattern match

40typeLiterals = mkPattern match

37 where

41 where

38− match TypeWildcard = Just "_"

42+ match TypeWildcard = Just $ text "_"

39− match (TypeVar var) = Just var

43+ match (TypeVar var) = Just $ text var

40− match (PrettyPrintObject row) = Just $ "{ " ++ prettyPrintRow row ++ " }"

44+ match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row

41− match (TypeConstructor ctor) = Just $ showQualified runProperName ctor

45+ match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor

42− match (TUnknown u) = Just $ '_' : show u

46+ match (TUnknown u) = Just $ text $ '_' : show u

43− match (Skolem name s _) = Just $ name ++ show s

47+ match (Skolem name s _) = Just $ text $ name ++ show s

44− match (ConstrainedType deps ty) = Just $ "(" ++ intercalate ", " (map (\(pn, ty') -> showQualified runProperName pn ++ " " ++ unwords (map prettyPrintTypeAtom ty')) deps) ++ ") => " ++ prettyPrintType ty

48+ match (ConstrainedType deps ty) = Just $ constraintsAsBox deps `before` (text ") => " <> typeAsBox ty)

45− match (SaturatedTypeSynonym name args) = Just $ showQualified runProperName name ++ "<" ++ intercalate "," (map prettyPrintTypeAtom args) ++ ">"

46− match REmpty = Just "()"

49+ match REmpty = Just $ text "()"

47− match row@RCons{} = Just $ '(' : prettyPrintRow row ++ ")"

50+ match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row

48 match _ = Nothing

51 match _ = Nothing

53+constraintsAsBox :: [(Qualified ProperName, [Type])] -> Box

54+constraintsAsBox = vcat left . zipWith (\i (pn, tys) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..]

55+ where

56+ constraintAsBox pn tys = hsep 1 left (text (runProperName (disqualify pn)) : map typeAtomAsBox tys)

57+

50-- |

58-- |

51-- Generate a pretty-printed string representing a Row

59-- Generate a pretty-printed string representing a Row

52--

60--

53−prettyPrintRow :: Type -> String

61+prettyPrintRowWith :: Char -> Char -> Type -> Box

54−prettyPrintRow = (\(tys, rest) -> intercalate ", " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs rest) . toList []

62+prettyPrintRowWith open close = uncurry listToBox . toList []

55 where

63 where

56− nameAndTypeToPs :: String -> Type -> String

64+ nameAndTypeToPs :: Char -> String -> Type -> Box

57− nameAndTypeToPs name ty = prettyPrintObjectKey name ++ " :: " ++ prettyPrintType ty

65+ nameAndTypeToPs start name ty = text (start : ' ' : prettyPrintObjectKey name ++ " :: ") <> typeAsBox ty

66+

58− tailToPs :: Type -> String

67+ tailToPs :: Type -> Box

59− tailToPs REmpty = ""

68+ tailToPs REmpty = nullBox

60− tailToPs other = " | " ++ prettyPrintType other

69+ tailToPs other = text "| " <> typeAsBox other

70+

71+ listToBox :: [(String, Type)] -> Type -> Box

72+ listToBox [] REmpty = text [open, close]

73+ listToBox [] rest = text [ open, ' ' ] <> tailToPs rest <> text [ ' ', close ]

74+ listToBox ts rest = vcat left $

75+ zipWith (\(nm, ty) i -> nameAndTypeToPs (if i == 0 then open else ',') nm ty) ts [0 :: Int ..] ++

76+ [ tailToPs rest, text [close] ]

77+

61 toList :: [(String, Type)] -> Type -> ([(String, Type)], Type)

78 toList :: [(String, Type)] -> Type -> ([(String, Type)], Type)

62 toList tys (RCons name ty row) = toList ((name, ty):tys) row

79 toList tys (RCons name ty row) = toList ((name, ty):tys) row

63 toList tys r = (tys, r)

80 toList tys r = (tys, r)

82+prettyPrintRow :: Type -> String

83+prettyPrintRow = render . prettyPrintRowWith '(' ')'

84+

65typeApp :: Pattern () Type (Type, Type)

85typeApp :: Pattern () Type (Type, Type)

66typeApp = mkPattern match

86typeApp = mkPattern match

67 where

87 where

@@ -92,19 +112,19 @@ insertPlaceholders = everywhereOnTypesTopDown convertForAlls . everywhereOnTypes

92 go idents other = PrettyPrintForAll idents other

112 go idents other = PrettyPrintForAll idents other

93 convertForAlls other = other

113 convertForAlls other = other

114

95−matchTypeAtom :: Pattern () Type String

115+matchTypeAtom :: Pattern () Type Box

96−matchTypeAtom = typeLiterals <+> fmap parens matchType

116+matchTypeAtom = typeLiterals <+> fmap ((`before` text ")") . (text "(" <>)) matchType

117

98−matchType :: Pattern () Type String

118+matchType :: Pattern () Type Box

99matchType = buildPrettyPrinter operators matchTypeAtom

119matchType = buildPrettyPrinter operators matchTypeAtom

100 where

120 where

101− operators :: OperatorTable () Type String

121+ operators :: OperatorTable () Type Box

102 operators =

122 operators =

103− OperatorTable [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ]

123+ OperatorTable [ [ AssocL typeApp $ \f x -> f `beforeWithSpace` x ]

104− , [ AssocR appliedFunction $ \arg ret -> arg ++ " -> " ++ ret

124+ , [ AssocR appliedFunction $ \arg ret -> (arg <> text " ") `before` (text "-> " <> ret)

105 ]

125 ]

106− , [ Wrap forall_ $ \idents ty -> "forall " ++ unwords idents ++ ". " ++ ty ]

126+ , [ Wrap forall_ $ \idents ty -> text ("forall " ++ unwords idents ++ ". ") <> ty ]

107− , [ Wrap kinded $ \k ty -> ty ++ " :: " ++ prettyPrintKind k ]

127+ , [ Wrap kinded $ \k ty -> ty `before` (text " :: " <> kindAsBox k) ]

108 ]

128 ]

109

129

110forall_ :: Pattern () Type ([String], Type)

130forall_ :: Pattern () Type ([String], Type)

@@ -113,15 +133,16 @@ forall_ = mkPattern match

113 match (PrettyPrintForAll idents ty) = Just (idents, ty)

133 match (PrettyPrintForAll idents ty) = Just (idents, ty)

114 match _ = Nothing

134 match _ = Nothing

115

135

116−-- |

136+typeAtomAsBox :: Type -> Box

137+typeAtomAsBox = fromMaybe (error "Incomplete pattern") . pattern matchTypeAtom () . insertPlaceholders

138+

117−-- Generate a pretty-printed string representing a Type, as it should appear inside parentheses

139+-- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses

118−--

119prettyPrintTypeAtom :: Type -> String

140prettyPrintTypeAtom :: Type -> String

120−prettyPrintTypeAtom = fromMaybe (error "Incomplete pattern") . pattern matchTypeAtom () . insertPlaceholders

141+prettyPrintTypeAtom = render . typeAtomAsBox

121

142

143+typeAsBox :: Type -> Box

144+typeAsBox = fromMaybe (error "Incomplete pattern") . pattern matchType () . insertPlaceholders

122

145

123−-- |

124−-- Generate a pretty-printed string representing a Type

146+-- | Generate a pretty-printed string representing a Type

125−--

126prettyPrintType :: Type -> String

147prettyPrintType :: Type -> String

127−prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType () . insertPlaceholders

148+prettyPrintType = render . typeAsBox

src/Language/PureScript/Pretty/Values.hs+91−152

@@ -21,173 +21,112 @@ module Language.PureScript.Pretty.Values (

21 prettyPrintBinderAtom

22) where

24−import Data.Maybe (fromMaybe)

25import Data.List (intercalate)

24import Data.List (intercalate)

27−import Control.Arrow ((<+>), runKleisli, second)

26+import Control.Arrow (second)

28−import Control.PatternArrows

29−import Control.Monad.State

30−#if __GLASGOW_HASKELL__ < 710

31−import Control.Applicative

32−#endif

34import Language.PureScript.AST

28import Language.PureScript.AST

35import Language.PureScript.Names

29import Language.PureScript.Names

36import Language.PureScript.Pretty.Common

30import Language.PureScript.Pretty.Common

37−import Language.PureScript.Pretty.Types (prettyPrintType, prettyPrintTypeAtom)

31+import Language.PureScript.Pretty.Types (typeAsBox, typeAtomAsBox)

39−literals :: Pattern PrinterState Expr String

33+import Text.PrettyPrint.Boxes

40−literals = mkPattern' match

34+

35+-- | Render an aligned list of items separated with commas

36+list :: Char -> Char -> (a -> Box) -> [a] -> Box

37+list open close _ [] = text [open, close]

38+list open close f xs = vcat left (zipWith toLine [0 :: Int ..] xs ++ [ text [ close ] ])

41 where

39 where

42− match :: Expr -> StateT PrinterState Maybe String

40+ toLine i a = text [ if i == 0 then open else ',', ' ' ] <> f a

41+

42+prettyPrintObject :: [(String, Maybe Expr)] -> Box

43+prettyPrintObject = list '{' '}' prettyPrintObjectProperty

44+ where

45+ prettyPrintObjectProperty :: (String, Maybe Expr) -> Box

46+ prettyPrintObjectProperty (key, value) = text (prettyPrintObjectKey key ++ ": ") <> maybe (text "_") prettyPrintValue value

47+

48+-- | Pretty-print an expression

49+prettyPrintValue :: Expr -> Box

50+prettyPrintValue (IfThenElse cond th el) =

51+ (text "if " <> prettyPrintValueAtom cond)

52+ // moveRight 2 (vcat left [ text "then " <> prettyPrintValueAtom th

53+ , text "else " <> prettyPrintValueAtom el

54+ ])

55+prettyPrintValue (Accessor prop val) = prettyPrintValueAtom val <> text ("." ++ show prop)

56+prettyPrintValue (ObjectUpdate o ps) = prettyPrintValueAtom o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> prettyPrintValue val) ps

57+prettyPrintValue (ObjectUpdater o ps) = maybe (text "_") prettyPrintValueAtom o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> maybe (text "_") prettyPrintValue val) ps

58+prettyPrintValue (App val arg) = prettyPrintValueAtom val `beforeWithSpace` prettyPrintValueAtom arg

59+prettyPrintValue (Abs (Left arg) val) = text ('\\' : showIdent arg ++ " -> ") // moveRight 2 (prettyPrintValue val)

60+prettyPrintValue (TypeClassDictionaryConstructorApp className ps) =

61+ text (runProperName (disqualify className) ++ " ") <> prettyPrintValueAtom ps

62+prettyPrintValue (Case values binders) =

63+ (text "case " <> foldl1 beforeWithSpace (map prettyPrintValueAtom values) <> text " of") //

64+ moveRight 2 (vcat left (map prettyPrintCaseAlternative binders))

65+prettyPrintValue (Let ds val) =

66+ text "let" //

67+ moveRight 2 (vcat left (map prettyPrintDeclaration ds)) //

68+ (text "in " <> prettyPrintValue val)

69+prettyPrintValue (Do els) =

70+ text "do " <> vcat left (map prettyPrintDoNotationElement els)

71+prettyPrintValue (TypeClassDictionary (name, tys) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys

72+prettyPrintValue (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name)

73+prettyPrintValue (PositionedValue _ _ val) = prettyPrintValue val

74+prettyPrintValue expr = prettyPrintValueAtom expr

75+

76+-- | Pretty-print an atomic expression, adding parentheses if necessary.

77+prettyPrintValueAtom :: Expr -> Box

43− match (NumericLiteral n) = return $ either show show n

78+prettyPrintValueAtom (NumericLiteral n) = text $ either show show n

44− match (StringLiteral s) = return $ show s

79+prettyPrintValueAtom (StringLiteral s) = text $ show s

45− match (CharLiteral c) = return $ show c

80+prettyPrintValueAtom (CharLiteral c) = text $ show c

46− match (BooleanLiteral True) = return "true"

81+prettyPrintValueAtom (BooleanLiteral True) = text "true"

47− match (BooleanLiteral False) = return "false"

82+prettyPrintValueAtom (BooleanLiteral False) = text "false"

48− match (ArrayLiteral xs) = return $ "[" ++ intercalate ", " (map prettyPrintValue xs) ++ "]"

83+prettyPrintValueAtom (ArrayLiteral xs) = list '[' ']' prettyPrintValue xs

49− match (ObjectLiteral ps) = prettyPrintObject' $ second Just `map` ps

84+prettyPrintValueAtom (ObjectLiteral ps) = prettyPrintObject $ second Just `map` ps

50− match (ObjectConstructor ps) = prettyPrintObject' ps

85+prettyPrintValueAtom (ObjectConstructor ps) = prettyPrintObject ps

51− match (ObjectGetter prop) = return $ "(." ++ prop ++ ")"

86+prettyPrintValueAtom (ObjectGetter prop) = text $ "_." ++ show prop

52− match (TypeClassDictionaryConstructorApp className ps) = concat <$> sequence

53− [ return (showQualified runProperName className ++ "(\n")

54− , match ps

55− , return ")"

56− ]

57− match (Constructor name) = return $ showQualified runProperName name

87+prettyPrintValueAtom (Constructor name) = text $ runProperName (disqualify name)

58− match (Case values binders) = concat <$> sequence

88+prettyPrintValueAtom (Var ident) = text $ showIdent (disqualify ident)

59− [ return "case "

60− , unwords <$> forM values prettyPrintValue'

61− , return " of\n"

62− , withIndent $ prettyPrintMany prettyPrintCaseAlternative binders

63− , currentIndent

64− ]

65− match (Let ds val) = concat <$> sequence

66− [ return "let\n"

67− , withIndent $ prettyPrintMany prettyPrintDeclaration ds

68− , return "\n"

69− , currentIndent

70− , return "in "

71− , prettyPrintValue' val

72− ]

73− match (Var ident) = return $ showQualified showIdent ident

74− match (Do els) = concat <$> sequence

75− [ return "do\n"

76− , withIndent $ prettyPrintMany prettyPrintDoNotationElement els

77− , currentIndent

78− ]

79− match (OperatorSection op (Right val)) = return $ "(" ++ prettyPrintValue op ++ " " ++ prettyPrintValue val ++ ")"

89+prettyPrintValueAtom (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue op) `beforeWithSpace` prettyPrintValue val) `before` text ")"

80− match (OperatorSection op (Left val)) = return $ "(" ++ prettyPrintValue val ++ " " ++ prettyPrintValue op ++ ")"

90+prettyPrintValueAtom (OperatorSection op (Left val)) = ((text "(" <> prettyPrintValue val) `beforeWithSpace` prettyPrintValue op) `before` text ")"

81− match (TypeClassDictionary (name, tys) _) = return $ "<<dict " ++ showQualified runProperName name ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ">>"

82− match (SuperClassDictionary name _) = return $ "<<superclass dict " ++ showQualified runProperName name ++ ">>"

83− match (TypedValue _ val _) = prettyPrintValue' val

91+prettyPrintValueAtom (TypedValue _ val _) = prettyPrintValue val

84− match (PositionedValue _ _ val) = prettyPrintValue' val

92+prettyPrintValueAtom (PositionedValue _ _ val) = prettyPrintValueAtom val

85− match _ = mzero

93+prettyPrintValueAtom expr = (text "(" <> prettyPrintValue expr) `before` text ")"

86−

94+

87−prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String

95+prettyPrintDeclaration :: Declaration -> Box

88−prettyPrintDeclaration (TypeDeclaration ident ty) = return $ showIdent ident ++ " :: " ++ prettyPrintType ty

96+prettyPrintDeclaration (TypeDeclaration ident ty) =

97+ text (showIdent ident ++ " :: ") <> typeAsBox ty

89−prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) = concat <$> sequence

98+prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) =

90− [ return $ showIdent ident ++ " = "

91− , prettyPrintValue' val

99+ text (showIdent ident ++ " = ") <> prettyPrintValue val

92− ]

93prettyPrintDeclaration (PositionedDeclaration _ _ d) = prettyPrintDeclaration d

100prettyPrintDeclaration (PositionedDeclaration _ _ d) = prettyPrintDeclaration d

94prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"

101prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"

102

96−prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String

103+prettyPrintCaseAlternative :: CaseAlternative -> Box

97prettyPrintCaseAlternative (CaseAlternative binders result) =

104prettyPrintCaseAlternative (CaseAlternative binders result) =

98− concat <$> sequence

99− [ return (unwords (map prettyPrintBinderAtom binders))

105+ text (unwords (map prettyPrintBinderAtom binders)) <> prettyPrintResult result

100− , prettyPrintResult result

101− ]

102 where

106 where

103− prettyPrintResult (Left gs) = concat <$> sequence

107+ prettyPrintResult :: Either [(Guard, Expr)] Expr -> Box

104− [ return "\n"

108+ prettyPrintResult (Left gs) =

105− , withIndent $ prettyPrintMany prettyPrintGuardedValue gs

109+ vcat left (map prettyPrintGuardedValue gs)

106− ]

107− prettyPrintResult (Right v) = (" -> " ++) <$> prettyPrintValue' v

110+ prettyPrintResult (Right v) = text " -> " <> prettyPrintValue v

108−

111+

109− prettyPrintGuardedValue (grd, val) =

112+ prettyPrintGuardedValue :: (Guard, Expr) -> Box

110− concat <$> sequence

113+ prettyPrintGuardedValue (grd, val) = foldl1 before

111− [ return "| "

114+ [ text " | "

112− , prettyPrintValue' grd

115+ , prettyPrintValue grd

113− , return " -> "

116+ , text " -> "

114− , prettyPrintValue' val

117+ , prettyPrintValue val

115− ]

118+ ]

116−

119+

117−prettyPrintDoNotationElement :: DoNotationElement -> StateT PrinterState Maybe String

120+prettyPrintDoNotationElement :: DoNotationElement -> Box

118prettyPrintDoNotationElement (DoNotationValue val) =

121prettyPrintDoNotationElement (DoNotationValue val) =

119− prettyPrintValue' val

122+ prettyPrintValue val

120prettyPrintDoNotationElement (DoNotationBind binder val) =

123prettyPrintDoNotationElement (DoNotationBind binder val) =

121− concat <$> sequence

122− [ return (prettyPrintBinder binder)

124+ text (prettyPrintBinder binder ++ " <- ") <> prettyPrintValue val

123− , return " <- "

124− , prettyPrintValue' val

125− ]

126prettyPrintDoNotationElement (DoNotationLet ds) =

125prettyPrintDoNotationElement (DoNotationLet ds) =

127− concat <$> sequence

126+ text "let" //

128− [ return "let "

129− , withIndent $ prettyPrintMany prettyPrintDeclaration ds

127+ moveRight 2 (vcat left (map prettyPrintDeclaration ds))

130− ]

131prettyPrintDoNotationElement (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement el

128prettyPrintDoNotationElement (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement el

132

129

133−prettyPrintObject' :: [(String, Maybe Expr)] -> StateT PrinterState Maybe String

134−prettyPrintObject' [] = return "{}"

135−prettyPrintObject' ps = return $ "{ " ++ intercalate ", " (map prettyPrintObjectProperty ps) ++ "}"

136− where

137− prettyPrintObjectProperty :: (String, Maybe Expr) -> String

138− prettyPrintObjectProperty (key, value) = prettyPrintObjectKey key ++ ": " ++ maybe "_" prettyPrintValue value

139−

140−ifThenElse :: Pattern PrinterState Expr ((Expr, Expr), Expr)

141−ifThenElse = mkPattern match

142− where

143− match (IfThenElse cond th el) = Just ((th, el), cond)

144− match _ = Nothing

145−

146−accessor :: Pattern PrinterState Expr (String, Expr)

147−accessor = mkPattern match

148− where

149− match (Accessor prop val) = Just (prop, val)

150− match _ = Nothing

151−

152−objectUpdate :: Pattern PrinterState Expr ([String], Expr)

153−objectUpdate = mkPattern match

154− where

155− match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)

156− match (ObjectUpdater o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ maybe "_" prettyPrintValue val, fromMaybe (Var (Qualified Nothing $ Ident "_")) o)

157− match _ = Nothing

158−

159−app :: Pattern PrinterState Expr (String, Expr)

160−app = mkPattern match

161− where

162− match (App val arg) = Just (prettyPrintValue arg, val)

163− match _ = Nothing

164−

165−lam :: Pattern PrinterState Expr (String, Expr)

166−lam = mkPattern match

167− where

168− match (Abs (Left arg) val) = Just (showIdent arg, val)

169− match _ = Nothing

170−

171−-- |

172−-- Generate a pretty-printed string representing an expression

173−--

174−prettyPrintValue :: Expr -> String

175−prettyPrintValue = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintValue'

176−

177−prettyPrintValue' :: Expr -> StateT PrinterState Maybe String

178−prettyPrintValue' = runKleisli $ runPattern matchValue

179− where

180− matchValue :: Pattern PrinterState Expr String

181− matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)

182− operators :: OperatorTable PrinterState Expr String

183− operators =

184− OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]

185− , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]

186− , [ Wrap app $ \arg val -> val ++ "(" ++ arg ++ ")" ]

187− , [ Split lam $ \arg val -> "\\" ++ arg ++ " -> " ++ prettyPrintValue val ]

188− , [ Wrap ifThenElse $ \(th, el) cond -> "if " ++ cond ++ " then " ++ prettyPrintValue th ++ " else " ++ prettyPrintValue el ]

189− ]

190−

191prettyPrintBinderAtom :: Binder -> String

130prettyPrintBinderAtom :: Binder -> String

192prettyPrintBinderAtom NullBinder = "_"

131prettyPrintBinderAtom NullBinder = "_"

193prettyPrintBinderAtom (StringBinder str) = show str

132prettyPrintBinderAtom (StringBinder str) = show str

@@ -196,7 +135,7 @@ prettyPrintBinderAtom (NumberBinder num) = either show show num

196prettyPrintBinderAtom (BooleanBinder True) = "true"

135prettyPrintBinderAtom (BooleanBinder True) = "true"

197prettyPrintBinderAtom (BooleanBinder False) = "false"

136prettyPrintBinderAtom (BooleanBinder False) = "false"

198prettyPrintBinderAtom (VarBinder ident) = showIdent ident

137prettyPrintBinderAtom (VarBinder ident) = showIdent ident

199−prettyPrintBinderAtom (ConstructorBinder ctor []) = showQualified runProperName ctor

138+prettyPrintBinderAtom (ConstructorBinder ctor []) = runProperName (disqualify ctor)

200prettyPrintBinderAtom (ObjectBinder bs) =

139prettyPrintBinderAtom (ObjectBinder bs) =

201 "{ "

140 "{ "

202 ++ intercalate ", " (map prettyPrintObjectPropertyBinder bs)

141 ++ intercalate ", " (map prettyPrintObjectPropertyBinder bs)

@@ -216,7 +155,7 @@ prettyPrintBinderAtom b = parens (prettyPrintBinder b)

216-- Generate a pretty-printed string representing a Binder

155-- Generate a pretty-printed string representing a Binder

217--

156--

218prettyPrintBinder :: Binder -> String

157prettyPrintBinder :: Binder -> String

219−prettyPrintBinder (ConstructorBinder ctor []) = showQualified runProperName ctor

158+prettyPrintBinder (ConstructorBinder ctor []) = runProperName (disqualify ctor)

220−prettyPrintBinder (ConstructorBinder ctor args) = showQualified runProperName ctor ++ " " ++ unwords (map prettyPrintBinderAtom args)

159+prettyPrintBinder (ConstructorBinder ctor args) = runProperName (disqualify ctor) ++ " " ++ unwords (map prettyPrintBinderAtom args)

221prettyPrintBinder (PositionedBinder _ _ binder) = prettyPrintBinder binder

160prettyPrintBinder (PositionedBinder _ _ binder) = prettyPrintBinder binder

222prettyPrintBinder b = prettyPrintBinderAtom b

161prettyPrintBinder b = prettyPrintBinderAtom b