├── .gitignore ├── Dump.hs ├── LICENSE ├── Menu.hs ├── README.md ├── Test.hs ├── generics.cabal └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | *.sw[pon] 2 | *.o 3 | *.so 4 | cabal.sandbox.config 5 | .cabal-sandbox 6 | dist/ 7 | *.hi 8 | *.o 9 | includes 10 | *.html 11 | *.epub 12 | *.agdai 13 | .stack-work 14 | *.db 15 | -------------------------------------------------------------------------------- /Dump.hs: -------------------------------------------------------------------------------- 1 | module Dump where 2 | 3 | import GHC 4 | import GHC.Paths as Paths 5 | 6 | import Name 7 | import TyCon 8 | import TypeRep 9 | import DataCon 10 | import HscTypes 11 | 12 | import Text.Show.Pretty 13 | 14 | -- Deconstructed datatypes. 15 | 16 | data Datatype = Datatype 17 | { dataTypeName :: String 18 | , modName :: String 19 | , isNewtype :: Bool 20 | , datatype :: Data 21 | , recursive :: Bool 22 | } deriving (Show) 23 | 24 | data Constructor = Constructor 25 | { conName :: String 26 | } deriving (Show) 27 | 28 | data Selector = Selector 29 | { selName :: String 30 | } deriving (Show) 31 | 32 | data Metadata 33 | = D Datatype 34 | | C Constructor 35 | | S Selector Data 36 | deriving (Show) 37 | 38 | data Data 39 | = Sum [Data] 40 | | Product [Data] 41 | | M1 Metadata 42 | | K1 String 43 | | V1 44 | deriving (Show) 45 | 46 | -- Deconstructor 47 | 48 | deconstruct :: [TyCon] -> [Data] 49 | deconstruct = fmap go 50 | where 51 | go x 52 | | isProduct x = M1 $ D Datatype 53 | { dataTypeName = getOccString (tyConName x) 54 | , modName = modString x 55 | , isNewtype = isNewTyCon x 56 | , datatype = Product (mkProduct x) 57 | , recursive = isRecursiveTyCon x 58 | } 59 | 60 | | isVoid x = M1 $ D Datatype 61 | { dataTypeName = getOccString (tyConName x) 62 | , modName = modString x 63 | , isNewtype = isNewTyCon x 64 | , datatype = V1 65 | , recursive = isRecursiveTyCon x 66 | } 67 | 68 | | otherwise = M1 $ D Datatype 69 | { dataTypeName = getOccString (tyConName x) 70 | , modName = modString x 71 | , isNewtype = isNewTyCon x 72 | , datatype = Sum (mkProduct x) 73 | , recursive = isRecursiveTyCon x 74 | } 75 | 76 | mkRecord :: TyCon -> [Data] 77 | mkRecord x = concatMap mkRProduct (tyConDataCons x) 78 | 79 | mkProduct :: TyCon -> [Data] 80 | mkProduct x = fmap go (tyConDataCons x) 81 | where 82 | go :: DataCon -> Data 83 | go x | isRecord x = Product (mkRProduct x) 84 | go x | isDProduct x = Product (mkDProduct x) 85 | go x = M1 $ C (Constructor (conNames x)) 86 | 87 | mkDProduct :: DataCon -> [Data] 88 | mkDProduct xs = [K1 (showType x) | x <- dataConOrigArgTys xs] 89 | 90 | mkRProduct :: DataCon -> [Data] 91 | mkRProduct x = [M1 (S (Selector (getOccString fld)) ty) | (fld, ty) <- zip (fieldNames x) (mkDProduct x)] 92 | 93 | modString :: TyCon -> String 94 | modString = moduleNameString . moduleName . nameModule . tyConName 95 | 96 | showType :: Type -> String 97 | showType (TyVarTy tv) = getOccString tv 98 | showType (TyConApp tc tys) = getOccString tc 99 | showType (FunTy a b) = showType a ++ "->" ++ showType b 100 | showType (AppTy a b) = showType a ++ " " ++ showType b 101 | showType (ForAllTy _ a) = showType a 102 | 103 | fieldNames :: DataCon -> [FieldLabel] 104 | fieldNames = dataConFieldLabels 105 | 106 | conNames :: DataCon -> String 107 | conNames = getOccString . dataConName 108 | 109 | isRecord :: DataCon -> Bool 110 | isRecord x = length (fieldNames x) > 0 111 | 112 | isProduct :: TyCon -> Bool 113 | isProduct = isProductTyCon 114 | 115 | isDProduct :: DataCon -> Bool 116 | isDProduct x = dataConRepArity x > 0 117 | 118 | isVoid :: TyCon -> Bool 119 | isVoid x = length (tyConDataCons x) == 0 120 | 121 | main :: IO () 122 | main = do 123 | 124 | -- Inside the GHC Monad 125 | rep <- runGhc (Just Paths.libdir) $ do 126 | 127 | -- Spin up a GHC compiler environment 128 | dflags <- getSessionDynFlags 129 | setSessionDynFlags dflags 130 | 131 | -- Make a dummy module to inject 132 | let mn = mkModuleName "Test" 133 | 134 | -- Make a dummy target 135 | addTarget Target { 136 | targetId = TargetModule mn 137 | , targetAllowObjCode = True 138 | , targetContents = Nothing 139 | } 140 | 141 | -- Run the GHC pipeline 142 | load LoadAllTargets 143 | modSum <- getModSummary mn 144 | p <- parseModule modSum 145 | t <- typecheckModule p 146 | 147 | -- Pluck out the module tycons after we're done type-checking 148 | DesugaredModule tcmod modguts <- desugarModule t 149 | let tycons = mg_tcs modguts 150 | 151 | -- Deconstruct all datatypes into their sums-of-products. 152 | return (deconstruct tycons) 153 | 154 | putStrLn (ppShow rep) 155 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Stephen Diehl (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Menu.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PolyKinds #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DeriveAnyClass #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE DefaultSignatures #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | 10 | module Menu where 11 | 12 | import Data.Text 13 | import Data.Proxy 14 | import GHC.Generics 15 | 16 | import Text.Show.Pretty (ppShow) 17 | 18 | -- Datatypes 19 | 20 | data Pie = Pie 21 | { filling :: Filling 22 | , topping :: Maybe Topping 23 | } deriving (Show, Generic, Menu) 24 | 25 | data Crisp = Crisp 26 | { contents :: Filling 27 | , temperature :: Temperature 28 | } deriving (Show, Generic, Menu) 29 | 30 | data Filling = Apple | Cherry | Pumpkin 31 | deriving (Show, Generic, Menu) 32 | 33 | data Topping = IceCream | WhipCream 34 | deriving (Show, Generic, Menu) 35 | 36 | data Temperature = Warm | Cold 37 | deriving (Show, Generic, Menu) 38 | 39 | data Item 40 | = Item Text [Item] 41 | | Variant Text [Item] 42 | | Choice Text 43 | deriving (Show, Generic) 44 | 45 | 46 | -- Menu Classes 47 | 48 | class Menu a where 49 | menu :: a -> [Item] 50 | default menu :: (Generic a, GMenu (Rep a)) => a -> [Item] 51 | menu _ = gmenu (Proxy :: Proxy a) 52 | 53 | 54 | instance Menu a => Menu (Maybe a) where 55 | menu _ = [Choice (pack "AsIs")] ++ (menu (undefined :: a)) 56 | 57 | instance Menu a => Menu [a] where 58 | menu _ = (menu (undefined :: a)) 59 | 60 | instance (Menu a, Menu b) => Menu (a,b) where 61 | menu _ = menu (undefined :: a) ++ menu (undefined :: b) 62 | 63 | -- Generic Menu 64 | class GMenu a where 65 | gopts :: Proxy a -> [Item] 66 | 67 | -- Datatype 68 | instance GMenu f => GMenu (M1 D x f) where 69 | gopts _ = gopts (Proxy :: Proxy f) 70 | 71 | -- Constructor Metadata 72 | instance (GMenu f, Constructor c) => GMenu (M1 C c f) where 73 | gopts x 74 | | conIsRecord (undefined :: t c f a) = 75 | [Item (pack (conName m)) (gopts (Proxy :: Proxy f))] 76 | 77 | | otherwise = [Choice (pack (conName m))] 78 | where m = (undefined :: t c f a) 79 | 80 | -- Selector Metadata 81 | instance (GMenu f, Selector c) => GMenu (M1 S c f) where 82 | gopts _ = [Variant (pack (selName m)) (gopts (Proxy :: Proxy f))] 83 | where m = (undefined :: t c f a) 84 | 85 | -- Constructor Paramater 86 | instance (GMenu (Rep f), Menu f) => GMenu (K1 R f) where 87 | gopts _ = menu (undefined :: f) 88 | 89 | -- Sum branch 90 | instance (GMenu a, GMenu b) => GMenu (a :+: b) where 91 | gopts _ = gopts (Proxy :: Proxy a) ++ gopts (Proxy :: Proxy b) 92 | 93 | -- Product branch 94 | instance (GMenu a, GMenu b) => GMenu (a :*: b) where 95 | gopts _ = gopts (Proxy :: Proxy a) ++ gopts (Proxy :: Proxy b) 96 | 97 | -- Void branch 98 | instance GMenu U1 where 99 | gopts _ = [] 100 | 101 | gmenu :: forall a. (Generic a, GMenu (Rep a)) => Proxy a -> [Item] 102 | gmenu _ = gopts (Proxy :: Proxy (Rep a)) 103 | 104 | sample1 :: IO () 105 | sample1 = putStrLn $ ppShow $ menu (undefined :: Pie) 106 | 107 | sample2 :: IO () 108 | sample2 = putStrLn $ ppShow $ menu (undefined :: (Pie, Crisp)) 109 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Cooking Classes With Datatype Generic Programming 2 | ================================================ 3 | 4 | ```haskell 5 | $ stack repl 6 | 7 | Prelude> :load Dump.hs 8 | Dump> main 9 | 10 | Prelude> :load Menu.hs 11 | Menu> sample1 12 | Menu> sample2 13 | ``` 14 | -------------------------------------------------------------------------------- /Test.hs: -------------------------------------------------------------------------------- 1 | module Test where 2 | 3 | data PlatonicSolid 4 | = Tetrahedron 5 | | Cube 6 | | Octahedron 7 | | Dodecahedron 8 | | Icosahedron 9 | 10 | data Person = Person 11 | { firstName :: String 12 | , lastName :: String 13 | , age :: Int 14 | , height :: Float 15 | , phoneNumber :: String 16 | , flavor :: String 17 | } deriving (Show) 18 | 19 | data Point a b = Point a b 20 | 21 | data T 22 | = T1 { a :: Int, b :: Float } 23 | | T2 { c :: Int, d :: Double } 24 | 25 | data Hash a b = a :. b 26 | 27 | data List a = Nil | Cons a (List a) 28 | 29 | newtype Meters = Meters Int 30 | 31 | newtype Id x = MkId x 32 | newtype Fix f = MkFix (f (Fix f)) 33 | 34 | data Void 35 | -------------------------------------------------------------------------------- /generics.cabal: -------------------------------------------------------------------------------- 1 | name: generics 2 | version: 0.1.2 3 | license: MIT 4 | license-file: LICENSE 5 | author: Stephen Diehl 6 | maintainer: stephen.m.diehl@gmail.com 7 | copyright: 2016 Stephen Diehl 8 | category: Generics 9 | build-type: Simple 10 | cabal-version: >=1.10 11 | tested-with: GHC == 7.6.3 12 | 13 | library 14 | exposed-modules: 15 | Dump 16 | Menu 17 | 18 | build-depends: 19 | base >= 4.6 && <4.10, 20 | ghc >= 7.10 && < 8.1, 21 | ghc-paths >= 0.1 && <0.2, 22 | text -any, 23 | pretty-show -any, 24 | directory -any 25 | 26 | default-language: Haskell2010 27 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-4.2 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - '.' 9 | 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: [] 12 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Extra package databases containing global packages 17 | extra-package-dbs: [] 18 | 19 | # Control whether we use the GHC we find on the path 20 | # system-ghc: true 21 | 22 | # Require a specific version of stack, using version ranges 23 | # require-stack-version: -any # Default 24 | # require-stack-version: >= 0.1.4.0 25 | 26 | # Override the architecture used by stack, especially useful on Windows 27 | # arch: i386 28 | # arch: x86_64 29 | 30 | # Extra directories used by stack for building 31 | # extra-include-dirs: [/path/to/dir] 32 | # extra-lib-dirs: [/path/to/dir] 33 | --------------------------------------------------------------------------------