core driver

organisation and tidying

CHANGELOG.md

@@ -15,3 +15,5 @@
     }
   ```
 
+# Release 1.0.0
+

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

@@ -23,7 +23,7 @@ $ cabal test --test-show-details=direct
 $ rlpc -ddump-eval examples/factorial.hs
 # Compile and evaluate t.hs, with evaluation info dumped to t.log
 $ rlpc -ddump-eval -l t.log t.hs
-# Print the raw structure describing the compiler options and die
+# Print the raw structure describing the compiler options
 # (option parsing still must succeed in order to print)
 $ rlpc -ddump-opts t.hs
 ```
@@ -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
@@ -103,6 +104,7 @@ Listed in order of importance.
     - [ ] Actual compiler errors -- no more unexceptional `error` calls
     - [ ] Better CLI dump flags
     - [ ] Annotate the AST with token positions for errors
+- [ ] More examples
 
 ### March Release Plan
 - [ ] Tests

app/CoreDriver.hs

@@ -0,0 +1,17 @@
+module CoreDriver
+    ( driver
+    )
+    where
+--------------------------------------------------------------------------------
+import Compiler.RLPC
+import Control.Monad
+
+import Core.Lex
+import Core.Parse
+import GM
+--------------------------------------------------------------------------------
+
+driver :: RLPCIO ()
+driver = forFiles_ $ \f ->
+    withSource f (lexCoreR >=> parseCoreProgR >=> evalProgR)
+

app/Main.hs

@@ -10,12 +10,16 @@ import Data.HashSet             qualified as S
 import Data.Text                (Text)
 import Data.Text                qualified as T
 import Data.Text.IO             qualified as TIO
+import Data.List
 import System.IO
 import System.Exit              (exitSuccess)
 import Core
 import TI
 import GM
 import Lens.Micro.Mtl
+
+import CoreDriver               qualified
+import RlpDriver                qualified
 ----------------------------------------------------------------------------------
 
 optParser :: ParserInfo RLPCOptions
@@ -37,9 +41,15 @@ options = RLPCOptions
     {- -d -}
     <*> fmap S.fromList # many # option debugFlagReader
         (  short 'd'
-        <> help "dump evaluation logs"
+        <> help "pass debug flags"
         <> metavar "DEBUG FLAG"
         )
+    {- -f -}
+    <*> fmap S.fromList # many # option compilerFlagReader
+        (  short 'f'
+        <> help "pass compilation flags"
+        <> metavar "COMPILATION FLAG"
+        )
     {- --evaluator, -e -}
     <*> option evaluatorReader
         (  long "evaluator"
@@ -55,96 +65,45 @@ options = RLPCOptions
                 \triggering the garbage collector"
         <> value 50
         )
+    <*> option languageReader
+        (  long "language"
+        <> short 'x'
+        )
     <*> some (argument str $ metavar "FILES...")
     where
         infixr 9 #
         f # x = f x
 
+languageReader :: ReadM Language
+languageReader = maybeReader $ \case
+    "rlp"   -> Just LanguageRlp
+    "core"  -> Just LanguageCore
+    _       -> Nothing
+
+debugFlagReader :: ReadM DebugFlag
+debugFlagReader = str
+
+compilerFlagReader :: ReadM CompilerFlag
+compilerFlagReader = str
+
 evaluatorReader :: ReadM Evaluator
 evaluatorReader = maybeReader $ \case
     "gm"  -> Just EvaluatorGM
-    "tim" -> Just EvaluatorTI
+    "ti"  -> Just EvaluatorTI
     _     -> Nothing
 
 mmany :: (Alternative f, Monoid m) => f m -> f m
 mmany v = liftA2 (<>) v (mmany v)
 
-debugFlagReader :: ReadM DebugFlag
-debugFlagReader = maybeReader $ \case
-    "dump-eval"  -> Just DDumpEval
-    "dump-opts"  -> Just DDumpOpts
-    "dump-ast"   -> Just DDumpAST
-    _            -> Nothing
-
 ----------------------------------------------------------------------------------
 
--- temp
-data CompilerError = CompilerError String
-    deriving Show
-
-instance Exception CompilerError
-
 main :: IO ()
 main = do
     opts <- execParser optParser
-    (_, es) <- evalRLPCIO opts driver
-    forM_ es $ \ (CompilerError e) -> print $ "warning: " <> e
-    pure ()
+    void $ evalRLPCIO opts driver
 
-driver :: RLPCIO CompilerError ()
-driver = sequence_
-    [ dshowFlags
-    , ddumpAST
-    , ddumpEval
-    ]
-
-dshowFlags :: RLPCIO CompilerError ()
-dshowFlags = whenFlag flagDDumpOpts do
-    ask >>= liftIO . print
-
-ddumpAST :: RLPCIO CompilerError ()
-ddumpAST = whenFlag flagDDumpAST $ forFiles_ \o f -> do
-    liftIO $ withFile f ReadMode $ \h -> do
-        s <- TIO.hGetContents h
-        case parseProg o s of
-            Right (a,_) -> hPutStrLn stderr $ show a
-            Left e -> error "todo errors lol"
-
-ddumpEval :: RLPCIO CompilerError ()
-ddumpEval = whenFlag flagDDumpEval do
-    fs <- view rlpcInputFiles
-    forM_ fs $ \f -> liftIO (TIO.readFile f) >>= doProg
-
-    where
-        doProg :: Text -> RLPCIO CompilerError ()
-        doProg s = ask >>= \o -> case parseProg o s of
-            -- TODO: error handling
-            Left e -> addFatal . CompilerError $ show e
-            Right (a,_) -> do
-                log <- view rlpcLogFile
-                dumpEval <- chooseEval
-                case log of
-                    Just f  -> liftIO $ withFile f WriteMode $ dumpEval a
-                    Nothing -> liftIO $ dumpEval a stderr
-
-        -- choose the appropriate model based on the compiler opts
-        chooseEval = do
-            ev <- view rlpcEvaluator
-            pure $ case ev of
-                EvaluatorGM  -> v GM.hdbgProg
-                EvaluatorTI -> v TI.hdbgProg
-            where v f p h = f p h *> pure ()
-
-parseProg :: RLPCOptions
-          -> Text
-          -> Either SrcError (Program', [SrcError])
-parseProg o = evalRLPC o . (lexCore >=> parseCoreProg)
-
-forFiles_ :: (Monad m)
-          => (RLPCOptions -> FilePath -> RLPCT e m a)
-          -> RLPCT e m ()
-forFiles_ k = do
-    fs <- view rlpcInputFiles
-    o <- ask
-    forM_ fs (k o)
+driver :: RLPCIO ()
+driver = view rlpcLanguage >>= \case
+    LanguageCore -> CoreDriver.driver
+    LanguageRlp  -> RlpDriver.driver
 

app/RlpDriver.hs

@@ -0,0 +1,11 @@
+module RlpDriver
+    ( driver
+    )
+    where
+--------------------------------------------------------------------------------
+import Compiler.RLPC
+--------------------------------------------------------------------------------
+
+driver :: RLPCIO ()
+driver = undefined
+

rlp.cabal

@@ -7,7 +7,7 @@ license:            GPL-2.0-only
 -- license-file:       LICENSE
 author:             crumbtoo
 maintainer:         crumb@disroot.org
--- copyright:
+copyright:          Madeleine Sydney Ślaga
 category:           Language
 build-type:         Simple
 extra-doc-files:    README.md
@@ -37,8 +37,8 @@ library
                     , Rlp.Parse.Associate
                     , Rlp.Lex
                     , Rlp.Parse.Types
-
-    other-modules:    Data.Heap
+                    , Compiler.Types
+                    , Data.Heap
                     , Data.Pretty
                     , Core.Parse
                     , Core.Lex
@@ -48,7 +48,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 +69,26 @@ library
                     , data-fix >= 0.3.2 && < 0.4
                     , utf8-string >= 1.0.2 && < 1.1
                     , extra >= 1.7.0 && < 2
+                    , semigroupoids
+                    , comonad
+                    , lens
+                    , text-ansi
 
     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
+    other-modules:    RlpDriver
+                    , CoreDriver
+
+    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/RLPC.hs

@@ -11,64 +11,81 @@ errors and the family of RLPC monads.
 -- only used for mtl instances
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia #-}
+{-# LANGUAGE BlockArguments, ViewPatterns #-}
 module Compiler.RLPC
-    ( RLPC
-    , RLPCT(..)
-    , RLPCIO
-    , RLPCOptions(RLPCOptions)
-    , IsRlpcError(..)
-    , RlpcError(..)
-    , MsgEnvelope(..)
-    , addFatal
-    , addWound
-    , MonadErrorful
-    , Severity(..)
-    , Evaluator(..)
-    , evalRLPCT
-    , evalRLPCIO
-    , evalRLPC
-    , rlpcLogFile
-    , rlpcDebugOpts
-    , rlpcEvaluator
-    , rlpcInputFiles
-    , DebugFlag(..)
-    , whenFlag
-    , flagDDumpEval
-    , flagDDumpOpts
-    , flagDDumpAST
-    , def
-    , liftErrorful
+    (
+    -- * Rlpc Monad transformer
+      RLPCT(RLPCT),
+    -- ** Special cases
+      RLPC, RLPCIO
+    -- ** Running
+    , runRLPCT
+    , evalRLPCT, evalRLPCIO, evalRLPC
+    -- * Rlpc options
+    , Language(..), Evaluator(..)
+    , DebugFlag(..), CompilerFlag(..)
+    -- ** Lenses
+    , rlpcLogFile, rlpcDFlags, rlpcEvaluator, rlpcInputFiles, rlpcLanguage
+    -- * Misc. MTL-style functions
+    , liftErrorful, hoistRlpcT
+    -- * Misc. Rlpc Monad -related types
+    , RLPCOptions(RLPCOptions), IsRlpcError(..), RlpcError(..)
+    , MsgEnvelope(..), Severity(..)
+    , addDebugMsg
+    , whenDFlag, whenFFlag
+    -- * Misc. Utilities
+    , forFiles_, withSource
+    -- * Convenient re-exports
+    , addFatal, addWound, def
     )
     where
 ----------------------------------------------------------------------------------
 import Control.Arrow            ((>>>))
 import Control.Exception
+import Control.Monad
 import Control.Monad.Reader
 import Control.Monad.State      (MonadState(state))
 import Control.Monad.Errorful
+import Control.Monad.IO.Class
 import Compiler.RlpcError
+import Compiler.Types
 import Data.Functor.Identity
 import Data.Default.Class
 import Data.Foldable
 import GHC.Generics             (Generic)
+import Data.Maybe
 import Data.Hashable            (Hashable)
 import Data.HashSet             (HashSet)
 import Data.HashSet             qualified as S
 import Data.Coerce
-import Lens.Micro
-import Lens.Micro.TH
+import Data.Text                (Text)
+import Data.Text                qualified as T
+import Data.Text.IO             qualified as T
+import Text.ANSI                qualified as Ansi
+import Text.PrettyPrint         hiding ((<>))
+import Lens.Micro.Platform
+import Lens.Micro.Platform.Internal
 import System.Exit
 ----------------------------------------------------------------------------------
 
 newtype RLPCT m a = RLPCT {
         runRLPCT :: ReaderT RLPCOptions (ErrorfulT (MsgEnvelope RlpcError) m) a
     }
-    deriving (Functor, Applicative, Monad)
+    deriving ( Functor, Applicative, Monad
+             , MonadReader RLPCOptions, MonadErrorful (MsgEnvelope RlpcError))
+
+rlpc :: (IsRlpcError e, Monad m)
+     => (RLPCOptions -> (Maybe a, [MsgEnvelope e]))
+     -> RLPCT m a
+rlpc f = RLPCT . ReaderT $ \opt ->
+    ErrorfulT . pure $ f opt & _2 . each . mapped %~ liftRlpcError
 
 type RLPC = RLPCT Identity
 
 type RLPCIO = RLPCT IO
 
+instance (MonadIO m) => MonadIO (RLPCT m) where
+
 evalRLPC :: RLPCOptions
          -> RLPC a
          -> (Maybe a, [MsgEnvelope RlpcError])
@@ -76,31 +93,28 @@ evalRLPC opt r = runRLPCT r
                & flip runReaderT opt
                & runErrorful
 
-evalRLPCT :: (Monad m)
-          => RLPCOptions
+evalRLPCT :: RLPCOptions
           -> RLPCT m a
           -> m (Maybe a, [MsgEnvelope RlpcError])
-evalRLPCT = undefined
-
-evalRLPCIO :: RLPCOptions -> RLPCIO a -> IO a
-evalRLPCIO opt r = do
-    (ma,es) <- evalRLPCT opt r
-    putRlpcErrs es
-    case ma of
-        Just x  -> pure x
-        Nothing -> die "Failed, no code compiled."
-
-putRlpcErrs :: [MsgEnvelope RlpcError] -> IO ()
-putRlpcErrs = traverse_ print
+evalRLPCT opt r = runRLPCT r
+                & flip runReaderT opt
+                & runErrorfulT
 
 liftErrorful :: (Monad m, IsRlpcError e) => ErrorfulT (MsgEnvelope e) m a -> RLPCT m a
 liftErrorful e = RLPCT $ lift (fmap liftRlpcError `mapErrorful` e)
 
+hoistRlpcT :: (forall a. m a -> n a)
+         -> RLPCT m a -> RLPCT n a
+hoistRlpcT f rma = RLPCT $ ReaderT $ \opt ->
+    ErrorfulT $ f $ evalRLPCT opt rma
+
 data RLPCOptions = RLPCOptions
     { _rlpcLogFile     :: Maybe FilePath
-    , _rlpcDebugOpts   :: DebugOpts
+    , _rlpcDFlags      :: HashSet DebugFlag
+    , _rlpcFFlags      :: HashSet CompilerFlag
     , _rlpcEvaluator   :: Evaluator
     , _rlpcHeapTrigger :: Int
+    , _rlpcLanguage    :: Language
     , _rlpcInputFiles  :: [FilePath]
     }
     deriving Show
@@ -108,43 +122,117 @@ data RLPCOptions = RLPCOptions
 data Evaluator = EvaluatorGM | EvaluatorTI
     deriving Show
 
+data Language = LanguageRlp | LanguageCore
+    deriving Show
+
 ----------------------------------------------------------------------------------
 
 instance Default RLPCOptions where
     def = RLPCOptions
         { _rlpcLogFile = Nothing
-        , _rlpcDebugOpts = mempty
+        , _rlpcDFlags = mempty
+        , _rlpcFFlags = mempty
         , _rlpcEvaluator = EvaluatorGM
         , _rlpcHeapTrigger = 200
         , _rlpcInputFiles = []
+        , _rlpcLanguage = LanguageRlp
         }
 
-type DebugOpts = HashSet DebugFlag
+-- debug flags are passed with -dFLAG
+type DebugFlag = Text
 
-data DebugFlag = DDumpEval
-               | DDumpOpts
-               | DDumpAST
-               deriving (Show, Eq, Generic)
-
-instance Hashable DebugFlag
+type CompilerFlag = Text
 
 makeLenses ''RLPCOptions
 pure []
 
-whenFlag :: (MonadReader s m) => SimpleGetter s Bool -> m () -> m ()
-whenFlag l m = asks (^. l) >>= \a -> if a then m else pure ()
+addDebugMsg :: (Monad m, IsText e) => Text -> e -> RLPCT m ()
+addDebugMsg tag e = addWound . debugMsg tag $ Text [e ^. unpacked . packed]
 
--- there's probably a better way to write this. my current knowledge of lenses
--- is too weak.
-flagGetter :: DebugFlag -> SimpleGetter RLPCOptions Bool
-flagGetter d = to $ \s -> s ^. rlpcDebugOpts & S.member d
+-- TODO: rewrite this with prisms once microlens-pro drops :3
+whenDFlag :: (Monad m) => DebugFlag -> RLPCT m () -> RLPCT m ()
+whenDFlag f m = do
+    -- mfw no `At` instance for HashSet
+    fs <- view rlpcDFlags
+    let a = S.member f fs
+    when a m
 
-flagDDumpEval :: SimpleGetter RLPCOptions Bool
-flagDDumpEval = flagGetter DDumpEval
+whenFFlag :: (Monad m) => CompilerFlag -> RLPCT m () -> RLPCT m ()
+whenFFlag f m = do
+    -- mfw no `At` instance for HashSet
+    fs <- view rlpcFFlags
+    let a = S.member f fs
+    when a m
 
-flagDDumpOpts :: SimpleGetter RLPCOptions Bool
-flagDDumpOpts = flagGetter DDumpOpts
+--------------------------------------------------------------------------------
 
-flagDDumpAST :: SimpleGetter RLPCOptions Bool
-flagDDumpAST = flagGetter DDumpAST
+evalRLPCIO :: RLPCOptions -> RLPCIO a -> IO a
+evalRLPCIO opt r = do
+    (ma,es) <- evalRLPCT opt r
+    putRlpcErrs opt es
+    case ma of
+        Just x  -> pure x
+        Nothing -> die "Failed, no code compiled."
+
+putRlpcErrs :: RLPCOptions -> [MsgEnvelope RlpcError] -> IO ()
+putRlpcErrs opts = filter byTag
+               >>> traverse_ (putStrLn . ('\n':) . prettyRlpcMsg)
+    where
+        dflags = opts ^. rlpcDFlags
+
+        byTag :: MsgEnvelope RlpcError -> Bool
+        byTag (view msgSeverity -> SevDebug t) =
+            t `S.member` dflags
+
+prettyRlpcMsg :: MsgEnvelope RlpcError -> String
+prettyRlpcMsg m@(view msgSeverity -> SevDebug _) = prettyRlpcDebugMsg m
+prettyRlpcMsg m                                  = render $ docRlpcErr m
+
+prettyRlpcDebugMsg :: MsgEnvelope RlpcError -> String
+prettyRlpcDebugMsg msg =
+        T.unpack . foldMap mkLine $ [ t' | t <- ts, t' <- T.lines t ]
+    where
+        mkLine s = "-d" <> tag <> ": " <> s <> "\n"
+        Text ts = msg ^. msgDiagnostic
+        SevDebug tag = msg ^. msgSeverity
+
+docRlpcErr :: MsgEnvelope RlpcError -> Doc
+docRlpcErr msg = header
+                 $$ nest 2 bullets
+                 $$ source
+    where
+        source = vcat $ zipWith (<+>) rule srclines
+            where
+                rule = repeat (ttext . Ansi.blue . Ansi.bold $ "|")
+                srclines = ["", "<problematic source code>", ""]
+        filename = msgColour "<input>"
+        pos = msgColour $ tshow (msg ^. msgSpan . srcspanLine)
+                       <> ":"
+                       <> tshow (msg ^. msgSpan . srcspanColumn)
+
+        header = ttext $ filename <> msgColour ":" <> pos <> msgColour ": "
+                        <> errorColour "error" <> msgColour ":"
+
+        bullets = let Text ts = msg ^. msgDiagnostic
+                  in vcat $ hang "•" 2 . ttext . msgColour <$> ts
+
+        msgColour = Ansi.white . Ansi.bold
+        errorColour = Ansi.red . Ansi.bold
+        ttext = text . T.unpack
+        tshow :: (Show a) => a -> Text
+        tshow = T.pack . show
+
+--------------------------------------------------------------------------------
+
+forFiles_ :: (Monad m)
+          => (FilePath -> RLPCT m a)
+          -> RLPCT m ()
+forFiles_ k = do
+    fs <- view rlpcInputFiles
+    forM_ fs k
+
+-- TODO: catch any exceptions, i.e. non-existent files should be handled by the
+-- compiler
+withSource :: (MonadIO m) => FilePath -> (Text -> RLPCT m a) -> RLPCT m a
+withSource f k = liftIO (T.readFile f) >>= k
 

src/Compiler/RlpcError.hs

@@ -5,12 +5,15 @@ module Compiler.RlpcError
     , MsgEnvelope(..)
     , Severity(..)
     , RlpcError(..)
-    , SrcSpan(..)
     , msgSpan
     , msgDiagnostic
     , msgSeverity
     , liftRlpcErrors
     , errorMsg
+    , debugMsg
+    -- * Located Comonad
+    , Located(..)
+    , SrcSpan(..)
     )
     where
 ----------------------------------------------------------------------------------
@@ -20,6 +23,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
@@ -43,14 +47,9 @@ instance IsRlpcError RlpcError where
 
 data Severity = SevWarning
               | SevError
+              | SevDebug Text
               deriving Show
 
-data SrcSpan = SrcSpan
-    !Int -- ^ Line
-    !Int -- ^ Column
-    !Int -- ^ Length
-    deriving Show
-
 makeLenses ''MsgEnvelope
 
 liftRlpcErrors :: (Functor m, IsRlpcError e)
@@ -68,3 +67,11 @@ errorMsg s e = MsgEnvelope
     , _msgSeverity = SevError
     }
 
+debugMsg :: Text -> e -> MsgEnvelope e
+debugMsg tag e = MsgEnvelope
+    -- TODO: not pretty, but it is a debug message after all
+    { _msgSpan = SrcSpan 0 0 0 0
+    , _msgDiagnostic = e
+    , _msgSeverity = SevDebug tag
+    }
+

src/Compiler/Types.hs

@@ -0,0 +1,78 @@
+module Compiler.Types
+    ( SrcSpan(..)
+    , srcspanLine, srcspanColumn, srcspanAbs, srcspanLen
+    , Located(..)
+    , (<<~), (<~>)
+
+    -- * Re-exports
+    , Comonad
+    , Apply
+    , Bind
+    )
+    where
+--------------------------------------------------------------------------------
+import Control.Comonad
+import Data.Functor.Apply
+import Data.Functor.Bind
+import Control.Lens             hiding ((<<~))
+--------------------------------------------------------------------------------
+
+-- | 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
+
+tupling :: Iso' SrcSpan (Int, Int, Int, Int)
+tupling = iso (\ (SrcSpan a b c d) -> (a,b,c,d))
+              (\ (a,b,c,d) -> SrcSpan a b c d)
+
+srcspanLine, srcspanColumn, srcspanAbs, srcspanLen :: Lens' SrcSpan Int
+srcspanLine = tupling . _1
+srcspanColumn = tupling . _2
+srcspanAbs = tupling . _3
+srcspanLen = tupling . _4
+
+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/Control/Monad/Errorful.hs

@@ -1,11 +1,11 @@
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE TupleSections, PatternSynonyms #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE UndecidableInstances #-}
 module Control.Monad.Errorful
-    ( ErrorfulT
-    , runErrorfulT
+    ( ErrorfulT(..)
     , Errorful
+    , pattern Errorful
+    , errorful
     , runErrorful
     , mapErrorful
     , MonadErrorful(..)
@@ -13,6 +13,7 @@ module Control.Monad.Errorful
     where
 ----------------------------------------------------------------------------------
 import Control.Monad.State.Strict
+import Control.Monad.Reader
 import Control.Monad.Trans
 import Data.Functor.Identity
 import Data.Coerce
@@ -28,6 +29,9 @@ type Errorful e = ErrorfulT e Identity
 pattern Errorful :: (Maybe a, [e]) -> Errorful e a
 pattern Errorful a = ErrorfulT (Identity a)
 
+errorful :: (Applicative m) => (Maybe a, [e]) -> ErrorfulT e m a
+errorful = ErrorfulT . pure
+
 runErrorful :: Errorful e a -> (Maybe a, [e])
 runErrorful m = coerce (runErrorfulT m)
 
@@ -67,13 +71,13 @@ mapErrorful f (ErrorfulT m) = ErrorfulT $
     m & mapped . _2 . mapped %~ f
 
 -- when microlens-pro drops we can write this as
---    mapErrorful f = coerced . mapped . _2 . mappd %~ f
+--    mapErrorful f = coerced . mapped . _2 . mapped %~ f
 -- lol
 
 --------------------------------------------------------------------------------
 -- daily dose of n^2 instances
 
-instance (Monad m, MonadErrorful e m) => MonadErrorful e (StateT s m) where
-    addWound = undefined
-    addFatal = undefined
+instance (Monad m, MonadErrorful e m) => MonadErrorful e (ReaderT r m) where
+    addWound = lift . addWound
+    addFatal = lift . addFatal
 

src/Core/HindleyMilner.hs

@@ -105,7 +105,7 @@ checkCoreProg p = scDefs
              where scname = sc ^. _lhs._1
 
 -- | @checkCoreProgR p@ returns @p@ if @p@ successfully typechecks.
-checkCoreProgR :: Program' -> RLPC Program'
+checkCoreProgR :: (Applicative m) => Program' -> RLPCT m Program'
 checkCoreProgR p = undefined
 
 {-# WARNING checkCoreProgR "unimpl" #-}

src/Core/Lex.x

@@ -20,9 +20,11 @@ import Debug.Trace
 import Data.Text            (Text)
 import Data.Text            qualified as T
 import Data.String          (IsString(..))
+import Data.Functor.Identity
 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
 }
@@ -179,8 +181,11 @@ lexCore s = case m of
     where
         m = runAlex s lexStream
 
-lexCoreR :: Text -> RLPC [Located CoreToken]
-lexCoreR = lexCore
+lexCoreR :: forall m. (Applicative m) => Text -> RLPCT m [Located CoreToken]
+lexCoreR = hoistRlpcT generalise . lexCore
+    where
+        generalise :: forall a. Identity a -> m a
+        generalise (Identity a) = pure a
 
 -- | @lexCore@, but the tokens are stripped of location info. Useful for
 -- debugging

src/Core/Parse.y

@@ -17,9 +17,11 @@ module Core.Parse
 
 import Control.Monad        ((>=>))
 import Data.Foldable        (foldl')
+import Data.Functor.Identity
 import Core.Syntax
 import Core.Lex
 import Compiler.RLPC
+import Control.Monad
 import Lens.Micro
 import Data.Default.Class   (def)
 import Data.Hashable        (Hashable)
@@ -224,8 +226,16 @@ insScDef sc = programScDefs %~ (sc:)
 singletonScDef :: (Hashable b) => ScDef b -> Program b
 singletonScDef sc = insScDef sc mempty
 
-parseCoreProgR :: [Located CoreToken] -> RLPC Program'
-parseCoreProgR = parseCoreProg
+parseCoreProgR :: forall m. (Monad m) => [Located CoreToken] -> RLPCT m Program'
+parseCoreProgR = ddumpast <=< (hoistRlpcT generalise . parseCoreProg)
+    where
+        generalise :: forall a. Identity a -> m a
+        generalise (Identity a) = pure a
+
+        ddumpast :: Program' -> RLPCT m Program'
+        ddumpast p = do
+            addDebugMsg "dump-ast" . show $ p
+            pure p
 
 happyBind :: RLPC a -> (a -> RLPC b) -> RLPC b
 happyBind m k = m >>= k

src/Core/Syntax.hs

@@ -103,7 +103,7 @@ data Binding b = Binding b (Expr b)
 deriving instance (Eq b) => Eq (Binding b)
 
 infixl 1 :=
-pattern (:=) :: b -> (Expr b) -> (Binding b)
+pattern (:=) :: b -> Expr b -> Binding b
 pattern k := v = Binding k v
 
 data Alter b = Alter AltCon [b] (Expr b)
@@ -123,7 +123,7 @@ data AltCon = AltData Name
             | Default
             deriving (Show, Read, Eq, Lift)
 
-data Lit = IntL Int
+newtype Lit = IntL Int
     deriving (Show, Read, Eq, Lift)
 
 type Name = T.Text
@@ -201,7 +201,7 @@ instance HasLHS (Alter b) (Alter b) (AltCon, [b]) (AltCon, [b]) where
 instance HasLHS (ScDef b) (ScDef b) (b, [b]) (b, [b]) where
     _lhs = lens
         (\ (ScDef n as _) -> (n,as))
-        (\ (ScDef _ _ e) (n',as') -> (ScDef n' as' e))
+        (\ (ScDef _ _ e) (n',as') -> ScDef n' as' e)
 
 instance HasLHS (Binding b) (Binding b) b b where
     _lhs = lens

src/GM.hs

@@ -8,6 +8,7 @@ Description : The G-Machine
 module GM
     ( hdbgProg
     , evalProg
+    , evalProgR
     , Node(..)
     , gmEvalProg
     , finalStateOf
@@ -34,6 +35,7 @@ import System.IO                    (Handle, hPutStrLn)
 import Data.String                  (IsString)
 import Data.Heap
 import Debug.Trace
+import Compiler.RLPC
 import Core2Core
 import Core
 ----------------------------------------------------------------------------------
@@ -156,6 +158,21 @@ hdbgProg p hio = do
         [resAddr] = final ^. gmStack
         res = hLookupUnsafe resAddr h
 
+evalProgR :: (Monad m) => Program' -> RLPCT m (Node, Stats)
+evalProgR p = do
+    (renderOut . showState) `traverse_` states
+    renderOut . showStats $ sts
+    pure (res, sts)
+    where
+        renderOut r = addDebugMsg "dump-eval" $ render r ++ "\n"
+        states = eval . compile $ p
+        final = last states
+
+        sts = final ^. gmStats
+        -- the address of the result should be the one and only stack entry
+        [resAddr] = final ^. gmStack
+        res = hLookupUnsafe resAddr (final ^. gmHeap)
+
 eval :: GmState -> [GmState]
 eval st = st : rest
     where

src/Rlp/Lex.x

@@ -10,6 +10,9 @@ module Rlp.Lex
     , lexStream
     , lexDebug
     , lexCont
+    , popLexState
+    , programInitState
+    , runP'
     )
     where
 import Codec.Binary.UTF8.String (encodeChar)
@@ -57,7 +60,7 @@ $asciisym       = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]
     |infixr|infixl|infix
 
 @reservedop =
-    "=" | \\ | "->" | "|"
+    "=" | \\ | "->" | "|" | "::"
 
 rlp :-
     
@@ -73,6 +76,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 +124,14 @@ $white_no_nl+       ;
     ()                  { doBol }
 }
 
+<layout_let>
+{
+    \n                  { beginPush bol }
+    "{"                 { explicitLBrace }
+    "in"                { constToken TokenIn `thenDo` (popLexState *> popLayout) }
+    ()                  { doLayout }
+}
+
 <layout_top>
 {
     \n                  ;
@@ -144,6 +166,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 +192,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)
-                                   else (ln,col+1)
+                                   then (ln+1, 1, a+1)
+                                   else (ln, col+1, a+1)
         pure (b, inp')
     
     _ -> Just (head bs, inp')
@@ -187,19 +215,19 @@ pushLexState :: Int -> P ()
 pushLexState n = psLexState %= (n:)
 
 readInt :: Text -> Int
-readInt = T.foldr f 0 where
-    f c n = digitToInt c + 10*n
+readInt = T.foldl f 0 where
+    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,29 +235,12 @@ getPos = use (psInput . aiPos)
 alexEOF :: P (Located RlpToken)
 alexEOF = do
     inp <- getInput
-    pure (Located undefined TokenEOF)
-
-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)
-    }
+    pos <- getPos
+    pure (Located (spanFromPos pos 0) TokenEOF)
 
 runP' :: P a -> Text -> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
 runP' p s = runP p st where
-    st = initParseState s
+    st = initParseState [layout_top,0] s
 
 lexToken :: P (Located RlpToken)
 lexToken = do
@@ -238,7 +249,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 +285,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
@@ -283,7 +294,7 @@ popLayout = do
     psLayoutStack %= (drop 1)
     case ctx of
         Just l      -> pure l
-        Nothing     -> error "uhh"
+        Nothing     -> error "popLayout: layout stack empty! this is a bug."
 
 pushLayout :: Layout -> P ()
 pushLayout l = do
@@ -341,9 +352,13 @@ explicitRBrace inp l = do
 doLayout :: LexerAction (Located RlpToken)
 doLayout _ _ = do
     i <- indentLevel
+    -- traceM $ "doLayout: i: " <> show i
     pushLayout (Implicit i)
     popLexState
     insertLBrace
 
+programInitState :: Text -> ParseState
+programInitState = initParseState [layout_top,0]
+
 }
 

src/Rlp/Parse.y

@@ -1,39 +1,51 @@
 {
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase, ViewPatterns #-}
 module Rlp.Parse
     ( parseRlpProg
+    , parseRlpProgR
+    , parseRlpExpr
+    , parseRlpExprR
     )
     where
 import Compiler.RlpcError
+import Compiler.RLPC
 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 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                    (Text)
 import Data.Text                    qualified as T
+import Data.Void
 }
 
 %name parseRlpProg StandaloneProgram
+%name parseRlpExpr StandaloneExpr
 
 %monad { P }
 %lexer { lexCont } { Located _ TokenEOF }
 %error { parseError }
+%errorhandlertype explist
 %tokentype { Located RlpToken }
 
 %token
-    varname         { Located _ (TokenVarName $$) }
-    conname         { Located _ (TokenConName $$) }
-    consym          { Located _ (TokenConSym $$) }
-    varsym          { Located _ (TokenVarSym $$) }
+    varname         { Located _ (TokenVarName _) }
+    conname         { Located _ (TokenConName _) }
+    consym          { Located _ (TokenConSym _) }
+    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 +58,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,111 +81,150 @@ 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] }
+                    | {- epsilon -}         { [] }
 
 VS                  :: { Located RlpToken }
 VS                  : ';'                   { $1 }
                     | vsemi                 { $1 }
 
-Decl        :: { PartialDecl' }
+Decl        :: { Decl' RlpcPs }
             : FunDecl                   { $1 }
+            | TySigDecl                 { $1 }
             | DataDecl                  { $1 }
             | InfixDecl                 { $1 }
 
-InfixDecl   :: { PartialDecl' }
-            : InfixWord litint InfixOp  {% mkInfixD $1 $2 $3 }
+TySigDecl   :: { Decl' RlpcPs }
+            : Var '::' Type             { (\e -> TySigD [extract e]) <<~ $1 <~> $3 }
 
-InfixWord   :: { Assoc }
-            : infixl                    { InfixL }
-            | infixr                    { InfixR }
-            | infix                     { Infix  }
+InfixDecl   :: { Decl' RlpcPs }
+            : InfixWord litint InfixOp  { $1 =>> \w ->
+                                          InfixD (extract $1) (extractInt $ extract $2)
+                                          (extract $3) }
 
-DataDecl    :: { PartialDecl' }
-            : data Con TyParams '=' DataCons    { DataD $2 $3 $5 }
+InfixWord   :: { Located Assoc }
+            : 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 }
-            : Con Type1s                { ConAlt $1 $2 }
+DataCon     :: { ConAlt RlpcPs }
+            : 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 }
-            | varname                   { TyVar $1 }
+            | conname                   { fmap ConT (mkPsName $1) }
+            | varname                   { fmap VarT (mkPsName $1) }
 
-Type        :: { Type }
-            : Type '->' Type            { $1 :-> $3 }
+Type        :: { RlpType' RlpcPs }
+            : Type '->' Type            { FunT <<~ $1 <~> $3 }
             | Type1                     { $1 }
 
-FunDecl     :: { PartialDecl' }
-FunDecl     : Var Params '=' Expr       { FunD $1 $2 (Const $4) Nothing }
+FunDecl     :: { Decl' RlpcPs }
+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' }
-            : Var                       { VarP $1 }
-            | Lit                       { LitP $1 }
+Pat1        :: { Pat' RlpcPs }
+            : Var                       { fmap VarP $1 }
+            | Lit                       { LitP <<= $1 }
 
-Expr        :: { PartialExpr' }
-            : Expr1 varsym Expr         { Fix $ B $2 (unFix $1) (unFix $3) }
+Expr        :: { RlpExpr' RlpcPs }
+            : Expr1 InfixOp Expr        { $2 =>> \o ->
+                                          OAppE (extract o) $1 $3 }
             | Expr1                     { $1 }
+            | LetExpr                   { $1 }
 
-Expr1       :: { PartialExpr' }
-            : '(' Expr ')'              { wrapFix . Par . unwrapFix $ $2 }
-            | Lit                       { Fix . E $ LitEF $1 }
-            | Var                       { Fix . E $ VarEF $1 }
+LetExpr     :: { RlpExpr' RlpcPs }
+            : let layout1(Binding) in Expr { $1 \$> LetE $2 $4 }
 
--- 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) }
+layout1(p)  : '{' layout_list1(';',p) '}'   { $2 }
+            | VL  layout_list1(VS,p) VR     { $2 }
 
-InfixOp     :: { Name }
-            : consym                    { $1 }
-            | varsym                    { $1 }
+layout_list1(sep,p) : p                          { [$1] }
+                    | layout_list1(sep,p) sep p  { $1 `snoc` $3 }
 
-Lit         :: { Lit' }
-Lit         : litint                    { IntL $1 }
+Binding     :: { Binding' RlpcPs }
+            : Pat1 '=' Expr              { PatB <<~ $1 <~> $3 }
 
-Var         :: { VarId }
-Var         : varname                   { NameVar $1 }
+Expr1       :: { RlpExpr' RlpcPs }
+            : '(' Expr ')'              { $1 .> $2 <. $3 }
+            | Lit                       { fmap LitE $1 }
+            | Var                       { fmap VarE $1 }
 
-Con         :: { ConId }
-            : conname                   { NameCon $1 }
+InfixOp     :: { Located PsName }
+            : 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'
+parseRlpExprR = undefined
+
+parseRlpProgR :: (Monad m) => Text -> RLPCT m (RlpProgram RlpcPs)
+parseRlpProgR s = liftErrorful $ pToErrorful parseRlpProg st
+    where
+        st = programInitState s
+
+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 $
-    errorMsg (SrcSpan l c s) RlpParErrUnexpectedToken
+parseError :: (Located RlpToken, [String]) -> P a
+parseError ((Located ss t), exp) = addFatal $
+    errorMsg ss (RlpParErrUnexpectedToken t exp)
 
-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 +234,11 @@ 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 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))
-    ]
-
+associate x y = y
+{-# WARNING associate "temporarily undefined" #-}
 

src/Rlp/Parse/Types.hs

@@ -2,38 +2,28 @@
 {-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
 {-# LANGUAGE LambdaCase #-}
 module Rlp.Parse.Types
-    ( LexerAction
-    , MsgEnvelope(..)
-    , RlpcError(..)
-    , AlexInput(..)
-    , Position(..)
-    , RlpToken(..)
-    , P(..)
-    , ParseState(..)
-    , psLayoutStack
-    , psLexState
-    , psInput
-    , psOpTable
-    , Layout(..)
-    , Located(..)
-    , OpTable
-    , OpInfo
-    , RlpParseError(..)
-    , PartialDecl'
-    , Partial(..)
-    , pL, pR
-    , PartialE
-    , pattern WithInfo
-    , opInfoOrDef
-    , PartialExpr'
-    , aiPrevChar
-    , aiSource
-    , aiBytes
-    , aiPos
-    , addFatal
-    , addWound
-    , addFatalHere
-    , addWoundHere
+    (
+    -- * Trees That Grow
+      RlpcPs
+
+    -- * Parser monad and state
+    , P(..), ParseState(..), Layout(..), OpTable, OpInfo
+    , initParseState, initAlexInput
+    , pToErrorful
+    -- ** Lenses
+    , psLayoutStack, psLexState, psInput, psOpTable
+
+    -- * Other parser types
+    , RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction
+    , Located(..), PsName
+    -- ** Lenses
+    , aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn
+
+    , (<<~), (<~>)
+
+    -- * Error handling
+    , MsgEnvelope(..), RlpcError(..), RlpParseError(..)
+    , addFatal, addWound, addFatalHere, addWoundHere
     )
     where
 --------------------------------------------------------------------------------
@@ -49,12 +39,47 @@ 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 Data.Text                    qualified as T
 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 +91,9 @@ data AlexInput = AlexInput
     deriving Show
 
 type Position =
-    ( Int -- line
-    , Int -- column
+    ( Int -- ^ line
+    , Int -- ^ column
+    , Int -- ^ Absolutely
     )
 
 posLine :: Lens' Position Int
@@ -76,6 +102,9 @@ posLine = _1
 posColumn :: Lens' Position Int
 posColumn = _2
 
+posAbsolute :: Lens' Position Int
+posAbsolute = _3
+
 data RlpToken
     -- literals
     = TokenLitInt Int
@@ -106,7 +135,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
@@ -119,6 +148,11 @@ newtype P a = P {
     }
     deriving (Functor)
 
+pToErrorful :: (Applicative m)
+            => P a -> ParseState -> ErrorfulT (MsgEnvelope RlpParseError) m a
+pToErrorful p st = ErrorfulT $ pure (ma,es) where
+    (_,es,ma) = runP p st
+
 instance Applicative P where
     pure a = P $ \st -> (st, [], pure a)
     liftA2 = liftM2
@@ -154,9 +188,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)
 
@@ -165,53 +196,30 @@ type OpInfo = (Assoc, Int)
 data RlpParseError = RlpParErrOutOfBoundsPrecedence Int
                    | RlpParErrDuplicateInfixD Name
                    | RlpParErrLexical
-                   | RlpParErrUnexpectedToken
-                   deriving (Eq, Ord, Show)
+                   | RlpParErrUnexpectedToken RlpToken [String]
+                   deriving (Show)
 
 instance IsRlpcError RlpParseError where
+    liftRlpcError = \case
+        RlpParErrOutOfBoundsPrecedence n ->
+            Text [ "Illegal precedence in infixity declaration"
+                 , "rl' currently only allows precedences between 0 and 9."
+                 ]
+        RlpParErrDuplicateInfixD s ->
+            Text [ "Conflicting infixity declarations for operator "
+                    <> tshow s
+                 ]
+        RlpParErrLexical ->
+            Text [ "Unknown lexical error :(" ]
+        RlpParErrUnexpectedToken t exp ->
+            Text [ "Unexpected token " <> tshow t
+                 , "Expected: " <> tshow exp
+                 ]
+        where
+            tshow :: (Show a) => a -> T.Text
+            tshow = T.pack . 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
@@ -221,8 +229,9 @@ addWoundHere l e = P $ \st ->
     let e' = MsgEnvelope
             { _msgSpan = let pos = psInput . aiPos
                          in SrcSpan (st ^. pos . posLine)
-                                   (st ^. pos . posColumn)
-                                   l
+                                    (st ^. pos . posColumn)
+                                    (st ^. pos . posAbsolute)
+                                    l
             , _msgDiagnostic = e
             , _msgSeverity = SevError
             }
@@ -234,9 +243,28 @@ 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
             }
     in (st, [e'], Nothing)
 
+initParseState :: [Int] -> Text -> ParseState
+initParseState ls 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 = ls
+    , _psInput = initAlexInput s
+    , _psOpTable = mempty
+    }
+
+initAlexInput :: Text -> AlexInput
+initAlexInput s = AlexInput
+    { _aiPrevChar   = '\0'
+    , _aiSource     = s
+    , _aiBytes      = []
+    , _aiPos        = (1,1,0)
+    }
+

src/Rlp/Syntax.hs

@@ -1,40 +1,36 @@
 -- recursion-schemes
-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
--- recursion-schemes
-{-# LANGUAGE TemplateHaskell, TypeFamilies #-}
+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable
+  , TemplateHaskell, TypeFamilies #-}
 {-# LANGUAGE OverloadedStrings, PatternSynonyms #-}
+{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}
+{-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-}
 module Rlp.Syntax
-    ( RlpModule(..)
-    , RlpProgram(..)
-    , RlpProgram'
-    , rlpmodName
-    , rlpmodProgram
-    , RlpExpr(..)
-    , RlpExpr'
-    , RlpExprF(..)
-    , RlpExprF'
-    , Decl(..)
-    , Decl'
-    , Bind(..)
-    , Where
-    , Where'
-    , ConAlt(..)
-    , Type(..)
-    , pattern (:->)
+    (
+    -- * AST
+      RlpProgram(..)
+    , Decl(..), Decl', RlpExpr(..), RlpExpr'
+    , Pat(..), Pat'
     , Assoc(..)
-    , VarId(..)
-    , ConId(..)
-    , Pat(..)
-    , Pat'
-    , Lit(..)
-    , Lit'
-    , Name
+    , Lit(..), Lit'
+    , RlpType(..), RlpType'
+    , ConAlt(..)
+    , Binding(..), Binding'
 
-    -- TODO: ugh move this somewhere else later
-    , showsTernaryWith
-
-    -- * Convenience re-exports
-    , Text
+    -- * Trees That Grow boilerplate
+    -- ** Extension points
+    , IdP, XRec, UnXRec(..), MapXRec(..)
+    -- *** Decl
+    , 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]
-    deriving Show
+-- | dear god.
+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
--- 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]@.
+deriving instance (PhaseShow p, Show (XRec p Decl)) => Show (RlpProgram p)
 
-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
+data RlpType p = FunConT
+               | FunT (RlpType' p) (RlpType' p)
+               | AppT (RlpType' p) (RlpType' p)
+               | VarT (IdP p)
+               | 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]
-            deriving Show
+data ConAlt p = ConAlt (IdP p) [RlpType' p]
 
-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
+deriving instance (Show (IdP p), Show (XRec p RlpType)) => Show (ConAlt p)
 
-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 Where' = [Bind Name]
+type family XLetE p
+type family XVarE p
+type family XLamE p
+type family XCaseE p
+type family XIfE p
+type family XAppE p
+type family XLitE p
+type family XParE p
+type family XOAppE p
+type family XXRlpExprE p
+
+pattern LetE :: (XLetE p ~ ()) => [Binding' p] -> RlpExpr' p -> RlpExpr p
+pattern 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)
-           deriving Show
+data Alt p = AltA (Pat' p) (RlpExpr' p)
 
-data Bind b = PatB (Pat b) (RlpExpr b)
-            | FunB VarId [Pat b] (RlpExpr b)
-            deriving Show
+deriving instance (PhaseShow p) => Show (Alt p)
 
-data VarId = NameVar Text
-           | SymVar Text
-           deriving Show
+data Binding p = PatB (Pat' p) (RlpExpr' p)
+               | FunB (IdP p) [Pat' p] (RlpExpr' p)
 
-instance IsString VarId where
-    -- TODO: use symvar if it's an operator
-    fromString = NameVar . T.pack
+type Binding' p = XRec p Binding
 
-data ConId = NameCon Text
-           | SymCon Text
-           deriving Show
+deriving instance (Show (XRec p Pat), Show (XRec p RlpExpr), Show (IdP p)
+                  ) => Show (Binding p)
 
-data Pat b = VarP VarId
-           | LitP (Lit b)
-           | ConP ConId [Pat b]
-           deriving Show
+data Pat p = VarP (IdP p)
+           | LitP (Lit' p)
+           | ConP (IdP p) [Pat' p]
 
-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]
-           deriving Show
+           | ListL [RlpExpr' p]
 
-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)
-
-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
+-- 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
 
 --------------------------------------------------------------------------------