mirror of
https://github.com/gren-lang/compiler.git
synced 2024-09-11 08:45:42 +03:00
WIP: implement formatting
This commit is contained in:
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
|
module Gren.Format (toByteStringBuilder) where
|
||||||
|
|
||||||
import AST.Source qualified as Src
|
import AST.Source qualified as Src
|
||||||
import Data.ByteString.Builder qualified as B
|
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 :: 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
|
-- 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.NonEmptyList
|
||||||
Data.OneOrMore
|
Data.OneOrMore
|
||||||
Data.Utf8
|
Data.Utf8
|
||||||
|
Text.PrettyPrint.Avh4.Block
|
||||||
|
Text.PrettyPrint.Avh4.Indent
|
||||||
|
|
||||||
-- json
|
-- json
|
||||||
Json.Decode
|
Json.Decode
|
||||||
|
@ -96,7 +96,8 @@ resolveFile path =
|
|||||||
isDir <- Task.io (Dir.doesDirectoryExist path)
|
isDir <- Task.io (Dir.doesDirectoryExist path)
|
||||||
if isDir
|
if isDir
|
||||||
then resolveFiles =<< Task.io (fmap (path </>) . filter (not . ignore) <$> Dir.listDirectory path)
|
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
|
where
|
||||||
ignore dir =
|
ignore dir =
|
||||||
dir == ".gren"
|
dir == ".gren"
|
||||||
|
Loading…
Reference in New Issue
Block a user