{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Reason.Type where
import Data.Int (Int16, Int32, Int64, Int8)
import Data.IntMap
import Data.Map
import Data.Proxy
import Data.Text hiding (all)
import Data.Time
import GHC.Generics
import Prelude
import Data.Hashable(hash)
data ReasonDatatype
= ReasonDatatype Text ReasonConstructor
| ReasonPrimitive ReasonPrimitive
deriving (Show, Eq)
data ReasonPrimitive
= RInt
| RInt64
| RFloat
| RBool
| RChar
| RString
| RTimePosix
| RUnit
| RList ReasonDatatype
| ROption ReasonDatatype
| RTuple2 ReasonDatatype ReasonDatatype
| RTuple3 ReasonDatatype ReasonDatatype ReasonDatatype
| RMap ReasonPrimitive ReasonDatatype
deriving (Show, Eq)
data ReasonConstructor
= NamedConstructor Text ReasonValue
| RecordConstructor Text ReasonValue
| MultipleConstructors [ReasonConstructor]
deriving (Show, Eq)
data ReasonValue
= ReasonRef Text
| ReasonEmpty
| ReasonPrimitiveRef ReasonPrimitive
| Values ReasonValue ReasonValue
| ReasonField Text ReasonValue
deriving (Show, Eq)
class ReasonType a where
toReasonType :: a -> ReasonDatatype
toReasonType = genericToReasonDatatype . from
default toReasonType :: (Generic a, GenericReasonDatatype (Rep a)) =>
a -> ReasonDatatype
class GenericReasonDatatype f where
genericToReasonDatatype :: f a -> ReasonDatatype
instance (Datatype d, GenericReasonConstructor f) =>
GenericReasonDatatype (D1 d f) where
genericToReasonDatatype datatype =
ReasonDatatype
(pack (datatypeName datatype))
(genericToReasonConstructor (unM1 datatype))
class GenericReasonConstructor f where
genericToReasonConstructor :: f a -> ReasonConstructor
instance (Constructor c, GenericReasonValue f) =>
GenericReasonConstructor (C1 c f) where
genericToReasonConstructor constructor =
if conIsRecord constructor
then RecordConstructor name (genericToReasonValue (unM1 constructor))
else NamedConstructor name (genericToReasonValue (unM1 constructor))
where
name = pack $ conName constructor
instance (GenericReasonConstructor f, GenericReasonConstructor g) =>
GenericReasonConstructor (f :+: g) where
genericToReasonConstructor _ =
MultipleConstructors
[ genericToReasonConstructor (undefined :: f p)
, genericToReasonConstructor (undefined :: g p)
]
class GenericReasonValue f where
genericToReasonValue :: f a -> ReasonValue
instance (Selector s, GenericReasonValue a) =>
GenericReasonValue (S1 s a) where
genericToReasonValue selector =
case selName selector of
"" -> genericToReasonValue (undefined :: a p)
name -> ReasonField (pack name) (genericToReasonValue (undefined :: a p))
instance (GenericReasonValue f, GenericReasonValue g) =>
GenericReasonValue (f :*: g) where
genericToReasonValue _ =
Values
(genericToReasonValue (undefined :: f p))
(genericToReasonValue (undefined :: g p))
instance GenericReasonValue U1 where
genericToReasonValue _ = ReasonEmpty
instance ReasonType a =>
GenericReasonValue (Rec0 a) where
genericToReasonValue _ =
case toReasonType (Proxy :: Proxy a) of
ReasonPrimitive primitive -> ReasonPrimitiveRef primitive
ReasonDatatype name _ -> ReasonRef name
instance ReasonType a =>
ReasonType [a] where
toReasonType _ = ReasonPrimitive (RList (toReasonType (Proxy :: Proxy a)))
instance ReasonType a =>
ReasonType (Maybe a) where
toReasonType _ = ReasonPrimitive (ROption (toReasonType (Proxy :: Proxy a)))
instance ReasonType () where
toReasonType _ = ReasonPrimitive RUnit
instance ReasonType Text where
toReasonType _ = ReasonPrimitive RString
instance ReasonType Day where
toReasonType _ = ReasonPrimitive RTimePosix
instance ReasonType UTCTime where
toReasonType _ = ReasonPrimitive RTimePosix
instance ReasonType Float where
toReasonType _ = ReasonPrimitive RFloat
instance ReasonType Double where
toReasonType _ = ReasonPrimitive RFloat
instance ReasonType Int8 where
toReasonType _ = ReasonPrimitive RInt
instance ReasonType Int16 where
toReasonType _ = ReasonPrimitive RInt
instance ReasonType Int32 where
toReasonType _ = ReasonPrimitive RInt
instance ReasonType Int64 where
toReasonType _ = ReasonPrimitive RInt64
instance (ReasonType a, ReasonType b) =>
ReasonType (a, b) where
toReasonType _ =
ReasonPrimitive $
RTuple2 (toReasonType (Proxy :: Proxy a)) (toReasonType (Proxy :: Proxy b))
instance (ReasonType a, ReasonType b, ReasonType c) =>
ReasonType (a, b, c) where
toReasonType _ =
ReasonPrimitive $
RTuple3 (toReasonType (Proxy :: Proxy a)) (toReasonType (Proxy :: Proxy b)) (toReasonType (Proxy :: Proxy c))
instance (ReasonType a) =>
ReasonType (Proxy a) where
toReasonType _ = toReasonType (undefined :: a)
instance (HasReasonComparable k, ReasonType v) =>
ReasonType (Map k v) where
toReasonType _ =
ReasonPrimitive $
RMap (toReasonComparable (undefined :: k)) (toReasonType (Proxy :: Proxy v))
instance (ReasonType v) =>
ReasonType (IntMap v) where
toReasonType _ = ReasonPrimitive $ RMap RInt (toReasonType (Proxy :: Proxy v))
class HasReasonComparable a where
toReasonComparable :: a -> ReasonPrimitive
instance HasReasonComparable String where
toReasonComparable _ = RString
instance HasReasonComparable Text where
toReasonComparable _ = RString
instance ReasonType Int where
toReasonType _ = ReasonPrimitive RInt
instance ReasonType Char where
toReasonType _ = ReasonPrimitive RChar
instance ReasonType Bool where
toReasonType _ = ReasonPrimitive RBool
isEnumeration :: ReasonConstructor -> Bool
isEnumeration (NamedConstructor _ ReasonEmpty) = True
isEnumeration (MultipleConstructors cs) = all isEnumeration cs
isEnumeration _ = False
primitiveName :: ReasonPrimitive -> Text
primitiveName k = pack (show (abs (hash (show k))))