後からフィールドを追加できるレコード
通常のレコード型は一旦定義したらフィールドを追加したりはできないが、Template Haskellを使えば似たようなことができるのに気付いたので書いてみた。
次のように使う。
{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveDataTypeable #-} import OpenProduct defineOpenProduct "Foo" -- レコード型Fooを定義する defineOpField [t|Foo|] "FieldA" [t|Int|] [|0|] -- FooのフィールドとしてFieldAを定義する -- 型はIntで初期値は0 x :: Foo x = opSetField FieldA 4 opEmpty -- x = Foo{ fieldA = 4 } みたいな感じ defineOpField [t|Foo|] "FieldB" [t|Maybe String|] [|Nothing|] -- FooのフィールドとしてFieldBを定義する -- 型はMaybe Stringで初期値はNothing y :: Foo y = opSetField FieldB (Just "y") x -- y = x{ fieldB = Just "y" } みたいな感じ main = do print $ opGetField FieldA x -- 4 print $ opGetField FieldB x -- Nothing print $ opGetField FieldA y -- 4 print $ opGetField FieldB y -- Just "y"
実装は以下。
{-# LANGUAGE TypeFamilies, GADTs, FlexibleContexts #-} {-# OPTIONS_GHC -Wall #-} module OpenProduct ( OpenProduct -- abstract! , OPField -- abstract! , opEmpty , opGetField , opSetField , (%<) , (%=) , defineOpenProduct , defineOpField ) where import Control.Applicative import qualified Data.Map as M import Data.Maybe import Data.Typeable import GHC.Exts (Any) import Language.Haskell.TH import Unsafe.Coerce -- | 開レコードのクラス class OpenProduct a -- 全ての開レコードはこの型のnewtypeになる type OpRep = M.Map TypeRep Any toOpRep :: (OpenProduct a) => a -> OpRep toOpRep = unsafeCoerce fromOpRep :: (OpenProduct a) => OpRep -> a fromOpRep = unsafeCoerce -- | 空の開レコード opEmpty :: (OpenProduct a) => a opEmpty = fromOpRep M.empty -- | 開レコードのフィールドのクラス class (OpenProduct (OPContaining f)) => OPField f where type OPFieldType f -- ^ フィールドfの型 type OPContaining f -- ^ フィールドfを含む開レコードの型 opfKey :: f -> TypeRep opfDefaultValue :: f -> OPFieldType f -- | 開レコードのフィールドを読む opGetField, (%<) :: (OPField f) => f -> OPContaining f -> OPFieldType f opGetField fld rec = fromMaybe (opfDefaultValue fld) $ unsafeCoerce $ M.lookup (opfKey fld) $ toOpRep rec (%<) = opGetField -- | 開レコードのフィールドを更新する opSetField, (%=) :: (OPField f) => f -> OPFieldType f -> OPContaining f -> OPContaining f opSetField fld val rec = fromOpRep $ M.insert (opfKey fld) (unsafeCoerce val) $ toOpRep rec (%=) = opSetField ---- ここからマクロ ---- -- | 開レコードを定義する defineOpenProduct :: String -> Q [Dec] -- defineOpenProduct "Foo" => -- newtype Foo = Fooabc OpRep -- instance OpenProduct Foo defineOpenProduct nameS = do conName <- newName nameS return [ NewtypeD [] name [] (con conName) [] , InstanceD [] (AppT (ConT ''OpenProduct) (ConT name)) [] ] where name = mkName nameS con conName = NormalC conName [(NotStrict, ConT ''OpRep)] -- | フィールドを定義する defineOpField :: TypeQ -> String -> TypeQ -> ExpQ -> Q [Dec] -- defineOpField [t|Foo|] "Fld" [t|Int|] [|4|] => -- data Fld = Fld -- deriving (Typeable) -- instance OPField Fld where -- type OPFieldType Fld = Int -- type OPContaining Fld = Foo -- opfKey = typeOf -- opfDefaultValue = \_ -> 4 defineOpField recType nameS fldType defexp = sequence [ dataD (pure []) name [] [normalC name []] [''Typeable] , instanceD (pure []) (appT (conT ''OPField) (conT name)) [ tySynInstD ''OPFieldType [conT name] fldType , tySynInstD ''OPContaining [conT name] recType , valD (varP 'opfKey) (normalB $ varE 'typeOf) [] , valD (varP 'opfDefaultValue) (normalB $ lamE [wildP] defexp) [] ] ] where name = mkName nameS
使いみちはなんだろう。モナディックな関数のメモ化とか、packrat parsingとかに使えなくもないか