module Codegen where
import Data.Aeson
import Data.Char
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import Data.Text (Text, isInfixOf, pack, unpack)
import qualified Data.Text as T
import Language.Haskell.Codegen
import Language.TL.AST hiding (ADT (..), Ann, App, Type (..))
import qualified Language.TL.AST as A
import Text.Casing
type TyMap = Map Text Text
type FieldMapping = Map String String
type Modifier = String -> String
mkOption ::
Modifier ->
Options
mkOption :: Modifier -> Options
mkOption fieldM :: Modifier
fieldM =
Options
defaultOptions
{ fieldLabelModifier :: Modifier
fieldLabelModifier = Modifier
fieldM,
constructorTagModifier :: Modifier
constructorTagModifier = Modifier
lower,
sumEncoding :: SumEncoding
sumEncoding =
TaggedObject :: String -> String -> SumEncoding
TaggedObject
{ tagFieldName :: String
tagFieldName = "@type",
contentsFieldName :: String
contentsFieldName = Modifier
forall a. HasCallStack => String -> a
error "Not a record"
},
tagSingleConstructors :: Bool
tagSingleConstructors = Bool
True,
allNullaryToStringTag :: Bool
allNullaryToStringTag = Bool
False
}
mkModifier :: FieldMapping -> Modifier
mkModifier :: FieldMapping -> Modifier
mkModifier m :: FieldMapping
m s :: String
s = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (Modifier
camelToSnake String
s) (String -> FieldMapping -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
s FieldMapping
m)
defTyMap :: TyMap
defTyMap :: TyMap
defTyMap =
[(Text, Text)] -> TyMap
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
[ ("vector", "[]"),
("string", "T"),
("int32", "I32"),
("int64", "I64"),
("int53", "I53"),
("bytes", "ByteString64")
]
typeConv :: TyMap -> A.Type -> Type
typeConv :: TyMap -> Type -> Type
typeConv m :: TyMap
m (A.Type t :: Text
t) = Text -> Type
Type (Text -> Type) -> Text -> Type
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (Text -> Text
upper Text
t) (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> TyMap -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
t TyMap
m
typeConv m :: TyMap
m (A.TypeApp t :: Type
t ts :: [Type]
ts) = Type -> [Type] -> Type
app (TyMap -> Type -> Type
typeConv TyMap
m Type
t) ((Type -> Type) -> [Type] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyMap -> Type -> Type
typeConv TyMap
m) [Type]
ts)
typeConv _ A.NatType = Text -> Type
Type "Int"
app :: Type -> [Type] -> Type
app :: Type -> [Type] -> Type
app t :: Type
t = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ty :: Type
ty acc :: Type
acc -> Type -> Type -> Type
App Type
acc Type
ty) Type
t
convArg :: TyMap -> Arg -> Field
convArg :: TyMap -> Arg -> Field
convArg m :: TyMap
m Arg {..} =
let ty :: Type
ty = TyMap -> Type -> Type
typeConv TyMap
m Type
argType
in Field :: Text -> Maybe Text -> Type -> Field
Field
{ $sel:name:Field :: Text
name = Text
argName,
$sel:ty:Field :: Type
ty = case Maybe Text
ann of
Nothing -> Type
ty
Just doc :: Text
doc ->
if "may be null" Text -> Text -> Bool
`isInfixOf` Text
doc
then Type -> Type
warpM Type
ty
else Type
ty,
..
}
combToConstr :: TyMap -> Combinator -> Constr
combToConstr :: TyMap -> Combinator -> Constr
combToConstr m :: TyMap
m Combinator {..} =
Constr :: Text -> Maybe Text -> [Field] -> Constr
Constr
{ $sel:name:Constr :: Text
name = Text -> Text
upper Text
ident,
$sel:fields:Constr :: [Field]
fields = (Arg -> Field) -> [Arg] -> [Field]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyMap -> Arg -> Field
convArg TyMap
m) [Arg]
args,
..
}
formArr :: [Field] -> Type -> Ann -> TypeSig
formArr :: [Field] -> Type -> Maybe Text -> TypeSig
formArr fields :: [Field]
fields resT :: Type
resT resAnn :: Maybe Text
resAnn = (Field -> TypeSig -> TypeSig) -> TypeSig -> [Field] -> TypeSig
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Field {..} res :: TypeSig
res -> Conn :: Type -> Maybe Text -> TypeSig -> TypeSig
Conn {..}) (Result :: Type -> Maybe Text -> TypeSig
Result {$sel:ty:Result :: Type
ty = Type
resT, $sel:ann:Result :: Maybe Text
ann = Maybe Text
resAnn}) [Field]
fields
combToFun :: TyMap -> Combinator -> FunDef
combToFun :: TyMap -> Combinator -> FunDef
combToFun m :: TyMap
m c :: Combinator
c@Combinator {..} =
FunDef :: Text -> Maybe Text -> Constr -> Type -> FunDef
FunDef
{ $sel:name:FunDef :: Text
name = Text
ident,
$sel:constr:FunDef :: Constr
constr = TyMap -> Combinator -> Constr
combToConstr TyMap
m Combinator
c,
$sel:res:FunDef :: Type
res = TyMap -> Type -> Type
typeConv TyMap
m Type
resType,
..
}
convADT :: TyMap -> A.ADT -> ADT
convADT :: TyMap -> ADT -> ADT
convADT m :: TyMap
m A.ADT {..} =
let constr :: [Constr]
constr = (Combinator -> Constr) -> [Combinator] -> [Constr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyMap -> Combinator -> Constr
combToConstr TyMap
m) [Combinator]
constructors
in ADT :: Text -> Maybe Text -> [Constr] -> ADT
ADT
{ ..
}
countElem :: Eq a => a -> [a] -> Int
countElem :: a -> [a] -> Int
countElem _ [] = String -> Int
forall a. HasCallStack => String -> a
error "Not in list"
countElem a :: a
a (x :: a
x : xs :: [a]
xs) =
if a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a
then 0
else 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ a -> [a] -> Int
forall a. Eq a => a -> [a] -> Int
countElem a
a [a]
xs
sanitize' :: Text -> (Text, FieldMapping)
sanitize' :: Text -> (Text, FieldMapping)
sanitize' "type" = ("type_", [(String, String)] -> FieldMapping
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [("type_", "type")])
sanitize' "data" = ("data_", [(String, String)] -> FieldMapping
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [("data_", "data")])
sanitize' "pattern" = ("pattern_", [(String, String)] -> FieldMapping
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [("pattern_", "pattern")])
sanitize' t :: Text
t = (Text -> Text
snakeToCamel Text
t, FieldMapping
forall a. Monoid a => a
mempty)
sanitizeArg :: Int -> Text -> (Text, FieldMapping)
sanitizeArg :: Int -> Text -> (Text, FieldMapping)
sanitizeArg 0 t :: Text
t = Text -> (Text, FieldMapping)
sanitize' Text
t
sanitizeArg i :: Int
i t :: Text
t =
let n :: Text
n = (Text -> Text
snakeToCamel Text
t) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (Int -> String
forall a. Show a => a -> String
show Int
i)
in (Text
n, [(String, String)] -> FieldMapping
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Text -> String
unpack Text
n, Text -> String
unpack Text
t)])
type SanitizerState = (Map Text [Type], FieldMapping)
sanitizeField :: SanitizerState -> Field -> (SanitizerState, Field)
sanitizeField :: SanitizerState -> Field -> (SanitizerState, Field)
sanitizeField (tyMap :: Map Text [Type]
tyMap, fieldMap :: FieldMapping
fieldMap) Field {..} =
case Text -> Map Text [Type] -> Maybe [Type]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
name Map Text [Type]
tyMap of
Nothing ->
let (name' :: Text
name', dfm :: FieldMapping
dfm) = Int -> Text -> (Text, FieldMapping)
sanitizeArg 0 Text
name
in ((Text -> [Type] -> Map Text [Type] -> Map Text [Type]
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
name [Type
ty] Map Text [Type]
tyMap, FieldMapping
fieldMap FieldMapping -> FieldMapping -> FieldMapping
forall a. Semigroup a => a -> a -> a
<> FieldMapping
dfm), Field :: Text -> Maybe Text -> Type -> Field
Field {$sel:name:Field :: Text
name = Text
name', ..})
Just l :: [Type]
l ->
if Type
ty Type -> [Type] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Type]
l
then
let c :: Int
c = Type -> [Type] -> Int
forall a. Eq a => a -> [a] -> Int
countElem Type
ty [Type]
l
(name' :: Text
name', dfm :: FieldMapping
dfm) = Int -> Text -> (Text, FieldMapping)
sanitizeArg Int
c Text
name
in ((Map Text [Type]
tyMap, FieldMapping
fieldMap FieldMapping -> FieldMapping -> FieldMapping
forall a. Semigroup a => a -> a -> a
<> FieldMapping
dfm), Text -> Maybe Text -> Type -> Field
Field Text
name' Maybe Text
ann Type
ty)
else
let c :: Int
c = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
(name' :: Text
name', dfm :: FieldMapping
dfm) = Int -> Text -> (Text, FieldMapping)
sanitizeArg Int
c Text
name
tyMap' :: Map Text [Type]
tyMap' = Text -> [Type] -> Map Text [Type] -> Map Text [Type]
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
name ([Type]
l [Type] -> [Type] -> [Type]
forall a. Semigroup a => a -> a -> a
<> [Type
ty]) Map Text [Type]
tyMap
in ((Map Text [Type]
tyMap', FieldMapping
fieldMap FieldMapping -> FieldMapping -> FieldMapping
forall a. Semigroup a => a -> a -> a
<> FieldMapping
dfm), Text -> Maybe Text -> Type -> Field
Field Text
name' Maybe Text
ann Type
ty)
sanitizeField' :: Field -> (SanitizerState, [Field]) -> (SanitizerState, [Field])
sanitizeField' :: Field -> (SanitizerState, [Field]) -> (SanitizerState, [Field])
sanitizeField' f :: Field
f (s :: SanitizerState
s, fs :: [Field]
fs) =
let (s' :: SanitizerState
s', f' :: Field
f') = SanitizerState -> Field -> (SanitizerState, Field)
sanitizeField SanitizerState
s Field
f
in (SanitizerState
s', Field
f' Field -> [Field] -> [Field]
forall a. a -> [a] -> [a]
: [Field]
fs)
sanitizeConstr :: SanitizerState -> Constr -> (SanitizerState, Constr)
sanitizeConstr :: SanitizerState -> Constr -> (SanitizerState, Constr)
sanitizeConstr s :: SanitizerState
s Constr {..} =
let (s' :: SanitizerState
s', fields' :: [Field]
fields') = (Field -> (SanitizerState, [Field]) -> (SanitizerState, [Field]))
-> (SanitizerState, [Field])
-> [Field]
-> (SanitizerState, [Field])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Field -> (SanitizerState, [Field]) -> (SanitizerState, [Field])
sanitizeField' (SanitizerState
s, []) [Field]
fields
in ( SanitizerState
s',
Constr :: Text -> Maybe Text -> [Field] -> Constr
Constr
{ $sel:fields:Constr :: [Field]
fields = [Field]
fields',
..
}
)
sanitizeConstr' :: Constr -> (SanitizerState, [Constr]) -> (SanitizerState, [Constr])
sanitizeConstr' :: Constr -> (SanitizerState, [Constr]) -> (SanitizerState, [Constr])
sanitizeConstr' c :: Constr
c (s :: SanitizerState
s, cs :: [Constr]
cs) =
let (s' :: SanitizerState
s', c' :: Constr
c') = SanitizerState -> Constr -> (SanitizerState, Constr)
sanitizeConstr SanitizerState
s Constr
c
in (SanitizerState
s', Constr
c' Constr -> [Constr] -> [Constr]
forall a. a -> [a] -> [a]
: [Constr]
cs)
sanitizeADT :: ADT -> (ADT, FieldMapping)
sanitizeADT :: ADT -> (ADT, FieldMapping)
sanitizeADT ADT {..} =
let ((_, fm :: FieldMapping
fm), constr' :: [Constr]
constr') = (Constr
-> (SanitizerState, [Constr]) -> (SanitizerState, [Constr]))
-> (SanitizerState, [Constr])
-> [Constr]
-> (SanitizerState, [Constr])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Constr -> (SanitizerState, [Constr]) -> (SanitizerState, [Constr])
sanitizeConstr' (SanitizerState, [Constr])
forall a. Monoid a => a
mempty [Constr]
constr
in ( ADT :: Text -> Maybe Text -> [Constr] -> ADT
ADT
{ $sel:constr:ADT :: [Constr]
constr = [Constr]
constr',
..
},
FieldMapping
fm
)
convFun :: TyMap -> Function -> FunDef
convFun :: TyMap -> Function -> FunDef
convFun m :: TyMap
m (Function c :: Combinator
c) = TyMap -> Combinator -> FunDef
combToFun TyMap
m Combinator
c
paramADT :: FunDef -> ADT
paramADT :: FunDef -> ADT
paramADT FunDef {..} =
ADT :: Text -> Maybe Text -> [Constr] -> ADT
ADT
{ $sel:ann:ADT :: Maybe Text
ann = Text -> Maybe Text
forall a. a -> Maybe a
Just ("Parameter of Function " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name),
$sel:constr:ADT :: [Constr]
constr = [Constr
constr],
$sel:name:ADT :: Text
name = Text -> Text
upper Text
name
}