{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}

-- |
-- Module      : Streamly.Internal.Data.Stream.MkType
-- Copyright   : (c) 2022 Composewell Technologies
-- License     : BSD-3-Clause
-- Maintainer  : streamly@composewell.com
-- Stability   : experimental
-- Portability : GHC
--
module Streamly.Internal.Data.Stream.MkType
    (
    -- * Imports for Examples
    -- $setup

    -- * Template Haskell Macros
      mkZipType
    , mkCrossType

    -- * Re-exports
    , MonadIO(..)
    , MonadThrow(..)
    , MonadReader(..)
    , MonadTrans(..)
    , ap
    ) where

--------------------------------------------------------------------------------
-- Imports
--------------------------------------------------------------------------------

import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax

import Control.Monad (ap)
import Control.Monad.Catch (MonadThrow(..))
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Reader.Class (MonadReader(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Prelude hiding (repeat)

-- $setup
-- >>> :m
-- >>> import Language.Haskell.TH
-- >>> import qualified Streamly.Data.Stream.Prelude as Stream
-- >>> import Streamly.Internal.Data.Stream.MkType

--------------------------------------------------------------------------------
-- Helpers
--------------------------------------------------------------------------------

{-# INLINE singleton #-}
singleton :: a -> [a]
singleton :: forall a. a -> [a]
singleton a
x = [a
x]

toTypeStr :: String -> String
toTypeStr :: String -> String
toTypeStr String
typ = String
"mk" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typ

unTypeStr :: String -> String
unTypeStr :: String -> String
unTypeStr String
typ = String
"un" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typ

--------------------------------------------------------------------------------
-- Names
--------------------------------------------------------------------------------

_m :: Name
_m :: Name
_m = String -> Name
mkName String
"m"

_a :: Name
_a :: Name
_a = String -> Name
mkName String
"a"

_r :: Name
_r :: Name
_r = String -> Name
mkName String
"r"

_Stream :: Name
_Stream :: Name
_Stream = String -> Name
mkName String
"Stream.Stream"

_fmap :: Name
_fmap :: Name
_fmap = String -> Name
mkName String
"fmap"

_pure :: Name
_pure :: Name
_pure = String -> Name
mkName String
"pure"

_return :: Name
_return :: Name
_return = String -> Name
mkName String
"return"

_strm :: Name
_strm :: Name
_strm = String -> Name
mkName String
"strm"

_strm1 :: Name
_strm1 :: Name
_strm1 = String -> Name
mkName String
"strm1"

_strm2 :: Name
_strm2 :: Name
_strm2 = String -> Name
mkName String
"strm2"

_Functor :: Name
_Functor :: Name
_Functor = String -> Name
mkName String
"Functor"

_Applicative :: Name
_Applicative :: Name
_Applicative = String -> Name
mkName String
"Applicative"

_Monad :: Name
_Monad :: Name
_Monad = String -> Name
mkName String
"Monad"

_MonadTrans :: Name
_MonadTrans :: Name
_MonadTrans = String -> Name
mkName String
"MonadTrans"

_MonadIO :: Name
_MonadIO :: Name
_MonadIO = String -> Name
mkName String
"MonadIO"

_MonadThrow :: Name
_MonadThrow :: Name
_MonadThrow = String -> Name
mkName String
"MonadThrow"

_MonadReader :: Name
_MonadReader :: Name
_MonadReader = String -> Name
mkName String
"MonadReader"

_lift :: Name
_lift :: Name
_lift = String -> Name
mkName String
"lift"

_ask :: Name
_ask :: Name
_ask = String -> Name
mkName String
"ask"

_local :: Name
_local :: Name
_local = String -> Name
mkName String
"local"

_throwM :: Name
_throwM :: Name
_throwM = String -> Name
mkName String
"throwM"

_liftIO :: Name
_liftIO :: Name
_liftIO = String -> Name
mkName String
"liftIO"

_f :: Name
_f :: Name
_f = String -> Name
mkName String
"f"

_f1 :: Name
_f1 :: Name
_f1 = String -> Name
mkName String
"f1"

_dotOp :: Name
_dotOp :: Name
_dotOp = String -> Name
mkName String
"."

_apOp :: Name
_apOp :: Name
_apOp = String -> Name
mkName String
"<*>"

_bindOp :: Name
_bindOp :: Name
_bindOp = String -> Name
mkName String
">>="

_IsList :: Name
_IsList :: Name
_IsList = String -> Name
mkName String
"IsList"

_IsString :: Name
_IsString :: Name
_IsString = String -> Name
mkName String
"IsString"

_Eq :: Name
_Eq :: Name
_Eq = String -> Name
mkName String
"Eq"

_Ord :: Name
_Ord :: Name
_Ord = String -> Name
mkName String
"Ord"

_Traversable :: Name
_Traversable :: Name
_Traversable = String -> Name
mkName String
"Traversable"

_Identity :: Name
_Identity :: Name
_Identity = String -> Name
mkName String
"Identity"

_Read :: Name
_Read :: Name
_Read = String -> Name
mkName String
"Read"

_Show :: Name
_Show :: Name
_Show = String -> Name
mkName String
"Show"

_show :: Name
_show :: Name
_show = String -> Name
mkName String
"show"

_readPrec :: Name
_readPrec :: Name
_readPrec = String -> Name
mkName String
"readPrec"

_Semigroup :: Name
_Semigroup :: Name
_Semigroup = String -> Name
mkName String
"Semigroup"

_Monoid :: Name
_Monoid :: Name
_Monoid = String -> Name
mkName String
"Monoid"

_Foldable :: Name
_Foldable :: Name
_Foldable = String -> Name
mkName String
"Foldable"

--------------------------------------------------------------------------------
-- Simple derivations
--------------------------------------------------------------------------------

-- Requires TypeFamilies and UndecidableInstances
derivIsListIdent :: Name -> Q Dec
derivIsListIdent :: Name -> Q Dec
derivIsListIdent Name
_Type =
    Q Cxt -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => m Cxt -> m Type -> m Dec
standaloneDerivD
        (Cxt -> Q Cxt
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
        (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_IsList) ((Q Type -> Q Type -> Q Type) -> [Q Type] -> Q Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT [Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Type, Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Identity, Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
_a]))

derivIsStringIdent :: Name -> Q Dec
derivIsStringIdent :: Name -> Q Dec
derivIsStringIdent Name
_Type =
    Q Cxt -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => m Cxt -> m Type -> m Dec
standaloneDerivD
        (Type -> Cxt
forall a. a -> [a]
singleton (Type -> Cxt) -> Q Type -> Q Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|$(varT _a) ~ Char|])
        (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT
             (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_IsString)
             ((Q Type -> Q Type -> Q Type) -> [Q Type] -> Q Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT [Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Type, Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Identity, Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
_a]))

derivEqIdent :: Name -> Q Dec
derivEqIdent :: Name -> Q Dec
derivEqIdent Name
_Type =
    Q Cxt -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => m Cxt -> m Type -> m Dec
standaloneDerivD
        (Type -> Cxt
forall a. a -> [a]
singleton (Type -> Cxt) -> Q Type -> Q Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|Eq $(varT _a)|])
        (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Eq) ((Q Type -> Q Type -> Q Type) -> [Q Type] -> Q Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT [Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Type, Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Identity, Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
_a]))

derivOrdIdent :: Name -> Q Dec
derivOrdIdent :: Name -> Q Dec
derivOrdIdent Name
_Type =
    Q Cxt -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => m Cxt -> m Type -> m Dec
standaloneDerivD
        (Type -> Cxt
forall a. a -> [a]
singleton (Type -> Cxt) -> Q Type -> Q Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|Ord $(varT _a)|])
        (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Ord) ((Q Type -> Q Type -> Q Type) -> [Q Type] -> Q Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT [Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Type, Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Identity, Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
_a]))

{-
derivTraversableIdent :: Name -> Q Dec
derivTraversableIdent _Type =
    standaloneDerivD
        (pure [])
        (appT
             (conT _Traversable)
             (foldl1 appT [conT _Type, conT _Identity]))
-}

showInstance :: Name -> Q Dec
showInstance :: Name -> Q Dec
showInstance Name
_Type =
    Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
        (Type -> Cxt
forall a. a -> [a]
singleton (Type -> Cxt) -> Q Type -> Q Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Show) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
_a))
        (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Show) ((Q Type -> Q Type -> Q Type) -> [Q Type] -> Q Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT [Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Type, Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Identity, Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
_a]))
        [ Name -> Inline -> RuleMatch -> Phases -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD Name
_show Inline
Inline RuleMatch
FunLike Phases
AllPhases
        , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
              Name
_show
              [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                    [Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
_Type [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
_strm]]
                    (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
varE Name
_show) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_strm)))
                    []
              ]
        ]

readInstance :: Name -> Q Dec
readInstance :: Name -> Q Dec
readInstance Name
_Type =
    Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
        (Type -> Cxt
forall a. a -> [a]
singleton (Type -> Cxt) -> Q Type -> Q Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Read) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
_a))
        (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Read) ((Q Type -> Q Type -> Q Type) -> [Q Type] -> Q Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT [Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Type, Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Identity, Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
_a]))
        [ Name -> Inline -> RuleMatch -> Phases -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD Name
_readPrec Inline
Inline RuleMatch
FunLike Phases
AllPhases
        , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
              Name
_readPrec
              [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                    []
                    (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
                        ((Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 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 Name
_fmap, Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
_Type, Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_readPrec])
                    )
                    []
              ]
        ]

functorInstance :: Name -> Q Dec
functorInstance :: Name -> Q Dec
functorInstance Name
_Type = do
    Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
        (Type -> Cxt
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Cxt) -> Q Type -> Q Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Monad) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
_m))
        (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Functor) (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Type) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
_m)))
        [ Name -> Inline -> RuleMatch -> Phases -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD Name
_fmap Inline
Inline RuleMatch
FunLike Phases
AllPhases
        , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
              Name
_fmap
              [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                    [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
_f, Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
_Type [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
_strm]]
                    (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 Name
_Type)
                              (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (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 Name
_fmap) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_f)) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_strm))))
                    []
              ]
        ]

monadtransInstance :: Name -> Q Dec
monadtransInstance :: Name -> Q Dec
monadtransInstance Name
_Type =
    Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
        (Cxt -> Q Cxt
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
        (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_MonadTrans) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Type))
        [ Name -> Inline -> RuleMatch -> Phases -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD Name
_lift Inline
Inline RuleMatch
FunLike Phases
AllPhases
        , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
              Name
_lift
              [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                    []
                    (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
                         (Maybe (Q Exp) -> Q Exp -> Maybe (Q Exp) -> Q Exp
forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE
                              (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
_Type))
                              (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_dotOp)
                              (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"Stream.fromEffect")))))
                    []
              ]
        ]

monadioInstance :: Name -> Q Dec
monadioInstance :: Name -> Q Dec
monadioInstance Name
_Type =
    Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
        ([Q Type] -> Q Cxt
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
             [ Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Monad) (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Type) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
_m))
             , Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_MonadIO) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
_m)
             ])
        (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_MonadIO) (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Type) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
_m)))
        [ Name -> Inline -> RuleMatch -> Phases -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD Name
_liftIO Inline
Inline RuleMatch
FunLike Phases
AllPhases
        , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
              Name
_liftIO
              [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                    []
                    (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
                         (Maybe (Q Exp) -> Q Exp -> Maybe (Q Exp) -> Q Exp
forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE
                              (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
_Type))
                              (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_dotOp)
                              (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just
                                   (Maybe (Q Exp) -> Q Exp -> Maybe (Q Exp) -> Q Exp
forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE
                                        (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"Stream.fromEffect")))
                                        (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_dotOp)
                                        (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_liftIO))))))
                    []
              ]
        ]

monadthrowInstance :: Name -> Q Dec
monadthrowInstance :: Name -> Q Dec
monadthrowInstance Name
_Type =
    Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
        ([Q Type] -> Q Cxt
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
             [ Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Monad) (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Type) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
_m))
             , Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_MonadThrow) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
_m)
             ])
        (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_MonadThrow) (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Type) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
_m)))
        [ Name -> Inline -> RuleMatch -> Phases -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD Name
_throwM Inline
Inline RuleMatch
FunLike Phases
AllPhases
        , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
              Name
_throwM
              [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                    []
                    (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
                         (Maybe (Q Exp) -> Q Exp -> Maybe (Q Exp) -> Q Exp
forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE
                              (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
_Type))
                              (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_dotOp)
                              (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just
                                   (Maybe (Q Exp) -> Q Exp -> Maybe (Q Exp) -> Q Exp
forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE
                                        (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"Stream.fromEffect")))
                                        (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_dotOp)
                                        (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_throwM))))))
                    []
              ]
        ]

{-
monadreaderInstance :: Name -> Q Dec
monadreaderInstance _Type =
    instanceD
        (sequence
             [ appT (conT _Monad) (appT (conT _Type) (varT _m))
             , appT (appT (conT _MonadReader) (varT _r)) (varT _m)
             ])
        (appT (appT (conT _MonadReader) (varT _r)) (appT (conT _Type) (varT _m)))
        [ pragInlD _ask Inline FunLike AllPhases
        , funD _ask [clause [] (normalB (appE (varE _lift) (varE _ask))) []]
        , pragInlD _local Inline FunLike AllPhases
        , funD
              _local
              [ clause
                    [varP _f, conP _Type [varP _strm]]
                    (normalB
                         (appE
                              (conE _Type)
                              (appE (appE (varE _local) (varE _f)) (varE _strm))))
                    []
              ]
        ]
-}

--------------------------------------------------------------------------------
-- Type declaration
--------------------------------------------------------------------------------

typeDec :: String -> [Name] -> Q [Dec]
typeDec :: String -> [Name] -> Q [Dec]
typeDec String
dtNameStr [Name]
toDerive = do
    Dec
typ <-
        Q Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> Q Con
-> [Q DerivClause]
-> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> m Con
-> [m DerivClause]
-> m Dec
newtypeD
            (Cxt -> Q Cxt
forall (m :: * -> *) a. Monad m => a -> m a
return [])
            Name
_Type
            [Name -> TyVarBndr ()
plainTV Name
_m, Name -> TyVarBndr ()
plainTV Name
_a]
            Maybe Type
forall a. Maybe a
Nothing
            (Name -> [Q BangType] -> Q Con
forall (m :: * -> *). Quote m => Name -> [m BangType] -> m Con
normalC
                 (String -> Name
mkName String
dtNameStr)
                 [ Q Bang -> Q Type -> Q BangType
forall (m :: * -> *). Quote m => m Bang -> m Type -> m BangType
bangType
                       (Q SourceUnpackedness -> Q SourceStrictness -> Q Bang
forall (m :: * -> *).
Quote m =>
m SourceUnpackedness -> m SourceStrictness -> m Bang
bang Q SourceUnpackedness
forall (m :: * -> *). Quote m => m SourceUnpackedness
noSourceUnpackedness Q SourceStrictness
forall (m :: * -> *). Quote m => m SourceStrictness
noSourceStrictness)
                       (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Stream) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
_m)) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
_a))
                 ])
            [Maybe DerivStrategy -> [Q Type] -> Q DerivClause
forall (m :: * -> *).
Quote m =>
Maybe DerivStrategy -> [m Type] -> m DerivClause
derivClause Maybe DerivStrategy
forall a. Maybe a
Nothing (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> [Name] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
toDerive) | Bool -> Bool
not ([Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
toDerive)]
    let streamType :: Q Type
streamType = Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Stream) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
_m)) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
_a)
        nameType :: Q Type
nameType = Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Type) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
_m)) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
_a)
    Dec
mkTypSig <- Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
_toType (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT Q Type
forall (m :: * -> *). Quote m => m Type
arrowT Q Type
streamType) Q Type
nameType)
    Dec
mkTyp <- Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
_toType [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
_Type)) []]
    Dec
unTypSig <- Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
_unType (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT Q Type
forall (m :: * -> *). Quote m => m Type
arrowT Q Type
nameType) Q Type
streamType)
    Dec
unTyp <-
        Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
            Name
_unType
            [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
_Type [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
_strm]] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_strm)) []]
    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
typ, Dec
mkTypSig, Dec
mkTyp, Dec
unTypSig, Dec
unTyp]

    where

    _Type :: Name
_Type = String -> Name
mkName String
dtNameStr
    _toType :: Name
_toType = String -> Name
mkName (String -> String
toTypeStr String
dtNameStr)
    _unType :: Name
_unType = String -> Name
mkName (String -> String
unTypeStr String
dtNameStr)

--------------------------------------------------------------------------------
-- Main deivations
--------------------------------------------------------------------------------

mkStreamApplicative :: Bool -> String -> [String] -> String -> String -> Q Dec
mkStreamApplicative :: Bool -> String -> [String] -> String -> String -> Q Dec
mkStreamApplicative Bool
isMonad String
dtNameStr [String]
ctxM String
pureDefStr String
apDefStr =
    Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
        ((String -> Q Type) -> [String] -> Q Cxt
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
Prelude.mapM (\String
c -> Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (String -> Name
mkName String
c)) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
_m)) [String]
ctxM)
        (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Applicative) (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Type) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
_m)))
        [ Name -> Inline -> RuleMatch -> Phases -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD Name
_pure Inline
Inline RuleMatch
FunLike Phases
AllPhases
        , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
              Name
_pure
              [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                    []
                    (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
                         (Maybe (Q Exp) -> Q Exp -> Maybe (Q Exp) -> Q Exp
forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE
                              (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
_Type))
                              (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_dotOp)
                              (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_pureDef))))
                    []
              ]
        , Name -> Inline -> RuleMatch -> Phases -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD Name
_apOp Inline
Inline RuleMatch
FunLike Phases
AllPhases
        , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
              Name
_apOp
              [ if Bool
isMonad
                then Q Clause
apClauseMonad
                else Q Clause
apClauseApplicative
              ]
        ]

    where

    _Type :: Name
_Type = String -> Name
mkName String
dtNameStr
    _pureDef :: Name
_pureDef = String -> Name
mkName String
pureDefStr
    _apDef :: Name
_apDef = String -> Name
mkName String
apDefStr
    apClauseMonad :: Q Clause
apClauseMonad = [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_apDef)) []
    apClauseApplicative :: Q Clause
apClauseApplicative =
        [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
            [Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
_Type [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
_strm1], Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
_Type [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
_strm2]]
            (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 Name
_Type)
                      (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                           (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 Name
_apDef) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_strm1))
                           (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_strm2))))
            []

mkStreamMonad :: String -> [String] -> String -> Q Dec
mkStreamMonad :: String -> [String] -> String -> Q Dec
mkStreamMonad String
dtNameStr [String]
ctxM String
bindDefStr =
    Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
        ((String -> Q Type) -> [String] -> Q Cxt
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
Prelude.mapM (\String
c -> Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (String -> Name
mkName String
c)) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
_m)) [String]
ctxM)
        (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Monad) (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
_Type) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
_m)))
        [ Name -> Inline -> RuleMatch -> Phases -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD Name
_bindOp Inline
Inline RuleMatch
FunLike Phases
AllPhases
        , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
              Name
_bindOp
              [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                    [Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
_Type [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
_strm1], Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
_f]
                    (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
                         ([Q Dec] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Dec] -> m Exp -> m Exp
letE
                              [ Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
                                    Name
_f1
                                    [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                                          [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
_a]
                                          (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
varE Name
_unType)
                                                    (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 Name
_f) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_a))))
                                          []
                                    ]
                              ]
                              (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 Name
_Type)
                                   (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                                        (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 Name
_bindDef) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_strm1))
                                        (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_f1)))))
                    []
              ]
        ]

    where

    _Type :: Name
_Type = String -> Name
mkName String
dtNameStr
    _unType :: Name
_unType = String -> Name
mkName (String -> String
unTypeStr String
dtNameStr)
    _bindDef :: Name
_bindDef = String -> Name
mkName String
bindDefStr

--------------------------------------------------------------------------------
-- Functions
--------------------------------------------------------------------------------

flattenDec :: [Q [Dec]] -> Q [Dec]
flattenDec :: [Q [Dec]] -> Q [Dec]
flattenDec [] = [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
flattenDec (Q [Dec]
ma:[Q [Dec]]
mas) = do
    [Dec]
a <- Q [Dec]
ma
    [Dec]
as <- [Q [Dec]] -> Q [Dec]
flattenDec [Q [Dec]]
mas
    [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec]
a [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
as)

-- | Create a type with a zip-like applicative.
--
-- >>> expr <- runQ (mkZipType "ZipStream" "zipApply" False)
-- >>> putStrLn $ pprint expr
-- newtype ZipStream m a
--     = ZipStream (Stream.Stream m a)
--     deriving Foldable
-- mkZipStream :: Stream.Stream m a -> ZipStream m a
-- mkZipStream = ZipStream
-- unZipStream :: ZipStream m a -> Stream.Stream m a
-- unZipStream (ZipStream strm) = strm
-- deriving instance IsList (ZipStream Identity a)
-- deriving instance a ~
--                   GHC.Types.Char => IsString (ZipStream Identity a)
-- deriving instance GHC.Classes.Eq a => Eq (ZipStream Identity a)
-- deriving instance GHC.Classes.Ord a => Ord (ZipStream Identity a)
-- instance Show a => Show (ZipStream Identity a)
--     where {{-# INLINE show #-}; show (ZipStream strm) = show strm}
-- instance Read a => Read (ZipStream Identity a)
--     where {{-# INLINE readPrec #-}; readPrec = fmap ZipStream readPrec}
-- instance Monad m => Functor (ZipStream m)
--     where {{-# INLINE fmap #-};
--            fmap f (ZipStream strm) = ZipStream (fmap f strm)}
-- instance Monad m => Applicative (ZipStream m)
--     where {{-# INLINE pure #-};
--            pure = ZipStream . Stream.repeat;
--            {-# INLINE (<*>) #-};
--            (<*>) (ZipStream strm1) (ZipStream strm2) = ZipStream (zipApply strm1 strm2)}
mkZipType
    :: String -- ^ Name of the type
    -> String -- ^ Function to use for (\<*\>)
    -> Bool   -- ^ 'True' if (\<*\>) requires MonadAsync constraint (concurrent)
    -> Q [Dec]
mkZipType :: String -> String -> Bool -> Q [Dec]
mkZipType String
dtNameStr String
apOpStr Bool
isConcurrent =
    [Q [Dec]] -> Q [Dec]
flattenDec
        [ String -> [Name] -> Q [Dec]
typeDec String
dtNameStr [Name
_Foldable | Bool -> Bool
not Bool
isConcurrent]
        , [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
              ([Q Dec] -> Q [Dec]) -> [Q Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ if Bool -> Bool
not Bool
isConcurrent
                then [ Name -> Q Dec
derivIsListIdent Name
_Type
                     , Name -> Q Dec
derivIsStringIdent Name
_Type
                     , Name -> Q Dec
derivEqIdent Name
_Type
                     , Name -> Q Dec
derivOrdIdent Name
_Type
                     -- , derivTraversableIdent _Type
                     , Name -> Q Dec
showInstance Name
_Type
                     , Name -> Q Dec
readInstance Name
_Type
                     ]
                else []
        , [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
              [ Name -> Q Dec
functorInstance Name
_Type
              , Bool -> String -> [String] -> String -> String -> Q Dec
mkStreamApplicative
                    Bool
False
                    String
dtNameStr
                    [String]
classConstraints
                    String
"Stream.repeat"
                    String
apOpStr
              ]
        ]

    where

    _Type :: Name
_Type = String -> Name
mkName String
dtNameStr
    classConstraints :: [String]
classConstraints =
        if Bool
isConcurrent
        then [String
"Stream.MonadAsync"]
        else [String
"Monad"]

-- | Create a type with specific stream combination properties.
--
-- >>> expr <- runQ (mkCrossType "Parallel" "parBind" True)
-- >>> putStrLn $ pprint expr
-- newtype Parallel m a = Parallel (Stream.Stream m a)
-- mkParallel :: Stream.Stream m a -> Parallel m a
-- mkParallel = Parallel
-- unParallel :: Parallel m a -> Stream.Stream m a
-- unParallel (Parallel strm) = strm
-- instance Monad m => Functor (Parallel m)
--     where {{-# INLINE fmap #-};
--            fmap f (Parallel strm) = Parallel (fmap f strm)}
-- instance Stream.MonadAsync m => Monad (Parallel m)
--     where {{-# INLINE (>>=) #-};
--            (>>=) (Parallel strm1) f = let f1 a = unParallel (f a)
--                                        in Parallel (parBind strm1 f1)}
-- instance Stream.MonadAsync m => Applicative (Parallel m)
--     where {{-# INLINE pure #-};
--            pure = Parallel . Stream.fromPure;
--            {-# INLINE (<*>) #-};
--            (<*>) = ap}
-- instance (Monad (Parallel m), MonadIO m) => MonadIO (Parallel m)
--     where {{-# INLINE liftIO #-};
--            liftIO = Parallel . (Stream.fromEffect . liftIO)}
-- instance (Monad (Parallel m),
--           MonadThrow m) => MonadThrow (Parallel m)
--     where {{-# INLINE throwM #-};
--            throwM = Parallel . (Stream.fromEffect . throwM)}

mkCrossType
    :: String -- ^ Name of the type
    -> String -- ^ Function to use for (>>=)
    -> Bool   -- ^ 'True' if (>>=) requires MonadAsync constraint (concurrent)
    -> Q [Dec]
mkCrossType :: String -> String -> Bool -> Q [Dec]
mkCrossType String
dtNameStr String
bindOpStr Bool
isConcurrent =
    [Q [Dec]] -> Q [Dec]
flattenDec
        [ String -> [Name] -> Q [Dec]
typeDec String
dtNameStr [Name
_Foldable | Bool -> Bool
not Bool
isConcurrent]
        , [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
              ([Q Dec] -> Q [Dec]) -> [Q Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ if Bool -> Bool
not Bool
isConcurrent
                then [ Name -> Q Dec
derivIsListIdent Name
_Type
                     , Name -> Q Dec
derivIsStringIdent Name
_Type
                     , Name -> Q Dec
derivEqIdent Name
_Type
                     , Name -> Q Dec
derivOrdIdent Name
_Type
                     -- , derivTraversableIdent _Type
                     , Name -> Q Dec
showInstance Name
_Type
                     , Name -> Q Dec
readInstance Name
_Type
                     ]
                else []
        , [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Q Dec] -> Q [Dec]) -> [Q Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
              [ Name -> Q Dec
functorInstance Name
_Type
              , String -> [String] -> String -> Q Dec
mkStreamMonad String
dtNameStr [String]
classConstraints String
bindOpStr
              , Bool -> String -> [String] -> String -> String -> Q Dec
mkStreamApplicative
                    Bool
True
                    String
dtNameStr
                    [String]
classConstraints
                    String
"Stream.fromPure"
                    String
"ap"
              , Name -> Q Dec
monadioInstance Name
_Type
              , Name -> Q Dec
monadthrowInstance Name
_Type
              -- , monadreaderInstance _Type
              ] [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. [a] -> [a] -> [a]
++ [Name -> Q Dec
monadtransInstance Name
_Type | Bool -> Bool
not Bool
isConcurrent]
        ]

    where

    _Type :: Name
_Type = String -> Name
mkName String
dtNameStr
    classConstraints :: [String]
classConstraints =
        if Bool
isConcurrent
        then [String
"Stream.MonadAsync"]
        else [String
"Monad"]