renamePrettily

whole-program inference

whole-program inference

whole-program inference

README.org

@@ -58,20 +58,20 @@ Available debug flags include:
 
 * To-do List
 
-** TODO [#A] rlp to core desugaring                                    :feature:
+** TODO 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,11 +99,10 @@ Available debug flags include:
 ** DONE README.md -> README.org                                           :docs:
    CLOSED: [2024-03-28 Thu 10:44]
 
-** DONE [#A] ~case~ inference                                          :feature:
+** TODO ~case~ inference                                               :feature:
-   CLOSED: [2024-04-05 Fri 15:26]
 
-** DONE [#A] ADT support in Rlp/HindleyMilner.hs                       :feature:
+** DONE ADT support in Rlp/HindleyMilner.hs                            :feature:
-   CLOSED: [2024-04-05 Fri 12:28]
+   CLOSED: [2024-03-28 Thu 11:55]
 
 ** DONE whole-program inference (wrap top-level in a ~letrec~)         :feature:
    CLOSED: [2024-04-04 Thu 12:42]
@@ -116,16 +115,15 @@ Available debug flags include:
 
 ** TODO user-supplied annotation support in Rlp/HindleyMilner.hs       :feature:
 
-** DONE [#A] update architecture diagram                                  :docs:
+** TODO 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 [#A] G-machine visualiser                                         :docs:
+** TODO G-machine visualiser                                              :docs:
 
-** TODO [#C] lambda calculus visualiser                                   :docs:
+** TODO lambda calculus visualiser                                        :docs:
 
 ** TODO hmvis does not reload when redefining expressions                  :bug:
    To recreate:
@@ -154,20 +152,6 @@ Available debug flags include:
 - [ ] 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+
@@ -192,32 +176,13 @@ Available debug flags include:
 - [X] Compiler architecture diagram
 - [X] More examples
 
-** Final Release Plan
+** March Release Plan
-   SCHEDULED: <2024-04-19 Fri>
+- [ ] Tests
-*** TODO Complete all A-priority checks in the main todo-list!!
-*** TODO Tests
     - [ ] rl' parser
     - [ ] Type inference
-*** TODO Examples
+- [X] Ditch TTG in favour of a simpler AST focusing on extendability via Fix, Free, 
-    - [ ] quicksort
+  Cofree, etc. rather than boilerplate-heavy type families
-    - [ ] factorial
+- [X] rl' type inference
-    - [ ] your typical FP operations -- mapping, folding, etc.
+- [X] Core type checking
-*** 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

@@ -1,6 +0,0 @@
-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,7 +56,6 @@ library
                     , Rlp2Core
                     , Control.Monad.Utils
                     , Misc
-                    , Misc.MonadicRecursionSchemes
                     , Misc.Lift1
                     , Misc.CofreeF
                     , Core.SystemF
@@ -68,13 +67,14 @@ library
                     -- required for happy
                     , array >= 0.5.5 && < 0.6
                     , containers >= 0.6.7 && < 0.7
-                    , template-haskell >= 2.20.0 && < 2.23
+                    , template-haskell >= 2.20.0 && < 2.22
-                    , pretty >= 1.1.3 && < 1.2
+                    , prettyprinter
                     , 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
-                    , text >= 2.0.2 && < 2.3
+                    , transformers
+                    , 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,7 +119,11 @@ 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.3
+                 , text >= 2.0.2 && < 2.2
+                 , 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-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">
+<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">
   <diagram name="Page-1" id="ijVUcW-Be2043inOeyM6">
-    <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">
+    <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">
       <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.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">
+        <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">
           <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" source="l7NxJpuHm0Jx_7flO9iA-59" edge="1">
+        <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">
           <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;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">
+        <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">
           <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;" parent="l7NxJpuHm0Jx_7flO9iA-56" source="l7NxJpuHm0Jx_7flO9iA-58" target="l7NxJpuHm0Jx_7flO9iA-59" edge="1">
+        <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">
           <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;" parent="l7NxJpuHm0Jx_7flO9iA-56" vertex="1">
+        <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">
           <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,195 +68,185 @@
         <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;" parent="l7NxJpuHm0Jx_7flO9iA-69" vertex="1">
+        <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">
           <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;" parent="l7NxJpuHm0Jx_7flO9iA-2" vertex="1">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-6" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-2">
-          <mxGeometry x="904" y="68.42105263157895" width="244.8600518134714" height="697.8947368421053" as="geometry" />
+          <mxGeometry x="904" y="68.42105263157895" width="186.6" 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;" parent="MMc0v0DIyy0xya0iXp__-6" vertex="1">
+        <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">
           <mxGeometry width="186.6" height="107.07065060420568" as="geometry" />
         </mxCell>
-        <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">
+        <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">
-          <mxGeometry x="10" y="70" width="220" height="260.78" as="geometry" />
+          <mxGeometry x="9.568013810372213" y="356.90796215152363" width="167.46559322033886" height="82.98740890928475" as="geometry" />
         </mxCell>
-        <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">
+        <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">
-          <mxGeometry x="26" y="91.58" width="184" height="37.03" as="geometry" />
+          <mxGeometry x="9.562261652542377" y="263.9548629430177" width="167.46559322033886" height="82.98740890928475" as="geometry" />
         </mxCell>
-        <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">
+        <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">
-          <mxGeometry x="26" y="211.58" width="184" height="37.03" as="geometry" />
+          <mxGeometry x="9.56226165254238" y="168.9311122835313" width="167.46559322033886" height="82.98740890928475" as="geometry" />
         </mxCell>
-        <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">
+        <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">
-          <mxGeometry width="50" height="50" relative="1" as="geometry">
+          <mxGeometry x="9.56720338983051" y="73.90736162404495" width="167.46559322033886" height="82.98740890928475" as="geometry" />
-            <mxPoint x="-94" y="520" as="sourcePoint" />
-            <mxPoint x="-44" y="451.57894736842104" 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=[];" parent="MMc0v0DIyy0xya0iXp__-32" vertex="1" connectable="0">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-12" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-2">
-          <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;" parent="MMc0v0DIyy0xya0iXp__-12" vertex="1">
+        <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">
           <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;" parent="MMc0v0DIyy0xya0iXp__-12" vertex="1">
+        <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">
           <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;" parent="MMc0v0DIyy0xya0iXp__-12" vertex="1">
+        <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">
           <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;" parent="MMc0v0DIyy0xya0iXp__-12" vertex="1">
+        <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">
           <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;" parent="MMc0v0DIyy0xya0iXp__-12" vertex="1">
+        <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">
           <mxGeometry x="31.369948186528582" y="118.66932274509804" width="218.860103626943" height="37.02823529411765" 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;" parent="l7NxJpuHm0Jx_7flO9iA-2" source="MMc0v0DIyy0xya0iXp__-1" target="MMc0v0DIyy0xya0iXp__-12" edge="1">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-20" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-2">
+          <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;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">
+        <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">
           <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;" parent="l7NxJpuHm0Jx_7flO9iA-2" source="MMc0v0DIyy0xya0iXp__-12" target="MMc0v0DIyy0xya0iXp__-6" edge="1">
+        <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">
           <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;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">
+        <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">
           <mxGeometry x="0.0097" y="-1" relative="1" as="geometry">
             <mxPoint x="-1" as="offset" />
           </mxGeometry>
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-35" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-2" vertex="1">
+        <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">
+          <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;" parent="MMc0v0DIyy0xya0iXp__-35" vertex="1">
+        <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">
           <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;" parent="MMc0v0DIyy0xya0iXp__-35" vertex="1">
+        <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">
           <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;" parent="MMc0v0DIyy0xya0iXp__-35" vertex="1">
+        <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">
           <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;" parent="MMc0v0DIyy0xya0iXp__-35" source="MMc0v0DIyy0xya0iXp__-41" target="MMc0v0DIyy0xya0iXp__-42" edge="1">
+        <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">
           <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;" parent="l7NxJpuHm0Jx_7flO9iA-2" vertex="1">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-51" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-2">
           <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;" parent="MMc0v0DIyy0xya0iXp__-51" vertex="1">
+        <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">
           <mxGeometry width="281.59999999999997" height="10.299607843137254" as="geometry" />
         </mxCell>
-        <mxCell id="MMc0v0DIyy0xya0iXp__-46" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-72" vertex="1">
+        <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">
           <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;" parent="MMc0v0DIyy0xya0iXp__-46" vertex="1">
+        <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">
           <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="DDBEc0rYRfbomnRGFAIR-1" target="MMc0v0DIyy0xya0iXp__-46" edge="1">
+        <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">
           <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="MMc0v0DIyy0xya0iXp__-49" value="" style="endArrow=classic;html=1;rounded=0;" parent="l7NxJpuHm0Jx_7flO9iA-72" source="MMc0v0DIyy0xya0iXp__-46" target="l7NxJpuHm0Jx_7flO9iA-69" edge="1">
+        <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">
+          <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;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">
+        <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">
           <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;" parent="l7NxJpuHm0Jx_7flO9iA-72" vertex="1">
+        <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">
           <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;" parent="l7NxJpuHm0Jx_7flO9iA-72" source="MMc0v0DIyy0xya0iXp__-42" target="MMc0v0DIyy0xya0iXp__-57" edge="1">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-58" value="" style="endArrow=classic;html=1;rounded=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-72" source="MMc0v0DIyy0xya0iXp__-42" target="MMc0v0DIyy0xya0iXp__-57">
           <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="Core.Program PsName" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];fontFamily=Courier New;" parent="MMc0v0DIyy0xya0iXp__-58" vertex="1" connectable="0">
+        <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">
           <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;" parent="l7NxJpuHm0Jx_7flO9iA-72" source="MMc0v0DIyy0xya0iXp__-57" target="MMc0v0DIyy0xya0iXp__-15" edge="1">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-60" value="" style="endArrow=classic;html=1;rounded=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-72" source="MMc0v0DIyy0xya0iXp__-57" target="MMc0v0DIyy0xya0iXp__-15">
           <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="Core.Program Var" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];fontFamily=Courier New;" parent="MMc0v0DIyy0xya0iXp__-60" vertex="1" connectable="0">
+        <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">
           <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;" parent="1" vertex="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;" vertex="1" parent="1">
           <mxGeometry x="673.7099999999999" y="740" 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;" parent="1" source="MMc0v0DIyy0xya0iXp__-26" target="MMc0v0DIyy0xya0iXp__-41" edge="1">
+        <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">
+          <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,7 +13,6 @@ module Compiler.JustRun
     , justParseRlp
     , justTypeCheckCore
     , justHdbg
-    , justInferRlp
     , makeItPretty, makeItPretty'
     )
     where
@@ -36,7 +35,6 @@ import Data.Pretty
 
 import Rlp.AltParse
 import Rlp.AltSyntax                    qualified as Rlp
-import Rlp.HindleyMilner
 ----------------------------------------------------------------------------------
 
 justHdbg :: String -> IO GmState
@@ -67,12 +65,6 @@ 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,7 +263,6 @@ 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.HashSet                 (HashSet)
+import Data.Set                     (Set)
-import Data.HashSet                 qualified as S
+import Data.Set                     qualified as S
 import Core.Syntax
 import Control.Lens
 import GHC.Exts                     (IsList(..))
@@ -28,10 +28,29 @@ isAtomic _        = False
 
 ----------------------------------------------------------------------------------
 
-freeVariables :: Expr' -> HashSet Name
+freeVariables :: Expr b -> Set b
 freeVariables = undefined
--- freeVariables = cata \case
+
---     VarF n -> S.singleton n
+-- freeVariables :: Expr' -> Set Name
---     CaseF e as -> e <> (foldMap f as)
+-- freeVariables = cata go
---         where f (AlterF _ bs e) = fold e `S.difference` S.fromList bs
+--     where
+--         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.HashSet             (HashSet)
+import Data.Set                 (Set)
-import Data.HashSet             qualified as S
+import Data.Set                 qualified as S
 import Data.List
 import Data.Foldable
 import Control.Monad.Writer
@@ -22,8 +22,6 @@ 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
@@ -48,14 +46,10 @@ 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)
 
@@ -98,7 +92,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 :: HashSet Name -> Expr' -> Floater Expr'
+floatNonStrictCases :: Set Name -> Expr' -> Floater Expr'
 floatNonStrictCases g = goE
     where
         goE :: Expr' -> Floater Expr'
@@ -110,20 +104,24 @@ floatNonStrictCases g = goE
         goE e                   = goC e
 
         goC :: Expr' -> Floater Expr'
-        goC = cataM \case
+        -- the only truly non-trivial case: when a case expr is found in a
-            -- the only truly non-trivial case: when a case expr is found in a
+        -- non-strict context, we float it into a supercombinator, give it a
-            -- non-strict context, we float it into a supercombinator, give it a
+        -- name consumed from the state, record the newly created sc within the
-            -- name consumed from the state, record the newly created sc within the
+        -- Writer, and finally return an expression appropriately calling the sc
-            -- Writer, and finally return an expression appropriately calling the sc
+        goC p@(Case e as)       = do
-            CaseF e as -> do
+            n <- name
-                n <- name
+            let (e',sc) = floatCase g n p
-                let (e',sc) = floatCase g n (Case e as)
+                altBodies = (\(Alter _ _ b) -> b) <$> as
-                    altBodies = (\(Alter _ _ b) -> b) <$> as
+            tell [sc]
-                tell [sc]
+            goE e
-                goE e
+            traverse_ goE altBodies
-                traverse_ goE altBodies
+            pure e'
-                pure e'
+        goC (App f x)           = App <$> goC f <*> goC x
-            t -> pure $ embed t
+        goC (Let r bs e)        = Let r <$> bs' <*> goE e
+            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)
 
@@ -134,15 +132,10 @@ 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 :: HashSet Name -> Name -> Expr' -> (Expr', ScDef')
+floatCase :: Set 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                 hiding ((:<))
+import Control.Lens
 
 -- instances
 import Control.Comonad.Cofree
@@ -74,10 +74,6 @@ 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

@@ -1,14 +0,0 @@
-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,14 +2,13 @@
 module Rlp.AltSyntax
     (
     -- * AST
-      Program(..), Decl(..), ExprF(..), Pat(..), pattern ConP'
+      Program(..), Decl(..), ExprF(..), Pat(..)
     , RlpExprF, RlpExpr, Binding(..), Alter(..)
     , RlpExpr', RlpExprF', AnnotatedRlpExpr', Type'
     , DataCon(..), Type(..), Kind
     , pattern IntT, pattern TypeT
     , Core.Rec(..)
 
-    , TypedRlpExpr'
     , AnnotatedRlpExpr, TypedRlpExpr
     , TypeF(..)
 
@@ -19,7 +18,7 @@ module Rlp.AltSyntax
     -- * Optics
     , programDecls
     , _VarP, _FunB, _VarB
-    , _TySigD, _FunD, _DataD
+    , _TySigD, _FunD
     , _LetEF
     , Core.applicants1, Core.arrowStops
 
@@ -28,7 +27,6 @@ module Rlp.AltSyntax
 
     -- * Misc
     , serialiseCofree
-    , fixCofree
     )
     where
 --------------------------------------------------------------------------------
@@ -42,7 +40,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
@@ -60,7 +58,6 @@ 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)
@@ -144,20 +141,6 @@ 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
@@ -316,11 +299,3 @@ 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,7 +15,6 @@ 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
 
@@ -41,7 +40,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, ana)
+import Data.Fix                 hiding (cata, para, cataM)
 import Control.Comonad.Cofree
 import Control.Comonad
 
@@ -137,32 +136,6 @@ 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
@@ -192,9 +165,6 @@ 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
@@ -228,19 +198,11 @@ 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 = fmap (elimGlobalBinds [ ("Just", ForallT "a" $ VarT "a" :-> ConT "Maybe" `AppT` VarT "a")
+annotate = dendroscribeM (gather . fmap extract)
-                                 , ("isJust", ForallT "a" $ ConT "Maybe" `AppT` VarT "a" :-> ConT "Bool")])
-         . dendroscribeM (gather . fmap extract)
 
 orderConstraints :: [Constraint] -> [Constraint]
 orderConstraints cs = a <> b
@@ -304,32 +266,21 @@ 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 = extractCons p' ++ extractDefs p'
+    let bs = p' ^.. programDefs & each . _2 %~ (fst . extract)
         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 <$> traverse go ds where
+programDefs k (Program ds) = Program <$> go k ds where
-    go (FunD n as e) = refun as (k (n,e))
+    go k [] = pure []
-    go (DataD n as cs) = pure $ DataD n as cs
+    go k (FunD n as e : ds) = (:) <$> refun as (k (n,e)) <*> go k ds
-    go (TySigD n ts) = pure $ TySigD n ts
     refun as kne = uncurry (\a b -> FunD a as b) <$> kne
 
 --------------------------------------------------------------------------------

src/Rlp2Core.hs

@@ -26,13 +26,11 @@ 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
@@ -84,117 +82,31 @@ 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) = single programScDefs $
+declToCore (FunD b [] e) = mempty & programScDefs .~ [ScDef b' [] undefined]
-    [ScDef b' [] e']
+    where
-  where
+        b' = MkVar b (typeToCore $ extract e)
-    b' = MkVar b (typeToCore $ extract e)
+        e' = runPureEff . runNameSupply b . exprToCore $ 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 = cata \case
+typeToCore (VarT n) = TyVar n
-    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)
-           => RlpExprF Var (Core.Expr Var)
+           => TypedRlpExpr PsName
-           -> Eff es (Core.Expr Var)
+           -> Eff es (Cofree (Core.ExprF Var) Core.Type)
-
+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
 
--- fix-points:
+-- fixed 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,15 +103,6 @@
 (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 & _]}}
@@ -127,9 +118,6 @@
                     [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"