post

whole-program inference

whole-program inference

whole-program inference

README.org

@@ -58,20 +58,20 @@ Available debug flags include:
 
 * To-do List
 
-** TODO rlp to core desugaring                                         :feature:
+** TODO [#A] rlp to core desugaring                                    :feature:
 
 ** DONE [#A] HM memoisation prevents shadowing                             :bug:
    CLOSED: [2024-04-04 Thu 12:29]
-Example:
+   Example:
-#+begin_src haskell
+   #+begin_src haskell
--- >>> runHM' $ infer1 [rlpExpr|let f = \x -> x in f (let f = 2 in f)|]
+   -- >>> runHM' $ infer1 [rlpExpr|let f = \x -> x in f (let f = 2 in f)|]
--- Left [TyErrCouldNotUnify
+   -- Left [TyErrCouldNotUnify
---         (ConT "Int#")
+   --         (ConT "Int#")
---         (AppT (AppT FunT (ConT "Int#")) (VarT "$a2"))]
+   --         (AppT (AppT FunT (ConT "Int#")) (VarT "$a2"))]
--- >>> :t let f = \x -> x in f (let f = 2 in f)
+   -- >>> :t let f = \x -> x in f (let f = 2 in f)
--- let f = \x -> x in f (let f = 2 in f) :: Int
+   -- let f = \x -> x in f (let f = 2 in f) :: Int
-#+end_src
+   #+end_src
-For the time being, I just disabled the memoisation. This is very, very bad.
+   For the time being, I just disabled the memoisation. This is very, very bad.
 *** Closing Remarks
     Fixed by entirely rewriting the type inference algorithm :P. Memoisation is
     no longer required; the bottom-up inference a la Algorithm M was previously
@@ -99,10 +99,11 @@ For the time being, I just disabled the memoisation. This is very, very bad.
 ** DONE README.md -> README.org                                           :docs:
    CLOSED: [2024-03-28 Thu 10:44]
 
-** TODO ~case~ inference                                               :feature:
+** DONE [#A] ~case~ inference                                          :feature:
+   CLOSED: [2024-04-05 Fri 15:26]
 
-** DONE ADT support in Rlp/HindleyMilner.hs                            :feature:
+** DONE [#A] ADT support in Rlp/HindleyMilner.hs                       :feature:
-   CLOSED: [2024-03-28 Thu 11:55]
+   CLOSED: [2024-04-05 Fri 12:28]
 
 ** DONE whole-program inference (wrap top-level in a ~letrec~)         :feature:
    CLOSED: [2024-04-04 Thu 12:42]
@@ -115,15 +116,16 @@ For the time being, I just disabled the memoisation. This is very, very bad.
 
 ** TODO user-supplied annotation support in Rlp/HindleyMilner.hs       :feature:
 
-** TODO update architecture diagram                                       :docs:
+** DONE [#A] update architecture diagram                                  :docs:
+   CLOSED: [2024-04-05 Fri 15:41]
 
 ** TODO pattern support; everywhere [0%]                                :feature:
-   - [ ] in the type-checker
+   - [-] in the type-checker
    - [ ] in the desugarer
 
-** TODO G-machine visualiser                                              :docs:
+** TODO [#A] G-machine visualiser                                         :docs:
 
-** TODO lambda calculus visualiser                                        :docs:
+** TODO [#C] lambda calculus visualiser                                   :docs:
 
 ** TODO hmvis does not reload when redefining expressions                  :bug:
    To recreate:
@@ -152,6 +154,20 @@ For the time being, I just disabled the memoisation. This is very, very bad.
 - [ ] quicksort (core and rlp)
 - [ ] factorial (core and rlp)
 
+
+
+** TODO [#C] fix spacing in pretty-printing                                :bug:
+   note the extra space before the equals sign:
+   #begin_src
+   >>> makeItPretty $ justInferRlp "id x = x" <&> rlpProgToCore
+   Right 
+   
+   id : ∀ ($a0 : Type). $a0 -> $a0  = <lambda>;
+   #end_src
+
+
+** TODO Core.Utils.freeVariables does not handle let-bindings              :bug:
+
 * Releases
 
 ** +December Release+
@@ -176,13 +192,32 @@ For the time being, I just disabled the memoisation. This is very, very bad.
 - [X] Compiler architecture diagram
 - [X] More examples
 
-** March Release Plan
+** Final Release Plan
-- [ ] Tests
+   SCHEDULED: <2024-04-19 Fri>
+*** TODO Complete all A-priority checks in the main todo-list!!
+*** TODO Tests
     - [ ] rl' parser
     - [ ] Type inference
-- [X] Ditch TTG in favour of a simpler AST focusing on extendability via Fix, Free, 
+*** TODO Examples
-  Cofree, etc. rather than boilerplate-heavy type families
+    - [ ] quicksort
-- [X] rl' type inference
+    - [ ] factorial
-- [X] Core type checking
+    - [ ] your typical FP operations -- mapping, folding, etc.
+*** DONE Ditch TTG in favour of fixed-points of functors
+    Focus on extendability via Fix, Free, Cofree, etc. rather than
+    boilerplate-heavy type families
+*** DONE rl' type inference
+*** DONE Core type checking
 
+** Presentation
+   SCHEDULED: <2024-05-10 Fri>
+*** TODO Documentation
+    - [ ] Type inference / Algorithm M
+    - [ ] The G-Machine
+*** TODO G-Machine visualiser
+*** TODO Post-mortem write-up
+    e.g. what would I do differently next time, what have I learned, etc.
+*** TODO Final polish check [0/3]
+    - [ ] CLI
+    - [ ] G-Machine output
+    - [ ] ~Compiler.JustRun~ module
 

doc/src/commentary/post-mortem.rst

@@ -0,0 +1,6 @@
+rlpc Post-Mortem
+================
+
+I begin writing this (10:11 AM, 15 Apr) shortly after I push what I believe to
+be one of my final commits.
+

rlp.cabal

@@ -56,6 +56,7 @@ library
                     , Rlp2Core
                     , Control.Monad.Utils
                     , Misc
+                    , Misc.MonadicRecursionSchemes
                     , Misc.Lift1
                     , Misc.CofreeF
                     , Core.SystemF
@@ -67,14 +68,13 @@ library
                     -- required for happy
                     , array >= 0.5.5 && < 0.6
                     , containers >= 0.6.7 && < 0.7
-                    , template-haskell >= 2.20.0 && < 2.22
+                    , template-haskell >= 2.20.0 && < 2.23
-                    , prettyprinter
+                    , pretty >= 1.1.3 && < 1.2
                     , data-default >= 0.7.1 && < 0.8
                     , data-default-class >= 0.1.2 && < 0.2
                     , hashable >= 1.4.3 && < 1.5
                     , mtl >= 2.3.1 && < 2.4
-                    , transformers
+                    , text >= 2.0.2 && < 2.3
-                    , text >= 2.0.2 && < 2.2
                     , unordered-containers >= 0.2.20 && < 0.3
                     , recursion-schemes >= 5.2.2 && < 5.3
                     , data-fix >= 0.3.2 && < 0.4
@@ -119,11 +119,7 @@ executable rlpc
                  , mtl >= 2.3.1 && < 2.4
                  , unordered-containers >= 0.2.20 && < 0.3
                  , lens >=5.2.3 && <6.0
-                 , text >= 2.0.2 && < 2.2
+                 , text >= 2.0.2 && < 2.3
-                 , websockets
-                 , aeson
-                 , recursion-schemes >= 5.2.2 && < 5.3
-                 , comonad
 
     hs-source-dirs:   app
     default-language: GHC2021

rlpc.drawio

@@ -1,6 +1,6 @@
-<mxfile host="app.diagrams.net" modified="2024-02-08T07:33:52.268Z" agent="Mozilla/5.0 (Macintosh; Intel Mac OS X 10.15; rv:122.0) Gecko/20100101 Firefox/122.0" etag="_2ex2NLQLCDMU70EmKFT" version="23.0.2" type="device">
+<mxfile host="app.diagrams.net" modified="2024-04-05T21:39:15.427Z" agent="Mozilla/5.0 (Macintosh; Intel Mac OS X 10.15; rv:124.0) Gecko/20100101 Firefox/124.0" etag="vzU3tfRucuQcOEqioBHC" version="23.1.2" type="device">
   <diagram name="Page-1" id="ijVUcW-Be2043inOeyM6">
-    <mxGraphModel dx="1629" dy="2189" grid="1" gridSize="10" guides="1" tooltips="1" connect="1" arrows="1" fold="1" page="1" pageScale="1" pageWidth="827" pageHeight="1169" math="0" shadow="0">
+    <mxGraphModel dx="1792" dy="2289" grid="1" gridSize="10" guides="1" tooltips="1" connect="1" arrows="1" fold="1" page="1" pageScale="1" pageWidth="827" pageHeight="1169" math="0" shadow="0">
       <root>
         <mxCell id="0" />
         <mxCell id="1" parent="0" />
@@ -22,13 +22,13 @@
         <mxCell id="l7NxJpuHm0Jx_7flO9iA-57" value="&lt;div&gt;&lt;font face=&quot;Helvetica&quot;&gt;Parser&lt;/font&gt;&lt;/div&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-56" vertex="1">
           <mxGeometry width="431.6" height="27.6975" as="geometry" />
         </mxCell>
-        <mxCell id="l7NxJpuHm0Jx_7flO9iA-58" value="Rlp.Parse&lt;br&gt;&lt;div&gt;(src/Rlp/Parse.y)&lt;/div&gt;" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;whiteSpace=wrap;points=[];strokeColor=#6c8ebf;fillColor=#dae8fc;glass=0;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-56" vertex="1">
+        <mxCell id="l7NxJpuHm0Jx_7flO9iA-58" value="Rlp.AltParse&lt;br&gt;&lt;div&gt;(src/Rlp/AltParse.y)&lt;/div&gt;" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;whiteSpace=wrap;points=[];strokeColor=#6c8ebf;fillColor=#dae8fc;glass=0;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-56" vertex="1">
           <mxGeometry x="26.980533333333334" y="27.6975" width="371.43053333333336" height="55.395" as="geometry" />
         </mxCell>
         <mxCell id="l7NxJpuHm0Jx_7flO9iA-59" value="&lt;div&gt;Rlp.Lex&lt;/div&gt;&lt;div&gt;&lt;br&gt;&lt;/div&gt;&lt;div&gt;(src/Rlp/Lex.x)&lt;br&gt;&lt;/div&gt;" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-56" vertex="1">
           <mxGeometry x="26.98606666666666" y="147.72" width="170.33402285714286" height="55.395" as="geometry" />
         </mxCell>
-        <mxCell id="l7NxJpuHm0Jx_7flO9iA-61" value="" style="endArrow=classic;html=1;rounded=0;fontFamily=Courier New;exitX=0.25;exitY=0;exitDx=0;exitDy=0;" parent="l7NxJpuHm0Jx_7flO9iA-56" edge="1" source="l7NxJpuHm0Jx_7flO9iA-59">
+        <mxCell id="l7NxJpuHm0Jx_7flO9iA-61" value="" style="endArrow=classic;html=1;rounded=0;fontFamily=Courier New;exitX=0.25;exitY=0;exitDx=0;exitDy=0;" parent="l7NxJpuHm0Jx_7flO9iA-56" source="l7NxJpuHm0Jx_7flO9iA-59" edge="1">
           <mxGeometry relative="1" as="geometry">
             <mxPoint x="111.49666666666668" y="147.72" as="sourcePoint" />
             <mxPoint x="69.26631355932203" y="83.84879190161169" as="targetPoint" />
@@ -48,18 +48,18 @@
             <mxPoint x="394.60571428571427" y="175.4175" as="targetPoint" />
           </mxGeometry>
         </mxCell>
-        <mxCell id="l7NxJpuHm0Jx_7flO9iA-77" value="&lt;div&gt;RlpProgram&#39; RlpcPs&lt;/div&gt;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-75" vertex="1" connectable="0">
+        <mxCell id="l7NxJpuHm0Jx_7flO9iA-77" value="&lt;div&gt;Rlp.Program PsName RlpExpr&#39;&lt;br&gt;&lt;/div&gt;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-75" vertex="1" connectable="0">
           <mxGeometry x="0.0677" y="5" relative="1" as="geometry">
             <mxPoint x="39" y="6" as="offset" />
           </mxGeometry>
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-3" value="" style="endArrow=classic;html=1;rounded=0;exitX=0.368;exitY=1.014;exitDx=0;exitDy=0;exitPerimeter=0;entryX=0.811;entryY=-0.021;entryDx=0;entryDy=0;entryPerimeter=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-56" source="l7NxJpuHm0Jx_7flO9iA-58" target="l7NxJpuHm0Jx_7flO9iA-59">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-3" value="" style="endArrow=classic;html=1;rounded=0;exitX=0.368;exitY=1.014;exitDx=0;exitDy=0;exitPerimeter=0;entryX=0.811;entryY=-0.021;entryDx=0;entryDy=0;entryPerimeter=0;" parent="l7NxJpuHm0Jx_7flO9iA-56" source="l7NxJpuHm0Jx_7flO9iA-58" target="l7NxJpuHm0Jx_7flO9iA-59" edge="1">
           <mxGeometry width="50" height="50" relative="1" as="geometry">
             <mxPoint x="168.70805084745763" y="201.9041131288017" as="sourcePoint" />
             <mxPoint x="225.8584745762712" y="152.71439595080588" as="targetPoint" />
           </mxGeometry>
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-4" value="&lt;p style=&quot;line-height: 60%;&quot;&gt;&lt;font style=&quot;font-size: 7px;&quot;&gt;(lexer &amp;amp; parser threaded w/ CPS)&lt;/font&gt;&lt;/p&gt;" style="text;html=1;strokeColor=none;fillColor=none;align=center;verticalAlign=middle;whiteSpace=wrap;rounded=0;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-56">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-4" value="&lt;p style=&quot;line-height: 60%;&quot;&gt;&lt;font style=&quot;font-size: 7px;&quot;&gt;(lexer &amp;amp; parser threaded w/ CPS)&lt;/font&gt;&lt;/p&gt;" style="text;html=1;strokeColor=none;fillColor=none;align=center;verticalAlign=middle;whiteSpace=wrap;rounded=0;" parent="l7NxJpuHm0Jx_7flO9iA-56" vertex="1">
           <mxGeometry x="88.69745762711862" y="103.52467877281002" width="68.58050847457626" height="29.513830306797498" as="geometry" />
         </mxCell>
         <mxCell id="l7NxJpuHm0Jx_7flO9iA-69" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-2" vertex="1">
@@ -68,185 +68,195 @@
         <mxCell id="l7NxJpuHm0Jx_7flO9iA-70" value="&lt;div&gt;&lt;font face=&quot;Helvetica&quot;&gt;Desugarer&lt;/font&gt;&lt;/div&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-69" vertex="1">
           <mxGeometry width="431.6" height="46.091157894736845" as="geometry" />
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-1" value="&lt;div&gt;Rlp2Core&lt;/div&gt;" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-69">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-1" value="&lt;div&gt;Rlp2Core&lt;/div&gt;" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-69" vertex="1">
           <mxGeometry x="22.122266666666665" y="46.088669843028626" width="387.34440000000006" height="159.17559608494923" as="geometry" />
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-6" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-2">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-6" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-2" vertex="1">
-          <mxGeometry x="904" y="68.42105263157895" width="186.6" height="697.8947368421053" as="geometry" />
+          <mxGeometry x="904" y="68.42105263157895" width="244.8600518134714" height="697.8947368421053" as="geometry" />
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-7" value="&lt;font face=&quot;Helvetica&quot;&gt;Evaluation Model&lt;br&gt;&lt;/font&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-6">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-7" value="&lt;font face=&quot;Helvetica&quot;&gt;Evaluation Model&lt;br&gt;&lt;/font&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" parent="MMc0v0DIyy0xya0iXp__-6" vertex="1">
           <mxGeometry width="186.6" height="107.07065060420568" as="geometry" />
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-8" value="GM" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-6">
+        <mxCell id="DDBEc0rYRfbomnRGFAIR-4" value="GM" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;verticalAlign=top;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-6">
-          <mxGeometry x="9.568013810372213" y="356.90796215152363" width="167.46559322033886" height="82.98740890928475" as="geometry" />
+          <mxGeometry x="10" y="70" width="220" height="260.78" as="geometry" />
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-9" value="TM" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-6">
+        <mxCell id="DDBEc0rYRfbomnRGFAIR-5" value="&lt;font face=&quot;Courier New&quot;&gt;compile&lt;/font&gt;" style="rounded=1;whiteSpace=wrap;html=1;fillColor=#d5e8d4;strokeColor=#82b366;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-6">
-          <mxGeometry x="9.562261652542377" y="263.9548629430177" width="167.46559322033886" height="82.98740890928475" as="geometry" />
+          <mxGeometry x="26" y="91.58" width="184" height="37.03" as="geometry" />
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-10" value="TIM" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-6">
+        <mxCell id="DDBEc0rYRfbomnRGFAIR-6" value="&lt;font face=&quot;Courier New&quot;&gt;eval&lt;/font&gt;" style="rounded=1;whiteSpace=wrap;html=1;fillColor=#d5e8d4;strokeColor=#82b366;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-6">
-          <mxGeometry x="9.56226165254238" y="168.9311122835313" width="167.46559322033886" height="82.98740890928475" as="geometry" />
+          <mxGeometry x="26" y="211.58" width="184" height="37.03" as="geometry" />
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-11" value="STG" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-6">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-32" value="" style="endArrow=classic;html=1;rounded=0;entryX=0.5;entryY=0;entryDx=0;entryDy=0;exitX=0.5;exitY=1;exitDx=0;exitDy=0;" parent="MMc0v0DIyy0xya0iXp__-6" source="DDBEc0rYRfbomnRGFAIR-5" target="DDBEc0rYRfbomnRGFAIR-6" edge="1">
-          <mxGeometry x="9.56720338983051" y="73.90736162404495" width="167.46559322033886" height="82.98740890928475" as="geometry" />
+          <mxGeometry width="50" height="50" relative="1" as="geometry">
+            <mxPoint x="-94" y="520" as="sourcePoint" />
+            <mxPoint x="-44" y="451.57894736842104" as="targetPoint" />
+          </mxGeometry>
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-12" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-2">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-33" value="&lt;font face=&quot;Courier New&quot;&gt;[Instr]&lt;/font&gt;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];" parent="MMc0v0DIyy0xya0iXp__-32" vertex="1" connectable="0">
+          <mxGeometry x="0.0406" y="1" relative="1" as="geometry">
+            <mxPoint as="offset" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="DDBEc0rYRfbomnRGFAIR-7" value="" style="curved=1;endArrow=classic;html=1;rounded=0;entryX=0.922;entryY=0.046;entryDx=0;entryDy=0;entryPerimeter=0;" edge="1" parent="MMc0v0DIyy0xya0iXp__-6" target="DDBEc0rYRfbomnRGFAIR-6">
+          <mxGeometry width="50" height="50" relative="1" as="geometry">
+            <mxPoint x="210" y="231.57894736842104" as="sourcePoint" />
+            <mxPoint x="260" y="181.57894736842104" as="targetPoint" />
+            <Array as="points">
+              <mxPoint x="226" y="231.57894736842104" />
+              <mxPoint x="236" y="201.57894736842104" />
+              <mxPoint x="236" y="191.57894736842104" />
+              <mxPoint x="226" y="181.57894736842104" />
+              <mxPoint x="206" y="181.57894736842104" />
+              <mxPoint x="196" y="191.57894736842104" />
+            </Array>
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="DDBEc0rYRfbomnRGFAIR-8" value="&lt;font face=&quot;Courier New&quot;&gt;GMState&lt;/font&gt;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];" vertex="1" connectable="0" parent="MMc0v0DIyy0xya0iXp__-6">
+          <mxGeometry x="216" y="171.58333333333314" as="geometry">
+            <mxPoint x="-4" y="-1" as="offset" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-12" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-2" vertex="1">
           <mxGeometry x="530" y="68.42" width="281.6" height="314.74" as="geometry" />
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-13" value="&lt;div&gt;&lt;font face=&quot;Helvetica&quot;&gt;Preprocessing&lt;/font&gt;&lt;/div&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-12">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-13" value="&lt;div&gt;&lt;font face=&quot;Helvetica&quot;&gt;Preprocessing&lt;/font&gt;&lt;/div&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" parent="MMc0v0DIyy0xya0iXp__-12" vertex="1">
           <mxGeometry width="281.5999999999999" height="24.68549019607843" as="geometry" />
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-15" value="Core2Core" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;verticalAlign=top;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-12">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-15" value="Core2Core" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;verticalAlign=top;" parent="MMc0v0DIyy0xya0iXp__-12" vertex="1">
           <mxGeometry x="22.25077720207253" y="49.37098039215686" width="237.09844559585483" height="259.1976470588235" as="geometry" />
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-16" value="&lt;font face=&quot;Courier New&quot;&gt;tagData&lt;/font&gt;" style="rounded=1;whiteSpace=wrap;html=1;fillColor=#d5e8d4;strokeColor=#82b366;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-12">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-16" value="&lt;font face=&quot;Courier New&quot;&gt;tagData&lt;/font&gt;" style="rounded=1;whiteSpace=wrap;html=1;fillColor=#d5e8d4;strokeColor=#82b366;" parent="MMc0v0DIyy0xya0iXp__-12" vertex="1">
           <mxGeometry x="31.36994818652857" y="74.0564705882353" width="218.860103626943" height="37.02823529411765" as="geometry" />
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-18" value="&lt;font face=&quot;Courier New&quot;&gt;defineData&lt;/font&gt;" style="rounded=1;whiteSpace=wrap;html=1;fillColor=#d5e8d4;strokeColor=#82b366;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-12">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-18" value="&lt;font face=&quot;Courier New&quot;&gt;defineData&lt;/font&gt;" style="rounded=1;whiteSpace=wrap;html=1;fillColor=#d5e8d4;strokeColor=#82b366;" parent="MMc0v0DIyy0xya0iXp__-12" vertex="1">
           <mxGeometry x="31.36994818652857" y="160.45568627450984" width="218.860103626943" height="37.02823529411765" as="geometry" />
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-17" value="&lt;font face=&quot;Courier New&quot;&gt;liftNonStrictCases&lt;/font&gt;" style="rounded=1;whiteSpace=wrap;html=1;fillColor=#d5e8d4;strokeColor=#82b366;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-12">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-17" value="&lt;font face=&quot;Courier New&quot;&gt;liftNonStrictCases&lt;/font&gt;" style="rounded=1;whiteSpace=wrap;html=1;fillColor=#d5e8d4;strokeColor=#82b366;" parent="MMc0v0DIyy0xya0iXp__-12" vertex="1">
           <mxGeometry x="31.369948186528582" y="118.66932274509804" width="218.860103626943" height="37.02823529411765" as="geometry" />
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-20" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-2">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-27" value="" style="endArrow=classic;html=1;rounded=0;entryX=-0.019;entryY=0.844;entryDx=0;entryDy=0;entryPerimeter=0;exitX=0.98;exitY=0.066;exitDx=0;exitDy=0;exitPerimeter=0;" parent="l7NxJpuHm0Jx_7flO9iA-2" source="MMc0v0DIyy0xya0iXp__-1" target="MMc0v0DIyy0xya0iXp__-12" edge="1">
-          <mxGeometry x="1240" y="68.42105263157895" width="186.6" height="697.8947368421053" as="geometry" />
-        </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-21" value="&lt;font face=&quot;Helvetica&quot;&gt;Some target&lt;br&gt;&lt;/font&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-20">
-          <mxGeometry width="186.6" height="107.07065060420568" as="geometry" />
-        </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-27" value="" style="endArrow=classic;html=1;rounded=0;entryX=-0.019;entryY=0.844;entryDx=0;entryDy=0;entryPerimeter=0;exitX=0.98;exitY=0.066;exitDx=0;exitDy=0;exitPerimeter=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-2" source="MMc0v0DIyy0xya0iXp__-1" target="MMc0v0DIyy0xya0iXp__-12">
           <mxGeometry width="50" height="50" relative="1" as="geometry">
             <mxPoint x="450" y="684.2105263157895" as="sourcePoint" />
             <mxPoint x="500" y="615.7894736842105" as="targetPoint" />
           </mxGeometry>
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-28" value="&lt;font face=&quot;Courier New&quot;&gt;Program&#39;&lt;/font&gt;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];" vertex="1" connectable="0" parent="MMc0v0DIyy0xya0iXp__-27">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-28" value="&lt;font face=&quot;Courier New&quot;&gt;Core.Program Var&lt;br&gt;&lt;/font&gt;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];" parent="MMc0v0DIyy0xya0iXp__-27" vertex="1" connectable="0">
           <mxGeometry x="-0.1473" y="1" relative="1" as="geometry">
             <mxPoint x="7" y="1" as="offset" />
           </mxGeometry>
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-30" value="" style="endArrow=classic;html=1;rounded=0;entryX=-0.013;entryY=0.321;entryDx=0;entryDy=0;exitX=1;exitY=0.5;exitDx=0;exitDy=0;entryPerimeter=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-2" source="MMc0v0DIyy0xya0iXp__-12" target="MMc0v0DIyy0xya0iXp__-6">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-30" value="" style="endArrow=classic;html=1;rounded=0;entryX=-0.013;entryY=0.321;entryDx=0;entryDy=0;exitX=1;exitY=0.5;exitDx=0;exitDy=0;entryPerimeter=0;" parent="l7NxJpuHm0Jx_7flO9iA-2" source="MMc0v0DIyy0xya0iXp__-12" target="MMc0v0DIyy0xya0iXp__-6" edge="1">
           <mxGeometry width="50" height="50" relative="1" as="geometry">
             <mxPoint x="810" y="588.421052631579" as="sourcePoint" />
             <mxPoint x="860" y="520" as="targetPoint" />
           </mxGeometry>
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-31" value="&lt;font face=&quot;Courier New&quot;&gt;Program&#39;&lt;/font&gt;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];" vertex="1" connectable="0" parent="MMc0v0DIyy0xya0iXp__-30">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-31" value="&lt;font face=&quot;Courier New&quot;&gt;Core.Program Name&lt;br&gt;&lt;/font&gt;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];" parent="MMc0v0DIyy0xya0iXp__-30" vertex="1" connectable="0">
           <mxGeometry x="0.0097" y="-1" relative="1" as="geometry">
             <mxPoint x="-1" as="offset" />
           </mxGeometry>
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-32" value="" style="endArrow=classic;html=1;rounded=0;entryX=0;entryY=0.5;entryDx=0;entryDy=0;exitX=1;exitY=0.5;exitDx=0;exitDy=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-2" source="MMc0v0DIyy0xya0iXp__-6" target="MMc0v0DIyy0xya0iXp__-20">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-35" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-2" vertex="1">
-          <mxGeometry width="50" height="50" relative="1" as="geometry">
-            <mxPoint x="810" y="588.421052631579" as="sourcePoint" />
-            <mxPoint x="860" y="520" as="targetPoint" />
-          </mxGeometry>
-        </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-33" value="&lt;font face=&quot;Courier New&quot;&gt;[Instr]&lt;/font&gt;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];" vertex="1" connectable="0" parent="MMc0v0DIyy0xya0iXp__-32">
-          <mxGeometry x="0.0406" y="1" relative="1" as="geometry">
-            <mxPoint as="offset" />
-          </mxGeometry>
-        </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-35" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-2">
           <mxGeometry x="530" y="630" width="281.6" height="131.32" as="geometry" />
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-36" value="&lt;font face=&quot;Helvetica&quot;&gt;Core Parser&lt;br&gt;&lt;/font&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-35">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-36" value="&lt;font face=&quot;Helvetica&quot;&gt;Core Parser&lt;br&gt;&lt;/font&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" parent="MMc0v0DIyy0xya0iXp__-35" vertex="1">
           <mxGeometry width="281.59999999999997" height="10.299607843137254" as="geometry" />
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-41" value="Core.Lex" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-35">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-41" value="Core.Lex" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" parent="MMc0v0DIyy0xya0iXp__-35" vertex="1">
           <mxGeometry x="10.140518134715029" y="16.369019607843132" width="87.1306390328152" height="106.24535947712415" as="geometry" />
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-42" value="Core.Parse" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-35">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-42" value="Core.Parse" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" parent="MMc0v0DIyy0xya0iXp__-35" vertex="1">
           <mxGeometry x="182.3834196891192" y="16.369019607843146" width="87.1306390328152" height="106.24535947712415" as="geometry" />
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-43" value="&lt;font face=&quot;Courier New&quot;&gt;CoreToken&lt;/font&gt;" style="endArrow=classic;html=1;rounded=0;entryX=0;entryY=0.5;entryDx=0;entryDy=0;exitX=1;exitY=0.5;exitDx=0;exitDy=0;" edge="1" parent="MMc0v0DIyy0xya0iXp__-35" source="MMc0v0DIyy0xya0iXp__-41" target="MMc0v0DIyy0xya0iXp__-42">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-43" value="&lt;font face=&quot;Courier New&quot;&gt;CoreToken&lt;/font&gt;" style="endArrow=classic;html=1;rounded=0;entryX=0;entryY=0.5;entryDx=0;entryDy=0;exitX=1;exitY=0.5;exitDx=0;exitDy=0;" parent="MMc0v0DIyy0xya0iXp__-35" source="MMc0v0DIyy0xya0iXp__-41" target="MMc0v0DIyy0xya0iXp__-42" edge="1">
           <mxGeometry width="50" height="50" relative="1" as="geometry">
             <mxPoint x="-72.95336787564769" y="39.35921568627452" as="sourcePoint" />
             <mxPoint x="-12.15889464594128" y="1.0422222222222326" as="targetPoint" />
           </mxGeometry>
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-51" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-2">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-51" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-2" vertex="1">
           <mxGeometry x="530" y="440" width="281.6" height="131.32" as="geometry" />
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-52" value="&lt;font face=&quot;Helvetica&quot;&gt;Core Type-checker&lt;br&gt;&lt;/font&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-51">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-52" value="&lt;font face=&quot;Helvetica&quot;&gt;Core Type-checker&lt;br&gt;&lt;/font&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" parent="MMc0v0DIyy0xya0iXp__-51" vertex="1">
           <mxGeometry width="281.59999999999997" height="10.299607843137254" as="geometry" />
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-46" value="(currently unimplemented)" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-72">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-46" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-72" vertex="1">
           <mxGeometry x="40" y="360" width="431.6" height="90.46" as="geometry" />
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-47" value="&lt;font face=&quot;Verdana&quot;&gt;Type-checker&lt;/font&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-46">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-47" value="&lt;font face=&quot;Verdana&quot;&gt;Type-checker&lt;/font&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" parent="MMc0v0DIyy0xya0iXp__-46" vertex="1">
           <mxGeometry width="431.6" height="18.092000000000002" as="geometry" />
         </mxCell>
-        <mxCell id="l7NxJpuHm0Jx_7flO9iA-80" value="" style="endArrow=classic;html=1;rounded=0;" parent="l7NxJpuHm0Jx_7flO9iA-72" source="l7NxJpuHm0Jx_7flO9iA-74" target="MMc0v0DIyy0xya0iXp__-46" edge="1">
+        <mxCell id="l7NxJpuHm0Jx_7flO9iA-80" value="" style="endArrow=classic;html=1;rounded=0;" parent="l7NxJpuHm0Jx_7flO9iA-72" source="DDBEc0rYRfbomnRGFAIR-1" target="MMc0v0DIyy0xya0iXp__-46" edge="1">
           <mxGeometry relative="1" as="geometry">
             <mxPoint x="537.6" y="424.2105263157895" as="sourcePoint" />
             <mxPoint x="-40" y="490" as="targetPoint" />
           </mxGeometry>
         </mxCell>
-        <mxCell id="l7NxJpuHm0Jx_7flO9iA-81" value="&lt;font face=&quot;Courier New&quot;&gt;RlpProgram&#39; RlpcPs&lt;br&gt;&lt;/font&gt;" style="edgeLabel;resizable=0;html=1;align=center;verticalAlign=middle;" parent="l7NxJpuHm0Jx_7flO9iA-80" connectable="0" vertex="1">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-49" value="" style="endArrow=classic;html=1;rounded=0;" parent="l7NxJpuHm0Jx_7flO9iA-72" source="MMc0v0DIyy0xya0iXp__-46" target="l7NxJpuHm0Jx_7flO9iA-69" edge="1">
-          <mxGeometry relative="1" as="geometry">
-            <mxPoint x="6" as="offset" />
-          </mxGeometry>
-        </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-49" value="" style="endArrow=classic;html=1;rounded=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-72" source="MMc0v0DIyy0xya0iXp__-46" target="l7NxJpuHm0Jx_7flO9iA-69">
           <mxGeometry relative="1" as="geometry">
             <mxPoint x="352" y="282" as="sourcePoint" />
             <mxPoint x="295" y="370" as="targetPoint" />
           </mxGeometry>
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-50" value="&lt;font face=&quot;Courier New&quot;&gt;RlpProgram&#39; RlpcTc&lt;/font&gt;" style="edgeLabel;resizable=0;html=1;align=center;verticalAlign=middle;" connectable="0" vertex="1" parent="MMc0v0DIyy0xya0iXp__-49">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-50" value="&lt;font face=&quot;Courier New&quot;&gt;Rlp.Program PsName (Cofree RlpExprF&#39; Type&#39;)&lt;br&gt;&lt;/font&gt;" style="edgeLabel;resizable=0;html=1;align=center;verticalAlign=middle;" parent="MMc0v0DIyy0xya0iXp__-49" connectable="0" vertex="1">
           <mxGeometry relative="1" as="geometry">
             <mxPoint x="6" as="offset" />
           </mxGeometry>
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-57" value="Core.HindleyMilner" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-72">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-57" value="Core.HindleyMilner" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-72" vertex="1">
           <mxGeometry x="540" y="460" width="260" height="106.24" as="geometry" />
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-58" value="" style="endArrow=classic;html=1;rounded=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-72" source="MMc0v0DIyy0xya0iXp__-42" target="MMc0v0DIyy0xya0iXp__-57">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-58" value="" style="endArrow=classic;html=1;rounded=0;" parent="l7NxJpuHm0Jx_7flO9iA-72" source="MMc0v0DIyy0xya0iXp__-42" target="MMc0v0DIyy0xya0iXp__-57" edge="1">
           <mxGeometry width="50" height="50" relative="1" as="geometry">
             <mxPoint x="530" y="550" as="sourcePoint" />
             <mxPoint x="580" y="500" as="targetPoint" />
           </mxGeometry>
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-59" value="Program&#39;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];fontFamily=Courier New;" vertex="1" connectable="0" parent="MMc0v0DIyy0xya0iXp__-58">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-59" value="Core.Program PsName" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];fontFamily=Courier New;" parent="MMc0v0DIyy0xya0iXp__-58" vertex="1" connectable="0">
           <mxGeometry x="-0.0188" y="-3" relative="1" as="geometry">
             <mxPoint y="-1" as="offset" />
           </mxGeometry>
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-60" value="" style="endArrow=classic;html=1;rounded=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-72" source="MMc0v0DIyy0xya0iXp__-57" target="MMc0v0DIyy0xya0iXp__-15">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-60" value="" style="endArrow=classic;html=1;rounded=0;" parent="l7NxJpuHm0Jx_7flO9iA-72" source="MMc0v0DIyy0xya0iXp__-57" target="MMc0v0DIyy0xya0iXp__-15" edge="1">
           <mxGeometry width="50" height="50" relative="1" as="geometry">
             <mxPoint x="741" y="656" as="sourcePoint" />
             <mxPoint x="704" y="576" as="targetPoint" />
           </mxGeometry>
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-61" value="Program&#39;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];fontFamily=Courier New;" vertex="1" connectable="0" parent="MMc0v0DIyy0xya0iXp__-60">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-61" value="Core.Program Var" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];fontFamily=Courier New;" parent="MMc0v0DIyy0xya0iXp__-60" vertex="1" connectable="0">
           <mxGeometry x="-0.0188" y="-3" relative="1" as="geometry">
             <mxPoint y="-1" as="offset" />
           </mxGeometry>
         </mxCell>
+        <mxCell id="DDBEc0rYRfbomnRGFAIR-1" value="Rlp.HindleyMilner" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-72">
+          <mxGeometry x="49.47" y="380" width="410.53" height="60" as="geometry" />
+        </mxCell>
+        <mxCell id="DDBEc0rYRfbomnRGFAIR-2" value="" style="endArrow=classic;html=1;rounded=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-72" source="l7NxJpuHm0Jx_7flO9iA-74" target="DDBEc0rYRfbomnRGFAIR-1">
+          <mxGeometry relative="1" as="geometry">
+            <mxPoint x="492" y="212" as="sourcePoint" />
+            <mxPoint x="435" y="300" as="targetPoint" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="DDBEc0rYRfbomnRGFAIR-3" value="&lt;font face=&quot;Courier New&quot;&gt;Rlp.Program PsName RlpExpr&#39;&lt;br&gt;&lt;/font&gt;" style="edgeLabel;resizable=0;html=1;align=center;verticalAlign=middle;" connectable="0" vertex="1" parent="DDBEc0rYRfbomnRGFAIR-2">
+          <mxGeometry relative="1" as="geometry">
+            <mxPoint x="6" as="offset" />
+          </mxGeometry>
+        </mxCell>
         <mxCell id="l7NxJpuHm0Jx_7flO9iA-65" value="" style="endArrow=classic;html=1;rounded=0;fontFamily=Courier New;" parent="1" source="l7NxJpuHm0Jx_7flO9iA-64" target="l7NxJpuHm0Jx_7flO9iA-59" edge="1">
           <mxGeometry width="50" height="50" relative="1" as="geometry">
             <mxPoint x="290" y="400" as="sourcePoint" />
             <mxPoint x="340" y="350" as="targetPoint" />
           </mxGeometry>
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-26" value="&lt;font face=&quot;Helvetica&quot;&gt;Core source code&lt;br&gt;&lt;/font&gt;" style="rounded=0;whiteSpace=wrap;html=1;fillColor=#fff2cc;strokeColor=#d6b656;fontFamily=Courier New;" vertex="1" parent="1">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-26" value="&lt;font face=&quot;Helvetica&quot;&gt;Core source code&lt;br&gt;&lt;/font&gt;" style="rounded=0;whiteSpace=wrap;html=1;fillColor=#fff2cc;strokeColor=#d6b656;fontFamily=Courier New;" parent="1" vertex="1">
           <mxGeometry x="673.7099999999999" y="740" width="120" height="60" as="geometry" />
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-29" value="&lt;div&gt;&lt;font face=&quot;Helvetica&quot;&gt;???&lt;/font&gt;&lt;/div&gt;" style="rounded=0;whiteSpace=wrap;html=1;fillColor=#fff2cc;strokeColor=#d6b656;fontFamily=Courier New;" vertex="1" parent="1">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-34" value="" style="endArrow=classic;html=1;rounded=0;exitX=0.5;exitY=0;exitDx=0;exitDy=0;" parent="1" source="MMc0v0DIyy0xya0iXp__-26" target="MMc0v0DIyy0xya0iXp__-41" edge="1">
-          <mxGeometry x="1420" y="730" width="120" height="60" as="geometry" />
-        </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-34" value="" style="endArrow=classic;html=1;rounded=0;exitX=0.5;exitY=0;exitDx=0;exitDy=0;" edge="1" parent="1" source="MMc0v0DIyy0xya0iXp__-26" target="MMc0v0DIyy0xya0iXp__-41">
           <mxGeometry width="50" height="50" relative="1" as="geometry">
             <mxPoint x="960" y="370" as="sourcePoint" />
             <mxPoint x="690" y="570" as="targetPoint" />
           </mxGeometry>
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-62" value="" style="endArrow=classic;html=1;rounded=0;" edge="1" parent="1" source="MMc0v0DIyy0xya0iXp__-20" target="MMc0v0DIyy0xya0iXp__-29">
-          <mxGeometry width="50" height="50" relative="1" as="geometry">
-            <mxPoint x="1060" y="650" as="sourcePoint" />
-            <mxPoint x="1110" y="600" as="targetPoint" />
-          </mxGeometry>
-        </mxCell>
       </root>
     </mxGraphModel>
   </diagram>

src/Compiler/JustRun.hs

@@ -13,6 +13,7 @@ module Compiler.JustRun
     , justParseRlp
     , justTypeCheckCore
     , justHdbg
+    , justInferRlp
     , makeItPretty, makeItPretty'
     )
     where
@@ -35,6 +36,7 @@ import Data.Pretty
 
 import Rlp.AltParse
 import Rlp.AltSyntax                    qualified as Rlp
+import Rlp.HindleyMilner
 ----------------------------------------------------------------------------------
 
 justHdbg :: String -> IO GmState
@@ -65,6 +67,12 @@ justTypeCheckCore s = typechk (T.pack s)
                     & rlpcToEither
     where typechk = lexCoreR >=> parseCoreProgR >=> checkCoreProgR
 
+justInferRlp :: String
+              -> Either [MsgEnvelope RlpcError]
+                  (Rlp.Program Rlp.PsName Rlp.TypedRlpExpr')
+justInferRlp s = infr (T.pack s) & rlpcToEither
+    where infr = parseRlpProgR >=> typeCheckRlpProgR
+
 makeItPretty :: (Out a) => Either e a -> Either e (Doc ann)
 makeItPretty = fmap out
 

src/Core/Syntax.hs

@@ -263,6 +263,7 @@ type ScDef' = ScDef Name
 
 lambdaLifting :: Iso (ScDef b) (ScDef b') (b, Expr b) (b', Expr b')
 lambdaLifting = iso sa bt where
+    sa (ScDef n [] e) = (n, e) where
     sa (ScDef n as e) = (n, e') where
         e' = Lam as e
 

src/Core/Utils.hs

@@ -8,8 +8,8 @@ module Core.Utils
 ----------------------------------------------------------------------------------
 import Data.Functor.Foldable.TH     (makeBaseFunctor)
 import Data.Functor.Foldable
-import Data.Set                     (Set)
+import Data.HashSet                 (HashSet)
-import Data.Set                     qualified as S
+import Data.HashSet                 qualified as S
 import Core.Syntax
 import Control.Lens
 import GHC.Exts                     (IsList(..))
@@ -28,29 +28,10 @@ isAtomic _        = False
 
 ----------------------------------------------------------------------------------
 
-freeVariables :: Expr b -> Set b
+freeVariables :: Expr' -> HashSet Name
 freeVariables = undefined
-
+-- freeVariables = cata \case
--- freeVariables :: Expr' -> Set Name
+--     VarF n -> S.singleton n
--- freeVariables = cata go
+--     CaseF e as -> e <> (foldMap f as)
---     where
+--         where f (AlterF _ bs e) = fold e `S.difference` S.fromList bs
---         go :: ExprF Name (Set Name) -> Set Name
---         go (VarF k)         = S.singleton k
---         -- TODO: collect free vars in rhss of bs
---         go (LetF _ bs e)    = (e `S.union` esFree) `S.difference` ns
---             where
---                 es = bs ^.. each . _rhs :: [Expr']
---                 ns = S.fromList $ bs ^.. each . _lhs
---                 -- TODO: this feels a little wrong. maybe a different scheme is
---                 -- appropriate
---                 esFree = foldMap id $ freeVariables <$> es
-
---         go (CaseF e as)     = e `S.union` asFree
---             where
---                 -- asFree = foldMap id $ freeVariables <$> (fmap altToLam as)
---                 asFree = foldMap (freeVariables . altToLam) as
---                 -- we map alts to lambdas to avoid writing a 'freeVariablesAlt'
---                 altToLam (Alter _ ns e) = Lam ns e
---         go (LamF bs e)      = e `S.difference` (S.fromList bs)
---         go e                = foldMap id e
 

src/Core2Core.hs

@@ -11,8 +11,8 @@ module Core2Core
 ----------------------------------------------------------------------------------
 import Data.Functor.Foldable
 import Data.Maybe               (fromJust)
-import Data.Set                 (Set)
+import Data.HashSet             (HashSet)
-import Data.Set                 qualified as S
+import Data.HashSet             qualified as S
 import Data.List
 import Data.Foldable
 import Control.Monad.Writer
@@ -22,6 +22,8 @@ import Data.Text                qualified as T
 import Data.HashMap.Strict      (HashMap)
 import Numeric                  (showHex)
 
+import Misc.MonadicRecursionSchemes
+
 import Data.Pretty
 import Compiler.RLPC
 import Control.Lens
@@ -46,10 +48,14 @@ gmPrep :: Program' -> Program'
 gmPrep p = p & appFloater (floatNonStrictCases globals)
              & tagData
              & defineData
+             & etaReduce
     where
         globals = p ^.. programScDefs . each . _lhs . _1
                 & S.fromList
 
+programGlobals :: Program b -> HashSet b
+programGlobals = undefined
+
 -- | Define concrete supercombinators for all datatags defined via pragmas (or
 -- desugaring)
 
@@ -92,7 +98,7 @@ runFloater = flip evalStateT ns >>> runWriter
 
 -- TODO: formally define a "strict context" and reference that here
 -- the returned ScDefs are guaranteed to be free of non-strict cases.
-floatNonStrictCases :: Set Name -> Expr' -> Floater Expr'
+floatNonStrictCases :: HashSet Name -> Expr' -> Floater Expr'
 floatNonStrictCases g = goE
     where
         goE :: Expr' -> Floater Expr'
@@ -104,24 +110,20 @@ floatNonStrictCases g = goE
         goE e                   = goC e
 
         goC :: Expr' -> Floater Expr'
-        -- the only truly non-trivial case: when a case expr is found in a
+        goC = cataM \case
-        -- non-strict context, we float it into a supercombinator, give it a
+            -- the only truly non-trivial case: when a case expr is found in a
-        -- name consumed from the state, record the newly created sc within the
+            -- non-strict context, we float it into a supercombinator, give it a
-        -- Writer, and finally return an expression appropriately calling the sc
+            -- name consumed from the state, record the newly created sc within the
-        goC p@(Case e as)       = do
+            -- Writer, and finally return an expression appropriately calling the sc
-            n <- name
+            CaseF e as -> do
-            let (e',sc) = floatCase g n p
+                n <- name
-                altBodies = (\(Alter _ _ b) -> b) <$> as
+                let (e',sc) = floatCase g n (Case e as)
-            tell [sc]
+                    altBodies = (\(Alter _ _ b) -> b) <$> as
-            goE e
+                tell [sc]
-            traverse_ goE altBodies
+                goE e
-            pure e'
+                traverse_ goE altBodies
-        goC (App f x)           = App <$> goC f <*> goC x
+                pure e'
-        goC (Let r bs e)        = Let r <$> bs' <*> goE e
+            t -> pure $ embed t
-            where bs' = travBs goC bs
-        goC (Lit l)             = pure (Lit l)
-        goC (Var k)             = pure (Var k)
-        goC (Con t as)          = pure (Con t as)
 
         name = state (fromJust . Data.List.uncons)
 
@@ -132,10 +134,15 @@ floatNonStrictCases g = goE
         -- ^ ??? what the fuck?
         -- ^ 24/02/22: what is this shit lol?
 
+etaReduce :: Program' -> Program'
+etaReduce = programScDefs . each %~ \case
+    ScDef n as (Lam bs e) -> ScDef n (as ++ bs) e
+    ScDef n as e -> ScDef n as e
+
 -- when provided with a case expr, floatCase will float the case into a
 -- supercombinator of its free variables. the sc is returned along with an
 -- expression that calls the sc with the necessary arguments
-floatCase :: Set Name -> Name -> Expr' -> (Expr', ScDef')
+floatCase :: HashSet Name -> Name -> Expr' -> (Expr', ScDef')
 floatCase g n c@(Case e as) = (e', sc)
     where
         sc = ScDef n caseFrees c

src/Data/Pretty.hs

@@ -21,7 +21,7 @@ import Data.String                  (IsString(..))
 import Data.Text.Lens               hiding ((:<))
 import Data.Monoid                  hiding (Sum)
 import Data.Bool
-import Control.Lens
+import Control.Lens                 hiding ((:<))
 
 -- instances
 import Control.Comonad.Cofree
@@ -74,6 +74,10 @@ instance (Out1 f, Out1 g) => Out1 (Sum f g) where
 instance (Out (f (Fix f))) => Out (Fix f) where
     outPrec d (Fix f) = outPrec d f
 
+instance (Out (f (Cofree f a)), Out a) => Out (Cofree f a) where
+    outPrec d (a :< f) = maybeParens (d>0) $
+        hsep [outPrec 0 f, ":", outPrec 0 a]
+
 --------------------------------------------------------------------------------
 
 ttext :: Out t => t -> Doc ann

src/Misc/MonadicRecursionSchemes.hs

@@ -0,0 +1,14 @@
+module Misc.MonadicRecursionSchemes
+    where
+--------------------------------------------------------------------------------
+import Control.Monad
+import Data.Functor.Foldable
+--------------------------------------------------------------------------------
+
+-- | catamorphism
+cataM :: (Monad m, Traversable (Base t), Recursive t)
+      => (Base t a -> m a) -- ^ algebra
+      -> t -> m a
+cataM phi = h
+  where h = phi <=< mapM h . project
+

src/Rlp/AltSyntax.hs

@@ -2,13 +2,14 @@
 module Rlp.AltSyntax
     (
     -- * AST
-      Program(..), Decl(..), ExprF(..), Pat(..)
+      Program(..), Decl(..), ExprF(..), Pat(..), pattern ConP'
     , RlpExprF, RlpExpr, Binding(..), Alter(..)
     , RlpExpr', RlpExprF', AnnotatedRlpExpr', Type'
     , DataCon(..), Type(..), Kind
     , pattern IntT, pattern TypeT
     , Core.Rec(..)
 
+    , TypedRlpExpr'
     , AnnotatedRlpExpr, TypedRlpExpr
     , TypeF(..)
 
@@ -18,7 +19,7 @@ module Rlp.AltSyntax
     -- * Optics
     , programDecls
     , _VarP, _FunB, _VarB
-    , _TySigD, _FunD
+    , _TySigD, _FunD, _DataD
     , _LetEF
     , Core.applicants1, Core.arrowStops
 
@@ -27,6 +28,7 @@ module Rlp.AltSyntax
 
     -- * Misc
     , serialiseCofree
+    , fixCofree
     )
     where
 --------------------------------------------------------------------------------
@@ -40,7 +42,7 @@ import GHC.Generics             ( Generic, Generic1
 import Data.Hashable
 import Data.Hashable.Lifted
 import GHC.Exts                 (IsString)
-import Control.Lens             hiding ((.=))
+import Control.Lens             hiding ((.=), (:<))
 
 import Data.Functor.Extend
 import Data.Functor.Foldable.TH
@@ -58,6 +60,7 @@ import Core.Syntax              qualified as Core
 type RlpExpr' = RlpExpr PsName
 type RlpExprF' = RlpExprF PsName
 type AnnotatedRlpExpr' = Cofree (RlpExprF PsName)
+type TypedRlpExpr' = TypedRlpExpr PsName
 type Type' = Type PsName
 
 type AnnotatedRlpExpr b = Cofree (RlpExprF b)
@@ -141,6 +144,20 @@ data Pat b = VarP b
            | AppP (Pat b) (Pat b)
            deriving (Eq, Show, Generic, Generic1)
 
+conList :: Prism' (Pat b) (b, [Pat b])
+conList = prism' up down where
+    up (b,as)               = foldl AppP (ConP b) as
+    down (ConP b)           = Just (b, [])
+    down (AppP (ConP b) as) = Just (b, go as)
+    down _                  = Nothing
+
+    go (AppP f x) = f : go x
+    go p          = [p]
+
+pattern ConP' :: b -> [Pat b] -> Pat b
+pattern ConP' c as <- (preview conList -> Just (c,as))
+    where ConP' c as = review conList (c,as)
+
 deriveShow1 ''Alter
 deriveShow1 ''Binding
 deriveShow1 ''ExprF
@@ -299,3 +316,11 @@ serialiseCofree = cata \case
     ann :<$ e -> object [ "ann" .= ann
                         , "val" .= toJSON1 e ]
 
+--------------------------------------------------------------------------------
+
+fixCofree :: (Functor f, Functor g)
+          => Iso (Fix f) (Fix g) (Cofree f ()) (Cofree g b)
+fixCofree = iso sa bt where
+    sa = foldFix (() :<)
+    bt (_ :< f) = Fix (bt <$> f)
+

src/Rlp/HindleyMilner.hs

@@ -15,6 +15,7 @@ import Control.Monad.Accum
 import Control.Monad.Reader
 import Control.Monad
 import Control.Monad.Extra
+import Control.Monad.Free
 import Control.Arrow            ((>>>))
 import Control.Monad.Writer.Strict
 
@@ -40,7 +41,7 @@ import Debug.Trace
 import Data.Functor             hiding (unzip)
 import Data.Functor.Extend
 import Data.Functor.Foldable    hiding (fold)
-import Data.Fix                 hiding (cata, para, cataM)
+import Data.Fix                 hiding (cata, para, cataM, ana)
 import Control.Comonad.Cofree
 import Control.Comonad
 
@@ -136,6 +137,32 @@ gather (InR (LetEF Rec (withoutPatterns -> bs) (te,je))) = do
     elimRecBind (x,(tx,_)) j = elim x tx j
     elimBind (x,(tx,_)) j = elimGenerally x tx j
 
+gather (InR (CaseEF (te,je) as)) = do
+    as' <- gatherAlter te `traverse` as
+    t <- freshTv
+    let eqs = allEqual (t : (as' ^.. each . _1))
+        j = je <> foldOf (each . _2) as' <> eqs
+    pure (t,j)
+
+gatherAlter :: (Unique :> es)
+            => Type'
+            -> Alter PsName (Type', Judgement)
+            -> Eff es (Type', Judgement)
+gatherAlter te (Alter (ConP' n bs) (ta,ja)) = do
+    -- let tc' be the type of the saturated type constructor
+    tc' <- freshTv
+    bs' <- for bs (\b -> (b ^. singular _VarP,) <$> freshTv)
+    let tbs = bs' ^.. each . _2
+        tc = foldr (:->) tc' tbs
+        j = equal te tc' <> assume n tc <> forBinds elim bs' ja
+    pure (ta,j)
+
+allEqual :: [Type'] -> Judgement
+allEqual = fold . ana @[_] \case
+    [] -> Nil
+    [a] -> Nil
+    (a:b:xs) -> Cons (equal a b) (b:xs)
+
 forBinds :: (PsName -> Type' -> Judgement -> Judgement)
          -> [(PsName, Type')] -> Judgement -> Judgement
 forBinds f bs j = foldr (uncurry f) j bs
@@ -165,6 +192,9 @@ unify (c:cs) = case c of
     Equality (s :-> t) (s' :-> t')
         -> unify (Equality s s' : Equality t t' : cs)
 
+    Equality (AppT s t) (AppT s' t')
+        -> unify (Equality s s' : Equality t t' : cs)
+
     ImplicitInstance m s t
         | null $ (freeTvs t `S.difference` freeTvs m)
                     `S.intersection` activeTvs cs
@@ -198,11 +228,19 @@ generalise m t = foldr ForallT t as
 occurs :: (HasTypes a) => Name -> a -> Bool
 occurs x t = x `elem` freeTvs t
 
+elimGlobalBinds :: [(Name, Scheme)] -> Cofree RlpExprF' (Type', Judgement)
+                -> Cofree RlpExprF' (Type', Judgement)
+elimGlobalBinds bs = traversed . _2 %~ forBinds f bs where
+    f n t@(ForallT _ _) = elimGenerally n t
+    f n t               = elim n t
+
 --------------------------------------------------------------------------------
 
 annotate :: (Unique :> es)
          => RlpExpr' -> Eff es (Cofree RlpExprF' (Type', Judgement))
-annotate = dendroscribeM (gather . fmap extract)
+annotate = fmap (elimGlobalBinds [ ("Just", ForallT "a" $ VarT "a" :-> ConT "Maybe" `AppT` VarT "a")
+                                 , ("isJust", ForallT "a" $ ConT "Maybe" `AppT` VarT "a" :-> ConT "Bool")])
+         . dendroscribeM (gather . fmap extract)
 
 orderConstraints :: [Constraint] -> [Constraint]
 orderConstraints cs = a <> b
@@ -266,21 +304,32 @@ annotateDefs :: (Unique :> es)
                          (Cofree RlpExprF' (Type', Judgement)))
 annotateDefs = traverseOf (programDefs . _2) annotate
 
+extractDefs :: Program PsName (Cofree RlpExprF' (Type', Judgement))
+            -> [(Name, Type')]
+extractDefs p = p ^.. programDefs & each . _2 %~ fst . extract
+
+extractCons :: Program PsName (Cofree RlpExprF' (Type', Judgement))
+            -> [(Name, Type')]
+extractCons = foldMapOf (programDecls . each . _DataD) \(n,as,cs) ->
+    let root = foldl AppT (ConT n) (VarT <$> as)
+    in cs & fmap \ (DataCon cn cas) -> (cn, foldr (:->) root cas)
+
 annotateProg :: (Unique :> es)
              => Program PsName RlpExpr'
              -> Eff es (Program PsName
                          (Cofree RlpExprF' (Type', Judgement)))
 annotateProg p = do
     p' <- annotateDefs p
-    let bs = p' ^.. programDefs & each . _2 %~ (fst . extract)
+    let bs = extractCons p' ++ extractDefs p'
         p'' = p' & programDefs . _2 . traversed . _2
             %~ forBinds elimGenerally bs
     pure p''
 
 programDefs :: Traversal (Program b a) (Program b a') (b, a) (b, a')
-programDefs k (Program ds) = Program <$> go k ds where
+programDefs k (Program ds) = Program <$> traverse go ds where
-    go k [] = pure []
+    go (FunD n as e) = refun as (k (n,e))
-    go k (FunD n as e : ds) = (:) <$> refun as (k (n,e)) <*> go k ds
+    go (DataD n as cs) = pure $ DataD n as cs
+    go (TySigD n ts) = pure $ TySigD n ts
     refun as kne = uncurry (\a b -> FunD a as b) <$> kne
 
 --------------------------------------------------------------------------------

src/Rlp2Core.hs

@@ -26,11 +26,13 @@ import Data.Function                    (on)
 import GHC.Stack
 import Debug.Trace
 import Numeric
+import Misc.MonadicRecursionSchemes
 
 import Data.Fix                         hiding (cata, para, cataM)
 import Data.Functor.Bind
 import Data.Functor.Foldable
 import Control.Comonad
+import Control.Comonad.Cofree
 
 import Effectful.State.Static.Local
 import Effectful.Labeled
@@ -82,31 +84,117 @@ runNameSupply :: Text -> Eff (NameSupply ': es) a -> Eff es a
 runNameSupply pre = runLabeled $ evalState [ pre <> "_" <> tshow name | name <- [0..] ]
     where tshow = T.pack . show
 
+single :: (Monoid s) => ASetter s t a b -> b -> t
+single l a = mempty & l .~ a
+
 -- the rl' program is desugared by desugaring each declaration as a separate
 -- program, and taking the monoidal product of the lot :3
 
 rlpProgToCore :: Rlp.Program PsName (TypedRlpExpr PsName) -> Core.Program Var
 rlpProgToCore = foldMapOf (programDecls . each) declToCore
 
-declToCore :: Rlp.Decl PsName (TypedRlpExpr PsName) -> Core.Program Var
+--------------------------------------------------------------------------------
+
+declToCore :: Rlp.Decl PsName TypedRlpExpr' -> Core.Program Var
+
+declToCore (DataD n as ds)
+    = foldMap (uncurry $ conToCore t) ([0..] `zip` ds)
+   <> single programTyCons (H.singleton n k)
+  where
+    as' = TyVar <$> as
+    k = foldr (:->) t as'
+    t = foldl TyApp (TyCon n) as'
 
 -- assume full eta-expansion for now
-declToCore (FunD b [] e) = mempty & programScDefs .~ [ScDef b' [] undefined]
+declToCore (FunD b [] e) = single programScDefs $
-    where
+    [ScDef b' [] e']
-        b' = MkVar b (typeToCore $ extract e)
+  where
-        e' = runPureEff . runNameSupply b . exprToCore $ e
+    b' = MkVar b (typeToCore $ extract e)
+    e' = runPureEff . runNameSupply b . cataM exprToCore . retype $ e
+
+conToCore :: Core.Type -> Int -> DataCon PsName -> Core.Program Var
+conToCore t tag (DataCon b as)
+    = single programScDefs [ScDef b' [] $ Con tag arity]
+  where
+    arity = lengthOf arrowStops t - 1
+    b' = MkVar b t
+
+dummyExpr :: Text -> Core.Expr b
+dummyExpr a = Var ("<" <> a <> ">")
+
+stripTypes :: Core.Program Var -> Core.Program Name
+stripTypes p = Core.Program
+    { _programTyCons = p ^. programTyCons 
+    , _programDataTags = p ^. programDataTags
+    , _programScDefs =  p ^. programScDefs
+            & each . binders %~ (\ (MkVar n _) -> n)
+    -- TEMP
+    , _programTypeSigs = mempty
+    }
+
+--------------------------------------------------------------------------------
+
+-- | convert rl' types to Core types, annotate binders, and strip excess type
+-- info.
+retype :: Cofree RlpExprF' (Rlp.Type PsName) -> RlpExpr Var
+retype = (_extract %~ unquantify) >>> fmap typeToCore >>> cata \case
+    t :<$ InL (LamF bs e)
+        -> Finl (LamF bs' e)
+      where
+        bs' = zipWith MkVar bs (t ^.. arrowStops)
+
+    t :<$ InL (VarF n)
+        -> Finl (VarF n)
+
+    t :<$ InR (LetEF r bs e)
+        -> Finr (LetEF r _ _)
+
+    t :<$ InR (CaseEF e as)
+        -> _
+
+unquantify :: Rlp.Type b
+           -> Rlp.Type b
+unquantify (ForallT _ x) = unquantify x
+unquantify x             = x
 
 typeToCore :: Rlp.Type PsName -> Core.Type
-typeToCore (VarT n) = TyVar n
+typeToCore = cata \case
+    VarTF n   -> TyVar n
+    ConTF n   -> TyCon n
+    FunTF     -> TyFun
+    AppTF f x -> TyApp f x
+    -- TODO: we assume all quantified tyvars are of kind Type
+    ForallTF x m -> TyForall (MkVar x TyKindType) m
+
+--------------------------------------------------------------------------------
 
 exprToCore :: (NameSupply :> es)
-           => TypedRlpExpr PsName
+           => RlpExprF Var (Core.Expr Var)
-           -> Eff es (Cofree (Core.ExprF Var) Core.Type)
+           -> Eff es (Core.Expr Var)
-exprToCore = undefined
+
+exprToCore (InL e) = pure . embed $ e
+
+exprToCore (InR e) = exprToCore' e
+
+exprToCore' :: (NameSupply :> es)
+            => Rlp.ExprF Var (Core.Expr Var) -> Eff es (Core.Expr Var)
+
+exprToCore' (CaseEF e as) = pure $ Case e (alterToCore <$> as)
+
+exprToCore' _ = pure $ dummyExpr "expr"
+
+alterToCore :: Rlp.Alter Var (Expr Var) -> Core.Alter Var
+alterToCore (Rlp.Alter (ConP' (MkVar n _) bs) e)
+    = Core.Alter (AltData n) (noPatterns bs) e
+
+noPatterns :: [Pat b] -> [b]
+noPatterns ps = ps ^.. each . singular _VarP
+
+--------------------------------------------------------------------------------
 
 annotateVar :: Core.Type -> Core.ExprF PsName a -> Core.ExprF Var a
 
--- fixed points:
+-- fix-points:
 annotateVar _ (VarF n)   = VarF n
 annotateVar _ (ConF t a) = ConF t a
 annotateVar _ (AppF f x) = AppF f x

visualisers/hmvis/src/hmvis/annotated.cljs

@@ -103,6 +103,15 @@
 (defn LitExpr [_ l]
   [:code (str l)])
 
+(defn Alter [colours a]
+  (pprint a)
+  [:code "<alter>"])
+
+(defn CaseExpr [colours e as]
+  [:<> "case " [Expr colours 0 e] " of { "
+       "<alters>"
+       " }"])
+
 (defn Expr [[c & colours] p {e :e t :type}]
   (match e
     {:InL {:tag "LamF" :contents [bs body & _]}}
@@ -118,6 +127,9 @@
                     [Typed c t [LetExpr colours r bs body]])
     {:InL {:tag "LitF" :contents l}}
       [Typed c t [LitExpr colours l]]
+    {:InR {:tag "CaseEF" :contents [scrut as]}}
+      (maybe-parens (< ppr/app-prec1 p)
+                    [Typed c t [CaseExpr colours scrut as]])
     :else [:code "<expr>"]))
 
 (def rainbow-cycle (cycle ["red"