Merge pull request #165 from avh4/format-expose-constructors

robinheghan · web-flow · commit c3a39dc71779 · 2022-12-04T12:45:48.000+01:00
format: good things to fix before 0.2
diff --git a/compiler/src/AST/Source.hs b/compiler/src/AST/Source.hs
@@ -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
@@ -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
@@ -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_
@@ -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
diff --git a/compiler/src/Canonicalize/Expression.hs b/compiler/src/Canonicalize/Expression.hs
@@ -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)
@@ -258,7 +258,7 @@ addBindingsHelp bindings (A.At region pattern) =
       bindings
     Src.PStr _ ->
       bindings
-    Src.PInt _ ->
+    Src.PInt _ _ ->
       bindings
 
 -- BUILD BINDINGS GRAPH
@@ -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
diff --git a/compiler/src/Canonicalize/Module.hs b/compiler/src/Canonicalize/Module.hs
@@ -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)
diff --git a/compiler/src/Canonicalize/Pattern.hs b/compiler/src/Canonicalize/Pattern.hs
@@ -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]
diff --git a/compiler/src/Data/Utf8.hs b/compiler/src/Data/Utf8.hs
@@ -23,6 +23,7 @@ module Data.Utf8
     putVeryLong,
     --
     toChars,
+    toText,
     toBuilder,
     toEscapedBuilder,
     --
@@ -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)
@@ -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
diff --git a/compiler/src/Gren/Format.hs b/compiler/src/Gren/Format.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Werror=incomplete-patterns #-}
 {-# OPTIONS_GHC -Wno-error=unused-matches #-}
@@ -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_ =
@@ -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
@@ -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 =
@@ -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
@@ -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 $
@@ -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 =
@@ -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) =
@@ -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 =
diff --git a/compiler/src/Gren/Int.hs b/compiler/src/Gren/Int.hs
@@ -0,0 +1,4 @@
+module Gren.Int (IntFormat (..)) where
+
+data IntFormat = DecimalInt | HexInt
+  deriving (Show)
diff --git a/compiler/src/Gren/String.hs b/compiler/src/Gren/String.hs
@@ -5,6 +5,7 @@
 
 module Gren.String
   ( String,
+    StringFormat (..),
     toChars,
     fromChars,
     toBuilder,
@@ -31,6 +32,11 @@ type String =
 
 data GREN_STRING
 
+data StringFormat
+  = SingleLineString
+  | MultilineString
+  deriving (Show)
+
 -- HELPERS
 
 toChars :: String -> [Char]
diff --git a/compiler/src/Parse/Declaration.hs b/compiler/src/Parse/Declaration.hs
@@ -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
@@ -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)
diff --git a/compiler/src/Parse/Expression.hs b/compiler/src/Parse/Expression.hs
@@ -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 =
@@ -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
diff --git a/compiler/src/Parse/Module.hs b/compiler/src/Parse/Module.hs
@@ -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
@@ -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]
   }
 
@@ -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
@@ -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
 
diff --git a/compiler/src/Parse/Number.hs b/compiler/src/Parse/Number.hs
diff --git a/compiler/src/Parse/Pattern.hs b/compiler/src/Parse/Pattern.hs
diff --git a/compiler/src/Parse/String.hs b/compiler/src/Parse/String.hs
diff --git a/gren.cabal b/gren.cabal
diff --git a/tests/Integration/FormatSpec.hs b/tests/Integration/FormatSpec.hs
