diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 66394d53b..1555f6388 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -7,7 +7,7 @@ module Database.Esqueleto.Utils ( true, false - , justVal, justValList + , justVal, justValList, toValues , isJust, alt , isInfixOf, hasInfix , strConcat, substring @@ -50,7 +50,9 @@ import Data.Universe import qualified Data.Set as Set import qualified Data.List as List import qualified Data.Foldable as F +import Data.List.NonEmpty (NonEmpty(..)) import qualified Database.Esqueleto.Legacy as E +import qualified Database.Esqueleto.Experimental as Ex import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Internal.Internal as E import Database.Esqueleto.Utils.TH @@ -104,6 +106,9 @@ justValList :: PersistField typ => [typ] -> E.SqlExpr (E.ValueList (Maybe typ)) -- justValList = E.valList . map Just justValList = E.justList . E.valList +toValues :: PersistField typ => NonEmpty typ -> Ex.From (Ex.SqlExpr (Ex.Value typ)) -- E.From does not work here! Requires Experimental! +toValues = E.values . fmap Ex.val + infixl 4 =?. (=?.) :: PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool) (=?.) = (E.==.) . E.just diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 85671d0ae..13e20bf30 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -6,7 +6,7 @@ {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TODO: remove this line, once the module is completed {-# OPTIONS_GHC -Wno-error=unused-local-binds #-} -- TODO: remove this line, once the module is completed -{-# OPTIONS_GHC -Wno-warn=unused-local-binds #-} -- TODO: remove this line, once the module is completed + module Handler.Utils.Avs @@ -134,24 +134,35 @@ checkLicences = do noOne = AvsPersonId 0 vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) licences rollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) vorORrollfeld' - vorORrollfeld :: NonEmpty AvsPersonId = set2NonEmpty noOne (Set.map avsLicencePersonID vorORrollfeld') + vorORrollfeld = set2NonEmpty noOne (Set.map avsLicencePersonID vorORrollfeld') rollfeld = set2NonEmpty noOne (Set.map avsLicencePersonID rollfeld' ) -- we get a weird type error so we try a simple demo here: (_res :: [(E.Value AvsPersonId, E.Value AvsPersonId )]) <- runDB $ E.select $ do - (usrAvs E.:& (excl,_)) <- - E.from $ E.table @UserAvs `E.innerJoin` E.values ((E.val (AvsPersonId 10), E.val ("ten" :: Text)) - :| [ (E.val (AvsPersonId 20), E.val "twenty") - , (E.val (AvsPersonId 30), E.val "thirty") ] - ) - `E.on` (\(usrAvs E.:& (excl,_)) -> excl E.==. usrAvs E.^. UserAvsPersonId) + (usrAvs E.:& excl) <- + E.from $ E.table @UserAvs `E.innerJoin` E.toValues rollfeld + `E.on` (\(usrAvs E.:& excl) -> excl E.==. usrAvs E.^. UserAvsPersonId) return (usrAvs E.^. UserAvsPersonId, excl) -- > Looks like we need te Type NonEmpty (SqlExpr (Value typ)) i.e. we need to wrap everything with E.val?! - {- - - -- antijoinAvsLicences :: AvsLicence -> NonEmpty AvsPersonId -> DB [(E.Value (Maybe AvsPersonId), E.Value (Maybe AvsPersonId))] +{- + Cases to consider (AVS_Licence,has_valid_F, has_valid_R): + (0,0,0) -> ok; avs_id not returned from queries, no problem + (0,0,1) -> do nothing -- CHECK since id is returned by roll-query + (0,1,0) -> set F for id + (0,1,1) -> set R for id + (1,0,0) -> unset F for id + (1,0,1) -> unset F for id + (1,1,0) -> ok + (1,1,1) -> set R for id + (2,0,0) -> unset R for id + (2,0,1) -> unset R for id -- CHECK + (2,1,0) -> set F for id + (2,1,1) -> ok +-} + + antijoinAvsLicences :: AvsLicence -> NonEmpty AvsPersonId -> DB [(E.Value (Maybe AvsPersonId), E.Value (Maybe AvsPersonId))] antijoinAvsLicences lic avsLics = --fmap (fmap $(E.unValueN 2)) $ E.select $ do ((_qauli E.:& _qualUser E.:& usrAvs) E.:& excl) <- @@ -167,11 +178,11 @@ checkLicences = do ) `E.innerJoin` E.table @UserAvs `E.on` (\(_ E.:& qualUser E.:& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser) - ) `E.fullOuterJoin` E.values avsLics -- left-hand side produces all currently valid matching qualifications + ) `E.fullOuterJoin` E.toValues avsLics -- left-hand side produces all currently valid matching qualifications `E.on` (\((_ E.:& _ E.:& usrAvs) E.:& excl) -> usrAvs E.?. UserAvsPersonId E.==. excl) E.where_ $ E.isNothing excl E.||. E.isNothing (usrAvs E.?. UserAvsPersonId) -- anti join return (usrAvs E.?. UserAvsPersonId, excl) - -} + -- (_rollDelta, _vorfDelta) <- runDB $ (,) -- <$> antijoinAvsLicences AvsLicenceRollfeld rollfeld -- <*> antijoinAvsLicences AvsLicenceVorfeld vorORrollfeld