{-# 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 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 as E (Value(..),InnerJoin(..))

import qualified Data.CaseInsensitive as CI


_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


-----------------------------------
-- 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


_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)

-- 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_ ''StudyTermNameCandidate
makeLenses_ ''StudySubTermParentCandidate
makeLenses_ ''StudyTermStandaloneCandidate

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_ ''PredDNF

makeLenses_ ''Invitation

makeLenses_ ''ExamBonusRule
makeLenses_ ''ExamGradingRule
makeLenses_ ''ExamResult
makeLenses_ ''ExamBonus
makeLenses_ ''ExamPart
makeLenses_ ''ExamPartResult

makeLenses_ ''UTCTime

makeLenses_ ''Exam
makeLenses_ ''ExamOccurrence

makePrisms ''AuthenticationMode

makeLenses_ ''CourseUserNote

makeLenses_ ''CourseApplication
  
makeLenses_ ''Allocation

makeLenses_ ''File

makeLenses_ ''Submission
makeLenses_ ''SubmissionUser

makeLenses_ ''School
makeLenses_ ''SchoolLdap

makeLenses_ ''UserFunction

makeLenses_ ''CourseUserExamOfficeOptOut

makeLenses_ ''CourseNewsFile

makeLenses_ ''AllocationCourse

makeLenses_ ''Tutorial

makeLenses_ ''SessionFile
  
makeLenses_ ''ExternalExam
makeLenses_ ''ExternalExamOfficeSchool
makeLenses_ ''ExternalExamStaff
makeLenses_ ''ExternalExamResult
  

-- makeClassy_ ''Load

--------------------------
-- Fields for `UniWorX` --
--------------------------

class HasInstanceID s a | s -> a where
  instanceID :: 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