packages feed

traverse-code (empty) → 0.1

raw patch · 5 files changed

+269/−0 lines, 5 filesdep +basedep +containersdep +linear-generics

Dependencies added: base, containers, linear-generics, template-haskell, traverse-code

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for traverse-code++## 0.1 -- 2022-01-22++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2022, David Feuer++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 David Feuer 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.
+ src/Language/Haskell/TH/TraverseCode.hs view
@@ -0,0 +1,134 @@+{-# options_ghc -Wall #-}+{-# language TemplateHaskellQuotes #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language ScopedTypeVariables #-}+{-# language KindSignatures #-}+{-# language DataKinds #-}+{-# language TypeApplications #-}+{-# language TypeOperators #-}+{-# language EmptyCase #-}+{-# language DefaultSignatures #-}++module Language.Haskell.TH.TraverseCode+  ( TraverseCode (..)+  , sequenceCode+  , genericTraverseCode+  , genericSequenceCode+  ) where+import Generics.Linear+import Language.Haskell.TH.Syntax (Code, Lift (..), Exp (..), Quote, Name)+import qualified Language.Haskell.TH.Syntax as TH+--import qualified Language.Haskell.TH.Lib as TH+import Language.Haskell.TH.Lib (conE)+import Data.Kind (Type)++-- for instances+import qualified Data.Functor.Product as FProd+import qualified Data.Functor.Sum as FSum+import Data.Functor.Identity+import qualified Data.Sequence.Internal as Seq+import Data.Coerce+import Control.Applicative++class TraverseCode t where+  traverseCode :: Quote m => (a -> Code m b) -> t a -> Code m (t b)++  default traverseCode :: (Quote m, GTraverseCode (Rep1 t), Generic1 t) => (a -> Code m b) -> t a -> Code m (t b)+  traverseCode = genericTraverseCode++sequenceCode :: (TraverseCode t, Quote m) => t (Code m a) -> Code m (t a)+sequenceCode = traverseCode id++genericSequenceCode :: (Quote m, GTraverseCode (Rep1 t), Generic1 t) => t (Code m a) -> Code m (t a)+genericSequenceCode = TH.unsafeCodeCoerce . gtraverseCode id . from1++genericTraverseCode :: (Quote m, GTraverseCode (Rep1 t), Generic1 t) => (a -> Code m b) -> t a -> Code m (t b)+genericTraverseCode f = TH.unsafeCodeCoerce . gtraverseCode f . from1++class GTraverseCode f where+  gtraverseCode :: Quote m => (a -> Code m b) -> f a -> m Exp++data Goop (d :: Meta) (f :: Type -> Type) a = Goop++instance (Datatype c, GTraverseCodeCon f) => GTraverseCode (D1 c f) where+  gtraverseCode f (M1 x) = gtraverseCodeCon pkg modl f x+    where+      pkg = packageName (Goop @c @f)+      modl = moduleName (Goop @c @f)++class GTraverseCodeCon f where+  gtraverseCodeCon :: Quote m => String -> String -> (a -> Code m b) -> f a -> m Exp++-- This instance seems totally useless, but it's obviously valid.+instance GTraverseCodeCon V1 where+  gtraverseCodeCon _pkg _modl _f x = case x of++instance (GTraverseCodeCon f, GTraverseCodeCon g) => GTraverseCodeCon (f :+: g) where+  gtraverseCodeCon pkg modl f (L1 x) = gtraverseCodeCon pkg modl f x+  gtraverseCodeCon pkg modl f (R1 y) = gtraverseCodeCon pkg modl f y++instance (Constructor c, GTraverseCodeFields f) => GTraverseCodeCon (C1 c f) where+  gtraverseCodeCon pkg modl f (M1 x) = gtraverseCodeFields (conE conN) f x+    where+      conBase = conName (Goop @c @f)+      conN :: Name+      conN = TH.mkNameG_d pkg modl conBase++class GTraverseCodeFields f where+  gtraverseCodeFields :: Quote m => m Exp -> (a -> Code m b) -> f a -> m Exp++instance GTraverseCodeFields f => GTraverseCodeFields (S1 c f) where+  gtraverseCodeFields c f (M1 x) = gtraverseCodeFields c f x++instance (GTraverseCodeFields f, GTraverseCodeFields g) => GTraverseCodeFields (f :*: g) where+  gtraverseCodeFields c f (x :*: y) =+    gtraverseCodeFields (gtraverseCodeFields c f x) f y++instance Lift p => GTraverseCodeFields (K1 i p) where+  gtraverseCodeFields c _f (K1 x) = [| $c x |]++instance GTraverseCodeFields Par1 where+  gtraverseCodeFields cc f (Par1 ca) = [| $cc $(TH.unTypeCode (f ca)) |]++instance GTraverseCodeFields U1 where+  gtraverseCodeFields cc _f U1 = cc++instance (GTraverseCodeFields f, TraverseCode g) => GTraverseCodeFields (f :.: g) where+  gtraverseCodeFields cc f (Comp1 x) =+    gtraverseCodeFields cc (traverseCode f) x++-- TraverseCode instances++instance TraverseCode Maybe+instance TraverseCode Identity+instance TraverseCode []+instance TH.Lift a => TraverseCode (Either a)+instance TH.Lift a => TraverseCode ((,) a)+instance (TraverseCode f, TraverseCode g) => TraverseCode (FProd.Product f g)+instance (TraverseCode f, TraverseCode g) => TraverseCode (FSum.Sum f g)+instance Lift a => TraverseCode (Const a)++instance TraverseCode V1+instance TraverseCode U1+instance (TraverseCode f, TraverseCode g) => TraverseCode (f :*: g)+instance (TraverseCode f, TraverseCode g) => TraverseCode (f :+: g)+instance TraverseCode f => TraverseCode (M1 i c f)+instance TraverseCode Par1+instance Lift a => TraverseCode (K1 i a)++-- The Elem instance isn't needed for the Seq instance+instance TraverseCode Seq.Elem+instance TraverseCode Seq.Digit+instance TraverseCode Seq.Node+instance TraverseCode Seq.FingerTree+instance TraverseCode Seq.Seq where+  -- This wonky way of doing it makes for a more compact+  -- splice.+  traverseCode f s = [|| coerceFT $$(traverseCode f ft') ||]+    where+      ft' = coerceSeq (Seq.zipWith (flip const) (Seq.replicate (Seq.length s) ()) s)+coerceFT :: Seq.FingerTree a -> Seq.Seq a+coerceFT = coerce+coerceSeq :: Seq.Seq a -> Seq.FingerTree a+coerceSeq = coerce
+ test/TraverseCodeTest.hs view
@@ -0,0 +1,43 @@+{-# language TemplateHaskell #-}+module Main (main) where++import Language.Haskell.TH.TraverseCode+import qualified Data.Functor.Product as FP+import Data.Functor.Sum+import qualified Data.Sequence as S++boom :: a -> (Int, a)+boom a = $$(sequenceCode (12, [|| a ||]))++zorp :: Bool -> a -> Either Int a+zorp False a = $$(sequenceCode (Left 4))+zorp True a = $$(sequenceCode (Right [||a||]))++goo :: a -> a -> Maybe a -> FP.Product [] Maybe a+goo x1 x2 Nothing = $$(sequenceCode (FP.Pair [ [||x1||], [||x2||] ] Nothing))+goo x1 x2 (Just y) = $$(sequenceCode (FP.Pair [ [||x1||], [||x2||] ] (Just [||y||])))++emptySeq :: S.Seq a+emptySeq = $$(sequenceCode (S.fromList []))++single :: a -> S.Seq a+single a = $$(sequenceCode (S.fromList [ [||a||] ]))++double :: a -> a -> S.Seq a+double a b = $$(sequenceCode (S.fromList [ [||a||], [||b||] ]))++triple :: a -> a -> a -> S.Seq a+triple a b c = $$(sequenceCode (S.fromList [ [||a||], [||b||], [||c||] ]))++seq10 :: a -> a -> a -> a -> a ->+         a -> a -> a -> a -> a -> S.Seq a+seq10 a b c d e  f g h i j = $$(traverseCode id (S.fromList+   [ [||a||], [||b||], [||c||], [||d||], [||e||], [||f||], [||g||], [||h||],[||i||],[||j||] ]))++seq11 :: a -> a -> a -> a -> a ->+         a -> a -> a -> a -> a -> a -> S.Seq a+seq11 a b c d e  f g h i j k = $$(traverseCode id $ S.reverse (S.fromList+   [ [||a||], [||b||], [||c||], [||d||], [||e||], [||f||], [||g||], [||h||],[||i||],[||j||],[||k||] ]))++main :: IO ()+main = putStrLn "Test suite not yet implemented."
+ traverse-code.cabal view
@@ -0,0 +1,57 @@+cabal-version:      2.2+name:               traverse-code+version:            0.1+synopsis:           General data structure lifting for Template Haskell+tested-with:+    GHC ==9.0.1 || ==9.2.1++-- A longer description of the package.+description:+    .+    This package provides a simple type class to use Template Haskell+    to generate code for building data structures.+homepage:           https://github.com/treeowl/traverse-code++-- A URL where users can report bugs.+-- bug-reports:+license:            BSD-3-Clause+license-file:       LICENSE+author:             David Feuer+maintainer:         David.Feuer@gmail.com++-- A copyright notice.+-- copyright:+category:           Language+extra-source-files: CHANGELOG.md++library+    exposed-modules:+      Language.Haskell.TH.TraverseCode++    -- Modules included in this library but not exported.+    -- other-modules:++    -- LANGUAGE extensions used by modules in this package.+    other-extensions:+      TemplateHaskellQuotes++    -- TODO: figure out a base version; make things work with+    -- older Template Haskell+    build-depends:    base >=4.15.0.0 && < 4.17+                    , template-haskell >= 2.16+                    , containers+                    , linear-generics+    hs-source-dirs:   src+    default-language: Haskell2010++test-suite traverse-code-test+    default-language: Haskell2010+    type:             exitcode-stdio-1.0+    hs-source-dirs:   test+    main-is:          TraverseCodeTest.hs+    build-depends:+        base+      , template-haskell+      , traverse-code+      , containers+      , linear-generics