Add the format pragma (#2150)

* Closes #2117

src/Juvix/Data/Pragmas.hs

@@ -15,19 +15,28 @@ newtype PragmaUnroll = PragmaUnroll
   }
   deriving stock (Show, Eq, Ord, Data, Generic)
 
+newtype PragmaFormat = PragmaFormat
+  { _pragmaFormat :: Bool
+  }
+  deriving stock (Show, Eq, Ord, Data, Generic)
+
 data Pragmas = Pragmas
   { _pragmasInline :: Maybe PragmaInline,
-    _pragmasUnroll :: Maybe PragmaUnroll
+    _pragmasUnroll :: Maybe PragmaUnroll,
+    _pragmasFormat :: Maybe PragmaFormat
   }
   deriving stock (Show, Eq, Ord, Data, Generic)
 
 makeLenses ''PragmaUnroll
+makeLenses ''PragmaFormat
 makeLenses ''Pragmas
 
 instance Hashable PragmaInline
 
 instance Hashable PragmaUnroll
 
+instance Hashable PragmaFormat
+
 instance Hashable Pragmas
 
 instance FromJSON Pragmas where
@@ -37,6 +46,7 @@ instance FromJSON Pragmas where
       parsePragmas = do
         _pragmasInline <- keyMay "inline" parseInline
         _pragmasUnroll <- keyMay "unroll" parseUnroll
+        _pragmasFormat <- keyMay "format" parseFormat
         return Pragmas {..}
 
       parseInline :: Parse YamlError PragmaInline
@@ -59,6 +69,11 @@ instance FromJSON Pragmas where
         _pragmaUnrollDepth <- asIntegral
         return PragmaUnroll {..}
 
+      parseFormat :: Parse YamlError PragmaFormat
+      parseFormat = do
+        _pragmaFormat <- asBool
+        return PragmaFormat {..}
+
 -- | The Semigroup `<>` is used to propagate pragmas from an enclosing context.
 -- For example, if `p1` are the pragmas declared for a module `M`, and `p2` the
 -- pragmas declared for a function `f` inside `M`, then the actual pragmas for
@@ -67,12 +82,14 @@ instance Semigroup Pragmas where
   p1 <> p2 =
     Pragmas
       { _pragmasInline = p2 ^. pragmasInline <|> p1 ^. pragmasInline,
-        _pragmasUnroll = p2 ^. pragmasUnroll <|> p1 ^. pragmasUnroll
+        _pragmasUnroll = p2 ^. pragmasUnroll <|> p1 ^. pragmasUnroll,
+        _pragmasFormat = p2 ^. pragmasFormat <|> p1 ^. pragmasFormat
       }
 
 instance Monoid Pragmas where
   mempty =
     Pragmas
       { _pragmasInline = Nothing,
-        _pragmasUnroll = Nothing
+        _pragmasUnroll = Nothing,
+        _pragmasFormat = Nothing
       }

src/Juvix/Formatter.hs

@@ -90,7 +90,7 @@ formatProject p = do
       res <- combineResults <$> mapM format juvixFiles
       return (res, RecurseFilter (\hasJuvixYaml d -> not hasJuvixYaml && not (isHiddenDirectory d)))
 
-formatPath :: Member ScopeEff r => Path Abs File -> Sem r (NonEmpty AnsiText)
+formatPath :: Member ScopeEff r => Path Abs File -> Sem r (Maybe (NonEmpty AnsiText))
 formatPath p = do
   res <- scopeFile p
   formatScoperResult res
@@ -109,25 +109,38 @@ formatResultFromContents ::
   forall r.
   Members '[Output FormattedFileInfo] r =>
   Text ->
-  NonEmpty AnsiText ->
+  Maybe (NonEmpty AnsiText) ->
   Path Abs File ->
   Sem r FormatResult
-formatResultFromContents originalContents formattedContents filepath
-  | originalContents /= ansiPlainText formattedContents = do
-      output
-        ( FormattedFileInfo
-            { _formattedFileInfoPath = filepath,
-              _formattedFileInfoContentsAnsi = formattedContents
-            }
-        )
-      return FormatResultFail
-  | otherwise = return FormatResultOK
+formatResultFromContents originalContents mfc filepath =
+  case mfc of
+    Just formattedContents
+      | originalContents /= ansiPlainText formattedContents -> do
+          output
+            ( FormattedFileInfo
+                { _formattedFileInfoPath = filepath,
+                  _formattedFileInfoContentsAnsi = formattedContents
+                }
+            )
+          return FormatResultFail
+      | otherwise -> return FormatResultOK
+    Nothing ->
+      return FormatResultOK
 
-formatScoperResult :: Scoper.ScoperResult -> Sem r (NonEmpty AnsiText)
+formatScoperResult :: Scoper.ScoperResult -> Sem r (Maybe (NonEmpty AnsiText))
 formatScoperResult res = do
   let cs = res ^. Scoper.comments
       formattedModules = run (runReader cs (mapM formatTopModule (res ^. Scoper.resultModules)))
-  return formattedModules
+  case res ^. Scoper.mainModule . modulePragmas of
+    Just pragmas ->
+      case pragmas ^. withLocParam . withSourceValue . pragmasFormat of
+        Just PragmaFormat {..}
+          | not _pragmaFormat ->
+              return Nothing
+        _ ->
+          return (Just formattedModules)
+    Nothing ->
+      return (Just formattedModules)
   where
     formatTopModule :: Member (Reader Comments) r => Module 'Scoped 'ModuleTop -> Sem r AnsiText
     formatTopModule m = do

test/Scope/Positive.hs

@@ -238,5 +238,9 @@ tests =
     PosTest
       "Iterators"
       $(mkRelDir ".")
-      $(mkRelFile "Iterators.juvix")
+      $(mkRelFile "Iterators.juvix"),
+    PosTest
+      "Format pragma"
+      $(mkRelDir ".")
+      $(mkRelFile "FormatPragma.juvix")
   ]

tests/positive/FormatPragma.juvix

@@ -0,0 +1,14 @@
+{-# format: false #-}
+module FormatPragma;
+
+open import Stdlib.Prelude;
+
+-- Bam, bam!
+
+-- unformatted module
+
+fun : {A B C D : Type} -> (A -> A) -> (B -> C -> D) -> (A -> B -> C) -> (D -> C -> C) -> A -> B -> C;
+fun f g h i a b :=
+  i
+    (g b (h (f a) b))
+    (h a b);