{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      : Aihc.Parser
-- Description : Haskell parser for the AIHC compiler
-- License     : Unlicense
--
-- This module provides parsing functions for Haskell source code.
-- The main entry point is 'parseModule' for parsing complete Haskell modules.
-- Additional functions are provided for parsing individual expressions,
-- patterns, and types.
module Aihc.Parser
  ( -- * Parsing modules
    parseModule,

    -- * Configuration
    ParserConfig (..),
    defaultConfig,

    -- * Parse results
    ParseResult (..),
    ParseErrorBundle,
    errorBundlePretty,

    -- * Parsing expressions, patterns, and types
    parseExpr,
    parseType,
    parsePattern,
  )
where

import Aihc.Parser.Internal.Expr (exprParser, patternParser, typeParser)
import Aihc.Parser.Internal.Module (moduleParser)
import Aihc.Parser.Lex
  ( lexModuleTokensWithExtensions,
    lexTokensWithExtensions,
    readModuleHeaderExtensions,
  )
import Aihc.Parser.Pretty ()
import Aihc.Parser.Syntax (Expr, Extension (..), ExtensionSetting (..), Module, Pattern, Type)
import Aihc.Parser.Types
import Data.List qualified as List
import Data.Text (Text)
import Text.Megaparsec (runParser)
import Text.Megaparsec qualified as MP

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Aihc.Parser
-- >>> import Aihc.Parser.Syntax (moduleName)
-- >>> import Aihc.Parser.Shorthand (Shorthand(..))

-- | Default parser configuration.
--
-- * 'parserSourceName' is set to @\"\<input\>\"@
-- * 'parserExtensions' is empty (no extensions enabled by default)
--
-- >>> parserSourceName defaultConfig
-- "<input>"
--
-- >>> parserExtensions defaultConfig
-- []
defaultConfig :: ParserConfig
defaultConfig :: ParserConfig
defaultConfig =
  ParserConfig
    { parserSourceName :: FilePath
parserSourceName = FilePath
"<input>",
      parserExtensions :: [Extension]
parserExtensions = []
    }

-- | Parse a Haskell expression.
--
-- >>> shorthand $ parseExpr defaultConfig "1 + 2"
-- ParseOk (EInfix (EInt 1) "+" (EInt 2))
--
-- >>> shorthand $ parseExpr defaultConfig "\\x -> x + 1"
-- ParseOk (ELambdaPats [PVar "x"] (EInfix (EVar "x") "+" (EInt 1)))
--
-- Parse errors are returned as 'ParseErr':
--
-- >>> case parseExpr defaultConfig "1 +" of { ParseErr _ -> "error"; ParseOk _ -> "ok" }
-- "error"
parseExpr :: ParserConfig -> Text -> ParseResult Expr
parseExpr :: ParserConfig -> Text -> ParseResult Expr
parseExpr ParserConfig
cfg Text
input =
  let toks :: [LexToken]
toks = [Extension] -> Text -> [LexToken]
lexTokensWithExtensions (ParserConfig -> [Extension]
parserExtensions ParserConfig
cfg) Text
input
   in case Parsec Void TokStream Expr
-> FilePath
-> TokStream
-> Either (ParseErrorBundle TokStream Void) Expr
forall e s a.
Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
runParser (Parsec Void TokStream Expr
exprParser Parsec Void TokStream Expr
-> ParsecT Void TokStream Identity () -> Parsec Void TokStream Expr
forall a b.
ParsecT Void TokStream Identity a
-> ParsecT Void TokStream Identity b
-> ParsecT Void TokStream Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void TokStream Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
MP.eof) (ParserConfig -> FilePath
parserSourceName ParserConfig
cfg) ([LexToken] -> TokStream
TokStream [LexToken]
toks) of
        Left ParseErrorBundle TokStream Void
bundle -> ParseErrorBundle TokStream Void -> ParseResult Expr
forall a. ParseErrorBundle TokStream Void -> ParseResult a
ParseErr ParseErrorBundle TokStream Void
bundle
        Right Expr
expr -> Expr -> ParseResult Expr
forall a. a -> ParseResult a
ParseOk Expr
expr

-- | Parse a Haskell pattern.
--
-- >>> shorthand $ parsePattern defaultConfig "(x, y)"
-- ParseOk (PTuple [PVar "x", PVar "y"])
--
-- >>> shorthand $ parsePattern defaultConfig "Just x"
-- ParseOk (PCon "Just" [PVar "x"])
parsePattern :: ParserConfig -> Text -> ParseResult Pattern
parsePattern :: ParserConfig -> Text -> ParseResult Pattern
parsePattern ParserConfig
cfg Text
input =
  let toks :: [LexToken]
toks = [Extension] -> Text -> [LexToken]
lexTokensWithExtensions (ParserConfig -> [Extension]
parserExtensions ParserConfig
cfg) Text
input
   in case Parsec Void TokStream Pattern
-> FilePath
-> TokStream
-> Either (ParseErrorBundle TokStream Void) Pattern
forall e s a.
Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
runParser (Parsec Void TokStream Pattern
patternParser Parsec Void TokStream Pattern
-> ParsecT Void TokStream Identity ()
-> Parsec Void TokStream Pattern
forall a b.
ParsecT Void TokStream Identity a
-> ParsecT Void TokStream Identity b
-> ParsecT Void TokStream Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void TokStream Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
MP.eof) (ParserConfig -> FilePath
parserSourceName ParserConfig
cfg) ([LexToken] -> TokStream
TokStream [LexToken]
toks) of
        Left ParseErrorBundle TokStream Void
bundle -> ParseErrorBundle TokStream Void -> ParseResult Pattern
forall a. ParseErrorBundle TokStream Void -> ParseResult a
ParseErr ParseErrorBundle TokStream Void
bundle
        Right Pattern
pat -> Pattern -> ParseResult Pattern
forall a. a -> ParseResult a
ParseOk Pattern
pat

-- | Parse a Haskell type.
--
-- >>> shorthand $ parseType defaultConfig "Int -> Bool"
-- ParseOk (TFun (TCon "Int") (TCon "Bool"))
--
-- >>> shorthand $ parseType defaultConfig "Maybe a"
-- ParseOk (TApp (TCon "Maybe") (TVar "a"))
parseType :: ParserConfig -> Text -> ParseResult Type
parseType :: ParserConfig -> Text -> ParseResult Type
parseType ParserConfig
cfg Text
input =
  let toks :: [LexToken]
toks = [Extension] -> Text -> [LexToken]
lexTokensWithExtensions (ParserConfig -> [Extension]
parserExtensions ParserConfig
cfg) Text
input
   in case Parsec Void TokStream Type
-> FilePath
-> TokStream
-> Either (ParseErrorBundle TokStream Void) Type
forall e s a.
Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
runParser (Parsec Void TokStream Type
typeParser Parsec Void TokStream Type
-> ParsecT Void TokStream Identity () -> Parsec Void TokStream Type
forall a b.
ParsecT Void TokStream Identity a
-> ParsecT Void TokStream Identity b
-> ParsecT Void TokStream Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void TokStream Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
MP.eof) (ParserConfig -> FilePath
parserSourceName ParserConfig
cfg) ([LexToken] -> TokStream
TokStream [LexToken]
toks) of
        Left ParseErrorBundle TokStream Void
bundle -> ParseErrorBundle TokStream Void -> ParseResult Type
forall a. ParseErrorBundle TokStream Void -> ParseResult a
ParseErr ParseErrorBundle TokStream Void
bundle
        Right Type
ty -> Type -> ParseResult Type
forall a. a -> ParseResult a
ParseOk Type
ty

-- | Parse a complete Haskell module.
--
-- >>> shorthand $ parseModule defaultConfig "module Main where\nmain = putStrLn \"Hello\""
-- ParseOk (Module {name = "Main", decls = [DeclValue (FunctionBind "main" [Match {rhs = UnguardedRhs (EApp (EVar "putStrLn") (EString "Hello"))}])]})
--
-- Modules without a header are also supported:
--
-- >>> case parseModule defaultConfig "x = 1" of { ParseOk m -> moduleName m; ParseErr _ -> Just "error" }
-- Nothing
parseModule :: ParserConfig -> Text -> ParseResult Module
parseModule :: ParserConfig -> Text -> ParseResult Module
parseModule ParserConfig
cfg Text
input =
  let toks :: [LexToken]
toks = [Extension] -> Text -> [LexToken]
lexModuleTokensWithExtensions [Extension]
effectiveExtensions Text
input
   in case Parsec Void TokStream Module
-> FilePath
-> TokStream
-> Either (ParseErrorBundle TokStream Void) Module
forall e s a.
Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
runParser (Parsec Void TokStream Module
moduleParser Parsec Void TokStream Module
-> ParsecT Void TokStream Identity ()
-> Parsec Void TokStream Module
forall a b.
ParsecT Void TokStream Identity a
-> ParsecT Void TokStream Identity b
-> ParsecT Void TokStream Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void TokStream Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
MP.eof) (ParserConfig -> FilePath
parserSourceName ParserConfig
cfg) ([LexToken] -> TokStream
TokStream [LexToken]
toks) of
        Left ParseErrorBundle TokStream Void
bundle -> ParseErrorBundle TokStream Void -> ParseResult Module
forall a. ParseErrorBundle TokStream Void -> ParseResult a
ParseErr ParseErrorBundle TokStream Void
bundle
        Right Module
modu -> Module -> ParseResult Module
forall a. a -> ParseResult a
ParseOk Module
modu
  where
    effectiveExtensions :: [Extension]
effectiveExtensions =
      [Extension] -> [ExtensionSetting] -> [Extension]
applyExtensionSettings
        (ParserConfig -> [Extension]
parserExtensions ParserConfig
cfg)
        (Text -> [ExtensionSetting]
readModuleHeaderExtensions Text
input)

applyExtensionSettings :: [Extension] -> [ExtensionSetting] -> [Extension]
applyExtensionSettings :: [Extension] -> [ExtensionSetting] -> [Extension]
applyExtensionSettings = ([Extension] -> ExtensionSetting -> [Extension])
-> [Extension] -> [ExtensionSetting] -> [Extension]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' [Extension] -> ExtensionSetting -> [Extension]
applySetting
  where
    applySetting :: [Extension] -> ExtensionSetting -> [Extension]
applySetting [Extension]
exts ExtensionSetting
setting =
      case ExtensionSetting
setting of
        EnableExtension Extension
ext
          | Extension
ext Extension -> [Extension] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Extension]
exts -> [Extension]
exts
          | Bool
otherwise -> [Extension]
exts [Extension] -> [Extension] -> [Extension]
forall a. Semigroup a => a -> a -> a
<> [Extension
ext]
        DisableExtension Extension
ext -> (Extension -> Bool) -> [Extension] -> [Extension]
forall a. (a -> Bool) -> [a] -> [a]
filter (Extension -> Extension -> Bool
forall a. Eq a => a -> a -> Bool
/= Extension
ext) [Extension]
exts

-- | Pretty-print a parse error bundle.
errorBundlePretty :: ParseErrorBundle -> String
errorBundlePretty :: ParseErrorBundle TokStream Void -> FilePath
errorBundlePretty = ParseErrorBundle TokStream Void -> FilePath
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> FilePath
MP.errorBundlePretty