{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Language.PureScript.Bridge.Builder (
BridgeBuilder
, BridgePart
, FixUpBuilder
, FixUpBridge
, BridgeData
, fullBridge
, (^==)
, doCheck
, (<|>)
, psTypeParameters
, FullBridge
, buildBridge
, clearPackageFixUp
, errorFixUp
, buildBridgeWithCustomFixUp
) where
import Control.Applicative
import Control.Lens
import Control.Monad (MonadPlus, guard, mplus,
mzero)
import Control.Monad.Reader.Class
import Control.Monad.Trans.Reader (Reader, ReaderT (..),
runReader)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import qualified Data.Text as T
import Language.PureScript.Bridge.TypeInfo
newtype BridgeBuilder a =
BridgeBuilder (ReaderT BridgeData Maybe a)
deriving (forall a b. a -> BridgeBuilder b -> BridgeBuilder a
forall a b. (a -> b) -> BridgeBuilder a -> BridgeBuilder b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> BridgeBuilder b -> BridgeBuilder a
$c<$ :: forall a b. a -> BridgeBuilder b -> BridgeBuilder a
fmap :: forall a b. (a -> b) -> BridgeBuilder a -> BridgeBuilder b
$cfmap :: forall a b. (a -> b) -> BridgeBuilder a -> BridgeBuilder b
Functor, Functor BridgeBuilder
forall a. a -> BridgeBuilder a
forall a b. BridgeBuilder a -> BridgeBuilder b -> BridgeBuilder a
forall a b. BridgeBuilder a -> BridgeBuilder b -> BridgeBuilder b
forall a b.
BridgeBuilder (a -> b) -> BridgeBuilder a -> BridgeBuilder b
forall a b c.
(a -> b -> c)
-> BridgeBuilder a -> BridgeBuilder b -> BridgeBuilder c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. BridgeBuilder a -> BridgeBuilder b -> BridgeBuilder a
$c<* :: forall a b. BridgeBuilder a -> BridgeBuilder b -> BridgeBuilder a
*> :: forall a b. BridgeBuilder a -> BridgeBuilder b -> BridgeBuilder b
$c*> :: forall a b. BridgeBuilder a -> BridgeBuilder b -> BridgeBuilder b
liftA2 :: forall a b c.
(a -> b -> c)
-> BridgeBuilder a -> BridgeBuilder b -> BridgeBuilder c
$cliftA2 :: forall a b c.
(a -> b -> c)
-> BridgeBuilder a -> BridgeBuilder b -> BridgeBuilder c
<*> :: forall a b.
BridgeBuilder (a -> b) -> BridgeBuilder a -> BridgeBuilder b
$c<*> :: forall a b.
BridgeBuilder (a -> b) -> BridgeBuilder a -> BridgeBuilder b
pure :: forall a. a -> BridgeBuilder a
$cpure :: forall a. a -> BridgeBuilder a
Applicative, Applicative BridgeBuilder
forall a. a -> BridgeBuilder a
forall a b. BridgeBuilder a -> BridgeBuilder b -> BridgeBuilder b
forall a b.
BridgeBuilder a -> (a -> BridgeBuilder b) -> BridgeBuilder b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> BridgeBuilder a
$creturn :: forall a. a -> BridgeBuilder a
>> :: forall a b. BridgeBuilder a -> BridgeBuilder b -> BridgeBuilder b
$c>> :: forall a b. BridgeBuilder a -> BridgeBuilder b -> BridgeBuilder b
>>= :: forall a b.
BridgeBuilder a -> (a -> BridgeBuilder b) -> BridgeBuilder b
$c>>= :: forall a b.
BridgeBuilder a -> (a -> BridgeBuilder b) -> BridgeBuilder b
Monad, MonadReader BridgeData)
type BridgePart = BridgeBuilder PSType
newtype FixUpBuilder a = FixUpBuilder (Reader BridgeData a) deriving (forall a b. a -> FixUpBuilder b -> FixUpBuilder a
forall a b. (a -> b) -> FixUpBuilder a -> FixUpBuilder b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> FixUpBuilder b -> FixUpBuilder a
$c<$ :: forall a b. a -> FixUpBuilder b -> FixUpBuilder a
fmap :: forall a b. (a -> b) -> FixUpBuilder a -> FixUpBuilder b
$cfmap :: forall a b. (a -> b) -> FixUpBuilder a -> FixUpBuilder b
Functor, Functor FixUpBuilder
forall a. a -> FixUpBuilder a
forall a b. FixUpBuilder a -> FixUpBuilder b -> FixUpBuilder a
forall a b. FixUpBuilder a -> FixUpBuilder b -> FixUpBuilder b
forall a b.
FixUpBuilder (a -> b) -> FixUpBuilder a -> FixUpBuilder b
forall a b c.
(a -> b -> c) -> FixUpBuilder a -> FixUpBuilder b -> FixUpBuilder c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. FixUpBuilder a -> FixUpBuilder b -> FixUpBuilder a
$c<* :: forall a b. FixUpBuilder a -> FixUpBuilder b -> FixUpBuilder a
*> :: forall a b. FixUpBuilder a -> FixUpBuilder b -> FixUpBuilder b
$c*> :: forall a b. FixUpBuilder a -> FixUpBuilder b -> FixUpBuilder b
liftA2 :: forall a b c.
(a -> b -> c) -> FixUpBuilder a -> FixUpBuilder b -> FixUpBuilder c
$cliftA2 :: forall a b c.
(a -> b -> c) -> FixUpBuilder a -> FixUpBuilder b -> FixUpBuilder c
<*> :: forall a b.
FixUpBuilder (a -> b) -> FixUpBuilder a -> FixUpBuilder b
$c<*> :: forall a b.
FixUpBuilder (a -> b) -> FixUpBuilder a -> FixUpBuilder b
pure :: forall a. a -> FixUpBuilder a
$cpure :: forall a. a -> FixUpBuilder a
Applicative, Applicative FixUpBuilder
forall a. a -> FixUpBuilder a
forall a b. FixUpBuilder a -> FixUpBuilder b -> FixUpBuilder b
forall a b.
FixUpBuilder a -> (a -> FixUpBuilder b) -> FixUpBuilder b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> FixUpBuilder a
$creturn :: forall a. a -> FixUpBuilder a
>> :: forall a b. FixUpBuilder a -> FixUpBuilder b -> FixUpBuilder b
$c>> :: forall a b. FixUpBuilder a -> FixUpBuilder b -> FixUpBuilder b
>>= :: forall a b.
FixUpBuilder a -> (a -> FixUpBuilder b) -> FixUpBuilder b
$c>>= :: forall a b.
FixUpBuilder a -> (a -> FixUpBuilder b) -> FixUpBuilder b
Monad, MonadReader BridgeData)
type FixUpBridge = FixUpBuilder PSType
type FullBridge = HaskellType -> PSType
data BridgeData = BridgeData {
BridgeData -> HaskellType
_haskType :: HaskellType
, BridgeData -> FullBridge
_fullBridge :: FullBridge
}
instance HasHaskType BridgeData where
haskType :: Lens' BridgeData HaskellType
haskType HaskellType -> f HaskellType
inj (BridgeData HaskellType
iT FullBridge
fB) = forall a b c. (a -> b -> c) -> b -> a -> c
flip HaskellType -> FullBridge -> BridgeData
BridgeData FullBridge
fB forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HaskellType -> f HaskellType
inj HaskellType
iT
fullBridge :: Lens' BridgeData FullBridge
fullBridge :: Lens' BridgeData FullBridge
fullBridge FullBridge -> f FullBridge
inj (BridgeData HaskellType
iT FullBridge
fB) = HaskellType -> FullBridge -> BridgeData
BridgeData HaskellType
iT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FullBridge -> f FullBridge
inj FullBridge
fB
clearPackageFixUp :: MonadReader BridgeData m => m PSType
clearPackageFixUp :: forall (m :: * -> *). MonadReader BridgeData m => m PSType
clearPackageFixUp = do
HaskellType
input <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall t. HasHaskType t => Lens' t HaskellType
haskType
[PSType]
psArgs <- forall (m :: * -> *). MonadReader BridgeData m => m [PSType]
psTypeParameters
forall (m :: * -> *) a. Monad m => a -> m a
return TypeInfo {
_typePackage :: Text
_typePackage = Text
""
, _typeModule :: Text
_typeModule = HaskellType
input forall s a. s -> Getting a s a -> a
^. forall (lang :: Language). Lens' (TypeInfo lang) Text
typeModule
, _typeName :: Text
_typeName = HaskellType
input forall s a. s -> Getting a s a -> a
^. forall (lang :: Language). Lens' (TypeInfo lang) Text
typeName
, _typeParameters :: [PSType]
_typeParameters = [PSType]
psArgs
}
errorFixUp :: MonadReader BridgeData m => m PSType
errorFixUp :: forall (m :: * -> *). MonadReader BridgeData m => m PSType
errorFixUp = do
HaskellType
inType <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall t. HasHaskType t => Lens' t HaskellType
haskType
let message :: Text
message = Text
"No translation supplied for Haskell type: '"
forall a. Semigroup a => a -> a -> a
<> HaskellType
inType forall s a. s -> Getting a s a -> a
^. forall (lang :: Language). Lens' (TypeInfo lang) Text
typeName forall a. Semigroup a => a -> a -> a
<> Text
"', from module: '"
forall a. Semigroup a => a -> a -> a
<> HaskellType
inType forall s a. s -> Getting a s a -> a
^. forall (lang :: Language). Lens' (TypeInfo lang) Text
typeModule forall a. Semigroup a => a -> a -> a
<> Text
"', from package: '"
forall a. Semigroup a => a -> a -> a
<> HaskellType
inType forall s a. s -> Getting a s a -> a
^. forall (lang :: Language). Lens' (TypeInfo lang) Text
typePackage forall a. Semigroup a => a -> a -> a
<> Text
"'!"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
message
buildBridge :: BridgePart -> FullBridge
buildBridge :: BridgePart -> FullBridge
buildBridge = FixUpBridge -> BridgePart -> FullBridge
buildBridgeWithCustomFixUp forall (m :: * -> *). MonadReader BridgeData m => m PSType
clearPackageFixUp
buildBridgeWithCustomFixUp :: FixUpBridge -> BridgePart -> FullBridge
buildBridgeWithCustomFixUp :: FixUpBridge -> BridgePart -> FullBridge
buildBridgeWithCustomFixUp (FixUpBuilder Reader BridgeData PSType
fixUp) (BridgeBuilder ReaderT BridgeData Maybe PSType
bridgePart) = let
mayBridge :: HaskellType -> Maybe PSType
mayBridge :: HaskellType -> Maybe PSType
mayBridge HaskellType
inType = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT BridgeData Maybe PSType
bridgePart forall a b. (a -> b) -> a -> b
$ HaskellType -> FullBridge -> BridgeData
BridgeData HaskellType
inType FullBridge
bridge
fixBridge :: FullBridge
fixBridge HaskellType
inType = forall r a. Reader r a -> r -> a
runReader Reader BridgeData PSType
fixUp forall a b. (a -> b) -> a -> b
$ HaskellType -> FullBridge -> BridgeData
BridgeData HaskellType
inType FullBridge
bridge
bridge :: FullBridge
bridge HaskellType
inType = forall (lang :: Language). TypeInfo lang -> TypeInfo lang
fixTypeParameters forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (FullBridge
fixBridge HaskellType
inType) (HaskellType -> Maybe PSType
mayBridge HaskellType
inType)
in
FullBridge
bridge
fixTypeParameters :: TypeInfo lang -> TypeInfo lang
fixTypeParameters :: forall (lang :: Language). TypeInfo lang -> TypeInfo lang
fixTypeParameters TypeInfo lang
t = if Text
"TypeParameters" Text -> Text -> Bool
`T.isSuffixOf` forall (lang :: Language). TypeInfo lang -> Text
_typeModule TypeInfo lang
t
then TypeInfo lang
t {
_typePackage :: Text
_typePackage = Text
""
, _typeModule :: Text
_typeModule = Text
""
, _typeName :: Text
_typeName = TypeInfo lang
t forall s a. s -> Getting a s a -> a
^. forall (lang :: Language). Lens' (TypeInfo lang) Text
typeName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (Text -> Text
stripNum forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower)
}
else TypeInfo lang
t
where
stripNum :: Text -> Text
stripNum Text
v = forall a. a -> Maybe a -> a
fromMaybe Text
v (Text -> Text -> Maybe Text
T.stripSuffix Text
"1" Text
v)
instance Alternative BridgeBuilder where
empty :: forall a. BridgeBuilder a
empty = forall a. ReaderT BridgeData Maybe a -> BridgeBuilder a
BridgeBuilder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a. Maybe a
Nothing
BridgeBuilder ReaderT BridgeData Maybe a
a <|> :: forall a. BridgeBuilder a -> BridgeBuilder a -> BridgeBuilder a
<|> BridgeBuilder ReaderT BridgeData Maybe a
b = forall a. ReaderT BridgeData Maybe a -> BridgeBuilder a
BridgeBuilder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \BridgeData
bridgeData -> let
ia :: Maybe a
ia = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT BridgeData Maybe a
a BridgeData
bridgeData
ib :: Maybe a
ib = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT BridgeData Maybe a
b BridgeData
bridgeData
in
Maybe a
ia forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe a
ib
instance MonadPlus BridgeBuilder where
mzero :: forall a. BridgeBuilder a
mzero = forall (f :: * -> *) a. Alternative f => f a
empty
mplus :: forall a. BridgeBuilder a -> BridgeBuilder a -> BridgeBuilder a
mplus = forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)
doCheck :: Getter HaskellType a -> (a -> Bool) -> BridgeBuilder ()
doCheck :: forall a. Getter HaskellType a -> (a -> Bool) -> BridgeBuilder ()
doCheck Getter HaskellType a
l a -> Bool
check = forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views (forall t. HasHaskType t => Lens' t HaskellType
haskType forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getter HaskellType a
l) a -> Bool
check
(^==) :: Eq a => Getter HaskellType a -> a -> BridgeBuilder ()
Getter HaskellType a
l ^== :: forall a. Eq a => Getter HaskellType a -> a -> BridgeBuilder ()
^== a
a = forall a. Getter HaskellType a -> (a -> Bool) -> BridgeBuilder ()
doCheck Getter HaskellType a
l (forall a. Eq a => a -> a -> Bool
== a
a)
infix 4 ^==
psTypeParameters :: MonadReader BridgeData m => m [PSType]
psTypeParameters :: forall (m :: * -> *). MonadReader BridgeData m => m [PSType]
psTypeParameters = forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' BridgeData FullBridge
fullBridge forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall t. HasHaskType t => Lens' t HaskellType
haskType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (lang1 :: Language) (lang2 :: Language).
Lens
(TypeInfo lang1) (TypeInfo lang2) [TypeInfo lang1] [TypeInfo lang2]
typeParameters)