fixation fufilled - back to work!

rlp.cabal

@@ -31,7 +31,8 @@ library
                     , Core.HindleyMilner
                     , Control.Monad.Errorful
                     , Rlp.Syntax
-                    , Rlp.ParseDecls
+                    , Rlp.Parse.Decls
+                    , Rlp.Parse.Types
 
     other-modules:    Data.Heap
                     , Data.Pretty

src/RLP/Parse/Decls.hs

@@ -1,41 +1,30 @@
--- Show Fix
-{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE LambdaCase, BlockArguments #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-module Rlp.ParseDecls
+module Rlp.Parse.Decls
     (
     )
     where
 ----------------------------------------------------------------------------------
-import Rlp.Syntax
+import Control.Monad
+import Control.Monad.State
 import Text.Megaparsec              hiding (State)
 import Text.Megaparsec.Char
 import Text.Megaparsec.Char.Lexer   qualified as L
-import Data.Functor.Const
 import Data.Functor.Classes
+import Data.Functor.Foldable
 import Data.Text                    (Text)
 import Data.Text                    qualified as T
 import Data.List                    (foldl1')
-import Data.Void
 import Data.Char
 import Data.Functor
-import Data.Functor.Foldable
+import Data.Functor.Const
-import Data.Fix
+import Data.Fix                     hiding (cata)
-import Data.HashMap.Strict          qualified as H
+import Lens.Micro
-import Control.Monad
+import Rlp.Parse.Types
-import Control.Monad.State
+import Rlp.Syntax
-----------------------------------------------------------------------------------
-
-type Parser = ParsecT Void Text (State ParserState)
-
-data ParserState = ParserState
-    { _psPrecTable :: PrecTable
-    }
-    deriving Show
-
-type PrecTable = H.HashMap Name (Assoc, Int)
-
 ----------------------------------------------------------------------------------
 
 parseTest' :: (Show a) => Parser a -> Text -> IO ()
@@ -76,10 +65,11 @@ funD = FunD <$> varid <*> many pat1 <*> (symbol "=" *> fmap Const partialExpr)
 
 partialExpr :: Parser PartialExpr'
 partialExpr = choice
-    [ try $ fmap Fix $ U <$> partialExpr1' <*> lexeme infixOp <*> partialExpr'
+    [ try $ fmap Fix $ mkB <$> partialExpr1' <*> lexeme infixOp <*> partialExpr'
     , foldl1' papp <$> some partialExpr1
     ]
     where
+        mkB a f b = B f a b
         partialExpr1' = unFix <$> partialExpr1
         partialExpr' = unFix <$> partialExpr
 
@@ -140,32 +130,42 @@ lit = int
 
 ----------------------------------------------------------------------------------
 
--- absolute psycho shit
+type PartialE = Partial RlpExpr'
 
-type PartialDecl' = Decl (Const PartialExpr') Name
+-- complete :: OpTable -> Fix Partial -> RlpExpr'
+complete :: OpTable -> PartialExpr' -> RlpExpr'
+complete pt = let ?pt = pt in cata completePartial
 
-data Partial a = E (RlpExprF Name a)
+completePartial :: PartialE -> RlpExpr'
-               | U (Partial a) Name (Partial a)
+completePartial (E e)        = completeRlpExpr e
-               | P (Partial a)
+completePartial p@(B o l r)  = completeB (build p)
-               deriving (Show, Functor)
+completePartial (P e)        = completePartial e
 
-instance Show1 Partial where
+completeRlpExpr :: RlpExprF' RlpExpr' -> RlpExpr'
-    liftShowsPrec :: forall a. (Int -> a -> ShowS)
+completeRlpExpr = embed
-                  -> ([a] -> ShowS)
-                  -> Int -> Partial a -> ShowS
 
-    liftShowsPrec sp sl p m = case m of
+completeB :: PartialE -> RlpExpr'
-        (E e)       -> showsUnaryWith lshow "E" p e
+completeB = build
-        (U a f b)   -> showsTernaryWith lshow showsPrec lshow "U" p a f b
-        (P e)       -> showsUnaryWith lshow "P" p e
-        where
-            lshow :: forall f. (Show1 f) => Int -> f a -> ShowS
-            lshow = liftShowsPrec sp sl
 
-type PartialExpr' = Fix Partial
+build :: PartialE -> PartialE
+build e = go id e (rightmost e) where
+    rightmost :: Partial -> Partial
+    rightmost (B _ _ _) = rightmost r
+    rightmost (E n)     = undefined
 
-----------------------------------------------------------------------------------
+    go :: (?pt :: OpTable)
+       => (PartialE -> PartialE)
+       -> PartialE -> PartialE -> PartialE
+    go f p@(WithPrec o _ r) = case r of
+            E _     -> mkHole o (f . f')
+            P _     -> undefined
+            B _ _ _ -> go (mkHole o (f . f')) r
+        where f' r' = p & pR .~ r'
 
-mkOp :: RlpExpr b -> RlpExpr b -> RlpExpr b -> RlpExpr b
+mkHole :: (?pt :: OpTable)
-mkOp f a b = (f `AppE` a) `AppE` b
+       => OpInfo
+       -> (PartialE -> PartialE)
+       -> PartialE
+       -> PartialE
+mkHole = undefined
 

src/RLP/Parse/Types.hs

@@ -0,0 +1,65 @@
+module Rlp.Parse.Types
+    (
+    -- * Partial ASTs
+      Partial(..)
+    , PartialExpr'
+    , PartialDecl'
+
+    -- * Parser types
+    , Parser
+    , ParserState(..)
+    , OpTable
+    , OpInfo
+    )
+    where
+----------------------------------------------------------------------------------
+import Control.Monad.State
+import Data.HashMap.Strict          qualified as H
+import Data.Fix
+import Data.Functor.Foldable
+import Data.Functor.Const
+import Data.Functor.Classes
+import Data.Void
+import Text.Megaparsec              hiding (State)
+import Rlp.Syntax
+----------------------------------------------------------------------------------
+
+-- parser types
+
+type Parser = ParsecT Void Text (State ParserState)
+
+data ParserState = ParserState
+    { _psOpTable :: OpTable
+    }
+    deriving Show
+
+type OpTable = H.HashMap Name OpInfo
+type OpInfo = (Assoc, Int)
+
+----------------------------------------------------------------------------------
+
+-- absolute psycho shit (partial ASTs)
+
+type PartialDecl' = Decl (Const PartialExpr') Name
+
+data Partial a = E (RlpExprF Name a)
+               | B Name (Partial a) (Partial a)
+               | P (Partial a)
+               deriving (Show, Functor)
+
+-- 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
+        (P e)       -> showsUnaryWith lshow "P" p e
+        where
+            lshow :: forall f. (Show1 f) => Int -> f a -> ShowS
+            lshow = liftShowsPrec sp sl
+
+type PartialExpr' = Fix Partial
+

src/RLP/Syntax.hs

@@ -19,10 +19,12 @@ module Rlp.Syntax
 
     -- TODO: ugh move this somewhere else later
     , showsTernaryWith
+
+    -- * Convenience re-exports
+    , Text
     )
     where
 ----------------------------------------------------------------------------------
-import Data.Functor.Const
 import Data.Text                    (Text)
 import Data.Text                    qualified as T
 import Data.String                  (IsString(..))
@@ -32,7 +34,7 @@ import Lens.Micro
 import Core.Syntax                  hiding (Lit)
 import Core                         (HasRHS(..), HasLHS(..))
 ----------------------------------------------------------------------------------
- 
+
 newtype RlpProgram b = RlpProgram [Decl RlpExpr b]
 
 -- | The @e@ parameter is used for partial results. When parsing an input, we