content: {-# LANGUAGE ScopedTypeVariables, LambdaCase, BangPatterns, TupleSections, OverloadedStrings #-}
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  
  module Chainweb.Pact.Conversion
    ( fromLegacyQualifiedName
    , fromLegacyPactValue)
    where
  
  import qualified Pact.Types.Term as Legacy
  import qualified Pact.Types.Exp as Legacy
  import qualified Pact.Types.PactValue as Legacy
  import qualified Data.Set as S
  import qualified Data.Map.Strict as M
  
  import Pact.Core.ModRefs
  import Pact.Core.Literal
  import Pact.Core.Names
  import Pact.Core.Guards
  import Pact.Core.PactValue
  
  
  fromLegacyQualifiedName
    :: Legacy.QualifiedName
    -> QualifiedName
  fromLegacyQualifiedName (Legacy.QualifiedName mn n _) =
    QualifiedName n (fromLegacyModuleName mn)
  
  fromLegacyLiteral
    :: Legacy.Literal
    -> Either Literal PactValue
  fromLegacyLiteral = \case
    Legacy.LString s -> Left (LString s)
    Legacy.LInteger i -> Left (LInteger i)
    Legacy.LDecimal d -> Left (LDecimal d)
    Legacy.LBool b -> Left (LBool b)
    Legacy.LTime l -> Right $ PTime l
  
  fromLegacyPactId
    :: Legacy.PactId
    -> DefPactId
  fromLegacyPactId (Legacy.PactId pid) = DefPactId pid
  
  fromLegacyPactValue :: Legacy.PactValue -> Either String PactValue
  fromLegacyPactValue = \case
    Legacy.PLiteral l -> pure $ either PLiteral id $ fromLegacyLiteral l
    Legacy.PList p -> do
      l <- traverse fromLegacyPactValue p
      pure (PList l)
    Legacy.PObject (Legacy.ObjectMap om) -> do
      om' <- traverse fromLegacyPactValue om
      pure (PObject $ M.mapKeys (\(Legacy.FieldKey k) -> Field k) om')
    Legacy.PGuard g -> case g of
      Legacy.GPact (Legacy.PactGuard p n) -> let
        p' = fromLegacyPactId p
        in pure (PGuard (GDefPactGuard (DefPactGuard p' n)))
      Legacy.GKeySet (Legacy.KeySet k pred') ->  let
        ks = S.map (PublicKeyText . Legacy._pubKey)  k
        p' = \case
          (Legacy.Name (Legacy.BareName bn _def))
            | bn == "keys-all" -> pure KeysAll
            | bn == "keys-any" -> pure KeysAny
            | bn == "keys-2"   -> pure Keys2
          (Legacy.Name (Legacy.BareName bn _def)) -> pure (CustomPredicate (TBN $ BareName bn))
          (Legacy.QName qn) -> pure (CustomPredicate (TQN $ fromLegacyQualifiedName qn))
          o -> Left $ "fromLegacyPactValue: pred invariant: " <> show o
        in (PGuard . GKeyset . KeySet ks <$> p' pred')
      Legacy.GKeySetRef (Legacy.KeySetName ksn ns) -> let
        ns' = fromLegacyNamespaceName <$> ns
        in pure (PGuard . GKeySetRef $ KeySetName ksn ns')
      Legacy.GModule (Legacy.ModuleGuard mn n) -> let
        mn' = fromLegacyModuleName mn
        in pure (PGuard $ GModuleGuard (ModuleGuard mn' n))
      Legacy.GUser (Legacy.UserGuard n a) -> case n of
        Legacy.QName n' -> do
          let qn = fromLegacyQualifiedName n'
          args <- traverse fromLegacyPactValue a
          pure (PGuard $ GUserGuard (UserGuard qn args))
        _ -> Left "fromLegacyPactValue: invariant"
      Legacy.GCapability (Legacy.CapabilityGuard n a i) -> do
        let qn = fromLegacyQualifiedName n
        args <- traverse fromLegacyPactValue a
        pure (PGuard $ GCapabilityGuard (CapabilityGuard qn args (fromLegacyPactId <$> i)))
    Legacy.PModRef (Legacy.ModRef mn mmn _) -> let
      mn' = fromLegacyModuleName mn
      imp = S.fromList $ maybe [] (map fromLegacyModuleName) mmn
      in pure (PModRef $ ModRef mn' imp)
  
  
  fromLegacyNamespaceName :: Legacy.NamespaceName -> NamespaceName
  fromLegacyNamespaceName (Legacy.NamespaceName ns) = NamespaceName ns
  
  fromLegacyModuleName
    :: Legacy.ModuleName
    -> ModuleName
  fromLegacyModuleName (Legacy.ModuleName n ns)
    = ModuleName n (fromLegacyNamespaceName <$> ns)
  