never executed always true always false

    1 {-# LANGUAGE OverloadedStrings #-}
    2 
    3 -- |
    4 -- Module      : Aihc.Parser
    5 -- Description : Haskell parser for the AIHC compiler
    6 -- License     : Unlicense
    7 --
    8 -- This module provides parsing functions for Haskell source code.
    9 -- The main entry point is 'parseModule' for parsing complete Haskell modules.
   10 -- Additional functions are provided for parsing individual expressions,
   11 -- patterns, and types.
   12 module Aihc.Parser
   13   ( -- * Parsing modules
   14     parseModule,
   15 
   16     -- * Configuration
   17     ParserConfig (..),
   18     defaultConfig,
   19 
   20     -- * Parse results
   21     ParseResult (..),
   22     ParseErrorBundle,
   23     errorBundlePretty,
   24 
   25     -- * Parsing expressions, patterns, and types
   26     parseExpr,
   27     parseType,
   28     parsePattern,
   29   )
   30 where
   31 
   32 import Aihc.Parser.Internal.Expr (exprParser, patternParser, typeParser)
   33 import Aihc.Parser.Internal.Module (moduleParser)
   34 import Aihc.Parser.Lex
   35   ( lexModuleTokensWithExtensions,
   36     lexTokensWithExtensions,
   37     readModuleHeaderExtensions,
   38   )
   39 import Aihc.Parser.Pretty ()
   40 import Aihc.Parser.Syntax (Expr, Extension (..), ExtensionSetting (..), Module, Pattern, Type)
   41 import Aihc.Parser.Types
   42 import Data.List qualified as List
   43 import Data.Text (Text)
   44 import Text.Megaparsec (runParser)
   45 import Text.Megaparsec qualified as MP
   46 
   47 -- $setup
   48 -- >>> :set -XOverloadedStrings
   49 -- >>> import Aihc.Parser
   50 -- >>> import Aihc.Parser.Syntax (moduleName)
   51 -- >>> import Aihc.Parser.Shorthand (Shorthand(..))
   52 
   53 -- | Default parser configuration.
   54 --
   55 -- * 'parserSourceName' is set to @\"\<input\>\"@
   56 -- * 'parserExtensions' is empty (no extensions enabled by default)
   57 --
   58 -- >>> parserSourceName defaultConfig
   59 -- "<input>"
   60 --
   61 -- >>> parserExtensions defaultConfig
   62 -- []
   63 defaultConfig :: ParserConfig
   64 defaultConfig =
   65   ParserConfig
   66     { parserSourceName = "<input>",
   67       parserExtensions = []
   68     }
   69 
   70 -- | Parse a Haskell expression.
   71 --
   72 -- >>> shorthand $ parseExpr defaultConfig "1 + 2"
   73 -- ParseOk (EInfix (EInt 1) "+" (EInt 2))
   74 --
   75 -- >>> shorthand $ parseExpr defaultConfig "\\x -> x + 1"
   76 -- ParseOk (ELambdaPats [PVar "x"] (EInfix (EVar "x") "+" (EInt 1)))
   77 --
   78 -- Parse errors are returned as 'ParseErr':
   79 --
   80 -- >>> case parseExpr defaultConfig "1 +" of { ParseErr _ -> "error"; ParseOk _ -> "ok" }
   81 -- "error"
   82 parseExpr :: ParserConfig -> Text -> ParseResult Expr
   83 parseExpr cfg input =
   84   let toks = lexTokensWithExtensions (parserExtensions cfg) input
   85    in case runParser (exprParser <* MP.eof) (parserSourceName cfg) (TokStream toks) of
   86         Left bundle -> ParseErr bundle
   87         Right expr -> ParseOk expr
   88 
   89 -- | Parse a Haskell pattern.
   90 --
   91 -- >>> shorthand $ parsePattern defaultConfig "(x, y)"
   92 -- ParseOk (PTuple [PVar "x", PVar "y"])
   93 --
   94 -- >>> shorthand $ parsePattern defaultConfig "Just x"
   95 -- ParseOk (PCon "Just" [PVar "x"])
   96 parsePattern :: ParserConfig -> Text -> ParseResult Pattern
   97 parsePattern cfg input =
   98   let toks = lexTokensWithExtensions (parserExtensions cfg) input
   99    in case runParser (patternParser <* MP.eof) (parserSourceName cfg) (TokStream toks) of
  100         Left bundle -> ParseErr bundle
  101         Right pat -> ParseOk pat
  102 
  103 -- | Parse a Haskell type.
  104 --
  105 -- >>> shorthand $ parseType defaultConfig "Int -> Bool"
  106 -- ParseOk (TFun (TCon "Int") (TCon "Bool"))
  107 --
  108 -- >>> shorthand $ parseType defaultConfig "Maybe a"
  109 -- ParseOk (TApp (TCon "Maybe") (TVar "a"))
  110 parseType :: ParserConfig -> Text -> ParseResult Type
  111 parseType cfg input =
  112   let toks = lexTokensWithExtensions (parserExtensions cfg) input
  113    in case runParser (typeParser <* MP.eof) (parserSourceName cfg) (TokStream toks) of
  114         Left bundle -> ParseErr bundle
  115         Right ty -> ParseOk ty
  116 
  117 -- | Parse a complete Haskell module.
  118 --
  119 -- >>> shorthand $ parseModule defaultConfig "module Main where\nmain = putStrLn \"Hello\""
  120 -- ParseOk (Module {name = "Main", decls = [DeclValue (FunctionBind "main" [Match {rhs = UnguardedRhs (EApp (EVar "putStrLn") (EString "Hello"))}])]})
  121 --
  122 -- Modules without a header are also supported:
  123 --
  124 -- >>> case parseModule defaultConfig "x = 1" of { ParseOk m -> moduleName m; ParseErr _ -> Just "error" }
  125 -- Nothing
  126 parseModule :: ParserConfig -> Text -> ParseResult Module
  127 parseModule cfg input =
  128   let toks = lexModuleTokensWithExtensions effectiveExtensions input
  129    in case runParser (moduleParser <* MP.eof) (parserSourceName cfg) (TokStream toks) of
  130         Left bundle -> ParseErr bundle
  131         Right modu -> ParseOk modu
  132   where
  133     effectiveExtensions =
  134       applyExtensionSettings
  135         (parserExtensions cfg)
  136         (readModuleHeaderExtensions input)
  137 
  138 applyExtensionSettings :: [Extension] -> [ExtensionSetting] -> [Extension]
  139 applyExtensionSettings = List.foldl' applySetting
  140   where
  141     applySetting exts setting =
  142       case setting of
  143         EnableExtension ext
  144           | ext `elem` exts -> exts
  145           | otherwise -> exts <> [ext]
  146         DisableExtension ext -> filter (/= ext) exts
  147 
  148 -- | Pretty-print a parse error bundle.
  149 errorBundlePretty :: ParseErrorBundle -> String
  150 errorBundlePretty = MP.errorBundlePretty