hobbits 1.2.3 → 1.2.4
raw patch · 7 files changed
+194/−73 lines, 7 filesdep ~basedep ~haskell-src-extsdep ~template-haskell
Dependency ranges changed: base, haskell-src-exts, template-haskell
Files
- CHANGELOG +5/−0
- Data/Binding/Hobbits/Internal/Closed.hs +26/−10
- Data/Binding/Hobbits/Liftable.hs +22/−6
- Data/Binding/Hobbits/NuMatching.hs +131/−47
- Data/Binding/Hobbits/PatternParser.hs +3/−3
- Data/Type/RList.hs +2/−2
- hobbits.cabal +5/−5
CHANGELOG view
@@ -1,4 +1,9 @@ +1.2.3 -> 1.2.4+- exposed NuMatchingObj to the user+- updated cabal file to handle newer versions of GHC+- added a number of NuMatching and Liftable instances+ 1.2.2 -> 1.2.3 - Renamed Cl and unCl to Closed and unClosed, respectively - Moved mkClosed to Internal/Closed.hs
Data/Binding/Hobbits/Internal/Closed.hs view
@@ -32,6 +32,23 @@ operator. -} newtype Closed a = Closed { unClosed :: a } +-- | Extract the type of an 'Info' object+#if MIN_VERSION_template_haskell(2,11,0)+reifyNameType :: TH.Name -> Q Type+reifyNameType n =+ TH.reify n >>= \i ->+ case i of+ TH.VarI _ ty _ -> return ty+ _ -> fail $ "hobbits Panic -- could not reify `" ++ show n ++ "'."+#else+reifyNameType :: TH.Name -> Q Type+reifyNameType n =+ TH.reify n >>= \i ->+ case i of+ TH.VarI _ ty _ _ -> return ty+ _ -> fail $ "hobbits Panic -- could not reify `" ++ show n ++ "'."+#endif+ -- | @mkClosed@ is used with Template Haskell quotations to create closed terms -- of type 'Closed'. A quoted expression is closed if all of the names occuring in -- it are either:@@ -50,13 +67,12 @@ w e = return e closed n = do- i <- TH.reify n- case i of- TH.VarI _ ty _ _ -> TH.expandSyns ty >>= w- where- w (AppT (ConT m) _) | m == ''Closed = return ()- w (ForallT _ _ ty) = w ty- w _ = fail $ "`mkClosed` requires non-global variables to have type `Closed'.\n\t`"- ++ show (TH.ppr n) ++ "' does not. It's type is:\n\t `"- ++ show (TH.ppr ty) ++ "'."- _ -> fail $ "hobbits Panic -- could not reify `" ++ show n ++ "'."+ ty <- reifyNameType n+ TH.expandSyns ty >>= w ty+ where+ w _ (AppT (ConT m) _) | m == ''Closed = return ()+ w top_ty (ForallT _ _ ty') = w top_ty ty'+ w top_ty _ =+ fail $ "`mkClosed` requires non-global variables to have type `Closed'.\n\t`"+ ++ show (TH.ppr n) ++ "' does not. It's type is:\n\t `"+ ++ show (TH.ppr top_ty) ++ "'."
Data/Binding/Hobbits/Liftable.hs view
@@ -25,7 +25,9 @@ import Data.Binding.Hobbits.Closed import Data.Binding.Hobbits.NuMatching +import Data.Ratio + {-| The class @Liftable a@ gives a \"lifting function\" for a, which can take any data of type @a@ out of a multi-binding of type @'Mb' ctx a@.@@ -34,7 +36,7 @@ mbLift :: Mb ctx a -> a ---------------------------------------------------------------------------------- Lifting instances that must be defined inside the library abstraction boundary+-- * Lifting instances that must be defined inside the library abstraction boundary ------------------------------------------------------------------------------- instance Liftable Char where@@ -51,7 +53,7 @@ ---------------------------------------------------------------------------------- Lifting instances and related functions that could be defined outside the library+-- * Lifting instances and related functions that could be defined outside the library ------------------------------------------------------------------------------- -- README: this requires overlapping instances, because it clashes@@ -66,10 +68,12 @@ mbList [nuP| [] |] = [] mbList [nuP| x : xs |] = x : mbList xs ------------------------------------------------------------------------------------ Liftable1 and Liftable2--------------------------------------------------------------------------------+instance (Integral a, NuMatching a) => NuMatching (Ratio a) where+ nuMatchingProof =+ isoMbTypeRepr (\r -> (numerator r, denominator r)) (\(n,d) -> n%d)+instance (Integral a, Liftable a) => Liftable (Ratio a) where+ mbLift mb_r =+ (\(n,d) -> n%d) $ mbLift $ fmap (\r -> (numerator r, denominator r)) mb_r instance Liftable a => Liftable [a] where mbLift [nuP| [] |] = []@@ -80,6 +84,18 @@ instance (Liftable a, Liftable b) => Liftable (a,b) where mbLift [nuP| (x,y) |] = (mbLift x, mbLift y)++instance Liftable Bool where+ mbLift [nuP| True |] = True+ mbLift [nuP| False |] = False++instance Liftable a => Liftable (Maybe a) where+ mbLift [nuP| Nothing |] = Nothing+ mbLift [nuP| Just mb_a |] = Just $ mbLift mb_a++instance (Liftable a, Liftable b) => Liftable (Either a b) where+ mbLift [nuP| Left mb_a |] = Left $ mbLift mb_a+ mbLift [nuP| Right mb_b |] = Right $ mbLift mb_b -- README: these lead to overlapping instances...
Data/Binding/Hobbits/NuMatching.hs view
@@ -23,7 +23,7 @@ module Data.Binding.Hobbits.NuMatching ( NuMatching(..), mkNuMatching, NuMatchingList(..), NuMatching1(..),- MbTypeRepr(), isoMbTypeRepr+ MbTypeRepr(), isoMbTypeRepr, NuMatchingObj(..) ) where --import Data.Typeable@@ -42,7 +42,33 @@ mapNames :: NuMatching a => MapRList Name ctx -> MapRList Name ctx -> a -> a mapNames = mapNamesPf nuMatchingProof +-- | Helper to match a data declaration in a TH version-insensitive way+#if MIN_VERSION_template_haskell(2,11,0)+matchDataDecl :: Dec -> Maybe (Cxt, TH.Name, [TyVarBndr], [Con])+matchDataDecl (DataD cxt name tyvars _ constrs _) =+ Just (cxt, name, tyvars, constrs)+matchDataDecl (NewtypeD cxt name tyvars _ constr _) =+ Just (cxt, name, tyvars, [constr])+matchDataDecl _ = Nothing+#else+matchDataDecl :: Dec -> Maybe (Cxt, TH.Name, [TyVarBndr], [Con])+matchDataDecl (DataD cxt name tyvars constrs _) =+ Just (cxt, name, tyvars, constrs)+matchDataDecl (NewtypeD cxt name tyvars constr _) =+ Just (cxt, name, tyvars, [constr])+matchDataDecl _ = Nothing+#endif +-- | Helper to build an instance declaration in a TH version-insensitive way+#if MIN_VERSION_template_haskell(2,11,0)+mkInstanceD :: Cxt -> Type -> [Dec] -> Dec+mkInstanceD = InstanceD Nothing+#else+mkInstanceD :: Cxt -> Type -> [Dec] -> Dec+mkInstanceD = InstanceD+#endif++ {-| Instances of the @'NuMatching' a@ class allow pattern-matching on multi-bindings whose bodies have type @a@, i.e., on multi-bindings@@ -66,6 +92,9 @@ instance NuMatching a => NuMatching (Mb ctx a) where nuMatchingProof = MbTypeReprMb nuMatchingProof +instance NuMatching Bool where+ nuMatchingProof = MbTypeReprData (MkMbTypeReprData $ (\_ _ -> id))+ instance NuMatching Int where nuMatchingProof = MbTypeReprData (MkMbTypeReprData $ (\c1 c2 -> id)) @@ -87,6 +116,13 @@ instance (NuMatching a, NuMatching b, NuMatching c, NuMatching d) => NuMatching (a,b,c,d) where nuMatchingProof = MbTypeReprData (MkMbTypeReprData $ (\c1 c2 (a,b,c,d) -> (mapNames c1 c2 a, mapNames c1 c2 b, mapNames c1 c2 c, mapNames c1 c2 d))) +instance NuMatching a => NuMatching (Maybe a) where+ nuMatchingProof = MbTypeReprData+ (MkMbTypeReprData+ $ (\c1 c2 x -> case x of+ Just x -> Just (mapNames c1 c2 x)+ Nothing -> Nothing))+ instance (NuMatching a, NuMatching b) => NuMatching (Either a b) where nuMatchingProof = MbTypeReprData (MkMbTypeReprData@@ -208,9 +244,9 @@ fName <- newName "f" x1Name <- newName "x1" x2Name <- newName "x2"- clauses <- mapM (getClause (tName, fName, x1Name, x2Name)) constrs+ clauses <- getClauses (tName, fName, x1Name, x2Name) constrs mapNamesT <- mapNamesType (return cType)- return [InstanceD+ return [mkInstanceD cxt (AppT (ConT ''NuMatching) cType) [ValD (VarP 'nuMatchingProof) (NormalB@@ -248,10 +284,8 @@ getMbTypeReprInfo ctx tyvars topT (ConT tName) = do info <- reify tName case info of- TyConI (DataD _ _ tyvarsReq constrs _) ->- success tyvarsReq constrs- TyConI (NewtypeD _ _ tyvarsReq constr _) ->- success tyvarsReq [constr]+ TyConI (matchDataDecl -> Just (_, _, tyvarsReq, constrs)) ->+ success tyvarsReq constrs _ -> getMbTypeReprInfoFail topT (": info for " ++ (show tName) ++ " = " ++ (show info)) where success tyvarsReq constrs =@@ -283,28 +317,50 @@ -- get a list of Clauses, one for each constructor in constrs getClauses :: Names -> [Con] -> Q [Clause]- getClauses names constrs = mapM (getClause names) constrs+ getClauses _ [] = return [] - getClause :: Names -> Con -> Q Clause- getClause names (NormalC cName cTypes) =- getClauseHelper names (map snd cTypes)- (natsFrom 0)- (\l -> ConP cName (map (VarP . fst3) l))- (\l -> foldl AppE (ConE cName) (map fst3 l))+ getClauses names (NormalC cName cTypes : constrs) =+ do clause <-+ getClauseHelper names (map snd cTypes) (natsFrom 0)+ (\l -> ConP cName (map (VarP . fst3) l))+ (\l -> foldl AppE (ConE cName) (map fst3 l))+ clauses <- getClauses names constrs+ return $ clause : clauses - getClause names (RecC cName cVarTypes) =- getClauseHelper names (map thd3 cVarTypes)- (map fst3 cVarTypes)- (\l -> RecP cName- (map (\(var,_,field) -> (field, VarP var)) l))- (\l -> RecConE cName- (map (\(exp,_,field) -> (field, exp)) l))+ getClauses names (RecC cName cVarTypes : constrs) =+ do clause <-+ getClauseHelper names (map thd3 cVarTypes) (map fst3 cVarTypes)+ (\l -> RecP cName (map (\(var,_,field) -> (field, VarP var)) l))+ (\l -> RecConE cName (map (\(exp,_,field) -> (field, exp)) l))+ clauses <- getClauses names constrs+ return $ clause : clauses - getClause names (InfixC cType1 cName cType2) =- undefined -- FIXME+ getClauses names (InfixC cType1 cName cType2 : constrs) =+ undefined -- FIXME - getClause names (ForallC _ _ con) = getClause names con+#if MIN_VERSION_template_haskell(2,11,0)+ getClauses names (GadtC cNames cTypes _ : constrs) =+ do clauses1 <-+ forM cNames $ \cName ->+ getClauseHelper names (map snd cTypes) (natsFrom 0)+ (\l -> ConP cName (map (VarP . fst3) l))+ (\l -> foldl AppE (ConE cName) (map fst3 l))+ clauses2 <- getClauses names constrs+ return (clauses1 ++ clauses2) + getClauses names (RecGadtC cNames cVarTypes _ : constrs) =+ do clauses1 <-+ forM cNames $ \cName ->+ getClauseHelper names (map thd3 cVarTypes) (map fst3 cVarTypes)+ (\l -> RecP cName (map (\(var,_,field) -> (field, VarP var)) l))+ (\l -> RecConE cName (map (\(exp,_,field) -> (field, exp)) l))+ clauses2 <- getClauses names constrs+ return (clauses1 ++ clauses2)+#endif++ getClauses names (ForallC _ _ constr : constrs) =+ getClauses names (constr : constrs)+ getClauseHelper :: Names -> [Type] -> [a] -> ([(TH.Name,Type,a)] -> Pat) -> ([(Exp,Type,a)] -> Exp) ->@@ -341,7 +397,7 @@ mkMkMbTypeReprDataOld conNameQ = do conName <- conNameQ (cxt, name, tyvars, constrs) <- getMbTypeReprInfo conName- (clauses, reqCxt) <- runStateT (getClauses cxt name tyvars constrs) []+ (clauses, reqCxt) <- runStateT (getClauses cxt name tyvars [] constrs) [] fname <- newName "f" return (LetE [SigD fname@@ -360,7 +416,7 @@ getMbTypeReprInfo conName = reify conName >>= \info -> case info of- TyConI (DataD cxt name tyvars constrs _) ->+ TyConI (matchDataDecl -> Just (cxt, name, tyvars, constrs)) -> return (cxt, name, tyvars, constrs) _ -> fail ("mkMkMbTypeReprData: " ++ show conName ++ " is not a (G)ADT")@@ -382,31 +438,59 @@ -} -- get a list of Clauses, one for each constructor in constrs- getClauses :: Cxt -> TH.Name -> [TyVarBndr] -> [Con] -> CxtStateQ [Clause]- getClauses cxt name tyvars constrs =- mapM (getClause cxt name tyvars []) constrs+ getClauses :: Cxt -> TH.Name -> [TyVarBndr] -> [TyVarBndr] -> [Con] ->+ CxtStateQ [Clause]+ getClauses cxt name tyvars locTyvars [] = return [] - getClause :: Cxt -> TH.Name -> [TyVarBndr] -> [TyVarBndr] -> Con ->- CxtStateQ Clause- getClause cxt name tyvars locTyvars (NormalC cName cTypes) =- getClauseHelper cxt name tyvars locTyvars (map snd cTypes)- (natsFrom 0)- (\l -> ConP cName (map (VarP . fst3) l))- (\l -> foldl AppE (ConE cName) (map (VarE . fst3) l))+ getClauses cxt name tyvars locTyvars (NormalC cName cTypes : constrs) =+ do clause <-+ getClauseHelper cxt name tyvars locTyvars (map snd cTypes)+ (natsFrom 0)+ (\l -> ConP cName (map (VarP . fst3) l))+ (\l -> foldl AppE (ConE cName) (map (VarE . fst3) l))+ clauses <- getClauses cxt name tyvars locTyvars constrs+ return (clause : clauses) - getClause cxt name tyvars locTyvars (RecC cName cVarTypes) =- getClauseHelper cxt name tyvars locTyvars (map thd3 cVarTypes)- (map fst3 cVarTypes)- (\l -> RecP cName- (map (\(var,_,field) -> (field, VarP var)) l))- (\l -> RecConE cName- (map (\(var,_,field) -> (field, VarE var)) l))+ getClauses cxt name tyvars locTyvars (RecC cName cVarTypes : constrs) =+ do clause <-+ getClauseHelper cxt name tyvars locTyvars (map thd3 cVarTypes)+ (map fst3 cVarTypes)+ (\l -> RecP cName (map (\(var,_,field) -> (field, VarP var)) l))+ (\l -> RecConE cName (map (\(var,_,field) -> (field, VarE var)) l))+ clauses <- getClauses cxt name tyvars locTyvars constrs+ return (clause : clauses) - getClause cxt name tyvars locTyvars (InfixC cType1 cName cType2) =- undefined -- FIXME+ getClauses cxt name tyvars locTyvars (InfixC cType1 cName cType2 : _) =+ undefined -- FIXME - getClause cxt name tyvars locTyvars (ForallC tyvars2 cxt2 con) =- getClause (cxt ++ cxt2) name tyvars (locTyvars ++ tyvars2) con+ getClauses cxt name tyvars locTyvars (ForallC tyvars2 cxt2 constr+ : constrs) =+ do clauses1 <-+ getClauses (cxt ++ cxt2) name tyvars (locTyvars ++ tyvars2) [constr]+ clauses2 <- getClauses cxt name tyvars locTyvars constrs+ return (clauses1 ++ clauses2)++#if MIN_VERSION_template_haskell(2,11,0)+ getClauses cxt name tyvars locTyvars (GadtC cNames cTypes _ : constrs) =+ do clauses1 <-+ forM cNames $ \cName ->+ getClauseHelper cxt name tyvars locTyvars (map snd cTypes)+ (natsFrom 0) (\l -> ConP cName (map (VarP . fst3) l))+ (\l -> foldl AppE (ConE cName) (map (VarE . fst3) l))+ clauses2 <- getClauses cxt name tyvars locTyvars constrs+ return (clauses1 ++ clauses2)++ getClauses cxt name tyvars locTyvars (RecGadtC cNames cVarTypes _+ : constrs) =+ do clauses1 <-+ forM cNames $ \cName ->+ getClauseHelper cxt name tyvars locTyvars+ (map thd3 cVarTypes) (map fst3 cVarTypes)+ (\l -> RecP cName (map (\(var,_,field) -> (field, VarP var)) l))+ (\l -> RecConE cName (map (\(var,_,field) -> (field, VarE var)) l))+ clauses2 <- getClauses cxt name tyvars locTyvars constrs+ return (clauses1 ++ clauses2)+#endif getClauseHelper :: Cxt -> TH.Name -> [TyVarBndr] -> [TyVarBndr] -> [Type] -> [a] ->
Data/Binding/Hobbits/PatternParser.hs view
@@ -21,13 +21,13 @@ import qualified Language.Haskell.Meta.Parse as Sloppy import qualified Language.Haskell.Meta.Syntax.Translate as Translate -import Language.Haskell.Exts.Extension+import qualified Language.Haskell.Exts.Extension as Exts #if MIN_VERSION_haskell_src_exts(1,14,0) parsePatternExtensions =- map EnableExtension $ ViewPatterns : Sloppy.myDefaultExtensions+ map Exts.EnableExtension $ Exts.ViewPatterns : Sloppy.myDefaultExtensions #else-parsePatternExtensions = ViewPatterns : Sloppy.myDefaultExtensions+parsePatternExtensions = Exts.ViewPatterns : Sloppy.myDefaultExtensions #endif
Data/Type/RList.hs view
@@ -34,8 +34,8 @@ type family ((r1 :: RList *) :++: (r2 :: RList *)) :: RList * infixr 5 :++:-type instance r :++: RNil = r-type instance r1 :++: r2 :> a = (r1 :++: r2) :> a+type instance (r :++: RNil) = r+type instance (r1 :++: (r2 :> a)) = (r1 :++: r2) :> a proxyCons :: Proxy r -> f a -> Proxy (r :> a) proxyCons _ _ = Proxy
hobbits.cabal view
@@ -1,5 +1,5 @@ Name: hobbits-Version: 1.2.3+Version: 1.2.4 Synopsis: A library for canonically representing terms with binding Description: A library for canonically representing terms with binding via a@@ -19,8 +19,8 @@ extra-source-files: CHANGELOG Library- Build-Depends: base >= 4.7 && < 4.9- Build-Depends: template-haskell >= 2.9 && < 2.11+ Build-Depends: base >= 4.7 && < 5+ Build-Depends: template-haskell >= 2.9 && < 2.13 Build-Depends: syb Build-Depends: mtl@@ -28,8 +28,8 @@ Build-Depends: tagged Build-Depends: deepseq - Build-Depends: haskell-src-exts >= 1.17.1 && < 1.18, haskell-src-meta,- th-expand-syns >= 0.3 && < 0.4, transformers+ Build-Depends: haskell-src-exts >= 1.17.1 && < 1.20, haskell-src-meta,+ th-expand-syns >= 0.3 && < 0.5, transformers GHC-Options: -fwarn-incomplete-patterns -fwarn-unused-imports