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 ::
  -- | field modifier
  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
    }