mirror of
https://github.com/anoma/juvix.git
synced 2024-12-11 08:25:46 +03:00
[pretty] refactor to use PrettyCode type class extensively
This commit is contained in:
Jan Mas Rovira
parent
edd47ad00b
commit
e8c46040b0
@ -188,7 +188,7 @@ go c = case c of
|
||||
root <- getCurrentDirectory
|
||||
m <- parseModuleIO _scopeInputFile
|
||||
s <- fromRightIO' printErrorAnsi $ M.scopeCheck1 root m
|
||||
M.printTopModule (mkPrettyOptions opts) s
|
||||
M.printPrettyCode (mkPrettyOptions opts) s
|
||||
Parse ParseOptions {..} -> do
|
||||
m <- parseModuleIO _parseInputFile
|
||||
if _parseNoPrettyShow then print m else pPrint m
|
||||
|
||||
@ -1,22 +1,26 @@
|
||||
module MiniJuvix.Syntax.Concrete.Scoped.Pretty.Ansi where
|
||||
|
||||
import MiniJuvix.Syntax.Concrete.Language
|
||||
import MiniJuvix.Syntax.Concrete.Scoped.Name (NameKind (..))
|
||||
import MiniJuvix.Syntax.Concrete.Scoped.Pretty.Base
|
||||
import MiniJuvix.Prelude
|
||||
import Prettyprinter
|
||||
import Prettyprinter.Render.Terminal
|
||||
|
||||
printTopModuleDefault :: Module 'Scoped 'ModuleTop -> IO ()
|
||||
printTopModuleDefault = printTopModule defaultOptions
|
||||
printPrettyCodeDefault :: PrettyCode c => c -> IO ()
|
||||
printPrettyCodeDefault = printPrettyCode defaultOptions
|
||||
|
||||
printTopModule :: Options -> Module 'Scoped 'ModuleTop -> IO ()
|
||||
printTopModule opts m = renderIO stdout docStream'
|
||||
where
|
||||
docStream :: SimpleDocStream Ann
|
||||
docStream = layoutPretty defaultLayoutOptions (prettyTopModule opts m)
|
||||
docStream' :: SimpleDocStream AnsiStyle
|
||||
docStream' = reAnnotateS stylize docStream
|
||||
printPrettyCode :: PrettyCode c => Options -> c -> IO ()
|
||||
printPrettyCode = hPrintPrettyCode stdout
|
||||
|
||||
hPrintPrettyCode :: PrettyCode c => Handle -> Options -> c -> IO ()
|
||||
hPrintPrettyCode h opts = renderIO h . docStream opts
|
||||
|
||||
renderPrettyCode :: PrettyCode c => Options -> c -> Text
|
||||
renderPrettyCode opts = renderStrict . docStream opts
|
||||
|
||||
docStream :: PrettyCode c => Options -> c -> SimpleDocStream AnsiStyle
|
||||
docStream opts = reAnnotateS stylize . layoutPretty defaultLayoutOptions
|
||||
. run . runReader opts . ppCode
|
||||
|
||||
stylize :: Ann -> AnsiStyle
|
||||
stylize a = case a of
|
||||
|
||||
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
module MiniJuvix.Syntax.Concrete.Scoped.Pretty.Base (
|
||||
module MiniJuvix.Syntax.Concrete.Scoped.Pretty.Base,
|
||||
module MiniJuvix.Syntax.Concrete.Scoped.Pretty.Ann
|
||||
@ -12,7 +11,7 @@ import Prettyprinter hiding (braces, parens)
|
||||
import MiniJuvix.Syntax.Concrete.Scoped.Pretty.Ann
|
||||
|
||||
data Options = Options
|
||||
{ _optOptimizeParens :: Bool,
|
||||
{
|
||||
_optShowNameId :: Bool,
|
||||
_optInlineImports :: Bool,
|
||||
_optIndent :: Int
|
||||
@ -21,17 +20,17 @@ data Options = Options
|
||||
defaultOptions :: Options
|
||||
defaultOptions =
|
||||
Options
|
||||
{ _optOptimizeParens = True,
|
||||
{
|
||||
_optShowNameId = False,
|
||||
_optInlineImports = False,
|
||||
_optIndent = 2
|
||||
}
|
||||
|
||||
type IsStage s = (SingI s, PrettyCode (ExpressionType s), Eq (SymbolType s), HasFixity (ExpressionType s))
|
||||
class PrettyCode a where
|
||||
ppCode :: forall r. Members '[Reader Options] r => a -> Sem r (Doc Ann)
|
||||
|
||||
-- | Pretty prints a top module.
|
||||
prettyTopModule :: IsStage s => Options -> Module s 'ModuleTop -> Doc Ann
|
||||
prettyTopModule opts = run . runReader opts . ppModule
|
||||
runPrettyCode :: PrettyCode c => Options -> c -> Doc Ann
|
||||
runPrettyCode opts = run . runReader opts . ppCode
|
||||
|
||||
infixl 7 <+?>
|
||||
(<+?>) :: Doc ann -> Maybe (Doc ann) -> Doc ann
|
||||
@ -168,28 +167,25 @@ braces = enclose kwBraceL kwBraceR
|
||||
parens :: Doc Ann -> Doc Ann
|
||||
parens = enclose kwParenL kwParenR
|
||||
|
||||
ppModulePathType :: forall t s r. (SingI t, IsStage s, Members '[Reader Options] r) =>
|
||||
ppModulePathType :: forall t s r. (SingI t, SingI s, Members '[Reader Options] r) =>
|
||||
ModulePathType s t -> Sem r (Doc Ann)
|
||||
ppModulePathType x = case sing :: SModuleIsTop t of
|
||||
SModuleTop -> case sing :: SStage s of
|
||||
SParsed -> ppCTopModulePath x
|
||||
SScoped -> annSDef x <$> ppTopModulePath x
|
||||
SModuleLocal -> case sing :: SStage s of
|
||||
SParsed -> ppCSymbol x
|
||||
SScoped -> ppSSymbol x
|
||||
ppModulePathType x = case sing :: SStage s of
|
||||
SParsed -> case sing :: SModuleIsTop t of
|
||||
SModuleLocal -> ppCode x
|
||||
SModuleTop -> ppCode x
|
||||
SScoped -> case sing :: SModuleIsTop t of
|
||||
SModuleLocal -> annSDef x <$> ppCode x
|
||||
SModuleTop -> annSDef x <$> ppCode x
|
||||
|
||||
ppUnkindedSymbol :: Members '[Reader Options] r => Symbol -> Sem r (Doc Ann)
|
||||
ppUnkindedSymbol = fmap (annotate AnnUnkindedSym) . ppSymbol
|
||||
|
||||
ppSymbol :: forall s r. (SingI s, Members '[Reader Options] r) => SymbolType s -> Sem r (Doc Ann)
|
||||
ppSymbol = case sing :: SStage s of
|
||||
SParsed -> ppCSymbol
|
||||
SScoped -> ppSSymbol
|
||||
SParsed -> ppCode
|
||||
SScoped -> ppCode
|
||||
|
||||
ppCSymbol :: Members '[Reader Options] r => Symbol -> Sem r (Doc Ann)
|
||||
ppCSymbol Symbol {..} = return (pretty _symbolText)
|
||||
|
||||
groupStatements :: forall s. IsStage s => [Statement s] -> [[Statement s]]
|
||||
groupStatements :: forall s. SingI s => [Statement s] -> [[Statement s]]
|
||||
groupStatements = reverse . map reverse . uncurry cons . foldl' aux ([], [])
|
||||
where
|
||||
aux :: ([Statement s], [[Statement s]]) -> Statement s
|
||||
@ -220,10 +216,14 @@ groupStatements = reverse . map reverse . uncurry cons . foldl' aux ([], [])
|
||||
(StatementPrint {}, StatementPrint {}) -> True
|
||||
(StatementPrint {}, _) -> False
|
||||
(StatementTypeSignature sig, StatementFunctionClause fun) ->
|
||||
sigName sig == clauseOwnerFunction fun
|
||||
case sing :: SStage s of
|
||||
SParsed -> sigName sig == clauseOwnerFunction fun
|
||||
SScoped -> sigName sig == clauseOwnerFunction fun
|
||||
(StatementTypeSignature {}, _) -> False
|
||||
(StatementFunctionClause fun1, StatementFunctionClause fun2) ->
|
||||
clauseOwnerFunction fun1 == clauseOwnerFunction fun2
|
||||
case sing :: SStage s of
|
||||
SParsed -> clauseOwnerFunction fun1 == clauseOwnerFunction fun2
|
||||
SScoped -> clauseOwnerFunction fun1 == clauseOwnerFunction fun2
|
||||
(StatementFunctionClause {}, _) -> False
|
||||
definesSymbol :: Symbol -> Statement s -> Bool
|
||||
definesSymbol n s = case s of
|
||||
@ -241,142 +241,132 @@ groupStatements = reverse . map reverse . uncurry cons . foldl' aux ([], [])
|
||||
SScoped -> S._nameConcrete inductiveName :
|
||||
map (S._nameConcrete . constructorName) inductiveConstructors
|
||||
|
||||
instance SingI s => PrettyCode [Statement s] where
|
||||
ppCode ss = joinGroups <$> mapM (fmap mkGroup . mapM (fmap endSemicolon . ppCode)) (groupStatements ss)
|
||||
where
|
||||
mkGroup = vsep
|
||||
joinGroups = concatWith (\a b -> a <> line <> line <> b)
|
||||
|
||||
ppStatements :: (IsStage s, Members '[Reader Options] r)
|
||||
=> [Statement s] -> Sem r (Doc Ann)
|
||||
ppStatements ss = joinGroups <$> mapM (fmap mkGroup . mapM (fmap endSemicolon . ppStatement)) (groupStatements ss)
|
||||
where
|
||||
mkGroup = vsep
|
||||
joinGroups = concatWith (\a b -> a <> line <> line <> b)
|
||||
|
||||
ppStatement :: (IsStage s, Members '[Reader Options] r) => Statement s -> Sem r (Doc Ann)
|
||||
ppStatement s = case s of
|
||||
StatementOperator op -> ppOperatorSyntaxDef op
|
||||
StatementTypeSignature sig -> ppTypeSignature sig
|
||||
StatementImport i -> ppImport i
|
||||
StatementInductive d -> ppInductiveDef d
|
||||
StatementModule m -> ppModule m
|
||||
StatementOpenModule o -> ppOpen o
|
||||
StatementFunctionClause c -> ppFunctionClause c
|
||||
StatementAxiom a -> ppAxiom a
|
||||
StatementEval e -> ppEval e
|
||||
StatementPrint p -> ppPrint p
|
||||
instance SingI s => PrettyCode (Statement s) where
|
||||
ppCode s = case s of
|
||||
StatementOperator op -> ppCode op
|
||||
StatementTypeSignature sig -> ppCode sig
|
||||
StatementImport i -> ppCode i
|
||||
StatementInductive d -> ppCode d
|
||||
StatementModule m -> ppCode m
|
||||
StatementOpenModule o -> ppCode o
|
||||
StatementFunctionClause c -> ppCode c
|
||||
StatementAxiom a -> ppCode a
|
||||
StatementEval e -> ppCode e
|
||||
StatementPrint p -> ppCode p
|
||||
|
||||
ppTopModulePath :: forall s r. (SingI s, Members '[Reader Options] r) =>
|
||||
ModulePathType s 'ModuleTop -> Sem r (Doc Ann)
|
||||
ppTopModulePath = case sing :: SStage s of
|
||||
SParsed -> ppCTopModulePath
|
||||
SScoped -> ppSTopModulePath
|
||||
|
||||
ppCTopModulePath :: Members '[Reader Options] r => TopModulePath -> Sem r (Doc Ann)
|
||||
ppCTopModulePath TopModulePath {..} =
|
||||
dotted <$> mapM ppSymbol (modulePathDir ++ [modulePathName])
|
||||
|
||||
ppSTopModulePath :: Members '[Reader Options] r => S.TopModulePath -> Sem r (Doc Ann)
|
||||
ppSTopModulePath = ppSName' ppTopModulePath
|
||||
SParsed -> ppCode
|
||||
SScoped -> ppCode
|
||||
|
||||
endSemicolon :: Doc Ann -> Doc Ann
|
||||
endSemicolon x = x <> kwSemicolon
|
||||
|
||||
ppInductiveParameters :: (IsStage s, Members '[Reader Options] r)
|
||||
instance SingI s => PrettyCode (InductiveParameter s) where
|
||||
ppCode InductiveParameter {..} = do
|
||||
inductiveParameterName' <- annDef inductiveParameterName <$> ppSymbol inductiveParameterName
|
||||
inductiveParameterType' <- case sing :: SStage s of
|
||||
SParsed -> ppCode inductiveParameterType
|
||||
SScoped -> ppCode inductiveParameterType
|
||||
return $ parens (inductiveParameterName' <+> kwColon <+> inductiveParameterType')
|
||||
|
||||
instance SingI s => PrettyCode [InductiveParameter s] where
|
||||
ppCode = fmap hsep . mapM ppCode
|
||||
|
||||
ppInductiveParameters :: (SingI s, Members '[Reader Options] r)
|
||||
=> [InductiveParameter s] -> Sem r (Maybe (Doc Ann))
|
||||
ppInductiveParameters =
|
||||
fmap (fmap (hsep . toList) . nonEmpty) . mapM ppInductiveParameter
|
||||
ppInductiveParameters ps
|
||||
| null ps = return Nothing
|
||||
| otherwise = Just <$> ppCode ps
|
||||
|
||||
ppModule :: forall t r s. (SingI t, IsStage s, Members '[Reader Options] r)
|
||||
=> Module s t -> Sem r (Doc Ann)
|
||||
ppModule Module {..} = do
|
||||
moduleBody' <- ppStatements moduleBody >>= indented
|
||||
modulePath' <- ppModulePathType modulePath
|
||||
moduleParameters' <- ppInductiveParameters moduleParameters
|
||||
return $
|
||||
kwModule <+> modulePath' <+?> moduleParameters' <> kwSemicolon <> line
|
||||
<> moduleBody'
|
||||
<> line
|
||||
<> kwEnd
|
||||
<?> lastSemicolon
|
||||
where
|
||||
lastSemicolon = case sing :: SModuleIsTop t of
|
||||
SModuleLocal -> Nothing
|
||||
SModuleTop -> Just kwSemicolon
|
||||
|
||||
ppPrecedence :: Precedence -> Doc Ann
|
||||
ppPrecedence p = annotate AnnNumber $ case p of
|
||||
PrecMinusOmega -> pretty ("-ω" :: Text)
|
||||
PrecNat n -> pretty n
|
||||
PrecOmega -> pretty ("ω" :: Text)
|
||||
|
||||
ppOperatorSyntaxDef :: Members '[Reader Options] r => OperatorSyntaxDef -> Sem r (Doc Ann)
|
||||
ppOperatorSyntaxDef OperatorSyntaxDef {..} = do
|
||||
opSymbol' <- ppUnkindedSymbol opSymbol
|
||||
return $ ppFixity opFixity <+> opSymbol'
|
||||
where
|
||||
ppFixity :: Fixity -> Doc Ann
|
||||
ppFixity Fixity {..} =
|
||||
ppArity <+> ppPrecedence fixityPrecedence
|
||||
instance (SingI s, SingI t) => PrettyCode (Module s t) where
|
||||
ppCode Module {..} = do
|
||||
moduleBody' <- ppCode moduleBody >>= indented
|
||||
modulePath' <- ppModulePathType modulePath
|
||||
moduleParameters' <- ppInductiveParameters moduleParameters
|
||||
return $
|
||||
kwModule <+> modulePath' <+?> moduleParameters' <> kwSemicolon <> line
|
||||
<> moduleBody'
|
||||
<> line
|
||||
<> kwEnd
|
||||
<?> lastSemicolon
|
||||
where
|
||||
ppArity :: Doc Ann
|
||||
ppArity = case fixityArity of
|
||||
Unary {} -> kwPostfix
|
||||
Binary p -> case p of
|
||||
AssocRight -> kwInfixr
|
||||
AssocLeft -> kwInfixl
|
||||
AssocNone -> kwInfix
|
||||
lastSemicolon = case sing :: SModuleIsTop t of
|
||||
SModuleLocal -> Nothing
|
||||
SModuleTop -> Just kwSemicolon
|
||||
|
||||
ppInductiveConstructorDef :: (IsStage s, Members '[Reader Options] r)
|
||||
=> InductiveConstructorDef s -> Sem r (Doc Ann)
|
||||
ppInductiveConstructorDef InductiveConstructorDef {..} = do
|
||||
constructorName' <- annDef constructorName <$> ppSymbol constructorName
|
||||
constructorType' <- ppExpression constructorType
|
||||
return $ constructorName' <+> kwColon <+> constructorType'
|
||||
instance PrettyCode Precedence where
|
||||
ppCode p = return $ annotate AnnNumber $ case p of
|
||||
PrecMinusOmega -> pretty ("-ω" :: Text)
|
||||
PrecNat n -> pretty n
|
||||
PrecOmega -> pretty ("ω" :: Text)
|
||||
|
||||
ppInductiveDef :: forall r s. (IsStage s, Members '[Reader Options] r) =>
|
||||
InductiveDef s -> Sem r (Doc Ann)
|
||||
ppInductiveDef InductiveDef {..} = do
|
||||
inductiveName' <- annDef inductiveName <$> ppSymbol inductiveName
|
||||
inductiveParameters' <- ppInductiveParameters inductiveParameters
|
||||
inductiveType' <- ppTypeType
|
||||
inductiveConstructors' <- ppBlock ppInductiveConstructorDef inductiveConstructors
|
||||
return $
|
||||
kwInductive <+> inductiveName' <+?> inductiveParameters' <+?> inductiveType'
|
||||
<+> inductiveConstructors'
|
||||
where
|
||||
ppTypeType :: Sem r (Maybe (Doc Ann))
|
||||
ppTypeType = case inductiveType of
|
||||
Nothing -> return Nothing
|
||||
Just e -> Just . (kwColon <+>) <$> ppExpression e
|
||||
instance PrettyCode Fixity where
|
||||
ppCode Fixity {..} = do
|
||||
fixityPrecedence' <- ppCode fixityPrecedence
|
||||
fixityArity' <- ppCode fixityArity
|
||||
return $ fixityArity' <+> fixityPrecedence'
|
||||
|
||||
ppInductiveParameter :: (IsStage s, Members '[Reader Options] r) => InductiveParameter s -> Sem r (Doc Ann)
|
||||
ppInductiveParameter InductiveParameter {..} = do
|
||||
inductiveParameterName' <- annDef inductiveParameterName <$> ppSymbol inductiveParameterName
|
||||
inductiveParameterType' <- ppExpression inductiveParameterType
|
||||
return $ parens (inductiveParameterName' <+> kwColon <+> inductiveParameterType')
|
||||
instance PrettyCode OperatorArity where
|
||||
ppCode fixityArity = return $ case fixityArity of
|
||||
Unary {} -> kwPostfix
|
||||
Binary p -> case p of
|
||||
AssocRight -> kwInfixr
|
||||
AssocLeft -> kwInfixl
|
||||
AssocNone -> kwInfix
|
||||
|
||||
instance PrettyCode OperatorSyntaxDef where
|
||||
ppCode OperatorSyntaxDef {..} = do
|
||||
opSymbol' <- ppUnkindedSymbol opSymbol
|
||||
opFixity' <- ppCode opFixity
|
||||
return $ opFixity' <+> opSymbol'
|
||||
|
||||
instance SingI s => PrettyCode (InductiveConstructorDef s) where
|
||||
ppCode InductiveConstructorDef {..} = do
|
||||
constructorName' <- annDef constructorName <$> ppSymbol constructorName
|
||||
constructorType' <- ppExpression constructorType
|
||||
return $ constructorName' <+> kwColon <+> constructorType'
|
||||
|
||||
instance SingI s => PrettyCode (InductiveDef s) where
|
||||
ppCode :: forall r. Members '[Reader Options] r => InductiveDef s -> Sem r (Doc Ann)
|
||||
ppCode InductiveDef {..} = do
|
||||
inductiveName' <- annDef inductiveName <$> ppSymbol inductiveName
|
||||
inductiveParameters' <- ppInductiveParameters inductiveParameters
|
||||
inductiveType' <- ppTypeType
|
||||
inductiveConstructors' <- ppBlock inductiveConstructors
|
||||
return $
|
||||
kwInductive <+> inductiveName' <+?> inductiveParameters' <+?> inductiveType'
|
||||
<+> inductiveConstructors'
|
||||
where
|
||||
ppTypeType :: Sem r (Maybe (Doc Ann))
|
||||
ppTypeType = case inductiveType of
|
||||
Nothing -> return Nothing
|
||||
Just e -> Just . (kwColon <+>) <$> ppExpression e
|
||||
|
||||
dotted :: Foldable f => f (Doc Ann) -> Doc Ann
|
||||
dotted = concatWith (surround kwDot)
|
||||
|
||||
ppQualified :: Members '[Reader Options] r => QualifiedName -> Sem r (Doc Ann)
|
||||
ppQualified QualifiedName {..} = do
|
||||
let symbols = pathParts qualifiedPath NonEmpty.|> qualifiedSymbol
|
||||
dotted <$> mapM ppSymbol symbols
|
||||
instance PrettyCode QualifiedName where
|
||||
ppCode QualifiedName {..} = do
|
||||
let symbols = pathParts qualifiedPath NonEmpty.|> qualifiedSymbol
|
||||
dotted <$> mapM ppSymbol symbols
|
||||
|
||||
ppName :: forall s r. (SingI s, Members '[Reader Options] r) => NameType s -> Sem r (Doc Ann)
|
||||
ppName = case sing :: SStage s of
|
||||
SParsed -> ppCName
|
||||
SScoped -> ppSName
|
||||
SParsed -> ppCode
|
||||
SScoped -> ppCode
|
||||
|
||||
ppCName :: Members '[Reader Options] r => Name -> Sem r (Doc Ann)
|
||||
ppCName n = case n of
|
||||
NameUnqualified s -> ppSymbol s
|
||||
NameQualified s -> ppQualified s
|
||||
instance PrettyCode S.NameId where
|
||||
ppCode (S.NameId k) = return $ pretty k
|
||||
|
||||
ppNameId :: S.NameId -> Doc Ann
|
||||
ppNameId (S.NameId k) = pretty k
|
||||
|
||||
ppSSymbol :: Members '[Reader Options] r => S.Symbol -> Sem r (Doc Ann)
|
||||
ppSSymbol = ppSName' ppSymbol
|
||||
|
||||
annDef :: forall s. IsStage s => SymbolType s -> Doc Ann -> Doc Ann
|
||||
annDef :: forall s. SingI s => SymbolType s -> Doc Ann -> Doc Ann
|
||||
annDef nm = case sing :: SStage s of
|
||||
SScoped -> annSDef nm
|
||||
SParsed -> id
|
||||
@ -387,199 +377,204 @@ annSDef nm = annotate (AnnDef (S.absTopModulePath (S._nameDefinedIn nm)) (S._nam
|
||||
annSRef :: S.Name' n -> Doc Ann -> Doc Ann
|
||||
annSRef nm = annotate (AnnRef (S.absTopModulePath (S._nameDefinedIn nm)) (S._nameId nm))
|
||||
|
||||
annRef :: forall s. IsStage s => SymbolType s -> Doc Ann -> Doc Ann
|
||||
annRef :: forall s. SingI s => SymbolType s -> Doc Ann -> Doc Ann
|
||||
annRef nm = case sing :: SStage s of
|
||||
SParsed -> id
|
||||
SScoped -> annSRef nm
|
||||
|
||||
ppSName :: Members '[Reader Options] r => S.Name -> Sem r (Doc Ann)
|
||||
ppSName nm = annSRef nm <$> ppSName' ppName nm
|
||||
instance PrettyCode TopModulePath where
|
||||
ppCode TopModulePath {..} =
|
||||
dotted <$> mapM ppSymbol (modulePathDir ++ [modulePathName])
|
||||
|
||||
ppSName' :: Members '[Reader Options] r => (s -> Sem r (Doc Ann)) -> S.Name' s -> Sem r (Doc Ann)
|
||||
ppSName' ppConcrete S.Name' {..} = do
|
||||
nameConcrete' <- annotate (AnnKind _nameKind) <$> ppConcrete _nameConcrete
|
||||
showNameId <- asks _optShowNameId
|
||||
let uid = if showNameId then "@" <> ppNameId _nameId else mempty
|
||||
return $ nameConcrete' <> uid
|
||||
instance PrettyCode Symbol where
|
||||
ppCode = return . pretty . _symbolText
|
||||
|
||||
ppAtom :: (IsStage s, Members '[Reader Options] r) => ExpressionType s -> Sem r (Doc Ann)
|
||||
ppAtom e = parensCond (isAtomic e) <$> ppExpression e
|
||||
instance PrettyCode Name where
|
||||
ppCode n = case n of
|
||||
NameUnqualified s -> ppSymbol s
|
||||
NameQualified s -> ppCode s
|
||||
|
||||
ppOpen :: forall s r. (IsStage s, Members '[Reader Options] r)
|
||||
=> OpenModule s -> Sem r (Doc Ann)
|
||||
ppOpen OpenModule {..} = do
|
||||
openModuleName' <- ppName openModuleName
|
||||
openUsingHiding' <- sequence $ ppUsingHiding <$> openUsingHiding
|
||||
openParameters' <- ppOpenParams
|
||||
let openPublic' = ppPublic
|
||||
return $ keyword "open" <+> openModuleName' <+?> openParameters' <+?> openUsingHiding' <+?> openPublic'
|
||||
where
|
||||
ppOpenParams :: Sem r (Maybe (Doc Ann))
|
||||
ppOpenParams = case openParameters of
|
||||
[] -> return Nothing
|
||||
_ -> Just . hsep <$> mapM ppAtom openParameters
|
||||
ppUsingHiding :: UsingHiding -> Sem r (Doc Ann)
|
||||
ppUsingHiding uh = do
|
||||
bracedList <- encloseSep kwBraceL kwBraceR kwSemicolon . toList
|
||||
<$> mapM ppUnkindedSymbol syms
|
||||
return $ kw <+> bracedList
|
||||
instance PrettyCode n => PrettyCode (S.Name' n) where
|
||||
ppCode S.Name' {..} = do
|
||||
nameConcrete' <- annotate (AnnKind _nameKind) <$> ppCode _nameConcrete
|
||||
showNameId <- asks _optShowNameId
|
||||
uid <- if showNameId then ("@" <>) <$> ppCode _nameId else return mempty
|
||||
return $ nameConcrete' <> uid
|
||||
|
||||
instance SingI s => PrettyCode (OpenModule s) where
|
||||
ppCode :: forall r. Members '[Reader Options] r => OpenModule s -> Sem r (Doc Ann)
|
||||
ppCode OpenModule {..} = do
|
||||
openModuleName' <- ppName openModuleName
|
||||
openUsingHiding' <- sequence $ ppUsingHiding <$> openUsingHiding
|
||||
openParameters' <- ppOpenParams
|
||||
let openPublic' = ppPublic
|
||||
return $ keyword "open" <+> openModuleName' <+?> openParameters' <+?> openUsingHiding' <+?> openPublic'
|
||||
where
|
||||
(kw, syms) = case uh of
|
||||
Using s -> (kwUsing, s)
|
||||
Hiding s -> (kwHiding, s)
|
||||
ppPublic :: Maybe (Doc Ann)
|
||||
ppPublic = case openPublic of
|
||||
Public -> Just kwPublic
|
||||
NoPublic -> Nothing
|
||||
|
||||
ppTypeSignature :: (IsStage s, Members '[Reader Options] r) => TypeSignature s -> Sem r (Doc Ann)
|
||||
ppTypeSignature TypeSignature {..} = do
|
||||
sigName' <- annDef sigName <$> ppSymbol sigName
|
||||
sigType' <- ppExpression sigType
|
||||
return $ sigName' <+> kwColon <+> sigType'
|
||||
|
||||
ppFunction :: forall s r. (IsStage s, Members '[Reader Options] r) => Function s -> Sem r (Doc Ann)
|
||||
ppFunction Function {..} = do
|
||||
funParameter' <- ppFunParameter funParameter
|
||||
funReturn' <- ppRightExpression funFixity funReturn
|
||||
return $ funParameter' <+> kwArrowR <+> funReturn'
|
||||
where
|
||||
ppUsage :: Maybe Usage -> Doc Ann
|
||||
ppUsage m = case m of
|
||||
Nothing -> kwColon
|
||||
Just u -> case u of
|
||||
UsageNone -> kwColonZero
|
||||
UsageOnce -> kwColonOne
|
||||
UsageOmega -> kwColonOmega
|
||||
ppFunParameter :: FunctionParameter s -> Sem r (Doc Ann)
|
||||
ppFunParameter FunctionParameter {..} = do
|
||||
case paramName of
|
||||
Nothing -> ppLeftExpression funFixity paramType
|
||||
Just n -> do
|
||||
paramName' <- annDef n <$> ppSymbol n
|
||||
paramType' <- ppExpression paramType
|
||||
return $ parens (paramName' <+> ppUsage paramUsage <+> paramType')
|
||||
|
||||
ppUniverse :: Members '[Reader Options] r => Universe -> Sem r (Doc Ann)
|
||||
ppUniverse (Universe n) = return $ kwType <+?> (pretty <$> n)
|
||||
|
||||
ppLetBlock :: forall s r. (IsStage s, Members '[Reader Options] r) => LetBlock s -> Sem r (Doc Ann)
|
||||
ppLetBlock LetBlock {..} = do
|
||||
letClauses' <- ppBlock ppLetClause letClauses
|
||||
letExpression' <- ppExpression letExpression
|
||||
return $ kwLet <+> letClauses' <+> kwIn <+> letExpression'
|
||||
where
|
||||
ppLetClause :: LetClause s -> Sem r (Doc Ann)
|
||||
ppLetClause c = case c of
|
||||
LetTypeSig sig -> ppTypeSignature sig
|
||||
LetFunClause cl -> ppFunctionClause cl
|
||||
|
||||
ppBlock :: Members '[Reader Options] r => (a -> Sem r (Doc Ann)) -> [a] -> Sem r (Doc Ann)
|
||||
ppBlock ppItem items = mapM (fmap endSemicolon . ppItem) items >>= bracesIndent . vsep
|
||||
|
||||
ppMatch :: forall s r. (IsStage s, Members '[Reader Options] r) => Match s -> Sem r (Doc Ann)
|
||||
ppMatch Match {..} = do
|
||||
matchExpression' <- ppExpression matchExpression
|
||||
matchAlts' <- ppBlock ppMatchAlt matchAlts
|
||||
return $ kwMatch <+> matchExpression' <+> matchAlts'
|
||||
where
|
||||
ppMatchAlt :: MatchAlt s -> Sem r (Doc Ann)
|
||||
ppMatchAlt MatchAlt {..} = do
|
||||
matchAltPattern' <- ppPattern matchAltPattern
|
||||
matchAltBody' <- ppExpression matchAltBody
|
||||
return $ matchAltPattern' <+> kwMapsto <+> matchAltBody'
|
||||
|
||||
ppLambda :: forall r s. (IsStage s, Members '[Reader Options] r) => Lambda s -> Sem r (Doc Ann)
|
||||
ppLambda Lambda {..} = do
|
||||
lambdaClauses' <- ppBlock ppLambdaClause lambdaClauses
|
||||
return $ kwLambda <+> lambdaClauses'
|
||||
where
|
||||
ppLambdaClause :: LambdaClause s -> Sem r (Doc Ann)
|
||||
ppLambdaClause LambdaClause {..} = do
|
||||
lambdaParameters' <- hsep . toList <$> mapM ppPattern lambdaParameters
|
||||
lambdaBody' <- ppExpression lambdaBody
|
||||
return $ lambdaParameters' <+> kwMapsto <+> lambdaBody'
|
||||
|
||||
ppFunctionClause :: forall r s. (IsStage s, Members '[Reader Options] r)
|
||||
=> FunctionClause s -> Sem r (Doc Ann)
|
||||
ppFunctionClause FunctionClause {..} = do
|
||||
clauseOwnerFunction' <- annRef clauseOwnerFunction <$> ppSymbol clauseOwnerFunction
|
||||
clausePatterns' <- case nonEmpty clausePatterns of
|
||||
Nothing -> return Nothing
|
||||
Just ne -> Just . hsep . toList <$> mapM ppPattern ne
|
||||
clauseBody' <- ppExpression clauseBody
|
||||
clauseWhere' <- sequence (ppWhereBlock <$> clauseWhere)
|
||||
return $
|
||||
clauseOwnerFunction' <+?> clausePatterns' <+> kwAssignment <+> clauseBody'
|
||||
<+?> ((line <>) <$> clauseWhere')
|
||||
where
|
||||
ppWhereBlock :: WhereBlock s -> Sem r (Doc Ann)
|
||||
ppWhereBlock WhereBlock {..} =
|
||||
ppBlock ppWhereClause whereClauses >>= indented . (kwWhere <+>)
|
||||
ppAtom' = case sing :: SStage s of
|
||||
SParsed -> ppCodeAtom
|
||||
SScoped -> ppCodeAtom
|
||||
ppOpenParams :: Sem r (Maybe (Doc Ann))
|
||||
ppOpenParams = case openParameters of
|
||||
[] -> return Nothing
|
||||
_ -> Just . hsep <$> mapM ppAtom' openParameters
|
||||
ppUsingHiding :: UsingHiding -> Sem r (Doc Ann)
|
||||
ppUsingHiding uh = do
|
||||
bracedList <- encloseSep kwBraceL kwBraceR kwSemicolon . toList
|
||||
<$> mapM ppUnkindedSymbol syms
|
||||
return $ kw <+> bracedList
|
||||
where
|
||||
ppWhereClause :: WhereClause s -> Sem r (Doc Ann)
|
||||
ppWhereClause c = case c of
|
||||
WhereOpenModule o -> ppOpen o
|
||||
WhereTypeSig sig -> ppTypeSignature sig
|
||||
WhereFunClause fun -> ppFunctionClause fun
|
||||
(kw, syms) = case uh of
|
||||
Using s -> (kwUsing, s)
|
||||
Hiding s -> (kwHiding, s)
|
||||
ppPublic :: Maybe (Doc Ann)
|
||||
ppPublic = case openPublic of
|
||||
Public -> Just kwPublic
|
||||
NoPublic -> Nothing
|
||||
|
||||
ppAxiom :: (IsStage s, Members '[Reader Options] r) => AxiomDef s -> Sem r (Doc Ann)
|
||||
ppAxiom AxiomDef {..} = do
|
||||
axiomName' <- ppSymbol axiomName
|
||||
axiomType' <- ppExpression axiomType
|
||||
return $ kwAxiom <+> axiomName' <+> kwColon <+> axiomType'
|
||||
instance SingI s => PrettyCode (TypeSignature s) where
|
||||
ppCode TypeSignature {..} = do
|
||||
sigName' <- annDef sigName <$> ppSymbol sigName
|
||||
sigType' <- ppExpression sigType
|
||||
return $ sigName' <+> kwColon <+> sigType'
|
||||
|
||||
ppEval :: (IsStage s, Members '[Reader Options] r) => Eval s -> Sem r (Doc Ann)
|
||||
ppEval (Eval p) = do
|
||||
p' <- ppExpression p
|
||||
return $ kwEval <+> p'
|
||||
instance SingI s => PrettyCode (Function s) where
|
||||
ppCode :: forall r. Members '[Reader Options] r => Function s -> Sem r (Doc Ann)
|
||||
ppCode Function {..} = do
|
||||
funParameter' <- ppFunParameter funParameter
|
||||
funReturn' <- ppRightExpression' funFixity funReturn
|
||||
return $ funParameter' <+> kwArrowR <+> funReturn'
|
||||
where
|
||||
ppRightExpression' = case sing :: SStage s of
|
||||
SParsed -> ppRightExpression
|
||||
SScoped -> ppRightExpression
|
||||
ppLeftExpression' = case sing :: SStage s of
|
||||
SParsed -> ppLeftExpression
|
||||
SScoped -> ppLeftExpression
|
||||
ppUsage :: Maybe Usage -> Doc Ann
|
||||
ppUsage m = case m of
|
||||
Nothing -> kwColon
|
||||
Just u -> case u of
|
||||
UsageNone -> kwColonZero
|
||||
UsageOnce -> kwColonOne
|
||||
UsageOmega -> kwColonOmega
|
||||
ppFunParameter :: FunctionParameter s -> Sem r (Doc Ann)
|
||||
ppFunParameter FunctionParameter {..} = do
|
||||
case paramName of
|
||||
Nothing -> ppLeftExpression' funFixity paramType
|
||||
Just n -> do
|
||||
paramName' <- annDef n <$> ppSymbol n
|
||||
paramType' <- ppExpression paramType
|
||||
return $ parens (paramName' <+> ppUsage paramUsage <+> paramType')
|
||||
|
||||
ppPrint :: (IsStage s, Members '[Reader Options] r) => Print s -> Sem r (Doc Ann)
|
||||
ppPrint (Print p) = do
|
||||
p' <- ppExpression p
|
||||
return $ kwPrint <+> p'
|
||||
instance PrettyCode Universe where
|
||||
ppCode (Universe n) = return $ kwType <+?> (pretty <$> n)
|
||||
|
||||
ppImport :: forall r s. (IsStage s, Members '[Reader Options] r) => Import s -> Sem r (Doc Ann)
|
||||
ppImport (Import m) = do
|
||||
modulePath' <- ppModulePath
|
||||
inlineImport' <- inlineImport
|
||||
return $ kwImport <+> modulePath' <+?> inlineImport'
|
||||
where
|
||||
ppModulePath = case sing :: SStage s of
|
||||
SParsed -> ppCTopModulePath m
|
||||
SScoped -> annSRef (modulePath m) <$> ppTopModulePath (modulePath m)
|
||||
jumpLines :: Doc Ann -> Doc Ann
|
||||
jumpLines x = line <> x <> line
|
||||
inlineImport :: Sem r (Maybe (Doc Ann))
|
||||
inlineImport = do
|
||||
b <- asks _optInlineImports
|
||||
if b then case sing :: SStage s of
|
||||
SParsed -> return Nothing
|
||||
SScoped -> ppModule m >>= fmap (Just . braces . jumpLines) . indented
|
||||
else return Nothing
|
||||
instance SingI s => PrettyCode (LetBlock s) where
|
||||
ppCode LetBlock {..} = do
|
||||
letClauses' <- ppBlock letClauses
|
||||
letExpression' <- ppExpression letExpression
|
||||
return $ kwLet <+> letClauses' <+> kwIn <+> letExpression'
|
||||
|
||||
ppPattern :: forall s r. (IsStage s, Members '[Reader Options] r) => PatternType s -> Sem r (Doc Ann)
|
||||
ppPattern = case sing :: SStage s of
|
||||
SParsed -> ppCPattern
|
||||
SScoped -> ppSPattern
|
||||
instance SingI s => PrettyCode (LetClause s) where
|
||||
ppCode c = case c of
|
||||
LetTypeSig sig -> ppCode sig
|
||||
LetFunClause cl -> ppCode cl
|
||||
|
||||
ppCPattern :: forall r. Members '[Reader Options] r => PatternAtom 'Parsed -> Sem r (Doc Ann)
|
||||
ppCPattern a = case a of
|
||||
PatternAtomName n -> ppName n
|
||||
PatternAtomWildcard -> return kwWildcard
|
||||
PatternAtomEmpty -> return $ parens mempty
|
||||
PatternAtomParens p -> parens <$> ppCPatterns p
|
||||
ppBlock :: (PrettyCode a, Members '[Reader Options] r) => [a] -> Sem r (Doc Ann)
|
||||
ppBlock items = mapM (fmap endSemicolon . ppCode) items >>= bracesIndent . vsep
|
||||
|
||||
ppCPatterns :: forall r. Members '[Reader Options] r => PatternAtoms 'Parsed -> Sem r (Doc Ann)
|
||||
ppCPatterns (PatternAtoms ps) = hsep . toList <$> mapM ppCPattern ps
|
||||
instance SingI s => PrettyCode (MatchAlt s) where
|
||||
ppCode MatchAlt {..} = do
|
||||
matchAltPattern' <- ppPattern matchAltPattern
|
||||
matchAltBody' <- ppExpression matchAltBody
|
||||
return $ matchAltPattern' <+> kwMapsto <+> matchAltBody'
|
||||
|
||||
ppSPattern :: forall r. Members '[Reader Options] r => Pattern -> Sem r (Doc Ann)
|
||||
ppSPattern pat = do
|
||||
p' <- ppNestedPattern pat
|
||||
return $ if isAtomicPat pat then p' else parens p'
|
||||
where
|
||||
isAtomicPat :: Pattern -> Bool
|
||||
isAtomicPat p = case p of
|
||||
instance SingI s => PrettyCode (Match s) where
|
||||
ppCode Match {..} = do
|
||||
matchExpression' <- ppExpression matchExpression
|
||||
matchAlts' <- ppBlock matchAlts
|
||||
return $ kwMatch <+> matchExpression' <+> matchAlts'
|
||||
|
||||
instance SingI s => PrettyCode (LambdaClause s) where
|
||||
ppCode LambdaClause {..} = do
|
||||
lambdaParameters' <- hsep . toList <$> mapM ppPatternAtom lambdaParameters
|
||||
lambdaBody' <- ppExpression lambdaBody
|
||||
return $ lambdaParameters' <+> kwMapsto <+> lambdaBody'
|
||||
|
||||
instance SingI s => PrettyCode (Lambda s) where
|
||||
ppCode Lambda {..} = do
|
||||
lambdaClauses' <- ppBlock lambdaClauses
|
||||
return $ kwLambda <+> lambdaClauses'
|
||||
|
||||
instance SingI s => PrettyCode (FunctionClause s) where
|
||||
ppCode FunctionClause {..} = do
|
||||
clauseOwnerFunction' <- annRef clauseOwnerFunction <$> ppSymbol clauseOwnerFunction
|
||||
clausePatterns' <- case nonEmpty clausePatterns of
|
||||
Nothing -> return Nothing
|
||||
Just ne -> Just . hsep . toList <$> mapM ppPatternAtom ne
|
||||
clauseBody' <- ppExpression clauseBody
|
||||
clauseWhere' <- sequence (ppCode <$> clauseWhere)
|
||||
return $
|
||||
clauseOwnerFunction' <+?> clausePatterns' <+> kwAssignment <+> clauseBody'
|
||||
<+?> ((line <>) <$> clauseWhere')
|
||||
|
||||
instance SingI s => PrettyCode (WhereBlock s) where
|
||||
ppCode WhereBlock {..} = ppBlock whereClauses >>= indented . (kwWhere <+>)
|
||||
|
||||
instance SingI s => PrettyCode (WhereClause s) where
|
||||
ppCode c = case c of
|
||||
WhereOpenModule o -> ppCode o
|
||||
WhereTypeSig sig -> ppCode sig
|
||||
WhereFunClause fun -> ppCode fun
|
||||
|
||||
instance SingI s => PrettyCode (AxiomDef s) where
|
||||
ppCode AxiomDef {..} = do
|
||||
axiomName' <- ppSymbol axiomName
|
||||
axiomType' <- ppExpression axiomType
|
||||
return $ kwAxiom <+> axiomName' <+> kwColon <+> axiomType'
|
||||
|
||||
instance SingI s => PrettyCode (Eval s) where
|
||||
ppCode (Eval p) = do
|
||||
p' <- ppExpression p
|
||||
return $ kwEval <+> p'
|
||||
|
||||
instance SingI s => PrettyCode (Print s) where
|
||||
ppCode (Print p) = do
|
||||
p' <- ppExpression p
|
||||
return $ kwPrint <+> p'
|
||||
|
||||
instance SingI s => PrettyCode (Import s) where
|
||||
ppCode :: forall r. Members '[Reader Options] r => Import s -> Sem r (Doc Ann)
|
||||
ppCode (Import m) = do
|
||||
modulePath' <- ppModulePath
|
||||
inlineImport' <- inlineImport
|
||||
return $ kwImport <+> modulePath' <+?> inlineImport'
|
||||
where
|
||||
ppModulePath = case sing :: SStage s of
|
||||
SParsed -> ppCode m
|
||||
SScoped -> annSRef (modulePath m) <$> ppTopModulePath (modulePath m)
|
||||
jumpLines :: Doc Ann -> Doc Ann
|
||||
jumpLines x = line <> x <> line
|
||||
inlineImport :: Sem r (Maybe (Doc Ann))
|
||||
inlineImport = do
|
||||
b <- asks _optInlineImports
|
||||
if b then case sing :: SStage s of
|
||||
SParsed -> return Nothing
|
||||
SScoped -> ppCode m >>= fmap (Just . braces . jumpLines) . indented
|
||||
else return Nothing
|
||||
|
||||
instance PrettyCode (PatternAtom 'Parsed) where
|
||||
ppCode a = case a of
|
||||
PatternAtomName n -> ppName n
|
||||
PatternAtomWildcard -> return kwWildcard
|
||||
PatternAtomEmpty -> return $ parens mempty
|
||||
PatternAtomParens p -> parens <$> ppCode p
|
||||
|
||||
instance PrettyCode (PatternAtoms 'Parsed) where
|
||||
ppCode (PatternAtoms ps) = hsep . toList <$> mapM ppCode ps
|
||||
|
||||
instance HasAtoms Pattern where
|
||||
isAtomic p = case p of
|
||||
PatternVariable {} -> True
|
||||
PatternApplication {} -> False
|
||||
PatternConstructor {} -> True
|
||||
@ -588,39 +583,29 @@ ppSPattern pat = do
|
||||
PatternWildcard -> True
|
||||
PatternEmpty -> True
|
||||
|
||||
ppPattern :: forall s r. (SingI s, Members '[Reader Options] r) => PatternType s -> Sem r (Doc Ann)
|
||||
ppPattern = case sing :: SStage s of
|
||||
SParsed -> ppCode
|
||||
SScoped -> ppCode
|
||||
|
||||
ppNestedPattern :: forall r. Members '[Reader Options] r => Pattern -> Sem r (Doc Ann)
|
||||
ppNestedPattern = go
|
||||
where
|
||||
go :: Pattern -> Sem r (Doc Ann)
|
||||
go p = case p of
|
||||
PatternVariable v -> annDef v <$> ppSSymbol v
|
||||
PatternApplication l r -> do
|
||||
l' <- ppLeftExpression appFixity l
|
||||
r' <- ppRightExpression appFixity r
|
||||
return $ l' <+> r'
|
||||
PatternWildcard -> return kwWildcard
|
||||
PatternEmpty -> return $ parens mempty
|
||||
PatternConstructor constr -> ppSName constr
|
||||
PatternInfixApplication i -> ppPatternInfixApp i
|
||||
PatternPostfixApplication i -> ppPatternPostfixApp i
|
||||
ppPatternAtom :: forall s r. (SingI s, Members '[Reader Options] r) => PatternType s -> Sem r (Doc Ann)
|
||||
ppPatternAtom = case sing :: SStage s of
|
||||
SParsed -> ppCodeAtom
|
||||
SScoped -> ppCodeAtom
|
||||
|
||||
ppPatternInfixApp :: PatternInfixApp -> Sem r (Doc Ann)
|
||||
ppPatternInfixApp p@PatternInfixApp {..} = do
|
||||
patInfixConstructor' <- ppSName patInfixConstructor
|
||||
patInfixLeft' <- ppLeftExpression (pinfixFixity p) patInfixLeft
|
||||
patInfixRight' <- ppRightExpression (pinfixFixity p) patInfixRight
|
||||
return $ patInfixLeft' <+> patInfixConstructor' <+> patInfixRight'
|
||||
ppCodeAtom :: (HasAtoms c, PrettyCode c, Members '[Reader Options] r) => c -> Sem r (Doc Ann)
|
||||
ppCodeAtom c = do
|
||||
p' <- ppCode c
|
||||
return $ if isAtomic c then p' else parens p'
|
||||
|
||||
ppPatternPostfixApp :: PatternPostfixApp -> Sem r (Doc Ann)
|
||||
ppPatternPostfixApp p@PatternPostfixApp {..} = do
|
||||
patPostfixConstructor' <- ppSName patPostfixConstructor
|
||||
patPostfixParameter' <- ppLeftExpression (ppostfixFixity p) patPostfixParameter
|
||||
return $ patPostfixParameter' <+> patPostfixConstructor'
|
||||
instance HasAtoms (PatternAtom s) where
|
||||
isAtomic = const True
|
||||
|
||||
isAtomic :: forall s. IsStage s => ExpressionType s -> Bool
|
||||
isAtomic e = case sing :: SStage s of
|
||||
SScoped -> case e of
|
||||
class HasAtoms c where
|
||||
isAtomic :: c -> Bool
|
||||
|
||||
instance HasAtoms Expression where
|
||||
isAtomic e = case e of
|
||||
ExpressionIdentifier {} -> True
|
||||
ExpressionParensIdentifier {} -> True
|
||||
ExpressionApplication {} -> False
|
||||
@ -631,34 +616,72 @@ isAtomic e = case sing :: SStage s of
|
||||
ExpressionLetBlock {} -> True
|
||||
ExpressionUniverse {} -> True
|
||||
ExpressionFunction {} -> False
|
||||
SParsed -> case e of
|
||||
|
||||
instance HasAtoms (ExpressionAtoms s) where
|
||||
isAtomic e = case e of
|
||||
ExpressionAtoms (_ :| []) -> True
|
||||
ExpressionAtoms (_ :| _) -> False
|
||||
|
||||
ppInfixApplication :: forall r. Members '[Reader Options] r => InfixApplication -> Sem r (Doc Ann)
|
||||
ppInfixApplication i@InfixApplication {..} = do
|
||||
infixAppLeft' <- ppLeftExpression (infixFixity i) infixAppLeft
|
||||
infixAppOperator' <- ppSName infixAppOperator
|
||||
infixAppRight' <- ppRightExpression (infixFixity i) infixAppRight
|
||||
return $ infixAppLeft' <+> infixAppOperator' <+> infixAppRight'
|
||||
instance PrettyCode InfixApplication where
|
||||
ppCode i@InfixApplication {..} = do
|
||||
infixAppLeft' <- ppLeftExpression (infixFixity i) infixAppLeft
|
||||
infixAppOperator' <- ppCode infixAppOperator
|
||||
infixAppRight' <- ppRightExpression (infixFixity i) infixAppRight
|
||||
return $ infixAppLeft' <+> infixAppOperator' <+> infixAppRight'
|
||||
|
||||
ppPostfixApplication :: forall r. Members '[Reader Options] r => PostfixApplication -> Sem r (Doc Ann)
|
||||
ppPostfixApplication i@PostfixApplication {..} = do
|
||||
postfixAppParameter' <- ppPostExpression (postfixFixity i) postfixAppParameter
|
||||
postfixAppOperator' <- ppSName postfixAppOperator
|
||||
return $ postfixAppParameter' <+> postfixAppOperator'
|
||||
instance PrettyCode PostfixApplication where
|
||||
ppCode i@PostfixApplication {..} = do
|
||||
postfixAppParameter' <- ppPostExpression (postfixFixity i) postfixAppParameter
|
||||
postfixAppOperator' <- ppCode postfixAppOperator
|
||||
return $ postfixAppParameter' <+> postfixAppOperator'
|
||||
|
||||
class PrettyCode a where
|
||||
ppCode :: forall r. Members '[Reader Options] r => a -> Sem r (Doc Ann)
|
||||
instance PrettyCode Application where
|
||||
ppCode (Application l r) = do
|
||||
-- Note: parentheses on the left of an application are never necessary,
|
||||
-- but I prefer homogeneous code.
|
||||
l' <- ppLeftExpression appFixity l
|
||||
r' <- ppRightExpression appFixity r
|
||||
return $ l' <+> r'
|
||||
|
||||
instance PrettyCode Expression where
|
||||
ppCode = ppExpression
|
||||
ppCode e = case e of
|
||||
ExpressionIdentifier n -> ppCode n
|
||||
ExpressionParensIdentifier n -> parens <$> ppCode n
|
||||
ExpressionApplication a -> ppCode a
|
||||
ExpressionInfixApplication a -> ppCode a
|
||||
ExpressionPostfixApplication a -> ppCode a
|
||||
ExpressionLambda l -> ppCode l
|
||||
ExpressionMatch m -> ppCode m
|
||||
ExpressionLetBlock lb -> ppCode lb
|
||||
ExpressionUniverse u -> ppCode u
|
||||
ExpressionFunction f -> ppCode f
|
||||
|
||||
instance PrettyCode Pattern where
|
||||
ppCode = ppNestedPattern
|
||||
ppCode :: forall r. Members '[Reader Options] r => Pattern -> Sem r (Doc Ann)
|
||||
ppCode pat = case pat of
|
||||
PatternVariable v -> annDef v <$> ppCode v
|
||||
PatternApplication l r -> do
|
||||
l' <- ppLeftExpression appFixity l
|
||||
r' <- ppRightExpression appFixity r
|
||||
return $ l' <+> r'
|
||||
PatternWildcard -> return kwWildcard
|
||||
PatternEmpty -> return $ parens mempty
|
||||
PatternConstructor constr -> ppCode constr
|
||||
PatternInfixApplication i -> ppPatternInfixApp i
|
||||
PatternPostfixApplication i -> ppPatternPostfixApp i
|
||||
where
|
||||
ppPatternInfixApp :: PatternInfixApp -> Sem r (Doc Ann)
|
||||
ppPatternInfixApp p@PatternInfixApp {..} = do
|
||||
patInfixConstructor' <- ppCode patInfixConstructor
|
||||
patInfixLeft' <- ppLeftExpression (pinfixFixity p) patInfixLeft
|
||||
patInfixRight' <- ppRightExpression (pinfixFixity p) patInfixRight
|
||||
return $ patInfixLeft' <+> patInfixConstructor' <+> patInfixRight'
|
||||
|
||||
instance PrettyCode (ExpressionAtoms 'Parsed) where
|
||||
ppCode = goAtoms
|
||||
ppPatternPostfixApp :: PatternPostfixApp -> Sem r (Doc Ann)
|
||||
ppPatternPostfixApp p@PatternPostfixApp {..} = do
|
||||
patPostfixConstructor' <- ppCode patPostfixConstructor
|
||||
patPostfixParameter' <- ppLeftExpression (ppostfixFixity p) patPostfixParameter
|
||||
return $ patPostfixParameter' <+> patPostfixConstructor'
|
||||
|
||||
class HasFixity a where
|
||||
getFixity :: a -> Maybe Fixity
|
||||
@ -686,7 +709,6 @@ instance HasFixity Pattern where
|
||||
PatternWildcard -> Nothing
|
||||
PatternEmpty -> Nothing
|
||||
|
||||
-- TODO never used.
|
||||
instance HasFixity (ExpressionAtoms 'Parsed) where
|
||||
getFixity = const Nothing
|
||||
|
||||
@ -747,11 +769,11 @@ ppPostExpression ::(PrettyCode a, HasFixity a, Member (Reader Options) r) =>
|
||||
Fixity -> a -> Sem r (Doc Ann)
|
||||
ppPostExpression = ppLRExpression isPostfixAssoc
|
||||
|
||||
ppRightExpression :: (PrettyCode a, HasFixity a, Member (Reader Options) r ) =>
|
||||
ppRightExpression :: (PrettyCode a, HasFixity a, Member (Reader Options) r) =>
|
||||
Fixity -> a -> Sem r (Doc Ann)
|
||||
ppRightExpression = ppLRExpression isRightAssoc
|
||||
|
||||
ppLeftExpression :: (PrettyCode a, HasFixity a, Member (Reader Options) r ) =>
|
||||
ppLeftExpression :: (PrettyCode a, HasFixity a, Member (Reader Options) r) =>
|
||||
Fixity -> a -> Sem r (Doc Ann)
|
||||
ppLeftExpression = ppLRExpression isLeftAssoc
|
||||
|
||||
@ -762,41 +784,21 @@ ppLRExpression associates atom e =
|
||||
parensCond (atomParens associates (getFixity e) atom)
|
||||
<$> ppCode e
|
||||
|
||||
goAtom :: forall r. Members '[Reader Options] r => ExpressionAtom 'Parsed -> Sem r (Doc Ann)
|
||||
goAtom a = case a of
|
||||
AtomIdentifier n -> ppName n
|
||||
AtomLambda l -> ppLambda l
|
||||
AtomLetBlock lb -> ppLetBlock lb
|
||||
AtomUniverse uni -> ppUniverse uni
|
||||
AtomFunction fun -> ppFunction fun
|
||||
AtomFunArrow -> return kwArrowR
|
||||
AtomMatch m -> ppMatch m
|
||||
AtomParens e -> parens <$> goAtoms e
|
||||
instance SingI s => PrettyCode (ExpressionAtom s) where
|
||||
ppCode a = case a of
|
||||
AtomIdentifier n -> ppName n
|
||||
AtomLambda l -> ppCode l
|
||||
AtomLetBlock lb -> ppCode lb
|
||||
AtomUniverse uni -> ppCode uni
|
||||
AtomFunction fun -> ppCode fun
|
||||
AtomFunArrow -> return kwArrowR
|
||||
AtomMatch m -> ppCode m
|
||||
AtomParens e -> parens <$> ppExpression e
|
||||
|
||||
goAtoms :: forall r. Members '[Reader Options] r => ExpressionAtoms 'Parsed -> Sem r (Doc Ann)
|
||||
goAtoms (ExpressionAtoms l) = hsep . toList <$> mapM goAtom l
|
||||
instance SingI s => PrettyCode (ExpressionAtoms s) where
|
||||
ppCode (ExpressionAtoms l) = hsep . toList <$> mapM ppCode l
|
||||
|
||||
ppExpression :: forall s r. (IsStage s, Members '[Reader Options] r) => ExpressionType s -> Sem r (Doc Ann)
|
||||
ppExpression :: forall s r. (SingI s, Members '[Reader Options] r) => ExpressionType s -> Sem r (Doc Ann)
|
||||
ppExpression = case sing :: SStage s of
|
||||
SScoped -> go
|
||||
SParsed -> goAtoms
|
||||
where
|
||||
ppApplication :: Application -> Sem r (Doc Ann)
|
||||
ppApplication (Application l r) = do
|
||||
-- Note: parentheses on the left of an application are never necessary,
|
||||
-- but I prefer homogeneous code.
|
||||
l' <- ppLeftExpression appFixity l
|
||||
r' <- ppRightExpression appFixity r
|
||||
return $ l' <+> r'
|
||||
go :: Expression -> Sem r (Doc Ann)
|
||||
go e = case e of
|
||||
ExpressionIdentifier n -> ppSName n
|
||||
ExpressionParensIdentifier n -> parens <$> ppSName n
|
||||
ExpressionApplication a -> ppApplication a
|
||||
ExpressionInfixApplication a -> ppInfixApplication a
|
||||
ExpressionPostfixApplication a -> ppPostfixApplication a
|
||||
ExpressionLambda l -> ppLambda l
|
||||
ExpressionMatch m -> ppMatch m
|
||||
ExpressionLetBlock lb -> ppLetBlock lb
|
||||
ExpressionUniverse u -> ppUniverse u
|
||||
ExpressionFunction f -> ppFunction f
|
||||
SScoped -> ppCode
|
||||
SParsed -> ppCode
|
||||
|
||||
@ -82,7 +82,7 @@ genModule opts theme m =
|
||||
<> prettySrc
|
||||
|
||||
docStream :: Options -> Module 'Scoped 'ModuleTop -> SimpleDocStream Ann
|
||||
docStream opts m = layoutPretty defaultLayoutOptions (prettyTopModule opts m)
|
||||
docStream opts m = layoutPretty defaultLayoutOptions (runPrettyCode opts m)
|
||||
|
||||
renderTree :: SimpleDocTree Ann -> Html
|
||||
renderTree = go
|
||||
|
||||
22
src/MiniJuvix/Syntax/Concrete/Scoped/Pretty/Text.hs
Normal file
22
src/MiniJuvix/Syntax/Concrete/Scoped/Pretty/Text.hs
Normal file
@ -0,0 +1,22 @@
|
||||
module MiniJuvix.Syntax.Concrete.Scoped.Pretty.Text where
|
||||
|
||||
import MiniJuvix.Syntax.Concrete.Scoped.Pretty.Base
|
||||
import MiniJuvix.Prelude
|
||||
import Prettyprinter
|
||||
import Prettyprinter.Render.Text
|
||||
|
||||
printPrettyCodeDefault :: PrettyCode c => c -> IO ()
|
||||
printPrettyCodeDefault = printPrettyCode defaultOptions
|
||||
|
||||
printPrettyCode :: PrettyCode c => Options -> c -> IO ()
|
||||
printPrettyCode = hPrintPrettyCode stdout
|
||||
|
||||
hPrintPrettyCode :: PrettyCode c => Handle -> Options -> c -> IO ()
|
||||
hPrintPrettyCode h opts = renderIO h . docStream opts
|
||||
|
||||
renderPrettyCode :: PrettyCode c => Options -> c -> Text
|
||||
renderPrettyCode opts = renderStrict . docStream opts
|
||||
|
||||
docStream :: PrettyCode c => Options -> c -> SimpleDocStream Ann
|
||||
docStream opts = layoutPretty defaultLayoutOptions
|
||||
. run . runReader opts . ppCode
|
||||
Loading…
Reference in New Issue
Block a user