wip: printer

golden/print/flat

@@ -0,0 +1 @@
+(가 나 다 라)

golden/print/long

@@ -0,0 +1,4 @@
+(가
+ 나
+ 다
+ 라)

golden/print/null

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

golden/read/bool/read

@@ -0,0 +1,5 @@
+[ SynNone :< SimpleF ( SimpleBoolean True )
+, SynNone :< SimpleF ( SimpleBoolean True )
+, SynNone :< SimpleF ( SimpleBoolean False )
+, SynNone :< SimpleF ( SimpleBoolean False )
+]

golden/read/decimal/read

@@ -0,0 +1,9 @@
+[ SynNone :< SimpleF
+    ( SimpleNumber 45.0 )
+, SynNone :< SimpleF
+    ( SimpleNumber 5667.0 )
+, SynNone :< SimpleF
+    ( SimpleNumber
+        ( -123.0 )
+    )
+]

golden/read/list-dot-flat/read

@@ -0,0 +1,17 @@
+[ SynNone :< CompoundF
+    ( DotListF
+        (
+            ( SynNone :< SimpleF
+                ( SimpleSymbol "가" )
+            ) :|
+            [ SynNone :< SimpleF
+                ( SimpleSymbol "나" )
+            , SynNone :< SimpleF
+                ( SimpleSymbol "다" )
+            ]
+        )
+        ( SynNone :< SimpleF
+            ( SimpleSymbol "라" )
+        )
+    )
+]

golden/read/list-flat/read

@@ -0,0 +1,19 @@
+[ SynNone :< CompoundF
+    ( ListF Ordinary
+        [ SynNone :< SimpleF
+            ( SimpleSymbol "가" )
+        , SynNone :< SimpleF
+            ( SimpleSymbol "나" )
+        , SynNone :< SimpleF
+            ( SimpleSymbol "다" )
+        , SynNone :< SimpleF
+            ( SimpleSymbol "라" )
+        , SynNone :< SimpleF
+            ( SimpleNumber 1.0 )
+        , SynNone :< SimpleF
+            ( SimpleNumber 2.0 )
+        , SynNone :< SimpleF
+            ( SimpleNumber 3.0 )
+        ]
+    )
+]

golden/read/list/read

@@ -0,0 +1,40 @@
+[ SynNone :< CompoundF
+    ( DotListF
+        (
+            ( SynNone :< SimpleF
+                ( SimpleSymbol "a" )
+            ) :|
+            [ SynNone :< SimpleF
+                ( SimpleSymbol "b" )
+            , SynNone :< CompoundF
+                ( ListF Ordinary
+                    [ SynNone :< SimpleF
+                        ( SimpleSymbol "c" )
+                    , SynNone :< SimpleF
+                        ( SimpleSymbol "d" )
+                    ]
+                )
+            ]
+        )
+        ( SynNone :< CompoundF
+            ( ListF Ordinary
+                [ SynNone :< SimpleF
+                    ( SimpleSymbol "가" )
+                , SynNone :< CompoundF
+                    ( DotListF
+                        (
+                            ( SynNone :< SimpleF
+                                ( SimpleSymbol "나" )
+                            ) :| []
+                        )
+                        ( SynNone :< SimpleF
+                            ( SimpleSymbol "다" )
+                        )
+                    )
+                , SynNone :< SimpleF
+                    ( SimpleSymbol "라" )
+                ]
+            )
+        )
+    )
+]

golden/read/peculiar-identifier/read

@@ -0,0 +1,5 @@
+[ SynNone :< SimpleF
+    ( SimpleSymbol "+" )
+, SynNone :< SimpleF
+    ( SimpleSymbol "-" )
+]

golden/read/string/read

@@ -0,0 +1,3 @@
+[ SynNone :< SimpleF
+    ( SimpleString "가나다라" )
+]

golden/read/typical-identifier/read

@@ -0,0 +1,19 @@
+[ SynNone :< SimpleF
+    ( SimpleSymbol "abc" )
+, SynNone :< SimpleF
+    ( SimpleSymbol "bala-hwa$" )
+, SynNone :< SimpleF
+    ( SimpleSymbol "x!!!" )
+, SynNone :< SimpleF
+    ( SimpleSymbol "z" )
+, SynNone :< SimpleF
+    ( SimpleSymbol "z123" )
+, SynNone :< SimpleF
+    ( SimpleSymbol "나는너무졸리다" )
+, SynNone :< SimpleF
+    ( SimpleSymbol "學" )
+, SynNone :< SimpleF
+    ( SimpleSymbol "車室." )
+, SynNone :< SimpleF
+    ( SimpleSymbol "三個女人一臺戲。" )
+]

golden/reader/bool/read

@@ -1,9 +0,0 @@
-[ Fix
-    ( SimpleF ( Boolean True ) )
-, Fix
-    ( SimpleF ( Boolean True ) )
-, Fix
-    ( SimpleF ( Boolean False ) )
-, Fix
-    ( SimpleF ( Boolean False ) )
-]

golden/reader/decimal/read

@@ -1,15 +0,0 @@
-[ Fix
-    ( SimpleF
-        ( Number 45.0 )
-    )
-, Fix
-    ( SimpleF
-        ( Number 5667.0 )
-    )
-, Fix
-    ( SimpleF
-        ( Number
-            ( -123.0 )
-        )
-    )
-]

golden/reader/list-dot-flat/read

@@ -1,25 +0,0 @@
-[ Fix
-    ( CompoundF
-        ( DotListF
-            ( Fix
-                ( SimpleF
-                    ( Symbol "가" )
-                ) :|
-                [ Fix
-                    ( SimpleF
-                        ( Symbol "나" )
-                    )
-                , Fix
-                    ( SimpleF
-                        ( Symbol "다" )
-                    )
-                ]
-            )
-            ( Fix
-                ( SimpleF
-                    ( Symbol "라" )
-                )
-            )
-        )
-    )
-]

golden/reader/list-flat/read

@@ -1,35 +0,0 @@
-[ Fix
-    ( CompoundF
-        ( ListF
-            [ Fix
-                ( SimpleF
-                    ( Symbol "가" )
-                )
-            , Fix
-                ( SimpleF
-                    ( Symbol "나" )
-                )
-            , Fix
-                ( SimpleF
-                    ( Symbol "다" )
-                )
-            , Fix
-                ( SimpleF
-                    ( Symbol "라" )
-                )
-            , Fix
-                ( SimpleF
-                    ( Number 1.0 )
-                )
-            , Fix
-                ( SimpleF
-                    ( Number 2.0 )
-                )
-            , Fix
-                ( SimpleF
-                    ( Number 3.0 )
-                )
-            ]
-        )
-    )
-]

golden/reader/list/read

@@ -1,60 +0,0 @@
-[ Fix
-    ( CompoundF
-        ( DotListF
-            ( Fix
-                ( SimpleF
-                    ( Symbol "a" )
-                ) :|
-                [ Fix
-                    ( SimpleF
-                        ( Symbol "b" )
-                    )
-                , Fix
-                    ( CompoundF
-                        ( ListF
-                            [ Fix
-                                ( SimpleF
-                                    ( Symbol "c" )
-                                )
-                            , Fix
-                                ( SimpleF
-                                    ( Symbol "d" )
-                                )
-                            ]
-                        )
-                    )
-                ]
-            )
-            ( Fix
-                ( CompoundF
-                    ( ListF
-                        [ Fix
-                            ( SimpleF
-                                ( Symbol "가" )
-                            )
-                        , Fix
-                            ( CompoundF
-                                ( DotListF
-                                    ( Fix
-                                        ( SimpleF
-                                            ( Symbol "나" )
-                                        ) :| []
-                                    )
-                                    ( Fix
-                                        ( SimpleF
-                                            ( Symbol "다" )
-                                        )
-                                    )
-                                )
-                            )
-                        , Fix
-                            ( SimpleF
-                                ( Symbol "라" )
-                            )
-                        ]
-                    )
-                )
-            )
-        )
-    )
-]

golden/reader/peculiar-identifier/read

@@ -1,9 +0,0 @@
-[ Fix
-    ( SimpleF
-        ( Symbol "+" )
-    )
-, Fix
-    ( SimpleF
-        ( Symbol "-" )
-    )
-]

golden/reader/string/read

@@ -1,5 +0,0 @@
-[ Fix
-    ( SimpleF
-        ( String "가나다라" )
-    )
-]

golden/reader/typical-identifier/read

@@ -1,37 +0,0 @@
-[ Fix
-    ( SimpleF
-        ( Symbol "abc" )
-    )
-, Fix
-    ( SimpleF
-        ( Symbol "bala-hwa$" )
-    )
-, Fix
-    ( SimpleF
-        ( Symbol "x!!!" )
-    )
-, Fix
-    ( SimpleF
-        ( Symbol "z" )
-    )
-, Fix
-    ( SimpleF
-        ( Symbol "z123" )
-    )
-, Fix
-    ( SimpleF
-        ( Symbol "나는너무졸리다" )
-    )
-, Fix
-    ( SimpleF
-        ( Symbol "學" )
-    )
-, Fix
-    ( SimpleF
-        ( Symbol "車室." )
-    )
-, Fix
-    ( SimpleF
-        ( Symbol "三個女人一臺戲。" )
-    )
-]

gyehoek.cabal

@@ -74,7 +74,7 @@ library
     Gyehoek.Wasm
 
   build-depends:
-    , base                  ^>=4.21.2.0
+    , base                         ^>=4.21.2.0
     , binary
     , bytestring
     , comonad
@@ -97,6 +97,7 @@ library
     , ordered-containers
     , pretty-simple
     , prettyprinter
+    , prettyprinter-ansi-terminal
     , process
     , recursion-schemes
     , scientific
@@ -127,6 +128,7 @@ test-suite test
     Gyehoek.Test.Golden
     Gyehoek.Test.Scheme.Syntax
     Gyehoek.Test.Sexp
+    Gyehoek.Test.Sexp.Print
     Gyehoek.Test.Stack.VM
     Root
 

src/Gyehoek/Prelude.hs

@@ -16,6 +16,7 @@ module Gyehoek.Prelude
   , Hashable
   , NonEmpty((:|))
   , Natural
+  , (>>>)
   ) where
 
 import Control.Lens
@@ -35,4 +36,5 @@ import GHC.Stack (HasCallStack)
 import Data.Hashable (Hashable)
 import Data.List.NonEmpty (NonEmpty((:|)))
 import Numeric.Natural (Natural)
+import Control.Category ((>>>))
 

src/Gyehoek/Sexp/Print.hs

@@ -1,4 +1,75 @@
 module Gyehoek.Sexp.Print
-  (
+  ( printDatum
+  , printDatumW
   ) where
 
+import Gyehoek.Sexp.Syntax
+import Data.Text.Prettyprint.Doc
+import Data.Functor.Foldable
+import qualified Control.Comonad.Trans.Cofree as F
+import Prettyprinter.Util
+import Gyehoek.Prelude hiding (Simple, (:<))
+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)
+
+
+printDatum :: Datum -> Text
+printDatum = printDatumW 80
+
+printDatumW :: Int -> Datum -> Text
+printDatumW w =
+  prettyDatum 0
+  >>> layoutSmart opts
+  >>> reAnnotateS highlight
+  >>> ANSI.renderStrict
+  where
+    opts = LayoutOptions
+      { layoutPageWidth = AvailablePerLine w 1.0
+      }
+
+prettyDatum :: Int -> Datum -> Doc Syn
+prettyDatum depth = \case
+  syn :< SimpleF s -> annotate syn $ prettySimple depth s
+  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)
+        Ordinary; NSpecial _ -> pparen depth $
+          group . align . vsep $
+            prettyDatum (depth+1) <$> xs
+
+pparen depth = enclose (delim depth "(") (delim depth ")")
+delim depth = annotate (SynParen depth)
+
+delimited :: Int -> Doc Syn -> Doc Syn -> List (Doc Syn) -> Doc Syn
+delimited depth open close =
+  encloseSep (delim depth open) (delim depth close) softline
+
+prettySimple :: Int -> Simple -> Doc Syn
+prettySimple depth = \case
+  SimpleBoolean b -> annotate SynConstant $ if b then "#t" else "#f"
+  SimpleNumber n -> annotate SynConstant $ viaShow n
+  SimpleString s -> annotate SynString $ viaShow s
+  SimpleSymbol s -> pretty s
+
+rdpr n s = rd s >>= traverse_ \x -> do
+                                  putDocW n . prettyDatum 0 $ x
+                                  putStr "\n"
+
+putDoc :: Doc Syn -> IO ()
+putDoc = ANSI.renderIO stdout
+  . reAnnotateS highlight . layoutSmart defaultLayoutOptions . (<>"\n")
+
+highlight :: Syn -> AnsiStyle
+highlight = \case
+  SynBuiltin -> color Magenta <> italicized
+  SynParen n -> color $ rainbow ^?! ix n
+  _ -> mempty
+  where
+    rainbow = cycle [Red,Yellow,Green,Blue,Magenta,Cyan]

src/Gyehoek/Sexp/Read.hs

@@ -1,5 +1,7 @@
 module Gyehoek.Sexp.Read
   ( readFile
+  , readString
+  , rd
   ) where
 
 import Text.Megaparsec
@@ -25,13 +27,22 @@ newtype ReaderError = MkReaderError String
 instance Exception ReaderError where
   displayException (MkReaderError x) = x
 
+  -- temp
+rd = runEff . readString
+
 readFile :: IOE :> es => FilePath -> Eff es (List Datum)
 readFile f = do
   s <- liftIO . T.readFile $ f
   case runParser file f s of
     Right x -> pure x
     Left e -> do
-      -- liftIO . hPutStrLn stderr . errorBundlePretty $ e
+      liftIO . throw . MkReaderError . errorBundlePretty $ e
+
+readString :: IOE :> es => Text -> Eff es (List Datum)
+readString s = 
+  case runParser file "<none>" s of
+    Right x -> pure x
+    Left e -> do
       liftIO . throw . MkReaderError . errorBundlePretty $ e
 
 type P = Parsec Void Text
@@ -131,20 +142,20 @@ file = many datum <* eof
 
 datum :: P Datum
 datum = choice
-  [ Fix . CompoundF <$> compoundDatum
-  , Fix . SimpleF <$> simpleDatum
+  [ (SynNone :<) . CompoundF <$> compoundDatum
+  , (SynNone :<) . SimpleF <$> simpleDatum
   -- , labeled
   -- , labelRef
   ]
 
 simpleDatum :: P Simple
 simpleDatum = choice
-  [ Boolean <$> boolean
-  , Number <$> try number
-  -- , Character <$> character
-  , String <$> string
-  , Symbol <$> symbol
-  -- , Bytevector <$> bytevector
+  [ SimpleBoolean <$> boolean
+  , SimpleNumber <$> try number
+  -- , SimpleCharacter <$> character
+  , SimpleString <$> string
+  , SimpleSymbol <$> symbol
+  -- , SimpleBytevector <$> bytevector
   ]
 
 compoundDatum :: P Compound
@@ -155,9 +166,9 @@ compoundDatum = choice
 list :: P Compound
 list = label "list" . between lparen rparen $ do
   optional datum >>= \case
-    Nothing -> pure $ ListF []
+    Nothing -> pure $ ListF Ordinary []
     Just x -> do
       xs <- many datum
       optional (dot *> datum) >>= \case
-        Nothing -> pure $ ListF (x:xs)
+        Nothing -> pure $ ListF Ordinary (x:xs)
         Just y -> pure $ DotListF (x:|xs) y

src/Gyehoek/Sexp/Syntax.hs

@@ -12,6 +12,23 @@ module Gyehoek.Sexp.Syntax
   , Cofree((:<))
   , Fix(..)
   , Compound
+  , Indentation(..)
+  , Syn(..)
+  , pattern Simple
+  , pattern Compound
+  , pattern Labeled
+  , pattern LabelRef
+  , pattern Abbrev
+  , pattern Vector
+  , pattern DotList
+  , pattern Gyehoek.Sexp.Syntax.List
+  , adorn
+  , pattern Bytevector
+  , pattern Symbol
+  , pattern String
+  , pattern Character
+  , pattern Number
+  , pattern Boolean
   ) where
 
 import Language.Haskell.TH.Syntax (Lift)
@@ -35,17 +52,17 @@ data DatumF a
   deriving anyclass (NFData)
 
 data Simple
-  = Boolean Bool
-  | Number Scientific
-  | Character Char
-  | String Text
-  | Symbol Text
-  | Bytevector ByteString
+  = SimpleBoolean Bool
+  | SimpleNumber Scientific
+  | SimpleCharacter Char
+  | SimpleString Text
+  | SimpleSymbol Text
+  | SimpleBytevector ByteString
   deriving stock (Show, Eq, Data, Generic, Lift)
   deriving anyclass (NFData)
 
 data CompoundF a
-  = ListF (List a)
+  = ListF Indentation (List a)
   | DotListF (NonEmpty a) a
   | VectorF (List a)
   | AbbrevF Prefix a
@@ -69,10 +86,70 @@ newtype Label = MkLabel Natural
   deriving newtype (Eq, Ord, Show)
   deriving anyclass (NFData)
 
-deriveShow1 ''CompoundF
-deriveShow1 ''DatumF
+
+
+type Datum = Cofree DatumF Syn
+type Compound = CompoundF Datum
+
+data Indentation
+  = NSpecial Int
+  | Ordinary
+  deriving stock (Data, Eq, Generic, Show, Lift, Read)
+  deriving anyclass (NFData)
+
+data Syn
+  = SynMacro
+  | SynBuiltin
+  | SynProcedure
+  | SynParen Int
+  | SynString
+  | SynConstant
+  | SynNone
+  deriving (Show, Read)
 
 
 
-type Datum = Fix DatumF
-type Compound = CompoundF Datum
+deriveShow1 ''CompoundF
+deriveShow1 ''DatumF
+
+adorn :: Syn -> Datum -> Datum
+adorn syn (_ :< d) = syn :< d
+
+pattern Simple :: Simple -> Datum
+pattern Simple a <- _ :< SimpleF a
+  where Simple a = SynNone :< SimpleF a
+
+pattern Compound :: CompoundF Datum -> Datum
+pattern Compound a <- _ :< CompoundF a
+  where Compound a = SynNone :< CompoundF a
+
+pattern Labeled :: Label -> Datum -> Datum
+pattern Labeled l a <- _ :< LabeledF l a
+  where Labeled l a = SynNone :< LabeledF l a
+
+pattern LabelRef :: Label -> Datum
+pattern LabelRef l <- _ :< LabelRefF l
+  where LabelRef l = SynNone :< LabelRefF l
+
+pattern List :: List Datum -> Datum
+pattern List a <- _ :< CompoundF (ListF _ a)
+  where List a = SynNone :< CompoundF (ListF Ordinary a)
+
+pattern DotList :: NonEmpty Datum -> Datum -> Datum
+pattern DotList xs x <- _ :< CompoundF (DotListF xs x)
+  where DotList xs x = SynNone :< CompoundF (DotListF xs x)
+
+pattern Vector :: [Datum] -> Datum
+pattern Vector xs <- _ :< CompoundF (VectorF xs)
+  where Vector xs = SynNone :< CompoundF (VectorF xs)
+
+pattern Abbrev :: Prefix -> Datum -> Datum
+pattern Abbrev p a <- _ :< CompoundF (AbbrevF p a)
+  where Abbrev p a = SynNone :< CompoundF (AbbrevF p a)
+
+pattern Boolean a = Simple (SimpleBoolean a)
+pattern Number a = Simple (SimpleNumber a)
+pattern Character a = Simple (SimpleCharacter a)
+pattern String a = Simple (SimpleString a)
+pattern Symbol a = Simple (SimpleSymbol a)
+pattern Bytevector a = Simple (SimpleBytevector a)

test/Gyehoek/Test/Golden.hs

@@ -93,9 +93,9 @@ stackifyTests files = do
 
 test_reader :: IO TestTree
 test_reader = do
-  all_cases <- listDirectory "golden/reader"
+  all_cases <- listDirectory "golden/read"
   let tests = all_cases
-            & fmap ("golden/reader"</>)
+            & fmap ("golden/read"</>)
   pure . testGroup "reader" $ tests <&> \test ->
     let testname = takeFileName test
         scmfile = test </> "source.scm"

test/Gyehoek/Test/Sexp/Print.hs

@@ -0,0 +1,29 @@
+module Gyehoek.Test.Sexp.Print where
+
+import Test.Tasty (TestTree, testGroup, TestName)
+import Test.Tasty.HUnit
+import Gyehoek.Prelude
+import Gyehoek.Sexp.Syntax qualified as S
+import Gyehoek.Sexp.Print qualified as Sut
+import System.FilePath ((</>))
+import Test.Tasty.Silver
+
+
+tcase = tcaseW 80
+
+tcaseW :: Int -> TestName -> S.Datum -> TestTree
+tcaseW width name ast =
+  goldenVsAction
+    name
+    ("golden/print" </> name)
+    (pure $ Sut.printDatumW width ast)
+    id
+
+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
+      ]
+  ]