diff --git a/examples/CompareVersions.hs b/examples/CompareVersions.hs new file mode 100644 --- /dev/null +++ b/examples/CompareVersions.hs @@ -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 + + + diff --git a/examples/Expr.hs b/examples/Expr.hs new file mode 100644 --- /dev/null +++ b/examples/Expr.hs @@ -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 diff --git a/examples/New.hs b/examples/New.hs new file mode 100644 --- /dev/null +++ b/examples/New.hs @@ -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) diff --git a/examples/Old.hs b/examples/Old.hs new file mode 100644 --- /dev/null +++ b/examples/Old.hs @@ -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 diff --git a/examples/Parser.hs b/examples/Parser.hs new file mode 100644 --- /dev/null +++ b/examples/Parser.hs @@ -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 + + + + + diff --git a/examples/Utils.hs b/examples/Utils.hs new file mode 100644 --- /dev/null +++ b/examples/Utils.hs @@ -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 diff --git a/gdiff-th.cabal b/gdiff-th.cabal --- a/gdiff-th.cabal +++ b/gdiff-th.cabal @@ -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.* + diff --git a/src/Data/Generic/Diff/TH.hs b/src/Data/Generic/Diff/TH.hs --- a/src/Data/Generic/Diff/TH.hs +++ b/src/Data/Generic/Diff/TH.hs @@ -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 diff --git a/src/Data/Generic/Diff/TH/Conversion.hs b/src/Data/Generic/Diff/TH/Conversion.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generic/Diff/TH/Conversion.hs @@ -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 diff --git a/src/Data/Generic/Diff/TH/Internal.hs b/src/Data/Generic/Diff/TH/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generic/Diff/TH/Internal.hs @@ -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 + + + + + + diff --git a/src/Data/Generic/Diff/TH/Specialize.hs b/src/Data/Generic/Diff/TH/Specialize.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generic/Diff/TH/Specialize.hs @@ -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) diff --git a/src/Data/Generic/Diff/TH/Types.hs b/src/Data/Generic/Diff/TH/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generic/Diff/TH/Types.hs @@ -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 diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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 () + +