1
1
mirror of https://github.com/anoma/juvix.git synced 2025-01-06 06:53:33 +03:00

[ormolu] run ormolu

This commit is contained in:
Jan Mas Rovira 2022-01-20 12:55:46 +01:00
parent f736e57d58
commit 66f36c0bd4
5 changed files with 240 additions and 225 deletions

View File

@ -1,45 +1,51 @@
{-# LANGUAGE ApplicativeDo #-}
module Main (main) where
import MiniJuvix.Utils.Prelude
import Data.Aeson (defaultOptions)
import qualified MiniJuvix.Syntax.Concrete.Parser as M
import qualified MiniJuvix.Syntax.Concrete.Scoped.Scoper as M
import qualified MiniJuvix.Syntax.Concrete.Scoped.Pretty.Ansi as M
import MiniJuvix.Syntax.Concrete.Scoped.Pretty.Base (Options (_optShowNameId))
import qualified MiniJuvix.Syntax.Concrete.Scoped.Pretty.Base as M
import qualified MiniJuvix.Syntax.Concrete.Scoped.Scoper as M
import MiniJuvix.Utils.Prelude
import Options.Applicative
import Options.Applicative.Help.Pretty
import Data.Aeson (defaultOptions)
import MiniJuvix.Syntax.Concrete.Scoped.Pretty.Base (Options(_optShowNameId))
data Command =
Scope ScopeOptions
data Command
= Scope ScopeOptions
| Parse ParseOptions
data ScopeOptions = ScopeOptions {
_scopeRootDir :: FilePath
, _scopeInputFile :: FilePath
, _scopeShowIds :: Bool
data ScopeOptions = ScopeOptions
{ _scopeRootDir :: FilePath,
_scopeInputFile :: FilePath,
_scopeShowIds :: Bool
}
data ParseOptions = ParseOptions
parseScope :: Parser ScopeOptions
parseScope = do
_scopeRootDir <- strOption
(long "rootDir"
<> short 'd'
<> metavar "DIR"
<> value "."
<> showDefault
<> help "Root directory")
_scopeInputFile <- argument str
(metavar "MINIJUVIX_FILE"
<> help "Path to a .mjuvix file"
)
_scopeShowIds <- switch
( long "show-name-ids"
<> help "Show the unique number of each identifier"
)
_scopeRootDir <-
strOption
( long "rootDir"
<> short 'd'
<> metavar "DIR"
<> value "."
<> showDefault
<> help "Root directory"
)
_scopeInputFile <-
argument
str
( metavar "MINIJUVIX_FILE"
<> help "Path to a .mjuvix file"
)
_scopeShowIds <-
switch
( long "show-name-ids"
<> help "Show the unique number of each identifier"
)
pure ScopeOptions {..}
@ -47,26 +53,30 @@ parseParse :: Parser ParseOptions
parseParse = pure ParseOptions
descr :: ParserInfo Command
descr = info (parseCommand <**> helper)
(fullDesc
descr =
info
(parseCommand <**> helper)
( fullDesc
<> progDesc "The MiniJuvix compiler."
<> headerDoc (Just $ dullblue $ bold $ underline "MiniJuvix help")
<> footerDoc (Just foot)
)
)
where
foot :: Doc
foot = bold "maintainers: " <> "jan@heliax.dev; jonathan@heliax.dev"
foot :: Doc
foot = bold "maintainers: " <> "jan@heliax.dev; jonathan@heliax.dev"
parseCommand :: Parser Command
parseCommand = subparser (
command "parse" (info (Parse <$> parseParse) (progDesc "Parse some .mjuvix files"))
<> command "scope" (info (Scope <$> parseScope) (progDesc "Parse and scope some .mjuvix files"))
)
parseCommand =
subparser
( command "parse" (info (Parse <$> parseParse) (progDesc "Parse some .mjuvix files"))
<> command "scope" (info (Scope <$> parseScope) (progDesc "Parse and scope some .mjuvix files"))
)
mkPrettyOptions :: ScopeOptions -> M.Options
mkPrettyOptions ScopeOptions {..} = M.defaultOptions {
_optShowNameId = _scopeShowIds
}
mkPrettyOptions ScopeOptions {..} =
M.defaultOptions
{ _optShowNameId = _scopeShowIds
}
go :: Command -> IO ()
go c = case c of

View File

@ -234,22 +234,22 @@ deriving stock instance (Lift (ExpressionType s), Lift (SymbolType s)) => Lift (
-- Pattern
--------------------------------------------------------------------------------
data PatternInfixApp = PatternInfixApp {
patInfixConstructor :: NameType 'Scoped,
patInfixLeft :: Pattern,
patInfixRight :: Pattern
data PatternInfixApp = PatternInfixApp
{ patInfixConstructor :: NameType 'Scoped,
patInfixLeft :: Pattern,
patInfixRight :: Pattern
}
deriving stock (Show, Eq, Ord)
data PatternPostfixApp = PatternPostfixApp {
patPostfixConstructor :: NameType 'Scoped,
patPostfixParameter :: Pattern
data PatternPostfixApp = PatternPostfixApp
{ patPostfixConstructor :: NameType 'Scoped,
patPostfixParameter :: Pattern
}
deriving stock (Show, Eq, Ord)
data PatternPrefixApp = PatternPrefixApp {
patPrefixConstructor :: NameType 'Scoped,
patPrefixParameter :: Pattern
data PatternPrefixApp = PatternPrefixApp
{ patPrefixConstructor :: NameType 'Scoped,
patPrefixParameter :: Pattern
}
deriving stock (Show, Eq, Ord)
@ -826,9 +826,9 @@ data PostfixApplication = PostfixApplication
-- Let block expression
--------------------------------------------------------------------------------
data LetBlock (s :: Stage) = LetBlock {
letClauses :: [LetClause s],
letExpression :: ExpressionType s
data LetBlock (s :: Stage) = LetBlock
{ letClauses :: [LetClause s],
letExpression :: ExpressionType s
}
deriving stock instance

View File

@ -1,11 +1,11 @@
module MiniJuvix.Syntax.Concrete.Scoped.Pretty.Ansi where
import Prettyprinter
import MiniJuvix.Syntax.Concrete.Scoped.Pretty.Base
import MiniJuvix.Syntax.Concrete.Language
import MiniJuvix.Syntax.Concrete.Scoped.Name (NameKind (..))
import MiniJuvix.Syntax.Concrete.Scoped.Pretty.Base
import MiniJuvix.Utils.Prelude
import Prettyprinter
import Prettyprinter.Render.Terminal
import MiniJuvix.Syntax.Concrete.Scoped.Name (NameKind(..))
printTopModuleDefault :: Module 'Scoped 'ModuleTop -> IO ()
printTopModuleDefault = printTopModule defaultOptions
@ -13,10 +13,10 @@ printTopModuleDefault = printTopModule 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
docStream :: SimpleDocStream Ann
docStream = layoutPretty defaultLayoutOptions (prettyTopModule opts m)
docStream' :: SimpleDocStream AnsiStyle
docStream' = reAnnotateS stylize docStream
stylize :: Ann -> AnsiStyle
stylize a = case a of

View File

@ -1,37 +1,38 @@
module MiniJuvix.Syntax.Concrete.Scoped.Pretty.Base where
import qualified MiniJuvix.Syntax.Concrete.Scoped.Name as S
import MiniJuvix.Utils.Prelude hiding (Reader, runReader, asks)
import Data.Singletons
import MiniJuvix.Syntax.Concrete.Language
import qualified MiniJuvix.Syntax.Concrete.Scoped.Name as S
import MiniJuvix.Utils.Prelude hiding (Reader, asks, runReader)
import Polysemy
import Polysemy.Reader
import Prettyprinter hiding (braces, parens)
import Data.Singletons
data Ann = AnnKind S.NameKind
data Ann
= AnnKind S.NameKind
| AnnKeyword
| AnnDelimiter
data Options = Options {
_optOptimizeParens :: Bool,
_optShowNameId :: Bool,
_optIndent :: Int
data Options = Options
{ _optOptimizeParens :: Bool,
_optShowNameId :: Bool,
_optIndent :: Int
}
defaultOptions :: Options
defaultOptions = Options {
_optOptimizeParens = True,
_optShowNameId = False,
_optIndent = 2
}
defaultOptions =
Options
{ _optOptimizeParens = True,
_optShowNameId = False,
_optIndent = 2
}
-- | Pretty prints a top module.
prettyTopModule :: Options -> Module 'Scoped 'ModuleTop -> Doc Ann
prettyTopModule opts = run . runReader opts . ppModule
infixl 7 <+?>
(<+?>) :: Doc ann -> Maybe (Doc ann) -> Doc ann
(<+?>) a = maybe a (a <+>)
@ -185,30 +186,33 @@ endSemicolon x = x <> kwSemicolon
ppModule :: (SingI t, Members '[Reader Options] r) => Module 'Scoped t -> Sem r (Doc Ann)
ppModule Module {..} = do
moduleBody' <- mapM (fmap endSemicolon . ppStatement) moduleBody >>= indented . vsep
moduleBody' <- mapM (fmap endSemicolon . ppStatement) moduleBody >>= indented . vsep
modulePath' <- ppModulePathType modulePath
return $ kwModule <+> modulePath' <> kwSemicolon <> line
<> moduleBody' <> line
<> kwEnd <> kwSemicolon
return $
kwModule <+> modulePath' <> kwSemicolon <> line
<> moduleBody'
<> line
<> kwEnd
<> kwSemicolon
ppOperatorSyntaxDef :: Members '[Reader Options] r => OperatorSyntaxDef -> Sem r (Doc Ann)
ppOperatorSyntaxDef OperatorSyntaxDef {..} = do
opSymbol' <- ppSymbol opSymbol
return $ ppFixity opFixity <+> opSymbol'
where
ppFixity :: Fixity -> Doc Ann
ppFixity Fixity {..} =
ppArity <+> pretty fixityPrecedence
where
ppArity :: Doc Ann
ppArity = case fixityArity of
Unary p -> case p of
AssocPrefix -> kwPrefix
AssocPostfix -> kwPostfix
Binary p -> case p of
AssocRight -> kwInfixr
AssocLeft -> kwInfixl
AssocNone -> kwInfix
ppFixity :: Fixity -> Doc Ann
ppFixity Fixity {..} =
ppArity <+> pretty fixityPrecedence
where
ppArity :: Doc Ann
ppArity = case fixityArity of
Unary p -> case p of
AssocPrefix -> kwPrefix
AssocPostfix -> kwPostfix
Binary p -> case p of
AssocRight -> kwInfixr
AssocLeft -> kwInfixl
AssocNone -> kwInfix
ppDataConstructorDef :: Members '[Reader Options] r => DataConstructorDef 'Scoped -> Sem r (Doc Ann)
ppDataConstructorDef DataConstructorDef {..} = do
@ -222,18 +226,19 @@ ppDataTypeDef DataTypeDef {..} = do
dataTypeParameters' <- hsep <$> mapM ppDataTypeParameter dataTypeParameters
dataTypeType' <- ppTypeType
dataTypeConstructors' <- ppBlock ppDataConstructorDef dataTypeConstructors
return $ kwInductive <+> dataTypeName' <+> dataTypeParameters' <+?> dataTypeType'
<+> dataTypeConstructors'
return $
kwInductive <+> dataTypeName' <+> dataTypeParameters' <+?> dataTypeType'
<+> dataTypeConstructors'
where
ppTypeType :: Sem r (Maybe (Doc Ann))
ppTypeType = case dataTypeType of
Nothing -> return Nothing
Just e -> Just . (kwColon <+>) <$> ppExpression e
ppDataTypeParameter :: DataTypeParameter 'Scoped -> Sem r (Doc Ann)
ppDataTypeParameter DataTypeParameter {..} = do
dataTypeParameterName' <- ppSSymbol dataTypeParameterName
dataTypeParameterType' <- ppExpression dataTypeParameterType
return $ parens (dataTypeParameterName' <+> kwColon <+> dataTypeParameterType')
ppTypeType :: Sem r (Maybe (Doc Ann))
ppTypeType = case dataTypeType of
Nothing -> return Nothing
Just e -> Just . (kwColon <+>) <$> ppExpression e
ppDataTypeParameter :: DataTypeParameter 'Scoped -> Sem r (Doc Ann)
ppDataTypeParameter DataTypeParameter {..} = do
dataTypeParameterName' <- ppSSymbol dataTypeParameterName
dataTypeParameterType' <- ppExpression dataTypeParameterType
return $ parens (dataTypeParameterName' <+> kwColon <+> dataTypeParameterType')
dotted :: [Doc Ann] -> Doc Ann
dotted = concatWith (surround kwDot)
@ -274,8 +279,8 @@ ppOpen OpenModule {..} = do
openUsingHiding' <- ppUsingHiding
return $ keyword "open" <+> openModuleName' <+> openUsingHiding'
where
ppUsingHiding :: Sem r (Doc Ann)
ppUsingHiding = return $ pretty ("TODO" :: Text)
ppUsingHiding :: Sem r (Doc Ann)
ppUsingHiding = return $ pretty ("TODO" :: Text)
ppTypeSignature :: Members '[Reader Options] r => TypeSignature 'Scoped -> Sem r (Doc Ann)
ppTypeSignature TypeSignature {..} = do
@ -289,21 +294,21 @@ ppFunction Function {..} = do
funReturn' <- ppExpressionAtom 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 'Scoped -> Sem r (Doc Ann)
ppFunParameter FunctionParameter {..} = do
case paramName of
Nothing -> ppExpressionAtom paramType
Just n -> do
paramName' <- ppSSymbol n
paramType' <- ppExpression paramType
return $ parens (paramName' <+> ppUsage paramUsage <+> paramType')
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 'Scoped -> Sem r (Doc Ann)
ppFunParameter FunctionParameter {..} = do
case paramName of
Nothing -> ppExpressionAtom paramType
Just n -> do
paramName' <- ppSSymbol 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
@ -314,10 +319,10 @@ ppLetBlock LetBlock {..} = do
letExpression' <- ppExpression letExpression
return $ kwLet <+> letClauses' <+> kwIn <+> letExpression'
where
ppLetClause :: LetClause 'Scoped -> Sem r (Doc Ann)
ppLetClause c = case c of
LetTypeSig sig -> ppTypeSignature sig
LetFunClause cl -> ppFunctionClause cl
ppLetClause :: LetClause 'Scoped -> 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
@ -328,22 +333,22 @@ ppMatch Match {..} = do
matchAlts' <- ppBlock ppMatchAlt matchAlts
return $ kwMatch <+> matchExpression' <+> matchAlts'
where
ppMatchAlt :: MatchAlt 'Scoped -> Sem r (Doc Ann)
ppMatchAlt MatchAlt {..} = do
matchAltPattern' <- ppPattern matchAltPattern
matchAltBody' <- ppExpression matchAltBody
return $ matchAltPattern' <+> kwMapsto <+> matchAltBody'
ppMatchAlt :: MatchAlt 'Scoped -> Sem r (Doc Ann)
ppMatchAlt MatchAlt {..} = do
matchAltPattern' <- ppPattern matchAltPattern
matchAltBody' <- ppExpression matchAltBody
return $ matchAltPattern' <+> kwMapsto <+> matchAltBody'
ppLambda :: forall r. Members '[Reader Options] r => Lambda 'Scoped -> Sem r (Doc Ann)
ppLambda Lambda {..} = do
lambdaClauses' <- ppBlock ppLambdaClause lambdaClauses
return $ kwLambda <+> lambdaClauses'
where
ppLambdaClause :: LambdaClause 'Scoped -> Sem r (Doc Ann)
ppLambdaClause LambdaClause {..} = do
lambdaParameters' <- hsep . toList <$> mapM ppPattern lambdaParameters
lambdaBody' <- ppExpression lambdaBody
return $ lambdaParameters' <+> kwMapsto <+> lambdaBody'
ppLambdaClause :: LambdaClause 'Scoped -> Sem r (Doc Ann)
ppLambdaClause LambdaClause {..} = do
lambdaParameters' <- hsep . toList <$> mapM ppPattern lambdaParameters
lambdaBody' <- ppExpression lambdaBody
return $ lambdaParameters' <+> kwMapsto <+> lambdaBody'
ppFunctionClause :: forall r. Members '[Reader Options] r => FunctionClause 'Scoped -> Sem r (Doc Ann)
ppFunctionClause FunctionClause {..} = do
@ -351,17 +356,18 @@ ppFunctionClause FunctionClause {..} = do
clausePatterns' <- hsep <$> mapM ppPattern clausePatterns
clauseBody' <- ppExpression clauseBody
clauseWhere' <- sequence $ ppWhereBlock <$> clauseWhere
return $ clauseOwnerFunction' <+> clausePatterns' <+> kwAssignment <+> clauseBody'
<+?> (((line <> kwWhere) <+>) <$> clauseWhere')
return $
clauseOwnerFunction' <+> clausePatterns' <+> kwAssignment <+> clauseBody'
<+?> (((line <> kwWhere) <+>) <$> clauseWhere')
where
ppWhereBlock :: WhereBlock 'Scoped -> Sem r (Doc Ann)
ppWhereBlock WhereBlock {..} = ppBlock ppWhereClause whereClauses
where
ppWhereClause :: WhereClause 'Scoped -> Sem r (Doc Ann)
ppWhereClause c = case c of
WhereOpenModule o -> ppOpen o
WhereTypeSig sig -> ppTypeSignature sig
WhereFunClause fun -> ppFunctionClause fun
ppWhereBlock :: WhereBlock 'Scoped -> Sem r (Doc Ann)
ppWhereBlock WhereBlock {..} = ppBlock ppWhereClause whereClauses
where
ppWhereClause :: WhereClause 'Scoped -> Sem r (Doc Ann)
ppWhereClause c = case c of
WhereOpenModule o -> ppOpen o
WhereTypeSig sig -> ppTypeSignature sig
WhereFunClause fun -> ppFunctionClause fun
ppAxiom :: Members '[Reader Options] r => AxiomDef 'Scoped -> Sem r (Doc Ann)
ppAxiom AxiomDef {..} = do
@ -387,57 +393,57 @@ ppImport (Import (Module {..})) = do
ppPattern :: forall r. Members '[Reader Options] r => Pattern -> Sem r (Doc Ann)
ppPattern = goAtom
where
isAtomicPat :: Pattern -> Bool
isAtomicPat p = case p of
PatternVariable {} -> True
PatternApplication {} -> False
PatternConstructor {} -> True
PatternInfixApplication {} -> False
PatternPostfixApplication {} -> False
PatternPrefixApplication {} -> False
PatternWildcard -> True
PatternEmpty -> True
goAtom :: Pattern -> Sem r (Doc Ann)
goAtom p = do
p' <- go p
return $ if isAtomicPat p then p' else parens p'
go :: Pattern -> Sem r (Doc Ann)
go p = case p of
PatternVariable v -> ppSSymbol v
PatternApplication l r -> do
l' <- goAtom l
r' <- goAtom r
return $ l' <+> r'
PatternWildcard -> return kwWildcard
PatternEmpty -> return $ parens mempty
PatternConstructor constr -> ppSName constr
PatternInfixApplication i -> ppPatternInfixApp i
PatternPrefixApplication i -> ppPatternPrefixApp i
PatternPostfixApplication i -> ppPatternPostfixApp i
isAtomicPat :: Pattern -> Bool
isAtomicPat p = case p of
PatternVariable {} -> True
PatternApplication {} -> False
PatternConstructor {} -> True
PatternInfixApplication {} -> False
PatternPostfixApplication {} -> False
PatternPrefixApplication {} -> False
PatternWildcard -> True
PatternEmpty -> True
goAtom :: Pattern -> Sem r (Doc Ann)
goAtom p = do
p' <- go p
return $ if isAtomicPat p then p' else parens p'
go :: Pattern -> Sem r (Doc Ann)
go p = case p of
PatternVariable v -> ppSSymbol v
PatternApplication l r -> do
l' <- goAtom l
r' <- goAtom r
return $ l' <+> r'
PatternWildcard -> return kwWildcard
PatternEmpty -> return $ parens mempty
PatternConstructor constr -> ppSName constr
PatternInfixApplication i -> ppPatternInfixApp i
PatternPrefixApplication i -> ppPatternPrefixApp i
PatternPostfixApplication i -> ppPatternPostfixApp i
ppPatternInfixApp :: PatternInfixApp -> Sem r (Doc Ann)
ppPatternInfixApp PatternInfixApp {..} = do
patInfixConstructor' <- ppSName patInfixConstructor
patInfixLeft' <- goAtom patInfixLeft
patInfixRight' <- goAtom patInfixRight
return $ patInfixLeft' <+> patInfixConstructor' <+> patInfixRight'
ppPatternInfixApp :: PatternInfixApp -> Sem r (Doc Ann)
ppPatternInfixApp PatternInfixApp {..} = do
patInfixConstructor' <- ppSName patInfixConstructor
patInfixLeft' <- goAtom patInfixLeft
patInfixRight' <- goAtom patInfixRight
return $ patInfixLeft' <+> patInfixConstructor' <+> patInfixRight'
ppPatternPrefixApp :: PatternPrefixApp -> Sem r (Doc Ann)
ppPatternPrefixApp PatternPrefixApp {..} = do
patPrefixConstructor' <- ppSName patPrefixConstructor
patPrefixParameter' <- goAtom patPrefixParameter
return $ patPrefixConstructor' <+> patPrefixParameter'
ppPatternPrefixApp :: PatternPrefixApp -> Sem r (Doc Ann)
ppPatternPrefixApp PatternPrefixApp {..} = do
patPrefixConstructor' <- ppSName patPrefixConstructor
patPrefixParameter' <- goAtom patPrefixParameter
return $ patPrefixConstructor' <+> patPrefixParameter'
ppPatternPostfixApp :: PatternPostfixApp -> Sem r (Doc Ann)
ppPatternPostfixApp PatternPostfixApp {..} = do
patPostfixConstructor' <- ppSName patPostfixConstructor
patPostfixParameter' <- goAtom patPostfixParameter
return $ patPostfixConstructor' <+> patPostfixParameter'
ppPatternPostfixApp :: PatternPostfixApp -> Sem r (Doc Ann)
ppPatternPostfixApp PatternPostfixApp {..} = do
patPostfixConstructor' <- ppSName patPostfixConstructor
patPostfixParameter' <- goAtom patPostfixParameter
return $ patPostfixConstructor' <+> patPostfixParameter'
ppExpressionAtom :: forall r. Members '[Reader Options] r => Expression -> Sem r (Doc Ann)
ppExpressionAtom e = do
e' <- ppExpression e
return $ if isAtomic e then e' else parens e'
ppExpressionAtom e = do
e' <- ppExpression e
return $ if isAtomic e then e' else parens e'
isAtomic :: Expression -> Bool
isAtomic e = case e of
@ -452,39 +458,38 @@ isAtomic e = case e of
ExpressionFunction {} -> False
ppInfixApplication :: forall r. Members '[Reader Options] r => InfixApplication -> Sem r (Doc Ann)
ppInfixApplication InfixApplication {..} = do
ppInfixApplication InfixApplication {..} = do
infixAppLeft' <- ppExpressionAtom infixAppLeft
infixAppOperator' <- ppSName infixAppOperator
infixAppOperator' <- ppSName infixAppOperator
infixAppRight' <- ppExpressionAtom infixAppRight
return $ infixAppLeft' <+> infixAppOperator' <+> infixAppRight'
ppPostfixApplication :: forall r. Members '[Reader Options] r => PostfixApplication -> Sem r (Doc Ann)
ppPostfixApplication PostfixApplication {..} = do
ppPostfixApplication PostfixApplication {..} = do
postfixAppParameter' <- ppExpressionAtom postfixAppParameter
postfixAppOperator' <- ppSName postfixAppOperator
postfixAppOperator' <- ppSName postfixAppOperator
return $ postfixAppParameter' <+> postfixAppOperator'
ppExpression :: forall r. Members '[Reader Options] r => Expression -> Sem r (Doc Ann)
ppExpression = go
where
ppApplication :: Application -> Sem r (Doc Ann)
ppApplication (Application l r) = do
l' <- goAtom l
r' <- goAtom r
return $ l' <+> r'
goAtom :: Expression -> Sem r (Doc Ann)
goAtom e = do
e' <- go e
return $ if isAtomic e then e' else parens e'
go :: Expression -> Sem r (Doc Ann)
go e = case e of
ExpressionIdentifier n -> 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
ppApplication :: Application -> Sem r (Doc Ann)
ppApplication (Application l r) = do
l' <- goAtom l
r' <- goAtom r
return $ l' <+> r'
goAtom :: Expression -> Sem r (Doc Ann)
goAtom e = do
e' <- go e
return $ if isAtomic e then e' else parens e'
go :: Expression -> Sem r (Doc Ann)
go e = case e of
ExpressionIdentifier n -> 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

View File

@ -1030,13 +1030,13 @@ parseTerm :: forall r. Members '[Reader (Parse Expression), Embed Parse] r => Se
parseTerm = do
pExpr <- ask
embed @Parse $
parseUniverse
<|> parseNoInfixIdentifier
<|> parseParens pExpr
<|> parseFunction
<|> parseLambda
<|> parseMatch
<|> parseLetBlock
parseUniverse
<|> parseNoInfixIdentifier
<|> parseParens pExpr
<|> parseFunction
<|> parseLambda
<|> parseMatch
<|> parseLetBlock
where
parseLambda :: Parse Expression
parseLambda = ExpressionLambda <$> P.token lambda mempty
@ -1124,7 +1124,7 @@ makePatternTable = do
nameToPattern n@S.Name' {..} = case _nameKind of
S.KNameConstructor -> PatternConstructor n
S.KNameLocal
| NameUnqualified s <- _nameConcrete -> PatternVariable S.Name' {S._nameConcrete = s, ..}
| NameUnqualified s <- _nameConcrete -> PatternVariable S.Name' {S._nameConcrete = s, ..}
_ -> error "impossible"
getEntry :: SymbolInfo -> SymbolEntry
getEntry (SymbolInfo m) = case toList m of
@ -1185,11 +1185,11 @@ parsePrePatTerm ::
parsePrePatTerm = do
pPat <- ask
embed @ParsePat $
parseNoInfixConstructor
<|> parseVariable
<|> parseParens pPat
<|> parseWildcard
<|> parseEmpty
parseNoInfixConstructor
<|> parseVariable
<|> parseParens pPat
<|> parseWildcard
<|> parseEmpty
where
parseNoInfixConstructor :: ParsePat Pattern
parseNoInfixConstructor =