never executed always true always false
    1 {-|
    2 Module: Flaw.Editor.EditableEntity
    3 Description: Class for defining layout to edit entities.
    4 License: MIT
    5 -}
    6 
    7 {-# LANGUAGE DefaultSignatures, FlexibleContexts, FlexibleInstances, OverloadedStrings, RankNTypes, TemplateHaskell, TypeFamilies, TypeOperators #-}
    8 
    9 module Flaw.Editor.EditableEntity
   10   ( EditableLayoutState(..)
   11   , EditableLayoutM
   12   , EditableEntity(..)
   13   , editableLayoutForEntityId
   14   ) where
   15 
   16 import Control.Concurrent.STM
   17 import Control.Monad.Reader
   18 import qualified Data.Text as T
   19 import qualified GHC.Generics as G
   20 
   21 import Flaw.Book
   22 import Flaw.Editor.Entity
   23 import Flaw.Flow
   24 import Flaw.UI.Layout
   25 import Flaw.UI.Popup
   26 
   27 data EditableLayoutState = EditableLayoutState
   28   { elsFlow :: !Flow
   29   , elsBook :: !Book
   30   , elsEntityManager :: !EntityManager
   31   , elsPopupService :: !PopupService
   32   }
   33 
   34 type EditableLayoutM = ReaderT EditableLayoutState FlowLayoutM
   35 
   36 -- | Value able to be edited in editor.
   37 class Entity a => EditableEntity a where
   38   -- | Get editable entity's type name.
   39   editableEntityTypeName :: a -> T.Text
   40   default editableEntityTypeName :: (G.Generic a, GenericEditableDatatype (G.Rep a)) => a -> T.Text
   41   editableEntityTypeName = genericEditableDatatypeName . G.from
   42 
   43   -- | Get editable entity's constructor name.
   44   editableEntityConstructorName :: a -> T.Text
   45   default editableEntityConstructorName :: (G.Generic a, G.Rep a ~ G.M1 G.D c f, GenericEditableConstructor f) => a -> T.Text
   46   editableEntityConstructorName = genericEditableConstructorName . G.unM1 . G.from
   47 
   48   -- | Get editable entity's layout.
   49   editableEntityLayout :: a -> (EntityChange a -> STM ()) -> EditableLayoutM (a -> EntityChange a -> STM ())
   50   default editableEntityLayout :: (G.Generic a, GenericEditableDatatype (G.Rep a), EntityChange a ~ GenericEntityChange a) => a -> (EntityChange a -> STM ()) -> EditableLayoutM (a -> EntityChange a -> STM ())
   51   editableEntityLayout initialEntity setter = (. G.from) <$> genericEditableDatatypeLayout (G.from initialEntity) setter
   52 
   53 instance EntityInterface EditableEntity where
   54   getEntityInterfaceId _ = $(hashTextToEntityInterfaceId "EditableEntity")
   55 
   56 class GenericEntityDatatype f => GenericEditableDatatype f where
   57   genericEditableDatatypeName :: f p -> T.Text
   58   genericEditableDatatypeLayout :: f p -> (GenericEntityDatatypeChange f -> STM ()) -> EditableLayoutM (f p -> GenericEntityDatatypeChange f -> STM ())
   59 
   60 class GenericEntityConstructor f => GenericEditableConstructor f where
   61   genericEditableConstructorName :: f p -> T.Text
   62   genericEditableConstructorLayout :: f p -> (GenericEntityConstructorChange f -> STM ()) -> EditableLayoutM (f p -> GenericEntityConstructorChange f -> STM ())
   63 
   64 class GenericEntitySelector f => GenericEditableSelector f where
   65   genericEditableSelectorLayout :: f p -> (GenericEntitySelectorChange f -> STM ()) -> EditableLayoutM (f p -> GenericEntitySelectorChange f -> STM ())
   66 
   67 class GenericEntityValue f => GenericEditableValue f where
   68   genericEditableValueLayout :: f p -> (GenericEntityValueChange f -> STM ()) -> EditableLayoutM (f p -> GenericEntityValueChange f -> STM ())
   69 
   70 -- datatype metadata
   71 instance (G.Datatype c, GenericEditableConstructor f) => GenericEditableDatatype (G.M1 G.D c f) where
   72   genericEditableDatatypeName = T.pack . G.datatypeName
   73   genericEditableDatatypeLayout initialEntity setter = do
   74     lift $ titleInFlowLayout $ genericEditableDatatypeName initialEntity
   75     (. G.unM1) <$> genericEditableConstructorLayout (G.unM1 initialEntity) setter
   76   {-# INLINEABLE genericEditableDatatypeLayout #-}
   77 
   78 -- constructor metadata
   79 instance (G.Constructor c, GenericEditableSelector f) => GenericEditableConstructor (G.M1 G.C c f) where
   80   genericEditableConstructorName = T.pack . G.conName
   81   genericEditableConstructorLayout initialEntity setter = (. G.unM1) <$> genericEditableSelectorLayout (G.unM1 initialEntity) setter
   82   {-# INLINEABLE genericEditableConstructorLayout #-}
   83 
   84 -- selector metadata
   85 instance (G.Selector c, GenericEditableValue f) => GenericEditableSelector (G.M1 G.S c f) where
   86   genericEditableSelectorLayout initialEntity setter = ReaderT $ \s -> let
   87     sublayout = runReaderT (genericEditableValueLayout (G.unM1 initialEntity) setter) s
   88     in (. G.unM1) <$> labeledFlowLayout (T.pack $ G.selName initialEntity) sublayout
   89   {-# INLINEABLE genericEditableSelectorLayout #-}
   90 
   91 -- constructor sum metadata
   92 -- instance GenericEditableConstructor (a G.:+: b)
   93 -- We are yet to support multiple constructors, because a way to switch
   94 -- multiple UIs for different constructors (tabs? combobox?) is not implemented yet.
   95 
   96 -- selector sum metadata
   97 instance (GenericEditableSelector a, GenericEditableSelector b) => GenericEditableSelector (a G.:*: b) where
   98   genericEditableSelectorLayout (a G.:*: b) setter = do
   99     update1 <- genericEditableSelectorLayout a (setter . Left)
  100     update2 <- genericEditableSelectorLayout b (setter . Right)
  101     return $ \(na G.:*: nb) change -> case change of
  102       Left l -> update1 na l
  103       Right r -> update2 nb r
  104   {-# INLINEABLE genericEditableSelectorLayout #-}
  105 
  106 -- value
  107 instance (BasicEntity a, EditableEntity a) => GenericEditableValue (G.K1 G.R a) where
  108   genericEditableValueLayout initialEntity setter = (. G.unK1) <$> editableEntityLayout (G.unK1 initialEntity) setter
  109   {-# INLINEABLE genericEditableValueLayout #-}
  110 
  111 -- | Create editable layout watching at specified entity id.
  112 editableLayoutForEntityId :: EditableLayoutState -> EntityId -> (forall a. FlowLayoutM a -> STM a) -> IO ()
  113 editableLayoutForEntityId s@EditableLayoutState
  114   { elsBook = bk
  115   , elsEntityManager = entityManager
  116   } entityId makeLayout = do
  117   someEntityVar <- getSomeEntityVar entityManager entityId
  118 
  119   -- every time entity changes its type, initForEntityType is called
  120   -- it allocates flow and other stuff for watching entity's history
  121   -- while it's of the given type
  122   dbk <- book bk newDynamicBook
  123   let
  124     initForEntityType = join $ atomically $ do -- STM monad
  125       SomeEntity initialEntity <- readSomeEntityVar someEntityVar
  126       let
  127         getInitialEntityVar :: a -> EntityVar a
  128         getInitialEntityVar _ = EntityVar someEntityVar
  129         entityVar = getInitialEntityVar initialEntity
  130       entityHistoryChan <- entityVarHistory entityVar
  131       return $ do -- IO monad
  132         -- make layout for entity if it's editable
  133         updateLayout <- case interfaceEntity (Proxy :: Proxy EditableEntity) initialEntity of
  134           EntityInterfaced -> atomically $ makeLayout $ runReaderT (editableEntityLayout initialEntity (applyEntityChange entityVar)) s
  135             { elsBook = dbk
  136             }
  137           EntityNotInterfaced -> return $ \_ _ -> return () -- empty layout
  138         book dbk $ forkFlow $ forever $ do
  139           m <- atomically $ catchSTM (Just <$> readEntityHistoryChan entityHistoryChan) $ \EntityWrongTypeException -> return Nothing
  140           case m of
  141             Just (newEntity, entityChange) -> atomically $ updateLayout newEntity entityChange
  142             Nothing -> do
  143               -- run new init
  144               rdbk <- releaseBook dbk
  145               initForEntityType
  146               -- kill itself
  147               rdbk
  148     in initForEntityType