matchable-th 0.1.2.1 → 0.2
raw patch · 5 files changed
+417/−411 lines, 5 filesdep +bifunctorsdep ~template-haskellPVP ok
version bump matches the API change (PVP)
Dependencies added: bifunctors
Dependency ranges changed: template-haskell
API changes (from Hackage documentation)
- Data.Matchable.TH: instance GHC.Base.Monoid Data.Matchable.TH.FunUsage2
- Data.Matchable.TH: instance GHC.Base.Semigroup Data.Matchable.TH.FunUsage2
+ Data.Matchable.TH: deriveInstances :: Q [Dec] -> Q [Dec]
+ Data.Matchable.TH: makeLiftEq :: Name -> Q Exp
+ Data.Matchable.TH: makeLiftEq2 :: Name -> Q Exp
Files
- README.md +20/−42
- matchable-th.cabal +3/−2
- src/Data/Matchable/TH.hs +283/−287
- src/Data/Matchable/TH/Matcher.hs +59/−0
- test/th.hs +52/−80
README.md view
@@ -8,65 +8,43 @@ ``` haskell {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} import Data.Functor.Classes (Eq1(..)) import Data.Matchable-import Data.Matchable.TH+import Data.Matchable.TH ( deriveInstances ) newtype G a = G [(a, Int, a)] deriving (Show, Eq, Functor) -$(deriveMatchable ''G)+deriveInstances [d|+ deriving instance Eq1 G+ deriving instance Matchable G+ |] --- @deriveMatchable@ generates a @Matchable@ instance only,--- so you also have to declare @Functor G@ and @Eq1 G@.--- There is a handy @DeriveFunctor@ extension.--- Also, you can use @liftEqDefault@ to easily implement @liftEq@.-instance Eq1 G where- liftEq = liftEqDefault ``` ``` haskell+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} -import Data.Functor.Classes (Eq2(..))-import Data.Bimatchable-import Data.Matchable.TH---- Most simple case-data BiF a b = BiF0 | BiF1 a b- deriving (Show, Eq)--$(deriveBimatchable ''BiF)--instance Eq a => Eq1 (BiF a) where- liftEq = liftEq2Default (==)--instance Eq2 BiF where- liftEq2 = liftEq2Default--instance Functor (BiF a) where- fmap = bimapRecovered id--instance Bifunctor BiF where- bimap = bimapRecovered+import Data.Functor.Classes ( Eq1, Eq2 )+import Data.Bifunctor ( Bifunctor(..) )+import Data.Bimatchable ( Bimatchable )+import Data.Matchable ( Matchable )+import Data.Matchable.TH ( deriveInstances ) -- Test case for using [], tuple, and another Bimatchable instance data BiG a b = BiG0 | BiG1 [a] [b] | BiG2 (Int, BiF a b) deriving (Show, Eq) -$(deriveBimatchable ''BiG)--instance Eq a => Eq1 (BiG a) where- liftEq = liftEq2Default (==)--instance Eq2 BiG where- liftEq2 = liftEq2Default--instance Functor (BiG a) where- fmap = bimapRecovered id--instance Bifunctor BiG where- bimap = bimapRecovered+deriveInstances [d|+ deriving instance Bifunctor BiG+ deriving instance Eq a => Eq1 (BiG a)+ deriving instance Eq a => Matchable (BiG a)+ deriving instance Eq2 BiG+ deriving instance Bimatchable BiG+ |] ```
matchable-th.cabal view
@@ -1,5 +1,5 @@ name: matchable-th-version: 0.1.2.1+version: 0.2 synopsis: Generates Matchable instances using TemplateHaskell description: This package provides TemplateHaskell function to generate instances of @Matchable@ and @Bimatchable@ type classes,@@ -23,8 +23,10 @@ library hs-source-dirs: src exposed-modules: Data.Matchable.TH+ other-modules: Data.Matchable.TH.Matcher build-depends: base >= 4.10 && <5, matchable >= 0.1.2,+ bifunctors >= 5.1, template-haskell >= 2.4 && < 2.21, th-abstraction >= 0.4.0.0 ghc-options: -Wall@@ -36,4 +38,3 @@ main-is: th.hs build-depends: base, containers, matchable, matchable-th default-language: Haskell2010-
src/Data/Matchable/TH.hs view
@@ -1,22 +1,196 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveFunctor #-} module Data.Matchable.TH (+ deriveInstances,+ deriveMatchable, makeZipMatchWith,- deriveBimatchable, makeBizipMatchWith+ deriveBimatchable, makeBizipMatchWith,++ makeLiftEq, makeLiftEq2 ) where +import Data.Bifunctor (Bifunctor (..))+import Data.Traversable (forM) import Data.Bimatchable (Bimatchable (..)) import Data.Matchable (Matchable (..))--import Data.Monoid (Monoid (..))-import Data.Semigroup (Semigroup (..))+import Data.Functor.Classes ( Eq2(..), Eq1(..) ) import Language.Haskell.TH hiding (TyVarBndr(..)) import Language.Haskell.TH.Datatype (ConstructorInfo (..), DatatypeInfo (..), reifyDatatype) import Language.Haskell.TH.Datatype.TyVarBndr +import Data.Bifunctor.TH ( makeBimap )+import Data.Monoid (Any (..))++import Data.Matchable.TH.Matcher++warnStrat :: Maybe DerivStrategy -> Q ()+warnStrat Nothing = pure ()+warnStrat (Just strat) = reportWarning $ "Specifying deriving strategy have no effect: " ++ show strat++data Deriver = Deriver { _className :: Name, _methodDerivers :: [(Name, Name -> Q Exp)] }++deriveInstanceWith :: Deriver -> Cxt -> Type -> Q [Dec]+deriveInstanceWith deriver context ty =+ case spine ty of+ (ConT dataCon, _) -> do+ methods <- forM (_methodDerivers deriver) $ \(methodName, makeImpl) -> do+ impl <- makeImpl dataCon+ pure $ FunD methodName [ Clause [] (NormalB impl) [] ]+ pure [InstanceD Nothing context (ConT (_className deriver) `AppT` ty) methods]+ _ -> do reportError ("Instance declaration must be of shape Cls (TyCon ty1 ty2 ...), but it's" ++ show ty)+ pure []++-- | This function transforms multiple instance declarations written in @StandaloneDeriving@+-- format to instances derived by TemplateHaskell.+--+-- ==== Example+-- +-- @+-- {-# LANGUAGE DeriveFunctor #-}+-- {-# LANGUAGE StandaloneDeriving #-}+-- [-# LANGUAGE TemplateHaskell #-}+-- data Foo a b = Foo a b (Either a b)+-- deriving (Show, Eq, Functor)+-- @+-- +-- To use 'deriveInstances' for @Foo@, write as below:+--+-- @+-- deriveInstances [d|+-- deriving instance Eq a => Eq1 (Foo a)+-- deriving instance Eq a => Matchable (Foo a)+-- deriving instance Eq2 Foo+-- deriving instance Bifunctor Foo+-- deriving instance Bimatchable Foo+-- |]+-- @++deriveInstances :: Q [Dec] -> Q [Dec]+deriveInstances decsQ = do+ decs <- decsQ+ derivedDecss <- mapM deriveInstance decs+ pure $ concat derivedDecss++deriveInstance :: Dec -> Q [Dec]+deriveInstance dec = case dec of+ StandaloneDerivD strat context typ -> case typ of+ AppT (ConT cls) typ'+ | cls == ''Eq -> reportWarning "Use stock deriving for Eq" >> pure [dec]+ | cls == ''Functor -> reportWarning "Use stock deriving for Functor" >> pure [dec]+ | cls == ''Bifunctor -> warnStrat strat >> deriveInstanceWith bifunctorDeriver context typ'+ | cls == ''Eq1 -> warnStrat strat >> deriveInstanceWith eq1Deriver context typ'+ | cls == ''Matchable -> warnStrat strat >> deriveInstanceWith matchableDeriver context typ'+ | cls == ''Eq2 -> warnStrat strat >> deriveInstanceWith eq2Deriver context typ'+ | cls == ''Bimatchable -> warnStrat strat >> deriveInstanceWith bimatchableDeriver context typ'+ _ -> reportError ("Unsupported Instance: " ++ show typ) >> pure []+ _ -> reportError "Use standalone deriving declarations only" >> pure []++bifunctorDeriver, eq1Deriver, matchableDeriver, eq2Deriver, bimatchableDeriver :: Deriver+bifunctorDeriver = Deriver ''Bifunctor [ ('bimap, makeBimap) ]+eq1Deriver = Deriver ''Eq1 [ ('liftEq, makeLiftEq) ]++eq2Deriver = Deriver ''Eq2 [ ('liftEq2, makeLiftEq2 ) ]+matchableDeriver = Deriver ''Matchable [ ('zipMatchWith, makeZipMatchWith) ]+bimatchableDeriver = Deriver ''Bimatchable [ ('bizipMatchWith, makeBizipMatchWith) ]++makeLiftEq :: Name -> Q Exp+makeLiftEq name = do+ DatatypeInfo { datatypeVars = dtVarsNames , datatypeCons = cons }+ <- reifyDatatype name+ tyA <- case viewLast dtVarsNames of+ Nothing -> fail $ "Not a type constructor:" ++ show name+ Just (_, a) -> return (VarT (tvName a))+ + eq <- newName "eq"++ matchClauses <- forM cons $+ \(ConstructorInfo ctrName _ _ fields _ _) -> do+ matcher <- combineMatchers (conP ctrName) andBoolExprs <$> mapM (dEq1Field tyA eq) fields+ let Any bodyUsesF = additionalInfo matcher+ fPat = if bodyUsesF then varP eq else wildP+ return $ clause [fPat, leftPat matcher, rightPat matcher] (normalB (bodyExp matcher)) []+ let mismatchClause = clause [ wildP, wildP, wildP ] (normalB [| False |]) []+ finalClauses = case cons of+ [] -> []+ [_] -> matchClauses+ _ -> matchClauses ++ [mismatchClause]+ + lifteq <- newName "lifteq"+ letE [ funD lifteq finalClauses ] (varE lifteq)++dEq1Field :: Type -> Name -> Type -> Q (Matcher Any)+dEq1Field tyA fName = go+ where+ isConst t = not (occurs tyA t)++ go ty = case ty of+ _ | ty == tyA -> funMatcher (varE fName) (Any True)+ | isConst ty -> funMatcher ([| (==) |]) (Any False)+ AppT g ty' | isConst g -> do+ matcher <- go ty'+ liftMatcher [| liftEq |] matcher+ AppT (AppT g ty1') ty2' | isConst g -> do+ matcher1 <- go ty1'+ matcher2 <- go ty2'+ liftMatcher2 [| liftEq2 |] matcher1 matcher2+ (spine -> (TupleT _, subtys)) -> do+ matchers <- mapM go (reverse subtys)+ pure $ combineMatchers tupP andBoolExprs matchers+ _ -> unexpectedType ty "Eq1"++makeLiftEq2 :: Name -> Q Exp+makeLiftEq2 name = do+ DatatypeInfo { datatypeVars = dtVarsNames , datatypeCons = cons }+ <- reifyDatatype name+ (tyA, tyB) <- case viewLastTwo dtVarsNames of+ Nothing -> fail $ "Not a type constructor:" ++ show name+ Just (_, a, b) -> return (VarT (tvName a), VarT (tvName b))+ + eqA <- newName "eqA"+ eqB <- newName "eqB"++ matchClauses <- forM cons $+ \(ConstructorInfo ctrName _ _ fields _ _) -> do+ matcher <- combineMatchers (conP ctrName) andBoolExprs <$> mapM (dEq2Field tyA eqA tyB eqB) fields+ let (Any bodyUsesF, Any bodyUsesG) = additionalInfo matcher+ fPat = if bodyUsesF then varP eqA else wildP+ gPat = if bodyUsesG then varP eqB else wildP+ return $ clause [fPat, gPat, leftPat matcher, rightPat matcher] (normalB (bodyExp matcher)) []+ let mismatchClause = clause [ wildP, wildP, wildP, wildP ] (normalB [| False |]) []+ finalClauses = case cons of+ [] -> []+ [_] -> matchClauses+ _ -> matchClauses ++ [mismatchClause]+ + lifteq <- newName "lifteq"+ letE [ funD lifteq finalClauses ] (varE lifteq)++dEq2Field :: Type -> Name -> Type -> Name -> Type -> Q (Matcher (Any, Any))+dEq2Field tyA fName tyB gName = go+ where+ isConst t = not (occurs tyA t || occurs tyB t)++ go ty = case ty of+ _ | ty == tyA -> funMatcher (varE fName) (Any True, Any False)+ | ty == tyB -> funMatcher (varE gName) (Any False, Any True)+ | isConst ty -> funMatcher ([| (==) |]) mempty+ AppT g ty' | isConst g -> do+ matcher <- go ty'+ liftMatcher [| liftEq |] matcher+ AppT (AppT g ty1') ty2' | isConst g -> do+ matcher1 <- go ty1'+ matcher2 <- go ty2'+ liftMatcher2 [| liftEq2 |] matcher1 matcher2+ (spine -> (TupleT _, subtys)) -> do+ matchers <- mapM go (reverse subtys)+ pure $ combineMatchers tupP andBoolExprs matchers+ _ -> unexpectedType ty "Eq1"+ -- | Build an instance of 'Matchable' for a data type. -- -- /e.g./@@ -36,22 +210,20 @@ -- @ deriveMatchable :: Name -> Q [Dec] deriveMatchable name = do- ((ctx, f), zipMatchWithE) <- makeZipMatchWith' name+ ((ctx, f), zipMatchWithClauses) <- makeZipMatchWith' name - dec <- instanceD ctx (appT (conT ''Matchable) (pure f))- [ funD 'zipMatchWith [clause [] (normalB zipMatchWithE) []] ]+ dec <- instanceD (pure ctx) (appT (conT ''Matchable) (pure f))+ [ funD 'zipMatchWith zipMatchWithClauses ] pure [dec] makeZipMatchWith :: Name -> ExpQ-makeZipMatchWith name = makeZipMatchWith' name >>= snd--viewLast :: [a] -> Maybe ([a], a)-viewLast as = case reverse as of- [] -> Nothing- a:rest -> Just (reverse rest, a)+makeZipMatchWith name = do+ (_, clauses) <- makeZipMatchWith' name+ z <- newName "z"+ letE [ funD z clauses ] (varE z) -makeZipMatchWith' :: Name -> Q ((Q Cxt, Type), ExpQ)+makeZipMatchWith' :: Name -> Q ((Cxt, Type), [Q Clause]) makeZipMatchWith' name = do info <- reifyDatatype name let DatatypeInfo { datatypeVars = dtVarsNames , datatypeCons = cons } = info@@ -61,140 +233,52 @@ f <- newName "f" - let mkMatchClause (ConstructorInfo ctrName _ _ fields _ _) =- do matchers <- mapM (dMatchField tyA f) fields- let lFieldsP = leftPat <$> matchers- rFieldsP = rightPat <$> matchers- bodyUsesF = any additionalInfo matchers- body = foldl (\x y -> [| $x <*> $y |])- [| pure $(conE ctrName) |]- (bodyExp <$> matchers)- ctx = concatMap requiredCtx matchers- fPat = if bodyUsesF then varP f else wildP- lPat = conP ctrName lFieldsP- rPat = conP ctrName rFieldsP- return (clause [fPat, lPat, rPat] (normalB body) [], ctx)-- matchClausesAndCtxs <- mapM mkMatchClause cons+ matchClausesAndCtxs <- forM cons $+ \(ConstructorInfo ctrName _ _ fields _ _) -> do+ let body = foldl (\x y -> [| $x <*> $y |]) [| pure $(conE ctrName) |]+ matcher <- combineMatchers (conP ctrName) body <$> mapM (dMatchField tyA f) fields+ let (ctx, Any bodyUsesF) = additionalInfo matcher+ fPat = if bodyUsesF then varP f else wildP+ return $ (ctx, clause [fPat, leftPat matcher, rightPat matcher] (normalB (bodyExp matcher)) []) - let matchClauses = map fst matchClausesAndCtxs- ctx = concatMap snd matchClausesAndCtxs+ let matchClauses = map snd matchClausesAndCtxs+ ctx = concatMap fst matchClausesAndCtxs mismatchClause = clause [ wildP, wildP, wildP ] (normalB [| Nothing |]) [] finalClauses = case cons of [] -> [] [_] -> matchClauses _ -> matchClauses ++ [mismatchClause] - zmw <- newName "zmw"- return ((sequenceA ctx, dtFunctor), letE [ funD zmw finalClauses ] (varE zmw))--data Matcher u = Matcher- { leftPat :: PatQ- , rightPat :: PatQ- , bodyExp :: ExpQ- , requiredCtx :: [TypeQ]- , additionalInfo :: u }--dMatchField :: Type -> Name -> Type -> Q (Matcher Bool)-dMatchField tyA fName ty = case spine ty of- _ | ty == tyA -> do- l <- newName "l"- r <- newName "r"- return $ Matcher- { leftPat = varP l- , rightPat = varP r- , additionalInfo = True- , bodyExp = [| $(varE fName) $(varE l) $(varE r) |]- , requiredCtx = [] }- | not (occurs tyA ty) -> do- l <- newName "l"- r <- newName "r"- let ctx = [ pure (AppT (ConT ''Eq) ty) | hasTyVar ty ]- return $ Matcher- { leftPat = varP l- , rightPat = varP r- , additionalInfo = False- , bodyExp = [| if $(varE l) == $(varE r)- then Just $(varE l)- else Nothing |]- , requiredCtx = ctx }- (ListT, ty':_) -> dWrapped ty'- (TupleT n, subtys) -> do- matchers <- mapM (dMatchField tyA fName) (reverse subtys)- let lP = tupP (leftPat <$> matchers)- rP = tupP (rightPat <$> matchers)- tupcon = [| pure $(conE (tupleDataName n)) |]- anyUsesF = any additionalInfo matchers- body = foldl (\x y -> [| $x <*> $y |]) tupcon (bodyExp <$> matchers)- ctx = concatMap requiredCtx matchers- return $ Matcher- { leftPat = lP- , rightPat = rP- , additionalInfo = anyUsesF- , bodyExp = body- , requiredCtx = ctx }- (ConT tcon, ty' : rest) | all (not . occurs tyA) rest -> do- let g = foldr (flip AppT) (ConT tcon) rest- ctxG = [ pure (AppT (ConT ''Matchable) g) | hasTyVar g ]- matcher <- dWrapped ty'- return $ matcher{ requiredCtx = ctxG ++ requiredCtx matcher }- (ConT tcon, ty1' : ty2' : rest) | all (not . occurs tyA) rest -> do- let g = foldr (flip AppT) (ConT tcon) rest- ctxG = [ pure (AppT (ConT ''Bimatchable) g) | hasTyVar g ]- -- Note that since @spine@ reverses argument order,- -- it must be dWrappedBi ty2 ty1.- matcher <- dWrappedBi ty2' ty1'- return $ matcher{ requiredCtx = ctxG ++ requiredCtx matcher }- (VarT t, ty' : rest) | all (not . occurs tyA) rest -> do- let g = foldr (flip AppT) (VarT t) rest- ctxG = [ pure (AppT (ConT ''Matchable) g) ]- matcher <- dWrapped ty'- return $ matcher{ requiredCtx = ctxG ++ requiredCtx matcher }- (VarT t, ty1' : ty2' : rest) | all (not . occurs tyA) rest -> do- let g = foldr (flip AppT) (VarT t) rest- ctxG = [ pure (AppT (ConT ''Bimatchable) g) | hasTyVar g ]- matcher <- dWrappedBi ty2' ty1'- return $ matcher{ requiredCtx = ctxG ++ requiredCtx matcher }- (ForallT _ _ _, _) -> unexpectedType ty "Matchable"- (ParensT _, _) -> error "Never reach here"- (AppT _ _, _) -> error "Never reach here"- (SigT _ _, _) -> error "Never reach here"- _ -> unexpectedType ty "Matchable"+ return ((ctx, dtFunctor), finalClauses) +dMatchField :: Type -> Name -> Type -> Q (Matcher (Cxt, Any))+dMatchField tyA fName = go where- dWrapped :: Type -> Q (Matcher Bool)- dWrapped ty' =do- l <- newName "l"- r <- newName "r"- (usesF', ctx, fun) <- do- matcher <- dMatchField tyA fName ty'- let fun = lamE [leftPat matcher, rightPat matcher] (bodyExp matcher)- return (additionalInfo matcher, requiredCtx matcher, fun)- return $ Matcher- { leftPat = varP l- , rightPat = varP r- , additionalInfo = usesF'- , bodyExp = [| zipMatchWith $fun $(varE l) $(varE r) |]- , requiredCtx = ctx }+ isConst = not . occurs tyA - dWrappedBi :: Type -> Type -> Q (Matcher Bool)- dWrappedBi ty1 ty2 = do- l <- newName "l"- r <- newName "r"- (usesF', ctx, fun1, fun2) <- do- matcher1 <- dMatchField tyA fName ty1- matcher2 <- dMatchField tyA fName ty2- let fun1 = lamE [leftPat matcher1, rightPat matcher1] (bodyExp matcher1)- fun2 = lamE [leftPat matcher2, rightPat matcher2] (bodyExp matcher2)- usesF' = additionalInfo matcher1 || additionalInfo matcher2- ctx = requiredCtx matcher1 ++ requiredCtx matcher2- return (usesF', ctx, fun1, fun2)- return $ Matcher- { leftPat = varP l- , rightPat = varP r- , additionalInfo = usesF'- , bodyExp = [| bizipMatchWith $fun1 $fun2 $(varE l) $(varE r) |]- , requiredCtx = ctx }+ go ty = case ty of+ _ | ty == tyA -> funMatcher (varE fName) ([], Any True)+ | isConst ty -> + let ctx = [ AppT (ConT ''Eq) ty | hasTyVar ty ]+ in matcherExpr+ (\l r -> [| if $l == $r then Just $l else Nothing |])+ (ctx, Any False)+ (AppT g ty') | isConst g -> do+ let ctxG = [ AppT (ConT ''Matchable) g | hasTyVar g ]+ matcher <- go ty'+ matcher' <- liftMatcher [| zipMatchWith |] matcher+ return $ (ctxG, mempty) `addInfo` matcher'+ (AppT (AppT g ty1') ty2') | isConst g -> do+ let ctxG = [ AppT (ConT ''Bimatchable) g | hasTyVar g ]+ matcher1 <- go ty1'+ matcher2 <- go ty2'+ matcher' <- liftMatcher2 [| bizipMatchWith |] matcher1 matcher2+ return $ (ctxG, mempty) `addInfo` matcher'+ (spine -> (TupleT n, subtys)) -> do+ let body = foldl (\x y -> [| $x <*> $y |]) [| pure $(conE (tupleDataName n)) |]+ matchers <- mapM go (reverse subtys)+ pure $ combineMatchers tupP body matchers+ _ -> unexpectedType ty "Matchable" -- | Build an instance of 'Bimatchable' for a data type. --@@ -214,22 +298,20 @@ -- @ deriveBimatchable :: Name -> Q [Dec] deriveBimatchable name = do- ((ctx, f), zipMatchWithE) <- makeBizipMatchWith' name+ ((ctx, f), clauses) <- makeBizipMatchWith' name - dec <- instanceD ctx (appT (conT ''Bimatchable) (pure f))- [ funD 'bizipMatchWith [clause [] (normalB zipMatchWithE) []] ]+ dec <- instanceD (pure ctx) (appT (conT ''Bimatchable) (pure f))+ [ funD 'bizipMatchWith clauses ] pure [dec] makeBizipMatchWith :: Name -> ExpQ-makeBizipMatchWith name = makeBizipMatchWith' name >>= snd--viewLastTwo :: [a] -> Maybe ([a],a,a)-viewLastTwo as = case reverse as of- b:a:rest -> Just (reverse rest, a, b)- _ -> Nothing+makeBizipMatchWith name = do+ (_, clauses) <- makeBizipMatchWith' name+ z <- newName "z"+ letE [ funD z clauses ] (varE z) -makeBizipMatchWith' :: Name -> Q ((Q Cxt, Type), ExpQ)+makeBizipMatchWith' :: Name -> Q ((Cxt, Type), [Q Clause]) makeBizipMatchWith' name = do info <- reifyDatatype name let DatatypeInfo { datatypeVars = dtVars , datatypeCons = cons } = info@@ -240,155 +322,55 @@ f <- newName "f" g <- newName "g" - let mkMatchClause (ConstructorInfo ctrName _ _ fields _ _) =- do matchers <- mapM (dBimatchField tyA f tyB g) fields- let lFieldsP = leftPat <$> matchers- rFieldsP = rightPat <$> matchers- Usage2 usesF usesG = foldMap additionalInfo matchers- body = foldl (\x y -> [| $x <*> $y |])- [| pure $(conE ctrName) |]- (bodyExp <$> matchers)- ctx = concatMap requiredCtx matchers- fPat = if usesF then varP f else wildP- gPat = if usesG then varP g else wildP- lPat = conP ctrName lFieldsP- rPat = conP ctrName rFieldsP- return (clause [fPat, gPat, lPat, rPat] (normalB body) [], ctx)-- matchClausesAndCtxs <- mapM mkMatchClause cons+ matchClausesAndCtxs <- forM cons $+ \(ConstructorInfo ctrName _ _ fields _ _) -> do+ let body = foldl (\x y -> [| $x <*> $y |]) [| pure $(conE ctrName) |]+ matcher <- combineMatchers (conP ctrName) body <$> mapM (dBimatchField tyA f tyB g) fields+ let (ctx, Any bodyUsesF, Any bodyUsesG) = additionalInfo matcher+ fPat = if bodyUsesF then varP f else wildP+ gPat = if bodyUsesG then varP g else wildP+ return $ (ctx, clause [fPat, gPat, leftPat matcher, rightPat matcher] (normalB (bodyExp matcher)) []) - let matchClauses = map fst matchClausesAndCtxs- ctx = concatMap snd matchClausesAndCtxs+ let matchClauses = map snd matchClausesAndCtxs+ ctx = concatMap fst matchClausesAndCtxs mismatchClause = clause [ wildP, wildP, wildP, wildP ] (normalB [| Nothing |]) [] finalClauses = case cons of [] -> [] [_] -> matchClauses _ -> matchClauses ++ [mismatchClause] - bzmw <- newName "bzmw"- return ((sequenceA ctx, dtFunctor), letE [ funD bzmw finalClauses ] (varE bzmw))--data FunUsage2 = Usage2 Bool Bool--instance Semigroup FunUsage2 where- Usage2 f1 g1 <> Usage2 f2 g2 = Usage2 (f1 || f2) (g1 || g2)--instance Monoid FunUsage2 where- mempty = Usage2 False False- mappend = (<>)--dBimatchField :: Type -> Name -> Type -> Name -> Type -> Q (Matcher FunUsage2)-dBimatchField tyA fName tyB gName ty = case spine ty of- _ | ty == tyA -> do- l <- newName "l"- r <- newName "r"- return $ Matcher- { leftPat = varP l- , rightPat = varP r- , additionalInfo = Usage2 True False- , bodyExp = [| $(varE fName) $(varE l) $(varE r) |]- , requiredCtx = [] }- | ty == tyB -> do- l <- newName "l"- r <- newName "r"- return $ Matcher- { leftPat = varP l- , rightPat = varP r- , additionalInfo = Usage2 False True- , bodyExp = [| $(varE gName) $(varE l) $(varE r) |]- , requiredCtx = [] }- | isConst ty -> do- l <- newName "l"- r <- newName "r"- let ctx = [ pure (AppT (ConT ''Eq) ty) | hasTyVar ty ]- return $ Matcher- { leftPat = varP l- , rightPat = varP r- , additionalInfo = Usage2 False False- , bodyExp = [| if $(varE l) == $(varE r)- then Just $(varE l)- else Nothing |]- , requiredCtx = ctx }- (ListT, ty':_) -> dWrapped ty'- (TupleT n, subtys) -> do- matchers <- mapM (dBimatchField tyA fName tyB gName) (reverse subtys)- let lP = tupP (leftPat <$> matchers)- rP = tupP (rightPat <$> matchers)- tupcon = [| pure $(conE (tupleDataName n)) |]- anyUsesF = foldMap additionalInfo matchers- body = foldl (\x y -> [| $x <*> $y |]) tupcon (bodyExp <$> matchers)- ctx = concatMap requiredCtx matchers- return $ Matcher- { leftPat = lP- , rightPat = rP- , additionalInfo = anyUsesF- , bodyExp = body- , requiredCtx = ctx }- (ConT tcon, ty' : rest) | all isConst rest -> do- let g = foldr (flip AppT) (ConT tcon) rest- ctxG = [ pure (AppT (ConT ''Matchable) g) | hasTyVar g ]- matcher <- dWrapped ty'- return $ matcher{ requiredCtx = ctxG ++ requiredCtx matcher }- (ConT tcon, ty1' : ty2' : rest) | all isConst rest -> do- let g = foldr (flip AppT) (ConT tcon) rest- ctxG = [ pure (AppT (ConT ''Bimatchable) g) | hasTyVar g ]- -- Note that since @spine@ reverses argument order,- -- it must be dWrappedBi ty2 ty1.- matcher <- dWrappedBi ty2' ty1'- return $ matcher{ requiredCtx = ctxG ++ requiredCtx matcher }- (VarT t, ty' : rest) | all isConst rest -> do- let g = foldr (flip AppT) (VarT t) rest- ctxG = [ pure (AppT (ConT ''Matchable) g) ]- matcher <- dWrapped ty'- return $ matcher{ requiredCtx = ctxG ++ requiredCtx matcher }- (VarT t, ty1' : ty2' : rest) | all isConst rest -> do- let g = foldr (flip AppT) (VarT t) rest- ctxG = [ pure (AppT (ConT ''Bimatchable) g) | hasTyVar g ]- matcher <- dWrappedBi ty2' ty1'- return $ matcher{ requiredCtx = ctxG ++ requiredCtx matcher }- (ForallT _ _ _, _) -> unexpectedType ty "Bimatchable"- (ParensT _, _) -> error "Never reach here"- (AppT _ _, _) -> error "Never reach here"- (SigT _ _, _) -> error "Never reach here"- _ -> unexpectedType ty "Bimatchable"+ return ((ctx, dtFunctor), finalClauses) +dBimatchField :: Type -> Name -> Type -> Name -> Type -> Q (Matcher (Cxt, Any, Any))+dBimatchField tyA fName tyB gName = go where- isConst :: Type -> Bool isConst t = not (occurs tyA t || occurs tyB t)-- dWrapped :: Type -> Q (Matcher FunUsage2)- dWrapped ty' = do- l <- newName "l"- r <- newName "r"- (usesF', ctx, fun) <- do- matcher <- dBimatchField tyA fName tyB gName ty'- let fun = lamE [leftPat matcher, rightPat matcher] (bodyExp matcher)- return (additionalInfo matcher, requiredCtx matcher, fun)- return $ Matcher- { leftPat = varP l- , rightPat = varP r- , additionalInfo = usesF'- , bodyExp = [| zipMatchWith $fun $(varE l) $(varE r) |]- , requiredCtx = ctx }-- dWrappedBi :: Type -> Type -> Q (Matcher FunUsage2)- dWrappedBi ty1 ty2 = do- l <- newName "l"- r <- newName "r"- (usesF', ctx, fun1, fun2) <- do- matcher1 <- dBimatchField tyA fName tyB gName ty1- matcher2 <- dBimatchField tyA fName tyB gName ty2- let fun1 = lamE [leftPat matcher1, rightPat matcher1] (bodyExp matcher1)- fun2 = lamE [leftPat matcher2, rightPat matcher2] (bodyExp matcher2)- usesF' = additionalInfo matcher1 <> additionalInfo matcher2- ctx = requiredCtx matcher1 ++ requiredCtx matcher2- return (usesF', ctx, fun1, fun2)- return $ Matcher- { leftPat = varP l- , rightPat = varP r- , additionalInfo = usesF'- , bodyExp = [| bizipMatchWith $fun1 $fun2 $(varE l) $(varE r) |]- , requiredCtx = ctx }+ + go ty = case ty of+ _ | ty == tyA -> funMatcher (varE fName) ([], Any True, Any False)+ | ty == tyB -> funMatcher (varE gName) ([], Any False, Any True)+ | isConst ty -> + let ctx = [ AppT (ConT ''Eq) ty | hasTyVar ty ]+ in matcherExpr+ (\l r -> [| if $l == $r then Just $l else Nothing |])+ (ctx, Any False, Any False)+ (AppT g ty') | isConst g -> do+ let ctxG = [ AppT (ConT ''Matchable) g | hasTyVar g ]+ matcher <- go ty'+ matcher' <- liftMatcher [| zipMatchWith |] matcher+ return $ (ctxG, mempty, mempty) `addInfo` matcher'+ (AppT (AppT g ty1') ty2') | isConst g -> do+ let ctxG = [ AppT (ConT ''Bimatchable) g | hasTyVar g ]+ matcher1 <- go ty1'+ matcher2 <- go ty2'+ matcher' <- liftMatcher2 [| bizipMatchWith |] matcher1 matcher2+ return $ (ctxG, mempty, mempty) `addInfo` matcher'+ (spine -> (TupleT n, subtys)) -> do+ matchers <- mapM go (reverse subtys)+ let body = foldl (\x y -> [| $x <*> $y |]) [| pure $(conE (tupleDataName n)) |]+ pure $ combineMatchers tupP body matchers+ _ -> unexpectedType ty "Bimatchable"+ ----------------------------- @@ -398,6 +380,10 @@ " (it's only possible to implement " ++ cls ++ " genericaly when all subterms are traversable)" +andBoolExprs :: [Q Exp] -> Q Exp+andBoolExprs [] = [| True |]+andBoolExprs xs = foldr1 (\x y -> [| $x && $y |]) xs+ spine :: Type -> (Type, [Type]) spine (ParensT t) = spine t spine (AppT t1 t2) = let (h, r) = spine t1 in (h, t2:r)@@ -418,3 +404,13 @@ hasTyVar (AppT t1 t2) = hasTyVar t1 || hasTyVar t2 hasTyVar (SigT t _) = hasTyVar t hasTyVar _ = False++viewLast :: [a] -> Maybe ([a], a)+viewLast as = case reverse as of+ [] -> Nothing+ a:rest -> Just (reverse rest, a)++viewLastTwo :: [a] -> Maybe ([a],a,a)+viewLastTwo as = case reverse as of+ b:a:rest -> Just (reverse rest, a, b)+ _ -> Nothing
+ src/Data/Matchable/TH/Matcher.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveFunctor #-}+module Data.Matchable.TH.Matcher(+ Matcher(..),+ addInfo, + matcherToFun,+ + matcherExpr, + funMatcher, liftMatcher, liftMatcher2, combineMatchers+) where++import Language.Haskell.TH++data Matcher u = Matcher+ { leftPat :: PatQ+ , rightPat :: PatQ+ , bodyExp :: ExpQ+ , additionalInfo :: u }+ deriving Functor++addInfo :: Semigroup a => a -> Matcher a -> Matcher a+addInfo a = fmap (a <>)++matcherToFun :: Matcher a -> ExpQ+matcherToFun matcher = lamE [leftPat matcher, rightPat matcher] (bodyExp matcher)++matcherExpr :: (ExpQ -> ExpQ -> ExpQ) -> a -> Q (Matcher a)+matcherExpr expr a = do+ l <- newName "l"+ r <- newName "r"+ return $ Matcher+ { leftPat = varP l+ , rightPat = varP r+ , bodyExp = expr (varE l) (varE r)+ , additionalInfo = a }++funMatcher :: ExpQ -> a -> Q (Matcher a)+funMatcher f = matcherExpr (\l r -> [| $f $l $r |])++liftMatcher :: ExpQ -> Matcher a -> Q (Matcher a)+liftMatcher lifter matcher = funMatcher [| $lifter $fun |] (additionalInfo matcher)+ where+ fun = matcherToFun matcher++liftMatcher2 :: (Semigroup a) => ExpQ -> Matcher a -> Matcher a -> Q (Matcher a)+liftMatcher2 lifter matcher1 matcher2 = funMatcher [| $lifter $fun1 $fun2 |] info'+ where+ fun1 = matcherToFun matcher1+ fun2 = matcherToFun matcher2+ info' = additionalInfo matcher1 <> additionalInfo matcher2++combineMatchers :: (Monoid a) => ([PatQ] -> PatQ) -> ([ExpQ] -> ExpQ) -> [Matcher a] -> Matcher a+combineMatchers patCombiner expCombiner matchers =+ Matcher {+ leftPat = patCombiner (leftPat <$> matchers)+ , rightPat = patCombiner (rightPat <$> matchers)+ , bodyExp = expCombiner (bodyExp <$> matchers)+ , additionalInfo = foldMap additionalInfo matchers+ }
test/th.hs view
@@ -2,13 +2,14 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-} module Main(main) where -import Data.Functor.Classes-import Data.Bifunctor-import Data.Bimatchable-import Data.Matchable-import Data.Matchable.TH+import Data.Functor.Classes ( Eq2, Eq1 )+import Data.Bifunctor ( Bifunctor(..) )+import Data.Bimatchable ( Bimatchable )+import Data.Matchable ( Matchable )+import Data.Matchable.TH ( deriveInstances ) main :: IO () main = putStrLn "compiles"@@ -17,116 +18,87 @@ data F a = F0 | F1 a | F2 a a deriving (Show, Eq, Functor) -$(deriveMatchable ''F)--instance Eq1 F where- liftEq = liftEqDefault+deriveInstances [d|+ deriving instance Eq1 F+ deriving instance Matchable F+ |] -- Test case for using [] and tuples newtype G a = G [(a, Int, a)] deriving (Show, Eq, Functor) -$(deriveMatchable ''G)--instance Eq1 G where- liftEq = liftEqDefault+deriveInstances [d|+ deriving instance Eq1 G+ deriving instance Matchable G+ |] -- Test case for extra type variable data H a b = H0 a | H1 a b | H2 [Either a b] deriving (Show, Eq, Functor) -$(deriveMatchable ''H)--instance (Eq a) => Eq1 (H a) where- liftEq = liftEqDefault--{---@$(deriveMatchable ''H)@ expands like below:-- instance (Eq a, Matchable (Either a)) => Matchable (H a) where ...--This requires UndecidableInstances extension, and warned by GHC-as it exibits worse type inference.--Mitigating this problem might need manually implement constraint-solver in TH side, so it's not an easy target.---}+deriveInstances [d|+ deriving instance Eq a => Eq1 (H a)+ deriving instance Eq a => Matchable (H a)+ |] -- Test case for using Matchable and Bimatchable data I a b = I a (F b) (Either [b] (a,b)) deriving (Show, Eq) -$(deriveMatchable ''I)--instance (Eq a) => Eq1 (I a) where- liftEq = liftEqDefault+instance Functor (I a) where+ fmap f (I a fb e) = I a (f <$> fb) (bimap (fmap f) (fmap f) e) -instance (Eq a) => Functor (I a) where- fmap = fmapRecovered+deriveInstances [d|+ deriving instance Eq a => Eq1 (I a)+ deriving instance Eq a => Matchable (I a)+ |] -- Test case for recursive type data J a = J0 | J1 (J a, Int) a (Int, J a) deriving (Show, Eq, Functor) -$(deriveMatchable ''J)--instance Eq1 J where- liftEq = liftEqDefault+deriveInstances [d|+ deriving instance Eq1 J+ deriving instance Matchable J+ |] ------------------------------- -- Most simple case data BiF a b = BiF0 | BiF1 a b- deriving (Show, Eq)--$(deriveBimatchable ''BiF)--instance Eq a => Eq1 (BiF a) where- liftEq = liftEq2Default (==)--instance Eq2 BiF where- liftEq2 = liftEq2Default--instance Functor (BiF a) where- fmap = bimapRecovered id+ deriving (Show, Eq, Functor) -instance Bifunctor BiF where- bimap = bimapRecovered+deriveInstances [d|+ deriving instance Bifunctor BiF+ deriving instance Eq a => Eq1 (BiF a)+ deriving instance Eq a => Matchable (BiF a)+ deriving instance Eq2 BiF+ deriving instance Bimatchable BiF+ |] -- Test case for using [], tuple, and another Bimatchable instance data BiG a b = BiG0 | BiG1 [a] [b] | BiG2 (Int, BiF a b)- deriving (Show, Eq)--$(deriveBimatchable ''BiG)--instance Eq a => Eq1 (BiG a) where- liftEq = liftEq2Default (==)--instance Eq2 BiG where- liftEq2 = liftEq2Default--instance Functor (BiG a) where- fmap = bimapRecovered id+ deriving (Show, Eq, Functor) -instance Bifunctor BiG where- bimap = bimapRecovered+deriveInstances [d|+ deriving instance Bifunctor BiG+ deriving instance Eq a => Eq1 (BiG a)+ deriving instance Eq a => Matchable (BiG a)+ deriving instance Eq2 BiG+ deriving instance Bimatchable BiG+ |] -- Test case for recursive type data BiH a b = BiH1 a b | BiH2 (BiH b a) (BiH a String) deriving (Show, Eq) -$(deriveBimatchable ''BiH)--instance Eq a => Eq1 (BiH a) where- liftEq = liftEq2Default (==)--instance Eq2 BiH where- liftEq2 = liftEq2Default+deriveInstances [d|+ deriving instance Bifunctor BiH+ deriving instance Eq a => Eq1 (BiH a)+ deriving instance Eq a => Matchable (BiH a)+ deriving instance Eq2 BiH+ deriving instance Bimatchable BiH+ |] instance Functor (BiH a) where- fmap = bimapRecovered id--instance Bifunctor BiH where- bimap = bimapRecovered+ fmap = second