Description.hs

{- HLINT ignore "Use camelCase" -}
module Records.EDSL.Description where

import Data.Char (toLower, toUpper)
import Data.Maybe
import Data.Text qualified as Text
import Language.Haskell.Meta.Parse qualified as Meta
import Language.Haskell.TH qualified as TH
import Optics
import Relude hiding (lines)
import Text.Megaparsec as M
import Text.Megaparsec.Char qualified as M
import Text.Megaparsec.Char.Lexer qualified as L
import Witch

data RecordDesc n = RecordDesc
  { opts :: RecordOpts
  , typeNameText :: Text
  , typeName :: n
  , constrName :: n
  , description :: Maybe Description
  , fields :: [FieldDesc n]
  }
  deriving stock (Show, Generic, Functor, Foldable, Traversable)
  deriving anyclass (GenericLabelOptics)

newtype RecordOpts = RecordOpts
  { customPrefix :: Maybe Text
  }
  deriving stock (Show, Generic)
  deriving anyclass (GenericLabelOptics)

data TypeDesc = TypeDesc
  { type_ :: TH.Type
  , text :: Text
  }
  deriving stock (Show, Eq, Generic)
  deriving anyclass (GenericLabelOptics)

data FieldDesc n = FieldDesc
  { name :: n
  , nameText :: Text
  , description :: Maybe Description
  , type_ :: FieldType
  , isOptional :: Bool
  }
  deriving stock (Show, Generic, Functor, Foldable, Traversable)
  deriving anyclass (GenericLabelOptics)

data FieldType
  = FieldTypeAs {hask :: TypeDesc}
  | FieldTypeFrom {hask, json :: TypeDesc}
  | FieldTypeTryFrom {hask, json :: TypeDesc}
  deriving stock (Show, Generic)
  deriving anyclass (GenericLabelOptics)

data Description = Description {isExtra :: Bool, text :: Text}
  deriving stock (Show, Generic)
  deriving anyclass (GenericLabelOptics)

qFieldToExternalFormat :: FieldType -> TH.ExpQ
qFieldToExternalFormat = \case
  FieldTypeAs {} -> [|identity|]
  FieldTypeFrom {hask = a, json = b}
    | isMaybeType a.type_ && isMaybeType b.type_ -> [|(fmap from :: $(pure a.type_) -> $(pure b.type_))|]
    | otherwise -> [|(from :: $(pure a.type_) -> $(pure b.type_))|]
  FieldTypeTryFrom {hask = a, json = b}
    | isMaybeType a.type_ && isMaybeType b.type_ -> [|(fmap from :: $(pure a.type_) -> $(pure b.type_))|]
    | otherwise -> [|(from :: $(pure a.type_) -> $(pure b.type_))|]

qFieldFromExternalFormat :: FieldType -> TH.ExpQ
qFieldFromExternalFormat = \case
  FieldTypeAs {} -> [|pure|]
  FieldTypeFrom {hask = b, json = a}
    | isMaybeType a.type_ && isMaybeType b.type_ -> [|(pure . (fmap from :: $(pure a.type_) -> $(pure b.type_)))|]
    | otherwise -> [|(pure . (from :: $(pure a.type_) -> $(pure b.type_)))|]
  FieldTypeTryFrom {hask = TypeDesc {type_ = b}, json = TypeDesc {type_ = a}}
    | isMaybeType a && isMaybeType b ->
        [|
          maybe
            (pure Nothing)
            (either (fail . show) pure . (tryFrom @($(pure a)) @($(pure b))))
          |]
    | otherwise ->
        [|either (fail . show) pure . (tryFrom @($(pure a)) @($(pure b)))|]

addFieldPrefixes :: RecordDesc Text -> RecordDesc Text
addFieldPrefixes r@RecordDesc {typeName, opts = RecordOpts {customPrefix}} =
  r
    & #fields
      % mapped
      % mapped
      %~ \fld ->
        case customPrefix of
          Nothing -> (typeName & ix 0 %~ toLower) <> (fld & ix 0 %~ toUpper)
          Just pfix
            | Text.null pfix -> fld
            | otherwise -> pfix <> (fld & ix 0 %~ toUpper)

isMaybeType :: TH.Type -> Bool
isMaybeType = \case
  TH.ConT m -> TH.nameBase m == "Maybe"
  TH.AppT a _ -> isMaybeType a
  TH.ParensT a -> isMaybeType a
  _ -> False

--------------------------------------------------------------------------------
-- Parsing
--
--

type P = ParsecT Void Text TH.Q

symbol :: Text -> P ()
symbol = void . L.symbol M.space

lexeme :: P a -> P a
lexeme = L.lexeme (M.space1 <|> void (M.lookAhead (M.oneOf ("()[]{},.:" :: [Char]))))

braces, brackets :: P a -> P a
braces = between (symbol "{") (symbol "}")
brackets = between (symbol "[") (symbol "]")

parseName :: P Text
parseName = lexeme (toText <$> M.some M.alphaNumChar)

newtype RecordOpt
  = RO_CustomPrefix Text

parseRecordOpts :: P RecordOpts
parseRecordOpts =
  M.many parseOpt
    <&> foldl' addOpt RecordOpts {customPrefix = Nothing}
  where
    parseOpt =
      choice
        [ do
            symbol "--no-field-prefix"
            pure (RO_CustomPrefix "")
        , do
            symbol "--field-prefix="
            RO_CustomPrefix <$> parseName
        ]
    addOpt z = \case
      RO_CustomPrefix p -> z {customPrefix = Just p}

parseRecordDescs :: P [RecordDesc Text]
parseRecordDescs =
  M.some
    ( M.space >> do
        description <- parseDescription
        symbol "record"
        name <- parseName
        opts <- parseRecordOpts
        fields <- braces (M.sepEndBy1 (parseField <* M.space) (symbol ","))
        pure
          RecordDesc
            { opts
            , typeNameText = name
            , typeName = name
            , constrName = name
            , description
            , fields
            }
    )

parseDescription :: P (Maybe Description)
parseDescription = M.try $ M.optional do
  _ <- commentMarker
  _isExtra <- isJust <$> M.try (M.optional (M.chunk "+ "))
  line1 <- M.takeWhileP Nothing (/= '\n') <* M.newline
  lines <- M.many $ try do
    M.hspace
    commentMarker
    M.takeWhileP Nothing (/= '\n') <* M.newline
  let text = unlines (line1 : lines)
  pure Description {isExtra = True, text}
  where
    commentMarker :: P ()
    commentMarker = void (M.chunk "--")

parseField :: P (FieldDesc Text)
parseField = do
  fdesc <- parseDescription <* M.space
  fname <- parseName
  symbol "::"
  type_ <- do
    let
      parseEndOfDecl = M.chunk ",\n" <|> M.chunk "\n"
      parseDelim = M.chunk " via? " <|> M.chunk " via " <|> M.lookAhead parseEndOfDecl
      parseUntilEndOfDecl = M.manyTill M.anySingle (M.lookAhead parseEndOfDecl)
    hask <- parseTypeDesc =<< M.manyTill M.anySingle (M.lookAhead parseDelim)
    delim <- parseDelim
    case delim of
      " via? " -> (\json -> FieldTypeTryFrom {hask, json}) <$> (parseTypeDesc =<< parseUntilEndOfDecl)
      " via " -> (\json -> FieldTypeFrom {hask, json}) <$> (parseTypeDesc =<< parseUntilEndOfDecl)
      _ -> pure FieldTypeAs {hask}
  pure
    FieldDesc
      { name = fname
      , nameText = fname
      , description = fdesc
      , type_
      , isOptional = isMaybeType (qFieldJSONTypeDesc type_).type_
      }
  where
    parseTypeDesc text = case Meta.parseType text of
      Right type_ -> pure TypeDesc {type_, text = Text.pack text}
      Left err -> fail err

qFieldJSONTypeDesc :: FieldType -> TypeDesc
qFieldJSONTypeDesc = \case
  FieldTypeAs {hask} -> hask
  FieldTypeFrom {json} -> json
  FieldTypeTryFrom {json} -> json