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

Commit 5179e88

Browse files
robrixrobrix
authored
Merge pull request #200 from github/break-hearts-not-builds
Fold over Core without iter
2 parents d721aad + 0eb17e3 commit 5179e88

File tree

3 files changed

+58
-130
lines changed

3 files changed

+58
-130
lines changed

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

Lines changed: 5 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -194,25 +194,8 @@ annWith :: (Carrier sig m, Member Core sig) => CallStack -> m a -> m a
194194
annWith callStack = maybe id (fmap send . Ann) (stackLoc callStack)
195195

196196

197-
stripAnnotations :: (Member Core sig, Syntax sig) => Term sig a -> Term sig a
198-
stripAnnotations = iter id alg Var Var
199-
where alg t | Just c <- prj t, Ann _ b <- c = b
200-
| otherwise = Term t
201-
202-
203-
instance Syntax Core where
204-
foldSyntax go k h = \case
205-
Let a -> Let a
206-
a :>> b -> go h a :>> go h b
207-
Lam u b -> Lam u (foldSyntax go k h b)
208-
a :$ b -> go h a :$ go h b
209-
Unit -> Unit
210-
Bool b -> Bool b
211-
If c t e -> If (go h c) (go h t) (go h e)
212-
String s -> String s
213-
Load t -> Load (go h t)
214-
Edge e t -> Edge e (go h t)
215-
Frame -> Frame
216-
a :. b -> go h a :. go h b
217-
a := b -> go h a := go h b
218-
Ann loc t -> Ann loc (go h t)
197+
stripAnnotations :: (Member Core sig, HFunctor sig, forall g . Functor g => Functor (sig g)) => Term sig a -> Term sig a
198+
stripAnnotations (Var v) = Var v
199+
stripAnnotations (Term t)
200+
| Just c <- prj t, Ann _ b <- c = stripAnnotations b
201+
| otherwise = Term (hmap stripAnnotations t)

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

Lines changed: 52 additions & 57 deletions
Original file line numberDiff line numberDiff line change
@@ -11,7 +11,6 @@ module Data.Core.Pretty
1111
import Control.Effect.Reader
1212
import Data.Core
1313
import Data.File
14-
import Data.Functor.Const
1514
import Data.Name
1615
import Data.Scope
1716
import Data.Term
@@ -56,57 +55,58 @@ inParens amount go = do
5655
body <- with amount go
5756
pure (encloseIf (amount >= prec) (symbol "(") (symbol ")") body)
5857

59-
prettify :: (Member (Reader [AnsiDoc]) sig, Member (Reader Prec) sig, Carrier sig m)
60-
=> Style
61-
-> Core (Const (m AnsiDoc)) a
62-
-> m AnsiDoc
63-
prettify style = \case
64-
Let a -> pure $ keyword "let" <+> name a
65-
Const a :>> Const b -> do
66-
prec <- ask @Prec
67-
fore <- with 12 a
68-
aft <- with 12 b
69-
70-
let open = symbol ("{" <> softline)
71-
close = symbol (softline <> "}")
72-
separator = ";" <> Pretty.line
73-
body = fore <> separator <> aft
74-
75-
pure . Pretty.align $ encloseIf (12 > prec) open close (Pretty.align body)
76-
77-
Lam n f -> inParens 11 $ do
78-
(x, body) <- bind n f
79-
pure (lambda <> x <+> arrow <+> body)
80-
81-
Frame -> pure $ primitive "frame"
82-
Unit -> pure $ primitive "unit"
83-
Bool b -> pure $ primitive (if b then "true" else "false")
84-
String s -> pure . strlit $ Pretty.viaShow s
85-
86-
Const f :$ Const x -> inParens 11 $ (<+>) <$> f <*> x
87-
88-
If (Const con) (Const tru) (Const fal) -> do
89-
con' <- "if" `appending` con
90-
tru' <- "then" `appending` tru
91-
fal' <- "else" `appending` fal
92-
pure $ Pretty.sep [con', tru', fal']
93-
94-
Load (Const p) -> "load" `appending` p
95-
Edge Lexical (Const n) -> "lexical" `appending` n
96-
Edge Import (Const n) -> "import" `appending` n
97-
Const item :. Const body -> inParens 4 $ do
98-
f <- item
99-
g <- body
100-
pure (f <> symbol "." <> g)
101-
102-
Const lhs := Const rhs -> inParens 3 $ do
103-
f <- lhs
104-
g <- rhs
105-
pure (f <+> symbol "=" <+> g)
106-
107-
-- Annotations are not pretty-printed, as it lowers the signal/noise ratio too profoundly.
108-
Ann _ (Const c) -> c
109-
where bind (Ignored x) f = let x' = name x in (,) x' <$> local (x':) (getConst (unScope f))
58+
prettyCore :: Style -> Term Core User -> AnsiDoc
59+
prettyCore style = run . runReader @Prec 0 . go (pure . name)
60+
where go :: (Member (Reader Prec) sig, Carrier sig m) => (a -> m AnsiDoc) -> Term Core a -> m AnsiDoc
61+
go var = \case
62+
Var v -> var v
63+
Term t -> case t of
64+
Let a -> pure $ keyword "let" <+> name a
65+
a :>> b -> do
66+
prec <- ask @Prec
67+
fore <- with 12 (go var a)
68+
aft <- with 12 (go var b)
69+
70+
let open = symbol ("{" <> softline)
71+
close = symbol (softline <> "}")
72+
separator = ";" <> Pretty.line
73+
body = fore <> separator <> aft
74+
75+
pure . Pretty.align $ encloseIf (12 > prec) open close (Pretty.align body)
76+
77+
Lam n f -> inParens 11 $ do
78+
(x, body) <- bind n f
79+
pure (lambda <> x <+> arrow <+> body)
80+
81+
Frame -> pure $ primitive "frame"
82+
Unit -> pure $ primitive "unit"
83+
Bool b -> pure $ primitive (if b then "true" else "false")
84+
String s -> pure . strlit $ Pretty.viaShow s
85+
86+
f :$ x -> inParens 11 $ (<+>) <$> go var f <*> go var x
87+
88+
If con tru fal -> do
89+
con' <- "if" `appending` go var con
90+
tru' <- "then" `appending` go var tru
91+
fal' <- "else" `appending` go var fal
92+
pure $ Pretty.sep [con', tru', fal']
93+
94+
Load p -> "load" `appending` go var p
95+
Edge Lexical n -> "lexical" `appending` go var n
96+
Edge Import n -> "import" `appending` go var n
97+
item :. body -> inParens 4 $ do
98+
f <- go var item
99+
g <- go var body
100+
pure (f <> symbol "." <> g)
101+
102+
lhs := rhs -> inParens 3 $ do
103+
f <- go var lhs
104+
g <- go var rhs
105+
pure (f <+> symbol "=" <+> g)
106+
107+
-- Annotations are not pretty-printed, as it lowers the signal/noise ratio too profoundly.
108+
Ann _ c -> go var c
109+
where bind (Ignored x) f = let x' = name x in (,) x' <$> go (incr (const (pure x')) var) (fromScope f)
110110
lambda = case style of
111111
Unicode -> symbol "λ"
112112
Ascii -> symbol "\\"
@@ -117,8 +117,3 @@ prettify style = \case
117117

118118
appending :: Functor f => AnsiDoc -> f AnsiDoc -> f AnsiDoc
119119
appending k item = (keyword k <+>) <$> item
120-
121-
prettyCore :: Style -> Term Core User -> AnsiDoc
122-
prettyCore s = run . runReader @Prec 0 . runReader @[AnsiDoc] [] . cata id (prettify s) bound (pure . name)
123-
where bound (Z _) = asks (head @AnsiDoc)
124-
bound (S n) = local (tail @AnsiDoc) n

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

Lines changed: 1 addition & 51 deletions
Original file line numberDiff line numberDiff line change
@@ -1,18 +1,11 @@
1-
{-# LANGUAGE DeriveTraversable, FlexibleInstances, LambdaCase, MultiParamTypeClasses, QuantifiedConstraints, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
1+
{-# LANGUAGE DeriveTraversable, FlexibleInstances, MultiParamTypeClasses, QuantifiedConstraints, StandaloneDeriving, UndecidableInstances #-}
22
module Data.Term
33
( Term(..)
4-
, Syntax(..)
5-
, iter
6-
, cata
7-
, interpret
84
) where
95

106
import Control.Effect.Carrier
117
import Control.Monad (ap)
128
import Control.Monad.Module
13-
import Data.Coerce (coerce)
14-
import Data.Functor.Const
15-
import Data.Scope
169

1710
data Term sig a
1811
= Var a
@@ -48,46 +41,3 @@ instance RightModule sig => Monad (Term sig) where
4841

4942
instance RightModule sig => Carrier sig (Term sig) where
5043
eff = Term
51-
52-
53-
class (HFunctor sig, forall g . Functor g => Functor (sig g)) => Syntax sig where
54-
foldSyntax :: (forall x y . (x -> m y) -> f x -> n y)
55-
-> (forall a . Incr () (n a) -> m (Incr () (n a)))
56-
-> (a -> m b)
57-
-> sig f a
58-
-> sig n b
59-
60-
instance Syntax (Scope ()) where
61-
foldSyntax go bound free = Scope . go (bound . fmap (go free)) . unScope
62-
63-
instance (Syntax l, Syntax r) => Syntax (l :+: r) where
64-
foldSyntax go bound free (L l) = L (foldSyntax go bound free l)
65-
foldSyntax go bound free (R r) = R (foldSyntax go bound free r)
66-
67-
68-
iter :: forall m n sig a b
69-
. Syntax sig
70-
=> (forall a . m a -> n a)
71-
-> (forall a . sig n a -> n a)
72-
-> (forall a . Incr () (n a) -> m (Incr () (n a)))
73-
-> (a -> m b)
74-
-> Term sig a
75-
-> n b
76-
iter var alg bound = go
77-
where go :: forall x y . (x -> m y) -> Term sig x -> n y
78-
go free = \case
79-
Var a -> var (free a)
80-
Term t -> alg (foldSyntax go bound free t)
81-
82-
cata :: Syntax sig
83-
=> (a -> b)
84-
-> (forall a . sig (Const b) a -> b)
85-
-> (Incr () b -> a)
86-
-> (x -> a)
87-
-> Term sig x
88-
-> b
89-
cata var alg k h = getConst . iter (coerce var) (Const . alg) (coerce k) (Const . h)
90-
91-
92-
interpret :: (Carrier sig m, Member eff sig, Syntax eff) => (forall a . Incr () (m a) -> m (Incr () (m a))) -> (a -> m b) -> Term eff a -> m b
93-
interpret = iter id send

0 commit comments

Comments
 (0)