module Codegen where

import Data.Aeson
import Data.Char
import Data.Foldable
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import Data.Text (Text, 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

upper :: Text -> Text
upper :: Text -> Text
upper t :: Text
t = Char -> Text -> Text
T.cons (Char -> Char
toUpper (Char -> Char) -> Char -> Char
forall a b. (a -> b) -> a -> b
$ Text -> Char
T.head Text
t) (Text -> Text
T.tail Text
t)

lower :: String -> String
lower :: String -> String
lower t :: String
t = (Char -> Char
toLower (Char -> Char) -> Char -> Char
forall a b. (a -> b) -> a -> b
$ String -> Char
forall a. [a] -> a
head String
t) Char -> String -> String
forall a. a -> [a] -> [a]
: (String -> String
forall a. [a] -> [a]
tail String
t)

type TyMap = Map Text Text

type FieldMapping = Map String String

type Modifier = String -> String

mkOption ::
  -- | field modifier
  Modifier ->
  Options
mkOption :: (String -> String) -> Options
mkOption fieldM :: String -> String
fieldM =
  Options
defaultOptions
    { fieldLabelModifier :: String -> String
fieldLabelModifier = String -> String
fieldM,
      constructorTagModifier :: String -> String
constructorTagModifier = String -> String
lower,
      sumEncoding :: SumEncoding
sumEncoding =
        TaggedObject :: String -> String -> SumEncoding
TaggedObject
          { tagFieldName :: String
tagFieldName = "@type",
            contentsFieldName :: String
contentsFieldName = String -> String
forall a. HasCallStack => String -> a
error "Not a record"
          },
      tagSingleConstructors :: Bool
tagSingleConstructors = Bool
True,
      allNullaryToStringTag :: Bool
allNullaryToStringTag = Bool
False
    }

mkModifier :: FieldMapping -> Modifier
mkModifier :: FieldMapping -> String -> String
mkModifier m :: FieldMapping
m s :: String
s = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe 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 m :: TyMap
m 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 :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\acc :: Type
acc ty :: Type
ty -> Type -> Type -> Type
App Type
acc Type
ty) Type
t

convArg :: TyMap -> Int -> Arg -> (Field, (String, String))
convArg :: TyMap -> Int -> Arg -> (Field, (String, String))
convArg m :: TyMap
m i :: Int
i Arg {..} =
  let newName :: Text
newName = Text
argName 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 ( Field :: Text -> Maybe Text -> Type -> Field
Field
          { $sel:name:Field :: Text
name = Text
newName,
            $sel:ty:Field :: Type
ty = TyMap -> Type -> Type
typeConv TyMap
m Type
argType,
            ..
          },
        (Text -> String
unpack Text
newName, Text -> String
unpack Text
argName)
      )

convArg' :: TyMap -> Arg -> Field
convArg' :: TyMap -> Arg -> Field
convArg' m :: TyMap
m Arg {..} =
  Field :: Text -> Maybe Text -> Type -> Field
Field
    { $sel:name:Field :: Text
name = Text -> Text
sanitize Text
argName,
      $sel:ty:Field :: Type
ty = TyMap -> Type -> Type
typeConv TyMap
m Type
argType,
      ..
    }

sanitize :: Text -> Text
sanitize :: Text -> Text
sanitize "type" = "type_"
sanitize "data" = "data_"
sanitize x :: Text
x = Text
x

defMapping :: FieldMapping
defMapping :: FieldMapping
defMapping =
  [(String, String)] -> FieldMapping
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
    [ ("type_", "type"),
      ("data_", "data")
    ]

combToConstr :: TyMap -> Int -> Combinator -> (Constr, FieldMapping)
combToConstr :: TyMap -> Int -> Combinator -> (Constr, FieldMapping)
combToConstr m :: TyMap
m i :: Int
i Combinator {..} =
  let (fields :: [Field]
fields, l :: [(String, String)]
l) = [(Field, (String, String))] -> ([Field], [(String, String)])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Field, (String, String))] -> ([Field], [(String, String)]))
-> [(Field, (String, String))] -> ([Field], [(String, String)])
forall a b. (a -> b) -> a -> b
$ (Arg -> (Field, (String, String)))
-> [Arg] -> [(Field, (String, String))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyMap -> Int -> Arg -> (Field, (String, String))
convArg TyMap
m Int
i) [Arg]
args
   in ( Constr :: Text -> Maybe Text -> [Field] -> Constr
Constr
          { $sel:name:Constr :: Text
name = Text -> Text
upper Text
ident,
            ..
          },
        [(String, String)] -> FieldMapping
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(String, String)]
l
      )

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 = (TypeSig -> Field -> TypeSig) -> TypeSig -> [Field] -> TypeSig
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\res :: TypeSig
res Field {..} -> Conn :: Type -> Maybe Text -> 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, mappings :: [FieldMapping]
mappings) = [(Constr, FieldMapping)] -> ([Constr], [FieldMapping])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Constr, FieldMapping)] -> ([Constr], [FieldMapping]))
-> [(Constr, FieldMapping)] -> ([Constr], [FieldMapping])
forall a b. (a -> b) -> a -> b
$ ((Int, Combinator) -> (Constr, FieldMapping))
-> [(Int, Combinator)] -> [(Constr, FieldMapping)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> Combinator -> (Constr, FieldMapping))
-> (Int, Combinator) -> (Constr, FieldMapping)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (TyMap -> Int -> Combinator -> (Constr, FieldMapping)
combToConstr TyMap
m)) ([(Int, Combinator)] -> [(Constr, FieldMapping)])
-> [(Int, Combinator)] -> [(Constr, FieldMapping)]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Combinator] -> [(Int, Combinator)]
forall a b. [a] -> [b] -> [(a, b)]
zip [1 ..] [Combinator]
constructors
      mapping :: FieldMapping
mapping = [FieldMapping] -> FieldMapping
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [FieldMapping]
mappings
   in ADT :: Text -> Maybe Text -> [Constr] -> FieldMapping -> ADT
ADT
        { ..
        }

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] -> FieldMapping -> 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:mapping:ADT :: FieldMapping
mapping = FieldMapping
defMapping,
      $sel:constr:ADT :: [Constr]
constr = [Constr
constr],
      $sel:name:ADT :: Text
name = Text -> Text
upper Text
name
    }