diff --git a/app/Main.hs b/app/Main.hs index 269a0da89..991bbcd10 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/src/MiniJuvix/Syntax/Concrete/Language.hs b/src/MiniJuvix/Syntax/Concrete/Language.hs index 51a88e2a5..16287b9ab 100644 --- a/src/MiniJuvix/Syntax/Concrete/Language.hs +++ b/src/MiniJuvix/Syntax/Concrete/Language.hs @@ -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 diff --git a/src/MiniJuvix/Syntax/Concrete/Scoped/Pretty/Ansi.hs b/src/MiniJuvix/Syntax/Concrete/Scoped/Pretty/Ansi.hs index 0fd7a4157..1bf72c345 100644 --- a/src/MiniJuvix/Syntax/Concrete/Scoped/Pretty/Ansi.hs +++ b/src/MiniJuvix/Syntax/Concrete/Scoped/Pretty/Ansi.hs @@ -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 diff --git a/src/MiniJuvix/Syntax/Concrete/Scoped/Pretty/Base.hs b/src/MiniJuvix/Syntax/Concrete/Scoped/Pretty/Base.hs index 26f7a79b4..ada7b0eee 100644 --- a/src/MiniJuvix/Syntax/Concrete/Scoped/Pretty/Base.hs +++ b/src/MiniJuvix/Syntax/Concrete/Scoped/Pretty/Base.hs @@ -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 diff --git a/src/MiniJuvix/Syntax/Concrete/Scoped/Scoper.hs b/src/MiniJuvix/Syntax/Concrete/Scoped/Scoper.hs index 0c9e00d8d..001b12c4a 100644 --- a/src/MiniJuvix/Syntax/Concrete/Scoped/Scoper.hs +++ b/src/MiniJuvix/Syntax/Concrete/Scoped/Scoper.hs @@ -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 =