packages feed

th-lego (empty) → 0.1

raw patch · 7 files changed

+565/−0 lines, 7 filesdep +basedep +template-haskelldep +template-haskell-compat-v0208setup-changed

Dependencies added: base, template-haskell, template-haskell-compat-v0208, text

Files

+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2020 Nikita Volkov++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ library/THLego/Helpers.hs view
@@ -0,0 +1,131 @@+module THLego.Helpers+where++import THLego.Prelude+import Language.Haskell.TH+import qualified TemplateHaskell.Compat.V0208 as Compat+import qualified Data.Text as Text+++-- * Decs+-------------------------++typeSynonymDec :: Name -> Type -> Dec+typeSynonymDec a b =+  TySynD a [] b++recordNewtypeDec :: Name -> Name -> Type -> Dec+recordNewtypeDec _name _accessorName _type =+  NewtypeD [] _name [] Nothing _con []+  where+    _con =+      RecC _name [(_accessorName, noBang, _type)]++normalNewtypeDec :: Name -> Type -> Dec+normalNewtypeDec _name _type =+  NewtypeD [] _name [] Nothing _con []+  where+    _con =+      NormalC _name [(noBang, _type)]++recordAdtDec :: Name -> [(Name, Type)] -> Dec+recordAdtDec typeName fields =+  DataD [] typeName [] Nothing [con] []+  where+    con =+      RecC typeName (fmap (\ (fieldName, fieldType) -> (fieldName, fieldBang, fieldType)) fields)++productAdtDec :: Name -> [Type] -> Dec+productAdtDec typeName memberTypes =+  DataD [] typeName [] Nothing [con] []+  where+    con =+      NormalC typeName (fmap ((fieldBang,)) memberTypes)++sumAdtDec :: Name -> [(Name, [Type])] -> Dec+sumAdtDec a b =+  DataD [] a [] Nothing (fmap (uncurry sumCon) b) []++sumCon :: Name -> [Type] -> Con+sumCon a b =+  NormalC a (fmap (fieldBang,) b)++enumDec :: Name -> [Name] -> Dec+enumDec a b =+  DataD [] a [] Nothing (fmap (\ c -> NormalC c []) b) []+++-- *+-------------------------++textName :: Text -> Name+textName =+  mkName . Text.unpack++textTyLit :: Text -> TyLit+textTyLit =+  StrTyLit . Text.unpack++noBang :: Bang+noBang =+  Bang NoSourceUnpackedness NoSourceStrictness++fieldBang :: Bang+fieldBang =+  Bang NoSourceUnpackedness SourceStrict++multiAppT :: Type -> [Type] -> Type+multiAppT base args =+  foldl' AppT base args++multiAppE :: Exp -> [Exp] -> Exp+multiAppE base args =+  foldl' AppE base args++arrowChainT :: [Type] -> Type -> Type+arrowChainT params result =+  foldr (\ a b -> AppT (AppT ArrowT a) b) result params++appliedTupleT :: [Type] -> Type+appliedTupleT a =+  foldl' AppT (TupleT (length a)) a++appliedTupleOrSingletonT :: [Type] -> Type+appliedTupleOrSingletonT =+  \ case+    [a] -> a+    a -> appliedTupleT a++appliedTupleE :: [Exp] -> Exp+appliedTupleE =+  Compat.tupE++appliedTupleOrSingletonE :: [Exp] -> Exp+appliedTupleOrSingletonE =+  \ case+    [a] -> a+    a -> appliedTupleE a++indexName :: Int -> Name+indexName =+  mkName . showChar '_' . show++enumNames :: Int -> [Name]+enumNames =+  fmap indexName . enumFromTo 0 . pred++aName :: Name+aName =+  mkName "a"++bName :: Name+bName =+  mkName "b"++cName :: Name+cName =+  mkName "c"++eqConstraintT :: Name -> Type -> Type+eqConstraintT name =+  AppT (AppT EqualityT (VarT name))
+ library/THLego/Instances.hs view
@@ -0,0 +1,177 @@+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+++-- * IsLabel+-------------------------++isLabel :: TyLit -> Type -> Exp -> Dec+isLabel label repType fromLabelExp =+  InstanceD Nothing [] headType [fromLabelDec]+  where+    headType =+      multiAppT (ConT ''IsLabel) [LitT label, repType]+    fromLabelDec =+      FunD 'fromLabel [Clause [] body []]+      where+        body =+          NormalB fromLabelExp++-- ** Constructor+-------------------------++newtypeConstructorIsLabel :: TyLit -> Type -> Name -> Type -> Dec+newtypeConstructorIsLabel label ownerType conName memberType =+  isLabel label repType fromLabelExp+  where+    repType =+      arrowChainT [memberType] ownerType+    fromLabelExp =+      ConE conName++sumConstructorIsLabel :: TyLit -> Type -> Name -> [Type] -> Dec+sumConstructorIsLabel label ownerType conName memberTypes =+  isLabel label repType fromLabelExp+  where+    repType =+      arrowChainT memberTypes ownerType+    fromLabelExp =+      ConE conName++enumConstructorIsLabel :: TyLit -> Type -> Name -> Dec+enumConstructorIsLabel label ownerType conName =+  isLabel label ownerType fromLabelExp+  where+    fromLabelExp =+      ConE conName++{-|+'IsLabel' instance which converts tuple to ADT.+-}+tupleAdtConstructorIsLabel :: TyLit -> Type -> Name -> [Type] -> Dec+tupleAdtConstructorIsLabel label ownerType conName memberTypes =+  isLabel label repType fromLabelExp+  where+    repType =+      arrowChainT [appliedTupleT memberTypes] ownerType+    fromLabelExp =+      Lambdas.tupleToProduct conName (length memberTypes)++-- ** Accessor+-------------------------++productAccessorIsLabel :: TyLit -> Type -> Type -> Name -> Int -> Int -> Dec+productAccessorIsLabel label ownerType projectionType conName numMembers offset =+  isLabel label repType fromLabelExp+  where+    repType =+      multiAppT ArrowT [ownerType, projectionType]+    fromLabelExp =+      Lambdas.productGetter conName numMembers offset++sumAccessorIsLabel :: TyLit -> Type -> Name -> [Type] -> Dec+sumAccessorIsLabel label ownerType conName memberTypes =+  isLabel label repType fromLabelExp+  where+    repType =+      multiAppT ArrowT [ownerType, projectionType]+      where+        projectionType =+          AppT (ConT ''Maybe) (appliedTupleT memberTypes)+    fromLabelExp =+      Lambdas.adtConstructorNarrower conName (length memberTypes)++enumAccessorIsLabel :: TyLit -> Type -> Name -> Dec+enumAccessorIsLabel label ownerType conName =+  isLabel label repType fromLabelExp+  where+    repType =+      multiAppT ArrowT [ownerType, projectionType]+      where+        projectionType =+          ConT ''Bool+    fromLabelExp =+      Lambdas.enumConstructorToBool conName+++-- * 'HasField'+-------------------------++{-| The most general template for 'HasField'. -}+hasField :: TyLit -> Type -> Type -> [Clause] -> Dec+hasField fieldLabel ownerType projectionType getFieldFunClauses =+  InstanceD Nothing [] headType [getFieldDec]+  where+    headType =+      multiAppT (ConT ''HasField) [LitT fieldLabel, ownerType, projectionType]+    getFieldDec =+      FunD 'getField getFieldFunClauses++{-|+Field which projects enum values into bools.+-}+enumHasField :: TyLit -> Type -> Name -> Dec+enumHasField fieldLabel ownerType constructorName =+  hasField fieldLabel ownerType projectionType getFieldFunClauses+  where+    projectionType =+      ConT ''Bool+    getFieldFunClauses =+      [matching, unmatching]+      where+        matching =+          Clause [ConP constructorName []] (NormalB bodyExp) []+          where+            bodyExp =+              ConE 'True+        unmatching =+          Clause [WildP] (NormalB bodyExp) []+          where+            bodyExp =+              ConE 'False++sumHasField :: TyLit -> Type -> Name -> [Type] -> Dec+sumHasField fieldLabel ownerType constructorName memberTypes =+  hasField fieldLabel ownerType projectionType getFieldFunClauses+  where+    projectionType =+      AppT (ConT ''Maybe) (appliedTupleOrSingletonT memberTypes)+    getFieldFunClauses =+      [matching, unmatching]+      where+        varNames =+          enumFromTo 1 (length memberTypes) &+          fmap (mkName . showChar '_' . show)+        matching =+          Clause [ConP constructorName pats] (NormalB bodyExp) []+          where+            pats =+              fmap VarP varNames+            bodyExp =+              AppE (ConE 'Just) (appliedTupleE (fmap VarE varNames))+        unmatching =+          Clause [WildP] (NormalB bodyExp) []+          where+            bodyExp =+              ConE 'Nothing++productHasField :: TyLit -> Type -> Type -> Name -> Int -> Int -> Dec+productHasField fieldLabel ownerType projectionType constructorName totalMemberTypes offset =+  hasField fieldLabel ownerType projectionType getFieldFunClauses+  where+    getFieldFunClauses =+      [Clause [ConP constructorName pats] (NormalB bodyExp) []]+      where+        pats =+          replicate offset WildP <>+          bool empty [VarP aName] (totalMemberTypes > 0) <>+          replicate (totalMemberTypes - offset - 1) WildP+        bodyExp =+          VarE aName
+ library/THLego/Lambdas.hs view
@@ -0,0 +1,113 @@+module THLego.Lambdas+where++import THLego.Prelude+import THLego.Helpers+import Language.Haskell.TH+import qualified TemplateHaskell.Compat.V0208 as Compat+++{-|+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.+-}+productGetter :: Name -> Int -> Int -> Exp+productGetter conName numMembers index =+  LamE [pat] exp+  where+    varName =+      indexName index+    pat =+      ConP conName pats+      where+        pats =+          replicate index WildP <>+          pure (VarP varName) <>+          replicate (numMembers - index - 1) WildP+    exp =+      VarE varName++{-|+Lambda expression, which sets a product member by index.+-}+productSetter :: Name -> Int -> Int -> Exp+productSetter conName numMembers index =+  LamE [stateP, valP] exp+  where+    valName =+      mkName "x"+    stateP =+      ConP conName pats+      where+        pats =+          fmap (VarP . indexName) (enumFromTo 0 (pred numMembers))+    valP =+      VarP valName+    exp =+      foldl' AppE (ConE conName) (fmap VarE names)+      where+        names =+          fmap indexName (enumFromTo 0 (pred index)) <>+          pure valName <>+          fmap indexName (enumFromTo (succ index) (pred numMembers))++adtConstructorNarrower :: Name -> Int -> Exp+adtConstructorNarrower conName numMembers =+  matcher [positive, negative]+  where+    positive =+      Match (ConP conName (fmap VarP varNames)) (NormalB exp) []+      where+        varNames =+          fmap indexName (enumFromTo 0 (pred numMembers))+        exp =+          AppE (ConE 'Just) (Compat.tupE (fmap VarE varNames))+    negative =+      Match WildP (NormalB (ConE 'Nothing)) []++enumConstructorToBool :: Name -> Exp+enumConstructorToBool constructorName =+  matcher [positive, negative]+  where+    positive =+      Match (ConP constructorName []) (NormalB bodyExp) []+      where+        bodyExp =+          ConE 'True+    negative =+      Match WildP (NormalB bodyExp) []+      where+        bodyExp =+          ConE 'False++singleConstructorAdtToTuple :: Name -> Int -> Exp+singleConstructorAdtToTuple conName numMembers =+  LamE [pat] exp+  where+    varNames =+      fmap indexName (enumFromTo 0 (pred numMembers))+    pat =+      ConP conName (fmap VarP varNames)+    exp =+      Compat.tupE (fmap VarE varNames)++tupleToProduct :: Name -> Int -> Exp+tupleToProduct conName numMembers =+  LamE [pat] exp+  where+    varNames =+      fmap indexName (enumFromTo 0 (pred numMembers))+    pat =+      TupP (fmap VarP varNames)+    exp =+      multiAppE (ConE conName) (fmap VarE varNames)++namedFieldSetter :: Name -> Exp+namedFieldSetter fieldName =+  LamE [VarP aName, VarP bName] (RecUpdE (VarE aName) [(fieldName, VarE bName)])
+ library/THLego/Prelude.hs view
@@ -0,0 +1,86 @@+module THLego.Prelude+( +  module Exports,+  showAsText,+)+where++-- base+-------------------------+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.Fail as Exports+import Control.Monad.Fix as Exports hiding (fix)+import Control.Monad.ST as Exports+import Data.Bifunctor as Exports+import Data.Bits as Exports+import Data.Bool as Exports+import Data.Char as Exports+import Data.Coerce as Exports+import Data.Complex as Exports+import Data.Data as Exports+import Data.Dynamic as Exports+import Data.Either as Exports+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.Compose as Exports+import Data.Functor.Contravariant as Exports+import Data.Int as Exports+import Data.IORef 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.Maybe as Exports+import Data.Monoid as Exports hiding (Alt)+import Data.Ord as Exports+import Data.Proxy as Exports+import Data.Ratio as Exports+import Data.STRef as Exports+import Data.String as Exports+import Data.Traversable as Exports+import Data.Tuple as Exports+import Data.Unique as Exports+import Data.Version as Exports+import Data.Void as Exports+import Data.Word as Exports+import Debug.Trace as Exports+import Foreign.ForeignPtr as Exports+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.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)+import System.IO.Error as Exports+import System.IO.Unsafe as Exports+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, 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 Unsafe.Coerce as Exports++-- text+-------------------------+import Data.Text as Exports (Text)+++showAsText :: Show a => a -> Text+showAsText = show >>> fromString
+ th-lego.cabal view
@@ -0,0 +1,34 @@+name: th-lego+version: 0.1+synopsis: Template Haskell construction utilities+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 <nikita.y.volkov@mail.ru>+maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>+copyright: (c) 2020 Nikita Volkov+license: MIT+license-file: LICENSE+build-type: Simple+cabal-version: >=1.10++source-repository head+  type: git+  location: git://github.com/nikita-volkov/th-lego.git++library+  hs-source-dirs: library+  default-extensions: BangPatterns, BlockArguments, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, DerivingVia, 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+  exposed-modules:+    THLego.Helpers+    THLego.Instances+    THLego.Lambdas+  other-modules:+    THLego.Prelude+  build-depends:+    base >=4.11 && <5,+    template-haskell >=2.15 && <3,+    template-haskell-compat-v0208 >=0.1.5 && <0.2,+    text >=1 && <2