git.iko.soy/Idris-dev
on b6effdb help sign in
Idris-dev/src/IRTS/CodegenJava.hs
1660 lines 74 kB history raw
1module IRTS.CodegenJava (codegenJava) where
3import Core.TT
4import IRTS.BCImp
5import IRTS.CodegenCommon
6import IRTS.Lang
7import IRTS.Simplified
8import Paths_idris
9import Util.System
11import Control.Applicative
12import Control.Arrow
13import Control.Monad
14import qualified Control.Monad.Trans as T
15import Control.Monad.Trans.State
16import Data.Char
17import Data.Maybe (fromJust)
18import Data.List (isPrefixOf, isSuffixOf, intercalate)
19import qualified Data.Text as T
20import qualified Data.Text.IO as TIO
21import Language.Java.Parser
22import Language.Java.Pretty
23import Language.Java.Syntax hiding (Name)
24import qualified Language.Java.Syntax as J
25import System.Directory
26import System.Exit
27import System.FilePath
28import System.IO
29import System.Process
31data CodeGenerationEnv = CodeGenerationEnv { globalVariablePositions :: [(Name, Integer)] }
33type CodeGeneration = StateT (CodeGenerationEnv) (Either String)
35codegenJava :: [(Name, SExp)] -> -- initialization of globals
36 [(Name, SDecl)] ->
37 FilePath -> -- output file name
38 [String] -> -- headers
39 [String] -> -- libs
40 OutputType ->
41 IO ()
42codegenJava globalInit defs out hdrs libs exec = do
43 withTempdir (takeBaseName out) $ \ tmpDir -> do
44 let srcdir = tmpDir </> "src" </> "main" </> "java"
45 createDirectoryIfMissing True srcdir
46 let (Ident clsName) =
47 either error id (evalStateT (mkClassName out) (mkCodeGenEnv globalInit))
48 let outjava = srcdir </> clsName <.> "java"
49 let jout = either error
50 (flatIndent . prettyPrint)
51 (evalStateT (mkCompilationUnit globalInit defs hdrs out) (mkCodeGenEnv globalInit))
52 writeFile outjava jout
53 if (exec == Raw)
54 then copyFile outjava (takeDirectory out </> clsName <.> "java")
55 else do
56 execPom <- getExecutablePom
57 execPomTemplate <- TIO.readFile execPom
58 let execPom = T.replace (T.pack "$MAIN-CLASS$")
59 (T.pack clsName)
60 (T.replace (T.pack "$ARTIFACT-NAME$")
61 (T.pack $ takeBaseName out)
62 (T.replace (T.pack "$DEPENDENCIES$")
63 (mkPomDependencies libs)
64 execPomTemplate
65 )
66 )
67 TIO.writeFile (tmpDir </> "pom.xml") execPom
68 mvnCmd <- getMvn
69 let args = ["-f", (tmpDir </> "pom.xml")]
70 (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ ["compile"]) ""
71 when (exit /= ExitSuccess) $ error ("FAILURE: " ++ mvnCmd ++ " compile\n" ++ err ++ mvout)
72 if (exec == Object)
73 then do
74 classFiles <-
75 map (\ clsFile -> tmpDir </> "target" </> "classes" </> clsFile)
76 . filter ((".class" ==) . takeExtension)
77 <$> getDirectoryContents (tmpDir </> "target" </> "classes")
78 mapM_ (\ clsFile -> copyFile clsFile (takeDirectory out </> takeFileName clsFile))
79 classFiles
80 else do
81 (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ ["package"]) ""
82 when (exit /= ExitSuccess) (error ("FAILURE: " ++ mvnCmd ++ " package\n" ++ err ++ mvout))
83 copyFile (tmpDir </> "target" </> (takeBaseName out) <.> "jar") out
84 handle <- openBinaryFile out ReadMode
85 contents <- TIO.hGetContents handle
86 hClose handle
87 handle <- openBinaryFile out WriteMode
88 TIO.hPutStr handle (T.append (T.pack jarHeader) contents)
89 hFlush handle
90 hClose handle
91 perms <- getPermissions out
92 setPermissions out (setOwnerExecutable True perms)
93 readProcess mvnCmd (args ++ ["clean"]) ""
94 removeFile (tmpDir </> "pom.xml")
96jarHeader :: String
97jarHeader =
98 "#!/bin/sh\n"
99 ++ "MYSELF=`which \"$0\" 2>/dev/null`\n"
100 ++ "[ $? -gt 0 -a -f \"$0\" ] && MYSELF=\"./$0\"\n"
101 ++ "java=java\n"
102 ++ "if test -n \"$JAVA_HOME\"; then\n"
103 ++ " java=\"$JAVA_HOME/bin/java\"\n"
104 ++ "fi\n"
105 ++ "exec \"$java\" $java_args -jar $MYSELF \"$@\""
106 ++ "exit 1\n"
108mkPomDependencies :: [String] -> T.Text
109mkPomDependencies deps =
110 T.concat $ map (T.concat . map (T.append (T.pack " ")) . mkDependency . T.pack) deps
111 where
112 mkDependency s =
113 case T.splitOn (T.pack ":") s of
114 [g, a, v] ->
115 [ T.pack $ "<dependency>\n"
116 , T.append (T.pack " ") $ mkGroupId g
117 , T.append (T.pack " ") $ mkArtifactId a
118 , T.append (T.pack " ") $ mkVersion v
119 , T.pack $ "</dependency>\n"
120 ]
121 _ -> []
122 mkGroupId g = T.append (T.pack $ "<groupId>") (T.append g $ T.pack "</groupId>\n")
123 mkArtifactId a = T.append (T.pack $ "<artifactId>") (T.append a $ T.pack "</artifactId>\n")
124 mkVersion v = T.append (T.pack $ "<version>") (T.append v $ T.pack "</version>\n")
126mkCodeGenEnv :: [(Name, SExp)] -> CodeGenerationEnv
127mkCodeGenEnv globalInit =
128 CodeGenerationEnv $ zipWith (\ (name, _) pos -> (name, pos)) globalInit [0..]
130mkCompilationUnit :: [(Name, SExp)] -> [(Name, SDecl)] -> [String] -> FilePath -> CodeGeneration CompilationUnit
131mkCompilationUnit globalInit defs hdrs out =
132 CompilationUnit Nothing ( [ ImportDecl False idrisRts True
133 , ImportDecl True idrisForeign True
134 , ImportDecl False bigInteger False
135 , ImportDecl False stringBuffer False
136 , ImportDecl False runtimeException False
137 , ImportDecl False scanner False
138 , ImportDecl False arrays False
139 ] ++ otherHdrs
140 )
141 <$> mkTypeDecl globalInit defs out
142 where
143 idrisRts = J.Name $ map Ident ["org", "idris", "rts"]
144 idrisForeign = J.Name $ map Ident ["org", "idris", "rts", "ForeignPrimitives"]
145 bigInteger = J.Name $ map Ident ["java", "math", "BigInteger"]
146 stringBuffer = J.Name $ map Ident ["java", "lang", "StringBuffer"]
147 runtimeException = J.Name $ map Ident ["java", "lang", "RuntimeException"]
148 scanner = J.Name $ map Ident ["java", "util", "Scanner"]
149 arrays = J.Name $ map Ident ["java", "util", "Arrays"]
150 otherHdrs = map ( (\ name -> ImportDecl False name False)
151 . J.Name
152 . map (Ident . T.unpack)
153 . T.splitOn (T.pack ".")
154 . T.pack)
155 $ filter (not . isSuffixOf ".h") hdrs
157flatIndent :: String -> String
158flatIndent (' ' : ' ' : xs) = flatIndent xs
159flatIndent (x:xs) = x:flatIndent xs
160flatIndent [] = []
162prefixCallNamespaces :: Ident -> SExp -> SExp
163prefixCallNamespaces (Ident name) (SApp tail (NS n ns) args) = SApp tail (NS n (name:ns)) args
164prefixCallNamespaces name (SLet var e1 e2) = SLet var (prefixCallNamespaces name e1) (prefixCallNamespaces name e2)
165prefixCallNamespaces name (SUpdate var e) = SUpdate var (prefixCallNamespaces name e)
166prefixCallNamespaces name (SCase var alts) = SCase var (map (prefixCallNamespacesCase name) alts)
167prefixCallNamespaces name (SChkCase var alts) = SChkCase var (map (prefixCallNamespacesCase name) alts)
168prefixCallNamespaces _ exp = exp
170prefixCallNamespacesCase :: Ident -> SAlt -> SAlt
171prefixCallNamespacesCase name (SConCase x y n ns e) = SConCase x y n ns (prefixCallNamespaces name e)
172prefixCallNamespacesCase name (SConstCase c e) = SConstCase c (prefixCallNamespaces name e)
173prefixCallNamespacesCase name (SDefaultCase e) = SDefaultCase (prefixCallNamespaces name e)
175prefixCallNamespacesDecl :: Ident -> SDecl -> SDecl
176prefixCallNamespacesDecl name (SFun fname args i e) = SFun fname args i (prefixCallNamespaces name e)
178mkTypeDecl :: [(Name, SExp)] -> [(Name, SDecl)] -> FilePath -> CodeGeneration [TypeDecl]
179mkTypeDecl globalInit defs out =
180 (\ name body -> [ClassTypeDecl $ ClassDecl [ Public
181 , Annotation $ SingleElementAnnotation
182 (J.Name [Ident "SuppressWarnings"])
183 (EVVal . InitExp . Lit $ String "unchecked")
184 ]
185 name
186 []
187 Nothing
188 []
189 body])
190 <$> mkClassName out
191 <*> ( mkClassName out
192 >>= (\ ident -> mkClassBody globalInit (map (second (prefixCallNamespacesDecl ident)) defs))
193 )
195mkClassName :: FilePath -> CodeGeneration Ident
196mkClassName path =
197 T.lift $ left (\ err -> "Parser error in \"" ++ path ++ "\": " ++ (show err))
198 (parser ident . takeBaseName $ takeFileName path)
200mkClassBody :: [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration ClassBody
201mkClassBody globalInit defs =
202 (\ globals defs -> ClassBody . (globals++) . addMainMethod . mergeInnerClasses $ defs)
203 <$> mkGlobalContext globalInit
204 <*> mapM mkDecl defs
206mkGlobalContext :: [(Name, SExp)] -> CodeGeneration [Decl]
207mkGlobalContext [] = return []
208mkGlobalContext initExps =
209 (\ exps -> [ MemberDecl $ FieldDecl [Private, Static, Final]
210 objectArrayType
211 [VarDecl (VarId $ Ident "globalContext")
212 (Just . InitArray $ ArrayInit exps)
213 ]
214 ]
215 )
216 <$> mapM (\ (_, exp) -> InitExp <$> mkExp exp) initExps
220addMainMethod :: [Decl] -> [Decl]
221addMainMethod decls
222 | findMain decls = mkMainMethod : decls
223 | otherwise = decls
224 where
225 findMain ((MemberDecl (MemberClassDecl (ClassDecl _ (Ident "Main") _ _ _ (ClassBody body)))):_) =
226 findMainMethod body
227 findMain (_:decls) = findMain decls
228 findMain [] = False
230 findMainMethod ((MemberDecl (MethodDecl _ _ _ (Ident "main") [] _ _)):_) = True
231 findMainMethod (_:decls) = findMainMethod decls
232 findMainMethod [] = False
234mkMainMethod :: Decl
235mkMainMethod =
236 MemberDecl $ MethodDecl [Public, Static]
237 []
238 Nothing
239 (Ident "main")
240 [FormalParam [] stringArrayType False (VarId $ Ident "args")]
241 []
242 (MethodBody . Just $ Block [ BlockStmt . ExpStmt . MethodInv $
243 MethodCall (J.Name [Ident "idris_initArgs"])
244 [ MethodInv $ TypeMethodCall
245 (J.Name [Ident "Thread"])
246 []
247 (Ident "currentThread")
248 []
249 , ExpName $ J.Name [Ident "args"]
250 ]
251 , BlockStmt . ExpStmt . MethodInv $
252 MethodCall (J.Name [Ident "runMain_0"])
253 []
254 ]
255 )
257mergeInnerClasses :: [Decl] -> [Decl]
258mergeInnerClasses = foldl mergeInner []
259 where
260 mergeInner ((decl@(MemberDecl (MemberClassDecl (ClassDecl priv name targs ext imp (ClassBody body))))):decls)
261 decl'@(MemberDecl (MemberClassDecl (ClassDecl _ name' _ ext' imp' (ClassBody body'))))
262 | name == name' =
263 (MemberDecl $ MemberClassDecl $
264 ClassDecl priv
265 name
266 targs
267 (mplus ext ext')
268 (imp ++ imp')
269 (ClassBody $ mergeInnerClasses (body ++ body')))
270 : decls
271 | otherwise = decl:(mergeInner decls decl')
272 mergeInner (decl:decls) decl' = decl:(mergeInner decls decl')
273 mergeInner [] decl' = [decl']
276mkIdentifier :: Name -> CodeGeneration Ident
277mkIdentifier (NS name _) = mkIdentifier name
278mkIdentifier (MN i name) = (\ (Ident x) -> Ident $ x ++ ('_' : show i))
279 <$> mkIdentifier (UN name)
280mkIdentifier (UN name) =
281 T.lift $ left (\ err -> "Parser error in \"" ++ name ++ "\": " ++ (show err))
282 ( parser ident
283 . cleanReserved
284 . cleanNonLetter
285 . cleanStart
286 $ cleanWs False name)
287 where
288 cleanStart (x:xs)
289 | isNumber x = '_' : (x:xs)
290 | otherwise = (x:xs)
291 cleanStart [] = []
292 cleanNonLetter (x:xs)
293 | x == '#' = "_Hash" ++ cleanNonLetter xs
294 | x == '@' = "_At" ++ cleanNonLetter xs
295 | x == '$' = "_Dollar" ++ cleanNonLetter xs
296 | x == '!' = "_Bang" ++ cleanNonLetter xs
297 | x == '.' = "_Dot" ++ cleanNonLetter xs
298 | x == '\'' = "_Prime" ++ cleanNonLetter xs
299 | x == '*' = "_Times" ++ cleanNonLetter xs
300 | x == '+' = "_Plus" ++ cleanNonLetter xs
301 | x == '/' = "_Divide" ++ cleanNonLetter xs
302 | x == '-' = "_Minus" ++ cleanNonLetter xs
303 | x == '%' = "_Mod" ++ cleanNonLetter xs
304 | x == '<' = "_LessThan" ++ cleanNonLetter xs
305 | x == '=' = "_Equals" ++ cleanNonLetter xs
306 | x == '>' = "_MoreThan" ++ cleanNonLetter xs
307 | x == '[' = "_LSBrace" ++ cleanNonLetter xs
308 | x == ']' = "_RSBrace" ++ cleanNonLetter xs
309 | x == '(' = "_LBrace" ++ cleanNonLetter xs
310 | x == ')' = "_RBrace" ++ cleanNonLetter xs
311 | x == '_' = "__" ++ cleanNonLetter xs
312 | not (isAlphaNum x) = "_" ++ (show $ ord x) ++ xs
313 | otherwise = x:cleanNonLetter xs
314 cleanNonLetter [] = []
315 cleanWs capitalize (x:xs)
316 | isSpace x = cleanWs True xs
317 | capitalize = (toUpper x) : (cleanWs False xs)
318 | otherwise = x : (cleanWs False xs)
319 cleanWs _ [] = []
322 cleanReserved "param" = "_param"
323 cleanReserved "globalContext" = "_globalContext"
324 cleanReserved "context" = "_context"
325 cleanReserved "newcontext" = "_newcontext"
327 cleanReserved "void" = "_void"
328 cleanReserved "null" = "_null"
329 cleanReserved "int" = "_int"
330 cleanReserved "long" = "_long"
331 cleanReserved "char" = "_char"
332 cleanReserved "byte" = "_byte"
333 cleanReserved "double" = "_double"
334 cleanReserved "float" = "_float"
335 cleanReserved "boolean" = "_boolean"
336 cleanReserved "Object" = "_Object"
337 cleanReserved "String" = "_String"
338 cleanReserved "StringBuilder" = "_StringBuilder"
339 cleanReserved "StringBuffer" = "_StringBuffer"
340 cleanReserved "Scanner" = "_Scanner"
341 cleanReserved "Integer" = "_Integer"
342 cleanReserved "Double" = "_Double"
343 cleanReserved "Byte" = "_Byte"
344 cleanReserved "Character" = "_Character"
345 cleanReserved "BigInteger" = "_BigInteger"
346 cleanReserved "Boolean" = "_Boolean"
347 cleanReserved "Closure" = "_Closure"
348 cleanReserved "IdrisObject" = "_IdrisObject"
349 cleanReserved "TailCallClosure" = "_TailCallClosure"
350 cleanReserved "System" = "_System"
351 cleanReserved "Math" = "_Math"
352 cleanReserved "Arrays" = "_Arrays"
353 cleanReserved "RuntimeException" = "_RuntimeException"
354 cleanReserved "Comparable" = "_Comparable"
356 cleanReserved "class" = "_class"
357 cleanReserved "enum" = "_enum"
358 cleanReserved "interface" = "_interface"
359 cleanReserved "extends" = "_extends"
360 cleanReserved "implements" = "_implements"
361 cleanReserved "public" = "_public"
362 cleanReserved "private" = "_private"
363 cleanReserved "protected" = "_protected"
364 cleanReserved "static" = "_static"
365 cleanReserved "final" = "_final"
366 cleanReserved "abstract" = "_abstract"
367 cleanReserved "strict" = "_strict"
368 cleanReserved "volatile" = "_volatile"
369 cleanReserved "transient" = "_transient"
370 cleanReserved "native" = "_native"
371 cleanReserved "const" = "_const"
373 cleanReserved "import" = "_import"
374 cleanReserved "package" = "_package"
376 cleanReserved "throw" = "_throw"
377 cleanReserved "throws" = "_throws"
378 cleanReserved "try" = "_try"
379 cleanReserved "catch" = "_catch"
381 cleanReserved "synchronized" = "_synchronized"
383 cleanReserved "if" = "_if"
384 cleanReserved "else" = "_else"
385 cleanReserved "switch" = "_switch"
386 cleanReserved "case" = "_case"
387 cleanReserved "default" = "_default"
389 cleanReserved "while" = "_while"
390 cleanReserved "for" = "_for"
391 cleanReserved "do" = "_do"
392 cleanReserved "break" = "_break"
393 cleanReserved "continue" = "_continue"
394 cleanReserved "goto" = "_goto"
396 cleanReserved "this" = "_this"
397 cleanReserved "super" = "_super"
398 cleanReserved "new" = "_new"
399 cleanReserved "return" = "_return"
401 cleanReserved "idris_initArgs" = "_idris_initArgs"
402 cleanReserved "idris_numArgs" = "_idris_numArgs"
403 cleanReserved "idris_getArg" = "_idris_getArg"
404 cleanReserved "getenv" = "_getenv"
405 cleanReserved "exit" = "_exit"
406 cleanReserved "usleep" = "_usleep"
407 cleanReserved "idris_sendMessage" = "_idris_sendMessage"
408 cleanReserved "idris_checkMessage" = "_idris_checkMessage"
409 cleanReserved "idris_recvMessage" = "_idris_recvMessage"
410 cleanReserved "putStr" = "_putStr"
411 cleanReserved "putchar" = "_putchar"
412 cleanReserved "getchar" = "_getchar"
413 cleanReserved "fileOpen" = "_fileOpen"
414 cleanReserved "fileClose" = "_fileClose"
415 cleanReserved "fputStr" = "_fputStr"
416 cleanReserved "fileEOF" = "_fileEOF"
417 cleanReserved "isNull" = "_isNull"
418 cleanReserved "idris_K" = "_idris_K"
419 cleanReserved "idris_flipK" = "_idris_flipK"
420 cleanReserved "idris_assignStack" = "_idris_assignStack"
421 cleanReserved "free" = "_free"
422 cleanReserved "malloc" = "_malloc"
423 cleanReserved "idris_peek" = "_idris_peek"
424 cleanReserved "idris_poke" = "_idris_poke"
425 cleanReserved "idris_memmove" = "_idris_memmove"
427 cleanReserved x = x
429mkName :: Name -> CodeGeneration J.Name
430mkName (NS name nss) = (\ n ns -> J.Name (n:ns))
431 <$> mkIdentifier name
432 <*> mapM (mkIdentifier . UN) nss
433mkName n = J.Name . (:[]) <$> mkIdentifier n
435voidType :: ClassType
436voidType = ClassType [(Ident "Void", [])]
438objectType :: ClassType
439objectType = ClassType [(Ident "Object", [])]
441objectArrayType :: Language.Java.Syntax.Type
442objectArrayType = RefType . ArrayType . RefType . ClassRefType $ objectType
444idrisClosureType :: ClassType
445idrisClosureType = ClassType [(Ident "Closure", [])]
447idrisTailCallClosureType :: ClassType
448idrisTailCallClosureType = ClassType [(Ident "TailCallClosure", [])]
450idrisObjectType :: ClassType
451idrisObjectType = ClassType [(Ident "IdrisObject", [])]
453contextArray :: LVar -> Exp
454contextArray (Loc _) = ExpName $ J.Name [Ident "context"]
455contextArray (Glob _) = ExpName $ J.Name [Ident "globalContext"]
457charType :: ClassType
458charType = ClassType [(Ident "Character", [])]
460byteType :: ClassType
461byteType = ClassType [(Ident "Byte", [])]
463shortType :: ClassType
464shortType = ClassType [(Ident "Short", [])]
466integerType :: ClassType
467integerType = ClassType [(Ident "Integer", [])]
469longType :: ClassType
470longType = ClassType [(Ident "Integer", [])]
472bigIntegerType :: ClassType
473bigIntegerType = ClassType [(Ident "BigInteger", [])]
475doubleType :: ClassType
476doubleType = ClassType [(Ident "Double", [])]
478stringType :: ClassType
479stringType = ClassType [(Ident "String", [])]
481stringArrayType :: Language.Java.Syntax.Type
482stringArrayType = RefType . ArrayType . RefType . ClassRefType $ stringType
484exceptionType :: ClassType
485exceptionType = ClassType [(Ident "Throwable", [])]
487runtimeExceptionType :: ClassType
488runtimeExceptionType = ClassType [(Ident "RuntimeException", [])]
490comparableType :: ClassType
491comparableType = ClassType [(Ident "Comparable", [])]
493mkDecl :: (Name, SDecl) -> CodeGeneration Decl
494mkDecl ((NS n (ns:nss)), decl) =
495 (\ name body -> MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body)
496 <$> mkIdentifier (UN ns)
497 <*> mkClassBody [] [(NS n nss, decl)]
498mkDecl (_, SFun name params stackSize body) =
499 (\ name params paramNames methodBody ->
500 MemberDecl $ MethodDecl [Public, Static]
501 []
502 (Just . RefType $ ClassRefType objectType)
503 name
504 params
505 []
506 (MethodBody . Just $ Block
507 [ LocalVars [Final]
508 objectArrayType
509 [ VarDecl (VarDeclArray . VarId $ Ident "context")
510 (Just . InitArray . ArrayInit $
511 paramNames
512 ++ replicate stackSize (InitExp . Lit $ Null))
513 ]
514 , BlockStmt . Return $ Just methodBody
515 ]
516 )
517 )
518 <$> mkIdentifier name
519 <*> mapM mkFormalParam params
520 <*> mapM (\ p -> (InitExp . ExpName) <$> mkName p) params
521 <*> mkExp body
524mkClosure :: [Name] -> Int -> SExp -> CodeGeneration Exp
525mkClosure params stackSize body =
526 (\ paramArray body ->
527 InstanceCreation []
528 idrisClosureType
529 [paramArray]
530 (Just $ ClassBody [body])
531 )
532 <$> mkStackInit params stackSize
533 <*> mkClosureCall body
535mkFormalParam :: Name -> CodeGeneration FormalParam
536mkFormalParam name =
537 (\ name -> FormalParam [Final] (RefType . ClassRefType $ objectType) False (VarId name))
538 <$> mkIdentifier name
540mkClosureCall :: SExp -> CodeGeneration Decl
541mkClosureCall body =
542 (\ body -> MemberDecl $ MethodDecl [Public] [] (Just . RefType $ ClassRefType objectType) (Ident "call") [] [] body)
543 <$> mkMethodBody body
545mkMethodBody :: SExp -> CodeGeneration MethodBody
546mkMethodBody exp =
547 (\ exp -> MethodBody . Just . Block $ [BlockStmt . Return . Just $ exp])
548 <$> mkExp exp
550mkStackInit :: [Name] -> Int -> CodeGeneration Exp
551mkStackInit params stackSize =
552 (\ localVars -> ArrayCreateInit objectArrayType 0 . ArrayInit $
553 (map (InitExp . ExpName) localVars)
554 ++ (replicate (stackSize) (InitExp $ Lit Null)))
555 <$> mapM mkName params
557mkK :: Exp -> Exp -> Exp
558mkK result drop =
559 MethodInv $ MethodCall (J.Name [Ident "idris_K"]) [ result, drop ]
561mkFlipK :: Exp -> Exp -> Exp
562mkFlipK drop result =
563 MethodInv $ MethodCall (J.Name [Ident "idris_flipK"]) [ drop, result ]
565mkLet :: LVar -> SExp -> SExp -> CodeGeneration Exp
566mkLet (Loc pos) oldExp newExp =
567 (\ oldExp newExp ->
568 mkFlipK ( Assign ( ArrayLhs $ ArrayIndex (ExpName $ J.Name [Ident "context"])
569 (Lit $ Int (toInteger pos)))
570 EqualA
571 newExp
572 )
573 oldExp
574 )
575 <$> mkExp oldExp
576 <*> mkExp newExp
577mkLet (Glob _) _ _ = T.lift $ Left "Cannot let bind to global variable"
579reverseNameSpace :: J.Name -> J.Name
580reverseNameSpace (J.Name ids) =
581 J.Name ((tail ids) ++ [head ids])
583mkCase :: Bool -> LVar -> [SAlt] -> CodeGeneration Exp
584mkCase checked var ((SConCase parentStackPos consIndex _ params branchExpression):cases) =
585 mkConsCase checked
586 var
587 parentStackPos
588 consIndex
589 params
590 branchExpression
591 (SCase var cases)
592mkCase checked var (c@(SConstCase constant branchExpression):cases) =
593 (\ constant branchExpression alternative var->
594 Cond ( MethodInv $ PrimaryMethodCall (constant)
595 []
596 (Ident "equals")
597 [var]
598 )
599 branchExpression
600 alternative
601 )
602 <$> mkExp (SConst constant)
603 <*> mkExp branchExpression
604 <*> mkCase checked var cases
605 <*> mkVarAccess Nothing var
606mkCase checked var (SDefaultCase exp:cases) = mkExp exp
607mkCase checked _ [] = mkExp (SError "Non-exhaustive pattern")
609mkConsCase :: Bool -> LVar -> Int -> Int -> [Name] -> SExp -> SExp -> CodeGeneration Exp
610mkConsCase checked
611 toDeconstruct
612 parentStackStart
613 consIndex
614 params
615 branchExpression
616 alternative =
617 (\ caseBinding alternative var varCasted->
618 Cond (BinOp (InstanceOf (var)
619 (ClassRefType idrisObjectType)
620 )
621 CAnd
622 ( BinOp
623 ( MethodInv $ PrimaryMethodCall (varCasted)
624 []
625 (Ident "getConstructorId")
626 []
627 )
628 Equal
629 (Lit $ Int (toInteger consIndex))
630 )
631 )
632 (caseBinding)
633 alternative
634 )
635 <$> mkCaseBinding checked toDeconstruct parentStackStart params branchExpression
636 <*> mkExp alternative
637 <*> mkVarAccess (Nothing) toDeconstruct
638 <*> mkVarAccess (Just idrisObjectType) toDeconstruct
641mkCaseBinding :: Bool -> LVar -> Int -> [Name] -> SExp -> CodeGeneration Exp
642mkCaseBinding True var parentStackStart params branchExpression =
643 (\ branchExpression deconstruction ->
644 mkFlipK (MethodInv $ MethodCall (J.Name [Ident "idris_assignStack"])
645 ( (ExpName $ J.Name [Ident "context"])
646 : (Lit $ Int (toInteger parentStackStart))
647 : deconstruction
648 ))
649 (branchExpression)
650 )
651 <$> mkExp branchExpression
652 <*> mkCaseBindingDeconstruction var params
653mkCaseBinding False var parentStackStart params branchExpression =
654 (\ bindingMethod deconstruction ->
655 MethodInv $ PrimaryMethodCall
656 ( MethodInv $ PrimaryMethodCall (InstanceCreation []
657 (ClassType [(Ident "Object", [])])
658 []
659 (Just $ ClassBody [MemberDecl $ bindingMethod])
660 )
661 []
662 (Ident "apply")
663 ( contextArray (Loc undefined) : deconstruction )
664 )
665 []
666 (Ident "call")
667 []
668 )
669 <$> mkCaseBindingMethod parentStackStart params branchExpression
670 <*> mkCaseBindingDeconstruction var params
672mkCaseBindingDeconstruction :: LVar -> [Name] -> CodeGeneration [Exp]
673mkCaseBindingDeconstruction var members =
674 mapM (mkProjection var) ([0..(length members - 1)])
676mkCaseBindingMethod :: Int -> [Name] -> SExp -> CodeGeneration MemberDecl
677mkCaseBindingMethod parentStackStart params branchExpression =
678 (\ formalParams caseBindingStack branchExpression ->
679 MethodDecl [Final, Public]
680 []
681 (Just . RefType $ ClassRefType idrisClosureType)
682 (Ident "apply")
683 (mkContextParam:formalParams)
684 []
685 (MethodBody . Just . Block $
686 caseBindingStack ++
687 [BlockStmt . Return $ Just branchExpression]))
688 <$> mapM mkFormalParam params
689 <*> mkBindingStack False parentStackStart params
690 <*> mkBindingClosure branchExpression
692mkContextParam :: FormalParam
693mkContextParam =
694 FormalParam [Final] (objectArrayType) False (VarId (Ident "context"))
696mkBindingClosure :: SExp -> CodeGeneration Exp
697mkBindingClosure oldExp =
698 (\ oldCall ->
699 InstanceCreation []
700 idrisClosureType
701 [ ExpName $ J.Name [Ident "new_context"] ]
702 (Just $ ClassBody [oldCall])
703 )
704 <$> mkClosureCall oldExp
707mkBindingStack :: Bool -> Int -> [Name] -> CodeGeneration [BlockStmt]
708mkBindingStack checked parentStackStart params =
709 (\ paramNames ->
710 ( LocalVars [Final]
711 objectArrayType
712 [ VarDecl (VarDeclArray . VarId $ Ident "new_context")
713 (Just . InitExp $ mkContextCopy checked parentStackStart params)
714 ])
715 : ( map (\ (param, pos) ->
716 BlockStmt . ExpStmt $
717 Assign (ArrayLhs $ ArrayIndex (ExpName $ J.Name [Ident "new_context"])
718 (Lit $ Int (toInteger pos)))
719 EqualA
720 (ExpName param)) $ zip paramNames [parentStackStart..]
721 )
722 )
723 <$> mapM mkName params
725mkContextCopy :: Bool -> Int -> [Name] -> Exp
726mkContextCopy True parentStackStart params =
727 MethodInv $ PrimaryMethodCall (ExpName $ J.Name [Ident "context"])
728 []
729 (Ident "clone")
730 []
731mkContextCopy False parentStackStart params =
732 MethodInv $ TypeMethodCall (J.Name [Ident "Arrays"])
733 []
734 (Ident "copyOf")
735 [ ExpName $ J.Name [Ident "context"]
736 , MethodInv
737 $ TypeMethodCall (J.Name [Ident "Math"])
738 []
739 (Ident "max")
740 [ FieldAccess $ PrimaryFieldAccess (ExpName $ J.Name [Ident "context"])
741 (Ident "length")
742 , Lit . Int $ toInteger (parentStackStart + length params)
743 ]
744 ]
746mkProjection :: LVar -> Int -> CodeGeneration Exp
747mkProjection var memberNr =
748 (\ var -> ArrayAccess $ ArrayIndex ( MethodInv $ PrimaryMethodCall
749 (var)
750 []
751 (Ident "getData")
752 []
753 )
754 (Lit $ Int (toInteger memberNr))
755 )
756 <$> mkVarAccess (Just idrisObjectType) var
758type ClassName = String
760mkPrimitive :: ClassName -> Literal -> Exp
761mkPrimitive className value =
762 MethodInv $ TypeMethodCall (J.Name [Ident className])
763 []
764 (Ident "valueOf")
765 [Lit $ value]
767mkClass :: ClassType -> Exp
768mkClass classType =
769 ClassLit . Just . RefType .ClassRefType $ classType
771mkBinOpExp :: ClassType -> Op -> [LVar] -> CodeGeneration Exp
772mkBinOpExp castTo op (var:vars) = do
773 start <- mkVarAccess (Just castTo) var
774 foldM (\ exp var -> BinOp exp op <$> mkVarAccess (Just castTo) var) start vars
776mkBinOpExpTrans :: (Exp -> Exp) -> (Exp -> Exp) -> ClassType -> Op -> [LVar] -> CodeGeneration Exp
777mkBinOpExpTrans opTransformation resultTransformation castTo op (var:vars) = do
778 start <- (mkVarAccess (Just castTo) var)
779 foldM (\ exp var -> resultTransformation
780 . BinOp (opTransformation exp) op
781 . opTransformation
782 <$> mkVarAccess (Just castTo) var)
783 start
784 vars
786mkBinOpExpConv :: String -> PrimType -> ClassType -> Op -> [LVar] -> CodeGeneration Exp
787mkBinOpExpConv fromMethodName toType fromType@(ClassType [(cls@(Ident _), [])]) op args =
788 mkBinOpExpTrans (\ exp -> MethodInv $ TypeMethodCall (J.Name [cls])
789 []
790 (Ident fromMethodName)
791 [exp]
792 )
793 (\ exp -> MethodInv $ TypeMethodCall (J.Name [cls])
794 []
795 (Ident "valueOf")
796 [Cast (PrimType $ toType) exp]
797 )
798 fromType
799 op
800 args
802mkLogicalBinOpExp :: ClassType -> Op -> [LVar] -> CodeGeneration Exp
803mkLogicalBinOpExp castTo op (var:vars) = do
804 start <- mkVarAccess (Just castTo) var
805 foldM (\ exp var -> mkBoolToNumber castTo . BinOp exp op <$> mkVarAccess (Just castTo) var)
806 start
807 vars
809mkMethodOpChain1 :: (Exp -> Exp) -> ClassType -> String -> [LVar] -> CodeGeneration Exp
810mkMethodOpChain1 = mkMethodOpChain id
812mkMethodOpChain :: (Exp -> Exp) -> (Exp -> Exp) -> ClassType -> String -> [LVar] -> CodeGeneration Exp
813mkMethodOpChain initialTransformation resultTransformation castTo method (arg:args) = do
814 start <- initialTransformation <$> mkVarAccess (Just $ castTo) arg
815 foldM (\ exp arg' ->
816 resultTransformation
817 . MethodInv
818 . PrimaryMethodCall exp [] (Ident method)
819 . (:[])
820 <$> mkVarAccess (Just $ castTo) arg'
821 )
822 start
823 args
825mkBoolToNumber :: ClassType -> Exp -> Exp
826mkBoolToNumber (ClassType [(Ident name, [])]) boolExp =
827 Cond boolExp (mkPrimitive name (Int 1)) (mkPrimitive name (Int 0))
829mkZeroExt :: String -> Int -> ClassType -> ClassType -> LVar -> CodeGeneration Exp
830mkZeroExt toMethod bits fromType toType@(ClassType [(toTypeName, [])]) var = do
831 (\ var sext ->
832 MethodInv $ TypeMethodCall (J.Name [toTypeName])
833 []
834 (Ident "valueOf")
835 [ Cond ( BinOp (var)
836 LThan
837 (Lit $ Int 0)
838 )
839 ( BinOp (Lit $ Int (2^bits))
840 Add
841 (sext)
842 )
843 sext
844 ]
845 )
846 <$> mkVarAccess (Just $ fromType) var
847 <*> mkSignedExt' toMethod fromType var
849mkSignedExt :: String -> ClassType -> ClassType -> LVar -> CodeGeneration Exp
850mkSignedExt toMethod fromType (ClassType [(toTypeName, [])]) var =
851 (\ sext -> MethodInv $ TypeMethodCall (J.Name [toTypeName])
852 []
853 (Ident "valueOf")
854 [ sext ]
855 )
856 <$> mkSignedExt' toMethod fromType var
858mkSignedExt' :: String -> ClassType -> LVar -> CodeGeneration Exp
859mkSignedExt' toMethod fromType var =
860 (\ var -> MethodInv $ PrimaryMethodCall (var)
861 []
862 (Ident toMethod)
863 []
864 )
865 <$> mkVarAccess (Just $ fromType) var
867data SPartialOrder
868 = SLt
869 | SLe
870 | SEq
871 | SGe
872 | SGt
874mkPartialOrder :: SPartialOrder -> Exp -> Exp
875mkPartialOrder SLt x = (BinOp (Lit $ Int (-1)) Equal x)
876mkPartialOrder SLe x =
877 BinOp (BinOp (Lit $ Int (-1)) Equal x)
878 COr
879 (BinOp (Lit $ Int 0) Equal x)
880mkPartialOrder SEq x = BinOp (Lit $ Int 0) Equal x
881mkPartialOrder SGe x =
882 BinOp (BinOp (Lit $ Int 1) Equal x)
883 COr
884 (BinOp (Lit $ Int 0) Equal x)
885mkPartialOrder SGt x = (BinOp (Lit $ Int 1) Equal x)
887varPos :: LVar -> CodeGeneration Integer
888varPos (Loc i) = return (toInteger i)
889varPos (Glob name) = do
890 positions <- globalVariablePositions <$> get
891 case lookup name positions of
892 (Just pos) -> return pos
893 Nothing -> T.lift . Left $ "Invalid global variable id: " ++ show name
895mkVarAccess :: Maybe ClassType -> LVar -> CodeGeneration Exp
896mkVarAccess Nothing var =
897 (\ pos -> ArrayAccess $ ArrayIndex (contextArray var) (Lit $ Int pos))
898 <$> varPos var
899mkVarAccess (Just castTo) var =
900 Cast (RefType . ClassRefType $ castTo) <$> (mkVarAccess Nothing var)
902mkPrimitiveCast :: ClassType -> ClassType -> LVar -> CodeGeneration Exp
903mkPrimitiveCast fromType (ClassType [(toType, [])]) var =
904 (\ var ->
905 MethodInv $ TypeMethodCall (J.Name [toType])
906 []
907 (Ident "valueOf")
908 [var]
909 )
910 <$> mkVarAccess (Just fromType) var
912mkToString :: ClassType -> LVar -> CodeGeneration Exp
913mkToString castTo var =
914 (\ var -> MethodInv $ PrimaryMethodCall (var)
915 []
916 (Ident "toString")
917 []
918 )
919 <$> mkVarAccess (Just castTo) var
920data Std = In | Out | Err
922instance Show Std where
923 show In = "in"
924 show Out = "out"
925 show Err = "err"
927mkSystemStd :: Std -> Exp
928mkSystemStd std = FieldAccess $ PrimaryFieldAccess (ExpName $ J.Name [Ident "System"]) (Ident $ show std)
930mkSystemOutPrint :: Exp -> Exp
931mkSystemOutPrint value =
932 MethodInv $ PrimaryMethodCall (mkSystemStd Out)
933 []
934 (Ident "print")
935 [value]
937mkMathFun :: String -> LVar -> CodeGeneration Exp
938mkMathFun funName var =
939 (\ var -> MethodInv $ TypeMethodCall (J.Name [Ident "Double"])
940 []
941 (Ident "valueOf")
942 [ MethodInv $ TypeMethodCall (J.Name [Ident "Math"])
943 []
944 (Ident funName)
945 [var]
946 ]
947 )
948 <$> mkVarAccess (Just doubleType) var
950mkStringAtIndex :: LVar -> Exp -> CodeGeneration Exp
951mkStringAtIndex var indexExp =
952 (\ var -> MethodInv $ TypeMethodCall (J.Name [Ident "Integer"])
953 []
954 (Ident "valueOf")
955 [ MethodInv $ PrimaryMethodCall (var)
956 []
957 (Ident "charAt")
958 [indexExp]
959 ]
960 )
961 <$> mkVarAccess (Just stringType) var
963mkForeignType :: FType -> Maybe ClassType
964mkForeignType FInt = return integerType
965mkForeignType FChar = return integerType
966mkForeignType FString = return stringType
967mkForeignType FPtr = return objectType
968mkForeignType FDouble = return doubleType
969mkForeignType FAny = return objectType
970mkForeignType FUnit = Nothing
972mkForeignVarAccess :: FType -> LVar -> CodeGeneration Exp
973mkForeignVarAccess FInt var =
974 (\ var -> MethodInv $ PrimaryMethodCall (var)
975 []
976 (Ident "intValue")
977 []
978 )
979 <$> mkVarAccess (Just integerType) var
980mkForeignVarAccess FChar var = Cast (PrimType CharT) <$> mkForeignVarAccess FInt var
981mkForeignVarAccess FDouble var =
982 (\ var -> MethodInv $ PrimaryMethodCall (var)
983 []
984 (Ident "doubleValue")
985 []
986 )
987 <$> mkVarAccess (Just doubleType) var
988mkForeignVarAccess otherType var = mkVarAccess (mkForeignType otherType) var
990mkFromForeignType :: FType -> Exp -> Exp
991mkFromForeignType FInt from =
992 MethodInv $ TypeMethodCall (J.Name [Ident "Integer"])
993 []
994 (Ident "valueOf")
995 [from]
996mkFromForeignType FChar from = mkFromForeignType FInt from
997mkFromForeignType FDouble from =
998 MethodInv $ TypeMethodCall (J.Name [Ident "Double"])
999 []
1000 (Ident "valueOf")
1001 [from]
1002mkFromForeignType _ from = from
1004mkForeignInvoke :: FType -> String -> [(FType, LVar)] -> CodeGeneration Exp
1005mkForeignInvoke fType method args =
1006 (\ foreignInvokeMeth ->
1007 MethodInv $ PrimaryMethodCall (InstanceCreation []
1008 objectType
1009 []
1010 (Just $ ClassBody [ MemberDecl $ foreignInvokeMeth ])
1012 []
1013 (Ident "foreignInvoke")
1014 []
1016 <$> mkForeignInvokeMethod fType method args
1019mkForeignInvokeMethod :: FType -> String -> [(FType, LVar)] -> CodeGeneration MemberDecl
1020mkForeignInvokeMethod fType method args =
1021 (\ tryBlock ->
1022 MethodDecl [Public, Final]
1023 []
1024 (Just . RefType $ ClassRefType objectType)
1025 (Ident "foreignInvoke")
1026 []
1027 []
1028 (MethodBody . Just $ Block
1029 [ BlockStmt
1030 $ Try tryBlock
1031 [ Catch (FormalParam []
1032 (RefType $ ClassRefType exceptionType)
1033 False
1034 (VarId $ Ident "ex")
1036 (Block [ BlockStmt
1037 . Throw
1038 $ InstanceCreation []
1039 runtimeExceptionType
1040 [ExpName $ J.Name [Ident "ex"]]
1041 Nothing
1045 Nothing
1049 <$> mkForeignInvokeTryBlock fType method args
1052mkForeignInvokeTryBlock :: FType -> String -> [(FType, LVar)] -> CodeGeneration Block
1053mkForeignInvokeTryBlock FUnit method args =
1054 (\ method args -> Block [ BlockStmt . ExpStmt . MethodInv $ MethodCall method args
1055 , BlockStmt $ Return (Just $ Lit Null)
1058 <$> ( T.lift $ left (\ err -> "Error parsing name \"" ++ method ++ "\" :" ++ (show err))
1059 (parser name method)
1061 <*> mapM (uncurry mkForeignVarAccess) args
1062mkForeignInvokeTryBlock fType method args =
1063 (\ method args -> Block [ BlockStmt . Return
1064 . Just
1065 . mkFromForeignType fType
1066 . MethodInv
1067 $ MethodCall method args
1070 <$> ( T.lift $ left (\ err -> "Error parsing name \"" ++ method ++ "\" :" ++ (show err))
1071 (parser name method)
1073 <*> mapM (uncurry mkForeignVarAccess) args
1075mkMethodClosure :: Name -> [LVar] -> CodeGeneration Exp
1076mkMethodClosure name args =
1077 (\ name args ->
1078 InstanceCreation []
1079 idrisClosureType
1080 [ (ExpName $ J.Name [Ident "context"]) ]
1081 ( Just
1082 $ ClassBody
1083 [ MemberDecl
1084 $ MethodDecl [Public, Final]
1085 []
1086 (Just . RefType $ ClassRefType objectType)
1087 (Ident "call")
1088 []
1089 []
1090 ( MethodBody
1091 . Just
1092 $ Block [ BlockStmt
1093 . Return
1094 . Just
1095 . MethodInv
1096 $ MethodCall (reverseNameSpace name)
1097 args
1103 <$> mkName name
1104 <*> mapM (mkExp . SV) args
1106mkThread :: LVar -> CodeGeneration Exp
1107mkThread arg =
1108 (\ eval ->
1109 MethodInv
1110 $ PrimaryMethodCall (InstanceCreation []
1111 (ClassType [(Ident "Thread", [])])
1112 [ eval ]
1113 ( Just
1114 $ ClassBody [ MemberDecl
1115 $ MethodDecl [Public, Final]
1116 []
1117 (Just . RefType $ ClassRefType objectType)
1118 (Ident "_start")
1119 []
1120 []
1121 ( MethodBody
1122 . Just
1123 $ Block [ BlockStmt
1124 . ExpStmt
1125 . MethodInv
1126 $ MethodCall (J.Name [Ident "start"])
1127 []
1128 , BlockStmt
1129 . Return
1130 . Just
1131 $ This
1137 []
1138 (Ident "_start")
1139 []
1141 <$> mkThreadBinding arg
1143mkThreadBinding :: LVar -> CodeGeneration Exp
1144mkThreadBinding var =
1145 (\ bindingMethod var ->
1146 MethodInv $ PrimaryMethodCall ( InstanceCreation []
1147 objectType
1148 []
1149 (Just $ ClassBody [MemberDecl $ bindingMethod])
1151 []
1152 (Ident "apply")
1153 [ var ]
1155 <$> mkThreadBindingMethod
1156 <*> mkVarAccess Nothing var
1159mkThreadBindingMethod :: CodeGeneration MemberDecl
1160mkThreadBindingMethod =
1161 (\ compute ->
1162 MethodDecl [Final, Public]
1163 []
1164 (Just . RefType $ ClassRefType idrisClosureType)
1165 (Ident "apply")
1166 [ FormalParam [Final] (RefType . ClassRefType $ objectType) False (VarId $ Ident "param") ]
1167 []
1168 (MethodBody . Just $ Block
1169 [ mkThreadBindingStack
1170 , BlockStmt . Return $ Just compute
1174 <$> mkBindingClosure (SUpdate (Loc 0) (SApp False (MN 0 "EVAL") [Loc 0]))
1177mkThreadBindingStack :: BlockStmt
1178mkThreadBindingStack =
1179 LocalVars [Final]
1180 objectArrayType
1181 [ VarDecl (VarDeclArray . VarId $ Ident "new_context")
1182 (Just . InitArray $ ArrayInit [InitExp . ExpName $ J.Name [Ident "param"]])
1186mkExp :: SExp -> CodeGeneration Exp
1187mkExp (SV var) = mkVarAccess Nothing var
1188mkExp (SApp False name args) =
1189 (\ methClosure ->
1190 MethodInv $ PrimaryMethodCall ( InstanceCreation []
1191 idrisTailCallClosureType
1192 [ methClosure ]
1193 Nothing
1195 []
1196 (Ident "call")
1197 []
1199 <$> mkMethodClosure name args
1200mkExp (SApp True name args) =
1201 (\ methClosure ->
1202 ( InstanceCreation []
1203 idrisTailCallClosureType
1204 [ methClosure ]
1205 Nothing
1208 <$> mkMethodClosure name args
1209mkExp (SLet var new old) =
1210 mkLet var old new
1211mkExp (SUpdate var exp) =
1212 (\ rhs varPos -> Assign (ArrayLhs $ ArrayIndex (contextArray var) (Lit $ Int varPos))
1213 EqualA
1214 rhs
1216 <$> mkExp exp
1217 <*> varPos var
1218mkExp (SCon conId name args) =
1219 (\ args -> InstanceCreation []
1220 idrisObjectType
1221 ((Lit $ Int (toInteger conId)):args)
1222 Nothing)
1223 <$> mapM (mkExp .SV) args
1224mkExp (SCase var alts) = mkCase False var alts
1225mkExp (SChkCase var alts) = mkCase True var alts
1226mkExp (SProj var i) = mkProjection var i
1227mkExp (SConst (I x)) = return $ mkPrimitive "Integer" (Int (toInteger x))
1228mkExp (SConst (BI x)) =
1229 return $ InstanceCreation []
1230 (ClassType [(Ident "BigInteger", [])])
1231 [Lit $ String (show x)]
1232 Nothing
1233mkExp (SConst (Fl x)) = return $ mkPrimitive "Double" (Double x)
1234mkExp (SConst (Ch x)) = return $ mkPrimitive "Integer" (Char x)
1235mkExp (SConst (Str x)) = return $ Lit $ String x
1236mkExp (SConst IType) = return $ mkClass integerType
1237mkExp (SConst BIType) = return $ mkClass bigIntegerType
1238mkExp (SConst FlType) = return $ mkClass doubleType
1239mkExp (SConst ChType) = return $ mkClass charType
1240mkExp (SConst StrType) = return $ mkClass stringType
1241mkExp (SConst (B8 x)) = return $ mkPrimitive "Byte" (Int (toInteger x))
1242mkExp (SConst (B16 x)) = return $ mkPrimitive "Short" (Int (toInteger x))
1243mkExp (SConst (B32 x)) = return $ mkPrimitive "Integer" (Int (toInteger x))
1244mkExp (SConst (B64 x)) = return $ mkPrimitive "Long" (Int (toInteger x))
1245mkExp (SConst (B8Type))= return $ mkClass byteType
1246mkExp (SConst (B16Type)) = return $ mkClass shortType
1247mkExp (SConst (B32Type)) = return $ mkClass integerType
1248mkExp (SConst (B64Type)) = return $ mkClass longType
1249mkExp (SConst (PtrType)) = return $ mkClass objectType
1250mkExp (SConst (VoidType)) = return $ mkClass voidType
1251mkExp (SConst (Forgot)) = return $ mkClass objectType
1252mkExp (SForeign _ fType meth args) = mkForeignInvoke fType meth args
1253mkExp (SOp LPlus args) = mkBinOpExp integerType Add args
1254mkExp (SOp LMinus args) = mkBinOpExp integerType Sub args
1255mkExp (SOp LTimes args) = mkBinOpExp integerType Mult args
1256mkExp (SOp LDiv args) = mkBinOpExp integerType Div args
1257mkExp (SOp LMod args) = mkBinOpExp integerType Rem args
1258mkExp (SOp LAnd args) = mkBinOpExp integerType And args
1259mkExp (SOp LOr args) = mkBinOpExp integerType Or args
1260mkExp (SOp LXOr args) = mkBinOpExp integerType Xor args
1261mkExp (SOp LCompl [var]) =
1262 PreBitCompl <$> mkVarAccess (Just $ integerType) var
1263mkExp (SOp LSHL args) = mkBinOpExp integerType LShift args
1264mkExp (SOp LSHR args) = mkBinOpExp integerType RShift args
1265mkExp (SOp LEq args) =
1266 mkMethodOpChain1 (mkBoolToNumber integerType) objectType "equals" args
1267mkExp (SOp LLt args) = mkLogicalBinOpExp integerType LThan args
1268mkExp (SOp LLe args) = mkLogicalBinOpExp integerType LThanE args
1269mkExp (SOp LGt args) = mkLogicalBinOpExp integerType GThan args
1270mkExp (SOp LGe args) = mkLogicalBinOpExp integerType GThanE args
1271mkExp (SOp LFPlus args) = mkBinOpExp doubleType Add args
1272mkExp (SOp LFMinus args) = mkBinOpExp doubleType Sub args
1273mkExp (SOp LFTimes args) = mkBinOpExp doubleType Mult args
1274mkExp (SOp LFDiv args) = mkBinOpExp doubleType Div args
1275mkExp (SOp LFEq args) =
1276 mkMethodOpChain1 (mkBoolToNumber doubleType) doubleType "equals" args
1277mkExp (SOp LFLt args) = mkLogicalBinOpExp integerType LThan args
1278mkExp (SOp LFLe args) = mkLogicalBinOpExp integerType LThanE args
1279mkExp (SOp LFGt args) = mkLogicalBinOpExp integerType GThan args
1280mkExp (SOp LFGe args) = mkLogicalBinOpExp integerType GThanE args
1281mkExp (SOp LBPlus args) = mkMethodOpChain1 id bigIntegerType "add" args
1282mkExp (SOp LBMinus args) = mkMethodOpChain1 id bigIntegerType "subtract" args
1283mkExp (SOp LBTimes args) = mkMethodOpChain1 id bigIntegerType "multiply" args
1284mkExp (SOp LBDiv args) = mkMethodOpChain1 id bigIntegerType "divide" args
1285mkExp (SOp LBMod args) = mkMethodOpChain1 id bigIntegerType "mod" args
1286mkExp (SOp LBEq args) =
1287 mkMethodOpChain1 (mkBoolToNumber bigIntegerType) bigIntegerType "equals" args
1288mkExp (SOp LBLt args) =
1289 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1290 . mkPartialOrder SLt
1291 )
1292 bigIntegerType
1293 "compare"
1294 args
1295mkExp (SOp LBLe args) =
1296 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1297 . mkPartialOrder SLe
1298 )
1299 bigIntegerType
1300 "compare"
1301 args
1302mkExp (SOp LBGt args) =
1303 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1304 . mkPartialOrder SGt
1305 )
1306 bigIntegerType
1307 "compare"
1308 args
1309mkExp (SOp LBGe args) =
1310 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1311 . mkPartialOrder SGe
1312 )
1313 bigIntegerType
1314 "compare"
1315 args
1316mkExp (SOp LStrConcat args) =
1317 mkMethodOpChain (\ exp -> InstanceCreation []
1318 (ClassType [(Ident "StringBuilder", [])])
1319 [exp]
1320 Nothing
1322 (\ exp -> MethodInv $ PrimaryMethodCall exp [] (Ident "toString") [])
1323 stringType
1324 "append"
1325 args
1326mkExp (SOp LStrLt args@[_, _]) =
1327 mkMethodOpChain1 ( mkBoolToNumber integerType
1328 . mkPartialOrder SLt
1330 stringType
1331 "compare"
1332 args
1333mkExp (SOp LStrEq args@[_, _]) =
1334 mkMethodOpChain1 ( mkBoolToNumber integerType)
1335 stringType
1336 "equals"
1337 args
1338mkExp (SOp LStrLen [arg]) =
1339 (\ var -> MethodInv $ PrimaryMethodCall var [] (Ident "length") [])
1340 <$> mkVarAccess (Just stringType) arg
1341mkExp (SOp LIntFloat [arg]) =
1342 mkPrimitiveCast integerType doubleType arg
1343mkExp (SOp LFloatInt [arg]) =
1344 mkPrimitiveCast doubleType integerType arg
1345mkExp (SOp LIntStr [arg]) =
1346 mkToString integerType arg
1347mkExp (SOp LStrInt [arg]) =
1348 mkPrimitiveCast stringType integerType arg
1349mkExp (SOp LFloatStr [arg]) =
1350 mkToString doubleType arg
1351mkExp (SOp LStrFloat [arg]) =
1352 mkPrimitiveCast doubleType stringType arg
1353mkExp (SOp LIntBig [arg]) =
1354 mkPrimitiveCast integerType bigIntegerType arg
1355mkExp (SOp LBigInt [arg]) =
1356 mkPrimitiveCast bigIntegerType integerType arg
1357mkExp (SOp LStrBig [arg]) =
1358 (\ var -> InstanceCreation [] bigIntegerType [var] Nothing)
1359 <$> mkVarAccess (Just stringType) arg
1360mkExp (SOp LBigStr [arg]) =
1361 mkToString bigIntegerType arg
1362mkExp (SOp LChInt [arg]) =
1363 mkVarAccess (Just integerType) arg
1364mkExp (SOp LIntCh [arg]) =
1365 mkVarAccess (Just integerType) arg
1366mkExp (SOp LPrintNum [arg]) =
1367 mkSystemOutPrint <$> (mkVarAccess Nothing arg)
1368mkExp (SOp LPrintStr [arg]) =
1369 mkSystemOutPrint <$> (mkVarAccess (Just stringType) arg)
1370mkExp (SOp LReadStr [arg]) = mkExp (SForeign LANG_C FString "idris_readStr" [(FPtr, arg)])
1371mkExp (SOp LB8Lt args) = mkLogicalBinOpExp byteType LThan args
1372mkExp (SOp LB8Lte args) = mkLogicalBinOpExp byteType LThanE args
1373mkExp (SOp LB8Eq args) =
1374 mkMethodOpChain1 (mkBoolToNumber byteType) byteType "equals" args
1375mkExp (SOp LB8Gt args) = mkLogicalBinOpExp byteType GThan args
1376mkExp (SOp LB8Gte args) = mkLogicalBinOpExp byteType GThanE args
1377mkExp (SOp LB8Plus args) = mkBinOpExp byteType Add args
1378mkExp (SOp LB8Minus args) = mkBinOpExp byteType Sub args
1379mkExp (SOp LB8Times args) = mkBinOpExp byteType Mult args
1380mkExp (SOp LB8UDiv args) = mkBinOpExpConv "shortValue" ShortT byteType Div args
1381mkExp (SOp LB8SDiv args) = mkBinOpExp byteType Div args
1382mkExp (SOp LB8URem args) = mkBinOpExpConv "shortValue" ShortT byteType Rem args
1383mkExp (SOp LB8SRem args) = mkBinOpExp byteType Rem args
1384mkExp (SOp LB8Shl args) = mkBinOpExp byteType LShift args
1385mkExp (SOp LB8LShr args) = mkBinOpExp byteType RRShift args
1386mkExp (SOp LB8AShr args) = mkBinOpExp byteType RShift args
1387mkExp (SOp LB8And args) = mkBinOpExp byteType And args
1388mkExp (SOp LB8Or args) = mkBinOpExp byteType Or args
1389mkExp (SOp LB8Xor args) = mkBinOpExp byteType Xor args
1390mkExp (SOp LB8Compl [var]) =
1391 PreBitCompl <$> mkVarAccess (Just $ byteType) var
1392mkExp (SOp LB8Z16 [var]) = mkZeroExt "shortValue" 8 byteType shortType var
1393mkExp (SOp LB8Z32 [var]) = mkZeroExt "intValue" 8 byteType integerType var
1394mkExp (SOp LB8Z64 [var]) = mkZeroExt "longValue" 8 byteType longType var
1395mkExp (SOp LB8S16 [var]) = mkSignedExt "shortValue" byteType shortType var
1396mkExp (SOp LB8S32 [var]) = mkSignedExt "intValue" byteType integerType var
1397mkExp (SOp LB8S64 [var]) = mkSignedExt "longValue" byteType longType var
1398mkExp (SOp LB16Lt args) = mkLogicalBinOpExp shortType LThan args
1399mkExp (SOp LB16Lte args) = mkLogicalBinOpExp shortType LThanE args
1400mkExp (SOp LB16Eq args) =
1401 mkMethodOpChain1 (mkBoolToNumber shortType) shortType "equals" args
1402mkExp (SOp LB16Gt args) = mkLogicalBinOpExp shortType GThan args
1403mkExp (SOp LB16Gte args) = mkLogicalBinOpExp shortType GThanE args
1404mkExp (SOp LB16Plus args) = mkBinOpExp shortType Add args
1405mkExp (SOp LB16Minus args) = mkBinOpExp shortType Sub args
1406mkExp (SOp LB16Times args) = mkBinOpExp shortType Mult args
1407mkExp (SOp LB16UDiv args) = mkBinOpExpConv "intValue" IntT shortType Div args
1408mkExp (SOp LB16SDiv args) = mkBinOpExp shortType Div args
1409mkExp (SOp LB16URem args) = mkBinOpExpConv "intValue" IntT shortType Rem args
1410mkExp (SOp LB16SRem args) = mkBinOpExp shortType Rem args
1411mkExp (SOp LB16Shl args) = mkBinOpExp shortType LShift args
1412mkExp (SOp LB16LShr args) = mkBinOpExp shortType RRShift args
1413mkExp (SOp LB16AShr args) = mkBinOpExp shortType RShift args
1414mkExp (SOp LB16And args) = mkBinOpExp shortType And args
1415mkExp (SOp LB16Or args) = mkBinOpExp shortType Or args
1416mkExp (SOp LB16Xor args) = mkBinOpExp shortType Xor args
1417mkExp (SOp LB16Compl [var]) =
1418 PreBitCompl <$> mkVarAccess (Just $ shortType) var
1419mkExp (SOp LB16Z32 [var]) = mkZeroExt "intValue" 16 shortType integerType var
1420mkExp (SOp LB16Z64 [var]) = mkZeroExt "longValue" 16 shortType longType var
1421mkExp (SOp LB16S32 [var]) = mkSignedExt "intValue" shortType integerType var
1422mkExp (SOp LB16S64 [var]) = mkSignedExt "longValue" shortType longType var
1423mkExp (SOp LB16T8 [var]) =
1424 (\ var -> MethodInv $
1425 TypeMethodCall (J.Name [Ident "Byte"])
1426 []
1427 (Ident "valueOf")
1428 [ MethodInv
1429 $ PrimaryMethodCall var [] (Ident "byteValue") [] ]
1431 <$> mkVarAccess (Just $ shortType) var
1432mkExp (SOp LB32Lt args) = mkLogicalBinOpExp integerType LThan args
1433mkExp (SOp LB32Lte args) = mkLogicalBinOpExp integerType LThanE args
1434mkExp (SOp LB32Eq args) =
1435 mkMethodOpChain1 (mkBoolToNumber integerType) integerType "equals" args
1436mkExp (SOp LB32Gt args) = mkLogicalBinOpExp integerType GThan args
1437mkExp (SOp LB32Gte args) = mkLogicalBinOpExp integerType GThanE args
1438mkExp (SOp LB32Plus args) = mkBinOpExp integerType Add args
1439mkExp (SOp LB32Minus args) = mkBinOpExp integerType Sub args
1440mkExp (SOp LB32Times args) = mkBinOpExp integerType Mult args
1441mkExp (SOp LB32UDiv args) = mkBinOpExpConv "longValue" LongT integerType Div args
1442mkExp (SOp LB32SDiv args) = mkBinOpExp integerType Div args
1443mkExp (SOp LB32URem args) = mkBinOpExpConv "longValue" LongT integerType Rem args
1444mkExp (SOp LB32SRem args) = mkBinOpExp integerType Rem args
1445mkExp (SOp LB32Shl args) = mkBinOpExp integerType LShift args
1446mkExp (SOp LB32LShr args) = mkBinOpExp integerType RRShift args
1447mkExp (SOp LB32AShr args) = mkBinOpExp integerType RShift args
1448mkExp (SOp LB32And args) = mkBinOpExp integerType And args
1449mkExp (SOp LB32Or args) = mkBinOpExp integerType Or args
1450mkExp (SOp LB32Xor args) = mkBinOpExp integerType Xor args
1451mkExp (SOp LB32Compl [var]) =
1452 PreBitCompl <$> mkVarAccess (Just $ integerType) var
1453mkExp (SOp LB32Z64 [var]) = mkZeroExt "longValue" 32 integerType longType var
1454mkExp (SOp LB32S64 [var]) = mkSignedExt "longValue" integerType longType var
1455mkExp (SOp LB32T8 [var]) =
1456 (\ var -> MethodInv
1457 $ TypeMethodCall (J.Name [Ident "Byte"])
1458 []
1459 (Ident "valueOf")
1460 [ MethodInv $ PrimaryMethodCall var [] (Ident "byteValue") [] ]
1462 <$> mkVarAccess (Just $ integerType) var
1463mkExp (SOp LB32T16 [var]) =
1464 (\ var -> MethodInv
1465 $ TypeMethodCall (J.Name [Ident "Short"])
1466 []
1467 (Ident "valueOf")
1468 [ MethodInv $ PrimaryMethodCall var [] (Ident "shortValue") [] ]
1470 <$> mkVarAccess (Just $ integerType) var
1471mkExp (SOp LB64Lt args) = mkLogicalBinOpExp longType LThan args
1472mkExp (SOp LB64Lte args) = mkLogicalBinOpExp longType LThanE args
1473mkExp (SOp LB64Eq args) =
1474 mkMethodOpChain1 (mkBoolToNumber longType) longType "equals" args
1475mkExp (SOp LB64Gt args) = mkLogicalBinOpExp longType GThan args
1476mkExp (SOp LB64Gte args) = mkLogicalBinOpExp longType GThanE args
1477mkExp (SOp LB64Plus args) = mkBinOpExp longType Add args
1478mkExp (SOp LB64Minus args) = mkBinOpExp longType Sub args
1479mkExp (SOp LB64Times args) = mkBinOpExp longType Mult args
1480mkExp (SOp LB64UDiv (arg:args)) = do
1481 (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)
1482 return $ foldl (\ exp arg ->
1483 MethodInv $ PrimaryMethodCall
1484 ( MethodInv $ PrimaryMethodCall
1485 ( MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1486 []
1487 (Ident "valueOf")
1488 [ exp ]
1490 []
1491 (Ident "divide")
1492 [ MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1493 []
1494 (Ident "valueOf")
1495 [ arg ]
1498 []
1499 (Ident "longValue")
1500 []
1501 )
1502 arg
1503 args
1504mkExp (SOp LB64SDiv args) = mkBinOpExp longType Div args
1505mkExp (SOp LB64URem (arg:args)) = do
1506 (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)
1507 return $ foldl (\ exp arg ->
1508 MethodInv $ PrimaryMethodCall
1509 ( MethodInv $ PrimaryMethodCall
1510 ( MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1511 []
1512 (Ident "valueOf")
1513 [ exp ]
1515 []
1516 (Ident "remainder")
1517 [ MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1518 []
1519 (Ident "valueOf")
1520 [ arg ]
1523 []
1524 (Ident "longValue")
1525 []
1526 )
1527 arg
1528 args
1529mkExp (SOp LB64SRem args) = mkBinOpExp longType Rem args
1530mkExp (SOp LB64Shl args) = mkBinOpExp longType LShift args
1531mkExp (SOp LB64LShr args) = mkBinOpExp longType RRShift args
1532mkExp (SOp LB64AShr args) = mkBinOpExp longType RShift args
1533mkExp (SOp LB64And args) = mkBinOpExp longType And args
1534mkExp (SOp LB64Or args) = mkBinOpExp longType Or args
1535mkExp (SOp LB64Xor args) = mkBinOpExp longType Xor args
1536mkExp (SOp LB64Compl [var]) =
1537 PreBitCompl <$> mkVarAccess (Just $ longType) var
1538mkExp (SOp LB64T8 [var]) =
1539 (\ var -> MethodInv
1540 $ TypeMethodCall (J.Name [Ident "Byte"])
1541 []
1542 (Ident "valueOf")
1543 [ MethodInv
1544 $ PrimaryMethodCall var [] (Ident "byteValue") []
1547 <$> mkVarAccess (Just $ longType) var
1548mkExp (SOp LB64T16 [var]) =
1549 (\ var -> MethodInv
1550 $ TypeMethodCall (J.Name [Ident "Short"])
1551 []
1552 (Ident "valueOf")
1553 [ MethodInv $ PrimaryMethodCall var [] (Ident "shortValue") [] ]
1555 <$> mkVarAccess (Just $ longType) var
1556mkExp (SOp LB64T32 [var]) =
1557 (\ var -> MethodInv
1558 $ TypeMethodCall (J.Name [Ident "Integer"])
1559 []
1560 (Ident "valueOf")
1561 [ MethodInv $ PrimaryMethodCall var [] (Ident "intValue") [] ]
1563 <$> mkVarAccess (Just $ longType) var
1564mkExp (SOp LIntB8 [arg]) = mkExp (SOp LB32T8 [arg])
1565mkExp (SOp LIntB16 [arg]) = mkExp (SOp LB32T16 [arg])
1566mkExp (SOp LIntB32 [arg]) = mkExp (SV arg)
1567mkExp (SOp LIntB64 [arg]) = mkExp (SOp LB32S64 [arg])
1568mkExp (SOp LB32Int [arg]) = mkExp (SV arg)
1569mkExp (SOp LFExp [arg]) = mkMathFun "exp" arg
1570mkExp (SOp LFLog [arg]) = mkMathFun "log" arg
1571mkExp (SOp LFSin [arg]) = mkMathFun "sin" arg
1572mkExp (SOp LFCos [arg]) = mkMathFun "cos" arg
1573mkExp (SOp LFTan [arg]) = mkMathFun "tan" arg
1574mkExp (SOp LFASin [arg]) = mkMathFun "asin" arg
1575mkExp (SOp LFACos [arg]) = mkMathFun "acos" arg
1576mkExp (SOp LFATan [arg]) = mkMathFun "atan" arg
1577mkExp (SOp LFSqrt [arg]) = mkMathFun "sqrt" arg
1578mkExp (SOp LFFloor [arg]) = mkMathFun "floor" arg
1579mkExp (SOp LFCeil [arg]) = mkMathFun "ceil" arg
1580mkExp (SOp LStrHead [arg]) = mkStringAtIndex arg (Lit $ Int 0)
1581mkExp (SOp LStrTail [arg]) =
1582 (\ var -> MethodInv $ PrimaryMethodCall (var)
1583 []
1584 (Ident "substring")
1585 [Lit $ Int 1]
1586 )
1587 <$> mkVarAccess (Just stringType) arg
1588mkExp (SOp LStrCons [c, cs]) =
1589 (\ cVar csVar -> MethodInv $
1590 PrimaryMethodCall ( MethodInv $ PrimaryMethodCall (InstanceCreation []
1591 (ClassType [(Ident "StringBuilder", [])])
1592 [csVar]
1593 Nothing
1595 []
1596 (Ident "insert")
1597 [ Lit $ Int 0,
1598 Cast (PrimType CharT)
1599 (MethodInv $ PrimaryMethodCall
1600 (cVar)
1601 []
1602 (Ident "intValue")
1603 []
1607 []
1608 (Ident "toString")
1609 []
1611 <$> mkVarAccess (Just integerType) c
1612 <*> mkVarAccess (Just stringType) cs
1613mkExp (SOp LStrIndex [str, i]) = mkVarAccess (Just integerType) i >>= mkStringAtIndex str
1614mkExp (SOp LStrRev [str]) =
1615 (\ var -> MethodInv $
1616 PrimaryMethodCall ( MethodInv $ PrimaryMethodCall (InstanceCreation []
1617 (ClassType [(Ident "StringBuffer", [])])
1618 [var]
1619 Nothing
1621 []
1622 (Ident "reverse")
1623 []
1625 []
1626 (Ident "toString")
1627 []
1629 <$> mkVarAccess (Just stringType) str
1630mkExp (SOp LStdIn []) = return $ mkSystemStd In
1631mkExp (SOp LStdOut []) = return $ mkSystemStd Out
1632mkExp (SOp LStdErr []) = return $ mkSystemStd Err
1633mkExp (SOp LFork [arg]) = mkThread arg
1634mkExp (SOp LPar [arg]) = mkExp (SV arg)
1635mkExp (SOp LVMPtr []) =
1636 return $ MethodInv $ TypeMethodCall (J.Name [Ident "Thread"]) [] (Ident "currentThread") []
1637mkExp (SOp LNoOp args) = mkExp . SV $ last args
1638mkExp (SNothing) = return $ Lit Null
1639mkExp (SError err) =
1640 return . MethodInv $
1641 PrimaryMethodCall (InstanceCreation []
1642 runtimeExceptionType
1643 [Lit $ String err]
1644 ( Just $ ClassBody
1645 [ MemberDecl $ MethodDecl [Public, Final]
1646 []
1647 (Just . RefType $ ClassRefType objectType)
1648 (Ident "throwSelf")
1649 []
1650 []
1651 ( MethodBody . Just $
1652 Block [ BlockStmt (Throw This) ]
1657 []
1658 (Ident "throwSelf")
1659 []
1660mkExp other = error (show other)