warlock-0.1.0.0: src/Warlock.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- |
-- Module      : Warlock
-- Description : Unified Template Haskell derivation for Witch From/TryFrom instances
-- License     : MIT
-- Maintainer  : ian@iankduncan.com
-- Stability   : experimental
--
-- = Overview
--
-- Unified Template Haskell derivation supporting both structural (positional)
-- and semantic (name-based) mapping strategies.
--
-- = Quick Start
--
-- @
-- import Warlock
--
-- -- Structural mapping (by position):
-- deriveAutomap ByPosition ''Foo ''Either
--
-- -- Semantic mapping (by name):
-- deriveAutomap (ByName datatypePrefixConfig) ''Person ''Employee
--
-- -- With custom configuration:
-- deriveAutomap (ByName $ datatypePrefixConfig \`withDefaults\` [(\"newField\", [| 0 |])])
--               ''Source ''Dest
-- @
--
-- = Matching Strategies
--
-- [@ByPosition@]: Structural matching by declaration order.
-- Constructors: 1st → 1st, 2nd → 2nd. Fields: always positional.
-- Use for: Types with same shape but different names (`Either`, `Maybe`, etc.)
--
-- [@ByName@]: Semantic matching with configurable rules.
-- Constructors: matched by name (case-insensitive).
-- Fields: matched by name with prefix rules, defaults, computed fields.
-- Use for: Types with naming conventions (`personName` ↔ `employeeName`)
--
-- = Configuration
--
-- Common configs:
--
-- * 'datatypePrefixConfig' - Handle `personName` ↔ `employeeName` (most common)
-- * 'constructorPrefixConfig' - Handle constructor-prefixed fields
-- * 'defaultConfig' - No automatic rules (exact name matching)
--
-- Field-level customization:
--
-- * 'withDefaults' - Provide default values for new fields
-- * 'withRenames' - Rename specific fields
-- * 'withRules' - Add custom field rules (computed, virtual, disassemble)
--
-- = Examples
--
-- @
-- -- Simple structural mapping:
-- data Result = Success String | Failure Int
-- data HttpStatus = Ok String | Error Int
-- deriveAutomap ByPosition ''Result ''HttpStatus
--
-- -- Name-based with automatic prefix handling:
-- data Person = Person { personName :: String, personAge :: Int }
-- data Employee = Employee { employeeName :: String, employeeAge :: Int }
-- deriveAutomap (ByName datatypePrefixConfig) ''Person ''Employee
--
-- -- With defaults for new fields:
-- deriveAutomap (ByName $ datatypePrefixConfig \`withDefaults\`
--                [(\"employeeId\", [| 0 |])]
--               ) ''Person ''Employee
--
-- -- Combining multiple source fields:
-- deriveAutomap (ByName $ defaultConfig \`withRules\`
--                [ combineFields \"fullName\" $ do
--                    firstName <- get \"firstName\"
--                    lastName <- get \"lastName\"
--                    pure [| $firstName ++ \" \" ++ $lastName |]
--                ]
--               ) ''PersonV1 ''PersonV2
-- @
module Warlock
  ( -- * Main Derivation API
    MatchStrategy(..)
  , deriveAutomap
  , deriveAutomapWith
  , deriveTryAutomap
  , deriveAutomapBoth
  , deriveTryAutomapBoth

    -- * Configuration
  , Config
  , AutoMapConfig(..)  -- Export constructor for record syntax
  , datatypePrefixConfig
  , constructorPrefixConfig
  , conventionalConfig
  , snakeToCamelConfig
  , camelToSnakeConfig
  , defaultConfig

    -- * Configuration Helpers
  , withDefaults
  , withRenames
  , withRules
  , withConstructorMap
  , withNormalize
  , withRuleGens

    -- * Constructor Mapping
  , ConstructorMapping(..)
  , ToConstructorMapping(..)
  , stripSuffix
  , addSuffix
  , replaceSuffix

    -- * Field Rules (for ByName strategy)
  , FieldRule(..)
  , FieldRef(..)
  , ToFieldRef(..)
  , field
  , fromField
  , withDefault
  , withExpr
  , asVirtual
  , withComputed

    -- * Pre-composed Field Rules
  , rename
  , defaultTo
  , ignore
  , mapField
  , virtualField
  , computedField
  , combineFields
  , disassembleFields
  , DisassembledField(..)
  , (.=)

    -- * Disassemble Field Getters
  , DisassembleGetter
  , getSource
  , getSourceName

    -- * Field Getters (for computed fields)
  , FieldGetter
  , get
  , getName

    -- * Field Rule Generators
  , datatypePrefixRules
  , constructorPrefixRules
  , customPrefixRules
  , stripConstructorPrefix
  , addConstructorPrefix
  , RuleGenContext(..)

    -- * Name Normalizers
  , snakeToCamel
  , camelToSnake
  , stripPrefix
  , lowerFirst

    -- * Conversion Helpers
  , automap
  , tryAutomap
  , automapEach
  , tryAutomapEach

    -- * Internal (for Warlock.Tweak and advanced use)
  , resolveFieldRulesAndBuildInstance
  , resolveFieldRulesAndBuildInstanceWithType

    -- * Re-exports from Witch
  , module Witch
  ) where

import Data.Function ((&))
import qualified Witch as W
import Witch (From(..), TryFrom(..), TryFromException(..))
import Language.Haskell.TH
import Control.Monad (forM, when)
import Control.Applicative ((<|>))
import Data.List (find)
import Data.Char (toLower)
import GHC.Records (HasField(..))
import GHC.TypeLits (KnownSymbol, symbolVal)
import GHC.OverloadedLabels (IsLabel(..))
import Data.Proxy (Proxy(..))

--------------------------------------------------------------------------------
-- Strategy Type

-- | Strategy for matching constructors and fields during derivation.
data MatchStrategy
  = ByPosition
    -- ^ Match structurally by position.
    -- Constructors: 1st → 1st, 2nd → 2nd (must have same count).
    -- Fields: always positional (must have same arity per constructor).
  | ByName Config
    -- ^ Match by name with configurable rules.
    -- Constructors: by name (case-insensitive).
    -- Fields: by name with prefix rules, defaults, computed fields, etc.

-- | Configuration alias for cleaner API
type Config = AutoMapConfig

--------------------------------------------------------------------------------
-- Field Reference Types

-- | A reference to a field, either real (compile-time checked) or virtual (runtime via HasField).
--
-- Use:
-- - 'RealField' with TH names: @'fieldName@ for compile-time safety
-- - 'VirtualField' with strings or #labels: @#fieldName@ or @\"fieldName\"@ for HasField lookups
data FieldRef
  = RealField Name      -- ^ Real field that exists in the data type
  | VirtualField String -- ^ Virtual field accessed via HasField at runtime
  deriving (Show)

-- | Type class for converting various representations to FieldRef
class ToFieldRef a where
  toFieldRef :: a -> FieldRef

-- | TH Names become real fields
instance ToFieldRef Name where
  toFieldRef = RealField

-- | Strings become virtual fields
instance ToFieldRef String where
  toFieldRef = VirtualField

-- | OverloadedLabels support: #fieldName becomes a virtual field
instance (KnownSymbol s) => IsLabel s FieldRef where
  fromLabel = VirtualField (symbolVal (Proxy @s))

-- | Extract the string representation of a FieldRef (for normalization)
fieldRefToString :: FieldRef -> String
fieldRefToString (RealField n) = nameBase n
fieldRefToString (VirtualField s) = s

--------------------------------------------------------------------------------
-- Constructor Mapping Types

-- | Strategy for mapping constructor names during derivation.
--
-- Use:
-- - 'Identity' - no transformation (1:1 mapping by name)
-- - 'DirectMapping' - explicit constructor mappings: @[('OldCon, 'NewCon)]@
-- - 'Transform' - custom function: @Transform (\s -> s ++ "V2")@
-- - Helper combinators: 'stripSuffix', 'addSuffix', 'replaceSuffix'
data ConstructorMapping
  = Identity                           -- ^ No transformation (constructor names match)
  | DirectMapping [(Name, Name)]       -- ^ Explicit constructor name mappings (compile-time checked)
  | Transform (String -> String)       -- ^ Custom transformation function

-- | Type class for converting to ConstructorMapping
class ToConstructorMapping a where
  toConstructorMapping :: a -> ConstructorMapping

-- | Identity function becomes Identity mapping
instance ToConstructorMapping () where
  toConstructorMapping () = Identity

-- | String transformations become Transform
instance ToConstructorMapping (String -> String) where
  toConstructorMapping = Transform

-- | List of Name pairs becomes DirectMapping
instance ToConstructorMapping [(Name, Name)] where
  toConstructorMapping = DirectMapping

-- | ConstructorMapping is already a ConstructorMapping
instance ToConstructorMapping ConstructorMapping where
  toConstructorMapping = id

-- | Apply a constructor mapping to a constructor name
applyConstructorMapping :: ConstructorMapping -> String -> String
applyConstructorMapping Identity s = s
applyConstructorMapping (DirectMapping mappings) s =
  -- Case-insensitive lookup since constructor matching is case-insensitive
  case find (\(srcName, _) -> map toLower (nameBase srcName) == map toLower s) mappings of
    Just (_, targetName) -> nameBase targetName
    Nothing -> s  -- Fall back to identity if not in mapping
applyConstructorMapping (Transform f) s = f s

-- | Helper: Strip a suffix from constructor names
--
-- Example: @stripSuffix "V1"@ transforms @FooV1@ to @Foo@
stripSuffix :: String -> ConstructorMapping
stripSuffix suffix = Transform $ \s ->
  case reverse s of
    revS | reverse suffix == take (length suffix) revS ->
           reverse (drop (length suffix) revS)
    _ -> s

-- | Helper: Add a suffix to constructor names
--
-- Example: @addSuffix "V2"@ transforms @Foo@ to @FooV2@
addSuffix :: String -> ConstructorMapping
addSuffix suffix = Transform (++ suffix)

-- | Helper: Replace one suffix with another
--
-- Example: @replaceSuffix "V1" "V2"@ transforms @FooV1@ to @FooV2@
replaceSuffix :: String -> String -> ConstructorMapping
replaceSuffix oldSuffix newSuffix = Transform $ \s ->
  case reverse s of
    revS | reverse oldSuffix == take (length oldSuffix) revS ->
           reverse (drop (length oldSuffix) revS) ++ newSuffix
    _ -> s ++ newSuffix  -- If old suffix not found, just add new one

--------------------------------------------------------------------------------
-- Conversion Functions (re-exports from witch)

-- | Alias for 'W.from' - total conversion
automap :: W.From a b => a -> b
automap = W.from

-- | Alias for 'W.tryFrom' - fallible conversion
tryAutomap :: W.TryFrom a b => a -> Either (W.TryFromException a b) b
tryAutomap = W.tryFrom

-- | Map a conversion over a list
automapEach :: W.From a b => [a] -> [b]
automapEach = map W.from

-- | Try to map a conversion over a list, collecting results
tryAutomapEach :: W.TryFrom a b => [a] -> [Either (W.TryFromException a b) b]
tryAutomapEach = map W.tryFrom

--------------------------------------------------------------------------------
-- Main Derivation API

-- | Derive a 'From' instance using the specified matching strategy.
--
-- @
-- -- Structural:
-- deriveAutomap ByPosition ''Foo ''Bar
--
-- -- Semantic:
-- deriveAutomap (ByName datatypePrefixConfig) ''Person ''Employee
-- @
deriveAutomap :: MatchStrategy -> Name -> Name -> Q [Dec]
deriveAutomap ByPosition = deriveByPosition
deriveAutomap (ByName config) = deriveByName config

-- | Derive a 'From' instance for parameterized types.
--
-- This allows deriving instances for applied type constructors like @Container Int@.
--
-- @
-- deriveAutomapWith (ByName datatypePrefixConfig) [t| Container Int |] [t| IntContainer |]
-- @
deriveAutomapWith :: MatchStrategy -> Q Type -> Q Type -> Q [Dec]
deriveAutomapWith ByPosition srcTypeQ dstTypeQ =
  deriveWithTypePositional False srcTypeQ dstTypeQ
deriveAutomapWith (ByName config) srcTypeQ dstTypeQ =
  deriveWithTypeByName config srcTypeQ dstTypeQ

-- | Derive a 'TryFrom' instance using the specified matching strategy.
deriveTryAutomap :: MatchStrategy -> Name -> Name -> Q [Dec]
deriveTryAutomap ByPosition = deriveTryByPosition
deriveTryAutomap (ByName config) = deriveTryByName config

-- | Derive both directions: @From a b@ and @From b a@
deriveAutomapBoth :: MatchStrategy -> Name -> Name -> Q [Dec]
deriveAutomapBoth strategy srcName dstName = do
  forward <- deriveAutomap strategy srcName dstName
  backward <- deriveAutomap strategy dstName srcName
  pure (forward ++ backward)

-- | Derive both directions: @TryFrom a b@ and @TryFrom b a@
deriveTryAutomapBoth :: MatchStrategy -> Name -> Name -> Q [Dec]
deriveTryAutomapBoth strategy srcName dstName = do
  forward <- deriveTryAutomap strategy srcName dstName
  backward <- deriveTryAutomap strategy dstName srcName
  pure (forward ++ backward)

--------------------------------------------------------------------------------
-- Configuration Types (for ByName strategy)

-- | A rule for how to populate a destination field.
--
-- Use the builder functions ('field', 'from', 'withDefault', etc.) to construct rules.
--
-- Examples:
--   * @rename "balance" "balance_cents"@
--   * @defaultTo "region" [| "US" :: String |]@
--   * @mapField "name" (\srcF dstF -> [| $(varE srcF) ++ "!" |])@
data FieldRule = FieldRule
  { dst      :: Name
  , src      :: Maybe FieldRef  -- Can be real or virtual field
  , default_ :: Maybe (Q Exp)
  , expr     :: Maybe (Name -> Name -> Q Exp)
  , virtual  :: Bool
  , computed :: Maybe ([(String, Name)] -> Q Exp)
  }

-- | Context information passed to field rule generators.
data RuleGenContext = RuleGenContext
  { sourceTypeName        :: Name
  , sourceConstructorName :: Name
  , destinationTypeName   :: Name
  , destinationConstructorName :: Name
  , normalizeFunction     :: String -> String
  }

-- | Configuration for name-based derivation.
--
-- Common patterns:
--
-- @
-- -- Version suffixes for enums:
-- defaultConfig { constructorMap = (++ "V2") }
--
-- -- Field prefix rules:
-- defaultConfig { ruleGens = [datatypePrefixRules] }
--
-- -- Custom field transformations:
-- defaultConfig
--   { normalize = snakeToCamel
--   , staticRules = [defaultTo "newField" [| "default" |]]
--   }
-- @
data AutoMapConfig = AutoMapConfig
  { normalize          :: String -> String
  , ruleGens           :: [RuleGenContext -> String -> Maybe FieldRule]
  , staticRules        :: [FieldRule]
  , constructorMap     :: ConstructorMapping
  }

--------------------------------------------------------------------------------
-- Pre-defined Configurations

-- | Basic config: identity normalization, no rules, identity constructor mapping.
defaultConfig :: Config
defaultConfig = AutoMapConfig id [] [] Identity

-- | Config for Haskell datatype naming convention: fields prefixed by type name
--
-- Example: @Person { personName :: String }@ ↔ @Employee { employeeName :: String }@
datatypePrefixConfig :: Config
datatypePrefixConfig = defaultConfig { ruleGens = [datatypePrefixRules] }

-- | Config for constructor-prefixed fields
constructorPrefixConfig :: Config
constructorPrefixConfig = defaultConfig { ruleGens = [constructorPrefixRules] }

-- | Config that tries both datatype and constructor prefix conventions
conventionalConfig :: Config
conventionalConfig = defaultConfig { ruleGens = [datatypePrefixRules, constructorPrefixRules] }

-- | Config for snake_case → camelCase field name normalization
snakeToCamelConfig :: Config
snakeToCamelConfig = defaultConfig { normalize = snakeToCamel }

-- | Config for camelCase → snake_case field name normalization
camelToSnakeConfig :: Config
camelToSnakeConfig = defaultConfig { normalize = camelToSnake }

--------------------------------------------------------------------------------
-- Configuration Helpers

-- | Add defaults to a config
--
-- Example: @withDefaults config [("cvv", [| "000" |]), ("currency", [| "USD" |])]@
withDefaults :: Config -> [(Name, Q Exp)] -> Config
withDefaults cfg defaults = cfg { staticRules = staticRules cfg ++ map (uncurry defaultTo) defaults }

-- | Add renames to a config
--
-- Example: @withRenames config [(''newName, ''oldName)]@  (real fields)
-- Example: @withRenames config [(''empName, #fullName)]@  (virtual field)
withRenames :: ToFieldRef a => Config -> [(Name, a)] -> Config
withRenames cfg renames = cfg { staticRules = staticRules cfg ++ map (uncurry rename) renames }

-- | Add custom rules to a config
--
-- Example: @withRules config [virtualField "name" "fullName"]@
withRules :: Config -> [FieldRule] -> Config
withRules cfg rules = cfg { staticRules = staticRules cfg ++ rules }

-- | Set the constructor name mapping strategy
--
-- Examples:
--   @withConstructorMap config (addSuffix \"V2\")@
--   @withConstructorMap config [(''OldCon, ''NewCon)]@
--   @withConstructorMap config (\\s -> s ++ \"V2\")@
withConstructorMap :: ToConstructorMapping a => Config -> a -> Config
withConstructorMap cfg mapping = cfg { constructorMap = toConstructorMapping mapping }

-- | Set the field name normalization function
--
-- Example: @withNormalize config snakeToCamel@
withNormalize :: Config -> (String -> String) -> Config
withNormalize cfg f = cfg { normalize = f }

-- | Set the rule generators
--
-- Example: @withRuleGens config [datatypePrefixRules, customPrefixRules "foo" "bar"]@
withRuleGens :: Config -> [RuleGenContext -> String -> Maybe FieldRule] -> Config
withRuleGens cfg gens = cfg { ruleGens = gens }

--------------------------------------------------------------------------------
-- Field Rule Builders

-- | Create a base field rule for a destination field (use modifiers to customize)
--
-- Example: @field "balance"@
field :: Name -> FieldRule
field dstField = FieldRule dstField Nothing Nothing Nothing False Nothing

-- | Specify the source field name (modifier)
--
-- Example: @field ''balance & fromField ''balance_cents@  (real field)
-- Example: @field ''name & fromField #fullName@  (virtual field via OverloadedLabels)
fromField :: ToFieldRef a => a -> FieldRule -> FieldRule
fromField srcField rule = rule { src = Just (toFieldRef srcField) }

-- | Provide a default value when source is missing (modifier)
--
-- Example: @field "region" & withDefault [| "US" |]@
withDefault :: Q Exp -> FieldRule -> FieldRule
withDefault defVal rule = rule { default_ = Just defVal }

-- | Use a custom expression to compute the field (modifier)
--
-- Example: @field "name" & withExpr (\src dst -> [| $(varE src) ++ "!" |])@
withExpr :: (Name -> Name -> Q Exp) -> FieldRule -> FieldRule
withExpr customExpr rule = rule { expr = Just customExpr }

-- | Mark field as virtual (accessed via HasField) (modifier)
asVirtual :: FieldRule -> FieldRule
asVirtual rule = rule { virtual = True }

-- | Use a computed expression that combines multiple fields (modifier)
withComputed :: ([(String, Name)] -> Q Exp) -> FieldRule -> FieldRule
withComputed computeExpr rule = rule { computed = Just computeExpr }

--------------------------------------------------------------------------------
-- Pre-composed Field Rules

-- | Rename a field
rename :: ToFieldRef a => Name -> a -> FieldRule
rename dstField srcField = field dstField & fromField srcField

-- | Provide a default value for a destination field
defaultTo :: Name -> Q Exp -> FieldRule
defaultTo dstField defVal = field dstField & withDefault defVal

-- | Ignore a destination field
ignore :: Name -> FieldRule
ignore dstField = field dstField & withDefault [| error "ignored field" |]

-- | Map a field with a custom expression
mapField :: Name -> (Name -> Name -> Q Exp) -> FieldRule
mapField dstField customExpr = field dstField & withExpr customExpr

-- | Create a virtual field rule (uses HasField at runtime)
--
-- Example: @virtualField ''empName #fullName@ (using OverloadedLabels)
-- Example: @virtualField ''empName \"fullName\"@ (using String)
virtualField :: ToFieldRef a => Name -> a -> FieldRule
virtualField dstField srcField = field dstField & fromField srcField & asVirtual

-- | Create a computed field rule (compile-time)
computedField :: Name -> Q Exp -> FieldRule
computedField dstField expr =
  FieldRule dstField Nothing Nothing (Just $ \_ _ -> expr) False Nothing

-- | Monad for safely extracting field variables in 'combineFields'
newtype FieldGetter a = FieldGetter { runFieldGetter :: [(String, Name)] -> Either String (a, [String]) }

instance Functor FieldGetter where
  fmap f (FieldGetter g) = FieldGetter $ \ctx -> case g ctx of
    Left err -> Left err
    Right (a, used) -> Right (f a, used)

instance Applicative FieldGetter where
  pure x = FieldGetter $ \_ -> Right (x, [])
  FieldGetter ff <*> FieldGetter fa = FieldGetter $ \ctx -> case ff ctx of
    Left err -> Left err
    Right (f, used1) -> case fa ctx of
      Left err -> Left err
      Right (a, used2) -> Right (f a, used1 ++ used2)

instance Monad FieldGetter where
  FieldGetter m >>= f = FieldGetter $ \ctx -> case m ctx of
    Left err -> Left err
    Right (a, used1) -> case runFieldGetter (f a) ctx of
      Left err -> Left err
      Right (b, used2) -> Right (b, used1 ++ used2)

-- | Extract a field variable as a Template Haskell expression
get :: Name -> FieldGetter (Q Exp)
get fieldName = FieldGetter $ \fieldVarMap ->
  let fieldNameStr = nameBase fieldName
  in case lookup fieldNameStr fieldVarMap of
       Just var -> Right (varE var, [fieldNameStr])
       Nothing -> Left $ "Field '" ++ fieldNameStr ++ "' not found in source type"

-- | Extract a field variable as a Name
getName :: Name -> FieldGetter Name
getName fName = FieldGetter $ \fieldVarMap ->
  let fieldNameStr = nameBase fName
  in case lookup fieldNameStr fieldVarMap of
       Just var -> Right (var, [fieldNameStr])
       Nothing -> Left $ "Field '" ++ fieldNameStr ++ "' not found in source type"

-- | Combine multiple source fields into a destination field
combineFields :: Name -> FieldGetter (Q Exp) -> FieldRule
combineFields dstField getter =
  FieldRule dstField Nothing Nothing Nothing False (Just mkComputed)
  where
    mkComputed fieldVarMap = case runFieldGetter getter fieldVarMap of
      Left err -> fail $ "combineFields for '" ++ nameBase dstField ++ "': " ++ err
      Right (expr, _usedFields) -> expr

-- | Monad for accessing the source field in 'disassembleFields'
newtype DisassembleGetter a = DisassembleGetter { runDisassembleGetter :: Name -> a }

instance Functor DisassembleGetter where
  fmap f (DisassembleGetter g) = DisassembleGetter (f . g)

instance Applicative DisassembleGetter where
  pure x = DisassembleGetter (const x)
  DisassembleGetter f <*> DisassembleGetter x = DisassembleGetter (\n -> f n (x n))

instance Monad DisassembleGetter where
  DisassembleGetter f >>= k = DisassembleGetter $ \n ->
    runDisassembleGetter (k (f n)) n

-- | Get the source field as a Template Haskell expression
--
-- Example: @src <- getSource; pure [| words $src |]@
getSource :: DisassembleGetter (Q Exp)
getSource = DisassembleGetter varE

-- | Get the source field as a Name (for advanced use cases)
--
-- Example: @srcName <- getSourceName; pure [| $(varE srcName) |]@
getSourceName :: DisassembleGetter Name
getSourceName = DisassembleGetter id

-- | A field assignment for disassembled fields
data DisassembledField = DisassembledField Name (DisassembleGetter (Q Exp))

-- | Infix operator for creating disassembled field assignments
--
-- Example:
-- @
-- 'firstName .= do
--   src <- getSource
--   pure [| case words $src of (f:_) -> f; _ -> "" |]
-- @
(.=) :: Name -> DisassembleGetter (Q Exp) -> DisassembledField
(.=) = DisassembledField
infixr 0 .=

-- | Disassemble one source field into multiple destination fields
--
-- Example:
-- @
-- disassembleFields 'fullName
--   [ 'firstName .= do
--       src <- getSource
--       pure [| case words $src of (f:_) -> f; _ -> "" |]
--   , 'lastName .= do
--       src <- getSource
--       pure [| case words $src of (_:l:_) -> l; _ -> "" |]
--   ]
-- @
disassembleFields :: ToFieldRef a => a -> [DisassembledField] -> [FieldRule]
disassembleFields srcField assignments =
  [ FieldRule dstField (Just (toFieldRef srcField)) Nothing (Just mkExpr) False Nothing
  | DisassembledField dstField getter <- assignments
  , let mkExpr srcVarName _dstVarName = runDisassembleGetter getter srcVarName
  ]

--------------------------------------------------------------------------------
-- Field Rule Generators

-- | Strip a prefix from a string
stripPrefix :: String -> String -> Maybe String
stripPrefix [] ys = Just ys
stripPrefix _ [] = Nothing
stripPrefix (x:xs) (y:ys)
  | x == y    = stripPrefix xs ys
  | otherwise = Nothing

-- | Lowercase the first character
lowerFirst :: String -> String
lowerFirst [] = []
lowerFirst (c:cs) = toLower' c : cs
  where toLower' ch = if ch >= 'A' && ch <= 'Z' then toEnum (fromEnum ch + 32) else ch

-- | Generate field rules for datatypes following "prefix fields with datatype name" convention
datatypePrefixRules :: RuleGenContext -> String -> Maybe FieldRule
datatypePrefixRules RuleGenContext{..} dstField = do
  let dstTypeName = lowerFirst $ nameBase destinationTypeName
      srcTypeName = lowerFirst $ nameBase sourceTypeName
  suffix <- stripPrefix dstTypeName dstField
  let srcField = srcTypeName ++ suffix
  pure $ FieldRule (mkName dstField) (Just (RealField (mkName srcField))) Nothing Nothing False Nothing

-- | Generate field rules for datatypes following "prefix fields with constructor name" convention
constructorPrefixRules :: RuleGenContext -> String -> Maybe FieldRule
constructorPrefixRules RuleGenContext{..} dstField = do
  let dstConName = lowerFirst $ nameBase destinationConstructorName
      srcConName = lowerFirst $ nameBase sourceConstructorName
  suffix <- stripPrefix dstConName dstField
  let srcField = srcConName ++ suffix
  pure $ FieldRule (mkName dstField) (Just (RealField (mkName srcField))) Nothing Nothing False Nothing

-- | Generate field rules for custom prefix transformations
customPrefixRules :: String -> String -> RuleGenContext -> String -> Maybe FieldRule
customPrefixRules dstPrefix srcPrefix _ctx dstField = do
  suffix <- stripPrefix dstPrefix dstField
  let srcField = srcPrefix ++ suffix
  pure $ FieldRule (mkName dstField) (Just (RealField (mkName srcField))) Nothing Nothing False Nothing

-- | Strip constructor prefix from destination fields
stripConstructorPrefix :: String -> RuleGenContext -> String -> Maybe FieldRule
stripConstructorPrefix prefix _ctx dstField = do
  suffix <- stripPrefix prefix dstField
  pure $ FieldRule (mkName dstField) (Just (RealField (mkName suffix))) Nothing Nothing False Nothing

-- | Add constructor prefix to source field lookups
addConstructorPrefix :: String -> RuleGenContext -> String -> Maybe FieldRule
addConstructorPrefix prefix _ctx dstField =
  let srcField = prefix ++ dstField
  in Just $ FieldRule (mkName dstField) (Just (RealField (mkName srcField))) Nothing Nothing False Nothing

--------------------------------------------------------------------------------
-- Name Normalizers

-- | Convert snake_case to camelCase
snakeToCamel :: String -> String
snakeToCamel = go True
  where
    go _ [] = []
    go _ ('_':cs) = go True cs
    go True (c:cs) = toEnum (fromEnum c - 32) : go False cs
    go _    (c:cs) = c : go False cs

-- | Convert camelCase to snake_case
camelToSnake :: String -> String
camelToSnake = concatMap step
  where
    step c | c >= 'A' && c <= 'Z' = ['_', toEnum (fromEnum c + 32)]
           | otherwise            = [c]

--------------------------------------------------------------------------------
-- Constructor Information

-- | Represents a constructor's fields
data ConstructorInfo
  = RecordConstructor Name [(Name, Bang, Type)]
  | PositionalConstructor Name [(Bang, Type)]
  deriving (Show)

-- | Extract constructors from a type
expectConstructors :: Name -> Q [ConstructorInfo]
expectConstructors tyName = reify tyName >>= \case
  TyConI (DataD _ _ _ _ cons _) -> mapM extractCon cons
  TyConI (NewtypeD _ _ _ _ con _) -> (:[]) <$> extractCon con
  _ -> fail $ "Witch.TH: type " <> show tyName <> " must be a data type"
  where
    extractCon (RecC conName fields) = pure $ RecordConstructor conName fields
    extractCon (NormalC conName fields) = pure $ PositionalConstructor conName fields
    extractCon (InfixC t1 conName t2) = pure $ PositionalConstructor conName [t1, t2]
    extractCon _ = fail "Witch.TH: unsupported constructor type (GADTs, existentials not supported)"

-- | Get constructor name
getConstructorName :: ConstructorInfo -> Name
getConstructorName (RecordConstructor n _) = n
getConstructorName (PositionalConstructor n _) = n

-- | Build a map from normalized fieldName -> actual Name
mkFieldMap :: (String -> String) -> [(Name, Bang, Type)] -> [(String, Name)]
mkFieldMap norm fs = [ (norm (nameBase n), n) | (n,_,_) <- fs ]

--------------------------------------------------------------------------------
-- Positional (Structural) Derivation

deriveByPosition :: Name -> Name -> Q [Dec]
deriveByPosition = derivePositional False

deriveTryByPosition :: Name -> Name -> Q [Dec]
deriveTryByPosition = derivePositional True

derivePositional :: Bool -> Name -> Name -> Q [Dec]
derivePositional isTry srcName dstName = do
  srcCons <- getConstructorsSimple srcName
  dstCons <- getConstructorsSimple dstName

  when (length srcCons /= length dstCons) $
    fail $ "Witch.TH.ByPosition: constructor count mismatch: "
        <> show srcName <> " has " <> show (length srcCons) <> " constructors, "
        <> show dstName <> " has " <> show (length dstCons) <> " constructors"

  sVar <- newName "s"
  matches <- forM (zip srcCons dstCons) $ \(srcCon, dstCon) ->
    derivePositionalCase isTry srcCon dstCon

  let fromMethod = if isTry then 'W.tryFrom else 'W.from
      fromBody = caseE (varE sVar) (map pure matches)

  if isTry
    then instanceD (pure []) [t| TryFrom $(conT srcName) $(conT dstName) |]
           [ funD fromMethod [clause [varP sVar] (normalB fromBody) []] ] >>= pure . (:[])
    else instanceD (pure []) [t| From $(conT srcName) $(conT dstName) |]
           [ funD fromMethod [clause [varP sVar] (normalB fromBody) []] ] >>= pure . (:[])

type SimpleConstructorInfo = (Name, Int)

getConstructorsSimple :: Name -> Q [SimpleConstructorInfo]
getConstructorsSimple tyName = reify tyName >>= \case
  TyConI (DataD _ _ _ _ cons _) -> mapM extractConInfo cons
  TyConI (NewtypeD _ _ _ _ con _) -> (:[]) <$> extractConInfo con
  _ -> fail $ "Witch.TH: " <> show tyName <> " must be a data type"
  where
    extractConInfo (NormalC conName fields) = pure (conName, length fields)
    extractConInfo (RecC conName fields) = pure (conName, length fields)
    extractConInfo (InfixC _ conName _) = pure (conName, 2)
    extractConInfo _ = fail "Witch.TH: unsupported constructor type"

derivePositionalCase :: Bool -> SimpleConstructorInfo -> SimpleConstructorInfo -> Q Match
derivePositionalCase isTry (srcConName, srcArity) (dstConName, dstArity) = do
  when (srcArity /= dstArity) $
    fail $ "Witch.TH.ByPosition: arity mismatch: "
        <> show srcConName <> " has " <> show srcArity <> " fields, "
        <> show dstConName <> " has " <> show dstArity <> " fields"

  srcVars <- mapM (\i -> newName ("x" ++ show i)) [1..srcArity]
  let pat = ConP srcConName [] (map VarP srcVars)
      convertVar v = if isTry then [| W.tryFrom $(varE v) |] else [| W.from $(varE v) |]

  if isTry && srcArity > 0
    then do
      let applyAll = foldl (\acc v -> [| $acc <*> $(convertVar v) |])
                           [| pure $(conE dstConName) |]
                           srcVars
      match (pure pat) (normalB applyAll) []
    else do
      conversions <- mapM convertVar srcVars
      let bodyExp = foldl AppE (ConE dstConName) conversions
      match (pure pat) (normalB (pure bodyExp)) []

-- Positional derivation for parameterized types
deriveWithTypePositional :: Bool -> Q Type -> Q Type -> Q [Dec]
deriveWithTypePositional isTry srcTypeQ dstTypeQ = do
  srcType <- srcTypeQ
  dstType <- dstTypeQ

  let getBaseName :: Type -> Name
      getBaseName (ConT name) = name
      getBaseName (AppT t _) = getBaseName t
      getBaseName t = error $ "deriveWithType: unsupported type structure: " ++ show t

      srcName = getBaseName srcType
      dstName = getBaseName dstType

  srcCons <- getConstructorsSimple srcName
  dstCons <- getConstructorsSimple dstName

  when (length srcCons /= length dstCons) $
    fail $ "Witch.TH.ByPosition: constructor count mismatch"

  sVar <- newName "s"
  matches <- forM (zip srcCons dstCons) $ \(srcCon, dstCon) ->
    derivePositionalCase isTry srcCon dstCon

  let fromMethod = if isTry then 'W.tryFrom else 'W.from
      fromBody = caseE (varE sVar) (map pure matches)

  if isTry
    then instanceD (pure []) [t| TryFrom $srcTypeQ $dstTypeQ |]
           [ funD fromMethod [clause [varP sVar] (normalB fromBody) []] ] >>= pure . (:[])
    else instanceD (pure []) [t| From $srcTypeQ $dstTypeQ |]
           [ funD fromMethod [clause [varP sVar] (normalB fromBody) []] ] >>= pure . (:[])

--------------------------------------------------------------------------------
-- Name-Based (Semantic) Derivation

deriveByName :: Config -> Name -> Name -> Q [Dec]
deriveByName config srcName dstName = do
  srcCons <- expectConstructors srcName
  dstCons <- expectConstructors dstName

  case (srcCons, dstCons) of
    ([src], [dst]) -> deriveSingleConstructor config srcName dstName src dst
    _ -> deriveMultiConstructor config srcName dstName srcCons dstCons

-- Name-based derivation for parameterized types
deriveWithTypeByName :: Config -> Q Type -> Q Type -> Q [Dec]
deriveWithTypeByName config srcTypeQ dstTypeQ = do
  srcType <- srcTypeQ
  dstType <- dstTypeQ

  let getBaseName :: Type -> Name
      getBaseName (ConT name) = name
      getBaseName (AppT t _) = getBaseName t
      getBaseName t = error $ "deriveWithType: unsupported type structure: " ++ show t

      srcName = getBaseName srcType
      dstName = getBaseName dstType

  srcCons <- expectConstructors srcName
  dstCons <- expectConstructors dstName

  case (srcCons, dstCons) of
    ([src], [dst]) -> deriveSingleConstructorWithType config srcTypeQ dstTypeQ srcName dstName src dst
    _ -> deriveMultiConstructorWithType config srcTypeQ dstTypeQ srcName dstName srcCons dstCons

deriveTryByName :: Config -> Name -> Name -> Q [Dec]
deriveTryByName _config srcName dstName = do
  -- Simple implementation - could be enhanced to use config
  srcCons <- expectConstructors srcName
  dstCons <- expectConstructors dstName

  case (srcCons, dstCons) of
    ([RecordConstructor _srcCon srcFields], [RecordConstructor dstCon dstFields]) -> do
      let srcMap = [ (nameBase n, n) | (n,_,_) <- srcFields ]
          findSrc nm = lookup nm srcMap

      sVar <- newName "s"
      fieldApps <- mapM (\(dstFName,_,_) -> do
          let key = nameBase dstFName
          case findSrc key of
            Just srcNm -> [| V (W.tryInto ($(varE srcNm) $(varE sVar)) :: Either String _) |]
            Nothing -> [| V (Left ["missing source field for '" <> key <> "'"]) |]
        ) dstFields

      let buildRec = do
            xs <- mapM (\_ -> newName "x") dstFields
            let pairs = zipWith (\(n,_,_) x -> (n, VarE x)) dstFields xs
            pure $ LamE (map VarP xs) (RecConE dstCon pairs)

      recBuilder <- buildRec
      let bodyExp = foldl (\acc v -> [| $(acc) <*> $(v) |]) [| pure $(pure recBuilder) |] (fmap pure fieldApps)
          body = normalB [| vToEither $ $(bodyExp) |]

      instanceD (pure []) [t| W.TryFrom $(conT srcName) $(conT dstName) |]
        [ funD 'W.tryFrom [clause [varP sVar] body []] ] >>= pure . (:[])

    _ -> fail "Witch.TH: TryFrom with ByName only supports single-constructor records for now"

-- Validation applicative for TryFrom
newtype V a = V { unV :: Either [String] a }

instance Functor V where
  fmap f (V e) = V (fmap f e)

instance Applicative V where
  pure = V . Right
  V (Left e1) <*> V (Left e2) = V (Left (e1 <> e2))
  V (Left e)  <*> _           = V (Left e)
  _           <*> V (Left e)  = V (Left e)
  V (Right f) <*> V (Right x) = V (Right (f x))

vToEither :: V a -> Either [String] a
vToEither = unV

deriveSingleConstructor :: Config -> Name -> Name -> ConstructorInfo -> ConstructorInfo -> Q [Dec]
deriveSingleConstructor config srcName dstName srcCon dstCon =
  case (srcCon, dstCon) of
    (RecordConstructor srcConName srcFields, RecordConstructor dstConName dstFields) ->
      deriveSingleRecordConstructor config srcName dstName srcConName srcFields dstConName dstFields

    (PositionalConstructor srcConName srcFields, PositionalConstructor dstConName dstFields) ->
      deriveSimplePositional srcName dstName srcConName srcFields dstConName dstFields

    _ -> fail "Witch.TH: cannot mix record and positional constructors"

deriveSingleConstructorWithType :: Config -> Q Type -> Q Type -> Name -> Name -> ConstructorInfo -> ConstructorInfo -> Q [Dec]
deriveSingleConstructorWithType config srcTypeQ dstTypeQ srcName dstName srcCon dstCon =
  case (srcCon, dstCon) of
    (RecordConstructor srcConName srcFields, RecordConstructor dstConName dstFields) ->
      deriveSingleRecordConstructorWithType config srcTypeQ dstTypeQ srcName dstName srcConName srcFields dstConName dstFields

    (PositionalConstructor srcConName srcFields, PositionalConstructor dstConName dstFields) ->
      deriveSimplePositionalWithType srcTypeQ dstTypeQ srcConName srcFields dstConName dstFields

    _ -> fail "Witch.TH: cannot mix record and positional constructors"

deriveSimplePositional :: Name -> Name -> Name -> [(Bang, Type)] -> Name -> [(Bang, Type)] -> Q [Dec]
deriveSimplePositional srcName dstName srcCon srcFields dstCon dstFields = do
  when (length srcFields /= length dstFields) $
    fail $ "Witch.TH: arity mismatch"

  srcVars <- mapM (\i -> newName ("x" ++ show i)) [1..length srcFields]
  let srcPat = ConP srcCon [] (map VarP srcVars)
      dstExp = foldl AppE (ConE dstCon) [AppE (VarE 'W.into) (VarE v) | v <- srcVars]

  instanceD (pure []) [t| W.From $(conT srcName) $(conT dstName) |]
    [ funD 'W.from [clause [pure srcPat] (normalB (pure dstExp)) []] ] >>= pure . (:[])

deriveSimplePositionalWithType :: Q Type -> Q Type -> Name -> [(Bang, Type)] -> Name -> [(Bang, Type)] -> Q [Dec]
deriveSimplePositionalWithType srcTypeQ dstTypeQ srcCon srcFields dstCon dstFields = do
  when (length srcFields /= length dstFields) $
    fail $ "Witch.TH: arity mismatch"

  srcVars <- mapM (\i -> newName ("x" ++ show i)) [1..length srcFields]
  let srcPat = ConP srcCon [] (map VarP srcVars)
      dstExp = foldl AppE (ConE dstCon) [AppE (VarE 'W.into) (VarE v) | v <- srcVars]

  instanceD (pure []) [t| W.From $srcTypeQ $dstTypeQ |]
    [ funD 'W.from [clause [pure srcPat] (normalB (pure dstExp)) []] ] >>= pure . (:[])

--------------------------------------------------------------------------------
-- Internal: Reusable Field Rule Resolution
--
-- These functions are used by both the main derive functions and Warlock.Tweak

-- | Resolve field rules and build a complete From instance for a record constructor.
-- This function must be atomic because TH newName generates unique IDs that can't be
-- reliably shared across function boundaries.
resolveFieldRulesAndBuildInstance
  :: Config
  -> Name  -- ^ Source type name
  -> Name  -- ^ Source constructor name
  -> [(Name, Bang, Type)]  -- ^ Source fields
  -> Name  -- ^ Destination type name
  -> Name  -- ^ Destination constructor name
  -> [(Name, Bang, Type)]  -- ^ Destination fields
  -> Q Dec  -- ^ Complete From instance
resolveFieldRulesAndBuildInstance AutoMapConfig{..} srcName srcCon srcFields dstName dstCon dstFields = do
  let srcMap = mkFieldMap normalize srcFields
      findSrc nm = lookup nm srcMap
      staticRulesByDst = [(normalize (nameBase (dst r)), r) | r <- staticRules]
      ruleGenCtx = RuleGenContext srcName srcCon dstName dstCon normalize
      tryGen [] _ = Nothing
      tryGen (g:gs) dstKey = g ruleGenCtx dstKey <|> tryGen gs dstKey

  srcVal <- newName "_srcVal"
  fieldVars <- mapM (\(fName, _, _) -> do
      vName <- newName ("v_" ++ nameBase fName)
      pure (fName, vName)) srcFields

  let fieldVarMap = [(nameBase fName, vName) | (fName, vName) <- fieldVars]

  assigns <- forM dstFields $ \(dstFName, _, _) -> do
    let dstKey  = normalize (nameBase dstFName)
        mbRule  = tryGen ruleGens dstKey <|> lookup dstKey staticRulesByDst
    e <- case mbRule of
      Just r | Just f <- computed r -> f fieldVarMap
             | Just f <- expr r -> do
                 let srcKey = case src r of
                       Just s -> normalize (fieldRefToString s)
                       Nothing -> dstKey
                 case lookup srcKey fieldVarMap of
                   Just srcVarName -> f srcVarName dstFName
                   Nothing -> fail $ "Witch.TH: expr references unknown source field '" <> srcKey <> "'"
             | virtual r -> do
                 let srcFieldName = maybe dstKey fieldRefToString (src r)
                     getFieldTyApp = AppTypeE (VarE 'getField) (LitT (StrTyLit srcFieldName))
                     getFieldApp = AppE getFieldTyApp (VarE srcVal)
                 [| W.into $(pure getFieldApp) |]
             | otherwise -> do
                 let srcKey = maybe dstKey (normalize . fieldRefToString) (src r)
                 case findSrc srcKey of
                   Just srcFName ->
                     case lookup (nameBase srcFName) fieldVarMap of
                       Just vName -> [| W.into $(varE vName) |]
                       Nothing -> fail $ "Internal error: field not in pattern"
                   Nothing -> case default_ r of
                     Just d  -> d
                     Nothing -> fail $ "Witch.TH: no source field for '" <> nameBase dstFName <> "'"
      Nothing ->
        case findSrc dstKey of
          Just srcFName ->
            case lookup (nameBase srcFName) fieldVarMap of
              Just vName -> [| W.into $(varE vName) |]
              Nothing -> fail $ "Internal error: field not in pattern"
          Nothing -> fail $ "Witch.TH: no source for destination field '" <> nameBase dstFName <> "'"
    pure (dstFName, e)

  -- Build the instance using the same variables
  let pat = AsP srcVal (RecP srcCon [(fName, VarP vName) | (fName, vName) <- fieldVars])
      bodyExp = RecConE dstCon assigns

  instanceD (pure []) [t| W.From $(conT srcName) $(conT dstName) |]
    [ funD 'W.from [clause [pure pat] (normalB (pure bodyExp)) []] ]

-- | Version for parameterized types
resolveFieldRulesAndBuildInstanceWithType
  :: Config
  -> Q Type  -- ^ Source type
  -> Name  -- ^ Source type name (for context)
  -> Name  -- ^ Source constructor name
  -> [(Name, Bang, Type)]  -- ^ Source fields
  -> Q Type  -- ^ Destination type
  -> Name  -- ^ Destination type name (for context)
  -> Name  -- ^ Destination constructor name
  -> [(Name, Bang, Type)]  -- ^ Destination fields
  -> Q Dec
resolveFieldRulesAndBuildInstanceWithType AutoMapConfig{..} srcTypeQ srcName srcCon srcFields dstTypeQ dstName dstCon dstFields = do
  let srcMap = mkFieldMap normalize srcFields
      findSrc nm = lookup nm srcMap
      staticRulesByDst = [(normalize (nameBase (dst r)), r) | r <- staticRules]
      ruleGenCtx = RuleGenContext srcName srcCon dstName dstCon normalize
      tryGen [] _ = Nothing
      tryGen (g:gs) dstKey = g ruleGenCtx dstKey <|> tryGen gs dstKey

  srcVal <- newName "_srcVal"
  fieldVars <- mapM (\(fName, _, _) -> do
      vName <- newName ("v_" ++ nameBase fName)
      pure (fName, vName)) srcFields

  let fieldVarMap = [(nameBase fName, vName) | (fName, vName) <- fieldVars]

  assigns <- forM dstFields $ \(dstFName, _, _) -> do
    let dstKey  = normalize (nameBase dstFName)
        mbRule  = tryGen ruleGens dstKey <|> lookup dstKey staticRulesByDst
    e <- case mbRule of
      Just r | Just f <- computed r -> f fieldVarMap
             | Just f <- expr r -> do
                 let srcKey = case src r of
                       Just s -> normalize (fieldRefToString s)
                       Nothing -> dstKey
                 case lookup srcKey fieldVarMap of
                   Just srcVarName -> f srcVarName dstFName
                   Nothing -> fail $ "Witch.TH: expr references unknown source field '" <> srcKey <> "'"
             | virtual r -> do
                 let srcFieldName = maybe dstKey fieldRefToString (src r)
                     getFieldTyApp = AppTypeE (VarE 'getField) (LitT (StrTyLit srcFieldName))
                     getFieldApp = AppE getFieldTyApp (VarE srcVal)
                 [| W.into $(pure getFieldApp) |]
             | otherwise -> do
                 let srcKey = maybe dstKey (normalize . fieldRefToString) (src r)
                 case findSrc srcKey of
                   Just srcFName ->
                     case lookup (nameBase srcFName) fieldVarMap of
                       Just vName -> [| W.into $(varE vName) |]
                       Nothing -> fail $ "Internal error: field not in pattern"
                   Nothing -> case default_ r of
                     Just d  -> d
                     Nothing -> fail $ "Witch.TH: no source field for '" <> nameBase dstFName <> "'"
      Nothing ->
        case findSrc dstKey of
          Just srcFName ->
            case lookup (nameBase srcFName) fieldVarMap of
              Just vName -> [| W.into $(varE vName) |]
              Nothing -> fail $ "Internal error: field not in pattern"
          Nothing -> fail $ "Witch.TH: no source for destination field '" <> nameBase dstFName <> "'"
    pure (dstFName, e)

  let pat = AsP srcVal (RecP srcCon [(fName, VarP vName) | (fName, vName) <- fieldVars])
      bodyExp = RecConE dstCon assigns

  instanceD (pure []) [t| W.From $srcTypeQ $dstTypeQ |]
    [ funD 'W.from [clause [pure pat] (normalB (pure bodyExp)) []] ]

-- | Helper for building a match case in multi-constructor derivations
resolveFieldRulesForMatch
  :: Config
  -> Name  -- ^ Source type name
  -> Name  -- ^ Source constructor name
  -> [(Name, Bang, Type)]  -- ^ Source fields
  -> Name  -- ^ Destination type name
  -> Name  -- ^ Destination constructor name
  -> [(Name, Bang, Type)]  -- ^ Destination fields
  -> Q Match
resolveFieldRulesForMatch AutoMapConfig{..} srcName srcCon srcFields dstName dstCon dstFields = do
  let srcMap = mkFieldMap normalize srcFields
      findSrc nm = lookup nm srcMap
      staticRulesByDst = [(normalize (nameBase (dst r)), r) | r <- staticRules]
      ruleGenCtx = RuleGenContext srcName srcCon dstName dstCon normalize
      tryGen [] _ = Nothing
      tryGen (g:gs) dstKey = g ruleGenCtx dstKey <|> tryGen gs dstKey

  srcVal <- newName "_srcVal"
  fieldVars <- mapM (\(fName, _, _) -> do
      vName <- newName ("v_" ++ nameBase fName)
      pure (fName, vName)) srcFields

  let fieldVarMap = [(nameBase fName, vName) | (fName, vName) <- fieldVars]

  assigns <- forM dstFields $ \(dstFName, _, _) -> do
    let dstKey  = normalize (nameBase dstFName)
        mbRule  = tryGen ruleGens dstKey <|> lookup dstKey staticRulesByDst
    e <- case mbRule of
      Just r | Just f <- computed r -> f fieldVarMap
             | Just f <- expr r -> do
                 let srcKey = case src r of
                       Just s -> normalize (fieldRefToString s)
                       Nothing -> dstKey
                 case lookup srcKey fieldVarMap of
                   Just srcVarName -> f srcVarName dstFName
                   Nothing -> fail $ "Witch.TH: expr references unknown source field '" <> srcKey <> "'"
             | virtual r -> do
                 let srcFieldName = maybe dstKey fieldRefToString (src r)
                     getFieldTyApp = AppTypeE (VarE 'getField) (LitT (StrTyLit srcFieldName))
                     getFieldApp = AppE getFieldTyApp (VarE srcVal)
                 [| W.into $(pure getFieldApp) |]
             | otherwise -> do
                 let srcKey = maybe dstKey (normalize . fieldRefToString) (src r)
                 case findSrc srcKey of
                   Just srcFName ->
                     case lookup (nameBase srcFName) fieldVarMap of
                       Just vName -> [| W.into $(varE vName) |]
                       Nothing -> fail $ "Internal error: field not in pattern"
                   Nothing -> case default_ r of
                     Just d  -> d
                     Nothing -> fail $ "Witch.TH: no source field for '" <> nameBase dstFName <> "'"
      Nothing ->
        case findSrc dstKey of
          Just srcFName ->
            case lookup (nameBase srcFName) fieldVarMap of
              Just vName -> [| W.into $(varE vName) |]
              Nothing -> fail $ "Internal error: field not in pattern"
          Nothing -> fail $ "Witch.TH: no source for destination field '" <> nameBase dstFName <> "'"
    pure (dstFName, e)

  let pat = AsP srcVal (RecP srcCon [(fName, VarP vName) | (fName, vName) <- fieldVars])
      bodyExp = RecConE dstCon assigns

  match (pure pat) (normalB (pure bodyExp)) []

deriveSingleRecordConstructor :: Config -> Name -> Name -> Name -> [(Name, Bang, Type)] -> Name -> [(Name, Bang, Type)] -> Q [Dec]
deriveSingleRecordConstructor config srcName dstName srcCon srcFields dstCon dstFields = do
  inst <- resolveFieldRulesAndBuildInstance config srcName srcCon srcFields dstName dstCon dstFields
  pure [inst]

deriveSingleRecordConstructorWithType :: Config -> Q Type -> Q Type -> Name -> Name -> Name -> [(Name, Bang, Type)] -> Name -> [(Name, Bang, Type)] -> Q [Dec]
deriveSingleRecordConstructorWithType config srcTypeQ dstTypeQ srcName dstName srcCon srcFields dstCon dstFields = do
  inst <- resolveFieldRulesAndBuildInstanceWithType config srcTypeQ srcName srcCon srcFields dstTypeQ dstName dstCon dstFields
  pure [inst]

deriveMultiConstructor :: Config -> Name -> Name -> [ConstructorInfo] -> [ConstructorInfo] -> Q [Dec]
deriveMultiConstructor config@AutoMapConfig{..} srcName dstName srcCons dstCons = do
  sVar <- newName "s"

  matches <- case (srcCons, dstCons) of
    ([srcCon], [dstCon]) -> do
      m <- deriveConstructorMatch config srcName dstName srcCon dstCon
      return [m]

    _ -> forM srcCons $ \srcCon -> do
      let srcConName = getConstructorName srcCon
          srcTransformed = applyConstructorMapping constructorMap (nameBase srcConName)
          maybeDstCon = find (\c -> map toLower (nameBase (getConstructorName c)) == map toLower srcTransformed) dstCons
      case maybeDstCon of
        Just dstCon -> deriveConstructorMatch config srcName dstName srcCon dstCon
        Nothing -> fail $ "Witch.TH: no matching destination constructor for " <> show srcConName

  let body = caseE (varE sVar) (map pure matches)

  instanceD (pure []) [t| W.From $(conT srcName) $(conT dstName) |]
    [ funD 'W.from [clause [varP sVar] (normalB body) []] ] >>= pure . (:[])

deriveMultiConstructorWithType :: Config -> Q Type -> Q Type -> Name -> Name -> [ConstructorInfo] -> [ConstructorInfo] -> Q [Dec]
deriveMultiConstructorWithType config@AutoMapConfig{..} srcTypeQ dstTypeQ srcName dstName srcCons dstCons = do
  sVar <- newName "s"

  matches <- case (srcCons, dstCons) of
    ([srcCon], [dstCon]) -> do
      m <- deriveConstructorMatch config srcName dstName srcCon dstCon
      return [m]

    _ -> forM srcCons $ \srcCon -> do
      let srcConName = getConstructorName srcCon
          srcTransformed = applyConstructorMapping constructorMap (nameBase srcConName)
          maybeDstCon = find (\c -> map toLower (nameBase (getConstructorName c)) == map toLower srcTransformed) dstCons
      case maybeDstCon of
        Just dstCon -> deriveConstructorMatch config srcName dstName srcCon dstCon
        Nothing -> fail $ "Witch.TH: no matching destination constructor for " <> show srcConName

  let body = caseE (varE sVar) (map pure matches)

  instanceD (pure []) [t| W.From $srcTypeQ $dstTypeQ |]
    [ funD 'W.from [clause [varP sVar] (normalB body) []] ] >>= pure . (:[])

deriveConstructorMatch :: Config -> Name -> Name -> ConstructorInfo -> ConstructorInfo -> Q Match
deriveConstructorMatch config srcName dstName srcCon dstCon =
  case (srcCon, dstCon) of
    (RecordConstructor srcConName srcFields, RecordConstructor dstConName dstFields) ->
      deriveRecordMatch config srcName dstName srcConName srcFields dstConName dstFields

    (PositionalConstructor srcConName srcFields, PositionalConstructor dstConName dstFields) ->
      derivePositionalMatch srcConName srcFields dstConName dstFields

    _ -> fail "Witch.TH: cannot mix record and positional constructors"

derivePositionalMatch :: Name -> [(Bang, Type)] -> Name -> [(Bang, Type)] -> Q Match
derivePositionalMatch srcConName srcFields dstConName dstFields = do
  when (length srcFields /= length dstFields) $
    fail $ "Witch.TH: arity mismatch in " <> show srcConName

  srcVars <- mapM (\i -> newName ("x" ++ show i)) [1..length srcFields]
  let pat = ConP srcConName [] (map VarP srcVars)
      bodyExp = foldl AppE (ConE dstConName) [AppE (VarE 'W.into) (VarE v) | v <- srcVars]

  match (pure pat) (normalB (pure bodyExp)) []

deriveRecordMatch :: Config -> Name -> Name -> Name -> [(Name, Bang, Type)] -> Name -> [(Name, Bang, Type)] -> Q Match
deriveRecordMatch config srcName dstName srcCon srcFields dstCon dstFields =
  resolveFieldRulesForMatch config srcName srcCon srcFields dstName dstCon dstFields