{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}

-- | This module re-exports a subset of `Yaya.Fold`, intended for when you want
--   to define recursion scheme instances for your existing recursive types.
--
--   This is /not/ the recommended way to use Yaya, but it solves some real
--   problems:
-- 1. you have existing directly-recursive types and you want to start taking
--    advantage of recursion schemes without having to rewrite your existing
--    code, or
-- 2. a directly-recursive type has been imposed on you by some other library
--    and you want to take advantage of recursion schemes.
--
--   The distinction between these two cases is whether you have control of the
--   @data@ declaration. In the first case, you probably do. In that case, you
--   should only generate the /safe/ instances, and ensure that all the
--   recursive type references are /strict/ (if you want a `Recursive`
--   instance). If you don't have control, then you /may/ need to generate all
--   instances.
--
--   Another difference when you have control is that it means you may migrate
--   away from direct recursion entirely, at which point this import should
--   disappear.
module Yaya.Retrofit
  ( module Yaya.Fold,
    PatternFunctorRules (..),
    defaultRules,
    extractPatternFunctor,
  )
where

import Control.Exception (Exception (..), throw)
import Control.Monad ((<=<))
import Data.Bifunctor (bimap)
import Data.Either.Validation (Validation (..), validationToEither)
import Data.Functor.Identity (Identity (..))
import Data.List.NonEmpty (NonEmpty)
import Language.Haskell.TH as TH
import Language.Haskell.TH.Datatype as TH.Abs
import Language.Haskell.TH.Syntax (mkNameG_tc)
import Text.Read.Lex (isSymbolChar)
import Yaya.Fold
  ( Corecursive (..),
    Projectable (..),
    Recursive (..),
    Steppable (..),
    recursiveEq,
    recursiveShowsPrec,
  )

#if MIN_VERSION_template_haskell(2, 17, 0)
type TyVarBndr' = TyVarBndr ()
#else
type TyVarBndr' = TyVarBndr
#endif

conP' :: Name -> [Pat] -> Pat
#if MIN_VERSION_template_haskell(2, 18, 0)
conP' n = ConP n []
#else
conP' :: Name -> [Pat] -> Pat
conP' = Name -> [Pat] -> Pat
ConP
#endif

-- | Extract a pattern functor and relevant instances from a simply recursive type.
--
-- /e.g./
--
-- @
-- data Expr a
--     = Lit a
--     | Add (Expr a) (Expr a)
--     | Expr a :* [Expr a]
--   deriving (Show)
--
-- `extractPatternFunctor` `defaultRules` ''Expr
-- @
--
-- will create
--
-- @
-- data ExprF a x
--     = LitF a
--     | AddF x x
--     | x :*$ [x]
--   deriving ('Functor', 'Foldable', 'Traversable')
--
-- instance `Projectable` (->) (Expr a) (ExprF a) where
--   `project` (Lit x)   = LitF x
--   `project` (Add x y) = AddF x y
--   `project` (x :* y)  = x :*$ y
--
-- instance `Steppable` (->) (Expr a) (ExprF a) where
--   `embed` (LitF x)   = Lit x
--   `embed` (AddF x y) = Add x y
--   `embed` (x :*$ y)  = x :* y
--
-- instance `Recursive` (->) (Expr a) (ExprF a) where
--   `cata` φ = φ . `fmap` (`cata` φ) . `project`
--
-- instance `Corecursive` (->) (Expr a) (ExprF a) where
--   `ana` ψ = `embed` . `fmap` (`ana` ψ) . ψ
-- @
--
-- /Notes:/
--
-- - `extractPatternFunctor` works properly only with ADTs.
--   Existentials and GADTs aren't supported,
--   as we don't try to do better than
--   <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#deriving-functor-instances GHC's DeriveFunctor>.
-- - we always generate both `Recursive` and `Corecursive` instances, but one of these is always unsafe.
--   In future, we should check the strictness of the recursive parameter and generate only the appropriate one (unless overridden by a rule).
extractPatternFunctor :: PatternFunctorRules -> Name -> Q [Dec]
extractPatternFunctor :: PatternFunctorRules -> Name -> Q [Dec]
extractPatternFunctor PatternFunctorRules
rules =
  (UnsupportedDatatype -> Q [Dec])
-> (Q [Dec] -> Q [Dec])
-> Either UnsupportedDatatype (Q [Dec])
-> Q [Dec]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either UnsupportedDatatype -> Q [Dec]
forall a e. Exception e => e -> a
throw Q [Dec] -> Q [Dec]
forall a. a -> a
id (Either UnsupportedDatatype (Q [Dec]) -> Q [Dec])
-> (DatatypeInfo -> Either UnsupportedDatatype (Q [Dec]))
-> DatatypeInfo
-> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatternFunctorRules
-> DatatypeInfo -> Either UnsupportedDatatype (Q [Dec])
makePrimForDI PatternFunctorRules
rules (DatatypeInfo -> Q [Dec])
-> (Name -> Q DatatypeInfo) -> Name -> Q [Dec]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> Q DatatypeInfo
reifyDatatype

-- | Rules of renaming data names
data PatternFunctorRules = PatternFunctorRules
  { PatternFunctorRules -> Name -> Name
patternType :: Name -> Name,
    PatternFunctorRules -> Name -> Name
patternCon :: Name -> Name,
    PatternFunctorRules -> Name -> Name
patternField :: Name -> Name
  }

-- | Default 'PatternFunctorRules': append @F@ or @$@ to data type, constructors and field names.
defaultRules :: PatternFunctorRules
defaultRules :: PatternFunctorRules
defaultRules =
  PatternFunctorRules :: (Name -> Name)
-> (Name -> Name) -> (Name -> Name) -> PatternFunctorRules
PatternFunctorRules
    { patternType :: Name -> Name
patternType = Name -> Name
toFName,
      patternCon :: Name -> Name
patternCon = Name -> Name
toFName,
      patternField :: Name -> Name
patternField = Name -> Name
toFName
    }

toFName :: Name -> Name
toFName :: Name -> Name
toFName = String -> Name
mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
f (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
  where
    f :: String -> String
f String
name
      | String -> Bool
isInfixName String
name = String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"$"
      | Bool
otherwise = String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"F"

    isInfixName :: String -> Bool
    isInfixName :: String -> Bool
isInfixName = (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSymbolChar

data UnsupportedDatatype
  = UnsupportedInstTypes (NonEmpty Type)
  | UnsupportedVariant DatatypeVariant

instance Show UnsupportedDatatype where
  show :: UnsupportedDatatype -> String
show = \case
    UnsupportedInstTypes NonEmpty Type
tys ->
      String
"extractPatternFunctor: Couldn't process the following types " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> NonEmpty Type -> String
forall a. Show a => a -> String
show NonEmpty Type
tys
    UnsupportedVariant DatatypeVariant
_variant ->
      String
"extractPatternFunctor: Data families are currently not supported."

instance Exception UnsupportedDatatype

makePrimForDI ::
  PatternFunctorRules -> DatatypeInfo -> Either UnsupportedDatatype (Q [Dec])
makePrimForDI :: PatternFunctorRules
-> DatatypeInfo -> Either UnsupportedDatatype (Q [Dec])
makePrimForDI
  PatternFunctorRules
rules
  ( DatatypeInfo
      { datatypeName :: DatatypeInfo -> Name
datatypeName = Name
tyName,
        datatypeInstTypes :: DatatypeInfo -> [Type]
datatypeInstTypes = [Type]
instTys,
        datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons,
        datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant = DatatypeVariant
variant
      }
    ) =
    if Bool
isDataFamInstance
      then UnsupportedDatatype -> Either UnsupportedDatatype (Q [Dec])
forall a b. a -> Either a b
Left (UnsupportedDatatype -> Either UnsupportedDatatype (Q [Dec]))
-> UnsupportedDatatype -> Either UnsupportedDatatype (Q [Dec])
forall a b. (a -> b) -> a -> b
$ DatatypeVariant -> UnsupportedDatatype
UnsupportedVariant DatatypeVariant
variant
      else
        (NonEmpty Type -> UnsupportedDatatype)
-> ([TyVarBndr'] -> Q [Dec])
-> Either (NonEmpty Type) [TyVarBndr']
-> Either UnsupportedDatatype (Q [Dec])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap
          NonEmpty Type -> UnsupportedDatatype
UnsupportedInstTypes
          (([TyVarBndr'] -> [ConstructorInfo] -> Q [Dec])
-> [ConstructorInfo] -> [TyVarBndr'] -> Q [Dec]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (PatternFunctorRules
-> Bool -> Name -> [TyVarBndr'] -> [ConstructorInfo] -> Q [Dec]
makePrimForDI' PatternFunctorRules
rules (DatatypeVariant
variant DatatypeVariant -> DatatypeVariant -> Bool
forall a. Eq a => a -> a -> Bool
== DatatypeVariant
Newtype) Name
tyName) [ConstructorInfo]
cons)
          (Either (NonEmpty Type) [TyVarBndr']
 -> Either UnsupportedDatatype (Q [Dec]))
-> (Validation (NonEmpty Type) [TyVarBndr']
    -> Either (NonEmpty Type) [TyVarBndr'])
-> Validation (NonEmpty Type) [TyVarBndr']
-> Either UnsupportedDatatype (Q [Dec])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validation (NonEmpty Type) [TyVarBndr']
-> Either (NonEmpty Type) [TyVarBndr']
forall e a. Validation e a -> Either e a
validationToEither
          (Validation (NonEmpty Type) [TyVarBndr']
 -> Either UnsupportedDatatype (Q [Dec]))
-> Validation (NonEmpty Type) [TyVarBndr']
-> Either UnsupportedDatatype (Q [Dec])
forall a b. (a -> b) -> a -> b
$ (Type -> Validation (NonEmpty Type) TyVarBndr')
-> [Type] -> Validation (NonEmpty Type) [TyVarBndr']
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\Type
ty -> Validation (NonEmpty Type) TyVarBndr'
-> (TyVarBndr' -> Validation (NonEmpty Type) TyVarBndr')
-> Maybe TyVarBndr'
-> Validation (NonEmpty Type) TyVarBndr'
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (NonEmpty Type -> Validation (NonEmpty Type) TyVarBndr'
forall e a. e -> Validation e a
Failure (NonEmpty Type -> Validation (NonEmpty Type) TyVarBndr')
-> NonEmpty Type -> Validation (NonEmpty Type) TyVarBndr'
forall a b. (a -> b) -> a -> b
$ Type -> NonEmpty Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty) TyVarBndr' -> Validation (NonEmpty Type) TyVarBndr'
forall e a. a -> Validation e a
Success (Maybe TyVarBndr' -> Validation (NonEmpty Type) TyVarBndr')
-> Maybe TyVarBndr' -> Validation (NonEmpty Type) TyVarBndr'
forall a b. (a -> b) -> a -> b
$ Type -> Maybe TyVarBndr'
toTyVarBndr Type
ty) [Type]
instTys
    where
      isDataFamInstance :: Bool
isDataFamInstance = case DatatypeVariant
variant of
        DatatypeVariant
DataInstance -> Bool
True
        DatatypeVariant
NewtypeInstance -> Bool
True
        DatatypeVariant
Datatype -> Bool
False
        DatatypeVariant
Newtype -> Bool
False

      toTyVarBndr :: Type -> Maybe TyVarBndr'
      toTyVarBndr :: Type -> Maybe TyVarBndr'
toTyVarBndr (VarT Name
n) = TyVarBndr' -> Maybe TyVarBndr'
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TyVarBndr' -> Maybe TyVarBndr') -> TyVarBndr' -> Maybe TyVarBndr'
forall a b. (a -> b) -> a -> b
$ Name -> TyVarBndr'
plainTV Name
n
      toTyVarBndr (SigT (VarT Name
n) Type
k) = TyVarBndr' -> Maybe TyVarBndr'
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TyVarBndr' -> Maybe TyVarBndr') -> TyVarBndr' -> Maybe TyVarBndr'
forall a b. (a -> b) -> a -> b
$ Name -> Type -> TyVarBndr'
kindedTV Name
n Type
k
      toTyVarBndr Type
_ = Maybe TyVarBndr'
forall a. Maybe a
Nothing

-- TH 2.12.O means GHC 8.2.1, otherwise, we work back to GHC 8.0.1
#if MIN_VERSION_template_haskell(2, 12, 0)
deriveds :: [DerivClause]
deriveds :: [DerivClause]
deriveds =
  DerivClause -> [DerivClause]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DerivClause -> [DerivClause]) -> DerivClause -> [DerivClause]
forall a b. (a -> b) -> a -> b
$
    Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause
      Maybe DerivStrategy
forall a. Maybe a
Nothing
      [ Name -> Type
ConT Name
functorTypeName,
        Name -> Type
ConT Name
foldableTypeName,
        Name -> Type
ConT Name
traversableTypeName
      ]
#else
deriveds :: [TH.Type]
deriveds =
  [ ConT functorTypeName,
    ConT foldableTypeName,
    ConT traversableTypeName
  ]
#endif

makePrimForDI' ::
  PatternFunctorRules -> Bool -> Name -> [TyVarBndr'] -> [ConstructorInfo] -> Q [Dec]
makePrimForDI' :: PatternFunctorRules
-> Bool -> Name -> [TyVarBndr'] -> [ConstructorInfo] -> Q [Dec]
makePrimForDI' PatternFunctorRules
rules Bool
isNewtype Name
tyName [TyVarBndr']
vars [ConstructorInfo]
cons = do
  -- variable parameters
  let vars' :: [Type]
vars' = (Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT ([TyVarBndr'] -> [Name]
typeVars [TyVarBndr']
vars)
  -- Name of base functor
  let tyNameF :: Name
tyNameF = PatternFunctorRules -> Name -> Name
patternType PatternFunctorRules
rules Name
tyName
  -- Recursive type
  let s :: Type
s = Name -> [Type] -> Type
conAppsT Name
tyName [Type]
vars'
  -- Additional argument
  Name
rName <- String -> Q Name
newName String
"r"
  let r :: Type
r = Name -> Type
VarT Name
rName

  -- Vars
  let varsF :: [TyVarBndr']
varsF = [TyVarBndr']
vars [TyVarBndr'] -> [TyVarBndr'] -> [TyVarBndr']
forall a. [a] -> [a] -> [a]
++ [Name -> TyVarBndr'
plainTV Name
rName]

  -- #33
  [ConstructorInfo]
cons' <- (ConstructorInfo -> Q ConstructorInfo)
-> [ConstructorInfo] -> Q [ConstructorInfo]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Type -> Q Type) -> ConstructorInfo -> Q ConstructorInfo
Traversal' ConstructorInfo Type
conTypeTraversal Type -> Q Type
resolveTypeSynonyms) [ConstructorInfo]
cons
  let consF :: [Con]
consF =
        ConstructorInfo -> Con
toCon
          (ConstructorInfo -> Con)
-> (ConstructorInfo -> ConstructorInfo) -> ConstructorInfo -> Con
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Name) -> ConstructorInfo -> ConstructorInfo
conNameMap (PatternFunctorRules -> Name -> Name
patternCon PatternFunctorRules
rules)
          (ConstructorInfo -> ConstructorInfo)
-> (ConstructorInfo -> ConstructorInfo)
-> ConstructorInfo
-> ConstructorInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Name) -> ConstructorInfo -> ConstructorInfo
conFieldNameMap (PatternFunctorRules -> Name -> Name
patternField PatternFunctorRules
rules)
          (ConstructorInfo -> ConstructorInfo)
-> (ConstructorInfo -> ConstructorInfo)
-> ConstructorInfo
-> ConstructorInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Type) -> ConstructorInfo -> ConstructorInfo
conTypeMap (Type -> Type -> Type -> Type
substType Type
s Type
r)
          (ConstructorInfo -> Con) -> [ConstructorInfo] -> [Con]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConstructorInfo]
cons'

  -- Data definition
  let dataDec :: Dec
dataDec = case [Con]
consF of
        [Con
conF]
          | Bool
isNewtype -> [Type]
-> Name
-> [TyVarBndr']
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
NewtypeD [] Name
tyNameF [TyVarBndr']
varsF Maybe Type
forall a. Maybe a
Nothing Con
conF [DerivClause]
deriveds
        [Con]
_ -> [Type]
-> Name
-> [TyVarBndr']
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
tyNameF [TyVarBndr']
varsF Maybe Type
forall a. Maybe a
Nothing [Con]
consF [DerivClause]
deriveds

  [Dec]
recursiveDec <-
    [d|
      instance Projectable (->) $(pure s) $(pure $ conAppsT tyNameF vars') where
        project = $(LamCaseE <$> mkMorphism id (patternCon rules) cons')

      instance Steppable (->) $(pure s) $(pure $ conAppsT tyNameF vars') where
        embed = $(LamCaseE <$> mkMorphism (patternCon rules) id cons')

      instance Recursive (->) $(pure s) $(pure $ conAppsT tyNameF vars') where
        cata φ = φ . fmap (cata φ) . project

      instance Corecursive (->) $(pure s) $(pure $ conAppsT tyNameF vars') where
        ana ψ = embed . fmap (ana ψ) . ψ
      |]
  -- Combine
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec
dataDec] [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec]
recursiveDec)

-- | makes clauses to rename constructors
mkMorphism ::
  (Name -> Name) ->
  (Name -> Name) ->
  [ConstructorInfo] ->
  Q [Match]
mkMorphism :: (Name -> Name) -> (Name -> Name) -> [ConstructorInfo] -> Q [Match]
mkMorphism Name -> Name
nFrom Name -> Name
nTo =
  (ConstructorInfo -> Q Match) -> [ConstructorInfo] -> Q [Match]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
    ( \ConstructorInfo
ci -> do
        let n :: Name
n = ConstructorInfo -> Name
constructorName ConstructorInfo
ci
        [Name]
fs <- (Type -> Q Name) -> [Type] -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Q Name -> Type -> Q Name
forall a b. a -> b -> a
const (Q Name -> Type -> Q Name) -> Q Name -> Type -> Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"x") ([Type] -> Q [Name]) -> [Type] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> [Type]
constructorFields ConstructorInfo
ci
        Match -> Q Match
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Match -> Q Match) -> Match -> Q Match
forall a b. (a -> b) -> a -> b
$
          Pat -> Body -> [Dec] -> Match
Match
            (Name -> [Pat] -> Pat
conP' (Name -> Name
nFrom Name
n) ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
fs)) -- pattern
            (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Name
nTo Name
n) ((Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
fs)) -- body
            [] -- where dec
    )

-------------------------------------------------------------------------------
-- Traversals
-------------------------------------------------------------------------------

conNameTraversal :: Traversal' ConstructorInfo Name
conNameTraversal :: (Name -> f Name) -> ConstructorInfo -> f ConstructorInfo
conNameTraversal = (ConstructorInfo -> Name)
-> (ConstructorInfo -> Name -> ConstructorInfo)
-> Lens' ConstructorInfo Name
forall s a. (s -> a) -> (s -> a -> s) -> Lens' s a
lens ConstructorInfo -> Name
constructorName (\ConstructorInfo
s Name
v -> ConstructorInfo
s {constructorName :: Name
constructorName = Name
v})

conFieldNameTraversal :: Traversal' ConstructorInfo Name
conFieldNameTraversal :: (Name -> f Name) -> ConstructorInfo -> f ConstructorInfo
conFieldNameTraversal =
  (ConstructorInfo -> ConstructorVariant)
-> (ConstructorInfo -> ConstructorVariant -> ConstructorInfo)
-> Lens' ConstructorInfo ConstructorVariant
forall s a. (s -> a) -> (s -> a -> s) -> Lens' s a
lens ConstructorInfo -> ConstructorVariant
constructorVariant (\ConstructorInfo
s ConstructorVariant
v -> ConstructorInfo
s {constructorVariant :: ConstructorVariant
constructorVariant = ConstructorVariant
v})
    ((ConstructorVariant -> f ConstructorVariant)
 -> ConstructorInfo -> f ConstructorInfo)
-> ((Name -> f Name) -> ConstructorVariant -> f ConstructorVariant)
-> (Name -> f Name)
-> ConstructorInfo
-> f ConstructorInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> f Name) -> ConstructorVariant -> f ConstructorVariant
Traversal' ConstructorVariant Name
conVariantTraversal
  where
    conVariantTraversal :: Traversal' ConstructorVariant Name
    conVariantTraversal :: (Name -> f Name) -> ConstructorVariant -> f ConstructorVariant
conVariantTraversal Name -> f Name
_ ConstructorVariant
NormalConstructor = ConstructorVariant -> f ConstructorVariant
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConstructorVariant
NormalConstructor
    conVariantTraversal Name -> f Name
_ ConstructorVariant
InfixConstructor = ConstructorVariant -> f ConstructorVariant
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConstructorVariant
InfixConstructor
    conVariantTraversal Name -> f Name
f (RecordConstructor [Name]
fs) = [Name] -> ConstructorVariant
RecordConstructor ([Name] -> ConstructorVariant) -> f [Name] -> f ConstructorVariant
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> f Name) -> [Name] -> f [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Name -> f Name
f [Name]
fs

conTypeTraversal :: Traversal' ConstructorInfo Type
conTypeTraversal :: (Type -> f Type) -> ConstructorInfo -> f ConstructorInfo
conTypeTraversal =
  (ConstructorInfo -> [Type])
-> (ConstructorInfo -> [Type] -> ConstructorInfo)
-> Lens' ConstructorInfo [Type]
forall s a. (s -> a) -> (s -> a -> s) -> Lens' s a
lens ConstructorInfo -> [Type]
constructorFields (\ConstructorInfo
s [Type]
v -> ConstructorInfo
s {constructorFields :: [Type]
constructorFields = [Type]
v})
    (([Type] -> f [Type]) -> ConstructorInfo -> f ConstructorInfo)
-> ((Type -> f Type) -> [Type] -> f [Type])
-> (Type -> f Type)
-> ConstructorInfo
-> f ConstructorInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> f Type) -> [Type] -> f [Type]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse

conNameMap :: (Name -> Name) -> ConstructorInfo -> ConstructorInfo
conNameMap :: (Name -> Name) -> ConstructorInfo -> ConstructorInfo
conNameMap = Traversal' ConstructorInfo Name
-> (Name -> Name) -> ConstructorInfo -> ConstructorInfo
forall s a. Traversal' s a -> (a -> a) -> s -> s
over Traversal' ConstructorInfo Name
conNameTraversal

conFieldNameMap :: (Name -> Name) -> ConstructorInfo -> ConstructorInfo
conFieldNameMap :: (Name -> Name) -> ConstructorInfo -> ConstructorInfo
conFieldNameMap = Traversal' ConstructorInfo Name
-> (Name -> Name) -> ConstructorInfo -> ConstructorInfo
forall s a. Traversal' s a -> (a -> a) -> s -> s
over Traversal' ConstructorInfo Name
conFieldNameTraversal

conTypeMap :: (Type -> Type) -> ConstructorInfo -> ConstructorInfo
conTypeMap :: (Type -> Type) -> ConstructorInfo -> ConstructorInfo
conTypeMap = Traversal' ConstructorInfo Type
-> (Type -> Type) -> ConstructorInfo -> ConstructorInfo
forall s a. Traversal' s a -> (a -> a) -> s -> s
over Traversal' ConstructorInfo Type
conTypeTraversal

-------------------------------------------------------------------------------
-- Lenses
-------------------------------------------------------------------------------

type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s

type Traversal' s a = forall f. Applicative f => (a -> f a) -> s -> f s

lens :: (s -> a) -> (s -> a -> s) -> Lens' s a
lens :: (s -> a) -> (s -> a -> s) -> Lens' s a
lens s -> a
sa s -> a -> s
sas a -> f a
afa s
s = s -> a -> s
sas s
s (a -> s) -> f a -> f s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f a
afa (s -> a
sa s
s)
{-# INLINE lens #-}

over :: Traversal' s a -> (a -> a) -> s -> s
over :: Traversal' s a -> (a -> a) -> s -> s
over Traversal' s a
l a -> a
f = Identity s -> s
forall a. Identity a -> a
runIdentity (Identity s -> s) -> (s -> Identity s) -> s -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Identity a) -> s -> Identity s
Traversal' s a
l (a -> Identity a
forall a. a -> Identity a
Identity (a -> Identity a) -> (a -> a) -> a -> Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f)
{-# INLINE over #-}

-------------------------------------------------------------------------------
-- Type mangling
-------------------------------------------------------------------------------

-- | Extract type variables
typeVars :: [TyVarBndr'] -> [Name]
typeVars :: [TyVarBndr'] -> [Name]
typeVars = (TyVarBndr' -> Name) -> [TyVarBndr'] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr' -> Name
forall flag. TyVarBndr' -> Name
tvName

-- | Apply arguments to a type constructor.
conAppsT :: Name -> [Type] -> Type
conAppsT :: Name -> [Type] -> Type
conAppsT Name
conName = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
conName)

-- | Provides substitution for types
substType ::
  Type ->
  Type ->
  Type ->
  Type
substType :: Type -> Type -> Type -> Type
substType Type
a Type
b = Type -> Type
go
  where
    go :: Type -> Type
go Type
x | Type
x Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
a = Type
b
    go (VarT Name
n) = Name -> Type
VarT Name
n
    go (AppT Type
l Type
r) = Type -> Type -> Type
AppT (Type -> Type
go Type
l) (Type -> Type
go Type
r)
    go (ForallT [TyVarBndr']
xs [Type]
ctx Type
t) = [TyVarBndr'] -> [Type] -> Type -> Type
ForallT [TyVarBndr']
xs [Type]
ctx (Type -> Type
go Type
t)
    -- This may fail with kind error
    go (SigT Type
t Type
k) = Type -> Type -> Type
SigT (Type -> Type
go Type
t) Type
k
    go (InfixT Type
l Name
n Type
r) = Type -> Name -> Type -> Type
InfixT (Type -> Type
go Type
l) Name
n (Type -> Type
go Type
r)
    go (UInfixT Type
l Name
n Type
r) = Type -> Name -> Type -> Type
UInfixT (Type -> Type
go Type
l) Name
n (Type -> Type
go Type
r)
    go (ParensT Type
t) = Type -> Type
ParensT (Type -> Type
go Type
t)
    -- Rest are unchanged
    go Type
x = Type
x

toCon :: ConstructorInfo -> Con
toCon :: ConstructorInfo -> Con
toCon
  ( ConstructorInfo
      { constructorName :: ConstructorInfo -> Name
constructorName = Name
name,
        constructorVars :: ConstructorInfo -> [TyVarBndr']
constructorVars = [TyVarBndr']
vars,
        constructorContext :: ConstructorInfo -> [Type]
constructorContext = [Type]
ctxt,
        constructorFields :: ConstructorInfo -> [Type]
constructorFields = [Type]
ftys,
        constructorStrictness :: ConstructorInfo -> [FieldStrictness]
constructorStrictness = [FieldStrictness]
fstricts,
        constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
variant
      }
    )
    | Bool -> Bool
not ([TyVarBndr'] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr']
vars Bool -> Bool -> Bool
&& [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
ctxt) =
        String -> Con
forall a. HasCallStack => String -> a
error String
"makeBaseFunctor: GADTs are not currently supported."
    | Bool
otherwise =
        let bangs :: [Bang]
bangs = (FieldStrictness -> Bang) -> [FieldStrictness] -> [Bang]
forall a b. (a -> b) -> [a] -> [b]
map FieldStrictness -> Bang
toBang [FieldStrictness]
fstricts
         in case ConstructorVariant
variant of
              ConstructorVariant
NormalConstructor -> Name -> [BangType] -> Con
NormalC Name
name ([BangType] -> Con) -> [BangType] -> Con
forall a b. (a -> b) -> a -> b
$ [Bang] -> [Type] -> [BangType]
forall a b. [a] -> [b] -> [(a, b)]
zip [Bang]
bangs [Type]
ftys
              RecordConstructor [Name]
fnames -> Name -> [VarBangType] -> Con
RecC Name
name ([VarBangType] -> Con) -> [VarBangType] -> Con
forall a b. (a -> b) -> a -> b
$ [Name] -> [Bang] -> [Type] -> [VarBangType]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Name]
fnames [Bang]
bangs [Type]
ftys
              ConstructorVariant
InfixConstructor ->
                let [Bang
bang1, Bang
bang2] = [Bang]
bangs
                    [Type
fty1, Type
fty2] = [Type]
ftys
                 in BangType -> Name -> BangType -> Con
InfixC (Bang
bang1, Type
fty1) Name
name (Bang
bang2, Type
fty2)
    where
      toBang :: FieldStrictness -> Bang
toBang (FieldStrictness Unpackedness
upkd Strictness
strct) =
        SourceUnpackedness -> SourceStrictness -> Bang
Bang
          (Unpackedness -> SourceUnpackedness
toSourceUnpackedness Unpackedness
upkd)
          (Strictness -> SourceStrictness
toSourceStrictness Strictness
strct)
        where
          toSourceUnpackedness :: Unpackedness -> SourceUnpackedness
          toSourceUnpackedness :: Unpackedness -> SourceUnpackedness
toSourceUnpackedness Unpackedness
UnspecifiedUnpackedness = SourceUnpackedness
NoSourceUnpackedness
          toSourceUnpackedness Unpackedness
NoUnpack = SourceUnpackedness
SourceNoUnpack
          toSourceUnpackedness Unpackedness
Unpack = SourceUnpackedness
SourceUnpack

          toSourceStrictness :: Strictness -> SourceStrictness
          toSourceStrictness :: Strictness -> SourceStrictness
toSourceStrictness Strictness
UnspecifiedStrictness = SourceStrictness
NoSourceStrictness
          toSourceStrictness Strictness
Lazy = SourceStrictness
SourceLazy
          toSourceStrictness Strictness
TH.Abs.Strict = SourceStrictness
SourceStrict

-------------------------------------------------------------------------------
-- Manually quoted names
-------------------------------------------------------------------------------
-- By manually generating these names we avoid needing to use the
-- TemplateHaskell language extension when compiling this library.
-- This allows the library to be used in stage1 cross-compilers.

functorTypeName :: Name
functorTypeName :: Name
functorTypeName = String -> String -> String -> Name
mkNameG_tc String
"base" String
"GHC.Base" String
"Functor"

foldableTypeName :: Name
foldableTypeName :: Name
foldableTypeName = String -> String -> String -> Name
mkNameG_tc String
"base" String
"Data.Foldable" String
"Foldable"

traversableTypeName :: Name
traversableTypeName :: Name
traversableTypeName = String -> String -> String -> Name
mkNameG_tc String
"base" String
"Data.Traversable" String
"Traversable"