Skip to content
Browse files

add default th

  • Loading branch information...
1 parent 2846a58 commit 1b2d04523dccbda538e6af8affc8a6aa7546cee2 @nfjinjing committed
Showing with 92 additions and 6 deletions.
  1. +6 −1 Nemesis
  2. +4 −2 air.cabal
  3. +6 −2 src/Air/TH.hs
  4. +18 −0 src/Air/TH/Air.hs
  5. +37 −0 src/Air/TH/Default.hs
  6. +3 −1 src/Air/{Here/TH.hs → TH/Here.hs}
  7. +18 −0 src/Test.hs
View
7 Nemesis
@@ -14,7 +14,12 @@ nemesis = do
desc "run shell"
task "i" - do
- sh "ghci -isrc src/Air.hs"
+ sh "ghci -isrc -XTemplateHaskell src/Air.hs"
+
+ desc "run test shell"
+ task "t" - do
+ sh "ghci -isrc -XTemplateHaskell -ddump-splices src/Test.hs"
+
desc "put all .hs files in manifest"
task "manifest" - do
View
6 air.cabal
@@ -1,5 +1,5 @@
Name: air
-Version: 2011.6.12
+Version: 2011.6.18
Build-type: Simple
Synopsis: air
Description: An alternative Haskell Prelude library.
@@ -35,7 +35,9 @@ library
Air
, Air.Light
, Air.Env
- , Air.Here.TH
+ , Air.TH.Here
+ , Air.TH.Default
+ , Air.TH.Air
, Air.TH
, Air.Control.Monad.ListBuilder
, Air.Control.Monad.ObjectBuilder
View
8 src/Air/TH.hs
@@ -1,8 +1,12 @@
module Air.TH (
module Air.Data.Record.SimpleLabel
- , module Air.Here.TH
+ , module Air.TH.Here
+ , module Air.TH.Default
+ , module Air.TH.Air
) where
import Air.Data.Record.SimpleLabel
-import Air.Here.TH
+import Air.TH.Here
+import Air.TH.Default
+import Air.TH.Air
View
18 src/Air/TH/Air.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Air.TH.Air where
+
+import Language.Haskell.TH
+import Control.Monad (replicateM)
+
+
+{-
+> $(tuple 3) [1,2,3,4,5]
+ (1,2,3)
+ > $(tuple 2) [1,2]
+ (1,2)
+-}
+tuple :: Int -> ExpQ
+tuple n = do
+ ns <- replicateM n (newName "x")
+ lamE [foldr (\x y -> conP '(:) [varP x,y]) wildP ns] (tupE $ map varE ns)
View
37 src/Air/TH/Default.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Air.TH.Default where
+
+import Language.Haskell.TH
+import Data.Default
+
+
+-- $(reify ''Dummy >>= show > stringE)
+-- "TyConI (DataD [] Main.Dummy [] [RecC Main.Dummy [(Main.test_field_1,NotStrict,ConT GHC.Base.String),(Main.test_field_2,NotStrict,ConT GHC.Integer.Type.Integer)]] [])"
+
+-- runQ [d| instance Default Dummy where def = Dummy def def |]
+-- [InstanceD [] (AppT (ConT Data.Default.Default) (ConT Main.Dummy)) [ValD (VarP def) (NormalB (AppE (AppE (ConE Main.Dummy) (VarE def)) (VarE def))) []]]
+
+-- runQ [d| instance Default Dummy where def = Dummy {test_field_1 = def, test_field_2 = def} |]
+-- [InstanceD [] (AppT (ConT Data.Default.Default) (ConT Main.Dummy)) [ValD (VarP def) (NormalB (RecConE Main.Dummy [(Main.test_field_1,VarE def),(Main.test_field_2,VarE def)])) []]]
+
+
+mkDefault :: Name -> Q [Dec]
+mkDefault name = do
+ info <- reify name
+ case info of
+ TyConI x -> do
+ case x of
+ (DataD _ data_name _ recs _) -> do
+ case recs of
+ [] -> error $ "no phontom type"
+ (RecC record_name fields):_ -> do
+ let def_name = mkName "def"
+ let def_fields = map (\(field_name, _, _) -> (field_name, VarE def_name)) fields
+ return $ return $
+ InstanceD []
+ (AppT (ConT ''Default) (ConT data_name))
+ [ValD (VarP def_name) (NormalB (RecConE record_name def_fields)) []]
+ NewtypeD _ _ _ _ _ -> error "Newtypes are not supported"
+ _ -> error $ "Unknown declaration type"
+ _ -> error "Only datatypes can be processed"
View
4 src/Air/Here/TH.hs → src/Air/TH/Here.hs
@@ -1,6 +1,6 @@
-- {-# LANGUAGE CPP #-}
-module Air.Here.TH where
+module Air.TH.Here where
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
@@ -14,3 +14,5 @@ here =
quoteExp = litE . stringL
, quotePat = litP . stringL
}
+
+
View
18 src/Test.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+
+import Language.Haskell.TH
+import Air.Env
+import Air.TH
+import Prelude ()
+import Data.Default
+
+data Dummy = Dummy
+ {
+ test_field_1 :: String
+ , test_field_2 :: Integer
+ }
+ deriving (Show)
+
+mkDefault ''Dummy
+

0 comments on commit 1b2d045

Please sign in to comment.
Something went wrong with that request. Please try again.