{-# LANGUAGE TemplateHaskellQuotes #-}
module Optics.TH.Internal.Sum
  ( makePrisms
  , makePrismLabels
  , makeClassyPrisms
  , makeDecPrisms
  ) where

import Data.Char
import Data.Maybe
import Data.Traversable
import Language.Haskell.TH
import Language.Haskell.TH.Datatype.TyVarBndr
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Language.Haskell.TH.Datatype as D

import Data.Set.Optics
import Language.Haskell.TH.Optics.Internal
import Optics.Core hiding (cons)
import Optics.Internal.Magic
import Optics.TH.Internal.Utils

-- | Generate a 'Prism' for each constructor of a data type. Isos generated when
-- possible. Reviews are created for constructors with existentially quantified
-- constructors and GADTs.
--
-- /e.g./
--
-- @
-- data FooBarBaz a
--   = Foo Int
--   | Bar a
--   | Baz Int Char
-- makePrisms ''FooBarBaz
-- @
--
-- will create
--
-- @
-- _Foo :: Prism' (FooBarBaz a) Int
-- _Bar :: Prism (FooBarBaz a) (FooBarBaz b) a b
-- _Baz :: Prism' (FooBarBaz a) (Int, Char)
-- @
makePrisms :: Name {- ^ Type constructor name -} -> DecsQ
makePrisms :: Name -> DecsQ
makePrisms = Bool -> Name -> DecsQ
makePrisms' Bool
True

-- | Generate a 'Prism' for each constructor of a data type and combine them
-- into a single class. No Isos are created. Reviews are created for
-- constructors with existentially quantified constructors and GADTs.
--
-- /e.g./
--
-- @
-- data FooBarBaz a
--   = Foo Int
--   | Bar a
--   | Baz Int Char
-- makeClassyPrisms ''FooBarBaz
-- @
--
-- will create
--
-- @
-- class AsFooBarBaz s a | s -> a where
--   _FooBarBaz :: Prism' s (FooBarBaz a)
--   _Foo :: Prism' s Int
--   _Bar :: Prism' s a
--   _Baz :: Prism' s (Int,Char)
--
--   _Foo = _FooBarBaz % _Foo
--   _Bar = _FooBarBaz % _Bar
--   _Baz = _FooBarBaz % _Baz
--
-- instance AsFooBarBaz (FooBarBaz a) a
-- @
--
-- Generate an "As" class of prisms. Names are selected by prefixing the
-- constructor name with an underscore. Constructors with multiple fields will
-- construct Prisms to tuples of those fields.
makeClassyPrisms :: Name {- ^ Type constructor name -} -> DecsQ
makeClassyPrisms :: Name -> DecsQ
makeClassyPrisms = Bool -> Name -> DecsQ
makePrisms' Bool
False

makePrismLabels :: Name -> DecsQ
makePrismLabels :: Name -> DecsQ
makePrismLabels Name
typeName = do
  Q ()
requireExtensionsForLabels
  DatatypeInfo
info <- Name -> Q DatatypeInfo
D.reifyDatatype Name
typeName
  let cons :: [NCon]
cons = (ConstructorInfo -> NCon) -> [ConstructorInfo] -> [NCon]
forall a b. (a -> b) -> [a] -> [b]
map (DatatypeInfo -> ConstructorInfo -> NCon
normalizeCon DatatypeInfo
info) ([ConstructorInfo] -> [NCon]) -> [ConstructorInfo] -> [NCon]
forall a b. (a -> b) -> a -> b
$ DatatypeInfo -> [ConstructorInfo]
D.datatypeCons DatatypeInfo
info
  [Maybe Dec] -> [Dec]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Dec] -> [Dec]) -> Q [Maybe Dec] -> DecsQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NCon -> Q (Maybe Dec)) -> [NCon] -> Q [Maybe Dec]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (DatatypeInfo -> [NCon] -> NCon -> Q (Maybe Dec)
makeLabel DatatypeInfo
info [NCon]
cons) [NCon]
cons
  where
    makeLabel :: D.DatatypeInfo -> [NCon] -> NCon -> Q (Maybe Dec)
    makeLabel :: DatatypeInfo -> [NCon] -> NCon -> Q (Maybe Dec)
makeLabel DatatypeInfo
info [NCon]
cons NCon
con = do
      stab :: Stab
stab@(Stab Bool
tvsCovered [Type]
cx OpticType
otype Type
s Type
t Type
a Type
b) <- StabConfig -> Type -> [NCon] -> NCon -> Q Stab
computeOpticType StabConfig
labelConfig Type
ty [NCon]
cons NCon
con
      (Type
k,  Type
cxtK) <- Type -> String -> Q (Type, Type)
eqSubst (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ OpticType -> Name
opticTypeToTag OpticType
otype) String
"k"
      (Type
a', Type
cxtA) <- Type -> String -> Q (Type, Type)
eqSubst Type
a String
"a"
      (Type
b', Type
cxtB) <- Type -> String -> Q (Type, Type)
eqSubst Type
b String
"b"
      let label :: String
label = Name -> String
nameBase (Name -> String) -> (Name -> Name) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
prismName (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ Optic' A_Lens '[] NCon Name -> NCon -> Name
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens '[] NCon Name
nconName NCon
con
          tyArgs :: [Type]
tyArgs = [TyLit -> Type
LitT (String -> TyLit
StrTyLit String
label), Type
k, Type
s, Type
t, Type
a', Type
b']
          context :: [Type]
context = [[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ -- If some of the type variables are not covered, instance is
              -- dysfunctional.
              if Bool
tvsCovered then [] else [Name -> [Type] -> Type
conAppsT ''Dysfunctional [Type]
tyArgs]
            , [Type
cxtK, Type
cxtA, Type
cxtB]
            , [Type]
cx
            ]
      Dec -> Maybe Dec
forall a. a -> Maybe a
Just (Dec -> Maybe Dec) -> Q Dec -> Q (Maybe Dec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [Type] -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([Type] -> Q [Type]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
context)
                         (Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Type
conAppsT ''LabelOptic [Type]
tyArgs)
                         (Stab -> Name -> [Q Dec]
fun Stab
stab 'labelOptic)
      where
        ty :: Type
ty        = DatatypeInfo -> Type -> Type
addKindInfo DatatypeInfo
info (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ DatatypeInfo -> Type
D.datatypeType DatatypeInfo
info
        isNewtype :: Bool
isNewtype = DatatypeInfo -> DatatypeVariant
D.datatypeVariant DatatypeInfo
info DatatypeVariant -> DatatypeVariant -> Bool
forall a. Eq a => a -> a -> Bool
== DatatypeVariant
D.Newtype

        opticTypeToTag :: OpticType -> Name
opticTypeToTag OpticType
IsoType    = ''An_Iso
        opticTypeToTag OpticType
PrismType  = ''A_Prism
        opticTypeToTag OpticType
ReviewType = ''A_Review -- for complete match

        fun :: Stab -> Name -> [DecQ]
        fun :: Stab -> Name -> [Q Dec]
fun Stab
stab Name
n = Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
n) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Stab -> Q Exp
funDef Stab
stab) [] Q Dec -> [Q Dec] -> [Q Dec]
forall a. a -> [a] -> [a]
: Name -> [Q Dec]
inlinePragma Name
n

        funDef :: Stab -> ExpQ
        funDef :: Stab -> Q Exp
funDef Stab
stab
          | Bool
isNewtype = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'coerced
          | Bool
otherwise = Stab -> [NCon] -> NCon -> Q Exp
makeConOpticExp Stab
stab [NCon]
cons NCon
con

-- | Main entry point into Prism generation for a given type constructor name.
makePrisms' :: Bool -> Name -> DecsQ
makePrisms' :: Bool -> Name -> DecsQ
makePrisms' Bool
normal Name
typeName =
  do DatatypeInfo
info <- Name -> Q DatatypeInfo
D.reifyDatatype Name
typeName
     let cls :: Maybe Name
cls | Bool
normal    = Maybe Name
forall a. Maybe a
Nothing
             | Bool
otherwise = Name -> Maybe Name
forall a. a -> Maybe a
Just (DatatypeInfo -> Name
D.datatypeName DatatypeInfo
info)
         cons :: [ConstructorInfo]
cons = DatatypeInfo -> [ConstructorInfo]
D.datatypeCons DatatypeInfo
info
     DatatypeInfo -> [NCon] -> Maybe Name -> DecsQ
makeConsPrisms DatatypeInfo
info ((ConstructorInfo -> NCon) -> [ConstructorInfo] -> [NCon]
forall a b. (a -> b) -> [a] -> [b]
map (DatatypeInfo -> ConstructorInfo -> NCon
normalizeCon DatatypeInfo
info) [ConstructorInfo]
cons) Maybe Name
cls


-- | Generate prisms for the given 'Dec'
makeDecPrisms :: Bool {- ^ generate top-level definitions -} -> Dec -> DecsQ
makeDecPrisms :: Bool -> Dec -> DecsQ
makeDecPrisms Bool
normal Dec
dec =
  do DatatypeInfo
info <- Dec -> Q DatatypeInfo
D.normalizeDec Dec
dec
     let cls :: Maybe Name
cls | Bool
normal    = Maybe Name
forall a. Maybe a
Nothing
             | Bool
otherwise = Name -> Maybe Name
forall a. a -> Maybe a
Just (DatatypeInfo -> Name
D.datatypeName DatatypeInfo
info)
         cons :: [ConstructorInfo]
cons = DatatypeInfo -> [ConstructorInfo]
D.datatypeCons DatatypeInfo
info
     DatatypeInfo -> [NCon] -> Maybe Name -> DecsQ
makeConsPrisms DatatypeInfo
info ((ConstructorInfo -> NCon) -> [ConstructorInfo] -> [NCon]
forall a b. (a -> b) -> [a] -> [b]
map (DatatypeInfo -> ConstructorInfo -> NCon
normalizeCon DatatypeInfo
info) [ConstructorInfo]
cons) Maybe Name
cls

-- | Generate prisms for the given type, normalized constructors, and an
-- optional name to be used for generating a prism class. This function
-- dispatches between Iso generation, normal top-level prisms, and classy
-- prisms.
makeConsPrisms :: D.DatatypeInfo -> [NCon] -> Maybe Name -> DecsQ

-- top-level definitions
makeConsPrisms :: DatatypeInfo -> [NCon] -> Maybe Name -> DecsQ
makeConsPrisms DatatypeInfo
info [NCon]
cons Maybe Name
Nothing = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> DecsQ)
-> ((NCon -> DecsQ) -> Q [[Dec]]) -> (NCon -> DecsQ) -> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NCon] -> (NCon -> DecsQ) -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [NCon]
cons ((NCon -> DecsQ) -> DecsQ) -> (NCon -> DecsQ) -> DecsQ
forall a b. (a -> b) -> a -> b
$ \NCon
con -> do
  Stab
stab <- StabConfig -> Type -> [NCon] -> NCon -> Q Stab
computeOpticType StabConfig
defaultConfig Type
ty [NCon]
cons NCon
con
  let n :: Name
n = Name -> Name
prismName (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ Optic' A_Lens '[] NCon Name -> NCon -> Name
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens '[] NCon Name
nconName NCon
con
      body :: Q Exp
body = if Bool
isNewtype
             then Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'coerced
             else Stab -> [NCon] -> NCon -> Q Exp
makeConOpticExp Stab
stab [NCon]
cons NCon
con
  [Q Dec] -> DecsQ
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA ([Q Dec] -> DecsQ) -> [Q Dec] -> DecsQ
forall a b. (a -> b) -> a -> b
$
    [ Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
n (Q Type -> Q Dec) -> (Type -> Q Type) -> Type -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> (Type -> Type) -> Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
close (Type -> Q Dec) -> Type -> Q Dec
forall a b. (a -> b) -> a -> b
$ Stab -> Type
stabToType Stab
stab
    , Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
n) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []
    ] [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. [a] -> [a] -> [a]
++ Name -> [Q Dec]
inlinePragma Name
n
  where
    ty :: Type
ty        = DatatypeInfo -> Type -> Type
addKindInfo DatatypeInfo
info (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ DatatypeInfo -> Type
D.datatypeType DatatypeInfo
info
    isNewtype :: Bool
isNewtype = DatatypeInfo -> DatatypeVariant
D.datatypeVariant DatatypeInfo
info DatatypeVariant -> DatatypeVariant -> Bool
forall a. Eq a => a -> a -> Bool
== DatatypeVariant
D.Newtype

-- classy prism class and instance
makeConsPrisms DatatypeInfo
info [NCon]
cons (Just Name
typeName) =
  [Q Dec] -> DecsQ
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA
    [ Type -> Name -> Name -> [NCon] -> Q Dec
makeClassyPrismClass Type
ty Name
className Name
methodName [NCon]
cons
    , Type -> Name -> Name -> [NCon] -> Q Dec
makeClassyPrismInstance Type
ty Name
className Name
methodName [NCon]
cons
    ]
  where
    ty :: Type
ty = DatatypeInfo -> Type
D.datatypeType DatatypeInfo
info
    className :: Name
className = String -> Name
mkName (String
"As" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
typeName)
    methodName :: Name
methodName = Name -> Name
prismName Name
typeName

----------------------------------------

data StabConfig = StabConfig
  { StabConfig -> Bool
scForLabelInstance :: Bool
  , StabConfig -> Bool
scAllowIsos        :: Bool
  }

defaultConfig :: StabConfig
defaultConfig :: StabConfig
defaultConfig = StabConfig
  { scForLabelInstance :: Bool
scForLabelInstance = Bool
False
  , scAllowIsos :: Bool
scAllowIsos        = Bool
True
  }

classyConfig :: StabConfig
classyConfig :: StabConfig
classyConfig = StabConfig
  { scForLabelInstance :: Bool
scForLabelInstance = Bool
False
  , scAllowIsos :: Bool
scAllowIsos        = Bool
False
  }

labelConfig :: StabConfig
labelConfig :: StabConfig
labelConfig = StabConfig
  { scForLabelInstance :: Bool
scForLabelInstance = Bool
True
  , scAllowIsos :: Bool
scAllowIsos        = Bool
True
  }

data OpticType = IsoType | PrismType | ReviewType
  deriving OpticType -> OpticType -> Bool
(OpticType -> OpticType -> Bool)
-> (OpticType -> OpticType -> Bool) -> Eq OpticType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OpticType -> OpticType -> Bool
== :: OpticType -> OpticType -> Bool
$c/= :: OpticType -> OpticType -> Bool
/= :: OpticType -> OpticType -> Bool
Eq
data Stab  = Stab Bool Cxt OpticType Type Type Type Type

simplifyStab :: Stab -> Stab
simplifyStab :: Stab -> Stab
simplifyStab (Stab Bool
tvsCovered [Type]
cx OpticType
ty Type
_ Type
t Type
_ Type
b) = Bool -> [Type] -> OpticType -> Type -> Type -> Type -> Type -> Stab
Stab Bool
tvsCovered [Type]
cx OpticType
ty Type
t Type
t Type
b Type
b
  -- simplification uses t and b because those types
  -- are interesting in the Review case

stabSimple :: Stab -> Bool
stabSimple :: Stab -> Bool
stabSimple (Stab Bool
_ [Type]
_ OpticType
_ Type
s Type
t Type
a Type
b) = Type
s Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
t Bool -> Bool -> Bool
&& Type
a Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
b

stabToType :: Stab -> Type
stabToType :: Stab -> Type
stabToType stab :: Stab
stab@(Stab Bool
_ [Type]
cx OpticType
ty Type
s Type
t Type
a Type
b) = [TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [TyVarBndr Specificity]
vs [Type]
cx (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
  case OpticType
ty of
    OpticType
IsoType    | Stab -> Bool
stabSimple Stab
stab -> ''Iso'    Name -> [Type] -> Type
`conAppsT` [Type
s,Type
a]
               | Bool
otherwise       -> ''Iso     Name -> [Type] -> Type
`conAppsT` [Type
s,Type
t,Type
a,Type
b]
    OpticType
PrismType  | Stab -> Bool
stabSimple Stab
stab -> ''Prism'  Name -> [Type] -> Type
`conAppsT` [Type
s,Type
a]
               | Bool
otherwise       -> ''Prism   Name -> [Type] -> Type
`conAppsT` [Type
s,Type
t,Type
a,Type
b]
    OpticType
ReviewType                   -> ''Review  Name -> [Type] -> Type
`conAppsT` [Type
t,Type
b]

  where
    vs :: [TyVarBndr Specificity]
vs = Specificity -> [TyVarBndr_ ()] -> [TyVarBndr Specificity]
forall newFlag oldFlag.
newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
changeTVFlags Specificity
SpecifiedSpec
       ([TyVarBndr_ ()] -> [TyVarBndr Specificity])
-> (Set Type -> [TyVarBndr_ ()])
-> Set Type
-> [TyVarBndr Specificity]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Type] -> [TyVarBndr_ ()]
D.freeVariablesWellScoped
       ([Type] -> [TyVarBndr_ ()])
-> (Set Type -> [Type]) -> Set Type -> [TyVarBndr_ ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Type -> [Type]
forall a. Set a -> [a]
S.toList
       (Set Type -> [TyVarBndr Specificity])
-> Set Type -> [TyVarBndr Specificity]
forall a b. (a -> b) -> a -> b
$ Optic' A_Fold '[] [Type] Type -> [Type] -> Set Type
forall k a (is :: IxList) s.
(Is k A_Fold, Ord a) =>
Optic' k is s a -> s -> Set a
setOf (Optic' A_Fold '[] [Type] Type
forall (f :: * -> *) a. Foldable f => Fold (f a) a
folded Optic' A_Fold '[] [Type] Type
-> Optic A_Fold '[] Type Type Type Type
-> Optic' A_Fold '[] [Type] Type
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Fold '[] Type Type Type Type
typeVarsKinded) [Type]
cx

stabType :: Stab -> OpticType
stabType :: Stab -> OpticType
stabType (Stab Bool
_ [Type]
_ OpticType
o Type
_ Type
_ Type
_ Type
_) = OpticType
o

computeOpticType :: StabConfig -> Type -> [NCon] -> NCon -> Q Stab
computeOpticType :: StabConfig -> Type -> [NCon] -> NCon -> Q Stab
computeOpticType StabConfig
conf Type
t [NCon]
cons NCon
con =
  do let cons' :: [NCon]
cons' = NCon -> [NCon] -> [NCon]
forall a. Eq a => a -> [a] -> [a]
L.delete NCon
con [NCon]
cons
     if [Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (NCon -> [Name]
_nconVars NCon
con)
         then StabConfig -> Type -> [Type] -> [NCon] -> NCon -> Q Stab
computePrismType StabConfig
conf Type
t (Optic' A_Lens '[] NCon [Type] -> NCon -> [Type]
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens '[] NCon [Type]
nconCxt NCon
con) [NCon]
cons' NCon
con
         else Type -> [Type] -> [Type] -> Q Stab
computeReviewType Type
t (Optic' A_Lens '[] NCon [Type] -> NCon -> [Type]
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens '[] NCon [Type]
nconCxt NCon
con) (Optic' A_Lens '[] NCon [Type] -> NCon -> [Type]
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens '[] NCon [Type]
nconTypes NCon
con)

computeReviewType :: Type -> Cxt -> [Type] -> Q Stab
computeReviewType :: Type -> [Type] -> [Type] -> Q Stab
computeReviewType Type
t [Type]
cx [Type]
tys = do
  Type
b <- [Q Type] -> Q Type
toTupleT ((Type -> Q Type) -> [Type] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Type]
tys)
  Stab -> Q Stab
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> [Type] -> OpticType -> Type -> Type -> Type -> Type -> Stab
Stab Bool
False [Type]
cx OpticType
ReviewType Type
t Type
t Type
b Type
b)

-- | Compute the full type-changing Prism type given an outer type, list of
-- constructors, and target constructor name.
computePrismType :: StabConfig -> Type -> Cxt -> [NCon] -> NCon -> Q Stab
computePrismType :: StabConfig -> Type -> [Type] -> [NCon] -> NCon -> Q Stab
computePrismType StabConfig
conf Type
s [Type]
cx [NCon]
cons NCon
con = do
  let ts :: [Type]
ts       = Optic' A_Lens '[] NCon [Type] -> NCon -> [Type]
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens '[] NCon [Type]
nconTypes NCon
con
      free :: Set Name
free     = Optic' A_Traversal '[] Type Name -> Type -> Set Name
forall k a (is :: IxList) s.
(Is k A_Fold, Ord a) =>
Optic' k is s a -> s -> Set a
setOf Optic' A_Traversal '[] Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
s
      fixed :: Set Name
fixed    = Optic' A_Traversal '[] [NCon] Name -> [NCon] -> Set Name
forall k a (is :: IxList) s.
(Is k A_Fold, Ord a) =>
Optic' k is s a -> s -> Set a
setOf Optic' A_Traversal '[] [NCon] Name
forall t. HasTypeVars t => Traversal' t Name
typeVars [NCon]
cons
      phantoms :: Set Name
phantoms = Set Name
free Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
S.\\ Optic' A_Fold '[] [NCon] Name -> [NCon] -> Set Name
forall k a (is :: IxList) s.
(Is k A_Fold, Ord a) =>
Optic' k is s a -> s -> Set a
setOf (Fold [NCon] NCon
forall (f :: * -> *) a. Foldable f => Fold (f a) a
folded Fold [NCon] NCon
-> Optic' A_Lens '[] NCon [Type]
-> Optic A_Fold '[] [NCon] [NCon] [Type] [Type]
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic' A_Lens '[] NCon [Type]
nconTypes Optic A_Fold '[] [NCon] [NCon] [Type] [Type]
-> Optic A_Traversal '[] [Type] [Type] Name Name
-> Optic' A_Fold '[] [NCon] Name
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Traversal '[] [Type] [Type] Name Name
forall t. HasTypeVars t => Traversal' t Name
typeVars) (NCon
con NCon -> [NCon] -> [NCon]
forall a. a -> [a] -> [a]
: [NCon]
cons)

      unbound :: Set Name
unbound    = Set Name
free Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
S.\\ Set Name
fixed
      tvsCovered :: Bool
tvsCovered = if StabConfig -> Bool
scForLabelInstance StabConfig
conf
                   then Set Name -> Bool
forall a. Set a -> Bool
S.null Set Name
phantoms
                   else Bool
True
  Map Name Name
sub <- Map Name (Q Name) -> Q (Map Name Name)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a.
Applicative f =>
Map Name (f a) -> f (Map Name a)
sequenceA ((Name -> Q Name) -> Set Name -> Map Name (Q Name)
forall k a. (k -> a) -> Set k -> Map k a
M.fromSet (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> (Name -> String) -> Name -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) Set Name
unbound)
  Type
a   <- [Q Type] -> Q Type
toTupleT ((Type -> Q Type) -> [Type] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Type]
ts)
  Type
b   <- [Q Type] -> Q Type
toTupleT ((Type -> Q Type) -> [Type] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Name Name -> [Type] -> [Type]
forall t. HasTypeVars t => Map Name Name -> t -> t
substTypeVars Map Name Name
sub [Type]
ts))
  --runIO $ do
  --  putStrLn $ "S:        " ++ show s
  --  putStrLn $ "A:        " ++ show a
  --  putStrLn $ "FREE:     " ++ show free
  --  putStrLn $ "FIXED:    " ++ show fixed
  --  putStrLn $ "PHANTOMS: " ++ show phantoms
  --  putStrLn $ "UNBOUND:  " ++ show unbound
  let t :: Type
t = Map Name Name -> Type -> Type
forall t. HasTypeVars t => Map Name Name -> t -> t
substTypeVars Map Name Name
sub Type
s
      cx' :: [Type]
cx' = Map Name Name -> [Type] -> [Type]
forall t. HasTypeVars t => Map Name Name -> t -> t
substTypeVars Map Name Name
sub [Type]
cx
      otype :: OpticType
otype = if [NCon] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NCon]
cons Bool -> Bool -> Bool
&& StabConfig -> Bool
scAllowIsos StabConfig
conf
              then OpticType
IsoType
              else OpticType
PrismType
  Stab -> Q Stab
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> [Type] -> OpticType -> Type -> Type -> Type -> Type -> Stab
Stab Bool
tvsCovered [Type]
cx' OpticType
otype Type
s Type
t Type
a Type
b)

-- | Construct either a Review or Prism as appropriate
makeConOpticExp :: Stab -> [NCon] -> NCon -> ExpQ
makeConOpticExp :: Stab -> [NCon] -> NCon -> Q Exp
makeConOpticExp Stab
stab [NCon]
cons NCon
con =
  case Stab -> OpticType
stabType Stab
stab of
    OpticType
IsoType    -> NCon -> Q Exp
makeConIsoExp NCon
con
    OpticType
PrismType  -> Stab -> [NCon] -> NCon -> Q Exp
makeConPrismExp Stab
stab [NCon]
cons NCon
con
    OpticType
ReviewType -> NCon -> Q Exp
makeConReviewExp NCon
con

-- | Construct prism expression
--
-- prism <<reviewer>> <<remitter>>
makeConPrismExp ::
  Stab ->
  [NCon] {- ^ constructors       -} ->
  NCon   {- ^ target constructor -} ->
  ExpQ
makeConPrismExp :: Stab -> [NCon] -> NCon -> Q Exp
makeConPrismExp Stab
stab [NCon]
cons NCon
con = [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'prism, Q Exp
reviewer, Q Exp
remitter]
  where
  ts :: [Type]
ts = Optic' A_Lens '[] NCon [Type] -> NCon -> [Type]
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens '[] NCon [Type]
nconTypes NCon
con
  fields :: Int
fields  = [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts
  conName :: Name
conName = Optic' A_Lens '[] NCon Name -> NCon -> Name
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens '[] NCon Name
nconName NCon
con

  reviewer :: Q Exp
reviewer                   = Name -> Int -> Q Exp
makeReviewer       Name
conName Int
fields
  remitter :: Q Exp
remitter | Stab -> Bool
stabSimple Stab
stab = Name -> Int -> Q Exp
makeSimpleRemitter Name
conName Int
fields
           | Bool
otherwise       = [NCon] -> Name -> Q Exp
makeFullRemitter [NCon]
cons Name
conName


-- | Construct an Iso expression
--
-- iso <<reviewer>> <<remitter>>
makeConIsoExp :: NCon -> ExpQ
makeConIsoExp :: NCon -> Q Exp
makeConIsoExp NCon
con = [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'iso, Q Exp
remitter, Q Exp
reviewer]
  where
  conName :: Name
conName = Optic' A_Lens '[] NCon Name -> NCon -> Name
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens '[] NCon Name
nconName NCon
con
  fields :: Int
fields  = [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Optic' A_Lens '[] NCon [Type] -> NCon -> [Type]
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens '[] NCon [Type]
nconTypes NCon
con)

  reviewer :: Q Exp
reviewer = Name -> Int -> Q Exp
makeReviewer    Name
conName Int
fields
  remitter :: Q Exp
remitter = Name -> Int -> Q Exp
makeIsoRemitter Name
conName Int
fields


-- | Construct a Review expression
--
-- unto (\(x,y,z) -> Con x y z)
makeConReviewExp :: NCon -> ExpQ
makeConReviewExp :: NCon -> Q Exp
makeConReviewExp NCon
con = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'unto) Q Exp
reviewer
  where
  conName :: Name
conName = Optic' A_Lens '[] NCon Name -> NCon -> Name
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens '[] NCon Name
nconName NCon
con
  fields :: Int
fields  = [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Optic' A_Lens '[] NCon [Type] -> NCon -> [Type]
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens '[] NCon [Type]
nconTypes NCon
con)

  reviewer :: Q Exp
reviewer = Name -> Int -> Q Exp
makeReviewer Name
conName Int
fields


------------------------------------------------------------------------
-- Prism and Iso component builders
------------------------------------------------------------------------


-- | Construct the review portion of a prism.
--
-- (\(x,y,z) -> Con x y z) :: b -> t
makeReviewer :: Name -> Int -> ExpQ
makeReviewer :: Name -> Int -> Q Exp
makeReviewer Name
conName Int
fields =
  do [Name]
xs <- String -> Int -> Q [Name]
newNames String
"x" Int
fields
     Q Pat -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Exp
lam1E ([Q Pat] -> Q Pat
toTupleP ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
xs))
           (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName Q Exp -> [Q Exp] -> Q Exp
`appsE1` (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
xs)


-- | Construct the remit portion of a prism.
-- Pattern match only target constructor, no type changing
--
-- (\s -> case s of
--          Con x y z -> Right (x,y,z)
--          _         -> Left s
-- ) :: s -> Either s a
makeSimpleRemitter :: Name -> Int -> ExpQ
makeSimpleRemitter :: Name -> Int -> Q Exp
makeSimpleRemitter Name
conName Int
fields =
  do Name
x  <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
     [Name]
xs <- String -> Int -> Q [Name]
newNames String
"y" Int
fields
     let matches :: [Q Match]
matches =
           [ Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
xs))
                   (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'Right) ([Q Exp] -> Q Exp
toTupleE ((Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
xs))))
                   []
           , Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'Left) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x))) []
           ]
     Q Pat -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Exp
lam1E (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x) (Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) [Q Match]
matches)


-- | Pattern match all constructors to enable type-changing
--
-- (\s -> case s of
--          Con x y z -> Right (x,y,z)
--          Other_n w   -> Left (Other_n w)
-- ) :: s -> Either t a
makeFullRemitter :: [NCon] -> Name -> ExpQ
makeFullRemitter :: [NCon] -> Name -> Q Exp
makeFullRemitter [NCon]
cons Name
target =
  do Name
x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
     Q Pat -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Exp
lam1E (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x) (Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) ((NCon -> Q Match) -> [NCon] -> [Q Match]
forall a b. (a -> b) -> [a] -> [b]
map NCon -> Q Match
mkMatch [NCon]
cons))
  where
  mkMatch :: NCon -> Q Match
mkMatch (NCon Name
conName [Name]
_ [Type]
_ [Type]
n) =
    do [Name]
xs <- String -> Int -> Q [Name]
newNames String
"y" ([Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
n)
       Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
xs))
             (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
               (if Name
conName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
target
                  then Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'Right) ([Q Exp] -> Q Exp
toTupleE ((Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
xs))
                  else Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'Left) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName Q Exp -> [Q Exp] -> Q Exp
`appsE1` (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
xs)))
             []


-- | Construct the remitter suitable for use in an 'Iso'
--
-- (\(Con x y z) -> (x,y,z)) :: s -> a
makeIsoRemitter :: Name -> Int -> ExpQ
makeIsoRemitter :: Name -> Int -> Q Exp
makeIsoRemitter Name
conName Int
fields =
  do [Name]
xs <- String -> Int -> Q [Name]
newNames String
"x" Int
fields
     Q Pat -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Exp
lam1E (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
xs))
           ([Q Exp] -> Q Exp
toTupleE ((Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
xs))


------------------------------------------------------------------------
-- Classy prisms
------------------------------------------------------------------------


-- | Construct the classy prisms class for a given type and constructors.
--
-- class ClassName r <<vars in type>> | r -> <<vars in Type>> where
--   topMethodName   :: Prism' r Type
--   conMethodName_n :: Prism' r conTypes_n
--   conMethodName_n = topMethodName . conMethodName_n
makeClassyPrismClass ::
  Type   {- Outer type      -} ->
  Name   {- Class name      -} ->
  Name   {- Top method name -} ->
  [NCon] {- Constructors    -} ->
  DecQ
makeClassyPrismClass :: Type -> Name -> Name -> [NCon] -> Q Dec
makeClassyPrismClass Type
t Name
className Name
methodName [NCon]
cons =
  do Name
r <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"r"
     let methodType :: Q Type
methodType = Q Type -> [Q Type] -> Q Type
appsT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Prism') [Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
r,Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t]
     [[Dec]]
methodss <- (NCon -> DecsQ) -> [NCon] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Type -> NCon -> DecsQ
mkMethod (Name -> Type
VarT Name
r)) [NCon]
cons'
     Q [Type] -> Name -> [TyVarBndr_ ()] -> [FunDep] -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> Name -> [TyVarBndr_ ()] -> [FunDep] -> [m Dec] -> m Dec
classD ([Q Type] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt[]) Name
className ((Name -> TyVarBndr_ ()) -> [Name] -> [TyVarBndr_ ()]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr_ ()
plainTV (Name
r Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
vs)) (Name -> [FunDep]
fds Name
r)
       ( Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
methodName Q Type
methodType
       Q Dec -> [Q Dec] -> [Q Dec]
forall a. a -> [a] -> [a]
: (Dec -> Q Dec) -> [Dec] -> [Q Dec]
forall a b. (a -> b) -> [a] -> [b]
map Dec -> Q Dec
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
methodss)
       )

  where
  mkMethod :: Type -> NCon -> DecsQ
mkMethod Type
r NCon
con =
    do Stab Bool
tvsCovered [Type]
cx OpticType
o Type
_ Type
_ Type
_ Type
b <- StabConfig -> Type -> [NCon] -> NCon -> Q Stab
computeOpticType StabConfig
classyConfig Type
t [NCon]
cons NCon
con
       let stab' :: Stab
stab' = Bool -> [Type] -> OpticType -> Type -> Type -> Type -> Type -> Stab
Stab Bool
tvsCovered [Type]
cx OpticType
o Type
r Type
r Type
b Type
b
           defName :: Name
defName = Optic' A_Lens '[] NCon Name -> NCon -> Name
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens '[] NCon Name
nconName NCon
con
           body :: Q Exp
body    = [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE '(%), Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
methodName, Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
defName]
       [Q Dec] -> DecsQ
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA
         [ Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
defName        (Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Stab -> Type
stabToType Stab
stab'))
         , Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
defName) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []
         ]

  cons' :: [NCon]
cons'         = (NCon -> NCon) -> [NCon] -> [NCon]
forall a b. (a -> b) -> [a] -> [b]
map (Optic' A_Lens '[] NCon Name -> (Name -> Name) -> NCon -> NCon
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Optic' A_Lens '[] NCon Name
nconName Name -> Name
prismName) [NCon]
cons
  vs :: [Name]
vs            = Set Name -> [Name]
forall a. Set a -> [a]
S.toList (Optic' A_Traversal '[] Type Name -> Type -> Set Name
forall k a (is :: IxList) s.
(Is k A_Fold, Ord a) =>
Optic' k is s a -> s -> Set a
setOf Optic' A_Traversal '[] Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
t)
  fds :: Name -> [FunDep]
fds Name
r
    | [Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
vs   = []
    | Bool
otherwise = [[Name] -> [Name] -> FunDep
FunDep [Name
r] [Name]
vs]



-- | Construct the classy prisms instance for a given type and constructors.
--
-- instance Classname OuterType where
--   topMethodName = id
--   conMethodName_n = <<prism>>
makeClassyPrismInstance ::
  Type ->
  Name     {- Class name      -} ->
  Name     {- Top method name -} ->
  [NCon] {- Constructors    -} ->
  DecQ
makeClassyPrismInstance :: Type -> Name -> Name -> [NCon] -> Q Dec
makeClassyPrismInstance Type
s Name
className Name
methodName [NCon]
cons =
  do let vs :: [Name]
vs = Set Name -> [Name]
forall a. Set a -> [a]
S.toList (Optic' A_Traversal '[] Type Name -> Type -> Set Name
forall k a (is :: IxList) s.
(Is k A_Fold, Ord a) =>
Optic' k is s a -> s -> Set a
setOf Optic' A_Traversal '[] Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
s)
         cls :: Type
cls = Name
className Name -> [Type] -> Type
`conAppsT` (Type
s Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: (Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
vs)

     Q [Type] -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([Q Type] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt[]) (Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
cls)
       (   Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
methodName)
                (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'castOptic Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'equality)) []
       Q Dec -> [Q Dec] -> [Q Dec]
forall a. a -> [a] -> [a]
: [ do Stab
stab <- StabConfig -> Type -> [NCon] -> NCon -> Q Stab
computeOpticType StabConfig
classyConfig Type
s [NCon]
cons NCon
con
              let stab' :: Stab
stab' = Stab -> Stab
simplifyStab Stab
stab
              Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (Name -> Name
prismName Name
conName))
                (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Stab -> [NCon] -> NCon -> Q Exp
makeConOpticExp Stab
stab' [NCon]
cons NCon
con)) []
           | NCon
con <- [NCon]
cons
           , let conName :: Name
conName = Optic' A_Lens '[] NCon Name -> NCon -> Name
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens '[] NCon Name
nconName NCon
con
           ]
       )


------------------------------------------------------------------------
-- Utilities
------------------------------------------------------------------------


-- | Normalized constructor
data NCon = NCon
  { NCon -> Name
_nconName :: Name
  , NCon -> [Name]
_nconVars :: [Name]
  , NCon -> [Type]
_nconCxt  :: Cxt
  , NCon -> [Type]
_nconTypes :: [Type]
  }
  deriving (NCon -> NCon -> Bool
(NCon -> NCon -> Bool) -> (NCon -> NCon -> Bool) -> Eq NCon
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NCon -> NCon -> Bool
== :: NCon -> NCon -> Bool
$c/= :: NCon -> NCon -> Bool
/= :: NCon -> NCon -> Bool
Eq, Int -> NCon -> String -> String
[NCon] -> String -> String
NCon -> String
(Int -> NCon -> String -> String)
-> (NCon -> String) -> ([NCon] -> String -> String) -> Show NCon
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> NCon -> String -> String
showsPrec :: Int -> NCon -> String -> String
$cshow :: NCon -> String
show :: NCon -> String
$cshowList :: [NCon] -> String -> String
showList :: [NCon] -> String -> String
Show)

instance HasTypeVars NCon where
  typeVarsEx :: Set Name -> Traversal' NCon Name
typeVarsEx Set Name
s = TraversalVL NCon NCon Name Name -> Traversal' NCon Name
forall s t a b. TraversalVL s t a b -> Traversal s t a b
traversalVL (TraversalVL NCon NCon Name Name -> Traversal' NCon Name)
-> TraversalVL NCon NCon Name Name -> Traversal' NCon Name
forall a b. (a -> b) -> a -> b
$ \Name -> f Name
f (NCon Name
x [Name]
vars [Type]
y [Type]
z) ->
    let s' :: Set Name
s' = (Set Name -> Name -> Set Name) -> Set Name -> [Name] -> Set Name
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' ((Name -> Set Name -> Set Name) -> Set Name -> Name -> Set Name
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> Set Name -> Set Name
forall a. Ord a => a -> Set a -> Set a
S.insert) Set Name
s [Name]
vars
    in Name -> [Name] -> [Type] -> [Type] -> NCon
NCon Name
x [Name]
vars ([Type] -> [Type] -> NCon) -> f [Type] -> f ([Type] -> NCon)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Optic A_Traversal '[] [Type] [Type] Name Name
-> (Name -> f Name) -> [Type] -> f [Type]
forall k (f :: * -> *) (is :: IxList) s t a b.
(Is k A_Traversal, Applicative f) =>
Optic k is s t a b -> (a -> f b) -> s -> f t
traverseOf (Set Name -> Optic A_Traversal '[] [Type] [Type] Name Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s') Name -> f Name
f [Type]
y
                   f ([Type] -> NCon) -> f [Type] -> f NCon
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Optic A_Traversal '[] [Type] [Type] Name Name
-> (Name -> f Name) -> [Type] -> f [Type]
forall k (f :: * -> *) (is :: IxList) s t a b.
(Is k A_Traversal, Applicative f) =>
Optic k is s t a b -> (a -> f b) -> s -> f t
traverseOf (Set Name -> Optic A_Traversal '[] [Type] [Type] Name Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s') Name -> f Name
f [Type]
z

nconName :: Lens' NCon Name
nconName :: Optic' A_Lens '[] NCon Name
nconName = LensVL NCon NCon Name Name -> Optic' A_Lens '[] NCon Name
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL (LensVL NCon NCon Name Name -> Optic' A_Lens '[] NCon Name)
-> LensVL NCon NCon Name Name -> Optic' A_Lens '[] NCon Name
forall a b. (a -> b) -> a -> b
$ \Name -> f Name
f NCon
x -> (Name -> NCon) -> f Name -> f NCon
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Name
y -> NCon
x {_nconName = y}) (Name -> f Name
f (NCon -> Name
_nconName NCon
x))

nconCxt :: Lens' NCon Cxt
nconCxt :: Optic' A_Lens '[] NCon [Type]
nconCxt = LensVL NCon NCon [Type] [Type] -> Optic' A_Lens '[] NCon [Type]
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL (LensVL NCon NCon [Type] [Type] -> Optic' A_Lens '[] NCon [Type])
-> LensVL NCon NCon [Type] [Type] -> Optic' A_Lens '[] NCon [Type]
forall a b. (a -> b) -> a -> b
$ \[Type] -> f [Type]
f NCon
x -> ([Type] -> NCon) -> f [Type] -> f NCon
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[Type]
y -> NCon
x {_nconCxt = y}) ([Type] -> f [Type]
f (NCon -> [Type]
_nconCxt NCon
x))

nconTypes :: Lens' NCon [Type]
nconTypes :: Optic' A_Lens '[] NCon [Type]
nconTypes = LensVL NCon NCon [Type] [Type] -> Optic' A_Lens '[] NCon [Type]
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL (LensVL NCon NCon [Type] [Type] -> Optic' A_Lens '[] NCon [Type])
-> LensVL NCon NCon [Type] [Type] -> Optic' A_Lens '[] NCon [Type]
forall a b. (a -> b) -> a -> b
$ \[Type] -> f [Type]
f NCon
x -> ([Type] -> NCon) -> f [Type] -> f NCon
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[Type]
y -> NCon
x {_nconTypes = y}) ([Type] -> f [Type]
f (NCon -> [Type]
_nconTypes NCon
x))


-- | Normalize a single 'Con' to its constructor name and field types.
normalizeCon :: D.DatatypeInfo -> D.ConstructorInfo -> NCon
normalizeCon :: DatatypeInfo -> ConstructorInfo -> NCon
normalizeCon DatatypeInfo
di ConstructorInfo
info = NCon
  { _nconName :: Name
_nconName  = ConstructorInfo -> Name
D.constructorName ConstructorInfo
info
  , _nconVars :: [Name]
_nconVars  = TyVarBndr_ () -> Name
forall flag. TyVarBndr_ flag -> Name
D.tvName (TyVarBndr_ () -> Name) -> [TyVarBndr_ ()] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConstructorInfo -> [TyVarBndr_ ()]
D.constructorVars ConstructorInfo
info
  , _nconCxt :: [Type]
_nconCxt   = ConstructorInfo -> [Type]
D.constructorContext ConstructorInfo
info
  , _nconTypes :: [Type]
_nconTypes = let tyVars :: [Type]
tyVars = (TyVarBndr_ () -> Type) -> [TyVarBndr_ ()] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr_ () -> Type
forall flag. TyVarBndr_ flag -> Type
tyVarBndrToType (ConstructorInfo -> [TyVarBndr_ ()]
D.constructorVars ConstructorInfo
info)
                 in [Type] -> DatatypeInfo -> Type -> Type
addKindInfo' [Type]
tyVars DatatypeInfo
di (Type -> Type) -> [Type] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConstructorInfo -> [Type]
D.constructorFields ConstructorInfo
info
  }


-- | Compute a prism's name by prefixing an underscore for normal
-- constructors and period for operators.
prismName :: Name -> Name
prismName :: Name -> Name
prismName Name
n = case Name -> String
nameBase Name
n of
                [] -> String -> Name
forall a. HasCallStack => String -> a
error String
"prismName: empty name base?"
                Char
x:String
xs | Char -> Bool
isUpper Char
x -> String -> Name
mkName (Char
'_'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs)
                     | Bool
otherwise -> String -> Name
mkName (Char
'.'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs) -- operator


-- | Quantify all the free variables in a type.
close :: Type -> Type
close :: Type -> Type
close (ForallT [TyVarBndr Specificity]
vars [Type]
cx Type
ty) = [TyVarBndr Specificity] -> [Type] -> Type -> Type
quantifyType [TyVarBndr Specificity]
vars [Type]
cx Type
ty
close Type
ty                   = [TyVarBndr Specificity] -> [Type] -> Type -> Type
quantifyType []   [] Type
ty