Merge remote-tracking branch 'origin/master' into feat/exercises

src/Foundation.hs

@@ -48,11 +48,11 @@ import Data.Conduit (($$))
 import Data.Conduit.List (sourceList)
 
 import Control.Monad.Except (MonadError(..), runExceptT)
-import Handler.Utils.StudyFeatures
 
 import System.FilePath
 
 import Handler.Utils.Templates
+import Handler.Utils.StudyFeatures
 
 -- infixl 9 :$:
 -- pattern a :$: b = a b

src/Handler/Utils.hs

@@ -10,8 +10,6 @@ module Handler.Utils
 
 
 
-import Import.NoFoundation
-  
 import Handler.Utils.DateTime as Handler.Utils
 import Handler.Utils.Term as Handler.Utils
 import Handler.Utils.Form as Handler.Utils
@@ -22,108 +20,3 @@ import Handler.Utils.Zip as Handler.Utils
 import Handler.Utils.Rating as Handler.Utils
 import Handler.Utils.Submission as Handler.Utils
 import Handler.Utils.Templates as Handler.Utils
-
-import Text.Blaze (Markup, ToMarkup)
-
-import Data.Map (Map)
-import qualified Data.Map as Map
-import qualified Data.List as List
-
-import Database.Persist.Class
-
-tickmark :: IsString a => a
-tickmark = fromString "✔"
-
-text2Html :: Text -> Html
-text2Html = toHtml -- prevents ambiguous types
-
-toWgt :: (ToMarkup a, MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
-  a -> WidgetT site m ()
-toWgt = toWidget . toHtml
-
-text2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
-                Text -> WidgetT site m ()
-text2widget t = [whamlet|#{t}|]
-
-str2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
-                String -> WidgetT site m ()
-str2widget s = [whamlet|#{s}|]
-
-
-withFragment :: ( Monad m
-                ) => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ())
-withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget)
-
------------
--- Maybe --
------------
-whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
-whenIsJust (Just x) f = f x
-whenIsJust Nothing  _ = return ()
-
-
-
-----------
--- Maps --
-----------
-entities2map :: PersistEntity record => [Entity record] -> Map (Key record) record
-entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty
-
-
-------------
--- Routes --
-------------
-
--- -- redirectBack :: Handler Html
--- -- redirectBack :: HandlerT UniWorX IO Html
--- redirectBack = defaultLayout $ do
---   [whamlet| BACK |]
---   -- [julius| window.history.back(); |]
-
-
---------------
--- Database --
---------------
-
--- getKeyBy :: PersistEntity val => Unique val -> ReaderT backend0 m0 (Maybe (Entity val))
--- getKeyBy :: Unique a -> YesodDB site (Key a)
-
-getKeyBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
-  => Unique record -> ReaderT backend m (Maybe (Key record))
-getKeyBy u = (fmap entityKey) <$> getBy u -- TODO optimize this, so that DB does not deliver entire record!
-
-getKeyBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
-  => Unique record -> ReaderT backend m (Key record)
-getKeyBy404 = (fmap entityKey) . getBy404 -- TODO optimize this, so that DB does not deliver entire record!
-
-
-myReplaceUnique
-    :: (MonadIO m
-       ,Eq (Unique record)
-       ,PersistRecordBackend record backend
-       ,PersistUniqueWrite backend)
-    => Key record -> record -> ReaderT backend m (Maybe (Unique record))
-myReplaceUnique key datumNew = getJust key >>= replaceOriginal
-  where
-    uniqueKeysNew = persistUniqueKeys datumNew
-    replaceOriginal original = do
-        conflict <- checkUniqueKeys changedKeys
-        case conflict of
-            Nothing -> replace key datumNew >> return Nothing
-            (Just conflictingKey) -> return $ Just conflictingKey
-      where
-        changedKeys = uniqueKeysNew List.\\ uniqueKeysOriginal
-        uniqueKeysOriginal = persistUniqueKeys original
-
-checkUniqueKeys
-    :: (MonadIO m
-       ,PersistEntity record
-       ,PersistUniqueRead backend
-       ,PersistRecordBackend record backend)
-    => [Unique record] -> ReaderT backend m (Maybe (Unique record))
-checkUniqueKeys [] = return Nothing
-checkUniqueKeys (x:xs) = do
-    y <- getBy x
-    case y of
-        Nothing -> checkUniqueKeys xs
-        Just _ -> return (Just x)

src/Import.hs

@@ -2,6 +2,5 @@ module Import
     ( module Import
     ) where
 
-import Common                as Import    
 import Foundation            as Import
 import Import.NoFoundation   as Import

src/Import/NoFoundation.hs

@@ -10,6 +10,7 @@ import Settings.StaticFiles  as Import
 import Yesod.Auth            as Import
 import Yesod.Core.Types      as Import (loggerSet)
 import Yesod.Default.Config2 as Import
+import Utils                 as Import
 
 
 import Data.Fixed            as Import

src/Model/Types.hs

@@ -10,11 +10,10 @@
 module Model.Types where
 
 import ClassyPrelude
+import Utils
 
 import Data.Fixed
 
-import Common
-
 import Database.Persist.TH
 import Database.Persist.Class
 import Database.Persist.Sql

src/Utils.hs

@@ -0,0 +1,56 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Utils
+  ( module Utils
+  ) where
+
+import ClassyPrelude.Yesod
+
+import Utils.DB as Utils
+import Utils.Common as Utils
+
+import Text.Blaze (Markup, ToMarkup)
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified Data.List as List
+
+
+tickmark :: IsString a => a
+tickmark = fromString "✔"
+
+text2Html :: Text -> Html
+text2Html = toHtml -- prevents ambiguous types
+
+toWgt :: (ToMarkup a, MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
+  a -> WidgetT site m ()
+toWgt = toWidget . toHtml
+
+text2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
+                Text -> WidgetT site m ()
+text2widget t = [whamlet|#{t}|]
+
+str2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
+                String -> WidgetT site m ()
+str2widget s = [whamlet|#{s}|]
+
+
+withFragment :: ( Monad m
+                ) => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ())
+withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget)
+
+-----------
+-- Maybe --
+-----------
+whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
+whenIsJust (Just x) f = f x
+whenIsJust Nothing  _ = return ()
+
+
+
+----------
+-- Maps --
+----------

src/Utils/Common.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE QuasiQuotes #-}
 
-module Common where
+module Utils.Common where
 -- Common Utility Functions
 
 import Language.Haskell.TH

src/Utils/DB.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Utils.DB where
+
+import ClassyPrelude.Yesod
+
+import qualified Data.List as List
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+import Database.Persist
+
+-- getKeyBy :: PersistEntity val => Unique val -> ReaderT backend0 m0 (Maybe (Entity val))
+-- getKeyBy :: Unique a -> YesodDB site (Key a)
+
+entities2map :: PersistEntity record => [Entity record] -> Map (Key record) record
+entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty
+
+getKeyBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
+  => Unique record -> ReaderT backend m (Maybe (Key record))
+getKeyBy u = (fmap entityKey) <$> getBy u -- TODO optimize this, so that DB does not deliver entire record!
+
+getKeyBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
+  => Unique record -> ReaderT backend m (Key record)
+getKeyBy404 = (fmap entityKey) . getBy404 -- TODO optimize this, so that DB does not deliver entire record!
+
+
+myReplaceUnique
+    :: (MonadIO m
+       ,Eq (Unique record)
+       ,PersistRecordBackend record backend
+       ,PersistUniqueWrite backend)
+    => Key record -> record -> ReaderT backend m (Maybe (Unique record))
+myReplaceUnique key datumNew = getJust key >>= replaceOriginal
+  where
+    uniqueKeysNew = persistUniqueKeys datumNew
+    replaceOriginal original = do
+        conflict <- checkUniqueKeys changedKeys
+        case conflict of
+            Nothing -> replace key datumNew >> return Nothing
+            (Just conflictingKey) -> return $ Just conflictingKey
+      where
+        changedKeys = uniqueKeysNew List.\\ uniqueKeysOriginal
+        uniqueKeysOriginal = persistUniqueKeys original
+
+checkUniqueKeys
+    :: (MonadIO m
+       ,PersistEntity record
+       ,PersistUniqueRead backend
+       ,PersistRecordBackend record backend)
+    => [Unique record] -> ReaderT backend m (Maybe (Unique record))
+checkUniqueKeys [] = return Nothing
+checkUniqueKeys (x:xs) = do
+    y <- getBy x
+    case y of
+        Nothing -> checkUniqueKeys xs
+        Just _ -> return (Just x)

templates/standalone/inputs.julius

@@ -29,7 +29,7 @@
     var currValidInputCount = 0;
     var addMore = false;
     var inputName = input.getAttribute('name');
-    var isMulti = input.getAttribute('multiple') ? true : false;
+    var isMulti = input.hasAttribute('multiple') ? true : false;
     // FileInput PseudoClass
     function FileInput(container, input, label, remover) {
       this.container = container;