{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE TypeSynonymInstances       #-}

-- | A bridge builder DSL, powered by 'Monad', 'Alternative' and lens.
--
--   Bridges can be built within the 'BridgeBuilder' monad.
--   You can check properties of the to-be-bridged 'HaskellType' with '^==' or 'doCheck',
--   you have choice ('<|>'), you can fail ('empty') and you can return a translated
--   'PSType' ('return'). The 'HaskellType' can be accessed with:
--
-- > view haskType
--
--   Find usage examples in "Language.PureScript.Bridge.Primitives" and "Language.PureScript.Bridge.PSTypes"
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

-- | Bridges to use when a 'BridgePart' returns 'Nothing' (See 'buildBridgeWithCustomFixUp').
--
--   It is similar to BridgeBuilder but does not offer choice or failure. It is used for constructing fallbacks
--   if a 'BridgePart' evaluates to 'Nothing'.
--
--   For type definitions you should use the more generic ('MonadReader' 'BridgeData' m) constraint. This way your code will work
--   in both 'FixUpBuilder' and 'BridgeBuilder':
--
-- > {-# LANGUAGE FlexibleContexts #-}
-- >
-- > import           Control.Monad.Reader.Class
-- > import           Language.PureScript.Bridge.TypeInfo

-- >
-- > psEither :: MonadReader BridgeData m => m PSType
-- > psEither = ....
--
--   instead of:
--
-- > psEither :: BridgePart
-- > psEither = ....
--
--   or
--
-- > psEither :: FixUpBridge
-- > psEither = ....
--
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 {
  -- | The Haskell type to translate.
    BridgeData -> HaskellType
_haskType   :: HaskellType
  -- | Reference to the bridge itself, needed for translation of type constructors.
  , BridgeData -> FullBridge
_fullBridge :: FullBridge
  }

-- | By implementing the 'haskType' lens in the HasHaskType class, we are able
--   to use it for both 'BridgeData' and a plain 'HaskellType', therefore
--   you can use it with 'doCheck' and '^==' for checks on the complete 'HaskellType'
--   value.
--
--   Example:
--
-- > stringBridge :: BridgePart
-- > stringBridge = do
-- >   -- Note: we are using the HaskellType instance here:
-- >   haskType ^== mkTypeInfo (Proxy :: Proxy String)
-- >   return psString
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

-- | Lens for access to the complete bridge from within our Reader monad.
--
--   This is used for example for implementing 'psTypeParameters'.
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

-- | Bridge to PureScript by simply clearing out the '_typePackage' field.
--   This bridge is used by default as 'FixUpBridge' by 'buildBridge':
--
-- > buildBridge = buildBridgeWithCustomFixUp clearPackageFixUp
--
--   Thus, if no bridge matches a type, it gets optimistically translated to a PureScript type
--   which is idential to the Haskell type. Only the '_typePackage' field gets cleared,
--   as it is very unlikely that the PureScript package is called the same as the Haskell package.
--
--   Alternatively, if you are not that optimistic, you can use errorFixUp
--   - which simply calls 'error' when used.
--
-- > buildBridgeWithCustomFixUp errorFixUp yourBridge
--
--   Of course you can also write your own 'FixUpBridge'. It works the same
--   as for 'BridgePart', but you can not have choice ('<|>') or failure ('empty').
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
    }

-- | A 'FixUpBridge' which calles 'error' when used.
--   Usage:
--
-- > buildBridgeWithCustomFixUp errorFixUp yourBridge
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

-- | Build a bridge.
--
--   This is a convenience wrapper for 'buildBridgeWithCustomFixUp' and should normally be sufficient.
--
--   Definition:
--
-- > buildBridgeWithCustomFixUp clearPackageFixUp
buildBridge :: BridgePart -> FullBridge
buildBridge :: BridgePart -> FullBridge
buildBridge = FixUpBridge -> BridgePart -> FullBridge
buildBridgeWithCustomFixUp forall (m :: * -> *). MonadReader BridgeData m => m PSType
clearPackageFixUp


-- | Takes a constructed BridgePart and makes it a total function ('FullBridge')
--   by using the supplied 'FixUpBridge' when 'BridgePart' returns 'Nothing'.
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


-- | Translate types that come from any module named "Something.TypeParameters" to lower case:
--
--   Also drop the 1 at the end if present.
--   This method gets called by 'buildBridge' and buildBridgeWithCustomFixUp for you - you should not need to call it.
--
--   It enables you to even bridge type constructor definitions, see "Language.PureScript.Bridge.TypeParameters" for more details.
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
"" -- Don't suggest any packages
        , _typeModule :: Text
_typeModule = Text
"" -- Don't import any modules
        , _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)


-- | Alternative instance for BridgeBuilder so you can construct bridges with '<|>',
--   which behaves like a logical 'or' ('||'). If the left-hand side results in Nothing
--   the right-hand side is used, otherwise the left-hand side.
--   For usage examples see "Language.PureScript.Bridge.Primitives".
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
(<|>)

-- | Do some check on properties of 'haskType'.
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

-- | Check parts of 'haskType' for equality:
--
-- > textBridge :: BridgePart
-- > textBridge = do
-- >   typeName ^== "Text"
-- >   typeModule ^== "Data.Text.Internal" <|> typeModule ^== "Data.Text.Internal.Lazy"
-- >   return psString
(^==) :: 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 ^==

-- | Bridge 'haskType' 'typeParameters' over to PureScript types.
--
--   To be used for bridging type constructors.
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)