diff --git a/.dir-locals.el b/.dir-locals.el index 8348b19..fc1236c 100644 --- a/.dir-locals.el +++ b/.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)))))))) diff --git a/golden/print/begin-nonempty-thin b/golden/print/begin-nonempty-thin new file mode 100644 index 0000000..17862c2 --- /dev/null +++ b/golden/print/begin-nonempty-thin @@ -0,0 +1,4 @@ +(begin + 책을 + 더 + 먹으세요~!) \ No newline at end of file diff --git a/golden/print/begin-nonempty-wide b/golden/print/begin-nonempty-wide new file mode 100644 index 0000000..17862c2 --- /dev/null +++ b/golden/print/begin-nonempty-wide @@ -0,0 +1,4 @@ +(begin + 책을 + 더 + 먹으세요~!) \ No newline at end of file diff --git a/golden/print/lambda-thin b/golden/print/lambda-thin new file mode 100644 index 0000000..78cb74c --- /dev/null +++ b/golden/print/lambda-thin @@ -0,0 +1,5 @@ +(lambda + (어간 + 어미) + (display + 꾸깃)) \ No newline at end of file diff --git a/golden/print/lambda-wide b/golden/print/lambda-wide new file mode 100644 index 0000000..b989bcc --- /dev/null +++ b/golden/print/lambda-wide @@ -0,0 +1,2 @@ +(lambda (어간 어미) + (display 꾸깃)) \ No newline at end of file diff --git a/golden/print/rainbow b/golden/print/rainbow new file mode 100644 index 0000000..9ba5d84 --- /dev/null +++ b/golden/print/rainbow @@ -0,0 +1 @@ +((((())))) \ No newline at end of file diff --git a/golden/print/long b/golden/print/simple-list-thin similarity index 100% rename from golden/print/long rename to golden/print/simple-list-thin diff --git a/golden/print/flat b/golden/print/simple-list-wide similarity index 100% rename from golden/print/flat rename to golden/print/simple-list-wide diff --git a/src/Gyehoek/Sexp/Print.hs b/src/Gyehoek/Sexp/Print.hs index 9d721fa..7d0421c 100644 --- a/src/Gyehoek/Sexp/Print.hs +++ b/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 diff --git a/src/Gyehoek/Sexp/Syntax.hs b/src/Gyehoek/Sexp/Syntax.hs index 45be9ab..e8c2def 100644 --- a/src/Gyehoek/Sexp/Syntax.hs +++ b/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 diff --git a/test/Gyehoek/Test/Sexp/Print.hs b/test/Gyehoek/Test/Sexp/Print.hs index 4933e75..0cbfc57 100644 --- a/test/Gyehoek/Test/Sexp/Print.hs +++ b/test/Gyehoek/Test/Sexp/Print.hs @@ -19,11 +19,31 @@ tcaseW width name ast = (pure $ Sut.printDatumW width ast) id +thinWide name x = testGroup name + [ tcase (name <> "-wide") x + , tcaseW 4 (name <> "-thin") x + ] + +datumBegin xs = S.indentWith (S.NSpecial 0) . S.List $ + (S.adorn S.SynBuiltin . S.Symbol $ "begin") : xs + +datumLambda formals body = + S.indentWith (S.NSpecial 1) . S.List $ + (S.adorn S.SynBuiltin . S.Symbol $ "lambda") : formals : body + 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) $ + datumBegin [ S.Symbol "책을" + , S.Symbol "더" + , S.Symbol "먹으세요~!" + ] + , thinWide "lambda" $ + datumLambda (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 []]]]] ]