good enough

HasLocation

app/Main.hs

@@ -74,11 +74,6 @@ options = RLPCOptions
         <> metavar "rlp|core"
         <> help "the language to be compiled -- see README"
         )
-    <*> flag False True
-        (  long "render"
-        <> short 'r'
-        <> help "render a diagram of each GM state"
-        )
     <*> some (argument str $ metavar "FILES...")
     where
         infixr 9 #

rlp.cabal

@@ -22,9 +22,6 @@ library
     exposed-modules:  Core
                     , TI
                     , GM
-                    , GM.Visual
-                    , GM.Types
-                    , GM.Print
                     , Compiler.RLPC
                     , Compiler.RlpcError
                     , Compiler.JustRun
@@ -35,6 +32,8 @@ library
                     , Core.HindleyMilner
                     , Control.Monad.Errorful
                     , Rlp.Syntax
+                    , Rlp.Syntax.Backstage
+                    , Rlp.Syntax.Types
                     -- , Rlp.Parse.Decls
                     , Rlp.Parse
                     , Rlp.Parse.Associate
@@ -76,9 +75,7 @@ library
                     , effectful-core ^>=2.3.0.0
                     , deriving-compat ^>=0.6.0
                     , these >=0.2 && <2.0
-                    , diagrams
+                    , free >=5.2
-                    , diagrams-lib
-                    , diagrams-cairo
 
     hs-source-dirs:   src
     default-language: GHC2021
@@ -122,8 +119,10 @@ test-suite rlp-test
                  , QuickCheck
                  , hspec            ==2.*
                  , microlens
+                 , lens >=5.2.3 && <6.0
     other-modules: Arith
                  , GMSpec
                  , Core.HindleyMilnerSpec
+                 , Compiler.TypesSpec
     build-tool-depends: hspec-discover:hspec-discover
 

src/Compiler/RLPC.hs

@@ -120,7 +120,6 @@ data RLPCOptions = RLPCOptions
     , _rlpcEvaluator   :: Evaluator
     , _rlpcHeapTrigger :: Int
     , _rlpcLanguage    :: Maybe Language
-    , _rlpcRender      :: Bool
     , _rlpcInputFiles  :: [FilePath]
     }
     deriving Show
@@ -142,7 +141,6 @@ instance Default RLPCOptions where
         , _rlpcHeapTrigger = 200
         , _rlpcInputFiles = []
         , _rlpcLanguage = Nothing
-        , _rlpcRender = False
         }
 
 -- debug flags are passed with -dFLAG
@@ -222,9 +220,9 @@ docRlpcErr msg = header
                 rule = repeat (ttext . Ansi.blue . Ansi.bold $ "|")
                 srclines = ["", "<problematic source code>", ""]
         filename = msgColour "<input>"
-        pos = msgColour $ tshow (msg ^. msgSpan . srcspanLine)
+        pos = msgColour $ tshow (msg ^. msgSpan . srcSpanLine)
                        <> ":"
-                       <> tshow (msg ^. msgSpan . srcspanColumn)
+                       <> tshow (msg ^. msgSpan . srcSpanColumn)
 
         header = ttext $ filename <> msgColour ":" <> pos <> msgColour ": "
                         <> errorColour "error" <> msgColour ":"

src/Compiler/Types.hs

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

src/GM.hs

@@ -11,11 +11,6 @@ module GM
     , evalProgR
     , GmState(..)
     , gmCode, gmStack, gmDump, gmHeap, gmEnv, gmStats
-    , stsReductions
-    , stsPrimReductions
-    , stsAllocations
-    , stsDereferences
-    , stsGCCycles
     , Node(..)
     , showState
     , gmEvalProg
@@ -34,9 +29,10 @@ import Data.Tuple                   (swap)
 import Control.Lens
 import Data.Text.Lens               (IsText, packed, unpacked)
 import Text.Printf
+import Text.PrettyPrint             hiding ((<>))
+import Text.PrettyPrint.HughesPJ    (maybeParens)
 import Data.Foldable                (traverse_)
 import System.IO                    (Handle, hPutStrLn)
-import Text.PrettyPrint             (render)
 -- TODO: an actual output system
 -- TODO: an actual output system
 -- TODO: an actual output system
@@ -45,12 +41,9 @@ import System.IO.Unsafe             (unsafePerformIO)
 import Data.String                  (IsString)
 import Data.Heap
 import Debug.Trace
-
 import Compiler.RLPC
 import Core2Core
 import Core
-import GM.Types
-import GM.Print
 ----------------------------------------------------------------------------------
 
 tag_Unit_unit :: Int
@@ -62,19 +55,105 @@ tag_Bool_True = 1
 tag_Bool_False :: Int
 tag_Bool_False = 0
 
+{-}
+
+hdbgProg = undefined
+evalProg = undefined
+
+data Node = NNum Int
+          | NAp Addr Addr
+          | NInd Addr
+          | NUninitialised
+          | NConstr Tag [Addr] -- NConstr Tag Components
+          | NMarked Node
+          deriving (Show, Eq)
+
+--}
+
+data GmState = GmState
+    { _gmCode   :: Code
+    , _gmStack  :: Stack
+    , _gmDump   :: Dump
+    , _gmHeap   :: GmHeap
+    , _gmEnv    :: Env
+    , _gmStats  :: Stats
+    }
+    deriving Show
+
+type Code = [Instr]
+type Stack = [Addr]
+type Dump = [(Code, Stack)]
+type Env = [(Key, Addr)]
+type GmHeap = Heap Node
+
+data Key = NameKey Name
+         | ConstrKey Tag Int
+         deriving (Show, Eq)
+
+-- >> [ref/Instr]
+data Instr = Unwind
+           | PushGlobal Name
+           | PushConstr Tag Int
+           | PushInt Int
+           | Push Int
+           | MkAp
+           | Slide Int
+           | Update Int
+           | Pop Int
+           | Alloc Int
+           | Eval
+           -- arith
+           | Neg | Add | Sub | Mul | Div
+           -- comparison
+           | Equals | Lesser | GreaterEq
+           | Pack Tag Int -- Pack Tag Arity
+           | CaseJump [(Tag, Code)]
+           | Split Int
+           | Print
+           | Halt
+           deriving (Show, Eq)
+-- << [ref/Instr]
+
+data Node = NNum Int
+          | NAp Addr Addr
+          -- NGlobal is the GM equivalent of NSupercomb. rather than storing a
+          -- template to be instantiated, NGlobal holds the global's arity and
+          -- the pre-compiled code :3
+          | NGlobal Int Code
+          | NInd Addr
+          | NUninitialised
+          | NConstr Tag [Addr] -- NConstr Tag Components
+          | NMarked Node
+          deriving (Show, Eq)
+
+-- TODO: log executed instructions
+data Stats = Stats
+    { _stsReductions     :: Int
+    , _stsPrimReductions :: Int
+    , _stsAllocations    :: Int
+    , _stsDereferences   :: Int
+    , _stsGCCycles       :: Int
+    }
+    deriving Show
+
+instance Default Stats where
+    def = Stats 0 0 0 0 0
+
+-- TODO: _gmGlobals should not have a setter
+makeLenses ''GmState
+makeLenses ''Stats
+pure []
+
 ----------------------------------------------------------------------------------
 
-evalProg :: Program' -> [GmState]
+evalProg :: Program' -> Maybe (Node, Stats)
-evalProg = eval . compile
+evalProg p = res <&> (,sts)
-
+    where
--- evalProg :: Program' -> Maybe (Node, Stats)
+        final = eval (compile p) & last
--- evalProg p = res <&> (,sts)
+        h = final ^. gmHeap
---     where
+        sts = final ^. gmStats
---         final = eval (compile p) & last
+        resAddr = final ^. gmStack ^? _head
---         h = final ^. gmHeap
+        res = resAddr >>= flip hLookup h
---         sts = final ^. gmStats
---         resAddr = final ^. gmStack ^? _head
---         res = resAddr >>= flip hLookup h
 
 hdbgProg :: Program' -> Handle -> IO GmState
 hdbgProg p hio = do
@@ -736,8 +815,185 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
         argOffset :: Int -> Env -> Env
         argOffset n = each . _2 %~ (+n)
 
+showCon :: (IsText a) => Tag -> Int -> a
+showCon t n = printf "Pack{%d %d}" t n ^. packed
+
 ----------------------------------------------------------------------------------
 
+pprTabstop :: Int
+pprTabstop = 4
+
+qquotes :: Doc -> Doc
+qquotes d = "`" <> d <> "'"
+
+showStats :: Stats -> Doc
+showStats sts = "==== Stats ============" $$ stats
+    where
+        stats = text $ printf
+            "Reductions      : %5d\n\
+            \Prim Reductions : %5d\n\
+            \Allocations     : %5d\n\
+            \GC Cycles       : %5d"
+            (sts ^. stsReductions)
+            (sts ^. stsPrimReductions)
+            (sts ^. stsAllocations)
+            (sts ^. stsGCCycles)
+
+showState :: GmState -> Doc
+showState st = vcat
+        [ "==== GmState " <> int stnum <> " "
+            <> text (replicate (28 - 13 - 1 - digitalWidth stnum) '=')
+        , "-- Next instructions -------"
+        , info $ showCodeShort c
+        , "-- Stack -------------------"
+        , info $ showStack st
+        , "-- Heap --------------------"
+        , info $ showHeap st
+        , "-- Dump --------------------"
+        , info $ showDump st
+        ]
+    where
+        stnum = st ^. (gmStats . stsReductions)
+        c = st ^. gmCode
+
+        -- indent data
+        info = nest pprTabstop
+
+showCodeShort :: Code -> Doc
+showCodeShort c = braces c'
+    where
+        c' | length c > 3 = list (showInstr <$> take 3 c) <> "; ..."
+           | otherwise    = list (showInstr <$> c)
+        list = hcat . punctuate "; "
+
+showStackShort :: Stack -> Doc
+showStackShort s = brackets s'
+    where
+           -- no access to heap, otherwise we'd use showNodeAt
+        s' | length s > 3 = list (showEntry <$> take 3 s) <> ", ..."
+           | otherwise    = list (showEntry <$> s)
+        list = hcat . punctuate ", "
+        showEntry = text . show
+
+showStack :: GmState -> Doc
+showStack st = vcat $ uncurry showEntry <$> si
+    where
+        h = st ^. gmHeap
+        s = st ^. gmStack
+
+        -- stack with labeled indices
+        si = [0..] `zip` s
+
+        w = maxWidth (addresses h)
+        showIndex n = padInt w n <> ": "
+
+        showEntry :: Int -> Addr -> Doc
+        showEntry n a = showIndex n <> showNodeAt st a
+
+showDump :: GmState -> Doc
+showDump st = vcat $ uncurry showEntry <$> di
+    where
+        d = st ^. gmDump
+        di = [0..] `zip` d
+
+        showIndex n = padInt w n <> ": "
+        w = maxWidth (fst <$> di)
+
+        showEntry :: Int -> (Code, Stack) -> Doc
+        showEntry n (c,s) = showIndex n <> nest pprTabstop entry
+            where
+                entry = ("Stack : " <> showCodeShort c)
+                     $$ ("Code  : " <> showStackShort s)
+
+padInt :: Int -> Int -> Doc
+padInt m n = text (replicate (m - digitalWidth n) ' ') <> int n
+
+maxWidth :: [Int] -> Int
+maxWidth ns = digitalWidth $ maximum ns
+
+digitalWidth :: Int -> Int
+digitalWidth = length . show
+
+showHeap :: GmState -> Doc
+showHeap st = vcat $ showEntry <$> addrs
+    where
+        showAddr n = padInt w n <> ": "
+
+        w = maxWidth addrs
+        h = st ^. gmHeap
+        addrs = addresses h
+
+        showEntry :: Addr -> Doc
+        showEntry a = showAddr a <> showNodeAt st a
+
+showNodeAt :: GmState -> Addr -> Doc
+showNodeAt = showNodeAtP 0
+
+showNodeAtP :: Int -> GmState -> Addr -> Doc
+showNodeAtP p st a = case hLookup a h of
+    Just (NNum n)        -> int n <> "#"
+    Just (NGlobal _ _)   -> textt name
+        where
+            g = st ^. gmEnv
+            name = case lookup a (swap <$> g) of
+                Just (NameKey n)     -> n
+                Just (ConstrKey t n) -> showCon t n
+                _                    -> errTxtInvalidAddress
+    -- TODO: left-associativity
+    Just (NAp f x)       -> pprec $ showNodeAtP (p+1) st f
+                                <+> showNodeAtP (p+1) st x
+    Just (NInd a')       -> pprec $ "NInd -> " <> showNodeAtP (p+1) st a'
+    Just (NConstr t as)  -> pprec $ "NConstr"
+                                <+> int t
+                                <+> brackets (list $ showNodeAtP 0 st <$> as)
+        where list = hcat . punctuate ", "
+    Just NUninitialised  -> "<uninitialised>"
+    Nothing              -> errTxtInvalidAddress
+    where
+        h = st ^. gmHeap
+        pprec = maybeParens (p > 0)
+
+showSc :: GmState -> (Name, Addr) -> Doc
+showSc st (k,a) = "Supercomb " <> qquotes (textt k) <> colon
+               $$ code
+    where
+        code = case hLookup a (st ^. gmHeap) of
+            Just (NGlobal _ c) -> showCode c
+            Just _             -> errTxtInvalidObject
+            Nothing            -> errTxtInvalidAddress
+
+errTxtInvalidObject, errTxtInvalidAddress :: (IsString a) => a
+errTxtInvalidObject = "<invalid object>"
+errTxtInvalidAddress = "<invalid address>"
+
+showCode :: Code -> Doc
+showCode c = "Code" <+> braces instrs
+    where instrs = vcat $ showInstr <$> c
+
+showInstr :: Instr -> Doc
+showInstr (CaseJump alts) = "CaseJump" $$ nest pprTabstop alternatives
+    where
+        showAlt (t,c) = "<" <> int t <> ">" <> showCodeShort c
+        alternatives = foldr (\a acc -> showAlt a $$ acc) mempty alts
+showInstr i = text $ show i
+
+textt :: (IsText a) => a -> Doc
+textt t = t ^. unpacked & text
+
+----------------------------------------------------------------------------------
+
+lookupN :: Name -> Env -> Maybe Addr
+lookupN k = lookup (NameKey k)
+
+lookupC :: Tag -> Int -> Env -> Maybe Addr
+lookupC t n = lookup (ConstrKey t n)
+
+----------------------------------------------------------------------------------
+
+gc :: GmState -> GmState
+gc st = (sweepNodes . markNodes $ st)
+      & gmStats . stsGCCycles %~ succ
+
 markNodes :: GmState -> GmState
 markNodes st = st & gmHeap %~ thread (markFrom <$> roots)
     where
@@ -780,18 +1036,6 @@ sweepNodes st = st & gmHeap %~ thread (f <$> addresses h)
 thread :: [a -> a] -> (a -> a)
 thread = appEndo . foldMap Endo
 
-gc :: GmState -> GmState
-gc st = (sweepNodes . markNodes $ st)
-      & gmStats . stsGCCycles %~ succ
-
---------------------------------------------------------------------------------
-
-lookupN :: Name -> Env -> Maybe Addr
-lookupN k = lookup (NameKey k)
-
-lookupC :: Tag -> Int -> Env -> Maybe Addr
-lookupC t n = lookup (ConstrKey t n)
-
 ----------------------------------------------------------------------------------
 
 gmEvalProg :: Program' -> GmState
@@ -803,7 +1047,8 @@ finalStateOf f = f . gmEvalProg
 resultOf :: Program' -> Maybe Node
 resultOf p = do
     a <- res
-    hLookup a h
+    n <- hLookup a h
+    pure n
     where
         res = st ^? gmStack . _head
         st = gmEvalProg p

src/GM/Print.hs

@@ -1,186 +0,0 @@
-module GM.Print
-    ( showState
-    , showStats
-    , showNodeAt
-    )
-    where
---------------------------------------------------------------------------------
-import Data.Monoid
-import Data.String              (IsString(..))
-import Data.Text.Lens           (IsText, packed, unpacked)
-import Text.Printf
-
-import Text.PrettyPrint             hiding ((<>))
-import Text.PrettyPrint.HughesPJ    (maybeParens)
-import Control.Lens
-
-import Data.Heap
-import Core.Syntax
-import GM.Types
---------------------------------------------------------------------------------
-
-pprTabstop :: Int
-pprTabstop = 4
-
-qquotes :: Doc -> Doc
-qquotes d = "`" <> d <> "'"
-
-showStats :: Stats -> Doc
-showStats sts = "==== Stats ============" $$ stats
-    where
-        stats = text $ printf
-            "Reductions      : %5d\n\
-            \Prim Reductions : %5d\n\
-            \Allocations     : %5d\n\
-            \GC Cycles       : %5d"
-            (sts ^. stsReductions)
-            (sts ^. stsPrimReductions)
-            (sts ^. stsAllocations)
-            (sts ^. stsGCCycles)
-
-showState :: GmState -> Doc
-showState st = vcat
-        [ "==== GmState " <> int stnum <> " "
-            <> text (replicate (28 - 13 - 1 - digitalWidth stnum) '=')
-        , "-- Next instructions -------"
-        , info $ showCodeShort c
-        , "-- Stack -------------------"
-        , info $ showStack st
-        , "-- Heap --------------------"
-        , info $ showHeap st
-        , "-- Dump --------------------"
-        , info $ showDump st
-        ]
-    where
-        stnum = st ^. (gmStats . stsReductions)
-        c = st ^. gmCode
-
-        -- indent data
-        info = nest pprTabstop
-
-showCodeShort :: Code -> Doc
-showCodeShort c = braces c'
-    where
-        c' | length c > 3 = list (showInstr <$> take 3 c) <> "; ..."
-           | otherwise    = list (showInstr <$> c)
-        list = hcat . punctuate "; "
-
-showStackShort :: Stack -> Doc
-showStackShort s = brackets s'
-    where
-           -- no access to heap, otherwise we'd use showNodeAt
-        s' | length s > 3 = list (showEntry <$> take 3 s) <> ", ..."
-           | otherwise    = list (showEntry <$> s)
-        list = hcat . punctuate ", "
-        showEntry = text . show
-
-showStack :: GmState -> Doc
-showStack st = vcat $ uncurry showEntry <$> si
-    where
-        h = st ^. gmHeap
-        s = st ^. gmStack
-
-        -- stack with labeled indices
-        si = [0..] `zip` s
-
-        w = maxWidth (addresses h)
-        showIndex n = padInt w n <> ": "
-
-        showEntry :: Int -> Addr -> Doc
-        showEntry n a = showIndex n <> showNodeAt st a
-
-showDump :: GmState -> Doc
-showDump st = vcat $ uncurry showEntry <$> di
-    where
-        d = st ^. gmDump
-        di = [0..] `zip` d
-
-        showIndex n = padInt w n <> ": "
-        w = maxWidth (fst <$> di)
-
-        showEntry :: Int -> (Code, Stack) -> Doc
-        showEntry n (c,s) = showIndex n <> nest pprTabstop entry
-            where
-                entry = ("Stack : " <> showCodeShort c)
-                     $$ ("Code  : " <> showStackShort s)
-
-padInt :: Int -> Int -> Doc
-padInt m n = text (replicate (m - digitalWidth n) ' ') <> int n
-
-maxWidth :: [Int] -> Int
-maxWidth ns = digitalWidth $ maximum ns
-
-digitalWidth :: Int -> Int
-digitalWidth = length . show
-
-showHeap :: GmState -> Doc
-showHeap st = vcat $ showEntry <$> addrs
-    where
-        showAddr n = padInt w n <> ": "
-
-        w = maxWidth addrs
-        h = st ^. gmHeap
-        addrs = addresses h
-
-        showEntry :: Addr -> Doc
-        showEntry a = showAddr a <> showNodeAt st a
-
-showNodeAt :: GmState -> Addr -> Doc
-showNodeAt = showNodeAtP 0
-
-showNodeAtP :: Int -> GmState -> Addr -> Doc
-showNodeAtP p st a = case hLookup a h of
-    Just (NNum n)        -> int n <> "#"
-    Just (NGlobal _ _)   -> textt name
-        where
-            g = st ^. gmEnv
-            name = case lookup a (view swapped <$> g) of
-                Just (NameKey n)     -> n
-                Just (ConstrKey t n) -> showCon t n
-                _                    -> errTxtInvalidAddress
-    -- TODO: left-associativity
-    Just (NAp f x)       -> pprec $ showNodeAtP (p+1) st f
-                                <+> showNodeAtP (p+1) st x
-    Just (NInd a')       -> pprec $ "NInd -> " <> showNodeAtP (p+1) st a'
-    Just (NConstr t as)  -> pprec $ "NConstr"
-                                <+> int t
-                                <+> brackets (list $ showNodeAtP 0 st <$> as)
-        where list = hcat . punctuate ", "
-    Just NUninitialised  -> "<uninitialised>"
-    Nothing              -> errTxtInvalidAddress
-    where
-        h = st ^. gmHeap
-        pprec = maybeParens (p > 0)
-
-showSc :: GmState -> (Name, Addr) -> Doc
-showSc st (k,a) = "Supercomb " <> qquotes (textt k) <> colon
-               $$ code
-    where
-        code = case hLookup a (st ^. gmHeap) of
-            Just (NGlobal _ c) -> showCode c
-            Just _             -> errTxtInvalidObject
-            Nothing            -> errTxtInvalidAddress
-
-errTxtInvalidObject, errTxtInvalidAddress :: (IsString a) => a
-errTxtInvalidObject = "<invalid object>"
-errTxtInvalidAddress = "<invalid address>"
-
-showCode :: Code -> Doc
-showCode c = "Code" <+> braces instrs
-    where instrs = vcat $ showInstr <$> c
-
-showInstr :: Instr -> Doc
-showInstr (CaseJump alts) = "CaseJump" $$ nest pprTabstop alternatives
-    where
-        showAlt (t,c) = "<" <> int t <> ">" <> showCodeShort c
-        alternatives = foldr (\a acc -> showAlt a $$ acc) mempty alts
-showInstr i = text $ show i
-
-textt :: (IsText a) => a -> Doc
-textt t = t ^. unpacked & text
-
-----------------------------------------------------------------------------------
-
-showCon :: (IsText a) => Tag -> Int -> a
-showCon t n = printf "Pack{%d %d}" t n ^. packed
-

src/GM/Types.hs

@@ -1,83 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-module GM.Types where
---------------------------------------------------------------------------------
-import Control.Lens.Combinators
-import Data.Heap
-import Data.Default
-
-import Core.Syntax
---------------------------------------------------------------------------------
-
-data GmState = GmState
-    { _gmCode   :: Code
-    , _gmStack  :: Stack
-    , _gmDump   :: Dump
-    , _gmHeap   :: GmHeap
-    , _gmEnv    :: Env
-    , _gmStats  :: Stats
-    }
-    deriving Show
-
-type Code = [Instr]
-type Stack = [Addr]
-type Dump = [(Code, Stack)]
-type Env = [(Key, Addr)]
-type GmHeap = Heap Node
-
-data Key = NameKey Name
-         | ConstrKey Tag Int
-         deriving (Show, Eq)
-
--- >> [ref/Instr]
-data Instr = Unwind
-           | PushGlobal Name
-           | PushConstr Tag Int
-           | PushInt Int
-           | Push Int
-           | MkAp
-           | Slide Int
-           | Update Int
-           | Pop Int
-           | Alloc Int
-           | Eval
-           -- arith
-           | Neg | Add | Sub | Mul | Div
-           -- comparison
-           | Equals | Lesser | GreaterEq
-           | Pack Tag Int -- Pack Tag Arity
-           | CaseJump [(Tag, Code)]
-           | Split Int
-           | Print
-           | Halt
-           deriving (Show, Eq)
--- << [ref/Instr]
-
-data Node = NNum Int
-          | NAp Addr Addr
-          -- NGlobal is the GM equivalent of NSupercomb. rather than storing a
-          -- template to be instantiated, NGlobal holds the global's arity and
-          -- the pre-compiled code :3
-          | NGlobal Int Code
-          | NInd Addr
-          | NUninitialised
-          | NConstr Tag [Addr] -- NConstr Tag Components
-          | NMarked Node
-          deriving (Show, Eq)
-
--- TODO: log executed instructions
-data Stats = Stats
-    { _stsReductions     :: Int
-    , _stsPrimReductions :: Int
-    , _stsAllocations    :: Int
-    , _stsDereferences   :: Int
-    , _stsGCCycles       :: Int
-    }
-    deriving Show
-
-instance Default Stats where
-    def = Stats 0 0 0 0 0
-
--- TODO: _gmGlobals should not have a setter
-makeLenses ''GmState
-makeLenses ''Stats
-

src/GM/Visual.hs

@@ -1,54 +0,0 @@
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-}
-module GM.Visual
-    ( renderGmState
-    )
-    where
---------------------------------------------------------------------------------
-import Text.Printf
-import Data.Function            ((&), on)
-import Text.PrettyPrint         qualified as P
-
-import Diagrams.Prelude
-import Diagrams.Backend.Cairo
-
-import GM.Types
-import GM.Print
---------------------------------------------------------------------------------
-
-renderGmState :: GmState -> IO ()
-renderGmState st = renderCairo path size (drawState st)
-    where
-        size = mkSizeSpec2D (Just 1000) (Just 1000)
-        path = printf "/tmp/render/%04d.png" n
-        n = st ^. gmStats . stsReductions
-
-drawState :: GmState -> Diagram B
-drawState = drawStack
-
-drawStack :: GmState -> Diagram B
-drawStack st = st & vcatOf (gmStack . each . to cell)
-    where
-        cell a = rect 10 5
-              <> text (printf "%04x: %s" a (P.render . showNodeAt st $ a))
-
-vcatOf :: (InSpace V2 n a, Floating n, Juxtaposable a, HasOrigin a, Monoid' a)
-       => Getting (Endo [a]) s a -> s -> a
-vcatOf l = vcat . (^.. l)
-
-newtype Vap a = Vap { getVap :: a }
-
-instance (InSpace V2 n a, Juxtaposable a, Semigroup a)
-         => Semigroup (Vap a) where (<>) = (Vap .) . ((===) `on` getVap)
-instance (InSpace V2 n a, Juxtaposable a, Monoid a)
-         => Monoid (Vap a) where mempty = Vap mempty
-
-newtype Hap a = Hap { getHap :: a }
-
-instance (InSpace V2 n a, Juxtaposable a, Semigroup a)
-         => Semigroup (Hap a) where (<>) = (Hap .) . ((|||) `on` getHap)
-instance (InSpace V2 n a, Juxtaposable a, Monoid a)
-         => Monoid (Hap a) where mempty = Hap mempty
-

src/Rlp/Lex.x

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

src/Rlp/Parse.y

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

src/Rlp/Parse/Associate.hs

@@ -16,7 +16,7 @@ import Rlp.Parse.Types
 import Rlp.Syntax
 --------------------------------------------------------------------------------
 
-associate :: OpTable -> Decl' RlpcPs -> Decl' RlpcPs
+associate :: OpTable -> Decl RlpcPs a -> Decl RlpcPs a
 associate _ p = p
 
 {-# WARNING associate "unimplemented" #-}

src/Rlp/Parse/Types.hs

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

src/Rlp/Syntax.hs

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

src/Rlp/Syntax/Backstage.hs

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

src/Rlp/Syntax/Types.hs

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

src/Rlp/TH.hs

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

src/Rlp2Core.hs

@@ -41,6 +41,12 @@ import Rlp.Syntax                       as Rlp
 import Rlp.Parse.Types                  (RlpcPs, PsName)
 --------------------------------------------------------------------------------
 
+desugarRlpProgR = undefined
+desugarRlpProg = undefined
+desugarRlpExpr = undefined
+
+{--
+
 type Tree a = Either Name (Name, Branch a)
 
 -- | Rose tree branch representing "nested" "patterns" in the Core language. That
@@ -234,3 +240,5 @@ typeToCore (VarT'' x)   = TyVar (dsNameToName x)
 dsNameToName :: IdP RlpcPs -> Name
 dsNameToName = id
 
+-}
+

tst/Compiler/TypesSpec.hs

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