tagged-th (empty) → 0.1

raw patch · 5 files changed

+173/−0 lines, 5 filesdep +basedep +taggeddep +template-haskellsetup-changed

Dependencies added: base, tagged, template-haskell, type-spine

Files

• Data/Proxy/TH.hs +53/−0
• Data/Proxy/TH/Aux.hs +89/−0
• LICENSE +1/−0
• Setup.hs +2/−0
• tagged-th.cabal +28/−0

@@ -0,0 +1,53 @@+{-# LANGUAGE TemplateHaskell, KindSignatures, ViewPatterns, EmptyDataDecls #-}++{- |++Module      :  Data.Proxy.TH+Copyright   :  (c) The University of Kansas 2011+License     :  BSD3++Maintainer  :  nicolas.frisby@gmail.com+Stability   :  experimental+Portability :  see LANGUAGE pragmas (... GHC)++Quasiquoter and TH-splice generator for proxies using @type-spine@'s @k -> *@+kind wrappers.++-}+module Data.Proxy.TH (module Data.Proxy.TH, Proxy(..)) where++import Data.Proxy.TH.Aux++import Type.Spine.Stage0 (kTypeG)++import Language.Haskell.TH+import Language.Haskell.TH.Quote++import Data.Proxy+++++qProxy :: QuasiQuoter+qProxy = QuasiQuoter (\s -> [| Proxy :: $(typ s) |])+                     pat typ (error "Data.Proxy.TH.qProxy Dec") where+  typ s = do+    (i, k) <- parseProxy_ s+    let holder = kTypeG k+    [t| Proxy ($holder $(return i)) |]+  pat s = viewP [| id :: $(typ s) -> $(typ s) |] (conP 'Proxy [])++thProxyT :: Type -> Q Type+thProxyT ty@(unAppT -> (ConT n, length -> k)) = do+  i <- reify n+  (drop k -> ks) <- case i of+    TyConI (DataD _ _ tvbs _ _) -> return $ map tvb_kind tvbs+    TyConI (NewtypeD _ _ tvbs _ _) -> return $ map tvb_kind tvbs+    PrimTyConI _ args _ -> return (replicate args StarK)+    _ -> thProxyT_fail $ Just n+  let holder = kTypeG $ foldr ArrowK StarK ks+  [t| Proxy ($holder $(return ty)) |]+thProxyT _ = thProxyT_fail Nothing++thProxy :: Type -> Q Exp+thProxy ty = [| Proxy :: $(thProxyT ty) |]

@@ -0,0 +1,89 @@+{-# LANGUAGE ViewPatterns #-}++{- |++Module      :  Data.Proxy.TH.Aux+Copyright   :  (c) The University of Kansas 2011+License     :  BSD3++Maintainer  :  nicolas.frisby@gmail.com+Stability   :  experimental+Portability :  see LANGUAGE pragmas (... GHC)++A parser for simple type expressions, including kinds and excluding operators.++-}+module Data.Proxy.TH.Aux where++import Language.Haskell.TH++import Type.Spine.Kinds (trim, parseK)++import qualified Control.Arrow as Arrow+import Control.Monad (liftM, when, MonadPlus(..))++import Data.Char (isLower, isUpper)++instance MonadPlus Q where mzero = fail "mzero"; mplus = flip recover++tvb_kind (PlainTV _) = StarK+tvb_kind (KindedTV _ k) = k++unAppT (AppT f x) = Arrow.second (++ [x]) $ unAppT f+unAppT ty = (ty, [])++++occT n@(nameBase -> (c : _)) | startsIdent c = VarT n+                             | otherwise = ConT n+occT _ = error "occT needs a non-empty name"++--------------------+startsIdent c = isLower c || '_' == c++startsName c = isUpper c || startsIdent c++parseIdent :: MonadPlus m => String -> m ([Type], String)+parseIdent s = do+  s <- return $ trim s+  (i, s) <- return $+    break (`notElem` "_'" ++ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']) s+  when (null i) $ fail $ "no identifier: `" ++ s ++ "'"+  return $ ([occT $ mkName i], s)++parseParen s = ($ s) $ parseParen' . trim+parseParen' ('(' : s) = do+  (ty, trim -> s) <- parseType s+  case s of+    ')' : s -> return ([foldl1 AppT ty], s)+    _ -> fail $ "expecting `)': " ++ s+parseParen' s = fail $ "expecting `(': " ++ s++parseType s = do+  (ty, s) <- parseIdent s `mplus` parseParen s+  x <- (Just `liftM` parseType s) `mplus` return Nothing+  return $ maybe (ty, s) (Arrow.first (foldl1 AppT ty :)) x++parseProxy_ :: MonadPlus m => String -> m (Type, Kind)+parseProxy_ s = parseProxy s >>= \(x, s) -> case trim s of+  "" -> return x+  _ -> fail $ "Data.Proxy.TH.Aux.parseProxy_: " ++ s++parseProxy :: MonadPlus m => String -> m ((Type, Kind), String)+parseProxy = w . trim where+  w s@((startsName -> True) : _) = do+    (foldl1 AppT -> ty, s) <- parseType s+    case trim s of+      ':' : ':' : s -> do+        (k, s) <- parseK s+        return ((ty, k), s)+      _ -> return ((ty, StarK), s)+  w s = fail $ "Data.Proxy.TH.Aux.parseProxy: " ++ s++++--------------------+thProxyT_fail :: Maybe Name -> Q a+thProxyT_fail n = fail $ "thProxyT handles only applications of data/newtype and primitive type constructors" ++ case n of+  Just n -> "; " ++ show n ++ " is unsupported"+  Nothing -> ""

@@ -0,0 +1,1 @@+BSD3

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

@@ -0,0 +1,28 @@+name: tagged-th+version: 0.1++build-type: Simple++category: Template Haskell, Phantom Types++author: Nicolas Frisby <nicolas.frisby@gmail.com>+maintainer: Nicolas Frisby <nicolas.frisby@gmail.com>++stability: experimental++synopsis: QuasiQuoter and Template Haskell splices for creating proxies at higher-kinds++description: QuasiQuoter and Template Haskell splices for creating proxies at+  higher-kinds (via @type-spine@'s @k -> *@ kind wrappers)++license: BSD3+license-file: LICENSE++cabal-version: >= 1.6.0.1++library+  build-depends: base >= 4 && < 5, template-haskell+  build-depends: tagged >= 0.2 && < 0.3+  build-depends: type-spine < 0.2++  exposed-modules: Data.Proxy.TH, Data.Proxy.TH.Aux