diff --git a/src/Foundation.hs b/src/Foundation.hs index e10d1c515..221ccbaa4 100644 --- a/src/Foundation.hs +++ b/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 diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 31d7b1324..33fc5f0f4 100644 --- a/src/Handler/Utils.hs +++ 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) diff --git a/src/Import.hs b/src/Import.hs index e2466be59..a10200156 100644 --- a/src/Import.hs +++ b/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 diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 4d7ca2b97..2157df182 100644 --- a/src/Import/NoFoundation.hs +++ b/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 diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 321df30b8..9aac70705 100644 --- a/src/Model/Types.hs +++ b/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 diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 index 000000000..a1816cb71 --- /dev/null +++ b/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 -- +---------- diff --git a/src/Common.hs b/src/Utils/Common.hs similarity index 98% rename from src/Common.hs rename to src/Utils/Common.hs index 290bb16ad..7ef941d4d 100644 --- a/src/Common.hs +++ b/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 diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs new file mode 100644 index 000000000..744cbe85a --- /dev/null +++ b/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) diff --git a/templates/standalone/inputs.julius b/templates/standalone/inputs.julius index bced64e6e..4744d8628 100644 --- a/templates/standalone/inputs.julius +++ b/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;