{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Utils.Lens ( module Utils.Lens ) where

import ClassyPrelude.Yesod hiding (HasHttpManager(..))
import qualified ClassyPrelude.Yesod as Yesod (HasHttpManager(..))
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

_SchoolId :: Iso' SchoolId SchoolShorthand
_SchoolId = iso unSchoolKey SchoolKey


-----------------------------------
-- Lens Definitions for our Types


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


makeLenses_ ''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_ ''StudyTermCandidate

makeLenses_ ''FieldView

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_ ''ExamBonusRule
makeLenses_ ''ExamGradingRule
makeLenses_ ''ExamResult

makeLenses_ ''UTCTime

makeLenses_ ''ExamOccurrence

makePrisms ''AuthenticationMode

makeLenses_ ''CourseUserNote

makeLenses_ ''CourseApplication
  
makeLenses_ ''Allocation


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