summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGregor Kleen <gkleen@yggdrasil.li>2017-03-15 20:12:46 +0100
committerGregor Kleen <gkleen@yggdrasil.li>2017-03-15 20:12:46 +0100
commit3ed9ec8ca70afb556f75d4e087043f4c67f50974 (patch)
treedbc7e2d17e87d89bb5fd80c7592e4e7de582e815
parent7888d76bc45caed34cb3aa10824807d01057d746 (diff)
parent127d763a6a68d8fd242e093ba9f55bf769635842 (diff)
downloadbar-3ed9ec8ca70afb556f75d4e087043f4c67f50974.tar
bar-3ed9ec8ca70afb556f75d4e087043f4c67f50974.tar.gz
bar-3ed9ec8ca70afb556f75d4e087043f4c67f50974.tar.bz2
bar-3ed9ec8ca70afb556f75d4e087043f4c67f50974.tar.xz
bar-3ed9ec8ca70afb556f75d4e087043f4c67f50974.zip
Merge branch 'feat/optimizeTypes'
-rw-r--r--Handler/InventoryListing.hs2
-rw-r--r--Handler/ReferenceListing.hs2
-rw-r--r--Handler/UpdateItem.hs2
-rw-r--r--Model.hs35
-rw-r--r--bar.cabal2
-rw-r--r--bar.nix14
6 files changed, 39 insertions, 18 deletions
diff --git a/Handler/InventoryListing.hs b/Handler/InventoryListing.hs
index cbf4eab..c2ec5d1 100644
--- a/Handler/InventoryListing.hs
+++ b/Handler/InventoryListing.hs
@@ -16,7 +16,7 @@ postInventoryListingR = do
16 FormFailure errors -> mapM_ (addMessage "formError" . toHtml) errors 16 FormFailure errors -> mapM_ (addMessage "formError" . toHtml) errors
17 _ -> return () 17 _ -> return ()
18 18
19 (stockSort -> stock) <- runDB $ mapM withType =<< selectList [] [] 19 (stockSort -> stock) <- runDB $ withTypes =<< selectList [] []
20 20
21 selectRep $ do 21 selectRep $ do
22 provideJson (stock :: [WithType (Entity Item)]) 22 provideJson (stock :: [WithType (Entity Item)])
diff --git a/Handler/ReferenceListing.hs b/Handler/ReferenceListing.hs
index e433429..690f3f7 100644
--- a/Handler/ReferenceListing.hs
+++ b/Handler/ReferenceListing.hs
@@ -17,7 +17,7 @@ postReferenceListingR = do
17 FormFailure errors -> mapM_ (addMessage "formError" . toHtml) errors 17 FormFailure errors -> mapM_ (addMessage "formError" . toHtml) errors
18 _ -> return () 18 _ -> return ()
19 19
20 (referenceSort -> reference) <- runDB $ mapM withType =<< selectList [] [Asc ReferenceKind] 20 (referenceSort -> reference) <- runDB $ withTypes =<< selectList [] [Asc ReferenceKind]
21 21
22 selectRep $ do 22 selectRep $ do
23 provideJson (reference :: [WithType (Entity Reference)]) 23 provideJson (reference :: [WithType (Entity Reference)])
diff --git a/Handler/UpdateItem.hs b/Handler/UpdateItem.hs
index 503d8ca..b4c8713 100644
--- a/Handler/UpdateItem.hs
+++ b/Handler/UpdateItem.hs
@@ -28,7 +28,7 @@ postUpdateItemR fsUpdateId = do
28 provideRep $ case updateResult of 28 provideRep $ case updateResult of
29 FormSuccess _ -> redirect $ InventoryListingR :#: fsUpdateId :: Handler Html 29 FormSuccess _ -> redirect $ InventoryListingR :#: fsUpdateId :: Handler Html
30 _ -> do 30 _ -> do
31 (stockSort -> stock) <- runDB $ mapM withType =<< selectList [] [] 31 (stockSort -> stock) <- runDB $ withTypes =<< selectList [] []
32 defaultLayout $ inventoryListing InventoryState 32 defaultLayout $ inventoryListing InventoryState
33 { invFormState = Just UpdateForm{..} 33 { invFormState = Just UpdateForm{..}
34 , .. 34 , ..
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
10import Data.Text (Text) 10import Data.Text (Text)
11import qualified Data.Text as Text 11import qualified Data.Text as Text
12 12
13import Data.Map (Map, (!))
14import qualified Data.Map as Map
15
13import qualified Data.HashMap.Lazy as HashMap 16import qualified Data.HashMap.Lazy as HashMap
14 17
15import Data.Aeson 18import Data.Aeson
@@ -23,19 +26,24 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"]
23 $(persistFileWith lowerCaseSettings "config/models") 26 $(persistFileWith lowerCaseSettings "config/models")
24 27
25class HasType a where 28class HasType a where
26 getType :: ( BaseBackend backend ~ SqlBackend 29 fkType :: a -> Key Kind
27 , MonadIO m 30
28 , PersistStoreRead backend 31getType :: ( BaseBackend backend ~ SqlBackend
29 ) => a -> ReaderT backend m Kind 32 , MonadIO m
33 , PersistStoreRead backend
34 , HasType a
35 ) => a -> ReaderT backend m Kind
36getType = getJust . fkType
30 37
31instance HasType Item where 38instance HasType Item where
32 getType = belongsToJust itemFkType 39 fkType = itemFkType
33 40
34instance HasType Reference where 41instance HasType Reference where
35 getType = belongsToJust referenceFkType 42 fkType = referenceFkType
36 43
37instance HasType a => HasType (Entity a) where 44instance HasType a => HasType (Entity a) where
38 getType Entity{..} = getType entityVal 45 fkType = fkType . entityVal
46
39 47
40withType :: ( BaseBackend backend ~ SqlBackend 48withType :: ( BaseBackend backend ~ SqlBackend
41 , MonadIO m 49 , MonadIO m
@@ -44,6 +52,19 @@ withType :: ( BaseBackend backend ~ SqlBackend
44 ) => a -> ReaderT backend m (WithType a) 52 ) => a -> ReaderT backend m (WithType a)
45withType val = (val `WithType`) . kindType <$> getType val 53withType val = (val `WithType`) . kindType <$> getType val
46 54
55withTypes :: ( BaseBackend backend ~ SqlBackend
56 , MonadIO m
57 , PersistStoreRead backend
58 , PersistQueryRead backend
59 , HasType a
60 , Functor f
61 ) => f a -> ReaderT backend m (f (WithType a))
62withTypes vals = do
63 typeMap <- Map.fromList . map (\(Entity kindKey kind) -> (kindKey, kind)) <$> selectList [] []
64 let
65 lookupType x = (x `WithType`) . kindType $ typeMap ! fkType x
66 return $ lookupType <$> vals
67
47instance Ord Item where 68instance Ord Item where
48 x `compare` y = mconcat cmprs 69 x `compare` y = mconcat cmprs
49 where 70 where
diff --git a/bar.cabal b/bar.cabal
index 112a89d..5003000 100644
--- a/bar.cabal
+++ b/bar.cabal
@@ -1,5 +1,5 @@
1name: bar 1name: bar
2version: 0.0.0 2version: 0.1.0
3cabal-version: >= 1.8 3cabal-version: >= 1.8
4build-type: Simple 4build-type: Simple
5 5
diff --git a/bar.nix b/bar.nix
index 7fb7da0..714ee94 100644
--- a/bar.nix
+++ b/bar.nix
@@ -4,13 +4,13 @@
4, file-embed, hjsmin, http-conduit, lens, monad-control 4, file-embed, hjsmin, http-conduit, lens, monad-control
5, monad-logger, mtl, persistent, persistent-postgresql 5, monad-logger, mtl, persistent, persistent-postgresql
6, persistent-template, safe, shakespeare, stdenv, template-haskell 6, persistent-template, safe, shakespeare, stdenv, template-haskell
7, text, thermoprint-client, thermoprint-spec, time 7, text, thermoprint-client, time, unordered-containers, vector, wai
8, unordered-containers, vector, wai, wai-extra, wai-logger, warp 8, wai-extra, wai-logger, warp, yaml, yesod, yesod-auth, yesod-core
9, yaml, yesod, yesod-auth, yesod-core, yesod-form, yesod-static 9, yesod-form, yesod-static
10}: 10}:
11mkDerivation { 11mkDerivation {
12 pname = "bar"; 12 pname = "bar";
13 version = "0.0.0"; 13 version = "0.1.0";
14 src = ./.; 14 src = ./.;
15 isLibrary = true; 15 isLibrary = true;
16 isExecutable = true; 16 isExecutable = true;
@@ -20,9 +20,9 @@ mkDerivation {
20 data-default directory fast-logger file-embed hjsmin http-conduit 20 data-default directory fast-logger file-embed hjsmin http-conduit
21 lens monad-control monad-logger mtl persistent 21 lens monad-control monad-logger mtl persistent
22 persistent-postgresql persistent-template safe shakespeare 22 persistent-postgresql persistent-template safe shakespeare
23 template-haskell text thermoprint-client thermoprint-spec time 23 template-haskell text thermoprint-client time unordered-containers
24 unordered-containers vector wai wai-extra wai-logger warp yaml 24 vector wai wai-extra wai-logger warp yaml yesod yesod-auth
25 yesod yesod-auth yesod-core yesod-form yesod-static 25 yesod-core yesod-form yesod-static
26 ]; 26 ];
27 executableHaskellDepends = [ base ]; 27 executableHaskellDepends = [ base ];
28 doHaddock = false; 28 doHaddock = false;