Merge remote-tracking branch 'origin/topic/termprinter4' into topic/codebase-editor

parser-typechecker/src/Unison/Pattern.hs

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

parser-typechecker/src/Unison/PatternP.hs

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

parser-typechecker/src/Unison/Term.hs

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

parser-typechecker/src/Unison/TermPrinter.hs

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

parser-typechecker/src/Unison/Type.hs

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

parser-typechecker/tests/Unison/Test/TermPrinter.hs

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