unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-10-05 14:17:33 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'wip/pp2' of github.com:unisonweb/unison into topic/codebase-editor

Browse Source
This commit is contained in:
Runar Bjarnason 2018-12-11 11:11:27 -05:00
commit 6b94e912bc
13 changed files with 647 additions and 477 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
parser-typechecker/prettyprintdemo/Main.hs Normal file
View File

@ -0,0 +1,68 @@
{-# Language OverloadedStrings #-}
{-# Language TypeApplications #-}
module Main where
import Data.String (fromString)
import Unison.Util.Pretty as PP
import Data.Text (Text)
main :: IO ()
main = do
-- putStrLn . PP.toANSI 60 $ ex1
-- print $ examples
putStrLn . PP.toANSI 25 $ examples
where
-- ex1 = PP.linesSpaced [PP.red "hi", PP.blue "blue"]
examples = PP.linesSpaced [
PP.bold "Creating `Pretty`s",
"Use `OverloadedStrings`, `lit`, and `text` to get values into `Pretty`",
"Here's an overloaded string",
PP.lit "Here's a call to `lit`", -- works for any `IsString`
PP.text ("No need to Text.unpack, just `PP.text` directly" :: Text),
PP.bold "Use the `Monoid` and/or `Semigroup` to combine strings",
"Hello, " <> PP.red "world!",
PP.yellow "`wrapWords` does automatic line wrapping",
PP.wrapWords loremIpsum,
PP.bold "Indentation: can indent by n spaces, or by another `Pretty`",
PP.indentN 2 (PP.wrapWords loremIpsum),
PP.indent (PP.red ">> ") (PP.wrapWords loremIpsum),
PP.bold "Other handy functions",
PP.bulleted [
PP.sep ", " (replicate 10 "a"),
PP.lines ["Alice", PP.hiBlue "Bob", "Carol"],
PP.blue "foo bar baz"
],
PP.indentN 4 $ PP.bulleted ["Alice", "Bob", "Carol"],
PP.dashed ["Alice", PP.red "Bob", "Carol"],
PP.column2 [
(PP.bold "Name", PP.bold "Favorite color"),
("Alice" , PP.red "Red"),
("Bob" , PP.blue "Blue"),
("Carolina" , PP.green "Green"),
("Dave" , PP.black "Black")
],
PP.numbered (fromString . show) [
"a", "b", "c", "d", "e", "f", "g", "h", "i", "j"],
-- Feel free to start the numbering wherever you like
PP.numbered (fromString . show . (10 +)) ["uno", "dos", "tres"],
PP.bold "Grouping and breaking",
PP.wrapWords "The orElse function chooses between two `Pretty`, preferring the first if it fits, and using the second otherwise.",
PP.wrapWords "The `group` function introduces a level of breaking. The renderer will try to avoid breaking up a `group` unless it's needed. Groups are broken \"outside in\".",
-- question - I think this group shouldn't be needed
PP.group (PP.orElse "This fits." "So this won't be used."),
"This is a very long string which won't fit."
`PP.orElse` "This is a very...(truncated)"
]
loremIpsum = "Lorem ipsum dolor sit amet, consectetur adipiscing elit."
-- loremIpsum = "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Maecenas sem nisi, venenatis viverra ex eu, tristique dapibus justo. Ut lobortis mattis rutrum. Vivamus mattis eros diam, a egestas mi venenatis vel. Nunc felis dui, consectetur ac volutpat vitae, molestie in augue. Cras nec aliquet ex. In et sem vel sapien auctor euismod. Pellentesque eu aliquam dolor. Cras porttitor mi velit, dapibus vulputate odio pharetra non. Etiam iaculis nulla eu nisl euismod ultricies."

10
parser-typechecker/src/Unison/Codebase.hs
View File

@ -49,8 +49,8 @@ import qualified Unison.Typechecker.TypeLookup as TL
import qualified Unison.UnisonFile as UF
import Unison.Util.AnnotatedText ( AnnotatedText )
import Unison.Util.ColorText ( Color )
import Unison.Util.PrettyPrint ( PrettyPrint )
import qualified Unison.Util.PrettyPrint as PP
import Unison.Util.Pretty ( Pretty )
import qualified Unison.Util.Pretty as PP
import qualified Unison.Var as Var
import Unison.Var ( Var )
@ -193,7 +193,7 @@ prettyBinding
-> Name
-> Referent
-> Branch
-> m (Maybe (PrettyPrint String))
-> m (Maybe (Pretty String))
prettyBinding _ _ (Referent.Ref (Reference.Builtin _)) _ = pure Nothing
prettyBinding cb name r0@(Referent.Ref r1@(Reference.DerivedId r)) b =
go =<< getTerm cb r
@ -217,7 +217,7 @@ prettyBinding cb name r0@(Referent.Ref r1@(Reference.DerivedId r)) b =
prettyBinding _ _ r _ = error $ "unpossible " ++ show r
prettyBindings :: (Var.Var v, Monad m)
=> Codebase m v a -> [(Name,Referent)] -> Branch -> m (PrettyPrint String)
=> Codebase m v a -> [(Name,Referent)] -> Branch -> m (Pretty String)
prettyBindings cb tms b = do
ds <- catMaybes <$> (forM tms $ \(name,r) -> prettyBinding cb name r b)
pure $ PP.linesSpaced ds
@ -228,7 +228,7 @@ prettyBindingsQ
=> Codebase m v a
-> String
-> Branch
-> m (PrettyPrint String)
-> m (Pretty String)
prettyBindingsQ cb query b =
let possible = Branch.allTermNames (Branch.head b)
matches =

2
parser-typechecker/src/Unison/Codebase/CommandLine.hs
View File

@ -70,7 +70,7 @@ import qualified Unison.UnisonFile as UF
import qualified Unison.Util.ColorText as Color
import qualified Unison.Util.Menu as Menu
import Unison.Util.Monoid
import qualified Unison.Util.PrettyPrint as PP
import qualified Unison.Util.Pretty as PP
import Unison.Util.TQueue ( TQueue )
import qualified Unison.Util.TQueue as TQueue
import Unison.Var ( Var )

21
parser-typechecker/src/Unison/PrettyPrint.hs
View File

@ -1,21 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Unison.PrettyPrint where
import Unison.Util.PrettyPrint
import Data.String (IsString)
import Unison.Lexer (symbolyId)
import Data.Either (isRight)
parenthesize :: (Semigroup a, IsString a) => a -> a
parenthesize doc = "(" <> doc <> ")"
parenthesizeIf :: (Semigroup a, IsString a) => Bool -> a -> a
parenthesizeIf cond doc = if cond then parenthesize doc else doc
parenthesizeGroupIf :: (Semigroup a, IsString a) => Bool -> PrettyPrint a -> PrettyPrint a
parenthesizeGroupIf cond doc = parenthesizeIf cond (Group doc)
prettyVar :: (Semigroup a, IsString a) => String -> a -> a
prettyVar a = parenthesizeIf(isRight $ symbolyId a)

312
parser-typechecker/src/Unison/TermPrinter.hs
View File

@ -4,10 +4,10 @@
module Unison.TermPrinter where
import Control.Monad (join)
import Data.List
import qualified Data.Text as Text
import Data.Foldable ( fold
, toList
)
import Data.Maybe ( fromMaybe
, isJust
@ -26,8 +26,8 @@ import qualified Unison.TypePrinter as TypePrinter
import Unison.Var ( Var )
import qualified Unison.Var as Var
import Unison.Util.Monoid ( intercalateMap )
import qualified Unison.Util.PrettyPrint as PP
import Unison.Util.PrettyPrint ( PrettyPrint(..) )
import qualified Unison.Util.Pretty as PP
import Unison.Util.Pretty ( Pretty )
import Unison.PrettyPrintEnv ( PrettyPrintEnv )
import qualified Unison.PrettyPrintEnv as PrettyPrintEnv
@ -38,17 +38,17 @@ import qualified Unison.PrettyPrintEnv as PrettyPrintEnv
data AmbientContext = AmbientContext
{
-- The operator precedence of the enclosing context (a number from 0 to 11,
-- or -1 to render without outer parentheses unconditionally).
-- or -1 to render without outer parentheses unconditionally).
-- Function application has precedence 10.
precedence :: Int
, blockContext :: BlockContext
, infixContext :: InfixContext
}
-- Description of the position of this ABT node, when viewed in the
-- Description of the position of this ABT node, when viewed in the
-- surface syntax.
data BlockContext
-- This ABT node is at the top level of a TermParser.block.
-- This ABT node is at the top level of a TermParser.block.
= Block
| Normal
deriving (Eq)
@ -66,7 +66,7 @@ data InfixContext
>=10
10f 10x
This example shows that a function application f x is enclosed in
This example shows that a function application f x is enclosed in
parentheses whenever the ambient precedence around it is >= 10, and that
when printing its two components, an ambient precedence of 10 is used in
both places.
@ -118,21 +118,20 @@ pretty
=> PrettyPrintEnv
-> AmbientContext
-> AnnotatedTerm v a
-> PrettyPrint String
-> Pretty String
pretty n AmbientContext { precedence = p, blockContext = bc, infixContext = ic } term
= specialCases term $ \case
Var' v -> parenIfInfix (varName v) ic $ l $ varName v
Var' v -> parenIfInfix (Var.nameStr v) ic . PP.text $ Var.name v
Ref' r -> parenIfInfix name ic $ l $ name
where name = Text.unpack (PrettyPrintEnv.termName n (Referent.Ref r))
Ann' tm t ->
paren (p >= 0)
$ pretty n (ac 10 Normal) tm
<> b " "
<> (PP.Nest " " $ PP.Group (l ": " <> TypePrinter.pretty n 0 t))
Int' i -> (if i >= 0 then l "+" else Empty) <> (l $ show i)
<> PP.hang " :" (TypePrinter.pretty n 0 t)
Int' i -> (if i >= 0 then l "+" else mempty) <> (l $ show i)
Nat' u -> l $ show u
Float' f -> l $ show f
-- TODO How to handle Infinity, -Infinity and NaN? Parser cannot parse
-- TODO How to handle Infinity, -Infinity and NaN? Parser cannot parse
-- them. Haskell doesn't have literals for them either. Is this
-- function only required to operate on terms produced by the parser?
-- In which case the code is fine as it stands. If it can somehow run
@ -147,135 +146,102 @@ pretty n AmbientContext { precedence = p, blockContext = bc, infixContext = ic }
Request' ref i -> l (Text.unpack (PrettyPrintEnv.requestName n ref i))
Handle' h body ->
paren (p >= 2)
$ l "handle"
<> b " "
<> pretty n (ac 2 Normal) h
<> b " "
<> l "in"
<> b " "
<> PP.Nest " " (PP.Group (pretty n (ac 2 Block) body))
$ ("handle" `PP.hang` pretty n (ac 2 Normal) h)
<> PP.softbreak
<> ("in" `PP.hang` pretty n (ac 2 Block) body)
App' x (Constructor' Type.UnitRef 0) ->
paren (p >= 11) $ l "!" <> pretty n (ac 11 Normal) x
AskInfo' x -> paren (p >= 11) $ pretty n (ac 11 Normal) x <> l "?"
LamNamed' v x | (Var.name v) == "()" ->
paren (p >= 11) $ l "'" <> pretty n (ac 11 Normal) x
Vector' xs ->
PP.Group
$ l "["
<> intercalateMap ("," <> b " ")
(PP.Nest " " . pretty n (ac 0 Normal))
(toList xs)
<> l "]"
If' cond t f ->
paren (p >= 2)
$ ( PP.Group
( l "if"
<> b " "
<> (PP.Nest " " $ PP.Group $ pretty n (ac 2 Block) cond)
)
<> b " "
<> PP.Group
( l "then"
<> b " "
<> (PP.Nest " " $ PP.Group $ pretty n (ac 2 Block) t)
)
<> b " "
<> PP.Group
( l "else"
<> b " "
<> (PP.Nest " " $ PP.Group $ pretty n (ac 2 Block) f)
)
)
Vector' xs -> PP.group $
"[" <> optSpace
<> intercalateMap ("," <> PP.softbreak <> optSpace)
(pretty n (ac 0 Normal))
xs
<> "]"
where optSpace = PP.orElse "" " "
If' cond t f -> paren (p >= 2) $
if height > 0 then PP.lines [
"if " <> pcond <> (" then") `PP.hang` pt,
"else" `PP.hang` pf
]
else PP.spaced [
"if" `PP.hang` pcond <> (" then" `PP.hang` pt),
"else" `PP.hang` pf
]
where
height = PP.preferredHeight pt `max` PP.preferredHeight pf
pcond = pretty n (ac 2 Block) cond
pt = pretty n (ac 2 Block) t
pf = pretty n (ac 2 Block) f
And' x y ->
paren (p >= 10)
$ l "and"
<> b " "
<> pretty n (ac 10 Normal) x
<> b " "
<> pretty n (ac 10 Normal) y
paren (p >= 10) $ PP.spaced [
"and", pretty n (ac 10 Normal) x,
pretty n (ac 10 Normal) y
]
Or' x y ->
paren (p >= 10)
$ l "or"
<> b " "
<> pretty n (ac 10 Normal) x
<> b " "
<> pretty n (ac 10 Normal) y
paren (p >= 10) $ PP.spaced [
"or", pretty n (ac 10 Normal) x,
pretty n (ac 10 Normal) y
]
LetRecNamed' bs e -> printLet bc bs e
Lets' bs e -> printLet bc (map (\(_, v, binding) -> (v, binding)) bs) e
Match' scrutinee branches ->
paren (p >= 2)
$ PP.BrokenGroup
$ PP.Group
(l "case" <> b " " <> pretty n (ac 2 Normal) scrutinee <> b " " <> l
"of"
)
<> b " "
<> (PP.Nest " " $ fold (intersperse (b "; ") (map printCase branches)))
Match' scrutinee branches -> paren (p >= 2) $
("case " <> pretty n (ac 2 Normal) scrutinee <> " of") `PP.hang` bs
where bs = PP.lines (map printCase branches)
t -> l "error: " <> l (show t)
where
specialCases term go = case (term, binaryOpsPred) of
(Tuple' [x], _) ->
paren (p >= 10)
$ l "Pair"
<> b " "
<> pretty n (ac 10 Normal) x
<> b " "
<> l "()"
paren (p >= 10) $ "Pair" `PP.hang`
PP.spaced [pretty n (ac 10 Normal) x, "()" ]
(Tuple' xs, _) -> paren True $ commaList xs
BinaryAppsPred' apps lastArg ->
paren (p >= 3) $ binaryApps apps <> pretty n (ac 3 Normal) lastArg
BinaryAppsPred' apps lastArg -> paren (p >= 3) $
binaryApps apps (pretty n (ac 3 Normal) lastArg)
_ -> case (term, nonForcePred) of
AppsPred' f args | not $ isVarKindInfo f ->
paren (p >= 10) $ pretty n (ac 10 Normal) f <> b " " <> PP.Nest
" "
(PP.Group (intercalateMap (b " ") (pretty n (ac 10 Normal)) args))
paren (p >= 10) $ pretty n (ac 10 Normal) f `PP.hang`
PP.spacedMap (pretty n (ac 10 Normal)) args
_ -> case (term, nonUnitArgPred) of
LamsNamedPred' vs body ->
paren (p >= 3)
$ varList vs
<> l " ->"
<> b " "
<> (PP.Nest " " $ PP.Group $ pretty n (ac 2 Block) body)
paren (p >= 3) $
(varList vs <> " ->") `PP.hang` pretty n (ac 2 Block) body
_ -> go term
sepList sep xs = sepList' (pretty n (ac 0 Normal)) sep xs
sepList' f sep xs = fold $ intersperse sep (map f xs)
varList vs = sepList' (\v -> l $ varName v) (b " ") vs
commaList = sepList (l "," <> b " ")
varList vs = sepList' (PP.text . Var.name) PP.softbreak vs
commaList = sepList ("," <> PP.softbreak)
-- The parser requires lets to use layout, so use BrokenGroup to get some
-- unconditional line-breaks. These will replace the occurrences of b"; ".
printLet sc bs e =
paren ((sc /= Block) && p >= 12)
$ PP.BrokenGroup
$ letIntro
$ (mconcat (map printBinding bs))
<> PP.Group (pretty n (ac 0 Normal) e)
$ PP.lines (map printBinding bs ++
[PP.group $ pretty n (ac 0 Normal) e])
where
printBinding (v, binding) = if isBlank $ varName v
then pretty n (ac (-1) Normal) binding <> b "; "
else prettyBinding n v binding <> b "; "
printBinding (v, binding) = if isBlank $ Var.nameStr v
then pretty n (ac (-1) Normal) binding
else prettyBinding n v binding
letIntro = case sc of
Block -> id
Normal -> \x -> l "let" <> b "; " <> (PP.Nest " " x)
Normal -> \x -> "let" `PP.hang` x
isBlank ('_' : rest) | (isJust ((readMaybe rest) :: Maybe Int)) = True
isBlank _ = False
printCase (MatchCase pat guard (AbsN' vs body)) =
PP.Group
$ PP.Group
((fst $ prettyPattern n (-1) vs pat) <> b " " <> printGuard guard <> l
"->"
)
<> b " "
<> (PP.Nest " " $ PP.Group $ pretty n (ac 0 Block) body) where
printGuard (Just g) = l "|" <> b " " <> pretty n (ac 2 Normal) g <> b " "
printGuard Nothing = Empty
PP.group $ lhs `PP.hang` pretty n (ac 0 Block) body
where
lhs = PP.group (fst (prettyPattern n (-1) vs pat) <> " ")
<> printGuard guard
<> "->"
printGuard (Just g) = PP.group $ PP.spaced ["|", pretty n (ac 2 Normal) g, ""]
printGuard Nothing = mempty
printCase _ = l "error"
-- This predicate controls which binary functions we render as infix
-- operators. At the moment the policy is just to render symbolic
-- operators as infix - not 'wordy' function names. So we produce
-- This predicate controls which binary functions we render as infix
-- operators. At the moment the policy is just to render symbolic
-- operators as infix - not 'wordy' function names. So we produce
-- "x + y" and "foo x y" but not "x `foo` y".
binaryOpsPred :: Var v => AnnotatedTerm v a -> Bool
binaryOpsPred = \case
@ -292,19 +258,26 @@ pretty n AmbientContext { precedence = p, blockContext = bc, infixContext = ic }
nonUnitArgPred v = (Var.name v) /= "()"
-- Render a binary infix operator sequence, like [(a2, f2), (a1, f1)],
-- meaning (a1 `f1` a2) `f2` (a3 rendered by the caller), producing
-- "a1 `f1` a2 `f2`". Except the operators are all symbolic, so we won't
-- produce any backticks. We build the result out from the right,
-- meaning (a1 `f1` a2) `f2` (a3 rendered by the caller), producing
-- "a1 `f1` a2 `f2`". Except the operators are all symbolic, so we won't
-- produce any backticks. We build the result out from the right,
-- starting at `f2`.
binaryApps
:: Var v => [(AnnotatedTerm v a, AnnotatedTerm v a)] -> PrettyPrint String
binaryApps xs = foldr (flip (<>)) mempty (map r xs)
:: Var v => [(AnnotatedTerm v a, AnnotatedTerm v a)]
-> Pretty String
-> Pretty String
binaryApps xs last = unbroken `PP.orElse` broken
-- todo: use `PP.column2` in the case where we need to break
where
r (a, f) =
pretty n (ac 3 Normal) a
<> b " "
<> pretty n (AmbientContext 10 Normal Infix) f
<> b " "
unbroken = PP.spaced (ps ++ [last])
broken = PP.column2 (psCols $ [""] ++ ps ++ [last])
psCols ps = case take 2 ps of
[x,y] -> (x,y) : psCols (drop 2 ps)
[] -> []
_ -> error "??"
ps = join $ [r a f | (a, f) <- reverse xs ]
r a f = [pretty n (ac 3 Normal) a,
pretty n (AmbientContext 10 Normal Infix) f]
pretty' :: Var v => Maybe Int -> PrettyPrintEnv -> AnnotatedTerm v a -> String
pretty' (Just width) n t = PP.render width $ pretty n (ac (-1) Normal) t
@ -316,75 +289,63 @@ prettyPattern
-> Int
-> [v]
-> Pattern loc
-> (PrettyPrint String, [v])
-> (Pretty String, [v])
-- vs is the list of pattern variables used by the pattern, plus possibly a
-- tail of variables it doesn't use. This tail is the second component of
-- the return value.
prettyPattern n p vs patt = case patt of
Pattern.Unbound _ -> (l "_", vs)
Pattern.Var _ -> let (v : tail_vs) = vs in (l $ varName v, tail_vs)
Pattern.Var _ -> let (v : tail_vs) = vs in (l $ Var.nameStr v, tail_vs)
Pattern.Boolean _ b -> (if b then l "true" else l "false", vs)
Pattern.Int _ i -> ((if i >= 0 then l "+" else Empty) <> (l $ show i), vs)
Pattern.Int _ i -> ((if i >= 0 then l "+" else mempty) <> (l $ show i), vs)
Pattern.Nat _ u -> (l $ show u, vs)
Pattern.Float _ f -> (l $ show f, vs)
Pattern.Tuple [pp] ->
let (printed, tail_vs) = prettyPattern n 10 vs pp
in ( paren (p >= 10) $ l "Pair" <> b " " <> printed <> b " " <> l "()"
, tail_vs
)
in ( paren (p >= 10) $ PP.sep " " ["Pair", printed, "()"]
, tail_vs )
Pattern.Tuple pats ->
let (pats_printed, tail_vs) = patterns vs pats
in (paren True $ intercalateMap (l "," <> b " ") id pats_printed, tail_vs)
in (PP.parenthesizeCommas pats_printed, tail_vs)
Pattern.Constructor _ ref i [] ->
(PP.text (PrettyPrintEnv.patternName n ref i), vs)
Pattern.Constructor _ ref i pats ->
let (pats_printed, tail_vs) = patternsSep (b " ") vs pats
let (pats_printed, tail_vs) = patternsSep PP.softbreak vs pats
in ( paren (p >= 10)
$ l (Text.unpack (PrettyPrintEnv.patternName n ref i))
<> pats_printed
, tail_vs
)
$ PP.text (PrettyPrintEnv.patternName n ref i)
`PP.hang` pats_printed
, tail_vs)
Pattern.As _ pat ->
let (v : tail_vs) = vs
(printed, eventual_tail) = prettyPattern n 11 tail_vs pat
in (paren (p >= 11) $ ((l $ varName v) <> l "@" <> printed), eventual_tail)
in (paren (p >= 11) $ ((l $ Var.nameStr v) <> l "@" <> printed), eventual_tail)
Pattern.EffectPure _ pat ->
let (printed, eventual_tail) = prettyPattern n (-1) vs pat
in (l "{" <> b " " <> printed <> b " " <> l "}", eventual_tail)
in (PP.sep " " ["{", printed, "}"], eventual_tail)
Pattern.EffectBind _ ref i pats k_pat ->
let (pats_printed , tail_vs ) = patternsSep (b " ") vs pats
let (pats_printed , tail_vs ) = patternsSep PP.softbreak vs pats
(k_pat_printed, eventual_tail) = prettyPattern n 0 tail_vs k_pat
in ( l "{"
<> b ""
<> ( PP.Nest " "
$ PP.Group
$ b " "
<> l (Text.unpack (PrettyPrintEnv.patternName n ref i))
<> pats_printed
<> b " "
<> l "->"
<> b " "
<> k_pat_printed
<> b " "
)
<> l "}"
, eventual_tail
)
in ("{" <> l (Text.unpack (PrettyPrintEnv.patternName n ref i))
<> (intercalateMap " " id [pats_printed, "->", k_pat_printed]) <>
"}"
, eventual_tail)
t -> (l "error: " <> l (show t), vs)
where
l = Literal
l = PP.lit
patterns vs (pat : pats) =
let (printed , tail_vs ) = prettyPattern n (-1) vs pat
(rest_printed, eventual_tail) = patterns tail_vs pats
in (printed : rest_printed, eventual_tail)
patterns vs [] = ([], vs)
patternsSep sep vs pats = case patterns vs pats of
(printed, tail_vs) -> (foldMap (\x -> sep <> x) printed, tail_vs)
(printed, tail_vs) -> (PP.sep sep printed, tail_vs)
{- Render a binding, producing output of the form
foo : t -> u
foo a = ...
The first line is only output if the term has a type annotation as the
The first line is only output if the term has a type annotation as the
outermost constructor.
Binary functions with symbolic names are output infix, as follows:
@ -394,31 +355,29 @@ a + b = ...
-}
prettyBinding
:: Var v => PrettyPrintEnv -> v -> AnnotatedTerm v a -> PrettyPrint String
:: Var v => PrettyPrintEnv -> v -> AnnotatedTerm v a -> Pretty String
prettyBinding n v term = go (symbolic && isBinary term) term where
go infix' = \case
Ann' tm tp ->
PP.BrokenGroup
$ PP.Group (renderName v <> l " : " <> TypePrinter.pretty n (-1) tp)
<> b ";"
<> PP.Group (prettyBinding n v tm)
LamsNamedOpt' vs body -> PP.Group
( PP.Group (defnLhs v vs <> b " " <> l "=")
<> b " "
<> (PP.Nest " " $ PP.Group (pretty n (ac (-1) Block) body))
)
Ann' tm tp -> PP.lines [
PP.group (renderName v <> PP.hang " :" (TypePrinter.pretty n (-1) tp)),
PP.group (prettyBinding n v tm) ]
LamsNamedOpt' vs body -> PP.group $
PP.group (defnLhs v vs <> " =") `PP.hang`
pretty n (ac (-1) Block) body
where
t -> l "error: " <> l (show t)
where
defnLhs v vs = if infix'
then case vs of
x : y : _ ->
l (Text.unpack (Var.name x)) <> b " " <> l (varName v) <> b " " <> l
(Text.unpack (Var.name y))
PP.sep " " [PP.text (Var.name x),
PP.text (Var.name v),
PP.text (Var.name y)]
_ -> l "error"
else renderName v <> (args vs)
args vs = foldMap (\x -> b " " <> l (Text.unpack (Var.name x))) vs
renderName v = parenIfInfix (varName v) NonInfix $ l (varName v)
else if null vs then renderName v
else renderName v `PP.hang` args vs
args vs = PP.spacedMap (PP.text . Var.name) vs
renderName v = parenIfInfix (Var.nameStr v) NonInfix $ l (Var.nameStr v)
symbolic = isSymbolic (Var.name v)
isBinary = \case
Ann' tm _ -> isBinary tm
@ -429,23 +388,20 @@ prettyBinding'
:: Var v => Int -> PrettyPrintEnv -> v -> AnnotatedTerm v a -> String
prettyBinding' width n v t = PP.render width $ prettyBinding n v t
paren :: Bool -> PrettyPrint String -> PrettyPrint String
paren True s = PP.Group $ l "(" <> s <> l ")"
paren False s = PP.Group s
paren :: Bool -> Pretty String -> Pretty String
paren True s = PP.group $ "(" <> s <> ")"
paren False s = PP.group s
parenIfInfix
:: String -> InfixContext -> PrettyPrint String -> PrettyPrint String
:: String -> InfixContext -> Pretty String -> Pretty String
parenIfInfix name ic =
if isSymbolic (Text.pack name) && ic == NonInfix then paren True else id
varName :: Var v => v -> String
varName v = (Text.unpack (Var.name v))
l :: String -> Pretty String
l = PP.lit
l :: String -> PrettyPrint String
l = Literal
b :: String -> PrettyPrint String
b = Breakable
-- b :: String -> Pretty String
-- b = Breakable
-- When we use imports in rendering, this will need revisiting, so that we can
-- render say 'foo.+ x y' as 'import foo ... x + y'. symbolyId doesn't match

71
parser-typechecker/src/Unison/TypePrinter.hs
View File

@ -12,9 +12,8 @@ import Unison.Reference ( pattern Builtin )
import Unison.Type
import Unison.Var ( Var )
import qualified Unison.Var as Var
import Unison.Util.Monoid ( intercalateMap )
import qualified Unison.Util.PrettyPrint as PP
import Unison.Util.PrettyPrint ( PrettyPrint(..) )
import qualified Unison.Util.Pretty as PP
import Unison.Util.Pretty (Pretty)
import Unison.PrettyPrintEnv ( PrettyPrintEnv )
import qualified Unison.PrettyPrintEnv as PrettyPrintEnv
@ -41,9 +40,9 @@ import qualified Unison.PrettyPrintEnv as PrettyPrintEnv
-}
pretty
:: Var v => PrettyPrintEnv -> Int -> AnnotatedType v a -> PrettyPrint String
-- p is the operator precedence of the enclosing context (a number from 0 to
-- 11, or -1 to avoid outer parentheses unconditionally). Function
:: Var v => PrettyPrintEnv -> Int -> AnnotatedType v a -> Pretty String
-- p is the operator precedence of the enclosing context (a number from 0 to
-- 11, or -1 to avoid outer parentheses unconditionally). Function
-- application has precedence 10.
pretty n p tp = case tp of
Var' v -> l $ Text.unpack (Var.name v)
@ -52,39 +51,33 @@ pretty n p tp = case tp of
Abs' _ -> l $ "error" -- TypeParser does not currently emit Abs
Ann' _ _ -> l $ "error" -- TypeParser does not currently emit Ann
App' (Ref' (Builtin "Sequence")) x ->
PP.Group $ l "[" <> pretty n 0 x <> l "]"
Tuple' [x] ->
parenNest (p >= 10) $ l "Pair" <> b " " <> pretty n 10 x <> b " " <> l "()"
Tuple' xs -> parenNest True $ commaList xs
Apps' f xs ->
parenNoGroup (p >= 10)
$ pretty n 9 f
<> ( PP.Nest " "
$ PP.Group (mconcat $ map (\x -> b " " <> pretty n 10 x) xs)
)
Effect1' e t -> parenNest (p >= 10) $ pretty n 9 e <> l " " <> pretty n 10 t
PP.group $ l "[" <> pretty n 0 x <> l "]"
Tuple' [x] -> PP.parenthesizeIf (p >= 10) $
"Pair" `PP.hang` PP.spaced [pretty n 10 x, "()"]
Tuple' xs -> PP.parenthesizeCommas $ map (pretty n 0) xs
Apps' f xs -> PP.parenthesizeIf (p >= 10) $
pretty n 9 f `PP.hang` PP.spaced (pretty n 10 <$> xs)
Effect1' e t -> PP.parenthesizeIf (p >= 10) $ pretty n 9 e <> l " " <> pretty n 10 t
Effects' es -> effects (Just es)
ForallNamed' v body -> if (p < 0)
then pretty n p body
else
paren True $ l "∀ " <> l (Text.unpack (Var.name v)) <> l ". " <> PP.Nest
" "
(PP.Group $ pretty n (-1) body)
else paren True $
("∀ " <> l (Text.unpack (Var.name v)) <> ".")
`PP.hang` pretty n (-1) body
t@(Arrow' _ _) -> case (ungeneralizeEffects t) of
EffectfulArrows' (Ref' UnitRef) rest -> arrows True True rest
EffectfulArrows' fst rest ->
parenNest (p >= 0) $ pretty n 0 fst <> arrows False False rest
PP.parenthesizeIf (p >= 0) $ pretty n 0 fst <> arrows False False rest
_ -> l "error"
_ -> l "error"
where
commaList xs = intercalateMap (l "," <> b " ") (pretty n 0) xs
effects Nothing = Empty
effects (Just es) = PP.Group $ l "{" <> commaList es <> l "}"
effects Nothing = mempty
effects (Just es) = PP.group $ "{" <> PP.commas (pretty n 0 <$> es) <> "}"
arrow delay first mes =
(if first then Empty else b " " <> l "->")
<> (if delay then (if first then l "'" else l " '") else Empty)
(if first then mempty else PP.softbreak <> l "->")
<> (if delay then (if first then l "'" else l " '") else mempty)
<> effects mes
<> if (isJust mes) || (not delay) && (not first) then l " " else Empty
<> if (isJust mes) || (not delay) && (not first) then l " " else mempty
arrows delay first [(mes, Ref' UnitRef)] = arrow delay first mes <> l "()"
arrows delay first ((mes, Ref' UnitRef) : rest) =
@ -95,32 +88,32 @@ pretty n p tp = case tp of
$ pretty n 0 arg
<> arrows False False rest
)
arrows False False [] = Empty
arrows False True [] = Empty -- not reachable
arrows True _ [] = Empty -- not reachable
arrows False False [] = mempty
arrows False True [] = mempty -- not reachable
arrows True _ [] = mempty -- not reachable
paren True s = PP.Group $ l "(" <> s <> l ")"
paren False s = PP.Group s
paren True s = PP.group $ l "(" <> s <> l ")"
paren False s = PP.group s
parenNoGroup True s = l "(" <> s <> l ")"
parenNoGroup False s = s
parenNest useParen contents = PP.Nest " " $ paren useParen contents
-- parenNest useParen contents = PP.Nest " " $ paren useParen contents
l = Literal
l = PP.lit
b = Breakable
-- b = Breakable
pretty' :: Var v => Maybe Int -> PrettyPrintEnv -> AnnotatedType v a -> String
pretty' (Just width) n t = PP.render width $ pretty n (-1) t
pretty' Nothing n t = PP.renderUnbroken $ pretty n (-1) t
pretty' Nothing n t = PP.render maxBound $ pretty n (-1) t
prettySignatures
:: Var v
=> PrettyPrintEnv
-> [(Name, AnnotatedType v a)]
-> PrettyPrint String
-> Pretty String
prettySignatures env ts = PP.column2
[ (PP.text name, ":" <> PP.softbreak <> PP.Nest " " (pretty env (-1) typ))
[ (PP.text name, ":" <> PP.hang "" (pretty env (-1) typ))
| (name, typ) <- ts
]

11
parser-typechecker/src/Unison/Util/AnnotatedText.hs
View File

@ -50,6 +50,17 @@ instance LL.ListLike (AnnotatedText a) Char where
Nothing -> LL.uncons (AnnotatedText tl)
Just (hd,s) -> Just (hd, AnnotatedText $ (s,a) :<| tl)
Seq.Empty -> Nothing
take n (AnnotatedText at) = case at of
Seq.Empty -> AnnotatedText Seq.Empty
(s,a) :<| tl ->
if n <= length s then AnnotatedText $ pure (take n s, a)
else AnnotatedText (pure (s,a)) <>
LL.take (n - length s) (AnnotatedText tl)
drop n (AnnotatedText at) = case at of
Seq.Empty -> AnnotatedText Seq.Empty
(s,a) :<| tl ->
if n <= length s then AnnotatedText $ pure (drop n s, a)
else LL.drop (n - length s) (AnnotatedText tl)
null (AnnotatedText at) = all (null . fst) at
-- Quoted text (indented, with source line numbers) with annotated portions.

2
parser-typechecker/src/Unison/Util/ColorText.hs
View File

@ -29,7 +29,7 @@ black t = style Black t
red t = style Red t
green t = style Green t
yellow t = style Yellow t
blue t = style Yellow t
blue t = style Blue t
purple t = style Purple t
cyan t = style Cyan t
white t = style White t

344
parser-typechecker/src/Unison/Util/Pretty.hs Normal file
View File

@ -0,0 +1,344 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Unison.Util.Pretty (
Pretty,
bulleted,
-- breakable
column2,
commas,
dashed,
flatMap,
group,
hang',
hang,
hangUngrouped',
hangUngrouped,
indent,
indentAfterNewline,
indentN,
indentNAfterNewline,
leftPad,
lines,
linesSpaced,
lit,
map,
nest,
newline,
numbered,
orElse,
orElses,
parenthesize,
parenthesizeCommas,
parenthesizeIf,
preferredWidth,
preferredHeight,
render,
renderUnbroken,
rightPad,
sep,
sepSpaced,
softbreak,
spaceIfBreak,
spacesIfBreak,
spaced,
spacedMap,
surroundCommas,
text,
toANSI,
toPlain,
wrap,
wrapWords,
black, red, green, yellow, blue, purple, cyan, white, hiBlack, hiRed, hiGreen, hiYellow, hiBlue, hiPurple, hiCyan, hiWhite, bold
) where
import Data.Foldable ( toList )
import Data.List ( foldl' , foldr1, intersperse )
import Data.Sequence ( Seq )
import Data.String ( IsString , fromString )
import Data.Text ( Text )
import Prelude hiding ( lines , map )
import qualified Unison.Util.ColorText as CT
import Unison.Util.Monoid ( intercalateMap )
import qualified Data.ListLike as LL
import qualified Data.Sequence as Seq
import qualified Data.Text as Text
type Width = Int
data Pretty s = Pretty { delta :: Delta, out :: F s (Pretty s) }
data F s r
= Empty | Group r | Lit s | Wrap (Seq r) | OrElse r r | Append (Seq r)
deriving (Show, Foldable, Traversable, Functor)
lit :: (IsString s, LL.ListLike s Char) => s -> Pretty s
lit s = lit' (foldMap chDelta $ LL.toList s) s
lit' :: Delta -> s -> Pretty s
lit' d s = Pretty d (Lit s)
orElse :: Pretty s -> Pretty s -> Pretty s
orElse p1 p2 = Pretty (delta p1) (OrElse p1 p2)
orElses :: [Pretty s] -> Pretty s
orElses [] = mempty
orElses ps = foldr1 orElse ps
wrap :: IsString s => [Pretty s] -> Pretty s
wrap [] = mempty
wrap (p:ps) = wrap_ . Seq.fromList $
p : fmap (\p -> (" " <> p) `orElse` (newline <> p)) ps
wrap_ :: Seq (Pretty s) -> Pretty s
wrap_ ps = Pretty (foldMap delta ps) (Wrap ps)
wrapWords :: IsString s => String -> Pretty s
wrapWords = wrap . fmap fromString . words
group :: Pretty s -> Pretty s
group p = Pretty (delta p) (Group p)
toANSI :: Width -> Pretty CT.ColorText -> String
toANSI avail p = CT.toANSI (render avail p)
toPlain :: Width -> Pretty CT.ColorText -> String
toPlain avail p = CT.toPlain (render avail p)
renderUnbroken :: (Monoid s, IsString s) => Pretty s -> s
renderUnbroken = render maxBound
render :: (Monoid s, IsString s) => Width -> Pretty s -> s
render availableWidth p = go mempty [Right p] where
go _ [] = mempty
go cur (p:rest) = case p of
Right p -> -- `p` might fit, let's try it!
if p `fits` cur then flow p <> go (cur <> delta p) rest
else go cur (Left p : rest) -- nope, switch to breaking mode
Left p -> case out p of -- `p` requires breaking
Append ps -> go cur ((Left <$> toList ps) <> rest)
Empty -> go cur rest
Group p -> go cur (Right p : rest)
-- Note: literals can't be broken further so they're
-- added to output unconditionally
Lit l -> l <> go (cur <> delta p) rest
OrElse _ p -> go cur (Right p : rest)
Wrap ps -> go cur ((Right <$> toList ps) <> rest)
flow p = case out p of
Append ps -> foldMap flow ps
Empty -> mempty
Group p -> flow p
Lit s -> s
OrElse p _ -> flow p
Wrap ps -> foldMap flow ps
fits p cur =
let cur' = cur { maxCol = col cur }
in maxCol (cur' <> delta p) < availableWidth
newline :: IsString s => Pretty s
newline = lit' (chDelta '\n') (fromString "\n")
spaceIfBreak :: IsString s => Pretty s
spaceIfBreak = "" `orElse` " "
spacesIfBreak :: IsString s => Int -> Pretty s
spacesIfBreak n = "" `orElse` (fromString $ replicate n ' ')
softbreak :: IsString s => Pretty s
softbreak = " " `orElse` newline
spaced :: (Foldable f, IsString s) => f (Pretty s) -> Pretty s
spaced = intercalateMap softbreak id
spacedMap :: (Foldable f, IsString s) => (a -> Pretty s) -> f a -> Pretty s
spacedMap f as = spaced . fmap f $ toList as
commas :: (Foldable f, IsString s) => f (Pretty s) -> Pretty s
commas = intercalateMap ("," <> softbreak) id
parenthesizeCommas :: (Foldable f, IsString s) => f (Pretty s) -> Pretty s
parenthesizeCommas = surroundCommas "(" ")"
surroundCommas :: (Foldable f, IsString s) => Pretty s -> Pretty s -> f (Pretty s) -> Pretty s
surroundCommas start stop fs = group $
start <> spaceIfBreak
<> intercalateMap ("," <> softbreak <> align) id fs
<> stop
where align = spacesIfBreak (preferredWidth start + 1)
sepSpaced :: (Foldable f, IsString s) => Pretty s -> f (Pretty s) -> Pretty s
sepSpaced between = sep (between <> softbreak)
sep :: (Foldable f, IsString s) => Pretty s -> f (Pretty s) -> Pretty s
sep between = intercalateMap between id
parenthesize :: IsString s => Pretty s -> Pretty s
parenthesize p = group $ "(" <> p <> ")"
parenthesizeIf :: IsString s => Bool -> Pretty s -> Pretty s
parenthesizeIf False s = s
parenthesizeIf True s = parenthesize s
lines :: (Foldable f, IsString s) => f (Pretty s) -> Pretty s
lines = intercalateMap newline id
linesSpaced :: (Foldable f, IsString s) => f (Pretty s) -> Pretty s
linesSpaced ps = lines (intersperse "" $ toList ps)
bulleted :: (Foldable f, LL.ListLike s Char, IsString s) => f (Pretty s) -> Pretty s
bulleted = intercalateMap newline (\b -> "* " <> indentAfterNewline " " b)
dashed :: (Foldable f, LL.ListLike s Char, IsString s) => f (Pretty s) -> Pretty s
dashed = intercalateMap newline (\b -> "- " <> indentAfterNewline " " b)
numbered :: (Foldable f, LL.ListLike s Char, IsString s) => (Int -> Pretty s) -> f (Pretty s) -> Pretty s
numbered num ps = column2 (fmap num [1..] `zip` toList ps)
leftPad, rightPad :: IsString s => Int -> Pretty s -> Pretty s
leftPad n p =
let rem = n - preferredWidth p
in if rem > 0 then fromString (replicate rem ' ') <> p
else p
rightPad n p =
let rem = n - preferredWidth p
in if rem > 0 then p <> fromString (replicate rem ' ')
else p
column2 :: (LL.ListLike s Char, IsString s) => [(Pretty s, Pretty s)] -> Pretty s
column2 rows = lines (group <$> alignedRows) where
maxWidth = foldl' max 0 (preferredWidth . fst <$> rows) + 1
alignedRows = [ rightPad maxWidth col0 <> indentNAfterNewline maxWidth col1
| (col0, col1) <- rows ]
text :: IsString s => Text -> Pretty s
text t = fromString (Text.unpack t)
hang' :: (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s -> Pretty s -> Pretty s
hang' from by p = group $
if preferredHeight p > 0 then from <> "\n" <> group (indent by p)
else (from <> " " <> group p) `orElse`
(from <> "\n" <> group (indent by p))
hangUngrouped' :: (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s -> Pretty s -> Pretty s
hangUngrouped' from by p =
if preferredHeight p > 0 then from <> "\n" <> indent by p
else (from <> " " <> p) `orElse`
(from <> "\n" <> indent by p)
hangUngrouped :: (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s -> Pretty s
hangUngrouped from p = hangUngrouped' from " " p
hang :: (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s -> Pretty s
hang from p = hang' from " " p
nest :: (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s -> Pretty s
nest by = hang' "" by
indent :: (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s -> Pretty s
indent by p = by <> indentAfterNewline by p
indentN :: (LL.ListLike s Char, IsString s) => Width -> Pretty s -> Pretty s
indentN by = indent (fromString $ replicate by ' ')
indentNAfterNewline :: (LL.ListLike s Char, IsString s) => Width -> Pretty s -> Pretty s
indentNAfterNewline by = indentAfterNewline (fromString $ replicate by ' ')
indentAfterNewline :: (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s -> Pretty s
indentAfterNewline by p = flatMap f p where
f s0 = case LL.break (== '\n') s0 of
(hd, s) -> if LL.null s then lit s0
-- use `take` and `drop` to preserve annotations or
-- or other extra info attached to the original `s`
else lit (LL.take (LL.length hd) s0) <>
"\n" <> by <> f (LL.drop 1 s)
instance IsString s => IsString (Pretty s) where
fromString s = lit' (foldMap chDelta s) (fromString s)
instance Semigroup (Pretty s) where (<>) = mappend
instance Monoid (Pretty s) where
mempty = Pretty mempty Empty
mappend p1 p2 = Pretty (delta p1 <> delta p2) .
Append $ case (out p1, out p2) of
(Append ps1, Append ps2) -> ps1 <> ps2
(Append ps1, _) -> ps1 <> pure p2
(_, Append ps2) -> pure p1 <> ps2
(_,_) -> pure p1 <> pure p2
data Delta =
Delta { line :: !Int, col :: !Int, maxCol :: !Int }
deriving (Eq,Ord,Show)
instance Semigroup Delta where (<>) = mappend
instance Monoid Delta where
mempty = Delta 0 0 0
mappend (Delta l c mc) (Delta 0 c2 mc2) = Delta l (c + c2) (mc `max` mc2 `max` (c+c2))
mappend (Delta l _ mc) (Delta l2 c2 mc2) = Delta (l + l2) c2 (mc `max` mc2)
chDelta :: Char -> Delta
chDelta '\n' = Delta 1 0 0
chDelta _ = Delta 0 1 1
preferredWidth :: Pretty s -> Width
preferredWidth p = col (delta p)
preferredHeight :: Pretty s -> Width
preferredHeight p = line (delta p)
black, red, green, yellow, blue, purple, cyan, white, hiBlack, hiRed, hiGreen,
hiYellow, hiBlue, hiPurple, hiCyan, hiWhite, bold :: Pretty CT.ColorText -> Pretty CT.ColorText
black = map CT.black
red = map CT.red
green = map CT.green
yellow = map CT.yellow
blue = map CT.blue
purple = map CT.purple
cyan = map CT.cyan
white = map CT.white
hiBlack = map CT.hiBlack
hiRed = map CT.hiRed
hiGreen = map CT.hiGreen
hiYellow = map CT.hiYellow
hiBlue = map CT.hiBlue
hiPurple = map CT.hiPurple
hiCyan = map CT.hiCyan
hiWhite = map CT.hiWhite
bold = map CT.bold
instance Show s => Show (Pretty s) where
show p = render 80 (metaPretty p)
metaPretty :: Show s => Pretty s -> Pretty String
metaPretty p = go (0::Int) p where
go prec p = case out p of
Lit s -> parenthesizeIf (prec > 0) $ "Lit" `hang` lit (show s)
Empty -> "Empty"
Group g -> parenthesizeIf (prec > 0) $ "Group" `hang` go 1 g
Wrap s -> parenthesizeIf (prec > 0) $ "Wrap" `hang`
surroundCommas "[" "]" (go 1 <$> s)
OrElse a b -> parenthesizeIf (prec > 0) $
"OrElse" `hang` spaced [go 1 a, go 1 b]
Append s -> surroundCommas "[" "]" (go 1 <$> s)
map :: LL.ListLike s2 Char => (s -> s2) -> Pretty s -> Pretty s2
map f p = case out p of
Append ps -> foldMap (map f) ps
Empty -> mempty
Group p -> group (map f p)
Lit s -> lit' (foldMap chDelta $ LL.toList s2) s2 where s2 = f s
OrElse p1 p2 -> orElse (map f p1) (map f p2)
Wrap p -> wrap_ (map f <$> p)
flatMap :: (s -> Pretty s2) -> Pretty s -> Pretty s2
flatMap f p = case out p of
Append ps -> foldMap (flatMap f) ps
Empty -> mempty
Group p -> group (flatMap f p)
Lit s -> f s
OrElse p1 p2 -> orElse (flatMap f p1) (flatMap f p2)
Wrap p -> wrap_ (flatMap f <$> p)

189
parser-typechecker/src/Unison/Util/PrettyPrint.hs
View File

@ -1,189 +0,0 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Unison.Util.PrettyPrint where
import Prelude hiding (lines)
import Data.List (foldl')
import qualified Data.Text as Text
import Data.Text (Text)
import qualified Data.ListLike as LL
import Data.String (IsString, fromString)
import Unison.Util.Monoid (intercalateMap)
-- A tree of `a` tokens, to be rendered to a character window by traversing the
-- leaves depth-first left-to-right, marked up with specifiers about where to
-- insert line-breaks.
data PrettyPrint a
= Empty
| Literal a
| Append (PrettyPrint a) (PrettyPrint a)
-- A subtree which can be rendered across multiple lines, and then indented.
-- Example (\b_ for Breakable space):
-- "if foo\b_then\b_" <> Nest " " then_body
| Nest a (PrettyPrint a)
-- A delimiter token, which can optionally be replaced with a newline.
| Breakable a
-- A subtree for which we can decide to render broken or unbroken, separately
-- from the enclosing tree.
-- Example: (UInt64\b_-> UInt64\b_-> UInt64)
| Group (PrettyPrint a)
-- Same as Group, except it will always be rendered broken by renderBroken. Used for let bindings.
| BrokenGroup (PrettyPrint a)
-- What mode is this call to renderBroken using?
data BreakMode
= Normal
-- Line breaking is has been forced on by a BrokenGroup. (Another Group can return it to normal.)
| Forced deriving (Eq)
containsForcedBreaks :: LL.ListLike a b => PrettyPrint a -> Bool
containsForcedBreaks = \case
Empty -> False
Literal _ -> False
Append a b -> (containsForcedBreaks a) || (containsForcedBreaks b)
Nest _prefix a -> containsForcedBreaks a
Breakable _ -> False
Group a -> containsForcedBreaks a
BrokenGroup _ -> True
unbrokenWidth :: LL.ListLike a b => PrettyPrint a -> Int
unbrokenWidth = \case
Empty -> 0
Literal a -> LL.length a
Append a b -> unbrokenWidth a + unbrokenWidth b
Nest _prefix a -> unbrokenWidth a
Breakable a -> LL.length a
Group a -> unbrokenWidth a
BrokenGroup a -> unbrokenWidth a
-- renderUnbroken produces output that fails the parser, in the following case.
-- * Let and Let Rec - these are rendered with "; " between bindings, which the parser does not accept.
renderUnbroken :: Monoid a => PrettyPrint a -> a
renderUnbroken = \case
Empty -> mempty
Literal a -> a
Append a b -> renderUnbroken a <> renderUnbroken b
Nest _prefix a -> renderUnbroken a
Breakable delim -> delim
Group a -> renderUnbroken a
BrokenGroup a -> renderUnbroken a
-- Render a `PrettyPrint a` into a rectangular window of width `width` characters.
-- `leading` characters of the first line have already been used (can be > width).
-- `start` is True if this is at the start of the outer-most term being printed.
renderBroken :: forall a b. (LL.ListLike a b, Eq b)
=> BreakMode -> Bool -> Int -> Int -> b -> PrettyPrint a -> a
renderBroken breakMode start width leading lineSeparator = \case
Empty -> LL.empty
Literal a -> a
Append a b ->
let ra = renderBroken breakMode False width leading lineSeparator a
trailing = lengthOfLastLine lineSeparator ra
in ra <> renderBroken breakMode False width trailing lineSeparator b
Nest prefix a ->
if ((leading == 0) && (not start))
then
-- Indent the subtree.
let ra = renderBroken breakMode False (width - LL.length prefix) 0 lineSeparator a
in prefix <> replaceOneWithMany lineSeparator (LL.cons lineSeparator prefix) ra
else renderBroken breakMode False width leading lineSeparator a
Breakable _delim -> LL.singleton lineSeparator
-- Going inside a Group can allow us to revert to unbroken rendering.
Group a -> render' Normal False width leading lineSeparator a
BrokenGroup a -> render' Forced False width leading lineSeparator a
where
replaceOneWithMany :: (LL.FoldableLL a b, Eq b) => b -> a -> a -> a
replaceOneWithMany target replacement list =
LL.foldr (go target replacement) LL.empty list
where go :: (LL.FoldableLL a b, Eq b) => b -> a -> b -> a -> a
go target replacement b a =
if b == target then LL.append replacement a else LL.cons b a
lengthOfLastLine :: (LL.ListLike a b, Eq b) => b -> a -> Int
lengthOfLastLine lineSeparator ra =
let ixs = LL.findIndices (==lineSeparator) ra in
(LL.length ra) - case ixs of
[] -> 0
_ -> (LL.last ixs) + 1
render :: (LL.ListLike a Char) => Int -> PrettyPrint a -> a
render width doc = render' Normal True width 0 '\n' doc
-- Render broken only if necessary.
render' :: (LL.ListLike a b, Eq b) => BreakMode -> Bool -> Int -> Int -> b -> PrettyPrint a -> a
render' breakMode start width leading lineSeparator doc =
if (breakMode /= Forced) && (not $ containsForcedBreaks doc) && (unbrokenWidth doc <= width - leading)
then renderUnbroken doc
else renderBroken breakMode start width leading lineSeparator doc
softbreak :: IsString a => PrettyPrint a
softbreak = Breakable " "
semicolon :: IsString a => PrettyPrint a
semicolon = Breakable "; "
comma :: IsString a => PrettyPrint a
comma = Breakable ", "
softbreaks :: (Foldable f, IsString a) => f (PrettyPrint a) -> PrettyPrint a
softbreaks = intercalateMap softbreak id
semicolons :: (Foldable f, IsString a) => f (PrettyPrint a) -> PrettyPrint a
semicolons = intercalateMap semicolon id
commas :: (Foldable f, IsString a) => f (PrettyPrint a) -> PrettyPrint a
commas = intercalateMap comma id
lines :: (Foldable f, IsString a) => f (PrettyPrint a) -> PrettyPrint a
lines ps = brokenGroup $ softbreaks ps
linesSpaced :: (Foldable f, IsString a) => f (PrettyPrint a) -> PrettyPrint a
linesSpaced ps = brokenGroup $ intercalateMap (softbreak <> softbreak) id ps
group :: PrettyPrint a -> PrettyPrint a
group p = Group p
brokenGroup :: PrettyPrint a -> PrettyPrint a
brokenGroup p = BrokenGroup p
breakable :: IsString a => a -> PrettyPrint a
breakable = Breakable
padTo :: (IsString a, LL.ListLike a b) => Int -> PrettyPrint a -> PrettyPrint a
padTo n p =
let rem = n - unbrokenWidth p
in if rem > 0 then p <> (fromString (replicate rem ' '))
else p
column2 :: (IsString a, LL.ListLike a b) => [(PrettyPrint a, PrettyPrint a)] -> PrettyPrint a
column2 rows = lines (group <$> alignedRows) where
maxWidth = foldl' max 0 (unbrokenWidth . fst <$> rows) + 1
alignedRows = [ padTo maxWidth col0 <> col1 | (col0, col1) <- rows ]
text :: IsString a => Text -> PrettyPrint a
text t = fromString (Text.unpack t)
instance Semigroup (PrettyPrint a) where
(<>) = mappend
instance Monoid (PrettyPrint a) where
mempty = Empty
mappend a b = Append a b
instance IsString a => IsString (PrettyPrint a) where
fromString = Literal . fromString
instance Show a => Show (PrettyPrint a) where
show = \case
Empty -> "Empty"
Literal a -> "Literal " ++ (show a)
Append a b -> "Append (" ++ (show a) ++ ") (" ++ (show b) ++ ")"
Nest prefix a -> "Nest (prefix = " ++ (show prefix) ++ ") (" ++ (show a) ++ ")"
Breakable a -> "Breakable (" ++ (show a) ++ ")"
Group a -> "Group (" ++ (show a) ++ ")"
BrokenGroup a -> "BrokenGroup (" ++ (show a) ++ ")"

70
parser-typechecker/tests/Unison/Test/TermPrinter.hs
View File

@ -12,7 +12,7 @@ import qualified Unison.Type as Type
import Unison.Symbol (Symbol, symbol)
import Unison.Builtin
import Unison.Parser (Ann(..))
import qualified Unison.Util.PrettyPrint as PP
import qualified Unison.Util.Pretty as PP
import qualified Unison.PrettyPrintEnv as PPE
get_names :: PPE.PrettyPrintEnv
@ -33,8 +33,8 @@ tc_diff_rtt rtt s expected width =
actual_reparsed = Unison.Builtin.tm actual
in scope s $ tests [(
if actual == expected then ok
else do note $ "expected: " ++ show expected
note $ "actual : " ++ show actual
else do note $ "expected:\n" ++ expected
note $ "actual:\n" ++ actual
note $ "show(input) : " ++ show input_term
note $ "prettyprint : " ++ show prettied
crash "actual != expected"
@ -110,14 +110,9 @@ test = scope "termprinter" . tests $
, tc "Optional.None"
, tc "handle foo in bar"
, tc "Pair 1 1"
-- let bindings have no unbroken form accepted by the parser.
-- We could choose to render them broken anyway, but that would complicate
-- PrettyPrint.renderUnbroken a great deal.
, tc_diff_rtt False "let\n\
\ x = 1\n\
\ x\n"
"let; x = 1; x"
0
, tc "let\n\
\ x = 1\n\
\ x"
, tc_breaks 50 "let\n\
\ x = 1\n\
\ x"
@ -141,8 +136,8 @@ test = scope "termprinter" . tests $
, tc "case x of 3.14159 -> foo"
, tc_diff_rtt False "case x of\n\
\ true -> foo\n\
\ false -> bar"
"case x of true -> foo; false -> bar" 0
\ false -> bar"
"case x of\n true -> foo\n false -> bar" 0
, tc_breaks 50 "case x of\n\
\ true -> foo\n\
\ false -> bar"
@ -167,15 +162,17 @@ test = scope "termprinter" . tests $
"let\n\
\ x : Int\n\
\ x = 1\n\
\ (x : Int)" 50
\ (x : Int)" 50
, tc "case x of 12 -> (y : Int)"
, tc "if a then (b : Int) else (c : Int)"
, tc "case x of 12 -> if a then b else c"
, tc "case x of 12 -> x -> f x"
, tc_diff "case x of (12) -> x" $ "case x of 12 -> x"
, tc_diff "case (x) of 12 -> x" $ "case x of 12 -> x"
, tc_breaks 50 "case x of\n\
\ 12 -> x"
, tc "case x of 12 -> x"
, tc_diff_rtt True "case x of\n\
\ 12 -> x"
"case x of 12 -> x" 50
, tc_breaks 15 "case x of\n\
\ 12 -> x\n\
\ 13 -> y\n\
@ -212,11 +209,10 @@ test = scope "termprinter" . tests $
, tc "0.0"
, tc "-0.0"
, pending $ tc_diff "+0.0" $ "0.0" -- TODO parser throws "Prelude.read: no parse" - should it? Note +0 works for UInt.
, tc_breaks_diff 21 "case x of 12 -> if a then b else c" $
, tc_breaks_diff 21 "case x of 12 -> if a then b else c" $
"case x of\n\
\ 12 ->\n\
\ if a\n\
\ then b\n\
\ if a then b\n\
\ else c"
, tc_diff_rtt True "if foo\n\
\then\n\
@ -227,23 +223,21 @@ test = scope "termprinter" . tests $
\ namespace baz where\n\
\ f : Int -> Int\n\
\ f x = x\n\
\ 13"
"if foo\n\
\then\n\
\ and true true\n\
\ 13"
"if foo then\n\
\ and true true\n\
\ 12\n\
\else\n\
\ baz.f : Int -> Int\n\
\ baz.f x = x\n\
\ 13" 50
, tc_breaks 50 "if foo\n\
\then\n\
\ 13" 50
, tc_breaks 50 "if foo then\n\
\ and true true\n\
\ 12\n\
\else\n\
\ baz.f : Int -> Int\n\
\ baz.f x = x\n\
\ 13"
\ 13"
, pending $ tc_breaks 90 "handle foo in\n\
\ a = 5\n\
\ b =\n\
@ -334,31 +328,35 @@ test = scope "termprinter" . tests $
\ Optional.None -> 0\n\
\ Optional.Some hd1 -> 0\n\
\ go [] a b"
, tc_breaks 50 "case x of\n\
, tc_breaks 30 "case x of\n\
\ (Optional.None, _) -> foo"
, pending $ tc_breaks 50 "if true\n\
\then\n\
\ case x of\n\
\ case x of\n\
\ 12 -> x\n\
\else\n\
\ x" -- TODO parser bug? 'unexpected else', parens around case doens't help, cf next test
, pending $ tc_breaks 50 "if true\n\
\then x\n\
\else\n\
\ (case x of\n\
\ (case x of\n\
\ 12 -> x)" -- TODO parser bug, 'unexpected )'
, tc_diff_rtt False "if true\n\
\then x\n\
\else case x of\n\
\else case x of\n\
\ 12 -> x"
"if true\n\
\then x\n\
"if true then x\n\
\else\n\
\ (case x of\n\
\ 12 -> x)" 50 -- TODO fix surplus parens around case.
\ (case x of\n\
\ 12 -> x)" 20 -- TODO fix surplus parens around case.
-- Are they only surplus due to layout cues?
-- And no round trip, due to issue in test directly above.
, pending $ tc_breaks 80 "x -> (if c then t else f)" -- TODO 'unexpected )', surplus parens
, tc_diff_rtt False "if true\n\
\then x\n\
\else case x of\n\
\ 12 -> x"
"if true then x else (case x of 12 -> x)" 50
, pending $ tc_breaks 80 "x -> (if c then t else f)" -- TODO 'unexpected )', surplus parens
, tc_breaks 80 "'let\n\
\ foo = bar\n\
\ baz foo"

11
parser-typechecker/tests/Unison/Test/TypePrinter.hs
View File

@ -8,7 +8,7 @@ import Unison.TypePrinter
import Unison.Symbol (Symbol)
import Unison.Builtin
import Unison.Parser (Ann(..))
import qualified Unison.Util.PrettyPrint as PP
import qualified Unison.Util.Pretty as PP
import qualified Unison.PrettyPrintEnv as PPE
@ -30,6 +30,8 @@ tc_diff_rtt rtt s expected width =
if actual == expected then ok
else do note $ "expected: " ++ show expected
note $ "actual : " ++ show actual
note $ "expectedS:\n" ++ expected
note $ "actualS:\n" ++ actual
note $ "show(input) : " ++ show input_type
note $ "prettyprint : " ++ show prettied
crash "actual != expected"
@ -157,12 +159,11 @@ test = scope "typeprinter" . tests $
, tc_diff_rtt False "Pair (forall a. (a -> a -> a)) b" -- as above, and TODO not nesting under Pair
"Pair\n\
\(∀ a. a -> a -> a)\n\
\b" 24
\ (∀ a. a -> a -> a) b" 24
, tc_diff_rtt False "Pair (forall a. (a -> a -> a)) b" -- as above, and TODO not breaking under forall
"Pair\n\
\(∀ a. a -> a -> a)\n\
\b" 14
\ (∀ a. a -> a -> a)\n\
\ b" 21
]

13
parser-typechecker/unison-parser-typechecker.cabal
View File

@ -68,7 +68,6 @@ library
Unison.Paths
Unison.Pattern
Unison.PatternP
Unison.PrettyPrint
Unison.PrettyPrintEnv
Unison.PrintError
Unison.Reference
@ -98,7 +97,7 @@ library
Unison.Util.Logger
Unison.Util.Menu
Unison.Util.Monoid
Unison.Util.PrettyPrint
Unison.Util.Pretty
Unison.Util.Range
Unison.Util.Relation
Unison.Util.TQueue
@ -181,6 +180,16 @@ executable unison
safe,
unison-parser-typechecker
executable prettyprintdemo
main-is: Main.hs
hs-source-dirs: prettyprintdemo
ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures
build-depends:
base,
safe,
text,
unison-parser-typechecker
executable unisonold
main-is: Main.hs
hs-source-dirs: unisonold