mirror of
https://github.com/unisonweb/unison.git
synced 2024-10-05 06:07:21 +03:00
Merge remote-tracking branch 'origin/topic/termprinter4' into topic/codebase-editor
This commit is contained in:
commit
a5e19d4d46
@ -1,4 +1,4 @@
|
||||
{-# Language DeriveFunctor, DeriveTraversable, DeriveGeneric, PatternSynonyms #-}
|
||||
{-# Language DeriveFunctor, DeriveTraversable, DeriveGeneric, PatternSynonyms, ViewPatterns, OverloadedStrings #-}
|
||||
|
||||
module Unison.Pattern where
|
||||
|
||||
@ -8,6 +8,7 @@ import Data.Word (Word64)
|
||||
import Data.Foldable as Foldable
|
||||
import GHC.Generics
|
||||
import Unison.Reference (Reference)
|
||||
import qualified Unison.Reference as Reference
|
||||
import qualified Unison.Hashable as H
|
||||
|
||||
type Pattern = PatternP ()
|
||||
@ -76,6 +77,13 @@ pattern Constructor r cid ps = ConstructorP () r cid ps
|
||||
pattern As p = AsP () p
|
||||
pattern EffectPure p = EffectPureP () p
|
||||
pattern EffectBind r cid ps k = EffectBindP () r cid ps k
|
||||
pattern Tuple ps <- (unTuple -> Just ps)
|
||||
|
||||
unTuple :: PatternP loc -> Maybe [PatternP loc]
|
||||
unTuple p = case p of
|
||||
ConstructorP _ (Reference.Builtin "Pair") 0 [fst, snd] -> (fst : ) <$> unTuple snd
|
||||
ConstructorP _ (Reference.Builtin "()") 0 [] -> Just []
|
||||
_ -> Nothing
|
||||
|
||||
instance H.Hashable (PatternP p) where
|
||||
tokens (UnboundP _) = [H.Tag 0]
|
||||
|
@ -1,4 +1,4 @@
|
||||
{-# Language PatternSynonyms #-}
|
||||
{-# Language PatternSynonyms, ViewPatterns #-}
|
||||
|
||||
module Unison.PatternP where
|
||||
|
||||
@ -16,6 +16,7 @@ pattern Constructor loc r cid ps = P.ConstructorP loc r cid ps
|
||||
pattern As loc p = P.AsP loc p
|
||||
pattern EffectPure loc p = P.EffectPureP loc p
|
||||
pattern EffectBind loc r c args k = P.EffectBindP loc r c args k
|
||||
pattern Tuple ps <- (P.unTuple -> Just ps)
|
||||
|
||||
loc :: P.PatternP loc -> loc
|
||||
loc = P.loc
|
||||
|
@ -224,6 +224,7 @@ pattern BinaryApps' apps lastArg <- (unBinaryApps -> Just (apps, lastArg))
|
||||
pattern BinaryAppsPred' apps lastArg <- (unBinaryAppsPred -> Just (apps, lastArg))
|
||||
pattern Ann' x t <- (ABT.out -> ABT.Tm (Ann x t))
|
||||
pattern Vector' xs <- (ABT.out -> ABT.Tm (Vector xs))
|
||||
pattern Tuple' xs <- (unTuple' -> Just xs)
|
||||
pattern Lam' subst <- ABT.Tm' (Lam (ABT.Abs' subst))
|
||||
pattern LamNamed' v body <- (ABT.out -> ABT.Tm (Lam (ABT.Term _ _ (ABT.Abs v body))))
|
||||
pattern LamsNamed' vs body <- (unLams' -> Just (vs, body))
|
||||
@ -545,6 +546,12 @@ unLamsPred' ((LamNamed' v body), pred) | pred v = case unLamsPred' (body, pred)
|
||||
Just (vs, body) -> Just (v:vs, body)
|
||||
unLamsPred' _ = Nothing
|
||||
|
||||
unTuple' :: AnnotatedTerm2 vt at ap v a -> Maybe [AnnotatedTerm2 vt at ap v a]
|
||||
unTuple' t = case t of
|
||||
Apps' (Constructor' (Reference.Builtin "Pair") 0) [fst, snd] -> (fst :) <$> unTuple' snd
|
||||
Constructor' (Reference.Builtin "()") 0 -> Just []
|
||||
_ -> Nothing
|
||||
|
||||
unReqOrCtor :: AnnotatedTerm2 vt at ap v a -> Maybe (Reference, Int)
|
||||
unReqOrCtor (Constructor' r cid) = Just (r, cid)
|
||||
unReqOrCtor (Request' r cid) = Just (r, cid)
|
||||
@ -774,7 +781,7 @@ instance (Var v, Show a) => Show (F v a0 p a) where
|
||||
B.Blank -> s"_"
|
||||
B.Recorded (B.Placeholder _ r) -> s("_" ++ r)
|
||||
B.Recorded (B.Resolve _ r) -> s r
|
||||
go _ (Ref r) = showsPrec 0 r
|
||||
go _ (Ref r) = s"Ref(" <> showsPrec 0 r <> s")"
|
||||
go _ (Let _ b body) = showParen True (s"let " <> showsPrec 0 b <> s" in " <> showsPrec 0 body)
|
||||
go _ (LetRec _ bs body) = showParen True (s"let rec" <> showsPrec 0 bs <> s" in " <> showsPrec 0 body)
|
||||
go _ (Handle b body) = showParen True (s"handle " <> showsPrec 0 b <> s " in " <> showsPrec 0 body)
|
||||
|
@ -26,7 +26,7 @@ import Unison.Util.PrettyPrint (PrettyPrint(..))
|
||||
import Unison.PrettyPrintEnv (PrettyPrintEnv)
|
||||
import qualified Unison.PrettyPrintEnv as PrettyPrintEnv
|
||||
|
||||
--TODO let suppression, missing features, delay blocks
|
||||
--TODO let suppression, delay blocks
|
||||
--TODO precedence comment and double check in type printer
|
||||
--TODO ? askInfo suffix; > watches
|
||||
--TODO try it out on 'real' code (as an in-place edit pass on unison-src maybe)
|
||||
@ -127,6 +127,8 @@ pretty n p term = specialCases term $ \case
|
||||
t -> l"error: " <> l (show t)
|
||||
where specialCases term go =
|
||||
case (term, binaryOpsPred) of
|
||||
(Tuple' [x], _) -> parenNest (p >= 10) $ l"Pair" <> b" " <> pretty n 10 x <> b" " <> l"()"
|
||||
(Tuple' xs, _) -> parenNest True $ commaList xs
|
||||
BinaryAppsPred' apps lastArg -> parenNest (p >= 3) $ binaryApps apps <> pretty n 10 lastArg
|
||||
_ -> case (term, nonForcePred) of
|
||||
AppsPred' f args -> parenNest (p >= 10) $
|
||||
@ -177,10 +179,6 @@ pretty n p term = specialCases term $ \case
|
||||
nonUnitArgPred :: Var v => v -> Bool
|
||||
nonUnitArgPred v = (Var.name v) /= "()"
|
||||
|
||||
-- When we use imports in rendering, this will need revisiting, so that we can render
|
||||
-- say 'foo.+ x y' as 'import foo ... x + y'. symbolyId0 doesn't match 'foo.+', only '+'.
|
||||
isSymbolic name = case symbolyId0 $ Text.unpack $ name of Right _ -> True; _ -> False
|
||||
|
||||
-- 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.
|
||||
@ -204,9 +202,14 @@ prettyPattern n p vs patt = case patt of
|
||||
Pattern.Int _ i -> ((if i >= 0 then l"+" else Empty) <> (l $ show i), vs)
|
||||
Pattern.Nat _ u -> (l $ show u, vs)
|
||||
Pattern.Float _ f -> (l $ show f, vs)
|
||||
Pattern.Constructor _ Type.UnitRef 0 [] -> (l"()", vs)
|
||||
Pattern.Constructor _ ref i pats -> let
|
||||
Pattern.Tuple [pp] -> let
|
||||
(printed, tail_vs) = prettyPattern n 10 vs pp
|
||||
in (parenNest (p >= 10) $ l"Pair" <> b" " <> printed <> b" " <> l"()", tail_vs)
|
||||
Pattern.Tuple pats -> let
|
||||
(pats_printed, tail_vs) = patterns vs pats
|
||||
in (parenNest True $ intercalateMap (l"," <> b" ") id pats_printed, tail_vs)
|
||||
Pattern.Constructor _ ref i pats -> let
|
||||
(pats_printed, tail_vs) = patternsSep (b" ") vs pats
|
||||
in (parenNest (p >= 10) $ l (Text.unpack (PrettyPrintEnv.patternName n ref i)) <> pats_printed, tail_vs)
|
||||
Pattern.As _ pat -> let (v : tail_vs) = vs
|
||||
(printed, eventual_tail) = prettyPattern n 11 tail_vs pat
|
||||
@ -214,7 +217,7 @@ prettyPattern n p vs patt = case patt of
|
||||
Pattern.EffectPure _ pat -> let (printed, eventual_tail) = prettyPattern n (-1) vs pat
|
||||
in (l"{" <> b" " <> printed <> b" " <> l"}", eventual_tail)
|
||||
Pattern.EffectBind _ ref i pats k_pat -> let
|
||||
(pats_printed, tail_vs) = patterns vs pats
|
||||
(pats_printed, tail_vs) = patternsSep (b" ") 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" " <>
|
||||
@ -223,8 +226,10 @@ prettyPattern n p vs patt = case patt of
|
||||
where l = Literal
|
||||
patterns vs (pat : pats) = let (printed, tail_vs) = prettyPattern n 10 vs pat
|
||||
(rest_printed, eventual_tail) = patterns tail_vs pats
|
||||
in (b" " <> printed <> rest_printed, eventual_tail)
|
||||
patterns vs [] = (Empty, vs)
|
||||
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)
|
||||
|
||||
{- Render a binding, producing output of the form
|
||||
|
||||
@ -232,17 +237,41 @@ foo : t -> u
|
||||
foo a = ...
|
||||
|
||||
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:
|
||||
|
||||
(+) : t -> t -> t
|
||||
a + b = ...
|
||||
|
||||
-}
|
||||
prettyBinding :: Var v => PrettyPrintEnv -> v -> AnnotatedTerm v a -> PrettyPrint String
|
||||
prettyBinding n v = \case
|
||||
Ann' tm tp -> PP.BrokenGroup $
|
||||
PP.Group (l (varName v) <> l" : " <> TypePrinter.pretty n (-1) tp) <> b";" <>
|
||||
PP.Group (prettyBinding n v tm)
|
||||
LamsNamedOpt' vs body ->
|
||||
PP.Group (l (varName v) <> args <> b" " <> l"=") <> b" " <>
|
||||
(PP.Nest " " $ PP.Group (pretty n (-1) body))
|
||||
where args = foldMap (\x -> b" " <> l (Text.unpack (Var.name x))) vs
|
||||
t -> l"error: " <> l (show t)
|
||||
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 (defnLhs v vs <> b" " <> l"=") <> b" " <>
|
||||
(PP.Nest " " $ PP.Group (pretty n (-1) body))
|
||||
where
|
||||
t -> l"error: " <> l (show t)
|
||||
where
|
||||
renderName v = (if symbolic
|
||||
then paren True
|
||||
else id) $ l (varName v)
|
||||
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))
|
||||
_ -> l"error"
|
||||
else renderName v <> (args vs)
|
||||
args vs = foldMap (\x -> b" " <> l (Text.unpack (Var.name x))) vs
|
||||
isBinary = \case
|
||||
Ann' tm _ -> isBinary tm
|
||||
LamsNamedOpt' vs _ -> length vs == 2
|
||||
_ -> False -- unhittable
|
||||
symbolic = isSymbolic (Var.name v)
|
||||
|
||||
prettyBinding' :: Var v => Int -> PrettyPrintEnv -> v -> AnnotatedTerm v a -> String
|
||||
prettyBinding' width n v t = PP.render width $ prettyBinding n v t
|
||||
@ -262,3 +291,8 @@ l = Literal
|
||||
|
||||
b :: String -> PrettyPrint 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'. symbolyId0 doesn't match 'foo.+', only '+'.
|
||||
isSymbolic :: Text.Text -> Bool
|
||||
isSymbolic name = case symbolyId0 $ Text.unpack $ name of Right _ -> True; _ -> False
|
||||
|
@ -159,15 +159,10 @@ unForalls t = go t []
|
||||
go body vs = Just(reverse vs, body)
|
||||
|
||||
unTuple :: Var v => AnnotatedType v a -> Maybe [AnnotatedType v a]
|
||||
unTuple t = (case t of
|
||||
(Apps' (Ref' PairRef) [_,_]) -> id
|
||||
(Ref' UnitRef) -> id
|
||||
_ -> const Nothing) $
|
||||
go t
|
||||
where go :: Var v => AnnotatedType v a -> Maybe [AnnotatedType v a]
|
||||
go (Apps' (Ref' PairRef) (t:t':[])) = (t:) <$> go t'
|
||||
go (Ref' UnitRef) = Just []
|
||||
go _ = Nothing
|
||||
unTuple t = case t of
|
||||
Apps' (Ref' PairRef) [fst, snd] -> (fst :) <$> unTuple snd
|
||||
Ref' UnitRef -> Just []
|
||||
_ -> Nothing
|
||||
|
||||
unEffect0 :: Ord v => AnnotatedType v a -> ([AnnotatedType v a], AnnotatedType v a)
|
||||
unEffect0 (Effect1' e a) = (flattenEffects e, a)
|
||||
|
@ -151,8 +151,8 @@ test = scope "termprinter" . tests $
|
||||
, tc "case x of 3.14159 -> foo"
|
||||
, tc "case x of true -> foo"
|
||||
, tc "case x of false -> foo"
|
||||
, tc_diff "case x of y@(()) -> y" $ "case x of y@() -> y" -- TODO lose the brackets for `As (unary constructor)`
|
||||
, tc_diff "case x of a@(b@(c@(()))) -> c" $ "case x of a@(b@(c@())) -> c"
|
||||
, tc "case x of y@() -> y"
|
||||
, tc "case x of a@(b@(c@())) -> c"
|
||||
, tc "case e of { a } -> z"
|
||||
--, tc "case e of { () -> k } -> z" -- TODO doesn't parse since 'many leaf' expected before the "-> k"
|
||||
-- need an actual effect constructor to test this with
|
||||
@ -273,22 +273,36 @@ test = scope "termprinter" . tests $
|
||||
, tc "'(!foo)"
|
||||
, tc "x -> '(y -> 'z)"
|
||||
, tc "'(x -> '(y -> z))"
|
||||
, pending $ tc "(\"a\", 2)"
|
||||
, pending $ tc "(\"a\", 2, 2.0)"
|
||||
, pending $ tc_diff "(2)" $ "2"
|
||||
, pending $ tc "Pair 2 ()" -- unary tuple
|
||||
, pending $ tc "case x of a + b -> foo"
|
||||
, pending $ tc "case x of (a, b) -> a"
|
||||
, pending $ tc "case x of [a, b] -> a"
|
||||
, pending $ tc "case x of [a] -> a"
|
||||
, pending $ tc "case x of [] -> a"
|
||||
, tc "(\"a\", 2)"
|
||||
, tc "(\"a\", 2, 2.0)"
|
||||
, tc_diff "(2)" $ "2"
|
||||
, pending $ tc_diff "Pair \"2\" (Pair 2 ())" $ "(\"2\", 2)" -- TODO parser produced
|
||||
-- Pair "2" (Pair 2 ()#0)
|
||||
-- instead of
|
||||
-- Pair#0 "2" (Pair#0 2 ()#0)
|
||||
-- Maybe because in this context the
|
||||
-- parser can't distinguish between a constructor
|
||||
-- called 'Pair' and a function called 'Pair'.
|
||||
, pending $ tc "Pair 2 ()" -- unary tuple; fails for same reason as above
|
||||
, tc "case x of (a, b) -> a"
|
||||
, tc "case x of () -> foo"
|
||||
, pending $ tc "case x of [a, b] -> a" -- issue #266
|
||||
, pending $ tc "case x of [a] -> a" -- ditto
|
||||
, pending $ tc "case x of [] -> a" -- ditto
|
||||
, tc_binding 50 "foo" (Just "Int") "3" "foo : Int\n\
|
||||
\foo = 3"
|
||||
, tc_binding 50 "foo" Nothing "3" "foo = 3"
|
||||
, tc_binding 50 "foo" (Just "Int -> Int") "n -> 3" "foo : Int -> Int\n\
|
||||
\foo n = 3"
|
||||
\foo n = 3"
|
||||
, tc_binding 50 "foo" Nothing "n -> 3" "foo n = 3"
|
||||
, tc_binding 50 "foo" Nothing "n m -> 3" "foo n m = 3"
|
||||
, tc_binding 9 "foo" Nothing "n m -> 3" "foo n m =\n\
|
||||
\ 3"
|
||||
, tc_binding 50 "+" (Just "Int -> Int -> Int") "a b -> foo a b" "(+) : Int -> Int -> Int\n\
|
||||
\a + b = foo a b"
|
||||
, tc_binding 50 "+" (Just "Int -> Int -> Int -> Int") "a b c -> foo a b c" "(+) : Int -> Int -> Int -> Int\n\
|
||||
\(+) a b c = foo a b c"
|
||||
, tc_binding 50 "+" Nothing "a b -> foo a b" "a + b = foo a b"
|
||||
, tc_binding 50 "+" Nothing "a b c -> foo a b c" "(+) a b c = foo a b c"
|
||||
|
||||
]
|
||||
|
Loading…
Reference in New Issue
Block a user