module OCaml.BuckleScript.Types
( OCamlDatatype (..)
, OCamlPrimitive (..)
, OCamlConstructor (..)
, ValueConstructor (..)
, EnumeratorConstructor (..)
, OCamlValue (..)
, OCamlType (..)
, HaskellTypeMetaData (..)
, OCamlTypeMetaData (..)
, 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.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)
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