records-edsl-core-0.1.0: Records/EDSL/Declare.hs

{- HLINT ignore "Use camelCase" -}

module Records.EDSL.Declare (
  declareSchemaRecords,
  declareSchemaRecordsFromFile,
)
where

import Data.Maybe
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Syntax qualified as TH
import Records.EDSL.Deriving.Type
import Records.EDSL.Description
import Relude hiding (lines)
import Text.Megaparsec as M

-- | Declare records. Recommendation: use @ -XMultilineStrings @
declareSchemaRecords :: Deriver -> Text -> TH.DecsQ
declareSchemaRecords derivers text = do
  recs <-
    M.runParserT parseRecordDescs "" text >>= \case
      Left e -> error (toText (M.errorBundlePretty e))
      Right a -> pure a
  decss <- forM recs (schemaRecordType derivers)
  pure (concat decss)

-- | Declare records from a file
declareSchemaRecordsFromFile :: Deriver -> FilePath -> TH.DecsQ
declareSchemaRecordsFromFile derivers fp = do
  TH.qAddDependentFile fp
  text <- TH.runIO (decodeUtf8 <$> readFileBS fp)
  declareSchemaRecords derivers text

--------------------------------------------------------------------------------

schemaRecordType :: Deriver -> RecordDesc Text -> TH.DecsQ
schemaRecordType derivers rdesc = do
  self@RecordDesc {typeName, constrName, fields} <- traverse (TH.newName . toString) (addFieldPrefixes rdesc)
  let
    fieldCount = length fields
    asNewtype = fieldCount == 1
    qRecord =
      TH.RecC
        constrName
        [ ( name
          , TH.Bang TH.NoSourceUnpackedness (if asNewtype then TH.NoSourceStrictness else TH.SourceStrict)
          , type_.hask.type_
          )
        | FieldDesc {name, type_} <- fields
        ]
  qDataDecl <-
    if asNewtype
      then TH.newtypeD (pure []) typeName [] Nothing (pure qRecord) []
      else TH.dataD (pure []) typeName [] Nothing [pure qRecord] []
  derivations <- runDeriver derivers self
  pure (qDataDecl : derivations)