packages feed

warlock (empty) → 0.1.0.0

raw patch · 23 files changed

+6819/−0 lines, 23 filesdep +barbiesdep +basedep +containerssetup-changed

Dependencies added: barbies, base, containers, hspec, hspec-discover, template-haskell, text, warlock, witch

Files

+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog for `autowitch`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## Unreleased++## 0.1.0.0 - YYYY-MM-DD
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright 2025 Author name here++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1.  Redistributions of source code must retain the above copyright notice, this+    list of conditions and the following disclaimer.++2.  Redistributions in binary form must reproduce the above copyright notice,+    this list of conditions and the following disclaimer in the documentation+    and/or other materials provided with the distribution.++3.  Neither the name of the copyright holder nor the names of its contributors+    may be used to endorse or promote products derived from this software+    without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,792 @@+# Warlock++Automatic type-safe mapping between Haskell data types using Template Haskell and the `witch` library.++**📖 New to Warlock? Start with the [comprehensive tutorial](src/Warlock/Tutorial.hs)!**++## Features++- **Compile-time type safety**: Field names and constructor names checked at compile-time using TH `Name`+- **Two matching strategies**:+  - `ByPosition`: Structural mapping by declaration order+  - `ByName`: Semantic mapping with configurable rules+- **Record and positional constructors**: Support for both named fields and positional arguments+- **Multi-constructor ADTs**: Full support for sum types with multiple constructors+- **Flexible field rules**:+  - Compile-time checked field names (`'fieldName`)+  - Virtual fields via `HasField` with `#fieldName` syntax+  - Computed fields combining multiple sources+  - Disassemble fields splitting one into many+- **Type-safe constructor mapping**:+  - Explicit mappings: `[('OldCon, 'NewCon)]`+  - Helper functions: `addSuffix`, `stripSuffix`, `replaceSuffix`+  - Custom transformations: `Transform (++ "V2")`+- **Type-safe conversions**: Uses `witch`'s `From`/`TryFrom` for nested type conversions+- **Field evolution**: Handle API versioning with added/removed fields+- **Common conventions built-in**: `datatypePrefixConfig`, `constructorPrefixConfig`, etc.++## Quick Start++### Simple Record Mapping++```haskell+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}++import Warlock+import qualified Witch as W++data Person = Person { name :: String, age :: Int }+data Employee = Employee { name :: String, age :: Int }++-- Derive mapping: fields matched by name+deriveAutomap (ByName defaultConfig) ''Person ''Employee++-- Use it+let person = Person "Alice" 30+let employee = W.from person :: Employee+```++### Handling Naming Conventions++```haskell+data Person = Person+  { personName :: String+  , personAge :: Int+  }++data Employee = Employee+  { employeeName :: String+  , employeeAge :: Int+  }++-- Automatically handles type-prefixed fields+deriveAutomap (ByName datatypePrefixConfig) ''Person ''Employee+```++### Positional Matching++```haskell+data Point2D = Point2D Int Int+data Vector2D = Vector2D Int Int++-- Maps by position: 1st → 1st, 2nd → 2nd+deriveAutomap ByPosition ''Point2D ''Vector2D+```++### Multi-Constructor ADTs with Field Evolution++```haskell+data PaymentV1+  = CardPaymentV1 { cardNumber :: String, expiry :: String }+  | CashPaymentV1 { amount :: Double }++data PaymentV2+  = CardPaymentV2+      { cardNumber :: String+      , expiry :: String+      , cvv :: String  -- New field!+      }+  | CashPaymentV2 { amount :: Double, currency :: String }++-- Handle field evolution with defaults and constructor mapping+deriveAutomap+  (ByName $+    defaultConfig+    `withConstructorMap` replaceSuffix "V1" "V2"+    `withDefaults`+      [ ('cvv, [| "000" |])+      , ('currency, [| "USD" |])+      ])+  ''PaymentV1+  ''PaymentV2+```++## Field References: Compile-Time Safety++Warlock uses Template Haskell `Name` for compile-time checked field references:++```haskell+-- ✅ Compile-time checked - typos caught at compile time!+rename 'newBalance 'oldBalance+defaultTo 'region [| "US" |]++-- ✅ Virtual fields use #fieldName syntax (OverloadedLabels)+virtualField 'empName #fullName++-- ✅ Or use strings for virtual fields+virtualField 'empName "fullName"+```++**Benefits:**+- Typos in field names → compile errors+- Refactoring tools can track field renames+- IDE autocomplete works+- No runtime surprises++## Field Rules++### Composable Builder Pattern++```haskell+{-# LANGUAGE OverloadedLabels #-}++import Warlock+import Data.Function ((&))++-- Build rules step-by-step+field 'balance & fromField 'balance_cents+field 'region & withDefault [| "US" |]+field 'empName & fromField #fullName & asVirtual  -- Virtual field!+field 'newBalance & fromField 'oldBalance & withDefault [| 0 |]+```++### Pre-composed Helpers++```haskell+-- For convenience+rename 'balance 'balance_cents           -- Real fields (TH Name)+defaultTo 'region [| "US" |]+virtualField 'empName #fullName          -- Virtual field (OverloadedLabels)+virtualField 'empName "fullName"         -- Or String+ignore 'internalField+mapField 'name (\src dst -> [| customTransform |])+```++### Available Modifiers++- `fromField` - Specify source field (accepts `'name` or `#name`)+- `withDefault` - Provide default value when source is missing+- `withExpr` - Custom TH expression+- `asVirtual` - Use `HasField` to access virtual/computed fields+- `withComputed` - Combine multiple source fields++## Field Manipulation Patterns++### Virtual Fields (HasField)++Use runtime `HasField` instances to access computed properties:++```haskell+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedLabels #-}+import GHC.Records (HasField(..))++data Person = Person+  { firstName :: String+  , lastName :: String+  , age :: Int+  }++-- Define virtual field at runtime+instance HasField "fullName" Person String where+  getField (Person first last _) = first ++ " " ++ last++data Employee = Employee+  { empName :: String+  , empAge :: Int+  }++-- Map from virtual field using #syntax+deriveAutomap+  (ByName $ defaultConfig+    `withRules`+      [ virtualField 'empName #fullName+      , rename 'empAge 'age+      ])+  ''Person+  ''Employee+```++**Characteristics:**+- **Source:** 1 field via `HasField` instance+- **When:** Runtime (via `getField`)+- **Syntax:** `#fieldName` (OverloadedLabels) or `"fieldName"`++### Computed Fields (combineFields)++Combine multiple source fields at compile-time:++```haskell+deriveAutomap+  (ByName $ defaultConfig+    `withRules`+      [ combineFields 'fullName $ do+          firstName <- get 'firstName+          lastName <- get 'lastName+          pure [| $firstName ++ " " ++ $lastName |]+      , rename 'age 'personAge+      ])+  ''PersonV1+  ''PersonV2+```++**Monadic FieldGetter interface:**+- `get 'fieldName` - Extract field as TH expression (Q Exp)+- `getName 'fieldName` - Extract field's Name (advanced)+- Compile-time error if field doesn't exist+- Type-safe, no manual `varE` needed++**Characteristics:**+- **Source:** N fields from source record+- **When:** Compile-time (Template Haskell)+- **Syntax:** Monadic do-notation with `get`++### Disassembled Fields (disassembleFields)++Split one source field into multiple destination fields:++```haskell+deriveAutomap+  (ByName $ defaultConfig+    `withRules`+      ( disassembleFields 'fullName+          [ 'firstName .= do+              src <- getSource+              pure [| case words $src of+                        (f:_) -> f+                        _ -> ""+                   |]+          , 'lastName .= do+              src <- getSource+              pure [| case words $src of+                        (_:l:_) -> l+                        _ -> ""+                   |]+          ]+      +++      [ rename 'age 'personAge ]+      ))+  ''PersonV1+  ''PersonV2+```++**Monadic DisassembleGetter interface:**+- `getSource` - Get source field as TH expression (Q Exp)+- `getSourceName` - Get source field as Name (advanced)+- Clean syntax, no manual `varE` needed++**Characteristics:**+- **Source:** 1 field from source record+- **Target:** N fields in destination record+- **When:** Compile-time (Template Haskell)+- **Syntax:** Monadic do-notation with `getSource`++## Constructor Mapping++Map constructor names with compile-time safety:++### Direct Mapping (Compile-time Checked!)++```haskell+-- ✅ Constructor names checked at compile time+defaultConfig `withConstructorMap`+  [ ('CircleShape, 'CircleInfo)+  , ('RectangleShape, 'RectangleInfo)+  ]+```++### Helper Functions++```haskell+-- Add suffix: Foo → FooV2+defaultConfig `withConstructorMap` addSuffix "V2"++-- Strip suffix: FooV2 → Foo+defaultConfig `withConstructorMap` stripSuffix "V2"++-- Replace suffix: FooV1 → FooV2+defaultConfig `withConstructorMap` replaceSuffix "V1" "V2"+```++### Custom Transformations++```haskell+-- Wrap in Transform for custom logic+defaultConfig `withConstructorMap` Transform (\s -> s ++ "V2")++-- Or pass function directly+defaultConfig `withConstructorMap` (++ "V2")+```++## Configuration Presets++Common configurations for typical Haskell code:++```haskell+-- Most common: datatype-prefixed fields (personName ↔ employeeName)+deriveAutomap (ByName datatypePrefixConfig) ''Person ''Employee++-- Constructor-prefixed fields+deriveAutomap (ByName constructorPrefixConfig) ''Person ''Employee++-- Try both conventions (datatype first, then constructor)+deriveAutomap (ByName conventionalConfig) ''Person ''Employee++-- snake_case ↔ camelCase (e.g., for JSON/DB interop)+deriveAutomap (ByName snakeToCamelConfig) ''DbRecord ''HaskellRecord+deriveAutomap (ByName camelToSnakeConfig) ''HaskellRecord ''DbRecord++-- Combine configs with helpers:+deriveAutomap+  (ByName $+    datatypePrefixConfig+    `withDefaults` [('newField, [| defaultVal |])]+    `withConstructorMap` addSuffix "V2")+  ''OldType+  ''NewType+```++## Configuration Helpers++- `withDefaults :: Config -> [(Name, Q Exp)] -> Config` - Add default values+- `withRenames :: Config -> [(Name, FieldRef)] -> Config` - Add field renames+- `withRules :: Config -> [FieldRule] -> Config` - Add custom rules+- `withConstructorMap :: Config -> ConstructorMapping -> Config` - Map constructor names+- `withNormalize :: Config -> (String -> String) -> Config` - Set normalization function+- `withRuleGens :: Config -> [RuleGenContext -> String -> Maybe FieldRule] -> Config` - Add rule generators++## Built-in Rule Generators++- `datatypePrefixRules` - Handles type-prefixed fields (personName → employeeName)+- `constructorPrefixRules` - Handles constructor-prefixed fields+- `customPrefixRules` - Specify custom prefixes manually+- `stripConstructorPrefix` - Remove constructor prefixes+- `addConstructorPrefix` - Add constructor prefixes++## ADT Support++- ✅ Single-constructor records+- ✅ Multi-constructor records (sum types)+- ✅ Positional constructors+- ✅ Mixed ADTs (multiple constructors)+- ✅ Field addition with defaults+- ✅ Field removal (silently ignored)+- ✅ Constructor matching by name (case-insensitive)+- ✅ Compile-time constructor name checking with `DirectMapping`+- ⚠️ Cannot mix record and positional in same constructor pair+- ⚠️ Constructor names must be unique per module (use qualified imports if needed)++## Parameterized Types++For types with type parameters, use `deriveWithType`:++```haskell+data Container a = Container { value :: a }+data IntContainer = IntContainer { value :: Int }++-- Specify concrete type application+deriveWithType (ByName defaultConfig) [t| Container Int |] [t| IntContainer |]+```++## API Summary++### Main Derivation Functions++- `derive :: MatchStrategy -> Name -> Name -> Q [Dec]`+- `deriveWithType :: MatchStrategy -> Q Type -> Q Type -> Q [Dec]`+- `deriveTry :: MatchStrategy -> Name -> Name -> Q [Dec]` - Generate `TryFrom` instead+- `deriveBoth :: MatchStrategy -> Name -> Name -> Q [Dec]` - Generate both directions++### Match Strategies++- `ByPosition` - Structural matching (by declaration order)+- `ByName Config` - Semantic matching (by name with rules)++### Types++- `FieldRef` - Either `RealField Name` or `VirtualField String`+- `ConstructorMapping` - `Identity`, `DirectMapping [(Name, Name)]`, or `Transform (String -> String)`+- `FieldRule` - Configuration for a single field mapping+- `FieldGetter a` - Monad for extracting source fields in `combineFields`+- `DisassembleGetter a` - Monad for accessing source field in `disassembleFields`++## Warlock.Tweak - Type Generation with Modifications++The `Warlock.Tweak` module generates new data types from existing ones with field modifications, perfect for creating DTOs, API response types, and projections. Inspired by TypeScript's utility types like `Pick<T, K>` and `Omit<T, K>`.++### Quick Example++```haskell+{-# LANGUAGE TemplateHaskell #-}+import qualified Warlock.Tweak as Tweak+import Warlock.Tweak (pick, omit)++data User = User+  { userId :: Int+  , userName :: String+  , userEmail :: String+  , userPassword :: String  -- Sensitive!+  , userCreatedAt :: String+  }++-- Pick specific fields (TypeScript Pick<User, "id" | "name">)+pick ''User "UserSummary" ['userId, 'userName]++-- Omit sensitive fields (TypeScript Omit<User, "password">)+omit ''User "UserResponse" ['userPassword]++-- Generates new types + From instances automatically+-- let summary = from user :: UserSummary+```++### TypeScript-Style API++**`pick`** - Select specific fields (like TypeScript's `Pick<T, K>`):+```haskell+-- Simple usage+pick ''User "UserMinimal" ['userId, 'userName]++-- With configuration+pick' (defaultTweakConfig `Tweak.stripPrefix` "user")+      ''User "UserClean" ['userName, 'userEmail]+-- Generated: UserClean { name :: String, email :: String }+```++**`omit`** - Exclude specific fields (like TypeScript's `Omit<T, K>`):+```haskell+-- Simple usage+omit ''User "UserDTO" ['userPassword, 'userCreatedAt]++-- With configuration+omit' (defaultTweakConfig `Tweak.addPrefix` "dto")+      ''User "UserAPI" ['userPassword]+-- Generated: UserAPI { dtouserId :: Int, dtouserName :: String, ... }+```++### Composable Configuration++All functions support composable configuration using helper functions:++**`stripPrefix`** - Remove common prefix from fields:+```haskell+pick' (defaultTweakConfig `Tweak.stripPrefix` "user")+      ''User "UserClean" ['userName, 'userEmail]+-- userName -> name, userEmail -> email+```++**`addPrefix`** - Add prefix to all fields:+```haskell+omit' (defaultTweakConfig `Tweak.addPrefix` "api")+      ''User "UserAPI" ['userPassword]+-- userId -> apiuserId, userName -> apiuserName, etc.+```++**`replacePrefix`** - Swap one prefix for another:+```haskell+pick' (defaultTweakConfig `Tweak.replacePrefix` ("product", "item"))+      ''Product "ItemSummary" ['productId, 'productName]+-- productId -> itemId, productName -> itemName+```++**`withRenames`** - Direct field name mappings:+```haskell+pick' (defaultTweakConfig `Tweak.withRenames` [('userId, mkName "id")])+      ''User "UserRenamed" ['userId, 'userName]+-- userId -> id, userName stays userName+```++**Chain operations** - Combine multiple transformations:+```haskell+pick' (defaultTweakConfig+        `Tweak.stripPrefix` "user"+        `Tweak.addPrefix` "dto")+      ''User "UserDTO" ['userName, 'userEmail]+-- userName -> dtoName, userEmail -> dtoEmail+```++### Configuration Options++```haskell+data TweakConfig = TweakConfig+  { fieldSelector :: FieldSelector        -- Which fields to keep/drop+  , fieldRenames :: [(Name, Name)]        -- Explicit field renames+  , prefixOps :: [PrefixOp]              -- Prefix operations+  , autoDerive :: Bool                    -- Auto-generate From instances (default: True)+  , deriveStrategy :: Maybe MatchStrategy -- Custom Warlock strategy+  }++-- Composable helpers:+withFields :: TweakConfig -> [Name] -> TweakConfig+withoutFields :: TweakConfig -> [Name] -> TweakConfig+Tweak.withRenames :: TweakConfig -> [(Name, Name)] -> TweakConfig+Tweak.addPrefix :: TweakConfig -> String -> TweakConfig+Tweak.stripPrefix :: TweakConfig -> String -> TweakConfig+Tweak.replacePrefix :: TweakConfig -> (String, String) -> TweakConfig+withAutoDerive :: TweakConfig -> Bool -> TweakConfig+withDeriveStrategy :: TweakConfig -> MatchStrategy -> TweakConfig+```++### Use Cases++**API Response DTOs:**+```haskell+-- Omit sensitive fields for API responses+omit ''User "UserResponse" ['userPassword, 'userSalt, 'userTokens]+```++**Database to Domain:**+```haskell+-- Strip "db" prefix from Persistent-generated types+pick' (defaultTweakConfig `Tweak.stripPrefix` "dbUser")+      ''DbUser "User" ['dbUserId, 'dbUserName, 'dbUserEmail]+```++**Field Projections:**+```haskell+-- Create minimal type for specific use cases+pick ''User "UserSummary" ['userId, 'userName]+```++**API Versioning:**+```haskell+-- Add prefix for versioned types+pick' (defaultTweakConfig `Tweak.addPrefix` "v2")+      ''User "UserV2" ['userId, 'userName, 'userEmail]+```++### Notes++- Automatically generates `From` instances between source and derived types (unless `withAutoDerive False`)+- Field names are automatically lowercased after prefix operations to maintain Haskell conventions+- Constructor name defaults to match type name+- Single-constructor record types only (no sum types or positional constructors yet)+- Module must be imported qualified to avoid name conflicts: `import qualified Warlock.Tweak as Tweak`++## Warlock.HKD - Higher-Kinded Data Generation++Generate Higher-Kinded Data (HKD) versions of your types for use with libraries like `barbies`. HKD types wrap each field in a type constructor, enabling powerful patterns for validation, partial construction, and generic programming.++```haskell+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+import Warlock.HKD+import Data.Functor.Identity+import Witch (from)++data Person = Person+  { name :: String+  , age :: Int+  , email :: String+  } deriving (Show, Eq)++-- Generate HKD type with default config+deriveHKD' ''Person++-- Now you have:+-- - Type family: HKD Person f+-- - Concrete type: Person' f+-- - From instances for Identity wrapper conversion+```++### Type Family and Instances++The `deriveHKD` function generates:++1. **A concrete HKD data type** with fields wrapped in `f`:+```haskell+data Person' f = Person'+  { name :: f String+  , age :: f Int+  , email :: f String+  }+```++2. **A type family instance** for convenient syntax:+```haskell+type instance HKD Person f = Person' f+```++3. **From instances** for Identity conversion (bidirectional):+```haskell+instance From (Person' Identity) Person+instance From Person (Person' Identity)+```++### Basic Usage++**Bidirectional Conversion:**+```haskell+let person = Person "Alice" 30 "alice@example.com"+let hkdPerson = from person :: HKD Person Identity+let unwrapped = from hkdPerson :: Person+```++**Partial Construction with Maybe:**+```haskell+-- Build up a Person incrementally+let partial = Person' (Just "Bob") Nothing (Just "bob@example.com") :: Person' Maybe++-- Validate and convert when complete+validatePerson :: Person' Maybe -> Maybe Person+validatePerson (Person' (Just n) (Just a) (Just e)) = Just (Person n a e)+validatePerson _ = Nothing+```++**Optional Fields:**+```haskell+-- Form validation where fields might be missing+data UserForm f = UserForm+  { username :: f String+  , password :: f String+  , confirmPassword :: f String+  }++deriveHKD' ''UserForm++-- During form filling, fields are Maybe String+let formInProgress = UserForm' (Just "alice") Nothing Nothing :: UserForm' Maybe+```++### Configuration++Customize field and constructor naming:++**Field Prefix:**+```haskell+data User = User+  { userName :: String+  , userEmail :: String+  }++-- Fields: hkduserName, hkduserEmail+deriveHKD (defaultHKDConfig `withFieldPrefix` "hkd") ''User+```++**Constructor Suffix:**+```haskell+-- Constructor: PersonHKD instead of Person'+deriveHKD (defaultHKDConfig `withConstructorSuffix` "HKD") ''Person+```++**Custom Transforms:**+```haskell+deriveHKD (defaultHKDConfig+  `withFieldTransform` (\name -> "field_" ++ name)+  `withConstructorTransform` (\name -> name ++ "_HKD")+) ''MyType+```++**Disable From Instances:**+```haskell+-- Generate only the HKD type, no From instances+deriveHKD (withoutFromInstances defaultHKDConfig) ''MyType+```++### Multi-Constructor Support++HKD generation works with sum types:++```haskell+data Payment+  = CreditCard { cardNumber :: String, cvv :: String }+  | Cash { amount :: Double }+  | Check { checkNumber :: Int }++deriveHKD' ''Payment++-- Generates Payment' with all constructors wrapped+let payment = CreditCard "1234" "123"+let hkdPayment = from payment :: HKD Payment Identity+let unwrapped = from hkdPayment :: Payment+```++### Integration with Barbies++While Warlock.HKD generates the HKD types and From instances, you can use `barbies` for generic traversals by deriving the necessary instances:++```haskell+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveGeneric #-}+import GHC.Generics (Generic)+import qualified Barbies as B++data Person = Person { name :: String, age :: Int }+deriveHKD' ''Person++deriving instance Generic (Person' f)+instance B.FunctorB Person'+instance B.TraversableB Person'+instance B.ApplicativeB Person'++-- Now use barbies operations+validateFields :: Person' Maybe -> Either [String] Person+validateFields p = B.btraverse (maybe (Left ["missing"]) Right) p+```++### Use Cases++**Form Validation:**+```haskell+-- Track validation state per field+data PersonForm f = PersonForm+  { name :: f String+  , age :: f Int+  , email :: f String+  }++type ValidationResult = Either String++validateForm :: PersonForm Maybe -> PersonForm ValidationResult+validateForm = -- validate each field++-- Collect to final result+collectValidation :: PersonForm (Either String) -> Either [String] Person+collectValidation = B.btraverse (either (Left . pure) Right)+```++**Incremental Construction:**+```haskell+-- Build complex objects step by step+data Config f = Config+  { host :: f String+  , port :: f Int+  , timeout :: f Int+  }++emptyConfig :: Config Maybe+emptyConfig = Config Nothing Nothing Nothing++addHost :: String -> Config Maybe -> Config Maybe+addHost h cfg = cfg { host = Just h }+```++**Optional Fields in APIs:**+```haskell+-- PATCH requests with optional updates+data UserUpdate f = UserUpdate+  { updateName :: f String+  , updateEmail :: f String+  , updateAge :: f Int+  }++-- Only update provided fields+applyUpdate :: User -> UserUpdate Maybe -> User+applyUpdate user upd = User+  { userName = fromMaybe (userName user) (updateName upd)+  , userEmail = fromMaybe (userEmail user) (updateEmail upd)+  , userAge = fromMaybe (userAge user) (updateAge upd)+  }+```++## Learning Resources++### Warlock.Tutorial++For a comprehensive guide covering all features from basic to advanced usage, see the **[Warlock.Tutorial](src/Warlock/Tutorial.hs)** module. This extensive tutorial includes:++- Introduction & core concepts (ByPosition vs ByName decision tree)+- Getting started with simple examples+- Naming conventions (datatype prefix, constructor prefix, snake/camel case)+- Advanced field manipulation (virtual fields, computed fields, disassembled fields)+- Constructor mapping strategies+- Type generation with Warlock.Tweak (Pick/Omit DTOs)+- Higher-Kinded Data with Warlock.HKD+- Real-world patterns (API versioning, database conversions, DTOs)+- Advanced techniques and troubleshooting++The tutorial is designed to be read sequentially and includes complete, working examples for every concept.++## License++MIT
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Warlock.hs view
@@ -0,0 +1,1311 @@+{-# 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
+ src/Warlock/HKD.hs view
@@ -0,0 +1,398 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      : Warlock.HKD+-- Description : Higher-Kinded Data (HKD) type generation+-- License     : MIT+--+-- = Overview+--+-- Generate HKD versions of your types for use with @barbies@ and other+-- HKD libraries. Automatically creates 'Witch.From' instances for conversion+-- between regular types and their Identity-wrapped HKD equivalents.+--+-- = Quick Example+--+-- @+-- {-# LANGUAGE TemplateHaskell #-}+-- {-# LANGUAGE TypeFamilies #-}+-- import Warlock.HKD+-- import Data.Functor.Identity+-- import Witch (from)+--+-- data Person = Person+--   { name :: String+--   , age :: Int+--   }+--+-- deriveHKD' ''Person+--+-- -- Generates:+-- -- type instance HKD Person f = Person' f+-- -- data Person' f = Person' { name :: f String, age :: f Int }+-- -- instance From (HKD Person Identity) Person+-- -- instance From Person (HKD Person Identity)+--+-- -- Usage:+-- let person = Person "Alice" 30+-- let hkdPerson = from person :: HKD Person Identity+-- let unwrapped = from hkdPerson :: Person+--+-- -- Usage with barbies:+-- import qualified Barbies as B+-- validatePerson :: Person' Maybe -> Either [String] Person+-- validatePerson p = B.btraverse (maybe (Left ["missing"]) Right) p+-- @+--+-- = Use Cases+--+-- * **Validation**: Wrap fields in Maybe for partial construction+-- * **Form handling**: Build up data incrementally+-- * **Serialization**: Handle optional fields gracefully+-- * **Testing**: Generate test data with default values+-- * **Barbies integration**: Use with btraverse, bpure, etc.++module Warlock.HKD+  ( -- * Type Family+    HKD++    -- * Template Haskell Generation+  , deriveHKD+  , deriveHKD'++    -- * Configuration+  , HKDConfig(..)+  , defaultHKDConfig+  , withFieldTransform+  , withConstructorTransform+  , withFieldPrefix+  , withConstructorSuffix+  , withoutFromInstances+  ) where++import Language.Haskell.TH+import qualified Data.Kind as Kind+import Data.Functor.Identity (Identity(..))+import qualified Witch++--------------------------------------------------------------------------------+-- Type Family++-- | Higher-Kinded Data type family.+--+-- Transforms a regular type into its HKD equivalent where each field+-- is wrapped in a type constructor @f@.+--+-- @+-- type instance HKD Person f = Person' f+-- @+type HKD :: Kind.Type -> (Kind.Type -> Kind.Type) -> Kind.Type+type family HKD a f++--------------------------------------------------------------------------------+-- Configuration++-- | Configuration for HKD generation.+--+-- Controls how the HKD type and its components are named, and whether+-- to generate From instances.+data HKDConfig = HKDConfig+  { hkdFieldNameTransform :: String -> String+    -- ^ Transform field names. Default: id (keep original names)+  , hkdConstructorNameTransform :: String -> String+    -- ^ Transform constructor names. Default: (++ "'") (add prime suffix)+  , hkdGenerateFromInstances :: Bool+    -- ^ Auto-generate From instances. Default: True+  }++-- | Default HKD configuration.+--+-- - Field names: unchanged+-- - Constructor names: add prime suffix (@Person@ → @Person'@)+-- - Generate From instances: yes+defaultHKDConfig :: HKDConfig+defaultHKDConfig = HKDConfig+  { hkdFieldNameTransform = id+  , hkdConstructorNameTransform = (++ "'")+  , hkdGenerateFromInstances = True+  }++-- | Set custom field name transform function.+--+-- @+-- deriveHKD (defaultHKDConfig \`withFieldTransform\` (\"hkd\" ++)) ''Person+-- @+withFieldTransform :: (String -> String) -> HKDConfig -> HKDConfig+withFieldTransform f cfg = cfg { hkdFieldNameTransform = f }++-- | Set custom constructor name transform function.+--+-- @+-- deriveHKD (defaultHKDConfig \`withConstructorTransform\` (++ "HKD")) ''Person+-- @+withConstructorTransform :: (String -> String) -> HKDConfig -> HKDConfig+withConstructorTransform f cfg = cfg { hkdConstructorNameTransform = f }++-- | Add prefix to field names.+--+-- @+-- deriveHKD (defaultHKDConfig \`withFieldPrefix\` "hkd") ''Person+-- -- name → hkdname+-- @+withFieldPrefix :: HKDConfig -> String -> HKDConfig+withFieldPrefix cfg prefix = withFieldTransform (prefix ++) cfg++-- | Add suffix to constructor names.+--+-- @+-- deriveHKD (defaultHKDConfig \`withConstructorSuffix\` "HKD") ''Person+-- -- Person → PersonHKD+-- @+withConstructorSuffix :: HKDConfig -> String -> HKDConfig+withConstructorSuffix cfg suffix = withConstructorTransform (++ suffix) cfg++-- | Disable automatic From instance generation.+withoutFromInstances :: HKDConfig -> HKDConfig+withoutFromInstances cfg = cfg { hkdGenerateFromInstances = False }++--------------------------------------------------------------------------------+-- Template Haskell Generation++-- | Generate HKD type with custom configuration.+--+-- @+-- deriveHKD defaultHKDConfig ''Person+-- deriveHKD (defaultHKDConfig \`withFieldPrefix\` "hkd") ''Person+-- @+deriveHKD :: HKDConfig -> Name -> Q [Dec]+deriveHKD config typeName = do+  -- Extract type information+  info <- reify typeName+  (typeVars, constructors) <- extractTypeInfo info++  -- Generate HKD data type+  let hkdTypeName = mkName $ hkdConstructorNameTransform config (nameBase typeName)+  hkdDataDecl <- generateHKDDataType config hkdTypeName typeVars constructors++  -- Generate type family instance+  let fVar = mkName "f"+  let typeFamilyInst = generateTypeFamilyInstance typeName hkdTypeName typeVars fVar++  -- Generate From instances if enabled+  fromInstances <- if hkdGenerateFromInstances config+    then generateFromInstances config typeName hkdTypeName typeVars constructors+    else pure []++  pure $ hkdDataDecl : typeFamilyInst : fromInstances++-- | Generate HKD type with default configuration.+--+-- @+-- deriveHKD' ''Person+-- @+deriveHKD' :: Name -> Q [Dec]+deriveHKD' = deriveHKD defaultHKDConfig++--------------------------------------------------------------------------------+-- Implementation: Extract Type Info++extractTypeInfo :: Info -> Q ([TyVarBndr BndrVis], [Con])+extractTypeInfo info = case info of+  TyConI (DataD _ _ typeVars _ cons _) ->+    pure (typeVars, cons)+  TyConI (NewtypeD _ _ typeVars _ con _) ->+    pure (typeVars, [con])+  _ -> fail $ "Warlock.HKD: Cannot derive HKD for " ++ show info++--------------------------------------------------------------------------------+-- Implementation: Generate HKD Data Type++generateHKDDataType :: HKDConfig -> Name -> [TyVarBndr BndrVis] -> [Con] -> Q Dec+generateHKDDataType config hkdTypeName typeVars constructors = do+  let fVar = mkName "f"+  let fTyVar = PlainTV fVar BndrReq++  -- Add 'f' as the last type variable+  let allTyVars = typeVars ++ [fTyVar]++  -- Transform constructors+  hkdCons <- mapM (transformConstructor config fVar) constructors++  pure $ DataD [] hkdTypeName allTyVars Nothing hkdCons []++transformConstructor :: HKDConfig -> Name -> Con -> Q Con+transformConstructor config fVar con = case con of+  RecC conName fields -> do+    hkdFields <- mapM (transformField config fVar) fields+    let hkdConName = mkName $ hkdConstructorNameTransform config (nameBase conName)+    pure $ RecC hkdConName hkdFields++  NormalC conName fields -> do+    hkdFields <- mapM (transformBangType config fVar) fields+    let hkdConName = mkName $ hkdConstructorNameTransform config (nameBase conName)+    pure $ NormalC hkdConName hkdFields++  InfixC left conName right -> do+    hkdLeft <- transformBangType config fVar left+    hkdRight <- transformBangType config fVar right+    let hkdConName = mkName $ hkdConstructorNameTransform config (nameBase conName)+    pure $ InfixC hkdLeft hkdConName hkdRight++  _ -> fail "Warlock.HKD: GADT constructors not supported"++transformField :: HKDConfig -> Name -> VarBangType -> Q VarBangType+transformField config fVar (fieldName, bndr, fieldType) = do+  let hkdFieldName = mkName $ hkdFieldNameTransform config (nameBase fieldName)+  let hkdFieldType = AppT (VarT fVar) fieldType+  pure (hkdFieldName, bndr, hkdFieldType)++transformBangType :: HKDConfig -> Name -> BangType -> Q BangType+transformBangType _config fVar (bndr, fieldType) = do+  let hkdFieldType = AppT (VarT fVar) fieldType+  pure (bndr, hkdFieldType)++--------------------------------------------------------------------------------+-- Implementation: Generate Type Family Instance++generateTypeFamilyInstance :: Name -> Name -> [TyVarBndr BndrVis] -> Name -> Dec+generateTypeFamilyInstance origTypeName hkdTypeName typeVars fVar =+  let -- Build the original type applied to its type variables+      origTypeVarNames = map getTyVarName typeVars+      origType = foldl AppT (ConT origTypeName) (map VarT origTypeVarNames)++      -- Build the HKD type applied to type variables + f+      hkdType = foldl AppT (ConT hkdTypeName) (map VarT (origTypeVarNames ++ [fVar]))++      -- type instance HKD OrigType f = HKDType' f+      lhs = AppT (AppT (ConT ''HKD) origType) (VarT fVar)+  in TySynInstD (TySynEqn Nothing lhs hkdType)+  where+    getTyVarName :: TyVarBndr BndrVis -> Name+    getTyVarName (PlainTV n _) = n+    getTyVarName (KindedTV n _ _) = n++--------------------------------------------------------------------------------+-- Implementation: Generate From Instances++generateFromInstances :: HKDConfig -> Name -> Name -> [TyVarBndr BndrVis] -> [Con] -> Q [Dec]+generateFromInstances config origTypeName hkdTypeName typeVars constructors = do+  -- Generate: From (HKD OrigType Identity) OrigType+  unwrapInst <- generateUnwrapInstance config origTypeName hkdTypeName typeVars constructors++  -- Generate: From OrigType (HKD OrigType Identity)+  wrapInst <- generateWrapInstance config origTypeName hkdTypeName typeVars constructors++  pure [unwrapInst, wrapInst]++generateUnwrapInstance :: HKDConfig -> Name -> Name -> [TyVarBndr BndrVis] -> [Con] -> Q Dec+generateUnwrapInstance config origTypeName hkdTypeName typeVars constructors = do+  let typeVarNames = map getTyVarName typeVars+  let origType = foldl AppT (ConT origTypeName) (map VarT typeVarNames)+  -- Use concrete HKD type instead of type family for instance head+  -- Apply Identity as a type constructor, not a type variable+  let hkdType = foldl AppT (ConT hkdTypeName) (map VarT typeVarNames ++ [ConT ''Identity])++  -- Generate from clauses for each constructor+  clauses <- mapM (generateUnwrapClause config) constructors++  let fromMethod = FunD (mkName "from") clauses++  pure $ InstanceD Nothing [] (AppT (AppT (ConT ''Witch.From) hkdType) origType) [fromMethod]+  where+    getTyVarName (PlainTV n _) = n+    getTyVarName (KindedTV n _ _) = n++generateUnwrapClause :: HKDConfig -> Con -> Q Clause+generateUnwrapClause config con = case con of+  RecC conName fields -> do+    -- Generate pattern: HKDCon' (Identity f1) (Identity f2) ...+    fieldVars <- mapM (\_ -> newName "x") fields+    let hkdConName = mkName $ hkdConstructorNameTransform config (nameBase conName)+    -- Use transformed field names for pattern matching+    let transformedFields = [(mkName $ hkdFieldNameTransform config (nameBase fname), var) | ((fname, _, _), var) <- zip fields fieldVars]+    let hkdPattern = RecP hkdConName [(fname, ConP 'Identity [] [VarP var]) | (fname, var) <- transformedFields]++    -- Generate expression: OrigCon f1 f2 ...+    let origConExp = foldl AppE (ConE conName) (map VarE fieldVars)++    pure $ Clause [hkdPattern] (NormalB origConExp) []++  NormalC conName fields -> do+    fieldVars <- mapM (\_ -> newName "x") fields+    let hkdConName = mkName $ hkdConstructorNameTransform config (nameBase conName)+    let hkdPattern = ConP hkdConName [] [ConP 'Identity [] [VarP var] | var <- fieldVars]+    let origConExp = foldl AppE (ConE conName) (map VarE fieldVars)++    pure $ Clause [hkdPattern] (NormalB origConExp) []++  InfixC _ conName _ -> do+    leftVar <- newName "l"+    rightVar <- newName "r"+    let hkdConName = mkName $ hkdConstructorNameTransform config (nameBase conName)+    let hkdPattern = InfixP (ConP 'Identity [] [VarP leftVar]) hkdConName (ConP 'Identity [] [VarP rightVar])+    let origConExp = InfixE (Just (VarE leftVar)) (ConE conName) (Just (VarE rightVar))++    pure $ Clause [hkdPattern] (NormalB origConExp) []++  _ -> fail "Warlock.HKD: GADT constructors not supported in From instances"++generateWrapInstance :: HKDConfig -> Name -> Name -> [TyVarBndr BndrVis] -> [Con] -> Q Dec+generateWrapInstance config origTypeName hkdTypeName typeVars constructors = do+  let typeVarNames = map getTyVarName typeVars+  let origType = foldl AppT (ConT origTypeName) (map VarT typeVarNames)+  -- Use concrete HKD type instead of type family for instance head+  -- Apply Identity as a type constructor, not a type variable+  let hkdType = foldl AppT (ConT hkdTypeName) (map VarT typeVarNames ++ [ConT ''Identity])++  -- Generate from clauses for each constructor+  clauses <- mapM (generateWrapClause config) constructors++  let fromMethod = FunD (mkName "from") clauses++  pure $ InstanceD Nothing [] (AppT (AppT (ConT ''Witch.From) origType) hkdType) [fromMethod]+  where+    getTyVarName (PlainTV n _) = n+    getTyVarName (KindedTV n _ _) = n++generateWrapClause :: HKDConfig -> Con -> Q Clause+generateWrapClause config con = case con of+  RecC conName fields -> do+    -- Generate pattern: OrigCon f1 f2 ...+    fieldVars <- mapM (\_ -> newName "x") fields+    let origPattern = RecP conName [(fname, VarP var) | ((fname, _, _), var) <- zip fields fieldVars]++    -- Generate expression: HKDCon' (Identity f1) (Identity f2) ...+    let hkdConName = mkName $ hkdConstructorNameTransform config (nameBase conName)+    let transformedFields = [(mkName $ hkdFieldNameTransform config (nameBase fname), AppE (ConE 'Identity) (VarE var)) | ((fname, _, _), var) <- zip fields fieldVars]+    let hkdConExp = RecConE hkdConName transformedFields++    pure $ Clause [origPattern] (NormalB hkdConExp) []++  NormalC conName fields -> do+    fieldVars <- mapM (\_ -> newName "x") fields+    let origPattern = ConP conName [] [VarP var | var <- fieldVars]+    let hkdConName = mkName $ hkdConstructorNameTransform config (nameBase conName)+    let hkdConExp = foldl AppE (ConE hkdConName) [AppE (ConE 'Identity) (VarE var) | var <- fieldVars]++    pure $ Clause [origPattern] (NormalB hkdConExp) []++  InfixC _ conName _ -> do+    leftVar <- newName "l"+    rightVar <- newName "r"+    let origPattern = InfixP (VarP leftVar) conName (VarP rightVar)+    let hkdConName = mkName $ hkdConstructorNameTransform config (nameBase conName)+    let hkdConExp = InfixE+          (Just (AppE (ConE 'Identity) (VarE leftVar)))+          (ConE hkdConName)+          (Just (AppE (ConE 'Identity) (VarE rightVar)))++    pure $ Clause [origPattern] (NormalB hkdConExp) []++  _ -> fail "Warlock.HKD: GADT constructors not supported in From instances"+
+ src/Warlock/Tutorial.hs view
@@ -0,0 +1,1170 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverloadedLabels #-}++-- |+-- Module      : Warlock.Tutorial+-- Description : Comprehensive tutorial for the Warlock library+-- License     : MIT+-- Maintainer  : ian@iankduncan.com+-- Stability   : experimental+--+-- = Welcome to Warlock!+--+-- Warlock is a Template Haskell library for automatic type-safe mapping between+-- Haskell data types. It builds on the @witch@ library to provide compile-time+-- verified conversions with flexible configuration options.+--+-- This tutorial will guide you from basic usage to advanced techniques, showing+-- you how to leverage Warlock's features for real-world scenarios.+--+-- == Table of Contents+--+-- 1. "Warlock.Tutorial#g:intro" - Introduction & Core Concepts+-- 2. "Warlock.Tutorial#g:basics" - Getting Started (Basic Examples)+-- 3. "Warlock.Tutorial#g:naming" - Naming Conventions+-- 4. "Warlock.Tutorial#g:fields" - Advanced Field Manipulation+-- 5. "Warlock.Tutorial#g:constructors" - Constructor Mapping+-- 6. "Warlock.Tutorial#g:tweak" - Type Generation with Warlock.Tweak+-- 7. "Warlock.Tutorial#g:hkd" - Higher-Kinded Data with Warlock.HKD+-- 8. "Warlock.Tutorial#g:realworld" - Real-World Patterns+-- 9. "Warlock.Tutorial#g:advanced" - Advanced Techniques+-- 10. "Warlock.Tutorial#g:troubleshooting" - Troubleshooting Guide+--+-- = Introduction & Core Concepts #intro#+--+-- == What is Warlock?+--+-- Warlock generates 'Witch.From' and 'Witch.TryFrom' instances between data types,+-- eliminating boilerplate conversion code while maintaining type safety. Unlike+-- manual instances or generic deriving, Warlock gives you:+--+-- * __Compile-time field name checking__: Typos caught at compile time+-- * __Flexible mapping strategies__: Structural or semantic matching+-- * __Powerful field rules__: Computed fields, virtual fields, defaults+-- * __Type generation__: Create DTOs and HKD types automatically+--+-- == When to Use Warlock+--+-- Warlock excels at:+--+-- * API versioning (V1 → V2 → V3 migrations)+-- * Database to domain model conversions+-- * Creating DTOs for web APIs+-- * Form validation with HKD patterns+-- * Protocol buffer conversions+-- * Multi-layer architecture with distinct types per layer+--+-- == The witch Library+--+-- Warlock builds on @witch@, which provides two type classes:+--+-- * 'Witch.From' - Total conversions that always succeed+-- * 'Witch.TryFrom' - Partial conversions that may fail+--+-- Once Warlock generates instances, you use @witch@'s conversion functions:+--+-- @+-- -- Total conversion+-- employee = 'Witch.from' person :: Employee+--+-- -- Fallible conversion+-- result = 'Witch.tryFrom' text :: Either (TryFromException Text Int) Int+-- @+--+-- == ByPosition vs ByName: Decision Tree+--+-- Warlock offers two matching strategies:+--+-- +------------------+------------------------------------------------++-- | ByPosition       | Structural matching by declaration order       |+-- +------------------+------------------------------------------------++-- | Use when:        | - Types have same shape, different names       |+-- |                  | - Converting between library types (Either,    |+-- |                  |   Maybe, tuples)                               |+-- |                  | - No field naming conventions                  |+-- +------------------+------------------------------------------------++-- | ByName Config    | Semantic matching with configurable rules      |+-- +------------------+------------------------------------------------++-- | Use when:        | - Field names follow conventions               |+-- |                  | - Need field evolution (add/remove fields)     |+-- |                  | - Require computed or virtual fields           |+-- |                  | - Multi-constructor ADTs with naming patterns  |+-- +------------------+------------------------------------------------++--+-- __Rule of thumb:__ Start with 'ByName' for record types, use 'ByPosition'+-- for positional constructors or when converting standard library types.+--+-- = Getting Started (Basic Examples) #basics#+--+-- == Simple Record Mapping+--+-- The most common case: two records with the same field names.+--+-- @+-- {-\# LANGUAGE TemplateHaskell \#-}+-- {-\# LANGUAGE MultiParamTypeClasses \#-}+--+-- import Warlock+-- import qualified Witch as W+--+-- data Person = Person { name :: String, age :: Int }+-- data Employee = Employee { name :: String, age :: Int }+--+-- -- Generate From instance: Person → Employee+-- 'deriveAutomap' ('ByName' 'defaultConfig') ''Person ''Employee+--+-- example :: Employee+-- example = W.from (Person \"Alice\" 30)+-- @+--+-- The generated instance matches fields by name (exact match required).+--+-- == Positional Constructor Mapping+--+-- For types without field names, use 'ByPosition':+--+-- @+-- data Point2D = Point2D Int Int+-- data Vector2D = Vector2D Int Int+--+-- -- Match by position: 1st → 1st, 2nd → 2nd+-- 'deriveAutomap' 'ByPosition' ''Point2D ''Vector2D+--+-- example :: Vector2D+-- example = W.from (Point2D 3 4)  -- Vector2D 3 4+-- @+--+-- == Adding Default Values+--+-- When the destination type has fields not present in the source:+--+-- @+-- data PersonV1 = PersonV1 { personName :: String }+-- data PersonV2 = PersonV2+--   { personName :: String+--   , personAge :: Int      -- New field!+--   , personRegion :: String -- Another new field!+--   }+--+-- 'deriveAutomap'+--   ('ByName' $+--     'datatypePrefixConfig'+--     \`'withDefaults'\`+--       [ ('personAge, [| 0 :: Int |])+--       , ('personRegion, [| \"US\" :: String |])+--       ])+--   ''PersonV1+--   ''PersonV2+--+-- example :: PersonV2+-- example = W.from (PersonV1 \"Bob\")+-- -- PersonV2 { personName = \"Bob\", personAge = 0, personRegion = \"US\" }+-- @+--+-- == Basic Field Renaming+--+-- When field names differ between types:+--+-- @+-- data Source = Source+--   { oldName :: String+--   , oldBalance :: Double+--   }+--+-- data Dest = Dest+--   { newName :: String+--   , newBalance :: Double+--   }+--+-- 'deriveAutomap'+--   ('ByName' $+--     'defaultConfig'+--     \`'withRenames'\`+--       [ ('newName, 'oldName)+--       , ('newBalance, 'oldBalance)+--       ])+--   ''Source+--   ''Dest+-- @+--+-- = Naming Conventions #naming#+--+-- Haskell code often follows naming conventions. Warlock provides pre-built+-- configurations for common patterns.+--+-- == Datatype Prefix Convention+--+-- The most common pattern: fields prefixed with the type name.+--+-- @+-- data Person = Person+--   { personName :: String+--   , personAge :: Int+--   }+--+-- data Employee = Employee+--   { employeeName :: String+--   , employeeAge :: Int+--   }+--+-- -- Automatically strips \"person\" and adds \"employee\"+-- 'deriveAutomap' ('ByName' 'datatypePrefixConfig') ''Person ''Employee+-- @+--+-- How it works:+--+-- 1. Strip source type prefix: @personName@ → @Name@+-- 2. Add destination type prefix: @Name@ → @employeeName@+-- 3. Case handled automatically: @Person@ → @person@, @Employee@ → @employee@+--+-- == Constructor Prefix Convention+--+-- Less common but still used: fields prefixed with constructor name.+--+-- @+-- data Result+--   = Success { successValue :: String, successTime :: Int }+--   | Failure { failureError :: String, failureTime :: Int }+--+-- data Response+--   = Ok { okValue :: String, okTime :: Int }+--   | Err { errError :: String, errTime :: Int }+--+-- 'deriveAutomap'+--   ('ByName' $ 'constructorPrefixConfig' \`'withConstructorMap'\`+--     [ ('Success, 'Ok)+--     , ('Failure, 'Err)+--     ])+--   ''Result+--   ''Response+-- @+--+-- == Snake Case ↔ Camel Case+--+-- For interfacing with databases or JSON APIs:+--+-- @+-- data DbUser = DbUser+--   { user_name :: String+--   , user_email :: String+--   , created_at :: String+--   }+--+-- data User = User+--   { userName :: String+--   , userEmail :: String+--   , createdAt :: String+--   }+--+-- 'deriveAutomap' ('ByName' 'snakeToCamelConfig') ''DbUser ''User+-- @+--+-- == Custom Normalization+--+-- Build your own normalization function:+--+-- @+-- import Data.Char (toUpper)+--+-- -- Remove \"internal\" prefix and uppercase first letter+-- customNormalize :: String -> String+-- customNormalize s = case 'Warlock.stripPrefix' \"internal\" s of+--   Just rest -> case rest of+--     (c:cs) -> toUpper c : cs+--     [] -> []+--   Nothing -> s+--+-- data Internal = Internal { internalData :: String }+-- data Public = Public { data_ :: String }+--+-- 'deriveAutomap'+--   ('ByName' $ 'defaultConfig'+--     \`'withNormalize'\` customNormalize+--     \`'withRenames'\` [('data_, 'internalData)])+--   ''Internal+--   ''Public+-- @+--+-- = Advanced Field Manipulation #fields#+--+-- Warlock provides three powerful mechanisms for complex field transformations:+--+-- * __Virtual fields__: Runtime computation via 'GHC.Records.HasField'+-- * __Computed fields__: Compile-time combination of multiple sources+-- * __Disassembled fields__: Splitting one source into multiple destinations+--+-- == Virtual Fields with HasField+--+-- Virtual fields use GHC's @HasField@ mechanism to access computed properties+-- that don't exist as actual fields.+--+-- @+-- {-\# LANGUAGE DataKinds \#-}+-- {-\# LANGUAGE OverloadedLabels \#-}+--+-- import GHC.Records (HasField(..))+--+-- data Person = Person+--   { firstName :: String+--   , lastName :: String+--   , age :: Int+--   }+--+-- -- Define virtual field at runtime+-- instance HasField \"fullName\" Person String where+--   getField (Person first last _) = first ++ \" \" ++ last+--+-- instance HasField \"ageGroup\" Person String where+--   getField (Person _ _ a) = if a < 18 then \"minor\" else \"adult\"+--+-- data Employee = Employee+--   { empName :: String+--   , empAge :: Int+--   , category :: String+--   }+--+-- 'deriveAutomap'+--   ('ByName' $+--     'defaultConfig'+--     \`'withRules'\`+--       [ 'virtualField' 'empName #fullName  -- OverloadedLabels syntax+--       , 'rename' 'empAge 'age+--       , 'virtualField' 'category \"ageGroup\"  -- String syntax+--       ])+--   ''Person+--   ''Employee+-- @+--+-- __When to use virtual fields:__+--+-- * Source field is computed at runtime (not a real field)+-- * Single source, single destination+-- * Logic lives in @HasField@ instance+--+-- == Computed Fields (Combining Multiple Fields)+--+-- Combine multiple source fields at compile time using Template Haskell:+--+-- @+-- data Address = Address+--   { street :: String+--   , city :: String+--   , country :: String+--   }+--+-- data ShortAddress = ShortAddress+--   { location :: String+--   }+--+-- 'deriveAutomap'+--   ('ByName' $+--     'defaultConfig'+--     \`'withRules'\`+--       [ 'combineFields' 'location $ do+--           street <- 'Warlock.get' 'street+--           city <- 'Warlock.get' 'city+--           country <- 'Warlock.get' 'country+--           pure [| \$street ++ \", \" ++ \$city ++ \", \" ++ \$country |]+--       ])+--   ''Address+--   ''ShortAddress+-- @+--+-- The 'Warlock.FieldGetter' monad provides:+--+-- * 'Warlock.get' - Extract field as Template Haskell expression+-- * 'Warlock.getName' - Extract field as 'Language.Haskell.TH.Name' (advanced)+-- * Compile-time checking: references to missing fields are caught+--+-- __When to use computed fields:__+--+-- * Multiple sources, single destination+-- * Compile-time transformation+-- * Need to combine or calculate from multiple fields+--+-- == Disassembled Fields (Splitting One Into Many)+--+-- Split one source field into multiple destination fields:+--+-- @+-- data FullName = FullName { fullName :: String }+-- data SplitName = SplitName+--   { firstName :: String+--   , lastName :: String+--   }+--+-- 'deriveAutomap'+--   ('ByName' $+--     'defaultConfig'+--     \`'withRules'\`+--       ('disassembleFields' 'fullName+--         [ 'firstName 'Warlock..=' do+--             src <- 'Warlock.getSource'+--             pure [| case words \$src of (f:_) -> f; _ -> \"\" |]+--         , 'lastName 'Warlock..=' do+--             src <- 'Warlock.getSource'+--             pure [| case words \$src of (_:l:_) -> l; _ -> \"\" |]+--         ]))+--   ''FullName+--   ''SplitName+-- @+--+-- The 'Warlock.DisassembleGetter' monad provides:+--+-- * 'Warlock.getSource' - Get source field as TH expression+-- * 'Warlock.getSourceName' - Get source field as 'Language.Haskell.TH.Name'+--+-- __When to use disassembled fields:__+--+-- * Single source, multiple destinations+-- * Parsing or splitting structured data+-- * Extracting components from composite values+--+-- == Field Rule Composition+--+-- Rules can be composed using the builder pattern:+--+-- @+-- import Data.Function ((&))+--+-- -- Explicit builder style+-- rule1 = 'Warlock.field' 'balance & 'Warlock.fromField' 'balance_cents+-- rule2 = 'Warlock.field' 'region & 'Warlock.withDefault' [| \"US\" |]+--+-- -- Pre-composed helpers (more common)+-- rule3 = 'rename' 'newName 'oldName+-- rule4 = 'defaultTo' 'region [| \"US\" |]+-- @+--+-- = Constructor Mapping #constructors#+--+-- For multi-constructor ADTs (sum types), Warlock can map constructor names+-- with compile-time safety.+--+-- == Direct Constructor Mapping+--+-- Explicit constructor name mappings with compile-time checking:+--+-- @+-- data ShapeV1+--   = CircleV1 { radius :: Double }+--   | RectangleV1 { width :: Double, height :: Double }+--+-- data ShapeV2+--   = Circle { radius :: Double }+--   | Rectangle { width :: Double, height :: Double }+--+-- 'deriveAutomap'+--   ('ByName' $+--     'defaultConfig'+--     \`'withConstructorMap'\`+--       [ ('CircleV1, 'Circle)+--       , ('RectangleV1, 'Rectangle)+--       ])+--   ''ShapeV1+--   ''ShapeV2+-- @+--+-- The Template Haskell names @'CircleV1@ and @'Circle@ are checked at compile+-- time, so typos are caught immediately.+--+-- == Suffix Transformations+--+-- Common pattern: add or remove version suffixes.+--+-- @+-- data PaymentV1+--   = CardPaymentV1 { cardNumber :: String }+--   | CashPaymentV1 { amount :: Double }+--+-- data PaymentV2+--   = CardPaymentV2 { cardNumber :: String, cvv :: String }+--   | CashPaymentV2 { amount :: Double, currency :: String }+--+-- 'deriveAutomap'+--   ('ByName' $+--     'defaultConfig'+--     \`'withConstructorMap'\` 'replaceSuffix' \"V1\" \"V2\"+--     \`'withDefaults'\`+--       [ ('cvv, [| \"000\" |])+--       , ('currency, [| \"USD\" |])+--       ])+--   ''PaymentV1+--   ''PaymentV2+-- @+--+-- Available helpers:+--+-- * 'stripSuffix' @\"V1\"@ - Remove suffix: @FooV1@ → @Foo@+-- * 'addSuffix' @\"V2\"@ - Add suffix: @Foo@ → @FooV2@+-- * 'replaceSuffix' @\"V1\" \"V2\"@ - Replace: @FooV1@ → @FooV2@+--+-- == Custom Constructor Transformations+--+-- For complex patterns, provide a transformation function:+--+-- @+-- import Data.Char (toUpper)+--+-- uppercaseFirst :: String -> String+-- uppercaseFirst [] = []+-- uppercaseFirst (c:cs) = toUpper c : cs+--+-- 'deriveAutomap'+--   ('ByName' $+--     'defaultConfig'+--     \`'withConstructorMap'\` 'Warlock.Transform' uppercaseFirst)+--   ''Source+--   ''Dest+-- @+--+-- Or use a lambda directly (wrapped in 'Warlock.Transform'):+--+-- @+-- 'deriveAutomap'+--   ('ByName' $+--     'defaultConfig'+--     \`'withConstructorMap'\` 'Warlock.Transform' (++ \"_New\"))+--   ''Old+--   ''New+-- @+--+-- == Multi-Constructor ADTs with Field Evolution+--+-- Combining constructor mapping with field defaults:+--+-- @+-- data EventV1+--   = UserLoginV1 { userId :: Int, loginTime :: String }+--   | UserLogoutV1 { userId :: Int }+--   | ErrorOccurredV1 { errorMsg :: String }+--+-- data EventV2+--   = UserLoginV2 { userId :: Int, loginTime :: String, ipAddress :: String }+--   | UserLogoutV2 { userId :: Int, sessionDuration :: Int }+--   | ErrorOccurredV2 { errorMsg :: String, errorCode :: Int }+--+-- 'deriveAutomap'+--   ('ByName' $+--     'defaultConfig'+--     \`'withConstructorMap'\` 'replaceSuffix' \"V1\" \"V2\"+--     \`'withDefaults'\`+--       [ ('ipAddress, [| \"unknown\" |])+--       , ('sessionDuration, [| 0 |])+--       , ('errorCode, [| 500 |])+--       ])+--   ''EventV1+--   ''EventV2+-- @+--+-- = Type Generation with Warlock.Tweak #tweak#+--+-- @Warlock.Tweak@ generates new data types from existing ones, inspired by+-- TypeScript's utility types like @Pick\<T, K\>@ and @Omit\<T, K\>@.+--+-- == Pick: Selecting Specific Fields+--+-- Create a type with only selected fields:+--+-- @+-- import qualified Warlock.Tweak as Tweak+-- import Warlock.Tweak (pick)+--+-- data User = User+--   { userId :: Int+--   , userName :: String+--   , userEmail :: String+--   , userPassword :: String+--   , userCreatedAt :: String+--   }+--+-- -- Pick only public fields (TypeScript: Pick\<User, \"id\" | \"name\"\>)+-- pick ''User \"UserSummary\" ['userId, 'userName]+--+-- -- Generates:+-- -- data UserSummary = UserSummary+-- --   { userId :: Int+-- --   , userName :: String+-- --   }+-- -- instance From User UserSummary+-- @+--+-- == Omit: Excluding Specific Fields+--+-- Create a type excluding sensitive fields:+--+-- @+-- import Warlock.Tweak (omit)+--+-- -- Omit sensitive fields (TypeScript: Omit\<User, \"password\"\>)+-- omit ''User \"UserResponse\" ['userPassword]+--+-- -- Generates:+-- -- data UserResponse = UserResponse+-- --   { userId :: Int+-- --   , userName :: String+-- --   , userEmail :: String+-- --   , userCreatedAt :: String+-- --   }+-- -- instance From User UserResponse+-- @+--+-- == Prefix Operations with Tweak+--+-- Combine field selection with prefix transformations:+--+-- @+-- -- Strip \"user\" prefix from field names+-- pick ''User \"UserClean\" ['userId, 'userName, 'userEmail]+--   \`Tweak.stripPrefix\` \"user\"+--+-- -- Generates:+-- -- data UserClean = UserClean+-- --   { id :: Int+-- --   , name :: String+-- --   , email :: String+-- --   }+-- @+--+-- Available prefix operations:+--+-- * @\`Tweak.stripPrefix\` \"user\"@ - Remove prefix+-- * @\`Tweak.addPrefix\` \"dto\"@ - Add prefix+-- * @\`Tweak.replacePrefix\` (\"user\", \"api\")@ - Replace prefix+--+-- == Combining with Field Rules+--+-- @Warlock.Tweak@ supports all Warlock field rules:+--+-- @+-- import Warlock.Tweak (withRules)+--+-- pick ''Person \"PersonDTO\" ['fullName, 'age]+--   \`withRules\`+--   [ combineFields 'fullName $ do+--       first <- Warlock.get 'firstName+--       last <- Warlock.get 'lastName+--       pure [| \$first ++ \" \" ++ \$last |]+--   , rename 'age 'personAge+--   ]+-- @+--+-- == API Response Types+--+-- Common pattern: create response DTOs for web APIs:+--+-- @+-- data DbUser = DbUser+--   { dbUserId :: Int+--   , dbUserName :: String+--   , dbUserEmail :: String+--   , dbUserPasswordHash :: ByteString+--   , dbUserSalt :: ByteString+--   , dbUserCreatedAt :: UTCTime+--   , dbUserUpdatedAt :: UTCTime+--   }+--+-- -- Public API response (omit internal fields, strip prefix)+-- omit ''DbUser \"UserResponse\"+--   [ 'dbUserPasswordHash+--   , 'dbUserSalt+--   ]+--   \`Tweak.stripPrefix\` \"dbUser\"+--+-- -- Generates:+-- -- data UserResponse = UserResponse+-- --   { id :: Int+-- --   , name :: String+-- --   , email :: String+-- --   , createdAt :: UTCTime+-- --   , updatedAt :: UTCTime+-- --   }+-- @+--+-- = Higher-Kinded Data with Warlock.HKD #hkd#+--+-- @Warlock.HKD@ generates Higher-Kinded Data types where each field is wrapped+-- in a type constructor @f@. This enables powerful patterns for validation,+-- partial construction, and generic programming.+--+-- == Basic HKD Generation+--+-- @+-- {-\# LANGUAGE TemplateHaskell \#-}+-- {-\# LANGUAGE TypeFamilies \#-}+--+-- import Warlock.HKD+-- import Data.Functor.Identity+-- import Witch (from)+--+-- data Person = Person+--   { name :: String+--   , age :: Int+--   , email :: String+--   }+--+-- 'Warlock.HKD.deriveHKD'' ''Person+--+-- -- Generates:+-- -- data Person' f = Person'+-- --   { name :: f String+-- --   , age :: f Int+-- --   , email :: f String+-- --   }+-- -- type instance HKD Person f = Person' f+-- -- instance From (Person' Identity) Person+-- -- instance From Person (Person' Identity)+-- @+--+-- == Identity Wrapper Conversion+--+-- The primary use case: wrap and unwrap values in 'Data.Functor.Identity':+--+-- @+-- -- Wrap in Identity+-- let person = Person \"Alice\" 30 \"alice\@example.com\"+-- let hkdPerson = from person :: HKD Person Identity+--+-- -- Unwrap from Identity+-- let unwrapped = from hkdPerson :: Person+-- @+--+-- == Form Validation with Maybe+--+-- Build up values incrementally with 'Maybe', then validate:+--+-- @+-- -- Form data with optional fields+-- let formData = Person' (Just \"Bob\") Nothing (Just \"bob\@example.com\")+--              :: Person' Maybe+--+-- -- Validate: all fields must be present+-- validatePerson :: Person' Maybe -> Maybe Person+-- validatePerson (Person' (Just n) (Just a) (Just e)) = Just (Person n a e)+-- validatePerson _ = Nothing+--+-- case validatePerson formData of+--   Just person -> putStrLn \"Valid!\"+--   Nothing -> putStrLn \"Missing fields\"+-- @+--+-- == Integration with Barbies+--+-- Warlock.HKD generates types compatible with the @barbies@ library for+-- generic traversals:+--+-- @+-- {-\# LANGUAGE DeriveGeneric \#-}+-- {-\# LANGUAGE StandaloneDeriving \#-}+--+-- import qualified Barbies as B+-- import GHC.Generics (Generic)+--+-- data Person = Person+--   { name :: String+--   , age :: Int+--   }+--+-- deriveHKD' ''Person+--+-- deriving instance Generic (Person' f)+-- instance B.FunctorB Person'+-- instance B.TraversableB Person'+-- instance B.ApplicativeB Person'+--+-- -- Now use barbies operations+-- validateForm :: Person' Maybe -> Either [String] Person+-- validateForm p = case B.btraverse (maybe (Left [\"missing\"]) Right) p of+--   Left errs -> Left errs+--   Right identityPerson -> Right (from identityPerson)+-- @+--+-- == Custom HKD Configuration+--+-- Customize field and constructor naming:+--+-- @+-- -- Add \"hkd\" prefix to fields+-- deriveHKD (defaultHKDConfig \`withFieldPrefix\` \"hkd\") ''User+--+-- -- Use \"HKD\" suffix for constructor+-- deriveHKD (defaultHKDConfig \`withConstructorSuffix\` \"HKD\") ''Person+--+-- -- Generates: PersonHKD instead of Person'+-- @+--+-- = Real-World Patterns #realworld#+--+-- == API Versioning (V1 → V2 → V3)+--+-- Gracefully evolve your API over multiple versions:+--+-- @+-- -- Version 1: Initial release+-- data UserV1 = UserV1+--   { userV1Name :: String+--   , userV1Email :: String+--   }+--+-- -- Version 2: Added age field+-- data UserV2 = UserV2+--   { userV2Name :: String+--   , userV2Email :: String+--   , userV2Age :: Int+--   }+--+-- -- Version 3: Split name into first/last+-- data UserV3 = UserV3+--   { userV3FirstName :: String+--   , userV3LastName :: String+--   , userV3Email :: String+--   , userV3Age :: Int+--   }+--+-- -- V1 → V2: Add default age+-- deriveAutomap+--   (ByName $ datatypePrefixConfig+--     \`withDefaults\` [('userV2Age, [| 0 |])])+--   ''UserV1 ''UserV2+--+-- -- V2 → V3: Split name, keep other fields+-- deriveAutomap+--   (ByName $ datatypePrefixConfig+--     \`withRules\`+--       (disassembleFields 'userV2Name+--         [ 'userV3FirstName .= do+--             src <- getSource+--             pure [| case words \$src of (f:_) -> f; _ -> \"\" |]+--         , 'userV3LastName .= do+--             src <- getSource+--             pure [| case words \$src of (_:l:_) -> l; _ -> \"\" |]+--         ]))+--   ''UserV2 ''UserV3+--+-- -- Now you can chain conversions+-- upgradeToLatest :: UserV1 -> UserV3+-- upgradeToLatest v1 = from (from v1 :: UserV2)+-- @+--+-- == Database to Domain Model Conversion+--+-- Separate persistence layer from domain logic:+--+-- @+-- -- Persistent-generated database entity+-- data DbProduct = DbProduct+--   { dbProductId :: Int+--   , dbProductName :: String+--   , dbProductPriceCents :: Int+--   , dbProductCreatedAt :: UTCTime+--   }+--+-- -- Clean domain model+-- data Product = Product+--   { productId :: Int+--   , productName :: String+--   , productPrice :: Double  -- Different type!+--   }+--+-- deriveAutomap+--   (ByName $ customPrefixRules \"product\" \"dbProduct\"+--     \`withRules\`+--       [ mapField 'productPrice $ \\src _dst ->+--           [| fromIntegral (dbProductPriceCents \$(varE src)) / 100.0 |]+--       ])+--   ''DbProduct ''Product+-- @+--+-- == Request/Response DTOs+--+-- Create separate types for API requests and responses:+--+-- @+-- -- Internal domain model+-- data User = User+--   { userId :: Int+--   , userName :: String+--   , userEmail :: String+--   , userPasswordHash :: ByteString+--   , userCreatedAt :: UTCTime+--   }+--+-- -- API request (no ID, no timestamps)+-- pick ''User \"CreateUserRequest\" ['userName, 'userEmail, 'userPasswordHash]+--   \`Tweak.stripPrefix\` \"user\"+--+-- -- API response (no password)+-- omit ''User \"UserResponse\" ['userPasswordHash]+--   \`Tweak.stripPrefix\` \"user\"+--+-- -- Generates:+-- -- data CreateUserRequest = CreateUserRequest+-- --   { name :: String+-- --   , email :: String+-- --   , passwordHash :: ByteString+-- --   }+-- --+-- -- data UserResponse = UserResponse+-- --   { id :: Int+-- --   , name :: String+-- --   , email :: String+-- --   , createdAt :: UTCTime+-- --   }+-- @+--+-- == Nested Type Conversions+--+-- Warlock automatically handles nested conversions using @witch@'s @into@:+--+-- @+-- data PersonV1 = PersonV1 { age :: Int }+-- data PersonV2 = PersonV2 { age :: Integer }  -- Different type+--+-- deriveAutomap (ByName defaultConfig) ''PersonV1 ''PersonV2+--+-- -- Requires: instance From Int Integer (provided by witch)+--+-- -- For lists and other containers:+-- data TeamV1 = TeamV1 { members :: [PersonV1] }+-- data TeamV2 = TeamV2 { members :: [PersonV2] }+--+-- deriveAutomap (ByName defaultConfig) ''TeamV1 ''TeamV2+--+-- -- Requires: instance From PersonV1 PersonV2 (derived above)+-- -- Warlock uses witch's into to convert the list elements+-- @+--+-- == Multi-Step Transformations+--+-- Chain multiple transformations for complex scenarios:+--+-- @+-- -- Step 1: Generate DTO with Tweak+-- omit ''User \"UserDTO\" ['userPassword]+--   \`Tweak.stripPrefix\` \"user\"+--+-- -- Step 2: Generate HKD for validation+-- deriveHKD' ''UserDTO+--+-- -- Step 3: Use in form validation+-- validateUserForm :: UserDTO' Maybe -> Either [String] User+-- validateUserForm formData = do+--   -- Validate with barbies+--   dto <- btraverse (maybe (Left [\"missing\"]) Right) formData+--   -- Add back password (from separate secure input)+--   password <- getPasswordSecurely+--   pure $ User+--     { userId = id (from dto)+--     , userName = name (from dto)+--     , userEmail = email (from dto)+--     , userPassword = password+--     , userCreatedAt = now+--     }+-- @+--+-- = Advanced Techniques #advanced#+--+-- == Combining Tweak + HKD+--+-- Generate DTOs and their HKD versions for form handling:+--+-- @+-- data User = User+--   { userId :: Int+--   , userName :: String+--   , userEmail :: String+--   , userPassword :: String+--   }+--+-- -- Step 1: Create DTO (omit ID)+-- omit ''User \"UserForm\" ['userId]+--   \`Tweak.stripPrefix\` \"user\"+--+-- -- Step 2: Generate HKD for partial form data+-- deriveHKD' ''UserForm+--+-- -- Usage:+-- emptyForm :: UserForm' Maybe+-- emptyForm = UserForm' Nothing Nothing Nothing+--+-- fillName :: String -> UserForm' Maybe -> UserForm' Maybe+-- fillName n form = form { name = Just n }+-- @+--+-- == Custom Rule Generators+--+-- Create reusable field rule generators for your domain:+--+-- @+-- -- Rule generator for monetary fields (cents to dollars)+-- moneyFieldRules :: RuleGenContext -> String -> Maybe FieldRule+-- moneyFieldRules _ctx dstField+--   | \"price\" \`isPrefixOf\` dstField = Just $ mapField (mkName dstField) $+--       \\src _dst -> [| fromIntegral \$(varE src) / 100.0 |]+--   | \"cost\" \`isPrefixOf\` dstField = Just $ mapField (mkName dstField) $+--       \\src _dst -> [| fromIntegral \$(varE src) / 100.0 |]+--   | otherwise = Nothing+--+-- deriveAutomap+--   (ByName $ defaultConfig+--     \`withRuleGens\` [datatypePrefixRules, moneyFieldRules])+--   ''DbProduct ''Product+-- @+--+-- == Parameterized Types+--+-- Handle types with type parameters:+--+-- @+-- data Container a = Container { value :: a }+-- data Box a = Box { contents :: a }+--+-- -- Use deriveAutomapWith with concrete types+-- deriveAutomapWith (ByName defaultConfig)+--   [t| Container Int |]+--   [t| Box Int |]+--+-- -- Or derive for polymorphic case (if structures match)+-- deriveAutomap (ByName defaultConfig)+--   ''Container ''Box+-- @+--+-- == Performance Considerations+--+-- Warlock generates code at compile time, so there's zero runtime overhead+-- beyond the conversion logic itself. However, keep these in mind:+--+-- * __Compile times__: Large types or many derivations increase TH compile time+-- * __Code size__: Each derivation generates instance code (negligible impact)+-- * __Field rules__: Computed fields add expression complexity+-- * __Nested conversions__: Deep nesting may impact conversion performance+--+-- Tips for large codebases:+--+-- * Group related derivations in separate modules+-- * Use @ByPosition@ for simple positional types (simpler generated code)+-- * Profile if performance is a concern (usually not an issue)+--+-- = Troubleshooting Guide #troubleshooting#+--+-- == Common Compile Errors+--+-- === \"No instance for From ...\"+--+-- __Problem:__ Warlock uses @witch@'s @into@ for nested conversions.+--+-- @+-- -- Error: No instance for From Int String+-- data A = A { field :: Int }+-- data B = B { field :: String }+-- deriveAutomap (ByName defaultConfig) ''A ''B+-- @+--+-- __Solution:__ Provide the missing From instance or use a field rule:+--+-- @+-- deriveAutomap+--   (ByName $ defaultConfig+--     \`withRules\`+--       [ mapField 'field $ \\src _dst -> [| show \$(varE src) |]+--       ])+--   ''A ''B+-- @+--+-- === \"Field not found in source type\"+--+-- __Problem:__ Destination field has no corresponding source field.+--+-- __Solution:__ Add a default value or compute it:+--+-- @+-- deriveAutomap+--   (ByName $ defaultConfig \`withDefaults\` [('newField, [| defaultValue |])])+--   ''Source ''Dest+-- @+--+-- === \"Constructor count mismatch\"+--+-- __Problem:__ ByPosition requires same number of constructors.+--+-- __Solution:__ Use ByName instead, or ensure constructor counts match.+--+-- === \"Cannot mix record and positional constructors\"+--+-- __Problem:__ One type uses records, the other uses positional constructors.+--+-- __Solution:__ Both types must use the same constructor style (or use ByPosition+-- for both if they're positional).+--+-- == Debugging Generated Code+--+-- To see what code Warlock generates, use GHC's @-ddump-splices@ flag:+--+-- @+-- stack build --ghc-options=-ddump-splices+-- cabal build --ghc-options=-ddump-splices+-- @+--+-- This shows the full generated instance code, helpful for understanding+-- compilation errors.+--+-- == Type Inference Issues+--+-- Sometimes GHC needs type annotations when using @from@:+--+-- @+-- -- Ambiguous:+-- let x = from myValue+--+-- -- Fixed with type annotation:+-- let x = from myValue :: TargetType+--+-- -- Or using TypeApplications:+-- let x = from \@SourceType \@TargetType myValue+-- @+--+-- == When to Use Qualified Imports+--+-- Some Warlock names might conflict with your code:+--+-- @+-- -- Recommended for Tweak (many common names)+-- import qualified Warlock.Tweak as Tweak+--+-- -- Use: Tweak.pick, Tweak.omit, Tweak.stripPrefix+--+-- -- Main Warlock module usually doesn't need qualification+-- import Warlock+-- @+--+-- = Conclusion+--+-- You now have a comprehensive understanding of Warlock's capabilities!+--+-- __Key Takeaways:__+--+-- * Use 'ByName' for records, 'ByPosition' for positional types+-- * Leverage pre-built configs: 'datatypePrefixConfig', 'snakeToCamelConfig'+-- * Virtual fields for runtime computation, computed fields for compile-time+-- * @Warlock.Tweak@ for generating DTOs (@pick@/@omit@)+-- * @Warlock.HKD@ for validation and partial construction+-- * Combine features for powerful real-world patterns+--+-- __Next Steps:__+--+-- * Explore the main "Warlock" module documentation+-- * Check out "Warlock.Tweak" for DTO generation+-- * Learn about "Warlock.HKD" for HKD patterns+-- * Read the README for quick reference+--+-- Happy mapping! 🧙++module Warlock.Tutorial () where++-- This module is documentation-only. All exports are from Warlock, Warlock.Tweak, and Warlock.HKD.+
+ src/Warlock/Tweak.hs view
@@ -0,0 +1,633 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+-- |+-- Module      : Warlock.Tweak+-- Description : Generate new data types from existing ones with modifications+-- License     : MIT+--+-- = Overview+--+-- @Warlock.Tweak@ allows you to derive new data types from existing ones by+-- specifying field modifications (selection, renaming, prefix operations).+-- It automatically generates the new type and optionally creates 'Warlock.From'+-- instances between the source and derived types.+--+-- = Quick Example+--+-- @+-- {-# LANGUAGE TemplateHaskell #-}+-- import Warlock.Tweak+--+-- data User = User+--   { userId :: Int+--   , userName :: String+--   , userEmail :: String+--   , userPassword :: ByteString+--   }+--+-- -- Generate DTO without sensitive fields+-- tweakType+--   (DropFrom $ defaultTweakConfig+--     \`withoutFields\` ['userPassword]+--     \`stripPrefix\` "user")+--   "UserDTO"+--   ''User+--+-- -- Generates:+-- -- data UserDTO = UserDTO+-- --   { id :: Int+-- --   , name :: String+-- --   , email :: String+-- --   }+-- -- derive (ByName config) ''User ''UserDTO+-- @+--+-- = Use Cases+--+-- * **DTOs**: Create API response/request types from database entities+-- * **Projections**: Subset of fields for specific use cases+-- * **API Versioning**: Generate V1/V2 types with field evolution+-- * **Type Refinement**: Create more specific types by dropping optional fields+--+-- = Advanced Field Rules+--+-- Warlock.Tweak now supports all Warlock field rules including:+--+-- * 'combineFields' - Combine multiple source fields into one+-- * 'disassembleFields' - Split one source field into multiple+-- * 'mapField' - Apply custom transformations to fields+-- * 'virtualField' - Use HasField for dynamic field access+-- * 'computedField' - Compute field values from expressions+--+-- @+-- -- Combine firstName and lastName into fullName:+-- pick ''Person "PersonDTO" ['fullName, 'age] \`withRules\`+--   [ combineFields 'fullName $ do+--       first <- get 'firstName+--       last <- get 'lastName+--       pure [| $first ++ \" \" ++ $last |]+--   ]+--+-- -- Transform email to lowercase:+-- omit ''User "PublicUser" ['password] \`withRules\`+--   [ mapField 'email (\src _dst -> [| map toLower $(varE src) |])+--   ]+-- @+--+-- = Configuration+--+-- Configuration is composable using helper functions:+--+-- @+-- defaultTweakConfig+--   \`withFields\` ['field1, 'field2]        -- Keep only these+--   \`withRenames\` [('oldName, 'newName)]   -- Explicit renames+--   \`stripPrefix\` "user"                   -- Remove prefix from all fields+--   \`withAutoDerive\` False                 -- Disable automatic instance generation+-- @++module Warlock.Tweak+  ( -- * Type Derivation (TypeScript-style)+    pick+  , omit+  , pick'+  , omit'++    -- * Legacy API+  , tweakType+  , TweakStrategy(..)++    -- * Configuration+  , TweakConfig(..)+  , defaultTweakConfig+  , FieldSelector(..)+  , PrefixOp(..)++    -- * Configuration Helpers+  , withFields+  , withoutFields+  , withRenames+  , withPrefixOps+  , withAutoDerive+  , withRules+  , withDefaults+  , withNormalize+  , withRuleGens++    -- * Prefix Operations+  , stripPrefix+  , addPrefix+  , replacePrefix++    -- * Re-exports from Warlock (Field Rules)+  , Warlock.FieldRule+  , Warlock.rename+  , Warlock.defaultTo+  , Warlock.ignore+  , Warlock.mapField+  , Warlock.virtualField+  , Warlock.computedField+  , Warlock.combineFields+  , Warlock.disassembleFields+  , Warlock.DisassembledField+  , (Warlock..=)++    -- * Field Getters+  , Warlock.FieldGetter+  , Warlock.get+  , Warlock.getName+  , Warlock.DisassembleGetter+  , Warlock.getSource+  , Warlock.getSourceName++    -- * Name Normalizers+  , Warlock.snakeToCamel+  , Warlock.camelToSnake+  , Warlock.lowerFirst++    -- * Field Rule Generators+  , Warlock.datatypePrefixRules+  , Warlock.constructorPrefixRules+  , Warlock.customPrefixRules+  , Warlock.RuleGenContext(..)+  ) where++import Language.Haskell.TH+import Control.Monad (when, forM)+import Data.List (isPrefixOf)+import Data.Char (toLower, toUpper)+import qualified Warlock++--------------------------------------------------------------------------------+-- Core Types++-- | Strategy for deriving a new type from an existing one.+data TweakStrategy+  = KeepOnly TweakConfig   -- ^ Keep only specified fields+  | DropFrom TweakConfig   -- ^ Drop specified fields, keep rest+  | TransformWith TweakConfig  -- ^ Reserved for future type transformations++-- | Configuration for type derivation.+--+-- Build configurations using 'defaultTweakConfig' and helper functions:+--+-- @+-- defaultTweakConfig+--   \`withFields\` ['field1, 'field2]+--   \`stripPrefix\` "user"+-- @+data TweakConfig = TweakConfig+  { fieldSelector :: FieldSelector+    -- ^ Which fields to select/keep+  , warlockConfig :: Warlock.Config+    -- ^ Embedded Warlock configuration for field rules+  , autoDerive :: Bool+    -- ^ Whether to automatically generate From instances (default: True)+  }++-- | Selector for which fields to include.+data FieldSelector+  = AllFields+    -- ^ Select all fields (used with DropFrom)+  | SelectFields [Name]+    -- ^ Select only these specific fields (used with KeepOnly)+  deriving (Show, Eq)++-- | Prefix operations that can be applied to field names.+data PrefixOp+  = StripPrefix String+    -- ^ Remove prefix from field names+  | AddPrefix String+    -- ^ Add prefix to field names+  | ReplacePrefix String String+    -- ^ Replace one prefix with another+  deriving (Show, Eq)++--------------------------------------------------------------------------------+-- Default Configuration++-- | Default configuration: all fields, no renames, no prefix ops, auto-derive enabled.+defaultTweakConfig :: TweakConfig+defaultTweakConfig = TweakConfig+  { fieldSelector = AllFields+  , warlockConfig = Warlock.defaultConfig+  , autoDerive = True+  }++--------------------------------------------------------------------------------+-- Configuration Helpers++-- | Keep only the specified fields.+--+-- @+-- defaultTweakConfig \`withFields\` ['userId, 'userName]+-- @+withFields :: TweakConfig -> [Name] -> TweakConfig+withFields cfg fields = cfg { fieldSelector = SelectFields fields }++-- | Drop the specified fields (inverse of 'withFields').+--+-- @+-- defaultTweakConfig \`withoutFields\` ['userPassword, 'userCreatedAt]+-- @+withoutFields :: TweakConfig -> [Name] -> TweakConfig+withoutFields cfg fields = cfg { fieldSelector = SelectFields fields }++-- | Add explicit field renames.+--+-- @+-- defaultTweakConfig \`withRenames\` [('userId, 'id), ('userName, 'name)]+-- @+withRenames :: TweakConfig -> [(Name, Name)] -> TweakConfig+withRenames cfg renames = cfg { warlockConfig = Warlock.withRenames (warlockConfig cfg) renames }++-- | Set prefix operations (legacy support - now implemented via Warlock normalize).+--+-- @+-- defaultTweakConfig \`withPrefixOps\` [StripPrefix "user", AddPrefix "dto"]+-- @+withPrefixOps :: TweakConfig -> [PrefixOp] -> TweakConfig+withPrefixOps cfg ops =+  let oldNormalize = Warlock.normalize (warlockConfig cfg)+      newNormalize = composePrefixOps oldNormalize ops+  in cfg { warlockConfig = Warlock.withNormalize (warlockConfig cfg) newNormalize }+  where+    composePrefixOps :: (String -> String) -> [PrefixOp] -> (String -> String)+    composePrefixOps baseNorm ops' s = foldl applyOp (baseNorm s) ops'++    applyOp :: String -> PrefixOp -> String+    applyOp name (StripPrefix prefix) =+      if prefix `isPrefixOf` name+        then lowercaseFirst2 $ drop (length prefix) name+        else name+    applyOp name (AddPrefix prefix) = prefix ++ uppercaseFirst2 name+    applyOp name (ReplacePrefix old new) =+      if old `isPrefixOf` name+        then new ++ uppercaseFirst2 (drop (length old) name)+        else name++    lowercaseFirst2 :: String -> String+    lowercaseFirst2 [] = []+    lowercaseFirst2 (c:cs) = toLower c : cs++    uppercaseFirst2 :: String -> String+    uppercaseFirst2 [] = []+    uppercaseFirst2 (c:cs) = toUpper c : cs++-- | Enable or disable automatic instance generation.+--+-- @+-- defaultTweakConfig \`withAutoDerive\` False+-- @+withAutoDerive :: TweakConfig -> Bool -> TweakConfig+withAutoDerive cfg enabled = cfg { autoDerive = enabled }++-- | Add custom field rules (combineFields, disassembleFields, mapField, etc.).+--+-- @+-- defaultTweakConfig \`withRules\`+--   [ combineFields 'fullName $ do+--       first <- get 'firstName+--       last <- get 'lastName+--       pure [| $first ++ " " ++ $last |]+--   , mapField 'email (\src _dst -> [| toLower <$> $(varE src) |])+--   ]+-- @+withRules :: TweakConfig -> [Warlock.FieldRule] -> TweakConfig+withRules cfg rules = cfg { warlockConfig = Warlock.withRules (warlockConfig cfg) rules }++-- | Add default values for new fields.+--+-- @+-- defaultTweakConfig \`withDefaults\` [('newField, [| \"default\" |])]+-- @+withDefaults :: TweakConfig -> [(Name, Q Exp)] -> TweakConfig+withDefaults cfg defaults = cfg { warlockConfig = Warlock.withDefaults (warlockConfig cfg) defaults }++-- | Set the field name normalization function.+--+-- @+-- defaultTweakConfig \`withNormalize\` snakeToCamel+-- @+withNormalize :: TweakConfig -> (String -> String) -> TweakConfig+withNormalize cfg f = cfg { warlockConfig = Warlock.withNormalize (warlockConfig cfg) f }++-- | Set field rule generators.+--+-- @+-- defaultTweakConfig \`withRuleGens\` [datatypePrefixRules]+-- @+withRuleGens :: TweakConfig -> [Warlock.RuleGenContext -> String -> Maybe Warlock.FieldRule] -> TweakConfig+withRuleGens cfg gens = cfg { warlockConfig = Warlock.withRuleGens (warlockConfig cfg) gens }++--------------------------------------------------------------------------------+-- Convenience Functions++-- | Strip a prefix from all field names.+--+-- @+-- defaultTweakConfig \`stripPrefix\` "user"  -- userName -> name+-- @+stripPrefix :: TweakConfig -> String -> TweakConfig+stripPrefix cfg prefix = withPrefixOps cfg [StripPrefix prefix]++-- | Add a prefix to all field names.+--+-- @+-- defaultTweakConfig \`addPrefix\` "dto"  -- name -> dtoName+-- @+addPrefix :: TweakConfig -> String -> TweakConfig+addPrefix cfg prefix = withPrefixOps cfg [AddPrefix prefix]++-- | Replace one prefix with another.+--+-- @+-- defaultTweakConfig \`replacePrefix\` ("user", "dto")  -- userName -> dtoName+-- @+replacePrefix :: TweakConfig -> (String, String) -> TweakConfig+replacePrefix cfg (old, new) = withPrefixOps cfg [ReplacePrefix old new]++--------------------------------------------------------------------------------+-- TypeScript-style API++-- | Pick specific fields from a type to create a new type.+--+-- Similar to TypeScript's @Pick<T, K>@ utility type.+--+-- @+-- data User = User+--   { userId :: Int+--   , userName :: String+--   , userEmail :: String+--   , userPassword :: String+--   }+--+-- -- Pick only id and name fields+-- pick ''User "UserSummary" ['userId, 'userName]+--+-- -- With additional config+-- pick ''User "UserDTO" ['userId, 'userName, 'userEmail]+--   \`stripPrefix\` "user"+-- @+pick+  :: Name          -- ^ Source type+  -> String        -- ^ New type name+  -> [Name]        -- ^ Fields to pick+  -> Q [Dec]+pick sourceType newTypeName fields =+  tweakType (KeepOnly $ defaultTweakConfig `withFields` fields) newTypeName sourceType++-- | Omit specific fields from a type to create a new type.+--+-- Similar to TypeScript's @Omit<T, K>@ utility type.+--+-- @+-- data User = User+--   { userId :: Int+--   , userName :: String+--   , userEmail :: String+--   , userPassword :: String+--   }+--+-- -- Omit sensitive fields+-- omit ''User "UserDTO" ['userPassword]+--+-- -- With additional config+-- omit ''User "UserResponse" ['userPassword, 'userCreatedAt]+--   \`addPrefix\` "dto"+-- @+omit+  :: Name          -- ^ Source type+  -> String        -- ^ New type name+  -> [Name]        -- ^ Fields to omit+  -> Q [Dec]+omit sourceType newTypeName fields =+  tweakType (DropFrom $ defaultTweakConfig `withoutFields` fields) newTypeName sourceType++-- | Configuration-first version of 'pick' for use with config helpers.+--+-- @+-- pick' (defaultTweakConfig \`stripPrefix\` "user") ''User "UserClean" ['userName, 'userEmail]+-- @+pick'+  :: TweakConfig   -- ^ Configuration+  -> Name          -- ^ Source type+  -> String        -- ^ New type name+  -> [Name]        -- ^ Fields to pick+  -> Q [Dec]+pick' config sourceType newTypeName fields =+  tweakType (KeepOnly $ config `withFields` fields) newTypeName sourceType++-- | Configuration-first version of 'omit' for use with config helpers.+--+-- @+-- omit' (defaultTweakConfig \`addPrefix\` "dto") ''User "UserDTO" ['userPassword]+-- @+omit'+  :: TweakConfig   -- ^ Configuration+  -> Name          -- ^ Source type+  -> String        -- ^ New type name+  -> [Name]        -- ^ Fields to omit+  -> Q [Dec]+omit' config sourceType newTypeName fields =+  tweakType (DropFrom $ config `withoutFields` fields) newTypeName sourceType++--------------------------------------------------------------------------------+-- Main API (Legacy)++-- | Generate a new data type from an existing one with modifications.+--+-- @+-- -- Drop sensitive fields+-- tweakType (DropFrom $ defaultTweakConfig \`withoutFields\` ['userPassword])+--           "UserDTO"+--           ''User+--+-- -- Keep only specific fields+-- tweakType (KeepOnly $ defaultTweakConfig \`withFields\` ['userId, 'userName])+--           "UserMinimal"+--           ''User+-- @+tweakType+  :: TweakStrategy  -- ^ How to select/modify fields+  -> String         -- ^ New type name+  -> Name          -- ^ Source type name+  -> Q [Dec]       -- ^ Generated: data type + optional From instances+tweakType strategy newTypeName sourceTypeName = do+  -- Extract source type info+  sourceInfo <- reify sourceTypeName+  (sourceConName, sourceFields) <- extractFieldsWithCon sourceInfo++  -- Get config from strategy+  let config = case strategy of+        KeepOnly cfg -> cfg+        DropFrom cfg -> cfg+        TransformWith cfg -> cfg++  -- Apply field selection+  selectedFields <- applyFieldSelection strategy sourceFields++  -- Apply field renames+  renamedFields <- applyFieldRenames config selectedFields++  -- Generate new data type+  let newTypeNameQ = mkName newTypeName+  newTypeDec <- generateDataType newTypeNameQ renamedFields++  -- Generate Warlock instances if enabled+  instanceDecs <- if autoDerive config+    then generateInstances config sourceTypeName sourceConName newTypeNameQ selectedFields renamedFields+    else pure []++  pure $ newTypeDec : instanceDecs++--------------------------------------------------------------------------------+-- Implementation: Extract Source Type Info++extractFieldsWithCon :: Info -> Q (Name, [(Name, Bang, Type)])+extractFieldsWithCon info = case info of+  TyConI (DataD _ _ _ _ [RecC conName fields] _) ->+    pure (conName, fields)+  TyConI (NewtypeD _ _ _ _ (RecC conName fields) _) ->+    pure (conName, fields)+  TyConI (DataD _ _ _ _ [NormalC conName _fields] _) ->+    fail $ "Warlock.Tweak does not support positional constructors. "+        ++ "Constructor " ++ nameBase conName ++ " has no named fields."+  TyConI (DataD _ _ _ _ cons _) | length cons > 1 ->+    fail $ "Warlock.Tweak does not support multi-constructor ADTs (yet). "+        ++ "Found " ++ show (length cons) ++ " constructors."+  TyConI (DataD _ _ _ _ [] _) ->+    fail "Warlock.Tweak: Source type has no constructors."+  _ -> fail $ "Warlock.Tweak: Cannot derive from " ++ show info++--------------------------------------------------------------------------------+-- Implementation: Field Selection++applyFieldSelection :: TweakStrategy -> [(Name, Bang, Type)] -> Q [(Name, Bang, Type)]+applyFieldSelection strategy sourceFields =+  case strategy of+    KeepOnly cfg -> case fieldSelector cfg of+      AllFields -> pure sourceFields+      SelectFields names -> do+        let fieldMap = [(fname, (fname, b, ty)) | (fname, b, ty) <- sourceFields]+        forM names $ \fieldName ->+          case lookup fieldName fieldMap of+            Just field -> pure field+            Nothing -> fail $ "Field '" ++ nameBase fieldName ++ "' not found in source type"++    DropFrom cfg -> case fieldSelector cfg of+      AllFields -> pure sourceFields+      SelectFields namesToDrop -> do+        let shouldKeep (fname, _, _) = fname `notElem` namesToDrop+        pure $ filter shouldKeep sourceFields++    TransformWith _ ->+      fail "TransformWith strategy not yet implemented"++--------------------------------------------------------------------------------+-- Implementation: Field Renaming++applyFieldRenames :: TweakConfig -> [(Name, Bang, Type)] -> Q [(Name, Bang, Type)]+applyFieldRenames TweakConfig{..} inputFields = do+  -- Apply field transformations:+  -- 1. First check for explicit renames in staticRules+  -- 2. Then apply the normalize function for prefix operations++  let staticRules = Warlock.staticRules warlockConfig+      normalize = Warlock.normalize warlockConfig++      -- Build a map of explicit renames from staticRules+      -- In Warlock, a rename rule stores dst (populated field) and src (source field)+      -- For Tweak, we use renames to transform field names, so we reverse the mapping:+      -- the rule's dst is the OLD name (what we're renaming FROM)+      -- the rule's src is the NEW name (what we're renaming TO)+      explicitRenameMap =+        [ (dstName, srcName)  -- dst is old name, src is new name+        | rule <- staticRules+        , let dstName = Warlock.dst rule+        , Just (Warlock.RealField srcName) <- [Warlock.src rule]+        ]++      transformedFields = map applyTransform inputFields++      applyTransform :: (Name, Bang, Type) -> (Name, Bang, Type)+      applyTransform (fname, b, ty) =+        -- First check for explicit rename+        case lookup fname explicitRenameMap of+          Just newName -> (newName, b, ty)+          Nothing ->+            -- Otherwise apply normalize function+            let normalized = normalize (nameBase fname)+            in (mkName normalized, b, ty)++  -- Check for name collisions+  checkNameCollisions transformedFields++  pure transformedFields+  where++    checkNameCollisions :: [(Name, Bang, Type)] -> Q ()+    checkNameCollisions flds = do+      let names = map (\(n, _, _) -> nameBase n) flds+      let duplicates = findDuplicates names+      when (not $ null duplicates) $+        fail $ "Warlock.Tweak: Field name collision after renaming: "+            ++ show duplicates++    findDuplicates :: Eq a => [a] -> [a]+    findDuplicates [] = []+    findDuplicates (x:xs)+      | x `elem` xs = x : findDuplicates xs+      | otherwise = findDuplicates xs++--------------------------------------------------------------------------------+-- Implementation: Generate Data Type++generateDataType :: Name -> [(Name, Bang, Type)] -> Q Dec+generateDataType typeName fields = do+  let conName = typeName  -- Constructor name same as type name+  let conDec = RecC conName fields+  pure $ DataD [] typeName [] Nothing [conDec] []++--------------------------------------------------------------------------------+-- Implementation: Generate Warlock Instances++generateInstances+  :: TweakConfig+  -> Name  -- Source type+  -> Name  -- Source constructor+  -> Name  -- New type+  -> [(Name, Bang, Type)]  -- Source fields (before renaming)+  -> [(Name, Bang, Type)]  -- New fields (after renaming)+  -> Q [Dec]+generateInstances TweakConfig{..} sourceType sourceConName newType sourceFields newFields = do+  -- For Tweak, we need to create explicit rename rules for each field since the+  -- destination fields may have been renamed (e.g., userId -> dtoUserId).+  -- We create a config with identity normalization and explicit field mappings.+  --+  -- sourceFields and newFields are parallel arrays (same length, same order):+  -- sourceFields are the selected fields from the source type (before renaming)+  -- newFields are those same fields after applying field transformations++  let existingRules = Warlock.staticRules warlockConfig+      -- Extract destination field names from existing rules+      existingDstFields = [Warlock.dst r | r <- existingRules]++      -- Only add positional renames for fields that don't have explicit rules+      automaticRules =+        [ Warlock.rename destName srcName+        | ((srcName, _, _), (destName, _, _)) <- zip sourceFields newFields+        , destName `notElem` existingDstFields  -- Don't override explicit rules+        ]++      -- Use the warlock config but add automatic renames and set normalize to identity+      -- (since we've already applied transformations to the field names)+      tweakInstanceConfig = warlockConfig+        { Warlock.staticRules = existingRules ++ automaticRules+        , Warlock.normalize = id+        }++  inst <- Warlock.resolveFieldRulesAndBuildInstance tweakInstanceConfig sourceType sourceConName sourceFields newType newType newFields++  pure [inst]+
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Warlock/ADTSpec.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DuplicateRecordFields #-}+module Warlock.ADTSpec (spec) where++import Test.Hspec+import qualified Witch as W+import Warlock++-- Multi-constructor ADT with positional constructors+data Shape+  = CircleShape Double+  | RectangleShape Double Double+  | TriangleShape Double Double Double+  deriving (Show, Eq)++data ShapeInfo+  = CircleInfo Double+  | RectangleInfo Double Double+  | TriangleInfo Double Double Double+  deriving (Show, Eq)++deriveAutomap+  ( ByName $ defaultConfig+    `withConstructorMap`+    [ ('CircleShape, 'CircleInfo)+    , ('RectangleShape, 'RectangleInfo)+    , ('TriangleShape, 'TriangleInfo)+    ]+  )+  ''Shape+  ''ShapeInfo++-- Field evolution example+data PaymentV1+  = CardPaymentV1 { cardNumber :: String, expiry :: String }+  | BankPaymentV1 { accountNumber :: String, routing :: String, bankName :: String }+  | CashPaymentV1 { amount :: Double }+  deriving (Show, Eq)++data PaymentV2+  = CardPaymentV2 { cardNumber :: String, expiry :: String, cvv :: String, cardholderName :: String }+  | BankPaymentV2 { accountNumber :: String, routing :: String }+  | CashPaymentV2 { amount :: Double, currency :: String, receiptNumber :: String }+  deriving (Show, Eq)++deriveAutomap+  ( ByName $+    defaultConfig+    `withConstructorMap` replaceSuffix "V1" "V2"+    `withDefaults`+    [ ('cvv, [| "000" |])+    , ('cardholderName, [| "Unknown" |])+    , ('currency, [| "USD" |])+    , ('receiptNumber, [| "N/A" |])+    ]+  )+  ''PaymentV1+  ''PaymentV2++spec :: Spec+spec = do+  describe "Multi-constructor ADTs" $ do+    it "maps positional constructors by position" $ do+      let circle = CircleShape 5.0+      let circleInfo = W.from circle :: ShapeInfo+      circleInfo `shouldBe` CircleInfo 5.0++    it "handles multiple constructors with different arities" $ do+      let rect = RectangleShape 3.0 4.0+      let rectInfo = W.from rect :: ShapeInfo+      rectInfo `shouldBe` RectangleInfo 3.0 4.0++      let tri = TriangleShape 3.0 4.0 5.0+      let triInfo = W.from tri :: ShapeInfo+      triInfo `shouldBe` TriangleInfo 3.0 4.0 5.0++  describe "Field evolution" $ do+    it "adds new fields with defaults" $ do+      let cardV1 = CardPaymentV1 "1234-5678" "12/25"+      let cardV2 = W.from cardV1 :: PaymentV2+      case cardV2 of+        CardPaymentV2 num exp cvv holder -> do+          num `shouldBe` "1234-5678"+          exp `shouldBe` "12/25"+          cvv `shouldBe` "000"+          holder `shouldBe` "Unknown"+        _ -> expectationFailure "Expected CardPaymentV2"++    it "removes fields silently" $ do+      let bankV1 = BankPaymentV1 "9876543210" "123456789" "BigBank"+      let bankV2 = W.from bankV1 :: PaymentV2+      case bankV2 of+        BankPaymentV2 acct rout -> do+          acct `shouldBe` "9876543210"+          rout `shouldBe` "123456789"+        _ -> expectationFailure "Expected BankPaymentV2"++    it "handles multiple new fields" $ do+      let cashV1 = CashPaymentV1 100.5+      let cashV2 = W.from cashV1 :: PaymentV2+      case cashV2 of+        CashPaymentV2 amt curr receipt -> do+          amt `shouldBe` 100.5+          curr `shouldBe` "USD"+          receipt `shouldBe` "N/A"+        _ -> expectationFailure "Expected CashPaymentV2"+
+ test/Warlock/AutoSpec.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Warlock.AutoSpec (spec) where++import Test.Hspec+import qualified Witch as W+import Warlock++-- Test types for basic field mapping+data Foobert = Foobert+  { foobertName :: String+  , foobertAge :: Int+  } deriving (Show, Eq)++data Barfoo = Barfoo+  { barfooName :: String+  , barfooAge :: Int+  } deriving (Show, Eq)++deriveAutomap (ByName datatypePrefixConfig) ''Foobert ''Barfoo+deriveAutomap (ByName datatypePrefixConfig) ''Barfoo ''Foobert++-- Test types for constructor prefix rules+data Person = Person+  { personFirstName :: String+  , personLastName :: String+  , personAge :: Int+  } deriving (Show, Eq)++data Employee = Employee+  { empFirstName :: String+  , empLastName :: String+  , empAge :: Int+  } deriving (Show, Eq)++deriveAutomap+  ( ByName $ defaultConfig { ruleGens = [customPrefixRules "emp" "person"] } )+  ''Person+  ''Employee++-- Test types for positional constructors+data Point2D = Point2D Int Int deriving (Show, Eq)+data Vector2D = Vector2D Int Int deriving (Show, Eq)++deriveAutomap (ByName defaultConfig) ''Point2D ''Vector2D++spec :: Spec+spec = do+  describe "Basic AutoMap functionality" $ do+    it "maps between records with datatype prefix rules" $ do+      let foobert = Foobert "Alice" 30+      let barfoo = W.from foobert :: Barfoo+      barfoo `shouldBe` Barfoo "Alice" 30++    it "maps between records with constructor prefix rules" $ do+      let person = Person "Bob" "Smith" 25+      let employee = W.from person :: Employee+      employee `shouldBe` Employee "Bob" "Smith" 25++    it "maps between positional constructors" $ do+      let point = Point2D 3 4+      let vector = W.from point :: Vector2D+      vector `shouldBe` Vector2D 3 4++  describe "Bidirectional mapping" $ do+    it "can map back and forth" $ do+      let original = Foobert "Test" 42+      let converted = W.from original :: Barfoo+      let back = W.from converted :: Foobert+      back `shouldBe` original+
+ test/Warlock/ComposableRulesSpec.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Warlock.ComposableRulesSpec (spec) where++import Data.Function ((&))+import Test.Hspec+import Warlock+import qualified Witch as W++-- Test the new composable field rule API+data Source = Source+  { srcBalance :: Int+  , srcName :: String+  , srcStatus :: String+  } deriving (Show, Eq)++data Dest = Dest+  { balance :: Int+  , displayName :: String+  , status :: String+  , region :: String+  } deriving (Show, Eq)++-- Demonstrate composable field rules+deriveAutomap+  ( ByName $+    defaultConfig+    `withRules`+    [ field 'balance & fromField 'srcBalance+    , field 'displayName & fromField 'srcName+    , field 'status & fromField 'srcStatus+    , field 'region & withDefault [| "US" |]+    ]+  )+  ''Source+  ''Dest++-- Test combining modifiers+data ComplexSource = ComplexSource+  { oldBalance :: Int+  , oldName :: String+  } deriving (Show, Eq)++data ComplexDest = ComplexDest+  { newBalance :: Int+  , newName :: String+  } deriving (Show, Eq)++deriveAutomap+  ( ByName $+    defaultConfig+    `withRules`+    [ field 'newBalance & fromField 'oldBalance & withDefault [| 0 |]+    , field 'newName & fromField 'oldName & withDefault [| "Unknown" |]+    ]+  )+  ''ComplexSource+  ''ComplexDest++spec :: Spec+spec = do+  describe "Composable Field Rules" $ do+    describe "Basic composition" $ do+      it "allows chaining 'from' modifier" $ do+        let src = Source 100 "Alice" "active"+            dst = W.from src :: Dest+        dst `shouldBe` Dest 100 "Alice" "active" "US"++      it "supports withDefault modifier" $ do+        let src = Source 50 "Bob" "inactive"+            dst = W.from src :: Dest+        region dst `shouldBe` "US"++    describe "Combined modifiers" $ do+      it "allows chaining from and withDefault" $ do+        let src = ComplexSource 200 "Charlie"+            dst = W.from src :: ComplexDest+        dst `shouldBe` ComplexDest 200 "Charlie"++      it "uses default when combining modifiers" $ do+        let src = ComplexSource 0 ""+            dst = W.from src :: ComplexDest+        newBalance dst `shouldBe` 0+        newName dst `shouldBe` ""++    describe "Mixing composable and pre-composed styles" $ do+      it "both styles work together" $ do+        let src = Source 300 "David" "pending"+            dst = W.from src :: Dest+        balance dst `shouldBe` 300+        displayName dst `shouldBe` "David"+        status dst `shouldBe` "pending"+        region dst `shouldBe` "US"+
+ test/Warlock/ComputedFieldsSpec.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Warlock.ComputedFieldsSpec (spec) where++import Test.Hspec+import qualified Witch as W+import Warlock++-- Combining multiple source fields into one destination field+data PersonV1 = PersonV1+  { firstName :: String+  , lastName :: String+  , age :: Int+  } deriving (Show, Eq)++data PersonV2 = PersonV2+  { fullName :: String+  , personAge :: Int+  } deriving (Show, Eq)++deriveAutomap+  ( ByName $+    defaultConfig+    `withRules`+    [ combineFields 'fullName $ do+        firstName <- get 'firstName+        lastName <- get 'lastName+        pure [| $firstName ++ " " ++ $lastName |]+    , rename 'personAge 'age+    ]+  )+  ''PersonV1+  ''PersonV2++-- Multiple computed fields+data ProductV1 = ProductV1+  { itemName :: String+  , unitPrice :: Double+  , quantity :: Int+  } deriving (Show, Eq)++data ProductV2 = ProductV2+  { description :: String+  , totalCost :: Double+  } deriving (Show, Eq)++deriveAutomap+  ( ByName $+    defaultConfig+    { staticRules =+        [ combineFields 'description $ do+            itemName <- get 'itemName+            quantity <- get 'quantity+            pure [| $itemName ++ " (qty: " ++ show $quantity ++ ")" |]+        , combineFields 'totalCost $ do+            unitPrice <- get 'unitPrice+            quantity <- get 'quantity+            pure [| $unitPrice * fromIntegral $quantity |]+        ]+    }+  )+  ''ProductV1+  ''ProductV2++-- Splitting fields (reverse operation)+data PersonV3 = PersonV3+  { fullNameV3 :: String+  , ageV3 :: Int+  } deriving (Show, Eq)++data PersonV4 = PersonV4+  { firstNameV4 :: String+  , lastNameV4 :: String+  , ageV4 :: Int+  } deriving (Show, Eq)++splitFullName :: String -> (String, String)+splitFullName s = case words s of+  []  -> ("", "")+  [w] -> (w, "")+  (w:ws) -> (w, unwords ws)++deriveAutomap+  ( ByName $+    defaultConfig+    `withRules`+    [ combineFields 'firstNameV4 $ do+        fullNameV3 <- get 'fullNameV3+        pure [| fst (splitFullName $fullNameV3) |]+    , combineFields 'lastNameV4 $ do+        fullNameV3 <- get 'fullNameV3+        pure [| snd (splitFullName $fullNameV3) |]+    , rename 'ageV4 'ageV3+    ]+  )+  ''PersonV3+  ''PersonV4++spec :: Spec+spec = do+  describe "Computed destination fields" $ do+    it "combines multiple source fields into one destination field" $ do+      let personV1 = PersonV1 "Alice" "Smith" 30+      let personV2 = W.from personV1 :: PersonV2+      fullName personV2 `shouldBe` "Alice Smith"+      personAge personV2 `shouldBe` 30++    it "computes multiple destination fields from the same sources" $ do+      let productV1 = ProductV1 "Widget" 9.99 5+      let productV2 = W.from productV1 :: ProductV2+      description productV2 `shouldBe` "Widget (qty: 5)"+      totalCost productV2 `shouldBe` 49.95++    it "can split a field into multiple fields" $ do+      let personV3 = PersonV3 "Bob Jones" 25+      let personV4 = W.from personV3 :: PersonV4+      firstNameV4 personV4 `shouldBe` "Bob"+      lastNameV4 personV4 `shouldBe` "Jones"+      ageV4 personV4 `shouldBe` 25+
+ test/Warlock/ConstructorTransformSpec.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Warlock.ConstructorTransformSpec (spec) where++import Test.Hspec+import qualified Witch as W+import Warlock++-- Enum versioning with suffix+data StatusV1+  = Pending+  | InProgress+  | Completed+  | Failed+  deriving (Show, Eq)++data StatusV2+  = PendingV2+  | InProgressV2+  | CompletedV2+  | FailedV2+  deriving (Show, Eq)++deriveAutomap+  ( ByName $ defaultConfig `withConstructorMap` addSuffix "V2" )+  ''StatusV1+  ''StatusV2++deriveAutomap+  ( ByName $ defaultConfig `withConstructorMap` stripSuffix "V2" )+  ''StatusV2+  ''StatusV1++-- Prefix transformation+data Color+  = Red+  | Green+  | Blue+  deriving (Show, Eq)++data ColorCode+  = CodeRed+  | CodeGreen+  | CodeBlue+  deriving (Show, Eq)++deriveAutomap+  ( ByName $ defaultConfig `withConstructorMap` Transform ("Code" ++) )+  ''Color+  ''ColorCode++deriveAutomap+  ( ByName $ defaultConfig `withConstructorMap` Transform (drop 4) )+  ''ColorCode+  ''Color++spec :: Spec+spec = do+  describe "Constructor name transformation" $ do+    it "appends version suffix to constructor names" $ do+      W.from Pending `shouldBe` (PendingV2 :: StatusV2)+      W.from InProgress `shouldBe` (InProgressV2 :: StatusV2)+      W.from Completed `shouldBe` (CompletedV2 :: StatusV2)+      W.from Failed `shouldBe` (FailedV2 :: StatusV2)++    it "strips version suffix from constructor names" $ do+      W.from PendingV2 `shouldBe` (Pending :: StatusV1)+      W.from InProgressV2 `shouldBe` (InProgress :: StatusV1)+      W.from CompletedV2 `shouldBe` (Completed :: StatusV1)++    it "prepends prefix to constructor names" $ do+      W.from Red `shouldBe` (CodeRed :: ColorCode)+      W.from Green `shouldBe` (CodeGreen :: ColorCode)+      W.from Blue `shouldBe` (CodeBlue :: ColorCode)++    it "strips prefix from constructor names" $ do+      W.from CodeRed `shouldBe` (Red :: Color)+      W.from CodeGreen `shouldBe` (Green :: Color)+      W.from CodeBlue `shouldBe` (Blue :: Color)++    it "works bidirectionally" $ do+      let orig = InProgress+      let v2 = W.from orig :: StatusV2+      let back = W.from v2 :: StatusV1+      back `shouldBe` orig+
+ test/Warlock/DisassembleFieldsSpec.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Warlock.DisassembleFieldsSpec (spec) where++import Test.Hspec+import Warlock+import Language.Haskell.TH (varE)+import qualified Witch as W++-- V1: combined field+data PersonV1 = PersonV1+  { fullName :: String+  , age :: Int+  } deriving (Show, Eq)++-- V2: separate fields+data PersonV2 = PersonV2+  { firstName :: String+  , lastName :: String+  , personAge :: Int+  } deriving (Show, Eq)++-- Split fullName into firstName and lastName+deriveAutomap+  ( ByName $+    defaultConfig+    `withRules`+    ( disassembleFields 'fullName+        [ 'firstName .= do+            src <- getSource+            pure [| case words $src of+                      (f:_:_) -> f+                      [single] -> single+                      _ -> ""+                 |]+        , 'lastName .= do+            src <- getSource+            pure [| case words $src of+                      (_:l:_) -> l+                      _ -> ""+                 |]+        ]+    +++    [ rename 'personAge 'age+    ]+    )+  )+  ''PersonV1+  ''PersonV2++-- Another example: address parsing+data AddressV1 = AddressV1+  { fullAddress :: String+  , city :: String+  } deriving (Show, Eq)++data AddressV2 = AddressV2+  { street :: String+  , zipCode :: String+  , addressCity :: String+  } deriving (Show, Eq)++-- Split fullAddress into street and zipCode+deriveAutomap+  ( ByName $+    defaultConfig+    `withRules`+    ( disassembleFields 'fullAddress+        [ 'street .= do+            src <- getSource+            pure [| let parts = reverse $ words $src+                    in case parts of+                         (_:rest) -> unwords (reverse rest)+                         _ -> $src+                 |]+        , 'zipCode .= do+            src <- getSource+            pure [| let parts = reverse $ words $src+                    in case parts of+                         (zip:_) -> zip+                         _ -> ""+                 |]+        ]+    +++    [ rename 'addressCity 'city+    ]+    )+  )+  ''AddressV1+  ''AddressV2++spec :: Spec+spec = do+  describe "disassembleFields" $ do+    it "splits fullName into firstName and lastName" $ do+      let person = PersonV1 "John Doe" 30+      let result = W.from @PersonV1 @PersonV2 person+      result `shouldBe` PersonV2 "John" "Doe" 30++    it "handles single-word names" $ do+      let person = PersonV1 "Madonna" 65+      let result = W.from @PersonV1 @PersonV2 person+      result `shouldBe` PersonV2 "Madonna" "" 65++    it "splits address into street and zipCode" $ do+      let addr = AddressV1 "123 Main St 12345" "Springfield"+      let result = W.from @AddressV1 @AddressV2 addr+      result `shouldBe` AddressV2 "123 Main St" "12345" "Springfield"++    it "handles address without zipCode" $ do+      let addr = AddressV1 "Downtown" "Chicago"+      let result = W.from @AddressV1 @AddressV2 addr+      -- "Downtown" is treated as zipCode when there's only one word+      result `shouldBe` AddressV2 "" "Downtown" "Chicago"+
+ test/Warlock/EdgeCaseSpec.hs view
@@ -0,0 +1,836 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleInstances #-}+module Warlock.EdgeCaseSpec (spec) where++import Test.Hspec+import qualified Witch as W+import Warlock+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Int (Int32, Int64)+import GHC.Records (HasField(..))+import Language.Haskell.TH (varE)++--------------------------------------------------------------------------------+-- 1. Deep Nested Type Conversions+--------------------------------------------------------------------------------++-- Test that autowitch correctly applies W.into through nested structures+-- Using simple Int->String conversions that are already supported by witch++data Level1A = Level1A { value1 :: Int } deriving (Show, Eq)+data Level1B = Level1B { value1 :: Int } deriving (Show, Eq)++deriveAutomapBoth (ByName defaultConfig) ''Level1A ''Level1B++-- Level 2: Records containing Maybe+data Level2A = Level2A { maybeValue :: Maybe Int } deriving (Show, Eq)+data Level2B = Level2B { maybeValue :: Maybe Int } deriving (Show, Eq)++deriveAutomapBoth (ByName defaultConfig) ''Level2A ''Level2B++-- Level 3: Records containing Either+data Level3A = Level3A { eitherValue :: Either String Int } deriving (Show, Eq)+data Level3B = Level3B { eitherValue :: Either String Int } deriving (Show, Eq)++deriveAutomapBoth (ByName defaultConfig) ''Level3A ''Level3B++-- Level 4: Records containing Lists+data Level4A = Level4A { listValue :: [Int] } deriving (Show, Eq)+data Level4B = Level4B { listValue :: [Int] } deriving (Show, Eq)++deriveAutomapBoth (ByName defaultConfig) ''Level4A ''Level4B++-- Complex nested structure with records+data DeepNestA = DeepNestA+  { deepValue :: Maybe (Either String [Int])+  } deriving (Show, Eq)+data DeepNestB = DeepNestB+  { deepValue :: Maybe (Either String [Int])+  } deriving (Show, Eq)++deriveAutomapBoth (ByName defaultConfig) ''DeepNestA ''DeepNestB++-- Test nesting with actual type conversions via W.into+data WithConversionA = WithConversionA+  { innerRecord :: Level1A+  } deriving (Show, Eq)+data WithConversionB = WithConversionB+  { innerRecord :: Level1B+  } deriving (Show, Eq)++deriveAutomapBoth (ByName defaultConfig) ''WithConversionA ''WithConversionB++--------------------------------------------------------------------------------+-- 2. TryFrom Failures & Error Accumulation+--------------------------------------------------------------------------------++-- Note: TryFrom tests would require types where conversion can actually fail.+-- For comprehensive TryFrom testing, you'd need types with TryFrom instances+-- that can fail at runtime (e.g., parsing, validation, etc.)+-- Here we just test that the basic TryFrom derivation mechanism compiles.++data TrySource = TrySource+  { tryField1 :: String+  , tryField2 :: String+  , tryField3 :: String+  } deriving (Show, Eq)++data TryDest = TryDest+  { tryField1 :: String+  , tryField2 :: String+  , tryField3 :: String+  } deriving (Show, Eq)++-- Use regular automap for this test since String->String doesn't need TryFrom+deriveAutomapBoth (ByName defaultConfig) ''TrySource ''TryDest++--------------------------------------------------------------------------------+-- 3. Complex Type Compositions+--------------------------------------------------------------------------------++-- Tuples (no inner conversion needed)+data TupleRecordA = TupleRecordA+  { tupleData :: (Int, String, Bool)+  } deriving (Show, Eq)++data TupleRecordB = TupleRecordB+  { tupleData :: (Int, String, Bool)+  } deriving (Show, Eq)++deriveAutomapBoth (ByName defaultConfig) ''TupleRecordA ''TupleRecordB++-- Double Maybe+data DoubleMaybeA = DoubleMaybeA { doublyOptional :: Maybe (Maybe Int) } deriving (Show, Eq)+data DoubleMaybeB = DoubleMaybeB { doublyOptional :: Maybe (Maybe Int) } deriving (Show, Eq)++deriveAutomapBoth (ByName defaultConfig) ''DoubleMaybeA ''DoubleMaybeB++-- Nested Either+data NestedEitherA = NestedEitherA+  { eitherData :: Either (Either String Int) Bool+  } deriving (Show, Eq)+data NestedEitherB = NestedEitherB+  { eitherData :: Either (Either String Int) Bool+  } deriving (Show, Eq)++deriveAutomapBoth (ByName defaultConfig) ''NestedEitherA ''NestedEitherB++-- Complex container: Map with nested structures+data MapComplexA = MapComplexA+  { mapData :: Map String [Maybe Int]+  } deriving (Show, Eq)+data MapComplexB = MapComplexB+  { mapData :: Map String [Maybe Int]+  } deriving (Show, Eq)++deriveAutomapBoth (ByName defaultConfig) ''MapComplexA ''MapComplexB++--------------------------------------------------------------------------------+-- 4. Extreme Record Scenarios+--------------------------------------------------------------------------------++-- Empty records (zero fields)+data EmptyA = EmptyA deriving (Show, Eq)+data EmptyB = EmptyB deriving (Show, Eq)++deriveAutomapBoth (ByName defaultConfig) ''EmptyA ''EmptyB++-- Single field records+data SingleA = SingleA { singleField :: Int } deriving (Show, Eq)+data SingleB = SingleB { singleField :: Int } deriving (Show, Eq)++deriveAutomapBoth (ByName defaultConfig) ''SingleA ''SingleB++-- Large records (20+ fields)+data LargeRecordA = LargeRecordA+  { field01 :: Int, field02 :: Int, field03 :: Int, field04 :: Int, field05 :: Int+  , field06 :: Int, field07 :: Int, field08 :: Int, field09 :: Int, field10 :: Int+  , field11 :: Int, field12 :: Int, field13 :: Int, field14 :: Int, field15 :: Int+  , field16 :: Int, field17 :: Int, field18 :: Int, field19 :: Int, field20 :: Int+  , field21 :: String, field22 :: String, field23 :: String+  } deriving (Show, Eq)++data LargeRecordB = LargeRecordB+  { field01 :: Int, field02 :: Int, field03 :: Int, field04 :: Int, field05 :: Int+  , field06 :: Int, field07 :: Int, field08 :: Int, field09 :: Int, field10 :: Int+  , field11 :: Int, field12 :: Int, field13 :: Int, field14 :: Int, field15 :: Int+  , field16 :: Int, field17 :: Int, field18 :: Int, field19 :: Int, field20 :: Int+  , field21 :: String, field22 :: String, field23 :: String+  } deriving (Show, Eq)++deriveAutomapBoth (ByName defaultConfig) ''LargeRecordA ''LargeRecordB++-- All optional fields+data AllOptionalA = AllOptionalA+  { optField1 :: Maybe String+  , optField2 :: Maybe Int+  , optField3 :: Maybe Bool+  , optField4 :: Maybe Double+  } deriving (Show, Eq)++data AllOptionalB = AllOptionalB+  { optField1 :: Maybe String+  , optField2 :: Maybe Int+  , optField3 :: Maybe Bool+  , optField4 :: Maybe Double+  } deriving (Show, Eq)++deriveAutomapBoth (ByName defaultConfig) ''AllOptionalA ''AllOptionalB++--------------------------------------------------------------------------------+-- 5. Advanced Rule Combinations+--------------------------------------------------------------------------------++-- Combine Virtual + Computed + Defaults + Renames+data CombinedSource = CombinedSource+  { csFirstName :: String+  , csLastName :: String+  , csAge :: Int+  , csBalance :: Int+  } deriving (Show, Eq)++-- Virtual field for full name+instance HasField "fullName" CombinedSource String where+  getField (CombinedSource f l _ _) = f ++ " " ++ l++data CombinedDest = CombinedDest+  { cdName :: String           -- Virtual field from source+  , cdDisplayAge :: String     -- Computed from age+  , cdAmount :: Int            -- Renamed from balance+  , cdRegion :: String         -- Default value+  , cdStatus :: String         -- Default value+  } deriving (Show, Eq)++deriveAutomap+  ( ByName $+    defaultConfig+    `withRules`+    [ virtualField 'cdName "fullName"+    , combineFields 'cdDisplayAge $ do+        age <- get 'csAge+        pure [| show $(age) ++ " years old" |]+    , rename 'cdAmount 'csBalance+    , defaultTo 'cdRegion [| "US" |]+    , defaultTo 'cdStatus [| "active" |]+    ]+  )+  ''CombinedSource+  ''CombinedDest++-- Disassemble + Compute combination+data DisassembleComputeSource = DisassembleComputeSource+  { dcFullName :: String+  , dcPrice :: Int+  , dcQuantity :: Int+  } deriving (Show, Eq)++data DisassembleComputeDest = DisassembleComputeDest+  { dcFirstName :: String+  , dcLastName :: String+  , dcTotal :: Int+  } deriving (Show, Eq)++deriveAutomap+  ( ByName $+    defaultConfig+    `withRules`+    ( disassembleFields 'dcFullName+        [ 'dcFirstName .= do+            src <- getSource+            pure [| case words $src of+                      (f:_) -> f+                      [] -> ""+                 |]+        , 'dcLastName .= do+            src <- getSource+            pure [| case words $src of+                      (_:l:_) -> l+                      _ -> ""+                 |]+        ]+      +++      [ combineFields 'dcTotal $ do+          price <- get 'dcPrice+          qty <- get 'dcQuantity+          pure [| $(price) * $(qty) |]+      ]+    )+  )+  ''DisassembleComputeSource+  ''DisassembleComputeDest++-- Multiple computed fields with overlapping sources+data OverlapSource = OverlapSource+  { osX :: Int+  , osY :: Int+  , osZ :: Int+  } deriving (Show, Eq)++data OverlapDest = OverlapDest+  { odSum :: Int+  , odProduct :: Int+  , odAverage :: Double+  } deriving (Show, Eq)++deriveAutomap+  ( ByName $+    defaultConfig+    `withRules`+    [ combineFields 'odSum $ do+        x <- get 'osX+        y <- get 'osY+        z <- get 'osZ+        pure [| $(x) + $(y) + $(z) |]+    , combineFields 'odProduct $ do+        x <- get 'osX+        y <- get 'osY+        z <- get 'osZ+        pure [| $(x) * $(y) * $(z) |]+    , combineFields 'odAverage $ do+        x <- get 'osX+        y <- get 'osY+        z <- get 'osZ+        pure [| fromIntegral ($(x) + $(y) + $(z)) / 3.0 |]+    ]+  )+  ''OverlapSource+  ''OverlapDest++--------------------------------------------------------------------------------+-- 6. Constructor Edge Cases (ADTs)+--------------------------------------------------------------------------------++-- ADT with 10+ constructors+data ManyConstructorsA+  = ConA1 Int+  | ConA2 String+  | ConA3 Bool+  | ConA4 Double+  | ConA5 Int Int+  | ConA6 String String+  | ConA7 Bool Bool+  | ConA8 Int String+  | ConA9 String Bool+  | ConA10 Bool Int+  | ConA11 Double Double+  | ConA12 Int Int Int+  deriving (Show, Eq)++data ManyConstructorsB+  = ConB1 Int+  | ConB2 String+  | ConB3 Bool+  | ConB4 Double+  | ConB5 Int Int+  | ConB6 String String+  | ConB7 Bool Bool+  | ConB8 Int String+  | ConB9 String Bool+  | ConB10 Bool Int+  | ConB11 Double Double+  | ConB12 Int Int Int+  deriving (Show, Eq)++-- Map ConA* to ConB*+deriveAutomap+  ( ByName $+    defaultConfig `withConstructorMap` Transform (\s -> case take 4 s of "ConA" -> "ConB" ++ drop 4 s; _ -> s) )+  ''ManyConstructorsA+  ''ManyConstructorsB++deriveAutomap+  ( ByName $+    defaultConfig `withConstructorMap` Transform (\s -> case take 4 s of "ConB" -> "ConA" ++ drop 4 s; _ -> s) )+  ''ManyConstructorsB+  ''ManyConstructorsA++-- Single-constructor ADT (should work like a regular record)+data SingleConADT = SingleConADT { scField :: Int } deriving (Show, Eq)+data SingleConADT2 = SingleConADT2 { scField :: Int } deriving (Show, Eq)++deriveAutomapBoth (ByName defaultConfig) ''SingleConADT ''SingleConADT2++-- Constructor name edge cases: single character+data ShortNames = A Int | B String | C Bool deriving (Show, Eq)+data ShortNames2 = X Int | Y String | Z Bool deriving (Show, Eq)++deriveAutomap (ByName $ defaultConfig `withConstructorMap` [('A, 'X), ('B, 'Y), ('C, 'Z)]) ''ShortNames ''ShortNames2+deriveAutomap (ByName $ defaultConfig `withConstructorMap` [('X, 'A), ('Y, 'B), ('Z, 'C)]) ''ShortNames2 ''ShortNames++-- Mixed record and positional in same ADT+data MixedADT+  = MixedRecord { mixedField :: Int }+  | MixedPositional Int String+  deriving (Show, Eq)++data MixedADT2+  = MixedRecord2 { mixedField2 :: Int }+  | MixedPositional2 Int String+  deriving (Show, Eq)++deriveAutomap+  ( ByName $ defaultConfig `withConstructorMap` [('MixedRecord, 'MixedRecord2), ('MixedPositional, 'MixedPositional2)]+      `withRules` [rename 'mixedField2 'mixedField]+  ) ''MixedADT ''MixedADT2+deriveAutomap+  ( ByName $ defaultConfig `withConstructorMap` [('MixedRecord2, 'MixedRecord), ('MixedPositional2, 'MixedPositional)]+      `withRules` [rename 'mixedField 'mixedField2]+  ) ''MixedADT2 ''MixedADT++--------------------------------------------------------------------------------+-- 7. Normalization Edge Cases+--------------------------------------------------------------------------------++-- Underscores in various positions+data UnderscoreSource = UnderscoreSource+  { __leading :: Int+  , trailing__ :: Int+  , __both__ :: Int+  , mid__dle :: Int+  } deriving (Show, Eq)++data UnderscoreDest = UnderscoreDest+  { __leading :: Int+  , trailing__ :: Int+  , __both__ :: Int+  , mid__dle :: Int+  } deriving (Show, Eq)++deriveAutomapBoth (ByName defaultConfig) ''UnderscoreSource ''UnderscoreDest++-- Snake case with numbers+data SnakeNumbersA = SnakeNumbersA+  { field_123 :: Int+  , field_456_name :: String+  , x_1_y_2_z_3 :: Bool+  } deriving (Show, Eq)++data SnakeNumbersB = SnakeNumbersB+  { field_123 :: Int+  , field_456_name :: String+  , x_1_y_2_z_3 :: Bool+  } deriving (Show, Eq)++deriveAutomapBoth (ByName defaultConfig) ''SnakeNumbersA ''SnakeNumbersB++-- CamelCase with acronyms+data AcronymSource = AcronymSource+  { httpConnection :: String+  , xmlParser :: String+  , jsonAPI :: String+  } deriving (Show, Eq)++data AcronymDest = AcronymDest+  { httpConnection :: String+  , xmlParser :: String+  , jsonAPI :: String+  } deriving (Show, Eq)++deriveAutomapBoth (ByName defaultConfig) ''AcronymSource ''AcronymDest++-- Snake to Camel normalization+data SnakeCaseFields = SnakeCaseFields+  { first_name :: String+  , last_name :: String+  , phone_number :: String+  } deriving (Show, Eq)++data CamelCaseFields = CamelCaseFields+  { firstName :: String+  , lastName :: String+  , phoneNumber :: String+  } deriving (Show, Eq)++deriveAutomap (ByName snakeToCamelConfig) ''SnakeCaseFields ''CamelCaseFields++--------------------------------------------------------------------------------+-- 8. Type Parameter Stress Tests+--------------------------------------------------------------------------------++-- Multiple type parameters+data MultiParam a b c = MultiParam+  { mpA :: a+  , mpB :: b+  , mpC :: c+  } deriving (Show, Eq)++-- Concrete instances for testing+data ConcreteMultiA = ConcreteMultiA+  { mpA :: Int+  , mpB :: String+  , mpC :: Bool+  } deriving (Show, Eq)++data ConcreteMultiB = ConcreteMultiB+  { mpA :: Int+  , mpB :: String+  , mpC :: Bool+  } deriving (Show, Eq)++deriveAutomapBoth (ByName defaultConfig) ''ConcreteMultiA ''ConcreteMultiB++-- Phantom types+data PhantomA a = PhantomA { phantomValue :: Int } deriving (Show, Eq)+data PhantomB a = PhantomB { phantomValue :: Int } deriving (Show, Eq)++-- Concrete phantom instances+type PhantomIntA = PhantomA Int+type PhantomIntB = PhantomB Int++deriveAutomapWith (ByName defaultConfig) [t| PhantomA Int |] [t| PhantomB Int |]+deriveAutomapWith (ByName defaultConfig) [t| PhantomB Int |] [t| PhantomA Int |]++-- Type synonyms in parameterized contexts+type IntAlias = Int+type IntAlias2 = Int++data SynonymContainer = SynonymContainer { synField :: IntAlias } deriving (Show, Eq)+data SynonymContainer2 = SynonymContainer2 { synField :: IntAlias2 } deriving (Show, Eq)++deriveAutomapBoth (ByName defaultConfig) ''SynonymContainer ''SynonymContainer2++--------------------------------------------------------------------------------+-- 9. Default Value Edge Cases+--------------------------------------------------------------------------------++-- Complex default expressions+data ComplexDefaultSource = ComplexDefaultSource+  { cdsExisting :: Int+  } deriving (Show, Eq)++data ComplexDefaultDest = ComplexDefaultDest+  { cdsExisting :: Int+  , cdsLambda :: String+  , cdsCase :: String+  , cdsComplex :: Int+  } deriving (Show, Eq)++deriveAutomap+  ( ByName $+    defaultConfig+    `withDefaults`+    [ ('cdsLambda, [| (\x -> "Hello " ++ x) "World" |])+    , ('cdsCase, [| case (1 :: Int) of+                       1 -> "one"+                       2 -> "two"+                       _ -> "other"+                   |])+    , ('cdsComplex, [| sum [1..10] |])+    ]+  )+  ''ComplexDefaultSource+  ''ComplexDefaultDest++-- Defaults requiring type conversion+-- NOTE: Commented out - witch doesn't provide From Int32 Int64 or From Int64 Int32+-- data ConvSrc = ConvSrc { convVal :: Int32 } deriving (Show, Eq)+-- data ConvDst = ConvDst { convVal :: Int64 } deriving (Show, Eq)+-- deriveAutomapBoth (ByName defaultConfig) ''ConvSrc ''ConvDst++-- NOTE: Test commented out - depends on ConvSrc/ConvDst which requires unavailable witch instances+-- data DefaultConvSource = DefaultConvSource+--   { dcsField1 :: String+--   } deriving (Show, Eq)+--+-- data DefaultConvDest = DefaultConvDest+--   { dcsField1 :: String+--   , dcsNeedsConv :: ConvDst+--   } deriving (Show, Eq)+--+-- deriveAutoMapWith+--   ( defaultConfig+--     `withDefaults`+--     [ ("dcsNeedsConv", [| W.into (ConvSrc 42 :: ConvSrc) |])+--     ]+--   )+--   ''DefaultConvSource+--   ''DefaultConvDest++-- Multiple defaults in sequence+data ManyDefaultsSource = ManyDefaultsSource+  { mdsField1 :: String+  } deriving (Show, Eq)++data ManyDefaultsDest = ManyDefaultsDest+  { mdsField1 :: String+  , mdsDefault1 :: Int+  , mdsDefault2 :: String+  , mdsDefault3 :: Bool+  , mdsDefault4 :: Double+  , mdsDefault5 :: Maybe Int+  } deriving (Show, Eq)++deriveAutomap+  ( ByName $+    defaultConfig+    `withDefaults`+    [ ('mdsDefault1, [| 42 |])+    , ('mdsDefault2, [| "default" |])+    , ('mdsDefault3, [| True |])+    , ('mdsDefault4, [| 3.14 |])+    , ('mdsDefault5, [| Just 99 |])+    ]+  )+  ''ManyDefaultsSource+  ''ManyDefaultsDest+++--------------------------------------------------------------------------------+-- 11. Failure Modes & Error Messages+--------------------------------------------------------------------------------++-- Document expected compile-time errors:+{-+-- This should fail: missing field with no default+data MissingFieldSrc = MissingFieldSrc { mfField1 :: Int }+data MissingFieldDst = MissingFieldDst { mfField1 :: Int, mfField2 :: String }+-- deriveAutoMap ''MissingFieldSrc ''MissingFieldDst+-- Expected error: "AutoWitch: no source field for 'mfField2'"++-- This should fail: type mismatch without From instance+data TypeMismatchSrc = TypeMismatchSrc { tmField :: Int }+data TypeMismatchDst = TypeMismatchDst { tmField :: CustomType }+-- deriveAutoMap ''TypeMismatchSrc ''TypeMismatchDst+-- Expected error: No instance for (W.From Int CustomType)+-}++-- Testing runtime TryFrom would require types with actual failure cases+-- For now, we just verify the mechanism compiles+data TryFailSource = TryFailSource { tfField :: String } deriving (Show, Eq)+data TryFailDest = TryFailDest { tfField :: String } deriving (Show, Eq)++deriveAutomap (ByName defaultConfig) ''TryFailSource ''TryFailDest++--------------------------------------------------------------------------------+-- Test Specs+--------------------------------------------------------------------------------++spec :: Spec+spec = do+  describe "1. Deep Nested Conversions" $ do+    it "converts simple records" $ do+      let src = Level1A 42+      let (Level1B v) = W.from src+      v `shouldBe` 42++    it "handles Maybe fields" $ do+      let src1 = Level2A (Just 42)+      let (Level2B mv1) = W.from src1+      mv1 `shouldBe` Just 42++      let src2 = Level2A Nothing+      let (Level2B mv2) = W.from src2+      mv2 `shouldBe` Nothing++    it "handles Either fields" $ do+      let src1 = Level3A (Right 10)+      let (Level3B ev1) = W.from src1+      ev1 `shouldBe` Right 10++      let src2 = Level3A (Left "error")+      let (Level3B ev2) = W.from src2+      ev2 `shouldBe` Left "error"++    it "handles List fields" $ do+      let src = Level4A [1, 2, 3]+      let (Level4B lv) = W.from src+      lv `shouldBe` [1, 2, 3]++    it "handles complex nested structures" $ do+      let src = DeepNestA (Just (Right [1, 2, 3]))+      let (DeepNestB dv) = W.from src+      dv `shouldBe` Just (Right [1, 2, 3])++    it "converts nested records via W.into" $ do+      let src = WithConversionA (Level1A 99)+      let (WithConversionB (Level1B v)) = W.from src+      v `shouldBe` 99++  describe "2. TryFrom Mechanism" $ do+    it "successfully converts when all fields match" $ do+      let src = TrySource "a" "b" "c"+      let dst = W.from src :: TryDest+      dst `shouldBe` TryDest "a" "b" "c"++    it "handles bidirectional conversion" $ do+      let src = TrySource "x" "y" "z"+      let dst = W.from src :: TryDest+      let back = W.from dst :: TrySource+      back `shouldBe` src++  describe "3. Complex Type Compositions" $ do+    it "handles tuple fields" $ do+      let src = TupleRecordA (42, "test", True)+      let dst = W.from src :: TupleRecordB+      dst `shouldBe` TupleRecordB (42, "test", True)++    it "handles double Maybe" $ do+      let src1 = DoubleMaybeA (Just (Just 42))+      let dst1 = W.from src1 :: DoubleMaybeB+      dst1 `shouldBe` DoubleMaybeB (Just (Just 42))++      let src2 = DoubleMaybeA (Just Nothing)+      let dst2 = W.from src2 :: DoubleMaybeB+      dst2 `shouldBe` DoubleMaybeB (Just Nothing)++      let src3 = DoubleMaybeA Nothing+      let dst3 = W.from src3 :: DoubleMaybeB+      dst3 `shouldBe` DoubleMaybeB Nothing++    it "handles nested Either" $ do+      let src1 = NestedEitherA (Left (Left "err"))+      let dst1 = W.from src1 :: NestedEitherB+      dst1 `shouldBe` NestedEitherB (Left (Left "err"))++      let src2 = NestedEitherA (Left (Right 42))+      let dst2 = W.from src2 :: NestedEitherB+      dst2 `shouldBe` NestedEitherB (Left (Right 42))++      let src3 = NestedEitherA (Right True)+      let dst3 = W.from src3 :: NestedEitherB+      dst3 `shouldBe` NestedEitherB (Right True)++    it "converts Map with nested structures" $ do+      let src = MapComplexA $ Map.fromList+            [ ("key1", [Just 1, Nothing])+            , ("key2", [])+            ]+      let dst = W.from src :: MapComplexB+      dst `shouldBe` MapComplexB (Map.fromList+            [ ("key1", [Just 1, Nothing])+            , ("key2", [])+            ])++  describe "4. Extreme Record Scenarios" $ do+    it "handles empty records" $ do+      let src = EmptyA+      let dst = W.from src :: EmptyB+      dst `shouldBe` EmptyB++    it "handles single field records" $ do+      let src = SingleA 42+      let dst = W.from src :: SingleB+      dst `shouldBe` SingleB 42++    it "handles large records (20+ fields)" $ do+      let src = LargeRecordA 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 "a" "b" "c"+      let dst = W.from src :: LargeRecordB+      dst `shouldBe` LargeRecordB 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 "a" "b" "c"++    it "handles all optional fields" $ do+      let src = AllOptionalA (Just "test") (Just 42) Nothing (Just 3.14)+      let dst = W.from src :: AllOptionalB+      dst `shouldBe` AllOptionalB (Just "test") (Just 42) Nothing (Just 3.14)++  describe "5. Advanced Rule Combinations" $ do+    it "combines virtual + computed + defaults + renames" $ do+      let src = CombinedSource "John" "Doe" 30 1000+      let dst = W.from src :: CombinedDest+      dst `shouldBe` CombinedDest "John Doe" "30 years old" 1000 "US" "active"++    it "combines disassemble + compute" $ do+      let src = DisassembleComputeSource "Alice Bob" 10 5+      let dst = W.from src :: DisassembleComputeDest+      dst `shouldBe` DisassembleComputeDest "Alice" "Bob" 50++    it "handles multiple computed fields with overlapping sources" $ do+      let src = OverlapSource 2 3 5+      let dst = W.from src :: OverlapDest+      odSum dst `shouldBe` 10+      odProduct dst `shouldBe` 30+      odAverage dst `shouldSatisfy` (\x -> abs (x - 3.333333) < 0.001)++  describe "6. Constructor Edge Cases (ADTs)" $ do+    it "handles ADT with 10+ constructors" $ do+      W.from (ConA1 1) `shouldBe` (ConB1 1 :: ManyConstructorsB)+      W.from (ConA5 1 2) `shouldBe` (ConB5 1 2 :: ManyConstructorsB)+      W.from (ConA12 1 2 3) `shouldBe` (ConB12 1 2 3 :: ManyConstructorsB)++    it "handles single-constructor ADT" $ do+      let src = SingleConADT 42+      let dst = W.from src :: SingleConADT2+      dst `shouldBe` SingleConADT2 42++    it "handles single-character constructor names" $ do+      W.from (A 1) `shouldBe` (X 1 :: ShortNames2)+      W.from (B "test") `shouldBe` (Y "test" :: ShortNames2)+      W.from (C True) `shouldBe` (Z True :: ShortNames2)++    it "handles mixed record and positional constructors" $ do+      W.from (MixedRecord 42) `shouldBe` (MixedRecord2 42 :: MixedADT2)+      W.from (MixedPositional 1 "test") `shouldBe` (MixedPositional2 1 "test" :: MixedADT2)++  describe "7. Normalization Edge Cases" $ do+    it "handles underscores in various positions" $ do+      let src = UnderscoreSource 1 2 3 4+      let dst = W.from src :: UnderscoreDest+      dst `shouldBe` UnderscoreDest 1 2 3 4++    it "handles snake case with numbers" $ do+      let src = SnakeNumbersA 123 "test" True+      let dst = W.from src :: SnakeNumbersB+      dst `shouldBe` SnakeNumbersB 123 "test" True++    it "handles acronyms in field names" $ do+      let src = AcronymSource "http" "xml" "json"+      let dst = W.from src :: AcronymDest+      dst `shouldBe` AcronymDest "http" "xml" "json"++    it "converts snake_case to camelCase" $ do+      let src = SnakeCaseFields "John" "Doe" "555-1234"+      let dst = W.from src :: CamelCaseFields+      dst `shouldBe` CamelCaseFields "John" "Doe" "555-1234"++  describe "8. Type Parameter Stress Tests" $ do+    it "handles multiple type parameters" $ do+      let src = ConcreteMultiA 1 "test" True+      let dst = W.from src :: ConcreteMultiB+      dst `shouldBe` ConcreteMultiB 1 "test" True++    it "handles phantom types" $ do+      let src = PhantomA 42 :: PhantomA Int+      let dst = W.from src :: PhantomB Int+      dst `shouldBe` PhantomB 42++    it "handles type synonyms" $ do+      let src = SynonymContainer 42+      let dst = W.from src :: SynonymContainer2+      dst `shouldBe` SynonymContainer2 42++  describe "9. Default Value Edge Cases" $ do+    it "handles complex default expressions" $ do+      let src = ComplexDefaultSource 100+      let (ComplexDefaultDest existing lambda caseVal complex) = W.from src+      existing `shouldBe` 100+      lambda `shouldBe` "Hello World"+      caseVal `shouldBe` "one"+      complex `shouldBe` 55++    -- NOTE: Test commented out - depends on ConvSrc/ConvDst types+    -- it "handles defaults requiring type conversion" $ do+    --   let src = DefaultConvSource "test"+    --   let (DefaultConvDest field1 conv) = W.from src :: DefaultConvDest+    --   field1 `shouldBe` "test"+    --   conv `shouldBe` ConvDst 42++    it "handles multiple defaults in sequence" $ do+      let src = ManyDefaultsSource "original"+      let (ManyDefaultsDest f1 d1 d2 d3 d4 d5) = W.from src :: ManyDefaultsDest+      f1 `shouldBe` "original"+      d1 `shouldBe` 42+      d2 `shouldBe` "default"+      d3 `shouldBe` True+      d4 `shouldBe` 3.14+      d5 `shouldBe` Just 99++  describe "10. Failure Modes & Error Messages" $ do+    it "basic conversion works" $ do+      let src = TryFailSource "test"+      let dst = W.from src :: TryFailDest+      dst `shouldBe` TryFailDest "test"+
+ test/Warlock/HKDSpec.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}++module Warlock.HKDSpec (spec) where++import Test.Hspec+import Warlock.HKD+import Data.Functor.Identity (Identity(..))+import Witch (From, from)++--------------------------------------------------------------------------------+-- Test Types++-- Single-constructor record+data Person = Person+  { personName :: String+  , personAge :: Int+  } deriving (Show, Eq)++deriveHKD (defaultHKDConfig `withFieldPrefix` "hkd") ''Person++-- Multi-constructor ADT with records+data Payment+  = CreditCard { cardNumber :: String, cvv :: String }+  | Cash { amount :: Double }+  | Check { checkNumber :: Int, bankName :: String }+  deriving (Show, Eq)++deriveHKD (defaultHKDConfig `withFieldPrefix` "pay") ''Payment++-- Simple product type (no field names)+data Point = Point Int Int deriving (Show, Eq)++deriveHKD' ''Point++-- Type with custom config (field prefix)+data User = User+  { userName :: String+  , userEmail :: String+  } deriving (Show, Eq)++deriveHKD (defaultHKDConfig `withFieldPrefix` "hkd") ''User++-- Type with custom config (constructor suffix)+data Product = Product+  { productName :: String+  , productPrice :: Double+  } deriving (Show, Eq)++deriveHKD ((defaultHKDConfig `withConstructorSuffix` "HKD") `withFieldPrefix` "prod") ''Product++-- Type without From instances+data NoFrom = NoFrom { noFromField :: String } deriving (Show, Eq)++deriveHKD (withoutFromInstances (defaultHKDConfig `withFieldPrefix` "nf")) ''NoFrom++--------------------------------------------------------------------------------+-- Test Specs++spec :: Spec+spec = do+  describe "Warlock.HKD" $ do++    describe "Single-constructor records" $ do+      it "generates HKD type with Identity wrapper" $ do+        let person = Person "Alice" 30+        let hkdPerson = from person :: HKD Person Identity+        let unwrapped = from hkdPerson :: Person+        unwrapped `shouldBe` person++      it "can construct HKD types directly" $ do+        let hkdPerson = Person' (Identity "Bob") (Identity 25) :: HKD Person Identity+        case hkdPerson of+          Person' (Identity name) (Identity age) -> do+            name `shouldBe` "Bob"+            age `shouldBe` 25++      it "round-trips through Identity" $ do+        let original = Person "Charlie" 35+        let roundtripped = from (from original :: HKD Person Identity) :: Person+        roundtripped `shouldBe` original++    describe "Multi-constructor ADTs" $ do+      it "handles CreditCard constructor" $ do+        let payment = CreditCard "1234-5678" "123"+        let hkdPayment = from payment :: HKD Payment Identity+        let unwrapped = from hkdPayment :: Payment+        unwrapped `shouldBe` payment++      it "handles Cash constructor" $ do+        let payment = Cash 50.00+        let hkdPayment = from payment :: HKD Payment Identity+        let unwrapped = from hkdPayment :: Payment+        unwrapped `shouldBe` payment++      it "handles Check constructor" $ do+        let payment = Check 1001 "Bank of Haskell"+        let hkdPayment = from payment :: HKD Payment Identity+        let unwrapped = from hkdPayment :: Payment+        unwrapped `shouldBe` payment++      it "preserves constructor choice through conversion" $ do+        let cash = Cash 100.00+        let credit = CreditCard "9999" "999"+        let cashRoundtrip = from (from cash :: HKD Payment Identity) :: Payment+        let creditRoundtrip = from (from credit :: HKD Payment Identity) :: Payment+        cashRoundtrip `shouldBe` cash+        creditRoundtrip `shouldBe` credit++    describe "Positional constructors" $ do+      it "handles types without field names" $ do+        let point = Point 10 20+        let hkdPoint = from point :: HKD Point Identity+        let unwrapped = from hkdPoint :: Point+        unwrapped `shouldBe` point++    describe "Custom configuration" $ do+      it "applies field name prefix" $ do+        let user = User "alice" "alice@example.com"+        let hkdUser = from user :: HKD User Identity+        case hkdUser of+          User' (Identity name) (Identity email) -> do+            name `shouldBe` "alice"+            email `shouldBe` "alice@example.com"++      it "applies constructor suffix" $ do+        let product = Product "Widget" 19.99+        let hkdProduct = from product :: HKD Product Identity+        case hkdProduct of+          ProductHKD (Identity name) (Identity price) -> do+            name `shouldBe` "Widget"+            price `shouldBe` 19.99++      it "respects withoutFromInstances" $ do+        -- This should compile - we can still construct the type manually+        let noFromHKD = NoFrom' (Identity "test") :: HKD NoFrom Identity+        case noFromHKD of+          NoFrom' (Identity field) -> field `shouldBe` "test"+        -- Note: We don't test From instances here because they shouldn't exist+
+ test/Warlock/ParameterizedTypesSpec.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+module Warlock.ParameterizedTypesSpec (spec) where++import Test.Hspec+import Warlock+import qualified Witch as W+import Language.Haskell.TH (varE)++-- Test with polymorphic source type (Container Int <-> IntContainer)+data Container a = Container+  { containerValue :: a+  , containerLabel :: String+  } deriving (Show, Eq)++data IntContainer = IntContainer+  { intContainerValue :: Int+  , intContainerLabel :: String+  } deriving (Show, Eq)++-- Use deriveAutomapWith (ByName for polymorphic types+deriveAutomapWith (ByName datatypePrefixConfig) [t| IntContainer |] [t| Container Int |]+deriveAutomapWith (ByName datatypePrefixConfig) [t| Container Int |] [t| IntContainer |]++-- Test with multiple type parameters+data Pair a b = Pair+  { pairFirst :: a+  , pairSecond :: b+  } deriving (Show, Eq)++data StringIntPair = StringIntPair+  { stringIntPairFirst :: String+  , stringIntPairSecond :: Int+  } deriving (Show, Eq)++deriveAutomapWith (ByName datatypePrefixConfig) [t| StringIntPair |] [t| Pair String Int |]+deriveAutomapWith (ByName datatypePrefixConfig) [t| Pair String Int |] [t| StringIntPair |]++spec :: Spec+spec = do+  describe "Parameterized types" $ do+    describe "Polymorphic types (Container Int <-> IntContainer)" $ do+      it "maps to polymorphic Container type" $ do+        let intCont = IntContainer 42 "number"+            mapped = W.from intCont :: Container Int+        mapped `shouldBe` Container 42 "number"++      it "maps from polymorphic Container type" $ do+        let container = Container 99 "test" :: Container Int+            mapped = W.from container :: IntContainer+        mapped `shouldBe` IntContainer 99 "test"++    describe "Multiple type parameters (Pair String Int <-> StringIntPair)" $ do+      it "maps to polymorphic Pair type" $ do+        let pair = StringIntPair "hello" 123+            mapped = W.from pair :: Pair String Int+        mapped `shouldBe` Pair "hello" 123++      it "maps from polymorphic Pair type" $ do+        let pair = Pair "world" 456 :: Pair String Int+            mapped = W.from pair :: StringIntPair+        mapped `shouldBe` StringIntPair "world" 456++      it "works bidirectionally" $ do+        let original = StringIntPair "test" 789+            roundtrip = W.from (W.from original :: Pair String Int) :: StringIntPair+        roundtrip `shouldBe` original++
+ test/Warlock/THSpec.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Warlock.THSpec (spec) where++import Test.Hspec+import qualified Witch as W+import Warlock++-- Structural mapping by position+data Foo = FirstCase Int | SecondCase Bool+  deriving (Show, Eq)++data IntOrBool = LeftInt Int | RightBool Bool+  deriving (Show, Eq)++deriveAutomap ByPosition ''Foo ''IntOrBool+deriveAutomap ByPosition ''IntOrBool ''Foo++data Result = Success String | Failure Int+  deriving (Show, Eq)++data HttpResult = OkResponse String | ErrorResponse Int+  deriving (Show, Eq)++deriveAutomapBoth ByPosition ''Result ''HttpResult++data OptionalString = NoneStr | SomeStr String+  deriving (Show, Eq)++data MaybeString = NothingStr | JustStr String+  deriving (Show, Eq)++deriveAutomapBoth ByPosition ''OptionalString ''MaybeString++spec :: Spec+spec = do+  describe "Witch.TH structural mapping" $ do+    it "maps constructors by position, not name" $ do+      let foo1 = FirstCase 42+      let intOrBool1 = from foo1 :: IntOrBool+      intOrBool1 `shouldBe` LeftInt 42++      let foo2 = SecondCase True+      let intOrBool2 = from foo2 :: IntOrBool+      intOrBool2 `shouldBe` RightBool True++    it "works bidirectionally" $ do+      let orig = LeftInt 99+      let foo = from orig :: Foo+      let back = from foo :: IntOrBool+      back `shouldBe` orig++    it "maps by position for different constructor names" $ do+      let result = Success "all good"+      let http = from result :: HttpResult+      http `shouldBe` OkResponse "all good"++      let err = Failure 404+      let httpErr = from err :: HttpResult+      httpErr `shouldBe` ErrorResponse 404++    it "handles zero-argument constructors" $ do+      let none = NoneStr+      let maybe = from none :: MaybeString+      maybe `shouldBe` NothingStr++      let some = SomeStr "value"+      let maybeVal = from some :: MaybeString+      maybeVal `shouldBe` JustStr "value"+
+ test/Warlock/TweakSpec.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+module Warlock.TweakSpec (spec) where++import Test.Hspec+import Warlock+import qualified Warlock.Tweak as Tweak+import Warlock.Tweak (tweakType, TweakStrategy(..), defaultTweakConfig, withFields, withoutFields, withAutoDerive, pick, omit, pick', omit')+import Witch (From, from)+import Language.Haskell.TH (mkName)++--------------------------------------------------------------------------------+-- Test Types++data User = User+  { userId :: Int+  , userName :: String+  , userEmail :: String+  , userPassword :: String+  , userCreatedAt :: String+  } deriving (Show, Eq)++data Product = Product+  { productId :: Int+  , productName :: String+  , productPrice :: Double+  , productDescription :: String+  } deriving (Show, Eq)++--------------------------------------------------------------------------------+-- Test 1: Drop specific fields (DTO pattern) with prefix to avoid collision++tweakType (DropFrom $ (defaultTweakConfig+            `withoutFields` ['userPassword, 'userCreatedAt])+            `Tweak.addPrefix` "dto")+          "UserDTO"+          ''User++--------------------------------------------------------------------------------+-- Test 2: Keep only specific fields with prefix++tweakType (KeepOnly $ (defaultTweakConfig+            `withFields` ['userId, 'userName])+            `Tweak.addPrefix` "min")+          "UserMinimal"+          ''User++--------------------------------------------------------------------------------+-- Test 3: Strip prefix (avoiding 'id' conflict with Prelude)++tweakType (KeepOnly $ (defaultTweakConfig+            `withFields` ['userName, 'userEmail])+            `Tweak.stripPrefix` "user")+          "UserClean"+          ''User++--------------------------------------------------------------------------------+-- Test 4: Add prefix++tweakType (KeepOnly $ (defaultTweakConfig+            `withFields` ['productId, 'productName])+            `Tweak.addPrefix` "dto")+          "ProductDTO"+          ''Product++--------------------------------------------------------------------------------+-- Test 5: Replace prefix++tweakType (KeepOnly $ (defaultTweakConfig+            `withFields` ['productId, 'productName, 'productPrice])+            `Tweak.replacePrefix` ("product", "item"))+          "ItemSummary"+          ''Product++--------------------------------------------------------------------------------+-- Test 6: Explicit field renaming++tweakType (KeepOnly $ (defaultTweakConfig+            `withFields` ['userId, 'userName])+            `Tweak.withRenames` [('userId, mkName "renamedId"), ('userName, mkName "renamedName")])+          "UserRenamed"+          ''User++--------------------------------------------------------------------------------+-- Test 7: Disable auto-derive++tweakType (KeepOnly $ ((defaultTweakConfig+            `withFields` ['userId, 'userName])+            `Tweak.addPrefix` "no")+            `withAutoDerive` False)+          "UserNoInstances"+          ''User++-- Note: Not manually deriving instance for this test since it's about disabling auto-derive++--------------------------------------------------------------------------------+-- TypeScript-style API Tests++-- Test 8: pick (TypeScript-style) with prefix to avoid collision+pick' (defaultTweakConfig `Tweak.addPrefix` "pick") ''User "UserPick" ['userId, 'userName]++-- Test 9: omit (TypeScript-style) with prefix to avoid collision+omit' (defaultTweakConfig `Tweak.addPrefix` "omit") ''User "UserOmit" ['userPassword, 'userCreatedAt]++-- Test 10: pick with config (add prefix to avoid collision with test 3)+pick' (defaultTweakConfig `Tweak.stripPrefix` "user" `Tweak.addPrefix` "ts") ''User "UserPickStripped" ['userName, 'userEmail]++-- Test 11: omit with config (use different prefix to avoid collision with test 1)+omit' (defaultTweakConfig `Tweak.addPrefix` "api") ''User "UserOmitAPI" ['userPassword]++--------------------------------------------------------------------------------+-- Test Specs++spec :: Spec+spec = do+  describe "Warlock.Tweak" $ do++    describe "DropFrom" $ do+      it "creates type without specified fields" $ do+        let user = User 1 "Alice" "alice@example.com" "secret123" "2025-01-01"+        let dto = from user :: UserDTO+        case dto of+          UserDTO dtouid dtoname dtoemail -> do+            dtouid `shouldBe` 1+            dtoname `shouldBe` "Alice"+            dtoemail `shouldBe` "alice@example.com"++    describe "KeepOnly" $ do+      it "creates type with only specified fields" $ do+        let user = User 2 "Bob" "bob@example.com" "secret456" "2025-01-02"+        let minimal = from user :: UserMinimal+        case minimal of+          UserMinimal minuid minname -> do+            minuid `shouldBe` 2+            minname `shouldBe` "Bob"++    describe "stripPrefix" $ do+      it "removes prefix from field names" $ do+        let user = User 3 "Charlie" "charlie@example.com" "secret789" "2025-01-03"+        let clean = from user :: UserClean+        case clean of+          UserClean cleanname cleanemail -> do+            cleanname `shouldBe` "Charlie"+            cleanemail `shouldBe` "charlie@example.com"++    describe "addPrefix" $ do+      it "adds prefix to field names" $ do+        let product = Product 1 "Widget" 19.99 "A useful widget"+        let dto = from product :: ProductDTO+        case dto of+          ProductDTO dtoid dtoname -> do+            dtoid `shouldBe` 1+            dtoname `shouldBe` "Widget"++    describe "replacePrefix" $ do+      it "replaces one prefix with another" $ do+        let product = Product 2 "Gadget" 29.99 "An amazing gadget"+        let summary = from product :: ItemSummary+        case summary of+          ItemSummary itemid itemname itemprice -> do+            itemid `shouldBe` 2+            itemname `shouldBe` "Gadget"+            itemprice `shouldBe` 29.99++    describe "withRenames" $ do+      it "applies explicit field renames" $ do+        let user = User 4 "Diana" "diana@example.com" "secret000" "2025-01-04"+        let renamed = from user :: UserRenamed+        case renamed of+          UserRenamed rid rname -> do+            rid `shouldBe` 4+            rname `shouldBe` "Diana"++    describe "withAutoDerive False" $ do+      it "creates type without auto-generating instances" $ do+        -- Just test that the type was created successfully+        -- We can't test conversion since no instance was generated+        let noInstUser = UserNoInstances 5 "Eve"+        case noInstUser of+          UserNoInstances nouid noname -> do+            nouid `shouldBe` 5+            noname `shouldBe` "Eve"++    describe "TypeScript-style API" $ do+      describe "pick" $ do+        it "picks specific fields (TypeScript Pick<T, K> style)" $ do+          let user = User 6 "Frank" "frank@example.com" "secret222" "2025-01-06"+          let picked = from user :: UserPick+          case picked of+            UserPick pickuid pickname -> do+              pickuid `shouldBe` 6+              pickname `shouldBe` "Frank"++      describe "omit" $ do+        it "omits specific fields (TypeScript Omit<T, K> style)" $ do+          let user = User 7 "Grace" "grace@example.com" "secret333" "2025-01-07"+          let omitted = from user :: UserOmit+          case omitted of+            UserOmit omituid omitname omitemail -> do+              omituid `shouldBe` 7+              omitname `shouldBe` "Grace"+              omitemail `shouldBe` "grace@example.com"++      describe "pick with config" $ do+        it "picks fields and applies prefix operations" $ do+          let user = User 8 "Henry" "henry@example.com" "secret444" "2025-01-08"+          let picked = from user :: UserPickStripped+          case picked of+            UserPickStripped tsname tsemail -> do+              tsname `shouldBe` "Henry"+              tsemail `shouldBe` "henry@example.com"++      describe "omit with config" $ do+        it "omits fields and applies prefix operations" $ do+          let user = User 9 "Iris" "iris@example.com" "secret555" "2025-01-09"+          let omitted = from user :: UserOmitAPI+          case omitted of+            UserOmitAPI apiuid apiname apiemail apicreated -> do+              apiuid `shouldBe` 9+              apiname `shouldBe` "Iris"+              apiemail `shouldBe` "iris@example.com"+              apicreated `shouldBe` "2025-01-09"+
+ test/Warlock/TypeConversionSpec.hs view
@@ -0,0 +1,354 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module Warlock.TypeConversionSpec (spec) where++import Test.Hspec+import qualified Witch as W+import Warlock+import Data.Text (Text)++--------------------------------------------------------------------------------+-- Higher-Kinded From Type Classes (similar to aeson's ToJSON1/FromJSON1)+--------------------------------------------------------------------------------+--+-- This demonstrates an elegant solution to the problem of type conversions+-- in parameterized types. Instead of manually defining:+--+--   instance From (Maybe String) (Maybe Text)+--   instance From [String] [Text]+--   instance From (Either String b) (Either Text b)+--   ... and so on for every combination ...+--+-- We define two type classes that capture the *structure* of the conversion:+--+-- * From1: For single-parameter type constructors (Functors)+-- * From2: For two-parameter type constructors (Bifunctors)+--+-- Then we provide ONE generic instance that says:+--   "If you have a From1 instance for the container type,+--    and a From instance for the element type,+--    you automatically get a From instance for the container of elements"+--+-- This is the same pattern used by aeson (ToJSON1/FromJSON1),+-- hashable (Hashable1), and other libraries for dealing with+-- parameterized types in a compositional way.+--+--------------------------------------------------------------------------------++-- | Type class for converting between type constructors with one parameter.+-- This allows automatic derivation of From instances for parameterized types.+--+-- Example: if you have From String Text, and From1 Maybe,+-- you automatically get From (Maybe String) (Maybe Text)+class From1 f g | f -> g, g -> f where+  -- | Lift a conversion function into the type constructor+  liftFrom :: (a -> b) -> f a -> g b++-- | Type class for converting between type constructors with two parameters.+class From2 f g | f -> g, g -> f where+  -- | Lift two conversion functions into the type constructor+  liftFrom2 :: (a -> c) -> (b -> d) -> f a b -> g c d++-- Instances for common Functors (From1)+instance From1 Maybe Maybe where+  liftFrom = fmap++instance From1 [] [] where+  liftFrom = map++-- Instances for Bifunctors (From2)+instance From2 Either Either where+  liftFrom2 f _ (Left a)  = Left (f a)+  liftFrom2 _ g (Right b) = Right (g b)++instance From2 (,) (,) where+  liftFrom2 f g (a, b) = (f a, g b)++-- Generic instances that use From1 to derive From instances automatically+-- These are overlappable because more specific instances can override them+instance {-# OVERLAPPABLE #-} (From1 f g, W.From a b) => W.From (f a) (g b) where+  from = liftFrom W.from++-- For Either, we typically want to convert the Left type but keep Right unchanged+-- This is more specific than the From1 instance, so it takes precedence+instance {-# OVERLAPS #-} (From2 f g, W.From a c) => W.From (f a b) (g c b) where+  from = liftFrom2 W.from id++-- We'll add specific instances for record lists after we define the types++-- Now, thanks to From1, we automatically get these instances without defining them:+-- * From (Maybe String) (Maybe Text)+-- * From [String] [Text]+-- * From (Either String b) (Either Text b)+-- * And any other Functor/Bifunctor combinations!++--------------------------------------------------------------------------------+-- String <-> Text Conversions+--------------------------------------------------------------------------------++-- Simple record with String -> Text conversion+data PersonString = PersonString+  { personName :: String+  , personAge :: Int+  } deriving (Show, Eq)++data PersonText = PersonText+  { personName :: Text+  , personAge :: Int+  } deriving (Show, Eq)++deriveAutomap (ByName defaultConfig) ''PersonString ''PersonText+deriveAutomap (ByName defaultConfig) ''PersonText ''PersonString++-- Nested Maybe with type conversion+data MaybeStringRecord = MaybeStringRecord+  { nickname :: Maybe String+  , score :: Int+  } deriving (Show, Eq)++data MaybeTextRecord = MaybeTextRecord+  { nickname :: Maybe Text+  , score :: Int+  } deriving (Show, Eq)++deriveAutomap (ByName defaultConfig) ''MaybeStringRecord ''MaybeTextRecord++-- List with type conversion+data ListStringRecord = ListStringRecord+  { tags :: [String]+  , count :: Int+  } deriving (Show, Eq)++data ListTextRecord = ListTextRecord+  { tags :: [Text]+  , count :: Int+  } deriving (Show, Eq)++deriveAutomap (ByName defaultConfig) ''ListStringRecord ''ListTextRecord++-- Either with type conversion+data EitherStringRecord = EitherStringRecord+  { result :: Either String Int+  } deriving (Show, Eq)++data EitherTextRecord = EitherTextRecord+  { result :: Either Text Int+  } deriving (Show, Eq)++deriveAutomap (ByName defaultConfig) ''EitherStringRecord ''EitherTextRecord++-- Multiple fields with different conversions+data MixedSource = MixedSource+  { label :: String+  , description :: String+  , value :: Int+  } deriving (Show, Eq)++data MixedDest = MixedDest+  { label :: Text+  , description :: Text+  , value :: Int+  } deriving (Show, Eq)++deriveAutomap (ByName defaultConfig) ''MixedSource ''MixedDest++--------------------------------------------------------------------------------+-- Integer Type Conversions+--------------------------------------------------------------------------------++-- Note: For numeric type conversions, you would need to add From instances+-- witch library doesn't provide all numeric conversions by default+-- Here we'll just demonstrate with Natural/Integer which witch does support++-- Example: you can add your own instances like:+-- instance W.From Int Int32 where from = fromIntegral+-- instance W.From Word8 Word16 where from = fromIntegral++--------------------------------------------------------------------------------+-- Nested Type Conversions+--------------------------------------------------------------------------------++-- Record containing another record that needs type conversion+data InnerString = InnerString+  { innerText :: String+  } deriving (Show, Eq)++data InnerText = InnerText+  { innerText :: Text+  } deriving (Show, Eq)++deriveAutomap (ByName defaultConfig) ''InnerString ''InnerText++data OuterString = OuterString+  { outerLabel :: String+  , inner :: InnerString+  } deriving (Show, Eq)++data OuterText = OuterText+  { outerLabel :: Text+  , inner :: InnerText+  } deriving (Show, Eq)++deriveAutomap (ByName defaultConfig) ''OuterString ''OuterText++-- List of records with type conversion+data ItemString = ItemString+  { itemName :: String+  } deriving (Show, Eq)++data ItemText = ItemText+  { itemName :: Text+  } deriving (Show, Eq)++deriveAutomap (ByName defaultConfig) ''ItemString ''ItemText++data CartString = CartString+  { items :: [ItemString]+  } deriving (Show, Eq)++data CartText = CartText+  { items :: [ItemText]+  } deriving (Show, Eq)++deriveAutomap (ByName defaultConfig) ''CartString ''CartText++-- The derive calls above automatically generate From instances that use witch's+-- From instances to convert nested types. For lists of records, we need a helper:+instance W.From [ItemString] [ItemText] where+  from = map W.from++--------------------------------------------------------------------------------+-- Tests+--------------------------------------------------------------------------------++spec :: Spec+spec = do+  describe "String <-> Text conversions" $ do+    it "converts String to Text in simple record" $ do+      let person = PersonString "Alice" 30+      let converted = W.from person :: PersonText+      case converted of+        PersonText name age -> do+          name `shouldBe` "Alice"+          age `shouldBe` 30++    it "converts Text to String in simple record" $ do+      let person = PersonText "Bob" 25+      let converted = W.from person :: PersonString+      case converted of+        PersonString name age -> do+          name `shouldBe` "Bob"+          age `shouldBe` 25++    it "converts Maybe String to Maybe Text" $ do+      let record = MaybeStringRecord (Just "nickname") 100+      let converted = W.from record :: MaybeTextRecord+      case converted of+        MaybeTextRecord nick _ -> nick `shouldBe` Just "nickname"++    it "handles Nothing in Maybe conversions" $ do+      let record = MaybeStringRecord Nothing 100+      let converted = W.from record :: MaybeTextRecord+      case converted of+        MaybeTextRecord nick _ -> nick `shouldBe` Nothing++    it "converts [String] to [Text]" $ do+      let record = ListStringRecord ["tag1", "tag2", "tag3"] 3+      let converted = W.from record :: ListTextRecord+      case converted of+        ListTextRecord t c -> do+          t `shouldBe` ["tag1", "tag2", "tag3"]+          c `shouldBe` 3++    it "converts empty list" $ do+      let record = ListStringRecord [] 0+      let converted = W.from record :: ListTextRecord+      case converted of+        ListTextRecord t _ -> t `shouldBe` []++    it "converts Either String to Either Text (Left case)" $ do+      let record = EitherStringRecord (Left "error")+      let converted = W.from record :: EitherTextRecord+      case converted of+        EitherTextRecord r -> r `shouldBe` Left "error"++    it "converts Either String to Either Text (Right case)" $ do+      let record = EitherStringRecord (Right 42)+      let converted = W.from record :: EitherTextRecord+      case converted of+        EitherTextRecord r -> r `shouldBe` Right 42++    it "converts multiple String fields to Text" $ do+      let record = MixedSource "Label" "Description" 999+      let converted = W.from record :: MixedDest+      case converted of+        MixedDest l d v -> do+          l `shouldBe` "Label"+          d `shouldBe` "Description"+          v `shouldBe` 999++  -- Numeric conversions would require additional From instances+  -- which witch doesn't provide by default++  describe "Nested type conversions" $ do+    it "converts nested records with type conversions" $ do+      let innerRec = InnerString "inner text"+      let outerRec = OuterString "outer label" innerRec+      let converted = W.from outerRec :: OuterText+      case converted of+        OuterText lbl innerConverted -> do+          lbl `shouldBe` "outer label"+          case innerConverted of+            InnerText innerTxt -> innerTxt `shouldBe` "inner text"++    it "converts list of records with type conversions" $ do+      let itemList = [ItemString "item1", ItemString "item2"]+      let cart = CartString itemList+      let converted = W.from cart :: CartText+      case converted of+        CartText convertedItems -> do+          length convertedItems `shouldBe` 2+          case convertedItems of+            (ItemText name1 : ItemText name2 : _) -> do+              name1 `shouldBe` "item1"+              name2 `shouldBe` "item2"+            _ -> expectationFailure "Expected at least 2 items"++  describe "From1/From2 automatic derivation" $ do+    it "automatically derives Maybe conversions via From1" $ do+      -- No manual instance needed! From1 automatically provides this+      let maybeStr = Just "hello" :: Maybe String+      let maybeText = W.from maybeStr :: Maybe Text+      maybeText `shouldBe` Just "hello"++    it "automatically derives list conversions via From1" $ do+      -- No manual instance needed! From1 automatically provides this+      let strList = ["one", "two", "three"] :: [String]+      let textList = W.from strList :: [Text]+      textList `shouldBe` ["one", "two", "three"]++    it "automatically derives Either conversions via From2" $ do+      -- No manual instance needed! From2 automatically provides this+      let eitherStr = Left "error" :: Either String Int+      let eitherText = W.from eitherStr :: Either Text Int+      eitherText `shouldBe` Left "error"++    it "works with nested Maybe [String]" $ do+      -- Composition of From1 instances!+      let nested = Just ["a", "b", "c"] :: Maybe [String]+      let converted = W.from nested :: Maybe [Text]+      converted `shouldBe` Just ["a", "b", "c"]++    it "works with Either (Maybe String) Int" $ do+      -- Composition of From2 and From1!+      let complex = Left (Just "error") :: Either (Maybe String) Int+      let converted = W.from complex :: Either (Maybe Text) Int+      converted `shouldBe` Left (Just "error")+
+ test/Warlock/VirtualFieldsSpec.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+module Warlock.VirtualFieldsSpec (spec) where++import Test.Hspec+import Warlock+import qualified Witch as W+import GHC.Records (HasField(..))++-- Virtual field example: Person with computed fullName+data Person = Person+  { firstName :: String+  , lastName :: String+  , age :: Int+  } deriving (Show, Eq)++instance HasField "fullName" Person String where+  getField (Person first last _) = first ++ " " ++ last++instance HasField "category" Person String where+  getField (Person _ _ a) = if a < 18 then "minor" else "adult"++data Employee = Employee+  { empName :: String+  , empAge :: Int+  , ageGroup :: String+  } deriving (Show, Eq)++deriveAutomap+  ( ByName $+    defaultConfig+    `withRules`+    [ virtualField 'empName "fullName"+    , rename 'empAge 'age+    , virtualField 'ageGroup "category"+    ]+  )+  ''Person+  ''Employee++-- Rectangle with computed fields+data Rectangle = Rectangle+  { width :: Double+  , height :: Double+  } deriving (Show, Eq)++instance HasField "area" Rectangle Double where+  getField (Rectangle w h) = w * h++instance HasField "perimeter" Rectangle Double where+  getField (Rectangle w h) = 2 * (w + h)++instance HasField "aspectRatio" Rectangle Double where+  getField (Rectangle w h) = w / h++data RectangleInfo = RectangleInfo+  { size :: Double+  , border :: Double+  , ratio :: Double+  } deriving (Show, Eq)++deriveAutomap+  ( ByName $+    defaultConfig+    { staticRules =+        [ virtualField 'size "area"+        , virtualField 'border "perimeter"+        , virtualField 'ratio "aspectRatio"+        ]+    }+  )+  ''Rectangle+  ''RectangleInfo++spec :: Spec+spec = do+  describe "Virtual fields (HasField)" $ do+    it "can map from computed fullName field" $ do+      let person = Person "Alice" "Smith" 30+      let employee = W.from person :: Employee+      empName employee `shouldBe` "Alice Smith"+      empAge employee `shouldBe` 30+      ageGroup employee `shouldBe` "adult"++    it "computes category based on age" $ do+      let minor = Person "Bob" "Jones" 15+      let emp = W.from minor :: Employee+      ageGroup emp `shouldBe` "minor"++    it "can map multiple computed fields at once" $ do+      let rect = Rectangle 4.0 3.0+      let info = W.from rect :: RectangleInfo+      size info `shouldBe` 12.0+      border info `shouldBe` 14.0+      ratio info `shouldSatisfy` (\r -> abs (r - 1.333333) < 0.001)+
+ warlock.cabal view
@@ -0,0 +1,79 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.38.1.+--+-- see: https://github.com/sol/hpack++name:           warlock+version:        0.1.0.0+description:    Please see the README on GitHub at <https://github.com/githubuser/warlock#readme>+homepage:       https://github.com/githubuser/warlock#readme+bug-reports:    https://github.com/githubuser/warlock/issues+author:         Author name here+maintainer:     example@example.com+copyright:      2025 Author name here+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/githubuser/warlock++library+  exposed-modules:+      Warlock+      Warlock.HKD+      Warlock.Tweak+      Warlock.Tutorial+  other-modules:+      Paths_warlock+  autogen-modules:+      Paths_warlock+  hs-source-dirs:+      src+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      barbies >=2.0+    , base >=4.7 && <5+    , template-haskell+    , witch+  default-language: Haskell2010++test-suite warlock-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Warlock.ADTSpec+      Warlock.AutoSpec+      Warlock.ComposableRulesSpec+      Warlock.ComputedFieldsSpec+      Warlock.ConstructorTransformSpec+      Warlock.DisassembleFieldsSpec+      Warlock.EdgeCaseSpec+      Warlock.HKDSpec+      Warlock.ParameterizedTypesSpec+      Warlock.THSpec+      Warlock.TweakSpec+      Warlock.TypeConversionSpec+      Warlock.VirtualFieldsSpec+      Paths_warlock+  autogen-modules:+      Paths_warlock+  hs-source-dirs:+      test+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      barbies >=2.0+    , base >=4.7 && <5+    , containers+    , hspec >=2.0+    , hspec-discover+    , template-haskell+    , text+    , warlock+    , witch+  default-language: Haskell2010