138 lines
3.3 KiB
Haskell
138 lines
3.3 KiB
Haskell
module Utils.Lens ( module Utils.Lens ) where
|
|
|
|
import ClassyPrelude.Yesod
|
|
import Model
|
|
import Control.Lens as Utils.Lens hiding ((<.>), universe, snoc)
|
|
import Control.Lens.Extras as Utils.Lens (is)
|
|
import Utils.Lens.TH as Utils.Lens (makeLenses_, makeClassyFor_)
|
|
import Data.Set.Lens as Utils.Lens
|
|
|
|
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
|
|
|
|
import qualified Database.Esqueleto as E (Value(..),InnerJoin(..))
|
|
|
|
|
|
_PathPiece :: PathPiece v => Prism' Text v
|
|
_PathPiece = prism' toPathPiece fromPathPiece
|
|
|
|
maybePrism :: Prism' a b -> Prism' (Maybe a) (Maybe b)
|
|
maybePrism p = prism' (fmap $ review p) (fmap $ preview p )
|
|
|
|
applying :: Applicative f => Lens' s a -> Lens' (f s) (f a)
|
|
applying l = lens (fmap $ view l) (liftA2 . flip $ set l)
|
|
|
|
_InnerJoinLeft :: Lens' (E.InnerJoin l r) l -- forall f. Functor f => (a -> f a) -> s -> f s
|
|
_InnerJoinLeft f (E.InnerJoin l r) = (`E.InnerJoin` r) <$> f l
|
|
|
|
_InnerJoinRight :: Lens' (E.InnerJoin l r) r
|
|
_InnerJoinRight f (E.InnerJoin l r) = (l `E.InnerJoin`) <$> f r
|
|
|
|
_nullable :: MonoFoldable mono => Prism' mono (NonNull mono)
|
|
_nullable = prism' toNullable fromNullable
|
|
|
|
|
|
-----------------------------------
|
|
-- Lens Definitions for our Types
|
|
|
|
|
|
-- makeLenses_ ''Course
|
|
makeClassyFor_ "HasCourse" "hasCourse" ''Course
|
|
-- class HasCourse c where
|
|
-- hasCourse :: Lens' c Course
|
|
|
|
|
|
-- makeLenses_ ''User
|
|
makeClassyFor_ "HasUser" "hasUser" ''User
|
|
-- > :info HasUser
|
|
-- class HasUser c where
|
|
-- hasUser :: Lens' c User -- MINIMAL
|
|
-- _userDisplayName :: Lens' c Text
|
|
-- _userSurname :: Lens' c Text
|
|
-- _user...
|
|
--
|
|
|
|
|
|
makeLenses_ ''Entity
|
|
-- BUILD SERVER FAILS TO MAKE HADDOCK FOR THE ONE BELOW:
|
|
-- makeClassyFor_ "HasEntity" "hasEntity" ''Entity
|
|
-- class HasEntity c record | c -> record where
|
|
-- hasEntity :: Lens' c (Entity record)
|
|
--
|
|
-- Manual definition, explicitely leaving out the unwanted Functional Dependency, since we want Instances differing on the result-type
|
|
class HasEntity c record where
|
|
hasEntity :: Lens' c (Entity record)
|
|
|
|
-- Typed convenience to avoid type signatures, due to the missing FunctionalDepenency that we do not want.
|
|
hasEntityUser :: (HasEntity a User) => Lens' a (Entity User)
|
|
hasEntityUser = hasEntity
|
|
|
|
-- This is what we would want, but is an UndecidableInstance since the type is not reduced:
|
|
-- instance (HasEntity a User) => HasUser a where
|
|
-- hasUser = hasEntityUser
|
|
--
|
|
-- Possible, but rather useless:
|
|
-- instance (HasUser a) => HasUser (Entity a) where
|
|
-- hasUser = _entityVal . hasUser
|
|
|
|
|
|
makeLenses_ ''SheetCorrector
|
|
|
|
makeLenses_ ''Load
|
|
|
|
makeLenses_ ''SubmissionGroup
|
|
|
|
makeLenses_ ''SheetGrading
|
|
|
|
makeLenses_ ''SheetType
|
|
|
|
makePrisms ''SheetGroup
|
|
|
|
makePrisms ''AuthResult
|
|
|
|
makePrisms ''FormResult
|
|
|
|
makeLenses_ ''StudyFeatures
|
|
|
|
makeLenses_ ''StudyDegree
|
|
|
|
makeLenses_ ''StudyTerms
|
|
|
|
makeLenses_ ''StudyTermCandidate
|
|
|
|
makeLenses_ ''FieldView
|
|
|
|
makePrisms ''HandlerContents
|
|
|
|
makePrisms ''ErrorResponse
|
|
|
|
makeLenses_ ''UploadMode
|
|
|
|
makeLenses_ ''SubmissionMode
|
|
|
|
makePrisms ''E.Value
|
|
|
|
makeLenses_ ''OccurenceSchedule
|
|
|
|
makePrisms ''OccurenceSchedule
|
|
|
|
makeLenses_ ''OccurenceException
|
|
|
|
makePrisms ''OccurenceException
|
|
|
|
makeLenses_ ''Occurences
|
|
|
|
makeLenses_ ''PredDNF
|
|
|
|
|
|
-- makeClassy_ ''Load
|
|
|
|
--------------------------
|
|
-- Fields for `UniWorX` --
|
|
--------------------------
|
|
|
|
class HasInstanceID s a | s -> a where
|
|
instanceID :: Lens' s a
|
|
|
|
class HasJSONWebKeySet s a | s -> a where
|
|
jsonWebKeySet :: Lens' s a
|