mirror of
https://github.com/gren-lang/compiler.git
synced 2024-08-16 12:00:22 +03:00
WIP: implement formatting
This commit is contained in:
Aaron VonderHaar
parent
f74081e5d0
commit
1973aaf803
@ -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
|
||||
|
||||
337
compiler/src/Text/PrettyPrint/Avh4/Block.hs
Normal file
337
compiler/src/Text/PrettyPrint/Avh4/Block.hs
Normal file
@ -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'
|
||||
56
compiler/src/Text/PrettyPrint/Avh4/Indent.hs
Normal file
56
compiler/src/Text/PrettyPrint/Avh4/Indent.hs
Normal file
@ -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
|
||||
@ -112,6 +112,8 @@ Common gren-common
|
||||
Data.NonEmptyList
|
||||
Data.OneOrMore
|
||||
Data.Utf8
|
||||
Text.PrettyPrint.Avh4.Block
|
||||
Text.PrettyPrint.Avh4.Indent
|
||||
|
||||
-- json
|
||||
Json.Decode
|
||||
|
||||
@ -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"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user