enum-subset-generate (empty) → 0.1.0.0
raw patch · 9 files changed
+351/−0 lines, 9 filesdep +QuickCheckdep +basedep +enum-subset-generatesetup-changed
Dependencies added: QuickCheck, base, enum-subset-generate, generic-random, hspec, microlens, template-haskell
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +67/−0
- Setup.hs +2/−0
- enum-subset-generate.cabal +61/−0
- src/Data/MakeEnum.hs +107/−0
- src/Data/MakeEnum/Options.hs +22/−0
- test/Enum.hs +3/−0
- test/Spec.hs +56/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for enum-subset-generate++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Georg Rudoy (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Georg Rudoy nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,67 @@+# enum-subset-generate++[](https://travis-ci.org/0xd34df00d/enum-subset-generate)++Generates an ADT having a subset of constructors of some other ADT along with a+pair of functions to map between the two.++## Motivation++Consider implementing FFI bindings for a library. The lower level (directly+mapping the C API onto Haskell) might expose an enumeration as an ADT, not all+values of which might make sense for higher-level well-typed code. In this case+the higher-level bindings might instead expose the generated ADT.++As an example, consider a parser library for a language like C++ or Java. A+cursor pointing to a node in an AST might have a property like+```c+enum AccessSpecifier {+ AS_Invalid,+ AS_Public,+ AS_Protected,+ AS_Private+};++AccessSpecifier getAccessSpecifier(Cursor*);+```++Access specifier doesn't make much sense for a node representing a `for`-loop,+hence the `AS_Invalid` member.++A low-level Haskell bindings library might translate this enum into+```haskell+module Library.Bindings.FFI where++-- ...++data AccessSpecifier = Invalid+ | Public+ | Protected+ | Private+ deriving (Eq, Ord, Show)++getAccessSpecifier :: Cursor -> BindingsMonad AccessSpecifier+```++A more type-safe wrapper around this might introduce typed cursors and add a+constraint to the function:+```haskell+module Library.Bindings.Pure where++import qualified Library.Bindings.FFI as FFI++accessSpecifier :: HasAccessSpecifier t => Cursor t -> FFI.AccessSpecifier+```+so this `accessSpecifier` is guaranteed to always produce a non-`Invalid`+result. But since it's not explicitly stated in the types, the calling code will+not be able to know about this, so the compiler's case analyzer might still+require handling the case of `Invalid`.++Using this library, one might instead just do+```haskell+-- Generate an AccessSpecifier in this module using FFI.AccessSpecifier+-- but without the FFI.Invalid constructor.+mkEnum ''FFI.AccessSpecifier ['FFI.Invalid]++accessSpecifier :: HasAccessSpecifier t => Cursor t -> AccessSpecifier+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ enum-subset-generate.cabal view
@@ -0,0 +1,61 @@+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 210be2dcefc78aeda1dc543c2fa846235ed2b84ed1f12a983fd64581e6582774++name: enum-subset-generate+version: 0.1.0.0+synopsis: Generate an ADT being a subset of another ADT, and the corresponding mappings.+description: Please see the README on GitHub at <https://github.com/0xd34df00d/enum-subset-generate#readme>+category: Data+homepage: https://github.com/0xd34df00d/enum-subset-generate#readme+bug-reports: https://github.com/0xd34df00d/enum-subset-generate/issues+author: Georg Rudoy+maintainer: 0xd34df00d@gmail.com+copyright: 2018 Georg Rudoy+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10++extra-source-files:+ ChangeLog.md+ README.md++source-repository head+ type: git+ location: https://github.com/0xd34df00d/enum-subset-generate++library+ hs-source-dirs:+ src+ build-depends:+ base >=4.7 && <5+ , microlens+ , template-haskell+ exposed-modules:+ Data.MakeEnum+ Data.MakeEnum.Options+ other-modules:+ Paths_enum_subset_generate+ default-language: Haskell2010++test-suite enum-subset-generate-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ QuickCheck+ , base >=4.7 && <5+ , enum-subset-generate+ , generic-random+ , hspec+ , microlens+ , template-haskell+ other-modules:+ Enum+ Paths_enum_subset_generate+ default-language: Haskell2010
+ src/Data/MakeEnum.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE LambdaCase, RecordWildCards, ViewPatterns #-}++module Data.MakeEnum(+ makeEnum,+ makeEnumWith,+ ) where++import Control.Monad+import Data.Functor.Identity+import Data.Maybe+import Data.Monoid+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Lens.Micro hiding(filtered)++import Data.MakeEnum.Options++makeEnum :: Name -> [Name] -> Q [Dec]+makeEnum tyName omit = makeEnumWith tyName omit defaultOptions++makeEnumWith :: Name -> [Name] -> Options -> Q [Dec]+makeEnumWith tyName omit options = reify tyName >>= \case+ TyConI (unwrapDec -> Just dec) -> do+ let deducedOpts = deduceOptions dec options+ let (dec', origCons, name) = buildReducedEnum deducedOpts omit' dec+ (fromSig, fromFun) <- buildFromFun deducedOpts name origCons+ (toSig, toFun) <- buildToFun deducedOpts name origCons+ pure [dec', fromSig, fromFun, toSig, toFun]+ _ -> fail "unsupported type"+ where omit' = Just <$> omit++data DataDef = DataDef Cxt Name [TyVarBndr] (Maybe Kind) [Con] [DerivClause]+ deriving (Eq, Ord, Show)++unwrapDec :: Dec -> Maybe DataDef+unwrapDec (DataD cx name bndrs kind cons derivs) = Just $ DataDef cx name bndrs kind cons derivs+unwrapDec _ = Nothing++type DeducedOptions = OptionsT Identity++deduceOptions :: DataDef -> Options -> DeducedOptions+deduceOptions (DataDef _ name _ _ _ _) Options { .. } =+ Options+ { newEnumName = Identity $ fromMaybe (nameBase name) newEnumName+ , fromFunctionName = Identity $ fromMaybe ("from" <> nameBase name) fromFunctionName+ , toFunctionName = Identity $ fromMaybe ("to" <> nameBase name) toFunctionName+ , ..+ }++buildReducedEnum :: DeducedOptions -> [Maybe Name] -> DataDef -> (Dec, [Con], Name)+buildReducedEnum Options { .. } omit (DataDef cx name bndrs kind cons _) = (DataD cx name' bndrs kind cons' derivs, filtered, name)+ where filtered = filter ((`notElem` omit) . (^? nameT)) cons+ cons' = nameT `over` (mkName . ctorNameModifier . nameBase) <$> filtered+ name' = mkName $ runIdentity newEnumName+ derivs = [DerivClause Nothing $ ConT <$> deriveClasses]++buildFromFun :: DeducedOptions -> Name -> [Con] -> Q (Dec, Dec)+buildFromFun Options { .. } name cons = do+ Module _ (ModName thisModName) <- thisModule++ let funName = mkName $ runIdentity fromFunctionName+ let funSig = SigD funName $ ArrowT `AppT` ConT name `AppT` (ConT (mkName "Maybe") `AppT` ConT (mkName $ runIdentity newEnumName))++ clauses <- mapM (mkClause thisModName) cons+ let fallback = Clause [WildP] (NormalB $ ConE $ mkName "Nothing") []+ let funDef = FunD funName $ clauses ++ [fallback]++ pure (funSig, funDef)++ where+ mkClause thisModName (NormalC n ts) = do+ let thisName = mkName $ thisModName <> "." <> ctorNameModifier (nameBase n)+ binders <- replicateM (length ts) $ newName "p"+ let body = NormalB $ ConE (mkName "Just") `AppE` (ConE thisName `foldBinders` binders)+ pure $ Clause [ConP n $ VarP <$> binders] body []+ mkClause _ p = fail $ "this type of constructor is not supported yet:\n" <> pprint p++buildToFun :: DeducedOptions -> Name -> [Con] -> Q (Dec, Dec)+buildToFun Options { .. } name cons = do+ Module _ (ModName thisModName) <- thisModule++ let funName = mkName $ runIdentity toFunctionName+ let funSig = SigD funName $ ArrowT `AppT` ConT (mkName $ runIdentity newEnumName) `AppT` ConT name++ clauses <- mapM (mkClause thisModName) cons+ let funDef = FunD funName clauses++ pure (funSig, funDef)++ where+ mkClause thisModName (NormalC n ts) = do+ let thisName = mkName $ thisModName <> "." <> ctorNameModifier (nameBase n)+ binders <- replicateM (length ts) $ newName "p"+ let body = NormalB $ ConE n `foldBinders` binders+ pure $ Clause [ConP thisName $ VarP <$> binders] body []+ mkClause _ p = fail $ "this type of constructor is not supported yet:\n" <> pprint p++foldBinders :: Exp -> [Name] -> Exp+foldBinders name = foldl AppE name . map VarE++nameT :: Traversal' Con Name+nameT f (NormalC n bts) = (`NormalC` bts) <$> f n+nameT f (RecC n vbts) = (`RecC` vbts) <$> f n+nameT f (InfixC bt1 n bt2) = (\n' -> InfixC bt1 n' bt2) <$> f n+nameT f (ForallC tvbs cx n) = ForallC tvbs cx <$> nameT f n+nameT _ c@GadtC {} = pure c+nameT _ c@RecGadtC {} = pure c
+ src/Data/MakeEnum/Options.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE TemplateHaskell #-}++module Data.MakeEnum.Options(+ OptionsT(..),+ Options,+ defaultOptions+ ) where++import Language.Haskell.TH++data OptionsT f = Options+ { newEnumName :: f String+ , fromFunctionName :: f String+ , toFunctionName :: f String+ , ctorNameModifier :: String -> String+ , deriveClasses :: [Name]+ }++type Options = OptionsT Maybe++defaultOptions :: Options+defaultOptions = Options Nothing Nothing Nothing id [''Eq, ''Ord, ''Show]
+ test/Enum.hs view
@@ -0,0 +1,3 @@+module Enum where++data OtherModuleEnum = OMEUnknown | OMEVar1 | OMEVar2 | OMEVar3 deriving (Eq, Ord, Show)
+ test/Spec.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveGeneric #-}++import Generic.Random+import GHC.Generics(Generic)+import Test.Hspec+import Test.QuickCheck++import Data.MakeEnum+import Data.MakeEnum.Options++import Enum++makeEnumWith ''OtherModuleEnum ['OMEUnknown]+ defaultOptions { newEnumName = Just "OtherModuleEnumDerived"+ , deriveClasses = [''Eq, ''Ord, ''Show, ''Generic]+ }++instance Arbitrary OtherModuleEnumDerived where+ arbitrary = genericArbitrary uniform++data SameModuleEnum = SMEUnknown | SMEVar1 | SMEVar2 | SMEVar3 deriving (Eq, Ord, Show)++makeEnumWith ''SameModuleEnum ['SMEUnknown]+ defaultOptions { newEnumName = Just "SameModuleEnumDerived"+ , ctorNameModifier = ("Der" ++)+ , deriveClasses = [''Eq, ''Ord, ''Show, ''Generic]+ }++instance Arbitrary SameModuleEnumDerived where+ arbitrary = genericArbitrary uniform++data EnumWithFields = EWFVar1 String+ | EWFVar2 Int Int+ | EWFUnknown+ deriving (Eq, Ord, Show)++makeEnumWith ''EnumWithFields ['EWFUnknown]+ defaultOptions { newEnumName = Just "EnumWithFieldsDerived"+ , ctorNameModifier = ("Der" ++)+ , deriveClasses = [''Eq, ''Ord, ''Show, ''Generic]+ }++instance Arbitrary EnumWithFieldsDerived where+ arbitrary = genericArbitrary uniform++runTest :: (Arbitrary d, Eq d, Show d) => String -> s -> (s -> Maybe d) -> (d -> s) -> SpecWith ()+runTest str missing from to = describe str $ do+ it "maps missing cases correctly" $ from missing `shouldBe` Nothing+ it "converts the subset fine" $ property $ \x -> from (to x) == Just x++main :: IO ()+main = hspec $ do+ runTest "OtherModuleEnum" OMEUnknown fromOtherModuleEnum toOtherModuleEnum+ runTest "SameModuleEnum" SMEUnknown fromSameModuleEnum toSameModuleEnum+ runTest "EnumWithFields" EWFUnknown fromEnumWithFields toEnumWithFields