{-# LANGUAGE CPP #-}
{-# LANGUAGE Trustworthy #-}

#if __GLASGOW_HASKELL__ >= 800
{-# OPTIONS_GHC -Wno-trustworthy-safe #-}
#endif

#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TemplateHaskellQuotes #-}
#else
{-# LANGUAGE TemplateHaskell #-}
#endif

{- |
Module      :  Lens.Micro.Pro.TH
Copyright   :  (C) 2014-2016 Eric Mertens, Edward Kmett; 2018 Monadfix
License     :  BSD-style (see the file LICENSE)

Template Haskell functions to automatically define prisms.
-}
module Lens.Micro.Pro.TH
(
  makePrisms,
  makeClassyPrisms,
)
where

import Lens.Micro.Pro
import Lens.Micro.TH.Internal
  (HasTypeVars(..), typeVars, substTypeVars, newNames, conAppsT, inlinePragma)

import Data.Char (isUpper)
import Data.List
import Data.Monoid
import qualified Data.Set as Set
import Data.Set (Set)
import Data.Traversable
import Language.Haskell.TH
import Language.Haskell.TH.Datatype.TyVarBndr
import qualified Language.Haskell.TH.Datatype as D
import qualified Data.Map as Map

-- | 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.
--
-- In the event that the name of a data type is also the name of one of its
-- constructors, the name of the 'Prism' generated for the data type will be
-- prefixed with an extra @_@ (if the data type name is prefix) or @.@ (if the
-- name is infix) to disambiguate it from the 'Prism' for the corresponding
-- constructor. For example, this code:
--
-- @
-- data Quux = Quux Int | Fred Bool
-- makeClassyPrisms ''Quux
-- @
--
-- will create:
--
-- @
-- class AsQuux s where
--   __Quux :: Prism' s Quux -- Data type prism
--   _Quux :: Prism' s Int   -- Constructor prism
--   _Fred :: Prism' s Bool
--
--   _Quux = __Quux . _Quux
--   _Fred = __Quux . _Fred
--
-- instance AsQuux Quux
-- @
makeClassyPrisms :: Name {- ^ Type constructor name -} -> DecsQ
makeClassyPrisms :: Name -> DecsQ
makeClassyPrisms = Bool -> Name -> DecsQ
makePrisms' Bool
False

-- | 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
     Type -> [NCon] -> Maybe Name -> DecsQ
makeConsPrisms (DatatypeInfo -> Type
D.datatypeType DatatypeInfo
info) ((ConstructorInfo -> NCon) -> [ConstructorInfo] -> [NCon]
forall a b. (a -> b) -> [a] -> [b]
map ConstructorInfo -> NCon
normalizeCon [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 :: Type -> [NCon] -> Maybe Name -> DecsQ

-- special case: single constructor, not classy -> make iso
makeConsPrisms :: Type -> [NCon] -> Maybe Name -> DecsQ
makeConsPrisms Type
t [con :: NCon
con@(NCon Name
_ [] [] [Type]
_)] Maybe Name
Nothing = Type -> NCon -> DecsQ
makeConIso Type
t NCon
con

-- top-level definitions
makeConsPrisms Type
t [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) -> Q [[Dec]] -> DecsQ
forall a b. (a -> b) -> a -> b
$ [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) -> Q [[Dec]]) -> (NCon -> DecsQ) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ \NCon
con ->
    do let conName :: Name
conName = Getting Name NCon Name -> NCon -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name NCon Name
Lens' NCon Name
nconName NCon
con
       Stab
stab <- Type -> [NCon] -> NCon -> Q Stab
computeOpticType Type
t [NCon]
cons NCon
con
       let n :: Name
n = Name -> Name
prismName Name
conName
       [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
n (Type -> Q Type
close (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 (Stab -> [NCon] -> NCon -> Q Exp
makeConOpticExp Stab
stab [NCon]
cons NCon
con)) []
           ]
           [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. [a] -> [a] -> [a]
++ Name -> [Q Dec]
inlinePragma Name
n
         )


-- classy prism class and instance
makeConsPrisms Type
t [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
t Name
className Name
methodName [NCon]
cons
    , Type -> Name -> Name -> [NCon] -> Q Dec
makeClassyPrismInstance Type
t Name
className Name
methodName [NCon]
cons
    ]
  where
  typeNameBase :: String
typeNameBase = Name -> String
nameBase Name
typeName
  className :: Name
className = String -> Name
mkName (String
"As" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typeNameBase)
  sameNameAsCon :: Bool
sameNameAsCon = (NCon -> Bool) -> [NCon] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\NCon
con -> Name -> String
nameBase (Getting Name NCon Name -> NCon -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name NCon Name
Lens' NCon Name
nconName NCon
con) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
typeNameBase) [NCon]
cons
  methodName :: Name
methodName = Bool -> Name -> Name
prismName' Bool
sameNameAsCon Name
typeName


data OpticType = PrismType | ReviewType
data Stab  = Stab Cxt OpticType Type Type Type Type

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

  where
  vs :: [TyVarBndr Specificity]
vs = (Name -> TyVarBndr Specificity)
-> [Name] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr Specificity
plainTVInferred
     ([Name] -> [TyVarBndr Specificity])
-> [Name] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
forall a. Eq a => [a] -> [a]
nub -- stable order
     ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ Getting (Endo [Name]) [Type] Name -> [Type] -> [Name]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf Getting (Endo [Name]) [Type] Name
forall t. HasTypeVars t => Traversal' t Name
Traversal' [Type] Name
typeVars [Type]
cx

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

computeOpticType :: Type -> [NCon] -> NCon -> Q Stab
computeOpticType :: Type -> [NCon] -> NCon -> Q Stab
computeOpticType Type
t [NCon]
cons NCon
con =
  do let cons' :: [NCon]
cons' = NCon -> [NCon] -> [NCon]
forall a. Eq a => a -> [a] -> [a]
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 Type -> [Type] -> [NCon] -> NCon -> Q Stab
computePrismType Type
t (Getting [Type] NCon [Type] -> NCon -> [Type]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Type] NCon [Type]
Lens' NCon [Type]
nconCxt NCon
con) [NCon]
cons' NCon
con
         else Type -> [Type] -> [Type] -> Q Stab
computeReviewType Type
t (Getting [Type] NCon [Type] -> NCon -> [Type]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Type] NCon [Type]
Lens' NCon [Type]
nconCxt NCon
con) (Getting [Type] NCon [Type] -> NCon -> [Type]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Type] NCon [Type]
Lens' NCon [Type]
nconTypes NCon
con)


computeReviewType :: Type -> Cxt -> [Type] -> Q Stab
computeReviewType :: Type -> [Type] -> [Type] -> Q Stab
computeReviewType Type
s' [Type]
cx [Type]
tys =
  do let t :: Type
t = Type
s'
     Type
s <- (Name -> Type) -> Q Name -> Q Type
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Type
VarT (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"s")
     Type
a <- (Name -> Type) -> Q Name -> Q Type
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Type
VarT (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"a")
     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 ([Type] -> OpticType -> Type -> Type -> Type -> Type -> Stab
Stab [Type]
cx OpticType
ReviewType Type
s Type
t Type
a Type
b)


-- | Compute the full type-changing Prism type given an outer type,
-- list of constructors, and target constructor name. Additionally
-- return 'True' if the resulting type is a "simple" prism.
computePrismType :: Type -> Cxt -> [NCon] -> NCon -> Q Stab
computePrismType :: Type -> [Type] -> [NCon] -> NCon -> Q Stab
computePrismType Type
t [Type]
cx [NCon]
cons NCon
con =
  do let ts :: [Type]
ts      = Getting [Type] NCon [Type] -> NCon -> [Type]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Type] NCon [Type]
Lens' NCon [Type]
nconTypes NCon
con
         unbound :: Set Name
unbound = Getting (Endo [Name]) Type Name -> Type -> Set Name
forall a s. Ord a => Getting (Endo [a]) s a -> s -> Set a
setOf Getting (Endo [Name]) Type Name
forall t. HasTypeVars t => Traversal' t Name
Traversal' Type Name
typeVars Type
t Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Getting (Endo [Name]) [NCon] Name -> [NCon] -> Set Name
forall a s. Ord a => Getting (Endo [a]) s a -> s -> Set a
setOf Getting (Endo [Name]) [NCon] Name
forall t. HasTypeVars t => Traversal' t Name
Traversal' [NCon] Name
typeVars [NCon]
cons
     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 v. (k -> v) -> Set k -> Map k v
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
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]
ts)
     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 (Map Name Name -> [Type] -> [Type]
forall t. HasTypeVars t => Map Name Name -> t -> t
substTypeVars Map Name Name
sub [Type]
ts))
     let s :: Type
s = Map Name Name -> Type -> Type
forall t. HasTypeVars t => Map Name Name -> t -> t
substTypeVars Map Name Name
sub Type
t
     Stab -> Q Stab
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type] -> OpticType -> Type -> Type -> Type -> Type -> Stab
Stab [Type]
cx OpticType
PrismType Type
s Type
t Type
a Type
b)


computeIsoType :: Type -> [Type] -> TypeQ
computeIsoType :: Type -> [Type] -> Q Type
computeIsoType Type
t' [Type]
fields =
  do 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 v. (k -> v) -> Set k -> Map k v
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) (Getting (Endo [Name]) Type Name -> Type -> Set Name
forall a s. Ord a => Getting (Endo [a]) s a -> s -> Set a
setOf Getting (Endo [Name]) Type Name
forall t. HasTypeVars t => Traversal' t Name
Traversal' Type Name
typeVars Type
t'))
     let t :: Q Type
t = Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return                    Type
t'
         s :: Q Type
s = 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
t')
         b :: Q 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]
fields)
         a :: Q 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 (Map Name Name -> [Type] -> [Type]
forall t. HasTypeVars t => Map Name Name -> t -> t
substTypeVars Map Name Name
sub [Type]
fields))
         ty :: Q Type
ty | Map Name Name -> Bool
forall k a. Map k a -> Bool
Map.null Map Name Name
sub = Q Type -> [Q Type] -> Q Type
appsT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Iso') [Q Type
t,Q Type
b]
            | Bool
otherwise    = Q Type -> [Q Type] -> Q Type
appsT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Iso) [Q Type
s,Q Type
t,Q Type
a,Q Type
b]

     Type -> Q Type
close (Type -> Q Type) -> Q Type -> Q Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q Type
ty



-- | 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
PrismType  -> Stab -> [NCon] -> NCon -> Q Exp
makeConPrismExp Stab
stab [NCon]
cons NCon
con
    OpticType
ReviewType -> NCon -> Q Exp
makeConReviewExp NCon
con


-- | Construct an iso declaration
makeConIso :: Type -> NCon -> DecsQ
makeConIso :: Type -> NCon -> DecsQ
makeConIso Type
s NCon
con =
  do let ty :: Q Type
ty      = Type -> [Type] -> Q Type
computeIsoType Type
s (Getting [Type] NCon [Type] -> NCon -> [Type]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Type] NCon [Type]
Lens' NCon [Type]
nconTypes NCon
con)
         defName :: Name
defName = Name -> Name
prismName (Getting Name NCon Name -> NCon -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name NCon Name
Lens' NCon Name
nconName 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
       ( [ Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD       Name
defName  Q Type
ty
         , 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 (NCon -> Q Exp
makeConIsoExp NCon
con)) []
         ] [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. [a] -> [a] -> [a]
++
         Name -> [Q Dec]
inlinePragma Name
defName
       )


-- | 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 = Getting [Type] NCon [Type] -> NCon -> [Type]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Type] NCon [Type]
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 = Getting Name NCon Name -> NCon -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name NCon Name
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 = Getting Name NCon Name -> NCon -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name NCon Name
Lens' NCon Name
nconName NCon
con
  fields :: Int
fields  = [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Getting [Type] NCon [Type] -> NCon -> [Type]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Type] NCon [Type]
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 = Getting Name NCon Name -> NCon -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name NCon Name
Lens' NCon Name
nconName NCon
con
  fields :: Int
fields  = [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Getting [Type] NCon [Type] -> NCon -> [Type]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Type] NCon [Type]
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
--
-- (\x -> case s of
--          Con x y z -> Right (x,y,z)
--          _         -> Left x
-- ) :: 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
--
-- (\x -> 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 [Type]
cx OpticType
o Type
_ Type
_ Type
_ Type
b <- Type -> [NCon] -> NCon -> Q Stab
computeOpticType Type
t [NCon]
cons NCon
con
       let stab' :: Stab
stab' = [Type] -> OpticType -> Type -> Type -> Type -> Type -> Stab
Stab [Type]
cx OpticType
o Type
r Type
r Type
b Type
b
           defName :: Name
defName = Getting Name NCon Name -> NCon -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name NCon Name
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 (ASetter NCon NCon Name Name -> (Name -> Name) -> NCon -> NCon
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter NCon NCon Name Name
Lens' NCon Name
nconName Name -> Name
prismName) [NCon]
cons
  vs :: [Name]
vs            = Set Name -> [Name]
forall a. Set a -> [a]
Set.toList (Getting (Endo [Name]) Type Name -> Type -> Set Name
forall a s. Ord a => Getting (Endo [a]) s a -> s -> Set a
setOf Getting (Endo [Name]) Type Name
forall t. HasTypeVars t => Traversal' t Name
Traversal' Type 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]
Set.toList (Getting (Endo [Name]) Type Name -> Type -> Set Name
forall a s. Ord a => Getting (Endo [a]) s a -> s -> Set a
setOf Getting (Endo [Name]) Type Name
forall t. HasTypeVars t => Traversal' t Name
Traversal' Type 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 'id)) []
       Q Dec -> [Q Dec] -> [Q Dec]
forall a. a -> [a] -> [a]
: [ do Stab
stab <- Type -> [NCon] -> NCon -> Q Stab
computeOpticType 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 = Getting Name NCon Name -> NCon -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name NCon Name
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)

nconName :: Lens' NCon Name
nconName :: Lens' NCon Name
nconName 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 :: Lens' NCon [Type]
nconCxt [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 :: Lens' NCon [Type]
nconTypes [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))

instance HasTypeVars NCon where
  typeVarsEx :: Set Name -> Traversal' NCon Name
typeVarsEx Set Name
s Name -> f Name
f (NCon Name
x [Name]
vars [Type]
y [Type]
z) = 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
<$> Set Name -> Traversal' [Type] 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
<*> Set Name -> Traversal' [Type] Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s' Name -> f Name
f [Type]
z
    where 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
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
Set.insert) Set Name
s [Name]
vars

-- | Normalize a single 'Con' to its constructor name and field types.
normalizeCon :: D.ConstructorInfo -> NCon
normalizeCon :: ConstructorInfo -> NCon
normalizeCon ConstructorInfo
info = Name -> [Name] -> [Type] -> [Type] -> NCon
NCon (ConstructorInfo -> Name
D.constructorName ConstructorInfo
info)
                         (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)
                         (ConstructorInfo -> [Type]
D.constructorContext ConstructorInfo
info)
                         (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 = Bool -> Name -> Name
prismName' Bool
False

prismName' :: Bool -- ^ This is 'True' in the event that:
                   --
                   -- 1. We are generating the name of a classy prism for a
                   --    data type, and
                   -- 2. The data type shares a name with one of its
                   --    constructors (e.g., @data A = A@).
                   --
                   -- In such a scenario, we take care not to generate the same
                   -- prism name that the constructor receives (e.g., @_A@).
                   -- For prefix names, we accomplish this by adding an extra
                   -- underscore; for infix names, an extra dot.
           -> Name -> Name
prismName' :: Bool -> Name -> Name
prismName' Bool
sameNameAsCon Name
n =
  case Name -> String
nameBase Name
n of
    [] -> String -> Name
forall a. HasCallStack => String -> a
error String
"prismName: empty name base?"
    nb :: String
nb@(Char
x:String
_) | Char -> Bool
isUpper Char
x -> String -> Name
mkName (Char -> String -> String
prefix Char
'_' String
nb)
             | Bool
otherwise -> String -> Name
mkName (Char -> String -> String
prefix Char
'.' String
nb) -- operator
  where
    prefix :: Char -> String -> String
    prefix :: Char -> String -> String
prefix Char
char String
str | Bool
sameNameAsCon = Char
charChar -> String -> String
forall a. a -> [a] -> [a]
:Char
charChar -> String -> String
forall a. a -> [a] -> [a]
:String
str
                    | Bool
otherwise     =      Char
charChar -> String -> String
forall a. a -> [a] -> [a]
:String
str


-- | Quantify all the free variables in a type.
close :: Type -> TypeQ
close :: Type -> Q Type
close Type
t = [TyVarBndr Specificity] -> Q [Type] -> Q Type -> Q Type
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m [Type] -> m Type -> m Type
forallT ((Name -> TyVarBndr Specificity)
-> [Name] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr Specificity
plainTVInferred (Set Name -> [Name]
forall a. Set a -> [a]
Set.toList Set Name
vs)) ([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
t)
  where
  vs :: Set Name
vs = Getting (Endo [Name]) Type Name -> Type -> Set Name
forall a s. Ord a => Getting (Endo [a]) s a -> s -> Set a
setOf Getting (Endo [Name]) Type Name
forall t. HasTypeVars t => Traversal' t Name
Traversal' Type Name
typeVars Type
t

setOf :: Ord a => Getting (Endo [a]) s a -> s -> Set a
setOf :: forall a s. Ord a => Getting (Endo [a]) s a -> s -> Set a
setOf Getting (Endo [a]) s a
l s
s = [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList (s
s s -> Getting (Endo [a]) s a -> [a]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [a]) s a
l)

-- @fromSet@ wasn't always there, and we need compatibility with
-- containers-0.4 to compile on GHC 7.4.
fromSet :: (k -> v) -> Set.Set k -> Map.Map k v
#if MIN_VERSION_containers(0,5,0)
fromSet :: forall k v. (k -> v) -> Set k -> Map k v
fromSet = (k -> v) -> Set k -> Map k v
forall k v. (k -> v) -> Set k -> Map k v
Map.fromSet
#else
fromSet f x = Map.fromDistinctAscList [ (k,f k) | k <- Set.toAscList x ]
#endif

-- | Apply arguments to a type constructor
appsT :: TypeQ -> [TypeQ] -> TypeQ
appsT :: Q Type -> [Q Type] -> Q Type
appsT = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT

-- | Apply arguments to a function
appsE1 :: ExpQ -> [ExpQ] -> ExpQ
appsE1 :: Q Exp -> [Q Exp] -> Q Exp
appsE1 = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE

-- | Construct a tuple type given a list of types.
toTupleT :: [TypeQ] -> TypeQ
toTupleT :: [Q Type] -> Q Type
toTupleT [Q Type
x] = Q Type
x
toTupleT [Q Type]
xs = Q Type -> [Q Type] -> Q Type
appsT (Int -> Q Type
forall (m :: * -> *). Quote m => Int -> m Type
tupleT ([Q Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Q Type]
xs)) [Q Type]
xs

-- | Construct a tuple value given a list of expressions.
toTupleE :: [ExpQ] -> ExpQ
toTupleE :: [Q Exp] -> Q Exp
toTupleE [Q Exp
x] = Q Exp
x
toTupleE [Q Exp]
xs = [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE [Q Exp]
xs

-- | Construct a tuple pattern given a list of patterns.
toTupleP :: [PatQ] -> PatQ
toTupleP :: [Q Pat] -> Q Pat
toTupleP [Q Pat
x] = Q Pat
x
toTupleP [Q Pat]
xs = [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [Q Pat]
xs