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:
parent
f736e57d58
commit
66f36c0bd4
84
app/Main.hs
84
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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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 =
|
||||
|
Loading…
Reference in New Issue
Block a user