packages feed

gdiff-th 0.0.0.1 → 0.1.0.0

raw patch · 13 files changed

+753/−360 lines, 13 filesdep +containersdep +lensdep +pointless-haskelldep ~gdiffdep ~mtldep ~template-haskell

Dependencies added: containers, lens, pointless-haskell, th-expand-syns

Dependency ranges changed: gdiff, mtl, template-haskell, uniplate

Files

+ examples/CompareVersions.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeSynonymInstances, FlexibleContexts,+ GADTs, ExistentialQuantification, MultiParamTypeClasses, FlexibleInstances #-}+module Main where+import Language.Haskell.Exts (parseFile, Module, ParseResult(..), fromParseResult)+import Data.Generic.Diff.TH+import Data.Generic.Diff +import Control.Applicative+import Utils++makeGDiff ''Module++diffModule :: (Type ModuleFamily Module) +        => Module -> Module -> EditScript ModuleFamily Module Module+diffModule = diff++main = do +    old <- fromParseResult <$> parseFile "examples/Old.hs"+    new <- fromParseResult <$> parseFile "examples/New.hs"+    showCompressed $ diffModule old new++        +
+ examples/Expr.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE NoMonomorphismRestriction, GADTs, FlexibleContexts,+    TemplateHaskell, LiberalTypeSynonyms, MultiParamTypeClasses,+    DeriveDataTypeable #-}+module Expr where+import Text.Parsec hiding ((<+>), string)+import qualified Text.Parsec as P    +import qualified Text.Parsec.Token as P+import qualified Text.Parsec.Language as P+import Control.Applicative ((<$>))+import Data.Generic.Diff.TH+import Data.Generic.Diff   -- (EditScript(..), diff, Type, compress)+import System.Console.Terminfo.Color+import Text.PrettyPrint.Free hiding (parens)+import System.Console.Terminfo.Base+import System.Console.Terminfo.PrettyPrint+import Test.Feat+import Data.Typeable+import Utils++-- A simple Expression++data Exp = Exp :+: Exp+         | Exp :*: Exp+         | B Integer+         deriving(Show, Eq, Typeable)+         +makeGDiff ''Exp+         +-- Two examples using the num hack    +testA :: Exp+testA = foldl1 (:+:) . map B $ [0..20]++testB :: Exp+testB = foldl1 (:+:) . map B $ [0..8] ++ [42] ++ [10..20]   +    +-- For some reason I seem to need to do this to help out type inference+diffExp :: (Type ExpFamily Exp) +        => Exp -> Exp -> EditScript ExpFamily Exp Exp+diffExp = diff++diffAandB = showCompressed $ diffExp testA testB  ++main = diffAandB       +         +-- Now a more practical example
+ examples/New.hs view
@@ -0,0 +1,21 @@+module New where++data Song = Song {+        instruments :: [Instruments],+        name        :: String+    }+    deriving(Show, Eq)++data Instrument = Instrument {+        notes :: [Note],+        typ   :: InstrumentType+    }+    deriving(Show, Eq)+    +newtype Note = Note { unNote :: (Double, Model) }+    deriving(Show, Eq)++data Model = Exp Model Model+           | ADSR Model Model Model Model+           | Base Double+               deriving(Show, Eq)
+ examples/Old.hs view
@@ -0,0 +1,15 @@+module Old where++data Song = Song {+        instruments :: [Instruments]+    }++data Instrument = Instrument {+        notes :: [Note]+    }+    +type Note = (Double, Model)++data Model = Exp Model Model+           | ADSR Model Model Model Model+           | Base Double
+ examples/Parser.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE NoMonomorphismRestriction, GADTs, FlexibleContexts,+    TemplateHaskell, LiberalTypeSynonyms, MultiParamTypeClasses,+    DeriveDataTypeable #-}+module Parser where+import Expr+import Text.Parsec hiding ((<+>), string)+import qualified Text.Parsec as P    +import qualified Text.Parsec.Token as P+import qualified Text.Parsec.Language as P+import Control.Applicative ((<$>))+import Data.Generic.Diff.TH+import Data.Generic.Diff   -- (EditScript(..), diff, Type, compress)+import System.Console.Terminfo.Color+import Text.PrettyPrint.Free hiding (parens)+import System.Console.Terminfo.Base+import System.Console.Terminfo.PrettyPrint+import Test.Feat+import Data.Typeable+import Utils+         +--Pretty printer+ppr :: Exp -> String+ppr e = case e of+   x :+: y -> ppr x ++ " + " ++ ppr y+   x :*: y -> ppr x ++ " * " ++ ppr y+   B x     -> show x++-- parser    +badParser :: String -> Either ParseError Exp                     +badParser x = runParser pExp () "" x where+    pExp = foldl chainr1 (parens pExp <|> pInt) $ +                    map binOp [("+", (:+:)), ("*", (:*:))] ++    binOp (x, rest) = do+        spaces+        P.string x+        spaces+        return rest++    pInt = B <$> P.integer P.haskell++    parens = P.parens P.haskell+   +deriveEnumerable ''Exp ++-- A very important variant that will fail+pprToParseRoundTrip :: Exp -> Bool+pprToParseRoundTrip x = either (const False) (x ==) $ (badParser . ppr) x++checkParser = featCheck 12 pprToParseRoundTrip++-- A convienent hack for readablility       +instance Num Exp where+    (+) = (:+:)+    (*) = (:*:)+    fromInteger = B+    abs    = undefined+    signum = undefined++badParserBug = (*) ((*) 0 0) 0++fromRight' (Right x) = x++badParserDiff = showEdits $ diffExp badParserBug (fromRight' . badParser . ppr $ badParserBug) ++-- the fixed parser +goodParser :: String -> Either ParseError Exp                     +goodParser x = runParser pExp () "" x where+    pExp = foldl chainl1 (parens pExp <|> pInt) $ +                    map binOp [("+", (:+:)), ("*", (:*:))] ++    binOp (x, rest) = do+        spaces+        P.string x+        spaces+        return rest++    pInt = B <$> P.integer P.haskell++    parens = P.parens P.haskell+++++
+ examples/Utils.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE GADTs, KindSignatures, RankNTypes #-}+module Utils where+import Data.Generic.Diff   -- (EditScript(..), diff, Type, compress)+import System.Console.Terminfo.Color+import Text.PrettyPrint.Free hiding (parens)+import System.Console.Terminfo.PrettyPrint++showEdits :: forall (f :: * -> * -> *) txs tys.+                   EditScriptL f txs tys -> IO ()+showEdits      = display . pprEdits ++showCompressed :: Family f => EditScriptL f txs tys -> IO ()+showCompressed = display . pprEdits . compress++pprEdits :: EditScriptL f txs tys -> TermDoc+pprEdits x = case x of +    Cpy c d   -> (text $ string c) <+> pprEdits d+    CpyTree d -> text " ... "      <+> pprEdits d+    Del c d   -> (with (Foreground Red)   . text $ "- " ++ string c) <+> pprEdits d+    Ins c d   -> (with (Foreground Green) . text $ "+ " ++ string c) <+> pprEdits d+    End       -> line
gdiff-th.cabal view
@@ -7,12 +7,24 @@ -- 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.0.0.1+Version:             0.1.0.0  -- A short (one-line) description of the package. Synopsis:            Generate gdiff GADTs and Instances. -- A longer description of the package.-Description:  Generate gdiff GADTs and Instances. Very Alpha. Does not yet support GADTs among other this I'm sure.       +Description:  +    Generate gdiff GADTs and Instances. Alpha, but suprisingly functional. +    Very useful for unit testing large data structures. I have tested it on a +    few very large collections of types and it appears to work. Although, +    when I tried to compare two versions of a hackage package with src-exts +    the (GDiff) performance is terrible. In my personal experience of using+    gdiff in unit testing, the performance has be great. Your mileage may vary.+    .+    I wouldn't use it for sending patches over the wire or anything like that, +    I am not convinced there are no bugs in my code yet. There are examples in the @examples@ directory of the +    cabal tarball. Also the main module includes an example in the documentation.+    .    +    * New in this version: It's functional.  -- The license under which the package is released. License:             BSD3@@ -21,14 +33,14 @@ License-file:        LICENSE  -- The package author(s).--- Author:              +-- Author:  Jonathan Fischoff              -- An email address to which users can send suggestions, bug reports, -- and patches. Maintainer:          jonathangfischoff@gmail.com  -- A copyright notice.--- Copyright:           +-- Copyright: Copyright 2012 Jonathan Fischoff             Category:            Generics @@ -36,7 +48,12 @@  -- Extra files to be distributed with the package, such as examples or -- a README.--- Extra-source-files:  +Extra-source-files: examples/Expr.hs+                    examples/New.hs+                    examples/Old.hs+                    examples/CompareVersions.hs+                    examples/Parser.hs+                    examples/Utils.hs  -- Constraint on the version of Cabal needed to build this package. Cabal-version:       >=1.8@@ -48,16 +65,22 @@   -- Modules exported by the library.   Exposed-modules: Data.Generic.Diff.TH   +  Other-modules: Data.Generic.Diff.TH.Conversion, +                 Data.Generic.Diff.TH.Internal,+                 Data.Generic.Diff.TH.Types+                 Data.Generic.Diff.TH.Specialize+     -- Packages needed in order to build this package.   Build-depends: base >= 4.0 && <= 6.0,-                 template-haskell >= 2.6.0.0,-                 uniplate >= 1.6.5,-                 tuple >= 0.2.0.1,-                 mtl >= 2.0.1.0,-                 specialize-th >= 0.0.0.8,-                 universe-th >= 0.0.0.6,-                 type-sub-th >= 0.1.0.5,-                 gdiff >= 1.0+                 template-haskell == 2.8.*,+                 gdiff == 1.0.*,+                 th-expand-syns == 0.3.*,+                 uniplate == 1.6.*,+                 lens == 3.0.*,+                 pointless-haskell == 0.0.*,+                 containers == 0.5.*,+                 mtl == 2.1.*,+                 th-expand-syns == 0.3.*                                       ghc-options:            -Wall@@ -66,15 +89,13 @@     Hs-Source-Dirs: src, tests     type:       exitcode-stdio-1.0     main-is:    Main.hs-    build-depends: base >= 4.0 && <= 6.0,-                 template-haskell >= 2.6.0.0,+    build-depends:                   DebugTraceHelpers >= 0.12,                  QuickCheck >= 2.4.1.1,                  HUnit >= 1.2.4.2,                  test-framework-quickcheck2 >= 0.2.10,                  test-framework-hunit >= 0.2.7,                  test-framework >= 0.4.1.1,-                 uniplate >= 1.6.5,                  checkers >= 0.2.8,                  mtl >= 2.0.1.0,                  th-instances >= 0.1.0.14,@@ -82,5 +103,7 @@                  universe-th >= 0.0.0.6,                  type-sub-th >= 0.1.0.5,                  gdiff >= 1.0,-                 tuple >= 0.2.0.1-  +                 tuple >= 0.2.0.1,+                 pointless-haskell == 0.0.*,+                 containers == 0.5.*+
src/Data/Generic/Diff/TH.hs view
@@ -1,343 +1,66 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, QuasiQuotes, GADTs,-    FlexibleContexts, FlexibleInstances, NoMonomorphismRestriction, GeneralizedNewtypeDeriving #-}+-- | This module exports the Template Haskell functions necessary +--   deriving gdiff GADTs and associated instances. Usage is pretty +--   straightforward.+--+-- @+--module Example where+--import "Data.Generic.Diff"  +--import "Data.Generic.Diff.TH"  +--import "System.Console.Terminfo.Color"+--import "Text.PrettyPrint.Free hiding (parens)"+--import "System.Console.Terminfo.PrettyPrint"+--    +--data Exp = Exp :+: Exp+--         | Exp :*: Exp+--         | B Integer+--         deriving(Show, Eq, Typeable)+--+--{- Make the GDiff apparatus -}+--makeGDiff ''Exp+--  +--testA :: Exp+--testA = foldl1 (:+:) . map B $ [0..20]+--+--testB :: Exp+--testB = foldl1 (:+:) . map B $ [0..8] ++ [42] ++ [10..20]+--+--{- Make a type signature to help inference -}+--diffExp :: Type ExpFamily Exp => Exp -> Exp -> EditScript ExpFamily Exp Exp+--diffExp = diff+--+--diffAandB = showCompressed $ diffExp testA testB  +--+--main = diffAandB+--+--{- Utility functions to show colored diffs -}+--showEdits :: forall (f :: * -> * -> *) txs tys.+--                   EditScriptL f txs tys -> IO ()+--showEdits      = display . pprEdits +--+--showCompressed :: Family f => EditScriptL f txs tys -> IO ()+--showCompressed = display . pprEdits . compress+--+--pprEdits :: EditScriptL f txs tys -> TermDoc+--pprEdits x = case x of +--    Cpy c d   -> (text $ string c) <+> pprEdits d+--    CpyTree d -> text \" ... \"      <+> pprEdits d+--    Del c d   -> (with (Foreground Red)   . text $ \"- \" ++ string c) <+> pprEdits d+--    Ins c d   -> (with (Foreground Green) . text $ \"+ \" ++ string c) <+> pprEdits d+--    End       -> line+-- @+--+--  Running the main function above would result in the following output+-- @+--:+: :+: :+: :+: :+: :+: :+: :+: :+: :+: :+: :+:  ...  B + 42 - 9  ...   ...   ...   ...   ...   ...   ...   ...   ...   ...   ...  +-- @+--  Except with pretty colors :). module Data.Generic.Diff.TH (-    -- ** Main Interface-    make_family_gadt, -    -- ** Utils-    collect_type_args) where-import Language.Haskell.TH-import Control.Applicative-import Data.List-import Control.Monad-import Data.Generic.Diff ((:=:) (..), Nil (..), Cons (..))--- import Language.Haskell.TH.ExpandSyns-import Language.Haskell.TH.TypeSub-import Language.Haskell.TH.Universe-import Language.Haskell.TH.Specialize (expand_and_specialize, expand_and_specialize_syns)-import Data.Tuple.Select-import Control.Monad.Error-import Control.Monad.State-import Control.Monad.Reader--collect_type_args :: Type -> [Type]-collect_type_args (AppT x y) = x:(collect_type_args y)-collect_type_args x          = [x]--run_state x xs = runReaderT (runErrorT (runErrorStateT x)) xs--type ERType m e r a = ErrorT e (ReaderT r m) a--newtype ERT e r m a = ERT { runErrorStateT :: ERType m e r a }-    deriving (Monad, MonadError e, Functor, MonadPlus, MonadReader r)-    -instance MonadTrans (ERT String [Dec]) where-    lift = ERT . lift . lift --type DecState = ERT String [Dec] Q------------------------------------------------------------mk_specialized_universe :: Name -> Q [Dec]-mk_specialized_universe name = do -    first_universe       <- (map snd . filter ((/=name) . fst)) <$> get_universe name-    specialized_universe <- expand_and_specialize name name-    let combined_universe = map snd $ sub_universe (first_universe ++ specialized_universe) name-    return combined_universe----- | Pass in the name of to generate the GDiff GADT and instances. -make_family_gadt :: Name -> Q [Dec]-make_family_gadt name = do    -    result <- run_state (make_family_gadt' name) =<< mk_specialized_universe name-    case result of -        Right x -> return x-        Left x -> do-                     error x-                     return []--is_primitive name = any ((nameBase name) ==) ["Int",- "Char", "String", "Float", - "Double", "Int8", "Int16", "Int32",- "Int64", "Word", "Word8", - "Word16", "Word32", "Word64", "Addr"]--convert_to_gadt_constrs (name, cons) = map (mk_gadt_con name) cons--mk_gadt_con :: Name -> Con -> Con-mk_gadt_con name (NormalC c_name stys) = mk_gadt_con' name c_name $ map snd stys -mk_gadt_con name (RecC    c_name vtys) = mk_gadt_con' name c_name $ map sel3 vtys -mk_gadt_con name (InfixC  (_, x) c_name (_, y)) = mk_gadt_con' name c_name [x, y]---mk_gadt_con' name c_name tys | is_primitive name = ForallC [] [EqualP (VarT $ mkName "a") $ -    ConT name, EqualP (VarT $ mkName "b") $ ConT $ mkName "Nil" ]-    (NormalC (con_name_to_display (nameBase name) name) [(NotStrict, ConT $ name)])-mk_gadt_con' name c_name tys | otherwise = ForallC [] [EqualP (VarT $ mkName "a") $ ConT name, -    EqualP (VarT $ mkName "b") $ foldr AppT (ConT $ mkName "Nil") (add_cons tys) ]-    (NormalC (con_name_to_display (nameBase c_name) name) []) --con_name_to_display c_name name  | c_name == "[]" = mkName $ "Nil" ++ show name ++ "'"-con_name_to_display c_name name  | c_name == ":" = mkName $ show name ++ "__Cons'"-con_name_to_display c_name _ | otherwise = mkName $ c_name ++ "'"--display_to_con_name display_name name | display_name == "Nil" ++ show name     = mkName $ "[]"-display_to_con_name display_name name | display_name == (show name ++ "__Cons") = mkName $ ":"-display_to_con_name display_name _    | otherwise = mkName display_name--add_cons tys = map (AppT (ConT $ mkName "Cons")) tys --mk_gadt :: Name -> [Con] -> DecState Dec-mk_gadt gadt_name gadt_constrs = return $ DataD [] gadt_name [PlainTV $ mkName "a", PlainTV $ mkName "b"] -    gadt_constrs []---is_dec_name name x = result where-    dec_name = get_dec_name x-    result =  case dec_name of -                Right y -> name == y-                Left _  -> False   --make_family_gadt' :: Name -> DecState [Dec]-make_family_gadt' name = do-    first_universe       <- (map snd . filter ((/=name) . fst)) <$> (lift $ get_universe name)-    specialized_universe <- (filter (not . is_dec_name name)) <$> -                                (lift $ expand_and_specialize_syns name name)-    -    all_constructor <- get_cons_from_name-    let gadt_constrs     = nub $ concatMap convert_to_gadt_constrs all_constructor-        gadt_name        = mkName $ (nameBase name) ++ "Fam"-    data_dec        <- mk_gadt gadt_name gadt_constrs-    family_instance <- mk_family_instance data_dec-    type_instances  <- mk_type_instances gadt_name $ nub all_constructor--    return $ data_dec:family_instance:(specialized_universe ++ type_instances)---is_right (Right _) = True-is_right _ = False--get_dec_name :: Dec -> Result Name-get_dec_name (FunD name _)             = Right $ name-get_dec_name (ValD _ _ _)              = Left "ValD does not have a name"-get_dec_name (DataD _ name _ _ _)      = Right $ name-get_dec_name (NewtypeD _ name _ _ _)   = Right $ name-get_dec_name (TySynD name _ _)         = Right $ name-get_dec_name (ClassD _ name _ _ _)     = Right $ name-get_dec_name (InstanceD _ _ _)         = Left "InstanceD does not have a name"-get_dec_name (SigD name _)             = Right $ name-get_dec_name (ForeignD _)              = Left "ForeignD does not have a name"-get_dec_name (PragmaD _ )              = Left "PragmaD does not have a name"-get_dec_name (FamilyD _ name _ _)      = Right $ name-get_dec_name (DataInstD _ name _ _ _ ) = Right $ name--get_name_and_cons :: [Dec] -> [(Name, [Con])]-get_name_and_cons decs = go decs [] where-    go [] output = output-    go (x:xs) output = result where-        name_result = get_dec_name x-        cons = get_cons x-        result = case name_result of-                    Right x -> (x, cons):(go xs output)-                    _      -> go xs output--get_cons_from_name :: DecState [(Name, [Con])]-get_cons_from_name = do -    decs <- ask -    return $ get_name_and_cons decs--find_dec :: [Dec] -> Name -> Result Dec-find_dec decs name = maybe_to_either ("could not find dec " ++ show name ++ " in " ++ show decs) $ find (is_dec_name name) decs---maybe_to_either :: String -> Maybe a -> Result a-maybe_to_either msg (Just a) = Right a-maybe_to_either msg Nothing = Left msg--throw_either :: (Monad m, MonadError String m) => Result a -> m a-throw_either (Right x) = return x-throw_either (Left x)  = throwError x-------------------------------------------------------------------------------------------------------mk_family_instance :: Dec -> DecState Dec    -mk_family_instance (DataD _ name _ cons _) = do-    dec_eqs    <- mapM mk_deceq cons-    fields     <- mapM mk_field cons-    --todo add the default cases-    applys     <- mapM mk_apply cons-    strings    <- lift $ mapM mk_string cons-    let dec_fun    = FunD (mkName "decEq")  (dec_eqs ++ [default_dec]) -        fields_fun = FunD (mkName "fields") (fields ++ [default_field])-        apply_fun  = FunD (mkName "apply")  applys-        string_fun = FunD (mkName "string") strings --        dec  = InstanceD [] (AppT (ConT $ mkName "Family") (ConT name)) -            [dec_fun, fields_fun, apply_fun, string_fun]-    return dec-    -default_dec = Clause [WildP, WildP] (NormalB $ ConE $ mkName "Nothing") []   --mk_deceq :: Con -> DecState Clause-mk_deceq (ForallC _ _ (NormalC name []))   = lift $ clause [conP name [], conP name []] (normalB [| Just (Refl, Refl) |]) []   -mk_deceq (ForallC _ _ (NormalC name typs)) = lift $-    clause [conP name [varP $ mkName "x"], conP name [varP $ mkName "y"]] -    (normalB [| if $(varE $ mkName "x") == $(varE $ mkName "y") then Just (Refl, Refl) else Nothing |]) []--default_field = Clause [WildP, WildP] (NormalB $ ConE $ mkName "Nothing") []   -default_apply = Clause [WildP, WildP] (NormalB $ (AppE (VarE $ mkName "error") (LitE $ StringL "apply failed"))) []   --mk_field :: Con -> DecState Clause-mk_field (ForallC _ (x:y:[]) (NormalC c_name [])) = do -    pat  <- name_to_con_pat (mkName $ reverse $ tail $ reverse (show c_name)) $ get_pred_name  x -    let vars = collect_vars pat-    lift $ clause [conP c_name [], return pat] (normalB [| Just $(ccons_vars (reverse vars) [| CNil |]) |]) []-mk_field (ForallC _ _ (NormalC name typs)) = lift $ clause [conP name [wildP], wildP] (normalB [| Just CNil |]) []   --get_pred_name (EqualP _ (ConT n))  = n--name_to_con_pat :: Name -> Name -> DecState Pat-name_to_con_pat con_name n = do-    decs <- ask-    dec <- throw_either $ find_dec decs n-    data_dec_to_con_p con_name dec--get_con_name :: Con -> Name-get_con_name (NormalC n _)     = n-get_con_name (RecC n _)        = n-get_con_name (InfixC _ n _)    = n-get_con_name (ForallC _ _ con) = get_con_name con--is_nil_list con_name name typ | "Nil" `isPrefixOf` show con_name = True-is_nil_list con_name name typ | otherwise = False--reduce_type = undefined-reduce_type' = undefined--head_either []    = Left "Called head on empty list"-head_either (x:_) = Right x--data_dec_to_con_p :: Name -> Dec -> DecState Pat     -data_dec_to_con_p display_name x = do-     name <- throw_either $ get_dec_name x-     let con_name = display_to_con_name (nameBase display_name) name-     let cons = get_cons x-     let con_result = head_either $ -                filter ((show con_name ==) . nameBase . get_con_name) cons     -     con <- case con_result of -                Left _ -> throwError $ "data_dec_to_con_p failed with con_name = " ++ show con_name -                                ++ " and x " ++ show x-                Right x -> return x -            -     return $ con_to_con_p con ---rec_to_normal (RecC name vts) = NormalC name $ map (\(_, x, y) -> (x, y)) vts---con_to_con_p :: Con -> Pat-con_to_con_p x = result where-    name = get_con_name x-    typs = get_con_types x-    result = ConP name $ concat $ zipWith type_to_pat (map (:[]) ['a'..]) typs--type_to_pat var_preface (AppT ListT x) = -    [InfixP (VarP $ mkName (var_preface)) (mkName ":") (VarP $ mkName (var_preface ++ "s"))]-type_to_pat var_preface (VarT x) = [VarP $ mkName var_preface]     -type_to_pat var_preface (AppT (ConT x) y) = [ConP x $ type_to_pat (var_preface ++ "_a") y]-type_to_pat var_preface (ConT x) = [(VarP $ mkName var_preface)]--collect_vars (ConP _ pvars) = concatMap collect_vars pvars -collect_vars (InfixP x _ y) = concatMap collect_vars [x, y] -collect_vars (VarP x)       = [x]-collect_vars (ListP [])     = []---ccons_vars [] e = e-ccons_vars (x:xs) e = ccons_vars xs [| CCons $(varE x) $(e) |]--mk_apply :: Con -> DecState Clause-mk_apply (ForallC _ (x:y:[]) (NormalC name [])) = do-    ex <- name_to_con_exp (mkName $ reverse $ tail $ reverse (show name)) $ get_pred_name x -    let vars = collect_vars_exp ex-    lift $ clause [conP name [], ccons_vars_pat (reverse vars) $ conP (mkName "CNil") []]  -        (normalB (return ex)) []--mk_apply (ForallC _ _ (NormalC name typs)) = lift $ clause [conP name [varP $ mkName "x"], -    conP (mkName "CNil") []] (normalB $ varE $ mkName "x") []--name_to_con_exp :: Name -> Name -> DecState Exp-name_to_con_exp con_name n = do-    decs <- ask-    dec <- throw_either $ find_dec decs n-    data_dec_to_con_exp con_name dec--    -data_dec_to_con_exp :: Name -> Dec -> DecState Exp    -data_dec_to_con_exp display_name dec = do-    name <- throw_either $ get_dec_name dec-    let con_name = display_to_con_name (nameBase display_name) name-        cons = get_cons dec-        con_result = head_either $ -                        filter (((nameBase con_name)==) . nameBase . get_con_name) cons-                -    con <- case con_result of -               Left _ -> throwError $ "data_dec_to_con_p failed with con_name = " ++ show display_name -                               ++ " and x " ++ show dec-               Right x -> return x-        -    return $ con_to_con_e con ----collect_vars_exp (AppE x y) = collect_vars_exp x ++ collect_vars_exp y-collect_vars_exp (VarE x)   = [x]-collect_vars_exp (ListE xs) = concatMap collect_vars_exp xs-collect_vars_exp (ConE _)   = []-collect_vars_exp (InfixE (Just (VarE x)) _ (Just (VarE y)))   = [x, y]--ccons_vars_pat []     p = p-ccons_vars_pat (x:xs) p = ccons_vars_pat xs (conP (mkName "CCons") [varP x, p])--con_to_con_e :: Con -> Exp-con_to_con_e con = result where-    name = get_con_name con-    typs = get_con_types con-    result = foldl' AppE (ConE name) $ zipWith type_to_exp (map (:[]) ['a'..]) typs--type_to_exp var_preface (AppT ListT x) = -    InfixE (Just $ VarE $ mkName (var_preface)) (ConE $ mkName ":") -           (Just $ VarE $ mkName (var_preface ++ "s")) -type_to_exp var_preface (VarT x) = VarE $ mkName var_preface-type_to_exp var_preface (AppT x y) = AppE (type_to_exp (var_preface ++ "_a") x) -    (type_to_exp (var_preface ++ "_b") y)-type_to_exp var_preface (ConT x) = VarE $ mkName var_preface--mk_string :: Con -> Q Clause    -mk_string (ForallC _ _ (NormalC name []))   = -    clause [conP name []] (normalB $ stringE $ reverse $ tail $ reverse $ show $ name) []--mk_string (ForallC _ _ (NormalC name typs)) = -    clause [conP name [varP $ mkName "x"]] (normalB $ appE (varE $ mkName "show") $ -        varE $ mkName "x") []-----------------------------------------------------------------------------------------------    --mk_type_instances gadt_name cons = mapM (mk_type_instance gadt_name) cons--mk_type_instance gadt_name (name, cons) = do-    let cons_exps = map (make_const name) cons-    return $ InstanceD [] (AppT (AppT (ConT $ mkName "Type") (ConT gadt_name)) (ConT name)) [-                FunD (mkName "constructors") [Clause [] (NormalB $ ListE cons_exps) []]]---make_const name con | is_primitive name = AppE (ConE $ mkName "Abstr") (ConE $ -    con_name_to_display (nameBase $ name) name)-make_const name con | otherwise    = AppE (ConE $ mkName "Concr") (ConE $ -    con_name_to_display (nameBase $ get_con_name con) name) ------+    -- * Main Creation Function+    makeGDiff, +    -- * Customizable Creation+    makeGDiffWith, +    defaultFamSuffix,+    defaultConstructorRenamer, +    defaultPrimitives, +    ConstructorRenamer) where+import Data.Generic.Diff.TH.Internal
+ src/Data/Generic/Diff/TH/Conversion.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE TemplateHaskell #-}+module Data.Generic.Diff.TH.Conversion where+import Data.Generic.Diff.TH.Types+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH+import Control.Applicative+++isPrimitive :: [Name] -> Name -> Bool+isPrimitive primitives = flip elem primitives+-- TODO rename hardness+toConHardness :: [Name] -> TH.Type -> FamConType+toConHardness prims x = case x of+    ConT name +        | isPrimitive prims name -> Abstract+        | otherwise              -> Concrete+    _ -> Concrete+++typToString :: TH.Type -> String+typToString x = case x of+    ForallT _ _ typ -> typToString typ+    AppT a b        -> typToString a ++ typToString b+    ConT n          -> prettifyName n+    TupleT c        -> "Tuple" ++ show c+    UnboxedTupleT c -> "UnboxedTupleT" ++ show c+    ListT           -> "List"+    _               -> error $ "Unsupported type in " ++ show x++prettifyName :: Name -> String+prettifyName n +    | n == '(:)  = "Cons"+    | n == '[] = "Nils"+    | nameBase n == "()" = "Unit"+--    | isTuple $ nameBase n = "Tuple" +    | otherwise          = nameBase n+++getConName :: TH.Type -> Name+getConName x = case x of+    ConT n -> n+    _      -> error $ "getConName used on " ++ show x++toFamCon :: (Name -> Type -> Q Name) -> TH.Type -> (Maybe TH.Con) -> Q FamCon+toFamCon renamer typ x = do+    case x of+        Just con -> do+           let (n, fields) = getNameAndFields con +           newN <- renamer n typ   +           return $ FamCon Concrete newN n fields +        Nothing -> do +           let n = getConName typ+           newN <- renamer n typ+           return $ FamCon Abstract newN n [typ]++getNameAndFields :: TH.Con -> (Name, [TH.Type])+getNameAndFields con = case con of+    NormalC n stys  -> (n, map snd stys)+    RecC n vtys     -> (n, map (\(_, _, z) -> z) vtys)+    InfixC x n y    -> (n, [snd x, snd y])+    ForallC _ _ innerCon -> getNameAndFields innerCon++toFamType :: [Name] -> (Name -> Type -> Q Name) -> (TH.Type, Dec) -> Q FamType+toFamType prims renamer (t, x) = case x of+    DataD _ _ _ cons _   -> toFamType' prims renamer t cons+    NewtypeD _ _ _ con _ -> toFamType' prims renamer t [con]+    TySynD _ _ _         -> error $ "Logic error: all type declarations should be "+++                                         "converted to DataDecl or NewtypeDec"+    e                    -> error $ "unsuppored Dec: " ++ show e++toFamType' :: [Name] -> (Name -> Type -> Q Name) -> TH.Type -> [TH.Con] -> Q FamType+toFamType' prims renamer typ cons = do +    let hardness = toConHardness prims typ+    let consOrType = case hardness of+                        Concrete -> map Just cons+                        Abstract -> [Nothing] +    FamType typ <$> mapM (toFamCon renamer typ) consOrType ++toFam :: [Name] -> (Name -> Type -> Q Name) -> Name -> [(TH.Type, Dec)] -> Q Fam+toFam prims renamer name decs = Fam name <$> mapM (toFamType prims renamer) decs
+ src/Data/Generic/Diff/TH/Internal.hs view
@@ -0,0 +1,212 @@+{-#  LANGUAGE TemplateHaskell, QuasiQuotes, TupleSections, +    RecordWildCards, DeriveDataTypeable #-}+module Data.Generic.Diff.TH.Internal where+import Data.Generic.Diff.TH.Types+import Language.Haskell.TH+import qualified Language.Haskell.TH as TH+import Data.Generic.Diff +import Control.Monad+import Data.Generics.Uniplate.Data+import Data.Generic.Diff.TH.Specialize+import Data.Generic.Diff.TH.Conversion+import Data.Maybe(fromMaybe)+import Data.Word+import Data.Int++-- | Default primitives and expressions for showing them+defaultPrimitives :: [(Name, TH.Exp)]+defaultPrimitives = map (, VarE 'show) defaultNames++defaultNames :: [Name]+defaultNames = [+    ''Int     ,+    ''Char    ,+    ''String  ,+    ''Float   ,+    ''Double  ,+    ''Int8    ,+    ''Int16   ,+    ''Int32   ,+    ''Int64   ,+    ''Word    ,+    ''Word8   ,+    ''Word16  ,+    ''Word32  ,+    ''Word64  ,+    ''Integer  ]+++toConE :: FamCon -> TH.ExpQ      +toConE (FamCon {..}) = case _famConHardness of +             Concrete -> conE 'Concr `appE` conE _famConName+             Abstract -> conE 'Abstr `appE` conE _famConName++famInstance :: [(Name, TH.Exp)] -> Fam -> Q Dec+famInstance prims (Fam {..}) = do+    let constrs  = universeBi _famTypes+        +        --utiliy function+        funcFromCons :: (Name, FamCon -> ClauseQ, [ClauseQ]) -> DecQ+        funcFromCons (n, f, extra) = funD n $ map f constrs ++ extra++        -- f _ _ = Nothing+        defaultClause = clause [wildP, wildP] (normalB [e| Nothing |]) []++        decs = map funcFromCons [+                ('decEq , decClause   , [defaultClause]),+                ('apply , applyClause , []             ),+                ('fields, fieldClause , [defaultClause]),+                ('string, stringClause prims, []             )+               ]++        instanceType  = conT ''Family `appT` conT _famName++    instanceD (return []) instanceType decs++decClause :: FamCon -> ClauseQ+decClause (FamCon {..}) = case _famConHardness of+    Concrete -> clause [conP _famConName [], conP _famConName []] +                            (normalB [e| Just (Refl, Refl) |]) [] +    Abstract -> do+         x <- newName "x"+         y <- newName "y"+         clause [conP _famConName [varP x], +                 conP _famConName [varP y]] (normalB+                 [e| if $(varE x) == $(varE y) +                                then Just (Refl, Refl) +                                else Nothing |]) []  ++stringClause :: [(Name, TH.Exp)] -> FamCon -> ClauseQ+stringClause prims (FamCon {..}) = case _famConHardness of+    Concrete -> clause [conP _famConName []] +            (normalB . stringE . nameBase $ _famConOriginalName) [] +    Abstract -> do +            p <- newName "p"+            let showExp = fromMaybe ( error $ "Logic error." ++ show _famConOriginalName ++ +                                    " Primitive doesn't have a show TH.Expr") $+                                    lookup _famConOriginalName prims +            clause [conP _famConName [varP p]] (normalB $ return showExp `appE` varE p) []++fieldClause :: FamCon -> ClauseQ +fieldClause (FamCon {..}) = case _famConHardness of+    Concrete -> do +      parameterNames <- replicateM (length _famConTypes) (newName "x") +      let parameterListP = conP _famConOriginalName $ +                                map varP parameterNames +          body = normalB . appE (conE 'Just) $ +                    foldr (appE . appE (conE 'CCons) . varE) (conE 'CNil) parameterNames +      clause [conP _famConName [], parameterListP] body []+    Abstract -> clause [conP _famConName [wildP], wildP] (normalB [e| Just CNil |]) []++applyClause :: FamCon -> ClauseQ+applyClause (FamCon {..}) = case _famConHardness of+    Concrete -> do +           parameterNames <- replicateM (length _famConTypes) +                               (newName "x") +           let parameterListP = +                   foldl (\o n -> conP 'CCons [varP n, o]) (conP 'CNil []) +                       parameterNames+               body = normalB . foldl (\x y -> appE x $ varE y) +                                   (conE _famConOriginalName) $ +                                        reverse parameterNames +           clause [conP _famConName [], parameterListP] body []+    Abstract -> do+           nx <- newName "x"+           clause [conP _famConName [varP nx], conP 'CNil []] (normalB $ varE nx) [] ++familyTypeInstances :: Fam -> Q [Dec]+familyTypeInstances (Fam {..}) = mapM (typInstance _famName) _famTypes++typInstance :: Name -> FamType -> Q Dec+typInstance familyName (FamType {..}) = do+    --TODO make a helper function to make it clearer what this is doing+    let instanceType = foldl1 appT [conT   ''Data.Generic.Diff.Type ,+                                    conT   familyName                  , +                                    return _famTypeType              ]++        dec          = funD 'constructors [mainClause]+        mainClause   = clause [] (normalB . listE . map toConE $ _famTypeConstructors) []++    instanceD (return []) instanceType [dec]++mkAllInstances :: [(Name, TH.Exp)] -> Fam -> Q [Dec]+mkAllInstances prims x = liftM2 (:) (famInstance prims x) (familyTypeInstances x)++mkGADTConstructor :: Name -> Name -> TH.Type -> FamCon -> ConQ+mkGADTConstructor a b typ (FamCon {..}) = case _famConHardness of+        Concrete -> forallC [] +            (sequence [equalP (varT a) (return typ),+                equalP (varT b) (foldr (appT .appT (conT ''Cons) . return) (conT ''Nil) +                                     _famConTypes)]) +                            (normalC _famConName [])+        Abstract -> forallC [] (sequence [equalP (varT a) (return typ), +                            equalP (varT b) (conT ''Nil)]) +                           (normalC _famConName [return (NotStrict, ConT _famConOriginalName)]) ++mkGADT :: Fam -> Q Dec+mkGADT (Fam {..}) = do+    a <- newName "a"+    b <- newName "b"+    let constrs = +            concatMap (\(FamType {..}) -> map (mkGADTConstructor a b _famTypeType) _famTypeConstructors) +                                    _famTypes ++    dataD (return []) _famName [PlainTV a, PlainTV b] constrs []++-- | The type of function used for naming the GADTs constructors+--+--   Arg0 : The family suffix+--+--   Arg1 : The name of the constructor +--+--   Arg2 : The specialized type the constructor is from+type ConstructorRenamer = (String -> Name -> TH.Type -> Q Name)++-- | Customizable creation.+--+--   Arg0 : The suffix added to the Family +--+--   Arg1 : Function used for naming constructors of the GADT after specialization+--+--   Arg2 : A list of primitives and an expression for showing them+--+--   Arg3 : The root type+makeGDiffWith :: String -> ConstructorRenamer -> [(Name, TH.Exp)] -> Name -> Q [Dec]+makeGDiffWith familyPrefix constructorRenamer primitives name = do+    let familyName = mkName $ nameBase name ++ familyPrefix+        prefix     = nameBase name+        +    --check if it is a polymorphic type+    dec <- reify name+    +    when (not $ null [x | VarT x <- universeBi dec]) $ +        error "type must be monomorphic"+++    fam       <- toFam (map fst primitives) (constructorRenamer prefix) +                    familyName =<< specialize name+    instances <- mkAllInstances primitives fam+    gadt      <- mkGADT fam ++    return $ gadt : instances+    +-- | Default constructor renamer. Using the family suffix, the +--   name of the constructor and the specialized type of constructor+defaultConstructorRenamer :: String -> Name -> TH.Type -> Q Name+defaultConstructorRenamer prefix n typ = return . mkName $ +        filter (\x -> x /= '[' && x /= ']') $ prefix ++ +           typToString typ ++ prettifyName n ++ "C"+           +-- | Default suffix for the family "Family"           +defaultFamSuffix :: String+defaultFamSuffix = "Family"+    +-- | Create the GADT and instances for GDiff with the defaults    +makeGDiff :: Name -> Q [Dec]+makeGDiff = makeGDiffWith defaultFamSuffix defaultConstructorRenamer defaultPrimitives++++++
+ src/Data/Generic/Diff/TH/Specialize.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE TemplateHaskell, TupleSections #-}+module Data.Generic.Diff.TH.Specialize where+import Language.Haskell.TH+import Data.Generics.Uniplate.Data (childrenBi, transformBi, transformBiM)+import Data.Maybe (fromMaybe, maybeToList)+import Control.Monad.Reader+import Control.Monad.State+import Control.Applicative ((<$>))+import Data.List  (nub)+import Language.Haskell.TH.Ppr (split)+import Data.Traversable (traverse)+import Control.Arrow (first)+import Language.Haskell.TH.ExpandSyns (expandSyns)++specialize :: Name -> Q [(Type, Dec)]+specialize n = nub <$> evalStateT (specializeChildDecs [] n) []++type Context = StateT [([Type], Name)] Q++--This is the main recursive function+specializeChildDecs :: [Type] -> Name -> Context [(Type, Dec)]+specializeChildDecs args n = do+	--this is where I recurse+    let go x = case x of+          a@(AppT _ _) -> uncurry specializeChildDecs . collectArgs $ a+          ConT conName -> specializeChildDecs [] conName+          TupleT 0     -> fmap (maybeToList . fmap (ConT $ mkName "()",))  +                            (reifyDecOnce [] $ mkName "()")+          _            -> return [] ++    mdec <- reifyDecOnce args n+    case mdec of+        Just dec -> do+            let sdec = substTypes args dec+            children <- fmap concat . sequence $ [go t | t <- childrenBi sdec]+            return $ (foldl AppT (ConT n) args, sdec) : children+        Nothing  -> return []++--Only look up the [Type] Name combos once+--I also expand the type synonym here+reifyDecOnce :: [Type]-> Name -> Context (Maybe Dec)+reifyDecOnce ts n = do+    env <- get +    if (ts, n) `elem` env +        then return Nothing+        else do +          modify ((ts, n):)+          lift $ traverse expandTypes =<< reifyDec n++reifyDec :: Name -> Q (Maybe Dec)+reifyDec n = do+    info <- reify n+    case info of+        TyConI dec -> return $ Just dec+        _          -> return Nothing++substTypes :: [Type] -> Dec -> Dec+substTypes ts dec = result where+   tyvars = map getTyName . getTyVars $ dec+   m = zip tyvars ts++   go x = case x of+     oldT@(VarT n) -> fromMaybe oldT (lookup n m)  +     t -> t  ++   result = transformBi go dec+--   result = transformBi (subst' $ map (second Just) m) dec++expandTypes :: Dec -> Q Dec+expandTypes = transformBiM expandSyns+++------------------------------------------------------------------------------+--                                Utils                                     --+------------------------------------------------------------------------------++getTyVars :: Dec -> [TyVarBndr]+getTyVars x = case x of+    DataD _ _ tys _ _ -> tys+    NewtypeD _ _ tys _ _ -> tys+    TySynD _ tys _ -> tys+    ClassD _ _ tys _ _ -> tys+    FamilyD _ _ tys _ -> tys+    _ -> []++getTyName :: TyVarBndr -> Name+getTyName x = case x of+    PlainTV n    -> n+    KindedTV n _ -> n++getTypeName :: Type -> Name+getTypeName x = case x of+        ConT n -> n+        TupleT c          -> mkName $ "(" ++ replicate (c - 1) ',' ++ ")"+        UnboxedTupleT c   -> mkName $ "(" ++ replicate c ',' ++ ")"+        ListT             -> ''[]+        _ -> error $ show x ++ " is not a ConT"++collectArgs :: Type -> ([Type], Name)+collectArgs = swap . first getTypeName . split ++swap :: (a, b) -> (b, a)+swap (x, y) = (y, x)
+ src/Data/Generic/Diff/TH/Types.hs view
@@ -0,0 +1,35 @@+{-#  LANGUAGE TemplateHaskell, DeriveDataTypeable #-}+module Data.Generic.Diff.TH.Types where+import Control.Lens+import Data.Data+import Language.Haskell.TH++data FamConType = Concrete+                | Abstract+            deriving(Data, Typeable, Show, Eq)++data FamCon = FamCon {+        _famConHardness     :: FamConType,+        _famConName         :: Name      ,+        _famConOriginalName :: Name      ,+        _famConTypes        :: [Type]+    }+    deriving(Data, Typeable, Show, Eq)++makeLenses ''FamCon++data FamType = FamType {+        _famTypeType         :: Type    ,+        _famTypeConstructors :: [FamCon]+    }+    deriving(Data, Typeable, Show, Eq)++makeLenses ''FamType++data Fam = Fam {+        _famName  :: Name     ,+        _famTypes :: [FamType]+    }+    deriving(Data, Typeable, Show, Eq)++makeLenses ''Fam
+ tests/Main.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeSynonymInstances, + MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}+module Main where+import Data.Generic.Diff.TH ()+import Data.Generic.Diff ()+import Instances ()++