packages feed

th-instances 0.1.0.3 → 0.1.0.14

raw patch · 3 files changed

+262/−23 lines, 3 filesdep +derivedep +mtldep +th-kindsdep ~template-haskell

Dependencies added: derive, mtl, th-kinds, th-lift

Dependency ranges changed: template-haskell

Files

src/Language/Haskell/TH/Instances.hs view
@@ -1,56 +1,92 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} {- | A grab bag of useful instances for Template Haskell types -}-module Language.Haskell.TH.Instances where+module Language.Haskell.TH.Instances (+    module Language.Haskell.TH.Lift,+    module Language.Haskell.TH.LiftInstances,+    haskell_98_data_dec,+    type_arb, +    kind_arb,+    haskell_98_type_arb,+    primitive_types+) where      import Language.Haskell.TH+import Language.Haskell.TH.Lift+import Language.Haskell.TH.Syntax import Data.String import Test.QuickCheck import Control.Applicative import Test.QuickCheck.Instances.Char+import Control.Monad.Reader+import Data.List+import Language.Haskell.TH.LiftInstances+import Data.Char+import Data.DeriveTH +import qualified Language.Haskell.TH.Lift as L++clamp x y = if x < y+    then x+    else y+ instance IsString Name where     fromString x = mkName x      instance Arbitrary Name where-    arbitrary = mkName <$> arbitrary+    arbitrary = sized $ \x -> do+         c <- lowerAlpha+         mkName <$> (c:) <$> vectorOf (clamp 20 x) (oneof [numeric, lowerAlpha, upperAlpha])          arb_constructor_name = do      x <- upperAlpha-    xs <- listOf (oneof [numeric, lowerAlpha, upperAlpha])+    name_size <- choose (5, 20)+    xs <- sized (\x -> vectorOf name_size (oneof [numeric, lowerAlpha, upperAlpha]))     return $ mkName $ x:xs  instance Arbitrary Type where     arbitrary = sized type_arb-+    shrink (VarT _) = []+    shrink (ConT _) = []+    shrink (TupleT _) = []+    shrink (UnboxedTupleT _) = []+    shrink (ArrowT) = []+    shrink (ListT) = []+    shrink (ForallT x y z) = [ForallT x' y' z' | x' <- shrink x, y' <- shrink y, +                                                 z' <- shrink z]    +    shrink (SigT typ knd)  = [SigT t k | t <- shrink typ, k <- shrink knd]+    shrink (AppT x y)      = [x, y]+    +     type_arb :: Int -> Gen Type        type_arb depth = do-        let max_option = if depth > 0 then 8 else (5 :: Int)+        let new_depth = depth `div` 2+            max_option = if depth > 0 then 8 else 5 :: Int         typ <- choose (0, max_option)         case typ of-            0 -> VarT <$> mkName <$> listOf lowerAlpha+            0 -> VarT <$> mkName <$> vectorOf 20 lowerAlpha             1 -> ConT <$> arb_constructor_name             2 -> TupleT <$> arbitrary             3 -> UnboxedTupleT <$> arbitrary              4 -> return ArrowT             5 -> return ListT-            6 -> forallt_arb (depth - 1)-            7 -> SigT <$> type_arb (depth - 1) <*> arbitrary-            8 -> AppT <$> type_arb (depth - 1) <*> type_arb (depth - 1)+            6 -> ForallT <$> vectorOf (clamp 5 new_depth) (arb_ty_var_bndr (clamp 3 new_depth)) <*> +                             vectorOf (clamp 5 new_depth) (arb_pred        (clamp 3 new_depth)) <*> +                             type_arb new_depth+            7 -> SigT <$> type_arb new_depth <*> kind_arb new_depth+            8 -> AppT <$> type_arb new_depth <*> type_arb new_depth             ---this needs work but I have no use for it now-forallt_arb :: Int -> Gen Type-forallt_arb depth = do-    ForallT <$> (return []) <*> (return []) <*> (return $ VarT $ mkName "test")      instance Arbitrary Kind where     arbitrary = sized kind_arb  kind_arb :: Int -> Gen Kind        +kind_arb 0 = return StarK kind_arb depth = do-    let max_option = if depth > 0 then 1 else (2 :: Int)-    typ <- choose(0, max_option)+    typ <- choose(0, 1 :: Int)     case typ of          0 -> return StarK-        1 -> ArrowK <$> kind_arb (depth - 1) <*> kind_arb (depth - 1)+        1 -> ArrowK <$> kind_arb (depth `div` 2)+                    <*> kind_arb (depth `div` 2)      haskell_98_type_arb depth = do     let max_option = if depth > 0 then 6 else (5 :: Int)@@ -62,17 +98,164 @@         3 -> UnboxedTupleT <$> arbitrary          4 -> return ArrowT         5 -> return ListT-        6 -> AppT <$> haskell_98_type_arb (depth - 1) <*> haskell_98_type_arb (depth - 1)-        +        6 -> AppT <$> haskell_98_type_arb (depth `div` 2) +                  <*> haskell_98_type_arb (depth `div` 2)         +letter_strings =  map (\x -> mkName $ (x:[])) $ take 26 ['a'..] +instance Arbitrary Strict where+    arbitrary = oneof [return IsStrict, return NotStrict]++instance Arbitrary TyVarBndr where+    arbitrary = sized arb_ty_var_bndr where++arb_ty_var_bndr 0 = PlainTV <$> arbitrary+arb_ty_var_bndr size = do+    option <- arbitrary+    if option +        then PlainTV  <$> arbitrary +        else KindedTV <$> arbitrary <*> kind_arb (size `div` 2)         ++instance Arbitrary Pred where+    arbitrary = sized arb_pred where+++arb_pred 0 = return $ ClassP (mkName "test") [ConT $ mkName "test"]+arb_pred size = do+    option <- arbitrary+    if option +        then ClassP <$> arbitrary <*> vectorOf size (type_arb (size `div` 2))+        else EqualP <$> type_arb (size `div` 2) <*>  type_arb (size `div` 2)++instance Arbitrary Con where+    arbitrary = sized arb_con where++arb_con 0 = arb_con' 0 (2 :: Int)+arb_con size = arb_con' size 3+arb_con' size max_option = do+    option <- choose (0, max_option)+    case option of +        0 -> NormalC <$> arbitrary <*> arbitrary+        1 -> RecC <$> arbitrary <*> arbitrary+        2 -> InfixC <$> arbitrary <*> arbitrary <*> arbitrary+        3 -> ForallC <$> arbitrary <*> arbitrary <*> arb_con (size - 1) +--the right way to do this is probably to gen a simply typed environment +--and sample functions from it, and convert+--what I really need to do, is first I generate ++--name of data -> name of ty_var -> kind+--type KindEnv = [(Name, [(Name, Kind)])]++--look_up_kind env = undefined+--extend name kind = undefined++safe_prefix name =  map (replace_symbol . toLower) name++replace_symbol '[' = 'z'+replace_symbol ']' = 'q'+replace_symbol x = x++collect_kinded_tyvars :: Dec -> [TyVarBndr]+collect_kinded_tyvars (DataD _ _ tyvars _ _ ) = tyvars+collect_kinded_tyvars (NewtypeD _ _ tyvars _ _ ) = tyvars+ +prefix_ty_var :: Name -> TyVarBndr -> TyVarBndr+prefix_ty_var name (KindedTV ty_name kind) = KindedTV (mkName $ (safe_prefix $ nameBase name) ++ ("_") ++ (show ty_name)) kind++prefix_ty_vars :: Dec -> Dec+prefix_ty_vars (DataD x name tyvars z w ) = DataD x name (map (prefix_ty_var name) tyvars) z w+prefix_ty_vars (NewtypeD x name tyvars z w ) = NewtypeD x name (map (prefix_ty_var name) tyvars) z w++ty_var_kind :: TyVarBndr -> Kind+ty_var_kind (KindedTV _ kind) = kind++ty_var_name :: TyVarBndr -> Name+ty_var_name (KindedTV name _ ) = name+ty_var_name (PlainTV name) = name++set_ty_var_name :: Name -> TyVarBndr -> TyVarBndr+set_ty_var_name n (KindedTV _ k) = KindedTV n k++group_by_kind :: [TyVarBndr] -> [[TyVarBndr]]+group_by_kind tyvars = groupBy (\x y -> ty_var_kind x == ty_var_kind y ) tyvars++possibly_share :: Bool -> [TyVarBndr] -> [TyVarBndr]+--possibly_share True (x:xs) = result where+--    name   = ty_var_name x+--    new_xs = map (set_ty_var_name name) xs+--   result = x:xs+possibly_share _ x = x++possibly_make_plain :: Bool -> TyVarBndr -> TyVarBndr+possibly_make_plain _ (KindedTV n _) = PlainTV n+--possibly_make_plain _ x = x++dec_to_typ :: Dec -> Type+dec_to_typ (DataD _ name ty_vars _ _) = foldl' AppT (ConT name) $ map (VarT . ty_var_name) ty_vars+dec_to_typ (NewtypeD _ name ty_vars _ _) = foldl' AppT (ConT name) $ map (VarT . ty_var_name) ty_vars++--type KindContext = ReaderT KindEnv Gen++haskell_98_data_dec :: [Dec] -> Gen Dec+haskell_98_data_dec other_types = do+    --all of the dec must be explictly kinded!+    name <- arb_constructor_name+    ty_var_size <- choose (0, 10)+    typ_vars    <- vectorOf ty_var_size (elements letter_strings)+                  +    concre_size <- choose (0, 10)+    concre_typs <- vectorOf concre_size (elements other_types)+    +    let renamed_concre_decs = map prefix_ty_vars concre_typs+        renamed_concre_typs = map dec_to_typ renamed_concre_decs+        all_ty_var_bndrs    = nub $ concatMap collect_kinded_tyvars renamed_concre_decs+        grouped = group_by_kind all_ty_var_bndrs+    +    should_share <- vectorOf (length grouped) arbitrary         +    let shared  = concat $ zipWith possibly_share should_share grouped+    +    should_make_plain <- vectorOf (length shared) arbitrary +    let ty_var_bndrs  = zipWith possibly_make_plain should_make_plain shared+        typ_var_names = map ty_var_name ty_var_bndrs    +        var_types     = map VarT typ_var_names+    cons <- if length renamed_concre_typs > 0 +               then mapM arb_con_with_types =<< small_list_of (small_list_of $ elements (renamed_concre_typs))  -- ++ var_types+               else (:[]) <$> arb_con_with_types []+    index        <- choose(0, length cons - 1)     +    return $ DataD [] name ty_var_bndrs cons []      +arb_field_name = do+        x <- lowerAlpha+        name_size <- choose (10, 30)+        xs <- vectorOf name_size (oneof [numeric, lowerAlpha, upperAlpha])+        return $ mkName $ x:xs++arb_con_with_types :: [Type] -> Gen Con+arb_con_with_types xs = do+    name <- arb_constructor_name+    ss <- vectorOf (length xs) $ oneof [return IsStrict, return NotStrict]+    option <- choose (0, 1 :: Int)+    case option of+        0 -> return $ NormalC name $ zip ss xs+        1 -> do+             field_names <- vectorOf (length xs) arb_field_name+             let var_strict_types = zip3 field_names ss xs+             return $ RecC name var_strict_types+             +++primitive_types = $(L.lift =<< mapM explictly_kind [''Int, ''Bool, ''Char, ''Float, ''[]])     ++small_list_of elems = do+    size <- choose (0, 10)+    vectorOf size elems     +
+ src/Language/Haskell/TH/LiftInstances.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+{- | A grab bag of useful instances for Template Haskell types -}+module Language.Haskell.TH.LiftInstances where+    +import qualified Language.Haskell.TH.Lift as L+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+--import Language.Haskell.TH.LambdaConvert+import Language.Haskell.TH.KindInference++$(L.deriveLiftMany [''Match, ''Range, ''Stmt, ''Strict,+                  ''InlineSpec,+                  ''Safety,+                  ''Callconv,+                  ''Guard,+                  ''Lit,+                  ''Exp, ''FixityDirection, ''Clause, ''Pat,+                  ''Body, ''FunDep, ''Foreign,+                  ''Pragma, ''FamFlavour, ''TyVarBndr,+                  ''Kind, ''Pred, ''Con, +                  ''Dec, ''ClassInstance, ''Type, ''Fixity, ''Info])+                  +un_ty_con (TyConI x) = x++explictly_kind name = do+    Right kind      <- inferKind name+    TyConI data_dec <- reify name+    return $ convert_ty_vars data_dec kind+    +    +convert_ty_vars :: Dec -> Kind -> Dec+convert_ty_vars (DataD x y ty_vars z w) kind    = DataD x y (replace_ty_vars ty_vars kind) z w+convert_ty_vars (NewtypeD x y ty_vars z w) kind = NewtypeD x y (replace_ty_vars ty_vars kind) z w+ +replace_ty_vars ty_vars kind = result where+    kinds = unfold_kinds kind (length ty_vars)+    result = zipWith add_kind ty_vars kinds+    +unfold_kinds x y = unfold_kinds' x y []+    +unfold_kinds' _ 0        accum = accum+unfold_kinds' (ArrowK x y) i accum = unfold_kinds' y (i - 1) (x:accum)++add_kind (PlainTV n) k = KindedTV n k+add_kind x k = x+
th-instances.cabal view
@@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version:             0.1.0.3+Version:             0.1.0.14  -- A short (one-line) description of the package. Synopsis: A place to collect orphan instances for Template Haskell@@ -46,13 +46,17 @@ Library   Hs-Source-Dirs: src   -- Modules exported by the library.-  Exposed-modules: Language.Haskell.TH.Instances+  Exposed-modules: Language.Haskell.TH.Instances, Language.Haskell.TH.LiftInstances      -- Packages needed in order to build this package.   Build-depends: base > 4.0.0 && <= 5.0,                  template-haskell >= 2.6.0,                  QuickCheck >= 2.4.1.1,-                 checkers >= 0.2.8+                 checkers >= 0.2.8,+                 th-lift >= 0.5.4,+                 th-kinds >= 0.1.1,+                 mtl >= 2.0.1.0,+                 derive >= 2.5.4   ghc-options:            -Wall     Test-Suite tests@@ -64,5 +68,11 @@                  test-framework-quickcheck2 >= 0.2.10,                  test-framework-hunit >= 0.2.7,                  test-framework >= 0.4.1.1,-                 HUnit >= 1.2.4.2-  +                 HUnit >= 1.2.4.2,+                 QuickCheck >= 2.4.1.1,+                 th-lift >= 0.5.4,+                 th-kinds >= 0.1.1,+                 mtl >= 2.0.1.0,+                 template-haskell >= 2.6.0,+                 checkers >= 0.2.8,+                 derive >= 2.5.4