Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Use more robust method for getting constructors from a Name

  • Loading branch information...
commit 536a37c74f76af3532a000b3d407524b430445c4 1 parent dee723a
@mightybyte mightybyte authored
Showing with 56 additions and 24 deletions.
  1. +18 −13 src/Snap/Restful.hs
  2. +38 −11 src/Snap/Restful/TH.hs
View
31 src/Snap/Restful.hs
@@ -434,6 +434,8 @@ iPrimText t = [X.TextNode t]
iPrimShow :: Show a => a -> [X.Node]
iPrimShow = iPrimText . T.pack . show
+cPrimShow x = Build.fromString $ show x
+
instance PrimSplice String where
iPrimSplice x = iPrimText $ T.pack x
cPrimSplice x = Build.fromText $ T.pack x
@@ -442,49 +444,52 @@ instance PrimSplice Text where
cPrimSplice x = Build.fromText x
instance PrimSplice Int where
iPrimSplice x = iPrimShow x
- cPrimSplice x = Build.fromText $ T.pack $ show x
+ cPrimSplice = cPrimShow
instance PrimSplice Integer where
iPrimSplice x = iPrimShow x
- cPrimSplice x = Build.fromText $ T.pack $ show x
+ cPrimSplice = cPrimShow
instance PrimSplice Float where
iPrimSplice x = iPrimShow x
- cPrimSplice x = Build.fromText $ T.pack $ show x
+ cPrimSplice = cPrimShow
instance PrimSplice Double where
iPrimSplice x = iPrimShow x
- cPrimSplice x = Build.fromText $ T.pack $ show x
+ cPrimSplice = cPrimShow
instance PrimSplice Bool where
iPrimSplice x = iPrimShow x
- cPrimSplice x = Build.fromText $ T.pack $ show x
+ cPrimSplice = cPrimShow
instance PrimSplice Int8 where
iPrimSplice x = iPrimShow x
- cPrimSplice x = Build.fromText $ T.pack $ show x
+ cPrimSplice = cPrimShow
instance PrimSplice Int16 where
iPrimSplice x = iPrimShow x
- cPrimSplice x = Build.fromText $ T.pack $ show x
+ cPrimSplice = cPrimShow
instance PrimSplice Int32 where
iPrimSplice x = iPrimShow x
- cPrimSplice x = Build.fromText $ T.pack $ show x
+ cPrimSplice = cPrimShow
instance PrimSplice Int64 where
iPrimSplice x = iPrimShow x
- cPrimSplice x = Build.fromText $ T.pack $ show x
+ cPrimSplice = cPrimShow
instance PrimSplice Word8 where
iPrimSplice x = iPrimShow x
- cPrimSplice x = Build.fromText $ T.pack $ show x
+ cPrimSplice = cPrimShow
instance PrimSplice Word16 where
iPrimSplice x = iPrimShow x
- cPrimSplice x = Build.fromText $ T.pack $ show x
+ cPrimSplice = cPrimShow
instance PrimSplice Word32 where
iPrimSplice x = iPrimShow x
- cPrimSplice x = Build.fromText $ T.pack $ show x
+ cPrimSplice = cPrimShow
instance PrimSplice Word64 where
iPrimSplice x = iPrimShow x
- cPrimSplice x = Build.fromText $ T.pack $ show x
+ cPrimSplice = cPrimShow
instance PrimSplice Day where
iPrimSplice = iPrimSplice . dayText
cPrimSplice = cPrimSplice . dayText
+instance PrimSplice UTCTime where
+ iPrimSplice = iPrimShow
+ cPrimSplice = cPrimShow
instance PrimSplice a => PrimSplice (Maybe a) where
iPrimSplice Nothing = iPrimText ""
View
49 src/Snap/Restful/TH.hs
@@ -20,12 +20,39 @@ import Text.Digestive
------------------------------------------------------------------------------
+-- | Gets a list of constructors for a Name.
+nameCons :: Name -> Q [Con]
+nameCons n = do
+ info <- reify n
+ case info of
+ TyConI dec -> decCons dec
+ _ -> return []
+
+
+------------------------------------------------------------------------------
+-- | Gets a list of constructors for a Dec.
+decCons :: Dec -> Q [Con]
+decCons (DataD _ _ _ cons _) = return cons
+decCons (NewtypeD _ _ _ con _) = return [con]
+decCons (TySynD _ _ t) = typeCons t
+decCons _ = return []
+
+
+------------------------------------------------------------------------------
+-- | Gets a list of constructors for a Type.
+typeCons :: Type -> Q [Con]
+typeCons (AppT a _) = typeCons a
+typeCons (ConT n) = nameCons n
+typeCons _ = return []
+
+
+------------------------------------------------------------------------------
-- | Derives a HasFormlet instance for a data type.
deriveHasFormlet :: Name -> Q [Dec]
deriveHasFormlet n = do
- info <- reify n
- case info of
- (TyConI (DataD _ typeName _ [RecC conName fields] names)) -> do
+ cons <- nameCons n
+ case cons of
+ [RecC conName fields] -> do
defName <- newName "d"
let fieldFormlet (fn,_,_) = do
let name = litE $ StringL $ nameBase fn
@@ -48,12 +75,12 @@ deriveHasFormlet n = do
-- > fooSplices = $(iSplices ''Foo)
iSplices :: Name -> Q Exp
iSplices n = do
- info <- reify n
- case info of
- (TyConI (DataD _ typeName _ [RecC conName fields] names)) -> do
+ cons <- nameCons n
+ case cons of
+ [RecC conName fields] -> do
let fieldToTuple (fn,_,_) = do
f <- [| iPrimSplice . $(varE fn) |]
- return $ TupE [LitE $ StringL $ nameBase conName ++ ":" ++ nameBase fn,f]
+ return $ TupE [LitE $ StringL $ nameBase fn, f]
fs <- mapM fieldToTuple fields
return $ ListE fs
_ -> error "You can only generate splices for a data type with a single constructor and named record fields"
@@ -68,12 +95,12 @@ iSplices n = do
-- > fooSplices = $(cSplices ''Foo)
cSplices :: Name -> Q Exp
cSplices n = do
- info <- reify n
- case info of
- (TyConI (DataD _ typeName _ [RecC conName fields] names)) -> do
+ cons <- nameCons n
+ case cons of
+ [RecC conName fields] -> do
let fieldToTuple (fn,_,_) = do
f <- [| cPrimSplice . $(varE fn) |]
- return $ TupE [LitE $ StringL $ nameBase conName ++ ":" ++ nameBase fn,f]
+ return $ TupE [LitE $ StringL $ nameBase fn, f]
fs <- mapM fieldToTuple fields
return $ ListE fs
_ -> error "You can only generate splices for a data type with a single constructor and named record fields"
Please sign in to comment.
Something went wrong with that request. Please try again.