render types using intercalateMap

parser-typechecker/src/Unison/Kind.hs

@@ -6,10 +6,9 @@ import GHC.Generics
 import Unison.Hashable (Hashable)
 import qualified Unison.Hashable as Hashable
 
-data Kind = Star | Constraint | Arrow Kind Kind deriving (Eq,Ord,Read,Show,Generic)
+data Kind = Star | Arrow Kind Kind deriving (Eq,Ord,Read,Show,Generic)
 
 instance Hashable Kind where
   tokens k = case k of
     Star -> [Hashable.Tag 0]
-    Constraint -> [Hashable.Tag 1]
-    Arrow k1 k2 -> (Hashable.Tag 2 : Hashable.tokens k1) ++ Hashable.tokens k2
+    Arrow k1 k2 -> (Hashable.Tag 1 : Hashable.tokens k1) ++ Hashable.tokens k2

parser-typechecker/src/Unison/PrintError.hs

@@ -9,7 +9,7 @@ import           Data.Foldable
 import qualified Data.List.NonEmpty         as Nel
 import           Data.Map                   (Map)
 import qualified Data.Map                   as Map
-import           Data.Maybe                 (catMaybes, listToMaybe)
+import           Data.Maybe                 (catMaybes, listToMaybe, fromMaybe)
 import           Data.Sequence              (Seq (..))
 import qualified Data.Sequence              as Seq
 import qualified Data.Set                   as Set
@@ -17,6 +17,8 @@ import           Data.String                (fromString)
 import qualified Data.Text                  as Text
 import qualified Text.Megaparsec            as P
 import qualified Unison.ABT                 as ABT
+import qualified Unison.Kind                as Kind
+import           Unison.Kind                (Kind)
 import qualified Unison.Lexer               as L
 import           Unison.Parser              (Ann (..), Annotated, ann,
                                              showLineCol)
@@ -27,8 +29,9 @@ import           Unison.Type                (AnnotatedType)
 import qualified Unison.Type                as Type
 import qualified Unison.Typechecker.Context as C
 import qualified Unison.Util.AnnotatedText  as AT
-import           Unison.Util.ColorText      ()
+import           Unison.Util.ColorText      (StyledText)
 import qualified Unison.Util.ColorText      as Color
+import           Unison.Util.Monoid         (intercalateMap)
 import           Unison.Util.Range          (Range (..))
 import           Unison.Var                 (Var, qualifiedName)
 
@@ -43,7 +46,7 @@ data TypeError v loc
              , mismatchSite :: loc }
   | Other (C.Note v loc)
 
-renderTypeError :: (Var v, Annotated a)
+renderTypeError :: (Var v, Annotated a, Eq a)
                 => Env
                 -> TypeError v a
                 -> String
@@ -64,23 +67,63 @@ renderTypeError env e src = AT.AnnotatedDocument . Seq.fromList $
   , AT.Text $ styleInOverallType env (overallType2 e) (leaf2 e) Color.Color2
   ]
 
-renderType :: Var v => Env -> C.Type v loc -> String
-renderType _e t = show t
+renderType :: Var v
+           => Env
+           -> (loc -> StyledText -> StyledText)
+           -> C.Type v loc
+           -> StyledText
+renderType env f t = renderType0 env f (0 :: Int) t where
+  paren ambient threshold s =
+    if ambient >= threshold then "(" <> s <> ")" else mempty
+  renderType0 env f p t = f (ABT.annotation t) $ case t of
+    Type.Ref' r -> showRef' env r
+    Type.Arrows' ts -> paren p 2 $ arrows (go 2) ts
+    Type.Ann' t k -> paren p 0 $ (go 1) t <> " : " <> renderKind k
+    Type.Apps' f' args -> paren p 3 $ spaces (go 3) (f':args)
+    Type.Effect' es t -> paren p 3 $
+      "{" <> commas (go 0) es <> "} " <> (go 3) t
+    Type.ForallsNamed' vs body -> paren p 1 $
+      if (p == 0) then go 0 body
+      else "forall " <> spaces renderVar vs <> " . " <> go 1 body
+    Type.Var' v -> renderVar v
+    _ -> error "pattern match failure in PrintError.renderType"
+    where go p = renderType0 env f p
+          spaces = intercalateMap " "
+          arrows = intercalateMap " -> "
+          commas = intercalateMap ", "
 
-styleInOverallType :: (Var v, Annotated a)
+renderVar :: Var v => v -> StyledText
+renderVar = fromString . Text.unpack . qualifiedName
+
+renderKind :: Kind -> StyledText
+renderKind Kind.Star = "*"
+renderKind (Kind.Arrow k1 k2) = renderKind k1 <> " -> " <> renderKind k2
+
+showRef :: Env -> R.Reference -> String
+showRef env r = fromMaybe (show r) (Map.lookup r (referenceNames env))
+
+showRef' :: Env -> R.Reference -> StyledText
+showRef' e r = fromString $ showRef e r
+
+-- todo: do something different/better if cid not found
+showConstructor :: Env -> R.Reference -> Int -> String
+showConstructor env r cid =
+  fromMaybe (showRef env r ++ "/" ++ show cid)
+            (Map.lookup (r,cid) (constructorNames env))
+
+showConstructor' :: Env -> R.Reference -> Int -> StyledText
+showConstructor' env r cid = fromString $ showConstructor env r cid
+
+
+styleInOverallType :: (Var v, Annotated a, Eq a)
                    => Env
                    -> C.Type v a
                    -> C.Type v a
                    -> Color.Color
-                   -> Color.StyledText
+                   -> StyledText
 styleInOverallType e overallType leafType c =
-  if leafType == overallType
-  then Color.color c (fromString (prettyType e overallType))
-  else case overallType of
-    Type.Ref' _  -> fromString (prettyType e overallType)
-    _ -> error "todo"
-  -- (Color.color c . fromString $ renderType e leafType)
-  --   <> " (" <> (fromString . annotatedToEnglish) (ABT.annotation leafType) <> ")"
+  renderType e f overallType
+    where f loc s = if loc == ABT.annotation leafType then Color.color c s else s
 
 posToEnglish :: L.Pos -> String
 posToEnglish (L.Pos l c) = "Line " ++ show l ++ ", column " ++ show c

parser-typechecker/src/Unison/Type.hs

@@ -89,24 +89,31 @@ pattern Apps' f args <- (unApps -> Just (f, args))
 pattern Effect' es t <- ABT.Tm' (Effect es t)
 pattern Effect'' es t <- (stripEffect -> (es, t))
 pattern Forall' subst <- ABT.Tm' (Forall (ABT.Abs' subst))
+pattern ForallsNamed' vs body <- (unForalls -> Just (vs, body))
 pattern ForallNamed' v body <- ABT.Tm' (Forall (ABT.out -> ABT.Abs v body))
 pattern Var' v <- ABT.Var' v
 pattern Existential' v <- ABT.Var' (TypeVar.Existential v)
 pattern Universal' v <- ABT.Var' (TypeVar.Universal v)
 
-unArrows :: Type v -> Maybe [Type v]
+unArrows :: AnnotatedType v a -> Maybe [AnnotatedType v a]
 unArrows t =
   case go t of [] -> Nothing; l -> Just l
   where
     go (Arrow' i o) = i : go o
     go _ = []
 
-unApps :: Type v -> Maybe (Type v, [Type v])
+unApps :: AnnotatedType v a -> Maybe (AnnotatedType v a, [AnnotatedType v a])
 unApps t = case go t [] of [] -> Nothing; f:args -> Just (f,args)
   where
   go (App' i o) acc = go i (o:acc)
   go fn args = fn:args
 
+unForalls :: AnnotatedType v a -> Maybe ([v], AnnotatedType v a)
+unForalls t = go t []
+  where go (ForallNamed' v body) vs = go body (v:vs)
+        go _body [] = Nothing
+        go body vs = Just(reverse vs, body)
+
 matchExistential :: Eq v => v -> Type (TypeVar v) -> Bool
 matchExistential v (Existential' x) = x == v
 matchExistential _ _ = False

parser-typechecker/src/Unison/Util/AnnotatedText.hs

@@ -25,8 +25,6 @@ data AnnotatedExcerpt a = AnnotatedExcerpt
   , annotations :: Set (Range, a)
   } deriving (Eq, Ord, Show)
 
-
-
 markup :: Ord a => AnnotatedExcerpt a -> Set (Range, a) -> AnnotatedExcerpt a
 markup a r = a { annotations = r `Set.union` annotations a }
 
@@ -50,5 +48,13 @@ instance Monoid (AnnotatedDocument a) where
   mappend (AnnotatedDocument chunks) (AnnotatedDocument chunks') =
     AnnotatedDocument (chunks <> chunks')
 
+instance Semigroup (AnnotatedText a) where
+  (<>) = mappend
+  
+instance Monoid (AnnotatedText a) where
+  mempty = AnnotatedText mempty
+  mappend (AnnotatedText chunks) (AnnotatedText chunks') =
+    AnnotatedText (chunks <> chunks')
+
 instance Functor AnnotatedText where
   fmap f (AnnotatedText chunks) = AnnotatedText (second f <$> chunks)

parser-typechecker/src/Unison/Util/Monoid.hs

@@ -0,0 +1,10 @@
+module Unison.Util.Monoid where
+
+import Data.List (intersperse)
+import Data.Foldable (toList)
+
+-- List.intercalate extended to any monoid
+-- "The type that intercalate should have had to begin with."
+intercalateMap :: (Foldable t, Monoid a) => a -> (b -> a) -> t b -> a
+intercalateMap separator renderer elements =
+  mconcat $ intersperse separator (renderer <$> toList elements)

parser-typechecker/unison-parser-typechecker.cabal

@@ -66,6 +66,7 @@ library
     Unison.Util.AnnotatedText
     Unison.Util.ColorText
     Unison.Util.Logger
+    Unison.Util.Monoid
     Unison.Util.Range
     Unison.Var