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

got everything recompiling with updated prettyprinter

Browse Source 
Lots of prettyprint tests failing
This commit is contained in:
Paul Chiusano 2018-12-09 22:12:01 -05:00
parent beda42ab11
commit d170122fff
9 changed files with 188 additions and 431 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -39,8 +39,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)
@ -137,7 +137,7 @@ initialize c = do
goData = go Right
prettyBinding :: (Var.Var v, Monad m)
=> Codebase m v a -> Name -> Referent -> Branch -> m (Maybe (PrettyPrint String))
=> Codebase m v a -> Name -> Referent -> Branch -> m (Maybe (Pretty String))
prettyBinding _ _ (Names.Ref (Reference.Builtin _)) _ = pure Nothing
prettyBinding cb name r0@(Names.Ref r1@(Reference.DerivedId r)) b = go =<< getTerm cb r where
go Nothing = pure Nothing
@ -156,14 +156,14 @@ prettyBinding cb name r0@(Names.Ref r1@(Reference.DerivedId r)) b = go =<< getTe
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
-- Search for and display bindings matching the given query
prettyBindingsQ :: (Var.Var v, Monad m)
=> Codebase m v a -> String -> Branch -> m (PrettyPrint String)
=> Codebase m v a -> String -> Branch -> m (Pretty String)
prettyBindingsQ cb query b = let
possible = Branch.allTermNames (Branch.head b)
matches = sortedApproximateMatches query (Text.unpack <$> toList possible)

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 )

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

@ -7,7 +7,6 @@ module Unison.TermPrinter where
import Data.List
import qualified Data.Text as Text
import Data.Foldable ( fold
, toList
)
import Data.Maybe ( fromMaybe
, isJust
@ -26,8 +25,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 +37,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 +65,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 +117,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 (Names.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 +145,94 @@ 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) $ PP.spaced [
"if" `PP.hang` pretty n (ac 2 Block) cond,
"then" `PP.hang` pretty n (ac 2 Block) t,
"else" `PP.hang` 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)
$ PP.group
$ PP.spaced ["case", pretty n (ac 2 Normal) scrutinee, "of"]
`PP.hang` 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
_ -> 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)
<> PP.softbreak <> printGuard guard
<> "->"
printGuard (Just g) = 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 +249,17 @@ 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
:: Var v => [(AnnotatedTerm v a, AnnotatedTerm v a)] -> Pretty String
binaryApps xs = foldr (flip (<>)) mempty (map r xs)
where
r (a, f) =
pretty n (ac 3 Normal) a
<> b " "
<> pretty n (AmbientContext 10 Normal Infix) f
<> b " "
r (a, f) = PP.spaced [
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,61 +271,47 @@ 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 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
@ -384,7 +325,7 @@ prettyPattern n p vs patt = case patt of
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 +335,28 @@ 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 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 +367,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

69
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 "]"
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.parenthesizeIf (p >= 10) $ PP.spaced ["Pair", pretty n 10 x, "()" ]
Tuple' xs -> PP.parenthesizeCommas $ map (pretty n 0) xs
Apps' f xs -> parenNoGroup (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
]

30
parser-typechecker/src/Unison/Util/Pretty.hs
View File

@ -29,14 +29,18 @@ module Unison.Util.Pretty (
numbered,
orElse,
parenthesize,
parenthesizeCommas,
parenthesizeIf,
preferredWidth,
render,
renderUnbroken,
rightPad,
sep,
sepSpaced,
softbreak,
spaceIfBreak,
spaced,
spacedMap,
text,
toANSI,
toPlain,
@ -111,6 +115,9 @@ 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 avail p =
if preferredWidth p <= avail || minWidth p > avail then flow p
@ -144,23 +151,34 @@ render avail p =
newline :: IsString s => Pretty s
newline = lit' (chDelta '\n') (fromString "\n")
spaceIfBreak :: IsString s => Pretty s
spaceIfBreak = "" `orElse` " "
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 fs = parenthesize $
spaceIfBreak <>
intercalateMap ("," <> softbreak <> spaceIfBreak <> spaceIfBreak) id fs
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
sep between = intercalateMap between id
parenthesize :: IsString s => Pretty s -> Pretty s
parenthesize p = "(" <> p <> ")"
parenthesize p = group $ "(" <> p <> ")"
parenthesizeIf :: IsString s => Bool -> Pretty s -> Pretty s
parenthesizeIf False s = s
@ -201,10 +219,12 @@ 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' by sp p = (sp <> p) `orElse` ("\n" <> indent by (group p))
hang' from by p =
(from <> " " <> p) `orElse`
(from <> "\n" <> indent by (group p))
hang :: (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s
hang p = hang' " " " " p
hang :: (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s -> Pretty s
hang from p = hang' from " " p
indent :: (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s -> Pretty s
indent by p = by <> indentAfterNewline by p

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

@ -1,190 +0,0 @@
{-# LANGUAGE DeriveFunctor #-}
{-# 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) ++ ")"

30
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
@ -141,8 +141,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 true -> foo; false -> bar" 0
, tc_breaks 50 "case x of\n\
\ true -> foo\n\
\ false -> bar"
@ -167,7 +167,7 @@ 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"
@ -212,7 +212,7 @@ 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\
@ -227,15 +227,15 @@ test = scope "termprinter" . tests $
\ namespace baz where\n\
\ f : Int -> Int\n\
\ f x = x\n\
\ 13"
\ 13"
"if foo\n\
\then\n\
\ and true true\n\
\ and true true\n\
\ 12\n\
\else\n\
\ baz.f : Int -> Int\n\
\ baz.f x = x\n\
\ 13" 50
\ 13" 50
, tc_breaks 50 "if foo\n\
\then\n\
\ and true true\n\
@ -243,7 +243,7 @@ test = scope "termprinter" . tests $
\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\
@ -338,27 +338,27 @@ test = scope "termprinter" . tests $
\ (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\
\else\n\
\ (case x of\n\
\ 12 -> x)" 50 -- TODO fix surplus parens around case.
\ (case x of\n\
\ 12 -> x)" 50 -- 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
, 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"

2
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

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

@ -68,7 +68,7 @@ library
Unison.Paths
Unison.Pattern
Unison.PatternP
Unison.PrettyPrint
Unison.Pretty
Unison.PrettyPrintEnv
Unison.PrintError
Unison.Reference
@ -97,7 +97,6 @@ library
Unison.Util.Logger
Unison.Util.Menu
Unison.Util.Monoid
Unison.Util.PrettyPrint
Unison.Util.Pretty
Unison.Util.Range
Unison.Util.Relation