Skip to content

Commit 6231daa

Browse files
ChickenPropChickenProp
committed
Better unquote macro.
It's in its own file for now. Also fixes a bug preventing eliminators being used at multiple types.
1 parent b42f6f1 commit 6231daa

File tree

3 files changed

+200
-4
lines changed

3 files changed

+200
-4
lines changed

‎app/Main.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -6,11 +6,11 @@ import Control.Monad.Except (liftEither, runExceptT)
66
import qualified Data.Text.IO as Text
77
import qualified GHC.IO.Encoding as Encoding
88
import qualified Options.Applicative as O
9-
import Shower (printer)
109

1110
import App
1211
import Env
1312
import Eval
13+
import Gist
1414
import Syntax
1515

1616
data CmdLine = CmdLine
@@ -68,7 +68,7 @@ doCmdLine :: CmdLine -> IO ()
6868
doCmdLine (CmdLine {..}) = runExceptT go >>= \case
6969
Left err -> Text.putStrLn err
7070
Right Nothing -> return ()
71-
Right (Just res) -> printer res
71+
Right (Just res) -> print (prettyGist res)
7272
where
7373
go = do
7474
(fName, src) <- case program of

‎examples/quote-2.hth‎

Lines changed: 194 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,194 @@
1+
(declarations
2+
(def (: << (-> (-> $b $c) (-> (-> $a $b) (-> $a $c))))
3+
(λ (f g x) (f (g x))))
4+
5+
(def (: ++ (-> (List $a) (-> (List $a) (List $a))))
6+
(λ (a b)
7+
(elim-List b (λ (a1 as) (Cons a1 (++ as b))) a)))
8+
9+
(def (: +:map (-> (-> $a $b) (-> (+ $x $a) (+ $x $b))))
10+
(λ f (elim-+ (λ x (Left x)) (λ a (Right (f a))))))
11+
12+
(def (: +:map-m (-> (-> $a (+ $b $c)) (-> (List $a) (+ $b (List $c)))))
13+
(λ f
14+
(elim-List (Right Nil)
15+
(λ (hd tl)
16+
# This ugly bit is just `(:) <$> f hd <*> +:map-m f tl`
17+
(let ((f-hd (f hd)))
18+
(if~ f-hd (Left $x)
19+
f-hd
20+
(if~ f-hd (Right $x)
21+
(let ((recurs (+:map-m f tl)))
22+
(if~ recurs (Left $y)
23+
recurs
24+
(if~ recurs (Right $y)
25+
(Right (Cons x y))
26+
(error! "impossible"))))
27+
(error! "impossible"))))))))
28+
)
29+
30+
(declarations
31+
(def (: List:map (-> (-> $a $b) (-> (List $a) (List $b))))
32+
(λ f
33+
(elim-List Nil (λ (hd tl) (Cons (f hd) (List:map f tl))))))
34+
35+
(def (: List:foldr (-> (-> $a (-> $b $b))
36+
(-> $b
37+
(-> (List $a)
38+
$b))))
39+
(λ (f init)
40+
(elim-List init (λ (hd tl) (f hd (List:foldr f init tl))))))
41+
)
42+
43+
(declarations
44+
(type (Maybe $a) Nothing (Just $a))
45+
(def (: Maybe:map (-> (-> $a $b) (-> (Maybe $a) (Maybe $b))))
46+
(λ f (elim-Maybe Nothing (<< Just f))))
47+
)
48+
49+
(declarations
50+
(type Bool False True)
51+
(defmacro if
52+
(λ ts
53+
(if~ ts (Cons $else Nil)
54+
else
55+
(if~ ts (Cons $cond (Cons $then $rest))
56+
(STTree (» Cons (STBare "if~")
57+
cond
58+
(STBare "True")
59+
then
60+
(STTree (Cons (STBare "if") rest))
61+
Nil))
62+
(error! "`if` must have an odd number of args")))))
63+
)
64+
65+
(declarations
66+
(def (: all (-> (-> $a Bool) (-> (List $a) Bool)))
67+
(λ f
68+
(elim-List True
69+
(λ (hd tl) (if (f hd) (all f tl) False)))))
70+
)
71+
72+
73+
(declarations
74+
(def (: STTree-2 (-> SyntaxTree (-> SyntaxTree SyntaxTree)))
75+
(λ (a b) (STTree (» Cons a b Nil))))
76+
(def (: STTree-3 (-> SyntaxTree (-> SyntaxTree (-> SyntaxTree SyntaxTree))))
77+
(λ (a b c) (STTree (» Cons a b c Nil))))
78+
79+
(def (: quote-fun (-> SyntaxTree SyntaxTree))
80+
(letrec
81+
((q-bare (λ x (STTree-2 (STBare "STBare") (STString x))))
82+
(q-string (λ x (STTree-2 (STBare "STString") (STString x))))
83+
(q-float (λ x (STTree-2 (STBare "STFloat") (STFloat x))))
84+
((: q-tree (-> (List SyntaxTree) SyntaxTree))
85+
(λ x
86+
(STTree-2 (STBare "STTree")
87+
(List:foldr (λ (hd tl)
88+
(STTree-3 (STBare "Cons") hd tl))
89+
(STBare "Nil")
90+
(List:map quote-fun x))))))
91+
(elim-SyntaxTree q-bare q-float q-string q-tree)))
92+
93+
(defmacro quote
94+
(λ ts
95+
(if~ ts (Cons $t Nil)
96+
(quote-fun t)
97+
(error! "Can only quote one thing"))))
98+
)
99+
100+
(declarations
101+
(type QQTree
102+
(QQLeaf SyntaxTree)
103+
(QQ-↑ SyntaxTree)
104+
(QQ-↑↑ SyntaxTree)
105+
(QQNode (List QQTree)))
106+
107+
(def (: parse-QQTree (-> SyntaxTree (+ String QQTree)))
108+
(letrec (((: immediate-leaves (-> (List QQTree) (Maybe (List SyntaxTree))))
109+
(elim-List
110+
(Just Nil)
111+
(λ (hd tl)
112+
(if~ hd (QQLeaf $t)
113+
(Maybe:map (Cons t) (immediate-leaves tl))
114+
Nothing))))
115+
((: build-tree (-> (List QQTree) QQTree))
116+
(λ qs (elim-Maybe (QQNode qs)
117+
(<< QQLeaf STTree)
118+
(immediate-leaves qs)))))
119+
(λ t
120+
(if~ t (STTree $tree)
121+
(if~ tree (Cons (STBare "↑") $rest)
122+
(if~ rest (Cons $arg Nil)
123+
(Right (QQ-↑ arg))
124+
(Left "↑ given more than one arg"))
125+
(if~ tree (Cons (STBare "↑↑") $rest)
126+
(if~ rest (Cons $arg Nil)
127+
(Right (QQ-↑↑ arg))
128+
(Left "↑↑ given more than one arg"))
129+
(+:map build-tree (+:map-m parse-QQTree tree))))
130+
(Right (QQLeaf t))))))
131+
132+
(def (: unQQ-root (-> QQTree (+ String SyntaxTree)))
133+
(elim-QQTree
134+
(<< Right quote-fun)
135+
Right
136+
(λ _ (Left "Cannot unQQ a ↑↑ at the root"))
137+
(λ qs
138+
(elim-+
139+
Left
140+
(λ ts
141+
(Right (STTree-2 (quote STTree)
142+
(List:foldr (λ (hd tl)
143+
(STTree-3 (quote ++) hd tl))
144+
(quote Nil)
145+
ts))))
146+
(+:map-m unQQ-nested qs)))))
147+
148+
(def (: unQQ-nested (-> QQTree (+ String SyntaxTree)))
149+
(let ((st-list1 (λ x (STTree (» Cons (quote Cons) x (quote Nil) Nil)))))
150+
(elim-QQTree
151+
(» << Right st-list1 quote-fun)
152+
(<< Right st-list1)
153+
Right
154+
(λ qs
155+
(elim-+
156+
Left
157+
(λ ts
158+
(Right (st-list1 (STTree-2 (quote STTree)
159+
(List:foldr (λ (hd tl)
160+
(STTree-3 (quote ++) hd tl))
161+
(quote Nil)
162+
ts)))))
163+
(+:map-m unQQ-nested qs))))))
164+
165+
(def (: qq-fun (-> SyntaxTree (+ String SyntaxTree)))
166+
(λ t (elim-+ Left unQQ-root (parse-QQTree t))))
167+
168+
(defmacro qq
169+
(λ ts
170+
(if~ ts (Cons $t Nil)
171+
(elim-+ error! (λ x x) (qq-fun t))
172+
(error! "Can only qq one thing"))))
173+
)
174+
175+
(declarations
176+
(defmacro list
177+
(letrec ((go (elim-List
178+
(quote Nil)
179+
(λ (hd tl)
180+
(qq (Cons (↑ hd) (↑ (go tl))))))))
181+
go))
182+
)
183+
184+
(declarations
185+
(defmacro if-qq
186+
(λ ts
187+
(if~ ts (Cons $else Nil)
188+
else
189+
(if~ ts (Cons $cond (Cons $then $rest))
190+
(qq (if~ (↑ cond) True (↑ then) (if-qq (↑↑ rest))))
191+
(error! "`if` must have an odd number of args")))))
192+
)
193+
194+
(list 1 (if-qq False 2 True 3 False 4 5) 3)

‎src/Env.hs‎

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -177,8 +177,10 @@ declareTypeEliminator (TypeDecl' { tdName, tdVars, tdConstructors }) env = do
177177
typeElimName (teType, typeElimVal) (feVars env)
178178
return env { feVars = newVars }
179179
where
180+
resultTVar :: TVar Tc
181+
resultTVar = TV HType "%a"
180182
resultType :: MType Tc
181-
resultType = TVar (TV HType "%a")
183+
resultType = TVar resultTVar
182184

183185
valKind = foldr (\_ a -> HType :*-> a) HType tdVars
184186
allVars = TV HType <$> tdVars
@@ -195,7 +197,7 @@ declareTypeEliminator (TypeDecl' { tdName, tdVars, tdConstructors }) env = do
195197
typeElimType = do
196198
mt <- foldr (+->) (valType +-> resultType)
197199
<$> mapM (conElimType . snd) tdConstructors
198-
return $ Forall allVars mt
200+
return $ Forall (resultTVar : allVars) mt
199201

200202
typeElimName :: Name
201203
typeElimName = "elim-" <> tdName

0 commit comments

Comments
 (0)