module Require.Parser
  ( Parser
  , requireDirective
  , Megaparsec.parseMaybe
  ) where

import qualified Data.Char as Char
import qualified Data.Text as Text
import Relude
import Require.Types
import qualified Text.Megaparsec as Megaparsec
import qualified Text.Megaparsec.Char as Megaparsec

type Parser = Megaparsec.Parsec Void Text

requireDirective :: Parser RequireDirective
requireDirective :: Parser RequireDirective
requireDirective = do
  RequireDirective
directive <- [Parser RequireDirective] -> Parser RequireDirective
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
    [ RequireInfo -> RequireDirective
RequireDirective (RequireInfo -> RequireDirective)
-> ParsecT Void Text Identity RequireInfo
-> Parser RequireDirective
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity RequireInfo
requireInfo
    , RequireDirective
AutorequireDirective RequireDirective
-> ParsecT Void Text Identity Text -> Parser RequireDirective
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
Megaparsec.string Tokens Text
"autorequire"
    , Parser RequireDirective
moduleDirective
    ]
  ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
Megaparsec.space
  ParsecT Void Text Identity ()
skipLineComment
  RequireDirective -> Parser RequireDirective
forall (f :: * -> *) a. Applicative f => a -> f a
pure RequireDirective
directive

requireInfo :: Parser RequireInfo
requireInfo :: ParsecT Void Text Identity RequireInfo
requireInfo = do
  ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Text -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
Megaparsec.string Tokens Text
"require"
  ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
Megaparsec.space1
  ModuleName
module' <- Parser ModuleName
moduleNameParser
  ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
Megaparsec.space
  Maybe [Char]
alias' <- ParsecT Void Text Identity (Maybe [Char])
-> ParsecT Void Text Identity (Maybe [Char])
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
Megaparsec.try (ParsecT Void Text Identity (Maybe [Char])
 -> ParsecT Void Text Identity (Maybe [Char]))
-> ParsecT Void Text Identity (Maybe [Char])
-> ParsecT Void Text Identity (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ Maybe [Char]
-> ParsecT Void Text Identity (Maybe [Char])
-> ParsecT Void Text Identity (Maybe [Char])
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
Megaparsec.option Maybe [Char]
forall a. Maybe a
Nothing (ParsecT Void Text Identity (Maybe [Char])
 -> ParsecT Void Text Identity (Maybe [Char]))
-> ParsecT Void Text Identity (Maybe [Char])
-> ParsecT Void Text Identity (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ do
    ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Text -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
Megaparsec.string Tokens Text
"as"
    ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
Megaparsec.space1
    [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char])
-> ParsecT Void Text Identity [Char]
-> ParsecT Void Text Identity (Maybe [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
Megaparsec.some ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
Megaparsec.alphaNumChar
  ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
Megaparsec.space
  Maybe [Char]
types' <- Maybe [Char]
-> ParsecT Void Text Identity (Maybe [Char])
-> ParsecT Void Text Identity (Maybe [Char])
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
Megaparsec.option Maybe [Char]
forall a. Maybe a
Nothing (ParsecT Void Text Identity (Maybe [Char])
 -> ParsecT Void Text Identity (Maybe [Char]))
-> ParsecT Void Text Identity (Maybe [Char])
-> ParsecT Void Text Identity (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ do
    ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Char -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
Megaparsec.char Char
Token Text
'('
    [Char]
t' <- ParsecT Void Text Identity Char
-> ParsecT Void Text Identity [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
Megaparsec.many (ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
Megaparsec.alphaNumChar ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
Megaparsec.char Char
Token Text
',' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
Megaparsec.char Char
Token Text
' ')
    ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Char -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
Megaparsec.char Char
Token Text
')'
    Maybe [Char] -> ParsecT Void Text Identity (Maybe [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char] -> ParsecT Void Text Identity (Maybe [Char]))
-> Maybe [Char] -> ParsecT Void Text Identity (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
t'

  let defaultAlias :: Text
defaultAlias = ModuleName -> Text
defaultModuleAlias ModuleName
module'
  RequireInfo -> ParsecT Void Text Identity RequireInfo
forall (m :: * -> *) a. Monad m => a -> m a
return
    RequireInfo :: ModuleName -> Text -> Text -> RequireInfo
RequireInfo
      { riFullModuleName :: ModuleName
riFullModuleName = ModuleName
module',
        riModuleAlias :: Text
riModuleAlias = Text -> ([Char] -> Text) -> Maybe [Char] -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
defaultAlias [Char] -> Text
forall a. ToText a => a -> Text
toText Maybe [Char]
alias',
        riImportedTypes :: Text
riImportedTypes = Text -> ([Char] -> Text) -> Maybe [Char] -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
defaultAlias [Char] -> Text
forall a. ToText a => a -> Text
toText Maybe [Char]
types'
      }

moduleDirective :: Parser RequireDirective
moduleDirective :: Parser RequireDirective
moduleDirective = do
  ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Text -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
Megaparsec.string Tokens Text
"module"
  ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity () -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
Megaparsec.space1
  ModuleName
module' <- Parser ModuleName
moduleNameParser
  -- Ignore anything further from the line.
  ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Text -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Maybe [Char]
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
Megaparsec.takeWhileP Maybe [Char]
forall a. Maybe a
Nothing (Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
True)
  RequireDirective -> Parser RequireDirective
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RequireDirective -> Parser RequireDirective)
-> RequireDirective -> Parser RequireDirective
forall a b. (a -> b) -> a -> b
$ ModuleName -> RequireDirective
ModuleDirective ModuleName
module'

-- | Parses a haskell module name.
--
-- This parser is a superset of what makes a valid module name in Haskell
-- (e.g. we allow consecutive dots, lower-case first letters etc.).
moduleNameParser :: Parser ModuleName
moduleNameParser :: Parser ModuleName
moduleNameParser =
  (Text -> ModuleName)
-> ParsecT Void Text Identity Text -> Parser ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ModuleName
ModuleName (ParsecT Void Text Identity Text -> Parser ModuleName)
-> ParsecT Void Text Identity Text -> Parser ModuleName
forall a b. (a -> b) -> a -> b
$ Maybe [Char]
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
Megaparsec.takeWhile1P Maybe [Char]
forall a. Maybe a
Nothing ((Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text))
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall a b. (a -> b) -> a -> b
$ \Token Text
c ->
    Char -> Bool
Char.isAlphaNum Char
Token Text
c Bool -> Bool -> Bool
|| Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\''

-- | Skips a haskell line comment.
--
-- This parser never fails.
skipLineComment :: Parser ()
skipLineComment :: ParsecT Void Text Identity ()
skipLineComment = ParsecT Void Text Identity (Maybe Text)
-> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity (Maybe Text)
 -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity (Maybe Text)
-> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
Megaparsec.optional (ParsecT Void Text Identity Text
 -> ParsecT Void Text Identity (Maybe Text))
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Maybe Text)
forall a b. (a -> b) -> a -> b
$
  Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
Megaparsec.string Tokens Text
"--"
    ParsecT Void Text Identity Text
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
Megaparsec.space1 ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
Megaparsec.alphaNumChar ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
Megaparsec.eof)
    ParsecT Void Text Identity ()
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Maybe [Char]
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
Megaparsec.takeWhileP Maybe [Char]
forall a. Maybe a
Nothing (Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
True)

-- | Extracts the module alias to be used when none is specified. This
-- corresponds to the last segment of the module's hierarchical name.
--
-- >>> defaultModuleAlias (ModuleName "Data.Text.Lazy")
-- "Lazy"
-- >>> defaultModuleAlias (ModuleName "Main")
-- "Main"
defaultModuleAlias :: ModuleName -> Text
defaultModuleAlias :: ModuleName -> Text
defaultModuleAlias = (Char -> Bool) -> Text -> Text
Text.takeWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') (Text -> Text) -> (ModuleName -> Text) -> ModuleName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> Text
unModuleName