msyds/rlp
1
0
Fork 0
Code Issues 4 Pull Requests Actions Packages Projects Releases 2 Wiki Activity

pretty

Browse Source
This commit is contained in:
crumbtoo
2024-03-03 14:09:10 -07:00
parent 451b003e08
commit 1b56a7a627
10 changed files with 383 additions and 49 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
Makefile_happysrcs
View File

@@ -9,12 +9,16 @@ CABAL_BUILD = $(shell ./find-build.cl)
all: parsers lexers
parsers: $(CABAL_BUILD)/Rlp/Parse.hs $(CABAL_BUILD)/Core/Parse.hs
parsers: $(CABAL_BUILD)/Rlp/Parse.hs $(CABAL_BUILD)/Core/Parse.hs \
$(CABAL_BUILD)/Rlp/AltParse.hs
lexers: $(CABAL_BUILD)/Rlp/Lex.hs $(CABAL_BUILD)/Core/Lex.hs
$(CABAL_BUILD)/Rlp/Parse.hs: $(SRC)/Rlp/Parse.y
$(HAPPY) $(HAPPY_OPTS) $< -o $@
$(CABAL_BUILD)/Rlp/AltParse.hs: $(SRC)/Rlp/AltParse.y
$(HAPPY) $(HAPPY_OPTS) $< -o $@
$(CABAL_BUILD)/Rlp/Lex.hs: $(SRC)/Rlp/Lex.x
$(ALEX) $(ALEX_OPTS) $< -o $@

2
rlp.cabal
View File

@@ -32,6 +32,8 @@ library
, Core.HindleyMilner
, Control.Monad.Errorful
, Rlp.Syntax
, Rlp.AltSyntax
, Rlp.AltParse
, Rlp.Syntax.Backstage
, Rlp.Syntax.Types
-- , Rlp.Parse.Decls

19
src/Compiler/JustRun.hs
View File

@@ -10,6 +10,7 @@ types such as @RLPC@ or @Text@.
module Compiler.JustRun
( justLexCore
, justParseCore
, justParseRlp
, justTypeCheckCore
, justHdbg
, makeItPretty, makeItPretty'
@@ -29,15 +30,18 @@ import Data.Text qualified as T
import Data.Function ((&))
import System.IO
import GM
import Rlp.Parse
import Rlp2Core
import Data.Pretty
import Rlp.AltParse
import Rlp.AltSyntax qualified as Rlp
----------------------------------------------------------------------------------
justHdbg :: String -> IO GmState
justHdbg s = do
p <- evalRLPCIO def (parseRlpProgR >=> desugarRlpProgR $ T.pack s)
withFile "/tmp/t.log" WriteMode $ hdbgProg p
justHdbg = undefined
-- justHdbg s = do
-- p <- evalRLPCIO def (parseRlpProgR >=> desugarRlpProgR $ T.pack s)
-- withFile "/tmp/t.log" WriteMode $ hdbgProg p
justLexCore :: String -> Either [MsgEnvelope RlpcError] [CoreToken]
justLexCore s = lexCoreR (T.pack s)
@@ -49,6 +53,13 @@ justParseCore s = parse (T.pack s)
& rlpcToEither
where parse = lexCoreR @Identity >=> parseCoreProgR
justParseRlp :: String
-> Either [MsgEnvelope RlpcError]
(Rlp.Program Name (Rlp.RlpExpr Name))
justParseRlp s = parse (T.pack s)
& rlpcToEither
where parse = parseRlpProgR @Identity
justTypeCheckCore :: String -> Either [MsgEnvelope RlpcError] Program'
justTypeCheckCore s = typechk (T.pack s)
& rlpcToEither

23
src/Compiler/Types.hs
View File

@@ -46,8 +46,6 @@ import Data.Function (on)
data Located a = Located SrcSpan a
deriving (Show, Lift, Functor)
data Floc f = Floc SrcSpan (f (Floc f))
pattern (:<$) :: a -> f b -> Trans.Cofree.CofreeF f a b
pattern a :<$ b = a Trans.Cofree.:< b
@@ -56,10 +54,10 @@ pattern a :<$ b = a Trans.Cofree.:< b
infixl 5 <~>
-- (~>) :: (CanGet k, CanSet k', HasLocation k a, HasLocation k' b)
-- => a -> b -> b
-- a ~> b =
(~>) = undefined
(~>) :: (CanGet k, CanSet k', HasLocation k a, HasLocation k' b)
=> a -> b -> b
a ~> b = b & fromSet getSetLocation .~ (a ^. fromGet getSetLocation)
-- (~>) = undefined
infixl 4 ~>
@@ -97,15 +95,15 @@ data SrcSpan = SrcSpan
!Int -- ^ Length
deriving (Show, Eq, Lift)
tupling :: Iso' SrcSpan (Int, Int, Int, Int)
tupling = iso (\ (SrcSpan a b c d) -> (a,b,c,d))
_SrcSpan :: Iso' SrcSpan (Int, Int, Int, Int)
_SrcSpan = 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 = tupling . _1
srcSpanColumn = tupling . _2
srcSpanAbs = tupling . _3
srcSpanLen = tupling . _4
srcSpanLine = _SrcSpan . _1
srcSpanColumn = _SrcSpan . _2
srcSpanAbs = _SrcSpan . _3
srcSpanLen = _SrcSpan . _4
-- | debug tool
nolo :: a -> Located a
@@ -228,3 +226,4 @@ lochead afs (Located ss fss) = ss :< unwrap (lochead afs $ Located ss fss)
--------------------------------------------------------------------------------
makePrisms ''Located

68
src/Core/Syntax.hs
View File

@@ -420,36 +420,56 @@ instance (Pretty b) => Pretty (ScDef b) where
as = sc & hsepOf (_lhs . _2 . each . to ttext)
e = pretty $ sc ^. _rhs
instance (Pretty (f (Fix f))) => Pretty (Fix f) where
prettyPrec d (Fix f) = prettyPrec d f
-- Pretty Expr
-- LamF | appPrec1 | right
-- AppF | appPrec | left
instance (Pretty b, Pretty a) => Pretty (ExprF b a) where
prettyPrec _ (VarF n) = ttext n
prettyPrec _ (ConF t a) = "Pack{" <> (ttext t <+> ttext a) <> "}"
prettyPrec p (LamF bs e) = maybeParens (p>0) $
hsep ["λ", hsep (prettyPrec appPrec1 <$> bs), "->", pretty e]
prettyPrec p (LetF r bs e) = maybeParens (p>0)
$ hsep [pretty r, explicitLayout bs]
$+$ hsep ["in", pretty e]
prettyPrec p (AppF f x) = maybeParens (p>appPrec) $
prettyPrec appPrec f <+> prettyPrec appPrec1 x
prettyPrec p (LitF l) = prettyPrec p l
prettyPrec p (CaseF e as) = maybeParens (p>0) $
"case" <+> pretty e <+> "of"
$+$ nest 2 (explicitLayout as)
prettyPrec p (TypeF t) = "@" <> prettyPrec appPrec1 t
prettyPrec = prettyPrec1
-- prettyPrec _ (VarF n) = ttext n
-- prettyPrec _ (ConF t a) = "Pack{" <> (ttext t <+> ttext a) <> "}"
-- prettyPrec p (LamF bs e) = maybeParens (p>0) $
-- hsep ["λ", hsep (prettyPrec appPrec1 <$> bs), "->", pretty e]
-- prettyPrec p (LetF r bs e) = maybeParens (p>0)
-- $ hsep [pretty r, explicitLayout bs]
-- $+$ hsep ["in", pretty e]
-- prettyPrec p (AppF f x) = maybeParens (p>appPrec) $
-- prettyPrec appPrec f <+> prettyPrec appPrec1 x
-- prettyPrec p (LitF l) = prettyPrec p l
-- prettyPrec p (CaseF e as) = maybeParens (p>0) $
-- "case" <+> pretty e <+> "of"
-- $+$ nest 2 (explicitLayout as)
-- prettyPrec p (TypeF t) = "@" <> prettyPrec appPrec1 t
instance (Pretty b) => Pretty1 (ExprF b) where
liftPrettyPrec pr _ (VarF n) = ttext n
liftPrettyPrec pr _ (ConF t a) = "Pack{" <> (ttext t <+> ttext a) <> "}"
liftPrettyPrec pr p (LamF bs e) = maybeParens (p>0) $
hsep ["λ", hsep (prettyPrec appPrec1 <$> bs), "->", pr 0 e]
liftPrettyPrec pr p (LetF r bs e) = maybeParens (p>0)
$ hsep [pretty r, bs']
$+$ hsep ["in", pr 0 e]
where bs' = liftExplicitLayout (liftPrettyPrec pr 0) bs
liftPrettyPrec pr p (AppF f x) = maybeParens (p>appPrec) $
pr appPrec f <+> pr appPrec1 x
liftPrettyPrec pr p (LitF l) = prettyPrec p l
liftPrettyPrec pr p (CaseF e as) = maybeParens (p>0) $
"case" <+> pr 0 e <+> "of"
$+$ nest 2 as'
where as' = liftExplicitLayout (liftPrettyPrec pr 0) as
liftPrettyPrec pr p (TypeF t) = "@" <> prettyPrec appPrec1 t
instance Pretty Rec where
pretty Rec = "letrec"
pretty NonRec = "let"
instance (Pretty b, Pretty a) => Pretty (AlterF b a) where
pretty (AlterF c as e) =
hsep [pretty c, hsep (pretty <$> as), "->", pretty e]
prettyPrec = prettyPrec1
instance (Pretty b) => Pretty1 (AlterF b) where
liftPrettyPrec pr _ (AlterF c as e) =
hsep [pretty c, hsep (pretty <$> as), "->", liftPrettyPrec pr 0 e]
instance Pretty AltCon where
pretty (AltData n) = ttext n
@@ -461,7 +481,15 @@ instance Pretty Lit where
pretty (IntL n) = ttext n
instance (Pretty b, Pretty a) => Pretty (BindingF b a) where
pretty (BindingF k v) = hsep [pretty k, "=", pretty v]
prettyPrec = prettyPrec1
instance Pretty b => Pretty1 (BindingF b) where
liftPrettyPrec pr _ (BindingF k v) = hsep [pretty k, "=", liftPrettyPrec pr 0 v]
liftExplicitLayout :: (a -> Doc) -> [a] -> Doc
liftExplicitLayout pr as = vcat inner <+> "}" where
inner = zipWith (<+>) delims (pr <$> as)
delims = "{" : repeat ";"
explicitLayout :: (Pretty a) => [a] -> Doc
explicitLayout as = vcat inner <+> "}" where

37
src/Data/Pretty.hs
View File

@@ -1,13 +1,12 @@
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE QuantifiedConstraints, UndecidableInstances #-}
module Data.Pretty
( Pretty(..)
( Pretty(..), Pretty1(..)
, prettyPrec1
, rpretty
, ttext
-- * Pretty-printing lens combinators
, hsepOf, vsepOf
, vcatOf
, vlinesOf
, vsepTerm
, hsepOf, vsepOf, vcatOf, vlinesOf, vsepTerm
, vsep
, module Text.PrettyPrint
, maybeParens
, appPrec
@@ -20,12 +19,14 @@ import Text.PrettyPrint.HughesPJ hiding ((<>))
import Text.Printf
import Data.String (IsString(..))
import Data.Text.Lens hiding ((:<))
import Data.Monoid
import Data.Monoid hiding (Sum)
import Control.Lens
-- instances
import Control.Comonad.Cofree
import Data.Text qualified as T
import Data.Functor.Sum
import Data.Fix (Fix(..))
----------------------------------------------------------------------------------
class Pretty a where
@@ -53,7 +54,24 @@ instance (Show a) => Pretty (Showing a) where
deriving via Showing Int instance Pretty Int
class (forall a. Pretty a => Pretty (f a)) => Pretty1 f where
liftPrettyPrec :: (Int -> a -> Doc) -> f a -> Doc
liftPrettyPrec :: (Int -> a -> Doc) -> Int -> f a -> Doc
prettyPrec1 :: (Pretty1 f, Pretty a) => Int -> f a -> Doc
prettyPrec1 = liftPrettyPrec prettyPrec
instance (Pretty1 f, Pretty1 g, Pretty a) => Pretty (Sum f g a) where
prettyPrec p (InL fa) = prettyPrec1 p fa
prettyPrec p (InR ga) = prettyPrec1 p ga
instance (Pretty1 f, Pretty1 g) => Pretty1 (Sum f g) where
liftPrettyPrec pr p (InL fa) = liftPrettyPrec pr p fa
liftPrettyPrec pr p (InR ga) = liftPrettyPrec pr p ga
instance (Pretty (f (Fix f))) => Pretty (Fix f) where
prettyPrec d (Fix f) = prettyPrec d f
-- instance (Pretty1 f) => Pretty (Fix f) where
-- prettyPrec d (Fix f) = prettyPrec1 d f
--------------------------------------------------------------------------------
@@ -76,6 +94,9 @@ vlinesOf l = foldrOf l (\a b -> a $+$ "" $+$ b) mempty
vsepTerm :: Doc -> Doc -> Doc -> Doc
vsepTerm term a b = (a <> term) $+$ b
vsep :: [Doc] -> Doc
vsep = foldr ($+$) mempty
--------------------------------------------------------------------------------
appPrec, appPrec1 :: Int

172
src/Rlp/AltParse.y Normal file
View File

@@ -0,0 +1,172 @@
{
module Rlp.AltParse
( parseRlpProg
, parseRlpProgR
, runP'
)
where
import Data.List.Extra
import Data.Text (Text)
import Control.Comonad
import Control.Comonad.Cofree
import Control.Lens hiding (snoc)
import Compiler.RlpcError
import Compiler.RLPC
import Control.Monad.Errorful
import Rlp.Lex
import Rlp.AltSyntax
import Rlp.Parse.Types hiding (PsName)
import Core.Syntax qualified as Core
}
%name parseRlpProg StandaloneProgram
%name parseRlpExpr StandaloneExpr
%monad { P }
%lexer { lexCont } { Located _ TokenEOF }
%error { parseError }
%errorhandlertype explist
%tokentype { Located RlpToken }
%token
varname { Located _ (TokenVarName _) }
conname { Located _ (TokenConName _) }
consym { Located _ (TokenConSym _) }
varsym { Located _ (TokenVarSym _) }
data { Located _ TokenData }
case { Located _ TokenCase }
of { Located _ TokenOf }
litint { Located _ (TokenLitInt _) }
'=' { Located _ TokenEquals }
'|' { Located _ TokenPipe }
'::' { Located _ TokenHasType }
';' { Located _ TokenSemicolon }
'(' { Located _ TokenLParen }
')' { Located _ TokenRParen }
'->' { Located _ TokenArrow }
vsemi { Located _ TokenSemicolonV }
'{' { Located _ TokenLBrace }
'}' { Located _ TokenRBrace }
vlbrace { Located _ TokenLBraceV }
vrbrace { Located _ TokenRBraceV }
infixl { Located _ TokenInfixL }
infixr { Located _ TokenInfixR }
infix { Located _ TokenInfix }
let { Located _ TokenLet }
letrec { Located _ TokenLetrec }
in { Located _ TokenIn }
%nonassoc '='
%right '->'
%right in
%%
StandaloneProgram :: { Program Name (RlpExpr PsName) }
: layout0(Decl) { Program $1 }
StandaloneExpr :: { RlpExpr PsName }
: litint { undefined }
VL :: { () }
VL : vlbrace { () }
VR :: { () }
VR : vrbrace { () }
| error { () }
VS :: { () }
VS : ';' { () }
| vsemi { () }
Decl :: { Decl PsName (RlpExpr PsName) }
: FunD { $1 }
| DataD { $1 }
DataD :: { Decl PsName (RlpExpr PsName) }
: data Con TyVars { DataD $2 $3 [] }
| data Con TyVars '=' DataCons { DataD $2 $3 $5 }
DataCons :: { [DataCon PsName] }
: DataCon '|' DataCons { $1 : $3 }
| DataCon { [$1] }
DataCon :: { DataCon PsName }
: Con list0(Type1) { DataCon $1 $2 }
Type1 :: { Type PsName }
: varname { VarT $ extractVarName $1 }
| Con { ConT $1 }
TyVars :: { [PsName] }
: list0(varname) { $1 <&> view ( to extract
. singular _TokenVarName) }
FunD :: { Decl PsName (RlpExpr PsName) }
: Var Pat1s '=' Expr { FunD $1 $2 $4 }
Expr :: { RlpExpr PsName }
: AppE { $1 }
AppE :: { RlpExpr PsName }
: AppE VarE { Finl $ Core.AppF $1 $2 }
| VarE { $1 }
VarE :: { RlpExpr PsName }
: Var { Finl $ Core.VarF $1 }
Pat1s :: { [Pat PsName] }
: list0(Pat1) { $1 }
Pat1 :: { Pat PsName }
: Var { VarP $1 }
Con :: { PsName }
: conname { $1 ^. to extract
. singular _TokenConName }
| '(' consym ')' { $1 ^. to extract
. singular _TokenConSym }
Var :: { PsName }
: varname { $1 ^. to extract
. singular _TokenVarName }
| '(' varsym ')' { $2 ^. to extract
. singular _TokenVarSym }
-- list0(p : α) : [α]
list0(p) : {- epsilon -} { [] }
| list0(p) p { $1 `snoc` $2 }
-- layout0(p : β) :: [β]
layout0(p) : '{' layout_list0(';',p) '}' { $2 }
| VL layout_list0(VS,p) VR { $2 }
-- layout_list0(sep : α, p : β) :: [β]
layout_list0(sep,p) : p { [$1] }
| layout_list1(sep,p) sep p { $1 `snoc` $3 }
| {- epsilon -} { [] }
-- layout1(p : β) :: [β]
layout1(p) : '{' layout_list1(';',p) '}' { $2 }
| VL layout_list1(VS,p) VR { $2 }
-- layout_list1(sep : α, p : β) :: [β]
layout_list1(sep,p) : p { [$1] }
| layout_list1(sep,p) sep p { $1 `snoc` $3 }
{
extractVarName = view $ to extract . singular _TokenVarName
parseRlpProgR :: (Monad m) => Text -> RLPCT m (Program Name (RlpExpr PsName))
parseRlpProgR s = liftErrorful $ errorful (ma,es)
where
(_,es,ma) = runP' parseRlpProg s
parseError = error "explode"
}

91
src/Rlp/AltSyntax.hs Normal file
View File

@@ -0,0 +1,91 @@
{-# LANGUAGE TemplateHaskell, PatternSynonyms #-}
module Rlp.AltSyntax
(
-- * AST
Program(..), Decl(..), ExprF(..), Pat(..)
, RlpExprF, RlpExpr
, DataCon(..), Type(..)
, Core.Name, PsName
-- * Functor-related tools
, Fix(..), Cofree(..), Sum(..), pattern Finl, pattern Finr
)
where
--------------------------------------------------------------------------------
import Data.Functor.Sum
import Control.Comonad.Cofree
import Data.Fix
import Text.Show.Deriving
import Data.Text qualified as T
import Data.Pretty
import Compiler.Types
import Core.Syntax qualified as Core
--------------------------------------------------------------------------------
type PsName = T.Text
newtype Program b a = Program [Decl b a]
deriving Show
data Decl b a = FunD b [Pat b] a
| DataD b [b] [DataCon b]
deriving Show
data DataCon b = DataCon b [Type b]
deriving Show
data Type b = VarT b
| ConT b
| AppT (Type b) (Type b)
| FunT
deriving Show
data ExprF b a = InfixEF b a a
-- type Expr b = Cofree (ExprF b)
type RlpExprF b = Sum (Core.ExprF b) (ExprF b)
type RlpExpr b = Fix (RlpExprF b)
data Pat b = VarP b
deriving Show
deriveShow1 ''ExprF
deriving instance (Show b, Show a) => Show (ExprF b a)
pattern Finl :: f (Fix (Sum f g)) -> Fix (Sum f g)
pattern Finl fa = Fix (InL fa)
pattern Finr :: g (Fix (Sum f g)) -> Fix (Sum f g)
pattern Finr ga = Fix (InR ga)
--------------------------------------------------------------------------------
instance (Pretty b, Pretty a) => Pretty (ExprF b a) where
prettyPrec = prettyPrec1
instance Pretty b => Pretty1 (ExprF b) where
liftPrettyPrec pr p (InfixEF o a b) = maybeParens (p>0) $
pr 1 a <+> pretty o <+> pr 1 b
instance (Pretty b, Pretty a) => Pretty (Decl b a) where
prettyPrec = prettyPrec1
instance (Pretty b) => Pretty1 (Decl b) where
liftPrettyPrec pr p (FunD f as e) = maybeParens (p>0) $
hsep [ ttext f, hsep (prettyPrec appPrec1 <$> as)
, "=", pr 0 e ]
instance (Pretty b) => Pretty (Pat b) where
prettyPrec p (VarP b) = prettyPrec p b
instance (Pretty a, Pretty b) => Pretty (Program b a) where
prettyPrec = prettyPrec1
instance (Pretty b) => Pretty1 (Program b) where
liftPrettyPrec pr p (Program ds) = vsep $ liftPrettyPrec pr p <$> ds

4
src/Rlp/Parse/Types.hs
View File

@@ -18,7 +18,7 @@ module Rlp.Parse.Types
, RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction
, Located(..), PsName
-- ** Lenses
, _TokenLitInt, _TokenVarName, _TokenConName, _TokenVarSym
, _TokenLitInt, _TokenVarName, _TokenConName, _TokenVarSym, _TokenConSym
, aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn
-- * Error handling
@@ -277,7 +277,7 @@ initAlexInput s = AlexInput
{ _aiPrevChar = '\0'
, _aiSource = s
, _aiBytes = []
, _aiPos = (1,1,0)
, _aiPos = (1,0,0)
}
--------------------------------------------------------------------------------

10
src/Rlp2Core.hs
View File

@@ -28,6 +28,7 @@ import Data.Functor.Bind
import Data.Function (on)
import GHC.Stack
import Debug.Trace
import Numeric
import Effectful.State.Static.Local
import Effectful.Labeled
@@ -71,9 +72,10 @@ desugarRlpProg :: Rlp.Program RlpcPs SrcSpan -> Core.Program'
desugarRlpProg = rlpProgToCore
desugarRlpExpr :: Rlp.Expr' RlpcPs SrcSpan -> Core.Expr'
desugarRlpExpr = runPureEff . runNameSupply "anon" . exprToCore
desugarRlpExpr = runPureEff . runNameSupply "anon" . undefined
runNameSupply = undefined
runNameSupply :: Text -> Eff (NameSupply ': es) a -> Eff es a
runNameSupply pre = undefined -- evalState [ pre <> "_" <> tshow name | name <- [0..] ]
-- the rl' program is desugared by desugaring each declaration as a separate
-- program, and taking the monoidal product of the lot :3
@@ -84,5 +86,9 @@ rlpProgToCore = foldMapOf (programDecls . each) declToCore
declToCore :: Rlp.Decl RlpcPs SrcSpan -> Program'
declToCore = undefined
type NameSupply = State [Name]
exprToCore :: (NameSupply :> es)
=> Rlp.ExprF RlpcPs a -> Eff es Core.Expr'
exprToCore = undefined