module Hydra.Ext.Haskell.Coder (printModule) where

import Hydra.Kernel
import Hydra.CoreDecoding
import Hydra.Adapters.Coders
import Hydra.Ext.Haskell.Language
import Hydra.Ext.Haskell.Utils
import qualified Hydra.Ext.Haskell.Ast as H
import qualified Hydra.Lib.Strings as Strings
import qualified Hydra.Impl.Haskell.Dsl.Types as Types
import Hydra.Impl.Haskell.Dsl.Terms
import Hydra.Util.Codetree.Script
import Hydra.Ext.Haskell.Serde
import Hydra.Ext.Haskell.Settings

import qualified Control.Monad as CM
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Maybe as Y


constantDecls :: Context m -> Namespaces -> Name -> Type m -> [H.DeclarationWithComments]
constantDecls :: forall m.
Context m
-> Namespaces -> Name -> Type m -> [DeclarationWithComments]
constantDecls Context m
cx Namespaces
namespaces name :: Name
name@(Name String
nm) Type m
typ = if Bool
useCoreImport
    then Name -> (String, String) -> DeclarationWithComments
toDecl (String -> Name
Name String
"hydra/core.Name") (String, String)
nameDeclforall a. a -> [a] -> [a]
:(Name -> (String, String) -> DeclarationWithComments
toDecl (String -> Name
Name String
"hydra/core.FieldName") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, String)]
fieldDecls)
    else []
  where
    lname :: String
lname = Name -> String
localNameOfEager Name
name
    toDecl :: Name -> (String, String) -> DeclarationWithComments
toDecl Name
n (String
k, String
v) = Declaration -> Maybe String -> DeclarationWithComments
H.DeclarationWithComments Declaration
decl forall a. Maybe a
Nothing
      where
        decl :: Declaration
decl = ValueBinding -> Declaration
H.DeclarationValueBinding forall a b. (a -> b) -> a -> b
$
          ValueBinding_Simple -> ValueBinding
H.ValueBindingSimple forall a b. (a -> b) -> a -> b
$ Pattern
-> RightHandSide -> Maybe LocalBindings -> ValueBinding_Simple
H.ValueBinding_Simple Pattern
pat RightHandSide
rhs forall a. Maybe a
Nothing
        pat :: Pattern
pat = Pattern_Application -> Pattern
H.PatternApplication forall a b. (a -> b) -> a -> b
$ Name -> [Pattern] -> Pattern_Application
H.Pattern_Application (String -> Name
simpleName String
k) []
        rhs :: RightHandSide
rhs = Expression -> RightHandSide
H.RightHandSide forall a b. (a -> b) -> a -> b
$ Expression_Application -> Expression
H.ExpressionApplication forall a b. (a -> b) -> a -> b
$ Expression -> Expression -> Expression_Application
H.Expression_Application
          (Name -> Expression
H.ExpressionVariable forall a b. (a -> b) -> a -> b
$ Namespaces -> Name -> Name
elementReference Namespaces
namespaces Name
n)
          (Literal -> Expression
H.ExpressionLiteral forall a b. (a -> b) -> a -> b
$ String -> Literal
H.LiteralString String
v)
    nameDecl :: (String, String)
nameDecl = (String
"_" forall a. [a] -> [a] -> [a]
++ String
lname, String
nm)
    fieldsOf :: Type m -> [FieldType m]
fieldsOf Type m
t = case forall m. Type m -> Type m
stripType Type m
t of
      TypeRecord RowType m
rt -> forall m. RowType m -> [FieldType m]
rowTypeFields RowType m
rt
      TypeUnion RowType m
rt -> forall m. RowType m -> [FieldType m]
rowTypeFields RowType m
rt
      Type m
_ -> []
    fieldDecls :: [(String, String)]
fieldDecls = forall {m}. FieldType m -> (String, String)
toConstant forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {m}. Type m -> [FieldType m]
fieldsOf (forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall m. Context m -> Type m -> ([VariableType], Type m)
unpackLambdaType Context m
cx Type m
typ)
    toConstant :: FieldType m -> (String, String)
toConstant (FieldType (FieldName String
fname) Type m
_) = (String
"_" forall a. [a] -> [a] -> [a]
++ String
lname forall a. [a] -> [a] -> [a]
++ String
"_" forall a. [a] -> [a] -> [a]
++ String
fname, String
fname)

constructModule :: (Ord m, Read m, Show m)
  => Module m
  -> M.Map (Type m) (Coder (Context m) (Context m) (Term m) H.Expression)
  -> [(Element m, TypedTerm m)] -> GraphFlow m H.Module
constructModule :: forall m.
(Ord m, Read m, Show m) =>
Module m
-> Map (Type m) (Coder (Context m) (Context m) (Term m) Expression)
-> [(Element m, TypedTerm m)]
-> GraphFlow m Module
constructModule Module m
mod Map (Type m) (Coder (Context m) (Context m) (Term m) Expression)
coders [(Element m, TypedTerm m)]
pairs = do
    Context m
cx <- forall s. Flow s s
getState
    [DeclarationWithComments]
decls <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
L.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM (Context m
-> (Element m, TypedTerm m)
-> Flow (Context m) [DeclarationWithComments]
createDeclarations Context m
cx) [(Element m, TypedTerm m)]
pairs
    let mc :: Maybe String
mc = forall m. Module m -> Maybe String
moduleDescription Module m
mod
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe ModuleHead -> [Import] -> [DeclarationWithComments] -> Module
H.Module (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Maybe String -> ModuleName -> [Export] -> ModuleHead
H.ModuleHead Maybe String
mc (String -> ModuleName
importName forall a b. (a -> b) -> a -> b
$ Namespace -> String
h forall a b. (a -> b) -> a -> b
$ forall m. Module m -> Namespace
moduleNamespace Module m
mod) []) [Import]
imports [DeclarationWithComments]
decls
  where
    h :: Namespace -> String
h (Namespace String
name) = String
name

    createDeclarations :: Context m
-> (Element m, TypedTerm m)
-> Flow (Context m) [DeclarationWithComments]
createDeclarations Context m
cx pair :: (Element m, TypedTerm m)
pair@(Element m
el, TypedTerm Type m
typ Term m
term) = if forall m. Eq m => Context m -> Type m -> Bool
isType Context m
cx Type m
typ
      then forall m.
(Ord m, Read m, Show m) =>
Namespaces
-> Element m -> Term m -> GraphFlow m [DeclarationWithComments]
toTypeDeclarations Namespaces
namespaces Element m
el Term m
term
      else forall m.
(Ord m, Show m) =>
Map (Type m) (Coder (Context m) (Context m) (Term m) Expression)
-> Namespaces
-> (Element m, TypedTerm m)
-> GraphFlow m [DeclarationWithComments]
toDataDeclarations Map (Type m) (Coder (Context m) (Context m) (Term m) Expression)
coders Namespaces
namespaces (Element m, TypedTerm m)
pair

    namespaces :: Namespaces
namespaces = forall m. Module m -> Namespaces
namespacesForModule Module m
mod
    importName :: String -> ModuleName
importName String
name = String -> ModuleName
H.ModuleName forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
L.intercalate String
"." (String -> String
capitalize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> String -> [String]
Strings.splitOn String
"/" String
name)
    imports :: [Import]
imports = [Import]
domainImports forall a. [a] -> [a] -> [a]
++ [Import]
standardImports
      where
        domainImports :: [Import]
domainImports = (Namespace, ModuleName) -> Import
toImport forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
M.toList (Namespaces -> Map Namespace ModuleName
namespacesMapping Namespaces
namespaces)
          where
            toImport :: (Namespace, ModuleName) -> Import
toImport (Namespace String
name, ModuleName
alias) = Bool
-> ModuleName -> Maybe ModuleName -> Maybe Import_Spec -> Import
H.Import Bool
True (String -> ModuleName
importName String
name) (forall a. a -> Maybe a
Just ModuleName
alias) forall a. Maybe a
Nothing
        standardImports :: [Import]
standardImports = ModuleName -> Import
toImport forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ModuleName
H.ModuleName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [Maybe a] -> [a]
Y.catMaybes [
            forall a. a -> Maybe a
Just String
"Data.List",
            forall a. a -> Maybe a
Just String
"Data.Map",
            forall a. a -> Maybe a
Just String
"Data.Set"{-,
            if useCoreImport && moduleNamespace g /= Namespace "hydra/core"
              then Just "Hydra.Core"
              else Nothing-}]
          where
            toImport :: ModuleName -> Import
toImport ModuleName
name = Bool
-> ModuleName -> Maybe ModuleName -> Maybe Import_Spec -> Import
H.Import Bool
False ModuleName
name forall a. Maybe a
Nothing forall a. Maybe a
Nothing

encodeAdaptedType :: (Ord m, Read m, Show m) => Namespaces -> Type m -> GraphFlow m H.Type
encodeAdaptedType :: forall m.
(Ord m, Read m, Show m) =>
Namespaces -> Type m -> GraphFlow m Type
encodeAdaptedType Namespaces
namespaces Type m
typ = forall m.
(Ord m, Read m, Show m) =>
Language m -> Type m -> GraphFlow m (Type m)
adaptType forall m. Language m
haskellLanguage Type m
typ forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall m. Show m => Namespaces -> Type m -> GraphFlow m Type
encodeType Namespaces
namespaces

encodeFunction :: (Eq m, Ord m, Read m, Show m) => Namespaces -> Function m -> GraphFlow m H.Expression
encodeFunction :: forall m.
(Eq m, Ord m, Read m, Show m) =>
Namespaces -> Function m -> GraphFlow m Expression
encodeFunction Namespaces
namespaces Function m
fun = case Function m
fun of
    FunctionElimination Elimination m
e -> case Elimination m
e of
      Elimination m
EliminationElement -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> Expression
hsvar String
"id"
      EliminationList Term m
fun -> do
        let lhs :: Expression
lhs = String -> Expression
hsvar String
"foldl"
        Expression
rhs <- forall m.
(Eq m, Ord m, Read m, Show m) =>
Namespaces -> Term m -> GraphFlow m Expression
encodeTerm Namespaces
namespaces Term m
fun
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Expression -> Expression -> Expression
hsapp Expression
lhs Expression
rhs
      EliminationNominal Name
name -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> Expression
H.ExpressionVariable forall a b. (a -> b) -> a -> b
$ Namespaces -> Name -> Name
elementReference Namespaces
namespaces forall a b. (a -> b) -> a -> b
$
        Namespace -> String -> Name
qname (Name -> Namespace
namespaceOfEager Name
name) forall a b. (a -> b) -> a -> b
$ Name -> String
newtypeAccessorName Name
name
      EliminationOptional (OptionalCases Term m
nothing Term m
just) -> do
        CaseRhs
nothingRhs <- Expression -> CaseRhs
H.CaseRhs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m.
(Eq m, Ord m, Read m, Show m) =>
Namespaces -> Term m -> GraphFlow m Expression
encodeTerm Namespaces
namespaces Term m
nothing
        let nothingAlt :: Alternative
nothingAlt = Pattern -> CaseRhs -> Maybe LocalBindings -> Alternative
H.Alternative (Name -> Pattern
H.PatternName forall a b. (a -> b) -> a -> b
$ String -> Name
simpleName String
"Nothing") CaseRhs
nothingRhs forall a. Maybe a
Nothing
        Alternative
justAlt <- do
          -- Note: some of the following could be brought together with FunctionCases
          let v0 :: String
v0 = String
"v"
          let rhsTerm :: Term m
rhsTerm = forall m. Ord m => Term m -> Term m
simplifyTerm forall a b. (a -> b) -> a -> b
$ forall m. Term m -> Term m -> Term m
apply Term m
just (forall m. String -> Term m
variable String
v0)
          let v1 :: String
v1 = if forall a. Ord a => a -> Set a -> Bool
S.member (String -> Variable
Variable String
v0) forall a b. (a -> b) -> a -> b
$ forall m. Term m -> Set Variable
freeVariablesInTerm Term m
rhsTerm then String
v0 else String
"_"
          let lhs :: Pattern
lhs = Pattern_Application -> Pattern
H.PatternApplication forall a b. (a -> b) -> a -> b
$ Name -> [Pattern] -> Pattern_Application
H.Pattern_Application (String -> Name
rawName String
"Just") [Name -> Pattern
H.PatternName forall a b. (a -> b) -> a -> b
$ String -> Name
rawName String
v1]
          CaseRhs
rhs <- Expression -> CaseRhs
H.CaseRhs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m.
(Eq m, Ord m, Read m, Show m) =>
Namespaces -> Term m -> GraphFlow m Expression
encodeTerm Namespaces
namespaces Term m
rhsTerm
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Pattern -> CaseRhs -> Maybe LocalBindings -> Alternative
H.Alternative Pattern
lhs CaseRhs
rhs forall a. Maybe a
Nothing
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Expression_Case -> Expression
H.ExpressionCase forall a b. (a -> b) -> a -> b
$ Expression -> [Alternative] -> Expression_Case
H.Expression_Case (String -> Expression
hsvar String
"x") [Alternative
nothingAlt, Alternative
justAlt]
      EliminationRecord (Projection Name
dn FieldName
fname) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Expression
H.ExpressionVariable forall a b. (a -> b) -> a -> b
$ Namespaces -> Name -> FieldName -> Name
recordFieldReference Namespaces
namespaces Name
dn FieldName
fname
      EliminationUnion (CaseStatement Name
dn [Field m]
fields) -> String -> Expression -> Expression
hslambda String
"x" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphFlow m Expression
caseExpr -- note: could use a lambda case here
        where
          caseExpr :: GraphFlow m Expression
caseExpr = do
            RowType m
rt <- forall m a. GraphFlow m a -> GraphFlow m a
withSchemaContext forall a b. (a -> b) -> a -> b
$ forall m. Show m => Bool -> Name -> GraphFlow m (RowType m)
requireUnionType Bool
False Name
dn
            let fieldMap :: Map FieldName (FieldType m)
fieldMap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ (\FieldType m
f -> (forall m. FieldType m -> FieldName
fieldTypeName FieldType m
f, FieldType m
f)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m. RowType m -> [FieldType m]
rowTypeFields RowType m
rt
            Expression_Case -> Expression
H.ExpressionCase forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expression -> [Alternative] -> Expression_Case
H.Expression_Case (String -> Expression
hsvar String
"x") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM (forall {m} {m}.
(Read m, Show m, Ord m) =>
Map FieldName (FieldType m)
-> Field m -> Flow (Context m) Alternative
toAlt Map FieldName (FieldType m)
fieldMap) [Field m]
fields)
          toAlt :: Map FieldName (FieldType m)
-> Field m -> Flow (Context m) Alternative
toAlt Map FieldName (FieldType m)
fieldMap (Field FieldName
fn Term m
fun') = do
            let v0 :: String
v0 = String
"v"
            let raw :: Term m
raw = forall m. Term m -> Term m -> Term m
apply Term m
fun' (forall m. String -> Term m
variable String
v0)
            let rhsTerm :: Term m
rhsTerm = forall m. Ord m => Term m -> Term m
simplifyTerm Term m
raw
            let v1 :: String
v1 = if forall m. Variable -> Term m -> Bool
isFreeIn (String -> Variable
Variable String
v0) Term m
rhsTerm then String
"_" else String
v0
            let hname :: Name
hname = Namespaces -> Name -> FieldName -> Name
unionFieldReference Namespaces
namespaces Name
dn FieldName
fn
            [Pattern]
args <- case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FieldName
fn Map FieldName (FieldType m)
fieldMap of
              Just (FieldType FieldName
_ Type m
ft) -> case forall m. Type m -> Type m
stripType Type m
ft of
                TypeRecord (RowType Name
_ Maybe Name
Nothing []) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                Type m
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Name -> Pattern
H.PatternName forall a b. (a -> b) -> a -> b
$ String -> Name
rawName String
v1]
              Maybe (FieldType m)
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"field " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FieldName
fn forall a. [a] -> [a] -> [a]
++ String
" not found in " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
dn
            let lhs :: Pattern
lhs = Pattern_Application -> Pattern
H.PatternApplication forall a b. (a -> b) -> a -> b
$ Name -> [Pattern] -> Pattern_Application
H.Pattern_Application Name
hname [Pattern]
args
            CaseRhs
rhs <- Expression -> CaseRhs
H.CaseRhs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m.
(Eq m, Ord m, Read m, Show m) =>
Namespaces -> Term m -> GraphFlow m Expression
encodeTerm Namespaces
namespaces Term m
rhsTerm
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Pattern -> CaseRhs -> Maybe LocalBindings -> Alternative
H.Alternative Pattern
lhs CaseRhs
rhs forall a. Maybe a
Nothing
    FunctionLambda (Lambda (Variable String
v) Term m
body) -> String -> Expression -> Expression
hslambda String
v forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m.
(Eq m, Ord m, Read m, Show m) =>
Namespaces -> Term m -> GraphFlow m Expression
encodeTerm Namespaces
namespaces Term m
body
    FunctionPrimitive Name
name -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> Expression
H.ExpressionVariable forall a b. (a -> b) -> a -> b
$ Name -> Name
hsPrimitiveReference Name
name
    Function m
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"unexpected function: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Function m
fun

encodeLiteral :: Literal -> GraphFlow m H.Expression
encodeLiteral :: forall m. Literal -> GraphFlow m Expression
encodeLiteral Literal
av = case Literal
av of
    LiteralBoolean Bool
b -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> Expression
hsvar forall a b. (a -> b) -> a -> b
$ if Bool
b then String
"True" else String
"False"
    LiteralFloat FloatValue
fv -> case FloatValue
fv of
      FloatValueFloat32 Float
f -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Literal -> Expression
hslit forall a b. (a -> b) -> a -> b
$ Float -> Literal
H.LiteralFloat Float
f
      FloatValueFloat64 Double
f -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Literal -> Expression
hslit forall a b. (a -> b) -> a -> b
$ Double -> Literal
H.LiteralDouble Double
f
      FloatValue
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"floating-point number" FloatValue
fv
    LiteralInteger IntegerValue
iv -> case IntegerValue
iv of
      IntegerValueBigint Integer
i -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Literal -> Expression
hslit forall a b. (a -> b) -> a -> b
$ Integer -> Literal
H.LiteralInteger Integer
i
      IntegerValueInt32 Int
i -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Literal -> Expression
hslit forall a b. (a -> b) -> a -> b
$ Int -> Literal
H.LiteralInt Int
i
      IntegerValue
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"integer" IntegerValue
iv
    LiteralString String
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Literal -> Expression
hslit forall a b. (a -> b) -> a -> b
$ String -> Literal
H.LiteralString String
s
    Literal
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"literal value" Literal
av

encodeTerm :: (Eq m, Ord m, Read m, Show m) => Namespaces -> Term m -> GraphFlow m H.Expression
encodeTerm :: forall m.
(Eq m, Ord m, Read m, Show m) =>
Namespaces -> Term m -> GraphFlow m Expression
encodeTerm Namespaces
namespaces Term m
term = do
   case forall m. Term m -> Term m
stripTerm Term m
term of
    TermApplication (Application Term m
fun Term m
arg) -> case forall m. Term m -> Term m
stripTerm Term m
fun of
       TermFunction (FunctionElimination Elimination m
EliminationElement) -> Term m -> GraphFlow m Expression
encode Term m
arg
       Term m
_ -> Expression -> Expression -> Expression
hsapp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term m -> GraphFlow m Expression
encode Term m
fun forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term m -> GraphFlow m Expression
encode Term m
arg
    TermElement Name
name -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> Expression
H.ExpressionVariable forall a b. (a -> b) -> a -> b
$ Namespaces -> Name -> Name
elementReference Namespaces
namespaces Name
name
    TermFunction Function m
f -> forall m.
(Eq m, Ord m, Read m, Show m) =>
Namespaces -> Function m -> GraphFlow m Expression
encodeFunction Namespaces
namespaces Function m
f
    TermList [Term m]
els -> [Expression] -> Expression
H.ExpressionList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM Term m -> GraphFlow m Expression
encode [Term m]
els
    TermLiteral Literal
v -> forall m. Literal -> GraphFlow m Expression
encodeLiteral Literal
v
    TermNominal (Named Name
tname Term m
term') -> if Bool
newtypesNotTypedefs
      then Expression -> Expression -> Expression
hsapp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Expression
H.ExpressionVariable forall a b. (a -> b) -> a -> b
$ Namespaces -> Name -> Name
elementReference Namespaces
namespaces Name
tname) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term m -> GraphFlow m Expression
encode Term m
term'
      else Term m -> GraphFlow m Expression
encode Term m
term'
    TermOptional Maybe (Term m)
m -> case Maybe (Term m)
m of
      Maybe (Term m)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> Expression
hsvar String
"Nothing"
      Just Term m
t -> Expression -> Expression -> Expression
hsapp (String -> Expression
hsvar String
"Just") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term m -> GraphFlow m Expression
encode Term m
t
    TermProduct [Term m]
terms -> [Expression] -> Expression
H.ExpressionTuple forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM Term m -> GraphFlow m Expression
encode [Term m]
terms)
    TermRecord (Record Name
sname [Field m]
fields) -> do
      if forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [Field m]
fields -- TODO: too permissive; not all empty record types are the unit type
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Expression] -> Expression
H.ExpressionTuple []
        else do
            let typeName :: String
typeName = Name -> String
typeNameForRecord Name
sname
            [FieldUpdate]
updates <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM Field m -> Flow (Context m) FieldUpdate
toFieldUpdate [Field m]
fields
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Expression_ConstructRecord -> Expression
H.ExpressionConstructRecord forall a b. (a -> b) -> a -> b
$ Name -> [FieldUpdate] -> Expression_ConstructRecord
H.Expression_ConstructRecord (String -> Name
rawName String
typeName) [FieldUpdate]
updates
          where
            toFieldUpdate :: Field m -> Flow (Context m) FieldUpdate
toFieldUpdate (Field FieldName
fn Term m
ft) = Name -> Expression -> FieldUpdate
H.FieldUpdate (Namespaces -> Name -> FieldName -> Name
recordFieldReference Namespaces
namespaces Name
sname FieldName
fn) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term m -> GraphFlow m Expression
encode Term m
ft
    TermUnion (Union Name
sname (Field FieldName
fn Term m
ft)) -> do
      let lhs :: Expression
lhs = Name -> Expression
H.ExpressionVariable forall a b. (a -> b) -> a -> b
$ Namespaces -> Name -> FieldName -> Name
unionFieldReference Namespaces
namespaces Name
sname FieldName
fn
      case forall m. Term m -> Term m
stripTerm Term m
ft of
        TermRecord (Record Name
_ []) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression
lhs
        Term m
_ -> Expression -> Expression -> Expression
hsapp Expression
lhs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term m -> GraphFlow m Expression
encode Term m
ft
    TermVariable (Variable String
v) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> Expression
hsvar String
v
    Term m
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"unexpected term: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Term m
term
  where
    encode :: Term m -> GraphFlow m Expression
encode = forall m.
(Eq m, Ord m, Read m, Show m) =>
Namespaces -> Term m -> GraphFlow m Expression
encodeTerm Namespaces
namespaces

encodeType :: Show m => Namespaces -> Type m -> GraphFlow m H.Type
encodeType :: forall m. Show m => Namespaces -> Type m -> GraphFlow m Type
encodeType Namespaces
namespaces Type m
typ = case forall m. Type m -> Type m
stripType Type m
typ of
    TypeApplication (ApplicationType Type m
lhs Type m
rhs) -> [Type] -> Type
toTypeApplication forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
CM.sequence [Type m -> GraphFlow m Type
encode Type m
lhs, Type m -> GraphFlow m Type
encode Type m
rhs]
    TypeElement Type m
et -> Type m -> GraphFlow m Type
encode Type m
et
    TypeFunction (FunctionType Type m
dom Type m
cod) -> Type_Function -> Type
H.TypeFunction forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Type -> Type_Function
H.Type_Function forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type m -> GraphFlow m Type
encode Type m
dom forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type m -> GraphFlow m Type
encode Type m
cod)
    TypeLambda (LambdaType (VariableType String
v) Type m
body) -> [Type] -> Type
toTypeApplication forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
CM.sequence [
      Type m -> GraphFlow m Type
encode Type m
body,
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> Type
H.TypeVariable forall a b. (a -> b) -> a -> b
$ String -> Name
simpleName String
v]
    TypeList Type m
lt -> Type -> Type
H.TypeList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type m -> GraphFlow m Type
encode Type m
lt
    TypeLiteral LiteralType
lt -> Name -> Type
H.TypeVariable forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
rawName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case LiteralType
lt of
      LiteralType
LiteralTypeBoolean -> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Bool"
      LiteralTypeFloat FloatType
ft -> case FloatType
ft of
        FloatType
FloatTypeFloat32 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Float"
        FloatType
FloatTypeFloat64 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Double"
        FloatType
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"unexpected floating-point type: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FloatType
ft
      LiteralTypeInteger IntegerType
it -> case IntegerType
it of
        IntegerType
IntegerTypeBigint -> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Integer"
        IntegerType
IntegerTypeInt32 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Int"
        IntegerType
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"unexpected integer type: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show IntegerType
it
      LiteralType
LiteralTypeString -> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"String"
      LiteralType
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"unexpected literal type: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show LiteralType
lt
    TypeMap (MapType Type m
kt Type m
vt) -> [Type] -> Type
toTypeApplication forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
CM.sequence [
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> Type
H.TypeVariable forall a b. (a -> b) -> a -> b
$ String -> Name
rawName String
"Map",
      Type m -> GraphFlow m Type
encode Type m
kt,
      Type m -> GraphFlow m Type
encode Type m
vt]
    TypeNominal Name
name -> forall {f :: * -> *}. Applicative f => Name -> f Type
nominal Name
name
    TypeOptional Type m
ot -> [Type] -> Type
toTypeApplication forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
CM.sequence [
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> Type
H.TypeVariable forall a b. (a -> b) -> a -> b
$ String -> Name
rawName String
"Maybe",
      Type m -> GraphFlow m Type
encode Type m
ot]
    TypeProduct [Type m]
types -> [Type] -> Type
H.TypeTuple forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM Type m -> GraphFlow m Type
encode [Type m]
types)
    TypeRecord RowType m
rt -> case forall m. RowType m -> [FieldType m]
rowTypeFields RowType m
rt of
      [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Type] -> Type
H.TypeTuple []  -- TODO: too permissive; not all empty record types are the unit type
      [FieldType m]
_ -> forall {f :: * -> *}. Applicative f => Name -> f Type
nominal forall a b. (a -> b) -> a -> b
$ forall m. RowType m -> Name
rowTypeTypeName RowType m
rt
    TypeSet Type m
st -> [Type] -> Type
toTypeApplication forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
CM.sequence [
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> Type
H.TypeVariable forall a b. (a -> b) -> a -> b
$ String -> Name
rawName String
"Set",
      Type m -> GraphFlow m Type
encode Type m
st]
    TypeUnion RowType m
rt -> forall {f :: * -> *}. Applicative f => Name -> f Type
nominal forall a b. (a -> b) -> a -> b
$ forall m. RowType m -> Name
rowTypeTypeName RowType m
rt
    TypeVariable (VariableType String
v) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> Type
H.TypeVariable forall a b. (a -> b) -> a -> b
$ String -> Name
simpleName String
v
    Type m
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"unexpected type: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Type m
typ
  where
    encode :: Type m -> GraphFlow m Type
encode = forall m. Show m => Namespaces -> Type m -> GraphFlow m Type
encodeType Namespaces
namespaces
    nominal :: Name -> f Type
nominal Name
name = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> Type
H.TypeVariable forall a b. (a -> b) -> a -> b
$ Namespaces -> Name -> Name
elementReference Namespaces
namespaces Name
name

moduleToHaskellModule :: (Ord m, Read m, Show m) => Module m -> GraphFlow m H.Module
moduleToHaskellModule :: forall m. (Ord m, Read m, Show m) => Module m -> GraphFlow m Module
moduleToHaskellModule Module m
mod = forall m e d.
(Ord m, Read m, Show m) =>
Language m
-> (Term m -> GraphFlow m e)
-> (Module m
    -> Map (Type m) (Coder (Context m) (Context m) (Term m) e)
    -> [(Element m, TypedTerm m)]
    -> GraphFlow m d)
-> Module m
-> GraphFlow m d
transformModule forall m. Language m
haskellLanguage (forall m.
(Eq m, Ord m, Read m, Show m) =>
Namespaces -> Term m -> GraphFlow m Expression
encodeTerm Namespaces
namespaces) forall m.
(Ord m, Read m, Show m) =>
Module m
-> Map (Type m) (Coder (Context m) (Context m) (Term m) Expression)
-> [(Element m, TypedTerm m)]
-> GraphFlow m Module
constructModule Module m
mod
  where
    namespaces :: Namespaces
namespaces = forall m. Module m -> Namespaces
namespacesForModule Module m
mod

printModule :: (Ord m, Read m, Show m) => Module m -> GraphFlow m (M.Map FilePath String)
printModule :: forall m.
(Ord m, Read m, Show m) =>
Module m -> GraphFlow m (Map String String)
printModule Module m
mod = do
  Module
hsmod <- forall m. (Ord m, Read m, Show m) => Module m -> GraphFlow m Module
moduleToHaskellModule Module m
mod
  let s :: String
s = Expr -> String
printExpr forall a b. (a -> b) -> a -> b
$ Expr -> Expr
parenthesize forall a b. (a -> b) -> a -> b
$ forall a. ToTree a => a -> Expr
toTree Module
hsmod
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Bool -> FileExtension -> Namespace -> String
namespaceToFilePath Bool
True (String -> FileExtension
FileExtension String
"hs") forall a b. (a -> b) -> a -> b
$ forall m. Module m -> Namespace
moduleNamespace Module m
mod, String
s)]

toDataDeclarations :: (Ord m, Show m)
  => M.Map (Type m) (Coder (Context m) (Context m) (Term m) H.Expression) -> Namespaces
  -> (Element m, TypedTerm m) -> GraphFlow m [H.DeclarationWithComments]
toDataDeclarations :: forall m.
(Ord m, Show m) =>
Map (Type m) (Coder (Context m) (Context m) (Term m) Expression)
-> Namespaces
-> (Element m, TypedTerm m)
-> GraphFlow m [DeclarationWithComments]
toDataDeclarations Map (Type m) (Coder (Context m) (Context m) (Term m) Expression)
coders Namespaces
namespaces (Element m
el, TypedTerm Type m
typ Term m
term) = do
    let coder :: Coder (Context m) (Context m) (Term m) Expression
coder = forall a. HasCallStack => Maybe a -> a
Y.fromJust forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Type m
typ Map (Type m) (Coder (Context m) (Context m) (Term m) Expression)
coders
    RightHandSide
rhs <- Expression -> RightHandSide
H.RightHandSide forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode Coder (Context m) (Context m) (Term m) Expression
coder Term m
term
    let hname :: Name
hname = String -> Name
simpleName forall a b. (a -> b) -> a -> b
$ Name -> String
localNameOfEager forall a b. (a -> b) -> a -> b
$ forall m. Element m -> Name
elementName Element m
el
    let pat :: Pattern
pat = Pattern_Application -> Pattern
H.PatternApplication forall a b. (a -> b) -> a -> b
$ Name -> [Pattern] -> Pattern_Application
H.Pattern_Application Name
hname []
    Type
htype <- forall m. Show m => Namespaces -> Type m -> GraphFlow m Type
encodeType Namespaces
namespaces Type m
typ
    let decl :: Declaration
decl = TypedBinding -> Declaration
H.DeclarationTypedBinding forall a b. (a -> b) -> a -> b
$ TypeSignature -> ValueBinding -> TypedBinding
H.TypedBinding
                (Name -> Type -> TypeSignature
H.TypeSignature Name
hname Type
htype)
                (ValueBinding_Simple -> ValueBinding
H.ValueBindingSimple forall a b. (a -> b) -> a -> b
$ ValueBinding_Simple -> ValueBinding_Simple
rewriteValueBinding forall a b. (a -> b) -> a -> b
$ Pattern
-> RightHandSide -> Maybe LocalBindings -> ValueBinding_Simple
H.ValueBinding_Simple Pattern
pat RightHandSide
rhs forall a. Maybe a
Nothing)
    Context m
cx <- forall s. Flow s s
getState
    Maybe String
comments <- forall m.
AnnotationClass m -> Term m -> Flow (Context m) (Maybe String)
annotationClassTermDescription (forall m. Context m -> AnnotationClass m
contextAnnotations Context m
cx) Term m
term
    forall (m :: * -> *) a. Monad m => a -> m a
return [Declaration -> Maybe String -> DeclarationWithComments
H.DeclarationWithComments Declaration
decl Maybe String
comments]
  where
    rewriteValueBinding :: ValueBinding_Simple -> ValueBinding_Simple
rewriteValueBinding ValueBinding_Simple
vb = case ValueBinding_Simple
vb of
      H.ValueBinding_Simple (H.PatternApplication (H.Pattern_Application Name
name [Pattern]
args)) RightHandSide
rhs Maybe LocalBindings
bindings -> case RightHandSide
rhs of
        H.RightHandSide (H.ExpressionLambda (H.Expression_Lambda [Pattern]
vars Expression
body)) -> ValueBinding_Simple -> ValueBinding_Simple
rewriteValueBinding forall a b. (a -> b) -> a -> b
$
          Pattern
-> RightHandSide -> Maybe LocalBindings -> ValueBinding_Simple
H.ValueBinding_Simple
            (Pattern_Application -> Pattern
H.PatternApplication (Name -> [Pattern] -> Pattern_Application
H.Pattern_Application Name
name ([Pattern]
args forall a. [a] -> [a] -> [a]
++ [Pattern]
vars))) (Expression -> RightHandSide
H.RightHandSide Expression
body) Maybe LocalBindings
bindings
        RightHandSide
_ -> ValueBinding_Simple
vb

toTypeDeclarations :: (Ord m, Read m, Show m)
  => Namespaces -> Element m -> Term m -> GraphFlow m [H.DeclarationWithComments]
toTypeDeclarations :: forall m.
(Ord m, Read m, Show m) =>
Namespaces
-> Element m -> Term m -> GraphFlow m [DeclarationWithComments]
toTypeDeclarations Namespaces
namespaces Element m
el Term m
term = do
    Context m
cx <- forall s. Flow s s
getState
    let lname :: String
lname = Name -> String
localNameOfEager forall a b. (a -> b) -> a -> b
$ forall m. Element m -> Name
elementName Element m
el
    let hname :: Name
hname = String -> Name
simpleName String
lname
    Type m
t <- forall m. Show m => Term m -> GraphFlow m (Type m)
decodeType Term m
term
    Bool
isSer <- Flow (Context m) Bool
isSerializable
    let deriv :: Deriving
deriv = [Name] -> Deriving
H.Deriving forall a b. (a -> b) -> a -> b
$ if Bool
isSer
                  then String -> Name
rawName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String
"Eq", String
"Ord", String
"Read", String
"Show"]
                  else []
    let ([VariableType]
vars, Type m
t') = forall m. Context m -> Type m -> ([VariableType], Type m)
unpackLambdaType Context m
cx Type m
t
    let hd :: DeclarationHead
hd = Name -> [VariableType] -> DeclarationHead
declHead Name
hname forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
L.reverse [VariableType]
vars
    Declaration
decl <- case forall m. Type m -> Type m
stripType Type m
t' of
      TypeRecord RowType m
rt -> do
        ConstructorWithComments
cons <- forall {m}.
(Ord m, Read m, Show m) =>
String -> [FieldType m] -> Flow (Context m) ConstructorWithComments
recordCons String
lname forall a b. (a -> b) -> a -> b
$ forall m. RowType m -> [FieldType m]
rowTypeFields RowType m
rt
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DataDeclaration -> Declaration
H.DeclarationData forall a b. (a -> b) -> a -> b
$ DataDeclaration_Keyword
-> [Assertion]
-> DeclarationHead
-> [ConstructorWithComments]
-> [Deriving]
-> DataDeclaration
H.DataDeclaration DataDeclaration_Keyword
H.DataDeclaration_KeywordData [] DeclarationHead
hd [ConstructorWithComments
cons] [Deriving
deriv]
      TypeUnion RowType m
rt -> do
        [ConstructorWithComments]
cons <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM (forall {m}.
(Ord m, Read m, Show m) =>
String -> FieldType m -> Flow (Context m) ConstructorWithComments
unionCons String
lname) forall a b. (a -> b) -> a -> b
$ forall m. RowType m -> [FieldType m]
rowTypeFields RowType m
rt
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DataDeclaration -> Declaration
H.DeclarationData forall a b. (a -> b) -> a -> b
$ DataDeclaration_Keyword
-> [Assertion]
-> DeclarationHead
-> [ConstructorWithComments]
-> [Deriving]
-> DataDeclaration
H.DataDeclaration DataDeclaration_Keyword
H.DataDeclaration_KeywordData [] DeclarationHead
hd [ConstructorWithComments]
cons [Deriving
deriv]
      Type m
_ -> if Bool
newtypesNotTypedefs
        then do
          ConstructorWithComments
cons <- forall {m} {m}.
(Ord m, Read m, Show m) =>
Element m -> Type m -> Flow (Context m) ConstructorWithComments
newtypeCons Element m
el Type m
t'
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DataDeclaration -> Declaration
H.DeclarationData forall a b. (a -> b) -> a -> b
$ DataDeclaration_Keyword
-> [Assertion]
-> DeclarationHead
-> [ConstructorWithComments]
-> [Deriving]
-> DataDeclaration
H.DataDeclaration DataDeclaration_Keyword
H.DataDeclaration_KeywordNewtype [] DeclarationHead
hd [ConstructorWithComments
cons] [Deriving
deriv]
        else do
          Type
htype <- forall m.
(Ord m, Read m, Show m) =>
Namespaces -> Type m -> GraphFlow m Type
encodeAdaptedType Namespaces
namespaces Type m
t
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TypeDeclaration -> Declaration
H.DeclarationType (DeclarationHead -> Type -> TypeDeclaration
H.TypeDeclaration DeclarationHead
hd Type
htype)
    Maybe String
comments <- forall m.
AnnotationClass m -> Term m -> Flow (Context m) (Maybe String)
annotationClassTermDescription (forall m. Context m -> AnnotationClass m
contextAnnotations Context m
cx) Term m
term
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Declaration -> Maybe String -> DeclarationWithComments
H.DeclarationWithComments Declaration
decl Maybe String
comments] forall a. [a] -> [a] -> [a]
++ forall m.
Context m
-> Namespaces -> Name -> Type m -> [DeclarationWithComments]
constantDecls Context m
cx Namespaces
namespaces (forall m. Element m -> Name
elementName Element m
el) Type m
t
  where
    isSerializable :: Flow (Context m) Bool
isSerializable = do
        Map Name (Type m)
deps <- forall m. Show m => Name -> GraphFlow m (Map Name (Type m))
typeDependencies (forall m. Element m -> Name
elementName Element m
el)
        let allVariants :: Set TypeVariant
allVariants = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
L.concat (forall {m}. Type m -> [TypeVariant]
variants forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [a]
M.elems Map Name (Type m)
deps)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Bool
S.member TypeVariant
TypeVariantFunction Set TypeVariant
allVariants
      where
        variants :: Type m -> [TypeVariant]
variants Type m
typ = forall m. Type m -> TypeVariant
typeVariant forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a m.
TraversalOrder -> (a -> Type m -> a) -> a -> Type m -> a
foldOverType TraversalOrder
TraversalOrderPre (\[Type m]
m Type m
t -> Type m
tforall a. a -> [a] -> [a]
:[Type m]
m) [] Type m
typ

    declHead :: Name -> [VariableType] -> DeclarationHead
declHead Name
name [VariableType]
vars = case [VariableType]
vars of
      [] -> Name -> DeclarationHead
H.DeclarationHeadSimple Name
name
      ((VariableType String
h):[VariableType]
rest) -> DeclarationHead_Application -> DeclarationHead
H.DeclarationHeadApplication forall a b. (a -> b) -> a -> b
$
        DeclarationHead -> Variable -> DeclarationHead_Application
H.DeclarationHead_Application (Name -> [VariableType] -> DeclarationHead
declHead Name
name [VariableType]
rest) (Name -> Variable
H.Variable forall a b. (a -> b) -> a -> b
$ String -> Name
simpleName String
h)

    newtypeCons :: Element m -> Type m -> Flow (Context m) ConstructorWithComments
newtypeCons Element m
el Type m
typ = do
        Context m
cx <- forall s. Flow s s
getState
        let hname :: Name
hname = String -> Name
simpleName forall a b. (a -> b) -> a -> b
$ Name -> String
newtypeAccessorName forall a b. (a -> b) -> a -> b
$ forall m. Element m -> Name
elementName Element m
el
        Type
htype <- forall m.
(Ord m, Read m, Show m) =>
Namespaces -> Type m -> GraphFlow m Type
encodeAdaptedType Namespaces
namespaces Type m
typ
        Maybe String
comments <- forall m.
AnnotationClass m -> Type m -> Flow (Context m) (Maybe String)
annotationClassTypeDescription (forall m. Context m -> AnnotationClass m
contextAnnotations Context m
cx) Type m
typ
        let hfield :: FieldWithComments
hfield = Field -> Maybe String -> FieldWithComments
H.FieldWithComments (Name -> Type -> Field
H.Field Name
hname Type
htype) Maybe String
comments
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Constructor -> Maybe String -> ConstructorWithComments
H.ConstructorWithComments
          (Constructor_Record -> Constructor
H.ConstructorRecord forall a b. (a -> b) -> a -> b
$ Name -> [FieldWithComments] -> Constructor_Record
H.Constructor_Record (String -> Name
simpleName forall a b. (a -> b) -> a -> b
$ Name -> String
localNameOfEager forall a b. (a -> b) -> a -> b
$ forall m. Element m -> Name
elementName Element m
el) [FieldWithComments
hfield]) forall a. Maybe a
Nothing

    recordCons :: String -> [FieldType m] -> Flow (Context m) ConstructorWithComments
recordCons String
lname [FieldType m]
fields = do
        [FieldWithComments]
hFields <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM forall {m}.
(Ord m, Read m, Show m) =>
FieldType m -> Flow (Context m) FieldWithComments
toField [FieldType m]
fields
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Constructor -> Maybe String -> ConstructorWithComments
H.ConstructorWithComments (Constructor_Record -> Constructor
H.ConstructorRecord forall a b. (a -> b) -> a -> b
$ Name -> [FieldWithComments] -> Constructor_Record
H.Constructor_Record (String -> Name
simpleName String
lname) [FieldWithComments]
hFields) forall a. Maybe a
Nothing
      where
        toField :: FieldType m -> Flow (Context m) FieldWithComments
toField (FieldType (FieldName String
fname) Type m
ftype) = do
          let hname :: Name
hname = String -> Name
simpleName forall a b. (a -> b) -> a -> b
$ String -> String
decapitalize String
lname forall a. [a] -> [a] -> [a]
++ String -> String
capitalize String
fname
          Type
htype <- forall m.
(Ord m, Read m, Show m) =>
Namespaces -> Type m -> GraphFlow m Type
encodeAdaptedType Namespaces
namespaces Type m
ftype
          Context m
cx <- forall s. Flow s s
getState
          Maybe String
comments <- forall m.
AnnotationClass m -> Type m -> Flow (Context m) (Maybe String)
annotationClassTypeDescription (forall m. Context m -> AnnotationClass m
contextAnnotations Context m
cx) Type m
ftype
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Field -> Maybe String -> FieldWithComments
H.FieldWithComments (Name -> Type -> Field
H.Field Name
hname Type
htype) Maybe String
comments

    unionCons :: String -> FieldType m -> Flow (Context m) ConstructorWithComments
unionCons String
lname (FieldType (FieldName String
fname) Type m
ftype) = do
      Context m
cx <- forall s. Flow s s
getState
      Maybe String
comments <- forall m.
AnnotationClass m -> Type m -> Flow (Context m) (Maybe String)
annotationClassTypeDescription (forall m. Context m -> AnnotationClass m
contextAnnotations Context m
cx) Type m
ftype
      let nm :: String
nm = String -> String
capitalize String
lname forall a. [a] -> [a] -> [a]
++ String -> String
capitalize String
fname
      [Type]
typeList <- if forall m. Type m -> Type m
stripType Type m
ftype forall a. Eq a => a -> a -> Bool
== forall m. Type m
Types.unit
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        else do
          Type
htype <- forall m.
(Ord m, Read m, Show m) =>
Namespaces -> Type m -> GraphFlow m Type
encodeAdaptedType Namespaces
namespaces Type m
ftype
          forall (m :: * -> *) a. Monad m => a -> m a
return [Type
htype]
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Constructor -> Maybe String -> ConstructorWithComments
H.ConstructorWithComments (Constructor_Ordinary -> Constructor
H.ConstructorOrdinary forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Constructor_Ordinary
H.Constructor_Ordinary (String -> Name
simpleName String
nm) [Type]
typeList) Maybe String
comments