From 810bf2ba3f1ec979080917d8b7c8e59b908060ec Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Fri, 30 Aug 2024 08:33:32 -0400 Subject: [PATCH] wrap to terminal width We are using the prettyprinter library, which nicely wraps and indents the output to fit the screen, but we were using the default layout options, which assume that the screen is always exactly 80 characters wide. With a slightly sinful unsafePerformIO, we can use the terminal's actual width instead. --- src/Pretty.hs | 23 ++++++++++++++++++++--- 1 file changed, 20 insertions(+), 3 deletions(-) diff --git a/src/Pretty.hs b/src/Pretty.hs index 238d37c5..d8f90638 100644 --- a/src/Pretty.hs +++ b/src/Pretty.hs @@ -11,6 +11,7 @@ module Pretty (Doc, Pretty(..), string, text, viaShow, (<+>), (<>), align, hang, import Control.Lens hiding (List) import Control.Monad.State import qualified Data.HashMap.Strict as HM +import Data.Maybe (fromMaybe) import qualified Util.Set as Set import Prettyprinter hiding (Pretty(..), angles, parens) import qualified Prettyprinter as PP @@ -19,7 +20,10 @@ import Data.Sequence (Seq) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Foldable as F +import System.Environment (lookupEnv) import System.FilePath (takeFileName) +import System.IO.Unsafe (unsafePerformIO) +import Text.Read (readMaybe) import Binding import Binding.Info @@ -58,8 +62,21 @@ angles doc = text "⟨" <> align (group doc) <> "⟩" vec :: Doc ann -> Doc ann vec doc = text "[" <> align (group doc) <> "]" +customLayoutOptions :: LayoutOptions +customLayoutOptions = unsafePerformIO $ do + columnsMaybeString <- lookupEnv "COLUMNS" + let columnsMaybeInt :: Maybe Int + columnsMaybeInt = do + str <- columnsMaybeString + readMaybe str + let columns :: Int + columns = fromMaybe 80 columnsMaybeInt + + pure $ defaultLayoutOptions + {layoutPageWidth = AvailablePerLine columns 1.0} + pretty :: Pretty ann a => a -> Text -pretty x = renderStrict (layoutPretty defaultLayoutOptions (pp Env.empty x)) +pretty x = renderStrict (layoutPretty customLayoutOptions (pp Env.empty x)) prettyPrint :: Pretty ann a => a -> IO () prettyPrint x = putDoc (pp Env.empty x) @@ -69,7 +86,7 @@ prettyPrintLn x = putDoc (pp Env.empty x) >> putStrLn "" prettyEnv :: Pretty ann a => Env Var v -> a -> Text prettyEnv env x = - renderStrict (layoutPretty defaultLayoutOptions (pp (fmap (const ()) env) x)) + renderStrict (layoutPretty customLayoutOptions (pp (fmap (const ()) env) x)) prettyPrintEnv :: Pretty ann a => Env Var v -> a -> IO () prettyPrintEnv env x = @@ -201,7 +218,7 @@ class PrettyBinder ann a | a -> ann where instance PrettyBinder VarInfo a => PrettyBinder VarInfo (TyF a) where ppBind env t = let subs = ppBind env <$> t - in (pp env (fst <$> subs), foldMap snd subs) + in (pp env (fst <$> subs), foldMap snd subs) newtype BinderPair = BinderPair (Ident, Var)