start of PrettyPrinter.hs

parser-typechecker/src/Unison/PrettyPrint.hs

@@ -0,0 +1,21 @@
+{-# 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)

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

@@ -0,0 +1,107 @@
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Unison.Util.PrettyPrint where
+
+
+import qualified Data.ListLike      as LL
+import           Data.String        (IsString, fromString)
+import           Unison.Util.Monoid (intercalateMap)
+
+data PrettyPrint a
+  = Empty
+  | Literal a
+  | Append (PrettyPrint a) (PrettyPrint a)
+  | Nest a (PrettyPrint a)
+  | Breakable a
+  | Group (PrettyPrint a)
+
+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
+
+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
+
+renderBroken :: forall a b. (LL.ListLike a b, Eq b)
+             => Int -> Bool -> b -> PrettyPrint a -> a
+renderBroken width beginLine lineSeparator = \case
+  Empty -> LL.empty
+  Literal a -> a
+  Append a b ->
+    let ra = renderBroken width beginLine lineSeparator a
+        trailing = lengthOfLastLine lineSeparator ra
+    in ra <> renderBroken (width - trailing) (trailing == 0) lineSeparator b
+  Nest prefix a ->
+    if beginLine
+    then
+      let ra = renderBroken (width - LL.length prefix) False lineSeparator a
+      in prefix <> replaceOneWithMany lineSeparator (LL.cons lineSeparator prefix) ra
+    else renderBroken width False lineSeparator a
+  Breakable _delim -> LL.singleton lineSeparator
+  Group a -> render' width lineSeparator a
+
+  where
+    replaceOneWithMany :: (LL.FoldableLL a b, Eq b) => b -> a -> a -> a
+    replaceOneWithMany target replacement list =
+      LL.foldl (go target replacement) LL.empty list
+        where go :: (LL.FoldableLL a b, Eq b) => b -> a -> a -> b -> a
+              go target replacement a b =
+                if b == target then LL.append a replacement else a
+
+    lengthOfLastLine :: (LL.ListLike a b, Eq b) => b -> a -> Int
+    lengthOfLastLine lineSeparator ra =
+      LL.length ra + 1 - case LL.reverse $ LL.findIndices (==lineSeparator) ra of
+        []    -> -1
+        h : _ -> h
+
+render :: LL.ListLike a Char => Int -> PrettyPrint a -> a
+render width doc = render' width '\n' doc
+
+render' :: (LL.ListLike a b, Eq b) => Int -> b -> PrettyPrint a -> a
+render' width lineSeparator doc =
+  if unbrokenWidth doc <= width
+  then renderUnbroken doc
+  else renderBroken width False 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
+
+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

parser-typechecker/unison-parser-typechecker.cabal

@@ -51,6 +51,7 @@ library
     Unison.Paths
     Unison.Pattern
     Unison.PatternP
+    Unison.PrettyPrint
     Unison.PrintError
     Unison.Reference
     Unison.Runtime.Rt0
@@ -71,6 +72,7 @@ library
     Unison.Util.ColorText
     Unison.Util.Logger
     Unison.Util.Monoid
+    Unison.Util.PrettyPrint
     Unison.Util.Range
     Unison.Util.Watch
     Unison.Var
@@ -90,6 +92,7 @@ library
     fsnotify,
     hashable,
     lens,
+    ListLike,
     memory,
     monad-loops,
     mtl,