From d1e64eb12d8da0f7fcb845560782f4b37a31568c Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Wed, 3 Jan 2024 10:04:42 -0700 Subject: [PATCH] Show1 instances --- rlp.cabal | 3 +++ src/RLP/ParseDecls.hs | 45 ++++++++++++++++++++++++------------------- src/RLP/Syntax.hs | 30 ++++++++++++++++++++++++++++- 3 files changed, 57 insertions(+), 21 deletions(-) diff --git a/rlp.cabal b/rlp.cabal index b960ec6..172e047 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -43,6 +43,8 @@ library build-tool-depends: happy:happy, alex:alex -- other-extensions: + + -- TODO: version bounds build-depends: base ^>=4.18.0.0 , containers , microlens @@ -62,6 +64,7 @@ library , recursion-schemes , megaparsec , text + , data-fix hs-source-dirs: src default-language: GHC2021 diff --git a/src/RLP/ParseDecls.hs b/src/RLP/ParseDecls.hs index 83db884..7a36248 100644 --- a/src/RLP/ParseDecls.hs +++ b/src/RLP/ParseDecls.hs @@ -1,7 +1,8 @@ --- Show Y +-- Show Fix {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Rlp.ParseDecls ( ) @@ -12,6 +13,7 @@ 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.Text (Text) import Data.Text qualified as T import Data.List (foldl1') @@ -19,6 +21,7 @@ import Data.Void import Data.Char import Data.Functor import Data.Functor.Foldable +import Data.Fix import Data.HashMap.Strict qualified as H import Control.Monad import Control.Monad.State @@ -73,21 +76,21 @@ funD = FunD <$> varid <*> many pat1 <*> (symbol "=" *> fmap Const partialExpr) partialExpr :: Parser PartialExpr' partialExpr = choice - [ try $ fmap Y $ U <$> partialExpr1' <*> lexeme infixOp <*> partialExpr' + [ try $ fmap Fix $ U <$> partialExpr1' <*> lexeme infixOp <*> partialExpr' , foldl1' papp <$> some partialExpr1 ] where - partialExpr1' = unY <$> partialExpr1 - partialExpr' = unY <$> partialExpr + partialExpr1' = unFix <$> partialExpr1 + partialExpr' = unFix <$> partialExpr papp :: PartialExpr' -> PartialExpr' -> PartialExpr' - papp f x = Y . E $ f `AppEF` x + papp f x = Fix . E $ f `AppEF` x partialExpr1 :: Parser PartialExpr' partialExpr1 = choice - [ try $ char '(' *> (hoistY P <$> partialExpr) <* char ')' - , fmap Y $ varid' - , fmap Y $ lit' + [ try $ char '(' *> (hoistFix P <$> partialExpr) <* char ')' + , fmap Fix $ varid' + , fmap Fix $ lit' ] where varid' = E . VarEF <$> varid @@ -141,23 +144,25 @@ lit = int type PartialDecl' = Decl (Const PartialExpr') Name -newtype Y f = Y (f (Y f)) - -unY :: Y f -> f (Y f) -unY (Y f) = 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) | P (Partial a) deriving (Show, Functor) -type PartialExpr' = Y Partial +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 + (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 ---------------------------------------------------------------------------------- diff --git a/src/RLP/Syntax.hs b/src/RLP/Syntax.hs index eaf6b12..4a47b7a 100644 --- a/src/RLP/Syntax.hs +++ b/src/RLP/Syntax.hs @@ -16,6 +16,9 @@ module Rlp.Syntax , Lit(..) , Lit' , Name + + -- TODO: ugh move this somewhere else later + , showsTernaryWith ) where ---------------------------------------------------------------------------------- @@ -24,11 +27,12 @@ import Data.Text (Text) import Data.Text qualified as T import Data.String (IsString(..)) import Data.Functor.Foldable.TH (makeBaseFunctor) +import Data.Functor.Classes 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 @@ -114,3 +118,27 @@ 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 +