From 1973aaf8037eb64dd564e9257778b8bbee060328 Mon Sep 17 00:00:00 2001 From: Aaron VonderHaar Date: Fri, 26 Aug 2022 23:15:44 -0700 Subject: [PATCH] WIP: implement formatting --- compiler/src/Gren/Format.hs | 427 ++++++++++++++++++- compiler/src/Text/PrettyPrint/Avh4/Block.hs | 337 +++++++++++++++ compiler/src/Text/PrettyPrint/Avh4/Indent.hs | 56 +++ gren.cabal | 2 + terminal/src/Format.hs | 3 +- 5 files changed, 822 insertions(+), 3 deletions(-) create mode 100644 compiler/src/Text/PrettyPrint/Avh4/Block.hs create mode 100644 compiler/src/Text/PrettyPrint/Avh4/Indent.hs diff --git a/compiler/src/Gren/Format.hs b/compiler/src/Gren/Format.hs index b9c0f047..df006e46 100644 --- a/compiler/src/Gren/Format.hs +++ b/compiler/src/Gren/Format.hs @@ -1,9 +1,432 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-error=unused-matches #-} + module Gren.Format (toByteStringBuilder) where import AST.Source qualified as Src import Data.ByteString.Builder qualified as B +import Data.Char qualified as Char +import Data.List qualified as List +import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Maybe (catMaybes) +import Data.Name (Name) +import Data.Utf8 qualified as Utf8 +import Reporting.Annotation qualified as A +import Text.PrettyPrint.Avh4.Block (Block) +import Text.PrettyPrint.Avh4.Block qualified as Block +import Text.Printf (printf) toByteStringBuilder :: Src.Module -> B.Builder -toByteStringBuilder = +toByteStringBuilder module_ = + Block.render (formatModule module_) + +-- +-- Data structure extras +-- + +repair :: [(a, b)] -> a -> (a, [(b, a)]) +repair [] a' = (a', []) +repair ((first, b) : rest) a' = + (first, repairHelp b rest a') + where + repairHelp b1 [] a1 = [(b1, a1)] + repairHelp b1 ((a1, b2) : rest') a2 = + (b1, a1) : repairHelp b2 rest' a2 + +-- +-- Helper functions +-- + +utf8 :: Utf8.Utf8 any -> Block.Line +utf8 = Block.lineFromBuilder . Utf8.toBuilder + +addBlankLines :: Int -> Block -> Block +addBlankLines n block = + Block.stack $ + NonEmpty.prependList + (replicate n Block.blankLine) + (NonEmpty.singleton block) + +spaceOrStack :: NonEmpty Block -> Block +spaceOrStack = Block.rowOrStack (Just Block.space) + +spaceOrIndent :: NonEmpty Block -> Block +spaceOrIndent = Block.rowOrIndent (Just Block.space) + +{-# INLINE group #-} +group :: Char -> Char -> Char -> Bool -> [Block] -> Block +group open _ close _ [] = Block.line $ Block.char7 open <> Block.char7 close +group open sep close forceMultiline (first : rest) = + Block.rowOrStack' forceMultiline (Just Block.space) $ + Block.prefix 2 (Block.char7 open <> Block.space) first + :| fmap (Block.prefix 2 (Block.char7 sep <> Block.space)) (rest) + ++ [Block.line (Block.char7 close)] + +-- +-- AST -> Block +-- + +formatModule :: Src.Module -> Block +formatModule (Src.Module name exports docs imports values unions aliases binops effects) = -- TODO: implement actual formating - undefined + Block.stack $ + NonEmpty.fromList $ + catMaybes + [ Just $ + spaceOrIndent $ + NonEmpty.fromList $ + catMaybes + [ Just $ Block.line $ Block.string7 "module", + Just $ Block.line $ maybe (Block.string7 "Main") (utf8 . A.toValue) name, + formatExposing $ A.toValue exports + ], + -- TODO: filter out default imports + Just $ Block.stack $ Block.blankLine :| fmap formatImport imports, + let defs = + fmap snd $ + List.sortOn fst $ + concat @[] + [ fmap (formatValue . A.toValue) <$> values, + fmap (formatUnion . A.toValue) <$> unions, + fmap (formatAlias . A.toValue) <$> aliases + ] + in fmap Block.stack $ nonEmpty $ fmap (addBlankLines 2) defs + ] + +formatExposing :: Src.Exposing -> Maybe Block +formatExposing = \case + Src.Open -> Just $ Block.line $ Block.string7 "exposing (..)" + Src.Explicit [] -> Nothing + Src.Explicit exposed -> + Just $ + spaceOrIndent + [ Block.line $ Block.string7 "exposing", + group '(' ',' ')' False $ fmap formatExposed exposed + ] + +formatExposed :: Src.Exposed -> Block +formatExposed = \case + Src.Lower name -> Block.line $ utf8 $ A.toValue name + Src.Upper name privacy -> Block.line $ utf8 $ A.toValue name + Src.Operator _ name -> Block.line $ Block.char7 '(' <> utf8 name <> Block.char7 ')' + +formatImport :: Src.Import -> Block +formatImport (Src.Import name alias exposing) = + spaceOrIndent $ + NonEmpty.fromList $ + catMaybes + [ Just $ Block.line $ Block.string7 "import", + Just $ Block.line $ utf8 $ A.toValue name, + fmap formatImportAlias alias, + formatExposing exposing + ] + where + formatImportAlias :: Name -> Block + formatImportAlias name' = Block.line $ Block.string7 "as" <> Block.space <> utf8 name' + +formatValue :: Src.Value -> Block +formatValue (Src.Value name args body type_) = + formatBasicDef (A.toValue name) (fmap A.toValue args) (A.toValue body) (fmap A.toValue type_) + +formatBasicDef :: Name -> [Src.Pattern_] -> Src.Expr_ -> Maybe Src.Type_ -> Block +formatBasicDef name args body type_ = + Block.stack $ + NonEmpty.fromList $ + catMaybes + [ fmap formatTypeAnnotation type_, + Just $ + spaceOrIndent $ + Block.line (utf8 name) + :| fmap formatPattern args + ++ [ Block.line $ Block.char7 '=' + ], + Just $ Block.indent $ formatExpr body + ] + where + formatTypeAnnotation t = + spaceOrIndent + [ Block.line $ utf8 name <> Block.space <> Block.char7 ':', + formatType t + ] + +formatUnion :: Src.Union -> Block +formatUnion (Src.Union name args ctors) = + Block.stack $ + spaceOrIndent + [ Block.line (Block.string7 "type"), + spaceOrIndent $ + Block.line (utf8 $ A.toValue name) + :| fmap (Block.line . utf8 . A.toValue) args + ] + :| fmap Block.indent formatCtors + where + formatCtors = + case ctors of + [] -> [] + (first : rest) -> formatCtor '=' first : fmap (formatCtor '|') rest + + formatCtor open (name', args') = + spaceOrIndent $ + Block.line (Block.char7 open <> Block.space <> utf8 (A.toValue name')) + :| fmap (formatType . A.toValue) args' + +formatAlias :: Src.Alias -> Block +formatAlias (Src.Alias name args type_) = + Block.stack + [ spaceOrIndent + [ Block.line (Block.string7 "type alias"), + spaceOrIndent $ + Block.line (utf8 $ A.toValue name) + :| fmap (Block.line . utf8 . A.toValue) args, + Block.line (Block.char7 '=') + ], + Block.indent $ formatType (A.toValue type_) + ] + +formatExpr :: Src.Expr_ -> Block +formatExpr = \case + Src.Chr char -> + formatString StringStyleChar char + Src.Str string -> + formatString StringStyleSingleQuoted string + Src.Int int -> + Block.line $ Block.string7 (show int) + Src.Float float -> + Block.line $ Block.string7 "TODO: formatExpr: Float" + Src.Var _ name -> + Block.line $ utf8 name + Src.VarQual _ ns name -> + Block.line $ utf8 ns <> Block.char7 '.' <> utf8 name + Src.Array exprs -> + group '[' ',' ']' True $ + fmap (formatExpr . A.toValue) exprs + Src.Op name -> + Block.line $ Block.string7 "TODO: formatExpr: Op" + Src.Negate expr -> + Block.line $ Block.string7 "TODO: formatExpr: Negate" + Src.Binops rest' last_ -> + let (first, rest) = repair rest' last_ + in spaceOrIndent $ + formatExpr (A.toValue first) + :| fmap formatPair rest + where + formatPair (op, expr) = + Block.prefix + 4 + (utf8 (A.toValue op) <> Block.space) + (formatExpr $ A.toValue expr) + Src.Lambda args body -> + Block.line $ Block.string7 "TODO: formatExpr: Lambda" + Src.Call fn args -> + spaceOrIndent $ + formatExpr (A.toValue fn) + :| fmap (formatExpr . A.toValue) args + Src.If ifs else_ -> + Block.line $ Block.string7 "TODO: formatExpr: If" + Src.Let [] body -> + formatExpr $ A.toValue body + Src.Let (def1 : defs) body -> + Block.stack + [ Block.line (Block.string7 "let"), + Block.indent $ Block.stack $ fmap (formatDef . A.toValue) (def1 :| defs), + Block.line (Block.string7 "in"), + formatExpr (A.toValue body) + ] + Src.Case subject branches -> + Block.stack $ + spaceOrStack + [ spaceOrIndent + [ Block.line (Block.string7 "case"), + formatExpr (A.toValue subject) + ], + Block.line (Block.string7 "of") + ] + :| List.intersperse Block.blankLine (fmap (Block.indent . formatCaseBranch) branches) + where + formatCaseBranch (pat, expr) = + Block.stack + [ spaceOrStack + [ formatPattern (A.toValue pat), + Block.line $ Block.string7 "->" + ], + Block.indent $ formatExpr (A.toValue expr) + ] + Src.Accessor field -> + Block.line $ Block.char7 '.' <> utf8 field + Src.Access expr field -> + Block.addSuffix (Block.char7 '.' <> utf8 (A.toValue field)) (formatExpr $ A.toValue expr) + Src.Update (A.At _ base) fields -> + case fields of + [] -> + formatExpr base + [single] -> + spaceOrStack + [ spaceOrIndent + [ spaceOrIndent + [ Block.line $ Block.char7 '{', + formatExpr base + ], + formatField '|' single + ], + Block.line (Block.char7 '}') + ] + (first : rest) -> + Block.stack + [ spaceOrIndent + [ Block.line $ Block.char7 '{', + formatExpr base + ], + Block.indent $ + Block.stack $ + formatField '|' first + :| fmap (formatField ',') rest, + Block.line (Block.char7 '}') + ] + where + formatField sep (field, expr) = + spaceOrIndent + [ Block.line $ Block.char7 sep <> Block.space <> utf8 (A.toValue field) <> Block.string7 " =", + formatExpr (A.toValue expr) + ] + + -- Block.line $ Block.string7 "TODO: formatExpr: Update" + Src.Record fields -> + group '{' ',' '}' True $ fmap formatField fields + where + formatField (name, expr) = + spaceOrIndent + [ Block.line $ utf8 (A.toValue name) <> Block.space <> Block.char7 '=', + formatExpr (A.toValue expr) + ] + +formatDef :: Src.Def -> Block +formatDef = \case + Src.Define name args body ann -> + formatBasicDef (A.toValue name) (fmap A.toValue args) (A.toValue body) (fmap A.toValue ann) + Src.Destruct pat body -> + Block.stack + [ spaceOrIndent + [ formatPattern $ A.toValue pat, + Block.line $ Block.char7 '=' + ], + Block.indent $ formatExpr $ A.toValue body + ] + +formatType :: Src.Type_ -> Block +formatType = \case + Src.TLambda left right -> + spaceOrStack + -- TODO: XXX: left might need parens for nested TLambdas + -- TODO: don't indent nested multiline lambdas + [ formatType (A.toValue left), + Block.prefix + 3 + (Block.string7 "-> ") + (formatType $ A.toValue right) + ] + Src.TVar name -> + Block.line (utf8 name) + Src.TType _ name args -> + spaceOrIndent $ + Block.line (utf8 name) + :| fmap (formatType . A.toValue) args + Src.TTypeQual _ ns name args -> + spaceOrIndent $ + Block.line (utf8 ns <> Block.char7 '.' <> utf8 name) + :| fmap (formatType . A.toValue) args + Src.TRecord fields base -> + group '{' ',' '}' True $ fmap formatField fields + where + formatField (name, type_) = + spaceOrIndent + [ Block.line $ utf8 (A.toValue name) <> Block.space <> Block.char7 ':', + formatType (A.toValue type_) + ] + +formatPattern :: Src.Pattern_ -> Block +formatPattern = \case + Src.PAnything -> + Block.line $ Block.char7 '_' + Src.PVar name -> + Block.line $ utf8 name + Src.PRecord fields -> + Block.line $ Block.string7 "TODO: formatPattern: PRecord" + Src.PAlias pat name -> + spaceOrIndent + [ formatPattern (A.toValue pat), + Block.line $ Block.string7 "as " <> utf8 (A.toValue name) + ] + Src.PCtor _ name args -> + spaceOrIndent $ + Block.line (utf8 name) + :| fmap (formatPattern . A.toValue) args + Src.PCtorQual _ ns name args -> + spaceOrIndent $ + Block.line (utf8 ns <> Block.char7 '.' <> utf8 name) + :| fmap (formatPattern . A.toValue) args + Src.PArray items -> + group '[' ',' ']' False $ + fmap (formatPattern . A.toValue) items + Src.PChr char -> + formatString StringStyleChar char + Src.PStr string -> + formatString StringStyleSingleQuoted string + Src.PInt int -> + Block.line $ Block.string7 (show int) + +data StringStyle + = StringStyleChar + | StringStyleSingleQuoted + | StringStyleTripleQuoted + deriving (Eq) + +formatString :: StringStyle -> Utf8.Utf8 any -> Block +formatString style s' = + case style of + StringStyleChar -> + stringBox (Block.char7 '\'') id + StringStyleSingleQuoted -> + stringBox (Block.char7 '"') id + StringStyleTripleQuoted -> + stringBox (Block.string7 "\"\"\"") escapeMultiQuote + where + s = Utf8.toChars s' + + stringBox :: Block.Line -> (String -> String) -> Block + stringBox quotes escaper = + Block.line $ quotes <> Block.stringUtf8 (escaper $ concatMap fix s) <> quotes + + fix = \case + '\n' | style == StringStyleTripleQuoted -> ['\n'] + '\n' -> "\\n" + '\t' -> "\\t" + '\\' -> "\\\\" + '\"' | style == StringStyleSingleQuoted -> "\\\"" + '\'' | style == StringStyleChar -> "\\\'" + c | not $ Char.isPrint c -> hex c + ' ' -> [' '] + c | Char.isSpace c -> hex c + c -> [c] + + hex char = + "\\u{" ++ printf "%04X" (Char.ord char) ++ "}" + + escapeMultiQuote = + let step okay quotes remaining = + case remaining of + [] -> + reverse $ concat (replicate quotes "\"\\") ++ okay + next : rest -> + if next == '"' + then step okay (quotes + 1) rest + else + if quotes >= 3 + then step (next : (concat $ replicate quotes "\"\\") ++ okay) 0 rest + else + if quotes > 0 + then step (next : (replicate quotes '"') ++ okay) 0 rest + else step (next : okay) 0 rest + in step "" 0 diff --git a/compiler/src/Text/PrettyPrint/Avh4/Block.hs b/compiler/src/Text/PrettyPrint/Avh4/Block.hs new file mode 100644 index 00000000..7ea9a4b6 --- /dev/null +++ b/compiler/src/Text/PrettyPrint/Avh4/Block.hs @@ -0,0 +1,337 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +module Text.PrettyPrint.Avh4.Block + ( Line, + string7, + lineFromBuilder, + commentByteString, + space, + Block (SingleLine, MustBreak), + blankLine, + line, + mustBreak, + stack, + stack', + andThen, + indent, + prefix, + addSuffix, + joinMustBreak, + prefixOrIndent, + rowOrStack, + rowOrStack', + rowOrIndent, + rowOrIndent', + render, + char7, + stringUtf8, + ) +where + +import Data.ByteString (ByteString) +import Data.ByteString qualified as ByteString +import Data.ByteString.Builder qualified as B +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Semigroup (sconcat) +import Text.PrettyPrint.Avh4.Indent (Indent) +import Text.PrettyPrint.Avh4.Indent qualified as Indent + +-- | A `Line` is ALWAYS just one single line of text, +-- and can always be combined horizontally with other `Line`s. +-- +-- - `Space` is a single horizontal space, +-- - `Blank` is a line with no content. +-- - `Text` brings any text into the data structure. (Uses `ByteString.Builder` for the possibility of optimal performance) +-- - `Row` joins multiple elements onto one line. +data Line + = Text B.Builder + | Row Line Line + | Space + | Blank + +instance Semigroup Line where + a <> b = Row a b + +char7 :: Char -> Line +char7 = Text . B.char7 + +string7 :: String -> Line +string7 = Text . B.string7 + +-- | If you know the String only contains ASCII characters, then use `string7` instead for better performance. +stringUtf8 :: String -> Line +stringUtf8 = Text . B.stringUtf8 + +-- | You must guarantee that the content of the Builder does not contain newlines and does not start with whitespace. +lineFromBuilder :: B.Builder -> Line +lineFromBuilder = Text + +{-# INLINE mkTextByteString #-} +mkTextByteString :: ByteString -> Line +mkTextByteString = Text . B.byteString + +commentByteString :: ByteString -> Line +commentByteString bs = + if ByteString.null bs + then Blank + else mkTextByteString bs + +space :: Line +space = + Space + +data Indented a + = Indented Indent a + deriving (Functor) + +-- | `Block` contains Lines (at least one; it can't be empty). +-- +-- Block either: +-- - can appear in the middle of a line +-- (Stack someLine [], thus can be joined without problems), or +-- - has to appear on its own +-- (Stack someLine moreLines OR MustBreak someLine). +-- +-- - `SingleLine` is a single line, and the indentation level for the line. +-- - `MustBreak` is a single line (and its indentation level)) that cannot have anything joined to its right side. +-- Notably, it is used for `--` comments. +-- - `Stack` contains two or more lines, and the indentation level for each. +-- +-- Sometimes (see `prefix`) the first line of Stack +-- gets different treatment than the other lines. +data Block + = SingleLine (Indented Line) + | Stack (Indented Line) (Indented Line) [Indented Line] + | MustBreak (Indented Line) + +blankLine :: Block +blankLine = + line Blank + +line :: Line -> Block +line = + SingleLine . mkIndentedLine + +mustBreak :: Line -> Block +mustBreak = + MustBreak . mkIndentedLine + +mkIndentedLine :: Line -> Indented Line +mkIndentedLine Space = Indented (Indent.spaces 1) Blank +mkIndentedLine (Row Space next) = + let (Indented i rest') = mkIndentedLine next + in Indented (Indent.spaces 1 <> i) rest' +mkIndentedLine other = Indented mempty other + +stack' :: Block -> Block -> Block +stack' b1 b2 = + let (line1first, line1rest) = destructure b1 + (line2first, line2rest) = destructure b2 + in case line1rest ++ line2first : line2rest of + [] -> + error "the list will contain at least line2first" + first : rest -> + Stack line1first first rest + +andThen :: [Block] -> Block -> Block +andThen rest first = + foldl stack' first rest + +stack :: NonEmpty Block -> Block +stack = foldr1 stack' + +joinMustBreak :: Block -> Block -> Block +joinMustBreak inner eol = + case (inner, eol) of + (SingleLine (Indented i1 inner'), SingleLine (Indented _ eol')) -> + SingleLine $ + Indented i1 $ + inner' <> space <> eol' + (SingleLine (Indented i1 inner'), MustBreak (Indented _ eol')) -> + MustBreak $ + Indented i1 $ + inner' <> space <> eol' + _ -> + stack' inner eol + +{-# INLINE prefixOrIndent #-} +prefixOrIndent :: Maybe Line -> Line -> Block -> Block +prefixOrIndent joiner a b = + let join a b = + case joiner of + Nothing -> a <> b + Just j -> a <> j <> b + in case b of + SingleLine (Indented _ b') -> + line $ join a b' + MustBreak (Indented _ b') -> + mustBreak $ join a b' + _ -> + stack' (line a) (indent b) + +mapLines :: (Indented Line -> Indented Line) -> Block -> Block +mapLines fn = + mapFirstLine fn fn + +mapFirstLine :: (Indented Line -> Indented Line) -> (Indented Line -> Indented Line) -> Block -> Block +mapFirstLine firstFn restFn b = + case b of + SingleLine l1 -> + SingleLine (firstFn l1) + Stack l1 l2 ls -> + Stack (firstFn l1) (restFn l2) (map restFn ls) + MustBreak l1 -> + MustBreak (firstFn l1) + +mapLastLine :: (Indented Line -> Indented Line) -> Block -> Block +mapLastLine lastFn = \case + SingleLine l1 -> + SingleLine (lastFn l1) + Stack l1 l2 [] -> + Stack l1 (lastFn l2) [] + Stack l1 l2 ls -> + Stack l1 l2 (init ls ++ [lastFn $ last ls]) + MustBreak l1 -> + MustBreak (lastFn l1) + +indent :: Block -> Block +indent = + mapLines (\(Indented i l) -> Indented (Indent.tab <> i) l) + +{-# INLINE rowOrStack #-} +rowOrStack :: Maybe Line -> NonEmpty Block -> Block +rowOrStack = rowOrStack' False + +{-# INLINE rowOrStack' #-} +rowOrStack' :: Bool -> Maybe Line -> NonEmpty Block -> Block +rowOrStack' _ _ (single :| []) = single +rowOrStack' forceMultiline (Just joiner) blocks = + case allSingles blocks of + Right lines + | not forceMultiline -> + line $ sconcat $ NonEmpty.intersperse joiner lines + _ -> + stack blocks +rowOrStack' forceMultiline Nothing blocks = + case allSingles blocks of + Right lines + | not forceMultiline -> + line $ sconcat lines + _ -> + stack blocks + +{-# INLINE rowOrIndent #-} +rowOrIndent :: Maybe Line -> NonEmpty Block -> Block +rowOrIndent = rowOrIndent' False + +{-# INLINE rowOrIndent' #-} +rowOrIndent' :: Bool -> Maybe Line -> NonEmpty Block -> Block +rowOrIndent' _ _ (single :| []) = single +rowOrIndent' forceMultiline (Just joiner) blocks@(b1 :| rest) = + case allSingles blocks of + Right lines + | not forceMultiline -> + line $ sconcat $ NonEmpty.intersperse joiner lines + _ -> + stack (b1 :| (indent <$> rest)) +rowOrIndent' forceMultiline Nothing blocks@(b1 :| rest) = + case allSingles blocks of + Right lines + | not forceMultiline -> + line $ sconcat lines + _ -> + stack (b1 :| (indent <$> rest)) + +{-# DEPRECATED isLine "Rewrite to avoid inspecting the child blocks" #-} +isLine :: Block -> Either Block Line +isLine b = + case b of + SingleLine (Indented _ l) -> + Right l + _ -> + Left b + +destructure :: Block -> (Indented Line, [Indented Line]) +destructure b = + case b of + SingleLine l1 -> + (l1, []) + Stack l1 l2 rest -> + (l1, l2 : rest) + MustBreak l1 -> + (l1, []) + +allSingles :: Traversable t => t Block -> Either (t Block) (t Line) +allSingles blocks = + case mapM isLine blocks of + Right lines' -> + Right lines' + _ -> + Left blocks + +{- +Add the prefix to the first line, +pad the other lines with spaces of the same length + +NOTE: An exceptional case that we haven't really designed for is if the first line of the input Block is indented. + +EXAMPLE: +abcde +xyz +-----> +myPrefix abcde + xyz +-} +prefix :: Word -> Line -> Block -> Block +prefix prefixLength pref = + let padLineWithSpaces (Indented i l) = Indented (Indent.spaces prefixLength <> i) l + + addPrefixToLine Blank = stripEnd pref + addPrefixToLine l = pref <> l + in mapFirstLine (fmap addPrefixToLine) padLineWithSpaces + +stripEnd :: Line -> Line +stripEnd = \case + Space -> Blank + Row r1 r2 -> + case (stripEnd r1, stripEnd r2) of + (r1', Blank) -> r1' + (Blank, r2') -> r2' + (r1', r2') -> Row r1' r2' + Text t -> Text t + Blank -> Blank + +addSuffix :: Line -> Block -> Block +addSuffix suffix = + mapLastLine $ fmap (<> suffix) + +renderIndentedLine :: Indented Line -> B.Builder +renderIndentedLine (Indented i line') = + renderLine i line' <> B.char7 '\n' + +spaces :: Int -> B.Builder +spaces i = + B.byteString (ByteString.replicate i 0x20 {- space -}) + +renderLine :: Indent -> Line -> B.Builder +renderLine i = \case + Text text -> + spaces (Indent.width i) <> text + Space -> + spaces (1 + Indent.width i) + Row left right -> + renderLine i left <> renderLine mempty right + Blank -> + mempty + +render :: Block -> B.Builder +render = \case + SingleLine line' -> + renderIndentedLine line' + Stack l1 l2 rest -> + foldMap renderIndentedLine (l1 : l2 : rest) + MustBreak line' -> + renderIndentedLine line' diff --git a/compiler/src/Text/PrettyPrint/Avh4/Indent.hs b/compiler/src/Text/PrettyPrint/Avh4/Indent.hs new file mode 100644 index 00000000..203b8f32 --- /dev/null +++ b/compiler/src/Text/PrettyPrint/Avh4/Indent.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Text.PrettyPrint.Avh4.Indent (Indent, tab, spaces, width) where + +spacesInTab :: Word +spacesInTab = 4 + +-- | `Indent` represents an indentation level, +-- and the operator `<>` can be used to combine two indentations side-by-side, accounting for the tab size. +-- +-- Each `Indent` can be thought of as: +-- one or more TABs, followed by zero to three SPACEs. +-- +-- Combining two indents can be thought of as +-- typing the first and then the second sequence of +-- TABs and SPACEs in a word processor. +-- +-- For example: +-- +-- [TAB] <> [TAB] == [TAB][TAB] +-- [TAB] <> ... == [TAB]... +-- [TAB] <> [TAB]... == [TAB][TAB]... +-- <> ... == ... +-- [TAB].. <> [TAB] == [TAB][TAB] +-- .. <> . == ... +-- .. <> .. == [TAB] +newtype Indent + = Indent [Word] + deriving (Semigroup, Monoid, Show) + +instance Eq Indent where + a == b = + width' a == width' b + +tab :: Indent +tab = Indent [spacesInTab] + +spaces :: Word -> Indent +spaces = Indent . pure + +width :: Num n => Indent -> n +width = fromIntegral . width' + +width' :: Indent -> Word +width' (Indent is) = + foldl combine 0 is + +combine :: Word -> Word -> Word +combine pos i = + if i < spacesInTab + then -- The right side starts with spaces (and no TABs), + -- so just add everything together. + pos + i + else -- The right side starts with at least one TAB, + -- so remove the trailing spaces from the left. + pos - (pos `mod` spacesInTab) + i diff --git a/gren.cabal b/gren.cabal index 8efe9ee1..b359086a 100644 --- a/gren.cabal +++ b/gren.cabal @@ -112,6 +112,8 @@ Common gren-common Data.NonEmptyList Data.OneOrMore Data.Utf8 + Text.PrettyPrint.Avh4.Block + Text.PrettyPrint.Avh4.Indent -- json Json.Decode diff --git a/terminal/src/Format.hs b/terminal/src/Format.hs index f1f75379..927c58fe 100644 --- a/terminal/src/Format.hs +++ b/terminal/src/Format.hs @@ -96,7 +96,8 @@ resolveFile path = isDir <- Task.io (Dir.doesDirectoryExist path) if isDir then resolveFiles =<< Task.io (fmap (path ) . filter (not . ignore) <$> Dir.listDirectory path) - else return [path] + else -- XXX: only include file if it matches '*.gren' + return [path] where ignore dir = dir == ".gren"