後からフィールドを追加できるレコード

通常のレコード型は一旦定義したらフィールドを追加したりはできないが、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とかに使えなくもないか