type-machine (empty) → 0.1.0.0
raw patch · 24 files changed
+1790/−0 lines, 24 filesdep +basedep +containersdep +criterionsetup-changed
Dependencies added: base, containers, criterion, extensible, hspec, lens, mtl, superrecord, syb, template-haskell, type-machine
Files
- CHANGELOG.md +11/−0
- LICENSE +26/−0
- README.md +92/−0
- Setup.hs +3/−0
- benchmarks/runtime/Benchmark.hs +120/−0
- benchmarks/runtime/Gen.hs +195/−0
- benchmarks/runtime/Main.hs +7/−0
- examples/Vector.hs +18/−0
- src/TypeMachine.hs +28/−0
- src/TypeMachine/Functions.hs +290/−0
- src/TypeMachine/Infix.hs +78/−0
- src/TypeMachine/Internal/Utils.hs +9/−0
- src/TypeMachine/Log.hs +36/−0
- src/TypeMachine/TH.hs +13/−0
- src/TypeMachine/TH/Internal/Utils.hs +18/−0
- src/TypeMachine/TH/Is.hs +221/−0
- src/TypeMachine/TM.hs +51/−0
- src/TypeMachine/TM/Liftable.hs +27/−0
- src/TypeMachine/TM/Syntax.hs +51/−0
- src/TypeMachine/Type.hs +88/−0
- test/Spec.hs +1/−0
- test/TypeMachine/FunctionsSpec.hs +227/−0
- test/TypeMachine/IsSpec.hs +44/−0
- type-machine.cabal +136/−0
+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog for `type-machine`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## Unreleased++## 0.1.0.0 - YYYY-MM-DD
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright 2025 Author name here++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,92 @@+# Type Machine++TypeScript offers [*Utility Types*](https://www.typescriptlang.org/docs/handbook/utility-types.html), which allows creating a type from another.+There is no way of doing this in Haskell. You have to maintain all your types yourselves, and handle conversions from one to another yourself.++`type-machine` brings a solution to this problem. Using Template Haskell, generate new types using Type-Script-inspired functions like `omit`, `pick` and `record`.+It can also generate a conversion type-class that allows you to access fields and convert one type to another.++- Requirements+ - Requires a couple of language extensions (see example)+ - Input ADT must have exactly one record constructor+- Limitations+ - Does not support type parameters yet+ - `require` and `partial` only work with `Maybe` fields ++## Examples++```haskell+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DuplicateRecordFields #-}++data User = User {+ id :: Int,+ name :: String,+ email :: Maybe String+}++$(type_ "UserWithEmail" (required ["email"] <::> ''User))+-- data UserWithEmail = UserWithEmail {+-- id :: Int,+-- name :: String,+-- email :: String+-- }++$(type_ "UserWithoutId" (omit ["id"] <::> ''User))+-- data UserWithoutId = UserWithoutId {+-- name :: String,+-- email :: String+-- }++$(type_ "UserId" (pick ["id"] <::> ''User))+-- data UserId = UserId {+-- id :: Int+-- }++$(type_ "Vector3" (record ["x", "y", "z"] [t|Int|]))+-- data Vector3 = Vector3 {+-- x :: Int,+-- y :: Int,+-- z :: Int+-- }++-----+-- Type Parameters+-----++data MyMaybe a = { content :: Maybe a }++$(type_ "MyString" (apply [t|String|] <::> ''MyMaybe))+-- data MyString = MyString { +-- content :: Maybe String+-- }++-----+-- Is+-----++$(declareIs ''User)+-- class IsUser a where+-- getId :: a -> Int+-- getName :: a -> String+-- getEmail :: a -> String+-- setId :: Int -> a -> a+-- setName :: String -> a -> a+-- setEmail :: String -> a -> a+--+-- instance IsUser User where+-- getId = id+-- getName = name+-- getEmail = email+-- setId = ...+-- setName = ...+-- setEmail = ...++$(type_ "UserWithoutEmail" (omit ["email"] <::> ''User))+$(deriveIs ''User ''UserWithoutEmail)+-- instance IsUser UserWithoutEmail where+-- ...++$(type_ "UserWithoutId" (omit ["id"] <::> ''User))+$(deriveIs ''User ''UserWithoutId) -- Will fail+```
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ benchmarks/runtime/Benchmark.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wno-missing-signatures #-}+{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}++module Benchmark (benchmarks) where++import Control.Lens ((^.))+import Criterion.Main+import Data.Functor+import Gen+import SuperRecord (get)++$(genWithFieldCount 2)+$(genWithFieldCount 4)+$(genWithFieldCount 5)+$(genWithFieldCount 10)+$(genWithFieldCount 15)+$(genWithFieldCount 20)++benchmarks :: [Benchmark]+benchmarks = [build, traversals]++data Case = TM | SuperRecord | Extensible++buildRecord :: Case -> Int -> ()+buildRecord c n = flip seq () $ case n of+ 2 -> case c of+ TM -> field2_1 mkRecordTM2+ SuperRecord -> get #fSR2_1 mkSuperRRecord2+ Extensible -> mkExtensibleRecord2 ^. #fE2_1+ 4 -> case c of+ TM -> field4_1 mkRecordTM4+ SuperRecord -> get #fSR4_3 mkSuperRRecord4+ Extensible -> mkExtensibleRecord4 ^. #fE4_3+ 5 -> case c of+ TM -> field5_1 mkRecordTM5+ SuperRecord -> get #fSR5_4 mkSuperRRecord5+ Extensible -> mkExtensibleRecord5 ^. #fE5_4+ 10 -> case c of+ TM -> field10_9 mkRecordTM10+ SuperRecord -> get #fSR10_9 mkSuperRRecord10+ Extensible -> mkExtensibleRecord10 ^. #fE10_9+ 15 -> case c of+ TM -> field15_14 mkRecordTM15+ SuperRecord -> get #fSR15_14 mkSuperRRecord15+ Extensible -> mkExtensibleRecord15 ^. #fE15_14+ 20 -> case c of+ TM -> field20_19 mkRecordTM20+ SuperRecord -> get #fSR20_19 mkSuperRRecord20+ Extensible -> mkExtensibleRecord20 ^. #fE20_19+ _ -> error "unhandled n"++build :: Benchmark+build =+ bgroup+ "build"+ $ depths <&> \n ->+ bgroup+ (show n)+ ( cases <&> \(bname, case_) ->+ bench bname $+ nf+ (uncurry buildRecord)+ (case_, n)+ )+ where+ depths = [2, 4, 5, 10, 20]+ cases = [("tm", TM), ("superrecord", SuperRecord), ("extensible", Extensible)]++traversals :: Benchmark+traversals =+ bgroup+ "traverse"+ [ bgroup+ "2"+ [ bench "tm" $ nf sumRecordTM2 mkRecordTM2+ , bench "superrecord" $ nf sumSuperRRecord2 mkSuperRRecord2+ , bench "extensible" $ nf sumExtensibleRecord2 mkExtensibleRecord2+ ]+ , bgroup+ "4"+ [ bench "tm" $ nf sumRecordTM4 mkRecordTM4+ , bench "superrecord" $ nf sumSuperRRecord4 mkSuperRRecord4+ , bench "extensible" $ nf sumExtensibleRecord4 mkExtensibleRecord4+ ]+ , bgroup+ "5"+ [ bench "tm" $ nf sumRecordTM5 mkRecordTM5+ , bench "superrecord" $ nf sumSuperRRecord5 mkSuperRRecord5+ , bench "extensible" $ nf sumExtensibleRecord5 mkExtensibleRecord5+ ]+ , bgroup+ "10"+ [ bench "tm" $ nf sumRecordTM10 mkRecordTM10+ , bench "superrecord" $ nf sumSuperRRecord10 mkSuperRRecord10+ , bench "extensible" $ nf sumExtensibleRecord10 mkExtensibleRecord10+ ]+ , bgroup+ "15"+ [ bench "tm" $ nf sumRecordTM15 mkRecordTM15+ , bench "superrecord" $ nf sumSuperRRecord15 mkSuperRRecord15+ , bench "extensible" $ nf sumExtensibleRecord15 mkExtensibleRecord15+ ]+ , bgroup+ "20"+ [ bench "tm" $ nf sumRecordTM20 mkRecordTM20+ , bench "superrecord" $ nf sumSuperRRecord20 mkSuperRRecord20+ , bench "extensible" $ nf sumExtensibleRecord20 mkExtensibleRecord20+ ]+ ]
+ benchmarks/runtime/Gen.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wno-missing-export-lists #-}++module Gen where++import Control.Monad (forM)+import Control.Monad.Writer.Strict+import Data.Extensible+import Data.Map.Strict (fromList)+import Language.Haskell.TH hiding (Type)+import qualified Language.Haskell.TH as TH+import SuperRecord+import TypeMachine+import TypeMachine.Type (Type (Type))++genWithFieldCount :: Int -> Q [Dec]+genWithFieldCount n = do+ tm <- genTMRecord n+ superr <- genSuperrecord n+ extensible <- genExtensible n+ return $ tm ++ superr ++ extensible++withNFields :: Int -> String -> (Int -> Q TH.Type) -> TM Type+withNFields n fieldPrefix getType = do+ fields <- forM [0 .. n - 1] $ \i -> do+ let fieldName = fieldPrefix ++ show i+ fieldType <- lift $ getType i+ return (fieldName, (Bang NoSourceUnpackedness SourceStrict, fieldType))+ return (Type (TH.mkName "_") (fromList fields) [])++genTMRecord :: Int -> Q [Dec]+genTMRecord n = do+ let tyName = "RecordTM" ++ show n+ recDef <- type_ tyName $ withNFields n ("field" ++ show n ++ "_") (const [t|Int|])+ builder <- genTMRecordBuilder tyName n+ sumF <- genTMRecordSum tyName n+ return $ recDef ++ builder ++ sumF++genTMRecordBuilder :: String -> Int -> Q [Dec]+genTMRecordBuilder tyName fieldCount =+ return+ [ PragmaD $ InlineP (mkName fName) NoInline FunLike AllPhases+ , FunD+ (mkName fName)+ [Clause [] (NormalB constructorApp) []]+ ]+ where+ constructorApp = foldl (\f arg -> AppE f (LitE $ IntegerL $ fromIntegral arg)) (ConE $ mkName tyName) [0 .. fieldCount - 1]+ fName = "mk" ++ tyName++genTMRecordSum :: String -> Int -> Q [Dec]+genTMRecordSum tyName fieldCount = do+ body_ <- foldl (\rest arg -> [|$rest + $(varE arg)|]) [|0|] fieldVarNames+ sig <- sigD (mkName fName) [t|$(conT $ mkName tyName) -> Int|]+ return+ [ sig+ , PragmaD $ InlineP (mkName fName) NoInline FunLike AllPhases+ , FunD (mkName fName) [Clause [pattern_] (NormalB body_) []]+ ]+ where+ pattern_ = ConP (mkName tyName) [] (VarP <$> fieldVarNames)+ fieldVarNames = mkName . ("f" ++) . show <$> [0 .. fieldCount - 1]+ fName = "sum" ++ tyName++----------++genSuperrecord :: Int -> Q [Dec]+genSuperrecord n = do+ let tyName = "SuperRRecord" ++ show n+ recDef <- genSuperrecordType tyName n+ builder <- genSuperrecordBuilder tyName n+ sum_ <- genSuperrecordSum tyName n+ return $ recDef : builder ++ sum_++genSuperrecordType :: String -> Int -> Q Dec+genSuperrecordType tyName fCount = do+ fields <- forM [0 .. fCount - 1] $ \i -> do+ let fName = getSuperrecordFieldName fCount i+ [t|$(return $ LitT $ StrTyLit fName) := Int|]+ ty <- foldr (\arg rest -> [t|$(return arg) ': $rest|]) (return PromotedNilT) fields+ return $ TySynD (mkName tyName) [] ty++getSuperrecordFieldName :: Int -> Int -> String+getSuperrecordFieldName fCount idx = "fSR" ++ show fCount ++ "_" ++ show idx++genSuperrecordBuilder :: String -> Int -> Q [Dec]+genSuperrecordBuilder tyName fCount = do+ body_ <-+ foldr+ ( \arg rest ->+ let label = LabelE $ getSuperrecordFieldName fCount arg+ in [|$(return label) := ($(litE $ IntegerL $ fromIntegral arg) :: Int) & $rest|]+ )+ [|rnil|]+ [0 .. fCount - 1]+ sig <- sigD fName [t|SuperRecord.Record $(conT $ mkName tyName)|]++ return+ [ sig+ , PragmaD $ InlineP fName NoInline FunLike AllPhases+ , FunD fName [Clause [] (NormalB body_) []]+ ]+ where+ fName = mkName $ "mk" ++ tyName++genSuperrecordSum :: String -> Int -> Q [Dec]+genSuperrecordSum tyName fCount = do+ body_ <-+ foldl+ ( \rest arg ->+ let fieldLabel = labelE $ getSuperrecordFieldName fCount arg+ fieldGetter = [|get $fieldLabel $(varE rVar)|]+ in [|$rest + $fieldGetter|]+ )+ [|0|]+ [0 .. fCount - 1]+ sig <- sigD fName [t|SuperRecord.Record $(conT $ mkName tyName) -> Int|]+ return+ [ sig+ , PragmaD $ InlineP fName NoInline FunLike AllPhases+ , FunD fName [Clause [VarP rVar] (NormalB body_) []]+ ]+ where+ rVar = mkName "r"+ fName = mkName $ "sum" ++ tyName++--------------++genExtensible :: Int -> Q [Dec]+genExtensible n = do+ let tyName = "ExtensibleRecord" ++ show n+ recTy <- genExtensibleType tyName n+ builder <- genExtensibleBuilder tyName n+ sum_ <- genExtensibleSum tyName n+ return $ recTy ++ builder ++ sum_++getExtensibleFieldName :: Int -> Int -> String+getExtensibleFieldName fCount idx = "fE" ++ show fCount ++ "_" ++ show idx++genExtensibleType :: String -> Int -> Q [Dec]+genExtensibleType tyName fCount = do+ f <- mkField (unwords fieldNames)+ fields <- forM fieldNames $ \fName -> do [t|$(return $ LitT $ StrTyLit fName) Data.Extensible.:> Int|]+ fieldsTy <- foldr (\arg rest -> [t|$(return arg) ': $rest|]) (return PromotedNilT) fields+ let fieldsTyName = mkName $ tyName ++ "Fields"+ ty <- [t|Data.Extensible.Record $(conT fieldsTyName)|]+ return $+ f+ ++ [ TySynD fieldsTyName [] fieldsTy+ , TySynD (mkName tyName) [] ty+ ]+ where+ fieldNames = getExtensibleFieldName fCount <$> [0 .. fCount - 1]++genExtensibleBuilder :: String -> Int -> Q [Dec]+genExtensibleBuilder tyName fCount = do+ body_ <-+ foldr+ ( \arg rest ->+ let label = LabelE $ getExtensibleFieldName fCount arg+ in [|$(return label) @= (($(litE $ IntegerL $ fromIntegral arg)) :: Int) <: $rest|]+ )+ [|emptyRecord|]+ [0 .. fCount - 1]++ sig <- sigD fName [t|$(conT $ mkName tyName)|]+ return+ [ sig+ , PragmaD $ InlineP fName NoInline FunLike AllPhases+ , FunD fName [Clause [] (NormalB body_) []]+ ]+ where+ fName = mkName $ "mk" ++ tyName++genExtensibleSum :: String -> Int -> Q [Dec]+genExtensibleSum tyName fCount = do+ body_ <-+ foldl+ ( \rest arg ->+ let fieldLabel = labelE $ getExtensibleFieldName fCount arg+ fieldGetter = [|$(varE rVar) ^. $fieldLabel|]+ in [|$rest + $fieldGetter|]+ )+ [|0|]+ [0 .. fCount - 1]+ sig <- sigD fName [t|$(conT $ mkName tyName) -> Int|]+ return+ [ sig+ , PragmaD $ InlineP fName NoInline FunLike AllPhases+ , FunD fName [Clause [VarP rVar] (NormalB body_) []]+ ]+ where+ rVar = mkName "r"+ fName = mkName $ "sum" ++ tyName
+ benchmarks/runtime/Main.hs view
@@ -0,0 +1,7 @@+module Main (main) where++import qualified Benchmark+import Criterion.Main++main :: IO ()+main = defaultMain Benchmark.benchmarks
+ examples/Vector.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++module Main (main) where++import TypeMachine++$(type_ "Vector2" (record ["x", "y"] [t|Int|]))+$(defineIs ''Vector2)++$(type_ "Vector3" (union <::> ''Vector2 <:> record ["z"] [t|Int|]))+$(deriveIs ''Vector2 ''Vector3)++translateX :: (IsVector2 a) => Int -> a -> a+translateX n v = setX (n + getX v) v++main :: IO ()+main = return ()
+ src/TypeMachine.hs view
@@ -0,0 +1,28 @@+module TypeMachine (+ -- * Entrypoint+ type_,++ -- * Main Type Functions+ module TypeMachine.Functions,++ -- * Is+ defineIs,+ deriveIs,++ -- * Infixes+ (<:>),+ (<::>),+ (<.>),++ -- * Internal types+ Type,+ TM,++ -- * Log types+) where++import TypeMachine.Functions+import TypeMachine.TH+import TypeMachine.TM+import TypeMachine.TM.Syntax+import TypeMachine.Type
+ src/TypeMachine/Functions.hs view
@@ -0,0 +1,290 @@+{-# LANGUAGE FlexibleInstances #-}++module TypeMachine.Functions (+ -- * Fields+ pick,+ omit,++ -- * Record+ record,++ -- * Union and Intersection+ intersection,+ intersection',+ union,+ union',++ -- * Optional+ require,+ partial,+ partial',++ -- * Type Parameters+ apply,+ applyMany,++ -- * Utils+ keysOf,+)+where++import Control.Arrow (Arrow (second))+import Control.Monad (foldM, forM, unless, when)+import Control.Monad.Writer.Strict+import qualified Data.Foldable as Set+import Data.Generics+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Language.Haskell.TH hiding (Type, bang)+import qualified Language.Haskell.TH as TH+import TypeMachine.Internal.Utils+import TypeMachine.Log+import TypeMachine.TM+import TypeMachine.Type++-- | Mark fields are required+--+-- @+-- > data A = A { a :: Maybe Int, b :: Int }+-- > require ["a"] '<:>' 'toType' ''A+--+-- data _ = { a :: Int, b :: Int }+-- @+require :: [String] -> Type -> TM Type+require fieldsNameToRequire ty = do+ logUnknownFields fieldsNameToRequire ty+ updatedFields <- mapM (uncurry markAsRequired) (Map.toList $ fields ty)+ return ty{fields = Map.fromList updatedFields}+ where+ -- TODO Handle any type that is monadplus+ markAsRequired n (b, AppT (ConT p) t)+ | n `elem` fieldsNameToRequire && nameBase p == "Maybe" = return (n, (b, t))+ markAsRequired n r+ | n `elem` fieldsNameToRequire = addLog (fieldNotOptional n) >> return (n, r)+ markAsRequired n r = return (n, r)++-- | Pick/Select fields by name+--+-- Issues a warning when a key is not in the input 'Type'+--+-- @+-- > data A = A { a :: Int, b :: Int }+-- > pick ["a", "c"] '<:>' 'toType' ''A+--+-- data _ = { a :: Int }+-- @+pick :: [String] -> Type -> TM Type+pick namesToPick ty = do+ failIfHasTypeVariables ty+ logUnknownFields namesToPick ty+ let finalType = ty{fields = keepKeys namesToPick (fields ty)}+ logIfEmptyType finalType+ return finalType++-- | Remove fields by name+--+-- Issues a warning when a key is not in the input 'Type'+--+-- @+-- > data A = A { a :: Int, b :: Int }+-- > omit ["b", "c"] '<:>' 'toType' ''A+--+-- data _ = { a :: Int }+-- @+omit :: [String] -> Type -> TM Type+omit namesToOmit ty = do+ failIfHasTypeVariables ty+ logUnknownFields namesToOmit ty+ let resultType = ty{fields = removeKeys namesToOmit (fields ty)}+ logIfEmptyType resultType+ return resultType++-- | Keep the fields present in both types+--+-- If keys overlap, prefer the type of the left type+--+-- @+-- > data A = A { a :: Int, b :: Int }+-- > data B = B { b :: String, c :: Void }+-- > intersection '<:>' 'toType' ''A <:> 'toType' ''B+--+-- data _ = { b :: Int }+-- @+intersection :: Type -> Type -> TM Type+intersection a b = do+ failIfHasTypeVariables a+ failIfHasTypeVariables b+ let finalType = a{fields = Map.intersection (fields a) (fields b)}+ logIfEmptyType finalType+ return finalType++-- | Keep the fields present in both types+--+-- If keys overlap, prefer the type of the right type+--+-- @+-- > data A = A { a :: Int, b :: Int }+-- > data B = B { b :: String, c :: Void }+-- > intersection' '<:>' 'toType' ''A <:> 'toType' ''B+--+-- data _ = { b :: String }+-- @+intersection' :: Type -> Type -> TM Type+intersection' = flip intersection+{-# INLINE intersection' #-}++-- | Merge two types together+--+-- If keys overlap, prefer the type of the left type+--+-- @+-- > data A = A { a :: Int, b :: Int }+-- > data B = B { b :: String, c :: Void }+-- > union '<:>' 'toType' ''A <:> 'toType' ''B+--+-- data _ = { a :: Int, b :: Int, c :: Void }+-- @+union :: Type -> Type -> TM Type+union a b = do+ failIfHasTypeVariables a+ failIfHasTypeVariables b+ return $ a{fields = Map.union (fields a) (fields b)}++-- | Merge two types together+--+-- If keys overlap, prefer the type of the right type+--+-- @+-- > data A = A { a :: Int, b :: Int }+-- > data B = B { b :: String, c :: Void }+-- > union '<:>' 'toType' ''A <:> 'toType' ''B+--+-- data _ = { a :: Int, b :: String, c :: Void }+-- @+union' :: Type -> Type -> TM Type+union' = flip union+{-# INLINE union' #-}++-- | Get the names of the fields in in type+--+-- @+-- > data A = A { a :: Int, b :: Int }+-- > keysOf '<:>' 'toType' ''A+--+-- ["a", "b"]+-- @+keysOf :: Type -> TM [String]+keysOf = return . Map.keys . fields++-- | Marks all fields as 'Maybe'+--+-- Fields that already have a 'Maybe' type will not be changed.+--+-- @+-- > data A = A { a :: Int, b :: Maybe Int }+-- > partial '<:>' toType ''A+--+-- data _ = { a :: Maybe Int, b :: Maybe Int }+-- @+partial :: Type -> TM Type+partial = partial_ False++-- | Similar to 'partial'. Marks all fields as 'Maybe'+--+-- Fields that already have a 'Maybe' type will be wrapped in a 'Maybe'+--+-- @+-- > data A = A { a :: Int, b :: Maybe Int }+-- > partial' '<:>' toType ''A+--+-- data _ = { a :: Maybe Int, b :: Maybe (Maybe Int) }+-- @+partial' :: Type -> TM Type+partial' = partial_ True++partial_ :: Bool -> Type -> TM Type+partial_ rewrapMaybes ty = do+ nullableFields <- forM (fields ty) $ \field@(b, t) -> case t of+ AppT (ConT w) _ | nameBase w == "Maybe" && not rewrapMaybes -> return field+ _ -> lift $ (b,) <$> [t|Maybe $(return t)|]+ return ty{fields = nullableFields}++-- | Creates a type from a list of keys and a 'ToFieldType'+--+-- Issues a log if some keys are duplicated+--+-- @+-- > record ["a", "b"] [t|Int|]+--+-- data _ = { a :: Int, b :: Int }+-- @+record :: [String] -> Q TH.Type -> TM Type+record fNames t = do+ when (Set.length fNameSet /= length fNames) $+ addLog duplicateKey+ when (null fNames) $+ addLog emptyResultType+ fType <- lift t+ return $ Type (mkName "_") (Map.fromSet (const (bang, fType)) fNameSet) []+ where+ bang = Bang NoSourceUnpackedness NoSourceStrictness+ fNameSet = Set.fromList fNames++-- | Replaces the first type parameter with the given type+--+-- Issues a warning if there are no type variable+--+-- @+--+-- data A x = { a :: Maybe x }+--+-- > 'apply' [t|Int|] \<:\> 'toType' ''A+--+-- data _ = { a :: Maybe Int }+-- @+apply :: Q TH.Type -> Type -> TM Type+apply _ ty@(Type _ _ []) = addLogs [noTypeParameter] >> return ty+apply qt ty@(Type _ f ((tp, _) : tps)) = do+ typeParameterValue <- lift qt+ let fieldsWithTypeApplied = second (replaceTypeVar tp typeParameterValue) <$> f+ return ty{fields = fieldsWithTypeApplied, typeParams = tps}+ where+ replaceTypeVar varName value src =+ let+ mapper t@(VarT n) =+ if nameBase n == varName+ then value+ else t+ mapper t = t+ in+ everywhere (mkT mapper) src++-- | Applies multiple type arguments+--+-- Issues a warning if too many arguments are given+--+-- @+--+-- data A a b = { a :: Maybe a, b :: b }+--+-- > 'applyMany' ([t|Int|], [t|String|]) \<:\> 'toType' ''A+--+-- data _ = { a :: Maybe Int, b :: String }+-- @+applyMany :: [Q TH.Type] -> Type -> TM Type+applyMany typeArgs ty = foldM (flip apply) ty typeArgs++-- Utils for logs++logUnknownFields :: [String] -> Type -> TM ()+logUnknownFields fieldNames ty =+ addLogs $+ fieldNotInType <$> filter (\fName -> not (fName `hasField` ty)) fieldNames++logIfEmptyType :: Type -> TM ()+logIfEmptyType ty = when (Map.null $ fields ty) $ addLog emptyResultType++failIfHasTypeVariables :: Type -> TM ()+failIfHasTypeVariables ty =+ unless (null $ typeParams ty) $+ fail "Warning - The behaviour of this function is not tested on types with type parameters."
+ src/TypeMachine/Infix.hs view
@@ -0,0 +1,78 @@+module TypeMachine.Infix (+ -- * Intersection+ (<#|>),+ (<:#|>),+ (<#|:>),++ -- ** Flipped Intersection+ (<|#>),+ (<:|#>),+ (<|#:>),++ -- * Union+ (<#&>),+ (<:#&>),+ (<#&:>),++ -- ** Flipped Union+ (<&#>),+ (<:&#>),+ (<&#:>),+) where++import Language.Haskell.TH (Name)+import TypeMachine.Functions+import TypeMachine.TM+import TypeMachine.Type++-- | Alias to 'intersection'+(<#|>) :: Type -> Type -> TM Type+(<#|>) = intersection+{-# INLINE (<#|>) #-}++-- | Like '<#|>', but the first parameter is a name+(<:#|>) :: Name -> Type -> TM Type+a <:#|> b = toType a >>= \a' -> a' <#|> b++-- | Like '<#|>', but the second parameter is a name+(<#|:>) :: Type -> Name -> TM Type+a <#|:> b = toType b >>= \b' -> a <#|> b'++-- | Alias to 'intersection''+(<|#>) :: Type -> Type -> TM Type+(<|#>) = intersection'+{-# INLINE (<|#>) #-}++-- | Like '<|#>', but the first parameter is a name+(<:|#>) :: Name -> Type -> TM Type+a <:|#> b = toType a >>= \a' -> a' <|#> b++-- | Like '<|#>', but the second parameter is a name+(<|#:>) :: Type -> Name -> TM Type+a <|#:> b = toType b >>= \b' -> a <|#> b'++-- | Alias to 'union'+(<#&>) :: Type -> Type -> TM Type+(<#&>) = union+{-# INLINE (<#&>) #-}++-- | Like '<#&>', but the first parameter is a name+(<:#&>) :: Name -> Type -> TM Type+a <:#&> b = toType a >>= \a' -> a' <#&> b++-- | Like '<#&>', but the second parameter is a name+(<#&:>) :: Type -> Name -> TM Type+a <#&:> b = toType b >>= \b' -> a <#&> b'++-- | Alias to 'union''+(<&#>) :: Type -> Type -> TM Type+(<&#>) = union'+{-# INLINE (<&#>) #-}++-- | Like '<&#>', but the first parameter is a name+(<:&#>) :: Name -> Type -> TM Type+a <:&#> b = toType a >>= \a' -> a' <&#> b++-- | Like '<&#>', but the second parameter is a name+(<&#:>) :: Type -> Name -> TM Type+a <&#:> b = toType b >>= \b' -> a <&#> b'
+ src/TypeMachine/Internal/Utils.hs view
@@ -0,0 +1,9 @@+module TypeMachine.Internal.Utils (removeKeys, keepKeys) where++import qualified Data.Map.Strict as Map++removeKeys :: (Eq k) => [k] -> Map.Map k v -> Map.Map k v+removeKeys keys = Map.filterWithKey (\k _ -> k `notElem` keys)++keepKeys :: (Eq k) => [k] -> Map.Map k v -> Map.Map k v+keepKeys keys = Map.filterWithKey (\k _ -> k `elem` keys)
+ src/TypeMachine/Log.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE GADTs #-}++module TypeMachine.Log (+ TypeMachineLog,++ -- * Common Log messages+ fieldNotInType,+ emptyResultType,+ fieldNotOptional,+ duplicateKey,+ noTypeParameter,++ -- * Formatting+ formatLog,+) where++type TypeMachineLog = String++-- | Format a log message, to be printed to the user+formatLog :: TypeMachineLog -> String+formatLog = (++) "TypeMachine: "++fieldNotInType :: String -> TypeMachineLog+fieldNotInType f = "Field '" ++ f ++ "' not in type."++emptyResultType :: TypeMachineLog+emptyResultType = "Result type is empty."++fieldNotOptional :: String -> TypeMachineLog+fieldNotOptional f = "Field '" ++ f ++ "' is not optional."++noTypeParameter :: TypeMachineLog+noTypeParameter = "There are no type parameters in this type."++duplicateKey :: TypeMachineLog+duplicateKey = "Some keys are duplicated."
+ src/TypeMachine/TH.hs view
@@ -0,0 +1,13 @@+module TypeMachine.TH (type_, deriveIs, defineIs) where++import Language.Haskell.TH hiding (Type, reifyType)+import TypeMachine.TH.Is+import TypeMachine.TM (TM, runTM)+import TypeMachine.Type++-- | Entrypoint of TypeMachine. Create a new data type using a 'TM' computation+type_ :: String -> TM Type -> Q [Dec]+type_ newTyName t = do+ fRes <- runTM t+ let newType = fRes{name = mkName newTyName}+ return [typeToDec newType]
+ src/TypeMachine/TH/Internal/Utils.hs view
@@ -0,0 +1,18 @@+module TypeMachine.TH.Internal.Utils (capitalize, getRecordConstructorVars) where++import Data.Char (toUpper)+import Language.Haskell.TH hiding (Type, reifyType)++-- | Capitalize the first letter of a string+capitalize :: String -> String+capitalize (c : cs) = toUpper c : cs+capitalize cs = cs++-- From a 'DataD''s constructors, returns its unique constructor's fields.+--+-- Fails if the list of 'Con' does not have exactly one record constructor+getRecordConstructorVars :: (MonadFail m) => [Con] -> m [VarBangType]+getRecordConstructorVars [RecC _ vbt] = return vbt+getRecordConstructorVars _ = fail "Type-Machine Error: Expected type to have exactly one Record constructor"++-- TODO I don't like passing [Con] as parameter. Might need to redesign this function
+ src/TypeMachine/TH/Is.hs view
@@ -0,0 +1,221 @@+module TypeMachine.TH.Is (isClassName, deriveIs, defineIs) where++import Control.Monad (MonadPlus (mzero), forM)+import qualified Data.Map.Strict as Map+import Language.Haskell.TH hiding (Type, reifyType)+import qualified Language.Haskell.TH as TH+import Text.Printf+import TypeMachine.TH.Internal.Utils+import TypeMachine.Type (fields, reifyType)++-- | Get the name of the 'Is' class generated for the given type+--+-- @+-- > isClassName ''User+-- IsUser+-- @+isClassName :: Name -> Name+isClassName = mkName . ("Is" ++) . capitalize . nameBase++-- | Get the name of the 'to' function generated for the given type+--+-- @+-- > toFuncName ''User+-- toUser+-- @+toFuncName :: Name -> Name+toFuncName = mkName . ("to" ++) . capitalize . nameBase++-- | Returns the declaration of the instance of 'Is' for a given type+--+-- @+-- > deriveIs ''Animal ''Dog+--+-- instance IsAnimal Dog where+-- ...+-- @+deriveIs :: Name -> Name -> Q [Dec]+deriveIs sourceTypeName destTypeName = do+ destFields <- fields <$> reifyType destTypeName+ sourceFields <- fields <$> reifyType sourceTypeName+ let className = mkName ("Is" ++ nameBase sourceTypeName)+ classFuncs <- fmap concat $ forM (zip [0 ..] $ Map.toList sourceFields) $ \(i, (n, (_, t))) ->+ case Map.lookup n destFields of+ Just _ -> do+ getter <- fieldToGetter n+ setter <- fieldToSetter (length destFields) i n+ return [getter, setter]+ Nothing ->+ ifM+ (fieldIsOptional t)+ ( do+ getter <- fieldNameToMemptyFunDec n+ setter <- fieldNameToNoopFunDec n+ return [getter, setter]+ )+ ( fail+ ( printf+ "Type-Machine Error: Cannot define instance of %s for %s. Field '%s' is missing in %s "+ (nameBase className)+ destTypeStr+ n+ destTypeStr+ )+ )+ let inlinePragmas = mkInlinePragmas $ Map.keys sourceFields+ instanceDec =+ InstanceD+ Nothing+ []+ (AppT (ConT className) (ConT destTypeName))+ (inlinePragmas ++ classFuncs)+ return [instanceDec]+ where+ destTypeStr = nameBase destTypeName+ fieldNameToMemptyFunDec n =+ funD (mkName $ fieldNameToIsGetter n) [clause [] (normalB [|const mzero|]) []]++ fieldNameToNoopFunDec n =+ funD+ (mkName $ fieldNameToIsSetter n)+ [clause [wildP, varP inputObjName] (normalB $ varE inputObjName) []]+ where+ inputObjName = mkName "x"+ fieldToGetter n = do+ let funName = mkName $ fieldNameToIsGetter n+ resName = mkName "res"+ expr = [|$(varE resName)|]+ -- Note: using destTypeName makes Q think that we use the type, not the constructor+ funD+ funName+ [clause [return $ RecP (mkName destTypeStr) [(mkName n, VarP resName)]] (normalB expr) []]++ fieldToSetter fieldCount fieldPos fieldName = do+ fieldsNames <-+ forM+ [0 .. (fieldCount - 1)]+ ( \i ->+ if i == fieldPos+ then return $ mkName "_"+ else newName $ "f" ++ show i+ )+ let funName = mkName $ fieldNameToIsSetter fieldName+ let newValueName = mkName "new"+ let patt = ConP (mkName destTypeStr) [] (VarP <$> fieldsNames)+ let body =+ foldl+ ( \res f ->+ res `AppE` case nameBase f of+ "_" -> VarE newValueName+ _ -> VarE f+ )+ (ConE $ mkName destTypeStr)+ fieldsNames++ funD funName [clause [varP newValueName, return $ patt] (normalB $ return body) []]+ -- TODO handle non-parametric monadplus-es+ -- Returns true is field is instance of Monad plus+ fieldIsOptional :: TH.Type -> Q Bool+ fieldIsOptional (AppT t _) = isInstance ''MonadPlus [t]+ fieldIsOptional _ = return False+ ifM mbool t f = do bool <- mbool; if bool then t else f+ mkInlinePragmas :: [String] -> [Dec]+ mkInlinePragmas fieldNames = mkInlinePragma . mkName <$> setterAndGetterNames+ where+ setterAndGetterNames =+ foldr+ (\field rest -> fieldNameToIsSetter field : fieldNameToIsGetter field : rest)+ []+ fieldNames+ mkInlinePragma fName = PragmaD $ InlineP fName Inline FunLike AllPhases++----- Definition++-- | Define the 'Is' class for the given type and generate the 'To' function+--+-- @+-- > data User = User { id :: Int, name :: String }+-- > defineIs ''User+--+-- class IsUser a where+-- getId :: a -> Int+-- getName :: a -> String+--+-- setId :: Int -> a -> a+-- setName :: String -> a -> a+--+-- toUser :: (IsUser a) => a -> User+-- toUser a = User (getId a) (getName a)+--+-- instance IsUser User where+-- ...+--+-- @+defineIs :: Name -> Q [Dec]+defineIs tyName = do+ ty <- reifyType tyName+ classTypeVar <- newName "a"+ getters <- mapM (vbtToGetter classTypeVar) (Map.toList $ fields ty)+ setters <- mapM (vbtToSetter classTypeVar) (Map.toList $ fields ty)+ to <- defineTo tyName classTypeVar+ isItself <- deriveIs tyName tyName+ return $+ ClassD+ []+ (isClassName tyName)+ [PlainTV classTypeVar BndrReq]+ []+ (getters ++ setters ++ to)+ : isItself+ where+ -- vbtToGetter a id Int == getId :: a -> Int+ vbtToGetter :: Name -> (String, BangType) -> Q Dec+ vbtToGetter classtypeVar (n, (_, t)) =+ let+ memberName = mkName $ fieldNameToIsGetter n+ in+ sigD memberName [t|$(varT classtypeVar) -> $(return t)|]++ -- vbtToSetter a id Int == setId :: Int -> a -> a+ vbtToSetter :: Name -> (String, BangType) -> Q Dec+ vbtToSetter classtypeVar (n, (_, t)) =+ let+ memberName = mkName $ fieldNameToIsSetter n+ in+ sigD memberName [t|$(return t) -> $(varT classtypeVar) -> $(varT classtypeVar)|]++-- | Generate the 'To' function+--+-- @+-- > data User = User { id :: Int, name :: String }+--+-- toUser :: (IsUser a) => a -> User+-- toUser from = User (getId from) (getName from)+-- @+defineTo :: Name -> Name -> Q [Dec]+defineTo tyName tyVarName = do+ ty <- reifyType tyName+ toFuncType <-+ sigD+ toName+ [t|$(varT tyVarName) -> $(conT tyName)|]+ toFuncBody <-+ let+ from = mkName "from"+ app =+ foldl'+ (\r n -> [|$r ($(varE $ mkName $ fieldNameToIsGetter n) $(varE from))|])+ (conE $ mkName $ nameBase tyName)+ (Map.keys $ fields ty)+ in+ funD (toFuncName tyName) [clause [varP from] (normalB app) []]+ return [toFuncType, toFuncBody]+ where+ toName = toFuncName tyName++-- Internal+fieldNameToIsGetter :: String -> String+fieldNameToIsGetter = ("get" ++) . capitalize++fieldNameToIsSetter :: String -> String+fieldNameToIsSetter = ("set" ++) . capitalize
+ src/TypeMachine/TM.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE ImpredicativeTypes #-}++module TypeMachine.TM (+ -- * Monad+ TM,+ runTM,+ execTM,++ -- * Logging+ addLog,+ addLogs,++ -- * Utils+ toType,+) where++import Control.Monad (forM_)+import Control.Monad.Writer.Lazy+import Language.Haskell.TH hiding (Type, reifyType)+import TypeMachine.Log+import TypeMachine.Type++-- | The 'TM' (*TypeMachine*) monad can:+--+-- - Emit warning messages (e.g. when omitting that does not exist)+-- - Take advantage of the 'Language.Haskell.TH.Q' monad's features+type TM a = WriterT [TypeMachineLog] Q a++-- | Add a log message to issue+addLog :: TypeMachineLog -> TM ()+addLog l = tell [l]++addLogs :: [TypeMachineLog] -> TM ()+addLogs = tell++-- | Execute a 'TM' computation and issue logs using the 'Q' monad+runTM :: TM a -> Q a+runTM t = do+ (res, logs) <- runWriterT t+ forM_ logs $ reportWarning . formatLog+ return res++-- | Runs a 'TM', returns the logs to issue and the computation result+execTM :: TM a -> Q (a, [TypeMachineLog])+execTM = runWriterT++-- | Takes an ADT name, returns the `Type` for that ADT+--+-- A utilitary function to use 'reifyType' in the 'TM' monad+toType :: Name -> TM Type+toType = lift . reifyType
+ src/TypeMachine/TM/Liftable.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}++module TypeMachine.TM.Liftable (LiftableTMFunction (applyTM)) where++import TypeMachine.TM++class LiftableTMFunction f where+ applyTM :: forall a b. (f ~ (a -> b)) => (a -> b) -> TM a -> b++instance LiftableTMFunction (a -> TM b) where+ applyTM f v = v >>= f++instance LiftableTMFunction (a -> b -> TM c) where+ applyTM f ma b = do+ a <- ma+ f a b++instance LiftableTMFunction (a -> b -> c -> TM d) where+ applyTM f ma b c = do+ a <- ma+ f a b c++instance LiftableTMFunction (a -> b -> c -> d -> TM e) where+ applyTM f ma b c d = do+ a <- ma+ f a b c d
+ src/TypeMachine/TM/Syntax.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE FlexibleContexts #-}++module TypeMachine.TM.Syntax ((<:>), (<::>), (<.>)) where++import Language.Haskell.TH (Name)+import TypeMachine.TM+import TypeMachine.TM.Liftable+import TypeMachine.Type++-- | Apply a `TM a` value to a 'TM' computation that expects an `a`+--+-- Example:+--+-- @+-- 'omit' ["id"] '<:>' 'toType' ''User+-- @+(<:>) :: (LiftableTMFunction (a -> b)) => (a -> b) -> TM a -> b+(<:>) = applyTM++-- | Allows passing a name to a 'TM' function that takes a 'Type'+--+-- @+-- f '<::>' ''User == f '<:>' 'toType' ''User+-- @+(<::>) :: (LiftableTMFunction (Type -> a)) => (Type -> a) -> Name -> a+f <::> n = f <:> toType n++-- | Apply a `a` value to a 'TM' computation that expects an `a`.+--+-- It is just an application operator. It exists so that applications of 'TM' functions is visually homogeneous+-- Not using it when `a` is the first parameter can enhance readability.+--+-- Examples:+--+-- @+-- 'omit' '<.>' ["id"] '<:>' 'toType' ''User+-- -- Is equivalent to+-- 'omit' ["id"] '<:>' 'toType' ''User+-- @+--+-- If the parameters to this function were flipped, using '<.>' can be handy:+--+-- @+-- 'flip' 'omit' '<:>' 'toType' ''User '<.>' ["id"]+-- -- Instead of having to use parenthesis+-- ('flip' 'omit' '<:>' 'toType' ''User) ["id"]+-- -- Or the application operator:+-- 'flip' 'omit' '<:>' 'toType' ''User $ ["id"]+-- @+(<.>) :: (a -> b) -> a -> b+f <.> v = f v
+ src/TypeMachine/Type.hs view
@@ -0,0 +1,88 @@+module TypeMachine.Type (+ Type (..),+ getField,+ hasField,+ typeToDec,+ decToType,+ reifyType,+) where++import Data.Bifunctor (first)+import Data.Functor ((<&>))+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Language.Haskell.TH.Syntax hiding (Type, reifyType)+import qualified Language.Haskell.TH.Syntax as TH (Type)+import TypeMachine.TH.Internal.Utils++-- | Data structure to easily manipulate Template Haskell's 'Language.Haskell.TH.Dec.DataD'+data Type = Type+ { name :: Name+ -- ^ Name of the data type+ , fields :: Map String BangType+ -- ^ Fields of the data type+ , typeParams :: [(String, Maybe Kind)]+ -- ^ Type parameter of the ADT+ }+ deriving (Show, Eq)++getField :: String -> Type -> Maybe (Bang, TH.Type)+getField fieldName ty = Map.lookup fieldName (fields ty)++hasField :: String -> Type -> Bool+hasField n t = Map.member n $ fields t++-- | Turns a 'Type' back to a Template Haskell 'Language.Haskell.TH.Dec'+typeToDec :: Type -> Dec+typeToDec (Type n fs tp) =+ DataD+ []+ n+ (tpToTyVarBndrs . first mkName <$> tp)+ Nothing+ [RecC (mkName $ nameBase n) $ fieldsToVbt fs]+ []+ where+ tpToTyVarBndrs (varName, Nothing) = PlainTV varName BndrInvis+ tpToTyVarBndrs (varName, Just k) = KindedTV varName BndrInvis k++-- | Transform a Template Haskell 'Dec' into a TypeMachine's type+--+-- For this to succeed, the input type must have exactly one record constructor+decToType :: (Quasi m) => Dec -> m Type+decToType dec = do+ (tyName, tyBndrs, cons) <- case dec of+ (TySynD _ _ (ConT tyconsName)) -> do+ tyconsInfo <- runQ $ reify tyconsName+ case tyconsInfo of+ TyConI dec' -> getTyInfo dec'+ _ -> fail failMsg+ _ -> getTyInfo dec+ vbt <- getRecordConstructorVars cons+ let tparams =+ tyBndrs <&> \case+ PlainTV n _ -> (n, Nothing)+ KindedTV n _ k -> (n, Just k)+ return $ Type tyName (vbtToFields vbt) (first nameBase <$> tparams)+ where+ failMsg = "Unsupported data type: Expected record type with exactly one constructor"+ getTyInfo decl = case decl of+ (DataD _ tyName tybndrs _ cons _) -> return (tyName, tybndrs, cons)+ (NewtypeD _ tyName tybndrs _ con _) -> return (tyName, tybndrs, [con])+ _ -> fail failMsg++-- | Wrapper around the TH's 'reify' function. Fails if the type is not a datatype declaration+reifyType :: Name -> Q Type+reifyType n = do+ res <- reify n+ case res of+ TyConI ty -> decToType ty+ _ -> fail "Invalid Name. Expected Datatype declaration"++{-# INLINE fieldsToVbt #-}+fieldsToVbt :: Map String BangType -> [VarBangType]+fieldsToVbt = Map.foldrWithKey (\key (b, t) list -> (mkName key, b, t) : list) []++{-# INLINE vbtToFields #-}+vbtToFields :: [VarBangType] -> Map String BangType+vbtToFields = Map.fromList . fmap (\(n, b, t) -> (nameBase n, (b, t)))
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/TypeMachine/FunctionsSpec.hs view
@@ -0,0 +1,227 @@+module TypeMachine.FunctionsSpec (spec) where++import Control.Exception.Base+import Control.Monad+import Data.Either (isLeft)+import qualified Data.Map.Strict as Map+import Data.Maybe+import Language.Haskell.TH hiding (bang)+import Test.Hspec+import TypeMachine+import TypeMachine.Log+import TypeMachine.TM (execTM)+import TypeMachine.Type (Type (..))++spec :: Spec+spec =+ describe+ "Functions"+ $ do+ let bang = Bang NoSourceUnpackedness NoSourceStrictness+ idKey = "id"+ nameKey = "name"+ otherPropKey = "otherProp"+ userIdType = (bang, ConT $ mkName "Int")+ userNameType = (bang, ConT $ mkName "String")+ userOtherPropRequiredType = ConT $ mkName "String"+ userOtherPropType = (bang, AppT (ConT $ mkName "Maybe") userOtherPropRequiredType)+ typeWithVar =+ Type+ (mkName "TypeWithVar")+ ( Map.fromList+ [ ("a", (bang, VarT $ mkName "a"))+ ,+ ( "b"+ ,+ ( bang+ , ConT (mkName "Maybe")+ `AppT` ( ConT (mkName "Maybe")+ `AppT` VarT (mkName "b")+ )+ )+ )+ ]+ )+ [("a", Nothing), ("b", Nothing)]+ userType =+ Type+ (mkName "User")+ ( Map.fromList+ [ (idKey, userIdType)+ , (nameKey, userNameType)+ , (otherPropKey, userOtherPropType)+ ]+ )+ []+ describe "omit" $ do+ it "remove fields" $ do+ (userWithId, logs) <- testTM (omit [nameKey, otherPropKey] userType)+ logs `shouldBe` []+ length (fields userWithId) `shouldBe` length (fields userType) - 2+ Map.lookup idKey (fields userWithId) `shouldNotBe` Nothing+ Map.lookup "otherProp" (fields userWithId) `shouldBe` Nothing+ Map.lookup nameKey (fields userWithId) `shouldBe` Nothing+ describe "issue warning" $ do+ it "field does not exist" $ do+ (user2, logs) <- testTM (omit [nameKey, idKey, otherPropKey] userType)+ logs `shouldBe` [emptyResultType]+ length (fields user2) `shouldBe` 0+ it "field does not exist" $ do+ (user2, logs) <- testTM (omit [nameKey, "idonotexist"] userType)+ logs `shouldBe` [fieldNotInType "idonotexist"]+ length (fields user2) `shouldBe` length (fields userType) - 1+ describe "fail" $ do+ it "has type parameters" $ do+ shouldFail (omit [nameKey] typeWithVar)++ describe "required" $ do+ it "mark field as required" $ do+ (user2, logs) <- testTM (require [otherPropKey] userType)+ logs `shouldBe` []+ snd <$> Map.lookup otherPropKey (fields user2)+ `shouldBe` Just userOtherPropRequiredType+ describe "issue warning" $ do+ it "field does not exist" $ do+ (user2, logs) <- testTM (require ["idonotexist"] userType)+ logs `shouldBe` [fieldNotInType "idonotexist"]+ fields user2 `shouldBe` fields userType+ it "field is not optional" $ do+ (user2, logs) <- testTM (require [idKey] userType)+ logs `shouldBe` [fieldNotOptional "id"]+ fields user2 `shouldBe` fields userType++ describe "pick" $ do+ it "pick fields" $ do+ (userWithId, logs) <- testTM (pick [idKey] userType)+ logs `shouldBe` []+ length (fields userWithId) `shouldBe` 1+ Map.lookup idKey (fields userWithId) `shouldBe` Just userIdType+ describe "issue warning" $ do+ it "field does not exist" $ do+ (emptyType, logs) <- testTM (pick ["a", idKey] userType)+ logs `shouldBe` [fieldNotInType "a"]+ length (fields emptyType) `shouldBe` 1+ it "result type is empty" $ do+ (emptyType, logs) <- testTM (pick [] userType)+ logs `shouldBe` [emptyResultType]+ length (fields emptyType) `shouldBe` 0++ it "field does not exist and result type is empty" $ do+ (emptyType, logs) <- testTM (pick ["a"] userType)+ logs+ `shouldBe` [ fieldNotInType "a"+ , emptyResultType+ ]+ length (fields emptyType) `shouldBe` 0+ describe "fail" $ do+ it "has type parameters" $ do+ shouldFail (pick [nameKey] typeWithVar)++ describe "intersection" $ do+ it "should have only common fields" $ do+ (userWithId, _) <- testTM (pick [idKey] userType)+ (intersectionRes, logs) <- testTM (intersection userType userWithId)+ logs `shouldBe` []+ Map.toList (fields intersectionRes) `shouldBe` [(idKey, userIdType)]+ describe "issue warning" $ do+ it "result type is empty" $ do+ (emptyType, _) <- testTM (pick [] userType)+ (res, logs) <- testTM (intersection emptyType userType)+ logs `shouldBe` [emptyResultType]+ length (fields res) `shouldBe` 0+ describe "fail" $ do+ it "has type parameters" $ do+ shouldFail (intersection userType typeWithVar)++ describe "union" $ do+ it "should have all fields" $ do+ (userWithId, _) <- testTM (pick [idKey] userType)+ (unionRes, logs) <- testTM (union userType userWithId)+ logs `shouldBe` []+ fields unionRes `shouldBe` fields userType+ it "should prefer the first type" $ do+ (user2, _) <- testTM (require [otherPropKey] userType)+ (unionRes, logs) <- testTM (union user2 userType)+ logs `shouldBe` []+ length (fields unionRes) `shouldBe` 3+ snd <$> Map.lookup otherPropKey (fields unionRes)+ `shouldBe` Just userOtherPropRequiredType+ it "should prefer the second type" $ do+ (user2, _) <- testTM (require [otherPropKey] userType)+ (unionRes, logs) <- testTM (union' user2 userType)+ logs `shouldBe` []+ length (fields unionRes) `shouldBe` 3+ Map.lookup otherPropKey (fields unionRes)+ `shouldBe` Just userOtherPropType+ describe "fail" $ do+ it "has type parameters" $ do+ shouldFail (union userType typeWithVar)++ describe "partial" $ do+ it "should wrap all fields with Maybe, except optional ones" $ do+ (partialUser, logs) <- testTM (partial userType)+ logs `shouldBe` []+ Map.lookup otherPropKey (fields partialUser)+ `shouldBe` Map.lookup otherPropKey (fields userType)+ case snd <$> Map.lookup idKey (fields partialUser) of+ Just (AppT (ConT wrapper) wrapped) -> do+ nameBase wrapper `shouldBe` "Maybe"+ wrapped `shouldBe` snd userIdType+ x -> expectationFailure ("expected a type wrapped in maybe, got " ++ show x)+ it "should wrap all fields with Maybe, including optional ones" $ do+ (partialUser, logs) <- testTM (partial' userType)+ logs `shouldBe` []+ forM_ (Map.toList $ fields userType) $ \(fName, (_, fType)) ->+ case snd <$> Map.lookup fName (fields partialUser) of+ Just (AppT (ConT wrapper) wrapped) -> do+ nameBase wrapper `shouldBe` "Maybe"+ wrapped `shouldBe` fType+ x -> expectationFailure ("expected a type wrapped in maybe, got " ++ show x)++ describe "record" $ do+ it "should have all fields" $ do+ let fType = ConT (mkName "Maybe") `AppT` ConT (mkName "Int")+ (res, logs) <- testTM (record ["a", "b"] (return fType))+ logs `shouldBe` []+ length (fields res) `shouldBe` 2+ snd <$> Map.lookup "a" (fields res) `shouldBe` Just fType+ describe "issue warning" $ do+ it "empty record" $ do+ (emptyType, logs) <- testTM (record [] (conT $ mkName "Int"))+ logs `shouldBe` [emptyResultType]+ length (fields emptyType) `shouldBe` 0+ it "duplicate key" $ do+ (res, logs) <- testTM (record ["a", "a"] (conT $ mkName "Int"))+ logs `shouldBe` [duplicateKey]+ length (fields res) `shouldBe` 1++ describe "apply" $ do+ it "should replace type variables" $ do+ (res, logs) <- testTM (applyMany [[t|Int|], [t|String|]] typeWithVar)+ typeParams res `shouldBe` []+ logs `shouldBe` []+ -- Check first type variable+ let aField = snd $ fromJust $ Map.lookup "a" $ fields res+ case aField of+ ConT n -> nameBase n `shouldBe` "Int"+ t -> expectationFailure $ "expected a type constructor, got: " ++ show t+ -- Check second type variable+ logs `shouldBe` []+ let bField = snd $ fromJust $ Map.lookup "b" $ fields res+ case bField of+ AppT (ConT _) (AppT (ConT _) (ConT n)) -> nameBase n `shouldBe` "String"+ t ->+ expectationFailure $+ "expected two nexted type constructors, got: " ++ show t+ describe "issue warning" $ do+ it "no type variable" $ do+ (_, logs) <- testTM (apply [t|Int|] userType)+ logs `shouldBe` [noTypeParameter]+ where+ testTM = runQ . execTM+ shouldFail tm = do+ mres <-+ try+ (testTM tm) ::+ IO (Either IOException (TypeMachine.Type, [String]))+ mres `shouldSatisfy` isLeft
+ test/TypeMachine/IsSpec.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE DuplicateRecordFields #-}++module TypeMachine.IsSpec (spec) where++import Test.Hspec+import TypeMachine++data User = User+ { id :: Int+ , name :: String+ , optProp :: Maybe ()+ }+ deriving (Show, Eq)++$(defineIs ''User)+$(type_ "UserWithoutOptProp" (omit ["optProp"] <::> ''User))+$(deriveIs ''User ''UserWithoutOptProp)++spec :: Spec+spec =+ describe+ "'Is' typeclass"+ $ do+ describe "get fields using typeclass" $+ do+ it "original object" $ do+ let og = User 1 "A" (Just ())+ getId og `shouldBe` 1+ getName og `shouldBe` "A"+ getOptProp og `shouldBe` Just ()++ it "secondary object" $ do+ let og = UserWithoutOptProp 1 "A"+ getId og `shouldBe` 1+ getName og `shouldBe` "A"+ getOptProp og `shouldBe` Nothing+ describe "'to' function" $+ do+ let og = User 1 "A" (Just ())+ it "original object (identity)" $ do+ toUser og `shouldBe` og+ it "secondary object" $ do+ let obj = UserWithoutOptProp 1 "A"+ toUser obj `shouldBe` og{optProp = Nothing}
+ type-machine.cabal view
@@ -0,0 +1,136 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.38.0.+--+-- see: https://github.com/sol/hpack++name: type-machine+version: 0.1.0.0+synopsis: Template Haskell-based Type functions on record types in Haskell+description: Please see the README on GitHub at <https://github.com/Arthi-chaud/type-machine#readme>+category: Types+homepage: https://github.com/Arthi-chaud/type-machine#readme+bug-reports: https://github.com/Arthi-chaud/type-machine/issues+author: Arthi-chaud+maintainer: aj530@kent.ac.uk+copyright: 2025 Arthi-chaud+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/Arthi-chaud/type-machine++library+ exposed-modules:+ TypeMachine+ TypeMachine.Functions+ TypeMachine.Infix+ TypeMachine.TM+ TypeMachine.Type+ TypeMachine.TM.Syntax+ TypeMachine.Log+ TypeMachine.TH+ TypeMachine.TH.Is+ other-modules:+ TypeMachine.Internal.Utils+ TypeMachine.TH.Internal.Utils+ TypeMachine.TM.Liftable+ Paths_type_machine+ autogen-modules:+ Paths_type_machine+ hs-source-dirs:+ src+ default-extensions:+ TemplateHaskell+ LambdaCase+ TupleSections+ RankNTypes+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+ build-depends:+ base >=4.7 && <5+ , containers+ , mtl+ , syb+ , template-haskell+ default-language: Haskell2010++executable vector-example+ main-is: examples/Vector.hs+ other-modules:+ Paths_type_machine+ autogen-modules:+ Paths_type_machine+ default-extensions:+ TemplateHaskell+ LambdaCase+ TupleSections+ RankNTypes+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+ build-depends:+ base >=4.7 && <5+ , containers+ , syb+ , template-haskell+ , type-machine+ default-language: Haskell2010++test-suite type-machine-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ TypeMachine.FunctionsSpec+ TypeMachine.IsSpec+ Paths_type_machine+ autogen-modules:+ Paths_type_machine+ hs-source-dirs:+ test+ default-extensions:+ TemplateHaskell+ LambdaCase+ TupleSections+ RankNTypes+ 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 -Wno-unused-top-binds+ build-depends:+ base >=4.7 && <5+ , containers+ , hspec+ , syb+ , template-haskell+ , type-machine+ default-language: Haskell2010++benchmark bench+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Benchmark+ Gen+ Paths_type_machine+ autogen-modules:+ Paths_type_machine+ hs-source-dirs:+ benchmarks/runtime+ default-extensions:+ TemplateHaskell+ LambdaCase+ TupleSections+ RankNTypes+ 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=-T -Wno-unused-top-binds -Wno-orphans -Wno-redundant-constraints+ build-depends:+ base >=4.7 && <5+ , containers+ , criterion+ , extensible+ , lens+ , mtl+ , superrecord+ , syb+ , template-haskell+ , type-machine+ default-language: Haskell2010