github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-24 08:54:07 +03:00
Code Issues Projects Releases Wiki Activity

Simplify prettyCore.go.

Browse Source
This commit is contained in:
Rob Rix 2019-07-19 09:59:08 -04:00
parent d998f66133
commit a45c029d86
No known key found for this signature in database
GPG Key ID: F188A01508EA1CF7
1 changed files with 19 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
semantic-core/src/Data/Core/Pretty.hs
View File

@ -56,16 +56,15 @@ inParens amount go = do
pure (encloseIf (amount >= prec) (symbol "(") (symbol ")") body) pure (encloseIf (amount >= prec) (symbol "(") (symbol ")") body)
prettyCore :: Style -> Term Core User -> AnsiDoc prettyCore :: Style -> Term Core User -> AnsiDoc
prettyCore style = run . runReader @Prec 0 . go (pure . name) prettyCore style = run . runReader @Prec 0 . go
where go :: (Member (Reader Prec) sig, Carrier sig m) => (a -> m AnsiDoc) -> Term Core a -> m AnsiDoc where go = \case
go var = \case Var v -> pure (name v)
Var v -> var v
Term t -> case t of Term t -> case t of
Let a -> pure $ keyword "let" <+> name a Let a -> pure $ keyword "let" <+> name a
a :>> b -> do a :>> b -> do
prec <- ask @Prec prec <- ask @Prec
fore <- with 12 (go var a) fore <- with 12 (go a)
aft <- with 12 (go var b) aft <- with 12 (go b)
let open = symbol ("{" <> softline) let open = symbol ("{" <> softline)
close = symbol (softline <> "}") close = symbol (softline <> "}")
@ -76,37 +75,37 @@ prettyCore style = run . runReader @Prec 0 . go (pure . name)
Lam n f -> inParens 11 $ do Lam n f -> inParens 11 $ do
(x, body) <- bind n f (x, body) <- bind n f
pure (lambda <> x <+> arrow <+> body) pure (lambda <> name x <+> arrow <+> body)
Frame -> pure $ primitive "frame" Frame -> pure $ primitive "frame"
Unit -> pure $ primitive "unit" Unit -> pure $ primitive "unit"
Bool b -> pure $ primitive (if b then "true" else "false") Bool b -> pure $ primitive (if b then "true" else "false")
String s -> pure . strlit $ Pretty.viaShow s String s -> pure . strlit $ Pretty.viaShow s
f :$ x -> inParens 11 $ (<+>) <$> go var f <*> go var x f :$ x -> inParens 11 $ (<+>) <$> go f <*> go x
If con tru fal -> do If con tru fal -> do
con' <- "if" `appending` go var con con' <- "if" `appending` go con
tru' <- "then" `appending` go var tru tru' <- "then" `appending` go tru
fal' <- "else" `appending` go var fal fal' <- "else" `appending` go fal
pure $ Pretty.sep [con', tru', fal'] pure $ Pretty.sep [con', tru', fal']
Load p -> "load" `appending` go var p Load p -> "load" `appending` go p
Edge Lexical n -> "lexical" `appending` go var n Edge Lexical n -> "lexical" `appending` go n
Edge Import n -> "import" `appending` go var n Edge Import n -> "import" `appending` go n
item :. body -> inParens 4 $ do item :. body -> inParens 4 $ do
f <- go var item f <- go item
g <- go var body g <- go body
pure (f <> symbol "." <> g) pure (f <> symbol "." <> g)
lhs := rhs -> inParens 3 $ do lhs := rhs -> inParens 3 $ do
f <- go var lhs f <- go lhs
g <- go var rhs g <- go rhs
pure (f <+> symbol "=" <+> g) pure (f <+> symbol "=" <+> g)
-- Annotations are not pretty-printed, as it lowers the signal/noise ratio too profoundly. -- Annotations are not pretty-printed, as it lowers the signal/noise ratio too profoundly.
Ann _ c -> go var c Ann _ c -> go c
where bind (Ignored x) f = let x' = name x in (,) x' <$> go (incr (const (pure x')) var) (fromScope sequenceA f) where bind (Ignored x) f = (,) x <$> go (fromScope (incr (const (pure x)) id) f)
lambda = case style of lambda = case style of
Unicode -> symbol "λ" Unicode -> symbol "λ"
Ascii -> symbol "\\" Ascii -> symbol "\\"