{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE KindSignatures       #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE OverloadedStrings    #-}

module Language.PureScript.Bridge.SumType (
  SumType (..)
, mkSumType
, equal, order
, DataConstructor (..)
, RecordEntry (..)
, Instance(..)
, nootype
, getUsedTypes
, constructorToTypes
, sigConstructor
, sigValues
, sumTypeInfo
, sumTypeConstructors
, recLabel
, recValue
) where

import           Control.Lens hiding (from, to)
import           Data.List (nub)
import           Data.Maybe (maybeToList)
import           Data.Proxy
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Text (Text)
import qualified Data.Text as T
import           Data.Typeable
import           Generics.Deriving

import           Language.PureScript.Bridge.TypeInfo

-- | Generic representation of your Haskell types.
data SumType (lang :: Language) = SumType (TypeInfo lang) [DataConstructor lang] [Instance] deriving (Int -> SumType lang -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (lang :: Language). Int -> SumType lang -> ShowS
forall (lang :: Language). [SumType lang] -> ShowS
forall (lang :: Language). SumType lang -> String
showList :: [SumType lang] -> ShowS
$cshowList :: forall (lang :: Language). [SumType lang] -> ShowS
show :: SumType lang -> String
$cshow :: forall (lang :: Language). SumType lang -> String
showsPrec :: Int -> SumType lang -> ShowS
$cshowsPrec :: forall (lang :: Language). Int -> SumType lang -> ShowS
Show, SumType lang -> SumType lang -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (lang :: Language). SumType lang -> SumType lang -> Bool
/= :: SumType lang -> SumType lang -> Bool
$c/= :: forall (lang :: Language). SumType lang -> SumType lang -> Bool
== :: SumType lang -> SumType lang -> Bool
$c== :: forall (lang :: Language). SumType lang -> SumType lang -> Bool
Eq)

-- | TypInfo lens for 'SumType'.
sumTypeInfo :: Functor f => (TypeInfo lang -> f (TypeInfo lang) ) -> SumType lang -> f (SumType lang)
sumTypeInfo :: forall (f :: * -> *) (lang :: Language).
Functor f =>
(TypeInfo lang -> f (TypeInfo lang))
-> SumType lang -> f (SumType lang)
sumTypeInfo TypeInfo lang -> f (TypeInfo lang)
inj (SumType TypeInfo lang
info [DataConstructor lang]
constrs [Instance]
is) = (\TypeInfo lang
ti -> forall (lang :: Language).
TypeInfo lang
-> [DataConstructor lang] -> [Instance] -> SumType lang
SumType TypeInfo lang
ti [DataConstructor lang]
constrs [Instance]
is) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeInfo lang -> f (TypeInfo lang)
inj TypeInfo lang
info

-- | DataConstructor lens for 'SumType'.
sumTypeConstructors :: Functor f => ([DataConstructor lang] -> f [DataConstructor lang]) -> SumType lang -> f (SumType lang)
sumTypeConstructors :: forall (f :: * -> *) (lang :: Language).
Functor f =>
([DataConstructor lang] -> f [DataConstructor lang])
-> SumType lang -> f (SumType lang)
sumTypeConstructors [DataConstructor lang] -> f [DataConstructor lang]
inj (SumType TypeInfo lang
info [DataConstructor lang]
constrs [Instance]
is) = (\[DataConstructor lang]
cs -> forall (lang :: Language).
TypeInfo lang
-> [DataConstructor lang] -> [Instance] -> SumType lang
SumType TypeInfo lang
info [DataConstructor lang]
cs [Instance]
is) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DataConstructor lang] -> f [DataConstructor lang]
inj [DataConstructor lang]
constrs

-- | Create a representation of your sum (and product) types,
--   for doing type translations and writing it out to your PureScript modules.
--   In order to get the type information we use a dummy variable of type 'Proxy' (YourType).
mkSumType :: forall t. (Generic t, Typeable t, GDataConstructor (Rep t))
          => Proxy t -> SumType 'Haskell
mkSumType :: forall t.
(Generic t, Typeable t, GDataConstructor (Rep t)) =>
Proxy t -> SumType 'Haskell
mkSumType Proxy t
p = forall (lang :: Language).
TypeInfo lang
-> [DataConstructor lang] -> [Instance] -> SumType lang
SumType (forall t. Typeable t => Proxy t -> HaskellType
mkTypeInfo Proxy t
p) [DataConstructor 'Haskell]
constructors (Instance
Encode forall a. a -> [a] -> [a]
: Instance
Decode forall a. a -> [a] -> [a]
: Instance
EncodeJson forall a. a -> [a] -> [a]
: Instance
DecodeJson forall a. a -> [a] -> [a]
: Instance
Generic forall a. a -> [a] -> [a]
: forall a. Maybe a -> [a]
maybeToList (forall (lang :: Language). [DataConstructor lang] -> Maybe Instance
nootype [DataConstructor 'Haskell]
constructors))
  where
    constructors :: [DataConstructor 'Haskell]
constructors = forall (f :: * -> *) a.
GDataConstructor f =>
f a -> [DataConstructor 'Haskell]
gToConstructors (forall a x. Generic a => a -> Rep a x
from (forall a. HasCallStack => a
undefined :: t))

-- | Purescript typeclass instances that can be generated for your Haskell types.
data Instance = Encode | EncodeJson | Decode | DecodeJson | Generic | Newtype | Eq | Ord deriving (Instance -> Instance -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Instance -> Instance -> Bool
$c/= :: Instance -> Instance -> Bool
== :: Instance -> Instance -> Bool
$c== :: Instance -> Instance -> Bool
Eq, Int -> Instance -> ShowS
[Instance] -> ShowS
Instance -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Instance] -> ShowS
$cshowList :: [Instance] -> ShowS
show :: Instance -> String
$cshow :: Instance -> String
showsPrec :: Int -> Instance -> ShowS
$cshowsPrec :: Int -> Instance -> ShowS
Show)

-- | The Purescript typeclass `Newtype` might be derivable if the original
-- Haskell type was a simple type wrapper.
nootype :: [DataConstructor lang] -> Maybe Instance
nootype :: forall (lang :: Language). [DataConstructor lang] -> Maybe Instance
nootype [DataConstructor lang]
cs = case [DataConstructor lang]
cs of
  [DataConstructor lang
constr] | forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {a}. [a] -> Bool
isSingletonList (forall a b. a -> b -> a
const Bool
True) (forall (lang :: Language).
DataConstructor lang -> Either [TypeInfo lang] [RecordEntry lang]
_sigValues DataConstructor lang
constr) -> forall a. a -> Maybe a
Just Instance
Newtype
           | Bool
otherwise -> forall a. Maybe a
Nothing
  [DataConstructor lang]
_ -> forall a. Maybe a
Nothing
  where isSingletonList :: [a] -> Bool
isSingletonList [a
_] = Bool
True
        isSingletonList [a]
_   = Bool
False

-- | Ensure that an `Eq` instance is generated for your type.
equal :: Eq a => Proxy a -> SumType t -> SumType t
equal :: forall a (t :: Language). Eq a => Proxy a -> SumType t -> SumType t
equal Proxy a
_ (SumType TypeInfo t
ti [DataConstructor t]
dc [Instance]
is) = forall (lang :: Language).
TypeInfo lang
-> [DataConstructor lang] -> [Instance] -> SumType lang
SumType TypeInfo t
ti [DataConstructor t]
dc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ Instance
Eq forall a. a -> [a] -> [a]
: [Instance]
is

-- | Ensure that both `Eq` and `Ord` instances are generated for your type.
order :: Ord a => Proxy a -> SumType t -> SumType t
order :: forall a (t :: Language).
Ord a =>
Proxy a -> SumType t -> SumType t
order Proxy a
_ (SumType TypeInfo t
ti [DataConstructor t]
dc [Instance]
is) = forall (lang :: Language).
TypeInfo lang
-> [DataConstructor lang] -> [Instance] -> SumType lang
SumType TypeInfo t
ti [DataConstructor t]
dc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ Instance
Eq forall a. a -> [a] -> [a]
: Instance
Ord forall a. a -> [a] -> [a]
: [Instance]
is

data DataConstructor (lang :: Language) =
  DataConstructor { forall (lang :: Language). DataConstructor lang -> Text
_sigConstructor :: !Text -- ^ e.g. `Left`/`Right` for `Either`
                  , forall (lang :: Language).
DataConstructor lang -> Either [TypeInfo lang] [RecordEntry lang]
_sigValues      :: !(Either [TypeInfo lang] [RecordEntry lang])
                  } deriving (Int -> DataConstructor lang -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (lang :: Language). Int -> DataConstructor lang -> ShowS
forall (lang :: Language). [DataConstructor lang] -> ShowS
forall (lang :: Language). DataConstructor lang -> String
showList :: [DataConstructor lang] -> ShowS
$cshowList :: forall (lang :: Language). [DataConstructor lang] -> ShowS
show :: DataConstructor lang -> String
$cshow :: forall (lang :: Language). DataConstructor lang -> String
showsPrec :: Int -> DataConstructor lang -> ShowS
$cshowsPrec :: forall (lang :: Language). Int -> DataConstructor lang -> ShowS
Show, DataConstructor lang -> DataConstructor lang -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (lang :: Language).
DataConstructor lang -> DataConstructor lang -> Bool
/= :: DataConstructor lang -> DataConstructor lang -> Bool
$c/= :: forall (lang :: Language).
DataConstructor lang -> DataConstructor lang -> Bool
== :: DataConstructor lang -> DataConstructor lang -> Bool
$c== :: forall (lang :: Language).
DataConstructor lang -> DataConstructor lang -> Bool
Eq)

data RecordEntry (lang :: Language) =
  RecordEntry { forall (lang :: Language). RecordEntry lang -> Text
_recLabel :: !Text -- ^ e.g. `runState` for `State`
              , forall (lang :: Language). RecordEntry lang -> TypeInfo lang
_recValue :: !(TypeInfo lang)
              } deriving (Int -> RecordEntry lang -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (lang :: Language). Int -> RecordEntry lang -> ShowS
forall (lang :: Language). [RecordEntry lang] -> ShowS
forall (lang :: Language). RecordEntry lang -> String
showList :: [RecordEntry lang] -> ShowS
$cshowList :: forall (lang :: Language). [RecordEntry lang] -> ShowS
show :: RecordEntry lang -> String
$cshow :: forall (lang :: Language). RecordEntry lang -> String
showsPrec :: Int -> RecordEntry lang -> ShowS
$cshowsPrec :: forall (lang :: Language). Int -> RecordEntry lang -> ShowS
Show, RecordEntry lang -> RecordEntry lang -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (lang :: Language).
RecordEntry lang -> RecordEntry lang -> Bool
/= :: RecordEntry lang -> RecordEntry lang -> Bool
$c/= :: forall (lang :: Language).
RecordEntry lang -> RecordEntry lang -> Bool
== :: RecordEntry lang -> RecordEntry lang -> Bool
$c== :: forall (lang :: Language).
RecordEntry lang -> RecordEntry lang -> Bool
Eq)

class GDataConstructor f where
  gToConstructors :: f a -> [DataConstructor 'Haskell]

class GRecordEntry f where
  gToRecordEntries :: f a -> [RecordEntry 'Haskell]

instance (Datatype a, GDataConstructor c) =>  GDataConstructor (D1 a c) where
  gToConstructors :: forall a. D1 a c a -> [DataConstructor 'Haskell]
gToConstructors (M1 c a
c) = forall (f :: * -> *) a.
GDataConstructor f =>
f a -> [DataConstructor 'Haskell]
gToConstructors c a
c

instance (GDataConstructor a, GDataConstructor b) => GDataConstructor (a :+: b) where
  gToConstructors :: forall a. (:+:) a b a -> [DataConstructor 'Haskell]
gToConstructors ((:+:) a b a
_ :: (a :+: b) f) = forall (f :: * -> *) a.
GDataConstructor f =>
f a -> [DataConstructor 'Haskell]
gToConstructors (forall a. HasCallStack => a
undefined :: a f)
                                    forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a.
GDataConstructor f =>
f a -> [DataConstructor 'Haskell]
gToConstructors (forall a. HasCallStack => a
undefined :: b f)

instance (Constructor a, GRecordEntry b) => GDataConstructor (C1 a b) where
  gToConstructors :: forall a. C1 a b a -> [DataConstructor 'Haskell]
gToConstructors c :: C1 a b a
c@(M1 b a
r) = [ DataConstructor { _sigConstructor :: Text
_sigConstructor = Text
constructor
                                               , _sigValues :: Either [HaskellType] [RecordEntry 'Haskell]
_sigValues = Either [HaskellType] [RecordEntry 'Haskell]
values }
                             ]
    where
      constructor :: Text
constructor = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName C1 a b a
c
      values :: Either [HaskellType] [RecordEntry 'Haskell]
values = if forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Bool
conIsRecord C1 a b a
c
                  then forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a.
GRecordEntry f =>
f a -> [RecordEntry 'Haskell]
gToRecordEntries b a
r
                  else forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (lang :: Language). RecordEntry lang -> TypeInfo lang
_recValue forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a.
GRecordEntry f =>
f a -> [RecordEntry 'Haskell]
gToRecordEntries b a
r

instance (GRecordEntry a, GRecordEntry b) => GRecordEntry (a :*: b) where
  gToRecordEntries :: forall a. (:*:) a b a -> [RecordEntry 'Haskell]
gToRecordEntries ((:*:) a b a
_ :: (a :*: b) f) = forall (f :: * -> *) a.
GRecordEntry f =>
f a -> [RecordEntry 'Haskell]
gToRecordEntries (forall a. HasCallStack => a
undefined :: a f)
                                     forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a.
GRecordEntry f =>
f a -> [RecordEntry 'Haskell]
gToRecordEntries (forall a. HasCallStack => a
undefined :: b f)

instance GRecordEntry U1 where
  gToRecordEntries :: forall a. U1 a -> [RecordEntry 'Haskell]
gToRecordEntries U1 a
_ = []

instance (Selector a, Typeable t) => GRecordEntry (S1 a (K1 R t)) where
  gToRecordEntries :: forall a. S1 a (K1 R t) a -> [RecordEntry 'Haskell]
gToRecordEntries S1 a (K1 R t) a
e = [
      RecordEntry { _recLabel :: Text
_recLabel = String -> Text
T.pack (forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName S1 a (K1 R t) a
e)
      , _recValue :: HaskellType
_recValue = forall t. Typeable t => Proxy t -> HaskellType
mkTypeInfo (forall {k} (t :: k). Proxy t
Proxy :: Proxy t)
      }
    ]

-- | Get all used types in a sum type.
--
--   This includes all types found at the right hand side of a sum type
--   definition, not the type parameters of the sum type itself
getUsedTypes :: SumType lang -> Set (TypeInfo lang)
getUsedTypes :: forall (lang :: Language). SumType lang -> Set (TypeInfo lang)
getUsedTypes (SumType TypeInfo lang
_ [DataConstructor lang]
cs [Instance]
_) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall (lang :: Language).
DataConstructor lang -> Set (TypeInfo lang) -> Set (TypeInfo lang)
constructorToTypes forall a. Set a
Set.empty [DataConstructor lang]
cs

constructorToTypes :: DataConstructor lang -> Set (TypeInfo lang) -> Set (TypeInfo lang)
constructorToTypes :: forall (lang :: Language).
DataConstructor lang -> Set (TypeInfo lang) -> Set (TypeInfo lang)
constructorToTypes (DataConstructor Text
_ (Left [TypeInfo lang]
myTs)) Set (TypeInfo lang)
ts =
  forall a. Ord a => [a] -> Set a
Set.fromList (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall (lang :: Language). TypeInfo lang -> [TypeInfo lang]
flattenTypeInfo [TypeInfo lang]
myTs) forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set (TypeInfo lang)
ts
constructorToTypes (DataConstructor Text
_ (Right [RecordEntry lang]
rs))  Set (TypeInfo lang)
ts =
  forall a. Ord a => [a] -> Set a
Set.fromList (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall (lang :: Language). TypeInfo lang -> [TypeInfo lang]
flattenTypeInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (lang :: Language). RecordEntry lang -> TypeInfo lang
_recValue) [RecordEntry lang]
rs) forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set (TypeInfo lang)
ts

-- Lenses:
makeLenses ''DataConstructor
makeLenses ''RecordEntry