더 간단한 신택스 annotations

golden/print/begin-nonempty-thin

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

golden/print/begin-nonempty-wide

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

golden/print/lambda-thin

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

golden/print/lambda-wide

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

golden/print/simple-list-thin

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

golden/print/simple-list-wide

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

golden/read/bool/read

@@ -1,6 +1,5 @@
 [ MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/bool/source.scm"
             , sourceLine = Pos 1
@@ -9,8 +8,7 @@
         )
     } :< SimpleF ( SimpleBoolean True )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/bool/source.scm"
             , sourceLine = Pos 1
@@ -19,8 +17,7 @@
         )
     } :< SimpleF ( SimpleBoolean True )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/bool/source.scm"
             , sourceLine = Pos 1
@@ -29,8 +26,7 @@
         )
     } :< SimpleF ( SimpleBoolean False )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/bool/source.scm"
             , sourceLine = Pos 1

golden/read/decimal/read

@@ -1,6 +1,5 @@
 [ MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/decimal/source.scm"
             , sourceLine = Pos 1
@@ -10,8 +9,7 @@
     } :< SimpleF
     ( SimpleNumber 45.0 )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/decimal/source.scm"
             , sourceLine = Pos 1
@@ -21,8 +19,7 @@
     } :< SimpleF
     ( SimpleNumber 5667.0 )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/decimal/source.scm"
             , sourceLine = Pos 1

golden/read/list-dot-flat/read

@@ -1,6 +1,5 @@
 [ MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/list-dot-flat/source.scm"
             , sourceLine = Pos 1
@@ -11,8 +10,7 @@
     ( DotListF
         (
             ( MkAnn
-                { syntax = SynNone
+                { position = Just
-                , position = Just
                     ( SourcePos
                         { sourceName = "golden/read/list-dot-flat/source.scm"
                         , sourceLine = Pos 1
@@ -23,8 +21,7 @@
                 ( SimpleSymbol "가" )
             ) :|
             [ MkAnn
-                { syntax = SynNone
+                { position = Just
-                , position = Just
                     ( SourcePos
                         { sourceName = "golden/read/list-dot-flat/source.scm"
                         , sourceLine = Pos 1
@@ -34,8 +31,7 @@
                 } :< SimpleF
                 ( SimpleSymbol "나" )
             , MkAnn
-                { syntax = SynNone
+                { position = Just
-                , position = Just
                     ( SourcePos
                         { sourceName = "golden/read/list-dot-flat/source.scm"
                         , sourceLine = Pos 1
@@ -47,8 +43,7 @@
             ]
         )
         ( MkAnn
-            { syntax = SynNone
+            { position = Just
-            , position = Just
                 ( SourcePos
                     { sourceName = "golden/read/list-dot-flat/source.scm"
                     , sourceLine = Pos 1

golden/read/list-flat/read

@@ -1,6 +1,5 @@
 [ MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/list-flat/source.scm"
             , sourceLine = Pos 1
@@ -8,10 +7,9 @@
             }
         )
     } :< CompoundF
-    ( ListF Ordinary
+    ( ListF StyleData
         [ MkAnn
-            { syntax = SynNone
+            { position = Just
-            , position = Just
                 ( SourcePos
                     { sourceName = "golden/read/list-flat/source.scm"
                     , sourceLine = Pos 1
@@ -21,8 +19,7 @@
             } :< SimpleF
             ( SimpleSymbol "가" )
         , MkAnn
-            { syntax = SynNone
+            { position = Just
-            , position = Just
                 ( SourcePos
                     { sourceName = "golden/read/list-flat/source.scm"
                     , sourceLine = Pos 1
@@ -32,8 +29,7 @@
             } :< SimpleF
             ( SimpleSymbol "나" )
         , MkAnn
-            { syntax = SynNone
+            { position = Just
-            , position = Just
                 ( SourcePos
                     { sourceName = "golden/read/list-flat/source.scm"
                     , sourceLine = Pos 1
@@ -43,8 +39,7 @@
             } :< SimpleF
             ( SimpleSymbol "다" )
         , MkAnn
-            { syntax = SynNone
+            { position = Just
-            , position = Just
                 ( SourcePos
                     { sourceName = "golden/read/list-flat/source.scm"
                     , sourceLine = Pos 1
@@ -54,8 +49,7 @@
             } :< SimpleF
             ( SimpleSymbol "라" )
         , MkAnn
-            { syntax = SynNone
+            { position = Just
-            , position = Just
                 ( SourcePos
                     { sourceName = "golden/read/list-flat/source.scm"
                     , sourceLine = Pos 1
@@ -65,8 +59,7 @@
             } :< SimpleF
             ( SimpleNumber 1.0 )
         , MkAnn
-            { syntax = SynNone
+            { position = Just
-            , position = Just
                 ( SourcePos
                     { sourceName = "golden/read/list-flat/source.scm"
                     , sourceLine = Pos 1
@@ -76,8 +69,7 @@
             } :< SimpleF
             ( SimpleNumber 2.0 )
         , MkAnn
-            { syntax = SynNone
+            { position = Just
-            , position = Just
                 ( SourcePos
                     { sourceName = "golden/read/list-flat/source.scm"
                     , sourceLine = Pos 1

golden/read/list/read

@@ -1,6 +1,5 @@
 [ MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/list/source.scm"
             , sourceLine = Pos 1
@@ -11,8 +10,7 @@
     ( DotListF
         (
             ( MkAnn
-                { syntax = SynNone
+                { position = Just
-                , position = Just
                     ( SourcePos
                         { sourceName = "golden/read/list/source.scm"
                         , sourceLine = Pos 1
@@ -23,8 +21,7 @@
                 ( SimpleSymbol "a" )
             ) :|
             [ MkAnn
-                { syntax = SynNone
+                { position = Just
-                , position = Just
                     ( SourcePos
                         { sourceName = "golden/read/list/source.scm"
                         , sourceLine = Pos 1
@@ -34,8 +31,7 @@
                 } :< SimpleF
                 ( SimpleSymbol "b" )
             , MkAnn
-                { syntax = SynNone
+                { position = Just
-                , position = Just
                     ( SourcePos
                         { sourceName = "golden/read/list/source.scm"
                         , sourceLine = Pos 1
@@ -43,10 +39,9 @@
                         }
                     )
                 } :< CompoundF
-                ( ListF Ordinary
+                ( ListF StyleData
                     [ MkAnn
-                        { syntax = SynNone
+                        { position = Just
-                        , position = Just
                             ( SourcePos
                                 { sourceName = "golden/read/list/source.scm"
                                 , sourceLine = Pos 1
@@ -56,8 +51,7 @@
                         } :< SimpleF
                         ( SimpleSymbol "c" )
                     , MkAnn
-                        { syntax = SynNone
+                        { position = Just
-                        , position = Just
                             ( SourcePos
                                 { sourceName = "golden/read/list/source.scm"
                                 , sourceLine = Pos 1
@@ -71,8 +65,7 @@
             ]
         )
         ( MkAnn
-            { syntax = SynNone
+            { position = Just
-            , position = Just
                 ( SourcePos
                     { sourceName = "golden/read/list/source.scm"
                     , sourceLine = Pos 1
@@ -80,10 +73,9 @@
                     }
                 )
             } :< CompoundF
-            ( ListF Ordinary
+            ( ListF StyleData
                 [ MkAnn
-                    { syntax = SynNone
+                    { position = Just
-                    , position = Just
                         ( SourcePos
                             { sourceName = "golden/read/list/source.scm"
                             , sourceLine = Pos 1
@@ -93,8 +85,7 @@
                     } :< SimpleF
                     ( SimpleSymbol "가" )
                 , MkAnn
-                    { syntax = SynNone
+                    { position = Just
-                    , position = Just
                         ( SourcePos
                             { sourceName = "golden/read/list/source.scm"
                             , sourceLine = Pos 1
@@ -105,8 +96,7 @@
                     ( DotListF
                         (
                             ( MkAnn
-                                { syntax = SynNone
+                                { position = Just
-                                , position = Just
                                     ( SourcePos
                                         { sourceName = "golden/read/list/source.scm"
                                         , sourceLine = Pos 1
@@ -118,8 +108,7 @@
                             ) :| []
                         )
                         ( MkAnn
-                            { syntax = SynNone
+                            { position = Just
-                            , position = Just
                                 ( SourcePos
                                     { sourceName = "golden/read/list/source.scm"
                                     , sourceLine = Pos 1
@@ -131,8 +120,7 @@
                         )
                     )
                 , MkAnn
-                    { syntax = SynNone
+                    { position = Just
-                    , position = Just
                         ( SourcePos
                             { sourceName = "golden/read/list/source.scm"
                             , sourceLine = Pos 1

golden/read/meta-expression/read

@@ -1,6 +1,5 @@
 [ MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/meta-expression/source.scm"
             , sourceLine = Pos 1

golden/read/meta-splice-expression/read

@@ -1,6 +1,5 @@
 [ MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/meta-splice-expression/source.scm"
             , sourceLine = Pos 1

golden/read/meta-splice-variable/read

@@ -1,6 +1,5 @@
 [ MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/meta-splice-variable/source.scm"
             , sourceLine = Pos 1

golden/read/meta-variable/read

@@ -1,6 +1,5 @@
 [ MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/meta-variable/source.scm"
             , sourceLine = Pos 1

golden/read/peculiar-identifier-dot/read

@@ -1,6 +1,5 @@
 [ MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/peculiar-identifier-dot/source.scm"
             , sourceLine = Pos 1
@@ -10,8 +9,7 @@
     } :< SimpleF
     ( SimpleSymbol "..." )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/peculiar-identifier-dot/source.scm"
             , sourceLine = Pos 2
@@ -21,8 +19,7 @@
     } :< SimpleF
     ( SimpleSymbol ".." )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/peculiar-identifier-dot/source.scm"
             , sourceLine = Pos 3
@@ -32,8 +29,7 @@
     } :< SimpleF
     ( SimpleSymbol ".abc" )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/peculiar-identifier-dot/source.scm"
             , sourceLine = Pos 4
@@ -43,8 +39,7 @@
     } :< SimpleF
     ( SimpleSymbol "....abcc" )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/peculiar-identifier-dot/source.scm"
             , sourceLine = Pos 5
@@ -54,8 +49,7 @@
     } :< SimpleF
     ( SimpleSymbol ".++-" )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/peculiar-identifier-dot/source.scm"
             , sourceLine = Pos 6

golden/read/peculiar-identifier-sign/read

@@ -1,6 +1,5 @@
 [ MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/peculiar-identifier-sign/source.scm"
             , sourceLine = Pos 1
@@ -10,8 +9,7 @@
     } :< SimpleF
     ( SimpleSymbol "+" )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/peculiar-identifier-sign/source.scm"
             , sourceLine = Pos 1
@@ -21,8 +19,7 @@
     } :< SimpleF
     ( SimpleSymbol "-" )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/peculiar-identifier-sign/source.scm"
             , sourceLine = Pos 3
@@ -32,8 +29,7 @@
     } :< SimpleF
     ( SimpleSymbol "+." )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/peculiar-identifier-sign/source.scm"
             , sourceLine = Pos 3
@@ -43,8 +39,7 @@
     } :< SimpleF
     ( SimpleSymbol "+.." )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/peculiar-identifier-sign/source.scm"
             , sourceLine = Pos 3
@@ -54,8 +49,7 @@
     } :< SimpleF
     ( SimpleSymbol "-." )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/peculiar-identifier-sign/source.scm"
             , sourceLine = Pos 3
@@ -65,8 +59,7 @@
     } :< SimpleF
     ( SimpleSymbol "-...abc" )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/peculiar-identifier-sign/source.scm"
             , sourceLine = Pos 3

golden/read/string/read

@@ -1,6 +1,5 @@
 [ MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/string/source.scm"
             , sourceLine = Pos 1

golden/read/typical-identifier-token/read

@@ -1,6 +1,5 @@
 [ MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/typical-identifier-token/source.scm"
             , sourceLine = Pos 1
@@ -10,8 +9,7 @@
     } :< SimpleF
     ( SimpleSymbol "abc" )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/typical-identifier-token/source.scm"
             , sourceLine = Pos 1
@@ -21,8 +19,7 @@
     } :< SimpleF
     ( SimpleString "xyz" )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/typical-identifier-token/source.scm"
             , sourceLine = Pos 2
@@ -32,8 +29,7 @@
     } :< SimpleF
     ( SimpleSymbol "수학" )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/typical-identifier-token/source.scm"
             , sourceLine = Pos 2
@@ -41,10 +37,9 @@
             }
         )
     } :< CompoundF
-    ( ListF Ordinary
+    ( ListF StyleData
         [ MkAnn
-            { syntax = SynNone
+            { position = Just
-            , position = Just
                 ( SourcePos
                     { sourceName = "golden/read/typical-identifier-token/source.scm"
                     , sourceLine = Pos 2

golden/read/typical-identifier/read

@@ -1,6 +1,5 @@
 [ MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/typical-identifier/source.scm"
             , sourceLine = Pos 1
@@ -10,8 +9,7 @@
     } :< SimpleF
     ( SimpleSymbol "abc" )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/typical-identifier/source.scm"
             , sourceLine = Pos 1
@@ -21,8 +19,7 @@
     } :< SimpleF
     ( SimpleSymbol "bala-hwa$" )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/typical-identifier/source.scm"
             , sourceLine = Pos 1
@@ -32,8 +29,7 @@
     } :< SimpleF
     ( SimpleSymbol "x!!!" )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/typical-identifier/source.scm"
             , sourceLine = Pos 1
@@ -43,8 +39,7 @@
     } :< SimpleF
     ( SimpleSymbol "z" )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/typical-identifier/source.scm"
             , sourceLine = Pos 1
@@ -54,8 +49,7 @@
     } :< SimpleF
     ( SimpleSymbol "z123" )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/typical-identifier/source.scm"
             , sourceLine = Pos 1
@@ -65,8 +59,7 @@
     } :< SimpleF
     ( SimpleSymbol "나는너무졸리다" )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/typical-identifier/source.scm"
             , sourceLine = Pos 1
@@ -76,8 +69,7 @@
     } :< SimpleF
     ( SimpleSymbol "學" )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/typical-identifier/source.scm"
             , sourceLine = Pos 3
@@ -87,8 +79,7 @@
     } :< SimpleF
     ( SimpleSymbol "車室." )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/typical-identifier/source.scm"
             , sourceLine = Pos 5

gyehoek.cabal

@@ -26,6 +26,7 @@ common ghcstuffs
   ghc-options:
     -Wall -fdefer-type-errors -fno-show-valid-hole-fits
     -fdefer-out-of-scope-variables -threaded
+    -Wno-name-shadowing -Wno-partial-type-signatures
 
   default-extensions:
     BlockArguments
@@ -54,6 +55,7 @@ executable gyehoek
 library
   import:           ghcstuffs, ghcstuffs-dev
   ghc-options:      -fplugin=Effectful.Plugin
+  -- build-tool-depends: retrie:retrie
 
   -- cabal-fmt: expand src
   exposed-modules:

src/Gyehoek/CPS/Syntax.hs

@@ -5,6 +5,8 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{- HLINT ignore "Avoid lambda using `infix`" -}
+{- HLINT ignore "Redundant $" -}
 module Gyehoek.CPS.Syntax
   ( Val(..)
   , Kappa(..)
@@ -59,15 +61,12 @@ import Data.Monoid (Endo)
 import Data.Functor.Foldable.TH
 import Data.Data.Lens (uniplate)
 import Gyehoek.Prelude hiding (op)
-import Gyehoek.Sexp (Datum)
+import Gyehoek.Sexp (G, (:-)(..), Datum)
-import Gyehoek.Sexp (G, (:-)(..))
 import qualified Data.InvertibleGrammar.Base as IG
 import Gyehoek.GenSym (Gen)
 import Data.String (IsString)
 import Control.Applicative
 import qualified Data.HashMap.Strict as H
-import GHC.Records (HasField (..))
-import Data.Bifunctor
 
 -- Data types
 
@@ -103,6 +102,7 @@ data Obj
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
 
+pattern ObjLabel :: Label -> Obj
 pattern ObjLabel l = ObjImm (ImmLabel l)
 
 -- | a heap object.
@@ -188,7 +188,7 @@ pattern Halt1 x = ExpContinue (ValLabel "halt") [x]
 data Def = DefConstant Name Exp
   deriving (Show, Generic, Data)
 
-data Program = MkProgram
+newtype Program = MkProgram
   { body :: Lambda
   }
   deriving (Show, Generic, Data)
@@ -272,7 +272,7 @@ instance S.DatumIso Imm where
 
 instance S.DatumIso Label where
   datumIso = S.with \g -> S.coproduct
-    [ S.decorate S.SynConstant >>> S.datumIso @Name >>> S.prismIso
+    [ S.datumIso @Name >>> S.prismIso
           (S.expected "label")
           (prefixed @Name "$")
     , S.list $ S.el (S.sym "$") >>> S.el (S.datumIso @Name)
@@ -281,7 +281,7 @@ instance S.DatumIso Label where
 
 instance S.DatumIso Reg where
   datumIso = S.with \g ->
-    S.decorate S.SynVariable >>> S.datumIso @Name >>> S.prismIso
+    S.datumIso @Name >>> S.prismIso
       (S.expected "register")
       (prefixed @Name "%")
     >>> g
@@ -342,9 +342,9 @@ instance S.DatumIso Exp where
     $ S.With (. app)
     $ S.End
     where
-      continue = S.list $
+      continue = S.listWithStyle (S.StyleSyntax 1) $
-        S.el (S.decorate S.SynBuiltin >>> S.sym "continue")
+        S.el (S.sym "continue")
-        >>> S.el (S.decorate S.SynProcedure >>> S.datumIso)
+        >>> S.el S.datumIso
         >>> S.rest S.datumIso
       letrec = S.letLike "letrec" S.datumIso S.datumIso S.datumIso
       if_ = S.ifLike "if"
@@ -365,8 +365,8 @@ instance S.DatumIso Exp where
         >>> S.el (S.datumIso @Kexp)
         >>> S.rest (S.datumIso @Val)
         >>> S.onTail S.swap
-      builtin = S.list $
+      builtin = S.listWithStyle (S.StyleSyntax 1) $
-        S.el (S.decorate S.SynBuiltin >>> S.sym "builtin")
+        S.el (S.sym "builtin")
         >>> S.el (builtinDatumIso id (S.datumIso @Val))
         >>> S.el S.datumIso
 
@@ -414,15 +414,9 @@ cps = S.makeSx' [| toCPS |]
 
 
 
-deleteFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
-deleteFrom = flip $ foldr HS.delete
-
 insertFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
 insertFrom = flip $ foldr HS.insert
 
-toHashSetOf :: Hashable a => Getting (Endo (HashSet a)) s a -> s -> HashSet a
-toHashSetOf l = foldrOf l HS.insert mempty
-
 class Free a where
   free :: a -> HashSet Name
   free = freeWithBound mempty

src/Gyehoek/Language/Common.hs

@@ -59,6 +59,4 @@ instance Prefixed Name where
 --- DatumIsos
 
 instance S.DatumIso Name where
-  datumIso = S.decorate S.SynVariable
+  datumIso = S.symbol >>> S.iso coerce coerce
-    >>> S.symbol
-    >>> S.iso coerce coerce

src/Gyehoek/Scheme/Expand.hs

@@ -90,7 +90,7 @@ hashSetGrammar g =
 instance S.DatumIso Key where
   datumIso = S.with \g ->
     S.list
-      ( S.el (S.symBuiltin "@")
+      ( S.el (S.sym "@")
       >>> S.el (S.datumIso @Name)
       >>> S.el (hashSetGrammar S.datumIso)
       )
@@ -130,7 +130,7 @@ anykw s = S.Flip $ S.PartialIso
 
 prim_if :: S.DatumIso e => S.DatumGrammar (PrimIf e)
 prim_if = S.with \g ->
-  S.listWithIndentation (NSpecial 1)
+  S.listWithStyle (StyleSyntax 1)
     (S.el (anykw "if")
     >>> S.el S.datumIso
     >>> S.el S.datumIso
@@ -145,7 +145,7 @@ prim_lambda = S.with \g ->
 prim_let
   :: forall e. S.DatumIso e => S.DatumGrammar (PrimLet e)
 prim_let = S.with \g ->
-  (S.listWithIndentation (NSpecial 1) $
+  (S.listWithStyle (StyleSyntax 1) $
     S.el (anykw "let")
     >>> optEl (S.datumIso @Name)
     >>> S.el (S.list $ S.rest $ S.datumIso @(Name,e))
@@ -154,7 +154,7 @@ prim_let = S.with \g ->
 
 prim_let_syntax :: S.DatumIso e => S.DatumGrammar (PrimLetSyntax e)
 prim_let_syntax = S.with \g ->
-  (S.listWithIndentation (NSpecial 1) $
+  (S.listWithStyle (StyleSyntax 1) $
     S.el (anykw "let-syntax")
     >>> S.el (S.list $ S.rest $ S.datumIso)
     >>> S.rest S.datumIso)
@@ -163,10 +163,10 @@ prim_let_syntax = S.with \g ->
 instance S.DatumIso Bind where
   datumIso = S.match
     $ S.With (\g ->
-      S.list (S.el (S.symBuiltin "L") >>> S.el S.datumIso >>> S.el S.datumIso)
+      S.list (S.el (S.sym "L") >>> S.el S.datumIso >>> S.el S.datumIso)
       >>> g)
     $ S.With (\g ->
-      S.list (S.el (S.symBuiltin "G") >>> S.el S.datumIso)
+      S.list (S.el (S.sym "G") >>> S.el S.datumIso)
       >>> g)
     $ S.End
 

src/Gyehoek/Scheme/Expand/Old.hs

@@ -90,7 +90,7 @@ hashSetGrammar g =
 instance S.DatumIso Key where
   datumIso = S.with \g ->
     S.list
-      ( S.el (S.symBuiltin "@")
+      ( S.el (S.sym "@")
       >>> S.el (S.datumIso @Name)
       >>> S.el (hashSetGrammar S.datumIso)
       )
@@ -130,7 +130,7 @@ anykw s = S.Flip $ S.PartialIso
 
 prim_if :: S.DatumIso e => S.DatumGrammar (PrimIf e)
 prim_if = S.with \g ->
-  S.listWithIndentation (NSpecial 1)
+  S.listWithStyle (StyleSyntax 1)
     (S.el (anykw "if")
     >>> S.el S.datumIso
     >>> S.el S.datumIso
@@ -145,7 +145,7 @@ prim_lambda = S.with \g ->
 prim_let
   :: forall e. S.DatumIso e => S.DatumGrammar (PrimLet e)
 prim_let = S.with \g ->
-  (S.listWithIndentation (NSpecial 1) $
+  (S.listWithStyle (StyleSyntax 1) $
     S.el (anykw "let")
     >>> optEl (S.datumIso @Name)
     >>> S.el (S.list $ S.rest $ S.datumIso @(Name,e))
@@ -154,7 +154,7 @@ prim_let = S.with \g ->
 
 prim_let_syntax :: S.DatumIso e => S.DatumGrammar (PrimLetSyntax e)
 prim_let_syntax = S.with \g ->
-  (S.listWithIndentation (NSpecial 1) $
+  (S.listWithStyle (StyleSyntax 1) $
     S.el (anykw "let-syntax")
     >>> S.el (S.list $ S.rest $ S.datumIso)
     >>> S.rest S.datumIso)
@@ -163,10 +163,10 @@ prim_let_syntax = S.with \g ->
 instance S.DatumIso Bind where
   datumIso = S.match
     $ S.With (\g ->
-      S.list (S.el (S.symBuiltin "L") >>> S.el S.datumIso >>> S.el S.datumIso)
+      S.list (S.el (S.sym "L") >>> S.el S.datumIso >>> S.el S.datumIso)
       >>> g)
     $ S.With (\g ->
-      S.list (S.el (S.symBuiltin "G") >>> S.el S.datumIso)
+      S.list (S.el (S.sym "G") >>> S.el S.datumIso)
       >>> g)
     $ S.End
 

src/Gyehoek/Scheme/Syntax.hs

@@ -11,6 +11,8 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE ViewPatterns #-}
+{- HLINT ignore "Avoid lambda using `infix`" -}
+{- HLINT ignore "Redundant $" -}
 module Gyehoek.Scheme.Syntax
   ( Name(..)
   , Builtin(..)
@@ -36,8 +38,6 @@ module Gyehoek.Scheme.Syntax
   )
   where
 
-import Data.List (intersperse)
-import Effectful
 import Prelude hiding ((.), id)
 import Control.Category
 import Gyehoek.Sexp qualified as GS
@@ -50,12 +50,7 @@ import Data.Functor.Foldable hiding (fold)
 import qualified Data.HashSet as HS
 import Data.Foldable (fold, toList)
 import Language.Haskell.TH.Quote (QuasiQuoter)
-import Effectful.FileSystem (runFileSystem)
-import qualified Effectful.FileSystem.IO as FS
-import qualified Data.Text.Encoding as T
-import qualified Effectful.FileSystem.IO.ByteString as FB
 import qualified Data.Set.Ordered as O
-import Gyehoek.Sexp.Grammar qualified as Sexp
 import Gyehoek.Sexp.Grammar qualified as S
 import Gyehoek.Sexp.Grammar (DatumIso, G, DataIso, (:-)((:-)))
 import Gyehoek.Prelude
@@ -247,9 +242,7 @@ makeBaseFunctor ''Exp
 
 
 instance DatumIso Name where
-  datumIso = S.decorate S.SynVariable
+  datumIso = S.symbol >>> S.iso coerce coerce
-    >>> S.symbol
-    >>> S.iso coerce coerce
 
 builtinDatumIso
   :: (Text -> Text)
@@ -315,9 +308,9 @@ instance DatumIso Def where
   
 instance DatumIso Trans where
   datumIso = S.with \g ->
-    S.listWithIndentation
+    S.listWithStyle
-      (S.NSpecial 1)
+      (S.StyleSyntax 1)
-      ( S.el (S.symBuiltin "syntax-rules")
+      ( S.el (S.sym "syntax-rules")
       >>> S.Iso (\(ctx:-t) -> ctx:-"...":-t) (\(ctx:-_:-t) -> ctx:-t)
       >>> S.el (S.list $ S.rest (S.datumIso @Name))
       >>> S.rest (S.datumIso @Rule)
@@ -339,8 +332,8 @@ instance DatumIso Exp where
     $ S.With (\app -> app . S.list (S.el S.datumIso >>> S.rest S.datumIso))
     $ S.End
     where
-      letsyntax = S.listWithIndentation (S.NSpecial 1) $
+      letsyntax = S.listWithStyle (S.StyleSyntax 1) $
-        S.el (S.symBuiltin "let-syntax")
+        S.el (S.sym "let-syntax")
         >>> S.el (S.list $ S.rest $ S.datumIso)
         >>> S.el S.datumIso
       lam = S.lambdaLike S.lambdaKeyword S.datumIso (S.el S.datumIso)
@@ -481,16 +474,16 @@ instance DatumIso ImportSet where
     $ S.With (imp "rename" >>>)
     $ S.End
     where
-      imp s = S.list $ S.el (S.symBuiltin s)
+      imp s = S.list $ S.el (S.sym s)
         >>> S.el S.datumIso >>> S.restData S.dataIso
       imp' s = S.list $
-        S.el (S.symBuiltin s)
+        S.el (S.sym s)
         >>> S.el S.datumIso
         >>> S.el S.datumIso
 
 instance DatumIso ImportDecl where
   datumIso = S.with \decl ->
-    S.list (S.el (S.symBuiltin "import") >>> S.restData S.dataIso)
+    S.list (S.el (S.sym "import") >>> S.restData S.dataIso)
     >>> decl
 
 instance DataIso Program where

src/Gyehoek/Sexp/Grammar/Base.hs

@@ -1,3 +1,4 @@
+{- HLINT ignore "Avoid lambda" -}
 -- | cribbed from sexp-grammar:Language.SexpGrammar.Base
 module Gyehoek.Sexp.Grammar.Base
   ( module Gyehoek.Sexp.Syntax
@@ -8,12 +9,11 @@ module Gyehoek.Sexp.Grammar.Base
   , Grammar(..)
   , DatumGrammar
   , DataGrammar
-  , Grammar
   , ListContext(..)
   , (:-)((:-))
   -- * lists
   , list
-  , listWithIndentation
+  , listWithStyle
   , el
   , rest
   , restData
@@ -23,6 +23,7 @@ module Gyehoek.Sexp.Grammar.Base
   , headTagged1'
   , headTagged1
   , headTagged2
+  , headTagged2'
   -- * atoms
   , simple
   , string
@@ -33,24 +34,22 @@ module Gyehoek.Sexp.Grammar.Base
   , integer
   , int
   , unreadable
-  -- ** symbols
-  , symBuiltin
   -- * TODO: sort lol
   , prismIso
-  , isoIso, decorate
+  , isoIso
   , snoced
   , letLike
   , ifLike
   , lambdaLike
   , lambdaKeyword
   , kappaKeyword
-  , beginLike, headTagged2', dottedList, reifyContext, recontextualise, decontextualise
+  , beginLike
+  , dottedList
+  , reifyContext, recontextualise, decontextualise, redecorate
   ) where
 
 import Data.InvertibleGrammar
 import Data.InvertibleGrammar.Base
-import Data.InvertibleGrammar.Base as Re
-  ( Grammar(..))
 import Data.InvertibleGrammar.Combinators
 import Gyehoek.Prelude hiding (flipped, traversed, iso, cons, coerced, Iso, Simple, simple)
 import Gyehoek.Sexp.Syntax hiding (position)
@@ -58,7 +57,6 @@ import Gyehoek.Sexp.Print (printDatum')
 import Data.Scientific (Scientific)
 import qualified Data.Scientific as Sci
 import qualified Data.Text as T
-import Control.Monad.RWS (modify)
 import qualified Data.List.NonEmpty as NE
 import Data.Foldable (toList)
 
@@ -89,14 +87,6 @@ locate =
     (\(_ :- t) -> t)
     (\t -> noAnn :- t)
 
-modifyAnn :: (Ann -> Ann) -> G (Datum :- t) (Datum :- t)
-modifyAnn f = Iso
-  (\(d:-t) -> (d & ann %~ f) :- t)
-  (\(d:-t) -> (d & ann %~ f) :- t)
-
-decorate :: Syn -> G (Datum :- t) (Datum :- t)
-decorate s = modifyAnn $ #syntax .~ s
-
 newtype ListContext = MkListContext { inner :: List Datum }
 
 unexpectedSimple :: Simple -> Mismatch
@@ -108,7 +98,7 @@ unexpectedDatum = unexpected . printDatum'
 list
   :: G (ListContext :- t) (ListContext :- t')
   -> G (Datum :- t) t'
-list = listWithIndentation Ordinary
+list = listWithStyle StyleData
 
 -- |
 -- >>> let grammar = with \g -> dottedList (el int) int >>> g
@@ -143,11 +133,11 @@ dottedList g final = begin >>> Dive (onTail (g >>> end) >>> final)
            [] -> Right t
            d:_ -> Left $ unexpectedDatum d)
 
-listWithIndentation
+listWithStyle
-  :: Indentation
+  :: Style
   -> G (ListContext :- t) (ListContext :- t')
   -> G (Datum :- t) t'
-listWithIndentation ind g = begin >>> Dive (g >>> end)
+listWithStyle ind g = begin >>> Dive (g >>> end)
   where
     begin = locate >>> partialOsi
       (\case
@@ -378,33 +368,36 @@ int = integer >>> iso fromIntegral fromIntegral
 
 -- high-level combinators
 
+redecorate :: Style -> G (Datum :- t) t' -> G (Datum :- t) t'
+redecorate sty g = iso (styleWith sty) (styleWith sty) >>> g
+
 headTagged0 :: Text -> G (Datum :- t) t
-headTagged0 s = list $ el (symProcedure s)
+headTagged0 s = listWithStyle StyleCode $ el (sym s)
 
 headTagged0' :: Text -> DatumGrammar a -> G (Datum :- t) (List a :- t)
-headTagged0' s gt = list $ el (symProcedure s) >>> rest gt
+headTagged0' s gt = listWithStyle StyleCode $ el (sym s) >>> rest gt
 
 headTagged1 :: Text -> DatumGrammar a -> G (Datum :- t) (a :- t)
-headTagged1 s g1 = list $ el (symProcedure s) >>> el g1
+headTagged1 s g1 = listWithStyle StyleCode $ el (sym s) >>> el g1
 
 headTagged1'
   :: Text
   -> DatumGrammar a -> DatumGrammar b
   -> G (Datum :- t) (List b :- a :- t)
-headTagged1' s g1 gt = list $ el (symProcedure s) >>> el g1 >>> rest gt
+headTagged1' s g1 gt = list $ el (sym s) >>> el g1 >>> rest gt
 
 headTagged2
   :: Text
   -> DatumGrammar a -> DatumGrammar b
   -> G (Datum :- t) (b :- a :- t)
-headTagged2 s g1 g2 = list $ el (symProcedure s) >>> el g1 >>> el g2
+headTagged2 s g1 g2 = listWithStyle StyleCode $ el (sym s) >>> el g1 >>> el g2
 
 headTagged2'
   :: Text
   -> DatumGrammar a -> DatumGrammar b -> DatumGrammar c
   -> G (Datum :- t) (List c :- b :- a :- t)
 headTagged2' s g1 g2 gt =
-  list $ el (symProcedure s) >>> el g1 >>> el g2 >>> rest gt
+  listWithStyle StyleCode $ el (sym s) >>> el g1 >>> el g2 >>> rest gt
 
 ifLike
   -- | keyword
@@ -417,12 +410,8 @@ ifLike
   -> DatumGrammar c
   -> G (Datum :- t) (c :- b :- a :- t)
 ifLike kw c t f =
-  listWithIndentation (NSpecial 1) $
+  listWithStyle (StyleSyntax 1) $
-    el (symBuiltin kw) >>> el c >>> el t >>> el f
+    el (sym kw) >>> el c >>> el t >>> el f
-
-symBuiltin, symProcedure :: Text -> G (Datum :- t) t
-symBuiltin s = decorate SynBuiltin >>> sym s
-symProcedure s = decorate SynProcedure >>> sym s
 
 letLike
   :: Text
@@ -430,8 +419,8 @@ letLike
   -> (forall t. G (Datum :- t) (b :- t))
   -> G (Datum :- List (a, b) :- t1) t2
   -> G (Datum :- t1) t2
-letLike kw name rhs e = listWithIndentation (NSpecial 1) $
+letLike kw name rhs e = listWithStyle (StyleSyntax 1) $
-  el (symBuiltin kw) >>> el bindings >>> el e
+  el (sym kw) >>> el bindings >>> el e
   where
     bindings = list $ rest binding
     binding :: G (Datum :- t) ((_, _) :- t)
@@ -442,8 +431,8 @@ lambdaLike
   -> G (Datum :- t1) (a :- t2)
   -> G (ListContext :- a :- t2) (ListContext :- t3)
   -> G (Datum :- t1) t3
-lambdaLike kw formals body = listWithIndentation (NSpecial 1) $
+lambdaLike kw formals body = listWithStyle (StyleSyntax 1) $
-  el (decorate SynBuiltin >>> kw)
+  el kw
   >>> el formals
   >>> body
 
@@ -458,8 +447,8 @@ beginLike
   -> G (ListContext :- t) (ListContext :- t')
   -> G (Datum :- t) t'
 beginLike kw g =
-  listWithIndentation (NSpecial 0) $
+  listWithStyle (StyleSyntax 0) $
-    el (symBuiltin kw) >>> g
+    el (sym kw) >>> g
 
 -- | define a printed syntax for an object which cannot be read.
 unreadable

src/Gyehoek/Sexp/Print.hs

@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
 module Gyehoek.Sexp.Print
   ( printDatum
   , printDatumW
@@ -6,26 +7,34 @@ module Gyehoek.Sexp.Print
   , printData'
   , htmlDatum
   , htmlData
+  , putDoc
   ) where
 
 import Gyehoek.Sexp.Syntax
 import Prettyprinter
-import Data.Functor.Foldable
+import Gyehoek.Prelude hiding (Simple)
-import qualified Control.Comonad.Trans.Cofree as F
-import Prettyprinter.Util
-import Gyehoek.Prelude hiding (Simple, (:<))
-import Data.Foldable (traverse_, toList)
 import qualified Prettyprinter.Render.Terminal as ANSI
 import System.IO (stdout)
 import Prettyprinter.Render.Terminal (Color(..), color, italicized, AnsiStyle, bold, colorDull)
 import Prettyprinter.Render.Text (renderStrict)
-import qualified Data.Scientific as Sci
 import Data.List (intersperse)
 import Lucid
 import Prettyprinter.Render.Util.SimpleDocTree (treeForm)
 import Prettyprinter.Lucid (renderHtml)
+import Data.Foldable (toList)
+import qualified Data.Scientific as Sci
 
 
+data Syn
+  = SynSyntax
+  | SynProcedure
+  | SynParen Int
+  | SynString
+  | SynConstant
+  | SynVariable
+  | SynNone
+  deriving (Show, Read, Data, Generic, Eq)
+
 printDatum' :: Datum -> Text
 printDatum' =
   prettyDatum 0
@@ -83,7 +92,7 @@ printDatumW w =
 
 prettyDatum :: Int -> Datum -> Doc Syn
 prettyDatum depth datum = case datum of
-  Simple simp -> annotate (datum ^. syntax) $ prettySimple depth simp
+  Simple simp -> prettySimple depth simp
   DotList xs x ->
     pparen depth . group . align $
       vsep [ vsep (prettyDatum (depth+1) <$> toList xs)
@@ -91,35 +100,33 @@ prettyDatum depth datum = case datum of
            , prettyDatum (depth+1) x
            ]
       
-  List' indent xs ->
+  List' sty xs -> case sty of
-    case indent of
+    StyleSyntax n | keyword:args <- xs ->
-      NSpecial n | keyword:args <- xs ->
+      let (specialArgs,body) = splitAt n args
-        let (specialArgs,body) = splitAt n args
+      in pparen depth . nest 2 . vsep $
-        in pparen depth . nest 2 . vsep $
+          [ group . nest 2 . hcat $
-            [ group . nest 2 . hcat $
+            [ annotate SynSyntax $ prettyDatum (depth+1) keyword
-              [ prettyDatum (depth+1) keyword
+            , if null specialArgs then mempty else softline
-              , if null specialArgs then mempty else softline
+            , hsep $ prettyDatum (depth+1) <$> specialArgs
-              , hsep $ prettyDatum (depth+1) <$> specialArgs
-              ]
-            , vsep $ prettyDatum (depth+1) <$> body
             ]
-      Ordinary; NSpecial _ -> pparen depth $
+          , vsep $ prettyDatum (depth+1) <$> body
-        group . align . vsep $
+          ]
-          prettyDatum (depth+1) <$> xs
+    StyleCode | f:args <- xs -> pparen depth $
+      group . align . vsep . (_head %~ annotate SynProcedure) $
+        prettyDatum (depth+1) <$> xs
+    StyleData; StyleSyntax _; StyleCode -> pparen depth $
+      group . align . vsep $
+        prettyDatum (depth+1) <$> xs
   _ -> error [i|unimplemented: #{datum}|]
 
 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 ->
+  SimpleNumber n -> n
-    Sci.floatingOrInteger n
+    & Sci.floatingOrInteger @Double @Integer
     & either viaShow viaShow
     & annotate SynConstant
   SimpleString s -> annotate SynString $ viaShow s
@@ -132,7 +139,7 @@ putDoc = ANSI.renderIO stdout
 
 highlightAnsi :: Syn -> AnsiStyle
 highlightAnsi = \case
-  (SynBuiltin; SynMacro) -> color Magenta <> italicized <> bold
+  SynSyntax -> color Magenta <> italicized <> bold
   SynProcedure -> color Blue
   SynConstant -> color Yellow
   SynParen n -> colorDull $ rainbow ^?! ix n
@@ -144,8 +151,7 @@ highlightHtml :: Syn -> Html () -> Html ()
 highlightHtml syn = span_ [class_ synClass]
   where
     synClass = case syn of
-      SynBuiltin -> "syn-builtin"
+      SynSyntax -> "syn-builtin"
-      SynMacro -> "syn-macro"
       SynConstant -> "syn-constant"
       SynString -> "syn-string"
       SynProcedure -> "syn-procedure"

src/Gyehoek/Sexp/Read.hs

@@ -254,9 +254,9 @@ compoundDatum = choice
 list :: P Compound
 list = label "list" . between lparen rparen $ do
   optional datum >>= \case
-    Nothing -> pure $ ListF Ordinary []
+    Nothing -> pure $ ListF StyleData []
     Just x -> do
       xs <- many datum
       optional (dot *> datum) >>= \case
-        Nothing -> pure $ ListF Ordinary (x:xs)
+        Nothing -> pure $ ListF StyleData (x:xs)
         Just y -> pure $ DotListF (x:|xs) y

src/Gyehoek/Sexp/Syntax.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE ApplicativeDo #-}
+{- HLINT ignore "Use newtype instead of data" -}
 module Gyehoek.Sexp.Syntax
   ( DatumF(..)
   , Simple(..)
@@ -13,8 +14,7 @@ module Gyehoek.Sexp.Syntax
   , Cofree((:<))
   , Fix(..)
   , Compound
-  , Indentation(..)
+  , Style(..)
-  , Syn(..)
   , pattern Simple
   , pattern Compound
   , pattern Labeled
@@ -25,10 +25,8 @@ module Gyehoek.Sexp.Syntax
   , pattern Vector
   , pattern DotList
   , pattern Gyehoek.Sexp.Syntax.List
-  , syntax
+  , style
-  , indentation
+  , styleWith
-  , adorn
-  , indentWith
   , pattern Unreadable
   , pattern Bytevector
   , pattern Symbol
@@ -45,10 +43,10 @@ module Gyehoek.Sexp.Syntax
   , stripAnn
   ) where
 
-import Language.Haskell.TH.Syntax (Lift (lift), liftData)
+import Language.Haskell.TH.Syntax (Lift (lift))
 import Data.Scientific (Scientific)
 import Data.ByteString (ByteString)
-import Gyehoek.Prelude hiding ((:<), Simple)
+import Gyehoek.Prelude hiding (Simple)
 import Text.Megaparsec.Pos (SourcePos(..), sourcePosPretty)
 import Control.Comonad.Cofree (Cofree((:<)), _extract, _unwrap)
 import Data.Fix (Fix (..))
@@ -88,7 +86,7 @@ data Simple
   deriving anyclass (NFData)
 
 data CompoundF a
-  = ListF Indentation (List a)
+  = ListF Style (List a)
   | DotListF (NonEmpty a) a
   | VectorF (List a)
   | AbbrevF Prefix a
@@ -122,33 +120,21 @@ newtype Label = MkLabel Natural
 type Datum = Cofree DatumF Ann
 type Compound = CompoundF Datum
 
-data Indentation
+data Style
-  = NSpecial Int
+  = StyleSyntax Int
-  | Ordinary
+  | StyleCode
+  | StyleData
   deriving stock (Data, Eq, Generic, Show, Lift, Read)
   deriving anyclass (NFData)
 
-data Syn
-  = SynMacro
-  | SynBuiltin
-  | SynProcedure
-  | SynParen Int
-  | SynString
-  | SynConstant
-  | SynVariable
-  | SynNone
-  deriving (Show, Read, Data, Generic, Eq, Lift)
-
 data Ann = MkAnn
-  { syntax :: Syn
+  { position :: Maybe SourcePos
-  , position :: Maybe SourcePos
   }
   deriving (Show, Data, Eq, Generic)
 
 noAnn :: Ann
 noAnn = MkAnn
-  { syntax = SynNone
+  { position = Nothing
-  , position = Nothing
   }
 
 -- requisite of the Pretty instance for invertible-grammar's error type.
@@ -160,13 +146,6 @@ deriveEq1 ''CompoundF
 deriveShow1 ''DatumF
 deriveEq1 ''DatumF
 
-
---- optics
-
--- affine
-cdr :: Traversal' Datum Datum
-cdr k (a :< CompoundF (ListF ind xs)) = _
-
 
 --- modification and extraction of annotations
 
@@ -176,23 +155,18 @@ ann = _extract
 dat :: Lens' Datum (DatumF Datum)
 dat = _unwrap
 
-syntax :: Lens' Datum Syn
-syntax = ann . #syntax
-
 position :: Lens' Datum (Maybe SourcePos)
 position = ann . #position
 
-indentation :: Traversal' Datum Indentation
+-- affine
-indentation k (syn :< CompoundF (ListF ind xs)) = do
+style :: Traversal' Datum Style
+style k (syn :< CompoundF (ListF ind xs)) = do
   ind' <- k ind
   pure $ syn :< CompoundF (ListF ind' xs)
-indentation k a = pure a
+style k a = pure a
 
-adorn :: Syn -> Datum -> Datum
+styleWith :: Style -> Datum -> Datum
-adorn = set syntax
+styleWith = set style
-
-indentWith :: Indentation -> Datum -> Datum
-indentWith = set indentation
 
 stripAnn :: Datum -> Fix DatumF
 stripAnn = hoist tailF
@@ -226,9 +200,9 @@ pattern Meta x <- _ :< MetaF x
 
 pattern List :: List Datum -> Datum
 pattern List a <- _ :< CompoundF (ListF _ a)
-  where List a = noAnn :< CompoundF (ListF Ordinary a)
+  where List a = noAnn :< CompoundF (ListF StyleData a)
 
-pattern List' :: Indentation -> List Datum -> Datum
+pattern List' :: Style -> List Datum -> Datum
 pattern List' ind a <- _ :< CompoundF (ListF ind a)
   where List' ind a = noAnn :< CompoundF (ListF ind a)
 
@@ -244,12 +218,25 @@ pattern Abbrev :: Prefix -> Datum -> Datum
 pattern Abbrev p a <- _ :< CompoundF (AbbrevF p a)
   where Abbrev p a = noAnn :< CompoundF (AbbrevF p a)
 
+pattern Boolean :: Bool -> Datum
 pattern Boolean a = Simple (SimpleBoolean a)
+
+pattern Number :: Scientific -> Datum
 pattern Number a = Simple (SimpleNumber a)
+
+pattern Character :: Char -> Datum
 pattern Character a = Simple (SimpleCharacter a)
+
+pattern String :: Text -> Datum
 pattern String a = Simple (SimpleString a)
+
+pattern Symbol :: Text -> Datum
 pattern Symbol a = Simple (SimpleSymbol a)
+
+pattern Bytevector :: ByteString -> Datum
 pattern Bytevector a = Simple (SimpleBytevector a)
+
+pattern Unreadable :: Text -> Datum
 pattern Unreadable a = Simple (SimpleUnreadable a)
 
 

test/Gyehoek/Test/Sexp/Print.hs

@@ -24,19 +24,19 @@ thinWide name x = testGroup name
   , tcaseW 4 (name <> "-thin") x
   ]
 
-datumBegin xs = S.indentWith (S.NSpecial 0) . S.List $
+datumBegin xs = S.styleWith (S.StyleSyntax 0) . S.List $
-  (S.adorn S.SynBuiltin . S.Symbol $ "begin") : xs
+  S.Symbol "begin" : xs
 
 datumLambda formals body =
-  S.indentWith (S.NSpecial 1) . S.List $
+  S.styleWith (S.StyleSyntax 1) . S.List $
-  (S.adorn S.SynBuiltin . S.Symbol $ "lambda") : formals : body
+  S.Symbol "lambda" : formals : body
 
-test_print = testGroup "sexp pretty printer" $
+test_print = testGroup "sexp pretty printer"
   [ tcase "null" $ S.List []
   , thinWide "simple-list" $
     S.List [ S.Symbol s | s <- ["가","나","다","라"] ]
   , thinWide "begin-nonempty" $
-    S.indentWith (S.NSpecial 0) $
+    S.styleWith (S.StyleSyntax 0) $
     datumBegin [ S.Symbol "책을"
            , S.Symbol "더"
            , S.Symbol "먹으세요~!"