diff --git a/library/THLego/Helpers.hs b/library/THLego/Helpers.hs --- a/library/THLego/Helpers.hs +++ b/library/THLego/Helpers.hs @@ -51,8 +51,6 @@ enumDec a b = DataD [] a [] Nothing (fmap (\c -> NormalC c []) b) [] --- * - textName :: Text -> Name textName = mkName . Text.unpack @@ -145,8 +143,6 @@ eqConstraintT :: Name -> Type -> Type eqConstraintT name = AppT (AppT EqualityT (VarT name)) - --- * applicativeChainE :: Exp -> [Exp] -> Exp applicativeChainE mappingE apEList = diff --git a/library/THLego/Instances.hs b/library/THLego/Instances.hs --- a/library/THLego/Instances.hs +++ b/library/THLego/Instances.hs @@ -1,6 +1,5 @@ module THLego.Instances where -import qualified Data.Text as Text import Language.Haskell.TH import THLego.Helpers import qualified THLego.Helpers as Helpers @@ -250,7 +249,7 @@ [matching, unmatching] where matching = - Clause [Compat.conp constructorName []] (NormalB bodyExp) [] + Clause [Compat.conP constructorName []] (NormalB bodyExp) [] where bodyExp = ConE 'True @@ -294,7 +293,7 @@ memberTypes & mapWithAlphabeticName (const . id) matching = - Clause [Compat.conp constructorName pats] (NormalB bodyExp) [] + Clause [Compat.conP constructorName pats] (NormalB bodyExp) [] where pats = fmap VarP varNames @@ -327,7 +326,7 @@ hasField fieldLabel ownerType projectionType getFieldFunClauses where getFieldFunClauses = - [Clause [Compat.conp constructorName pats] (NormalB bodyExp) []] + [Clause [Compat.conP constructorName pats] (NormalB bodyExp) []] where pats = replicate offset WildP diff --git a/library/THLego/Lambdas.hs b/library/THLego/Lambdas.hs --- a/library/THLego/Lambdas.hs +++ b/library/THLego/Lambdas.hs @@ -31,7 +31,7 @@ onMemberP = VarP onMemberName productP = - Compat.conp conName pats + Compat.conP conName pats where pats = fmap VarP memberNames @@ -79,7 +79,7 @@ varName = alphabeticIndexName index pat = - Compat.conp conName pats + Compat.conP conName pats where pats = replicate index WildP @@ -110,7 +110,7 @@ memberNames = fmap alphabeticIndexName (enumFromTo 0 (pred numMembers)) stateP = - Compat.conp conName pats + Compat.conP conName pats where pats = (memberNames & take index & fmap VarP) @@ -138,8 +138,6 @@ productMapper conName numMembers index = LamE [mapperP, stateP] exp where - memberName = - alphabeticIndexName index memberNames = fmap alphabeticIndexName (enumFromTo 0 (pred numMembers)) valName = @@ -149,15 +147,15 @@ mapperP = VarP fnName stateP = - Compat.conp conName pats + Compat.conP conName pats where pats = 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)) + 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)) -- | -- Lambda expression, which maps a sum member by index. @@ -182,7 +180,7 @@ [pos, neg] where pos = - Match (Compat.conp conName memberPats) (NormalB bodyExp) [] + Match (Compat.conP conName memberPats) (NormalB bodyExp) [] where memberVarNames = fmap alphabeticIndexName (enumFromTo 0 (pred numMembers)) @@ -200,7 +198,7 @@ matcher [positive, negative] where positive = - Match (Compat.conp conName (fmap VarP varNames)) (NormalB exp) [] + Match (Compat.conP conName (fmap VarP varNames)) (NormalB exp) [] where varNames = fmap alphabeticIndexName (enumFromTo 0 (pred numMembers)) @@ -214,7 +212,7 @@ matcher [positive, negative] where positive = - Match (Compat.conp constructorName []) (NormalB bodyExp) [] + Match (Compat.conP constructorName []) (NormalB bodyExp) [] where bodyExp = ConE 'True @@ -231,7 +229,7 @@ varNames = fmap alphabeticIndexName (enumFromTo 0 (pred numMembers)) pat = - Compat.conp conName (fmap VarP varNames) + Compat.conP conName (fmap VarP varNames) exp = Compat.tupE (fmap VarE varNames) diff --git a/library/THLego/Prelude.hs b/library/THLego/Prelude.hs --- a/library/THLego/Prelude.hs +++ b/library/THLego/Prelude.hs @@ -26,7 +26,7 @@ import Data.Fixed as Exports import Data.Foldable as Exports hiding (toList) import Data.Function as Exports hiding (id, (.)) -import Data.Functor as Exports +import Data.Functor as Exports hiding (unzip) import Data.Functor.Compose as Exports import Data.IORef as Exports import Data.Int as Exports @@ -67,12 +67,10 @@ import System.Mem as Exports 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, 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 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 a) => a -> Text showAsText = show >>> fromString diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,152 +1,148 @@ module Main where 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.HUnit -import Test.Tasty.QuickCheck -import Test.Tasty.Runners import Prelude hiding (assert) +main :: IO () main = - defaultMain $ - testGroup + 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), + [ 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) + [ 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) ] ] diff --git a/th-lego.cabal b/th-lego.cabal --- a/th-lego.cabal +++ b/th-lego.cabal @@ -1,55 +1,130 @@ -name: th-lego -version: 0.3.0.2 -synopsis: Template Haskell construction utilities +cabal-version: 3.0 +name: th-lego +version: 0.3.0.3 +synopsis: Template Haskell construction utilities description: A collection of templates for the typical patterns appearing in construction of Template Haskell AST. E.g., typical instance declaration templates, lambda expressions for accessing members of data-types. -stability: Experimental -category: Template Haskell -homepage: https://github.com/nikita-volkov/th-lego -bug-reports: https://github.com/nikita-volkov/th-lego/issues -author: Nikita Volkov -maintainer: Nikita Volkov -copyright: (c) 2020 Nikita Volkov -license: MIT -license-file: LICENSE -build-type: Simple -cabal-version: >=1.10 +stability: Experimental +category: Template Haskell +homepage: https://github.com/nikita-volkov/th-lego +bug-reports: https://github.com/nikita-volkov/th-lego/issues +author: Nikita Volkov +maintainer: Nikita Volkov +copyright: (c) 2020 Nikita Volkov +license: MIT +license-file: LICENSE + source-repository head - type: git + type: git location: git://github.com/nikita-volkov/th-lego.git library - hs-source-dirs: library - default-extensions: BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, StrictData, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UnboxedTuples - default-language: Haskell2010 + hs-source-dirs: library + default-extensions: + NoImplicitPrelude + NoMonomorphismRestriction + BangPatterns + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + LambdaCase + LiberalTypeSynonyms + MagicHash + MultiParamTypeClasses + MultiWayIf + OverloadedStrings + ParallelListComp + PatternGuards + QuasiQuotes + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + StrictData + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + UnboxedTuples + + default-language: Haskell2010 exposed-modules: THLego.Helpers THLego.Instances THLego.Lambdas - other-modules: - THLego.Prelude + + other-modules: THLego.Prelude build-depends: - base >=4.10 && <5, - template-haskell >=2.8 && <3, - template-haskell-compat-v0208 >=0.1.5 && <0.2, - text >=1 && <3 + , base >=4.10 && <5 + , template-haskell >=2.8 && <3 + , template-haskell-compat-v0208 >=0.1.5 && <0.2 + , text >=1 && <3 test-suite test - type: exitcode-stdio-1.0 - hs-source-dirs: test - default-extensions: BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, StrictData, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UnboxedTuples - default-language: Haskell2010 - main-is: Main.hs + type: exitcode-stdio-1.0 + hs-source-dirs: test + default-extensions: + NoImplicitPrelude + NoMonomorphismRestriction + BangPatterns + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + LambdaCase + LiberalTypeSynonyms + MagicHash + MultiParamTypeClasses + MultiWayIf + OverloadedStrings + ParallelListComp + PatternGuards + QuasiQuotes + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + StrictData + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + UnboxedTuples + + default-language: Haskell2010 + main-is: Main.hs build-depends: - QuickCheck >=2.8.1 && <3, - quickcheck-instances >=0.3.11 && <0.4, - rerebase >=1.10.0.1 && <2, - tasty >=0.12 && <2, - tasty-hunit >=0.9 && <0.11, - tasty-quickcheck >=0.9 && <0.11, - template-haskell, - th-lego + , rerebase >=1.10.0.1 && <2 + , tasty >=0.12 && <2 + , tasty-hunit >=0.9 && <0.11 + , template-haskell + , th-lego