Skip to content

Commit

Permalink
Merge pull request #165 from avh4/format-expose-constructors
Browse files Browse the repository at this point in the history
format: good things to fix before 0.2
  • Loading branch information
robinheghan authored Dec 4, 2022
2 parents ec311b7 + afcb9d1 commit c3a39dc
Show file tree
Hide file tree
Showing 16 changed files with 179 additions and 69 deletions.
9 changes: 5 additions & 4 deletions compiler/src/AST/Source.hs
Original file line number Diff line number Diff line change
Expand Up @@ -50,6 +50,7 @@ import Data.List.NonEmpty (NonEmpty)
import Data.Name (Name)
import Data.Name qualified as Name
import Gren.Float qualified as EF
import Gren.Int qualified as GI
import Gren.String qualified as ES
import Parse.Primitives qualified as P
import Reporting.Annotation qualified as A
Expand All @@ -60,8 +61,8 @@ type Expr = A.Located Expr_

data Expr_
= Chr ES.String
| Str ES.String
| Int Int
| Str ES.String ES.StringFormat
| Int Int GI.IntFormat
| Float EF.Float
| Var VarType Name
| VarQual VarType Name Name
Expand Down Expand Up @@ -120,7 +121,7 @@ data Pattern_
| PArray [PArrayEntry]
| PChr ES.String
| PStr ES.String
| PInt Int
| PInt Int GI.IntFormat
deriving (Show)

type RecordFieldPattern = A.Located RecordFieldPattern_
Expand Down Expand Up @@ -158,7 +159,7 @@ data Module = Module
_values :: [(SourceOrder, A.Located Value)],
_unions :: [(SourceOrder, A.Located Union)],
_aliases :: [(SourceOrder, A.Located Alias)],
_binops :: [A.Located Infix],
_binops :: ([Comment], [A.Located Infix]),
_topLevelComments :: [(SourceOrder, NonEmpty Comment)],
_headerComments :: SC.HeaderComments,
_effects :: Effects
Expand Down
8 changes: 4 additions & 4 deletions compiler/src/Canonicalize/Expression.hs
Original file line number Diff line number Diff line change
Expand Up @@ -50,11 +50,11 @@ canonicalize :: Env.Env -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr
canonicalize env (A.At region expression) =
A.At region
<$> case expression of
Src.Str string ->
Src.Str string _ ->
Result.ok (Can.Str string)
Src.Chr char ->
Result.ok (Can.Chr char)
Src.Int int ->
Src.Int int _ ->
Result.ok (Can.Int int)
Src.Float float ->
Result.ok (Can.Float float)
Expand Down Expand Up @@ -258,7 +258,7 @@ addBindingsHelp bindings (A.At region pattern) =
bindings
Src.PStr _ ->
bindings
Src.PInt _ ->
Src.PInt _ _ ->
bindings

-- BUILD BINDINGS GRAPH
Expand Down Expand Up @@ -361,7 +361,7 @@ getPatternNames names (A.At region pattern) =
Src.PArray patterns -> List.foldl' getPatternNames names (fmap fst patterns)
Src.PChr _ -> names
Src.PStr _ -> names
Src.PInt _ -> names
Src.PInt _ _ -> names

extractRecordFieldPattern :: Src.RecordFieldPattern -> Src.Pattern
extractRecordFieldPattern (A.At _ (Src.RFPattern _ pattern)) = pattern
Expand Down
2 changes: 1 addition & 1 deletion compiler/src/Canonicalize/Module.hs
Original file line number Diff line number Diff line change
Expand Up @@ -35,7 +35,7 @@ type Result i w a =
-- MODULES

canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Result i [W.Warning] Can.Module
canonicalize pkg ifaces modul@(Src.Module _ exports docs imports valuesWithSourceOrder _ _ binops _ _ effects) =
canonicalize pkg ifaces modul@(Src.Module _ exports docs imports valuesWithSourceOrder _ _ (_, binops) _ _ effects) =
do
let values = fmap snd valuesWithSourceOrder
let home = ModuleName.Canonical pkg (Src.getName modul)
Expand Down
2 changes: 1 addition & 1 deletion compiler/src/Canonicalize/Pattern.hs
Original file line number Diff line number Diff line change
Expand Up @@ -78,7 +78,7 @@ canonicalize env (A.At region pattern) =
Result.ok (Can.PChr chr)
Src.PStr str ->
Result.ok (Can.PStr str)
Src.PInt int ->
Src.PInt int _ ->
Result.ok (Can.PInt int)

canonicalizeRecordFields :: Env.Env -> [Src.RecordFieldPattern] -> Result DupsDict w [Can.PatternRecordField]
Expand Down
9 changes: 9 additions & 0 deletions compiler/src/Data/Utf8.hs
Original file line number Diff line number Diff line change
Expand Up @@ -23,6 +23,7 @@ module Data.Utf8
putVeryLong,
--
toChars,
toText,
toBuilder,
toEscapedBuilder,
--
Expand All @@ -46,6 +47,7 @@ import Data.ByteString.Builder.Internal qualified as B
import Data.ByteString.Internal qualified as B
import Data.Char qualified as Char
import Data.List qualified as List
import Data.Text qualified as Text
import Foreign.ForeignPtr (touchForeignPtr)
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
import Foreign.Ptr (minusPtr, plusPtr)
Expand Down Expand Up @@ -330,6 +332,13 @@ word8ToInt# :: Word8# -> Int#
word8ToInt# word8 =
int8ToInt# (word8ToInt8# word8)

-- TO TEXT

toText :: Utf8 t -> Text.Text
toText =
-- This could most certainly be optimized for better performance
Text.pack . toChars

-- TO BUILDER

toBuilder :: Utf8 t -> B.Builder
Expand Down
87 changes: 63 additions & 24 deletions compiler/src/Gren/Format.hs
Original file line number Diff line number Diff line change
@@ -1,5 +1,6 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Werror=incomplete-patterns #-}
{-# OPTIONS_GHC -Wno-error=unused-matches #-}
Expand All @@ -21,11 +22,16 @@ import Data.Maybe (catMaybes, maybeToList)
import Data.Maybe qualified as Maybe
import Data.Name (Name)
import Data.Semigroup (sconcat)
import Data.Text qualified as Text
import Data.Text.Encoding (encodeUtf8Builder)
import Data.Utf8 qualified as Utf8
import Gren.Int qualified as GI
import Gren.String qualified as GS
import Parse.Primitives qualified as P
import Reporting.Annotation qualified as A
import Text.PrettyPrint.Avh4.Block (Block)
import Text.PrettyPrint.Avh4.Block qualified as Block
import Text.Printf qualified

toByteStringBuilder :: Src.Module -> B.Builder
toByteStringBuilder module_ =
Expand Down Expand Up @@ -202,7 +208,7 @@ formatCommentBlockNonEmpty =
spaceOrStack . fmap formatComment

formatModule :: Src.Module -> Block
formatModule (Src.Module moduleName exports docs imports values unions aliases binops topLevelComments comments effects) =
formatModule (Src.Module moduleName exports docs imports values unions aliases (commentsBeforeBinops, binops) topLevelComments comments effects) =
Block.stack $
NonEmpty.fromList $
catMaybes
Expand Down Expand Up @@ -279,10 +285,21 @@ formatModule (Src.Module moduleName exports docs imports values unions aliases b
Nothing -> Nothing
Just some ->
Just $
Block.stack
[ Block.blankLine,
Block.stack $ fmap (formatInfix . A.toValue) some
]
Block.stack $
NonEmpty.fromList $
mconcat
[ case formatCommentBlock commentsBeforeBinops of
Just comments_ ->
[ Block.blankLine,
Block.blankLine,
comments_,
Block.blankLine
]
Nothing -> [],
[ Block.blankLine,
Block.stack $ fmap (formatInfix . A.toValue) some
]
]

formatTopLevelCommentBlock :: NonEmpty Src.Comment -> Block
formatTopLevelCommentBlock comments =
Expand Down Expand Up @@ -352,23 +369,30 @@ formatExposing commentsAfterKeyword commentsAfterListing = \case
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.Upper name Src.Private -> Block.line $ utf8 (A.toValue name)
Src.Upper name (Src.Public _) -> Block.line $ utf8 (A.toValue name) <> Block.string7 "(..)"
Src.Operator _ name -> Block.line $ Block.char7 '(' <> utf8 name <> Block.char7 ')'

formatImport :: ([Src.Comment], Src.Import) -> Block
formatImport (commentsBefore, Src.Import name alias exposing exposingComments comments) =
let (SC.ImportComments commentsAfterKeyword commentsAfterName) = comments
in spaceOrIndent $
in Block.stack $
NonEmpty.fromList $
catMaybes
[ Just $ Block.line $ Block.string7 "import",
Just $ withCommentsBefore commentsAfterKeyword $ Block.line $ utf8 $ A.toValue name,
(spaceOrStack . fmap formatComment) <$> NonEmpty.nonEmpty commentsAfterName,
fmap formatImportAlias alias,
formatExposing
(maybe [] SC._afterExposing exposingComments)
(maybe [] SC._afterExposingListing exposingComments)
exposing
[ fmap (\b -> Block.stack [Block.blankLine, b]) $ formatCommentBlock commentsBefore,
Just $
spaceOrIndent $
NonEmpty.fromList $
catMaybes
[ Just $ Block.line $ Block.string7 "import",
Just $ withCommentsBefore commentsAfterKeyword $ Block.line $ utf8 $ A.toValue name,
(spaceOrStack . fmap formatComment) <$> NonEmpty.nonEmpty commentsAfterName,
fmap formatImportAlias alias,
formatExposing
(maybe [] SC._afterExposing exposingComments)
(maybe [] SC._afterExposingListing exposingComments)
exposing
]
]

formatImportAlias :: (Name, SC.ImportAliasComments) -> Block
Expand Down Expand Up @@ -536,13 +560,14 @@ formatExpr = \case
Src.Chr char ->
NoExpressionParens $
formatString StringStyleChar char
Src.Str string ->
Src.Str string GS.SingleLineString ->
NoExpressionParens $
formatString StringStyleSingleQuoted string
Src.Int int ->
Src.Str string GS.MultilineString ->
NoExpressionParens $
Block.line $
Block.string7 (show int)
formatString StringStyleTripleQuoted string
Src.Int int intFormat ->
NoExpressionParens $ formatInt intFormat int
Src.Float float ->
NoExpressionParens $
Block.line $
Expand Down Expand Up @@ -770,6 +795,16 @@ formatExpr = \case
exprParensNone $
formatExpr (A.toValue expr)

formatInt :: GI.IntFormat -> Int -> Block
formatInt intFormat int =
case intFormat of
GI.DecimalInt ->
Block.line $
Block.string7 (show int)
GI.HexInt ->
Block.line $
Block.string7 (Text.Printf.printf "0x%X" int)

parensComments :: [Src.Comment] -> [Src.Comment] -> Block -> Block
parensComments [] [] inner = inner
parensComments commentsBefore commentsAfter inner =
Expand Down Expand Up @@ -1005,10 +1040,8 @@ formatPattern = \case
Src.PStr string ->
NoPatternParens $
formatString StringStyleSingleQuoted string
Src.PInt int ->
NoPatternParens $
Block.line $
Block.string7 (show int)
Src.PInt int intFormat ->
NoPatternParens $ formatInt intFormat int

formatPatternConstructorArg :: ([Src.Comment], Src.Pattern) -> PatternBlock
formatPatternConstructorArg (commentsBefore, pat) =
Expand All @@ -1028,7 +1061,13 @@ formatString style str =
StringStyleSingleQuoted ->
stringBox (Block.char7 '"')
StringStyleTripleQuoted ->
stringBox (Block.string7 "\"\"\"")
Block.stack $
NonEmpty.fromList $
mconcat
[ [Block.line (Block.string7 "\"\"\"")],
fmap (Block.line . Block.lineFromBuilder . encodeUtf8Builder) $ Text.splitOn "\\n" $ (Utf8.toText str),
[Block.line (Block.string7 "\"\"\"")]
]
where
stringBox :: Block.Line -> Block
stringBox quotes =
Expand Down
4 changes: 4 additions & 0 deletions compiler/src/Gren/Int.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,4 @@
module Gren.Int (IntFormat (..)) where

data IntFormat = DecimalInt | HexInt
deriving (Show)
6 changes: 6 additions & 0 deletions compiler/src/Gren/String.hs
Original file line number Diff line number Diff line change
Expand Up @@ -5,6 +5,7 @@

module Gren.String
( String,
StringFormat (..),
toChars,
fromChars,
toBuilder,
Expand All @@ -31,6 +32,11 @@ type String =

data GREN_STRING

data StringFormat
= SingleLineString
| MultilineString
deriving (Show)

-- HELPERS

toChars :: String -> [Char]
Expand Down
6 changes: 3 additions & 3 deletions compiler/src/Parse/Declaration.hs
Original file line number Diff line number Diff line change
Expand Up @@ -234,7 +234,7 @@ portDecl maybeDocs =

-- INVARIANT: always chomps to a freshline
--
infix_ :: Parser E.Module (A.Located Src.Infix)
infix_ :: Parser E.Module (A.Located Src.Infix, [Src.Comment])
infix_ =
let err = E.Infix
_err = \_ -> E.Infix
Expand All @@ -260,6 +260,6 @@ infix_ =
Space.chompAndCheckIndent _err err
name <- Var.lower err
end <- getPosition
Space.chomp _err
commentsAfter <- Space.chomp _err
Space.checkFreshLine err
return (A.at start end (Src.Infix op associativity precedence name))
return (A.at start end (Src.Infix op associativity precedence name), commentsAfter)
6 changes: 3 additions & 3 deletions compiler/src/Parse/Expression.hs
Original file line number Diff line number Diff line change
Expand Up @@ -44,8 +44,8 @@ term =
string :: A.Position -> Parser E.Expr Src.Expr
string start =
do
str <- String.string E.Start E.String
addEnd start (Src.Str str)
(str, stringFormat) <- String.string E.Start E.String
addEnd start (Src.Str str stringFormat)

character :: A.Position -> Parser E.Expr Src.Expr
character start =
Expand All @@ -59,7 +59,7 @@ number start =
nmbr <- Number.number E.Start E.Number
addEnd start $
case nmbr of
Number.Int int -> Src.Int int
Number.Int int intFormat -> Src.Int int intFormat
Number.Float float -> Src.Float float

parenthesizedExpr :: A.Position -> Parser E.Expr Src.Expr
Expand Down
21 changes: 13 additions & 8 deletions compiler/src/Parse/Module.hs
Original file line number Diff line number Diff line change
Expand Up @@ -15,6 +15,7 @@ where

import AST.Source qualified as Src
import AST.SourceComments qualified as SC
import Data.Bifunctor (first)
import Data.ByteString qualified as BS
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import Data.Name qualified as Name
Expand Down Expand Up @@ -61,7 +62,7 @@ isKernel projectType =
data Module = Module
{ _header :: Maybe Header,
_imports :: [([Src.Comment], Src.Import)],
_infixes :: [A.Located Src.Infix],
_infixes :: ([Src.Comment], [A.Located Src.Infix]),
_decls :: [Decl.Decl]
}

Expand All @@ -71,9 +72,12 @@ chompModule projectType =
header <- chompHeader
let defaultImports = (if isCore projectType then [] else Imports.defaults)
(imports, commentsAfterImports) <- chompImports (fmap ([],) defaultImports) []
infixes <- if isKernel projectType then chompInfixes [] else return []
(infixes, commentsBeforeDecls) <-
if isKernel projectType
then fmap (first (commentsAfterImports,)) $ chompInfixes [] []
else return (([], []), commentsAfterImports)
let initialDecls =
case nonEmpty commentsAfterImports of
case nonEmpty commentsBeforeDecls of
Nothing -> []
Just comments -> [Decl.TopLevelComments comments]
decls <- specialize E.Declarations $ chompDecls initialDecls
Expand Down Expand Up @@ -203,14 +207,15 @@ chompDecls decls =
]
(reverse newDecls)

chompInfixes :: [A.Located Src.Infix] -> Parser E.Module [A.Located Src.Infix]
chompInfixes infixes =
chompInfixes :: [A.Located Src.Infix] -> [Src.Comment] -> Parser E.Module ([A.Located Src.Infix], [Src.Comment])
chompInfixes infixes commentsBefore =
oneOfWithFallback
[ do
binop <- Decl.infix_
chompInfixes (binop : infixes)
-- TODO: use commentsBefore
(binop, commentsAfter) <- Decl.infix_
chompInfixes (binop : infixes) commentsAfter
]
(reverse infixes)
(reverse infixes, commentsBefore)

-- MODULE DOC COMMENT

Expand Down
Loading

0 comments on commit c3a39dc

Please sign in to comment.