love when writing d instead of d-1 causes hours of stress

README.md

@@ -26,14 +26,12 @@ $ cabal test --test-show-details=direct
 #### TLDR
 
 ```sh
-# Compile and evaluate examples/rlp/QuickSort.rl
+# Compile and evaluate examples/factorial.cr, with evaluation info dumped to stderr
-$ rlpc examples/QuickSort.rl
+$ rlpc -ddump-eval examples/factorial.cr
 # Compile and evaluate t.cr, with evaluation info dumped to t.log
 $ rlpc -ddump-eval -l t.log t.cr
 # Compile and evaluate t.rl, dumping the desugared Core
 $ rlpc -ddump-desugared t.rl
-# Compile and evaluate t.rl with all compiler messages enabled
-$ rlpc -dALL t.rl
 ```
 
 #### Options
@@ -128,7 +126,7 @@ parsing remains.
     - [x] Garbage Collection
 - [ ] Stable documentation for the evaluation model
 
-### ~~February Release Plan~~
+### February Release Plan
 - [x] Beta rl' to Core
 - [x] UX improvements
     - [x] Actual compiler errors -- no more unexceptional `error` calls
@@ -136,14 +134,12 @@ parsing remains.
     - [x] Annotate the AST with token positions for errors (NOTE: As of Feb. 1,
       this has been done, but the locational info is not yet used in error messages)
 - [x] Compiler architecture diagram
-- [x] More examples
+- [ ] More examples
 
 ### March Release Plan
 - [ ] Tests
     - [ ] rl' parser
     - [ ] rl' lexer
-- [ ] Ditch TTG in favour of a simpler AST focusing on extendability via Fix, Free, 
-  Cofree, etc. rather than boilerplate-heavy type families
 
 ### Indefinite Release Plan
 
@@ -154,6 +150,8 @@ than the other release plans.
     - [ ] Complete all TODOs
     - [ ] Replace mtl with effectful
 - [ ] rl' type-checker
+- [ ] Ditch TTG in favour of a simpler AST focusing on extendability via Fix, Free, 
+  Cofree, etc. rather than boilerplate-heavy type families
 - [ ] Stable rl' to Core
 - [ ] Core polish
     - [ ] Better, stable parser
@@ -162,4 +160,3 @@ than the other release plans.
     - [ ] Less hacky pragmas
 - [ ] Choose a target. LLVM, JS, C, and WASM are currently top contenders
 - [ ] https://proglangdesign.net/wiki/challenges
-

app/CoreDriver.hs

@@ -6,7 +6,7 @@ module CoreDriver
 import Compiler.RLPC
 import Control.Monad
 import Data.Text                    qualified as T
-import Control.Lens.Combinators
+import Lens.Micro.Platform
 
 import Core.Lex
 import Core.Parse

app/Main.hs

@@ -19,7 +19,7 @@ import System.Exit              (exitSuccess)
 import Core
 import TI
 import GM
-import Control.Lens.Combinators hiding (argument)
+import Lens.Micro.Platform
 
 import CoreDriver               qualified
 import RlpDriver                qualified

cabal.project.local

@@ -0,0 +1,8 @@
+profiling: True
+ignore-project: False
+library-profiling: True
+executable-profiling: True
+profiling-detail: all-functions
+tests: True
+benchmarks: True
+

cabal.project.local~

@@ -0,0 +1,5 @@
+ignore-project: False
+library-profiling: True
+executable-profiling: True
+tests: True
+benchmarks: True

doc/src/commentary/gm.rst

@@ -63,13 +63,52 @@ an assembly target. The goal of our new G-Machine is to compile a *linear
 sequence of instructions* which, **when executed**, build up a graph
 representing the code.
 
-*************
+**************************
-The G-Machine
+Trees and Vines, in Theory
-*************
+**************************
+
+Rather than instantiating an expression at runtime -- traversing the AST and
+building a graph -- we want to compile all expressions at compile-time,
+generating a linear sequence of instructions which may be executed to build the
+graph.
+
+**************************
+Evaluation: Slurping Vines
+**************************
+
+WIP.
+
+Laziness
+--------
+
+WIP.
+
+* Instead of :code:`Slide (n+1); Unwind`, do :code:`Update n; Pop n; Unwind`
+
+****************************
+Compilation: Squashing Trees
+****************************
+
+WIP.
+
+Notice that we do not keep a (local) environment at run-time. The environment
+only exists at compile-time to map local names to stack indices. When compiling
+a supercombinator, the arguments are enumerated from zero (the top of the
+stack), and passed to :code:`compileR` as an environment.
 
 .. literalinclude:: /../../src/GM.hs
    :dedent:
-   :start-after: -- >> [ref/Instr]
+   :start-after: -- >> [ref/compileSc]
-   :end-before: -- << [ref/Instr]
+   :end-before: -- << [ref/compileSc]
+   :caption: src/GM.hs
+
+Of course, variables being indexed relative to the top of the stack means that
+they will become inaccurate the moment we push or pop the stack a single time.
+The way around this is quite simple: simply offset the stack when w
+
+.. literalinclude:: /../../src/GM.hs
+   :dedent:
+   :start-after: -- >> [ref/compileC]
+   :end-before: -- << [ref/compileC]
    :caption: src/GM.hs
 

doc/src/commentary/layout-lexing.rst

@@ -62,6 +62,159 @@ braces and semicolons. In developing our *layout* rules, we will follow in the
 pattern of translating the whitespace-sensitive source language to an explicitly
 sectioned language.
 
+But What About Haskell?
+***********************
+
+Parsing Haskell -- and thus rl' -- is only slightly more complex than Python,
+but the design is certainly more sensitive. 
+
+.. code-block:: haskell
+
+   -- line folds
+   something = this is a
+       single expression
+
+   -- an extremely common style found in haskell
+   data Some = Data
+       { is    :: Presented
+       , in    :: This
+       , silly :: Style
+       }
+
+   -- another style oddity
+   -- note that this is not a single
+   -- continued line! `look at`,
+   -- `this odd`, and `alignment` are all
+   -- discrete items!
+   anotherThing = do look at
+                     this odd
+                     alignment
+
+But enough fear, lets actually think about implementation. Firstly, some
+formality: what do we mean when we say layout? We will define layout as the
+rules we apply to an implicitly-sectioned language in order to yield one that is
+explicitly-sectioned. We will also define indentation of a lexeme as the column
+number of its first character.
+
+Thankfully for us, our entry point is quite clear; layouts only appear after a
+select few keywords, (with a minor exception; TODO: elaborate) being :code:`let`
+(followed by supercombinators), :code:`where` (followed by supercombinators),
+:code:`do` (followed by expressions), and :code:`of` (followed by alternatives)
+(TODO: all of these terms need linked glossary entries). In order to manage the
+cascade of layout contexts, our lexer will record a stack for which each element
+is either :math:`\varnothing`, denoting an explicit layout written with braces
+and semicolons, or a :math:`\langle n \rangle`, denoting an implicitly laid-out
+layout where the start of each item belonging to the layout is indented
+:math:`n` columns.
+
+.. code-block:: haskell
+
+    -- layout stack: []
+    module M where -- layout stack: [∅]
+
+    f x = let -- layout keyword; remember indentation of next token
+              y = w * w -- layout stack: [∅, <10>]
+              w = x + x
+              -- layout ends here
+          in do -- layout keyword; next token is a brace!
+              { -- layout stack: [∅]
+                  print y;
+                  print x;
+              }
+
+Finally, we also need the concept of "virtual" brace tokens, which as far as
+we're concerned at this moment are exactly like normal brace tokens, except
+implicitly inserted by the compiler. With the presented ideas in mind, we may
+begin to introduce a small set of informal rules describing the lexer's handling
+of layouts, the first being:
+
+1. If a layout keyword is followed by the token '{', push :math:`\varnothing`
+   onto the layout context stack. Otherwise, push :math:`\langle n \rangle` onto
+   the layout context stack where :math:`n` is the indentation of the token
+   following the layout keyword. Additionally, the lexer is to insert a virtual
+   opening brace after the token representing the layout keyword.
+
+Consider the following observations from that previous code sample:
+
+* Function definitions should belong to a layout, each of which may start at
+  column 1.
+
+* A layout can enclose multiple bodies, as seen in the :code:`let`-bindings and
+  the :code:`do`-expression.
+
+* Semicolons should *terminate* items, rather than *separate* them.
+
+Our current focus is the semicolons. In an implicit layout, items are on
+separate lines each aligned with the previous. A naïve implementation would be
+to insert the semicolon token when the EOL is reached, but this proves unideal
+when you consider the alignment requirement. In our implementation, our lexer
+will wait until the first token on a new line is reached, then compare
+indentation and insert a semicolon if appropriate. This comparison -- the
+nondescript measurement of "more, less, or equal indentation" rather than a
+numeric value -- is referred to as *offside* by myself internally and the
+Haskell report describing layouts. We informally formalise this rule as follows:
+
+2. When the first token on a line is preceeded only by whitespace, if the
+   token's first grapheme resides on a column number :math:`m` equal to the
+   indentation level of the enclosing context -- i.e. the :math:`\langle n
+   \rangle` on top of the layout stack. Should no such context exist on the
+   stack, assume :math:`m > n`.
+
+We have an idea of how to begin layouts, delimit the enclosed items, and last
+we'll need to end layouts. This is where the distinction between virtual and
+non-virtual brace tokens comes into play. The lexer needs only partial concern
+towards closing layouts; the complete responsibility is shared with the parser.
+This will be elaborated on in the next section. For now, we will be content with
+naïvely inserting a virtual closing brace when a token is indented right of the
+layout.
+
+3. Under the same conditions as rule 2., when :math:`m < n` the lexer shall
+   insert a virtual closing brace and pop the layout stack.
+
+This rule covers some cases including the top-level, however, consider
+tokenising the :code:`in` in a :code:`let`-expression. If our lexical analysis
+framework only allows for lexing a single token at a time, we cannot return both
+a virtual right-brace and a :code:`in`. Under this model, the lexer may simply
+pop the layout stack and return the :code:`in` token. As we'll see in the next
+section, as long as the lexer keeps track of its own context (i.e. the stack),
+the parser will cope just fine without the virtual end-brace.
+
+Parsing Lonely Braces
+*********************
+
+When viewed in the abstract, parsing and tokenising are near-identical tasks yet
+the two are very often decomposed into discrete systems with very different
+implementations. Lexers operate on streams of text and tokens, while parsers
+are typically far less linear, using a parse stack or recursing top-down. A
+big reason for this separation is state management: the parser aims to be as
+context-free as possible, while the lexer tends to burden the necessary
+statefulness. Still, the nature of a stream-oriented lexer makes backtracking
+difficult and quite inelegant.
+
+However, simply declaring a parse error to be not an error at all
+counterintuitively proves to be an elegant solution our layout problem which
+minimises backtracking and state in both the lexer and the parser. Consider the
+following definitions found in rlp's BNF:
+
+.. productionlist:: rlp
+   VOpen   : `vopen`
+   VClose  : `vclose` | `error`
+
+A parse error is recovered and treated as a closing brace. Another point of note
+in the BNF is the difference between virtual and non-virtual braces (TODO: i
+don't like that the BNF is formatted without newlines :/):
+
+.. productionlist:: rlp
+   LetExpr : `let` VOpen Bindings VClose `in` Expr | `let` `{` Bindings `}` `in` Expr
+
+This ensures that non-virtual braces are closed explicitly.
+
+This set of rules is adequete enough to satisfy our basic concerns about line
+continations and layout lists. For a more pedantic description of the layout
+system, see `chapter 10
+<https://www.haskell.org/onlinereport/haskell2010/haskellch10.html>`_ of the
+2010 Haskell Report, which I heavily referenced here.
+
 References
 ----------
 

examples/rlp/Help.rl

@@ -0,0 +1,10 @@
+id x = x
+
+thing = Identity 3
+
+data Identity a = Identity a
+
+main = case thing of
+    Identity x -> let y = x
+                  in y
+

examples/rlp/MapList.rl

@@ -0,0 +1,13 @@
+data List a = Nil | Cons a (List a)
+
+map :: (a -> b) -> List a -> List b
+map f l = case l of
+    Nil -> Nil
+    Cons a as -> Cons (f a) (map f as)
+
+list = Cons 1 (Cons 2 (Cons 3 Nil))
+
+lam x = *# x x
+
+main = print# (map lam list)
+

examples/rlp/QuickSort.rl

@@ -23,9 +23,18 @@ qsort l = case l of
             greater = filter (<# a) as
         in append (append (qsort lesser) (Cons a Nil)) (qsort greater)
 
-list :: List Int#
 list = Cons 9 (Cons 2 (Cons 3 (Cons 2
             (Cons 5 (Cons 2 (Cons 12 (Cons 89 Nil)))))))
 
-main = print# (qsort list)
+list2 = Cons 2 (Cons 3 Nil)
+
+lt :: Int# -> Int# -> Bool
+lt a = (>=# a)
+
+id x = x
+
+main = case list of
+    Nil -> Nil
+    Cons a as -> let lesser = filter (lt a) as
+                 in lesser
 

rlp.cabal

@@ -32,8 +32,6 @@ library
                     , Core.HindleyMilner
                     , Control.Monad.Errorful
                     , Rlp.Syntax
-                    , Rlp.Syntax.Backstage
-                    , Rlp.Syntax.Types
                     -- , Rlp.Parse.Decls
                     , Rlp.Parse
                     , Rlp.Parse.Associate
@@ -63,19 +61,27 @@ library
                     , hashable >= 1.4.3 && < 1.5
                     , mtl >= 2.3.1 && < 2.4
                     , text >= 2.0.2 && < 2.1
+                    , megaparsec >= 9.6.1 && < 9.7
+                    , microlens >= 0.4.13 && < 0.5
+                    , microlens-mtl >= 0.2.0 && < 0.3
+                    , microlens-platform >= 0.4.3 && < 0.5
+                    , microlens-th >= 0.4.3 && < 0.5
                     , unordered-containers >= 0.2.20 && < 0.3
                     , recursion-schemes >= 5.2.2 && < 5.3
                     , data-fix >= 0.3.2 && < 0.4
                     , utf8-string >= 1.0.2 && < 1.1
-                    , extra >= 1.7.0 && <2
+                    , extra >= 1.7.0 && < 2
-                    , semigroupoids >=6.0 && <6.1
+                    , semigroupoids
-                    , comonad >=5.0.0 && <6
+                    , comonad
-                    , lens >=5.2.3 && <6.0
+                    , lens
-                    , text-ansi >=0.2.0 && <0.4
+                    , text-ansi
+                    , microlens-pro ^>=0.2.0
                     , effectful-core ^>=2.3.0.0
                     , deriving-compat ^>=0.6.0
                     , these >=0.2 && <2.0
-                    , free >=5.2
+
+    ghc-options:
+        -fprof-auto
 
     hs-source-dirs:   src
     default-language: GHC2021
@@ -99,9 +105,9 @@ executable rlpc
     build-depends: base >=4.17.0.0 && <4.20.0.0
                  , rlp
                  , optparse-applicative >= 0.18.1 && < 0.19
+                 , microlens-platform
                  , mtl >= 2.3.1 && < 2.4
                  , unordered-containers >= 0.2.20 && < 0.3
-                 , lens >=5.2.3 && <6.0
                  , text >= 2.0.2 && < 2.1
 
     hs-source-dirs:   app
@@ -119,10 +125,8 @@ test-suite rlp-test
                  , QuickCheck
                  , hspec            ==2.*
                  , microlens
-                 , lens >=5.2.3 && <6.0
     other-modules: Arith
                  , GMSpec
                  , Core.HindleyMilnerSpec
-                 , Compiler.TypesSpec
     build-tool-depends: hspec-discover:hspec-discover
 

src/Compiler/JustRun.hs

@@ -11,7 +11,6 @@ module Compiler.JustRun
     ( justLexCore
     , justParseCore
     , justTypeCheckCore
-    , justHdbg
     )
     where
 ----------------------------------------------------------------------------------
@@ -21,22 +20,14 @@ import Core.HindleyMilner
 import Core.Syntax                      (Program')
 import Compiler.RLPC
 import Control.Arrow                    ((>>>))
-import Control.Monad                    ((>=>), void)
+import Control.Monad                    ((>=>))
 import Control.Comonad
 import Control.Lens
 import Data.Text                        qualified as T
 import Data.Function                    ((&))
-import System.IO
 import GM
-import Rlp.Parse
-import Rlp2Core
 ----------------------------------------------------------------------------------
 
-justHdbg :: String -> IO GmState
-justHdbg s = do
-    p <- evalRLPCIO def (parseRlpProgR >=> desugarRlpProgR $ T.pack s)
-    withFile "/tmp/t.log" WriteMode $ hdbgProg p
-
 justLexCore :: String -> Either [MsgEnvelope RlpcError] [CoreToken]
 justLexCore s = lexCoreR (T.pack s)
               & mapped . each %~ extract

src/Compiler/RLPC.hs

@@ -64,8 +64,8 @@ import Data.Text.IO             qualified as T
 import System.IO
 import Text.ANSI                qualified as Ansi
 import Text.PrettyPrint         hiding ((<>))
-import Control.Lens
+import Lens.Micro.Platform
-import Data.Text.Lens           (packed, unpacked, IsText)
+import Lens.Micro.Platform.Internal
 import System.Exit
 ----------------------------------------------------------------------------------
 
@@ -220,9 +220,9 @@ docRlpcErr msg = header
                 rule = repeat (ttext . Ansi.blue . Ansi.bold $ "|")
                 srclines = ["", "<problematic source code>", ""]
         filename = msgColour "<input>"
-        pos = msgColour $ tshow (msg ^. msgSpan . srcSpanLine)
+        pos = msgColour $ tshow (msg ^. msgSpan . srcspanLine)
                        <> ":"
-                       <> tshow (msg ^. msgSpan . srcSpanColumn)
+                       <> tshow (msg ^. msgSpan . srcspanColumn)
 
         header = ttext $ filename <> msgColour ":" <> pos <> msgColour ": "
                         <> errorColour "error" <> msgColour ":"

src/Compiler/RlpcError.hs

@@ -21,7 +21,8 @@ import Control.Monad.Errorful
 import Data.Text                (Text)
 import Data.Text                qualified as T
 import GHC.Exts                 (IsString(..))
-import Control.Lens
+import Lens.Micro.Platform
+import Lens.Micro.Platform.Internal
 import Compiler.Types
 ----------------------------------------------------------------------------------
 

src/Compiler/Types.hs

@@ -1,81 +1,33 @@
 {-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE UndecidableInstances, QuantifiedConstraints #-}
-{-# LANGUAGE PatternSynonyms #-}
 module Compiler.Types
     ( SrcSpan(..)
-    , srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen
+    , srcspanLine, srcspanColumn, srcspanAbs, srcspanLen
-    , pattern (:<$)
     , Located(..)
-    , HasLocation(..)
     , _Located
-    , nolo, nolo'
+    , located
-
+    , nolo
-    , (<~>), (~>), (~~>), (<~~)
+    , (<<~), (<~>), (<#>)
-
-    , comb2, comb3, comb4
-    , lochead
 
     -- * Re-exports
-    , Comonad(extract)
+    , Comonad
     , Apply
     , Bind
     )
     where
 --------------------------------------------------------------------------------
-import Language.Haskell.TH.Syntax   (Lift)
-
 import Control.Comonad
-import Control.Comonad.Cofree
-import Control.Comonad.Trans.Cofree qualified as Trans.Cofree
-import Control.Comonad.Trans.Cofree (CofreeF)
 import Data.Functor.Apply
 import Data.Functor.Bind
-import Data.Functor.Compose
+import Control.Lens             hiding ((<<~))
-import Data.Functor.Foldable
+import Language.Haskell.TH.Syntax   (Lift)
-import Data.Semigroup.Foldable
-import Data.Fix                     hiding (cata, ana)
-import Data.Kind
-import Control.Lens                 hiding ((<<~), (:<))
-
-import Data.List.NonEmpty           (NonEmpty)
-import Data.Function                (on)
 --------------------------------------------------------------------------------
 
 -- | Token wrapped with a span (line, column, absolute, length)
 data Located a = Located SrcSpan a
     deriving (Show, Lift, Functor)
 
-data Floc f = Floc SrcSpan (f (Floc f))
+located :: Lens (Located a) (Located b) a b
-
+located = lens extract ($>)
-pattern (:<$) :: a -> f b -> Trans.Cofree.CofreeF f a b
-pattern a :<$ b = a Trans.Cofree.:< b
-
-(<~>) :: a -> b -> SrcSpan
-(<~>) = undefined
-
-infixl 5 <~>
-
--- (~>) :: (CanGet k, CanSet k', HasLocation k a, HasLocation k' b)
---      => a -> b -> b
--- a ~> b = 
-(~>) = undefined
-
-infixl 4 ~>
-
--- (~~>) :: (CanGet k, HasLocation k a, CanSet k', HasLocation k' b)
---       => (a -> b) -> a -> b
--- (~~>) :: (f SrcSpan -> b) -> Cofree f SrcSpan -> Cofree f SrcSpan
--- f ~~> (ss :< as) = ss :< f as
-(~~>) = undefined
-
-infixl 3 ~~>
-
--- (<~~) :: (GetLocation a, HasLocation b) => (a -> b) -> a -> b
--- a <~~ b = a b & location <>~ srcspan b
-(<~~) = undefined
-
-infixr 2 <~~
 
 instance Apply Located where
     liftF2 f (Located sa p) (Located sb q)
@@ -95,136 +47,53 @@ data SrcSpan = SrcSpan
     !Int -- ^ Column
     !Int -- ^ Absolute
     !Int -- ^ Length
-    deriving (Show, Eq, Lift)
+    deriving (Show, Lift)
 
 tupling :: Iso' SrcSpan (Int, Int, Int, Int)
 tupling = iso (\ (SrcSpan a b c d) -> (a,b,c,d))
               (\ (a,b,c,d) -> SrcSpan a b c d)
 
-srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen :: Lens' SrcSpan Int
+srcspanLine, srcspanColumn, srcspanAbs, srcspanLen :: Lens' SrcSpan Int
-srcSpanLine = tupling . _1
+srcspanLine = tupling . _1
-srcSpanColumn = tupling . _2
+srcspanColumn = tupling . _2
-srcSpanAbs = tupling . _3
+srcspanAbs = tupling . _3
-srcSpanLen = tupling . _4
+srcspanLen = tupling . _4
 
 -- | debug tool
 nolo :: a -> Located a
 nolo = Located (SrcSpan 0 0 0 0)
 
-nolo' :: f (Cofree f SrcSpan) -> Cofree f SrcSpan
-nolo' as = SrcSpan 0 0 0 0 :< as
-
 instance Semigroup SrcSpan where
-    -- multiple identities? what are the consequences of this...?
-    SrcSpan _ _ _ 0 <> SrcSpan l c a s = SrcSpan l c a s
-    SrcSpan l c a s <> SrcSpan _ _ _ 0 = SrcSpan l c a s
-
     SrcSpan la ca aa sa <> SrcSpan lb cb ab sb = SrcSpan l c a s where
         l = min la lb
         c = min ca cb
         a = min aa ab
         s = case aa `compare` ab of
             EQ -> max sa sb
-            LT -> max sa (ab + sb - aa)
+            LT -> max sa (ab + lb - aa)
-            GT -> max sb (aa + sa - ab)
+            GT -> max sb (aa + la - ab)
 
---------------------------------------------------------------------------------
+-- | A synonym for '(<<=)' with a tighter precedence and left-associativity for
+-- use with '(<~>)' in a sort of, comonadic pseudo-applicative style.
 
-data GetOrSet = Get | Set | GetSet
+(<<~) :: (Comonad w) => (w a -> b) -> w a -> w b
+(<<~) = (<<=)
 
-class CanGet (k :: GetOrSet)
+infixl 4 <<~
-class CanSet (k :: GetOrSet) where
 
-instance CanGet Get
+-- | Similar to '(<*>)', but with a cokleisli arrow.
-instance CanGet GetSet
-instance CanSet Set
-instance CanSet GetSet
 
-data GetSetLens (k :: GetOrSet) s t a b :: Type where
+(<~>) :: (Comonad w, Bind w) => w (w a -> b) -> w a -> w b
-    Getter_      :: (s -> a)             -> GetSetLens Get s t a b
+mc <~> ma = mc >>- \f -> ma =>> f
-    Setter_      :: ((a -> b) -> s -> t) -> GetSetLens Set s t a b
-    GetterSetter :: (CanGet k', CanSet k')
-                 => (s -> a) -> (s -> b -> t) -> GetSetLens k' s t a b
 
-type GetSetLens' k s a = GetSetLens k s s a a
+infixl 4 <~>
 
-class HasLocation k s | s -> k where
+-- this is getting silly
-    -- location :: (Access k f, Functor f) => LensLike' f s SrcSpan
-    getSetLocation :: GetSetLens' k s SrcSpan
 
-type family Access (k :: GetOrSet) f where
+(<#>) :: (Functor f) => f (a -> b) -> a -> f b
-    Access GetSet f = Functor f
+fab <#> a = fmap ($ a) fab
-    Access Set f = Settable f
-    Access Get f = (Functor f, Contravariant f)
 
-instance HasLocation GetSet SrcSpan where
+infixl 4 <#>
-    getSetLocation = GetterSetter id (flip const)
-    -- location = fromGetSetLens getSetLocation
-
-instance (CanSet k, HasLocation k a) => HasLocation Set (r -> a) where
-    getSetLocation = Setter_ $ \ss ra r -> ra r & fromSet getSetLocation %~ ss
-    -- location = fromSet getSetLocation
-
-instance (HasLocation k a) => HasLocation k (Cofree f a) where
-    getSetLocation = case getSetLocation @_ @a of
-        Getter_ sa -> Getter_ $ \ (s :< _) -> sa s
-        Setter_ abst -> Setter_ $ \ss (s :< as) -> abst ss s :< as
-        GetterSetter sa sbt -> GetterSetter sa' sbt' where
-            sa' (s :< _) = sa s
-            sbt' (s :< as) b = sbt s b :< as
-
-location :: (Access k f, Functor f, HasLocation k s)
-         => LensLike' f s SrcSpan
-location = fromGetSetLens getSetLocation
-
-fromGetSetLens :: (Access k f, Functor f) => GetSetLens' k s a -> LensLike' f s a
-fromGetSetLens gsl = case gsl of
-    Getter_ sa          -> to sa
-    Setter_ abst        -> setting abst
-    GetterSetter sa sbt -> lens sa sbt
-
-fromGet :: (CanGet k) => GetSetLens k s t a b -> Getter s a
-fromGet (Getter_ sa)        = to sa
-fromGet (GetterSetter sa _) = to sa
-
-fromSet :: (CanSet k) => GetSetLens k s t a b -> Setter s t a b
-fromSet (Setter_ abst)        = setting abst
-fromSet (GetterSetter sa sbt) = lens sa sbt
-
-fromGetSet :: (CanGet k, CanSet k) => GetSetLens k s t a b -> Lens s t a b
-fromGetSet (GetterSetter sa sbt) = lens sa sbt
-
---------------------------------------------------------------------------------
-
-comb2 :: (Functor f, Semigroup m)
-      => (Cofree f m -> Cofree f m -> f (Cofree f m))
-      -> Cofree f m -> Cofree f m -> Cofree f m
-comb2 f a b = ss :< f a b
-    where ss = a `mextract` b
-
-comb3 :: (Functor f, Semigroup m)
-      => (Cofree f m -> Cofree f m -> Cofree f m -> f (Cofree f m))
-      -> Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m
-comb3 f a b c = ss :< f a b c
-    where ss = a `mapply` b `mextract` c
-
-comb4 :: (Functor f, Semigroup m)
-      => (Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m
-         -> f (Cofree f m))
-      -> Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m
-comb4 f a b c d = ss :< f a b c d
-    where ss = a `mapply` b `mapply` c `mextract` d
-
-mextract :: (Comonad w, Semigroup m) => w m -> w m -> m
-mextract = (<>) `on` extract
-
-mapply :: (Comonad w, Semigroup m) => w m -> w m -> w m
-mapply a b = b <&> (<> extract a)
-
-lochead :: Functor f
-        => (f SrcSpan -> f SrcSpan) -> Located (f SrcSpan) -> Cofree f SrcSpan
-lochead afs (Located ss fss) = ss :< unwrap (lochead afs $ Located ss fss)
-
---------------------------------------------------------------------------------
 
 makePrisms ''Located
+

src/Control/Monad/Errorful.hs

@@ -20,7 +20,7 @@ import Data.Functor.Identity
 import Data.Coerce
 import Data.HashSet                 (HashSet)
 import Data.HashSet                 qualified as H
-import Control.Lens
+import Lens.Micro
 ----------------------------------------------------------------------------------
 
 newtype ErrorfulT e m a = ErrorfulT { runErrorfulT :: m (Maybe a, [e]) }

src/Core/Examples.hs

@@ -8,6 +8,7 @@ module Core.Examples where
 ----------------------------------------------------------------------------------
 import Core.Syntax
 import Core.TH
+import Rlp.TH
 ----------------------------------------------------------------------------------
 
 -- fac3 = undefined
@@ -244,3 +245,17 @@ namedConsCase = [coreProg|
 
 --}
 
+qsort = [rlpProg|
+    data List a = Nil | Cons a (List a)
+
+    list = Cons 9 (Cons 2 (Cons 3 (Cons 2
+                (Cons 5 (Cons 2 (Cons 12 (Cons 89 Nil)))))))
+
+    id x = x
+
+    main = case list of
+        Nil -> Nil
+        Cons a as -> let lesser = as
+                     in print# lesser
+|]
+

src/Core/HindleyMilner.hs

@@ -16,7 +16,9 @@ module Core.HindleyMilner
     )
     where
 ----------------------------------------------------------------------------------
-import Control.Lens             hiding (Context', Context)
+import Lens.Micro
+import Lens.Micro.Mtl
+import Lens.Micro.Platform
 import Data.Maybe               (fromMaybe)
 import Data.Text                qualified as T
 import Data.Pretty              (rpretty)

src/Core/Lex.x

@@ -26,7 +26,8 @@ import Compiler.RLPC
 import Compiler.Types
 -- TODO: unify Located definitions
 import Compiler.RlpcError
-import Control.Lens
+import Lens.Micro
+import Lens.Micro.TH
 }
 
 %wrapper "monad-strict-text"

src/Core/Parse.y

@@ -24,7 +24,7 @@ import Core.Syntax
 import Core.Lex
 import Compiler.RLPC
 import Control.Monad
-import Control.Lens         hiding (snoc)
+import Lens.Micro
 import Data.Default.Class   (def)
 import Data.Hashable        (Hashable)
 import Data.List.Extra

src/Core/Syntax.hs

@@ -60,6 +60,8 @@ import Data.Bifoldable              (bifoldr)
 import GHC.Generics                 (Generic, Generically(..))
 -- Lift instances for the Core quasiquoters
 import Language.Haskell.TH.Syntax   (Lift)
+-- import Lens.Micro.TH                (makeLenses)
+-- import Lens.Micro
 import Control.Lens
 ----------------------------------------------------------------------------------
 

src/Core/Utils.hs

@@ -13,7 +13,7 @@ import Data.Functor.Foldable
 import Data.Set                     (Set)
 import Data.Set                     qualified as S
 import Core.Syntax
-import Control.Lens
+import Lens.Micro
 import GHC.Exts                     (IsList(..))
 ----------------------------------------------------------------------------------
 

src/Core2Core.hs

@@ -20,10 +20,12 @@ import Control.Monad.State.Lazy
 import Control.Arrow            ((>>>))
 import Data.Text                qualified as T
 import Data.HashMap.Strict      (HashMap)
+import Debug.Trace
 import Numeric                  (showHex)
 
 import Data.Pretty
 import Compiler.RLPC
+-- import Lens.Micro.Platform
 import Control.Lens
 import Core.Syntax
 import Core.Utils

src/Data/Heap.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ImplicitParams #-}
 {-
 Module : Data.Heap
 Description : A model heap used by abstract machine
@@ -26,7 +27,10 @@ import Data.Map                     (Map, (!?))
 import Debug.Trace
 import Data.Map.Strict              qualified as M
 import Data.List                    (intersect)
-import GHC.Stack                    (HasCallStack)
+import Data.IORef
+import System.IO.Unsafe
+import Control.Monad
+import GHC.Stack
 import Control.Lens
 ----------------------------------------------------------------------------------
 
@@ -74,13 +78,19 @@ instance Traversable Heap where
 
 ----------------------------------------------------------------------------------
 
-alloc :: Heap a -> a -> (Heap a, Addr)
+godhelpme :: IORef Int
-alloc (Heap (u:us) m) v = (Heap us (M.insert u v m), u)
+godhelpme = unsafePerformIO $ newIORef 0
+
+alloc :: HasCallStack => Heap a -> a -> (Heap a, Addr)
+alloc (Heap (u:us) m) v = unsafePerformIO $ do
+    -- i <- readIORef godhelpme
+    -- when (i >= 60000) $ error "fuck"
+    -- modifyIORef godhelpme succ
+    pure (Heap us (M.insert u v m), u)
 alloc (Heap [] _)     _ = error "heap model ran out of memory..."
 
-update :: Addr -> a -> Heap a -> Heap a
+update :: HasCallStack => Addr -> a -> Heap a -> Heap a
 update k v (Heap u m) = Heap u (M.adjust (const v) k m)
--- update k v (Heap u m) = Heap u (M.adjust (undefined) k m)
 
 adjust :: Addr -> (a -> a) -> Heap a -> Heap a
 adjust k f (Heap u m) = Heap u (M.adjust f k m)

src/GM.hs

@@ -9,12 +9,8 @@ module GM
     ( hdbgProg
     , evalProg
     , evalProgR
-    , GmState(..)
-    , gmCode, gmStack, gmDump, gmHeap, gmEnv, gmStats
     , Node(..)
-    , showState
     , gmEvalProg
-    , Stats(..)
     , finalStateOf
     , resultOf
     , resultOfExpr
@@ -26,13 +22,18 @@ import Data.List                    (mapAccumL)
 import Data.Maybe                   (fromMaybe, mapMaybe)
 import Data.Monoid                  (Endo(..))
 import Data.Tuple                   (swap)
-import Control.Lens
+import Lens.Micro
-import Data.Text.Lens               (IsText, packed, unpacked)
+import Lens.Micro.Extras            (view)
+import Lens.Micro.TH
+import Lens.Micro.Platform          (packed, unpacked)
+import Lens.Micro.Platform.Internal (IsText(..))
 import Text.Printf
 import Text.PrettyPrint             hiding ((<>))
 import Text.PrettyPrint.HughesPJ    (maybeParens)
 import Data.Foldable                (traverse_)
-import System.IO                    (Handle, hPutStrLn)
+import Control.Concurrent
+import System.Exit
+import System.IO                    (Handle, hPutStrLn, stderr)
 -- TODO: an actual output system
 -- TODO: an actual output system
 -- TODO: an actual output system
@@ -90,7 +91,6 @@ data Key = NameKey Name
          | ConstrKey Tag Int
          deriving (Show, Eq)
 
--- >> [ref/Instr]
 data Instr = Unwind
            | PushGlobal Name
            | PushConstr Tag Int
@@ -112,7 +112,6 @@ data Instr = Unwind
            | Print
            | Halt
            deriving (Show, Eq)
--- << [ref/Instr]
 
 data Node = NNum Int
           | NAp Addr Addr
@@ -155,7 +154,7 @@ evalProg p = res <&> (,sts)
         resAddr = final ^. gmStack ^? _head
         res = resAddr >>= flip hLookup h
 
-hdbgProg :: Program' -> Handle -> IO GmState
+hdbgProg :: Program' -> Handle -> IO (Node, Stats)
 hdbgProg p hio = do
     (renderOut . showState) `traverse_` states
     -- TODO: i'd like the statistics to be at the top of the file, but `sts`
@@ -163,7 +162,7 @@ hdbgProg p hio = do
     -- *can't* get partial logs in the case of a crash. this is in opposition to
     -- the above traversal which *will* produce partial logs. i love laziness :3
     renderOut . showStats $ sts
-    pure final
+    pure (res, sts)
     where
         renderOut r = hPutStrLn hio $ render r ++ "\n"
 
@@ -176,8 +175,11 @@ hdbgProg p hio = do
         [resAddr] = final ^. gmStack
         res = hLookupUnsafe resAddr h
 
-evalProgR :: (Monad m) => Program' -> RLPCT m (Node, Stats)
+evalProgR :: Program' -> RLPCIO (Node, Stats)
 evalProgR p = do
+    -- me <- liftIO myThreadId
+    -- liftIO $ forkIO $ threadDelay (5 * 10^6) *> throwTo me ExitSuccess *> exitSuccess
+    -- states & traverseOf_ (each . gmCode) (liftIO . print)
     (renderOut . showState) `traverse_` states
     renderOut . showStats $ sts
     pure (res, sts)
@@ -196,11 +198,11 @@ eval st = st : rest
     where
         rest | isFinal st   = []
              | otherwise    = eval next
-        next = doAdmin (step st)
+        next = doAdmin (step . (\a -> (unsafePerformIO . hPutStrLn stderr . ('\n':) . render . showState $ a) `seq` a) $ st)
 
 doAdmin :: GmState -> GmState
 doAdmin st = st & gmStats . stsReductions %~ succ
-                & doGC
+                -- & doGC
     where
         -- TODO: use heapTrigger option in RLPCOptions
         heapTrigger = 50
@@ -410,7 +412,8 @@ step st = case head (st ^. gmCode) of
                 (e:s) = st ^. gmStack
                 an = s !! n
                 h = st ^. gmHeap
-                h' = h `seq` update an (NInd e) h
+                -- PROBLEM HERE:
+                h' = update an (NInd e) h
 
         popI :: Int -> GmState
         popI n = st
@@ -645,7 +648,7 @@ compiledPrims =
     , binop "<#" Lesser
     , binop ">=#" GreaterEq
     , ("print#", 1, [ Push 0, Eval, Print, Pack tag_Unit_unit 0, Update 1, Pop 1
-                    , Unwind ])
+                    , Unwind])
     ]
     where
         unop k i = (k, 1, [Push 0, Eval, i, Update 1, Pop 1, Unwind])
@@ -659,7 +662,7 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
 
         -- note that we don't count sc allocations in the stats
         allocateSc :: GmHeap -> CompiledSC -> (GmHeap, (Key, Addr))
-        allocateSc h (n,d,c) = (h', (NameKey n, a))
+        allocateSc h (n,d,c) = traceShow a (h', (NameKey n, a))
             where (h',a) = alloc h $ NGlobal d c
 
         -- >> [ref/compileSc]
@@ -746,17 +749,19 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
         compileE _ (Lit l) = compileEL l
         compileE g (Let NonRec bs e) =
                 -- we use compileE instead of compileC
-                mconcat binders <> compileE g' e <> [Slide d]
+                traceShowId $ mconcat binders <> compileE g' e <> [Slide d]
             where
                 d = length bs
-                (g',binders) = mapAccumL compileBinder g bs
+                (g',binders) = mapAccumL compileBinder (argOffset (d-1) g) addressed
+                -- kinda gross. revisit this
+                addressed = bs `zip` reverse [0 .. d-1]
 
-                compileBinder :: Env -> Binding' -> (Env, Code)
+                compileBinder :: Env -> (Binding', Int) -> (Env, Code)
-                compileBinder m (k := v) = (m',c)
+                compileBinder m (k := v, a) = (m',c)
                     where
-                        m' = (NameKey k, 0) : argOffset 1 m
+                        m' = (NameKey k, a) : m
                         -- make note that we use m rather than m'!
-                        c = compileC m v
+                        c = trace (printf "compileC %s %s" (show m) (show v)) $ compileC m v
 
         compileE g (Let Rec bs e) =
                 Alloc d : initialisers <> body <> [Slide d]
@@ -783,7 +788,6 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
         compileE g ("/#" :$ a :$ b)  = inlineOp2 g Div    a b
         compileE g ("==#" :$ a :$ b) = inlineOp2 g Equals a b
         compileE g ("<#" :$ a :$ b)  = inlineOp2 g Lesser a b
-        compileE g (">=#" :$ a :$ b)  = inlineOp2 g GreaterEq a b
 
         compileE g (Case e as) = compileE g e <> [CaseJump (compileD g as)]
 

src/Rlp/Lex.x

@@ -8,7 +8,6 @@ module Rlp.Lex
     , Located(..)
     , lexToken
     , lexStream
-    , lexStream'
     , lexDebug
     , lexCont
     , popLexState
@@ -28,9 +27,9 @@ import Data.Text                (Text)
 import Data.Text                qualified as T
 import Data.Word
 import Data.Default
-import Control.Lens
+import Lens.Micro.Mtl
+import Lens.Micro
 
-import Compiler.Types
 import Debug.Trace
 import Rlp.Parse.Types
 }
@@ -276,12 +275,11 @@ lexCont :: (Located RlpToken -> P a) -> P a
 lexCont = (lexToken >>=)
 
 lexStream :: P [RlpToken]
-lexStream = fmap extract <$> lexStream'
+lexStream = do
-
+    t <- lexToken
-lexStream' :: P [Located RlpToken]
+    case t of
-lexStream' = lexToken >>= \case
+        Located _ TokenEOF -> pure [TokenEOF]
-    t@(Located _ TokenEOF) -> pure [t]
+        Located _ t        -> (t:) <$> lexStream
-    t        -> (t:) <$> lexStream'
 
 lexDebug :: (Located RlpToken -> P a) -> P a
 lexDebug k = do

src/Rlp/Parse.y

@@ -5,17 +5,15 @@ module Rlp.Parse
     , parseRlpProgR
     , parseRlpExpr
     , parseRlpExprR
-    , runP'
     )
     where
 import Compiler.RlpcError
 import Compiler.RLPC
-import Control.Comonad.Cofree
 import Rlp.Lex
 import Rlp.Syntax
 import Rlp.Parse.Types
 import Rlp.Parse.Associate
-import Control.Lens                 hiding (snoc, (.>), (<.), (<<~), (:<))
+import Lens.Micro.Platform
 import Data.List.Extra
 import Data.Fix
 import Data.Functor.Const
@@ -73,11 +71,12 @@ import Compiler.Types
 
 %%
 
-StandaloneProgram   :: { Program RlpcPs SrcSpan }
+StandaloneProgram   :: { RlpProgram RlpcPs }
-StandaloneProgram   : layout0(Decl)         {% mkProgram $1 }
+StandaloneProgram   : '{' Decls  '}'        {% mkProgram $2 }
+                    | VL  DeclsV VR         {% mkProgram $2 }
 
-StandaloneExpr      :: { Expr' RlpcPs SrcSpan }
+StandaloneExpr      :: { RlpExpr RlpcPs }
-                    : VL Expr VR            { $2 }
+                    : VL Expr VR            { extract $2 }
 
 VL  :: { () }
 VL  : vlbrace       { () }
@@ -86,105 +85,125 @@ VR  :: { () }
 VR  : vrbrace       { () }
     | error         { () }
 
-VS                  :: { () }
+Decls               :: { [Decl' RlpcPs] }
-VS                  : ';'                   { () }
+Decls               : Decl ';' Decls        { $1 : $3 }
-                    | vsemi                 { () }
+                    | Decl ';'              { [$1] }
+                    | Decl                  { [$1] }
 
-Decl        :: { Decl RlpcPs SrcSpan }
+DeclsV              :: { [Decl' RlpcPs] }
+DeclsV              : Decl VS DeclsV        { $1 : $3 }
+                    | Decl VS               { [$1] }
+                    | Decl                  { [$1] }
+
+VS                  :: { Located RlpToken }
+VS                  : ';'                   { $1 }
+                    | vsemi                 { $1 }
+
+Decl        :: { Decl' RlpcPs }
             : FunDecl                   { $1 }
             | TySigDecl                 { $1 }
             | DataDecl                  { $1 }
             | InfixDecl                 { $1 }
 
-TySigDecl   :: { Decl RlpcPs SrcSpan }
+TySigDecl   :: { Decl' RlpcPs }
-            : Var '::' Type             { TySigD [$1] $3 }
+            : Var '::' Type             { (\e -> TySigD [extract e]) <<~ $1 <~> $3 }
 
-InfixDecl   :: { Decl RlpcPs SrcSpan }
+InfixDecl   :: { Decl' RlpcPs }
-            : InfixWord litint InfixOp  {% mkInfixD $1 ($2 ^. _litint) $3 }
+            : InfixWord litint InfixOp  { $1 =>> \w ->
+                                          InfixD (extract $1) (extractInt $ extract $2)
+                                          (extract $3) }
 
-InfixWord   :: { Assoc }
+InfixWord   :: { Located Assoc }
-            : infixl                    { InfixL }
+            : infixl                    { $1 \$> InfixL }
-            | infixr                    { InfixR }
+            | infixr                    { $1 \$> InfixR }
-            | infix                     { Infix }
+            | infix                     { $1 \$> Infix  }
 
-DataDecl    :: { Decl RlpcPs SrcSpan }
+DataDecl    :: { Decl' RlpcPs }
-            : data Con TyParams '=' DataCons    { DataD $2 $3 $5 }
+            : data Con TyParams '=' DataCons    { $1 \$> DataD (extract $2) $3 $5 }
 
 TyParams    :: { [PsName] }
             : {- epsilon -}             { [] }
-            | TyParams varname          { $1 `snoc` extractName $2 }
+            | TyParams varname          { $1 `snoc` (extractName . extract $ $2) }
 
 DataCons    :: { [ConAlt RlpcPs] }
             : DataCons '|' DataCon      { $1 `snoc` $3 }
             | DataCon                   { [$1] }
 
 DataCon     :: { ConAlt RlpcPs }
-            : Con Type1s                { ConAlt $1 $2 }
+            : Con Type1s                { ConAlt (extract $1) $2 }
 
-Type1s      :: { [Ty RlpcPs] }
+Type1s      :: { [RlpType' RlpcPs] }
             : {- epsilon -}             { [] }
             | Type1s Type1              { $1 `snoc` $2 }
 
-Type1       :: { Ty RlpcPs }
+Type1       :: { RlpType' RlpcPs }
             : '(' Type ')'              { $2 }
-            | conname                   { ConT (extractName $1) }
+            | conname                   { fmap ConT (mkPsName $1) }
-            | varname                   { VarT (extractName $1) }
+            | varname                   { fmap VarT (mkPsName $1) }
 
-Type        :: { Ty RlpcPs }
+Type        :: { RlpType' RlpcPs }
-            : Type '->' Type            { FunT $1 $3 }
+            : Type '->' Type            { FunT <<~ $1 <~> $3 }
             | TypeApp                   { $1 }
 
-TypeApp     :: { Ty RlpcPs }
+TypeApp     :: { RlpType' RlpcPs }
             : Type1                     { $1 }
-            | TypeApp Type1             { AppT $1 $2 }
+            | TypeApp Type1             { AppT <<~ $1 <~> $2 }
 
-FunDecl     :: { Decl RlpcPs SrcSpan }
+FunDecl     :: { Decl' RlpcPs }
-FunDecl     : Var Params '=' Expr       { FunD $1 $2 $4 Nothing }
+FunDecl     : Var Params '=' Expr       { $4 =>> \e ->
+                                          FunD (extract $1) $2 e Nothing }
 
-Params      :: { [Pat RlpcPs] }
+Params      :: { [Pat' RlpcPs] }
 Params      : {- epsilon -}             { [] }
             | Params Pat1               { $1 `snoc` $2 }
 
-Pat         :: { Pat RlpcPs }
+Pat         :: { Pat' RlpcPs }
-            : Con Pat1s                 { ConP $1 $2 }
+            : Con Pat1s                 { $1 =>> \cn ->
+                                          ConP (extract $1) $2 }
             | Pat1                      { $1 }
 
-Pat1s       :: { [Pat RlpcPs] }
+Pat1s       :: { [Pat' RlpcPs] }
             : Pat1s Pat1                { $1 `snoc` $2 }
             | Pat1                      { [$1] }
 
-Pat1        :: { Pat RlpcPs }
+Pat1        :: { Pat' RlpcPs }
-            : Con                       { ConP $1 [] }
+            : Con                       { fmap (`ConP` []) $1 }
-            | Var                       { VarP $1 }
+            | Var                       { fmap VarP $1 }
-            | Lit                       { LitP $1 }
+            | Lit                       { LitP <<= $1 }
-            | '(' Pat ')'               { $2 }
+            | '(' Pat ')'               { $1 .> $2 <. $3 }
 
-Expr        :: { Expr' RlpcPs SrcSpan }
+Expr        :: { RlpExpr' RlpcPs }
             -- infixities delayed till next release :(
-            -- : Expr1 InfixOp Expr        { undefined }
+            -- : Expr1 InfixOp Expr        { $2 =>> \o ->
-            : AppExpr                   { $1 }
+            --                              OAppE (extract o) $1 $3 }
-            | TempInfixExpr             { $1 }
+            : TempInfixExpr             { $1 }
             | LetExpr                   { $1 }
             | CaseExpr                  { $1 }
+            | AppExpr                   { $1 }
 
-TempInfixExpr :: { Expr' RlpcPs SrcSpan }
+TempInfixExpr :: { RlpExpr' RlpcPs }
 TempInfixExpr : Expr1 InfixOp TempInfixExpr {% tempInfixExprErr $1 $3 }
-              | Expr1 InfixOp Expr1         { nolo' $ InfixEF $2 $1 $3 }
+              | Expr1 InfixOp Expr1 { $2 =>> \o ->
+                                      OAppE (extract o) $1 $3 }
 
-AppExpr     :: { Expr' RlpcPs SrcSpan }
+AppExpr     :: { RlpExpr' RlpcPs }
             : Expr1                     { $1 }
-            | AppExpr Expr1             { comb2 AppEF $1 $2 }
+            | AppExpr Expr1             { AppE <<~ $1 <~> $2 }
 
-LetExpr     :: { Expr' RlpcPs SrcSpan }
+LetExpr     :: { RlpExpr' RlpcPs }
-            : let layout1(Binding) in Expr      { nolo' $ LetEF NonRec $2 $4 }
+            : let layout1(Binding) in Expr      { $1 \$> LetE $2 $4 }
-            | letrec layout1(Binding) in Expr   { nolo' $ LetEF Rec $2 $4 }
+            | letrec layout1(Binding) in Expr   { $1 \$> LetrecE $2 $4 }
 
-CaseExpr    :: { Expr' RlpcPs SrcSpan }
+CaseExpr    :: { RlpExpr' RlpcPs }
-            : case Expr of layout0(Alt)     { nolo' $ CaseEF $2 $4 }
+            : case Expr of layout0(CaseAlt)
+                { CaseE <<~ $2 <#> $4 }
 
 -- TODO: where-binds
-Alt         :: { Alt' RlpcPs SrcSpan }
+CaseAlt     :: { (Alt RlpcPs, Where RlpcPs) }
-            : Pat '->' Expr                 { AltA $1 (view _unwrap $3) Nothing }
+            : Alt                           { ($1, []) }
+
+Alt         :: { Alt RlpcPs }
+            : Pat '->' Expr                 { AltA $1 $3 }
 
 -- layout0(p : β) :: [β]
 layout0(p)  : '{' layout_list0(';',p) '}'   { $2 }
@@ -203,68 +222,38 @@ layout1(p)  : '{' layout_list1(';',p) '}'   { $2 }
 layout_list1(sep,p) : p                          { [$1] }
                     | layout_list1(sep,p) sep p  { $1 `snoc` $3 }
 
-Binding     :: { Binding' RlpcPs SrcSpan }
+Binding     :: { Binding' RlpcPs }
-            : Pat '=' Expr              { PatB $1 (view _unwrap $3) }
+            : Pat '=' Expr              { PatB <<~ $1 <~> $3 }
 
-Expr1       :: { Expr' RlpcPs SrcSpan }
+Expr1       :: { RlpExpr' RlpcPs }
-            : '(' Expr ')'              { $2 }
+            : '(' Expr ')'              { $1 .> $2 <. $3 }
-            | Lit                       { nolo' $ LitEF $1 }
+            | Lit                       { fmap LitE $1 }
-            | Var                       { case $1 of Located ss _ -> ss :< VarEF $1 }
+            | Var                       { fmap VarE $1 }
-            | Con                       { case $1 of Located ss _ -> ss :< VarEF $1 }
+            | Con                       { fmap VarE $1 }
 
-InfixOp     :: { PsName }
+InfixOp     :: { Located PsName }
-            : consym                    { extractName $1 }
+            : consym                    { mkPsName $1 }
-            | varsym                    { extractName $1 }
+            | varsym                    { mkPsName $1 }
 
 -- TODO: microlens-pro save me microlens-pro (rewrite this with prisms)
-Lit         :: { Lit RlpcPs }
+Lit         :: { Lit' RlpcPs }
-            : litint                    { $1 ^. to extract
+            : litint                    { $1 <&> (IntL . (\ (TokenLitInt n) -> n)) }
-                                              . singular _TokenLitInt
-                                              . to IntL }
 
-Var         :: { PsName }
+Var         :: { Located PsName }
-Var         : varname                   { $1 <&> view (singular _TokenVarName) }
+Var         : varname                   { mkPsName $1 }
-            | varsym                    { $1 <&> view (singular _TokenVarSym) }
+            | varsym                    { mkPsName $1 }
 
-Con         :: { PsName }
+Con         :: { Located PsName }
-            : conname                   { $1 <&> view (singular _TokenConName) }
+            : conname                   { mkPsName $1 }
 
 {
 
-parseRlpProgR :: (Monad m) => Text -> RLPCT m (Program RlpcPs SrcSpan)
+parseRlpExprR :: (Monad m) => Text -> RLPCT m (RlpExpr RlpcPs)
-parseRlpProgR s = do
-    a <- liftErrorful $ pToErrorful parseRlpProg st
-    addDebugMsg @_ @String "dump-parsed" $ show a
-    pure a
-  where
-    st = programInitState s
-
-parseRlpExprR :: (Monad m) => Text -> RLPCT m (Expr' RlpcPs SrcSpan)
 parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st
     where
         st = programInitState s
 
-mkInfixD :: Assoc -> Int -> PsName -> P (Decl RlpcPs SrcSpan)
+parseRlpProgR :: (Monad m) => Text -> RLPCT m (RlpProgram RlpcPs)
-mkInfixD a p ln@(Located ss n) = do
-    let opl :: Lens' ParseState (Maybe OpInfo)
-        opl = psOpTable . at n
-    opl <~ (use opl >>= \case
-        Just o  -> addWoundHere l e >> pure (Just o) where
-            e = RlpParErrDuplicateInfixD n
-            l = T.length n
-        Nothing -> pure (Just (a,p))
-        )
-    pos <- use (psInput . aiPos)
-    pure $ InfixD a p ln
-
-{--
-
-parseRlpExprR :: (Monad m) => Text -> RLPCT m (Expr RlpcPs)
-parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st
-    where
-        st = programInitState s
-
-parseRlpProgR :: (Monad m) => Text -> RLPCT m (Program RlpcPs)
 parseRlpProgR s = do
     a <- liftErrorful $ pToErrorful parseRlpProg st
     addDebugMsg @_ @String "dump-parsed" $ show a
@@ -287,48 +276,37 @@ extractInt :: RlpToken -> Int
 extractInt (TokenLitInt n) = n
 extractInt _ = error "extractInt: ugh"
 
-mkProgram :: [Decl RlpcPs SrcSpan] -> P (Program RlpcPs SrcSpan)
+mkProgram :: [Decl' RlpcPs] -> P (RlpProgram RlpcPs)
 mkProgram ds = do
     pt <- use psOpTable
-    pure $ Program (associate pt <$> ds)
+    pure $ RlpProgram (associate pt <$> ds)
+
+parseError :: (Located RlpToken, [String]) -> P a
+parseError ((Located ss t), exp) = addFatal $
+    errorMsg ss (RlpParErrUnexpectedToken t exp)
+
+mkInfixD :: Assoc -> Int -> PsName -> P (Decl' RlpcPs)
+mkInfixD a p n = do
+    let opl :: Lens' ParseState (Maybe OpInfo)
+        opl = psOpTable . at n
+    opl <~ (use opl >>= \case
+        Just o  -> addWoundHere l e >> pure (Just o) where
+            e = RlpParErrDuplicateInfixD n
+            l = T.length n
+        Nothing -> pure (Just (a,p))
+        )
+    pos <- use (psInput . aiPos)
+    pure $ Located (spanFromPos pos 0) (InfixD a p n)
 
 intOfToken :: Located RlpToken -> Int
 intOfToken (Located _ (TokenLitInt n)) = n
 
-tempInfixExprErr :: Expr RlpcPs -> Expr RlpcPs -> P a
+tempInfixExprErr :: RlpExpr' RlpcPs -> RlpExpr' RlpcPs -> P a
 tempInfixExprErr (Located a _) (Located b _) =
     addFatal $ errorMsg (a <> b) $ RlpParErrOther
         [ "The rl' frontend is currently in beta. Support for infix expressions is minimal, sorry! :("
         , "In the mean time, don't mix any infix operators."
         ]
 
---}
-
-_litint :: Getter (Located RlpToken) Int
-_litint = to extract
-        . singular _TokenLitInt
-
-tempInfixExprErr :: Expr' RlpcPs SrcSpan -> Expr' RlpcPs SrcSpan -> P a
-tempInfixExprErr (a :< _) (b :< _) =
-    addFatal $ errorMsg (a <> b) $ RlpParErrOther
-        [ "The rl' frontend is currently in beta. Support for infix expressions is minimal, sorry! :("
-        , "In the mean time, don't mix any infix operators."
-        ]
-
-mkProgram :: [Decl RlpcPs SrcSpan] -> P (Program RlpcPs SrcSpan)
-mkProgram ds = do
-    pt <- use psOpTable
-    pure $ Program (associate pt <$> ds)
-
-extractName :: Located RlpToken -> PsName
-extractName (Located ss (TokenVarSym n)) = Located ss n
-extractName (Located ss (TokenVarName n)) = Located ss n
-extractName (Located ss (TokenConName n)) = Located ss n
-extractName (Located ss (TokenConSym n)) = Located ss n
-
-parseError :: (Located RlpToken, [String]) -> P a
-parseError ((Located ss t), exp) = addFatal $
-    errorMsg ss (RlpParErrUnexpectedToken t exp)
-
 }
 

src/Rlp/Parse/Associate.hs

@@ -11,12 +11,12 @@ import Data.Functor.Const
 import Data.Functor
 import Data.Text                        qualified as T
 import Text.Printf
-import Control.Lens
+import Lens.Micro
 import Rlp.Parse.Types
 import Rlp.Syntax
 --------------------------------------------------------------------------------
 
-associate :: OpTable -> Decl RlpcPs a -> Decl RlpcPs a
+associate :: OpTable -> Decl' RlpcPs -> Decl' RlpcPs
 associate _ p = p
 
 {-# WARNING associate "unimplemented" #-}

src/Rlp/Parse/Types.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE UndecidableInstances #-}
 module Rlp.Parse.Types
     (
     -- * Trees That Grow
@@ -18,9 +17,10 @@ module Rlp.Parse.Types
     , RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction
     , Located(..), PsName
     -- ** Lenses
-    , _TokenLitInt, _TokenVarName, _TokenConName, _TokenVarSym
     , aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn
 
+    , (<<~), (<~>)
+
     -- * Error handling
     , MsgEnvelope(..), RlpcError(..), RlpParseError(..)
     , addFatal, addWound, addFatalHere, addWoundHere
@@ -28,7 +28,6 @@ module Rlp.Parse.Types
     where
 --------------------------------------------------------------------------------
 import Core.Syntax                  (Name)
-import Text.Show.Deriving
 import Control.Monad
 import Control.Monad.State.Strict
 import Control.Monad.Errorful
@@ -45,7 +44,8 @@ import Data.HashMap.Strict          qualified as H
 import Data.Void
 import Data.Word                    (Word8)
 import Data.Text                    qualified as T
-import Control.Lens                 hiding ((<<~))
+import Lens.Micro.TH
+import Lens.Micro
 import Rlp.Syntax
 import Compiler.Types
 --------------------------------------------------------------------------------
@@ -54,9 +54,34 @@ import Compiler.Types
 
 data RlpcPs
 
-type instance NameP RlpcPs = PsName
+type instance XRec RlpcPs a = Located a
+type instance IdP RlpcPs = PsName
 
-type PsName = Located Text
+type instance XFunD RlpcPs = ()
+type instance XDataD RlpcPs = ()
+type instance XInfixD RlpcPs = ()
+type instance XTySigD RlpcPs = ()
+type instance XXDeclD RlpcPs = ()
+
+type instance XLetE RlpcPs = ()
+type instance XLetrecE RlpcPs = ()
+type instance XVarE RlpcPs = ()
+type instance XLamE RlpcPs = ()
+type instance XCaseE RlpcPs = ()
+type instance XIfE RlpcPs = ()
+type instance XAppE RlpcPs = ()
+type instance XLitE RlpcPs = ()
+type instance XParE RlpcPs = ()
+type instance XOAppE RlpcPs = ()
+type instance XXRlpExprE RlpcPs = ()
+
+type PsName = Text
+
+instance MapXRec RlpcPs where
+    mapXRec = fmap
+
+instance UnXRec RlpcPs where
+    unXRec = extract
 
 --------------------------------------------------------------------------------
 
@@ -94,10 +119,10 @@ data RlpToken
     -- literals
     = TokenLitInt Int
     -- identifiers
-    | TokenVarName Text
+    | TokenVarName Name
-    | TokenConName Text
+    | TokenConName Name
-    | TokenVarSym Text
+    | TokenVarSym Name
-    | TokenConSym Text
+    | TokenConSym Name
     -- reserved words
     | TokenData
     | TokenCase
@@ -128,31 +153,6 @@ data RlpToken
     | TokenEOF
     deriving (Show)
 
-_TokenLitInt :: Prism' RlpToken Int
-_TokenLitInt = prism TokenLitInt $ \case
-    TokenLitInt n -> Right n
-    x             -> Left x
-
-_TokenVarName :: Prism' RlpToken Text
-_TokenVarName = prism TokenVarName $ \case
-    TokenVarName n -> Right n
-    x              -> Left x
-
-_TokenVarSym :: Prism' RlpToken Text
-_TokenVarSym = prism TokenVarSym $ \case
-    TokenVarSym n -> Right n
-    x              -> Left x
-
-_TokenConName :: Prism' RlpToken Text
-_TokenConName = prism TokenConName $ \case
-    TokenConName n -> Right n
-    x              -> Left x
-
-_TokenConSym :: Prism' RlpToken Text
-_TokenConSym = prism TokenConSym $ \case
-    TokenConSym n -> Right n
-    x              -> Left x
-
 newtype P a = P {
         runP :: ParseState
              -> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
@@ -282,14 +282,13 @@ initAlexInput s = AlexInput
 
 --------------------------------------------------------------------------------
 
-
+deriving instance Lift (RlpProgram RlpcPs)
--- deriving instance Lift (Program RlpcPs)
+deriving instance Lift (Decl RlpcPs)
--- deriving instance Lift (Decl RlpcPs)
+deriving instance Lift (Pat RlpcPs)
--- deriving instance Lift (Pat RlpcPs)
+deriving instance Lift (Lit RlpcPs)
--- deriving instance Lift (Lit RlpcPs)
+deriving instance Lift (RlpExpr RlpcPs)
--- deriving instance Lift (Expr RlpcPs)
+deriving instance Lift (Binding RlpcPs)
--- deriving instance Lift (Binding RlpcPs)
+deriving instance Lift (RlpType RlpcPs)
--- deriving instance Lift (Ty RlpcPs)
+deriving instance Lift (Alt RlpcPs)
--- deriving instance Lift (Alt RlpcPs)
+deriving instance Lift (ConAlt RlpcPs)
--- deriving instance Lift (ConAlt RlpcPs)
 

src/Rlp/Syntax.hs

@@ -1,10 +1,363 @@
+-- recursion-schemes
+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable
+  , TemplateHaskell, TypeFamilies #-}
+{-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-}
+{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}
+{-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-}
 module Rlp.Syntax
-    ( module Rlp.Syntax.Backstage
+    (
-    , module Rlp.Syntax.Types
+    -- * AST
+      RlpProgram(..)
+    , progDecls
+    , Decl(..), Decl', RlpExpr(..), RlpExpr', RlpExprF(..)
+    , Pat(..), Pat'
+    , Alt(..), Where
+    , Assoc(..)
+    , Lit(..), Lit'
+    , RlpType(..), RlpType'
+    , ConAlt(..)
+    , Binding(..), Binding'
+
+    , _PatB, _FunB
+    , _VarP, _LitP, _ConP
+
+    -- * Trees That Grow boilerplate
+    -- ** Extension points
+    , IdP, IdP', XRec, UnXRec(..), MapXRec(..)
+    -- *** Decl
+    , XFunD, XTySigD, XInfixD, XDataD, XXDeclD
+    -- *** RlpExpr
+    , XLetE, XLetrecE, XVarE, XLamE, XCaseE, XIfE, XAppE, XLitE
+    , XParE, XOAppE, XXRlpExprE
+    -- ** Pattern synonyms
+    -- *** Decl
+    , pattern FunD, pattern TySigD, pattern InfixD, pattern DataD
+    , pattern FunD'', pattern TySigD'', pattern InfixD'', pattern DataD''
+    -- *** RlpExpr
+    , pattern LetE, pattern LetrecE, pattern VarE, pattern LamE, pattern CaseE
+    , pattern IfE , pattern AppE, pattern LitE, pattern ParE, pattern OAppE
+    , pattern XRlpExprE
+    -- *** RlpType
+    , pattern FunConT'', pattern FunT'', pattern AppT'', pattern VarT''
+    , pattern ConT''
+    -- *** Pat
+    , pattern VarP'', pattern LitP'', pattern ConP''
+    -- *** Binding
+    , pattern PatB''
     )
     where
---------------------------------------------------------------------------------
+----------------------------------------------------------------------------------
-import Rlp.Syntax.Backstage
+import Data.Text                    (Text)
-import Rlp.Syntax.Types
+import Data.Text                    qualified as T
+import Data.String                  (IsString(..))
+import Data.Functor.Foldable
+import Data.Functor.Foldable.TH     (makeBaseFunctor)
+import Data.Functor.Classes
+import Data.Functor.Identity
+import Data.Kind                    (Type)
+import GHC.Generics
+import Language.Haskell.TH.Syntax   (Lift)
+import Lens.Micro.Pro
+import Lens.Micro.Pro.TH
+import Core.Syntax                  hiding (Lit, Type, Binding, Binding')
+import Core                         (HasRHS(..), HasLHS(..))
+----------------------------------------------------------------------------------
+
+data RlpModule p = RlpModule
+    { _rlpmodName       :: Text
+    , _rlpmodProgram    :: RlpProgram p
+    }
+
+-- | dear god.
+type PhaseShow p =
+    ( Show (XRec p (Pat p)), Show (XRec p (RlpExpr p))
+    , Show (XRec p (Lit p)), Show (IdP p)
+    , Show (XRec p (RlpType p))
+    , Show (XRec p (Binding p))
+    )
+
+newtype RlpProgram p = RlpProgram [Decl' p]
+
+progDecls :: Lens' (RlpProgram p) [Decl' p]
+progDecls = lens
+    (\ (RlpProgram ds) -> ds)
+    (const RlpProgram)
+
+deriving instance (PhaseShow p, Show (XRec p (Decl p))) => Show (RlpProgram p)
+
+data RlpType p = FunConT
+               | FunT (RlpType' p) (RlpType' p)
+               | AppT (RlpType' p) (RlpType' p)
+               | VarT (IdP p)
+               | ConT (IdP p)
+
+type RlpType' p = XRec p (RlpType p)
+
+pattern FunConT'' :: (UnXRec p) => RlpType' p
+pattern FunT''    :: (UnXRec p) => RlpType' p -> RlpType' p -> RlpType' p
+pattern AppT''    :: (UnXRec p) => RlpType' p -> RlpType' p -> RlpType' p
+pattern VarT''    :: (UnXRec p) => IdP p -> RlpType' p
+pattern ConT''    :: (UnXRec p) => IdP p -> RlpType' p
+
+pattern FunConT''     <- (unXRec -> FunConT)
+pattern FunT''    s t <- (unXRec -> FunT s t)
+pattern AppT''    s t <- (unXRec -> AppT s t)
+pattern VarT''    n   <- (unXRec -> VarT n)
+pattern ConT''    n   <- (unXRec -> ConT n)
+
+deriving instance (PhaseShow p)
+                  => Show (RlpType p)
+
+data Decl p = FunD'   (XFunD p)    (IdP p) [Pat' p] (RlpExpr' p) (Maybe (Where p))
+            | TySigD' (XTySigD p)  [IdP p] (RlpType' p)
+            | DataD'  (XDataD p)   (IdP p) [IdP p] [ConAlt p]
+            | InfixD' (XInfixD p)  Assoc Int (IdP p)
+            | XDeclD' !(XXDeclD p)
+
+deriving instance
+    ( Show (XFunD p), Show (XTySigD p)
+    , Show (XDataD p), Show (XInfixD p)
+    , Show (XXDeclD p)
+    , PhaseShow p
+    ) 
+    => Show (Decl p)
+
+type family XFunD p
+type family XTySigD p
+type family XDataD p
+type family XInfixD p
+type family XXDeclD p
+
+pattern FunD   :: (XFunD p ~ ())
+               => IdP p -> [Pat' p] -> RlpExpr' p -> Maybe (Where p)
+               -> Decl p
+pattern TySigD :: (XTySigD p ~ ()) => [IdP p] -> RlpType' p -> Decl p
+pattern DataD  :: (XDataD p ~ ()) => IdP p -> [IdP p] -> [ConAlt p] -> Decl p
+pattern InfixD :: (XInfixD p ~ ()) => Assoc -> Int -> IdP p -> Decl p
+pattern XDeclD :: (XXDeclD p ~ ()) => Decl p
+
+pattern FunD n as e wh = FunD' () n as e wh
+pattern TySigD ns t    = TySigD' () ns t
+pattern DataD n as cs  = DataD' () n as cs
+pattern InfixD a p n   = InfixD' () a p n
+pattern XDeclD         = XDeclD' ()
+
+pattern FunD''   :: (UnXRec p)
+                 => IdP p -> [Pat' p] -> RlpExpr' p -> Maybe (Where p)
+                 -> Decl' p
+pattern TySigD'' :: (UnXRec p)
+                 => [IdP p] -> RlpType' p -> Decl' p
+pattern DataD''  :: (UnXRec p)
+                 => IdP p -> [IdP p] -> [ConAlt p] -> Decl' p
+pattern InfixD'' :: (UnXRec p)
+                 => Assoc -> Int -> IdP p -> Decl' p
+
+pattern FunD''   n as e wh <- (unXRec -> FunD' _ n as e wh)
+pattern TySigD'' ns t      <- (unXRec -> TySigD' _ ns t)
+pattern DataD''  n as ds   <- (unXRec -> DataD' _ n as ds)
+pattern InfixD'' a p n     <- (unXRec -> InfixD' _ a p n)
+
+type Decl' p = XRec p (Decl p)
+
+data Assoc = InfixL
+           | InfixR
+           | Infix
+           deriving (Show, Lift)
+
+data ConAlt p = ConAlt (IdP p) [RlpType' p]
+
+deriving instance (Show (IdP p), Show (XRec p (RlpType p))) => Show (ConAlt p)
+
+data RlpExpr p = LetE'      (XLetE p) [Binding' p] (RlpExpr' p)
+               | LetrecE'   (XLetrecE p) [Binding' p] (RlpExpr' p)
+               | VarE'      (XVarE p) (IdP p)
+               | LamE'      (XLamE p) [Pat p] (RlpExpr' p)
+               | CaseE'     (XCaseE p) (RlpExpr' p) [(Alt p, Where p)]
+               | IfE'       (XIfE p) (RlpExpr' p) (RlpExpr' p) (RlpExpr' p)
+               | AppE'      (XAppE p) (RlpExpr' p) (RlpExpr' p)
+               | LitE'      (XLitE p) (Lit p)
+               | ParE'      (XParE p) (RlpExpr' p)
+               | OAppE'     (XOAppE p) (IdP p) (RlpExpr' p) (RlpExpr' p)
+               | XRlpExprE' !(XXRlpExprE p)
+               deriving (Generic)
+
+type family XLetE p
+type family XLetrecE p
+type family XVarE p
+type family XLamE p
+type family XCaseE p
+type family XIfE p
+type family XAppE p
+type family XLitE p
+type family XParE p
+type family XOAppE p
+type family XXRlpExprE p
+
+pattern LetE :: (XLetE p ~ ()) => [Binding' p] -> RlpExpr' p -> RlpExpr p
+pattern LetrecE :: (XLetrecE p ~ ()) => [Binding' p] -> RlpExpr' p -> RlpExpr p
+pattern VarE :: (XVarE p ~ ()) => IdP p -> RlpExpr p
+pattern LamE :: (XLamE p ~ ()) => [Pat p] -> RlpExpr' p -> RlpExpr p
+pattern CaseE :: (XCaseE p ~ ()) => RlpExpr' p -> [(Alt p, Where p)] -> RlpExpr p
+pattern IfE :: (XIfE p ~ ()) => RlpExpr' p -> RlpExpr' p -> RlpExpr' p -> RlpExpr p
+pattern AppE :: (XAppE p ~ ()) => RlpExpr' p -> RlpExpr' p -> RlpExpr p
+pattern LitE :: (XLitE p ~ ()) => Lit p -> RlpExpr p
+pattern ParE :: (XParE p ~ ()) => RlpExpr' p -> RlpExpr p
+pattern OAppE :: (XOAppE p ~ ()) => IdP p -> RlpExpr' p -> RlpExpr' p -> RlpExpr p
+pattern XRlpExprE :: (XXRlpExprE p ~ ()) => RlpExpr p
+
+pattern LetE bs e = LetE' () bs e
+pattern LetrecE bs e = LetrecE' () bs e
+pattern VarE n = VarE' () n
+pattern LamE as e = LamE' () as e
+pattern CaseE e as = CaseE' () e as
+pattern IfE c a b = IfE' () c a b
+pattern AppE f x = AppE' () f x
+pattern LitE l = LitE' () l
+pattern ParE e = ParE' () e
+pattern OAppE n a b = OAppE' () n a b
+pattern XRlpExprE = XRlpExprE' ()
+
+deriving instance
+    ( Show (XLetE p), Show (XLetrecE p), Show (XVarE p)
+    , Show (XLamE p), Show (XCaseE p), Show (XIfE p)
+    , Show (XAppE p), Show (XLitE p), Show (XParE p)
+    , Show (XOAppE p), Show (XXRlpExprE p)
+    , PhaseShow p
+    ) => Show (RlpExpr p)
+
+type RlpExpr' p = XRec p (RlpExpr p)
+
+class UnXRec p where
+    unXRec :: XRec p a -> a
+
+class WrapXRec p where
+    wrapXRec :: a -> XRec p a
+
+class MapXRec p where
+    mapXRec :: (a -> b) -> XRec p a -> XRec p b
+
+-- old definition:
+-- type family XRec p (f :: Type -> Type) = (r :: Type) | r -> p f
+type family XRec p a = (r :: Type) | r -> p a
+
+type family IdP p
+
+type IdP' p = XRec p (IdP p)
+
+type Where p = [Binding p]
+
+-- do we want guards?
+data Alt p = AltA (Pat' p) (RlpExpr' p)
+
+deriving instance (PhaseShow p) => Show (Alt p)
+
+data Binding p = PatB (Pat' p) (RlpExpr' p)
+               | FunB (IdP p) [Pat' p] (RlpExpr' p)
+
+type Binding' p = XRec p (Binding p)
+
+pattern PatB'' :: (UnXRec p) => Pat' p -> RlpExpr' p -> Binding' p
+pattern PatB'' p e <- (unXRec -> PatB p e)
+
+deriving instance (Show (XRec p (Pat p)), Show (XRec p (RlpExpr p)), Show (IdP p)
+                  ) => Show (Binding p)
+
+data Pat p = VarP (IdP p)
+           | LitP (Lit' p)
+           | ConP (IdP p) [Pat' p]
+
+pattern VarP'' :: (UnXRec p) => IdP p -> Pat' p
+pattern LitP'' :: (UnXRec p) => Lit' p -> Pat' p
+pattern ConP'' :: (UnXRec p) => IdP p -> [Pat' p] -> Pat' p
+
+pattern VarP'' n    <- (unXRec -> VarP n)
+pattern LitP'' l    <- (unXRec -> LitP l)
+pattern ConP'' c as <- (unXRec -> ConP c as)
+
+deriving instance (PhaseShow p) => Show (Pat p)
+
+type Pat' p = XRec p (Pat p)
+
+data Lit p = IntL Int
+           | CharL Char
+           | ListL [RlpExpr' p]
+
+deriving instance (PhaseShow p) => Show (Lit p)
+
+type Lit' p = XRec p (Lit p)
+
+-- instance HasLHS Alt Alt Pat Pat where
+--     _lhs = lens
+--         (\ (AltA p _) -> p)
+--         (\ (AltA _ e) p' -> AltA p' e)
+
+-- instance HasRHS Alt Alt RlpExpr RlpExpr where
+--     _rhs = lens
+--         (\ (AltA _ e) -> e)
+--         (\ (AltA p _) e' -> AltA p e')
+
+-- makeBaseFunctor ''RlpExpr
+
+-- showsTernaryWith :: (Int -> x -> ShowS)
+--                  -> (Int -> y -> ShowS)
+--                  -> (Int -> z -> ShowS)
+--                  -> String -> Int
+--                  -> x -> y -> z
+--                  -> ShowS
+-- showsTernaryWith sa sb sc name p a b c = showParen (p > 10)
+--     $ showString name
+--     . showChar ' ' . sa 11 a 
+--     . showChar ' ' . sb 11 b
+--     . showChar ' ' . sc 11 c
+
 --------------------------------------------------------------------------------
 
+makeLenses ''RlpModule
+makePrisms ''Pat
+makePrisms ''Binding
+
+--------------------------------------------------------------------------------
+
+data RlpExprF p a = LetE'F  (XLetE p) [Binding' p] a
+                  | LetrecE'F  (XLetrecE p) [Binding' p] a
+                  | VarE'F  (XVarE p) (IdP p)
+                  | LamE'F  (XLamE p) [Pat p] a
+                  | CaseE'F (XCaseE p) a [(Alt p, Where p)]
+                  | IfE'F   (XIfE p) a a a
+                  | AppE'F  (XAppE p) a a
+                  | LitE'F  (XLitE p) (Lit p)
+                  | ParE'F  (XParE p) a
+                  | OAppE'F (XOAppE p) (IdP p) a a
+                  | XRlpExprE'F !(XXRlpExprE p)
+                  deriving (Functor, Foldable, Traversable, Generic)
+
+type instance Base (RlpExpr p) = RlpExprF p
+
+instance (UnXRec p) => Recursive (RlpExpr p) where
+    project = \case
+        LetE' xx bs e   -> LetE'F xx bs (unXRec e)
+        LetrecE' xx bs e   -> LetrecE'F xx bs (unXRec e)
+        VarE' xx n      -> VarE'F xx n
+        LamE' xx ps e   -> LamE'F xx ps (unXRec e)
+        CaseE' xx e as  -> CaseE'F xx (unXRec e) as
+        IfE' xx a b c   -> IfE'F xx (unXRec a) (unXRec b) (unXRec c)
+        AppE' xx f x    -> AppE'F xx (unXRec f) (unXRec x)
+        LitE' xx l      -> LitE'F xx l
+        ParE' xx e      -> ParE'F xx (unXRec e)
+        OAppE' xx f a b -> OAppE'F xx f (unXRec a) (unXRec b)
+        XRlpExprE' xx   -> XRlpExprE'F xx
+
+instance (WrapXRec p) => Corecursive (RlpExpr p) where
+    embed = \case
+        LetE'F xx bs e   -> LetE' xx bs (wrapXRec e)
+        LetrecE'F xx bs e   -> LetrecE' xx bs (wrapXRec e)
+        VarE'F xx n      -> VarE' xx n
+        LamE'F xx ps e   -> LamE' xx ps (wrapXRec e)
+        CaseE'F xx e as  -> CaseE' xx (wrapXRec e) as
+        IfE'F xx a b c   -> IfE' xx (wrapXRec a) (wrapXRec b) (wrapXRec c)
+        AppE'F xx f x    -> AppE' xx (wrapXRec f) (wrapXRec x)
+        LitE'F xx l      -> LitE' xx l
+        ParE'F xx e      -> ParE' xx (wrapXRec e)
+        OAppE'F xx f a b -> OAppE' xx f (wrapXRec a) (wrapXRec b)
+        XRlpExprE'F xx   -> XRlpExprE' xx
+

src/Rlp/Syntax/Backstage.hs

@@ -1,35 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE UndecidableInstances #-}
-module Rlp.Syntax.Backstage
-    ( strip
-    )
-    where
---------------------------------------------------------------------------------
-import Data.Fix                     hiding (cata)
-import Data.Functor.Classes
-import Data.Functor.Foldable
-import Rlp.Syntax.Types
-import Text.Show.Deriving
-import Language.Haskell.TH.Syntax   (Lift)
---------------------------------------------------------------------------------
-
--- oprhan instances because TH
-
-instance (Show (NameP p)) => Show1 (Alt p) where
-    liftShowsPrec = $(makeLiftShowsPrec ''Alt)
-
-instance (Show (NameP p)) => Show1 (Binding p) where
-    liftShowsPrec = $(makeLiftShowsPrec ''Binding)
-
-instance (Show (NameP p)) => Show1 (ExprF p) where
-    liftShowsPrec = $(makeLiftShowsPrec ''ExprF)
-
-deriving instance (Lift (NameP p), Lift a) => Lift (Expr' p a)
-deriving instance (Lift (NameP p), Lift a) => Lift (Decl p a)
-deriving instance (Show (NameP p), Show a) => Show (Decl p a)
-
-deriving instance (Show (NameP p), Show a) => Show (Program p a)
-
-strip :: Functor f => Cofree f a -> Fix f
-strip (_ :< as) = Fix $ strip <$> as
-

src/Rlp/Syntax/Types.hs

@@ -1,143 +0,0 @@
--- recursion-schemes
-{-# LANGUAGE DeriveTraversable, TemplateHaskell, TypeFamilies #-}
-{-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-}
-{-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-}
-module Rlp.Syntax.Types
-    (
-      NameP
-    , SimpleP
-    , Assoc(..)
-    , ConAlt(..)
-    , Alt(..), Alt'
-    , Ty(..)
-    , Binding(..), Binding'
-    , Expr', ExprF(..)
-    , Rec(..)
-    , Lit(..)
-    , Pat(..)
-    , Decl(..)
-    , Program(..)
-    , Where
-
-    -- * Re-exports
-    , Cofree(..)
-    , Trans.Cofree.CofreeF
-    , SrcSpan(..)
-    )
-    where
-----------------------------------------------------------------------------------
-import Data.Text                    (Text)
-import Data.Text                    qualified as T
-import Data.String                  (IsString(..))
-import Data.Functor.Classes
-import Data.Functor.Identity
-import Data.Functor.Compose
-import Data.Fix
-import Data.Kind                    (Type)
-import GHC.Generics
-import Language.Haskell.TH.Syntax   (Lift)
-import Control.Lens                 hiding ((:<))
-
-import Control.Comonad.Trans.Cofree qualified as Trans.Cofree
-import Control.Comonad.Cofree
-import Data.Functor.Foldable
-import Data.Functor.Foldable.TH     (makeBaseFunctor)
-
-import Compiler.Types               (SrcSpan(..), Located(..))
-import Core.Syntax                  qualified as Core
-import Core                         (Rec(..), HasRHS(..), HasLHS(..))
-----------------------------------------------------------------------------------
-
-data SimpleP
-
-type instance NameP SimpleP = String
-
-type family NameP p
-
-data ExprF p a = LetEF   Rec [Binding p a] a
-               | VarEF   (NameP p)
-               | LamEF   [Pat p] a
-               | CaseEF  a [Alt p a]
-               | IfEF    a a a
-               | AppEF   a a
-               | LitEF   (Lit p)
-               | ParEF   a
-               | InfixEF (NameP p) a a
-               deriving (Functor, Foldable, Traversable)
-
-data ConAlt p = ConAlt (NameP p) [Ty p]
-
-deriving instance (Lift (NameP p)) => Lift (ConAlt p)
-deriving instance (Show (NameP p)) => Show (ConAlt p)
-
-data Ty p = ConT (NameP p)
-          | VarT (NameP p)
-          | FunT (Ty p) (Ty p)
-          | AppT (Ty p) (Ty p)
-
-deriving instance (Show (NameP p)) => Show (Ty p)
-deriving instance (Lift (NameP p)) => Lift (Ty p)
-
-data Pat p = VarP (NameP p)
-           | LitP (Lit p)
-           | ConP (NameP p) [Pat p]
-
-deriving instance (Lift (NameP p)) => Lift (Pat p)
-deriving instance (Show (NameP p)) => Show (Pat p)
-
-data Lit p = IntL Int
-    deriving Show
-
-deriving instance (Lift (NameP p)) => Lift (Lit p)
-
-data Assoc = InfixL | InfixR | Infix
-    deriving (Lift, Show)
-
-deriving instance (Show (NameP p), Show a) => Show (ExprF p a)
-deriving instance (Lift (NameP p), Lift a) => Lift (ExprF p a)
-
-data Binding p a = PatB (Pat p) (ExprF p a)
-    deriving (Functor, Foldable, Traversable)
-
-deriving instance (Lift (NameP p), Lift a) => Lift (Binding p a)
-deriving instance (Show (NameP p), Show a) => Show (Binding p a)
-
-type Binding' p a = Binding p (Cofree (ExprF p) a)
-
-type Where p a = [Binding p a]
-
-data Alt p a = AltA (Pat p) (ExprF p a) (Maybe (Where p a))
-    deriving (Functor, Foldable, Traversable)
-
-deriving instance (Show (NameP p), Show a) => Show (Alt p a)
-deriving instance (Lift (NameP p), Lift a) => Lift (Alt p a)
-
-type Expr p = Fix (ExprF p)
-
-type Alt' p a = Alt p (Cofree (ExprF p) a)
-
---------------------------------------------------------------------------------
-
-data Program p a = Program
-    { _programDecls :: [Decl p a]
-    }
-
-data Decl p a = FunD   (NameP p) [Pat p] (Expr' p a) (Maybe (Where p a))
-              | TySigD [NameP p] (Ty p)
-              | DataD  (NameP p) [NameP p] [ConAlt p]
-              | InfixD Assoc Int (NameP p)
-
-type Decl' p a = Decl p (Cofree (ExprF p) a)
-
-type Expr' p = Cofree (ExprF p)
-
-makeLenses ''Program
-
-loccof :: Iso' (Cofree f SrcSpan) (Located (f (Cofree f SrcSpan)))
-loccof = iso sa bt where
-    sa :: Cofree f SrcSpan -> Located (f (Cofree f SrcSpan))
-    sa (ss :< as) = Located ss as
-
-    bt :: Located (f (Cofree f SrcSpan)) -> Cofree f SrcSpan
-    bt (Located ss as) = ss :< as
-

src/Rlp/TH.hs

@@ -17,12 +17,10 @@ import Rlp.Parse
 --------------------------------------------------------------------------------
 
 rlpProg :: QuasiQuoter
-rlpProg = undefined
+rlpProg = mkqq parseRlpProgR
--- rlpProg = mkqq parseRlpProgR
 
 rlpExpr :: QuasiQuoter
-rlpExpr = undefined
+rlpExpr = mkqq parseRlpExprR
--- rlpExpr = mkqq parseRlpExprR
 
 mkq :: (Lift a) => (Text -> RLPCIO a) -> String -> Q Exp
 mkq parse = evalAndParse >=> lift where

src/Rlp2Core.hs

@@ -13,6 +13,8 @@ import Control.Monad.Utils
 import Control.Arrow
 import Control.Applicative
 import Control.Comonad
+-- import Lens.Micro
+-- import Lens.Micro.Internal
 import Control.Lens
 import Compiler.RLPC
 import Data.List                        (mapAccumL, partition)
@@ -41,12 +43,6 @@ import Rlp.Syntax                       as Rlp
 import Rlp.Parse.Types                  (RlpcPs, PsName)
 --------------------------------------------------------------------------------
 
-desugarRlpProgR = undefined
-desugarRlpProg = undefined
-desugarRlpExpr = undefined
-
-{--
-
 type Tree a = Either Name (Name, Branch a)
 
 -- | Rose tree branch representing "nested" "patterns" in the Core language. That
@@ -240,5 +236,3 @@ typeToCore (VarT'' x)   = TyVar (dsNameToName x)
 dsNameToName :: IdP RlpcPs -> Name
 dsNameToName = id
 
--}
-

src/TI.hs

@@ -20,7 +20,8 @@ import System.IO                (Handle, hPutStr)
 import Text.Printf              (printf, hPrintf)
 import Data.Proxy               (Proxy(..))
 import Data.Monoid              (Endo(..))
-import Control.Lens
+import Lens.Micro
+import Lens.Micro.TH
 import Data.Pretty
 import Data.Heap
 import Core.Examples

tst/Arith.hs

@@ -41,7 +41,6 @@ evalArith (a ::* b)   = evalArith a * evalArith b
 evalArith (a ::- b)   = evalArith a - evalArith b
 
 instance Arbitrary ArithExpr where
-    -- TODO: implement shrink
     arbitrary = gen 4
         where
             gen :: Int -> Gen ArithExpr

tst/Compiler/TypesSpec.hs

@@ -1,67 +0,0 @@
-{-# LANGUAGE ParallelListComp #-}
-module Compiler.TypesSpec
-    ( spec
-    )
-    where
---------------------------------------------------------------------------------
-import Control.Lens.Combinators
-import Data.Function            ((&))
-
-import Test.QuickCheck
-import Test.Hspec
-
-import Compiler.Types           (SrcSpan(..), srcSpanAbs, srcSpanLen)
---------------------------------------------------------------------------------
-
-spec :: Spec
-spec = do
-    describe "SrcSpan" $ do
-        -- it "associates under closure"
-        --     prop_SrcSpan_mul_associative
-        it "commutes under closure"
-            prop_SrcSpan_mul_commutative
-        it "equals itself when squared"
-            prop_SrcSpan_mul_square_eq
-
-prop_SrcSpan_mul_associative :: Property
-prop_SrcSpan_mul_associative = property $ \a b c ->
-    -- very crudely approximate when overflow will occur; bail we think it
-    -- will
-    (([a,b,c] :: [SrcSpan]) & allOf (each . (srcSpanAbs <> srcSpanLen))
-                                    (< (maxBound @Int `div` 3)))
-    ==> (a <> b) <> c === a <> (b <> c :: SrcSpan)
-
-prop_SrcSpan_mul_commutative :: Property
-prop_SrcSpan_mul_commutative = property $ \a b ->
-    a <> b === (b <> a :: SrcSpan)
-
-prop_SrcSpan_mul_square_eq :: Property
-prop_SrcSpan_mul_square_eq = property $ \a ->
-    a <> a === (a :: SrcSpan)
-
-instance Arbitrary SrcSpan where
-    arbitrary = do
-        l <- chooseInt (1, maxBound)
-        c <- chooseInt (1, maxBound)
-        a <- chooseInt (0, maxBound)
-            `suchThat` (\n -> n >= pred l + pred c)
-        s <- chooseInt (0, maxBound)
-        pure $ SrcSpan l c a s
-
-    shrink (SrcSpan l c a s) =
-        [ SrcSpan l' c' a' s'
-        | (l',c',a',s') <- shrinkParts
-        , l' >= 1
-        , c' >= 1
-        , a' >= pred l' + pred c'
-        ]
-      where
-        -- shfl as = unsafePerformIO (generate $ shuffle as)
-        shrinkParts = 
-            [ (l',c',a',s')
-            | l' <- shrinkIntegral l
-            | c' <- shrinkIntegral c
-            | a' <- shrinkIntegral a
-            | s' <- shrinkIntegral s
-            ]
-