diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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` and `Omit`. + +### 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) +pick ''User "UserSummary" ['userId, 'userName] + +-- Omit sensitive fields (TypeScript Omit) +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`): +```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`): +```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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Warlock.hs b/src/Warlock.hs new file mode 100644 --- /dev/null +++ b/src/Warlock.hs @@ -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 diff --git a/src/Warlock/HKD.hs b/src/Warlock/HKD.hs new file mode 100644 --- /dev/null +++ b/src/Warlock/HKD.hs @@ -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" + diff --git a/src/Warlock/Tutorial.hs b/src/Warlock/Tutorial.hs new file mode 100644 --- /dev/null +++ b/src/Warlock/Tutorial.hs @@ -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\@ and @Omit\@. +-- +-- == 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\) +-- 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\) +-- 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. + diff --git a/src/Warlock/Tweak.hs b/src/Warlock/Tweak.hs new file mode 100644 --- /dev/null +++ b/src/Warlock/Tweak.hs @@ -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@ 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@ 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] + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Warlock/ADTSpec.hs b/test/Warlock/ADTSpec.hs new file mode 100644 --- /dev/null +++ b/test/Warlock/ADTSpec.hs @@ -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" + diff --git a/test/Warlock/AutoSpec.hs b/test/Warlock/AutoSpec.hs new file mode 100644 --- /dev/null +++ b/test/Warlock/AutoSpec.hs @@ -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 + diff --git a/test/Warlock/ComposableRulesSpec.hs b/test/Warlock/ComposableRulesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Warlock/ComposableRulesSpec.hs @@ -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" + diff --git a/test/Warlock/ComputedFieldsSpec.hs b/test/Warlock/ComputedFieldsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Warlock/ComputedFieldsSpec.hs @@ -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 + diff --git a/test/Warlock/ConstructorTransformSpec.hs b/test/Warlock/ConstructorTransformSpec.hs new file mode 100644 --- /dev/null +++ b/test/Warlock/ConstructorTransformSpec.hs @@ -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 + diff --git a/test/Warlock/DisassembleFieldsSpec.hs b/test/Warlock/DisassembleFieldsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Warlock/DisassembleFieldsSpec.hs @@ -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" + diff --git a/test/Warlock/EdgeCaseSpec.hs b/test/Warlock/EdgeCaseSpec.hs new file mode 100644 --- /dev/null +++ b/test/Warlock/EdgeCaseSpec.hs @@ -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" + diff --git a/test/Warlock/HKDSpec.hs b/test/Warlock/HKDSpec.hs new file mode 100644 --- /dev/null +++ b/test/Warlock/HKDSpec.hs @@ -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 + diff --git a/test/Warlock/ParameterizedTypesSpec.hs b/test/Warlock/ParameterizedTypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Warlock/ParameterizedTypesSpec.hs @@ -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 + + diff --git a/test/Warlock/THSpec.hs b/test/Warlock/THSpec.hs new file mode 100644 --- /dev/null +++ b/test/Warlock/THSpec.hs @@ -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" + diff --git a/test/Warlock/TweakSpec.hs b/test/Warlock/TweakSpec.hs new file mode 100644 --- /dev/null +++ b/test/Warlock/TweakSpec.hs @@ -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 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 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" + diff --git a/test/Warlock/TypeConversionSpec.hs b/test/Warlock/TypeConversionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Warlock/TypeConversionSpec.hs @@ -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") + diff --git a/test/Warlock/VirtualFieldsSpec.hs b/test/Warlock/VirtualFieldsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Warlock/VirtualFieldsSpec.hs @@ -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) + diff --git a/warlock.cabal b/warlock.cabal new file mode 100644 --- /dev/null +++ b/warlock.cabal @@ -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 +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