hydra-0.1.1: src/main/haskell/Hydra/Ext/Java/Coder.hs
module Hydra.Ext.Java.Coder (printModule) where
import Hydra.Kernel
import Hydra.CoreDecoding
import Hydra.Reduction
import Hydra.Ext.Java.Utils
import Hydra.Ext.Java.Language
import qualified Hydra.Impl.Haskell.Dsl.Terms as Terms
import qualified Hydra.Impl.Haskell.Dsl.Types as Types
import qualified Hydra.Ext.Java.Syntax as Java
import Hydra.Adapters.Coders
import Hydra.Util.Codetree.Script
import Hydra.Ext.Java.Serde
import Hydra.Ext.Java.Settings
import Hydra.Adapters.UtilsEtc
import Hydra.Types.Inference
import Hydra.Meta
import qualified Control.Monad as CM
import qualified Data.List as L
import qualified Data.List.Split as LS
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Maybe as Y
type Aliases = M.Map Namespace Java.PackageName
printModule :: (Ord m, Read m, Show m) => Module m -> GraphFlow m (M.Map FilePath String)
printModule mod = do
withTrace "encode in Java" $ do
units <- moduleToJavaCompilationUnit mod
return $ M.fromList $ forPair <$> M.toList units
where
forPair (name, unit) = (
elementNameToFilePath name,
printExpr $ parenthesize $ writeCompilationUnit unit)
boundTypeVariables :: Type m -> [VariableType]
boundTypeVariables typ = case typ of
TypeAnnotated (Annotated typ1 _) -> boundTypeVariables typ1
TypeLambda (LambdaType v body) -> v:(boundTypeVariables body)
_ -> []
commentsFromElement :: Element m -> GraphFlow m (Maybe String)
commentsFromElement el = do
cx <- getState
annotationClassTermDescription (contextAnnotations cx) (elementData el)
commentsFromFieldType :: FieldType m -> GraphFlow m (Maybe String)
commentsFromFieldType (FieldType _ t) = do
cx <- getState
annotationClassTypeDescription (contextAnnotations cx) t
addComment :: Java.ClassBodyDeclaration -> FieldType m -> GraphFlow m Java.ClassBodyDeclarationWithComments
addComment decl field = Java.ClassBodyDeclarationWithComments decl <$> commentsFromFieldType field
noComment :: Java.ClassBodyDeclaration -> Java.ClassBodyDeclarationWithComments
noComment decl = Java.ClassBodyDeclarationWithComments decl Nothing
elementNameToFilePath :: Name -> FilePath
elementNameToFilePath name = nameToFilePath False (FileExtension "java") $ fromQname ns (sanitizeJavaName local)
where
(ns, local) = toQnameEager name
moduleToJavaCompilationUnit :: (Ord m, Read m, Show m) => Module m -> GraphFlow m (M.Map Name Java.CompilationUnit)
moduleToJavaCompilationUnit mod = transformModule javaLanguage encode constructModule mod
where
aliases = importAliasesForModule mod
encode = encodeTerm aliases Nothing . contractTerm
classModsPublic :: [Java.ClassModifier]
classModsPublic = [Java.ClassModifierPublic]
constructModule :: (Ord m, Read m, Show m)
=> Module m -> M.Map (Type m) (Coder (Context m) (Context m) (Term m) Java.Expression) -> [(Element m, TypedTerm m)]
-> GraphFlow m (M.Map Name Java.CompilationUnit)
constructModule mod coders pairs = do
cx <- getState
let isTypePair = isType cx . typedTermType . snd
let typePairs = L.filter isTypePair pairs
let dataPairs = L.filter (not . isTypePair) pairs
typeUnits <- CM.mapM typeToClass typePairs
dataMembers <- CM.mapM (termToInterfaceMember coders) dataPairs
return $ M.fromList $ typeUnits ++ ([constructElementsInterface mod dataMembers | not (L.null dataMembers)])
where
pkg = javaPackageDeclaration $ moduleNamespace mod
aliases = importAliasesForModule mod
typeToClass pair@(el, _) = do
let imports = []
decl <- declarationForType aliases pair
return (elementName el,
Java.CompilationUnitOrdinary $ Java.OrdinaryCompilationUnit (Just pkg) imports [decl])
termToInterfaceMember coders pair = do
withTrace ("element " ++ unName (elementName el)) $ do
expanded <- contractTerm <$> (expandLambdas $ typedTermTerm $ snd pair) >>= annotateTermWithTypes
if isLambda expanded
then termToMethod coders el (typedTermType $ snd pair) expanded
else termToConstant coders el (typedTermType $ snd pair) expanded
where
el = fst pair
isLambda t = case stripTerm t of
TermFunction (FunctionLambda _) -> True
_ -> False
termToConstant coders el typ term = do
jtype <- Java.UnannType <$> encodeType aliases typ
jterm <- coderEncode (Y.fromJust $ M.lookup typ coders) term
let mods = []
let var = javaVariableDeclarator (javaVariableName $ elementName el) $ Just $ Java.VariableInitializerExpression jterm
return $ Java.InterfaceMemberDeclarationConstant $ Java.ConstantDeclaration mods jtype [var]
-- Lambdas cannot (in general) be turned into top-level constants, as there is no way of declaring type parameters for constants
termToMethod coders el typ term = case stripType typ of
TypeFunction (FunctionType dom cod) -> case stripTerm term of
TermFunction (FunctionLambda (Lambda v body)) -> do
jdom <- encodeType aliases dom
jcod <- encodeType aliases cod
let mods = [Java.InterfaceMethodModifierStatic]
let anns = []
let mname = sanitizeJavaName $ decapitalize $ localNameOfEager $ elementName el
let param = javaTypeToJavaFormalParameter jdom (FieldName $ unVariable v)
let result = javaTypeToJavaResult jcod
jbody <- encodeTerm aliases (Just cod) body
let returnSt = Java.BlockStatementStatement $ javaReturnStatement $ Just jbody
let tparams = javaTypeParametersForType typ
return $ interfaceMethodDeclaration mods tparams mname [param] result (Just [returnSt])
_ -> unexpected "function term" term
_ -> unexpected "function type" typ
constructElementsInterface :: Module m -> [Java.InterfaceMemberDeclaration] -> (Name, Java.CompilationUnit)
constructElementsInterface mod members = (elName, cu)
where
cu = Java.CompilationUnitOrdinary $ Java.OrdinaryCompilationUnit (Just pkg) [] [decl]
pkg = javaPackageDeclaration $ moduleNamespace mod
mods = [Java.InterfaceModifierPublic]
className = elementsClassName $ moduleNamespace mod
elName = fromQname (moduleNamespace mod) className
body = Java.InterfaceBody members
itf = Java.TypeDeclarationInterface $ Java.InterfaceDeclarationNormalInterface $
Java.NormalInterfaceDeclaration mods (javaTypeIdentifier className) [] [] body
decl = Java.TypeDeclarationWithComments itf $ moduleDescription mod
declarationForLambdaType :: (Eq m, Ord m, Read m, Show m) => Aliases
-> [Java.TypeParameter] -> Name -> LambdaType m -> GraphFlow m Java.ClassDeclaration
declarationForLambdaType aliases tparams elName (LambdaType (VariableType v) body) =
toClassDecl False aliases (tparams ++ [param]) elName body
where
param = javaTypeParameter $ capitalize v
declarationForRecordType :: (Ord m, Read m, Show m) => Bool -> Aliases -> [Java.TypeParameter] -> Name
-> [FieldType m] -> GraphFlow m Java.ClassDeclaration
declarationForRecordType isInner aliases tparams elName fields = do
memberVars <- CM.mapM toMemberVar fields
cx <- getState
memberVars' <- CM.zipWithM addComment memberVars fields
withMethods <- if L.length fields > 1
then CM.mapM toWithMethod fields
else pure []
cons <- constructor
tn <- if isInner then pure [] else do
d <- typeNameDecl aliases elName
return [d]
let bodyDecls = tn ++ memberVars' ++ (noComment <$> [cons, equalsMethod, hashCodeMethod] ++ withMethods)
return $ javaClassDeclaration aliases tparams elName classModsPublic Nothing bodyDecls
where
constructor = do
params <- CM.mapM (fieldTypeToFormalParam aliases) fields
let stmts = Java.BlockStatementStatement . toAssignStmt . fieldTypeName <$> fields
return $ makeConstructor aliases elName False params stmts
fieldArgs = fieldNameToJavaExpression . fieldTypeName <$> fields
toMemberVar (FieldType fname ft) = do
let mods = [Java.FieldModifierPublic, Java.FieldModifierFinal]
jt <- encodeType aliases ft
let var = fieldNameToJavaVariableDeclarator fname
return $ javaMemberField mods jt var
toWithMethod field = do
let mods = [Java.MethodModifierPublic]
let methodName = "with" ++ capitalize (unFieldName $ fieldTypeName field)
param <- fieldTypeToFormalParam aliases field
let anns = [] -- TODO
let result = referenceTypeToResult $ nameToJavaReferenceType aliases False elName Nothing
let consId = Java.Identifier $ sanitizeJavaName $ localNameOfEager elName
let returnStmt = Java.BlockStatementStatement $ javaReturnStatement $ Just $
javaConstructorCall (javaConstructorName consId Nothing) fieldArgs Nothing
return $ methodDeclaration mods [] anns methodName [param] result (Just [returnStmt])
equalsMethod = methodDeclaration mods [] anns "equals" [param] result $
Just [instanceOfStmt,
castStmt,
returnAllFieldsEqual]
where
anns = [overrideAnnotation]
mods = [Java.MethodModifierPublic]
param = javaTypeToJavaFormalParameter (javaRefType [] Nothing "Object") (FieldName otherName)
result = javaTypeToJavaResult javaBooleanType
otherName = "other"
tmpName = "o"
instanceOfStmt = Java.BlockStatementStatement $ Java.StatementIfThen $
Java.IfThenStatement cond returnFalse
where
cond = javaUnaryExpressionToJavaExpression $
Java.UnaryExpressionOther $
Java.UnaryExpressionNotPlusMinusNot $
javaRelationalExpressionToJavaUnaryExpression $
javaInstanceOf other parent
where
other = javaIdentifierToJavaRelationalExpression $ javaIdentifier otherName
parent = nameToJavaReferenceType aliases False elName Nothing
returnFalse = javaReturnStatement $ Just $ javaBooleanExpression False
castStmt = variableDeclarationStatement aliases elName id rhs
where
id = javaIdentifier tmpName
rhs = javaCastExpressionToJavaExpression $ javaCastExpression aliases rt var
var = javaIdentifierToJavaUnaryExpression $ Java.Identifier $ sanitizeJavaName otherName
rt = nameToJavaReferenceType aliases False elName Nothing
returnAllFieldsEqual = Java.BlockStatementStatement $ javaReturnStatement $ Just $ if L.null fields
then javaBooleanExpression True
else javaConditionalAndExpressionToJavaExpression $
Java.ConditionalAndExpression (eqClause . fieldTypeName <$> fields)
where
eqClause (FieldName fname) = javaPostfixExpressionToJavaInclusiveOrExpression $
javaMethodInvocationToJavaPostfixExpression $ Java.MethodInvocation header [arg]
where
arg = javaExpressionNameToJavaExpression $
fieldExpression (javaIdentifier tmpName) (javaIdentifier fname)
header = Java.MethodInvocation_HeaderComplex $ Java.MethodInvocation_Complex var [] (Java.Identifier "equals")
var = Java.MethodInvocation_VariantExpression $ Java.ExpressionName Nothing $ Java.Identifier $
sanitizeJavaName fname
hashCodeMethod = methodDeclaration mods [] anns "hashCode" [] result $ Just [returnSum]
where
anns = [overrideAnnotation]
mods = [Java.MethodModifierPublic]
result = javaTypeToJavaResult javaIntType
returnSum = Java.BlockStatementStatement $ if L.null fields
then returnZero
else javaReturnStatement $ Just $
javaAdditiveExpressionToJavaExpression $ addExpressions $
L.zipWith multPair multipliers (fieldTypeName <$> fields)
where
returnZero = javaReturnStatement $ Just $ javaIntExpression 0
multPair :: Int -> FieldName -> Java.MultiplicativeExpression
multPair i (FieldName fname) = Java.MultiplicativeExpressionTimes $
Java.MultiplicativeExpression_Binary lhs rhs
where
lhs = Java.MultiplicativeExpressionUnary $ javaPrimaryToJavaUnaryExpression $
javaLiteralToPrimary $ javaInt i
rhs = javaPostfixExpressionToJavaUnaryExpression $
javaMethodInvocationToJavaPostfixExpression $
methodInvocationStatic (javaIdentifier fname) (Java.Identifier "hashCode") []
multipliers = L.cycle first20Primes
where
first20Primes = [2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 53, 59, 61, 67, 71]
declarationForType :: (Ord m, Read m, Show m)
=> Aliases -> (Element m, TypedTerm m) -> GraphFlow m Java.TypeDeclarationWithComments
declarationForType aliases (el, TypedTerm _ term) = do
t <- decodeType term >>= adaptType javaLanguage
cd <- toClassDecl False aliases [] (elementName el) t
cx <- getState
comments <- commentsFromElement el
return $ Java.TypeDeclarationWithComments (Java.TypeDeclarationClass cd) comments
declarationForUnionType :: (Eq m, Ord m, Read m, Show m)
=> Aliases
-> [Java.TypeParameter] -> Name -> [FieldType m] -> GraphFlow m Java.ClassDeclaration
declarationForUnionType aliases tparams elName fields = do
variantClasses <- CM.mapM (fmap augmentVariantClass . unionFieldClass) fields
let variantDecls = Java.ClassBodyDeclarationClassMember . Java.ClassMemberDeclarationClass <$> variantClasses
cx <- getState
variantDecls' <- CM.zipWithM addComment variantDecls fields
let otherDecls = noComment <$> [privateConstructor, toAcceptMethod True, visitor, partialVisitor]
tn <- typeNameDecl aliases elName
let bodyDecls = [tn] ++ otherDecls ++ variantDecls'
let mods = classModsPublic ++ [Java.ClassModifierAbstract]
return $ javaClassDeclaration aliases tparams elName mods Nothing bodyDecls
where
privateConstructor = makeConstructor aliases elName True [] []
unionFieldClass (FieldType fname ftype) = do
let rtype = Types.record $ if Types.isUnit ftype then [] else [FieldType (FieldName valueFieldName) ftype]
toClassDecl True aliases [] (variantClassName False elName fname) rtype
augmentVariantClass (Java.ClassDeclarationNormal cd) = Java.ClassDeclarationNormal $ cd {
Java.normalClassDeclarationModifiers = [Java.ClassModifierPublic, Java.ClassModifierStatic, Java.ClassModifierFinal],
Java.normalClassDeclarationExtends = Just $ nameToJavaClassType aliases True args elName Nothing,
Java.normalClassDeclarationParameters = tparams,
Java.normalClassDeclarationBody = newBody (Java.normalClassDeclarationBody cd)}
where
newBody (Java.ClassBody decls) = Java.ClassBody $ decls ++ [noComment $ toAcceptMethod False]
args = typeParameterToTypeArgument <$> tparams
visitor = javaInterfaceDeclarationToJavaClassBodyDeclaration $
Java.NormalInterfaceDeclaration mods ti tparams extends body
where
mods = [Java.InterfaceModifierPublic]
ti = Java.TypeIdentifier $ Java.Identifier visitorName
tparams = [javaTypeParameter "R"]
extends = []
body = Java.InterfaceBody (toVisitMethod . fieldTypeName <$> fields)
where
toVisitMethod fname = interfaceMethodDeclaration [] [] visitMethodName [variantInstanceParam fname] resultR Nothing
partialVisitor = javaInterfaceDeclarationToJavaClassBodyDeclaration $
Java.NormalInterfaceDeclaration {
Java.normalInterfaceDeclarationModifiers = [Java.InterfaceModifierPublic],
Java.normalInterfaceDeclarationIdentifier = Java.TypeIdentifier $ Java.Identifier partialVisitorName,
Java.normalInterfaceDeclarationParameters = [javaTypeParameter "R"],
Java.normalInterfaceDeclarationExtends =
[Java.InterfaceType $ javaClassType [visitorTypeVariable] Nothing visitorName],
Java.normalInterfaceDeclarationBody = Java.InterfaceBody $ otherwise:(toVisitMethod . fieldTypeName <$> fields)}
where
otherwise = interfaceMethodDeclaration defaultMod [] "otherwise" [mainInstanceParam] resultR $ Just [throw]
where
throw = Java.BlockStatementStatement $ Java.StatementWithoutTrailing $
Java.StatementWithoutTrailingSubstatementThrow $ Java.ThrowStatement $
javaConstructorCall (javaConstructorName (Java.Identifier "IllegalStateException") Nothing) args Nothing
where
args = [javaAdditiveExpressionToJavaExpression $ addExpressions [
javaStringMultiplicativeExpression "Non-exhaustive patterns when matching: ",
Java.MultiplicativeExpressionUnary $ javaIdentifierToJavaUnaryExpression $ Java.Identifier "instance"]]
toVisitMethod fname = interfaceMethodDeclaration defaultMod [] visitMethodName [variantInstanceParam fname] resultR $
Just [returnOtherwise]
where
returnOtherwise = Java.BlockStatementStatement $ javaReturnStatement $ Just $
javaPrimaryToJavaExpression $ Java.PrimaryNoNewArray $ Java.PrimaryNoNewArrayMethodInvocation $
methodInvocation Nothing (Java.Identifier "otherwise") [javaIdentifierToJavaExpression $ Java.Identifier "instance"]
defaultMod = [Java.InterfaceMethodModifierDefault]
resultR = javaTypeToJavaResult $ Java.TypeReference visitorTypeVariable
mainInstanceParam = javaTypeToJavaFormalParameter classRef $ FieldName instanceName
where
classRef = javaClassTypeToJavaType $
nameToJavaClassType aliases False [] elName Nothing
variantInstanceParam fname = javaTypeToJavaFormalParameter classRef $ FieldName instanceName
where
classRef = javaClassTypeToJavaType $
nameToJavaClassType aliases False [] (variantClassName False elName fname) Nothing
elementJavaIdentifier :: Aliases -> Name -> Java.Identifier
elementJavaIdentifier aliases name = Java.Identifier $ jname ++ "." ++ local
where
(gname, local) = toQnameEager name
Java.Identifier jname = nameToJavaName aliases $ fromQname gname $ elementsClassName gname
elementsClassName :: Namespace -> String
elementsClassName (Namespace ns) = capitalize $ L.last $ LS.splitOn "/" ns
encodeElimination :: (Eq m, Ord m, Read m, Show m)
=> Aliases -> Maybe Java.Expression -> Type m -> Type m -> Elimination m -> GraphFlow m Java.Expression
encodeElimination aliases marg dom cod elm = case elm of
EliminationElement -> case marg of
Nothing -> encodeFunction aliases dom cod $ FunctionLambda $ Lambda var $ TermVariable var
where
var = Variable "v"
Just jarg -> pure jarg
EliminationNominal name -> case marg of
Nothing -> pure $ javaLambda var jbody
where
var = Variable "v"
arg = javaIdentifierToJavaExpression $ variableToJavaIdentifier var
jbody = javaConstructorCall (javaConstructorName (nameToJavaName aliases name) Nothing) [arg] Nothing
Just jarg -> pure $ javaFieldAccessToJavaExpression $ Java.FieldAccess qual (javaIdentifier valueFieldName)
where
qual = Java.FieldAccess_QualifierPrimary $ javaExpressionToJavaPrimary jarg
-- EliminationOptional (OptionalCases nothing just) ->
EliminationRecord (Projection _ fname) -> do
jdomr <- encodeType aliases dom >>= javaTypeToJavaReferenceType
jexp <- case marg of
Nothing -> pure $ javaLambda var jbody
where
var = Variable "v"
jbody = javaExpressionNameToJavaExpression $
fieldExpression (variableToJavaIdentifier var) (javaIdentifier $ unFieldName fname)
Just jarg -> pure $ javaFieldAccessToJavaExpression $ Java.FieldAccess qual (javaIdentifier $ unFieldName fname)
where
qual = Java.FieldAccess_QualifierPrimary $ javaExpressionToJavaPrimary jarg
return $ javaCastExpressionToJavaExpression $ javaCastExpression aliases jdomr $ javaExpressionToJavaUnaryExpression jexp
EliminationUnion (CaseStatement tname fields) -> case marg of
Nothing -> do
cx <- getState
let anns = contextAnnotations cx
let lhs = annotationClassSetTermType anns cx (Just $ Types.function (Types.nominal tname) cod) $ Terms.elimination elm
encodeTerm aliases Nothing $ Terms.lambda "v" $ Terms.apply lhs (Terms.variable "v")
Just jarg -> applyElimination jarg
where
applyElimination jarg = do
let prim = javaExpressionToJavaPrimary jarg
let consId = innerClassRef aliases tname visitorName
jcod <- encodeType aliases cod
let targs = Java.TypeArgumentsOrDiamondArguments [javaTypeToJavaTypeArgument jcod]
body <- Java.ClassBody <$> CM.mapM (bodyDecl jcod) fields
let visitor = javaConstructorCall (javaConstructorName consId $ Just targs) [] (Just body)
return $ javaMethodInvocationToJavaExpression $
methodInvocation (Just $ Right prim) (Java.Identifier "accept") [visitor]
where
bodyDecl jcod field = do
let jdom = Java.TypeReference $ nameToJavaReferenceType aliases True tname (Just $ capitalize $ unFieldName $ fieldName field)
let mods = [Java.MethodModifierPublic]
let anns = [overrideAnnotation]
let param = javaTypeToJavaFormalParameter jdom $ FieldName instanceName
let result = Java.ResultType $ Java.UnannType jcod
-- Note: the escaping is necessary because the instance.value field reference does not correspond to an actual Hydra projection term
let value = Terms.variable ("$" ++ instanceName ++ "." ++ valueFieldName)
jret <- encodeTerm aliases (Just cod) $ contractTerm $ Terms.apply (fieldTerm field) value
let returnStmt = Java.BlockStatementStatement $ javaReturnStatement $ Just jret
return $ noComment $ methodDeclaration mods [] anns visitMethodName [param] result (Just [returnStmt])
_ -> pure $ encodeLiteral $ LiteralString $
"Unimplemented elimination variant: " ++ show (eliminationVariant elm) -- TODO: temporary
encodeFunction :: (Eq m, Ord m, Read m, Show m)
=> Aliases -> Type m -> Type m -> Function m -> GraphFlow m Java.Expression
encodeFunction aliases dom cod fun = case fun of
-- FunctionCompareTo other ->
FunctionElimination elm -> encodeElimination aliases Nothing dom cod elm
FunctionLambda (Lambda var body) -> do
jbody <- encodeTerm aliases Nothing body
return $ javaLambda var jbody
-- FunctionPrimitive name ->
_ -> pure $ encodeLiteral $ LiteralString $
"Unimplemented function variant: " ++ show (functionVariant fun) -- TODO: temporary
encodeLiteral :: Literal -> Java.Expression
encodeLiteral lit = javaLiteralToJavaExpression $ case lit of
LiteralBoolean b -> javaBoolean b
LiteralFloat f -> Java.LiteralFloatingPoint $ Java.FloatingPointLiteral $ case f of
FloatValueFloat32 v -> realToFrac v
FloatValueFloat64 v -> v
LiteralInteger i -> case i of
IntegerValueBigint v -> integer v -- BigInteger
IntegerValueInt16 v -> int v -- short
IntegerValueInt32 v -> int v -- int
IntegerValueInt64 v -> integer v -- long
IntegerValueUint8 v -> int v -- byte
IntegerValueUint16 v -> Java.LiteralCharacter $ fromIntegral v -- char
where
integer = Java.LiteralInteger . Java.IntegerLiteral
int = integer . fromIntegral
LiteralString s -> javaString s
-- Note: we use Java object types everywhere, rather than primitive types, as the latter cannot be used
-- to build function types, parameterized types, etc.
encodeLiteralType :: LiteralType -> GraphFlow m Java.Type
encodeLiteralType lt = case lt of
LiteralTypeBoolean -> simple "Boolean"
LiteralTypeFloat ft -> case ft of
FloatTypeFloat32 -> simple "Float"
FloatTypeFloat64 -> simple "Double"
_ -> fail $ "unexpected float type: " ++ show ft
LiteralTypeInteger it -> case it of
IntegerTypeBigint -> pure $ javaRefType [] (Just $ javaPackageName ["java", "math"]) "BigInteger"
IntegerTypeInt16 -> simple "Short"
IntegerTypeInt32 -> simple "Integer"
IntegerTypeInt64 -> simple "Long"
IntegerTypeUint8 -> simple "Byte"
IntegerTypeUint16 -> simple "Character"
_ -> fail $ "unexpected integer type: " ++ show it
LiteralTypeString -> simple "String"
_ -> fail $ "unexpected literal type: " ++ show lt
where
simple n = pure $ javaRefType [] Nothing n
encodeTerm :: (Eq m, Ord m, Read m, Show m)
=> Aliases -> Maybe (Type m) -> Term m -> GraphFlow m Java.Expression
encodeTerm aliases mtype term = case term of
-- Note: we are currently only reading the type from the annotation, leaving any documentation etc. behind
TermAnnotated (Annotated term' ann) -> case mtype of
Just t -> encodeTerm aliases mtype term'
Nothing -> do
cx <- getState
mt <- annotationClassTypeOf (contextAnnotations cx) ann
encodeTerm aliases mt term'
TermApplication a -> case stripTerm fun of
TermFunction f -> case f of
FunctionPrimitive name -> forNamedFunction name args
FunctionElimination EliminationElement -> if L.length args > 0
then case stripTerm (L.head args) of
TermElement name -> do
forNamedFunction name (L.tail args)
_ -> fallback
else fallback
_ -> fallback
_ -> fallback
where
forNamedFunction name args = do
jargs <- CM.mapM encode args
let header = Java.MethodInvocation_HeaderSimple $ Java.MethodName $ elementJavaIdentifier aliases name
return $ javaMethodInvocationToJavaExpression $ Java.MethodInvocation header jargs
(fun, args) = uncurry [] term
where
uncurry args term = case term of
TermAnnotated (Annotated body _) -> uncurry args body
TermApplication (Application lhs rhs) -> uncurry (rhs:args) lhs
_ -> (term, args)
fallback = forApplication a
forApplication (Application lhs rhs) = do
cx <- getState
mt <- annotationClassTermType (contextAnnotations cx) lhs
t <- case mt of
Just t' -> pure t'
Nothing -> fail $ "expected a type annotation on function " ++ show lhs
(dom, cod) <- case stripType t of
TypeFunction (FunctionType dom cod) -> pure (dom, cod)
_ -> fail $ "expected a function type on function " ++ show lhs
case stripTerm lhs of
TermFunction f -> case f of
FunctionElimination e -> case e of
EliminationElement -> encodeTerm aliases Nothing rhs
_ -> do
jarg <- encode rhs
encodeElimination aliases (Just jarg) dom cod e
_ -> defaultExpression dom cod
_ -> defaultExpression dom cod
where
defaultExpression dom cod = do
-- Note: the domain type will not be used, so we just substitute the unit type
jfun <- encodeTerm aliases (Just $ Types.function dom cod) lhs
jarg <- encodeTerm aliases (Just dom) rhs
let prim = javaExpressionToJavaPrimary jfun
return $ javaMethodInvocationToJavaExpression $ methodInvocation (Just $ Right prim) (Java.Identifier "apply") [jarg]
TermElement name -> pure $ javaIdentifierToJavaExpression $ elementJavaIdentifier aliases name
TermFunction f -> case mtype of
Just t -> case stripType t of
TypeFunction (FunctionType dom cod) -> encodeFunction aliases dom cod f
_ -> unexpected "function type" $ t
Nothing -> failAsLiteral $ "unannotated function: " ++ show f
TermList els -> do
jels <- CM.mapM encode els
return $ javaMethodInvocationToJavaExpression $
methodInvocationStatic (Java.Identifier "java.util.Arrays") (Java.Identifier "asList") jels
TermLiteral l -> pure $ encodeLiteral l
-- TermMap (Map (Term m) (Term m))
TermNominal (Named name arg) -> do
jarg <- encode arg
return $ javaConstructorCall (javaConstructorName (nameToJavaName aliases name) Nothing) [jarg] Nothing
TermOptional mt -> case mt of
Nothing -> pure $ javaMethodInvocationToJavaExpression $
methodInvocationStatic (javaIdentifier "java.util.Optional") (Java.Identifier "empty") []
Just term1 -> do
expr <- encode term1
return $ javaMethodInvocationToJavaExpression $
methodInvocationStatic (javaIdentifier "java.util.Optional") (Java.Identifier "of") [expr]
TermRecord (Record name fields) -> do
fieldExprs <- CM.mapM encode (fieldTerm <$> fields)
let consId = nameToJavaName aliases name
return $ javaConstructorCall (javaConstructorName consId Nothing) fieldExprs Nothing
TermSet s -> do
jels <- CM.mapM encode $ S.toList s
let prim = javaMethodInvocationToJavaPrimary $
methodInvocationStatic (Java.Identifier "java.util.Stream") (Java.Identifier "of") jels
let coll = javaMethodInvocationToJavaExpression $
methodInvocationStatic (javaIdentifier "java.util.stream.Collectors") (Java.Identifier "toSet") []
return $ javaMethodInvocationToJavaExpression $
methodInvocation (Just $ Right prim) (Java.Identifier "collect") [coll]
TermUnion (Union name (Field (FieldName fname) v)) -> do
let (Java.Identifier typeId) = nameToJavaName aliases name
let consId = Java.Identifier $ typeId ++ "." ++ sanitizeJavaName (capitalize fname)
args <- if Terms.isUnit v
then return []
else do
ex <- encode v
return [ex]
return $ javaConstructorCall (javaConstructorName consId Nothing) args Nothing
TermVariable (Variable v) -> pure $ javaIdentifierToJavaExpression $ javaIdentifier v
_ -> failAsLiteral $ "Unimplemented term variant: " ++ show (termVariant term)
where
encode = encodeTerm aliases Nothing
failAsLiteral msg = pure $ encodeLiteral $ LiteralString msg
encodeType :: Show m => Aliases -> Type m -> GraphFlow m Java.Type
encodeType aliases t = case stripType t of
TypeApplication (ApplicationType lhs rhs) -> do
jlhs <- encode lhs
jrhs <- encode rhs >>= javaTypeToJavaReferenceType
addJavaTypeParameter jrhs jlhs
TypeElement et -> encode et -- Elements are simply unboxed
TypeFunction (FunctionType dom cod) -> do
jdom <- encode dom >>= javaTypeToJavaReferenceType
jcod <- encode cod >>= javaTypeToJavaReferenceType
return $ javaRefType [jdom, jcod] javaUtilFunctionPackageName "Function"
TypeLambda (LambdaType (VariableType v) body) -> do
jbody <- encode body
addJavaTypeParameter (javaTypeVariable v) jbody
TypeList et -> do
jet <- encode et
if listsAsArrays
then toJavaArrayType jet
else do
rt <- javaTypeToJavaReferenceType jet
return $ javaRefType [rt] javaUtilPackageName "List"
TypeLiteral lt -> encodeLiteralType lt
TypeMap (MapType kt vt) -> do
jkt <- encode kt >>= javaTypeToJavaReferenceType
jvt <- encode vt >>= javaTypeToJavaReferenceType
return $ javaRefType [jkt, jvt] javaUtilPackageName "Map"
TypeNominal name -> pure $ Java.TypeReference $ nameToJavaReferenceType aliases True name Nothing
TypeRecord (RowType _UnitType _ []) -> return $ javaRefType [] javaLangPackageName "Void"
TypeRecord (RowType name _ _) -> pure $ Java.TypeReference $ nameToJavaReferenceType aliases True name Nothing
TypeOptional ot -> do
jot <- encode ot >>= javaTypeToJavaReferenceType
return $ javaRefType [jot] javaUtilPackageName "Optional"
TypeSet st -> do
jst <- encode st >>= javaTypeToJavaReferenceType
return $ javaRefType [jst] javaUtilPackageName "Set"
TypeUnion (RowType name _ _) -> pure $ Java.TypeReference $ nameToJavaReferenceType aliases True name Nothing
TypeVariable (VariableType v) -> pure $ Java.TypeReference $ javaTypeVariable v
_ -> fail $ "can't encode unsupported type in Java: " ++ show t
where
encode = encodeType aliases
fieldTypeToFormalParam aliases (FieldType fname ft) = do
jt <- encodeType aliases ft
return $ javaTypeToJavaFormalParameter jt fname
getCodomain :: Show m => m -> GraphFlow m (Type m)
getCodomain ann = functionTypeCodomain <$> getFunctionType ann
getFunctionType :: Show m => m -> GraphFlow m (FunctionType m)
getFunctionType ann = do
cx <- getState
mt <- annotationClassTypeOf (contextAnnotations cx) ann
case mt of
Nothing -> fail "type annotation is required for function and elimination terms in Java"
Just t -> case t of
TypeFunction ft -> return ft
_ -> unexpected "function type" t
innerClassRef :: Aliases -> Name -> String -> Java.Identifier
innerClassRef aliases name local = Java.Identifier $ id ++ "." ++ local
where
Java.Identifier id = nameToJavaName aliases name
instanceName = "instance"
javaTypeParametersForType :: Type m -> [Java.TypeParameter]
javaTypeParametersForType typ = toParam <$> vars
where
toParam (VariableType v) = Java.TypeParameter [] (javaTypeIdentifier $ capitalize v) Nothing
-- vars = boundTypeVariables typ
vars = S.toList $ freeVariablesInType typ -- TODO: the fact that the variables are free is a bug, not a feature
partialVisitorName :: String
partialVisitorName = "PartialVisitor"
toClassDecl :: (Eq m, Ord m, Read m, Show m) => Bool -> Aliases -> [Java.TypeParameter]
-> Name -> Type m -> GraphFlow m Java.ClassDeclaration
toClassDecl isInner aliases tparams elName t = case stripType t of
TypeRecord rt -> declarationForRecordType isInner aliases tparams elName $ rowTypeFields rt
TypeUnion rt -> declarationForUnionType aliases tparams elName $ rowTypeFields rt
TypeLambda ut -> declarationForLambdaType aliases tparams elName ut
-- Other types are not supported as class declarations, so we wrap them as record types.
_ -> wrap t -- TODO: wrap and unwrap the corresponding terms as record terms.
where
wrap t' = declarationForRecordType isInner aliases tparams elName [Types.field valueFieldName t']
toDataDeclaration :: Aliases -> (a, TypedTerm m) -> GraphFlow m a
toDataDeclaration aliases (el, TypedTerm typ term) = do
fail "not implemented" -- TODO
typeNameDecl :: (Ord m, Read m, Show m) => Aliases -> Name -> GraphFlow m Java.ClassBodyDeclarationWithComments
typeNameDecl aliases name = do
jt <- encodeType aliases $ Types.nominal _Name
arg <- encodeTerm aliases Nothing $ Terms.string $ unName name
let init = Java.VariableInitializerExpression $ javaConstructorCall (javaConstructorName nameName Nothing) [arg] Nothing
let var = javaVariableDeclarator (Java.Identifier "NAME") (Just init)
return $ noComment $ javaMemberField mods jt var
where
mods = [Java.FieldModifierPublic, Java.FieldModifierStatic, Java.FieldModifierFinal]
nameName = nameToJavaName aliases _Name
valueFieldName :: String
valueFieldName = "value"
visitMethodName :: String
visitMethodName = "visit"
visitorName :: String
visitorName = "Visitor"