{-# 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
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)
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
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
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))
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)
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
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
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
, 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
, 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)
}
]
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
makeLenses ''DataConstructor
makeLenses ''RecordEntry