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