print begin

.dir-locals.el

@@ -8,4 +8,9 @@
   . ((eval
       . (progn (defun apply-cabal-fmt-h ()
                  (haskell-mode-buffer-apply-command "cabal-fmt"))
-               (add-hook 'before-save-hook #'apply-cabal-fmt-h nil t))))))
+               (add-hook 'before-save-hook #'apply-cabal-fmt-h nil t)))))
+ (nil
+  . ((eval
+      . (progn (defun display-ansi ()
+                 (interactive)
+                 (ansi-color-apply-on-region (point-min) (point-max))))))))

golden/print/begin-nonempty-thin

@@ -0,0 +1,4 @@
+(begin
+  책을
+  더
+  먹으세요~!)

golden/print/begin-nonempty-wide

@@ -0,0 +1,4 @@
+(begin
+  책을
+  더
+  먹으세요~!)

golden/print/lambda-nonempty-thin

@@ -0,0 +1,5 @@
+(lambda
+    (어간
+     어미)
+  (display
+   꾸깃))

golden/print/lambda-nonempty-wide

@@ -0,0 +1,2 @@
+(lambda (어간 어미)
+  (display 꾸깃))

golden/print/rainbow

@@ -0,0 +1 @@
+((((()))))

src/Gyehoek/Sexp/Print.hs

@@ -13,7 +13,7 @@ import Gyehoek.Sexp.Read (rd)
 import Data.Foldable (traverse_)
 import qualified Prettyprinter.Render.Terminal as ANSI
 import System.IO (stdout)
-import Prettyprinter.Render.Terminal (Color(..), color, italicized, AnsiStyle)
+import Prettyprinter.Render.Terminal (Color(..), color, italicized, AnsiStyle, bold)
 
 
 printDatum :: Datum -> Text
@@ -36,10 +36,16 @@ prettyDatum depth = \case
   syn :< CompoundF compound -> case compound of
     ListF indent xs ->
       case indent of
-        NSpecial 1 | special:body <- xs
-          -> pparen depth $
-              nest 2 $ prettyDatum (depth+1) special
-                   <+> vsep (prettyDatum (depth+1) <$> body)
+        NSpecial n | keyword:args <- xs ->
+          let (specialArgs,body) = splitAt n args
+          in pparen depth . nest 2 . vsep $
+              [ group . nest 2 . hcat $
+                [ prettyDatum (depth+1) keyword
+                , if null specialArgs then mempty else softline
+                , hsep $ prettyDatum (depth+1) <$> specialArgs
+                ]
+              , vsep $ prettyDatum (depth+1) <$> body
+              ]
         Ordinary; NSpecial _ -> pparen depth $
           group . align . vsep $
             prettyDatum (depth+1) <$> xs
@@ -68,7 +74,7 @@ putDoc = ANSI.renderIO stdout
 
 highlight :: Syn -> AnsiStyle
 highlight = \case
-  SynBuiltin -> color Magenta <> italicized
+  (SynBuiltin; SynMacro) -> color Magenta <> italicized <> bold
   SynParen n -> color $ rainbow ^?! ix n
   _ -> mempty
   where

src/Gyehoek/Sexp/Syntax.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ApplicativeDo #-}
 module Gyehoek.Sexp.Syntax
   ( DatumF(..)
   , Simple(..)
@@ -22,7 +23,10 @@ module Gyehoek.Sexp.Syntax
   , pattern Vector
   , pattern DotList
   , pattern Gyehoek.Sexp.Syntax.List
+  , syntax
+  , indentation
   , adorn
+  , indentWith
   , pattern Bytevector
   , pattern Symbol
   , pattern String
@@ -36,7 +40,7 @@ import Data.Scientific (Scientific)
 import Data.ByteString (ByteString)
 import Gyehoek.Prelude hiding ((:<), Simple)
 import Text.Megaparsec.Pos (SourcePos(..))
-import Control.Comonad.Cofree (Cofree((:<)))
+import Control.Comonad.Cofree (Cofree((:<)), _extract)
 import Data.Fix (Fix (..))
 import Data.Functor.Foldable
 import Text.Show.Deriving (deriveShow1)
@@ -112,9 +116,21 @@ data Syn
 deriveShow1 ''CompoundF
 deriveShow1 ''DatumF
 
+syntax :: Lens' Datum Syn
+syntax = _extract
+
+indentation :: Traversal' Datum Indentation
+indentation k (syn :< CompoundF (ListF ind xs)) = do
+  ind' <- k ind
+  pure $ syn :< CompoundF (ListF ind' xs)
+indentation k a = pure a
+
 adorn :: Syn -> Datum -> Datum
 adorn syn (_ :< d) = syn :< d
 
+indentWith :: Indentation -> Datum -> Datum
+indentWith = set indentation
+
 pattern Simple :: Simple -> Datum
 pattern Simple a <- _ :< SimpleF a
   where Simple a = SynNone :< SimpleF a

test/Gyehoek/Test/Sexp/Print.hs

@@ -19,11 +19,28 @@ tcaseW width name ast =
     (pure $ Sut.printDatumW width ast)
     id
 
+thinWide name x = testGroup name
+  [ tcase (name <> "-wide") x
+  , tcaseW 4 (name <> "-thin") x
+  ]
+
 test_print = testGroup "sexp pretty printer" $
   [ tcase "null" $ S.List []
-  , let x = S.List [ S.Symbol s | s <- ["가","나","다","라"] ]
-    in testGroup "simple list"
-      [ tcase "flat" x
-      , tcaseW 4 "long" x
-      ]
+  , thinWide "simple-list" $
+    S.List [ S.Symbol s | s <- ["가","나","다","라"] ]
+  , thinWide "begin-nonempty" $
+    S.indentWith (S.NSpecial 0) $
+    S.List [ S.adorn S.SynBuiltin $ S.Symbol "begin"
+           , S.Symbol "책을"
+           , S.Symbol "더"
+           , S.Symbol "먹으세요~!"
+           ]
+  , thinWide "lambda-nonempty" $
+    S.indentWith (S.NSpecial 1) $
+    S.List [ S.adorn S.SynBuiltin $ S.Symbol "lambda"
+           , S.List [S.Symbol "어간", S.Symbol "어미"]
+           , S.List [S.Symbol "display", S.Symbol "꾸깃"]
+           ]
+  , tcase "rainbow" $
+    S.List [S.List [S.List [S.List [S.List []]]]]
   ]