0c35b83 · rowtype-yoga/purescript-native

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

Use boxes library to print types and values.

commit0c35b83dd6b123516440c352eba68d825be6bc8c authorPhil Freeman <paf31@cantab.net> dateWed 7 Oct 2015, 20:49 (11 years ago) parentc70560a

6 files changed+273−257

compare with golang

unifiedsplit

src/Language/PureScript/Errors.hs+92−55 src/Language/PureScript/Names.hs+4 src/Language/PureScript/Pretty/Common.hs+11 src/Language/PureScript/Pretty/Kinds.hs+19−15 src/Language/PureScript/Pretty/Types.hs+56−35 src/Language/PureScript/Pretty/Values.hs+91−152

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

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

427427 ]

428428 goSimple (ErrorParsingExterns err) =

429429 paras [ lineWithLevel "parsing externs files: "

430− , indent . prettyPrintParseError $ err

430+ , prettyPrintParseError err

431431 ]

432432 goSimple (ErrorParsingFFIModule path) =

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

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

435435 ]

436436 goSimple (ErrorParsingModule err) =

437437 paras [ line "Unable to parse module: "

438− , indent . prettyPrintParseError $ err

438+ , prettyPrintParseError err

439439 ]

440440 goSimple (MissingFFIModule mn) =

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

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

444444 , indent . line $ path

445445 ]

446446 goSimple (MultipleFFIModules mn paths) =

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

448− ++ map (indent . line) paths

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

448+ , indent . paras $ map line paths

449+ ]

449450 goSimple (InvalidExternsFile path) =

450451 paras [ line "Externs file is invalid: "

451452 , indent . line $ path

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

462463 line "Overlapping names in let binding."

463464 goSimple (InfiniteType ty) =

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

465− , indent $ line $ prettyPrintType ty

466+ , indent $ typeAsBox ty

466467 ]

467468 goSimple (InfiniteKind ki) =

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

469− , indent $ line $ prettyPrintKind ki

470+ , indent $ kindAsBox ki

470471 ]

471472 goSimple (MultipleFixities name) =

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

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

475476 goSimple (OrphanFixityDeclaration op) =

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

477478 goSimple (RedefinedModule name filenames) =

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

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

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

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

481+ ]

480482 goSimple (RedefinedIdent name) =

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

482484 goSimple (UnknownModule mn) =

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

548550 goSimple (EscapedSkolem binding) =

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

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

551− , indent $ line $ prettyPrintValue expr

553+ , indent $ prettyPrintValue expr

552554 ]) binding

553555 goSimple (TypesDoNotUnify t1 t2)

554556 = paras [ line "Cannot unify type"

555− , indent $ line $ prettyPrintType t1

557+ , indent $ typeAsBox t1

556558 , line "with type"

557− , indent $ line $ prettyPrintType t2

559+ , indent $ typeAsBox t2

558560 ]

559561 goSimple (KindsDoNotUnify k1 k2) =

560562 paras [ line "Cannot unify kind"

561− , indent $ line $ prettyPrintKind k1

563+ , indent $ kindAsBox k1

562564 , line "with kind"

563− , indent $ line $ prettyPrintKind k2

565+ , indent $ kindAsBox k2

564566 ]

565567 goSimple (ConstrainedTypeUnified t1 t2) =

566568 paras [ line "Cannot unify constrained type"

567− , indent $ line $ prettyPrintType t1

569+ , indent $ typeAsBox t1

568570 , line "with type"

569− , indent $ line $ prettyPrintType t2

571+ , indent $ typeAsBox t2

570572 ]

571573 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:"

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

574580 ]

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

576582 goSimple (NoInstanceFound nm ts) =

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

583+ paras [ line "No instance found for"

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

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

586+ ]

587+ ]

578588 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+ ]

580595 goSimple (CannotDerive nm ts) =

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

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

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

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

599+ ]

600+ ]

582601 goSimple (CannotFindDerivingType nm) =

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

584603 goSimple (DuplicateLabel l expr) =

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

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

587− , indent $ line $ prettyPrintValue expr'

606+ , indent $ prettyPrintValue expr'

588607 ]) expr

589608 goSimple (DuplicateTypeArgument name) =

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

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

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

601620 goSimple (ExpectedType ty kind) =

602621 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."

604627 ]

605628 goSimple (IncorrectConstructorArity nm) =

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

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

608631 goSimple (ExprDoesNotHaveType expr ty) =

609632 paras [ line "Expression"

610− , indent $ line $ prettyPrintValue expr

633+ , indent $ prettyPrintValue expr

611634 , line "does not have type"

612− , indent $ line $ prettyPrintType ty

635+ , indent $ typeAsBox ty

613636 ]

614637 goSimple (PropertyIsMissing prop row) =

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

638+ paras [ line "Row"

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

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

641+ ]

616642 goSimple (CannotApplyFunction fn arg) =

617643 paras [ line "Cannot apply function of type"

618− , indent $ line $ prettyPrintType fn

644+ , indent $ typeAsBox fn

619645 , line "to argument"

620− , indent $ line $ prettyPrintValue arg

646+ , indent $ prettyPrintValue arg

621647 ]

622648 goSimple TypeSynonymInstance =

623649 line "Type synonym instances are disallowed"

624650 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."

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

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

628658 ]

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

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

631661 goSimple (InvalidInstanceHead ty) =

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

633− , indent $ line $ prettyPrintType ty

663+ , indent $ typeAsBox ty

634664 ]

635665 goSimple (TransitiveExportError x ys) =

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

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

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

644674 goSimple (ClassOperator className opName) =

645675 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:"

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

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

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

648678 ]

649679 goSimple (MisleadingEmptyTypeImport mn name) =

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

651681 goSimple (ImportHidingModule name) =

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

653683 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+ ]

655687 goSimple (NotExhaustivePattern bs b) =

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

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

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

669701 ]

670702 go (NotYetDefined names err) =

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

672− , indent $ go err

704+ , go err

673705 ]

674706 go (ErrorUnifyingTypes t1 t2 err) =

675707 paras [ lineWithLevel "unifying type "

676− , indent $ line $ prettyPrintType t1

708+ , indent $ typeAsBox t1

677709 , line "with type"

678− , indent $ line $ prettyPrintType t2

710+ , indent $ typeAsBox t2

679711 , go err

680712 ]

681713 go (ErrorInExpression expr err) =

682714 paras [ lineWithLevel "in expression:"

683− , indent $ line $ prettyPrintValue expr

715+ , indent $ prettyPrintValue expr

684716 , go err

685717 ]

686718 go (ErrorInModule mn err) =

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

689721 ]

690722 go (ErrorInSubsumption t1 t2 err) =

691723 paras [ lineWithLevel "checking that type "

692− , indent $ line $ prettyPrintType t1

724+ , indent $ typeAsBox t1

693725 , line "subsumes type"

694− , indent $ line $ prettyPrintType t2

726+ , indent $ typeAsBox t2

695727 , go err

696728 ]

697− go (ErrorInInstance name ts err) =

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

729+ go (ErrorInInstance nm ts err) =

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+ ]

699734 , go err

700735 ]

701736 go (ErrorCheckingKind ty err) =

702737 paras [ lineWithLevel "checking kind of type "

703− , indent $ line $ prettyPrintType ty

738+ , indent $ typeAsBox ty

704739 , go err

705740 ]

706741 go (ErrorInferringType expr err) =

707742 paras [ lineWithLevel "inferring type of value "

708− , indent $ line $ prettyPrintValue expr

743+ , indent $ prettyPrintValue expr

709744 , go err

710745 ]

711746 go (ErrorCheckingType expr ty err) =

712747 paras [ lineWithLevel "checking that value "

713− , indent $ line $ prettyPrintValue expr

748+ , indent $ prettyPrintValue expr

714749 , line "has type"

715− , indent $ line $ prettyPrintType ty

750+ , indent $ typeAsBox ty

716751 , go err

717752 ]

718753 go (ErrorInApplication f t a err) =

719754 paras [ lineWithLevel "applying function"

720− , indent $ line $ prettyPrintValue f

755+ , indent $ prettyPrintValue f

721756 , line "of type"

722− , indent $ line $ prettyPrintType t

757+ , indent $ typeAsBox t

723758 , line "to argument"

724− , indent $ line $ prettyPrintValue a

759+ , indent $ prettyPrintValue a

725760 , go err

726761 ]

727762 go (ErrorInDataConstructor nm err) =

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

758793 ]

759794 go (PositionedError srcSpan err) =

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

761− , indent $ go err

796+ , go err

762797 ]

763798 go (SimpleErrorWrapper sem) = goSimple sem

764799

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

842877

843878-- | Pretty print warnings as a Box

844879prettyPrintMultipleWarningsBox :: 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

846881

847882-- | Pretty print errors as a Box

848883prettyPrintMultipleErrorsBox :: 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

850885

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

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

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

856891 , result

857892 ]

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

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

860− return $

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

862− , Box.vsep 1 Box.left result

863− ]

894+ result <- forM es $ prettyPrintSingleError full level

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

896+ where

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

898+ , Box.moveRight 2 err

899+ ]

864900

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

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

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

910946

911947 clean = nub . filter (not . null)

912948

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

913950indent :: Box.Box -> Box.Box

914−indent = Box.moveRight 2

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

915952

916953line :: String -> Box.Box

917954line = Box.text

src/Language/PureScript/Names.hs+4

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

104104mkQualified :: a -> ModuleName -> Qualified a

105105mkQualified name mn = Qualified (Just mn) name

106106

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

108+disqualify :: Qualified a -> a

109+disqualify (Qualified _ a) = a

110+

107111-- |

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

109113--

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

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

1717

1818import Control.Monad.State

1919import Data.List (intercalate)

20+

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

2122

23+import Text.PrettyPrint.Boxes

24+

2225-- |

2326-- Wrap a string in parentheses

2427--

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

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

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

6972 | 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 @@

1414-----------------------------------------------------------------------------

1515

1616module Language.PureScript.Pretty.Kinds (

17− prettyPrintKind

17+ prettyPrintKind,

18+ kindAsBox

1819) where

1920

2021import Data.Maybe (fromMaybe)

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

2324import Control.PatternArrows

2425

2526import Language.PureScript.Kinds

26−import Language.PureScript.Pretty.Common

2727

28−typeLiterals :: Pattern () Kind String

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

29+

30+typeLiterals :: Pattern () Kind Box

2931typeLiterals = mkPattern match

3032 where

31− match Star = Just "*"

32− match Bang = Just "!"

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

33+ match Star = Just $ text "*"

34+ match Bang = Just $ text "!"

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

3436 match _ = Nothing

3537

3638matchRow :: Pattern () Kind ((), Kind)

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

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

4648 match _ = Nothing

4749

48−-- |

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

50−--

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

5151prettyPrintKind :: Kind -> String

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

52+prettyPrintKind = render . kindAsBox

53+

54+kindAsBox :: Kind -> Box

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

5356 where

54− matchKind :: Pattern () Kind String

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

56− operators :: OperatorTable () Kind String

57+ matchKind :: Pattern () Kind Box

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

59+

60+ operators :: OperatorTable () Kind Box

5761 operators =

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

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

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

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

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

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

1414-----------------------------------------------------------------------------

1515

1616module Language.PureScript.Pretty.Types (

17+ typeAsBox,

1718 prettyPrintType,

19+ typeAtomAsBox,

1820 prettyPrintTypeAtom,

21+ prettyPrintRowWith,

1922 prettyPrintRow

2023) where

2124

2225import Data.Maybe (fromMaybe)

23−import Data.List (intercalate)

2426

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

2628import Control.PatternArrows

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

3234import Language.PureScript.Pretty.Kinds

3335import Language.PureScript.Environment

3436

35−typeLiterals :: Pattern () Type String

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

38+

39+typeLiterals :: Pattern () Type Box

3640typeLiterals = mkPattern match

3741 where

38− match TypeWildcard = Just "_"

39− match (TypeVar var) = Just var

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

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

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

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

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

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

46− match REmpty = Just "()"

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

42+ match TypeWildcard = Just $ text "_"

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

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

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

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

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

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

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

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

4851 match _ = Nothing

4952

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+

5058-- |

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

5260--

53−prettyPrintRow :: Type -> String

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

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

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

5563 where

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

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

58− tailToPs :: Type -> String

59− tailToPs REmpty = ""

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

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

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

66+

67+ tailToPs :: Type -> Box

68+ tailToPs REmpty = nullBox

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+

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

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

6380 toList tys r = (tys, r)

6481

82+prettyPrintRow :: Type -> String

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

84+

6585typeApp :: Pattern () Type (Type, Type)

6686typeApp = mkPattern match

6787 where

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

92112 go idents other = PrettyPrintForAll idents other

93113 convertForAlls other = other

94114

95−matchTypeAtom :: Pattern () Type String

96−matchTypeAtom = typeLiterals <+> fmap parens matchType

115+matchTypeAtom :: Pattern () Type Box

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

97117

98−matchType :: Pattern () Type String

118+matchType :: Pattern () Type Box

99119matchType = buildPrettyPrinter operators matchTypeAtom

100120 where

101− operators :: OperatorTable () Type String

121+ operators :: OperatorTable () Type Box

102122 operators =

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

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

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

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

105125 ]

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

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

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

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

108128 ]

109129

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

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

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

114134 match _ = Nothing

115135

116−-- |

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

118−--

136+typeAtomAsBox :: Type -> Box

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

138+

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

119140prettyPrintTypeAtom :: Type -> String

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

141+prettyPrintTypeAtom = render . typeAtomAsBox

121142

143+typeAsBox :: Type -> Box

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

122145

123−-- |

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

125−--

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

126147prettyPrintType :: 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 (

2121 prettyPrintBinderAtom

2222) where

2323

24−import Data.Maybe (fromMaybe)

2524import Data.List (intercalate)

2625

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

28−import Control.PatternArrows

29−import Control.Monad.State

30−#if __GLASGOW_HASKELL__ < 710

31−import Control.Applicative

32−#endif

26+import Control.Arrow (second)

3327

3428import Language.PureScript.AST

3529import Language.PureScript.Names

3630import Language.PureScript.Pretty.Common

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

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

3832

39−literals :: Pattern PrinterState Expr String

40−literals = mkPattern' match

33+import Text.PrettyPrint.Boxes

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 ] ])

4139 where

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

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

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

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

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

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

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

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

50− match (ObjectConstructor ps) = prettyPrintObject' ps

51− match (ObjectGetter prop) = return $ "(." ++ 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

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

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 ++ ")"

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

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

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

85− match _ = mzero

86−

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

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

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

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

91− , prettyPrintValue' val

92− ]

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

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

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

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

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

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

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

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

85+prettyPrintValueAtom (ObjectConstructor ps) = prettyPrintObject ps

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

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

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

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

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

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

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

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

94+

95+prettyPrintDeclaration :: Declaration -> Box

96+prettyPrintDeclaration (TypeDeclaration ident ty) =

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

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

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

93100prettyPrintDeclaration (PositionedDeclaration _ _ d) = prettyPrintDeclaration d

94101prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"

95102

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

103+prettyPrintCaseAlternative :: CaseAlternative -> Box

97104prettyPrintCaseAlternative (CaseAlternative binders result) =

98− concat <$> sequence

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

100− , prettyPrintResult result

101− ]

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

102106 where

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

104− [ return "\n"

105− , withIndent $ prettyPrintMany prettyPrintGuardedValue gs

106− ]

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

108−

109− prettyPrintGuardedValue (grd, val) =

110− concat <$> sequence

111− [ return "| "

112− , prettyPrintValue' grd

113− , return " -> "

114− , prettyPrintValue' val

115− ]

116−

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

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

108+ prettyPrintResult (Left gs) =

109+ vcat left (map prettyPrintGuardedValue gs)

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

111+

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

113+ prettyPrintGuardedValue (grd, val) = foldl1 before

114+ [ text " | "

115+ , prettyPrintValue grd

116+ , text " -> "

117+ , prettyPrintValue val

118+ ]

119+

120+prettyPrintDoNotationElement :: DoNotationElement -> Box

118121prettyPrintDoNotationElement (DoNotationValue val) =

119− prettyPrintValue' val

122+ prettyPrintValue val

120123prettyPrintDoNotationElement (DoNotationBind binder val) =

121− concat <$> sequence

122− [ return (prettyPrintBinder binder)

123− , return " <- "

124− , prettyPrintValue' val

125− ]

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

126125prettyPrintDoNotationElement (DoNotationLet ds) =

127− concat <$> sequence

128− [ return "let "

129− , withIndent $ prettyPrintMany prettyPrintDeclaration ds

130− ]

126+ text "let" //

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

131128prettyPrintDoNotationElement (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement el

132129

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−

191130prettyPrintBinderAtom :: Binder -> String

192131prettyPrintBinderAtom NullBinder = "_"

193132prettyPrintBinderAtom (StringBinder str) = show str

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

196135prettyPrintBinderAtom (BooleanBinder True) = "true"

197136prettyPrintBinderAtom (BooleanBinder False) = "false"

198137prettyPrintBinderAtom (VarBinder ident) = showIdent ident

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

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

200139prettyPrintBinderAtom (ObjectBinder bs) =

201140 "{ "

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

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

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

217156--

218157prettyPrintBinder :: Binder -> String

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

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

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

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

221160prettyPrintBinder (PositionedBinder _ _ binder) = prettyPrintBinder binder

222161prettyPrintBinder b = prettyPrintBinderAtom b