Implement rendering of rewrite rule declarations

data/examples/declaration/rewrite-rule/basic-out.hs

@@ -0,0 +1,29 @@
+{-# RULES
+"fold/build" foldr k z (build g) = g k z
+  #-}
+
+{-# RULES
+"fusable/aux"
+  fusable x (aux y) =
+    faux x y
+  #-}
+
+{-# RULES
+"map/map"
+  map f
+    (map g xs) =
+    map
+      (f . g)
+      xs
+  #-}
+
+{-# RULES
+"++" xs ++ ys = augment (\c n -> foldr c n xs) ys
+"concat" xs `concat` ys = augment (\c n -> foldr c n xs) ys
+  #-}
+
+{-# RULES
+"++" xs ++ ys = augment (\c n -> foldr c n xs) ys
+"concat" xs `concat` ys = augment (\c n -> foldr c n xs) ys
+"map/Double" fmap f xs = foldr (++) f xs
+  #-}

data/examples/declaration/rewrite-rule/basic.hs

@@ -0,0 +1,27 @@
+{-# RULES
+"fold/build"  foldr k z (build g) = g k z
+  #-}
+
+{-# RULES
+"fusable/aux"
+    fusable x (aux y) = faux x y
+  #-}
+
+{-# RULES
+"map/map"
+  map f
+    (map g xs) = map
+    (f . g)
+    xs
+  #-}
+
+{-# RULES
+"++" xs ++ ys = augment (\c n -> foldr c n xs) ys
+"concat" xs `concat` ys = augment (\c n -> foldr c n xs) ys
+  #-}
+
+{-# RULES
+"++" xs ++ ys = augment (\c n -> foldr c n xs) ys;
+"concat" xs `concat` ys = augment (\c n -> foldr c n xs) ys;
+"map/Double" fmap f xs = foldr (++) f xs
+  #-}

data/examples/declaration/rewrite-rule/empty-out.hs

@@ -0,0 +1,3 @@
+{-# RULES
+
+  #-}

data/examples/declaration/rewrite-rule/empty.hs

@@ -0,0 +1,2 @@
+{-# RULES
+     #-}

data/examples/declaration/rewrite-rule/forall-out.hs

@@ -0,0 +1,9 @@
+{-# RULES
+"fold/build" forall k z. foldr k z (build g) = g k z
+  #-}
+
+{-# RULES
+"fusable/aux" forall x y.
+  fusable x (aux y) =
+    faux x y
+  #-}

data/examples/declaration/rewrite-rule/forall.hs

@@ -0,0 +1,8 @@
+{-# RULES
+"fold/build" forall k z . foldr k z (build g) = g k z
+  #-}
+
+{-# RULES
+"fusable/aux" forall x y.
+  fusable x (aux y) = faux x y
+  #-}

data/examples/declaration/rewrite-rule/phase-out.hs

@@ -0,0 +1,21 @@
+{-# RULES
+"map/map" [2]
+  map f
+    (map g xs) =
+    map
+      (f . g)
+      xs
+  #-}
+
+{-# RULES
+"map/map" [1] forall x y z.
+  map f
+    (map g xs) =
+    map
+      (f . g)
+      xs
+  #-}
+
+{-# RULES
+"++" [~1] forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys
+  #-}

data/examples/declaration/rewrite-rule/phase.hs

@@ -0,0 +1,19 @@
+{-# RULES
+"map/map" [2]
+  map f
+    (map g xs) = map
+    (f . g)
+    xs
+  #-}
+
+{-# RULES
+"map/map" [1] forall x y z.
+  map f
+    (map g xs) = map
+    (f . g)
+    xs
+  #-}
+
+{-# RULES
+"++" [~1] forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys
+  #-}

data/examples/declaration/rewrite-rule/prelude-out.hs

@@ -0,0 +1,74 @@
+{-# LANGUAGE MagicHash #-}
+
+{-# RULES
+"map/map" forall f g xs. map f (map g xs) = map (f . g) xs
+"map/append" forall f xs ys. map f (xs ++ ys) = map f xs ++ map f ys
+  #-}
+
+{-# RULES
+"fold/build" forall k z (g :: forall b. (a -> b -> b) -> b -> b).
+  foldr k z (build g) =
+    g k z
+"foldr/augment" forall k z xs (g :: forall b. (a -> b -> b) -> b -> b).
+  foldr k z (augment g xs) =
+    g k (foldr k z xs)
+"foldr/id" foldr (:) [] = \x -> x
+"foldr/app" [1] forall ys. foldr (:) ys = \xs -> xs ++ ys
+-- Only activate this from phase 1, because that's
+-- when we disable the rule that expands (++) into foldr
+
+-- The foldr/cons rule looks nice, but it can give disastrously
+-- bloated code when commpiling
+--      array (a,b) [(1,2), (2,2), (3,2), ...very long list... ]
+-- i.e. when there are very very long literal lists
+-- So I've disabled it for now. We could have special cases
+-- for short lists, I suppose.
+-- "foldr/cons" forall k z x xs. foldr k z (x:xs) = k x (foldr k z xs)
+"foldr/single" forall k z x. foldr k z [x] = k x z
+"foldr/nil" forall k z. foldr k z [] = z
+"augment/build" forall
+  (g :: forall b. (a -> b -> b) -> b -> b)
+  (h :: forall b. (a -> b -> b) -> b -> b).
+  augment g (build h) =
+    build (\c n -> g c (h c n))
+"augment/nil" forall (g :: forall b. (a -> b -> b) -> b -> b).
+  augment g [] =
+    build g
+  #-}
+
+{-# RULES
+"map" [~1] forall f xs. map f xs = build (\c n -> foldr (mapFB c f) n xs)
+"mapList" [1] forall f. foldr (mapFB (:) f) [] = map f
+"mapFB" forall c f g. mapFB (mapFB c f) g = mapFB c (f . g)
+  #-}
+
+{-# RULES
+"map/map" [~2] forall f g xs.
+  map f (map g xs) =
+    map (f . g) xs
+"f" op True y = False
+"g" op True y = False
+  #-}
+
+{-# RULES
+"x# `eqChar#` x#" forall x#. x# `eqChar#` x# = True
+"x# `neChar#` x#" forall x#. x# `neChar#` x# = False
+"x# `gtChar#` x#" forall x#. x# `gtChar#` x# = False
+"x# `geChar#` x#" forall x#. x# `geChar#` x# = True
+"x# `leChar#` x#" forall x#. x# `leChar#` x# = True
+"x# `ltChar#` x#" forall x#. x# `ltChar#` x# = False
+  #-}
+
+{-# RULES
+"unpack" [~1] forall a. unpackCString# a = build (unpackFoldrCString# a)
+"unpack-list" [1] forall a. unpackFoldrCString# a (:) [] = unpackCString# a
+"unpack-append" forall a n. unpackFoldrCString# a (:) n = unpackAppendCString# a n
+  #-}
+
+-- There's a built-in rule (in PrelRules.lhs) for
+--      unpackFoldr "foo" c (unpackFoldr "baz" c n)  =  unpackFoldr "foobaz" c n
+{-# RULES
+"foldr/build" forall f n (g :: forall b. (a -> b -> b) -> b -> b).
+  foldr f n (build g) =
+    g f n
+  #-}

data/examples/declaration/rewrite-rule/prelude.hs

@@ -0,0 +1,73 @@
+{-# LANGUAGE MagicHash  #-}
+
+{-# RULES
+"map/map"    forall f g xs.  map f (map g xs) = map (f.g) xs
+"map/append" forall f xs ys. map f (xs ++ ys) = map f xs ++ map f ys
+  #-}
+
+{-# RULES
+"fold/build"    forall k z (g::forall b. (a->b->b) -> b -> b) .
+                foldr k z (build g) = g k z
+
+"foldr/augment" forall k z xs (g::forall b. (a->b->b) -> b -> b) .
+                foldr k z (augment g xs) = g k (foldr k z xs)
+
+"foldr/id"                        foldr (:) [] = \x  -> x
+"foldr/app"     [1] forall ys. foldr (:) ys = \xs -> xs ++ ys
+        -- Only activate this from phase 1, because that's
+        -- when we disable the rule that expands (++) into foldr
+
+-- The foldr/cons rule looks nice, but it can give disastrously
+-- bloated code when commpiling
+--      array (a,b) [(1,2), (2,2), (3,2), ...very long list... ]
+-- i.e. when there are very very long literal lists
+-- So I've disabled it for now. We could have special cases
+-- for short lists, I suppose.
+-- "foldr/cons" forall k z x xs. foldr k z (x:xs) = k x (foldr k z xs)
+
+"foldr/single"  forall k z x. foldr k z [x] = k x z
+"foldr/nil"     forall k z.   foldr k z []  = z
+
+"augment/build" forall (g::forall b. (a->b->b) -> b -> b)
+                       (h::forall b. (a->b->b) -> b -> b) .
+                       augment g (build h) = build (\c n -> g c (h c n))
+"augment/nil"   forall (g::forall b. (a->b->b) -> b -> b) .
+                        augment g [] = build g
+ #-}
+
+{-# RULES
+"map"       [~1] forall f xs.   map f xs                = build (\c n -> foldr (mapFB c f) n xs)
+"mapList"   [1]  forall f.      foldr (mapFB (:) f) []  = map f
+"mapFB"     forall c f g.       mapFB (mapFB c f) g     = mapFB c (f.g)
+  #-}
+
+{-# RULES
+  "map/map" [~2]  forall f g xs.
+    map f (map g xs) = map (f.g) xs; "f" op True y = False;
+    "g" op True y = False
+#-}
+
+{-# RULES
+"x# `eqChar#` x#" forall x#. x# `eqChar#` x# = True
+"x# `neChar#` x#" forall x#. x# `neChar#` x# = False
+"x# `gtChar#` x#" forall x#. x# `gtChar#` x# = False
+"x# `geChar#` x#" forall x#. x# `geChar#` x# = True
+"x# `leChar#` x#" forall x#. x# `leChar#` x# = True
+"x# `ltChar#` x#" forall x#. x# `ltChar#` x# = False
+  #-}
+
+{-# RULES
+"unpack"       [~1] forall a   . unpackCString# a             = build (unpackFoldrCString# a)
+"unpack-list"  [1]  forall a   . unpackFoldrCString# a (:) [] = unpackCString# a
+"unpack-append"     forall a n . unpackFoldrCString# a (:) n  = unpackAppendCString# a n
+
+-- There's a built-in rule (in PrelRules.lhs) for
+--      unpackFoldr "foo" c (unpackFoldr "baz" c n)  =  unpackFoldr "foobaz" c n
+
+  #-}
+
+{-# RULES
+   "foldr/build"
+   forall f n (g ::  forall b. (a -> b -> b) -> b -> b).
+     foldr f n (build g) = g f n
+#-}

data/examples/declaration/rewrite-rule/type-signature-out.hs

@@ -0,0 +1,16 @@
+{-# RULES
+"fold/build" forall k z (g :: forall b. (a -> b -> b) -> b -> b). foldr k z (build g) = g k z
+  #-}
+
+{-# RULES
+"fold/build" forall
+  k
+  z
+  ( g
+    :: forall b. (a -> b -> b)
+    -> b
+    -> b
+  ).
+  foldr k z (build g) =
+    g k z
+  #-}

data/examples/declaration/rewrite-rule/type-signature.hs

@@ -0,0 +1,12 @@
+{-# RULES
+"fold/build" forall k z (g :: forall b. (a -> b -> b) -> b -> b). foldr k z (build g) = g k z
+  #-}
+
+{-# RULES
+"fold/build"
+  forall k z
+         (g :: forall b.
+           (a -> b -> b) -> b -> b).
+              foldr k z (build g) =
+              g k z
+  #-}

ormolu.cabal

@@ -70,6 +70,7 @@ library
                     , Ormolu.Printer.Meat.Declaration.Foreign
                     , Ormolu.Printer.Meat.Declaration.Instance
                     , Ormolu.Printer.Meat.Declaration.RoleAnnotation
+                    , Ormolu.Printer.Meat.Declaration.Rule
                     , Ormolu.Printer.Meat.Declaration.Signature
                     , Ormolu.Printer.Meat.Declaration.Splice
                     , Ormolu.Printer.Meat.Declaration.Type

src/Ormolu/Printer/Combinators.hs

@@ -296,7 +296,7 @@ pragma
 pragma pragmaText body = pragmaBraces $ do
   txt pragmaText
   breakpoint
-  inci body
+  body
 
 -- | Surround given entity by optional space before and a newline after, iff
 -- current layout is multiline.

src/Ormolu/Printer/Meat/Declaration.hs

@@ -22,6 +22,7 @@ import Ormolu.Printer.Meat.Declaration.Default
 import Ormolu.Printer.Meat.Declaration.Foreign
 import Ormolu.Printer.Meat.Declaration.Instance
 import Ormolu.Printer.Meat.Declaration.RoleAnnotation
+import Ormolu.Printer.Meat.Declaration.Rule
 import Ormolu.Printer.Meat.Declaration.Signature
 import Ormolu.Printer.Meat.Declaration.Splice
 import Ormolu.Printer.Meat.Declaration.Type
@@ -54,7 +55,7 @@ p_hsDecl style = \case
   ForD NoExt x -> p_foreignDecl x
   WarningD NoExt x -> p_warnDecls x
   AnnD NoExt x -> p_annDecl x
-  RuleD _ _ -> notImplemented "RuleD"
+  RuleD NoExt x -> p_ruleDecls x
   SpliceD NoExt x -> p_spliceDecl x
   DocD _ _ -> notImplemented "DocD"
   RoleAnnotD NoExt x -> p_roleAnnot x

src/Ormolu/Printer/Meat/Declaration/Annotation.hs

@@ -14,7 +14,7 @@ import Ormolu.Utils
 
 p_annDecl :: AnnDecl GhcPs -> R ()
 p_annDecl = \case
-  HsAnnotation NoExt _ annProv expr -> line . pragma "ANN" $ do
+  HsAnnotation NoExt _ annProv expr -> line . pragma "ANN" . inci $ do
     p_annProv annProv
     breakpoint
     located expr p_hsExpr

src/Ormolu/Printer/Meat/Declaration/Rule.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+
+module Ormolu.Printer.Meat.Declaration.Rule
+  ( p_ruleDecls
+  )
+where
+
+import BasicTypes
+import Control.Monad
+import FastString (unpackFS)
+import GHC
+import Ormolu.Printer.Combinators
+import Ormolu.Printer.Meat.Common
+import Ormolu.Printer.Meat.Declaration.Signature
+import Ormolu.Printer.Meat.Declaration.Value
+import Ormolu.Utils
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Text as T
+
+p_ruleDecls :: RuleDecls GhcPs -> R ()
+p_ruleDecls = \case
+  HsRules NoExt _ xs -> line $ pragma "RULES" $
+    velt' $ (located' p_ruleDecl) <$> xs
+  XRuleDecls NoExt -> notImplemented "XRuleDecls"
+
+p_ruleDecl :: RuleDecl GhcPs -> R ()
+p_ruleDecl = \case
+  HsRule NoExt ruleName activation ruleBndrs lhs rhs -> do
+    located ruleName p_ruleName
+    let gotBinders = not (null ruleBndrs)
+    when (visibleActivation activation || gotBinders) space
+    p_activation activation
+    when (visibleActivation activation && gotBinders) space
+    p_ruleBndrs ruleBndrs
+    breakpoint
+    inci $ do
+      located lhs p_hsExpr
+      txt " ="
+      inci $ do
+        breakpoint
+        located rhs p_hsExpr
+  XRuleDecl NoExt -> notImplemented "XRuleDecl"
+
+p_ruleName :: (SourceText, RuleName) -> R ()
+p_ruleName (_, name) = do
+  txt "\""
+  txt $ T.pack $ unpackFS $ name
+  txt "\""
+
+p_ruleBndrs :: [LRuleBndr GhcPs] -> R ()
+p_ruleBndrs bndrs =
+  forM_ (NE.nonEmpty bndrs) $ \bndrs_ne ->
+    switchLayout (combineSrcSpans' (getLoc <$> bndrs_ne)) $ do
+      txt "forall"
+      breakpoint
+      inci $ do
+        velt' (located' p_ruleBndr <$> bndrs)
+        txt "."
+
+p_ruleBndr :: RuleBndr GhcPs -> R ()
+p_ruleBndr = \case
+  RuleBndr NoExt x -> p_rdrName x
+  RuleBndrSig NoExt x hswc -> parens $ do
+    p_rdrName x
+    p_typeAscription hswc
+  XRuleBndr NoExt -> notImplemented "XRuleBndr"

src/Ormolu/Printer/Meat/Declaration/Signature.hs

@@ -8,6 +8,8 @@ module Ormolu.Printer.Meat.Declaration.Signature
   ( p_sigDecl
   , p_sigDecl'
   , p_typeAscription
+  , p_activation
+  , visibleActivation
   )
 where
 
@@ -106,6 +108,7 @@ p_inlineSig name InlinePragma {..} = pragmaBraces $ do
     NoUserInline -> notImplemented "NoUserInline"
   space
   p_activation inl_act
+  when (visibleActivation inl_act) space
   p_rdrName name
 
 p_specSig
@@ -117,6 +120,7 @@ p_specSig name ts InlinePragma {..} = pragmaBraces $ do
   txt "SPECIALIZE"
   space
   p_activation inl_act
+  when (visibleActivation inl_act) space
   p_rdrName name
   breakpoint
   inci $ do
@@ -134,15 +138,19 @@ p_activation = \case
     txt "[~"
     atom n
     txt "]"
-    space
   ActiveAfter _ n -> do
     txt "["
     atom n
     txt "]"
-    space
+
+visibleActivation :: Activation -> Bool
+visibleActivation = \case
+  NeverActive -> False
+  AlwaysActive -> False
+  _ -> True
 
 p_specInstSig :: LHsSigType GhcPs -> R ()
-p_specInstSig hsib = pragma "SPECIALIZE instance" $
+p_specInstSig hsib = pragma "SPECIALIZE instance" . inci $
   located (hsib_body hsib) p_hsType
 
 p_minimalSig
@@ -150,7 +158,7 @@ p_minimalSig
   -> R ()
 p_minimalSig =
   located' $ \booleanFormula ->
-    pragma "MINIMAL" (p_booleanFormula booleanFormula)
+    pragma "MINIMAL" (inci $ p_booleanFormula booleanFormula)
 
 p_booleanFormula
   :: BooleanFormula (Located RdrName) -- ^ Boolean formula
@@ -171,7 +179,7 @@ p_completeSig
   -> R ()
 p_completeSig cs' mty =
   located cs' $ \cs ->
-    pragma "COMPLETE" $ do
+    pragma "COMPLETE" . inci $ do
       velt (withSep comma p_rdrName cs)
       forM_ mty $ \ty -> do
         breakpoint
@@ -180,7 +188,7 @@ p_completeSig cs' mty =
           p_rdrName ty
 
 p_sccSig :: Located (IdP GhcPs) -> Maybe (Located StringLiteral) -> R ()
-p_sccSig loc literal = pragma "SCC" $ do
+p_sccSig loc literal = pragma "SCC" . inci $ do
   p_rdrName loc
   forM_ literal $ \x -> do
     breakpoint

src/Ormolu/Printer/Meat/Declaration/Warning.hs

@@ -32,13 +32,13 @@ p_moduleWarning wtxt = do
   let (pragmaText, lits) = warningText wtxt
   switchLayout (listSpan lits) $ do
     breakpoint
-    inci $ pragma pragmaText (p_lits lits)
+    inci $ pragma pragmaText (inci $ p_lits lits)
 
 p_topLevelWarning :: [Located RdrName] -> WarningTxt -> R ()
 p_topLevelWarning fnames wtxt = do
   let (pragmaText, lits) = warningText wtxt
   switchLayout (combineSrcSpans (listSpan fnames) (listSpan lits)) $ do
-    pragma pragmaText $ do
+    pragma pragmaText . inci $ do
       velt (withSep comma p_rdrName fnames)
       breakpoint
       p_lits lits