73 lines
2.0 KiB
Haskell
73 lines
2.0 KiB
Haskell
module Utils.Lens ( module Utils.Lens ) where
|
|
|
|
import Import.NoFoundation
|
|
import Control.Lens as Utils.Lens hiding ((<.>))
|
|
import Control.Lens.Extras as Utils.Lens (is)
|
|
import Utils.Lens.TH as Utils.Lens (makeLenses_, makeClassyFor_)
|
|
|
|
import qualified Database.Esqueleto as E (Value(..),InnerJoin(..))
|
|
|
|
_unValue :: Lens' (E.Value a) a
|
|
_unValue f (E.Value a) = E.Value <$> f a
|
|
|
|
_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
|
|
|
|
-- TEST HADDOCK
|
|
makeLenses_ ''Entity
|
|
-- makeClassyFor_ "HasEntity" "hasEntity" ''Entity
|
|
-- class HasEntity c record | c -> record where
|
|
-- hasEntity :: Lens' c (Entity record)
|
|
|
|
makeLenses_ ''Course
|
|
-- makeClassyFor_ "HasCourse" "hasCourse" ''Course
|
|
-- class HasCourse c where
|
|
-- hasCourse :: Lens' c Course
|
|
|
|
-- instance (HasCourse a) => HasCourse (Entity a) where
|
|
-- hasCourse = _entityVal . hasCourse
|
|
|
|
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...
|
|
--
|
|
|
|
-- TODO: Is this instance needed?
|
|
-- instance (HasUser a) => HasUser (Entity a) where
|
|
-- hasUser = _entityVal . hasUser
|
|
-- This is what we would want instead:
|
|
-- instance (HasEntity a User) => HasUser a where
|
|
-- hasUser = _entityVal
|
|
|
|
|
|
makeLenses_ ''SheetCorrector
|
|
|
|
makeLenses_ ''SubmissionGroup
|
|
|
|
makeLenses_ ''SheetGrading
|
|
|
|
makeLenses_ ''SheetType
|
|
|
|
makePrisms ''AuthResult
|
|
|
|
-- makeClassy_ ''Load
|
|
|
|
|