8000 Merge pull request #171 from github/serialize-precise-ast-as-s-expres… · github/semantic@6c31189 · GitHub
[go: up one dir, main page]
Skip to content
This repository was archived by the owner on Apr 1, 2025. It is now read-only.

Commit 6c31189

Browse files
robrixrobrix
authored
Merge pull request #171 from github/serialize-precise-ast-as-s-expressions
Serialize precise AST as s-expressions
2 parents c4c6b50 + 9bde466 commit 6c31189

File tree

2 files changed

+71
-0
lines changed

2 files changed

+71
-0
lines changed

‎semantic.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -271,6 +271,7 @@ library
271271
-- Serialization
272272
, Serializing.Format
273273
, Serializing.SExpression
274+
, Serializing.SExpression.Precise
274275
, Tags.Taggable
275276
, Tags.Tagging
276277
-- Custom Prelude

‎src/Serializing/SExpression/Precise.hs

Lines changed: 70 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,70 @@
1+
{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
2+
module Serializing.SExpression.Precise
3+
( serializeSExpression
4+
) where
5+
6+
import Data.ByteString.Builder
7+
import Data.Foldable (fold)
8+
import Data.List (intersperse)
9+
import Data.Text (Text)
10+
import GHC.Generics
11+
12+
serializeSExpression :: ToSExpression t => t -> Builder
13+
serializeSExpression t = toSExpression t 0 <> "\n"
14+
15+
16+
nl :: Int -> Builder
17+
nl n | n <= 0 = ""
18+
| otherwise = "\n"
19+
20+
pad :: Int -> Builder
21+
pad n = stringUtf8 (replicate (2 * n) ' ')
22+
23+
24+
class ToSExpression t where
25+
toSExpression :: t -> Int -> Builder
26+
27+
instance (ToSExpressionWithStrategy strategy t, strategy ~ ToSExpressionStrategy t) => ToSExpression t where
28+
toSExpression = toSExpressionWithStrategy @strategy undefined
29+
30+
31+
data Strategy = Generic | Show
32+
33+
type family ToSExpressionStrategy t :: Strategy where
34+
ToSExpressionStrategy Text = 'Show
35+
ToSExpressionStrategy _ = 'Generic
36+
37+
class ToSExpressionWithStrategy (strategy :: Strategy) t where
38+
toSExpressionWithStrategy :: proxy strategy -> t -> Int -> Builder
39+
40+
instance Show t => ToSExpressionWithStrategy 'Show t where
41+
toSExpressionWithStrategy _ t _ = stringUtf8 (show t)
42+
43+
instance (Generic t, GToSExpression (Rep t)) => ToSExpressionWithStrategy 'Generic t where
44+
toSExpressionWithStrategy _ t n = nl n <> pad n <> "(" <> fold (intersperse " " (gtoSExpression (from t) n)) <> ")"
45+
46+
47+
class GToSExpression f where
48+
gtoSExpression :: f (Int -> Builder) -> (Int -> [Builder])
49+
50+
instance GToSExpression f => GToSExpression (M1 D d f) where
51+
gtoSExpression = gtoSExpression . unM1
52+
53+
instance (GToSExpression f, GToSExpression g) => GToSExpression (f :+: g) where
54+
gtoSExpression (L1 l) = gtoSExpression l
55+
gtoSExpression (R1 r) = gtoSExpression r
56+
57+
instance (Constructor c, GToSExpression f) => GToSExpression (M1 C c f) where
58+
gtoSExpression m n = stringUtf8 (conName m) : gtoSExpression (unM1 m) (n + 1)
59+
60+
instance (GToSExpression f, GToSExpression g) => GToSExpression (f :*: g) where
61+
gtoSExpression (l :*: r) = gtoSExpression l <> gtoSExpression r
62+
63+
instance GToSExpression U1 where
64+
gtoSExpression _ _ = []
65+
66+
instance GToSExpression f => GToSExpression (M1 S s f) where
67+
gtoSExpression = gtoSExpression . unM1 -- FIXME: show the selector name, if any
68+
69+
instance ToSExpression k => GToSExpression (K1 R k) where
70+
gtoSExpression k = pure . toSExpression (unK1 k)

0 commit comments

Comments
 (0)
0