src/RLP/Parse/Decls.hs

@@ -17,6 +17,7 @@ import Data.Functor.Classes
 import Data.Functor.Foldable
 import Data.Text                    (Text)
 import Data.Text                    qualified as T
+import Data.HashMap.Strict          qualified as H
 import Data.List                    (foldl1')
 import Data.Char
 import Data.Functor
@@ -130,42 +131,81 @@ lit = int
 
 ----------------------------------------------------------------------------------
 
-type PartialE = Partial RlpExpr'
-
 -- complete :: OpTable -> Fix Partial -> RlpExpr'
-complete :: OpTable -> PartialExpr' -> RlpExpr'
+complete :: (?pt :: OpTable) => PartialExpr' -> RlpExpr'
-complete pt = let ?pt = pt in cata completePartial
+complete = cata completePartial
 
-completePartial :: PartialE -> RlpExpr'
+completePartial :: (?pt :: OpTable) => PartialE -> RlpExpr'
 completePartial (E e)        = completeRlpExpr e
 completePartial p@(B o l r)  = completeB (build p)
 completePartial (P e)        = completePartial e
 
-completeRlpExpr :: RlpExprF' RlpExpr' -> RlpExpr'
+completeRlpExpr :: (?pt :: OpTable) => RlpExprF' RlpExpr' -> RlpExpr'
 completeRlpExpr = embed
 
-completeB :: PartialE -> RlpExpr'
+completeB :: (?pt :: OpTable) => PartialE -> RlpExpr'
-completeB = build
+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
+    P e         -> completeB e
+    E e         -> completeRlpExpr e
 
-build :: PartialE -> PartialE
+build :: (?pt :: OpTable) => PartialE -> PartialE
 build e = go id e (rightmost e) where
-    rightmost :: Partial -> Partial
+    rightmost :: PartialE -> PartialE
-    rightmost (B _ _ _) = rightmost r
+    rightmost (B _ _ r) = rightmost r
-    rightmost (E n)     = undefined
+    rightmost p@(E _)   = p
+    rightmost p@(P _)   = p
 
     go :: (?pt :: OpTable)
        => (PartialE -> PartialE)
        -> PartialE -> PartialE -> PartialE
-    go f p@(WithPrec o _ r) = case r of
+    go f p@(WithInfo o _ r) = case r of
             E _     -> mkHole o (f . f')
-            P _     -> undefined
+            P _     -> 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 = undefined
+mkHole _     hole p@(P _)                   = hole p
+mkHole _     hole p@(E _)                   = hole p
+mkHole (a,d) hole p@(WithInfo (a',d') _ _)
+    | d' < d  = above
+    | d' > d  = below
+    | d == d' = case (a,a') of
+                  -- left-associative operators of equal precedence are
+                  -- associated left
+                  (InfixL,InfixL) -> above
+                  -- right-associative operators are handled similarly
+                  (InfixR,InfixR) -> below
+                  -- non-associative operators of equal precedence, or equal
+                  -- precedence operators of different associativities are
+                  -- invalid
+                  (_,     _)      -> error "invalid expression"
+    where
+        above = p & pL %~ hole
+        below = hole p
+
+examplePrecTable :: OpTable
+examplePrecTable = H.fromList
+    [ ("+",    (InfixL,6))
+    , ("*",    (InfixL,7))
+    , ("^",    (InfixR,8))
+    , (".",    (InfixR,7))
+    , ("~",    (Infix, 9))
+    , ("=",    (Infix, 4))
+    , ("&&",   (Infix, 3))
+    , ("||",   (Infix, 2))
+    , ("$",    (InfixR,0))
+    , ("&",    (InfixL,0))
+    ]
 

src/RLP/Parse/Types.hs

@@ -1,9 +1,17 @@
+{-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
+{-
+Description : Supporting types for the parser
+-}
 module Rlp.Parse.Types
     (
     -- * Partial ASTs
       Partial(..)
+    , PartialE
     , PartialExpr'
     , PartialDecl'
+    , pattern WithInfo
+    , pR
+    , pL
 
     -- * Parser types
     , Parser
@@ -20,7 +28,9 @@ import Data.Functor.Foldable
 import Data.Functor.Const
 import Data.Functor.Classes
 import Data.Void
+import Data.Maybe
 import Text.Megaparsec              hiding (State)
+import Lens.Micro
 import Rlp.Syntax
 ----------------------------------------------------------------------------------
 
@@ -47,6 +57,23 @@ data Partial a = E (RlpExprF Name a)
                | P (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)