From 127d763a6a68d8fd242e093ba9f55bf769635842 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 15 Mar 2017 20:11:41 +0100
Subject: Make typing many items more efficient

---
 Model.hs | 35 ++++++++++++++++++++++++++++-------
 1 file changed, 28 insertions(+), 7 deletions(-)

(limited to 'Model.hs')

diff --git a/Model.hs b/Model.hs
index 13f18b8..90f5904 100644
--- a/Model.hs
+++ b/Model.hs
@@ -10,6 +10,9 @@ import Control.Monad.Writer
 import           Data.Text   (Text)
 import qualified Data.Text as Text
 
+import           Data.Map   (Map, (!))
+import qualified Data.Map as Map
+
 import qualified Data.HashMap.Lazy as HashMap
 
 import Data.Aeson
@@ -23,19 +26,24 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"]
     $(persistFileWith lowerCaseSettings "config/models")
 
 class HasType a where
-  getType :: ( BaseBackend backend ~ SqlBackend
-             , MonadIO m
-             , PersistStoreRead backend
-             ) => a -> ReaderT backend m Kind
+  fkType :: a -> Key Kind
+  
+getType :: ( BaseBackend backend ~ SqlBackend
+           , MonadIO m
+           , PersistStoreRead backend
+           , HasType a
+           ) => a -> ReaderT backend m Kind
+getType = getJust . fkType
 
 instance HasType Item where
-  getType = belongsToJust itemFkType
+  fkType = itemFkType
 
 instance HasType Reference where
-  getType = belongsToJust referenceFkType
+  fkType = referenceFkType
 
 instance HasType a => HasType (Entity a) where
-  getType Entity{..} = getType entityVal
+  fkType = fkType . entityVal
+    
 
 withType :: ( BaseBackend backend ~ SqlBackend
             , MonadIO m
@@ -44,6 +52,19 @@ withType :: ( BaseBackend backend ~ SqlBackend
             ) => a -> ReaderT backend m (WithType a)
 withType val = (val `WithType`) . kindType <$> getType val
 
+withTypes :: ( BaseBackend backend ~ SqlBackend
+             , MonadIO m
+             , PersistStoreRead backend
+             , PersistQueryRead backend
+             , HasType a
+             , Functor f
+             ) => f a -> ReaderT backend m (f (WithType a))
+withTypes vals = do
+  typeMap <- Map.fromList . map (\(Entity kindKey kind) -> (kindKey, kind)) <$> selectList [] []
+  let
+    lookupType x = (x `WithType`) . kindType $ typeMap ! fkType x
+  return $ lookupType <$> vals
+
 instance Ord Item where
   x `compare` y = mconcat cmprs
     where
-- 
cgit v1.2.3