content: {-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-}
  {-|
  Module : Yarn.Lock.Parse
  Description : Parser for yarn.lock files
  Maintainer : Profpatsch
  Stability : experimental
  
  This module provides a parser for the AST of @yarn.lock@ files.
  -}
  module Yarn.Lock.Parse
  ( PackageFields(..), Package
  -- * Parsing
  -- ** Re-export
  , Parser
  -- ** Parsers
  , packageList
  , packageEntry
  -- * Internal Parsers
  , field, nestedField, simpleField
  , packageKeys
  ) where
  
  import qualified Data.Char as Ch
  import qualified Data.List.NonEmpty as NE
  import qualified Data.Text as T
  import qualified Data.Map.Strict as M
  import Control.Monad (void)
  import qualified Text.Megaparsec as MP
  import qualified Text.Megaparsec.Char as MP
  import qualified Text.Megaparsec.Char.Lexer as MPL
  import qualified Yarn.Lock.Types as YLT
  import Data.Text (Text)
  import Data.Void (Void)
  import Data.Map.Strict (Map)
  import qualified Data.Text as Text
  import Text.Megaparsec (Parsec, Stream (Tokens), (<?>))
  import Text.Megaparsec.Pos (SourcePos)
  import Control.Applicative ((<|>))
  
  
  -- | We use a simple (pure) @Megaparsec@ parser.
  type Parser = Parsec Void Text
  
  -- | The @yarn.lock@ format doesn’t specifically include a fixed scheme,
  -- it’s just an unnecessary custom version of a list of fields.
  --
  -- An field can either be a string or more fields w/ deeper indentation.
  --
  -- The actual conversion to semantic structures needs to be done afterwards.
  newtype PackageFields = PackageFields (Map Text (Either Text PackageFields))
    deriving (Show, Eq, Semigroup, Monoid)
  
  -- | A parsed 'Package' AST has one or more keys, a position in the original files
  -- and a collection of fields.
  type Package = YLT.Keyed (SourcePos, PackageFields)
  
  
  -- | Parse a complete yarn.lock into an abstract syntax tree,
  -- keeping the source positions of each package entry.
  packageList :: Parser [Package]
  packageList = MP.many $ (MP.skipMany (comment <|> MP.string "\n")) *> packageEntry
                  where
                    comment :: Parser (Tokens Text)
                    comment = MP.char '#' *> MP.takeWhileP Nothing (/= '\n')
  
  -- | A single Package.
  --
  -- Example:
  --
  -- @
  -- handlebars@^4.0.4:
  --   version "4.0.6"
  --   resolved "https://registry.yarnpkg.com/handlebars/-/handlebars-4.0.6.tgz#2ce4484850537f9c97a8026d5399b935c4ed4ed7"
  --   dependencies:
  --     async "^1.4.0"
  --     optimist "^0.6.1"
  --     source-map "^0.4.4"
  --   optionalDependencies:
  --     uglify-js "^2.6"
  --     "
  -- @
  packageEntry :: Parser (YLT.Keyed (SourcePos, PackageFields))
  packageEntry = MP.label "package entry" $ do
    pos <- MP.getSourcePos
    -- A package entry is a non-indented
    (keys, pkgs) <- nonIndented
              -- block that has a header of package keys
              -- and an indented part that contains fields
              $ indentedFieldsWithHeader packageKeys
    pure $ YLT.Keyed keys (pos, pkgs)
  
  -- | The list of PackageKeys that index the same Package
  --
  -- @
  -- align-text@^0.1.1, align-text@^0.1.3:\\n
  -- @
  packageKeys :: Parser (NE.NonEmpty YLT.PackageKey)
  packageKeys = MP.label "package keys" $ do
    firstEls <- MP.many (MP.try $ lexeme $ packageKey ":," <* MP.char ',')
    lastEl   <-                      packageKey ":"  <* MP.char ':'
    pure $ NE.fromList $ firstEls <> [lastEl]
  
  -- | A packageKey is @\<package-name\>\@\<semver\>@;
  --
  -- If the semver contains spaces, it is also quoted with @"@.
  packageKey :: [Char] -> Parser YLT.PackageKey
  packageKey separators = inString (pkgKey "\"")
           -- if no string delimiters is used we need to check for the separators
           -- this file format is shit :<
           <|> pkgKey separators
           <?> "package key"
    where
      pkgKey :: [Char] -> Parser YLT.PackageKey
      pkgKey valueChars = MP.label "package key" $ do
        key <- someTextOf (MP.noneOf valueChars)
        -- okay, here’s the rub:
        -- `@` is used for separation, but package names can also
        -- start with the `@` character (so-called “scoped packages”).
        -- Furthermore, versions can contain `@` as well.
        -- This file format is a pile of elephant shit.
        case breakDrop '@' key of
          ("", rest) -> case breakDrop '@' rest of
            -- scoped key with empty name
            ("", _) -> emptyKeyErr key
            -- scoped key ("@scope/package")
            (scopedName, ver) -> YLT.PackageKey
              <$> scoped (T.cons '@' scopedName) <*> pure ver
          -- just a simple key
          (name, ver) -> pure $ YLT.PackageKey (YLT.SimplePackageKey name) ver
  
      emptyKeyErr :: Text -> Parser a
      emptyKeyErr key = fail
        ("packagekey: package name can not be empty (is: "
        <> Text.unpack key <> ")")
  
      -- | Like 'T.breakOn', but drops the separator char.
      breakDrop :: Char -> Text -> (Text, Text)
      breakDrop c str = case T.breakOn (T.singleton c) str of
        (s, "") -> (s, "")
        (s, s') -> (s, T.drop 1 s')
  
      -- | Parses a (scoped) package key and throws an error if misformatted.
      scoped n = maybe
        (fail $ "packageKey: scoped variable must be of form @scope/package"
             <> " (is: " <> Text.unpack n <> ")")
        pure $ YLT.parsePackageKeyName n
  
  -- | Either a simple or a nested field.
  field :: Parser (Text, Either Text PackageFields)
  field = MP.try nested <|> simple <?> "field"
    where
      simple = fmap Left <$> simpleField
      nested = fmap Right <$> nestedField
  
  -- | A key-value pair, separated by space.
  -- Key any value may be enclosed in "".
  -- Returns key and value.
  simpleField :: Parser (Text, Text)
  simpleField = (,) <$> lexeme (strSymbolChars <|> symbolChars)
                    -- valueChars may be in Strings or maybe not >:
                    -- this file format is absolute garbage
                    <*> (strValueChars <|> valueChars)
                    <?> "simple field"
    where
      valueChars, strValueChars :: Parser Text
      valueChars = someTextOf (MP.noneOf ("\n\r\"" :: [Char]))
      strSymbolChars = inString $ symbolChars
      strValueChars = inString $ valueChars
        -- as with packageKey semvers, this can be empty
        <|> (pure T.empty <?> "an empty value field")
  
  -- | Similar to a @simpleField@, but instead of a string
  -- we get another block with deeper indentation.
  nestedField :: Parser (Text, PackageFields)
  nestedField = MP.label "nested field" $
    indentedFieldsWithHeader (symbolChars <* MP.char ':')
  
  
  -- internal parsers
  
  -- | There are two kinds of indented blocks:
  -- One where the header is the package
  -- and one where the header is already a package field key.
  indentedFieldsWithHeader :: Parser a -> Parser (a, PackageFields)
  indentedFieldsWithHeader header = indentBlock $ do
      -- … block that has a header of package keys
      hdr <- header
      -- … and an indented part that contains fields
      pure $ MPL.IndentSome Nothing
        (\fields -> pure (hdr, toPfs fields)) field
    where
      toPfs :: [(Text, Either Text PackageFields)] -> PackageFields
      toPfs = PackageFields . M.fromList
  
  -- | Characters allowed in key symbols.
  --
  -- TODO: those are partly npm package names, so check the allowed symbols, too.
  --
  -- Update: npm doesn’t specify the package name format, at all.
  -- Apart from the length.
  -- Update: According to https://docs.npmjs.com/misc/scope
  -- the package name format is “URL-safe characters, no leading dots or underscores” TODO
  symbolChars :: Parser Text
  symbolChars = MP.label "key symbol" $ someTextOf $ MP.satisfy
    (\c -> Ch.isAscii c &&
       (Ch.isLower c || Ch.isUpper c || Ch.isNumber c || c `elem` special))
    where special = "-_.@/" :: [Char]
  
  
  -- text versions of parsers & helpers
  
  someTextOf :: Parser Char -> Parser Text
  someTextOf c = T.pack <$> MP.some c
  
  -- | parse everything as inside a string
  inString :: Parser a -> Parser a
  inString = MP.between (MP.char '"') (MP.char '"')
  
  -- lexers
  
  -- | Parse whitespace.
  space :: Parser ()
  space = MPL.space (void MP.spaceChar)
                    (MPL.skipLineComment "# ")
                    (void $ MP.satisfy (const False))
  
  -- | Parse a lexeme.
  lexeme :: Parser a -> Parser a
  lexeme = MPL.lexeme space
  
  -- | Ensure parser is not indented.
  nonIndented :: Parser a -> Parser a
  nonIndented = MPL.nonIndented space
  indentBlock :: Parser (MPL.IndentOpt Parser a b)
              -> Parser a
  indentBlock = MPL.indentBlock space
  