semantic-version-0.0.1: src/Data/SemanticVersion/AlphanumericIdentifier.hs

{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE LambdaCase #-}

module Data.SemanticVersion.AlphanumericIdentifier where

import Control.Applicative
import Control.Lens
import Data.Digit
import Data.List.NonEmpty
import Data.SemanticVersion.NonDigit
import Data.SemanticVersion.IdentifierCharacter
import Data.SemanticVersion.IdentifierCharacters
import Text.Parser.Char
import Text.Parser.Combinators

-- $setup
-- >>> import Text.Parsec(parse)
-- >>> import Data.Either(isLeft)

-- <alphanumeric identifier> ::= <non-digit>
--                             | <non-digit> <identifier characters>
--                             | <identifier characters> <non-digit>
--                             | <identifier characters> <non-digit> <identifier characters>
data AlphanumericIdentifier =
  AlphanumericIdentifierNonDigit NonDigit
  | AlphanumericIdentifierNonDigits NonDigit IdentifierCharacters
  | AlphanumericIdentifierCharacters IdentifierCharacters NonDigit
  | AlphanumericIdentifierCharacters2 IdentifierCharacters NonDigit IdentifierCharacters
  deriving (Eq, Show)

class HasAlphanumericIdentifier a where
  alphanumericIdentifier ::
    Lens' a AlphanumericIdentifier

instance HasAlphanumericIdentifier AlphanumericIdentifier where
  alphanumericIdentifier =
    id

class AsAlphanumericIdentifier a where
  _AlphanumericIdentifier ::
    Prism' a AlphanumericIdentifier
  _AlphanumericIdentifierNonDigit ::
    Prism' a NonDigit
  _AlphanumericIdentifierNonDigit =
    _AlphanumericIdentifier .
    prism'
      AlphanumericIdentifierNonDigit
      (\case
        AlphanumericIdentifierNonDigit a ->
          Just a
        _ ->
          Nothing)
  _AlphanumericIdentifierNonDigits ::
    Prism' a (NonDigit, IdentifierCharacters)
  _AlphanumericIdentifierNonDigits =
    _AlphanumericIdentifier .
    prism'
      (uncurry AlphanumericIdentifierNonDigits)
      (\case
        AlphanumericIdentifierNonDigits d cs ->
          Just (d, cs)
        _ ->
          Nothing)
  _AlphanumericIdentifierCharacters ::
    Prism' a (IdentifierCharacters, NonDigit)
  _AlphanumericIdentifierCharacters =
    _AlphanumericIdentifier .
    prism'
      (uncurry AlphanumericIdentifierCharacters)
      (\case
        AlphanumericIdentifierCharacters cs d ->
          Just (cs, d)
        _ ->
          Nothing)
  _AlphanumericIdentifierCharacters2 ::
    Prism' a (IdentifierCharacters, NonDigit, IdentifierCharacters)
  _AlphanumericIdentifierCharacters2 =
    _AlphanumericIdentifier .
    prism'
      (\(cs1, d, cs2) -> AlphanumericIdentifierCharacters2 cs1 d cs2)
      (\case
        AlphanumericIdentifierCharacters2 cs1 d cs2 ->
          Just (cs1, d, cs2)
        _ ->
          Nothing)

instance AsAlphanumericIdentifier AlphanumericIdentifier where
  _AlphanumericIdentifier =
    id

instance HasNonDigit AlphanumericIdentifier where
  nonDigit f (AlphanumericIdentifierNonDigit d) =
    fmap AlphanumericIdentifierNonDigit (f d)
  nonDigit f (AlphanumericIdentifierNonDigits d cs) =
    fmap (`AlphanumericIdentifierNonDigits` cs) (f d)
  nonDigit f (AlphanumericIdentifierCharacters cs d) =
    fmap (AlphanumericIdentifierCharacters cs) (f d)
  nonDigit f (AlphanumericIdentifierCharacters2 cs1 d cs2) =
    fmap (\d' -> AlphanumericIdentifierCharacters2 cs1 d' cs2) (f d)

-- |
--
-- >>> parse (parseAlphanumericIdentifier <* eof) "parseAlphanumericIdentifier" "A"
-- Right (AlphanumericIdentifierNonDigit (NonDigitLetter (AlphaUpper Upper_A)))
--
-- >>> isLeft (parse parseAlphanumericIdentifier "parseAlphanumericIdentifier" "")
-- True
--
-- >>> parse (parseAlphanumericIdentifier <* eof) "parseAlphanumericIdentifier" "Abc-123--XYZ"
-- Right (AlphanumericIdentifierNonDigits (NonDigitLetter (AlphaUpper Upper_A)) (IdentifierCharacters (IdentifierCharacterNonDigit (NonDigitLetter (AlphaLower Lower_b)) :| [IdentifierCharacterNonDigit (NonDigitLetter (AlphaLower Lower_c)),IdentifierCharacterNonDigit NonDigitHyphen,IdentifierCharacterDigit DecDigit1,IdentifierCharacterDigit DecDigit2,IdentifierCharacterDigit DecDigit3,IdentifierCharacterNonDigit NonDigitHyphen,IdentifierCharacterNonDigit NonDigitHyphen,IdentifierCharacterNonDigit (NonDigitLetter (AlphaUpper Upper_X)),IdentifierCharacterNonDigit (NonDigitLetter (AlphaUpper Upper_Y)),IdentifierCharacterNonDigit (NonDigitLetter (AlphaUpper Upper_Z))])))
--
-- >>> isLeft (parse parseAlphanumericIdentifier "parseAlphanumericIdentifier" "+")
-- True
--
-- >>> isLeft (parse parseAlphanumericIdentifier "parseAlphanumericIdentifier" "0")
-- True
--
-- >>> isLeft (parse parseAlphanumericIdentifier "parseAlphanumericIdentifier" "0+")
-- True
--
-- >>> parse (parseAlphanumericIdentifier <* eof) "parseAlphanumericIdentifier" "0a"
-- Right (AlphanumericIdentifierCharacters (IdentifierCharacters (IdentifierCharacterDigit DecDigit0 :| [])) (NonDigitLetter (AlphaLower Lower_a)))
--
-- >>> parse parseAlphanumericIdentifier "parseAlphanumericIdentifier" "-"
-- Right (AlphanumericIdentifierNonDigit NonDigitHyphen)
--
-- >>> parse parseAlphanumericIdentifier "parseAlphanumericIdentifier" "Abc-123--XYZ+"
-- Right (AlphanumericIdentifierNonDigits (NonDigitLetter (AlphaUpper Upper_A)) (IdentifierCharacters (IdentifierCharacterNonDigit (NonDigitLetter (AlphaLower Lower_b)) :| [IdentifierCharacterNonDigit (NonDigitLetter (AlphaLower Lower_c)),IdentifierCharacterNonDigit NonDigitHyphen,IdentifierCharacterDigit DecDigit1,IdentifierCharacterDigit DecDigit2,IdentifierCharacterDigit DecDigit3,IdentifierCharacterNonDigit NonDigitHyphen,IdentifierCharacterNonDigit NonDigitHyphen,IdentifierCharacterNonDigit (NonDigitLetter (AlphaUpper Upper_X)),IdentifierCharacterNonDigit (NonDigitLetter (AlphaUpper Upper_Y)),IdentifierCharacterNonDigit (NonDigitLetter (AlphaUpper Upper_Z))])))
parseAlphanumericIdentifier ::
  CharParsing p =>
  p AlphanumericIdentifier
parseAlphanumericIdentifier =
  try (liftA2 maybe AlphanumericIdentifierNonDigit AlphanumericIdentifierNonDigits <$> parseNonDigit <*> try (optional parseIdentifierCharacters)) <|>
  (\c d ->
    let c' = IdentifierCharacters (IdentifierCharacterDigit <$> c)
    in  maybe (AlphanumericIdentifierCharacters c' d) (AlphanumericIdentifierCharacters2 c' d)) <$> some1 parseDecimal <*> parseNonDigit <*> try (optional parseIdentifierCharacters)