this sucks lol

unparsers

.ghci

@@ -1,18 +0,0 @@
-:set -XOverloadedStrings
-
-:set -package process
-
-:{
-import System.Exit qualified
-import System.Process qualified
-
-_reload_and_make _ = do
-    p <- System.Process.spawnCommand "make -f Makefile_happysrcs"
-    r <- System.Process.waitForProcess p
-    case r of
-        System.Exit.ExitSuccess -> pure ":reload"
-        _                       -> pure ""
-:}
-
-:def! r _reload_and_make
-

Makefile_happysrcs

@@ -1,19 +0,0 @@
-HAPPY = happy
-HAPPY_OPTS = -a -g -c
-ALEX = alex
-ALEX_OPTS = -g
-
-SRC = src
-CABAL_BUILD = dist-newstyle/build/x86_64-osx/ghc-9.6.2/rlp-0.1.0.0/build
-
-all: parsers lexers
-
-parsers: $(CABAL_BUILD)/Rlp/Parse.hs
-lexers: $(CABAL_BUILD)/Rlp/Lex.hs
-
-$(CABAL_BUILD)/Rlp/Parse.hs: $(SRC)/Rlp/Parse.y
-	$(HAPPY) $(HAPPY_OPTS) $< -o $@
-
-$(CABAL_BUILD)/Rlp/Lex.hs: $(SRC)/Rlp/Lex.x
-	$(ALEX) $(ALEX_OPTS) $< -o $@
-

doc/src/conf.py

@@ -32,7 +32,6 @@ html_theme = 'alabaster'
 imgmath_latex_preamble = r'''
 \usepackage{amsmath}
 \usepackage{tabularray}
-\usepackage{syntax}
 
 \newcommand{\transrule}[2]
     {\begin{tblr}{|rrrlc|}

doc/src/references/rlp-grammar.rst

@@ -1,67 +0,0 @@
-The Complete Syntax of rl'
-==========================
-
-WIP.
-
-Provided is the complete syntax of rl' in (pseudo) EBNF. {A} represents zero or
-more A's, [A] means optional A, and terminals are wrapped in 'single-quotes'.
-
-.. math
-   :nowrap:
-
-   \setlength{\grammarparsep}{20pt plus 1pt minus 1pt}
-   \setlength{\grammarindent}{12em}
-   \begin{grammar}
-       <Decl> ::= <InfixDecl>
-       \alt <DataDecl>
-       \alt <TypeSig>
-       \alt <FunDef>
-
-       <InfixDecl> ::= <InfixWord> `litint' <Name>
-       <InfixWord> ::= `infix'
-       \alt `infixl'
-       \alt `infixr'
-
-       <DataDecl> ::= `data' `conname' {}
-
-   \end{grammar}
-
-.. code-block:: bnf
-
-   Decl      ::= InfixDecl
-               | DataDecl
-               | TypeSig
-               | FunDef
-
-   InfixDecl ::= InfixWord 'litint' Operator
-   InfixWord ::= 'infix'
-               | 'infixl'
-               | 'infixr'
-
-   DataDecl  ::= 'data' 'conname' {'name'} '=' Data
-   DataCons  ::= 'conname' {Type1} ['|' DataCons]
-
-   TypeSig   ::= Var '::' Type
-   FunDef    ::= Var {Pat1} '=' Expr
-
-   Type      ::= Type1 {Type1}
-               -- note that (->) is right-associative,
-               -- and extends as far as possible
-               | Type '->' Type
-   Type1     ::= '(' Type ')'
-               | 'conname'
-
-   Pat       ::= 'conname' Pat1 {Pat1}
-               | Pat 'consym' Pat
-
-   Pat1      ::= Literal
-               | 'conname'
-               | '(' Pat ')'
-
-   Literal   ::= 'litint'
-
-   Var ::= 'varname'
-         | '(' 'varsym' ')'
-   Con ::= 'conname'
-         | '(' 'consym' ')'
-

rlp.cabal

@@ -12,7 +12,6 @@ category:           Language
 build-type:         Simple
 extra-doc-files:    README.md
 -- extra-source-files:
-tested-with:        GHC==9.6.2
 
 common warnings
 --    ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-unused-top-binds
@@ -31,46 +30,37 @@ library
                     , Core.TH
                     , Core.HindleyMilner
                     , Control.Monad.Errorful
-                    , Rlp.Syntax
-                    -- , Rlp.Parse.Decls
-                    , Rlp.Parse
-                    , Rlp.Parse.Associate
-                    , Rlp.Lex
-                    , Rlp.Parse.Types
-                    , Rlp.TH
 
     other-modules:    Data.Heap
                     , Data.Pretty
                     , Core.Parse
                     , Core.Lex
                     , Core2Core
-                    , Rlp2Core
                     , Control.Monad.Utils
+                    , RLP.Syntax
 
     build-tool-depends: happy:happy, alex:alex
 
     -- other-extensions:
     build-depends:    base ^>=4.18.0.0
+                    , containers
+                    , microlens
+                    , microlens-mtl
+                    , microlens-th
+                    , microlens-platform
+                    , mtl
+                    , template-haskell
                     -- required for happy
-                    , array >= 0.5.5 && < 0.6
+                    , array
-                    , containers >= 0.6.7 && < 0.7
+                    , data-default-class
-                    , template-haskell >= 2.20.0 && < 2.21
+                    , unordered-containers
-                    , pretty >= 1.1.3 && < 1.2
+                    , hashable
-                    , data-default >= 0.7.1 && < 0.8
+                    , pretty
-                    , data-default-class >= 0.1.2 && < 0.2
+                    -- TODO: either learn recursion-schemes, or stop depending
-                    , hashable >= 1.4.3 && < 1.5
+                    -- on it.
-                    , mtl >= 2.3.1 && < 2.4
+                    , recursion-schemes
-                    , text >= 2.0.2 && < 2.1
+                    , megaparsec
-                    , megaparsec >= 9.6.1 && < 9.7
+                    , text
-                    , 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
 
     hs-source-dirs:   src
     default-language: GHC2021
@@ -82,12 +72,12 @@ executable rlpc
     -- other-extensions:
     build-depends: base ^>=4.18.0.0
                  , rlp
-                 , optparse-applicative >= 0.18.1 && < 0.19
+                 , optparse-applicative
-                 , microlens >= 0.4.13 && < 0.5
+                 , microlens
-                 , microlens-mtl >= 0.2.0 && < 0.3
+                 , microlens-mtl
-                 , mtl >= 2.3.1 && < 2.4
+                 , mtl
-                 , unordered-containers >= 0.2.20 && < 0.3
+                 , unordered-containers
-                 , text >= 2.0.2 && < 2.1
+                 , text
 
     hs-source-dirs:   app
     default-language: GHC2021
@@ -100,12 +90,20 @@ test-suite rlp-test
     hs-source-dirs: tst
     main-is: Main.hs
     build-depends: base ^>=4.18.0.0
+                 , unordered-containers
                  , rlp
                  , QuickCheck
                  , hspec            ==2.*
                  , microlens
+                 , text
+                 , pretty
+                 , microlens-platform
+
     other-modules: Arith
                  , GMSpec
+                 , CoreSyntax
                  , Core.HindleyMilnerSpec
+                 , Core.ParseSpec
+
     build-tool-depends: hspec-discover:hspec-discover
 

src/Compiler/JustRun.hs

@@ -11,6 +11,8 @@ module Compiler.JustRun
     ( justLexSrc
     , justParseSrc
     , justTypeCheckSrc
+    , RlpcError
+    , Program'
     )
     where
 ----------------------------------------------------------------------------------

src/Compiler/RlpcError.hs

@@ -8,7 +8,7 @@ import Control.Monad.Errorful
 ----------------------------------------------------------------------------------
 
 data RlpcError = RlpcErr String -- temp
-    deriving Show
+    deriving (Show, Eq)
 
 class IsRlpcError a where
     liftRlpcErr :: a -> RlpcError

src/Core/Lex.x

@@ -103,6 +103,8 @@ rlp :-
     \n                      { skip }
 }
 
+-- TODO: negative literals
+
 <pragma>
 {
     "#-}"                   { constTok TokenRPragma `andBegin` 0 }

src/Core/Parse.y

@@ -77,6 +77,7 @@ Eof             : eof           { () }
 
 StandaloneProgram :: { Program Name }
 StandaloneProgram : Program eof                 { $1 }
+                  | eof                         { mempty }
 
 Program         :: { Program Name }
 Program         : ScTypeSig ';' Program         { insTypeSig $1 $3 }
@@ -147,6 +148,7 @@ Alters          : Alter ';' Alters              { $1 : $3 }
                 | Alter ';'                     { [$1] }
                 | Alter                         { [$1] }
 
+-- TODO: tags should be wrapped in <n> to allow matching against literals
 Alter           :: { Alter Name }
 Alter           : litint ParList '->' Expr      { Alter (AltData $1) $2 $4 }
 

src/Core/Syntax.hs

@@ -58,9 +58,9 @@ data Expr b = Var Name
             | Let Rec [Binding b] (Expr b)
             | App (Expr b) (Expr b)
             | Lit Lit
-            deriving (Show, Read, Lift)
+            deriving (Show, Eq, Read, Lift)
 
-deriving instance (Eq b) => Eq (Expr b)
+-- deriving instance (Eq b) => Eq (Expr b)
 
 data Type = TyFun
           | TyVar Name
@@ -86,18 +86,14 @@ pattern a :-> b = TyApp (TyApp TyFun a) b
 {-# COMPLETE Binding :: Binding #-}
 {-# COMPLETE (:=) :: Binding #-}
 data Binding b = Binding b (Expr b)
-    deriving (Show, Read, Lift)
+    deriving (Show, Read, Eq, Lift)
-
-deriving instance (Eq b) => Eq (Binding b)
 
 infixl 1 :=
 pattern (:=) :: b -> (Expr b) -> (Binding b)
 pattern k := v = Binding k v
 
 data Alter b = Alter AltCon [b] (Expr b)
-    deriving (Show, Read, Lift)
+    deriving (Show, Read, Eq, Lift)
-
-deriving instance (Eq b) => Eq (Alter b)
 
 data Rec = Rec
          | NonRec
@@ -115,7 +111,7 @@ type Name = T.Text
 type Tag = Int
 
 data ScDef b = ScDef b [b] (Expr b)
-    deriving (Show, Lift)
+    deriving (Show, Eq, Lift)
 
 unliftScDef :: ScDef b -> Expr b
 unliftScDef (ScDef _ as e) = Lam as e
@@ -127,7 +123,7 @@ data Program b = Program
     { _programScDefs   :: [ScDef b]
     , _programTypeSigs :: H.HashMap b Type
     }
-    deriving (Show, Lift)
+    deriving (Show, Eq, Lift)
 
 makeLenses ''Program
 pure []

src/RLP/Syntax.hs

@@ -0,0 +1,59 @@
+{-# LANGUAGE OverloadedStrings #-}
+module RLP.Syntax
+    ( RlpExpr
+    )
+    where
+----------------------------------------------------------------------------------
+import Data.Text                    (Text)
+import Lens.Micro
+import Core                         (HasRHS(..), HasLHS(..))
+----------------------------------------------------------------------------------
+
+newtype RlpProgram b = RlpProgram [Decl b]
+
+data Decl b = InfixD  InfixAssoc Int VarId
+            | FunD    VarId [Pat b] (RlpExpr b)
+            | DataD   ConId [ConId] [ConAlt]
+
+data ConAlt = ConAlt ConId [ConId]
+
+data InfixAssoc = Assoc | AssocL | AssocR
+
+data RlpExpr b = LetE  [Bind b] (RlpExpr b)
+               | VarE  VarId
+               | ConE  ConId
+               | LamE  [Pat b] (RlpExpr b)
+               | CaseE (RlpExpr b) [Alt b]
+               | IfE   (RlpExpr b) (RlpExpr b) (RlpExpr b)
+               | AppE  (RlpExpr b) (RlpExpr b)
+               | LitE  (Lit b)
+
+-- do we want guards?
+data Alt b = AltA (Pat b) (RlpExpr b)
+
+data Bind b = PatB (Pat b) (RlpExpr b)
+            | FunB VarId [Pat b] (RlpExpr b)
+
+data VarId = NameVar Text
+           | SymVar Text
+
+data ConId = NameCon Text
+           | SymCon Text
+
+data Pat b = VarP VarId
+           | LitP (Lit b)
+           | ConP ConId [Pat b]
+
+data Lit b = IntL Int
+           | CharL Char
+           | ListL [RlpExpr b]
+
+-- 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')

src/Rlp/Lex.x

@@ -1,347 +0,0 @@
-{
-{-# LANGUAGE ViewPatterns, LambdaCase #-}
-{-# LANGUAGE GeneralisedNewtypeDeriving #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Rlp.Lex
-    ( P(..)
-    , RlpToken(..)
-    , Located(..)
-    , lexToken
-    , lexDebug
-    , lexCont
-    , execP
-    , execP'
-    )
-    where
-import Codec.Binary.UTF8.String (encodeChar)
-import Control.Monad
-import Core.Syntax              (Name)
-import Data.Functor.Identity
-import Data.Char                (digitToInt)
-import Data.Monoid              (First)
-import Data.Maybe
-import Data.Text                (Text)
-import Data.Text                qualified as T
-import Data.Word
-import Data.Default
-import Lens.Micro.Mtl
-import Lens.Micro
-
-import Debug.Trace
-import Rlp.Parse.Types
-}
-
-$whitechar      = [ \t\n\r\f\v]
-
-$nl             = [\n\r]
-$white_no_nl    = $white # $nl
-
-$lower          = [a-z \_]
-$upper          = [A-Z]
-$alpha          = [$lower $upper]
-$digit          = 0-9
-
-$special        = [\(\)\,\;\[\]\{\}]
-$namechar       = [$alpha $digit \' \#]
-$asciisym       = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]
-
-@decimal        = $digit+
-
-@varname        = $lower $namechar*
-@conname        = $upper $namechar*
-@consym         = \: $asciisym*
-@varsym         = $asciisym+
-
-@reservedname = 
-    case|data|do|import|in|let|letrec|module|of|where
-
-@reservedop =
-    "=" | \\ | "->" | "|" | "::"
-
-rlp :-
-    
--- everywhere: skip whitespace
-$white_no_nl+       ;
-
--- everywhere: skip comments
--- TODO: don't treat operators like (-->) as comments
-"--".*              ;
-
--- we are indentation-sensitive! do not skip NLs!. upon encountering a newline,
--- we check indentation and potentially insert extra tokens. search this file
--- for the definition of `doBol`
-<0> \n                  { beginPush bol }
-
--- scan various identifiers and reserved words. order is important here!
-<0>
-{
-    @reservedname       { tokenWith lexReservedName }
-    @conname            { tokenWith TokenConName }
-    @varname            { tokenWith TokenVarName }
-    @reservedop         { tokenWith lexReservedOp }
-    @consym             { tokenWith TokenConSym }
-    @varsym             { tokenWith TokenVarSym }
-}
-
--- literals -- currently this is just unsigned integer literals
-<0>
-{
-    @decimal            { tokenWith (TokenLitInt . readInt) }
-}
-
--- control characters
-<0>
-{
-    "("                 { constToken TokenLParen }
-    ")"                 { constToken TokenRParen }
-    "{"                 { explicitLBrace }
-    "}"                 { explicitRBrace }
-    ";"                 { constToken TokenSemicolon }
-}
-
--- consume all whitespace leaving us at the beginning of the next non-empty
--- line. we then compare the indentation of that line to the enclosing layout
--- context and proceed accordingly
-<bol>
-{
-    $whitechar          ;
-    \n                  ;
-    ()                  { doBol }
-}
-
-<layout_top>
-{
-    \n                  ;
-    "{"                 { explicitLBrace `thenDo` popLexState }
-    ()                  { doLayout }
-}
-
-{
-
-lexReservedName :: Text -> RlpToken
-lexReservedName = \case
-    "data"      -> TokenData
-    "case"      -> TokenCase
-    "of"        -> TokenOf
-    "let"       -> TokenLet
-    "in"        -> TokenIn
-
-lexReservedOp :: Text -> RlpToken
-lexReservedOp = \case
-    "="     -> TokenEquals
-    "::"    -> TokenHasType
-    "|"     -> TokenPipe
-
--- | @andBegin@, with the subtle difference that the start code is set
---   /after/ the action
-thenBegin :: LexerAction a -> Int -> LexerAction a
-thenBegin act c inp l = do
-    a <- act inp l
-    psLexState . _head .= c
-    pure a
-
-andBegin :: LexerAction a -> Int -> LexerAction a
-andBegin act c inp l = do
-    psLexState . _head .= c
-    act inp l
-
-beginPush :: Int -> LexerAction (Located RlpToken)
-beginPush n _ _ = pushLexState n >> lexToken
-
-alexGetByte :: AlexInput -> Maybe (Word8, AlexInput)
-alexGetByte inp = case inp ^. aiBytes of
-    [] -> do
-        (c,t) <- T.uncons (inp ^. aiSource)
-        let (b:bs) = encodeChar c
-                       -- tail the source
-            inp' = inp & aiSource .~ t
-                       -- record the excess bytes for successive calls
-                       & aiBytes .~ bs
-                       -- report the previous char
-                       & aiPrevChar .~ c
-                       -- update the position
-                       & aiPos %~ \ (ln,col) ->
-                                   if c == '\n'
-                                   then (ln+1,1)
-                                   else (ln,col+1)
-        pure (b, inp')
-    
-    _ -> Just (head bs, inp')
-        where
-            (bs, inp') = inp & aiBytes <<%~ drop 1
-
-getInput :: P AlexInput
-getInput = use psInput
-
-getLexState :: P Int
-getLexState = use (psLexState . singular _head)
-
-alexInputPrevChar :: AlexInput -> Char
-alexInputPrevChar = view aiPrevChar
-
-pushLexState :: Int -> P ()
-pushLexState n = psLexState %= (n:)
-
-readInt :: Text -> Int
-readInt = T.foldr f 0 where
-    f c n = digitToInt c + 10*n
-
-constToken :: RlpToken -> LexerAction (Located RlpToken)
-constToken t inp l = do
-    pos <- use (psInput . aiPos)
-    pure (Located (pos,l) t)
-
-tokenWith :: (Text -> RlpToken) -> LexerAction (Located RlpToken)
-tokenWith tf inp l = do
-    pos <- getPos
-    let t = tf (T.take l $ inp ^. aiSource)
-    pure (Located (pos,l) t)
-
-getPos :: P Position
-getPos = use (psInput . aiPos)
-
-alexEOF :: P (Located RlpToken)
-alexEOF = do
-    inp <- getInput
-    pure (Located undefined TokenEOF)
-
-execP :: P a -> ParseState -> Maybe a
-execP p st = runP p st & snd
-
-execP' :: P a -> Text -> Maybe a
-execP' p s = execP p st where
-    st = initParseState s
-
-initParseState :: Text -> ParseState
-initParseState s = ParseState
-    { _psLayoutStack = []
-    -- IMPORTANT: the initial state is `bol` to begin the top-level layout,
-    -- which then returns to state 0 which continues the normal lexing process.
-    , _psLexState = [layout_top,0]
-    , _psInput = initAlexInput s
-    , _psOpTable = mempty
-    }
-
-initAlexInput :: Text -> AlexInput
-initAlexInput s = AlexInput
-    { _aiPrevChar   = '\0'
-    , _aiSource     = s
-    , _aiBytes      = []
-    , _aiPos        = (1,1)
-    }
-
-lexToken :: P (Located RlpToken)
-lexToken = do
-    inp <- getInput
-    c <- getLexState
-    st <- use id
-    -- traceM $ "st: " <> show st
-    case alexScan inp c of
-        AlexEOF -> pure $ Located (inp ^. aiPos, 0) TokenEOF
-        AlexSkip inp' l -> do
-            psInput .= inp'
-            lexToken
-        AlexToken inp' l act -> do
-            psInput .= inp'
-            act inp l
-
-lexCont :: (Located RlpToken -> P a) -> P a
-lexCont = (lexToken >>=)
-
-lexStream :: P [RlpToken]
-lexStream = do
-    t <- lexToken
-    case t of
-        Located _ TokenEOF -> pure [TokenEOF]
-        Located _ t        -> (t:) <$> lexStream
-
-lexDebug :: (Located RlpToken -> P a) -> P a
-lexDebug k = do
-    t <- lexToken
-    traceM $ "token: " <> show t
-    k t
-
-lexTest :: Text -> Maybe [RlpToken]
-lexTest s = execP' lexStream s
-
-indentLevel :: P Int
-indentLevel = do
-    pos <- use (psInput . aiPos)
-    pure (pos ^. _2)
-
-insertToken :: RlpToken -> P (Located RlpToken)
-insertToken t = do
-    pos <- use (psInput . aiPos)
-    pure (Located (pos, 0) t)
-
-popLayout :: P Layout
-popLayout = do
-    -- traceM "pop layout"
-    ctx <- preuse (psLayoutStack . _head)
-    psLayoutStack %= (drop 1)
-    case ctx of
-        Just l      -> pure l
-        Nothing     -> error "uhh"
-
-pushLayout :: Layout -> P ()
-pushLayout l = do
-    -- traceM "push layout"
-    psLayoutStack %= (l:)
-
-popLexState :: P ()
-popLexState = do
-    psLexState %= tail
-
-insertSemicolon, insertLBrace, insertRBrace :: P (Located RlpToken)
-insertSemicolon = {- traceM "inserting semi"   >> -} insertToken TokenSemicolonV
-insertLBrace    = {- traceM "inserting lbrace" >> -} insertToken TokenLBraceV
-insertRBrace    = {- traceM "inserting rbrace" >> -} insertToken TokenRBraceV
-
-cmpLayout :: P Ordering
-cmpLayout = do
-    i <- indentLevel
-    ctx <- preuse (psLayoutStack . _head)
-    case ctx of
-        Just (Implicit n) -> pure (i `compare` n)
-        _                 -> pure GT
-
-doBol :: LexerAction (Located RlpToken)
-doBol inp l = do
-    off <- cmpLayout
-    i <- indentLevel
-    traceM $ "i: " <> show i
-    -- important that we pop the lex state lest we find our lexer diverging
-    popLexState
-    case off of
-        -- the line is aligned with the previous. it therefore belongs to the
-        -- same list
-        EQ -> insertSemicolon
-        -- the line is indented further than the previous, so we assume it is a
-        -- line continuation. ignore it and move on!
-        GT -> lexToken
-        -- the line is indented less than the previous, pop the layout stack and
-        -- insert a closing brace.
-        LT -> popLayout >> insertRBrace
-
-thenDo :: LexerAction a -> P b -> LexerAction a
-thenDo act p inp l = act inp l <* p
-
-explicitLBrace :: LexerAction (Located RlpToken)
-explicitLBrace inp l = do
-    pushLayout Explicit
-    constToken TokenLBrace inp l
-
-explicitRBrace :: LexerAction (Located RlpToken)
-explicitRBrace inp l = do
-    popLayout
-    constToken TokenRBrace inp l
-
-doLayout :: LexerAction (Located RlpToken)
-doLayout _ _ = do
-    i <- indentLevel
-    pushLayout (Implicit i)
-    popLexState
-    insertLBrace
-
-}
-

src/Rlp/Parse.y

@@ -1,184 +0,0 @@
-{
-{-# LANGUAGE LambdaCase #-}
-module Rlp.Parse
-    ( parseRlpProg
-    , execP
-    , execP'
-    )
-    where
-import Rlp.Lex
-import Rlp.Syntax
-import Rlp.Parse.Types
-import Rlp.Parse.Associate
-import Lens.Micro
-import Lens.Micro.Mtl
-import Lens.Micro.Platform          ()
-import Data.List.Extra
-import Data.Fix
-import Data.Functor.Const
-}
-
-%name parseRlpProg StandaloneProgram
-
-%monad { P }
-%lexer { lexCont } { Located _ TokenEOF }
-%error { parseError }
-%tokentype { Located RlpToken }
-
-%token
-    varname         { Located _ (TokenVarName $$) }
-    conname         { Located _ (TokenConName $$) }
-    consym          { Located _ (TokenConSym $$) }
-    varsym          { Located _ (TokenVarSym $$) }
-    data            { Located _ TokenData }
-    litint          { Located _ (TokenLitInt $$) }
-    '::'            { Located _ TokenHasType }
-    '='             { Located _ TokenEquals }
-    '|'             { Located _ TokenPipe }
-    ';'             { Located _ TokenSemicolon }
-    '('             { Located _ TokenLParen }
-    ')'             { Located _ TokenRParen }
-    '->'            { Located _ TokenArrow }
-    vsemi           { Located _ TokenSemicolonV }
-    '{'             { Located _ TokenLBrace }
-    '}'             { Located _ TokenRBrace }
-    vlbrace         { Located _ TokenLBraceV }
-    vrbrace         { Located _ TokenRBraceV }
-    infixl          { Located _ TokenInfixL }
-    infixr          { Located _ TokenInfixR }
-    infix           { Located _ TokenInfix }
-
-%right '->'
-
-%%
-
-StandaloneProgram   :: { RlpProgram' }
-StandaloneProgram   : '{' Decls  '}'        {% mkProgram $2 }
-                    | VL  DeclsV VR         {% mkProgram $2 }
-
-VL  :: { () }
-VL  : vlbrace       { () }
-
-VR  :: { () }
-VR  : vrbrace       { () }
-    | error         { () }
-
-Decls               :: { [PartialDecl'] }
-Decls               : Decl ';' Decls        { $1 : $3 }
-                    | Decl ';'              { [$1] }
-                    | Decl                  { [$1] }
-
-DeclsV              :: { [PartialDecl'] }
-DeclsV              : Decl VS Decls         { $1 : $3 }
-                    | Decl VS               { [$1] }
-                    | Decl                  { [$1] }
-
-VS                  :: { Located RlpToken }
-VS                  : ';'                   { $1 }
-                    | vsemi                 { $1 }
-
-Decl        :: { PartialDecl' }
-            : FunDecl                   { $1 }
-            | TySigDecl                 { $1 }
-            | DataDecl                  { $1 }
-            | InfixDecl                 { $1 }
-
--- TODO: multiple vars
-
-TySigDecl   :: { PartialDecl' }
-            : Var '::' Type             { TySigD [$1] $3 }
-
-InfixDecl   :: { PartialDecl' }
-            : InfixWord litint InfixOp  {% mkInfixD $1 $2 $3 }
-
-InfixWord   :: { Assoc }
-            : infixl                    { InfixL }
-            | infixr                    { InfixR }
-            | infix                     { Infix  }
-
-DataDecl    :: { PartialDecl' }
-            : data Con TyParams '=' DataCons    { DataD $2 $3 $5 }
-
-TyParams    :: { [Name] }
-            : {- epsilon -}             { [] }
-            | TyParams varname          { $1 `snoc` $2 }
-
-DataCons    :: { [ConAlt] }
-            : DataCons '|' DataCon      { $1 `snoc` $3 }
-            | DataCon                   { [$1] }
-
-DataCon     :: { ConAlt }
-            : Con Type1s                { ConAlt $1 $2 }
-
-Type1s      :: { [Type] }
-            : {- epsilon -}             { [] }
-            | Type1s Type1              { $1 `snoc` $2 }
-
-Type1       :: { Type }
-            : '(' Type ')'              { $2 }
-            | conname                   { TyCon $1 }
-            | varname                   { TyVar $1 }
-
-Type        :: { Type }
-            : Type '->' Type            { $1 :-> $3 }
-            | Type1                     { $1 }
-
-FunDecl     :: { PartialDecl' }
-FunDecl     : Var Params '=' Expr       { FunD $1 $2 (Const $4) Nothing }
-
-Params      :: { [Pat'] }
-Params      : {- epsilon -}             { [] }
-            | Params Pat1               { $1 `snoc` $2 }
-
-Pat1        :: { Pat' }
-            : Var                       { VarP $1 }
-            | Lit                       { LitP $1 }
-
-Expr        :: { PartialExpr' }
-            : Expr1 varsym Expr         { Fix $ B $2 (unFix $1) (unFix $3) }
-            | Expr1                     { $1 }
-
-Expr1       :: { PartialExpr' }
-            : '(' Expr ')'              { wrapFix . Par . unwrapFix $ $2 }
-            | Lit                       { Fix . E $ LitEF $1 }
-            | Var                       { Fix . E $ VarEF $1 }
-
--- TODO: happy prefers left-associativity. doing such would require adjusting
--- the code in Rlp.Parse.Associate to expect left-associative input rather than
--- right.
-InfixExpr   :: { PartialExpr' }
-            : Expr1 varsym Expr         { Fix $ B $2 (unFix $1) (unFix $3) }
-
-InfixOp     :: { Name }
-            : consym                    { $1 }
-            | varsym                    { $1 }
-
-Lit         :: { Lit' }
-Lit         : litint                    { IntL $1 }
-
-Var         :: { VarId }
-Var         : varname                   { NameVar $1 }
-
-Con         :: { ConId }
-            : conname                   { NameCon $1 }
-
-{
-
-mkProgram :: [PartialDecl'] -> P RlpProgram'
-mkProgram ds = do
-    pt <- use psOpTable
-    pure $ RlpProgram (associate pt <$> ds)
-
-parseError :: Located RlpToken -> P a
-parseError = error . show
-
-mkInfixD :: Assoc -> Int -> Name -> P PartialDecl'
-mkInfixD a p n = do
-    let opl :: Lens' ParseState (Maybe OpInfo)
-        opl = psOpTable . at n
-    opl <~ (use opl >>= \case
-        Just o  -> error "(TODO: non-fatal) duplicate inix decls"
-        Nothing -> pure (Just (a,p))
-        )
-    pure $ InfixD a p n
-}

src/Rlp/Parse/Associate.hs

@@ -1,100 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms, ViewPatterns, ImplicitParams #-}
-module Rlp.Parse.Associate
-    ( associate
-    )
-    where
---------------------------------------------------------------------------------
-import Data.HashMap.Strict              qualified as H
-import Data.Functor.Foldable
-import Data.Functor.Const
-import Lens.Micro
-import Rlp.Parse.Types
-import Rlp.Syntax
---------------------------------------------------------------------------------
-
-associate :: OpTable -> PartialDecl' -> Decl' RlpExpr
-associate pt (FunD n as b w)    = FunD n as b' w
-    where b' = let ?pt = pt in completeExpr (getConst b)
-associate pt (TySigD ns t)      = TySigD ns t
-associate pt (DataD n as cs)    = DataD n as cs
-associate pt (InfixD a p n)     = InfixD a p n
-
-completeExpr :: (?pt :: OpTable) => PartialExpr' -> RlpExpr'
-completeExpr = cata completePartial
-
-completePartial :: (?pt :: OpTable) => PartialE -> RlpExpr'
-completePartial (E e)        = completeRlpExpr e
-completePartial p@(B o l r)  = completeB (build p)
-completePartial (Par e)      = completePartial e
-
-completeRlpExpr :: (?pt :: OpTable) => RlpExprF' RlpExpr' -> RlpExpr'
-completeRlpExpr = embed
-
-completeB :: (?pt :: OpTable) => PartialE -> RlpExpr'
-completeB p = case build p of
-    B o l r     -> (o' `AppE` l') `AppE` r'
-        where
-            -- TODO: how do we know it's symbolic?
-            o' = VarE (SymVar o)
-            l' = completeB l
-            r' = completeB r
-    Par e       -> completeB e
-    E e         -> completeRlpExpr e
-
-build :: (?pt :: OpTable) => PartialE -> PartialE
-build e = go id e (rightmost e) where
-    rightmost :: PartialE -> PartialE
-    rightmost (B _ _ r) = rightmost r
-    rightmost p@(E _)   = p
-    rightmost p@(Par _) = p
-
-    go :: (?pt :: OpTable)
-       => (PartialE -> PartialE)
-       -> PartialE -> PartialE -> PartialE
-    go f p@(WithInfo o _ r) = case r of
-            E _     -> mkHole o (f . f')
-            Par _   -> mkHole o (f . f')
-            B _ _ _ -> go (mkHole o (f . f')) r
-        where f' r' = p & pR .~ r'
-    go f _ = id
-
-mkHole :: (?pt :: OpTable)
-       => OpInfo
-       -> (PartialE -> PartialE)
-       -> PartialE
-       -> PartialE
-mkHole _     hole p@(Par _)                 = hole p
-mkHole _     hole p@(E _)                   = hole p
-mkHole (a,d) hole p@(WithInfo (a',d') _ _)
-    | d' < d  = above
-    | d' > d  = below
-    | d == d' = case (a,a') of
-                  -- left-associative operators of equal precedence are
-                  -- associated left
-                  (InfixL,InfixL) -> above
-                  -- right-associative operators are handled similarly
-                  (InfixR,InfixR) -> below
-                  -- non-associative operators of equal precedence, or equal
-                  -- precedence operators of different associativities are
-                  -- invalid
-                  (_,     _)      -> error "invalid expression"
-    where
-        above = p & pL %~ hole
-        below = hole p
-
-examplePrecTable :: OpTable
-examplePrecTable = H.fromList
-    [ ("+",    (InfixL,6))
-    , ("*",    (InfixL,7))
-    , ("^",    (InfixR,8))
-    , (".",    (InfixR,7))
-    , ("~",    (Infix, 9))
-    , ("=",    (Infix, 4))
-    , ("&&",   (Infix, 3))
-    , ("||",   (Infix, 2))
-    , ("$",    (InfixR,0))
-    , ("&",    (InfixL,0))
-    ]
-
-

src/Rlp/Parse/Types.hs

@@ -1,163 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
-{-# LANGUAGE LambdaCase #-}
-module Rlp.Parse.Types where
---------------------------------------------------------------------------------
-import Core.Syntax                  (Name)
-import Control.Monad
-import Control.Monad.State.Class
-import Data.Text                    (Text)
-import Data.Maybe
-import Data.Fix
-import Data.Functor.Foldable
-import Data.Functor.Const
-import Data.Functor.Classes
-import Data.HashMap.Strict          qualified as H
-import Data.Word                    (Word8)
-import Lens.Micro.TH
-import Lens.Micro
-import Rlp.Syntax
---------------------------------------------------------------------------------
-
-type LexerAction a = AlexInput -> Int -> P a
-
-data AlexInput = AlexInput
-    { _aiPrevChar   :: Char
-    , _aiSource     :: Text
-    , _aiBytes      :: [Word8]
-    , _aiPos        :: Position
-    }
-    deriving Show
-
-type Position =
-    ( Int -- line
-    , Int -- column
-    )
-
-data RlpToken
-    -- literals
-    = TokenLitInt Int
-    -- identifiers
-    | TokenVarName Name
-    | TokenConName Name
-    | TokenVarSym Name
-    | TokenConSym Name
-    -- reserved words
-    | TokenData
-    | TokenCase
-    | TokenOf
-    | TokenLet
-    | TokenIn
-    | TokenInfixL
-    | TokenInfixR
-    | TokenInfix
-    -- reserved ops
-    | TokenArrow
-    | TokenPipe
-    | TokenHasType
-    | TokenLambda
-    | TokenEquals
-    -- control symbols
-    | TokenSemicolon
-    | TokenLBrace
-    | TokenRBrace
-    | TokenLParen
-    | TokenRParen
-    -- 'virtual' control symbols, inserted by the lexer without any correlation
-    -- to a specific symbol
-    | TokenSemicolonV
-    | TokenLBraceV
-    | TokenRBraceV
-    | TokenEOF
-    deriving (Show)
-
-newtype P a = P { runP :: ParseState -> (ParseState, Maybe a) }
-    deriving (Functor)
-
-instance Applicative P where
-    pure a = P $ \st -> (st,Just a)
-    liftA2 = liftM2
-
-instance Monad P where
-    p >>= k = P $ \st ->
-        let (st',a) = runP p st
-        in case a of
-            Just x  -> runP (k x) st'
-            Nothing -> (st', Nothing)
-
-instance MonadState ParseState P where
-    state f = P $ \st ->
-        let (a,st') = f st
-        in (st', Just a)
-
-data ParseState = ParseState
-    { _psLayoutStack        :: [Layout]
-    , _psLexState           :: [Int]
-    , _psInput              :: AlexInput
-    , _psOpTable            :: OpTable
-    }
-    deriving Show
-
-data Layout = Explicit
-            | Implicit Int
-            deriving (Show, Eq)
-
-data Located a = Located (Position, Int) a
-    deriving (Show)
-
-type OpTable = H.HashMap Name OpInfo
-type OpInfo = (Assoc, Int)
-
--- data WithLocation a = WithLocation [String] a
-
-data RlpParseError = RlpParErrOutOfBoundsPrecedence Int
-                   | RlpParErrDuplicateInfixD
-    deriving (Eq, Ord, Show)
-
-----------------------------------------------------------------------------------
-
--- absolute psycho shit (partial ASTs)
-
-type PartialDecl' = Decl (Const PartialExpr') Name
-
-data Partial a = E (RlpExprF Name a)
-               | B Name (Partial a) (Partial a)
-               | Par (Partial a)
-               deriving (Show, Functor)
-
-pL :: Traversal' (Partial a) (Partial a)
-pL k (B o l r) = (\l' -> B o l' r) <$> k l
-pL _ x         = pure x
-
-pR :: Traversal' (Partial a) (Partial a)
-pR k (B o l r) = (\r' -> B o l r') <$> k r
-pR _ x         = pure x
-
-type PartialE = Partial RlpExpr'
-
--- i love you haskell
-pattern WithInfo :: (?pt :: OpTable) => OpInfo -> PartialE -> PartialE -> PartialE
-pattern WithInfo p l r <- B (opInfoOrDef -> p) l r
-
-opInfoOrDef :: (?pt :: OpTable) => Name -> OpInfo
-opInfoOrDef c = fromMaybe (InfixL,9) $ H.lookup c ?pt
-
--- required to satisfy constraint on Fix's show instance
-instance Show1 Partial where
-    liftShowsPrec :: forall a. (Int -> a -> ShowS)
-                  -> ([a] -> ShowS)
-                  -> Int -> Partial a -> ShowS
-
-    liftShowsPrec sp sl p m = case m of
-        (E e)       -> showsUnaryWith lshow "E" p e
-        (B f a b)   -> showsTernaryWith showsPrec lshow lshow "B" p f a b
-        (Par e)     -> showsUnaryWith lshow "Par" p e
-        where
-            lshow :: forall f. (Show1 f) => Int -> f a -> ShowS
-            lshow = liftShowsPrec sp sl
-
-type PartialExpr' = Fix Partial
-
-makeLenses ''AlexInput
-makeLenses ''ParseState
-

src/Rlp/Syntax.hs

@@ -1,178 +0,0 @@
--- recursion-schemes
-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
--- recursion-schemes
-{-# LANGUAGE TemplateHaskell, TypeFamilies #-}
-{-# LANGUAGE OverloadedStrings, PatternSynonyms #-}
-module Rlp.Syntax
-    ( RlpModule(..)
-    , RlpProgram(..)
-    , RlpProgram'
-    , rlpmodName
-    , rlpmodProgram
-    , RlpExpr(..)
-    , RlpExpr'
-    , RlpExprF(..)
-    , RlpExprF'
-    , Decl(..)
-    , Decl'
-    , Bind(..)
-    , Where
-    , Where'
-    , ConAlt(..)
-    , Type(..)
-    , pattern (:->)
-    , Assoc(..)
-    , VarId(..)
-    , ConId(..)
-    , Pat(..)
-    , Pat'
-    , Lit(..)
-    , Lit'
-    , Name
-
-    -- TODO: ugh move this somewhere else later
-    , showsTernaryWith
-
-    -- * Convenience re-exports
-    , Text
-    )
-    where
-----------------------------------------------------------------------------------
-import Data.Text                    (Text)
-import Data.Text                    qualified as T
-import Data.String                  (IsString(..))
-import Data.Functor.Foldable.TH     (makeBaseFunctor)
-import Data.Functor.Classes
-import Lens.Micro
-import Lens.Micro.TH
-import Language.Haskell.TH.Syntax   (Lift)
-import Core.Syntax                  hiding (Lit)
-import Core                         (HasRHS(..), HasLHS(..))
-----------------------------------------------------------------------------------
-
-data RlpModule b = RlpModule
-    { _rlpmodName       :: Text
-    , _rlpmodProgram    :: RlpProgram b
-    }
-
-newtype RlpProgram b = RlpProgram [Decl RlpExpr b]
-    deriving (Show, Lift)
-
-type RlpProgram' = RlpProgram Name
-
--- | The @e@ parameter is used for partial results. When parsing an input, we
--- first parse all top-level declarations in order to extract infix[lr]
--- declarations. This process yields a @[Decl (Const Text) Name]@, where @Const
--- Text@ stores the remaining unparsed function bodies. Once infixities are
--- accounted for, we may complete the parsing task and get a proper @[Decl
--- RlpExpr Name]@.
-
-data Decl e b = FunD    VarId [Pat b] (e b) (Maybe (Where b))
-              | TySigD  [VarId] Type
-              | DataD   ConId [Name] [ConAlt]
-              | InfixD  Assoc Int Name
-              deriving (Show, Lift)
-
-type Decl' e = Decl e Name
-
-data Assoc = InfixL
-           | InfixR
-           | Infix
-           deriving (Show, Lift)
-
-data ConAlt = ConAlt ConId [Type]
-            deriving (Show, Lift)
-
-data RlpExpr b = LetE  [Bind b] (RlpExpr b)
-               | VarE  VarId
-               | ConE  ConId
-               | LamE  [Pat b] (RlpExpr b)
-               | CaseE (RlpExpr b) [(Alt b, Where b)]
-               | IfE   (RlpExpr b) (RlpExpr b) (RlpExpr b)
-               | AppE  (RlpExpr b) (RlpExpr b)
-               | LitE  (Lit b)
-               deriving (Show, Lift)
-
-type RlpExpr' = RlpExpr Name
-
-type Where b = [Bind b]
-type Where' = [Bind Name]
-
--- do we want guards?
-data Alt b = AltA (Pat b) (RlpExpr b)
-           deriving (Show, Lift)
-
-data Bind b = PatB (Pat b) (RlpExpr b)
-            | FunB VarId [Pat b] (RlpExpr b)
-            deriving (Show, Lift)
-
-data VarId = NameVar Text
-           | SymVar Text
-           deriving (Show, Lift)
-
-instance IsString VarId where
-    -- TODO: use symvar if it's an operator
-    fromString = NameVar . T.pack
-
-data ConId = NameCon Text
-           | SymCon Text
-           deriving (Show, Lift)
-
-data Pat b = VarP VarId
-           | LitP (Lit b)
-           | ConP ConId [Pat b]
-           deriving (Show, Lift)
-
-type Pat' = Pat Name
-
-data Lit b = IntL Int
-           | CharL Char
-           | ListL [RlpExpr b]
-           deriving (Show, Lift)
-
-type Lit' = Lit Name
-
--- 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
-
-deriving instance (Show b, Show a) => Show (RlpExprF b a)
-
-type RlpExprF' = RlpExprF Name
-
--- society if derivable Show1
-instance (Show b) => Show1 (RlpExprF b) where
-    liftShowsPrec sp _ p m = case m of
-        (LetEF bs e)            -> showsBinaryWith showsPrec sp "LetEF" p bs e
-        (VarEF n)               -> showsUnaryWith showsPrec "VarEF" p n
-        (ConEF n)               -> showsUnaryWith showsPrec "ConEF" p n
-        (LamEF bs e)            -> showsBinaryWith showsPrec sp "LamEF" p bs e
-        (CaseEF e as)           -> showsBinaryWith sp showsPrec "CaseEF" p e as
-        (IfEF a b c)            -> showsTernaryWith sp sp sp "IfEF" p a b c
-        (AppEF f x)             -> showsBinaryWith sp sp "AppEF" p f x
-        (LitEF l)               -> showsUnaryWith showsPrec "LitEF" p l
-
-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
-

src/Rlp/TH.hs

@@ -1,30 +0,0 @@
-module Rlp.TH
-    ( rlpProg
-    )
-    where
---------------------------------------------------------------------------------
-import Language.Haskell.TH
-import Language.Haskell.TH.Syntax   hiding (Module)
-import Language.Haskell.TH.Quote
-import Control.Monad                ((>=>))
-import Compiler.RLPC
-import Data.Default.Class           (def)
-import Data.Text                    qualified as T
-import Rlp.Parse
---------------------------------------------------------------------------------
-
-rlpProg :: QuasiQuoter
-rlpProg = QuasiQuoter
-    { quoteExp = qRlpProg
-    , quotePat = error "rlp quasiquotes may only be used in expressions"
-    , quoteType = error "rlp quasiquotes may only be used in expressions"
-    , quoteDec = error "rlp quasiquotes may only be used in expressions"
-    }
-
-qRlpProg :: String -> Q Exp
-qRlpProg s = case parse (T.pack s) of
-    Nothing      -> error "error lol iddfk"
-    Just a       -> lift a
-    where
-        parse = execP' parseRlpProg
-

src/Rlp2Core.hs

@@ -1,44 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-module Rlp2Core
-    ( rlp2core
-    )
-    where
---------------------------------------------------------------------------------
-import Core.Syntax                  as Core
-import Rlp.Syntax                   as Rlp
-import Data.Foldable
-import Data.HashMap.Strict          qualified as H
-import Control.Monad.State
-import Lens.Micro.Platform
---------------------------------------------------------------------------------
-
-rlp2core :: RlpProgram' -> Program'
-rlp2core (RlpProgram ds) = execState (decl2core `traverse_` ds) init
-    where
-        init = Program
-            { _programScDefs    = mempty
-            , _programTypeSigs  = mempty
-            }
-
-type GenCoreProg b = State (Program b)
-
-type GenCoreProg' = GenCoreProg Name
-
-emitTypeSig :: Name -> Type -> GenCoreProg' ()
-emitTypeSig b t = do
-    let tl :: Lens' Program' (Maybe Type)
-        tl = programTypeSigs . at b
-    tl <~ (use tl >>= \case
-        -- TODO: non-fatal error
-        Just o  -> error "(TODO: non-fatal) duplicate type sigs"
-        Nothing -> pure (Just t)
-        )
-
-decl2core :: Decl' RlpExpr -> GenCoreProg' ()
-
-decl2core (DataD n as cs) = undefined
-
-decl2core (TySigD vs t) = mkSig `traverse_` vs where
-    mkSig :: VarId -> GenCoreProg' ()
-    mkSig (NameVar n) = emitTypeSig n t
-

tst/Core/ParseSpec.hs

@@ -0,0 +1,40 @@
+module Core.ParseSpec
+    ( spec
+    )
+    where
+----------------------------------------------------------------------------------
+import CoreSyntax
+import Core.Syntax
+import Compiler.JustRun
+import Compiler.RlpcError
+import Control.Monad                ((<=<))
+import Data.Coerce
+import Data.Text                    qualified as T
+import Data.Functor.Classes         (Eq1(..))
+import Test.Hspec
+import Test.QuickCheck
+----------------------------------------------------------------------------------
+
+spec :: Spec
+spec = do
+    it "should be a right-inverse to the unparser \
+        \up to source code congruency" $
+        withMaxSuccess 20 $ property $
+            \p -> (unparse <=< parse) p ~== Right p
+
+    -- TODO: abitrary ASTs
+    -- it "should be a right-inverse to the unparser\
+    --     \up to source code congruency" $
+    --     property $ \p -> (parse <=< unparse) p == Right p
+
+(~==) :: (Eq1 f) => f ProgramSrc -> f ProgramSrc -> Bool
+(~==) = liftEq congruentSrc
+
+infix 4 ~==
+
+parse :: ProgramSrc -> Either RlpcError Program'
+parse (ProgramSrc s) = justParseSrc (T.unpack s)
+
+unparse :: Program' -> Either RlpcError ProgramSrc
+unparse = Right . unparseCoreProg
+

tst/CoreSyntax.hs

@@ -0,0 +1,303 @@
+{-# LANGUAGE OverloadedStrings, LambdaCase, GeneralisedNewtypeDeriving #-}
+module CoreSyntax
+    ( ProgramSrc(..)
+    , congruentSrc
+    , unparseCoreProg
+    )
+    where
+----------------------------------------------------------------------------------
+import Core.Syntax
+import Compiler.JustRun             (justParseSrc)
+import Control.Arrow                ((>>>), (&&&))
+import Control.Monad
+import Data.List                    (intersperse)
+import Data.Coerce                  (coerce)
+import Data.Text                    (Text)
+import Data.Text                    qualified as T
+import Data.HashMap.Strict          qualified as H
+import Test.QuickCheck
+import Text.PrettyPrint             hiding ((<>))
+import Data.Functor                 ((<&>))
+import Data.Function                ((&), on)
+import Data.String                  (IsString(..))
+import Lens.Micro.Platform
+import Lens.Micro.Platform.Internal (IsText(..))
+----------------------------------------------------------------------------------
+
+newtype ProgramSrc = ProgramSrc Text
+    deriving (Show, Read, Eq, Semigroup, Monoid, IsString)
+
+instance Arbitrary ProgramSrc where
+    arbitrary = sized genProg where
+
+        genProg :: Int -> Gen ProgramSrc
+        genProg n = do
+            -- in generating a program, we create a random list of sc names and
+            -- assign them type signatures and definitions in random order.
+            ns <- replicateM n genName
+               -- generate a typesig and def for each name
+            ns & each %~ (genTySig &&& genScDef)
+               -- [(typesig, scdef)] -> [typesigs and scdefs]
+               & uncurry (++) . unzip
+               -- [Gen Text] -> Gen [Text]
+               & sequenceA
+               -- shuffle order of tysigs and scdefs
+               >>= shuffle
+               -- terminate each tysig and scdef with a semicolon with a blank
+               -- line for legibility
+               <&> intersperse ";\n\n"
+               -- mconcat into a single body of text
+               <&> mconcat
+               -- she's done! put a bow on her! :D
+               <&> ProgramSrc
+
+        genTySig :: Name -> Gen Text
+        genTySig n = conseq [pure n, ws, pure "::", ws, genTy]
+
+        genScDef :: Name -> Gen Text
+        genScDef n = conseq [pure n, ws, pure "=", ws, genExpr]
+
+        genExpr :: Gen Text
+        genExpr = gen 4 0 where
+            gen 0 _ = oneof
+                [ genVar
+                , genLit
+                ]
+            gen n p = oneof
+                [ gen 0 p
+                , wrapParens <$> gen n' 0
+                , genApp n p
+                , genLet n p
+                -- , genLam n p
+                -- , genCase n p
+                ]
+                where n' = next n
+
+            genVar = oneof
+                [ genName
+                , genCon
+                , wrapParens <$> genSymName
+                , wrapParens <$> genSymCon
+                ]
+
+            genCase n p = conseq [ pure "case", ws1, gen n' 0, ws1, pure "of"
+                                 , pure "{", alts, pure "}"
+                                 ]
+                        <&> pprec 0 p
+                where
+                    n' = next n
+                    alts = chooseSize (1,6) (listOf1 alt)
+                         <&> intersperse ";"
+                         <&> mconcat
+                    alt = conseq [ tag, ws, pure "->", ws1, gen n' 0 ]
+                    tag = T.pack . show <$> chooseInt (0,maxBound)
+
+            genLit = T.pack . show <$> chooseInt (0,maxBound)
+
+            genApp n p = chooseSize (2,10) (listOf1 (gen n' 1))
+                     <&> pprec 0 p . mconcat . intersperse " "
+                where
+                    n' = next n
+
+            genLet n p = conseq [ letw, ws, pure "{", ws, binds
+                                , ws, pure "}", ws, pure "in"
+                                , ws1, gen n' 0
+                                ]
+                where
+                    letw = arbitrary <&> \case
+                        Rec    -> "letrec"
+                        NonRec -> "let"
+                    binds = chooseSize (1,6) (listOf1 bind)
+                        <&> intersperse ";"
+                        <&> mconcat
+                    bind = conseq [var, ws, pure "=", ws, gen n' 0]
+                    var = oneof [genName, wrapParens <$> genSymName]
+                    n' = next n
+
+            genLam n p = conseq [l, ws, bs, ws, pure "->", ws, gen n' 0]
+                     <&> pprec 0 p
+                where
+                    -- whitespace because reserved op shenanigans :3
+                    l = elements [" \\ ", "λ"]
+                    n' = next n
+                    bs = chooseSize (0,6) (listOf1 genName)
+                     <&> mconcat
+
+            next = (`div` 2)
+
+        genTy :: Gen Text
+        genTy = gen 4 where
+            gen 0 = genCon
+            gen n = oneof
+                [ gen 0
+                -- function types
+                , conseq [gen n', ws, pure "->", ws, gen n']
+                -- TODO: type applications (remember precedence lol)
+                ]
+                where n' = n `div` 2
+
+instance Arbitrary Rec where
+    arbitrary = elements [Rec,NonRec]
+
+chooseSize :: (Int, Int) -> Gen a -> Gen a
+chooseSize (a,b) g = do
+    n <- chooseInt (a,b)
+    resize n g
+
+-- | @pprec q p s@ wraps @s@ with parens when @p <= q@
+pprec :: (IsString a, Monoid a) => Int -> Int -> a -> a
+pprec maxp p
+    | p <= maxp = id
+    | otherwise = wrapParens
+
+wrapParens :: (IsString a, Monoid a) => a -> a
+wrapParens t = "(" <> t <> ")"
+
+conseq :: (Applicative f, Monoid m, Traversable t)
+       => t (f m)
+       -> f m
+conseq tfm = sequenceA tfm <&> the_cool_kid's_concat
+    -- me when `concat` is generalised in the container but specialised in the
+    -- value, and `mconcat` is specialised in the container but generalised in
+    -- the value. shoutout `foldMap id`
+    where the_cool_kid's_concat = foldMap id
+
+genName :: Gen Name
+genName = T.pack <$> liftA2 (:) small namechars where
+    small = elements ['a'..'z']
+
+genCon :: Gen Name
+genCon = T.pack <$> liftA2 (:) large namechars where
+    large = elements ['A'..'Z']
+
+genSymName :: Gen Name
+genSymName = T.pack <$> liftA2 (:) symbol symchars where
+    symbol = elements nameSymbols
+
+genSymCon :: Gen Name
+genSymCon = T.pack . (':' :) <$> symchars
+
+namechars :: Gen String
+namechars = liftArbitrary namechar where
+    namechar :: Gen Char
+    namechar = elements $ ['a'..'z'] <> ['A'..'Z'] <> ['0'..'9'] <> "'"
+
+nameSymbols :: [Char]
+nameSymbols = "!#$%&*+./<=>?@^|-~"
+
+symchars :: Gen String
+symchars = liftArbitrary symchar where
+    symchar = elements $ ':' : nameSymbols
+
+txt :: (IsText t) => t -> Doc
+txt t = t ^. unpacked & text
+
+ws :: (IsString a) => Gen a
+ws = elements [""," ", "  "]
+
+ws1 :: (IsString a) => Gen a
+ws1 = elements [" ", "  "]
+
+----------------------------------------------------------------------------------
+
+-- | Two bodies of source code are considered congruent iff the parser produces
+-- identical ASTs for both.
+congruentSrc :: ProgramSrc -> ProgramSrc -> Bool
+congruentSrc = (==) `on` (justParseSrc . T.unpack . coerce)
+
+----------------------------------------------------------------------------------
+
+-- TODO: unparseCoreProg :: Program -> [CoreToken]
+-- womp womp.
+
+-- TODO: implement shrink
+
+-- | @unparseCoreProg@ should be inverse to @parseCoreProg@ up to source code
+-- congruency, newtype coercion and errors handling.
+unparseCoreProg :: Program' -> ProgramSrc
+unparseCoreProg p = unparseTypeSigs (p ^. programTypeSigs)
+                 <> unparseScDefs (p ^. programScDefs)
+
+unparseTypeSigs :: H.HashMap Name Type -> ProgramSrc
+unparseTypeSigs = H.foldrWithKey f mempty
+    where f k v a = unparseTypeSig k v <> ";\n\n" <> a
+
+unparseTypeSig :: Name -> Type -> ProgramSrc
+unparseTypeSig n t = unparseName n <> " :: " <> unparseType t
+
+unparseName :: Name -> ProgramSrc
+unparseName n
+    | T.head n `elem` (':' : nameSymbols)   = coerce $ wrapParens n
+    | otherwise                             = coerce n
+
+unparseType :: Type -> ProgramSrc
+unparseType = go 0 where
+    go :: Int -> Type -> ProgramSrc
+    -- (:->) is a special case of TyApp, but we want the infix syntax
+    go p (a :-> b)          = a : assocFun b
+                            <&> go 1
+                            & coerce (T.intercalate " -> ")
+                            & pprec 0 p
+    go p a@(TyApp f x)      = assocApp a
+                            <&> go 1
+                            & coerce (T.intercalate " ")
+                            & pprec 1 p
+    go _ TyFun              = "(->)"
+    go _ (TyCon a)          = unparseName a
+    go _ (TyVar a)          = unparseName a
+
+    assocFun :: Type -> [Type]
+    assocFun (a :-> b) = a : assocFun b
+    assocFun x         = [x]
+
+    assocApp :: Type -> [Type]
+    assocApp (TyApp f x) = assocApp f ++ [x]
+    assocApp x           = [x]
+
+unparseScDefs :: [ScDef'] -> ProgramSrc
+unparseScDefs = foldr f mempty where
+    f sc a = unparseScDef sc <> ";\n\n" <> a
+
+unparseScDef :: ScDef' -> ProgramSrc
+unparseScDef (ScDef n as e) = (unparseName <$> (n:as)) <> ["=", unparseExpr e]
+                            & coerce (T.intercalate " ")
+
+unparseExpr :: Expr' -> ProgramSrc
+unparseExpr = go 0 where
+    go :: Int -> Expr' -> ProgramSrc
+    go _ (Var n)        = unparseName n
+    go _ (Con t a)      = mconcat ["Pack{",srcShow t," ",srcShow a,"}"]
+    go _ (Lit l)        = unparseLit l
+    go p a@(App _ _)    = srci " " (go 1 <$> assocApp a)
+                        & pprec 0 p
+    go p (Lam bs e)     = "λ" <> srci " " (unparseName <$> bs)
+                              <> " -> " <> go 0 e
+                        & pprec 0 p
+    go p (Let r bs e)   = mconcat [lw," { ",bs'," } in ",go 0 e]
+                        & pprec 0 p
+        where
+            lw = case r of { NonRec -> "let"; Rec -> "letrec" }
+            bs' = srci "; " $ unparseBinding <$> bs
+    go p (Case e as)    = mconcat ["case ",go 0 e," of {",as',"}"]
+                        & pprec 0 p
+        where as' = srci "; " (unparseAlter <$> as)
+
+    assocApp (App f x) = assocApp f ++ [x]
+    assocApp f         = [f]
+
+    srci :: ProgramSrc -> [ProgramSrc] -> ProgramSrc
+    srci = coerce T.intercalate
+
+unparseBinding :: Binding' -> ProgramSrc
+unparseBinding (k := v) = mconcat [unparseName k, " = ", unparseExpr v]
+
+unparseLit :: Lit -> ProgramSrc
+unparseLit (IntL n) = srcShow n
+
+srcShow :: (Show a) => a -> ProgramSrc
+srcShow = coerce . T.pack . show
+
+unparseAlter :: Alter' -> ProgramSrc
+unparseAlter (Alter (AltData t) as e)   = srcShow t <> " " <> coerce (T.unwords as)
+                                       <> " -> " <> unparseExpr e
+

tst/GMSpec.hs

@@ -21,7 +21,7 @@ spec = do
         resultOf [coreProg|id x = x; main = (id (-#)) 3 2;|] `shouldBe` Just (NNum 1)
 
     it "should correctly evaluate arbitrary arithmetic" $ do
-        property $ \e ->
+        withMaxSuccess 40 $ property $ \e ->
             let arithRes = Just (evalArith e)
                 coreRes  = evalCore e
             in coreRes `shouldBe` arithRes