{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Data.Lens.Barlow.Construction where

import Control.Lens (Optic, traversed, _Just, _Left, _Right)
import Control.Lens.Iso (Profunctor)
import Control.Lens.Prism (Choice)
import Data.Generics.Product.Fields (HasField (field))
import Data.Generics.Product.Positions (HasPosition (position))
import Data.Generics.Sum.Constructors (AsConstructor (_Ctor))
import Data.Generics.Wrapped (Wrapped (wrappedIso))
import Data.Lens.Barlow.Types (Tag (..))

-- Translated https://github.com/sigma-andex/purescript-barlow-lens/blob/main/src/Data/Lens/Barlow/Construction.purs

class ConstructBarlow (path :: [Tag]) p f s t a b | path s -> a, path t -> b where
  constructBarlow :: Optic p f s t a b

instance ConstructBarlow '[] p f s t s t where
  constructBarlow :: Optic p f s t s t
constructBarlow = forall a. a -> a
id

instance (Choice p, ConstructBarlow path p f s t a b, Applicative f) => ConstructBarlow (Tag'RightArrow : path) p f (Either x s) (Either x t) a b where
  constructBarlow :: Optic p f (Either x s) (Either x t) a b
constructBarlow = forall c a b. Prism (Either c a) (Either c b) a b
_Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (path :: [Tag]) (p :: * -> * -> *) (f :: * -> *) s t a b.
ConstructBarlow path p f s t a b =>
Optic p f s t a b
constructBarlow @path

instance (Choice p, ConstructBarlow path p f s t a b, Applicative f) => ConstructBarlow (Tag'LeftArrow : path) p f (Either s x) (Either t x) a b where
  constructBarlow :: Optic p f (Either s x) (Either t x) a b
constructBarlow = forall a c b. Prism (Either a c) (Either b c) a b
_Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (path :: [Tag]) (p :: * -> * -> *) (f :: * -> *) s t a b.
ConstructBarlow path p f s t a b =>
Optic p f s t a b
constructBarlow @path

instance (Choice p, ConstructBarlow path p f q w a b, AsConstructor ctor s t q w, Applicative f) => ConstructBarlow (Tag'PercentageName ctor : path) p f s t a b where
  constructBarlow :: Optic p f s t a b
constructBarlow = forall (ctor :: Symbol) s t a b.
AsConstructor ctor s t a b =>
Prism s t a b
_Ctor @ctor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (path :: [Tag]) (p :: * -> * -> *) (f :: * -> *) s t a b.
ConstructBarlow path p f s t a b =>
Optic p f s t a b
constructBarlow @path

instance (p ~ (->), Applicative f, ConstructBarlow path p f s t a b, Traversable tr) => ConstructBarlow (Tag'Plus : path) p f (tr s) (tr t) a b where
  constructBarlow :: Optic p f (tr s) (tr t) a b
constructBarlow = forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (path :: [Tag]) (p :: * -> * -> *) (f :: * -> *) s t a b.
ConstructBarlow path p f s t a b =>
Optic p f s t a b
constructBarlow @path

instance (Profunctor p, ConstructBarlow path p f q w a b, Functor f, Wrapped s t q w) => ConstructBarlow (Tag'ExclamationMark : path) p f s t a b where
  constructBarlow :: Optic p f s t a b
constructBarlow = forall s t a b. Wrapped s t a b => Iso s t a b
wrappedIso forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (path :: [Tag]) (p :: * -> * -> *) (f :: * -> *) s t a b.
ConstructBarlow path p f s t a b =>
Optic p f s t a b
constructBarlow @path

instance (Choice p, ConstructBarlow path p f s t a b, Applicative f) => ConstructBarlow (Tag'QuestionMark : path) p f (Maybe s) (Maybe t) a b where
  constructBarlow :: Optic p f (Maybe s) (Maybe t) a b
constructBarlow = forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (path :: [Tag]) (p :: * -> * -> *) (f :: * -> *) s t a b.
ConstructBarlow path p f s t a b =>
Optic p f s t a b
constructBarlow @path

instance (p ~ (->), Functor f, ConstructBarlow path p f q w a b, HasPosition pos s t q w) => ConstructBarlow (Tag'PercentageNumber pos : path) p f s t a b where
  constructBarlow :: Optic p f s t a b
constructBarlow = forall (i :: Nat) s t a b. HasPosition i s t a b => Lens s t a b
position @pos forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (path :: [Tag]) (p :: * -> * -> *) (f :: * -> *) s t a b.
ConstructBarlow path p f s t a b =>
Optic p f s t a b
constructBarlow @path

instance (p ~ (->), Functor f, ConstructBarlow path p f q w a b, HasField sym s t q w) => ConstructBarlow (Tag'Name sym : path) p f s t a b where
  constructBarlow :: Optic p f s t a b
constructBarlow = forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @sym forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (path :: [Tag]) (p :: * -> * -> *) (f :: * -> *) s t a b.
ConstructBarlow path p f s t a b =>
Optic p f s t a b
constructBarlow @path