{-# 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)
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 Cxt
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 NoIx 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 NoIx NCon Name
nconName NCon
con
          tyArgs :: Cxt
tyArgs = [TyLit -> Type
LitT (String -> TyLit
StrTyLit String
label), Type
k, Type
s, Type
t, Type
a', Type
b']
          context :: Cxt
context = [Cxt] -> Cxt
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 -> Cxt -> Type
conAppsT ''Dysfunctional Cxt
tyArgs]
            , [Type
cxtK, Type
cxtA, Type
cxtB]
            , Cxt
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
<$> CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD (Cxt -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cxt
context)
                         (Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> TypeQ) -> Type -> TypeQ
forall a b. (a -> b) -> a -> b
$ Name -> Cxt -> Type
conAppsT ''LabelOptic Cxt
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 = PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
n) (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Stab -> ExpQ
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 -> ExpQ
funDef Stab
stab
          | Bool
isNewtype = Name -> ExpQ
varE 'coerced
          | Bool
otherwise = Stab -> [NCon] -> NCon -> ExpQ
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 (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 NoIx 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 NoIx NCon Name
nconName NCon
con
      body :: ExpQ
body = if Bool
isNewtype
             then Name -> ExpQ
varE 'coerced
             else Stab -> [NCon] -> NCon -> ExpQ
makeConOpticExp Stab
stab [NCon]
cons NCon
con
  [Q Dec] -> DecsQ
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA ([Q Dec] -> DecsQ) -> [Q Dec] -> DecsQ
forall a b. (a -> b) -> a -> b
$
    [ Name -> TypeQ -> Q Dec
sigD Name
n (TypeQ -> Q Dec) -> (Type -> TypeQ) -> Type -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> TypeQ) -> (Type -> Type) -> Type -> TypeQ
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
    , PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
n) (ExpQ -> BodyQ
normalB ExpQ
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)
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 :: Bool -> Bool -> StabConfig
StabConfig
  { scForLabelInstance :: Bool
scForLabelInstance = Bool
False
  , scAllowIsos :: Bool
scAllowIsos        = Bool
True
  }

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

labelConfig :: StabConfig
labelConfig :: StabConfig
labelConfig = StabConfig :: Bool -> Bool -> StabConfig
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
/= :: OpticType -> OpticType -> Bool
$c/= :: OpticType -> OpticType -> Bool
== :: OpticType -> OpticType -> Bool
$c== :: OpticType -> OpticType -> Bool
Eq
data Stab  = Stab Bool Cxt OpticType Type Type Type Type

simplifyStab :: Stab -> Stab
simplifyStab :: Stab -> Stab
simplifyStab (Stab Bool
tvsCovered Cxt
cx OpticType
ty Type
_ Type
t Type
_ Type
b) = Bool -> Cxt -> OpticType -> Type -> Type -> Type -> Type -> Stab
Stab Bool
tvsCovered Cxt
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
_ Cxt
_ 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
_ Cxt
cx OpticType
ty Type
s Type
t Type
a Type
b) = [TyVarBndr] -> Cxt -> Type -> Type
ForallT [TyVarBndr]
vs Cxt
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 -> Cxt -> Type
`conAppsT` [Type
s,Type
a]
               | Bool
otherwise       -> ''Iso     Name -> Cxt -> Type
`conAppsT` [Type
s,Type
t,Type
a,Type
b]
    OpticType
PrismType  | Stab -> Bool
stabSimple Stab
stab -> ''Prism'  Name -> Cxt -> Type
`conAppsT` [Type
s,Type
a]
               | Bool
otherwise       -> ''Prism   Name -> Cxt -> Type
`conAppsT` [Type
s,Type
t,Type
a,Type
b]
    OpticType
ReviewType                   -> ''Review  Name -> Cxt -> Type
`conAppsT` [Type
t,Type
b]

  where
    vs :: [TyVarBndr]
vs = Specificity -> [TyVarBndr] -> [TyVarBndr]
forall newFlag oldFlag. newFlag -> [TyVarBndr] -> [TyVarBndr]
changeTVFlags Specificity
SpecifiedSpec
       ([TyVarBndr] -> [TyVarBndr])
-> (Set Type -> [TyVarBndr]) -> Set Type -> [TyVarBndr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cxt -> [TyVarBndr]
D.freeVariablesWellScoped
       (Cxt -> [TyVarBndr])
-> (Set Type -> Cxt) -> Set Type -> [TyVarBndr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Type -> Cxt
forall a. Set a -> [a]
S.toList
       (Set Type -> [TyVarBndr]) -> Set Type -> [TyVarBndr]
forall a b. (a -> b) -> a -> b
$ Optic' A_Fold NoIx Cxt Type -> Cxt -> 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 NoIx Cxt Type
forall (f :: * -> *) a. Foldable f => Fold (f a) a
folded Optic' A_Fold NoIx Cxt Type
-> Optic A_Fold NoIx Type Type Type Type
-> Optic' A_Fold NoIx Cxt 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 NoIx Type Type Type Type
typeVarsKinded) Cxt
cx

stabType :: Stab -> OpticType
stabType :: Stab -> OpticType
stabType (Stab Bool
_ Cxt
_ 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 (t :: * -> *) a. Foldable t => t a -> Bool
null (NCon -> [Name]
_nconVars NCon
con)
         then StabConfig -> Type -> Cxt -> [NCon] -> NCon -> Q Stab
computePrismType StabConfig
conf Type
t (Optic' A_Lens NoIx NCon Cxt -> NCon -> Cxt
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx NCon Cxt
nconCxt NCon
con) [NCon]
cons' NCon
con
         else Type -> Cxt -> Cxt -> Q Stab
computeReviewType Type
t (Optic' A_Lens NoIx NCon Cxt -> NCon -> Cxt
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx NCon Cxt
nconCxt NCon
con) (Optic' A_Lens NoIx NCon Cxt -> NCon -> Cxt
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx NCon Cxt
nconTypes NCon
con)

computeReviewType :: Type -> Cxt -> [Type] -> Q Stab
computeReviewType :: Type -> Cxt -> Cxt -> Q Stab
computeReviewType Type
t Cxt
cx Cxt
tys = do
  Type
b <- [TypeQ] -> TypeQ
toTupleT ((Type -> TypeQ) -> Cxt -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
tys)
  Stab -> Q Stab
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Cxt -> OpticType -> Type -> Type -> Type -> Type -> Stab
Stab Bool
False Cxt
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 -> Cxt -> [NCon] -> NCon -> Q Stab
computePrismType StabConfig
conf Type
s Cxt
cx [NCon]
cons NCon
con = do
  let ts :: Cxt
ts       = Optic' A_Lens NoIx NCon Cxt -> NCon -> Cxt
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx NCon Cxt
nconTypes NCon
con
      free :: Set Name
free     = Optic' A_Traversal NoIx 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 NoIx Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
s
      fixed :: Set Name
fixed    = Optic' A_Traversal NoIx [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 NoIx [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 NoIx [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 NoIx NCon Cxt
-> Optic A_Fold NoIx [NCon] [NCon] Cxt Cxt
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 NoIx NCon Cxt
nconTypes Optic A_Fold NoIx [NCon] [NCon] Cxt Cxt
-> Optic A_Traversal NoIx Cxt Cxt Name Name
-> Optic' A_Fold NoIx [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 NoIx Cxt Cxt 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)
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
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   <- [TypeQ] -> TypeQ
toTupleT ((Type -> TypeQ) -> Cxt -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
ts)
  Type
b   <- [TypeQ] -> TypeQ
toTupleT ((Type -> TypeQ) -> Cxt -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Name Name -> Cxt -> Cxt
forall t. HasTypeVars t => Map Name Name -> t -> t
substTypeVars Map Name Name
sub Cxt
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' :: Cxt
cx' = Map Name Name -> Cxt -> Cxt
forall t. HasTypeVars t => Map Name Name -> t -> t
substTypeVars Map Name Name
sub Cxt
cx
      otype :: OpticType
otype = if [NCon] -> 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 (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Cxt -> OpticType -> Type -> Type -> Type -> Type -> Stab
Stab Bool
tvsCovered Cxt
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 -> ExpQ
makeConOpticExp Stab
stab [NCon]
cons NCon
con =
  case Stab -> OpticType
stabType Stab
stab of
    OpticType
IsoType    -> NCon -> ExpQ
makeConIsoExp NCon
con
    OpticType
PrismType  -> Stab -> [NCon] -> NCon -> ExpQ
makeConPrismExp Stab
stab [NCon]
cons NCon
con
    OpticType
ReviewType -> NCon -> ExpQ
makeConReviewExp NCon
con

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

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


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

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


-- | Construct a Review expression
--
-- unto (\(x,y,z) -> Con x y z)
makeConReviewExp :: NCon -> ExpQ
makeConReviewExp :: NCon -> ExpQ
makeConReviewExp NCon
con = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'unto) ExpQ
reviewer
  where
  conName :: Name
conName = Optic' A_Lens NoIx 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 NoIx NCon Name
nconName NCon
con
  fields :: Int
fields  = Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Optic' A_Lens NoIx NCon Cxt -> NCon -> Cxt
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx NCon Cxt
nconTypes NCon
con)

  reviewer :: ExpQ
reviewer = Name -> Int -> ExpQ
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 -> ExpQ
makeReviewer Name
conName Int
fields =
  do [Name]
xs <- String -> Int -> Q [Name]
newNames String
"x" Int
fields
     PatQ -> ExpQ -> ExpQ
lam1E ([PatQ] -> PatQ
toTupleP ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
xs))
           (Name -> ExpQ
conE Name
conName ExpQ -> [ExpQ] -> ExpQ
`appsE1` (Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
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 -> ExpQ
makeSimpleRemitter Name
conName Int
fields =
  do Name
x  <- String -> Q Name
newName String
"x"
     [Name]
xs <- String -> Int -> Q [Name]
newNames String
"y" Int
fields
     let matches :: [MatchQ]
matches =
           [ PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
conName ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
xs))
                   (ExpQ -> BodyQ
normalB (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE 'Right) ([ExpQ] -> ExpQ
toTupleE ((Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
xs))))
                   []
           , PatQ -> BodyQ -> [Q Dec] -> MatchQ
match PatQ
wildP (ExpQ -> BodyQ
normalB (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE 'Left) (Name -> ExpQ
varE Name
x))) []
           ]
     PatQ -> ExpQ -> ExpQ
lam1E (Name -> PatQ
varP Name
x) (ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
x) [MatchQ]
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 -> ExpQ
makeFullRemitter [NCon]
cons Name
target =
  do Name
x <- String -> Q Name
newName String
"x"
     PatQ -> ExpQ -> ExpQ
lam1E (Name -> PatQ
varP Name
x) (ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
x) ((NCon -> MatchQ) -> [NCon] -> [MatchQ]
forall a b. (a -> b) -> [a] -> [b]
map NCon -> MatchQ
mkMatch [NCon]
cons))
  where
  mkMatch :: NCon -> MatchQ
mkMatch (NCon Name
conName [Name]
_ Cxt
_ Cxt
n) =
    do [Name]
xs <- String -> Int -> Q [Name]
newNames String
"y" (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
n)
       PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
conName ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
xs))
             (ExpQ -> BodyQ
normalB
               (if Name
conName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
target
                  then ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE 'Right) ([ExpQ] -> ExpQ
toTupleE ((Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
xs))
                  else ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE 'Left) (Name -> ExpQ
conE Name
conName ExpQ -> [ExpQ] -> ExpQ
`appsE1` (Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
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 -> ExpQ
makeIsoRemitter Name
conName Int
fields =
  do [Name]
xs <- String -> Int -> Q [Name]
newNames String
"x" Int
fields
     PatQ -> ExpQ -> ExpQ
lam1E (Name -> [PatQ] -> PatQ
conP Name
conName ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
xs))
           ([ExpQ] -> ExpQ
toTupleE ((Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
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
newName String
"r"
     let methodType :: TypeQ
methodType = TypeQ -> [TypeQ] -> TypeQ
appsT (Name -> TypeQ
conT ''Prism') [Name -> TypeQ
varT Name
r,Type -> TypeQ
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)
traverse (Type -> NCon -> DecsQ
mkMethod (Name -> Type
VarT Name
r)) [NCon]
cons'
     CxtQ -> Name -> [TyVarBndr] -> [FunDep] -> [Q Dec] -> Q Dec
classD ([TypeQ] -> CxtQ
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 -> TypeQ -> Q Dec
sigD Name
methodName TypeQ
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 (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 Cxt
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 -> Cxt -> OpticType -> Type -> Type -> Type -> Type -> Stab
Stab Bool
tvsCovered Cxt
cx OpticType
o Type
r Type
r Type
b Type
b
           defName :: Name
defName = Optic' A_Lens NoIx 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 NoIx NCon Name
nconName NCon
con
           body :: ExpQ
body    = [ExpQ] -> ExpQ
appsE [Name -> ExpQ
varE '(%), Name -> ExpQ
varE Name
methodName, Name -> ExpQ
varE Name
defName]
       [Q Dec] -> DecsQ
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
         [ Name -> TypeQ -> Q Dec
sigD Name
defName        (Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Stab -> Type
stabToType Stab
stab'))
         , PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
defName) (ExpQ -> BodyQ
normalB ExpQ
body) []
         ]

  cons' :: [NCon]
cons'         = (NCon -> NCon) -> [NCon] -> [NCon]
forall a b. (a -> b) -> [a] -> [b]
map (Optic' A_Lens NoIx 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 NoIx NCon Name
nconName Name -> Name
prismName) [NCon]
cons
  vs :: [Name]
vs            = Set Name -> [Name]
forall a. Set a -> [a]
S.toList (Optic' A_Traversal NoIx 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 NoIx Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
t)
  fds :: Name -> [FunDep]
fds Name
r
    | [Name] -> 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 NoIx 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 NoIx Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
s)
         cls :: Type
cls = Name
className Name -> Cxt -> Type
`conAppsT` (Type
s Type -> Cxt -> Cxt
forall a. a -> [a] -> [a]
: (Name -> Type) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
vs)

     CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD ([TypeQ] -> CxtQ
cxt[]) (Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
cls)
       (   PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
methodName)
                (ExpQ -> BodyQ
normalB (Name -> ExpQ
varE 'castOptic ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
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
              PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP (Name -> Name
prismName Name
conName))
                (ExpQ -> BodyQ
normalB (Stab -> [NCon] -> NCon -> ExpQ
makeConOpticExp Stab
stab' [NCon]
cons NCon
con)) []
           | NCon
con <- [NCon]
cons
           , let conName :: Name
conName = Optic' A_Lens NoIx 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 NoIx NCon Name
nconName NCon
con
           ]
       )


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


-- | Normalized constructor
data NCon = NCon
  { NCon -> Name
_nconName :: Name
  , NCon -> [Name]
_nconVars :: [Name]
  , NCon -> Cxt
_nconCxt  :: Cxt
  , NCon -> Cxt
_nconTypes :: [Type]
  }
  deriving (NCon -> NCon -> Bool
(NCon -> NCon -> Bool) -> (NCon -> NCon -> Bool) -> Eq NCon
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NCon -> NCon -> Bool
$c/= :: NCon -> NCon -> Bool
== :: NCon -> NCon -> Bool
$c== :: 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
showList :: [NCon] -> String -> String
$cshowList :: [NCon] -> String -> String
show :: NCon -> String
$cshow :: NCon -> String
showsPrec :: Int -> NCon -> String -> String
$cshowsPrec :: Int -> 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 x vars y z) ->
    let s' :: Set Name
s' = (Set Name -> Name -> Set Name) -> Set Name -> [Name] -> Set Name
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] -> Cxt -> Cxt -> NCon
NCon Name
x [Name]
vars (Cxt -> Cxt -> NCon) -> f Cxt -> f (Cxt -> NCon)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Optic A_Traversal NoIx Cxt Cxt Name Name
-> (Name -> f Name) -> Cxt -> f Cxt
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 NoIx Cxt Cxt Name Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s') Name -> f Name
f Cxt
y
                   f (Cxt -> NCon) -> f Cxt -> f NCon
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Optic A_Traversal NoIx Cxt Cxt Name Name
-> (Name -> f Name) -> Cxt -> f Cxt
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 NoIx Cxt Cxt Name Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s') Name -> f Name
f Cxt
z

nconName :: Lens' NCon Name
nconName :: Optic' A_Lens NoIx NCon Name
nconName = LensVL NCon NCon Name Name -> Optic' A_Lens NoIx 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 NoIx NCon Name)
-> LensVL NCon NCon Name Name -> Optic' A_Lens NoIx NCon Name
forall a b. (a -> b) -> a -> b
$ \Name -> f Name
f NCon
x -> (Name -> NCon) -> f Name -> f NCon
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Name
y -> NCon
x {_nconName :: Name
_nconName = Name
y}) (Name -> f Name
f (NCon -> Name
_nconName NCon
x))

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

nconTypes :: Lens' NCon [Type]
nconTypes :: Optic' A_Lens NoIx NCon Cxt
nconTypes = LensVL NCon NCon Cxt Cxt -> Optic' A_Lens NoIx NCon Cxt
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL (LensVL NCon NCon Cxt Cxt -> Optic' A_Lens NoIx NCon Cxt)
-> LensVL NCon NCon Cxt Cxt -> Optic' A_Lens NoIx NCon Cxt
forall a b. (a -> b) -> a -> b
$ \Cxt -> f Cxt
f NCon
x -> (Cxt -> NCon) -> f Cxt -> f NCon
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Cxt
y -> NCon
x {_nconTypes :: Cxt
_nconTypes = Cxt
y}) (Cxt -> f Cxt
f (NCon -> Cxt
_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 :: Name -> [Name] -> Cxt -> Cxt -> NCon
NCon
  { _nconName :: Name
_nconName  = ConstructorInfo -> Name
D.constructorName ConstructorInfo
info
  , _nconVars :: [Name]
_nconVars  = TyVarBndr -> Name
forall flag. TyVarBndr -> 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 :: Cxt
_nconCxt   = ConstructorInfo -> Cxt
D.constructorContext ConstructorInfo
info
  , _nconTypes :: Cxt
_nconTypes = let tyVars :: Cxt
tyVars = (TyVarBndr -> Type) -> [TyVarBndr] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
forall flag. TyVarBndr -> Type
tyVarBndrToType (ConstructorInfo -> [TyVarBndr]
D.constructorVars ConstructorInfo
info)
                 in Cxt -> DatatypeInfo -> Type -> Type
addKindInfo' Cxt
tyVars DatatypeInfo
di (Type -> Type) -> Cxt -> Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConstructorInfo -> Cxt
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]
vars Cxt
cx Type
ty) = [TyVarBndr] -> Cxt -> Type -> Type
quantifyType [TyVarBndr]
vars Cxt
cx Type
ty
close Type
ty                   = [TyVarBndr] -> Cxt -> Type -> Type
quantifyType []   [] Type
ty