module Data.Object.Dynamic.Type where
import Control.Applicative ((<$>),pure, (<|>))
import qualified Control.Category as Cat ((.))
import Control.Lens
import qualified Control.Monad.RWS as RWS
import Data.Dynamic
import qualified Data.Map as Map
import qualified Data.Set as Set
newtype Object u = Object {unObject :: Table}
instance Objective (Object u) where
table = iso unObject Object
newtype Table = Table {unTable :: TableMap}
type TableMap = Map.Map TypeRep Dynamic
class Objective o where
table :: Simple Iso o Table
tableMap :: Simple Iso o (Map.Map TypeRep Dynamic)
tableMap = table Cat.. (iso unTable Table)
class (Objective o,Typeable memb, Typeable (ValType o memb)) => Member o memb where
type ValType o memb :: *
memberLens :: memb -> MemberLens o memb
memberLens = mkMemberLens
memberLookup :: memb -> Acyclic o (ValType o memb)
memberLookup = mkMemberLookup
type MemberLens o memb = (Member o memb) => Simple Traversal o (ValType o memb)
mkMemberLens ::
(Member o memb)
=> memb
-> MemberLens o memb
mkMemberLens label0 r2ar obj =
case fmap fst $ RWS.evalRWST (memberLookup label0) obj Set.empty of
Just r -> go r
Nothing -> pure obj
where
tbl :: Table
tbl = obj ^. table
key :: TypeRep
key = typeOf label0
go r = (\r' -> obj & over tableMap (Map.insert key (toDyn r')) )
<$> r2ar r
mkMemberLookupDef ::
(Member o memb)
=> memb
-> Acyclic o (ValType o memb)
-> Acyclic o (ValType o memb)
mkMemberLookupDef label0 def0 = do
obj <- RWS.ask
let
tblMap :: TableMap
tblMap = obj ^. tableMap
key :: TypeRep
key = typeOf label0
case (Map.lookup key tblMap >>= fromDynamic) of
Just ret -> RWS.lift $ return ret
Nothing -> do
usedKeys <- RWS.get
case key `Set.member` usedKeys of
True -> RWS.lift $ Nothing
False -> do
RWS.put (key `Set.insert` usedKeys)
ret <- def0
RWS.modify (Set.delete key)
return ret
mkMemberLookup ::
(Member o memb)
=> memb
-> Acyclic o (ValType o memb)
mkMemberLookup label0 = mkMemberLookupDef label0 (RWS.lift Nothing)
insert :: (Objective o, Member o memb, ValType o memb ~ val,
Typeable memb, Typeable val)
=> memb -> val -> o -> o
insert label0 val0 = over tableMap $ Map.insert tag (toDyn val0)
where
tag :: TypeRep
tag = typeOf label0
type Acyclic o a = RWS.RWST o () (Set.Set TypeRep) Maybe a
its :: Member o memb => memb -> Acyclic o (ValType o memb)
its = memberLookup
acyclically ::
(Member o memb)
=> Acyclic o (ValType o memb)
-> memb
-> Acyclic o (ValType o memb)
acyclically = flip mkMemberLookupDef