th-lego 0.2.3 → 0.3
raw patch · 6 files changed
+339/−378 lines, 6 files
Files
- library/THLego/Helpers.hs +12/−20
- library/THLego/Instances.hs +104/−121
- library/THLego/Lambdas.hs +63/−75
- library/THLego/Prelude.hs +16/−23
- test/Main.hs +143/−138
- th-lego.cabal +1/−1
library/THLego/Helpers.hs view
@@ -1,14 +1,11 @@-module THLego.Helpers-where+module THLego.Helpers where -import THLego.Prelude+import qualified Data.Text as Text import Language.Haskell.TH.Syntax+import THLego.Prelude import qualified TemplateHaskell.Compat.V0208 as Compat-import qualified Data.Text as Text - -- * Decs-------------------------- typeSynonymDec :: Name -> Type -> Dec typeSynonymDec a b =@@ -33,7 +30,7 @@ DataD [] typeName [] Nothing [con] [] where con =- RecC typeName (fmap (\ (fieldName, fieldType) -> (fieldName, fieldBang, fieldType)) fields)+ RecC typeName (fmap (\(fieldName, fieldType) -> (fieldName, fieldBang, fieldType)) fields) productAdtDec :: Name -> [Type] -> Dec productAdtDec typeName memberTypes =@@ -52,11 +49,9 @@ enumDec :: Name -> [Name] -> Dec enumDec a b =- DataD [] a [] Nothing (fmap (\ c -> NormalC c []) b) []-+ DataD [] a [] Nothing (fmap (\c -> NormalC c []) b) [] -- *-------------------------- textName :: Text -> Name textName =@@ -84,7 +79,7 @@ arrowChainT :: [Type] -> Type -> Type arrowChainT params result =- foldr (\ a b -> AppT (AppT ArrowT a) b) result params+ foldr (\a b -> AppT (AppT ArrowT a) b) result params appliedTupleT :: [Type] -> Type appliedTupleT a =@@ -92,7 +87,7 @@ appliedTupleOrSingletonT :: [Type] -> Type appliedTupleOrSingletonT =- \ case+ \case [a] -> a a -> appliedTupleT a @@ -102,7 +97,7 @@ appliedTupleOrSingletonE :: [Exp] -> Exp appliedTupleOrSingletonE =- \ case+ \case [a] -> a a -> appliedTupleE a @@ -125,9 +120,8 @@ enumAlphabeticNames = fmap alphabeticIndexName . enumFromTo 0 . pred -{-|-Map every element of a list with a new name.--}+-- |+-- Map every element of a list with a new name. {-# INLINE mapWithAlphabeticName #-} mapWithAlphabeticName :: (Name -> a -> b) -> [a] -> [b] mapWithAlphabeticName f list =@@ -152,9 +146,7 @@ eqConstraintT name = AppT (AppT EqualityT (VarT name)) - -- *-------------------------- applicativeChainE :: Exp -> [Exp] -> Exp applicativeChainE mappingE apEList =@@ -164,11 +156,11 @@ (VarE '(<*>)) (InfixE (Just mappingE) (VarE '(<$>)) (Just h) :| t) _ ->- mappingE+ AppE (VarE 'pure) mappingE intersperseInfixE :: Exp -> NonEmpty Exp -> Exp intersperseInfixE op =- foldl1 (\ l r -> InfixE (Just l) op (Just r))+ foldl1 (\l r -> InfixE (Just l) op (Just r)) textLitE :: Text -> Exp textLitE =
library/THLego/Instances.hs view
@@ -1,21 +1,17 @@-module THLego.Instances-where+module THLego.Instances where -import THLego.Prelude-import THLego.Helpers-import Language.Haskell.TH-import qualified TemplateHaskell.Compat.V0208 as Compat import qualified Data.Text as Text-import qualified THLego.Lambdas as Lambdas+import Language.Haskell.TH+import THLego.Helpers import qualified THLego.Helpers as Helpers-+import qualified THLego.Lambdas as Lambdas+import THLego.Prelude+import qualified TemplateHaskell.Compat.V0208 as Compat -- * IsLabel-------------------------- -{-|-The most general template for 'IsLabel'.--}+-- |+-- The most general template for 'IsLabel'. isLabel :: TyLit -> Type -> Exp -> Dec isLabel label repType fromLabelExp = InstanceD Nothing [] headType [fromLabelDec]@@ -29,19 +25,17 @@ NormalB fromLabelExp -- ** Constructor-------------------------- -{-|--> instance (a ~ Text) => IsLabel "error" (a -> Result)--}+-- |+--+-- > instance (a ~ Text) => IsLabel "error" (a -> Result) constructorIsLabel :: TyLit -> Type -> [Type] -> Exp -> Dec constructorIsLabel label ownerType memberTypes fromLabelExp = InstanceD Nothing paramPreds headType [fromLabelDec] where paramPreds = memberTypes- & Helpers.mapWithAlphabeticName (\ n t -> multiAppT EqualityT [VarT n, t])+ & Helpers.mapWithAlphabeticName (\n t -> multiAppT EqualityT [VarT n, t]) headType = multiAppT (ConT ''IsLabel) [LitT label, repType] where@@ -65,9 +59,8 @@ enumConstructorIsLabel label ownerType conName = sumConstructorIsLabel label ownerType conName [] -{-|-'IsLabel' instance which converts tuple to ADT.--}+-- |+-- 'IsLabel' instance which converts tuple to ADT. tupleAdtConstructorIsLabel :: TyLit -> Type -> Name -> [Type] -> Dec tupleAdtConstructorIsLabel label ownerType conName memberTypes = constructorIsLabel label ownerType [memberType] fromLabelExp@@ -78,24 +71,21 @@ Lambdas.tupleToProduct conName (length memberTypes) -- ** Mapper-------------------------- -{-|-Template of 'IsLabel' for instances mapping to mapper functions.--> instance (mapper ~ (Text -> Text)) => IsLabel "name" (mapper -> Person -> Person)---}+-- |+-- Template of 'IsLabel' for instances mapping to mapper functions.+--+-- > instance (mapper ~ (Text -> Text)) => IsLabel "name" (mapper -> Person -> Person) mapperIsLabel ::- {-| Field label. -}+ -- | Field label. TyLit ->- {-| Type of the product. -}+ -- | Type of the product. Type ->- {-| Type of the mapper function. -}+ -- | Type of the mapper function. Type ->- {-| 'fromLabel' definition expression. -}+ -- | 'fromLabel' definition expression. Exp ->- {-| 'IsLabel' instance declaration. -}+ -- | 'IsLabel' instance declaration. Dec mapperIsLabel label ownerType projectionType fromLabelExp = InstanceD Nothing [memberPred] headType [fromLabelDec]@@ -112,58 +102,58 @@ fromLabelDec = FunD 'fromLabel [Clause [] (NormalB fromLabelExp) []] -{-|-Template of 'IsLabel' for instances mapping to mapper functions.--> instance (mapper ~ (Text -> Text)) => IsLabel "name" (mapper -> Person -> Person)--}+-- |+-- Template of 'IsLabel' for instances mapping to mapper functions.+--+-- > instance (mapper ~ (Text -> Text)) => IsLabel "name" (mapper -> Person -> Person) productMapperIsLabel ::- {-| Field label. -}+ -- | Field label. TyLit ->- {-| Type of the product. -}+ -- | Type of the product. Type ->- {-| Type of the member we\'re focusing on. -}+ -- | Type of the member we\'re focusing on. Type ->- {-| Constructor name. -}+ -- | Constructor name. Name ->- {-| Total amount of members in the product. -}+ -- | Total amount of members in the product. Int ->- {-| Offset of the member we're focusing on. -}+ -- | Offset of the member we're focusing on. Int ->- {-| 'IsLabel' instance declaration. -}+ -- | 'IsLabel' instance declaration. Dec productMapperIsLabel label ownerType memberType conName totalMemberTypes offset =- mapperIsLabel label ownerType+ mapperIsLabel+ label+ ownerType (multiAppT ArrowT [memberType, memberType]) (Lambdas.productMapper conName totalMemberTypes offset) -{-|-Template of 'IsLabel' for instances mapping to mapper functions.--> instance (mapper ~ (Int -> Text -> (Int, Text))) => IsLabel "error" (mapper -> Result -> Result)--}+-- |+-- Template of 'IsLabel' for instances mapping to mapper functions.+--+-- > instance (mapper ~ (Int -> Text -> (Int, Text))) => IsLabel "error" (mapper -> Result -> Result) sumMapperIsLabel ::- {-| Field label. -}+ -- | Field label. TyLit ->- {-| Type of the product. -}+ -- | Type of the product. Type ->- {-| Constructor name. -}+ -- | Constructor name. Name ->- {-| Member types we\'re focusing on. -}+ -- | Member types we\'re focusing on. [Type] ->- {-| 'IsLabel' instance declaration. -}+ -- | 'IsLabel' instance declaration. Dec sumMapperIsLabel label ownerType conName memberTypes =- mapperIsLabel label ownerType+ mapperIsLabel+ label+ ownerType (arrowChainT memberTypes (appliedTupleOrSingletonT memberTypes)) (Lambdas.sumMapper conName (length memberTypes)) -- ** Accessor-------------------------- -{-|-Template of 'IsLabel' for instances mapping to accessor functions.--}+-- |+-- Template of 'IsLabel' for instances mapping to accessor functions. accessorIsLabel :: TyLit -> Type -> Type -> Exp -> Dec accessorIsLabel label ownerType projectionType fromLabelExp = InstanceD Nothing [memberPred] headType [fromLabelDec]@@ -180,23 +170,22 @@ fromLabelDec = FunD 'fromLabel [Clause [] (NormalB fromLabelExp) []] -{-|-Instance of 'IsLabel' for a member of a product type.--}+-- |+-- Instance of 'IsLabel' for a member of a product type. productAccessorIsLabel ::- {-| Field label. -}+ -- | Field label. TyLit ->- {-| Type of the product. -}+ -- | Type of the product. Type ->- {-| Type of the member we\'re focusing on. -}+ -- | Type of the member we\'re focusing on. Type ->- {-| Constructor name. -}+ -- | Constructor name. Name ->- {-| Total amount of members in the product. -}+ -- | Total amount of members in the product. Int ->- {-| Offset of the member we're focusing on. -}+ -- | Offset of the member we're focusing on. Int ->- {-| 'IsLabel' instance declaration. -}+ -- | 'IsLabel' instance declaration. Dec productAccessorIsLabel label ownerType projectionType conName numMembers offset = accessorIsLabel label ownerType projectionType fromLabelExp@@ -204,9 +193,8 @@ fromLabelExp = Lambdas.productGetter conName numMembers offset -{-|-> instance (a ~ Maybe Text) => IsLabel "error" (Result -> a)--}+-- |+-- > instance (a ~ Maybe Text) => IsLabel "error" (Result -> a) sumAccessorIsLabel :: TyLit -> Type -> Name -> [Type] -> Dec sumAccessorIsLabel label ownerType conName memberTypes = accessorIsLabel label ownerType projectionType fromLabelExp@@ -225,11 +213,9 @@ fromLabelExp = Lambdas.enumConstructorToBool conName - -- * 'HasField'-------------------------- -{-| The most general template for 'HasField'. -}+-- | The most general template for 'HasField'. hasField :: TyLit -> Type -> Type -> [Clause] -> Dec hasField fieldLabel ownerType projectionType getFieldFunClauses = InstanceD Nothing [] headType [getFieldDec]@@ -239,22 +225,21 @@ getFieldDec = FunD 'getField getFieldFunClauses -{-|-'HasField' instance which focuses on a variant of an enum-and projects it into 'Bool' signaling whether the value matches.--Generates code of the following pattern:--> instance HasField "fieldLabel" enumType Bool--}+-- |+-- 'HasField' instance which focuses on a variant of an enum+-- and projects it into 'Bool' signaling whether the value matches.+--+-- Generates code of the following pattern:+--+-- > instance HasField "fieldLabel" enumType Bool enumHasField ::- {-| Field label. -}+ -- | Field label. TyLit ->- {-| Enum type. -}+ -- | Enum type. Type ->- {-| Name of the constructor. -}+ -- | Name of the constructor. Name ->- {-| 'HasField' instance declaration. -}+ -- | 'HasField' instance declaration. Dec enumHasField fieldLabel ownerType constructorName = hasField fieldLabel ownerType projectionType getFieldFunClauses@@ -275,28 +260,27 @@ bodyExp = ConE 'False -{-|-Instance of 'HasField' for a constructor of a sum ADT,-projecting it into a 'Maybe' tuple of its members.--Generates code of the following pattern:--> instance HasField "fieldLabel" sumAdt (Maybe projectionType)--- When the amount of member types is 0, @projectionType@ is @()@.-- When the amount of member types is 1, it is that member type.-- Otherwise it is a tuple of those members.--}+-- |+-- Instance of 'HasField' for a constructor of a sum ADT,+-- projecting it into a 'Maybe' tuple of its members.+--+-- Generates code of the following pattern:+--+-- > instance HasField "fieldLabel" sumAdt (Maybe projectionType)+--+-- - When the amount of member types is 0, @projectionType@ is @()@.+-- - When the amount of member types is 1, it is that member type.+-- - Otherwise it is a tuple of those members. sumHasField ::- {-| Field label. -}+ -- | Field label. TyLit ->- {-| The ADT type. -}+ -- | The ADT type. Type ->- {-| Name of the constructor. -}+ -- | Name of the constructor. Name ->- {-| Member types of that constructor. -}+ -- | Member types of that constructor. [Type] ->- {-| 'HasField' instance declaration. -}+ -- | 'HasField' instance declaration. Dec sumHasField fieldLabel ownerType constructorName memberTypes = hasField fieldLabel ownerType projectionType getFieldFunClauses@@ -307,8 +291,8 @@ [matching, unmatching] where varNames =- memberTypes &- mapWithAlphabeticName (const . id)+ memberTypes+ & mapWithAlphabeticName (const . id) matching = Clause [ConP constructorName pats] (NormalB bodyExp) [] where@@ -322,23 +306,22 @@ bodyExp = ConE 'Nothing -{-|-Instance of 'HasField' for a member of a product type.--}+-- |+-- Instance of 'HasField' for a member of a product type. productHasField ::- {-| Field label. -}+ -- | Field label. TyLit ->- {-| Type of the product. -}+ -- | Type of the product. Type ->- {-| Type of the member we\'re focusing on. -}+ -- | Type of the member we\'re focusing on. Type ->- {-| Constructor name. -}+ -- | Constructor name. Name ->- {-| Total amount of members in the product. -}+ -- | Total amount of members in the product. Int ->- {-| Offset of the member we're focusing on. -}+ -- | Offset of the member we're focusing on. Int ->- {-| 'HasField' instance declaration. -}+ -- | 'HasField' instance declaration. Dec productHasField fieldLabel ownerType projectionType constructorName totalMemberTypes offset = hasField fieldLabel ownerType projectionType getFieldFunClauses@@ -347,8 +330,8 @@ [Clause [ConP constructorName pats] (NormalB bodyExp) []] where pats =- replicate offset WildP <>- bool empty [VarP aName] (totalMemberTypes > 0) <>- replicate (totalMemberTypes - offset - 1) WildP+ replicate offset WildP+ <> bool empty [VarP aName] (totalMemberTypes > 0)+ <> replicate (totalMemberTypes - offset - 1) WildP bodyExp = VarE aName
library/THLego/Lambdas.hs view
@@ -1,27 +1,23 @@-module THLego.Lambdas-where+module THLego.Lambdas where -import THLego.Prelude-import THLego.Helpers import Language.Haskell.TH+import THLego.Helpers+import THLego.Prelude import qualified TemplateHaskell.Compat.V0208 as Compat --{-|-Van Larrhoven lens.--}+-- |+-- Van Larrhoven lens. vlLens ::- {-| Constructor name. -}+ -- | Constructor name. Name ->- {-| Total amount of members. -}+ -- | Total amount of members. Int ->- {-| Index of the member. -}+ -- | Index of the member. Int ->- {-|- Lambda expression of the following type:- - > forall f. Functor f => (a -> f b) -> s -> f t- -}+ -- |+ -- Lambda expression of the following type:+ --+ -- > forall f. Functor f => (a -> f b) -> s -> f t Exp vlLens conName numMembers index = LamE [onMemberP, productP] exp@@ -51,34 +47,31 @@ multiAppE (ConE conName) (fmap VarE argNames) where argNames =- take index memberNames <>- [valueName] <>- drop (succ index) memberNames+ take index memberNames+ <> [valueName]+ <> drop (succ index) memberNames onMemberE = AppE (VarE onMemberName) (VarE (alphabeticIndexName index)) -{-|-Simulates lambda-case without the need for extension.--}+-- |+-- Simulates lambda-case without the need for extension. matcher :: [Match] -> Exp matcher matches = LamE [VarP aName] (CaseE (VarE aName) matches) -{-|-Lambda expression, which extracts a product member by index.--}+-- |+-- Lambda expression, which extracts a product member by index. productGetter ::- {-| Constructor name. -}+ -- | Constructor name. Name ->- {-| Total amount of members. -}+ -- | Total amount of members. Int ->- {-| Index of the member. -}+ -- | Index of the member. Int ->- {-|- Lambda expression of the following form:- - > product -> member- -}+ -- |+ -- Lambda expression of the following form:+ --+ -- > product -> member Exp productGetter conName numMembers index = LamE [pat] exp@@ -89,27 +82,25 @@ ConP conName pats where pats =- replicate index WildP <>- pure (VarP varName) <>- replicate (numMembers - index - 1) WildP+ replicate index WildP+ <> pure (VarP varName)+ <> replicate (numMembers - index - 1) WildP exp = VarE varName -{-|-Lambda expression, which sets a product member by index.--}+-- |+-- Lambda expression, which sets a product member by index. productSetter ::- {-| Constructor name. -}+ -- | Constructor name. Name ->- {-| Total amount of members. -}+ -- | Total amount of members. Int ->- {-| Index of the member. -}+ -- | Index of the member. Int ->- {-|- Lambda expression of the following form:-- > product -> member -> product- -}+ -- |+ -- Lambda expression of the following form:+ --+ -- > product -> member -> product Exp productSetter conName numMembers index = LamE [stateP, valP] exp@@ -122,29 +113,27 @@ ConP conName pats where pats =- (memberNames & take index & fmap VarP) <>- [WildP] <>- (memberNames & drop (succ index) & fmap VarP)+ (memberNames & take index & fmap VarP)+ <> [WildP]+ <> (memberNames & drop (succ index) & fmap VarP) valP = VarP memberName exp = foldl' AppE (ConE conName) (fmap VarE memberNames) -{-|-Lambda expression, which maps a product member by index.--}+-- |+-- Lambda expression, which maps a product member by index. productMapper ::- {-| Constructor name. -}+ -- | Constructor name. Name ->- {-| Total amount of members. -}+ -- | Total amount of members. Int ->- {-| Index of the member. -}+ -- | Index of the member. Int ->- {-|- Lambda expression of the following form:-- > (member -> member) -> product -> product- -}+ -- |+ -- Lambda expression of the following form:+ --+ -- > (member -> member) -> product -> product Exp productMapper conName numMembers index = LamE [mapperP, stateP] exp@@ -166,23 +155,21 @@ fmap VarP memberNames exp = foldl' AppE (ConE conName) $- fmap (VarE . alphabeticIndexName) (enumFromTo 0 (pred index)) <>- pure (AppE (VarE fnName) (VarE valName)) <>- fmap (VarE . alphabeticIndexName) (enumFromTo (succ index) (pred numMembers))+ fmap (VarE . alphabeticIndexName) (enumFromTo 0 (pred index))+ <> pure (AppE (VarE fnName) (VarE valName))+ <> fmap (VarE . alphabeticIndexName) (enumFromTo (succ index) (pred numMembers)) -{-|-Lambda expression, which maps a sum member by index.--}+-- |+-- Lambda expression, which maps a sum member by index. sumMapper ::- {-| Constructor name. -}+ -- | Constructor name. Name ->- {-| Total amount of members. -}+ -- | Total amount of members. Int ->- {-|- Lambda expression of the following form:-- > (membersTuple -> membersTuple) -> sum -> sum- -}+ -- |+ -- Lambda expression of the following form:+ --+ -- > (membersTuple -> membersTuple) -> sum -> sum Exp sumMapper conName numMembers = LamE [mapperP] (matcher matches)@@ -202,7 +189,8 @@ memberPats = fmap VarP memberVarNames bodyExp =- AppE (tupleOrSingletonToProduct conName numMembers)+ AppE+ (tupleOrSingletonToProduct conName numMembers) (multiAppE (VarE fnName) (fmap VarE memberVarNames)) neg = Match (VarP aName) (NormalB (VarE aName)) []
library/THLego/Prelude.hs view
@@ -1,21 +1,18 @@ module THLego.Prelude-( - module Exports,- showAsText,-)+ ( module Exports,+ showAsText,+ ) where --- base---------------------------import Control.Applicative as Exports hiding (WrappedArrow(..))+import Control.Applicative as Exports hiding (WrappedArrow (..)) import Control.Arrow as Exports hiding (first, second) import Control.Category as Exports import Control.Concurrent as Exports import Control.Exception as Exports-import Control.Monad as Exports hiding (fail, mapM_, sequence_, forM_, msum, mapM, sequence, forM)-import Control.Monad.IO.Class as Exports+import Control.Monad as Exports hiding (fail, forM, forM_, mapM, mapM_, msum, sequence, sequence_) import Control.Monad.Fail as Exports import Control.Monad.Fix as Exports hiding (fix)+import Control.Monad.IO.Class as Exports import Control.Monad.ST as Exports import Data.Bifunctor as Exports import Data.Bits as Exports@@ -31,11 +28,11 @@ import Data.Function as Exports hiding (id, (.)) import Data.Functor as Exports import Data.Functor.Compose as Exports-import Data.Int as Exports import Data.IORef as Exports+import Data.Int as Exports import Data.Ix as Exports-import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')-import Data.List.NonEmpty as Exports (NonEmpty(..))+import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons)+import Data.List.NonEmpty as Exports (NonEmpty (..)) import Data.Maybe as Exports import Data.Monoid as Exports hiding (Alt) import Data.Ord as Exports@@ -43,6 +40,7 @@ import Data.Ratio as Exports import Data.STRef as Exports import Data.String as Exports+import Data.Text as Exports (Text) import Data.Traversable as Exports import Data.Tuple as Exports import Data.Unique as Exports@@ -54,14 +52,13 @@ import Foreign.Ptr as Exports import Foreign.StablePtr as Exports import Foreign.Storable as Exports-import GHC.Conc as Exports hiding (orElse, withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead)-import GHC.Exts as Exports (IsList(..), lazy, inline, sortWith, groupWith)+import GHC.Conc as Exports hiding (orElse, threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar)+import GHC.Exts as Exports (IsList (..), groupWith, inline, lazy, sortWith) import GHC.Generics as Exports (Generic) import GHC.IO.Exception as Exports import GHC.OverloadedLabels as Exports import GHC.Records as Exports import Numeric as Exports-import Prelude as Exports hiding (fail, concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.)) import System.Environment as Exports import System.Exit as Exports import System.IO as Exports (Handle, hClose)@@ -71,15 +68,11 @@ import System.Mem.StableName as Exports import System.Timeout as Exports import Text.ParserCombinators.ReadP as Exports (ReadP, readP_to_S, readS_to_P)-import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec)-import Text.Printf as Exports (printf, hPrintf)-import Text.Read as Exports (Read(..), readMaybe, readEither)+import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readP_to_Prec, readPrec_to_P, readPrec_to_S, readS_to_Prec)+import Text.Printf as Exports (hPrintf, printf)+import Text.Read as Exports (Read (..), readEither, readMaybe) import Unsafe.Coerce as Exports---- text---------------------------import Data.Text as Exports (Text)-+import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.)) showAsText :: Show a => a -> Text showAsText = show >>> fromString
test/Main.hs view
@@ -1,147 +1,152 @@ module Main where -import Prelude hiding (assert)+import Language.Haskell.TH.Syntax+import qualified THLego.Helpers as Helpers+import qualified THLego.Instances as Instances+import qualified Test.QuickCheck as QuickCheck import Test.QuickCheck.Instances import Test.Tasty-import Test.Tasty.Runners import Test.Tasty.HUnit import Test.Tasty.QuickCheck-import Language.Haskell.TH.Syntax-import qualified Test.QuickCheck as QuickCheck-import qualified THLego.Instances as Instances-import qualified THLego.Helpers as Helpers-+import Test.Tasty.Runners+import Prelude hiding (assert) main =- defaultMain $ - testGroup "Instances" [- testCase "productMapperIsLabel" $ let- dec =- Instances.productMapperIsLabel- (StrTyLit "start")- (ConT ''CharPos)- (ConT ''Loc)- 'Loc- 5- 3- in- case dec of- InstanceD _ cxt headType _ ->- do- assertEqual ""- [AppT- (AppT EqualityT (VarT (mkName "mapper")))- (AppT (AppT ArrowT (ConT ''Loc))- (ConT ''Loc))]- cxt- assertEqual ""- (AppT- (AppT (ConT ''IsLabel) (LitT (StrTyLit "start")))- (AppT (AppT ArrowT (VarT (mkName "mapper")))- (AppT- (AppT ArrowT (ConT ''CharPos))- (ConT ''CharPos))))- headType- _ ->- assertFailure (show dec)- ,- testGroup "sumMapperIsLabel" [- testCase "No fields" $ let- dec =- Instances.sumMapperIsLabel- (StrTyLit "arrow")- (ConT ''Type)- 'ArrowT- []- in- case dec of- InstanceD _ decCxt decHeadType _ ->- let- mapperType =- TupleT 0- predType =- EqualityT- `AppT` VarT (mkName "mapper")- `AppT` mapperType- fnType =- ConT ''Type- & AppT (AppT ArrowT (ConT ''Type))- & AppT (AppT ArrowT (VarT (mkName "mapper")))- headType =- ConT ''IsLabel- `AppT` LitT (StrTyLit "arrow")- `AppT` fnType- in do- assertEqual "cxt" [predType] decCxt- assertEqual "headType" headType decHeadType- _ ->- assertFailure (show dec)- ,- testCase "1 field" $ let- dec =- Instances.sumMapperIsLabel- (StrTyLit "var")- (ConT ''Type)- 'VarT- [ConT ''Name]- in- case dec of- InstanceD _ decCxt decHeadType _ ->- let- mapperType =- ConT ''Name- & AppT (AppT ArrowT (ConT ''Name))- predType =- EqualityT `AppT` VarT (mkName "mapper") `AppT` mapperType- fnType =- ConT ''Type- & AppT (AppT ArrowT (ConT ''Type))- & AppT (AppT ArrowT (VarT (mkName "mapper")))- headType =- ConT ''IsLabel- `AppT` LitT (StrTyLit "var")- `AppT` fnType- in do- assertEqual "cxt" [predType] decCxt- assertEqual "headType" headType decHeadType- _ ->- assertFailure (show dec)- ,- testCase "Multiple fields" $ let- dec =- Instances.sumMapperIsLabel- (StrTyLit "val")- (ConT ''Dec)- 'ValD- [ConT ''Pat, ConT ''Body, AppT ListT (ConT ''Dec)]- in- case dec of- InstanceD _ decCxt decHeadType _ ->- let- tupleType =- TupleT 3- `AppT` (ConT ''Pat)- `AppT` (ConT ''Body)- `AppT` (AppT ListT (ConT ''Dec))- mapperType =- AppT (AppT ArrowT (ConT ''Pat))- (AppT (AppT ArrowT (ConT ''Body))- (AppT (AppT ArrowT (AppT ListT (ConT ''Dec)))- tupleType))- predType =- EqualityT `AppT` VarT (mkName "mapper") `AppT` mapperType- fnType =- ConT ''Dec- & AppT (AppT ArrowT (ConT ''Dec))- & AppT (AppT ArrowT (VarT (mkName "mapper")))- headType =- ConT ''IsLabel- `AppT` LitT (StrTyLit "val")- `AppT` fnType- in do- assertEqual "cxt" [predType] decCxt- assertEqual "headType" headType decHeadType- _ ->- assertFailure (show dec)+ defaultMain $+ testGroup+ "Instances"+ [ testCase "productMapperIsLabel" $+ let dec =+ Instances.productMapperIsLabel+ (StrTyLit "start")+ (ConT ''CharPos)+ (ConT ''Loc)+ 'Loc+ 5+ 3+ in case dec of+ InstanceD _ cxt headType _ ->+ do+ assertEqual+ ""+ [ AppT+ (AppT EqualityT (VarT (mkName "mapper")))+ ( AppT+ (AppT ArrowT (ConT ''Loc))+ (ConT ''Loc)+ )+ ]+ cxt+ assertEqual+ ""+ ( AppT+ (AppT (ConT ''IsLabel) (LitT (StrTyLit "start")))+ ( AppT+ (AppT ArrowT (VarT (mkName "mapper")))+ ( AppT+ (AppT ArrowT (ConT ''CharPos))+ (ConT ''CharPos)+ )+ )+ )+ headType+ _ ->+ assertFailure (show dec),+ testGroup+ "sumMapperIsLabel"+ [ testCase "No fields" $+ let dec =+ Instances.sumMapperIsLabel+ (StrTyLit "arrow")+ (ConT ''Type)+ 'ArrowT+ []+ in case dec of+ InstanceD _ decCxt decHeadType _ ->+ let mapperType =+ TupleT 0+ predType =+ EqualityT+ `AppT` VarT (mkName "mapper")+ `AppT` mapperType+ fnType =+ ConT ''Type+ & AppT (AppT ArrowT (ConT ''Type))+ & AppT (AppT ArrowT (VarT (mkName "mapper")))+ headType =+ ConT ''IsLabel+ `AppT` LitT (StrTyLit "arrow")+ `AppT` fnType+ in do+ assertEqual "cxt" [predType] decCxt+ assertEqual "headType" headType decHeadType+ _ ->+ assertFailure (show dec),+ testCase "1 field" $+ let dec =+ Instances.sumMapperIsLabel+ (StrTyLit "var")+ (ConT ''Type)+ 'VarT+ [ConT ''Name]+ in case dec of+ InstanceD _ decCxt decHeadType _ ->+ let mapperType =+ ConT ''Name+ & AppT (AppT ArrowT (ConT ''Name))+ predType =+ EqualityT `AppT` VarT (mkName "mapper") `AppT` mapperType+ fnType =+ ConT ''Type+ & AppT (AppT ArrowT (ConT ''Type))+ & AppT (AppT ArrowT (VarT (mkName "mapper")))+ headType =+ ConT ''IsLabel+ `AppT` LitT (StrTyLit "var")+ `AppT` fnType+ in do+ assertEqual "cxt" [predType] decCxt+ assertEqual "headType" headType decHeadType+ _ ->+ assertFailure (show dec),+ testCase "Multiple fields" $+ let dec =+ Instances.sumMapperIsLabel+ (StrTyLit "val")+ (ConT ''Dec)+ 'ValD+ [ConT ''Pat, ConT ''Body, AppT ListT (ConT ''Dec)]+ in case dec of+ InstanceD _ decCxt decHeadType _ ->+ let tupleType =+ TupleT 3+ `AppT` (ConT ''Pat)+ `AppT` (ConT ''Body)+ `AppT` (AppT ListT (ConT ''Dec))+ mapperType =+ AppT+ (AppT ArrowT (ConT ''Pat))+ ( AppT+ (AppT ArrowT (ConT ''Body))+ ( AppT+ (AppT ArrowT (AppT ListT (ConT ''Dec)))+ tupleType+ )+ )+ predType =+ EqualityT `AppT` VarT (mkName "mapper") `AppT` mapperType+ fnType =+ ConT ''Dec+ & AppT (AppT ArrowT (ConT ''Dec))+ & AppT (AppT ArrowT (VarT (mkName "mapper")))+ headType =+ ConT ''IsLabel+ `AppT` LitT (StrTyLit "val")+ `AppT` fnType+ in do+ assertEqual "cxt" [predType] decCxt+ assertEqual "headType" headType decHeadType+ _ ->+ assertFailure (show dec)+ ] ]- ]
th-lego.cabal view
@@ -1,5 +1,5 @@ name: th-lego-version: 0.2.3+version: 0.3 synopsis: Template Haskell construction utilities description: A collection of templates for the typical patterns appearing