{-# 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 (Show, Eq)
sumTypeInfo :: Functor f => (TypeInfo lang -> f (TypeInfo lang) ) -> SumType lang -> f (SumType lang)
sumTypeInfo inj (SumType info constrs is) = (\ti -> SumType ti constrs is) <$> inj info
sumTypeConstructors :: Functor f => ([DataConstructor lang] -> f [DataConstructor lang]) -> SumType lang -> f (SumType lang)
sumTypeConstructors inj (SumType info constrs is) = (\cs -> SumType info cs is) <$> inj constrs
mkSumType :: forall t. (Generic t, Typeable t, GDataConstructor (Rep t))
=> Proxy t -> SumType 'Haskell
mkSumType p = SumType (mkTypeInfo p) constructors (Encode : Decode : Generic : maybeToList (nootype constructors))
where
constructors = gToConstructors (from (undefined :: t))
data Instance = Encode | Decode | Generic | Newtype | Eq | Ord deriving (Eq, Show)
nootype :: [DataConstructor lang] -> Maybe Instance
nootype cs = case cs of
[constr] | either isSingletonList (const True) (_sigValues constr) -> Just Newtype
| otherwise -> Nothing
_ -> Nothing
where isSingletonList [_] = True
isSingletonList _ = False
equal :: Eq a => Proxy a -> SumType t -> SumType t
equal _ (SumType ti dc is) = SumType ti dc . nub $ Eq : is
order :: Ord a => Proxy a -> SumType t -> SumType t
order _ (SumType ti dc is) = SumType ti dc . nub $ Eq : Ord : is
data DataConstructor (lang :: Language) =
DataConstructor { _sigConstructor :: !Text
, _sigValues :: !(Either [TypeInfo lang] [RecordEntry lang])
} deriving (Show, Eq)
data RecordEntry (lang :: Language) =
RecordEntry { _recLabel :: !Text
, _recValue :: !(TypeInfo lang)
} deriving (Show, 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 (M1 c) = gToConstructors c
instance (GDataConstructor a, GDataConstructor b) => GDataConstructor (a :+: b) where
gToConstructors (_ :: (a :+: b) f) = gToConstructors (undefined :: a f)
++ gToConstructors (undefined :: b f)
instance (Constructor a, GRecordEntry b) => GDataConstructor (C1 a b) where
gToConstructors c@(M1 r) = [ DataConstructor { _sigConstructor = constructor
, _sigValues = values }
]
where
constructor = T.pack $ conName c
values = if conIsRecord c
then Right $ gToRecordEntries r
else Left $ map _recValue $ gToRecordEntries r
instance (GRecordEntry a, GRecordEntry b) => GRecordEntry (a :*: b) where
gToRecordEntries (_ :: (a :*: b) f) = gToRecordEntries (undefined :: a f)
++ gToRecordEntries (undefined :: b f)
instance GRecordEntry U1 where
gToRecordEntries _ = []
instance (Selector a, Typeable t) => GRecordEntry (S1 a (K1 R t)) where
gToRecordEntries e = [
RecordEntry { _recLabel = T.pack (selName e)
, _recValue = mkTypeInfo (Proxy :: Proxy t)
}
]
getUsedTypes :: SumType lang -> Set (TypeInfo lang)
getUsedTypes (SumType _ cs _) = foldr constructorToTypes Set.empty cs
constructorToTypes :: DataConstructor lang -> Set (TypeInfo lang) -> Set (TypeInfo lang)
constructorToTypes (DataConstructor _ (Left myTs)) ts =
Set.fromList (concatMap flattenTypeInfo myTs) `Set.union` ts
constructorToTypes (DataConstructor _ (Right rs)) ts =
Set.fromList (concatMap (flattenTypeInfo . _recValue) rs) `Set.union` ts
makeLenses ''DataConstructor
makeLenses ''RecordEntry