content: {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE NamedFieldPuns #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE TemplateHaskell #-}
  
  module RON.Schema.TH (
      module RON.Schema,
      mkReplicated,
      mkReplicated',
  ) where
  
  import RON.Prelude
  
  import Data.EDN.Extra (SourcePos (..), mkPos)
  import Data.Text qualified as Text
  import Data.Text.Encoding qualified as Text
  import Language.Haskell.TH (
      Loc (Loc),
      conE,
      conP,
      conT,
      lamCaseE,
      normalB,
   )
  import Language.Haskell.TH qualified as TH
  import Language.Haskell.TH.Quote (
      QuasiQuoter (QuasiQuoter),
      quoteDec,
      quoteExp,
      quotePat,
      quoteType,
   )
  import Language.Haskell.TH.Syntax (dataToPatQ, liftData)
  
  import RON.Data (Replicated (..), ReplicatedAsPayload (..))
  import RON.Error (throwErrorString)
  import RON.Schema
  import RON.Schema.EDN qualified as EDN
  import RON.Schema.TH.Common (mkGuideType, mkNameT)
  import RON.Schema.TH.Struct (mkReplicatedStructLww, mkReplicatedStructSet)
  import RON.UUID qualified as UUID
  
  -- | QuasiQuoter to generate Haskell types from RON-Schema
  mkReplicated :: (HasCallStack) => QuasiQuoter
  mkReplicated = QuasiQuoter{quoteDec, quoteExp = e, quotePat = e, quoteType = e}
    where
      e = error "declaration only"
      quoteDec source = do
          Loc{loc_filename, loc_start = (line, column)} <- TH.location
          let sourcePos =
                  SourcePos
                      { sourceName = loc_filename
                      , sourceLine = mkPos line
                      , sourceColumn = mkPos column
                      }
          schema <- EDN.readSchema sourcePos $ Text.pack source
          mkReplicated' schema
  
  -- | Generate Haskell types from RON-Schema
  mkReplicated' :: Schema 'Resolved -> TH.DecsQ
  mkReplicated' = fmap fold . traverse fromDecl
    where
      fromDecl decl = case decl of
          DAlias a -> mkAlias a
          DEnum e -> mkEnum e
          DOpaqueAtoms _ -> pure []
          DOpaqueObject _ -> pure []
          DStructLww s -> mkReplicatedStructLww s
          DStructSet s -> mkReplicatedStructSet s
  
  mkEnum :: TEnum -> TH.DecsQ
  mkEnum Enum{name, items} = do
      itemsUuids <- for items $ \item -> do
          uuid <- UUID.mkName $ Text.encodeUtf8 item
          pure (mkNameT item, uuid)
      dataType <- mkDataType
      [instanceReplicated] <- mkInstanceReplicated
      [instanceReplicatedAsPayload] <- mkInstanceReplicatedAsPayload itemsUuids
      pure [dataType, instanceReplicated, instanceReplicatedAsPayload]
    where
      typeName = conT $ mkNameT name
  
      mkDataType =
          TH.dataD
              (TH.cxt [])
              (mkNameT name)
              []
              Nothing
              [TH.normalC (mkNameT item) [] | item <- items]
              []
  
      mkInstanceReplicated =
          [d|
              instance Replicated $typeName where
                  encoding = payloadEncoding
              |]
  
      mkInstanceReplicatedAsPayload itemsUuids =
          [d|
              instance ReplicatedAsPayload $typeName where
                  toPayload = toPayload . $toUuid
                  fromPayload = fromPayload >=> $fromUuid
              |]
        where
          toUuid =
              lamCaseE
                  [ match (conP itemName []) (liftData uuid)
                  | (itemName, uuid) <- itemsUuids
                  ]
          fromUuid =
              lamCaseE $
                  [ match (liftDataP uuid) [|pure $(conE itemName)|]
                  | (itemName, uuid) <- itemsUuids
                  ]
                      ++ [ match
                              TH.wildP
                              [|throwErrorString "expected one of enum items"|]
                         ]
          liftDataP = dataToPatQ $ const Nothing
          match pat body = TH.match pat (normalB body) []
  
  mkAlias :: Alias Resolved -> TH.DecsQ
  mkAlias Alias{name, target} =
      (: []) <$> TH.tySynD (mkNameT name) [] (mkGuideType target)
  