diff --git a/src/RLP/ParseDecls.hs b/src/RLP/ParseDecls.hs index 9472063..83db884 100644 --- a/src/RLP/ParseDecls.hs +++ b/src/RLP/ParseDecls.hs @@ -1,5 +1,6 @@ -- Show Y {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE OverloadedStrings #-} module Rlp.ParseDecls ( @@ -17,6 +18,7 @@ import Data.List (foldl1') import Data.Void import Data.Char import Data.Functor +import Data.Functor.Foldable import Data.HashMap.Strict qualified as H import Control.Monad import Control.Monad.State @@ -83,7 +85,7 @@ partialExpr = choice partialExpr1 :: Parser PartialExpr' partialExpr1 = choice - [ try $ char '(' *> partialExpr <* char ')' + [ try $ char '(' *> (hoistY P <$> partialExpr) <* char ')' , fmap Y $ varid' , fmap Y $ lit' ] @@ -144,19 +146,21 @@ newtype Y f = Y (f (Y f)) unY :: Y f -> f (Y f) unY (Y f) = f -ymap :: (Functor f) => (forall a. f a -> g a) -> Y f -> Y g -ymap m (Y f) = Y $ m (ymap m <$> f) +hoistY :: (Functor f) => (forall a. f a -> g a) -> Y f -> Y g +hoistY m (Y f) = Y $ m (hoistY m <$> f) instance (Show (f (Y f))) => Show (Y f) where showsPrec p (Y f) = showsPrec p f data Partial a = E (RlpExprF Name a) | U (Partial a) Name (Partial a) - deriving Show + | P (Partial a) + deriving (Show, Functor) type PartialExpr' = Y Partial ---------------------------------------------------------------------------------- - +mkOp :: RlpExpr b -> RlpExpr b -> RlpExpr b -> RlpExpr b +mkOp f a b = (f `AppE` a) `AppE` b diff --git a/src/RLP/Syntax.hs b/src/RLP/Syntax.hs index 8a93059..eaf6b12 100644 --- a/src/RLP/Syntax.hs +++ b/src/RLP/Syntax.hs @@ -5,6 +5,7 @@ {-# LANGUAGE OverloadedStrings #-} module Rlp.Syntax ( RlpExpr(..) + , RlpExpr' , RlpExprF(..) , RlpExprF' , Decl(..) @@ -61,6 +62,8 @@ data RlpExpr b = LetE [Bind b] (RlpExpr b) | LitE (Lit b) deriving Show +type RlpExpr' = RlpExpr Name + -- do we want guards? data Alt b = AltA (Pat b) (RlpExpr b) deriving Show