type-spine (empty) → 0.1
raw patch · 7 files changed
+304/−0 lines, 7 filesdep +basedep +template-haskellsetup-changed
Dependencies added: base, template-haskell
Files
- LICENSE +1/−0
- Setup.hs +2/−0
- Type/Spine.hs +52/−0
- Type/Spine/Kinds.hs +106/−0
- Type/Spine/Stage0.hs +63/−0
- Type/Spine/TH.hs +49/−0
- type-spine.cabal +31/−0
+ LICENSE view
@@ -0,0 +1,1 @@+BSD3
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Type/Spine.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE TypeFamilies, TemplateHaskell, EmptyDataDecls, TypeOperators #-}++{- |++Module : Type.Spine+Copyright : (c) The University of Kansas 2011+License : BSD3++Maintainer : nicolas.frisby@gmail.com+Stability : experimental+Portability : see LANGUAGE pragmas (... GHC)++The spine-view on types.++-}+module Type.Spine (qK, Spine, TypeName, (:@), spineType) where++import Type.Spine.Kinds (parseK_, forallAppsK)+import Type.Spine.Stage0++import Language.Haskell.TH (Kind(ArrowK), tySynInstD, varT, mkName)+import Language.Haskell.TH.Quote (QuasiQuoter(..))++import Control.Monad ((<=<))++++-- | @[qK|...|]@ is the a type that takes one parameter of the corresponding+-- kind. (The name is an encoding of that parameter's kind based on prefix+-- notation for application.)+qK :: QuasiQuoter+qK = QuasiQuoter (error "Type.Spine.qK Exp")+ (error "Type.Spine.qK Pat")+ (kTypeG <=< parseK_) (error "Type.Spine.qK Dec")++infixl 9 :@+-- | A type-level application.+data tc :@ t++fmap concat $ forallAppsK $ \ak k ->+ let kq = kTypeG k; aq = kTypeG ak; fq = kTypeG $ ArrowK ak k+ [f, a] = map (varT . mkName) ["f", "a"]+ in (:[]) `fmap` tySynInstD ''Spine [[t| $kq ($f $a) |]] [t| $fq $f :@ $aq $a |]++++++fmap concat $ mapM spineType+ [''Bool, ''Char, ''Double, ''Float, ''Int, ''Integer, ''Ordering,+ ''(), ''(,), ''(,,), ''(,,,), ''(,,,,),+ ''IO, ''[], ''Maybe, ''(->), ''Either]
+ Type/Spine/Kinds.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE ViewPatterns #-}++{- |++Module : Type.Spine.Kinds+Copyright : (c) The University of Kansas 2011+License : BSD3++Maintainer : nicolas.frisby@gmail.com+Stability : experimental+Portability : see LANGUAGE pragmas (... GHC)++Kinds for the spine-view on types.++-}+module Type.Spine.Kinds where++import Language.Haskell.TH+import Language.Haskell.TH.Quote++import Control.Monad ((<=<), liftM)++import qualified Control.Arrow as Arrow+++-- | The set of kinds that this library will initially support as type+-- parameters.+parameterKinds :: [Kind]+parameterKinds =+ [StarK, ArrowK StarK StarK, ArrowK StarK (ArrowK StarK StarK)]++-- | The default number of parameters that this library will initially support.+maxParameters = 5 :: Int++-- | The kinds consequent from @parameterKinds@ and @maxParameters@.+allKinds = [ k | n <- [0..maxParameters], k <- generateK parameterKinds n ]++++-------------------- parsing kinds+badParseK s = fail $ "Data.Proxy.TH.Aux could not parse: " ++ s++parseK_ :: Monad m => String -> m Kind+parseK_ s = parseK s >>= \(k, s) -> case trim s of+ "" -> return k+ _ -> badParseK s++trim = dropWhile (==' ')++parseK :: Monad m => String -> m (Kind, String)+parseK s = w s where+ bad = badParseK s++ w s = w1 s >>= \p@(k, s) -> case trim s of+ '-' : '>' : s -> Arrow.first (ArrowK k) `liftM` w s+ _ -> return p++ w1 (' ' : s) = w1 s+ w1 ('(' : s) = w s >>= \(k, s) -> case trim s of+ ')' : s -> return (k, s)+ _ -> bad+ w1 ('*' : s) = return (StarK, s)+ w1 _ = bad++-------------------- serializing kind as Haskell identifier+stringK = w where+ w StarK = "S"+ w (ArrowK k1 k2) = 'T' : w k1 ++ w k2++nameK = mkName . ('K' :) . stringK where++typeK = conT . nameK++declareK k = do+ let n = nameK k+ let dec = DataD [] n [KindedTV (mkName "t") k] [] []+ i <- recover (return Nothing) $ Just `fmap` reify n+ case i of+ Nothing -> return [dec]+ Just (TyConI (DataD [] _ [PlainTV _] [] [])) | StarK == k -> return []+ Just (TyConI (DataD [] _ [KindedTV _ ((== k) -> True)] [] [])) -> return []+ _ -> fail $ "Data.Proxy.TH.Aux: " ++ show n ++ " is already declared (and not equivalently)"++-- | @[qK|...|]@ is either the declaration of a type that takes one parameter+-- of the corresponding kind, or an occurrence of that type constructor. (The+-- name is an encoding of that parameter's kind based on prefix notation for+-- application.)+qK :: QuasiQuoter+qK = QuasiQuoter (error "Type.Spine.Kinds.qK Exp")+ (error "Type.Spine.Kinds.qK Pat")+ (typeK <=< parseK_) (declareK <=< parseK_)+++-- | @generateK pks n@ generates all 'Kind's with @0@ to @n@ parameters taken+-- from @pks@.+generateK pks 0 = [StarK]+generateK pks n = concatMap (\k ->+ (map (flip ArrowK k) pks)) (generateK pks (n - 1))+++-- | Calls its argument once for each parameter and kind pair implied by+-- @maxParameters@ and @parameterKinds@.+forallAppsK :: (Kind -> Kind -> Q a) -> Q [a]+forallAppsK w = mapM (uncurry w) [ (ak, k)+ | n <- [0..maxParameters - 1], k <- generateK parameterKinds n,+ ak <- parameterKinds]
+ Type/Spine/Stage0.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE TypeFamilies, TemplateHaskell, KindSignatures, EmptyDataDecls #-}++{- |++Module : Type.Spine.Stage0+Copyright : (c) The University of Kansas 2011+License : BSD3++Maintainer : nicolas.frisby@gmail.com+Stability : experimental+Portability : see LANGUAGE pragmas (... GHC)++Declares the type wrappers (mappings @k -> *) for 'allKinds' and then defines+functions for referencing them. Also provides a Template Haskell function for+generating the @Spine@ type instances for user-defined datatypes.++-}+module Type.Spine.Stage0 where++import Language.Haskell.TH++import Type.Spine.TH (liftNameG, tyConSignature)+import Type.Spine.Kinds (allKinds, declareK, nameK)++import Control.Monad ((<=<))+++-- | The @Spine@ type family represents its argument as either a @TypeName@ or+-- an application via @(:@)@.+type family Spine t++-- | @TypeName@ represents an occurrence of totally unapplied type name.+data TypeName x++++fmap concat $ mapM declareK allKinds++-- | @kNameG k@ returns the globally unique name (i.e. TH's @NameG@) of the+-- declared wrapper for types of kind @k@.+kNameG :: Kind -> Q Name+kNameG k = $(caseE [| k |] $ [+ let n = nameK k in+ match (let p StarK = conP 'StarK []+ p (ArrowK k1 k2) = conP 'ArrowK [p k1, p k2] in p k)+ (normalB $ [| return $(liftNameG n) |]) []+ | k <- allKinds ] +++ [match wildP (normalB [| fail $ show k ++ " is not supported by type-kinds" |]) []])++-- | @kTypeG = conT <=< kNameG@.+kTypeG :: Kind -> Q Type+kTypeG = conT <=< kNameG+++++-- | @spineType n@ generates the @Spine@ instance for the type named @n@.+spineType :: Name -> Q [Dec]+spineType n = do+ (ks, k) <- tyConSignature n+ let kq = kTypeG $ foldr ArrowK k ks+ t = [t| $kq $(conT n) |]+ (:[]) `fmap` tySynInstD ''Spine [t] [t| TypeName $t |]
+ Type/Spine/TH.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE TemplateHaskell #-}++{- |++Module : Type.Spine.TH+Copyright : (c) The University of Kansas 2011+License : BSD3++Maintainer : nicolas.frisby@gmail.com+Stability : experimental+Portability : see LANGUAGE pragmas (... GHC)++Template Haskell in support of the spine-view on types.++-}+module Type.Spine.TH where++import Language.Haskell.TH+import Language.Haskell.TH.Syntax++++-- | A TemplateHaskell-lifter for 'NameG's.+liftNameG :: Name -> Q Exp+liftNameG n = do+ TyConI (DataD _ (Name occ (NameG _ pkg mod)) _ _ _) <- reify n+ [| mkNameG_tc $(stringE $ pkgString pkg) $(stringE $ modString mod) $(stringE $ occString occ) |]+++-- | Returns the kinds of a type constructor's type paratemers and range.+tyConSignature :: Name -> Q ([Kind], Kind)+tyConSignature n = do+ let bad = fail "Type.Spine.TH.tyConSignature expects the name of a data/newtype/data family"+ i <- reify n+ case i of+ TyConI dec -> case dec of+ DataD _ _ tvbs _ _ -> return (map tvb_kind tvbs, StarK)+ NewtypeD _ _ tvbs _ _ -> return (map tvb_kind tvbs, StarK)+ FamilyD DataFam _ tvbs mk -> return (map tvb_kind tvbs, maybe StarK (peel tvbs) mk)+ where peel [] k = k+ peel (_ : l) (ArrowK _ r) = peel l r+ peel _ _ = error "Type.Spine.TH: bad FamilyD kind"+ _ -> bad+ PrimTyConI _ i _ -> return (replicate i StarK, StarK)+ _ -> bad++tvb_kind :: TyVarBndr -> Kind+tvb_kind (PlainTV _) = StarK+tvb_kind (KindedTV _ k) = k
+ type-spine.cabal view
@@ -0,0 +1,31 @@+Name: type-spine+Version: 0.1+License: BSD3+License-File: LICENSE+Author: Nicolas Frisby <nicolas.frisby@gmail.com>+Maintainer: Nicolas Frisby <nicolas.frisby@gmail.com>++Category: Type System++Synopsis: A spine-view on types++Description: Until+ <http://research.microsoft.com/en-us/people/dimitris/fc-kind-poly.pdf>+ reaches the mainline, this is a surprisingly effective workaround. We support+ a limited number of kinds out-of-the-box, but it can be extended by the+ power-user. Also, quasiquotation makes the code rather legible. Given a+ finite set of kinds to support, generic type families can be defined that+ will work for an infinite number of types. It is very much a \"bumping up\"+ of the term-level /spine view/.+ .+ See the @type-cereal@ package for a use case.++Cabal-Version: >= 1.6.0.1++Build-Type: Simple+++Library+ Build-Depends: base >= 4 && < 5, template-haskell++ Exposed-Modules: Type.Spine, Type.Spine.Kinds, Type.Spine.Stage0, Type.Spine.TH