git.iko.soy/Idris-dev
on 7e29890 help sign in
Idris-dev/src/IRTS/CodegenJava.hs
1578 lines 69 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, foldl')
19import Data.Int
20import qualified Data.Text as T
21import qualified Data.Text.IO as TIO
22import Language.Java.Parser
23import Language.Java.Pretty
24import Language.Java.Syntax hiding (Name)
25import qualified Language.Java.Syntax as J
26import System.Directory
27import System.Exit
28import System.FilePath
29import System.IO
30import System.Process
32data CodeGenerationEnv = CodeGenerationEnv { globalVariablePositions :: [(Name, Integer)] }
34type CodeGeneration = StateT (CodeGenerationEnv) (Either String)
36codegenJava :: [(Name, SExp)] -> -- initialization of globals
37 [(Name, SDecl)] ->
38 FilePath -> -- output file name
39 [String] -> -- headers
40 [String] -> -- libs
41 OutputType ->
42 IO ()
43codegenJava globalInit defs out hdrs libs exec = do
44 withTempdir (takeBaseName out) $ \ tmpDir -> do
45 let srcdir = tmpDir </> "src" </> "main" </> "java"
46 createDirectoryIfMissing True srcdir
47 let (Ident clsName) =
48 either error id (evalStateT (mkClassName out) (mkCodeGenEnv globalInit))
49 let outjava = srcdir </> clsName <.> "java"
50 let jout = either error
51 (flatIndent . prettyPrint)
52 (evalStateT (mkCompilationUnit globalInit defs hdrs out) (mkCodeGenEnv globalInit))
53 writeFile outjava jout
54 if (exec == Raw)
55 then copyFile outjava (takeDirectory out </> clsName <.> "java")
56 else do
57 execPom <- getExecutablePom
58 execPomTemplate <- TIO.readFile execPom
59 let execPom = T.replace (T.pack "$MAIN-CLASS$")
60 (T.pack clsName)
61 (T.replace (T.pack "$ARTIFACT-NAME$")
62 (T.pack $ takeBaseName out)
63 (T.replace (T.pack "$DEPENDENCIES$")
64 (mkPomDependencies libs)
65 execPomTemplate
66 )
67 )
68 TIO.writeFile (tmpDir </> "pom.xml") execPom
69 mvnCmd <- getMvn
70 let args = ["-f", (tmpDir </> "pom.xml")]
71 (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ ["compile"]) ""
72 when (exit /= ExitSuccess) $ error ("FAILURE: " ++ mvnCmd ++ " compile\n" ++ err ++ mvout)
73 if (exec == Object)
74 then do
75 classFiles <-
76 map (\ clsFile -> tmpDir </> "target" </> "classes" </> clsFile)
77 . filter ((".class" ==) . takeExtension)
78 <$> getDirectoryContents (tmpDir </> "target" </> "classes")
79 mapM_ (\ clsFile -> copyFile clsFile (takeDirectory out </> takeFileName clsFile))
80 classFiles
81 else do
82 (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ ["package"]) ""
83 when (exit /= ExitSuccess) (error ("FAILURE: " ++ mvnCmd ++ " package\n" ++ err ++ mvout))
84 copyFile (tmpDir </> "target" </> (takeBaseName out) <.> "jar") out
85 handle <- openBinaryFile out ReadMode
86 contents <- TIO.hGetContents handle
87 hClose handle
88 handle <- openBinaryFile out WriteMode
89 TIO.hPutStr handle (T.append (T.pack jarHeader) contents)
90 hFlush handle
91 hClose handle
92 perms <- getPermissions out
93 setPermissions out (setOwnerExecutable True perms)
94 readProcess mvnCmd (args ++ ["clean"]) ""
95 removeFile (tmpDir </> "pom.xml")
97jarHeader :: String
98jarHeader =
99 "#!/bin/sh\n"
100 ++ "MYSELF=`which \"$0\" 2>/dev/null`\n"
101 ++ "[ $? -gt 0 -a -f \"$0\" ] && MYSELF=\"./$0\"\n"
102 ++ "java=java\n"
103 ++ "if test -n \"$JAVA_HOME\"; then\n"
104 ++ " java=\"$JAVA_HOME/bin/java\"\n"
105 ++ "fi\n"
106 ++ "exec \"$java\" $java_args -jar $MYSELF \"$@\""
107 ++ "exit 1\n"
109mkPomDependencies :: [String] -> T.Text
110mkPomDependencies deps =
111 T.concat $ map (T.concat . map (T.append (T.pack " ")) . mkDependency . T.pack) deps
112 where
113 mkDependency s =
114 case T.splitOn (T.pack ":") s of
115 [g, a, v] ->
116 [ T.pack $ "<dependency>\n"
117 , T.append (T.pack " ") $ mkGroupId g
118 , T.append (T.pack " ") $ mkArtifactId a
119 , T.append (T.pack " ") $ mkVersion v
120 , T.pack $ "</dependency>\n"
121 ]
122 _ -> []
123 mkGroupId g = T.append (T.pack $ "<groupId>") (T.append g $ T.pack "</groupId>\n")
124 mkArtifactId a = T.append (T.pack $ "<artifactId>") (T.append a $ T.pack "</artifactId>\n")
125 mkVersion v = T.append (T.pack $ "<version>") (T.append v $ T.pack "</version>\n")
127mkCodeGenEnv :: [(Name, SExp)] -> CodeGenerationEnv
128mkCodeGenEnv globalInit =
129 CodeGenerationEnv $ zipWith (\ (name, _) pos -> (name, pos)) globalInit [0..]
131mkCompilationUnit :: [(Name, SExp)] -> [(Name, SDecl)] -> [String] -> FilePath -> CodeGeneration CompilationUnit
132mkCompilationUnit globalInit defs hdrs out =
133 CompilationUnit Nothing ( [ ImportDecl False idrisRts True
134 , ImportDecl True idrisForeign True
135 , ImportDecl False bigInteger False
136 , ImportDecl False stringBuffer False
137 , ImportDecl False runtimeException False
138 , ImportDecl False scanner False
139 , ImportDecl False arrays False
140 ] ++ otherHdrs
141 )
142 <$> mkTypeDecl globalInit defs out
143 where
144 idrisRts = J.Name $ map Ident ["org", "idris", "rts"]
145 idrisForeign = J.Name $ map Ident ["org", "idris", "rts", "ForeignPrimitives"]
146 bigInteger = J.Name $ map Ident ["java", "math", "BigInteger"]
147 stringBuffer = J.Name $ map Ident ["java", "lang", "StringBuffer"]
148 runtimeException = J.Name $ map Ident ["java", "lang", "RuntimeException"]
149 scanner = J.Name $ map Ident ["java", "util", "Scanner"]
150 arrays = J.Name $ map Ident ["java", "util", "Arrays"]
151 otherHdrs = map ( (\ name -> ImportDecl False name False)
152 . J.Name
153 . map (Ident . T.unpack)
154 . T.splitOn (T.pack ".")
155 . T.pack)
156 $ filter (not . isSuffixOf ".h") hdrs
158flatIndent :: String -> String
159flatIndent (' ' : ' ' : xs) = flatIndent xs
160flatIndent (x:xs) = x:flatIndent xs
161flatIndent [] = []
163prefixCallNamespaces :: Ident -> SExp -> SExp
164prefixCallNamespaces (Ident name) (SApp tail (NS n ns) args) = SApp tail (NS n (name:ns)) args
165prefixCallNamespaces name (SLet var e1 e2) = SLet var (prefixCallNamespaces name e1) (prefixCallNamespaces name e2)
166prefixCallNamespaces name (SUpdate var e) = SUpdate var (prefixCallNamespaces name e)
167prefixCallNamespaces name (SCase var alts) = SCase var (map (prefixCallNamespacesCase name) alts)
168prefixCallNamespaces name (SChkCase var alts) = SChkCase var (map (prefixCallNamespacesCase name) alts)
169prefixCallNamespaces _ exp = exp
171prefixCallNamespacesCase :: Ident -> SAlt -> SAlt
172prefixCallNamespacesCase name (SConCase x y n ns e) = SConCase x y n ns (prefixCallNamespaces name e)
173prefixCallNamespacesCase name (SConstCase c e) = SConstCase c (prefixCallNamespaces name e)
174prefixCallNamespacesCase name (SDefaultCase e) = SDefaultCase (prefixCallNamespaces name e)
176prefixCallNamespacesDecl :: Ident -> SDecl -> SDecl
177prefixCallNamespacesDecl name (SFun fname args i e) = SFun fname args i (prefixCallNamespaces name e)
179mkTypeDecl :: [(Name, SExp)] -> [(Name, SDecl)] -> FilePath -> CodeGeneration [TypeDecl]
180mkTypeDecl globalInit defs out =
181 (\ name body -> [ClassTypeDecl $ ClassDecl [ Public
182 , Annotation $ SingleElementAnnotation
183 (J.Name [Ident "SuppressWarnings"])
184 (EVVal . InitExp . Lit $ String "unchecked")
185 ]
186 name
187 []
188 Nothing
189 []
190 body])
191 <$> mkClassName out
192 <*> ( mkClassName out
193 >>= (\ ident -> mkClassBody globalInit (map (second (prefixCallNamespacesDecl ident)) defs))
194 )
196mkClassName :: FilePath -> CodeGeneration Ident
197mkClassName path =
198 T.lift $ left (\ err -> "Parser error in \"" ++ path ++ "\": " ++ (show err))
199 (parser ident . takeBaseName $ takeFileName path)
201mkClassBody :: [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration ClassBody
202mkClassBody globalInit defs =
203 (\ globals defs -> ClassBody . (globals++) . addMainMethod . mergeInnerClasses $ defs)
204 <$> mkGlobalContext globalInit
205 <*> mapM mkDecl defs
207mkGlobalContext :: [(Name, SExp)] -> CodeGeneration [Decl]
208mkGlobalContext [] = return []
209mkGlobalContext initExps =
210 (\ exps -> [ MemberDecl $ FieldDecl [Private, Static, Final]
211 objectArrayType
212 [VarDecl (VarId $ Ident "globalContext")
213 (Just . InitArray $ ArrayInit exps)
214 ]
215 ]
216 )
217 <$> mapM (\ (_, exp) -> InitExp <$> mkExp exp) initExps
221addMainMethod :: [Decl] -> [Decl]
222addMainMethod decls
223 | findMain decls = mkMainMethod : decls
224 | otherwise = decls
225 where
226 findMain ((MemberDecl (MemberClassDecl (ClassDecl _ (Ident "Main") _ _ _ (ClassBody body)))):_) =
227 findMainMethod body
228 findMain (_:decls) = findMain decls
229 findMain [] = False
231 findMainMethod ((MemberDecl (MethodDecl _ _ _ (Ident "main") [] _ _)):_) = True
232 findMainMethod (_:decls) = findMainMethod decls
233 findMainMethod [] = False
235mkMainMethod :: Decl
236mkMainMethod =
237 MemberDecl $ MethodDecl [Public, Static]
238 []
239 Nothing
240 (Ident "main")
241 [FormalParam [] stringArrayType False (VarId $ Ident "args")]
242 []
243 (MethodBody . Just $ Block [ BlockStmt . ExpStmt . MethodInv $
244 MethodCall (J.Name [Ident "idris_initArgs"])
245 [ MethodInv $ TypeMethodCall
246 (J.Name [Ident "Thread"])
247 []
248 (Ident "currentThread")
249 []
250 , ExpName $ J.Name [Ident "args"]
251 ]
252 , BlockStmt . ExpStmt . MethodInv $
253 MethodCall (J.Name [Ident "runMain_0"])
254 []
255 ]
256 )
258mergeInnerClasses :: [Decl] -> [Decl]
259mergeInnerClasses = foldl' mergeInner []
260 where
261 mergeInner ((decl@(MemberDecl (MemberClassDecl (ClassDecl priv name targs ext imp (ClassBody body))))):decls)
262 decl'@(MemberDecl (MemberClassDecl (ClassDecl _ name' _ ext' imp' (ClassBody body'))))
263 | name == name' =
264 (MemberDecl $ MemberClassDecl $
265 ClassDecl priv
266 name
267 targs
268 (mplus ext ext')
269 (imp ++ imp')
270 (ClassBody $ mergeInnerClasses (body ++ body')))
271 : decls
272 | otherwise = decl:(mergeInner decls decl')
273 mergeInner (decl:decls) decl' = decl:(mergeInner decls decl')
274 mergeInner [] decl' = [decl']
277mkIdentifier :: Name -> CodeGeneration Ident
278mkIdentifier (NS name _) = mkIdentifier name
279mkIdentifier (MN i name) = (\ (Ident x) -> Ident $ x ++ ('_' : show i))
280 <$> mkIdentifier (UN name)
281mkIdentifier (UN name) =
282 T.lift $ left (\ err -> "Parser error in \"" ++ name ++ "\": " ++ (show err))
283 ( parser ident
284 . cleanReserved
285 . cleanNonLetter
286 . cleanStart
287 $ cleanWs False name)
288 where
289 cleanStart (x:xs)
290 | isNumber x = '_' : (x:xs)
291 | otherwise = (x:xs)
292 cleanStart [] = []
293 cleanNonLetter (x:xs)
294 | x == '#' = "_Hash" ++ cleanNonLetter xs
295 | x == '@' = "_At" ++ cleanNonLetter xs
296 | x == '$' = "_Dollar" ++ cleanNonLetter xs
297 | x == '!' = "_Bang" ++ cleanNonLetter xs
298 | x == '.' = "_Dot" ++ cleanNonLetter xs
299 | x == '\'' = "_Prime" ++ cleanNonLetter xs
300 | x == '*' = "_Times" ++ cleanNonLetter xs
301 | x == '+' = "_Plus" ++ cleanNonLetter xs
302 | x == '/' = "_Divide" ++ cleanNonLetter xs
303 | x == '-' = "_Minus" ++ cleanNonLetter xs
304 | x == '%' = "_Mod" ++ cleanNonLetter xs
305 | x == '<' = "_LessThan" ++ cleanNonLetter xs
306 | x == '=' = "_Equals" ++ cleanNonLetter xs
307 | x == '>' = "_MoreThan" ++ cleanNonLetter xs
308 | x == '[' = "_LSBrace" ++ cleanNonLetter xs
309 | x == ']' = "_RSBrace" ++ cleanNonLetter xs
310 | x == '(' = "_LBrace" ++ cleanNonLetter xs
311 | x == ')' = "_RBrace" ++ cleanNonLetter xs
312 | x == '_' = "__" ++ cleanNonLetter xs
313 | not (isAlphaNum x) = "_" ++ (show $ ord x) ++ xs
314 | otherwise = x:cleanNonLetter xs
315 cleanNonLetter [] = []
316 cleanWs capitalize (x:xs)
317 | isSpace x = cleanWs True xs
318 | capitalize = (toUpper x) : (cleanWs False xs)
319 | otherwise = x : (cleanWs False xs)
320 cleanWs _ [] = []
323 cleanReserved "param" = "_param"
324 cleanReserved "globalContext" = "_globalContext"
325 cleanReserved "context" = "_context"
326 cleanReserved "newcontext" = "_newcontext"
328 cleanReserved "void" = "_void"
329 cleanReserved "null" = "_null"
330 cleanReserved "int" = "_int"
331 cleanReserved "long" = "_long"
332 cleanReserved "char" = "_char"
333 cleanReserved "byte" = "_byte"
334 cleanReserved "double" = "_double"
335 cleanReserved "float" = "_float"
336 cleanReserved "boolean" = "_boolean"
337 cleanReserved "Object" = "_Object"
338 cleanReserved "String" = "_String"
339 cleanReserved "StringBuilder" = "_StringBuilder"
340 cleanReserved "StringBuffer" = "_StringBuffer"
341 cleanReserved "Scanner" = "_Scanner"
342 cleanReserved "Integer" = "_Integer"
343 cleanReserved "Double" = "_Double"
344 cleanReserved "Byte" = "_Byte"
345 cleanReserved "Character" = "_Character"
346 cleanReserved "BigInteger" = "_BigInteger"
347 cleanReserved "Boolean" = "_Boolean"
348 cleanReserved "Closure" = "_Closure"
349 cleanReserved "IdrisObject" = "_IdrisObject"
350 cleanReserved "TailCallClosure" = "_TailCallClosure"
351 cleanReserved "System" = "_System"
352 cleanReserved "Math" = "_Math"
353 cleanReserved "Arrays" = "_Arrays"
354 cleanReserved "RuntimeException" = "_RuntimeException"
355 cleanReserved "Comparable" = "_Comparable"
357 cleanReserved "class" = "_class"
358 cleanReserved "enum" = "_enum"
359 cleanReserved "interface" = "_interface"
360 cleanReserved "extends" = "_extends"
361 cleanReserved "implements" = "_implements"
362 cleanReserved "public" = "_public"
363 cleanReserved "private" = "_private"
364 cleanReserved "protected" = "_protected"
365 cleanReserved "static" = "_static"
366 cleanReserved "final" = "_final"
367 cleanReserved "abstract" = "_abstract"
368 cleanReserved "strict" = "_strict"
369 cleanReserved "volatile" = "_volatile"
370 cleanReserved "transient" = "_transient"
371 cleanReserved "native" = "_native"
372 cleanReserved "const" = "_const"
374 cleanReserved "import" = "_import"
375 cleanReserved "package" = "_package"
377 cleanReserved "throw" = "_throw"
378 cleanReserved "throws" = "_throws"
379 cleanReserved "try" = "_try"
380 cleanReserved "catch" = "_catch"
382 cleanReserved "synchronized" = "_synchronized"
384 cleanReserved "if" = "_if"
385 cleanReserved "else" = "_else"
386 cleanReserved "switch" = "_switch"
387 cleanReserved "case" = "_case"
388 cleanReserved "default" = "_default"
390 cleanReserved "while" = "_while"
391 cleanReserved "for" = "_for"
392 cleanReserved "do" = "_do"
393 cleanReserved "break" = "_break"
394 cleanReserved "continue" = "_continue"
395 cleanReserved "goto" = "_goto"
397 cleanReserved "this" = "_this"
398 cleanReserved "super" = "_super"
399 cleanReserved "new" = "_new"
400 cleanReserved "return" = "_return"
402 cleanReserved "idris_initArgs" = "_idris_initArgs"
403 cleanReserved "idris_numArgs" = "_idris_numArgs"
404 cleanReserved "idris_getArg" = "_idris_getArg"
405 cleanReserved "getenv" = "_getenv"
406 cleanReserved "exit" = "_exit"
407 cleanReserved "usleep" = "_usleep"
408 cleanReserved "idris_sendMessage" = "_idris_sendMessage"
409 cleanReserved "idris_checkMessage" = "_idris_checkMessage"
410 cleanReserved "idris_recvMessage" = "_idris_recvMessage"
411 cleanReserved "putStr" = "_putStr"
412 cleanReserved "putchar" = "_putchar"
413 cleanReserved "getchar" = "_getchar"
414 cleanReserved "fileOpen" = "_fileOpen"
415 cleanReserved "fileClose" = "_fileClose"
416 cleanReserved "fputStr" = "_fputStr"
417 cleanReserved "fileEOF" = "_fileEOF"
418 cleanReserved "isNull" = "_isNull"
419 cleanReserved "idris_K" = "_idris_K"
420 cleanReserved "idris_flipK" = "_idris_flipK"
421 cleanReserved "idris_assignStack" = "_idris_assignStack"
422 cleanReserved "free" = "_free"
423 cleanReserved "malloc" = "_malloc"
424 cleanReserved "idris_memset" = "_idris_memset"
425 cleanReserved "idris_peek" = "_idris_peek"
426 cleanReserved "idris_poke" = "_idris_poke"
427 cleanReserved "idris_memmove" = "_idris_memmove"
429 cleanReserved x = x
431mkName :: Name -> CodeGeneration J.Name
432mkName (NS name nss) = (\ n ns -> J.Name (n:ns))
433 <$> mkIdentifier name
434 <*> mapM (mkIdentifier . UN) nss
435mkName n = J.Name . (:[]) <$> mkIdentifier n
437voidType :: ClassType
438voidType = ClassType [(Ident "Void", [])]
440objectType :: ClassType
441objectType = ClassType [(Ident "Object", [])]
443objectArrayType :: Language.Java.Syntax.Type
444objectArrayType = RefType . ArrayType . RefType . ClassRefType $ objectType
446idrisClosureType :: ClassType
447idrisClosureType = ClassType [(Ident "Closure", [])]
449idrisTailCallClosureType :: ClassType
450idrisTailCallClosureType = ClassType [(Ident "TailCallClosure", [])]
452idrisObjectType :: ClassType
453idrisObjectType = ClassType [(Ident "IdrisObject", [])]
455contextArray :: LVar -> Exp
456contextArray (Loc _) = ExpName $ J.Name [Ident "context"]
457contextArray (Glob _) = ExpName $ J.Name [Ident "globalContext"]
459charType :: ClassType
460charType = ClassType [(Ident "Character", [])]
462byteType :: ClassType
463byteType = ClassType [(Ident "Byte", [])]
465shortType :: ClassType
466shortType = ClassType [(Ident "Short", [])]
468integerType :: ClassType
469integerType = ClassType [(Ident "Integer", [])]
471longType :: ClassType
472longType = ClassType [(Ident "Long", [])]
474nextIntTy :: IntTy -> IntTy
475nextIntTy IT8 = IT16
476nextIntTy IT16 = IT32
477nextIntTy IT32 = IT64
478nextIntTy IT64 = IT64
479nextIntTy ITNative = IT64
481intTyToIdent :: IntTy -> Ident
482intTyToIdent IT8 = Ident "Byte"
483intTyToIdent IT16 = Ident "Short"
484intTyToIdent IT32 = Ident "Integer"
485intTyToIdent IT64 = Ident "Long"
486intTyToIdent ITNative = Ident "Integer"
487intTyToIdent ITBig = Ident "BigInteger"
489intTyToClass :: IntTy -> ClassType
490intTyToClass ty = ClassType [(intTyToIdent ty, [])]
492intTyToMethod :: IntTy -> String
493intTyToMethod IT8 = "byteValue"
494intTyToMethod IT16 = "shortValue"
495intTyToMethod IT32 = "intValue"
496intTyToMethod IT64 = "longValue"
497intTyToMethod ITNative = "intValue"
499intTyToPrimTy :: IntTy -> PrimType
500intTyToPrimTy IT8 = ByteT
501intTyToPrimTy IT16 = ShortT
502intTyToPrimTy IT32 = IntT
503intTyToPrimTy IT64 = LongT
504intTyToPrimTy ITNative = IntT
506bigIntegerType :: ClassType
507bigIntegerType = ClassType [(Ident "BigInteger", [])]
509doubleType :: ClassType
510doubleType = ClassType [(Ident "Double", [])]
512stringType :: ClassType
513stringType = ClassType [(Ident "String", [])]
515stringArrayType :: Language.Java.Syntax.Type
516stringArrayType = RefType . ArrayType . RefType . ClassRefType $ stringType
518exceptionType :: ClassType
519exceptionType = ClassType [(Ident "Throwable", [])]
521runtimeExceptionType :: ClassType
522runtimeExceptionType = ClassType [(Ident "RuntimeException", [])]
524comparableType :: ClassType
525comparableType = ClassType [(Ident "Comparable", [])]
527mkDecl :: (Name, SDecl) -> CodeGeneration Decl
528mkDecl ((NS n (ns:nss)), decl) =
529 (\ name body -> MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body)
530 <$> mkIdentifier (UN ns)
531 <*> mkClassBody [] [(NS n nss, decl)]
532mkDecl (_, SFun name params stackSize body) =
533 (\ name params paramNames methodBody ->
534 MemberDecl $ MethodDecl [Public, Static]
535 []
536 (Just . RefType $ ClassRefType objectType)
537 name
538 params
539 []
540 (MethodBody . Just $ Block
541 [ LocalVars [Final]
542 objectArrayType
543 [ VarDecl (VarDeclArray . VarId $ Ident "context")
544 (Just . InitArray . ArrayInit $
545 paramNames
546 ++ replicate stackSize (InitExp . Lit $ Null))
547 ]
548 , BlockStmt . Return $ Just methodBody
549 ]
550 )
551 )
552 <$> mkIdentifier name
553 <*> mapM mkFormalParam params
554 <*> mapM (\ p -> (InitExp . ExpName) <$> mkName p) params
555 <*> mkExp body
558mkClosure :: [Name] -> Int -> SExp -> CodeGeneration Exp
559mkClosure params stackSize body =
560 (\ paramArray body ->
561 InstanceCreation []
562 idrisClosureType
563 [paramArray]
564 (Just $ ClassBody [body])
565 )
566 <$> mkStackInit params stackSize
567 <*> mkClosureCall body
569mkFormalParam :: Name -> CodeGeneration FormalParam
570mkFormalParam name =
571 (\ name -> FormalParam [Final] (RefType . ClassRefType $ objectType) False (VarId name))
572 <$> mkIdentifier name
574mkClosureCall :: SExp -> CodeGeneration Decl
575mkClosureCall body =
576 (\ body -> MemberDecl $ MethodDecl [Public] [] (Just . RefType $ ClassRefType objectType) (Ident "call") [] [] body)
577 <$> mkMethodBody body
579mkMethodBody :: SExp -> CodeGeneration MethodBody
580mkMethodBody exp =
581 (\ exp -> MethodBody . Just . Block $ [BlockStmt . Return . Just $ exp])
582 <$> mkExp exp
584mkStackInit :: [Name] -> Int -> CodeGeneration Exp
585mkStackInit params stackSize =
586 (\ localVars -> ArrayCreateInit objectArrayType 0 . ArrayInit $
587 (map (InitExp . ExpName) localVars)
588 ++ (replicate (stackSize) (InitExp $ Lit Null)))
589 <$> mapM mkName params
591mkK :: Exp -> Exp -> Exp
592mkK result drop =
593 MethodInv $ MethodCall (J.Name [Ident "idris_K"]) [ result, drop ]
595mkFlipK :: Exp -> Exp -> Exp
596mkFlipK drop result =
597 MethodInv $ MethodCall (J.Name [Ident "idris_flipK"]) [ drop, result ]
599mkLet :: LVar -> SExp -> SExp -> CodeGeneration Exp
600mkLet (Loc pos) oldExp newExp =
601 (\ oldExp newExp ->
602 mkFlipK ( Assign ( ArrayLhs $ ArrayIndex (ExpName $ J.Name [Ident "context"])
603 (Lit $ Int (toInteger pos)))
604 EqualA
605 newExp
606 )
607 oldExp
608 )
609 <$> mkExp oldExp
610 <*> mkExp newExp
611mkLet (Glob _) _ _ = T.lift $ Left "Cannot let bind to global variable"
613reverseNameSpace :: J.Name -> J.Name
614reverseNameSpace (J.Name ids) =
615 J.Name ((tail ids) ++ [head ids])
617mkCase :: Bool -> LVar -> [SAlt] -> CodeGeneration Exp
618mkCase checked var ((SConCase parentStackPos consIndex _ params branchExpression):cases) =
619 mkConsCase checked
620 var
621 parentStackPos
622 consIndex
623 params
624 branchExpression
625 (SCase var cases)
626mkCase checked var (c@(SConstCase constant branchExpression):cases) =
627 (\ constant branchExpression alternative var->
628 Cond ( MethodInv $ PrimaryMethodCall (constant)
629 []
630 (Ident "equals")
631 [var]
632 )
633 branchExpression
634 alternative
635 )
636 <$> mkExp (SConst constant)
637 <*> mkExp branchExpression
638 <*> mkCase checked var cases
639 <*> mkVarAccess Nothing var
640mkCase checked var (SDefaultCase exp:cases) = mkExp exp
641mkCase checked _ [] = mkExp (SError "Non-exhaustive pattern")
643mkConsCase :: Bool -> LVar -> Int -> Int -> [Name] -> SExp -> SExp -> CodeGeneration Exp
644mkConsCase checked
645 toDeconstruct
646 parentStackStart
647 consIndex
648 params
649 branchExpression
650 alternative =
651 (\ caseBinding alternative var varCasted->
652 Cond (BinOp (InstanceOf (var)
653 (ClassRefType idrisObjectType)
654 )
655 CAnd
656 ( BinOp
657 ( MethodInv $ PrimaryMethodCall (varCasted)
658 []
659 (Ident "getConstructorId")
660 []
661 )
662 Equal
663 (Lit $ Int (toInteger consIndex))
664 )
665 )
666 (caseBinding)
667 alternative
668 )
669 <$> mkCaseBinding checked toDeconstruct parentStackStart params branchExpression
670 <*> mkExp alternative
671 <*> mkVarAccess (Nothing) toDeconstruct
672 <*> mkVarAccess (Just idrisObjectType) toDeconstruct
675mkCaseBinding :: Bool -> LVar -> Int -> [Name] -> SExp -> CodeGeneration Exp
676mkCaseBinding True var parentStackStart params branchExpression =
677 (\ branchExpression deconstruction ->
678 mkFlipK (MethodInv $ MethodCall (J.Name [Ident "idris_assignStack"])
679 ( (ExpName $ J.Name [Ident "context"])
680 : (Lit $ Int (toInteger parentStackStart))
681 : deconstruction
682 ))
683 (branchExpression)
684 )
685 <$> mkExp branchExpression
686 <*> mkCaseBindingDeconstruction var params
687mkCaseBinding False var parentStackStart params branchExpression =
688 (\ bindingMethod deconstruction ->
689 MethodInv $ PrimaryMethodCall
690 ( MethodInv $ PrimaryMethodCall (InstanceCreation []
691 (ClassType [(Ident "Object", [])])
692 []
693 (Just $ ClassBody [MemberDecl $ bindingMethod])
694 )
695 []
696 (Ident "apply")
697 ( contextArray (Loc undefined) : deconstruction )
698 )
699 []
700 (Ident "call")
701 []
702 )
703 <$> mkCaseBindingMethod parentStackStart params branchExpression
704 <*> mkCaseBindingDeconstruction var params
706mkCaseBindingDeconstruction :: LVar -> [Name] -> CodeGeneration [Exp]
707mkCaseBindingDeconstruction var members =
708 mapM (mkProjection var) ([0..(length members - 1)])
710mkCaseBindingMethod :: Int -> [Name] -> SExp -> CodeGeneration MemberDecl
711mkCaseBindingMethod parentStackStart params branchExpression =
712 (\ formalParams caseBindingStack branchExpression ->
713 MethodDecl [Final, Public]
714 []
715 (Just . RefType $ ClassRefType idrisClosureType)
716 (Ident "apply")
717 (mkContextParam:formalParams)
718 []
719 (MethodBody . Just . Block $
720 caseBindingStack ++
721 [BlockStmt . Return $ Just branchExpression]))
722 <$> mapM mkFormalParam params
723 <*> mkBindingStack False parentStackStart params
724 <*> mkBindingClosure branchExpression
726mkContextParam :: FormalParam
727mkContextParam =
728 FormalParam [Final] (objectArrayType) False (VarId (Ident "context"))
730mkBindingClosure :: SExp -> CodeGeneration Exp
731mkBindingClosure oldExp =
732 (\ oldCall ->
733 InstanceCreation []
734 idrisClosureType
735 [ ExpName $ J.Name [Ident "new_context"] ]
736 (Just $ ClassBody [oldCall])
737 )
738 <$> mkClosureCall oldExp
741mkBindingStack :: Bool -> Int -> [Name] -> CodeGeneration [BlockStmt]
742mkBindingStack checked parentStackStart params =
743 (\ paramNames ->
744 ( LocalVars [Final]
745 objectArrayType
746 [ VarDecl (VarDeclArray . VarId $ Ident "new_context")
747 (Just . InitExp $ mkContextCopy checked parentStackStart params)
748 ])
749 : ( map (\ (param, pos) ->
750 BlockStmt . ExpStmt $
751 Assign (ArrayLhs $ ArrayIndex (ExpName $ J.Name [Ident "new_context"])
752 (Lit $ Int (toInteger pos)))
753 EqualA
754 (ExpName param)) $ zip paramNames [parentStackStart..]
755 )
756 )
757 <$> mapM mkName params
759mkContextCopy :: Bool -> Int -> [Name] -> Exp
760mkContextCopy True parentStackStart params =
761 MethodInv $ PrimaryMethodCall (ExpName $ J.Name [Ident "context"])
762 []
763 (Ident "clone")
764 []
765mkContextCopy False parentStackStart params =
766 MethodInv $ TypeMethodCall (J.Name [Ident "Arrays"])
767 []
768 (Ident "copyOf")
769 [ ExpName $ J.Name [Ident "context"]
770 , MethodInv
771 $ TypeMethodCall (J.Name [Ident "Math"])
772 []
773 (Ident "max")
774 [ FieldAccess $ PrimaryFieldAccess (ExpName $ J.Name [Ident "context"])
775 (Ident "length")
776 , Lit . Int $ toInteger (parentStackStart + length params)
777 ]
778 ]
780mkProjection :: LVar -> Int -> CodeGeneration Exp
781mkProjection var memberNr =
782 (\ var -> ArrayAccess $ ArrayIndex ( MethodInv $ PrimaryMethodCall
783 (var)
784 []
785 (Ident "getData")
786 []
787 )
788 (Lit $ Int (toInteger memberNr))
789 )
790 <$> mkVarAccess (Just idrisObjectType) var
792type ClassName = String
794mkPrimitive :: ClassName -> Literal -> Exp
795mkPrimitive className value =
796 MethodInv $ TypeMethodCall (J.Name [Ident className])
797 []
798 (Ident "valueOf")
799 [Lit $ value]
801mkClass :: ClassType -> Exp
802mkClass classType =
803 ClassLit . Just . RefType .ClassRefType $ classType
805mkBinOpExp :: ClassType -> Op -> [LVar] -> CodeGeneration Exp
806mkBinOpExp castTo op (var:vars) = do
807 start <- mkVarAccess (Just castTo) var
808 foldM (\ exp var -> BinOp exp op <$> mkVarAccess (Just castTo) var) start vars
810mkBinOpExpTrans :: (Exp -> Exp) -> (Exp -> Exp) -> ClassType -> Op -> [LVar] -> CodeGeneration Exp
811mkBinOpExpTrans opTransformation resultTransformation castTo op (var:vars) = do
812 start <- (mkVarAccess (Just castTo) var)
813 foldM (\ exp var -> resultTransformation
814 . BinOp (opTransformation exp) op
815 . opTransformation
816 <$> mkVarAccess (Just castTo) var)
817 start
818 vars
820mkBinOpExpConv :: String -> PrimType -> ClassType -> Op -> [LVar] -> CodeGeneration Exp
821mkBinOpExpConv fromMethodName toType fromType@(ClassType [(cls@(Ident _), [])]) op args =
822 mkBinOpExpTrans (\ exp -> MethodInv $ TypeMethodCall (J.Name [cls])
823 []
824 (Ident fromMethodName)
825 [exp]
826 )
827 (\ exp -> MethodInv $ TypeMethodCall (J.Name [cls])
828 []
829 (Ident "valueOf")
830 [Cast (PrimType $ toType) exp]
831 )
832 fromType
833 op
834 args
836mkLogicalBinOpExp :: ClassType -> Op -> [LVar] -> CodeGeneration Exp
837mkLogicalBinOpExp castTo op (var:vars) = do
838 start <- mkVarAccess (Just castTo) var
839 foldM (\ exp var -> mkBoolToNumber castTo . BinOp exp op <$> mkVarAccess (Just castTo) var)
840 start
841 vars
843mkMethodOpChain1 :: (Exp -> Exp) -> ClassType -> String -> [LVar] -> CodeGeneration Exp
844mkMethodOpChain1 = mkMethodOpChain id
846mkMethodOpChain :: (Exp -> Exp) -> (Exp -> Exp) -> ClassType -> String -> [LVar] -> CodeGeneration Exp
847mkMethodOpChain initialTransformation resultTransformation castTo method (arg:args) = do
848 start <- initialTransformation <$> mkVarAccess (Just $ castTo) arg
849 foldM (\ exp arg' ->
850 resultTransformation
851 . MethodInv
852 . PrimaryMethodCall exp [] (Ident method)
853 . (:[])
854 <$> mkVarAccess (Just $ castTo) arg'
855 )
856 start
857 args
859mkBoolToNumber :: ClassType -> Exp -> Exp
860mkBoolToNumber (ClassType [(Ident name, [])]) boolExp =
861 Cond boolExp (mkPrimitive name (Int 1)) (mkPrimitive name (Int 0))
863mkZeroExt :: String -> Int -> ClassType -> ClassType -> LVar -> CodeGeneration Exp
864mkZeroExt toMethod bits fromType toType@(ClassType [(toTypeName, [])]) var = do
865 (\ var sext ->
866 MethodInv $ TypeMethodCall (J.Name [toTypeName])
867 []
868 (Ident "valueOf")
869 [ Cond ( BinOp (var)
870 LThan
871 (Lit $ Int 0)
872 )
873 ( BinOp (Lit $ Int (2^bits))
874 Add
875 (sext)
876 )
877 sext
878 ]
879 )
880 <$> mkVarAccess (Just $ fromType) var
881 <*> mkSignedExt' toMethod fromType var
883mkSignedExt :: String -> ClassType -> ClassType -> LVar -> CodeGeneration Exp
884mkSignedExt toMethod fromType (ClassType [(toTypeName, [])]) var =
885 (\ sext -> MethodInv $ TypeMethodCall (J.Name [toTypeName])
886 []
887 (Ident "valueOf")
888 [ sext ]
889 )
890 <$> mkSignedExt' toMethod fromType var
892mkSignedExt' :: String -> ClassType -> LVar -> CodeGeneration Exp
893mkSignedExt' toMethod fromType var =
894 (\ var -> MethodInv $ PrimaryMethodCall (var)
895 []
896 (Ident toMethod)
897 []
898 )
899 <$> mkVarAccess (Just $ fromType) var
901data SPartialOrder
902 = SLt
903 | SLe
904 | SEq
905 | SGe
906 | SGt
908mkPartialOrder :: SPartialOrder -> Exp -> Exp
909mkPartialOrder SLt x = (BinOp (Lit $ Int (-1)) Equal x)
910mkPartialOrder SLe x =
911 BinOp (BinOp (Lit $ Int (-1)) Equal x)
912 COr
913 (BinOp (Lit $ Int 0) Equal x)
914mkPartialOrder SEq x = BinOp (Lit $ Int 0) Equal x
915mkPartialOrder SGe x =
916 BinOp (BinOp (Lit $ Int 1) Equal x)
917 COr
918 (BinOp (Lit $ Int 0) Equal x)
919mkPartialOrder SGt x = (BinOp (Lit $ Int 1) Equal x)
921varPos :: LVar -> CodeGeneration Integer
922varPos (Loc i) = return (toInteger i)
923varPos (Glob name) = do
924 positions <- globalVariablePositions <$> get
925 case lookup name positions of
926 (Just pos) -> return pos
927 Nothing -> T.lift . Left $ "Invalid global variable id: " ++ show name
929mkVarAccess :: Maybe ClassType -> LVar -> CodeGeneration Exp
930mkVarAccess Nothing var =
931 (\ pos -> ArrayAccess $ ArrayIndex (contextArray var) (Lit $ Int pos))
932 <$> varPos var
933mkVarAccess (Just castTo) var =
934 Cast (RefType . ClassRefType $ castTo) <$> (mkVarAccess Nothing var)
936mkPrimitiveCast :: ClassType -> ClassType -> LVar -> CodeGeneration Exp
937mkPrimitiveCast fromType (ClassType [(toType, [])]) var =
938 (\ var ->
939 MethodInv $ TypeMethodCall (J.Name [toType])
940 []
941 (Ident "valueOf")
942 [var]
943 )
944 <$> mkVarAccess (Just fromType) var
946mkToString :: ClassType -> LVar -> CodeGeneration Exp
947mkToString castTo var =
948 (\ var -> MethodInv $ PrimaryMethodCall (var)
949 []
950 (Ident "toString")
951 []
952 )
953 <$> mkVarAccess (Just castTo) var
954data Std = In | Out | Err
956instance Show Std where
957 show In = "in"
958 show Out = "out"
959 show Err = "err"
961mkSystemStd :: Std -> Exp
962mkSystemStd std = FieldAccess $ PrimaryFieldAccess (ExpName $ J.Name [Ident "System"]) (Ident $ show std)
964mkSystemOutPrint :: Exp -> Exp
965mkSystemOutPrint value =
966 MethodInv $ PrimaryMethodCall (mkSystemStd Out)
967 []
968 (Ident "print")
969 [value]
971mkMathFun :: String -> LVar -> CodeGeneration Exp
972mkMathFun funName var =
973 (\ var -> MethodInv $ TypeMethodCall (J.Name [Ident "Double"])
974 []
975 (Ident "valueOf")
976 [ MethodInv $ TypeMethodCall (J.Name [Ident "Math"])
977 []
978 (Ident funName)
979 [var]
980 ]
981 )
982 <$> mkVarAccess (Just doubleType) var
984mkStringAtIndex :: LVar -> Exp -> CodeGeneration Exp
985mkStringAtIndex var indexExp =
986 (\ var -> MethodInv $ TypeMethodCall (J.Name [Ident "Integer"])
987 []
988 (Ident "valueOf")
989 [ MethodInv $ PrimaryMethodCall (var)
990 []
991 (Ident "charAt")
992 [indexExp]
993 ]
994 )
995 <$> mkVarAccess (Just stringType) var
997mkForeignType :: FType -> Maybe ClassType
998mkForeignType (FInt ty) = return (intTyToClass ty)
999mkForeignType FChar = return integerType
1000mkForeignType FString = return stringType
1001mkForeignType FPtr = return objectType
1002mkForeignType FDouble = return doubleType
1003mkForeignType FAny = return objectType
1004mkForeignType FUnit = Nothing
1006mkForeignVarAccess :: FType -> LVar -> CodeGeneration Exp
1007mkForeignVarAccess (FInt ty) var =
1008 (\ var -> MethodInv $ PrimaryMethodCall var
1009 []
1010 (Ident (intTyToMethod ty))
1011 []
1013 <$> mkVarAccess (Just $ intTyToClass ty) var
1014mkForeignVarAccess FChar var = Cast (PrimType CharT) <$> mkForeignVarAccess (FInt IT32) var
1015mkForeignVarAccess FDouble var =
1016 (\ var -> MethodInv $ PrimaryMethodCall (var)
1017 []
1018 (Ident "doubleValue")
1019 []
1021 <$> mkVarAccess (Just doubleType) var
1022mkForeignVarAccess otherType var = mkVarAccess (mkForeignType otherType) var
1024mkFromForeignType :: FType -> Exp -> Exp
1025mkFromForeignType (FInt ty) from =
1026 MethodInv $ TypeMethodCall (J.Name [intTyToIdent ty])
1027 []
1028 (Ident "valueOf")
1029 [from]
1030mkFromForeignType FChar from = mkFromForeignType (FInt IT32) from
1031mkFromForeignType FDouble from =
1032 MethodInv $ TypeMethodCall (J.Name [Ident "Double"])
1033 []
1034 (Ident "valueOf")
1035 [from]
1036mkFromForeignType _ from = from
1038mkForeignInvoke :: FType -> String -> [(FType, LVar)] -> CodeGeneration Exp
1039mkForeignInvoke fType method args =
1040 (\ foreignInvokeMeth ->
1041 MethodInv $ PrimaryMethodCall (InstanceCreation []
1042 objectType
1043 []
1044 (Just $ ClassBody [ MemberDecl $ foreignInvokeMeth ])
1046 []
1047 (Ident "foreignInvoke")
1048 []
1050 <$> mkForeignInvokeMethod fType method args
1053mkForeignInvokeMethod :: FType -> String -> [(FType, LVar)] -> CodeGeneration MemberDecl
1054mkForeignInvokeMethod fType method args =
1055 (\ tryBlock ->
1056 MethodDecl [Public, Final]
1057 []
1058 (Just . RefType $ ClassRefType objectType)
1059 (Ident "foreignInvoke")
1060 []
1061 []
1062 (MethodBody . Just $ Block
1063 [ BlockStmt
1064 $ Try tryBlock
1065 [ Catch (FormalParam []
1066 (RefType $ ClassRefType exceptionType)
1067 False
1068 (VarId $ Ident "ex")
1070 (Block [ BlockStmt
1071 . Throw
1072 $ InstanceCreation []
1073 runtimeExceptionType
1074 [ExpName $ J.Name [Ident "ex"]]
1075 Nothing
1079 Nothing
1083 <$> mkForeignInvokeTryBlock fType method args
1086mkForeignInvokeTryBlock :: FType -> String -> [(FType, LVar)] -> CodeGeneration Block
1087mkForeignInvokeTryBlock FUnit method args =
1088 (\ method args -> Block [ BlockStmt . ExpStmt . MethodInv $ MethodCall method args
1089 , BlockStmt $ Return (Just $ Lit Null)
1092 <$> ( T.lift $ left (\ err -> "Error parsing name \"" ++ method ++ "\" :" ++ (show err))
1093 (parser name method)
1095 <*> mapM (uncurry mkForeignVarAccess) args
1096mkForeignInvokeTryBlock fType method args =
1097 (\ method args -> Block [ BlockStmt . Return
1098 . Just
1099 . mkFromForeignType fType
1100 . MethodInv
1101 $ MethodCall method args
1104 <$> ( T.lift $ left (\ err -> "Error parsing name \"" ++ method ++ "\" :" ++ (show err))
1105 (parser name method)
1107 <*> mapM (uncurry mkForeignVarAccess) args
1109mkMethodClosure :: Name -> [LVar] -> CodeGeneration Exp
1110mkMethodClosure name args =
1111 (\ name args ->
1112 InstanceCreation []
1113 idrisClosureType
1114 [ (ExpName $ J.Name [Ident "context"]) ]
1115 ( Just
1116 $ ClassBody
1117 [ MemberDecl
1118 $ MethodDecl [Public, Final]
1119 []
1120 (Just . RefType $ ClassRefType objectType)
1121 (Ident "call")
1122 []
1123 []
1124 ( MethodBody
1125 . Just
1126 $ Block [ BlockStmt
1127 . Return
1128 . Just
1129 . MethodInv
1130 $ MethodCall (reverseNameSpace name)
1131 args
1137 <$> mkName name
1138 <*> mapM (mkExp . SV) args
1140mkThread :: LVar -> CodeGeneration Exp
1141mkThread arg =
1142 (\ eval ->
1143 MethodInv
1144 $ PrimaryMethodCall (InstanceCreation []
1145 (ClassType [(Ident "Thread", [])])
1146 [ eval ]
1147 ( Just
1148 $ ClassBody [ MemberDecl
1149 $ MethodDecl [Public, Final]
1150 []
1151 (Just . RefType $ ClassRefType objectType)
1152 (Ident "_start")
1153 []
1154 []
1155 ( MethodBody
1156 . Just
1157 $ Block [ BlockStmt
1158 . ExpStmt
1159 . MethodInv
1160 $ MethodCall (J.Name [Ident "start"])
1161 []
1162 , BlockStmt
1163 . Return
1164 . Just
1165 $ This
1171 []
1172 (Ident "_start")
1173 []
1175 <$> mkThreadBinding arg
1177mkThreadBinding :: LVar -> CodeGeneration Exp
1178mkThreadBinding var =
1179 (\ bindingMethod var ->
1180 MethodInv $ PrimaryMethodCall ( InstanceCreation []
1181 objectType
1182 []
1183 (Just $ ClassBody [MemberDecl $ bindingMethod])
1185 []
1186 (Ident "apply")
1187 [ var ]
1189 <$> mkThreadBindingMethod
1190 <*> mkVarAccess Nothing var
1193mkThreadBindingMethod :: CodeGeneration MemberDecl
1194mkThreadBindingMethod =
1195 (\ compute ->
1196 MethodDecl [Final, Public]
1197 []
1198 (Just . RefType $ ClassRefType idrisClosureType)
1199 (Ident "apply")
1200 [ FormalParam [Final] (RefType . ClassRefType $ objectType) False (VarId $ Ident "param") ]
1201 []
1202 (MethodBody . Just $ Block
1203 [ mkThreadBindingStack
1204 , BlockStmt . Return $ Just compute
1208 <$> mkBindingClosure (SUpdate (Loc 0) (SApp False (MN 0 "EVAL") [Loc 0]))
1211mkThreadBindingStack :: BlockStmt
1212mkThreadBindingStack =
1213 LocalVars [Final]
1214 objectArrayType
1215 [ VarDecl (VarDeclArray . VarId $ Ident "new_context")
1216 (Just . InitArray $ ArrayInit [InitExp . ExpName $ J.Name [Ident "param"]])
1220mkExp :: SExp -> CodeGeneration Exp
1221mkExp (SV var) = mkVarAccess Nothing var
1222mkExp (SApp False name args) =
1223 (\ methClosure ->
1224 MethodInv $ PrimaryMethodCall ( InstanceCreation []
1225 idrisTailCallClosureType
1226 [ methClosure ]
1227 Nothing
1229 []
1230 (Ident "call")
1231 []
1233 <$> mkMethodClosure name args
1234mkExp (SApp True name args) =
1235 (\ methClosure ->
1236 ( InstanceCreation []
1237 idrisTailCallClosureType
1238 [ methClosure ]
1239 Nothing
1242 <$> mkMethodClosure name args
1243mkExp (SLet var new old) =
1244 mkLet var old new
1245mkExp (SUpdate var exp) =
1246 (\ rhs varPos -> Assign (ArrayLhs $ ArrayIndex (contextArray var) (Lit $ Int varPos))
1247 EqualA
1248 rhs
1250 <$> mkExp exp
1251 <*> varPos var
1252mkExp (SCon conId name args) =
1253 (\ args -> InstanceCreation []
1254 idrisObjectType
1255 ((Lit $ Int (toInteger conId)):args)
1256 Nothing)
1257 <$> mapM (mkExp .SV) args
1258mkExp (SCase var alts) = mkCase False var alts
1259mkExp (SChkCase var alts) = mkCase True var alts
1260mkExp (SProj var i) = mkProjection var i
1261mkExp (SConst (I x)) =
1262 let x' :: Int32; x' = fromInteger (toInteger x) in
1263 return $ mkPrimitive "Integer" (Int (fromInteger (toInteger x')))
1264mkExp (SConst (BI x)) =
1265 return $ InstanceCreation []
1266 (ClassType [(Ident "BigInteger", [])])
1267 [Lit $ String (show x)]
1268 Nothing
1269mkExp (SConst (Fl x)) = return $ mkPrimitive "Double" (Double x)
1270mkExp (SConst (Ch x)) = return $ mkPrimitive "Integer" (Char x)
1271mkExp (SConst (Str x)) = return $ Lit $ String x
1272mkExp (SConst IType) = return $ mkClass integerType
1273mkExp (SConst BIType) = return $ mkClass bigIntegerType
1274mkExp (SConst FlType) = return $ mkClass doubleType
1275mkExp (SConst ChType) = return $ mkClass charType
1276mkExp (SConst StrType) = return $ mkClass stringType
1277mkExp (SConst (B8 x)) = return $ mkPrimitive "Byte" (String (show x))
1278mkExp (SConst (B16 x)) = return $ mkPrimitive "Short" (String (show x))
1279mkExp (SConst (B32 x)) = return $ mkPrimitive "Integer" (Int (toInteger x))
1280mkExp (SConst (B64 x)) = return $ mkPrimitive "Long" (String (show x))
1281mkExp (SConst (B8Type))= return $ mkClass byteType
1282mkExp (SConst (B16Type)) = return $ mkClass shortType
1283mkExp (SConst (B32Type)) = return $ mkClass integerType
1284mkExp (SConst (B64Type)) = return $ mkClass longType
1285mkExp (SConst (PtrType)) = return $ mkClass objectType
1286mkExp (SConst (VoidType)) = return $ mkClass voidType
1287mkExp (SConst (Forgot)) = return $ mkClass objectType
1288mkExp (SForeign _ fType meth args) = mkForeignInvoke fType meth args
1289mkExp (SOp (LPlus ITNative) args) = mkExp (SOp (LPlus IT32) args)
1290mkExp (SOp (LMinus ITNative) args) = mkExp (SOp (LMinus IT32) args)
1291mkExp (SOp (LTimes ITNative) args) = mkExp (SOp (LTimes IT32) args)
1292mkExp (SOp (LSDiv ITNative) args) = mkExp (SOp (LSDiv IT32) args)
1293mkExp (SOp (LSRem ITNative) args) = mkExp (SOp (LSRem IT32) args)
1294mkExp (SOp (LAnd ITNative) args) = mkExp (SOp (LAnd IT32) args)
1295mkExp (SOp (LOr ITNative) args) = mkExp (SOp (LOr IT32) args)
1296mkExp (SOp (LXOr ITNative) args) = mkExp (SOp (LXOr IT32) args)
1297mkExp (SOp (LCompl ITNative) args) = mkExp (SOp (LCompl IT32) args)
1298mkExp (SOp (LSHL ITNative) args) = mkExp (SOp (LSHL IT32) args)
1299mkExp (SOp (LASHR ITNative) args) = mkExp (SOp (LASHR IT32) args)
1300mkExp (SOp (LEq ITNative) args) = mkExp (SOp (LEq IT32) args)
1301mkExp (SOp (LLt ITNative) args) = mkExp (SOp (LLt IT32) args)
1302mkExp (SOp (LLe ITNative) args) = mkExp (SOp (LLe IT32) args)
1303mkExp (SOp (LGt ITNative) args) = mkExp (SOp (LGt IT32) args)
1304mkExp (SOp (LGe ITNative) args) = mkExp (SOp (LGe IT32) args)
1305mkExp (SOp LFPlus args) = mkBinOpExp doubleType Add args
1306mkExp (SOp LFMinus args) = mkBinOpExp doubleType Sub args
1307mkExp (SOp LFTimes args) = mkBinOpExp doubleType Mult args
1308mkExp (SOp LFDiv args) = mkBinOpExp doubleType Div args
1309mkExp (SOp LFEq args) =
1310 mkMethodOpChain1 (mkBoolToNumber doubleType) doubleType "equals" args
1311mkExp (SOp LFLt args) = mkLogicalBinOpExp integerType LThan args
1312mkExp (SOp LFLe args) = mkLogicalBinOpExp integerType LThanE args
1313mkExp (SOp LFGt args) = mkLogicalBinOpExp integerType GThan args
1314mkExp (SOp LFGe args) = mkLogicalBinOpExp integerType GThanE args
1315mkExp (SOp (LPlus ITBig) args) = mkMethodOpChain1 id bigIntegerType "add" args
1316mkExp (SOp (LMinus ITBig) args) = mkMethodOpChain1 id bigIntegerType "subtract" args
1317mkExp (SOp (LTimes ITBig) args) = mkMethodOpChain1 id bigIntegerType "multiply" args
1318mkExp (SOp (LSDiv ITBig) args) = mkMethodOpChain1 id bigIntegerType "divide" args
1319mkExp (SOp (LSRem ITBig) args) = mkMethodOpChain1 id bigIntegerType "mod" args
1320mkExp (SOp (LEq ITBig) args) =
1321 mkMethodOpChain1 (mkBoolToNumber bigIntegerType) bigIntegerType "equals" args
1322mkExp (SOp (LLt ITBig) args) =
1323 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1324 . mkPartialOrder SLt
1325 )
1326 bigIntegerType
1327 "compareTo"
1328 args
1329mkExp (SOp (LLe ITBig) args) =
1330 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1331 . mkPartialOrder SLe
1332 )
1333 bigIntegerType
1334 "compareTo"
1335 args
1336mkExp (SOp (LGt ITBig) args) =
1337 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1338 . mkPartialOrder SGt
1339 )
1340 bigIntegerType
1341 "compareTo"
1342 args
1343mkExp (SOp (LGe ITBig) args) =
1344 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1345 . mkPartialOrder SGe
1346 )
1347 bigIntegerType
1348 "compareTo"
1349 args
1350mkExp (SOp LStrConcat args) =
1351 mkMethodOpChain (\ exp -> InstanceCreation []
1352 (ClassType [(Ident "StringBuilder", [])])
1353 [exp]
1354 Nothing
1356 (\ exp -> MethodInv $ PrimaryMethodCall exp [] (Ident "toString") [])
1357 stringType
1358 "append"
1359 args
1360mkExp (SOp LStrLt args@[_, _]) =
1361 mkMethodOpChain1 ( mkBoolToNumber integerType
1362 . mkPartialOrder SLt
1364 stringType
1365 "compareTo"
1366 args
1367mkExp (SOp LStrEq args@[_, _]) =
1368 mkMethodOpChain1 ( mkBoolToNumber integerType)
1369 stringType
1370 "equals"
1371 args
1372mkExp (SOp LStrLen [arg]) =
1373 (\ var -> MethodInv $ PrimaryMethodCall var [] (Ident "length") [])
1374 <$> mkVarAccess (Just stringType) arg
1375mkExp (SOp (LIntFloat ity) [arg]) =
1376 mkPrimitiveCast (intTyToClass ity) doubleType arg
1377mkExp (SOp (LFloatInt ity) [arg]) =
1378 mkSignedExt (intTyToMethod ity) doubleType (intTyToClass ity) arg
1379mkExp (SOp (LIntStr ity) [arg]) =
1380 mkToString (intTyToClass ity) arg
1381mkExp (SOp (LStrInt ity) [arg]) =
1382 mkPrimitiveCast stringType (intTyToClass ity) arg
1383mkExp (SOp LFloatStr [arg]) =
1384 mkToString doubleType arg
1385mkExp (SOp LStrFloat [arg]) =
1386 mkPrimitiveCast doubleType stringType arg
1387mkExp (SOp (LSExt ITNative ITBig) [arg]) =
1388 mkPrimitiveCast integerType bigIntegerType arg
1389mkExp (SOp (LTrunc ITBig ITNative) [arg]) =
1390 mkPrimitiveCast bigIntegerType integerType arg
1391mkExp (SOp (LChInt ITNative) [arg]) =
1392 mkVarAccess (Just integerType) arg
1393mkExp (SOp (LIntCh ITNative) [arg]) =
1394 mkVarAccess (Just integerType) arg
1395mkExp (SOp LPrintNum [arg]) =
1396 mkSystemOutPrint <$> (mkVarAccess Nothing arg)
1397mkExp (SOp LPrintStr [arg]) =
1398 mkSystemOutPrint <$> (mkVarAccess (Just stringType) arg)
1399mkExp (SOp LReadStr [arg]) = mkExp (SForeign LANG_C FString "idris_readStr" [(FPtr, arg)])
1400mkExp (SOp (LLt ty) args) = mkLogicalBinOpExp (intTyToClass ty) LThan args
1401mkExp (SOp (LLe ty) args) = mkLogicalBinOpExp (intTyToClass ty) LThanE args
1402mkExp (SOp (LEq ty) args) =
1403 mkMethodOpChain1 (mkBoolToNumber (intTyToClass ty)) (intTyToClass ty) "equals" args
1404mkExp (SOp (LGt ty) args) = mkLogicalBinOpExp (intTyToClass ty) GThan args
1405mkExp (SOp (LGe ty) args) = mkLogicalBinOpExp (intTyToClass ty) GThanE args
1406mkExp (SOp (LPlus ty) args) = mkBinOpExp (intTyToClass ty) Add args
1407mkExp (SOp (LMinus ty) args) = mkBinOpExp (intTyToClass ty) Sub args
1408mkExp (SOp (LTimes ty) args) = mkBinOpExp (intTyToClass ty) Mult args
1409mkExp (SOp (LUDiv IT64) (arg:args)) = do
1410 (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)
1411 return $ foldl (\ exp arg ->
1412 MethodInv $ PrimaryMethodCall
1413 ( MethodInv $ PrimaryMethodCall
1414 ( MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1415 []
1416 (Ident "valueOf")
1417 [ exp ]
1419 []
1420 (Ident "divide")
1421 [ MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1422 []
1423 (Ident "valueOf")
1424 [ arg ]
1427 []
1428 (Ident "longValue")
1429 []
1430 )
1431 arg
1432 args
1433mkExp (SOp (LUDiv ty) args) =
1434 mkBinOpExpConv (intTyToMethod $ nextIntTy ty)
1435 (intTyToPrimTy $ nextIntTy ty)
1436 (intTyToClass ty)
1437 Div
1438 args
1439mkExp (SOp (LSDiv ty) args) = mkBinOpExp (intTyToClass ty) Div args
1440mkExp (SOp (LURem IT64) (arg:args)) = do
1441 (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)
1442 return $ foldl (\ exp arg ->
1443 MethodInv $ PrimaryMethodCall
1444 ( MethodInv $ PrimaryMethodCall
1445 ( MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1446 []
1447 (Ident "valueOf")
1448 [ exp ]
1450 []
1451 (Ident "remainder")
1452 [ MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1453 []
1454 (Ident "valueOf")
1455 [ arg ]
1458 []
1459 (Ident "longValue")
1460 []
1461 )
1462 arg
1463 args
1464mkExp (SOp (LURem ty) args) =
1465 mkBinOpExpConv (intTyToMethod $ nextIntTy ty)
1466 (intTyToPrimTy $ nextIntTy ty)
1467 (intTyToClass ty)
1468 Rem
1469 args
1470mkExp (SOp (LSRem ty) args) = mkBinOpExp (intTyToClass ty) Rem args
1471mkExp (SOp (LSHL ty) args) = mkBinOpExp (intTyToClass ty) LShift args
1472mkExp (SOp (LLSHR ty) args) = mkBinOpExp (intTyToClass ty) RRShift args
1473mkExp (SOp (LASHR ty) args) = mkBinOpExp (intTyToClass ty) RShift args
1474mkExp (SOp (LAnd ty) args) = mkBinOpExp (intTyToClass ty) And args
1475mkExp (SOp (LOr ty) args) = mkBinOpExp (intTyToClass ty) Or args
1476mkExp (SOp (LXOr ty) args) = mkBinOpExp (intTyToClass ty) Xor args
1477mkExp (SOp (LCompl ty) [var]) = PreBitCompl <$> mkVarAccess (Just $ intTyToClass ty) var
1478mkExp (SOp (LZExt from to) [var])
1479 | intTyWidth from < intTyWidth to
1480 = mkZeroExt (intTyToMethod to) (intTyWidth from) (intTyToClass from) (intTyToClass to) var
1481mkExp (SOp (LSExt from to) [var])
1482 | intTyWidth from < intTyWidth to
1483 = mkSignedExt (intTyToMethod to) (intTyToClass from) (intTyToClass to) var
1484mkExp (SOp (LTrunc from to) [var])
1485 | intTyWidth from > intTyWidth to
1486 = mkSignedExt (intTyToMethod to) (intTyToClass from) (intTyToClass to) var
1487mkExp (SOp LFExp [arg]) = mkMathFun "exp" arg
1488mkExp (SOp LFLog [arg]) = mkMathFun "log" arg
1489mkExp (SOp LFSin [arg]) = mkMathFun "sin" arg
1490mkExp (SOp LFCos [arg]) = mkMathFun "cos" arg
1491mkExp (SOp LFTan [arg]) = mkMathFun "tan" arg
1492mkExp (SOp LFASin [arg]) = mkMathFun "asin" arg
1493mkExp (SOp LFACos [arg]) = mkMathFun "acos" arg
1494mkExp (SOp LFATan [arg]) = mkMathFun "atan" arg
1495mkExp (SOp LFSqrt [arg]) = mkMathFun "sqrt" arg
1496mkExp (SOp LFFloor [arg]) = mkMathFun "floor" arg
1497mkExp (SOp LFCeil [arg]) = mkMathFun "ceil" arg
1498mkExp (SOp LStrHead [arg]) = mkStringAtIndex arg (Lit $ Int 0)
1499mkExp (SOp LStrTail [arg]) =
1500 (\ var -> MethodInv $ PrimaryMethodCall (var)
1501 []
1502 (Ident "substring")
1503 [Lit $ Int 1]
1504 )
1505 <$> mkVarAccess (Just stringType) arg
1506mkExp (SOp LStrCons [c, cs]) =
1507 (\ cVar csVar -> MethodInv $
1508 PrimaryMethodCall ( MethodInv $ PrimaryMethodCall (InstanceCreation []
1509 (ClassType [(Ident "StringBuilder", [])])
1510 [csVar]
1511 Nothing
1513 []
1514 (Ident "insert")
1515 [ Lit $ Int 0,
1516 Cast (PrimType CharT)
1517 (MethodInv $ PrimaryMethodCall
1518 (cVar)
1519 []
1520 (Ident "intValue")
1521 []
1525 []
1526 (Ident "toString")
1527 []
1529 <$> mkVarAccess (Just integerType) c
1530 <*> mkVarAccess (Just stringType) cs
1531mkExp (SOp LStrIndex [str, i]) = mkVarAccess (Just integerType) i >>= mkStringAtIndex str
1532mkExp (SOp LStrRev [str]) =
1533 (\ var -> MethodInv $
1534 PrimaryMethodCall ( MethodInv $ PrimaryMethodCall (InstanceCreation []
1535 (ClassType [(Ident "StringBuffer", [])])
1536 [var]
1537 Nothing
1539 []
1540 (Ident "reverse")
1541 []
1543 []
1544 (Ident "toString")
1545 []
1547 <$> mkVarAccess (Just stringType) str
1548mkExp (SOp LStdIn []) = return $ mkSystemStd In
1549mkExp (SOp LStdOut []) = return $ mkSystemStd Out
1550mkExp (SOp LStdErr []) = return $ mkSystemStd Err
1551mkExp (SOp LFork [arg]) = mkThread arg
1552mkExp (SOp LPar [arg]) = mkExp (SV arg)
1553mkExp (SOp LVMPtr []) =
1554 return $ MethodInv $ TypeMethodCall (J.Name [Ident "Thread"]) [] (Ident "currentThread") []
1555mkExp (SOp LNoOp args) = mkExp . SV $ last args
1556mkExp (SNothing) = return $ Lit Null
1557mkExp (SError err) =
1558 return . MethodInv $
1559 PrimaryMethodCall (InstanceCreation []
1560 runtimeExceptionType
1561 [Lit $ String err]
1562 ( Just $ ClassBody
1563 [ MemberDecl $ MethodDecl [Public, Final]
1564 []
1565 (Just . RefType $ ClassRefType objectType)
1566 (Ident "throwSelf")
1567 []
1568 []
1569 ( MethodBody . Just $
1570 Block [ BlockStmt (Throw This) ]
1575 []
1576 (Ident "throwSelf")
1577 []
1578mkExp other = error (show other)