Skip to content
This repository was archived by the owner on Apr 1, 2025. It is now read-only.

Commit 2b446df

Browse files
author
Patrick Thomson
committed
Add pretty-printer.
1 parent e8ac13f commit 2b446df

File tree

4 files changed

+171
-59
lines changed

4 files changed

+171
-59
lines changed

‎semantic-core/semantic-core.cabal‎

Lines changed: 16 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -27,25 +27,28 @@ library
2727
, Control.Effect.Readline
2828
, Data.Core
2929
, Data.Core.Parser
30+
, Data.Core.Pretty
3031
, Data.File
3132
, Data.Loc
3233
, Data.Name
3334
, Data.Stack
3435
-- other-modules:
3536
-- other-extensions:
36-
build-depends: algebraic-graphs ^>= 0.3
37-
, base >= 4.11 && < 5
38-
, containers ^>= 0.6
39-
, directory ^>= 1.3
40-
, filepath ^>= 1.4
41-
, fused-effects ^>= 0.4
42-
, haskeline ^>= 0.7.5
43-
, parsers ^>= 0.12.10
44-
, prettyprinter ^>= 1.2.1
45-
, semigroupoids ^>= 5.3
46-
, transformers ^>= 0.5.6
47-
, trifecta ^>= 2
48-
, unordered-containers ^>= 0.2.10
37+
build-depends: algebraic-graphs ^>= 0.3
38+
, base >= 4.11 && < 5
39+
, containers ^>= 0.6
40+
, directory ^>= 1.3
41+
, filepath ^>= 1.4
42+
, fused-effects ^>= 0.4
43+
, haskeline ^>= 0.7.5
44+
, parsers ^>= 0.12.10
45+
, prettyprinter ^>= 1.2.1
46+
, prettyprinter-ansi-terminal ^>= 1.1.1
47+
, recursion-schemes ^>= 5.1
48+
, semigroupoids ^>= 5.3
49+
, transformers ^>= 0.5.6
50+
, trifecta ^>= 2
51+
, unordered-containers ^>= 0.2.10
4952
hs-source-dirs: src
5053
default-language: Haskell2010
5154
ghc-options: -Weverything -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-safe -Wno-unsafe -Wno-name-shadowing -Wno-monomorphism-restriction -Wno-missed-specialisations -Wno-all-missed-specialisations

‎semantic-core/src/Data/Core.hs‎

Lines changed: 18 additions & 46 deletions
Original file line numberDiff line numberDiff line change
@@ -1,27 +1,30 @@
1-
{-# LANGUAGE DeriveTraversable, FlexibleContexts, LambdaCase, OverloadedStrings, RecordWildCards #-}
1+
{-# LANGUAGE DeriveTraversable, FlexibleContexts, LambdaCase, OverloadedStrings, RecordWildCards, TemplateHaskell, TypeFamilies #-}
22
module Data.Core
33
( Core(..)
4+
, CoreF(..)
45
, Edge(..)
5-
, showCore
66
, lams
77
, ($$*)
88
, unapply
99
, unapplies
1010
, block
1111
, ann
1212
, annWith
13+
, stripAnnotations
1314
) where
1415

1516
import Control.Applicative (Alternative (..))
17+
import Data.Functor.Foldable hiding (ListF(..))
18+
import Data.Functor.Foldable.TH
1619
import Data.Foldable (foldl')
1720
import Data.Loc
1821
import Data.Name
1922
import Data.Stack
20-
import Data.Text.Prettyprint.Doc (Pretty (..), (<+>), vsep)
21-
import qualified Data.Text.Prettyprint.Doc as Pretty
22-
import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty
2323
import GHC.Stack
2424

25+
data Edge = Lexical | Import
26+
deriving (Eq, Ord, Show)
27+
2528
data Core
2629
= Var Name
2730
| Let Name
@@ -50,52 +53,16 @@ infixr 1 :>>
5053
infix 3 :=
5154
infixl 4 :.
5255

53-
data Edge = Lexical | Import
54-
deriving (Eq, Ord, Show)
56+
makeBaseFunctor ''Core
5557

56-
instance Pretty Edge where
57-
pretty = pretty . show
58+
infixl 2 :$$
59+
infixr 1 :>>$
60+
infix 3 :=$
61+
infixl 4 :.$
5862

5963
instance Semigroup Core where
6064
(<>) = (:>>)
6165

62-
softsemi :: Pretty.Doc a
63-
softsemi = Pretty.flatAlt mempty ";"
64-
65-
showCore :: Core -> String
66-
showCore = Pretty.renderString . Pretty.layoutPretty Pretty.defaultLayoutOptions . pretty
67-
68-
instance Pretty Core where
69-
pretty = \case
70-
Var a -> pretty a
71-
Let a -> "let" <+> pretty a
72-
a :>> b -> vsep [pretty a <> softsemi, pretty b]
73-
74-
Lam x f -> vsep [ Pretty.nest 2 $ vsep [ "λ" <> pretty x <+> "-> {"
75-
, pretty f
76-
]
77-
, "}"
78-
]
79-
80-
f :$ x -> pretty f <> "." <> pretty x
81-
Unit -> Pretty.parens mempty
82-
Bool b -> pretty b
83-
If c x y -> Pretty.sep [ "if" <+> pretty c
84-
, "then" <+> pretty x
85-
, "else" <+> pretty y
86-
]
87-
88-
String s -> pretty (show s)
89-
90-
Frame -> Pretty.braces mempty
91-
92-
Load p -> "load" <+> pretty p
93-
Edge e n -> pretty e <+> pretty n
94-
a :. b -> "push" <+> Pretty.parens (pretty a) <+> Pretty.brackets (pretty b)
95-
var := x -> pretty var <+> "=" <+> pretty x
96-
Ann (Loc p s) c -> pretty c <> Pretty.brackets (pretty p <> ":" <> pretty s)
97-
98-
9966
lams :: Foldable t => t Name -> Core -> Core
10067
lams names body = foldr Lam body names
10168

@@ -124,3 +91,8 @@ ann = annWith callStack
12491

12592
annWith :: CallStack -> Core -> Core
12693
annWith callStack c = maybe c (flip Ann c) (stackLoc callStack)
94+
95+
stripAnnotations :: Core -> Core
96+
stripAnnotations = cata go where
97+
go (AnnF _ item) = item
98+
go item = embed item

‎semantic-core/src/Data/Core/Pretty.hs‎

Lines changed: 130 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,130 @@
1+
{-# LANGUAGE FlexibleContexts, LambdaCase, OverloadedStrings, TypeApplications #-}
2+
3+
module Data.Core.Pretty
4+
( showCore
5+
, printCore
6+
, showFile
7+
, printFile
8+
, prettyCore
9+
) where
10+
11+
import Control.Effect
12+
import Control.Effect.Reader
13+
import Data.Core
14+
import Data.File
15+
import Data.Functor.Foldable
16+
import Data.Name
17+
import Data.Text.Prettyprint.Doc (Pretty (..), annotate, softline, (<+>))
18+
import qualified Data.Text.Prettyprint.Doc as Pretty
19+
import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty
20+
import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty
21+
22+
showCore :: Core -> String
23+
showCore = Pretty.renderString . Pretty.layoutSmart Pretty.defaultLayoutOptions . Pretty.unAnnotate . prettyCore Ascii
24+
25+
printCore :: Core -> IO ()
26+
printCore p = Pretty.putDoc (prettyCore Unicode p) *> putStrLn ""
27+
28+
showFile :: File Core -> String
29+
showFile = showCore . fileBody
30+
31+
printFile :: File Core -> IO ()
32+
printFile = printCore . fileBody
33+
34+
type AnsiDoc = Pretty.Doc Pretty.AnsiStyle
35+
36+
keyword, symbol, strlit, primitive :: AnsiDoc -> AnsiDoc
37+
keyword = annotate (Pretty.colorDull Pretty.Cyan)
38+
symbol = annotate (Pretty.color Pretty.Yellow)
39+
strlit = annotate (Pretty.colorDull Pretty.Green)
40+
primitive = keyword . mappend "#"
41+
42+
type Prec = Int
43+
44+
data Style = Unicode | Ascii
45+
46+
lambda, arrow :: (Member (Reader Style) sig, Carrier sig m) => m AnsiDoc
47+
lambda = ask @Style >>= \case
48+
Unicode -> pure $ symbol "λ"
49+
Ascii -> pure $ symbol "\\"
50+
arrow = ask @Style >>= \case
51+
Unicode -> pure $ symbol "→"
52+
Ascii -> pure $ symbol "->"
53+
54+
name :: Name -> AnsiDoc
55+
name = \case
56+
Gen p -> pretty p
57+
Path p -> strlit (Pretty.viaShow p )
58+
User n -> encloseIf (needsQuotation n) (symbol "#{") (symbol "}") (pretty n)
59+
60+
with :: (Member (Reader Prec) sig, Carrier sig m) => Prec -> m a -> m a
61+
with n = local (const n)
62+
63+
inParens :: (Member (Reader Prec) sig, Carrier sig m) => Prec -> m AnsiDoc -> m AnsiDoc
64+
inParens amount go = do
65+
prec <- ask
66+
body <- with amount go
67+
pure (encloseIf (amount >= prec) (symbol "(") (symbol ")") body)
68+
69+
encloseIf :: Monoid m => Bool -> m -> m -> m -> m
70+
encloseIf True l r x = l <> x <> r
71+
encloseIf False _ _ x = x
72+
73+
prettify :: (Member (Reader Prec) sig, Member (Reader Style) sig, Carrier sig m)
74+
=> CoreF (m AnsiDoc)
75+
-> m AnsiDoc
76+
prettify = \case
77+
VarF a -> pure $ name a
78+
LetF a -> pure $ keyword "let" <+> name a
79+
a :>>$ b -> do
80+
prec <- ask @Prec
81+
fore <- with 12 a
82+
aft <- with 12 b
83+
84+
let open = symbol (if 12 > prec then "{" <> softline else "")
85+
close = symbol (if 12 > prec then softline <> "}" else "")
86+
separator = ";" <> Pretty.line
87+
body = fore <> separator <> aft
88+
89+
pure . Pretty.align $ open <> Pretty.align body <> close
90+
91+
LamF x f -> inParens 11 $ do
92+
body <- f
93+
lam <- lambda
94+
arr <- arrow
95+
pure (lam <> name x <+> arr <+> body)
96+
97+
FrameF -> pure $ primitive "frame"
98+
UnitF -> pure $ primitive "unit"
99+
BoolF b -> pure $ primitive (if b then "true" else "false")
100+
StringF s -> pure . strlit $ Pretty.viaShow s
101+
102+
f :$$ x -> inParens 11 $ (<+>) <$> f <*> x
103+
104+
IfF con tru fal -> do
105+
con' <- "if" `appending` con
106+
tru' <- "then" `appending` tru
107+
fal' <- "else" `appending` fal
108+
pure $ Pretty.sep [con', tru', fal']
109+
110+
LoadF p -> "load" `appending` p
111+
EdgeF Lexical n -> "lexical" `appending` n
112+
EdgeF Import n -> "import" `appending` n
113+
item :.$ body -> inParens 5 $ do
114+
f <- item
115+
g <- body
116+
pure (f <> symbol "." <> g)
117+
118+
lhs :=$ rhs -> inParens 4 $ do
119+
f <- lhs
120+
g <- rhs
121+
pure (f <+> symbol "=" <+> g)
122+
123+
-- Annotations are not pretty-printed, as it lowers the signal/noise ratio too profoundly.
124+
AnnF _ c -> c
125+
126+
appending :: Functor f => AnsiDoc -> f AnsiDoc -> f AnsiDoc
127+
appending k item = (keyword k <+>) <$> item
128+
129+
prettyCore :: Style -> Core -> AnsiDoc
130+
prettyCore s = run . runReader @Prec 0 . runReader s . cata prettify

‎semantic-core/src/Data/Name.hs‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,7 @@ module Data.Name
55
, Name(..)
66
, reservedNames
77
, isSimpleCharacter
8+
, needsQuotation
89
, Gensym(..)
910
, (//)
1011
, gensym
@@ -24,6 +25,7 @@ import Control.Monad.Fail
2425
import Control.Monad.IO.Class
2526
import qualified Data.Char as Char
2627
import Data.HashSet (HashSet)
28+
import qualified Data.HashSet as HashSet
2729
import Data.Text.Prettyprint.Doc (Pretty (..))
2830
import qualified Data.Text.Prettyprint.Doc as Pretty
2931

@@ -58,6 +60,11 @@ reservedNames :: HashSet User
5860
reservedNames = [ "#true", "#false", "let", "#frame", "if", "then", "else"
5961
, "lexical", "import", "#unit", "load"]
6062

63+
-- | Returns true if any character would require quotation or if the
64+
-- name conflicts with a Core primitive.
65+
needsQuotation :: User -> Bool
66+
needsQuotation u = HashSet.member u reservedNames || any (not . isSimpleCharacter) u
67+
6168
-- | A ‘simple’ character is, loosely defined, a character that is compatible
6269
-- with identifiers in most ASCII-oriented programming languages. This is defined
6370
-- as the alphanumeric set plus @$@ and @_@.

0 commit comments

Comments
 (0)