333 lines
8.4 KiB
Haskell
333 lines
8.4 KiB
Haskell
{-# LANGUAGE UndecidableInstances #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
|
|
|
module Utils.Lens ( module Utils.Lens ) where
|
|
|
|
import Import.NoModel
|
|
import Model
|
|
import Model.Rating
|
|
import qualified ClassyPrelude.Yesod as Yesod (HasHttpManager(..))
|
|
|
|
import Control.Lens as Utils.Lens
|
|
hiding ( (<.>)
|
|
, universe
|
|
, cons, uncons, snoc, unsnoc, (<|)
|
|
, Index, index, (<.)
|
|
)
|
|
import Control.Lens.Extras as Utils.Lens (is)
|
|
import Utils.Lens.TH as Utils.Lens
|
|
import Data.Set.Lens as Utils.Lens
|
|
import Data.Map.Lens as Utils.Lens
|
|
|
|
import Data.Generics.Product.Types as Utils.Lens
|
|
|
|
import Yesod.Core.Types (HandlerContents(..))
|
|
|
|
import qualified Database.Esqueleto.Legacy as E (Value(..),InnerJoin(..))
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import Database.Persist.Sql (BackendKey(..))
|
|
|
|
|
|
_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
|
|
|
|
_SchoolId :: Iso' SchoolId SchoolShorthand
|
|
_SchoolId = iso unSchoolKey SchoolKey
|
|
|
|
_TermId :: Iso' TermId TermIdentifier
|
|
_TermId = iso unTermKey TermKey
|
|
|
|
_StudyTermsId :: Iso' StudyTermsId StudyTermsKey
|
|
_StudyTermsId = iso unStudyTermsKey StudyTermsKey'
|
|
|
|
_StudyDegreeId :: Iso' StudyDegreeId StudyDegreeKey
|
|
_StudyDegreeId = iso unStudyDegreeKey StudyDegreeKey'
|
|
|
|
_Maybe :: Iso' (Maybe ()) Bool
|
|
_Maybe = iso (is _Just) (bool Nothing (Just ()))
|
|
|
|
_CI :: FoldCase s => Iso' (CI s) s
|
|
_CI = iso CI.original CI.mk
|
|
|
|
instance Wrapped SqlBackendKey where
|
|
type Unwrapped SqlBackendKey = Int64
|
|
_Wrapped' = iso unSqlBackendKey SqlBackendKey
|
|
instance Rewrapped SqlBackendKey t
|
|
|
|
_SqlKey' :: ToBackendKey SqlBackend record => Iso' (Key record) Int64
|
|
_SqlKey' = iso fromSqlKey toSqlKey
|
|
|
|
_SqlKey :: ToBackendKey SqlBackend record => Iso' (Key record) SqlBackendKey
|
|
_SqlKey = _SqlKey' . _Unwrapped
|
|
|
|
_Integral :: (Integral a, Integral b) => Iso' a b
|
|
_Integral = iso fromIntegral fromIntegral
|
|
|
|
_not :: Iso' Bool Bool
|
|
_not = iso not not
|
|
|
|
-----------------------------------
|
|
-- Lens Definitions for our Types
|
|
|
|
makeClassyFor_ ''Term
|
|
|
|
|
|
-- makeLenses_ ''Course
|
|
makeClassyFor_ ''Course
|
|
-- class HasCourse c where
|
|
-- hasCourse :: Lens' c Course
|
|
|
|
|
|
-- makeLenses_ ''User
|
|
makeClassyFor_ ''User
|
|
-- > :info HasUser
|
|
-- class HasUser c where
|
|
-- hasUser :: Lens' c User -- MINIMAL
|
|
-- _userDisplayName :: Lens' c Text
|
|
-- _userSurname :: Lens' c Text
|
|
-- _user...
|
|
--
|
|
|
|
makeClassyFor_ ''StudyFeatures
|
|
|
|
makeClassyFor_ ''StudyDegree
|
|
|
|
makeClassyFor_ ''StudyTerms
|
|
makeClassyFor_ ''StudySubTerms
|
|
|
|
makeClassyFor_ ''Qualification
|
|
makeClassyFor_ ''QualificationUser
|
|
makeClassyFor_ ''LmsUser
|
|
makeClassyFor_ ''LmsUserlist
|
|
makeClassyFor_ ''LmsResult
|
|
|
|
_entityKey :: Getter (Entity record) (Key record)
|
|
-- ^ Not a `Lens'` for safety
|
|
_entityKey = to entityKey
|
|
|
|
_entityVal :: IndexedLens (Key record) (Entity record) (Entity record) record record
|
|
_entityVal = ilens ((,) <$> entityKey <*> entityVal) (\e v -> e { entityVal = v })
|
|
|
|
_Entity :: Iso (Entity record) (Entity record') (Key record, record) (Key record', record')
|
|
_Entity = iso ((,) <$> entityKey <*> entityVal) (uncurry Entity)
|
|
|
|
|
|
instance HasStudyFeatures a => HasStudyFeatures (Entity a) where
|
|
hasStudyFeatures = _entityVal . hasStudyFeatures
|
|
|
|
instance HasStudyTerms a => HasStudyTerms (Entity a) where
|
|
hasStudyTerms = _entityVal . hasStudyTerms
|
|
|
|
instance HasStudyDegree a => HasStudyDegree (Entity a) where
|
|
hasStudyDegree = _entityVal . hasStudyDegree
|
|
|
|
-- 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)
|
|
|
|
--Trivial instance, usefull for lifting to maybes
|
|
instance HasEntity (Entity r) r where
|
|
hasEntity = id
|
|
|
|
-- 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_ ''Sheet
|
|
|
|
makePrisms ''SheetGroup
|
|
|
|
makePrisms ''AuthResult
|
|
|
|
makePrisms ''FormResult
|
|
|
|
makeLenses_ ''StudyTermNameCandidate
|
|
makeLenses_ ''StudySubTermParentCandidate
|
|
makeLenses_ ''StudyTermStandaloneCandidate
|
|
|
|
makeLenses_ ''Field
|
|
makeLenses_ ''FieldView
|
|
makeLenses_ ''FieldSettings
|
|
|
|
makePrisms ''HandlerContents
|
|
|
|
makePrisms ''ErrorResponse
|
|
|
|
makePrisms ''UploadMode
|
|
makeLenses_ ''UploadMode
|
|
|
|
makeLenses_ ''SubmissionMode
|
|
|
|
makePrisms ''E.Value
|
|
|
|
makeLenses_ ''OccurrenceSchedule
|
|
|
|
makePrisms ''OccurrenceSchedule
|
|
|
|
makeLenses_ ''OccurrenceException
|
|
|
|
makePrisms ''OccurrenceException
|
|
|
|
makeLenses_ ''Occurrences
|
|
|
|
makeLenses_ ''Invitation
|
|
|
|
makeLenses_ ''ExamBonusRule
|
|
makeLenses_ ''ExamGradingRule
|
|
makeLenses_ ''ExamResult
|
|
makeLenses_ ''ExamBonus
|
|
makeLenses_ ''ExamPart
|
|
makeLenses_ ''ExamPartResult
|
|
makeLenses_ ''ExamRegistration
|
|
|
|
makeLenses_ ''UTCTime
|
|
|
|
makeLenses_ ''Exam
|
|
makeLenses_ ''ExamOccurrence
|
|
|
|
makePrisms ''AuthenticationMode
|
|
|
|
makeLenses_ ''CourseUserNote
|
|
makeLenses_ ''CourseParticipant
|
|
|
|
makeLenses_ ''CourseApplication
|
|
|
|
makeLenses_ ''Allocation
|
|
|
|
makeLenses_ ''Submission
|
|
makeLenses_ ''SubmissionUser
|
|
|
|
makeLenses_ ''School
|
|
makeLenses_ ''SchoolLdap
|
|
|
|
makeLenses_ ''UserFunction
|
|
|
|
makeLenses_ ''CourseUserExamOfficeOptOut
|
|
|
|
makeLenses_ ''CourseNewsFile
|
|
|
|
makeLenses_ ''AllocationCourse
|
|
makeLenses_ ''AllocationUser
|
|
|
|
makeLenses_ ''Tutorial
|
|
|
|
makeLenses_ ''SessionFile
|
|
|
|
makeLenses_ ''ExternalExam
|
|
makeLenses_ ''ExternalExamOfficeSchool
|
|
makeLenses_ ''ExternalExamStaff
|
|
makeLenses_ ''ExternalExamResult
|
|
|
|
makeLenses_ ''Rating
|
|
makeLenses_ ''Rating'
|
|
|
|
makeLenses_ ''FallbackPersonalisedSheetFilesKey
|
|
|
|
makeWrapped ''Textarea
|
|
makeLenses_ ''SentMail
|
|
|
|
makePrisms ''AllocationPriority
|
|
|
|
makePrisms ''RoomReference
|
|
makeLenses_ ''RoomReference
|
|
|
|
-- makeClassy_ ''Load
|
|
|
|
makePrisms ''SchoolAuthorshipStatementMode
|
|
makePrisms ''SheetAuthorshipStatementMode
|
|
|
|
makeLenses_ ''AuthorshipStatementSubmission
|
|
makeLenses_ ''AuthorshipStatementDefinition
|
|
|
|
--------------------------
|
|
-- Fields for `UniWorX` --
|
|
--------------------------
|
|
|
|
class HasInstanceID s a | s -> a where
|
|
instanceID :: Lens' s a
|
|
|
|
class HasClusterID s a | s -> a where
|
|
clusterID :: Lens' s a
|
|
|
|
class HasHttpManager s a | s -> a where
|
|
httpManager :: Lens' s a
|
|
|
|
instance HasHttpManager s Manager => Yesod.HasHttpManager s where
|
|
getHttpManager = view httpManager
|
|
|
|
class HasJSONWebKeySet s a | s -> a where
|
|
jsonWebKeySet :: Lens' s a
|
|
|
|
---------------
|
|
-- PathPiece --
|
|
---------------
|
|
|
|
mono :: forall mono mono'.
|
|
( MonoPointed mono
|
|
, MonoFoldable mono
|
|
, Monoid mono
|
|
, MonoPointed mono'
|
|
, MonoFoldable mono'
|
|
, Monoid mono'
|
|
) => Prism' (Element mono) (Element mono') -> Iso' mono mono'
|
|
mono p = iso (view $ mono' p) (view . mono' $ re p)
|
|
|
|
mono' :: forall mono mono'.
|
|
( MonoFoldable mono
|
|
, MonoPointed mono'
|
|
, Monoid mono'
|
|
)
|
|
=> Getting (First (Element mono')) (Element mono) (Element mono')
|
|
-> Getter mono mono'
|
|
mono' p' = to $ foldMap (maybe mempty opoint . preview p')
|
|
|
|
monoPathPieces :: ( PathPiece (Element mono')
|
|
, MonoPointed mono'
|
|
, Monoid mono'
|
|
, MonoFoldable mono'
|
|
, Element mono ~ Text
|
|
, MonoFoldable mono
|
|
, MonoPointed mono
|
|
, Monoid mono
|
|
) => Iso' mono mono'
|
|
monoPathPieces = mono _PathPiece
|