hetero-parameter-list-with-typelevel-tools (empty) → 0.1.0.0

raw patch · 8 files changed

+224/−0 lines, 8 filesdep +basedep +hetero-parameter-listdep +hetero-parameter-list-with-typelevel-toolssetup-changed

Dependencies added: base, hetero-parameter-list, hetero-parameter-list-with-typelevel-tools, template-haskell, typelevel-tools-yj

Files

• CHANGELOG.md +11/−0
• LICENSE +30/−0
• README.md +1/−0
• Setup.hs +2/−0
• hetero-parameter-list-with-typelevel-tools.cabal +58/−0
• src/Data/HeteroParList/Tuple.hs +14/−0
• src/Data/HeteroParList/Tuple/TH.hs +106/−0
• test/Spec.hs +2/−0

@@ -0,0 +1,11 @@+# Changelog for `try-hetero-parameter-list-with-typelevel-tools`++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

@@ -0,0 +1,30 @@+Copyright Author name here (c) 2023++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * 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.++    * Neither the name of Author name here nor the names of other+      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+OWNER 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.

@@ -0,0 +1,1 @@+# try-hetero-parameter-list-with-typelevel-tools

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,58 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.37.0.+--+-- see: https://github.com/sol/hpack++name:           hetero-parameter-list-with-typelevel-tools+version:        0.1.0.0+synopsis:       Hetero parameter list with type level tools+description:    Please see the README on GitHub at <https://github.com/githubuser/hetero-parameter-list-with-typelevel-tools#readme>+category:       Data+homepage:       https://github.com/githubuser/hetero-parameter-list-with-typelevel-tools#readme+bug-reports:    https://github.com/githubuser/hetero-parameter-list-with-typelevel-tools/issues+author:         Author name here+maintainer:     example@example.com+copyright:      2023 Author name here+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/githubuser/hetero-parameter-list-with-typelevel-tools++library+  exposed-modules:+      Data.HeteroParList.Tuple+      Data.HeteroParList.Tuple.TH+  other-modules:+      Paths_hetero_parameter_list_with_typelevel_tools+  hs-source-dirs:+      src+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      base >=4.7 && <5+    , hetero-parameter-list <2+    , template-haskell <3+    , typelevel-tools-yj <2+  default-language: Haskell2010++test-suite hetero-parameter-list-with-typelevel-tools-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_hetero_parameter_list_with_typelevel_tools+  hs-source-dirs:+      test+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , hetero-parameter-list <2+    , hetero-parameter-list-with-typelevel-tools+    , template-haskell <3+    , typelevel-tools-yj <2+  default-language: Haskell2010

@@ -0,0 +1,14 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE DataKinds, PolyKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Data.HeteroParList.Tuple where++import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex+import Data.HeteroParList.Tuple.TH++concat <$> uncurry mkMap `mapM` [ (i, n) | n <- [2 .. 10], i <- [0 .. n - 1] ]

@@ -0,0 +1,106 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE DataKinds, PolyKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Data.HeteroParList.Tuple.TH where++import Control.Monad+import Language.Haskell.TH++import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex+import Data.HeteroParList qualified as HeteroParList+import Data.HeteroParList (pattern (:**))++mkMap :: Int -> Int -> DecsQ+mkMap i n = do+	ts <- newName `mapM` take n typeVarNames+	ks <- newName `mapM` take n kindVarNames+	barAll cn fn ts ks i+	where+	cn = mkName $ "Map" ++ show i ++ "_" ++ show n+	fn = mkName $ "map" ++ show i ++ "_" ++ show n++barAll :: Name -> Name -> [Name] -> [Name] -> Int -> DecsQ+barAll cn fn ts ks i =+	sequence [barRaw cn fn ts ks i, barRaw0 cn fn, barRaw1 cn fn ts]++bar :: DecQ+bar = barRaw (mkName "Map0_2") (mkName "map0_2") [mkName "a", mkName "b"] [mkName "k0", mkName "k1"] 0++barRaw :: Name -> Name -> [Name] -> [Name] -> Int -> DecQ+barRaw cn fn ts ks i = classD (pure []) cn+	[kindedTV (mkName "ss") sskind] [] [sigD fn map0_2type]+	where+	sskind = listKind . tupleKind $ varK <$> ks+	map0_2type = ftype `arrT` (stype `arrT` dtype)+	ftype = do+		abcs <- zipWithM kindedInvis ts ks+		forallT	abcs (pure []) (tab `arrT` tb)+	kindedInvis v t = kindedInvisTV v SpecifiedSpec . pure $ varK t+	tab = varT (mkName "t") `appT` promotedTupleType (varT <$> ts)+	tb = varT (mkName "t'") `appT` varT (ts !! i)+	stype = pl `appT` varT (mkName "t") `appT` varT (mkName "ss")+	dtype = pl `appT` varT (mkName "t'") `appT` (m0_2 i (length ts) `appT` varT (mkName "ss"))++bar0 :: DecQ+bar0 = barRaw0 (mkName "Map0_2") (mkName "map0_2")++barRaw0 :: Name -> Name -> DecQ+barRaw0 cn fn = instanceD (cxt [])+	(conT cn `appT` promotedNilT)+	[funD fn [clause [wildP, conP 'HeteroParList.Nil []] (normalB $ conE 'HeteroParList.Nil) []]]++bar1 :: DecQ+bar1 = barRaw1 (mkName "Map0_2") (mkName "map0_2") [mkName "a", mkName "b"]++barRaw1 :: Name -> Name -> [Name] -> DecQ+barRaw1 cn fn ts = instanceD (cxt [conT cn `appT` varT (mkName "ts")])+	(conT cn `appT`+		(promotedTupleType (varT <$> ts) `promotedConsType`+			varT (mkName "ts")))+	[funD fn [clause+		[varP $ mkName "f", varP (mkName "x") `heteroConsP` varP (mkName "xs")]+		(normalB $ varE (mkName "f") `appE` varE (mkName "x") `heteroCons`+			(varE fn `appE` varE (mkName "f") `appE` varE (mkName "xs")))+		[]]]++pl :: TypeQ+pl = conT ''HeteroParList.PL++m0_2 :: Int -> Int -> TypeQ+-- m0_2 i n = conT $ mkNameG_tc "typelevel-tools" "Data.TypeLevel.MapIndex" ("M" ++ show i ++ "_" ++ show n)+m0_2 i n = conT . mkName $ "TMapIndex.M" ++ show i ++ "_" ++ show n++tupleKind :: [Kind] -> Kind+tupleKind ks = foldl appK (tupleK $ length ks) ks++listKind :: Kind -> Kind+listKind = (listK `appK`)++arrT :: Quote m => m Type -> m Type -> m Type+t1 `arrT` t2 = arrowT `appT` t1 `appT` t2++promotedTupleType :: Quote m => [m Type] -> m Type+promotedTupleType ts = foldl appT (promotedTupleT $ length ts) ts++promotedConsType :: Quote m => m Type -> m Type -> m Type+promotedConsType t ts = promotedConsT `appT` t `appT` ts++heteroCons :: Quote m => m Exp -> m Exp -> m Exp+heteroCons x xs = infixE (Just x) (conE '(:**)) (Just xs)++heteroConsP :: Quote m => m Pat -> m Pat -> m Pat+heteroConsP p ps = infixP p '(:**) ps++typeVarNames :: [String]+typeVarNames = ((: "") <$> ['a' .. 'z']) +++	[ cs ++ [c] | cs <- typeVarNames, c <- ['a' .. 'z'] ]++kindVarNames :: [String]+kindVarNames = ('k' :) . show <$> [0 :: Int ..]

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"