diff --git a/parser-typechecker/src/Unison/PrettyPrint.hs b/parser-typechecker/src/Unison/PrettyPrint.hs new file mode 100644 index 000000000..79fb309f3 --- /dev/null +++ b/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) diff --git a/parser-typechecker/src/Unison/Util/PrettyPrint.hs b/parser-typechecker/src/Unison/Util/PrettyPrint.hs new file mode 100644 index 000000000..2629fcab7 --- /dev/null +++ b/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 diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 785b094f5..ba07c4f00 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/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,