{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module OCaml.BuckleScript.Record
( toOCamlTypeSourceWith
) where
import Control.Monad.Reader
import Data.List (nub, sort)
import Data.Maybe (catMaybes)
import Data.Monoid ((<>))
import Data.Proxy (Proxy (..))
import Data.Typeable
import qualified Data.Map.Strict as Map
import OCaml.BuckleScript.Types
import OCaml.Internal.Common
import Data.Text (Text)
import qualified Data.Text as T
import Text.PrettyPrint.Leijen.Text
(Doc, (<+>), (<$$>), comma, indent, line, parens, space)
toOCamlTypeSourceWith :: forall a. OCamlType a => Options -> a -> T.Text
toOCamlTypeSourceWith options a =
case toOCamlType (Proxy :: Proxy a) of
OCamlDatatype haskellTypeMetaData _ _ ->
case Map.lookup haskellTypeMetaData (dependencies options) of
Just ocamlTypeMetaData -> pprinter $ runReader (render (toOCamlType a)) (TypeMetaData (Just ocamlTypeMetaData) options)
Nothing -> ""
_ -> pprinter $ runReader (render (toOCamlType a)) (TypeMetaData Nothing options)
class HasType a where
render :: a -> Reader TypeMetaData Doc
class HasRecordType a where
renderRecord :: a -> Reader TypeMetaData Doc
class HasTypeRef a where
renderRef :: a -> Reader TypeMetaData Doc
instance HasType OCamlDatatype where
render datatype@(OCamlDatatype _mOCamlTypeDataType typeName constructor@(OCamlSumOfRecordConstructor _ (MultipleConstructors constructors))) = do
sumRecordsData <- catMaybes <$> sequence (renderSumRecord typeName <$> constructors)
let sumRecords = msuffix (line <> line) (fst <$> sumRecordsData)
newConstructors = replaceRecordConstructors (snd <$> sumRecordsData) <$> constructors
typeParameters = renderTypeParameters constructor
fnName <- renderRef datatype
fnBody <- render (OCamlValueConstructor $ MultipleConstructors newConstructors)
pure $ sumRecords <> ("type" <+> typeParameters <+> fnName <+> "=" <$$> indent 2 ("|" <+> fnBody))
render datatype@(OCamlDatatype _ _ constructor@(OCamlValueConstructor (RecordConstructor _ _))) = do
let typeParameters = renderTypeParameters constructor
fnName <- renderRef datatype
fnBody <- render constructor
pure $ "type" <+> typeParameters <+> fnName <+> "=" <$$> indent 2 fnBody
render (OCamlDatatype _ typeName constructor) = do
let typeParameters = renderTypeParameters constructor
let fnName = stext . textLowercaseFirst $ typeName
fnBody <- render constructor
pure $ "type" <+> typeParameters <+> fnName <+> "=" <$$> indent 2 ("|" <+> fnBody)
render (OCamlPrimitive primitive) = renderRef primitive
instance HasTypeRef OCamlDatatype where
renderRef (OCamlDatatype _ _ (OCamlValueConstructor (NamedConstructor _ (OCamlRefApp typRep values)))) = do
dx <- renderRef values
let name = stext . textLowercaseFirst . T.pack . show $ typeRepTyCon typRep
mOCamlTypeMetaData <- asks topLevelOCamlTypeMetaData
case mOCamlTypeMetaData of
Nothing -> pure $ (parensIfNotBlank dx) <+> name
Just decOCamlTypeMetaData -> do
ds <- asks (dependencies . userOptions)
case Map.lookup (typeRepToHaskellTypeMetaData typRep) ds of
Just parOCamlTypeMetaData -> do
let prefix = stext $ mkModulePrefix decOCamlTypeMetaData parOCamlTypeMetaData
pure $ (parensIfNotBlank dx) <+> prefix <> name
Nothing -> fail ("expected to find dependency:\n\n" ++ "\n\nin\n\n" ++ show ds)
renderRef datatype@(OCamlDatatype typeRef typeName _) = do
if isTypeParameterRef datatype
then
pure . stext $ "'" <> textLowercaseFirst typeName
else do
mOCamlTypeMetaData <- asks topLevelOCamlTypeMetaData
case mOCamlTypeMetaData of
Nothing -> pure . stext . textLowercaseFirst $ typeName
Just decOCamlTypeMetaData -> do
ds <- asks (dependencies . userOptions)
case Map.lookup typeRef ds of
Just parOCamlTypeMetaData -> do
let prefix = stext $ mkModulePrefix decOCamlTypeMetaData parOCamlTypeMetaData
pure $ prefix <> (stext . textLowercaseFirst $ typeName)
Nothing -> fail ("expected to find dependency:\n\n" ++ show typeRef ++ "\n\nin\n\n" ++ show ds)
renderRef (OCamlPrimitive primitive) = renderRef primitive
instance HasTypeRef OCamlValue where
renderRef (OCamlRefAppValues x y) = do
dx <- render x
dy <- render y
pure $ dx <> comma <+> dy
renderRef (OCamlRef _metaData primitive) = pure $ stext primitive
renderRef (OCamlPrimitiveRef primitive) = renderRef primitive
renderRef _ = pure ""
instance HasType OCamlConstructor where
render (OCamlValueConstructor value) = render value
render (OCamlSumOfRecordConstructor _ value) = render value
render (OCamlEnumeratorConstructor constructors) =
mintercalate (line <> "|" <> space) <$> sequence (render <$> constructors)
instance HasType ValueConstructor where
render (RecordConstructor _ value) = do
fields <- renderRecord value
pure $ "{" <+> fields <$$> "}"
render (NamedConstructor constructorName (OCamlEmpty)) = do
pure $ stext constructorName
render (NamedConstructor constructorName value) = do
types <- render value
pure $ stext constructorName <+> "of" <+> types
render (MultipleConstructors constructors) = do
mintercalate (line <> "|" <> space) <$> sequence (render <$> constructors)
instance HasType EnumeratorConstructor where
render (EnumeratorConstructor name) = pure (stext name)
instance HasType OCamlValue where
render ref@(OCamlRef typeRef name) = do
mOCamlTypeMetaData <- asks topLevelOCamlTypeMetaData
case mOCamlTypeMetaData of
Nothing -> fail $ "OCaml.BuckleScript.Record (HasType (OCamlDatatype typeRep name)) mOCamlTypeMetaData is Nothing:\n\n" ++ (show ref)
Just ocamlTypeRef -> do
ds <- asks (dependencies . userOptions)
pure . stext $ appendModule ds ocamlTypeRef typeRef name
render (OCamlRefApp typRep values) = do
mOCamlTypeMetaData <- asks topLevelOCamlTypeMetaData
case mOCamlTypeMetaData of
Nothing -> fail $ "OCaml.BuckleScript.Record (HasType (OCamlDatatype typeRep name)) mOCamlTypeMetaData is Nothing:\n\n"
Just ocamlTypeRef -> do
ds <- asks (dependencies . userOptions)
dx <- render values
pure $ (parensIfNotBlank dx) <+> (stext $ appendModule ds ocamlTypeRef (typeRepToHaskellTypeMetaData typRep) (T.pack . show $ typeRepTyCon typRep))
render (OCamlTypeParameterRef name) = pure $ stext ("'" <> name)
render (OCamlPrimitiveRef primitive) = ocamlRefParens primitive <$> renderRef primitive
render (Values x y) = do
dx <- render x
dy <- render y
pure $ dx <+> "*" <+> dy
render (OCamlRefAppValues x y) = do
dx <- render x
dy <- render y
pure $ dx <> comma <+> dy
render (OCamlField name value) = do
dv <- renderRecord value
pure $ stext name <+> ":" <+> dv
render OCamlEmpty = pure ""
instance HasRecordType OCamlValue where
renderRecord (Values x y) = do
dx <- renderRecord x
dy <- renderRecord y
pure $ dx <$$> ";" <+> dy
renderRecord (OCamlPrimitiveRef primitive) = renderRef primitive
renderRecord value = render value
instance HasTypeRef OCamlPrimitive where
renderRef OBool = pure "bool"
renderRef OChar = pure "string"
renderRef ODate = pure "Js_date.t"
renderRef OFloat = pure "float"
renderRef OInt = pure "int"
renderRef OInt32 = pure "int32"
renderRef OString = pure "string"
renderRef OUnit = pure "unit"
renderRef (OList (OCamlPrimitive OChar)) = renderRef OString
renderRef (OList datatype) = do
dt <- renderRef datatype
pure $ parens dt <+> "list"
renderRef (OOption datatype) = do
dt <- renderRef datatype
pure $ parens dt <+> "option"
renderRef (OEither l r) = do
dl <- renderRef l
dr <- renderRef r
pure $ (parens $ dl <> comma <+> dr) <+> "Aeson.Compatibility.Either.t"
renderRef (OTuple2 a b) = do
da <- renderRef a
db <- renderRef b
pure . parens $ da <+> "*" <+> db
renderRef (OTuple3 a b c) = do
da <- renderRef a
db <- renderRef b
dc <- renderRef c
pure . parens $ da <+> "*" <+> db <+> "*" <+> dc
renderRef (OTuple4 a b c d) = do
da <- renderRef a
db <- renderRef b
dc <- renderRef c
dd <- renderRef d
pure . parens $ da <+> "*" <+> db <+> "*" <+> dc <+> "*" <+> dd
renderRef (OTuple5 a b c d e) = do
da <- renderRef a
db <- renderRef b
dc <- renderRef c
dd <- renderRef d
de <- renderRef e
pure . parens $ da <+> "*" <+> db <+> "*" <+> dc <+> "*" <+> dd <+> "*" <+> de
renderRef (OTuple6 a b c d e f) = do
da <- renderRef a
db <- renderRef b
dc <- renderRef c
dd <- renderRef d
de <- renderRef e
df <- renderRef f
pure . parens $ da <+> "*" <+> db <+> "*" <+> dc <+> "*" <+> dd <+> "*" <+> de <+> "*" <+> df
replaceRecordConstructors :: [(Text,ValueConstructor)] -> ValueConstructor -> ValueConstructor
replaceRecordConstructors newConstructors recordConstructor@(RecordConstructor oldName _) =
case length newRecordConstructor > 0 of
False -> recordConstructor
True -> head newRecordConstructor
where
replace (oldName', (RecordConstructor newName _value)) =
if oldName == oldName' then (Just $ NamedConstructor oldName' (OCamlRef (HaskellTypeMetaData "" "" "") newName)) else Nothing
replace _ = Nothing
newRecordConstructor = catMaybes $ replace <$> newConstructors
replaceRecordConstructors _ rc = rc
renderTypeParameters :: OCamlConstructor -> Doc
renderTypeParameters constructor = mkDocList $ stext . (<>) "'" <$> sort (nub $ getTypeParameters constructor)
renderSumRecord :: Text -> ValueConstructor -> Reader TypeMetaData (Maybe (Doc,(Text,ValueConstructor)))
renderSumRecord typeName constructor@(RecordConstructor name value) = do
let sumRecordName = typeName <> name
functionBody <- render constructor
pure $ Just (("type" <+> (stext (textLowercaseFirst sumRecordName)) <+> "=" <$$> indent 2 functionBody), (name, (RecordConstructor sumRecordName value)))
renderSumRecord _ _ = pure Nothing
appendModule :: Map.Map HaskellTypeMetaData OCamlTypeMetaData -> OCamlTypeMetaData -> HaskellTypeMetaData -> Text -> Text
appendModule m o h name =
case Map.lookup h m of
Just parOCamlTypeMetaData ->
(mkModulePrefix o parOCamlTypeMetaData) <> (textLowercaseFirst name)
Nothing -> textLowercaseFirst name
ocamlRefParens :: OCamlPrimitive -> Doc -> Doc
ocamlRefParens (OList (OCamlPrimitive OChar)) = id
ocamlRefParens (OList _) = parens
ocamlRefParens (OOption _) = parens
ocamlRefParens _ = id
parensIfNotBlank :: Doc -> Doc
parensIfNotBlank d = let dx = show d in if (length dx) > 0 && dx /= " " then parens d else d