organisation and cleaning

organisation and tidying

Makefile_happysrcs

@@ -1,5 +1,5 @@
 HAPPY = happy
-HAPPY_OPTS = -a -g -c
+HAPPY_OPTS = -a -g -c -i/tmp/t.info
 ALEX = alex
 ALEX_OPTS = -g
 

README.md

@@ -81,6 +81,7 @@ Listed in order of importance.
     - [ ] CLI usage
     - [ ] Tail call optimisation
     - [ ] Parsing rlp
+    - [ ] Trees That Grow
 - [ ] Tests
     - [x] Generic example programs
     - [ ] Parser

rlp.cabal

@@ -37,6 +37,7 @@ library
                     , Rlp.Parse.Associate
                     , Rlp.Lex
                     , Rlp.Parse.Types
+                    , Compiler.Types
 
     other-modules:    Data.Heap
                     , Data.Pretty
@@ -48,7 +49,7 @@ library
     build-tool-depends: happy:happy, alex:alex
 
     -- other-extensions:
-    build-depends:    base ^>=4.18.0.0
+    build-depends:    base >=4.17 && <4.20
                     -- required for happy
                     , array >= 0.5.5 && < 0.6
                     , containers >= 0.6.7 && < 0.7
@@ -69,19 +70,24 @@ library
                     , data-fix >= 0.3.2 && < 0.4
                     , utf8-string >= 1.0.2 && < 1.1
                     , extra >= 1.7.0 && < 2
+                    , semigroupoids
+                    , comonad
+                    , lens
 
     hs-source-dirs:   src
     default-language: GHC2021
 
     default-extensions:
         OverloadedStrings
+        TypeFamilies
+        LambdaCase
 
 executable rlpc
     import:           warnings
     main-is:          Main.hs
     -- other-modules:
     -- other-extensions:
-    build-depends: base ^>=4.18.0.0
+    build-depends: base >=4.17.0.0 && <4.20.0.0
                  , rlp
                  , optparse-applicative >= 0.18.1 && < 0.19
                  , microlens >= 0.4.13 && < 0.5

src/Compiler/RlpcError.hs

@@ -5,12 +5,14 @@ module Compiler.RlpcError
     , MsgEnvelope(..)
     , Severity(..)
     , RlpcError(..)
-    , SrcSpan(..)
     , msgSpan
     , msgDiagnostic
     , msgSeverity
     , liftRlpcErrors
     , errorMsg
+    -- * Located Comonad
+    , Located(..)
+    , SrcSpan(..)
     )
     where
 ----------------------------------------------------------------------------------
@@ -20,6 +22,7 @@ import Data.Text                qualified as T
 import GHC.Exts                 (IsString(..))
 import Lens.Micro.Platform
 import Lens.Micro.Platform.Internal
+import Compiler.Types
 ----------------------------------------------------------------------------------
 
 data MsgEnvelope e = MsgEnvelope
@@ -45,12 +48,6 @@ data Severity = SevWarning
               | SevError
               deriving Show
 
-data SrcSpan = SrcSpan
-    !Int -- ^ Line
-    !Int -- ^ Column
-    !Int -- ^ Length
-    deriving Show
-
 makeLenses ''MsgEnvelope
 
 liftRlpcErrors :: (Functor m, IsRlpcError e)

src/Compiler/Types.hs

@@ -0,0 +1,66 @@
+module Compiler.Types
+    ( SrcSpan(..)
+    , Located(..)
+    , (<<~), (<~>)
+
+    -- * Re-exports
+    , Comonad
+    , Apply
+    , Bind
+    )
+    where
+--------------------------------------------------------------------------------
+import Control.Comonad
+import Data.Functor.Apply
+import Data.Functor.Bind
+--------------------------------------------------------------------------------
+
+-- | Token wrapped with a span (line, column, absolute, length)
+data Located a = Located SrcSpan a
+    deriving (Show, Functor)
+
+instance Apply Located where
+    liftF2 f (Located sa p) (Located sb q)
+            = Located (sa <> sb) (p `f` q)
+
+instance Bind Located where
+    Located sa a >>- k = Located (sa <> sb) b
+        where
+            Located sb b = k a
+
+instance Comonad Located where
+    extract (Located _ a) = a
+    extend ck w@(Located p _) = Located p (ck w)
+
+data SrcSpan = SrcSpan
+    !Int -- ^ Line
+    !Int -- ^ Column
+    !Int -- ^ Absolute
+    !Int -- ^ Length
+    deriving Show
+
+instance Semigroup SrcSpan where
+    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 + lb - aa)
+            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.
+
+(<<~) :: (Comonad w) => (w a -> b) -> w a -> w b
+(<<~) = (<<=)
+
+infixl 4 <<~
+
+-- | Similar to '(<*>)', but with a cokleisli arrow.
+
+(<~>) :: (Comonad w, Bind w) => w (w a -> b) -> w a -> w b
+mc <~> ma = mc >>- \f -> ma =>> f
+
+infixl 4 <~>
+

src/Core/Lex.x

@@ -22,7 +22,8 @@ import Data.Text            qualified as T
 import Data.String          (IsString(..))
 import Core.Syntax
 import Compiler.RLPC
-import Compiler.RlpcError
+-- TODO: unify Located definitions
+import Compiler.RlpcError   hiding (Located(..))
 import Lens.Micro
 import Lens.Micro.TH
 }

src/Rlp/Lex.x

@@ -10,6 +10,7 @@ module Rlp.Lex
     , lexStream
     , lexDebug
     , lexCont
+    , popLexState
     )
     where
 import Codec.Binary.UTF8.String (encodeChar)
@@ -57,7 +58,7 @@ $asciisym       = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]
     |infixr|infixl|infix
 
 @reservedop =
-    "=" | \\ | "->" | "|"
+    "=" | \\ | "->" | "|" | "::"
 
 rlp :-
     
@@ -73,6 +74,17 @@ $white_no_nl+       ;
 -- for the definition of `doBol`
 <0> \n                  { beginPush bol }
 
+<layout>
+{
+    
+}
+
+-- layout keywords
+<0>
+{
+    "let"               { constToken TokenLet `thenBeginPush` layout_let }
+}
+
 -- scan various identifiers and reserved words. order is important here!
 <0>
 {
@@ -110,6 +122,14 @@ $white_no_nl+       ;
     ()                  { doBol }
 }
 
+<layout_let>
+{
+    \n                  { beginPush bol }
+    "{"                 { explicitLBrace }
+    "in"                { constToken TokenIn `thenDo` (popLexState *> popLayout) }
+    ()                  { doLayout }
+}
+
 <layout_top>
 {
     \n                  ;
@@ -144,6 +164,12 @@ thenBegin act c inp l = do
     psLexState . _head .= c
     pure a
 
+thenBeginPush :: LexerAction a -> Int -> LexerAction a
+thenBeginPush act c inp l = do
+    a <- act inp l
+    pushLexState c
+    pure a
+
 andBegin :: LexerAction a -> Int -> LexerAction a
 andBegin act c inp l = do
     psLexState . _head .= c
@@ -164,10 +190,10 @@ alexGetByte inp = case inp ^. aiBytes of
                        -- report the previous char
                        & aiPrevChar .~ c
                        -- update the position
-                       & aiPos %~ \ (ln,col) ->
+                       & aiPos %~ \ (ln,col,a) ->
                                    if c == '\n'
-                                   then (ln+1,1)
+                                   then (ln+1, 1, a+1)
-                                   else (ln,col+1)
+                                   else (ln, col+1, a+1)
         pure (b, inp')
     
     _ -> Just (head bs, inp')
@@ -187,19 +213,19 @@ pushLexState :: Int -> P ()
 pushLexState n = psLexState %= (n:)
 
 readInt :: Text -> Int
-readInt = T.foldr f 0 where
+readInt = T.foldl f 0 where
-    f c n = digitToInt c + 10*n
+    f n c = 10*n + digitToInt c
 
 constToken :: RlpToken -> LexerAction (Located RlpToken)
 constToken t inp l = do
     pos <- use (psInput . aiPos)
-    pure (Located (pos,l) t)
+    pure (Located (spanFromPos 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)
+    pure (Located (spanFromPos pos l) t)
 
 getPos :: P Position
 getPos = use (psInput . aiPos)
@@ -207,7 +233,8 @@ getPos = use (psInput . aiPos)
 alexEOF :: P (Located RlpToken)
 alexEOF = do
     inp <- getInput
-    pure (Located undefined TokenEOF)
+    pos <- getPos
+    pure (Located (spanFromPos pos 0) TokenEOF)
 
 initParseState :: Text -> ParseState
 initParseState s = ParseState
@@ -224,7 +251,7 @@ initAlexInput s = AlexInput
     { _aiPrevChar   = '\0'
     , _aiSource     = s
     , _aiBytes      = []
-    , _aiPos        = (1,1)
+    , _aiPos        = (1,1,0)
     }
 
 runP' :: P a -> Text -> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
@@ -238,7 +265,7 @@ lexToken = do
     st <- use id
     -- traceM $ "st: " <> show st
     case alexScan inp c of
-        AlexEOF -> pure $ Located (inp ^. aiPos, 0) TokenEOF
+        AlexEOF -> pure $ Located (spanFromPos (inp^.aiPos) 0) TokenEOF
         AlexSkip inp' l -> do
             psInput .= inp'
             lexToken
@@ -274,7 +301,7 @@ indentLevel = do
 insertToken :: RlpToken -> P (Located RlpToken)
 insertToken t = do
     pos <- use (psInput . aiPos)
-    pure (Located (pos, 0) t)
+    pure (Located (spanFromPos pos 0) t)
 
 popLayout :: P Layout
 popLayout = do
@@ -341,6 +368,7 @@ explicitRBrace inp l = do
 doLayout :: LexerAction (Located RlpToken)
 doLayout _ _ = do
     i <- indentLevel
+    traceM $ "doLayout: i: " <> show i
     pushLayout (Implicit i)
     popLexState
     insertLBrace

src/Rlp/Parse.y

@@ -1,7 +1,8 @@
 {
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase, ViewPatterns #-}
 module Rlp.Parse
     ( parseRlpProg
+    , parseRlpExpr
     )
     where
 import Compiler.RlpcError
@@ -9,16 +10,21 @@ import Rlp.Lex
 import Rlp.Syntax
 import Rlp.Parse.Types
 import Rlp.Parse.Associate
-import Lens.Micro
+import Lens.Micro.Platform
-import Lens.Micro.Mtl
-import Lens.Micro.Platform          ()
 import Data.List.Extra
 import Data.Fix
 import Data.Functor.Const
+import Data.Functor.Apply
+import Data.Functor.Bind
+import Control.Comonad
+import Data.Functor
+import Data.Semigroup.Traversable
 import Data.Text                    qualified as T
+import Data.Void
 }
 
 %name parseRlpProg StandaloneProgram
+%name parseRlpExpr StandaloneExpr
 
 %monad { P }
 %lexer { lexCont } { Located _ TokenEOF }
@@ -26,14 +32,15 @@ import Data.Text                    qualified as T
 %tokentype { Located RlpToken }
 
 %token
-    varname         { Located _ (TokenVarName $$) }
+    varname         { Located _ (TokenVarName _) }
-    conname         { Located _ (TokenConName $$) }
+    conname         { Located _ (TokenConName _) }
-    consym          { Located _ (TokenConSym $$) }
+    consym          { Located _ (TokenConSym _) }
-    varsym          { Located _ (TokenVarSym $$) }
+    varsym          { Located _ (TokenVarSym _) }
     data            { Located _ TokenData }
-    litint          { Located _ (TokenLitInt $$) }
+    litint          { Located _ (TokenLitInt _) }
     '='             { Located _ TokenEquals }
     '|'             { Located _ TokenPipe }
+    '::'            { Located _ TokenHasType }
     ';'             { Located _ TokenSemicolon }
     '('             { Located _ TokenLParen }
     ')'             { Located _ TokenRParen }
@@ -46,15 +53,22 @@ import Data.Text                    qualified as T
     infixl          { Located _ TokenInfixL }
     infixr          { Located _ TokenInfixR }
     infix           { Located _ TokenInfix }
+    let             { Located _ TokenLet }
+    in              { Located _ TokenIn }
 
+%nonassoc '='
 %right '->'
+%right in
 
 %%
 
-StandaloneProgram   :: { RlpProgram' }
+StandaloneProgram   :: { RlpProgram RlpcPs }
 StandaloneProgram   : '{' Decls  '}'        {% mkProgram $2 }
                     | VL  DeclsV VR         {% mkProgram $2 }
 
+StandaloneExpr      :: { RlpExpr RlpcPs }
+                    : VL Expr VR            { extract $2 }
+
 VL  :: { () }
 VL  : vlbrace       { () }
 
@@ -62,12 +76,12 @@ VR  :: { () }
 VR  : vrbrace       { () }
     | error         { () }
 
-Decls               :: { [PartialDecl'] }
+Decls               :: { [Decl' RlpcPs] }
 Decls               : Decl ';' Decls        { $1 : $3 }
                     | Decl ';'              { [$1] }
                     | Decl                  { [$1] }
 
-DeclsV              :: { [PartialDecl'] }
+DeclsV              :: { [Decl' RlpcPs] }
 DeclsV              : Decl VS Decls         { $1 : $3 }
                     | Decl VS               { [$1] }
                     | Decl                  { [$1] }
@@ -76,97 +90,128 @@ VS                  :: { Located RlpToken }
 VS                  : ';'                   { $1 }
                     | vsemi                 { $1 }
 
-Decl        :: { PartialDecl' }
+Decl        :: { Decl' RlpcPs }
             : FunDecl                   { $1 }
+            | TySigDecl                 { $1 }
             | DataDecl                  { $1 }
             | InfixDecl                 { $1 }
 
-InfixDecl   :: { PartialDecl' }
+TySigDecl   :: { Decl' RlpcPs }
-            : InfixWord litint InfixOp  {% mkInfixD $1 $2 $3 }
+            : Var '::' Type             { (\e -> TySigD [extract e]) <<~ $1 <~> $3 }
 
-InfixWord   :: { Assoc }
+InfixDecl   :: { Decl' RlpcPs }
-            : infixl                    { InfixL }
+            : InfixWord litint InfixOp  { $1 =>> \w ->
-            | infixr                    { InfixR }
+                                          InfixD (extract $1) (extractInt $ extract $2)
-            | infix                     { Infix  }
+                                          (extract $3) }
 
-DataDecl    :: { PartialDecl' }
+InfixWord   :: { Located Assoc }
-            : data Con TyParams '=' DataCons    { DataD $2 $3 $5 }
+            : infixl                    { $1 \$> InfixL }
+            | infixr                    { $1 \$> InfixR }
+            | infix                     { $1 \$> Infix  }
 
-TyParams    :: { [Name] }
+DataDecl    :: { Decl' RlpcPs }
+            : data Con TyParams '=' DataCons    { $1 \$> DataD (extract $2) $3 $5 }
+
+TyParams    :: { [PsName] }
             : {- epsilon -}             { [] }
-            | TyParams varname          { $1 `snoc` $2 }
+            | TyParams varname          { $1 `snoc` (extractName . extract $ $2) }
 
-DataCons    :: { [ConAlt] }
+DataCons    :: { [ConAlt RlpcPs] }
             : DataCons '|' DataCon      { $1 `snoc` $3 }
             | DataCon                   { [$1] }
 
-DataCon     :: { ConAlt }
+DataCon     :: { ConAlt RlpcPs }
-            : Con Type1s                { ConAlt $1 $2 }
+            : Con Type1s                { ConAlt (extract $1) $2 }
 
-Type1s      :: { [Type] }
+Type1s      :: { [RlpType' RlpcPs] }
             : {- epsilon -}             { [] }
             | Type1s Type1              { $1 `snoc` $2 }
 
-Type1       :: { Type }
+Type1       :: { RlpType' RlpcPs }
             : '(' Type ')'              { $2 }
-            | conname                   { TyCon $1 }
+            | conname                   { fmap ConT (mkPsName $1) }
-            | varname                   { TyVar $1 }
+            | varname                   { fmap VarT (mkPsName $1) }
 
-Type        :: { Type }
+Type        :: { RlpType' RlpcPs }
-            : Type '->' Type            { $1 :-> $3 }
+            : Type '->' Type            { FunT <<~ $1 <~> $3 }
             | Type1                     { $1 }
 
-FunDecl     :: { PartialDecl' }
+FunDecl     :: { Decl' RlpcPs }
-FunDecl     : Var Params '=' Expr       { FunD $1 $2 (Const $4) Nothing }
+FunDecl     : Var Params '=' Expr       { $4 =>> \e ->
+                                          FunD (extract $1) $2 e Nothing }
 
-Params      :: { [Pat'] }
+Params      :: { [Pat' RlpcPs] }
 Params      : {- epsilon -}             { [] }
             | Params Pat1               { $1 `snoc` $2 }
 
-Pat1        :: { Pat' }
+Pat1        :: { Pat' RlpcPs }
-            : Var                       { VarP $1 }
+            : Var                       { fmap VarP $1 }
-            | Lit                       { LitP $1 }
+            | Lit                       { LitP <<= $1 }
 
-Expr        :: { PartialExpr' }
+Expr        :: { RlpExpr' RlpcPs }
-            : Expr1 varsym Expr         { Fix $ B $2 (unFix $1) (unFix $3) }
+            : Expr1 InfixOp Expr        { $2 =>> \o ->
+                                          OAppE (extract o) $1 $3 }
             | Expr1                     { $1 }
+            | LetExpr                   { $1 }
 
-Expr1       :: { PartialExpr' }
+LetExpr     :: { RlpExpr' RlpcPs }
-            : '(' Expr ')'              { wrapFix . Par . unwrapFix $ $2 }
+            : let layout1(Binding) in Expr { $1 \$> LetE $2 $4 }
-            | Lit                       { Fix . E $ LitEF $1 }
-            | Var                       { Fix . E $ VarEF $1 }
 
--- TODO: happy prefers left-associativity. doing such would require adjusting
+layout1(p)  : '{' layout_list1(';',p) '}'   { $2 }
--- the code in Rlp.Parse.Associate to expect left-associative input rather than
+            | VL  layout_list1(VS,p) VR     { $2 }
--- right.
-InfixExpr   :: { PartialExpr' }
-            : Expr1 varsym Expr         { Fix $ B $2 (unFix $1) (unFix $3) }
 
-InfixOp     :: { Name }
+layout_list1(sep,p) : p                          { [$1] }
-            : consym                    { $1 }
+                    | layout_list1(sep,p) sep p  { $1 `snoc` $3 }
-            | varsym                    { $1 }
 
-Lit         :: { Lit' }
+Binding     :: { Binding' RlpcPs }
-Lit         : litint                    { IntL $1 }
+            : Pat1 '=' Expr              { PatB <<~ $1 <~> $3 }
 
-Var         :: { VarId }
+Expr1       :: { RlpExpr' RlpcPs }
-Var         : varname                   { NameVar $1 }
+            : '(' Expr ')'              { $1 .> $2 <. $3 }
+            | Lit                       { fmap LitE $1 }
+            | Var                       { fmap VarE $1 }
 
-Con         :: { ConId }
+InfixOp     :: { Located PsName }
-            : conname                   { NameCon $1 }
+            : consym                    { mkPsName $1 }
+            | varsym                    { mkPsName $1 }
+
+-- TODO: microlens-pro save me microlens-pro (rewrite this with prisms)
+Lit         :: { Lit' RlpcPs }
+            : litint                    { $1 <&> (IntL . (\ (TokenLitInt n) -> n)) }
+
+Var         :: { Located PsName }
+Var         : varname                   { mkPsName $1 }
+
+Con         :: { Located PsName }
+            : conname                   { mkPsName $1 }
 
 {
 
-mkProgram :: [PartialDecl'] -> P RlpProgram'
+mkPsName :: Located RlpToken -> Located PsName
+mkPsName = fmap extractName
+
+extractName :: RlpToken -> PsName
+extractName = \case
+    TokenVarName n -> n
+    TokenConName n -> n
+    TokenConSym  n -> n
+    TokenVarSym  n -> n
+    _              -> error "mkPsName: not an identifier"
+
+extractInt :: RlpToken -> Int
+extractInt (TokenLitInt n) = n
+extractInt _ = error "extractInt: ugh"
+
+mkProgram :: [Decl' RlpcPs] -> P (RlpProgram RlpcPs)
 mkProgram ds = do
     pt <- use psOpTable
     pure $ RlpProgram (associate pt <$> ds)
 
 parseError :: Located RlpToken -> P a
-parseError (Located ((l,c),s) t) = addFatal $
+parseError (Located ss t) = addFatal $
-    errorMsg (SrcSpan l c s) RlpParErrUnexpectedToken
+    errorMsg ss RlpParErrUnexpectedToken
 
-mkInfixD :: Assoc -> Int -> Name -> P PartialDecl'
+mkInfixD :: Assoc -> Int -> PsName -> P (Decl' RlpcPs)
 mkInfixD a p n = do
     let opl :: Lens' ParseState (Maybe OpInfo)
         opl = psOpTable . at n
@@ -176,6 +221,10 @@ mkInfixD a p n = do
             l = T.length n
         Nothing -> pure (Just (a,p))
         )
-    pure $ InfixD a p n
+    pos <- use (psInput . aiPos)
+    pure $ Located (spanFromPos pos 0) (InfixD a p n)
+
+intOfToken :: Located RlpToken -> Int
+intOfToken (Located _ (TokenLitInt n)) = n
 
 }

src/Rlp/Parse/Associate.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms, ViewPatterns, ImplicitParams #-}
 module Rlp.Parse.Associate
+    {-# WARNING "temporarily unimplemented" #-}
     ( associate
     )
     where
@@ -13,88 +14,6 @@ import Rlp.Parse.Types
 import Rlp.Syntax
 --------------------------------------------------------------------------------
 
-associate :: OpTable -> PartialDecl' -> Decl' RlpExpr
+associate x y = y
-associate pt (FunD n as b w)    = FunD n as b' w
+{-# WARNING associate "temporarily undefined" #-}
-    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

@@ -2,38 +2,26 @@
 {-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
 {-# LANGUAGE LambdaCase #-}
 module Rlp.Parse.Types
-    ( LexerAction
+    (
-    , MsgEnvelope(..)
+    -- * Trees That Grow
-    , RlpcError(..)
+      RlpcPs
-    , AlexInput(..)
+
-    , Position(..)
+    -- * Parser monad and state
-    , RlpToken(..)
+    , P(..), ParseState(..), Layout(..), OpTable, OpInfo
-    , P(..)
+    -- ** Lenses
-    , ParseState(..)
+    , psLayoutStack, psLexState, psInput, psOpTable
-    , psLayoutStack
+
-    , psLexState
+    -- * Other parser types
-    , psInput
+    , RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction
-    , psOpTable
+    , Located(..), PsName
-    , Layout(..)
+    -- ** Lenses
-    , Located(..)
+    , aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn
-    , OpTable
+
-    , OpInfo
+    , (<<~), (<~>)
-    , RlpParseError(..)
+
-    , PartialDecl'
+    -- * Error handling
-    , Partial(..)
+    , MsgEnvelope(..), RlpcError(..), RlpParseError(..)
-    , pL, pR
+    , addFatal, addWound, addFatalHere, addWoundHere
-    , PartialE
-    , pattern WithInfo
-    , opInfoOrDef
-    , PartialExpr'
-    , aiPrevChar
-    , aiSource
-    , aiBytes
-    , aiPos
-    , addFatal
-    , addWound
-    , addFatalHere
-    , addWoundHere
     )
     where
 --------------------------------------------------------------------------------
@@ -49,12 +37,46 @@ import Data.Functor.Foldable
 import Data.Functor.Const
 import Data.Functor.Classes
 import Data.HashMap.Strict          qualified as H
+import Data.Void
 import Data.Word                    (Word8)
 import Lens.Micro.TH
 import Lens.Micro
 import Rlp.Syntax
+import Compiler.Types
 --------------------------------------------------------------------------------
 
+-- | Phantom type identifying rlpc's parser phase
+
+data RlpcPs
+
+type instance XRec RlpcPs f = Located (f RlpcPs)
+type instance IdP RlpcPs = PsName
+
+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 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 PsName = Text
+
+--------------------------------------------------------------------------------
+
+spanFromPos :: Position -> Int -> SrcSpan
+spanFromPos (l,c,a) s = SrcSpan l c a s
+
+{-# INLINE spanFromPos #-}
+
 type LexerAction a = AlexInput -> Int -> P a
 
 data AlexInput = AlexInput
@@ -66,8 +88,9 @@ data AlexInput = AlexInput
     deriving Show
 
 type Position =
-    ( Int -- line
+    ( Int -- ^ line
-    , Int -- column
+    , Int -- ^ column
+    , Int -- ^ Absolutely
     )
 
 posLine :: Lens' Position Int
@@ -76,6 +99,9 @@ posLine = _1
 posColumn :: Lens' Position Int
 posColumn = _2
 
+posAbsolute :: Lens' Position Int
+posAbsolute = _3
+
 data RlpToken
     -- literals
     = TokenLitInt Int
@@ -106,7 +132,7 @@ data RlpToken
     | TokenLParen
     | TokenRParen
     -- 'virtual' control symbols, inserted by the lexer without any correlation
-    -- to a specific symbol
+    -- to a specific part of the input
     | TokenSemicolonV
     | TokenLBraceV
     | TokenRBraceV
@@ -154,9 +180,6 @@ 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)
 
@@ -171,47 +194,6 @@ data RlpParseError = RlpParErrOutOfBoundsPrecedence Int
 instance IsRlpcError RlpParseError where
 
 ----------------------------------------------------------------------------------
--- 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
@@ -221,8 +203,9 @@ addWoundHere l e = P $ \st ->
     let e' = MsgEnvelope
             { _msgSpan = let pos = psInput . aiPos
                          in SrcSpan (st ^. pos . posLine)
-                                   (st ^. pos . posColumn)
+                                    (st ^. pos . posColumn)
-                                   l
+                                    (st ^. pos . posAbsolute)
+                                    l
             , _msgDiagnostic = e
             , _msgSeverity = SevError
             }
@@ -234,6 +217,7 @@ addFatalHere l e = P $ \st ->
             { _msgSpan = let pos = psInput . aiPos
                          in SrcSpan (st ^. pos . posLine)
                                     (st ^. pos . posColumn)
+                                    (st ^. pos . posAbsolute)
                                     l
             , _msgDiagnostic = e
             , _msgSeverity = SevError

src/Rlp/Syntax.hs

@@ -1,40 +1,36 @@
 -- recursion-schemes
-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable
--- recursion-schemes
+  , TemplateHaskell, TypeFamilies #-}
-{-# LANGUAGE TemplateHaskell, TypeFamilies #-}
 {-# LANGUAGE OverloadedStrings, PatternSynonyms #-}
+{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}
+{-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-}
 module Rlp.Syntax
-    ( RlpModule(..)
+    (
-    , RlpProgram(..)
+    -- * AST
-    , RlpProgram'
+      RlpProgram(..)
-    , rlpmodName
+    , Decl(..), Decl', RlpExpr(..), RlpExpr'
-    , rlpmodProgram
+    , Pat(..), Pat'
-    , RlpExpr(..)
-    , RlpExpr'
-    , RlpExprF(..)
-    , RlpExprF'
-    , Decl(..)
-    , Decl'
-    , Bind(..)
-    , Where
-    , Where'
-    , ConAlt(..)
-    , Type(..)
-    , pattern (:->)
     , Assoc(..)
-    , VarId(..)
+    , Lit(..), Lit'
-    , ConId(..)
+    , RlpType(..), RlpType'
-    , Pat(..)
+    , ConAlt(..)
-    , Pat'
+    , Binding(..), Binding'
-    , Lit(..)
-    , Lit'
-    , Name
 
-    -- TODO: ugh move this somewhere else later
+    -- * Trees That Grow boilerplate
-    , showsTernaryWith
+    -- ** Extension points
-
+    , IdP, XRec, UnXRec(..), MapXRec(..)
-    -- * Convenience re-exports
+    -- *** Decl
-    , Text
+    , XFunD, XTySigD, XInfixD, XDataD, XXDeclD
+    -- *** RlpExpr
+    , XLetE, XVarE, XLamE, XCaseE, XIfE, XAppE, XLitE
+    , XParE, XOAppE, XXRlpExprE
+    -- ** Pattern synonyms
+    -- *** Decl
+    , pattern FunD, pattern TySigD, pattern InfixD, pattern DataD
+    -- *** RlpExpr
+    , pattern LetE, pattern VarE, pattern LamE, pattern CaseE, pattern IfE
+    , pattern AppE, pattern LitE, pattern ParE, pattern OAppE
+    , pattern XRlpExprE
     )
     where
 ----------------------------------------------------------------------------------
@@ -43,93 +39,180 @@ import Data.Text                    qualified as T
 import Data.String                  (IsString(..))
 import Data.Functor.Foldable.TH     (makeBaseFunctor)
 import Data.Functor.Classes
+import Data.Kind                    (Type)
 import Lens.Micro
 import Lens.Micro.TH
-import Core.Syntax                  hiding (Lit)
+import Core.Syntax                  hiding (Lit, Type, Binding, Binding')
 import Core                         (HasRHS(..), HasLHS(..))
 ----------------------------------------------------------------------------------
 
-data RlpModule b = RlpModule
+data RlpModule p = RlpModule
     { _rlpmodName       :: Text
-    , _rlpmodProgram    :: RlpProgram b
+    , _rlpmodProgram    :: RlpProgram p
     }
 
-newtype RlpProgram b = RlpProgram [Decl RlpExpr b]
+-- | dear god.
-    deriving Show
+type PhaseShow p =
+    ( Show (XRec p Pat), Show (XRec p RlpExpr)
+    , Show (XRec p Lit), Show (IdP p)
+    , Show (XRec p RlpType)
+    , Show (XRec p Binding)
+    )
 
-type RlpProgram' = RlpProgram Name
+newtype RlpProgram p = RlpProgram [Decl' p]
 
--- | The @e@ parameter is used for partial results. When parsing an input, we
+deriving instance (PhaseShow p, Show (XRec p Decl)) => Show (RlpProgram p)
--- 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))
+data RlpType p = FunConT
-              | TySigD  [VarId] Type
+               | FunT (RlpType' p) (RlpType' p)
-              | DataD   ConId [Name] [ConAlt]
+               | AppT (RlpType' p) (RlpType' p)
-              | InfixD  Assoc Int Name
+               | VarT (IdP p)
-              deriving Show
+               | ConT (IdP p)
 
-type Decl' e = Decl e Name
+type RlpType' p = XRec p RlpType
+
+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' ()
+
+type Decl' p = XRec p Decl
 
 data Assoc = InfixL
            | InfixR
            | Infix
-           deriving Show
+           deriving (Show)
 
-data ConAlt = ConAlt ConId [Type]
+data ConAlt p = ConAlt (IdP p) [RlpType' p]
-            deriving Show
 
-data RlpExpr b = LetE  [Bind b] (RlpExpr b)
+deriving instance (Show (IdP p), Show (XRec p RlpType)) => Show (ConAlt p)
-               | 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
 
-type RlpExpr' = RlpExpr Name
+data RlpExpr p = LetE'  (XLetE 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)
 
-type Where b = [Bind b]
+type family XLetE p
-type Where' = [Bind Name]
+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 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 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 (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
+
+class UnXRec p where
+    unXRec :: XRec p f -> f p
+
+class MapXRec p where
+    mapXRec :: (f p -> f' p') -> XRec p f -> XRec p' f'
+
+type family XRec p (f :: Type -> Type) = (r :: Type) | r -> p f
+
+type family IdP p
+
+type Where p = [Binding p]
 
 -- do we want guards?
-data Alt b = AltA (Pat b) (RlpExpr b)
+data Alt p = AltA (Pat' p) (RlpExpr' p)
-           deriving Show
 
-data Bind b = PatB (Pat b) (RlpExpr b)
+deriving instance (PhaseShow p) => Show (Alt p)
-            | FunB VarId [Pat b] (RlpExpr b)
-            deriving Show
 
-data VarId = NameVar Text
+data Binding p = PatB (Pat' p) (RlpExpr' p)
-           | SymVar Text
+               | FunB (IdP p) [Pat' p] (RlpExpr' p)
-           deriving Show
 
-instance IsString VarId where
+type Binding' p = XRec p Binding
-    -- TODO: use symvar if it's an operator
-    fromString = NameVar . T.pack
 
-data ConId = NameCon Text
+deriving instance (Show (XRec p Pat), Show (XRec p RlpExpr), Show (IdP p)
-           | SymCon Text
+                  ) => Show (Binding p)
-           deriving Show
 
-data Pat b = VarP VarId
+data Pat p = VarP (IdP p)
-           | LitP (Lit b)
+           | LitP (Lit' p)
-           | ConP ConId [Pat b]
+           | ConP (IdP p) [Pat' p]
-           deriving Show
 
-type Pat' = Pat Name
+deriving instance (PhaseShow p) => Show (Pat p)
 
-data Lit b = IntL Int
+type Pat' p = XRec p Pat
+
+data Lit p = IntL Int
            | CharL Char
-           | ListL [RlpExpr b]
+           | ListL [RlpExpr' p]
-           deriving Show
 
-type Lit' = Lit Name
+deriving instance (PhaseShow p) => Show (Lit p)
+
+type Lit' p = XRec p Lit
 
 -- instance HasLHS Alt Alt Pat Pat where
 --     _lhs = lens
@@ -143,33 +226,17 @@ type Lit' = Lit Name
 
 makeBaseFunctor ''RlpExpr
 
-deriving instance (Show b, Show a) => Show (RlpExprF b a)
+-- showsTernaryWith :: (Int -> x -> ShowS)
-
+--                  -> (Int -> y -> ShowS)
-type RlpExprF' = RlpExprF Name
+--                  -> (Int -> z -> ShowS)
-
+--                  -> String -> Int
--- society if derivable Show1
+--                  -> x -> y -> z
-instance (Show b) => Show1 (RlpExprF b) where
+--                  -> ShowS
-    liftShowsPrec sp _ p m = case m of
+-- showsTernaryWith sa sb sc name p a b c = showParen (p > 10)
-        (LetEF bs e)            -> showsBinaryWith showsPrec sp "LetEF" p bs e
+--     $ showString name
-        (VarEF n)               -> showsUnaryWith showsPrec "VarEF" p n
+--     . showChar ' ' . sa 11 a 
-        (ConEF n)               -> showsUnaryWith showsPrec "ConEF" p n
+--     . showChar ' ' . sb 11 b
-        (LamEF bs e)            -> showsBinaryWith showsPrec sp "LamEF" p bs e
+--     . showChar ' ' . sc 11 c
-        (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
 
 --------------------------------------------------------------------------------