From 7bc5f25984fe9359c5b8d5ab2a87635c4a4f9f75 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Fri, 25 Sep 2026 13:45:57 -0600 Subject: [PATCH] =?UTF-8?q?=EB=8D=94=20=EA=B0=84=EB=8B=A8=ED=95=9C=20?= =?UTF-8?q?=EC=8B=A0=ED=83=9D=EC=8A=A4=20annotations?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- golden/print/begin-nonempty-thin | 6 +- golden/print/begin-nonempty-wide | 6 +- golden/print/lambda-thin | 8 +-- golden/print/lambda-wide | 4 +- golden/print/simple-list-thin | 8 +-- golden/print/simple-list-wide | 2 +- golden/read/bool/read | 12 ++-- golden/read/decimal/read | 9 +-- golden/read/list-dot-flat/read | 15 ++--- golden/read/list-flat/read | 26 +++----- golden/read/list/read | 40 ++++------- golden/read/meta-expression/read | 3 +- golden/read/meta-splice-expression/read | 3 +- golden/read/meta-splice-variable/read | 3 +- golden/read/meta-variable/read | 3 +- golden/read/peculiar-identifier-dot/read | 18 ++--- golden/read/peculiar-identifier-sign/read | 21 ++---- golden/read/string/read | 3 +- golden/read/typical-identifier-token/read | 17 ++--- golden/read/typical-identifier/read | 27 +++----- gyehoek.cabal | 2 + src/Gyehoek/CPS/Syntax.hs | 30 ++++----- src/Gyehoek/Language/Common.hs | 4 +- src/Gyehoek/Scheme/Expand.hs | 12 ++-- src/Gyehoek/Scheme/Expand/Old.hs | 12 ++-- src/Gyehoek/Scheme/Syntax.hs | 29 +++----- src/Gyehoek/Sexp/Grammar/Base.hs | 67 ++++++++----------- src/Gyehoek/Sexp/Print.hs | 66 +++++++++--------- src/Gyehoek/Sexp/Read.hs | 4 +- src/Gyehoek/Sexp/Syntax.hs | 81 ++++++++++------------- test/Gyehoek/Test/Sexp/Print.hs | 12 ++-- 31 files changed, 229 insertions(+), 324 deletions(-) diff --git a/golden/print/begin-nonempty-thin b/golden/print/begin-nonempty-thin index e120fc1..5dc17a1 100644 --- a/golden/print/begin-nonempty-thin +++ b/golden/print/begin-nonempty-thin @@ -1,4 +1,4 @@ (begin - 책을 - 더 - 먹으세요~!) \ No newline at end of file + 책을 + 더 + 먹으세요~!) \ No newline at end of file diff --git a/golden/print/begin-nonempty-wide b/golden/print/begin-nonempty-wide index e120fc1..5dc17a1 100644 --- a/golden/print/begin-nonempty-wide +++ b/golden/print/begin-nonempty-wide @@ -1,4 +1,4 @@ (begin - 책을 - 더 - 먹으세요~!) \ No newline at end of file + 책을 + 더 + 먹으세요~!) \ No newline at end of file diff --git a/golden/print/lambda-thin b/golden/print/lambda-thin index f89ad45..b67da99 100644 --- a/golden/print/lambda-thin +++ b/golden/print/lambda-thin @@ -1,5 +1,5 @@ (lambda - (어간 - 어미) - (display - 꾸깃)) \ No newline at end of file + (어간 + 어미) + (display + 꾸깃)) \ No newline at end of file diff --git a/golden/print/lambda-wide b/golden/print/lambda-wide index fbe0b17..5e86983 100644 --- a/golden/print/lambda-wide +++ b/golden/print/lambda-wide @@ -1,2 +1,2 @@ -(lambda (어간 어미) - (display 꾸깃)) \ No newline at end of file +(lambda (어간 어미) + (display 꾸깃)) \ No newline at end of file diff --git a/golden/print/simple-list-thin b/golden/print/simple-list-thin index 73aea8b..83192bd 100644 --- a/golden/print/simple-list-thin +++ b/golden/print/simple-list-thin @@ -1,4 +1,4 @@ -(가 - 나 - 다 - 라) \ No newline at end of file +(가 + 나 + 다 + 라) \ No newline at end of file diff --git a/golden/print/simple-list-wide b/golden/print/simple-list-wide index b4745c3..195c39f 100644 --- a/golden/print/simple-list-wide +++ b/golden/print/simple-list-wide @@ -1 +1 @@ -(가 나 다 라) \ No newline at end of file +(가 나 다 라) \ No newline at end of file diff --git a/golden/read/bool/read b/golden/read/bool/read index c9bd1ea..a1862d2 100644 --- a/golden/read/bool/read +++ b/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 diff --git a/golden/read/decimal/read b/golden/read/decimal/read index 4b23079..4f74589 100644 --- a/golden/read/decimal/read +++ b/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 diff --git a/golden/read/list-dot-flat/read b/golden/read/list-dot-flat/read index c2f77de..5f774bf 100644 --- a/golden/read/list-dot-flat/read +++ b/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 diff --git a/golden/read/list-flat/read b/golden/read/list-flat/read index c1b1a96..ef7a88d 100644 --- a/golden/read/list-flat/read +++ b/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 diff --git a/golden/read/list/read b/golden/read/list/read index 6629342..b206236 100644 --- a/golden/read/list/read +++ b/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 diff --git a/golden/read/meta-expression/read b/golden/read/meta-expression/read index 685b9d2..c41820f 100644 --- a/golden/read/meta-expression/read +++ b/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 diff --git a/golden/read/meta-splice-expression/read b/golden/read/meta-splice-expression/read index e5de84d..64c487a 100644 --- a/golden/read/meta-splice-expression/read +++ b/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 diff --git a/golden/read/meta-splice-variable/read b/golden/read/meta-splice-variable/read index d8428ec..7211df8 100644 --- a/golden/read/meta-splice-variable/read +++ b/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 diff --git a/golden/read/meta-variable/read b/golden/read/meta-variable/read index 4ec3604..8c44a2c 100644 --- a/golden/read/meta-variable/read +++ b/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 diff --git a/golden/read/peculiar-identifier-dot/read b/golden/read/peculiar-identifier-dot/read index 7008166..f462c9e 100644 --- a/golden/read/peculiar-identifier-dot/read +++ b/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 diff --git a/golden/read/peculiar-identifier-sign/read b/golden/read/peculiar-identifier-sign/read index b3c5d89..98058cf 100644 --- a/golden/read/peculiar-identifier-sign/read +++ b/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 diff --git a/golden/read/string/read b/golden/read/string/read index aed8eb0..c5f0cb6 100644 --- a/golden/read/string/read +++ b/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 diff --git a/golden/read/typical-identifier-token/read b/golden/read/typical-identifier-token/read index 744edef..b6457d5 100644 --- a/golden/read/typical-identifier-token/read +++ b/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 diff --git a/golden/read/typical-identifier/read b/golden/read/typical-identifier/read index 2ee59d6..c8de8c4 100644 --- a/golden/read/typical-identifier/read +++ b/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 diff --git a/gyehoek.cabal b/gyehoek.cabal index b4c6693..80d3fae 100644 --- a/gyehoek.cabal +++ b/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: diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs index 80b102b..ed6dee6 100644 --- a/src/Gyehoek/CPS/Syntax.hs +++ b/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, (:-)(..)) +import Gyehoek.Sexp (G, (:-)(..), Datum) 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 $ - S.el (S.decorate S.SynBuiltin >>> S.sym "continue") - >>> S.el (S.decorate S.SynProcedure >>> S.datumIso) + continue = S.listWithStyle (S.StyleSyntax 1) $ + S.el (S.sym "continue") + >>> 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 $ - S.el (S.decorate S.SynBuiltin >>> S.sym "builtin") + builtin = S.listWithStyle (S.StyleSyntax 1) $ + 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 diff --git a/src/Gyehoek/Language/Common.hs b/src/Gyehoek/Language/Common.hs index 14d7c57..53e17af 100644 --- a/src/Gyehoek/Language/Common.hs +++ b/src/Gyehoek/Language/Common.hs @@ -59,6 +59,4 @@ instance Prefixed Name where --- DatumIsos instance S.DatumIso Name where - datumIso = S.decorate S.SynVariable - >>> S.symbol - >>> S.iso coerce coerce + datumIso = S.symbol >>> S.iso coerce coerce diff --git a/src/Gyehoek/Scheme/Expand.hs b/src/Gyehoek/Scheme/Expand.hs index ba5d4d5..2d0640b 100644 --- a/src/Gyehoek/Scheme/Expand.hs +++ b/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 diff --git a/src/Gyehoek/Scheme/Expand/Old.hs b/src/Gyehoek/Scheme/Expand/Old.hs index 49059df..a967f64 100644 --- a/src/Gyehoek/Scheme/Expand/Old.hs +++ b/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 diff --git a/src/Gyehoek/Scheme/Syntax.hs b/src/Gyehoek/Scheme/Syntax.hs index 6b05656..baa9070 100644 --- a/src/Gyehoek/Scheme/Syntax.hs +++ b/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 - >>> S.symbol - >>> S.iso coerce coerce + datumIso = 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.NSpecial 1) - ( S.el (S.symBuiltin "syntax-rules") + S.listWithStyle + (S.StyleSyntax 1) + ( 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) $ - S.el (S.symBuiltin "let-syntax") + letsyntax = S.listWithStyle (S.StyleSyntax 1) $ + 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 diff --git a/src/Gyehoek/Sexp/Grammar/Base.hs b/src/Gyehoek/Sexp/Grammar/Base.hs index cb713ac..5c88db7 100644 --- a/src/Gyehoek/Sexp/Grammar/Base.hs +++ b/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 - :: Indentation +listWithStyle + :: 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) $ - el (symBuiltin 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 + listWithStyle (StyleSyntax 1) $ + el (sym kw) >>> el c >>> el t >>> el f 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) $ - el (symBuiltin kw) >>> el bindings >>> el e +letLike kw name rhs e = listWithStyle (StyleSyntax 1) $ + 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) $ - el (decorate SynBuiltin >>> kw) +lambdaLike kw formals body = listWithStyle (StyleSyntax 1) $ + 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) $ - el (symBuiltin kw) >>> g + listWithStyle (StyleSyntax 0) $ + el (sym kw) >>> g -- | define a printed syntax for an object which cannot be read. unreadable diff --git a/src/Gyehoek/Sexp/Print.hs b/src/Gyehoek/Sexp/Print.hs index b78e337..8630560 100644 --- a/src/Gyehoek/Sexp/Print.hs +++ b/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 qualified Control.Comonad.Trans.Cofree as F -import Prettyprinter.Util -import Gyehoek.Prelude hiding (Simple, (:<)) -import Data.Foldable (traverse_, toList) +import Gyehoek.Prelude hiding (Simple) 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 -> - case indent of - 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 + List' sty xs -> case sty of + StyleSyntax n | keyword:args <- xs -> + let (specialArgs,body) = splitAt n args + in pparen depth . nest 2 . vsep $ + [ group . nest 2 . hcat $ + [ annotate SynSyntax $ prettyDatum (depth+1) keyword + , if null specialArgs then mempty else softline + , hsep $ prettyDatum (depth+1) <$> specialArgs ] - Ordinary; NSpecial _ -> pparen depth $ - group . align . vsep $ - prettyDatum (depth+1) <$> xs + , vsep $ prettyDatum (depth+1) <$> body + ] + 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 -> - Sci.floatingOrInteger n + SimpleNumber n -> 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" - SynMacro -> "syn-macro" + SynSyntax -> "syn-builtin" SynConstant -> "syn-constant" SynString -> "syn-string" SynProcedure -> "syn-procedure" diff --git a/src/Gyehoek/Sexp/Read.hs b/src/Gyehoek/Sexp/Read.hs index 3f778af..297aea5 100644 --- a/src/Gyehoek/Sexp/Read.hs +++ b/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 diff --git a/src/Gyehoek/Sexp/Syntax.hs b/src/Gyehoek/Sexp/Syntax.hs index 83b069a..4701449 100644 --- a/src/Gyehoek/Sexp/Syntax.hs +++ b/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(..) - , Syn(..) + , Style(..) , pattern Simple , pattern Compound , pattern Labeled @@ -25,10 +25,8 @@ module Gyehoek.Sexp.Syntax , pattern Vector , pattern DotList , pattern Gyehoek.Sexp.Syntax.List - , syntax - , indentation - , adorn - , indentWith + , style + , styleWith , 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 - = NSpecial Int - | Ordinary +data Style + = StyleSyntax Int + | 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 -indentation k (syn :< CompoundF (ListF ind xs)) = do +-- affine +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 -adorn = set syntax - -indentWith :: Indentation -> Datum -> Datum -indentWith = set indentation +styleWith :: Style -> Datum -> Datum +styleWith = set style 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) diff --git a/test/Gyehoek/Test/Sexp/Print.hs b/test/Gyehoek/Test/Sexp/Print.hs index 0cbfc57..e2a67b9 100644 --- a/test/Gyehoek/Test/Sexp/Print.hs +++ b/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 $ - (S.adorn S.SynBuiltin . S.Symbol $ "begin") : xs +datumBegin xs = S.styleWith (S.StyleSyntax 0) . S.List $ + S.Symbol "begin" : xs datumLambda formals body = - S.indentWith (S.NSpecial 1) . S.List $ - (S.adorn S.SynBuiltin . S.Symbol $ "lambda") : formals : body + S.styleWith (S.StyleSyntax 1) . S.List $ + 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 "먹으세요~!"