module OCaml.BuckleScript.Types
( OCamlDatatype (..)
, OCamlPrimitive (..)
, OCamlConstructor (..)
, ValueConstructor (..)
, EnumeratorConstructor (..)
, OCamlValue (..)
, OCamlType (..)
, HaskellTypeMetaData (..)
, OCamlTypeMetaData (..)
, typeableToOCamlType
, TypeParameterRef0
, TypeParameterRef1
, TypeParameterRef2
, TypeParameterRef3
, TypeParameterRef4
, TypeParameterRef5
, getTypeParameterRefNames
, getOCamlValues
, getTypeParameters
, isTypeParameterRef
, mkModulePrefix
) where
import Data.Int (Int16, Int32, Int64, Int8)
import Data.List (nub)
import Data.Maybe (catMaybes)
import Data.Monoid ((<>))
import Data.Proxy
import Data.Time
import Data.Typeable
import Data.Word (Word, Word8, Word16, Word32, Word64)
import GHC.Generics
import GHC.TypeLits (symbolVal, KnownSymbol)
import Prelude
import Data.Aeson (ToJSON, FromJSON)
import Data.Text (Text)
import qualified Data.Text as T
import Test.QuickCheck
import Test.QuickCheck.Arbitrary.ADT
data OCamlDatatype
= OCamlDatatype HaskellTypeMetaData Text OCamlConstructor
| OCamlPrimitive OCamlPrimitive
deriving (Show, Eq)
data HaskellTypeMetaData =
HaskellTypeMetaData
Text
Text
Text
deriving (Show, Eq, Ord)
data OCamlTypeMetaData =
OCamlTypeMetaData
Text
[Text]
[Text]
deriving (Show, Eq, Ord)
data OCamlPrimitive
= OInt
| OBool
| OChar
| ODate
| OFloat
| OString
| OUnit
| OList OCamlDatatype
| OOption OCamlDatatype
| OEither OCamlDatatype OCamlDatatype
| OTuple2 OCamlDatatype OCamlDatatype
| OTuple3 OCamlDatatype OCamlDatatype OCamlDatatype
| OTuple4 OCamlDatatype OCamlDatatype OCamlDatatype OCamlDatatype
| OTuple5 OCamlDatatype OCamlDatatype OCamlDatatype OCamlDatatype OCamlDatatype
| OTuple6 OCamlDatatype OCamlDatatype OCamlDatatype OCamlDatatype OCamlDatatype OCamlDatatype
deriving (Show, Eq)
data OCamlConstructor
= OCamlValueConstructor ValueConstructor
| OCamlEnumeratorConstructor [EnumeratorConstructor]
| OCamlSumOfRecordConstructor Text ValueConstructor
deriving (Show, Eq)
data ValueConstructor
= NamedConstructor Text OCamlValue
| RecordConstructor Text OCamlValue
| MultipleConstructors [ValueConstructor]
deriving (Show, Eq)
data EnumeratorConstructor
= EnumeratorConstructor Text
deriving (Show, Eq)
data OCamlValue
= OCamlRef HaskellTypeMetaData Text
| OCamlTypeParameterRef Text
| OCamlEmpty
| OCamlPrimitiveRef OCamlPrimitive
| OCamlField Text OCamlValue
| Values OCamlValue OCamlValue
deriving (Show, Eq)
class OCamlType a where
toOCamlType :: a -> OCamlDatatype
toOCamlType = genericToOCamlDatatype . from
default toOCamlType :: (Generic a, GenericOCamlDatatype (Rep a)) =>
a -> OCamlDatatype
class GenericOCamlDatatype f where
genericToOCamlDatatype :: f a -> OCamlDatatype
instance (KnownSymbol typ, KnownSymbol package, KnownSymbol modul, GenericValueConstructor f) => GenericOCamlDatatype (M1 D ('MetaData typ modul package 'False) f) where
genericToOCamlDatatype datatype =
OCamlDatatype
(HaskellTypeMetaData
(T.pack $ symbolVal (Proxy :: Proxy typ))
(T.pack $ symbolVal (Proxy :: Proxy modul))
(T.pack $ symbolVal (Proxy :: Proxy package)))
(T.pack (datatypeName datatype))
(transform (OCamlValueConstructor (genericToValueConstructor (unM1 datatype))))
where
transform ocamlConstructor =
if isEnumeration ocamlConstructor
then transformToEnumeration ocamlConstructor
else
if isSumWithRecord ocamlConstructor
then transformToSumOfRecord (T.pack (datatypeName datatype)) ocamlConstructor
else ocamlConstructor
instance (KnownSymbol typ, KnownSymbol package, KnownSymbol modul, GenericValueConstructor f) => GenericOCamlDatatype (M1 D ('MetaData typ modul package 'True) f) where
genericToOCamlDatatype datatype =
OCamlDatatype
(HaskellTypeMetaData
(T.pack $ symbolVal (Proxy :: Proxy typ))
(T.pack $ symbolVal (Proxy :: Proxy modul))
(T.pack $ symbolVal (Proxy :: Proxy package)))
(T.pack (datatypeName datatype))
(transform (OCamlValueConstructor (genericToValueConstructor (unM1 datatype))))
where
transform ocamlConstructor =
if isEnumeration ocamlConstructor
then transformToEnumeration ocamlConstructor
else
if isSumWithRecord ocamlConstructor
then transformToSumOfRecord (T.pack (datatypeName datatype)) ocamlConstructor
else ocamlConstructor
class GenericValueConstructor f where
genericToValueConstructor :: f a -> ValueConstructor
instance (Constructor c, GenericOCamlValue f) => GenericValueConstructor (C1 c f) where
genericToValueConstructor constructor =
if conIsRecord constructor
then RecordConstructor name (genericToOCamlValue (unM1 constructor))
else NamedConstructor name (genericToOCamlValue (unM1 constructor))
where
name = T.pack $ conName constructor
instance (GenericValueConstructor f, GenericValueConstructor g) =>
GenericValueConstructor (f :+: g) where
genericToValueConstructor _ =
MultipleConstructors
[ genericToValueConstructor (undefined :: f p)
, genericToValueConstructor (undefined :: g p)
]
class GenericOCamlValue f where
genericToOCamlValue :: f a -> OCamlValue
instance (Selector s, GenericOCamlValue a) =>
GenericOCamlValue (S1 s a) where
genericToOCamlValue selector =
case selName selector of
"" -> genericToOCamlValue (undefined :: a p)
name -> OCamlField (T.pack name) (genericToOCamlValue (undefined :: a p))
instance (GenericOCamlValue f, GenericOCamlValue g) =>
GenericOCamlValue (f :*: g) where
genericToOCamlValue _ =
Values
(genericToOCamlValue (undefined :: f p))
(genericToOCamlValue (undefined :: g p))
instance GenericOCamlValue U1 where
genericToOCamlValue _ = OCamlEmpty
instance OCamlType a => GenericOCamlValue (Rec0 a) where
genericToOCamlValue _ =
case toOCamlType (Proxy :: Proxy a) of
OCamlPrimitive primitive -> OCamlPrimitiveRef primitive
OCamlDatatype haskellTypeMetaData name _ -> mkRef haskellTypeMetaData name
where
typeParameterRefs = (T.append) <$> ["a"] <*> (T.pack . show <$> ([0..5] :: [Int]))
mkRef haskellTypeMetaData n
| n `elem` typeParameterRefs = OCamlTypeParameterRef n
| otherwise = OCamlRef haskellTypeMetaData n
instance OCamlType a => OCamlType [a] where
toOCamlType _ = OCamlPrimitive (OList (toOCamlType (Proxy :: Proxy a)))
instance OCamlType a => OCamlType (Maybe a) where
toOCamlType _ = OCamlPrimitive (OOption (toOCamlType (Proxy :: Proxy a)))
instance (OCamlType l, OCamlType r) => OCamlType (Either l r) where
toOCamlType _ = OCamlPrimitive (OEither (toOCamlType (Proxy :: Proxy l)) (toOCamlType (Proxy :: Proxy r)))
instance OCamlType () where
toOCamlType _ = OCamlPrimitive OUnit
instance OCamlType Text where
toOCamlType _ = OCamlPrimitive OString
instance OCamlType Day where
toOCamlType _ = OCamlPrimitive ODate
instance OCamlType UTCTime where
toOCamlType _ = OCamlPrimitive ODate
instance OCamlType Float where
toOCamlType _ = OCamlPrimitive OFloat
instance OCamlType Double where
toOCamlType _ = OCamlPrimitive OFloat
instance OCamlType Int8 where
toOCamlType _ = OCamlPrimitive OInt
instance OCamlType Int16 where
toOCamlType _ = OCamlPrimitive OInt
instance OCamlType Int32 where
toOCamlType _ = OCamlPrimitive OInt
instance OCamlType Int64 where
toOCamlType _ = OCamlPrimitive OInt
instance OCamlType Word where
toOCamlType _ = OCamlPrimitive OInt
instance OCamlType Word8 where
toOCamlType _ = OCamlPrimitive OInt
instance OCamlType Word16 where
toOCamlType _ = OCamlPrimitive OInt
instance OCamlType Word32 where
toOCamlType _ = OCamlPrimitive OInt
instance OCamlType Word64 where
toOCamlType _ = OCamlPrimitive OInt
instance OCamlType Int where
toOCamlType _ = OCamlPrimitive OInt
instance OCamlType Integer where
toOCamlType _ = OCamlPrimitive OInt
instance OCamlType Char where
toOCamlType _ = OCamlPrimitive OChar
instance OCamlType Bool where
toOCamlType _ = OCamlPrimitive OBool
instance (OCamlType a, OCamlType b) => OCamlType (a, b) where
toOCamlType _ =
OCamlPrimitive $
OTuple2 (toOCamlType (Proxy :: Proxy a)) (toOCamlType (Proxy :: Proxy b))
instance (OCamlType a, OCamlType b, OCamlType c) => OCamlType (a, b, c) where
toOCamlType _ =
OCamlPrimitive $
OTuple3 (toOCamlType (Proxy :: Proxy a)) (toOCamlType (Proxy :: Proxy b))
(toOCamlType (Proxy :: Proxy c))
instance (OCamlType a, OCamlType b, OCamlType c, OCamlType d) => OCamlType (a, b, c, d) where
toOCamlType _ =
OCamlPrimitive $
OTuple4 (toOCamlType (Proxy :: Proxy a)) (toOCamlType (Proxy :: Proxy b))
(toOCamlType (Proxy :: Proxy c)) (toOCamlType (Proxy :: Proxy d))
instance (OCamlType a, OCamlType b, OCamlType c, OCamlType d, OCamlType e) => OCamlType (a, b, c, d, e) where
toOCamlType _ =
OCamlPrimitive $
OTuple5 (toOCamlType (Proxy :: Proxy a)) (toOCamlType (Proxy :: Proxy b))
(toOCamlType (Proxy :: Proxy c)) (toOCamlType (Proxy :: Proxy d))
(toOCamlType (Proxy :: Proxy e))
instance (OCamlType a, OCamlType b, OCamlType c, OCamlType d, OCamlType e, OCamlType f) => OCamlType (a, b, c, d, e, f) where
toOCamlType _ =
OCamlPrimitive $
OTuple6 (toOCamlType (Proxy :: Proxy a)) (toOCamlType (Proxy :: Proxy b))
(toOCamlType (Proxy :: Proxy c)) (toOCamlType (Proxy :: Proxy d))
(toOCamlType (Proxy :: Proxy e)) (toOCamlType (Proxy :: Proxy f))
instance (OCamlType a) =>
OCamlType (Proxy a) where
toOCamlType _ = toOCamlType (undefined :: a)
typeableToOCamlType :: forall a. Typeable a => Proxy a -> OCamlDatatype
typeableToOCamlType Proxy =
OCamlDatatype
(HaskellTypeMetaData aTyConName aTyConModule aTyConPackage)
aTyConName
(OCamlValueConstructor . NamedConstructor aTyConName $ OCamlEmpty)
where
aTyCon = typeRepTyCon $ typeRep (Proxy :: Proxy a)
aTyConName = T.pack . tyConName $ aTyCon
aTyConModule = T.pack . tyConModule $ aTyCon
aTyConPackage = T.pack . tyConPackage $ aTyCon
newtype TypeParameterRef0 = TypeParameterRef0 Int deriving (Read, Show, Eq, Generic)
instance Arbitrary TypeParameterRef0 where arbitrary = TypeParameterRef0 <$> arbitrary
instance ToADTArbitrary TypeParameterRef0
instance FromJSON TypeParameterRef0
instance ToJSON TypeParameterRef0
instance OCamlType TypeParameterRef0 where
toOCamlType _ = OCamlDatatype (HaskellTypeMetaData "a0" "OCaml.BuckleScript.Types" "ocaml-export") "a0" $ OCamlValueConstructor $ NamedConstructor "a0" $ OCamlTypeParameterRef "a0"
newtype TypeParameterRef1 = TypeParameterRef1 Int deriving (Read, Show, Eq, Generic)
instance Arbitrary TypeParameterRef1 where arbitrary = TypeParameterRef1 <$> arbitrary
instance ToADTArbitrary TypeParameterRef1
instance FromJSON TypeParameterRef1
instance ToJSON TypeParameterRef1
instance OCamlType TypeParameterRef1 where
toOCamlType _ = OCamlDatatype (HaskellTypeMetaData "a1" "OCaml.BuckleScript.Types" "ocaml-export") "a1" $ OCamlValueConstructor $ NamedConstructor "a1" $ OCamlTypeParameterRef "a1"
data TypeParameterRef2 = TypeParameterRef2 Int deriving (Read, Show, Eq, Generic)
instance Arbitrary TypeParameterRef2 where arbitrary = TypeParameterRef2 <$> arbitrary
instance ToADTArbitrary TypeParameterRef2
instance FromJSON TypeParameterRef2
instance ToJSON TypeParameterRef2
instance OCamlType TypeParameterRef2 where
toOCamlType _ = OCamlDatatype (HaskellTypeMetaData "a2" "OCaml.BuckleScript.Types" "ocaml-export") "a2" $ OCamlValueConstructor $ NamedConstructor "a2" $ OCamlTypeParameterRef "a2"
data TypeParameterRef3 = TypeParameterRef3 Int deriving (Read, Show, Eq, Generic)
instance Arbitrary TypeParameterRef3 where arbitrary = TypeParameterRef3 <$> arbitrary
instance ToADTArbitrary TypeParameterRef3
instance FromJSON TypeParameterRef3
instance ToJSON TypeParameterRef3
instance OCamlType TypeParameterRef3 where
toOCamlType _ = OCamlDatatype (HaskellTypeMetaData "a3" "OCaml.BuckleScript.Types" "ocaml-export") "a3" $ OCamlValueConstructor $ NamedConstructor "a3" $ OCamlTypeParameterRef "a3"
data TypeParameterRef4 = TypeParameterRef4 Int deriving (Read, Show, Eq, Generic)
instance Arbitrary TypeParameterRef4 where arbitrary = TypeParameterRef4 <$> arbitrary
instance ToADTArbitrary TypeParameterRef4
instance FromJSON TypeParameterRef4
instance ToJSON TypeParameterRef4
instance OCamlType TypeParameterRef4 where
toOCamlType _ = OCamlDatatype (HaskellTypeMetaData "a4" "OCaml.BuckleScript.Types" "ocaml-export") "a4" $ OCamlValueConstructor $ NamedConstructor "a4" $ OCamlTypeParameterRef "a4"
data TypeParameterRef5 = TypeParameterRef5 Int deriving (Read, Show, Eq, Generic)
instance Arbitrary TypeParameterRef5 where arbitrary = TypeParameterRef5 <$> arbitrary
instance ToADTArbitrary TypeParameterRef5
instance FromJSON TypeParameterRef5
instance ToJSON TypeParameterRef5
instance OCamlType TypeParameterRef5 where
toOCamlType _ = OCamlDatatype (HaskellTypeMetaData "a5" "OCaml.BuckleScript.Types" "ocaml-export") "a5" $ OCamlValueConstructor $ NamedConstructor "a5" $ OCamlTypeParameterRef "a5"
isEnumeration :: OCamlConstructor -> Bool
isEnumeration (OCamlValueConstructor (NamedConstructor _ OCamlEmpty)) = True
isEnumeration (OCamlValueConstructor (MultipleConstructors cs)) = all isEnumeration (OCamlValueConstructor <$> cs)
isEnumeration _ = False
transformToEnumeration :: OCamlConstructor -> OCamlConstructor
transformToEnumeration (OCamlValueConstructor (NamedConstructor name OCamlEmpty)) =
OCamlEnumeratorConstructor [EnumeratorConstructor name]
transformToEnumeration (OCamlValueConstructor (MultipleConstructors cs)) =
OCamlEnumeratorConstructor . concat . catMaybes
$ getEnumeratorConstructor . transformToEnumeration . OCamlValueConstructor
<$> cs
where
getEnumeratorConstructor constructor =
case constructor of
(OCamlEnumeratorConstructor c) -> Just c
_ -> Nothing
transformToEnumeration cs = cs
transformToSumOfRecord :: Text -> OCamlConstructor -> OCamlConstructor
transformToSumOfRecord typeName (OCamlValueConstructor value@(MultipleConstructors _cs)) = OCamlSumOfRecordConstructor typeName value
transformToSumOfRecord _ constructor = constructor
isSumWithRecord :: OCamlConstructor -> Bool
isSumWithRecord (OCamlValueConstructor (MultipleConstructors cs)) =
(\x -> length x > 1 && or x) $ isSumWithRecordsAux . OCamlValueConstructor <$> cs
where
isSumWithRecordsAux :: OCamlConstructor -> Bool
isSumWithRecordsAux (OCamlValueConstructor (RecordConstructor _ _)) = True
isSumWithRecordsAux _ = False
isSumWithRecord _ = False
getTypeParameterRefNames :: [OCamlValue] -> [Text]
getTypeParameterRefNames = nub . concat . (fmap match)
where
lift (OCamlDatatype _ _ constructor) = getTypeParameters constructor
lift _ = []
match value =
case value of
(OCamlTypeParameterRef name) -> [name]
(Values v1 v2) -> match v1 ++ match v2
(OCamlField _ v1) -> match v1
(OCamlPrimitiveRef (OList v1)) -> lift v1
(OCamlPrimitiveRef (OOption v1)) -> lift v1
(OCamlPrimitiveRef (OTuple2 v1 v2)) -> lift v1 ++ lift v2
(OCamlPrimitiveRef (OTuple3 v1 v2 v3)) -> lift v1 ++ lift v2 ++ lift v3
(OCamlPrimitiveRef (OTuple4 v1 v2 v3 v4)) -> lift v1 ++ lift v2 ++ lift v3 ++ lift v4
(OCamlPrimitiveRef (OTuple5 v1 v2 v3 v4 v5)) -> lift v1 ++ lift v2 ++ lift v3 ++ lift v4 ++ lift v5
(OCamlPrimitiveRef (OTuple6 v1 v2 v3 v4 v5 v6)) -> lift v1 ++ lift v2 ++ lift v3 ++ lift v4 ++ lift v5 ++ lift v6
_ -> []
getOCamlValues :: ValueConstructor -> [OCamlValue]
getOCamlValues (NamedConstructor _ value) = [value]
getOCamlValues (RecordConstructor _ value) = [value]
getOCamlValues (MultipleConstructors cs) = concat $ getOCamlValues <$> cs
getTypeParameters :: OCamlConstructor -> [Text]
getTypeParameters (OCamlValueConstructor vc) = getTypeParameterRefNames . getOCamlValues $ vc
getTypeParameters (OCamlSumOfRecordConstructor _ vc) = getTypeParameterRefNames . getOCamlValues $ vc
getTypeParameters _ = []
isTypeParameterRef :: OCamlDatatype -> Bool
isTypeParameterRef (OCamlDatatype _ _ (OCamlValueConstructor (NamedConstructor _ (OCamlTypeParameterRef _)))) = True
isTypeParameterRef _ = False
mkModulePrefix :: OCamlTypeMetaData -> OCamlTypeMetaData -> Text
mkModulePrefix (OCamlTypeMetaData _ decModules decSubModules) (OCamlTypeMetaData _ parModules parSubModules) =
if prefix /= "" then prefix <> "." else ""
where
(l,r) = zipWithRightRemainder (decModules <> decSubModules) (parModules <> parSubModules)
prefix = T.intercalate "." $ (removeMatchingHead l) <> r
removeMatchingHead :: Eq a => [(a,a)] -> [a]
removeMatchingHead [] = []
removeMatchingHead (hd:tl) =
if fst hd == snd hd
then removeMatchingHead tl
else [snd hd] <> (snd <$> tl)
zipWithRightRemainder :: [a] -> [b] -> ([(a,b)], [b])
zipWithRightRemainder [] bs = ([], bs)
zipWithRightRemainder _ab [] = ([], [])
zipWithRightRemainder (a:as) (b:bs) = ([(a,b)], []) <> zipWithRightRemainder as bs