git.iko.soy/Idris-dev
on abe5605 help sign in
Idris-dev/src/IRTS/CodegenJava.hs
1594 lines 70 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"
488intTyToClass :: IntTy -> ClassType
489intTyToClass ty = ClassType [(intTyToIdent ty, [])]
491intTyToMethod :: IntTy -> String
492intTyToMethod IT8 = "byteValue"
493intTyToMethod IT16 = "shortValue"
494intTyToMethod IT32 = "intValue"
495intTyToMethod IT64 = "longValue"
496intTyToMethod ITNative = "intValue"
498intTyToPrimTy :: IntTy -> PrimType
499intTyToPrimTy IT8 = ByteT
500intTyToPrimTy IT16 = ShortT
501intTyToPrimTy IT32 = IntT
502intTyToPrimTy IT64 = LongT
503intTyToPrimTy ITNative = IntT
505bigIntegerType :: ClassType
506bigIntegerType = ClassType [(Ident "BigInteger", [])]
508doubleType :: ClassType
509doubleType = ClassType [(Ident "Double", [])]
511stringType :: ClassType
512stringType = ClassType [(Ident "String", [])]
514stringArrayType :: Language.Java.Syntax.Type
515stringArrayType = RefType . ArrayType . RefType . ClassRefType $ stringType
517exceptionType :: ClassType
518exceptionType = ClassType [(Ident "Throwable", [])]
520runtimeExceptionType :: ClassType
521runtimeExceptionType = ClassType [(Ident "RuntimeException", [])]
523comparableType :: ClassType
524comparableType = ClassType [(Ident "Comparable", [])]
526mkDecl :: (Name, SDecl) -> CodeGeneration Decl
527mkDecl ((NS n (ns:nss)), decl) =
528 (\ name body -> MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body)
529 <$> mkIdentifier (UN ns)
530 <*> mkClassBody [] [(NS n nss, decl)]
531mkDecl (_, SFun name params stackSize body) =
532 (\ name params paramNames methodBody ->
533 MemberDecl $ MethodDecl [Public, Static]
534 []
535 (Just . RefType $ ClassRefType objectType)
536 name
537 params
538 []
539 (MethodBody . Just $ Block
540 [ LocalVars [Final]
541 objectArrayType
542 [ VarDecl (VarDeclArray . VarId $ Ident "context")
543 (Just . InitArray . ArrayInit $
544 paramNames
545 ++ replicate stackSize (InitExp . Lit $ Null))
546 ]
547 , BlockStmt . Return $ Just methodBody
548 ]
549 )
550 )
551 <$> mkIdentifier name
552 <*> mapM mkFormalParam params
553 <*> mapM (\ p -> (InitExp . ExpName) <$> mkName p) params
554 <*> mkExp body
557mkClosure :: [Name] -> Int -> SExp -> CodeGeneration Exp
558mkClosure params stackSize body =
559 (\ paramArray body ->
560 InstanceCreation []
561 idrisClosureType
562 [paramArray]
563 (Just $ ClassBody [body])
564 )
565 <$> mkStackInit params stackSize
566 <*> mkClosureCall body
568mkFormalParam :: Name -> CodeGeneration FormalParam
569mkFormalParam name =
570 (\ name -> FormalParam [Final] (RefType . ClassRefType $ objectType) False (VarId name))
571 <$> mkIdentifier name
573mkClosureCall :: SExp -> CodeGeneration Decl
574mkClosureCall body =
575 (\ body -> MemberDecl $ MethodDecl [Public] [] (Just . RefType $ ClassRefType objectType) (Ident "call") [] [] body)
576 <$> mkMethodBody body
578mkMethodBody :: SExp -> CodeGeneration MethodBody
579mkMethodBody exp =
580 (\ exp -> MethodBody . Just . Block $ [BlockStmt . Return . Just $ exp])
581 <$> mkExp exp
583mkStackInit :: [Name] -> Int -> CodeGeneration Exp
584mkStackInit params stackSize =
585 (\ localVars -> ArrayCreateInit objectArrayType 0 . ArrayInit $
586 (map (InitExp . ExpName) localVars)
587 ++ (replicate (stackSize) (InitExp $ Lit Null)))
588 <$> mapM mkName params
590mkK :: Exp -> Exp -> Exp
591mkK result drop =
592 MethodInv $ MethodCall (J.Name [Ident "idris_K"]) [ result, drop ]
594mkFlipK :: Exp -> Exp -> Exp
595mkFlipK drop result =
596 MethodInv $ MethodCall (J.Name [Ident "idris_flipK"]) [ drop, result ]
598mkLet :: LVar -> SExp -> SExp -> CodeGeneration Exp
599mkLet (Loc pos) oldExp newExp =
600 (\ oldExp newExp ->
601 mkFlipK ( Assign ( ArrayLhs $ ArrayIndex (ExpName $ J.Name [Ident "context"])
602 (Lit $ Int (toInteger pos)))
603 EqualA
604 newExp
605 )
606 oldExp
607 )
608 <$> mkExp oldExp
609 <*> mkExp newExp
610mkLet (Glob _) _ _ = T.lift $ Left "Cannot let bind to global variable"
612reverseNameSpace :: J.Name -> J.Name
613reverseNameSpace (J.Name ids) =
614 J.Name ((tail ids) ++ [head ids])
616mkCase :: Bool -> LVar -> [SAlt] -> CodeGeneration Exp
617mkCase checked var ((SConCase parentStackPos consIndex _ params branchExpression):cases) =
618 mkConsCase checked
619 var
620 parentStackPos
621 consIndex
622 params
623 branchExpression
624 (SCase var cases)
625mkCase checked var (c@(SConstCase constant branchExpression):cases) =
626 (\ constant branchExpression alternative var->
627 Cond ( MethodInv $ PrimaryMethodCall (constant)
628 []
629 (Ident "equals")
630 [var]
631 )
632 branchExpression
633 alternative
634 )
635 <$> mkExp (SConst constant)
636 <*> mkExp branchExpression
637 <*> mkCase checked var cases
638 <*> mkVarAccess Nothing var
639mkCase checked var (SDefaultCase exp:cases) = mkExp exp
640mkCase checked _ [] = mkExp (SError "Non-exhaustive pattern")
642mkConsCase :: Bool -> LVar -> Int -> Int -> [Name] -> SExp -> SExp -> CodeGeneration Exp
643mkConsCase checked
644 toDeconstruct
645 parentStackStart
646 consIndex
647 params
648 branchExpression
649 alternative =
650 (\ caseBinding alternative var varCasted->
651 Cond (BinOp (InstanceOf (var)
652 (ClassRefType idrisObjectType)
653 )
654 CAnd
655 ( BinOp
656 ( MethodInv $ PrimaryMethodCall (varCasted)
657 []
658 (Ident "getConstructorId")
659 []
660 )
661 Equal
662 (Lit $ Int (toInteger consIndex))
663 )
664 )
665 (caseBinding)
666 alternative
667 )
668 <$> mkCaseBinding checked toDeconstruct parentStackStart params branchExpression
669 <*> mkExp alternative
670 <*> mkVarAccess (Nothing) toDeconstruct
671 <*> mkVarAccess (Just idrisObjectType) toDeconstruct
674mkCaseBinding :: Bool -> LVar -> Int -> [Name] -> SExp -> CodeGeneration Exp
675mkCaseBinding True var parentStackStart params branchExpression =
676 (\ branchExpression deconstruction ->
677 mkFlipK (MethodInv $ MethodCall (J.Name [Ident "idris_assignStack"])
678 ( (ExpName $ J.Name [Ident "context"])
679 : (Lit $ Int (toInteger parentStackStart))
680 : deconstruction
681 ))
682 (branchExpression)
683 )
684 <$> mkExp branchExpression
685 <*> mkCaseBindingDeconstruction var params
686mkCaseBinding False var parentStackStart params branchExpression =
687 (\ bindingMethod deconstruction ->
688 MethodInv $ PrimaryMethodCall
689 ( MethodInv $ PrimaryMethodCall (InstanceCreation []
690 (ClassType [(Ident "Object", [])])
691 []
692 (Just $ ClassBody [MemberDecl $ bindingMethod])
693 )
694 []
695 (Ident "apply")
696 ( contextArray (Loc undefined) : deconstruction )
697 )
698 []
699 (Ident "call")
700 []
701 )
702 <$> mkCaseBindingMethod parentStackStart params branchExpression
703 <*> mkCaseBindingDeconstruction var params
705mkCaseBindingDeconstruction :: LVar -> [Name] -> CodeGeneration [Exp]
706mkCaseBindingDeconstruction var members =
707 mapM (mkProjection var) ([0..(length members - 1)])
709mkCaseBindingMethod :: Int -> [Name] -> SExp -> CodeGeneration MemberDecl
710mkCaseBindingMethod parentStackStart params branchExpression =
711 (\ formalParams caseBindingStack branchExpression ->
712 MethodDecl [Final, Public]
713 []
714 (Just . RefType $ ClassRefType idrisClosureType)
715 (Ident "apply")
716 (mkContextParam:formalParams)
717 []
718 (MethodBody . Just . Block $
719 caseBindingStack ++
720 [BlockStmt . Return $ Just branchExpression]))
721 <$> mapM mkFormalParam params
722 <*> mkBindingStack False parentStackStart params
723 <*> mkBindingClosure branchExpression
725mkContextParam :: FormalParam
726mkContextParam =
727 FormalParam [Final] (objectArrayType) False (VarId (Ident "context"))
729mkBindingClosure :: SExp -> CodeGeneration Exp
730mkBindingClosure oldExp =
731 (\ oldCall ->
732 InstanceCreation []
733 idrisClosureType
734 [ ExpName $ J.Name [Ident "new_context"] ]
735 (Just $ ClassBody [oldCall])
736 )
737 <$> mkClosureCall oldExp
740mkBindingStack :: Bool -> Int -> [Name] -> CodeGeneration [BlockStmt]
741mkBindingStack checked parentStackStart params =
742 (\ paramNames ->
743 ( LocalVars [Final]
744 objectArrayType
745 [ VarDecl (VarDeclArray . VarId $ Ident "new_context")
746 (Just . InitExp $ mkContextCopy checked parentStackStart params)
747 ])
748 : ( map (\ (param, pos) ->
749 BlockStmt . ExpStmt $
750 Assign (ArrayLhs $ ArrayIndex (ExpName $ J.Name [Ident "new_context"])
751 (Lit $ Int (toInteger pos)))
752 EqualA
753 (ExpName param)) $ zip paramNames [parentStackStart..]
754 )
755 )
756 <$> mapM mkName params
758mkContextCopy :: Bool -> Int -> [Name] -> Exp
759mkContextCopy True parentStackStart params =
760 MethodInv $ PrimaryMethodCall (ExpName $ J.Name [Ident "context"])
761 []
762 (Ident "clone")
763 []
764mkContextCopy False parentStackStart params =
765 MethodInv $ TypeMethodCall (J.Name [Ident "Arrays"])
766 []
767 (Ident "copyOf")
768 [ ExpName $ J.Name [Ident "context"]
769 , MethodInv
770 $ TypeMethodCall (J.Name [Ident "Math"])
771 []
772 (Ident "max")
773 [ FieldAccess $ PrimaryFieldAccess (ExpName $ J.Name [Ident "context"])
774 (Ident "length")
775 , Lit . Int $ toInteger (parentStackStart + length params)
776 ]
777 ]
779mkProjection :: LVar -> Int -> CodeGeneration Exp
780mkProjection var memberNr =
781 (\ var -> ArrayAccess $ ArrayIndex ( MethodInv $ PrimaryMethodCall
782 (var)
783 []
784 (Ident "getData")
785 []
786 )
787 (Lit $ Int (toInteger memberNr))
788 )
789 <$> mkVarAccess (Just idrisObjectType) var
791type ClassName = String
793mkPrimitive :: ClassName -> Literal -> Exp
794mkPrimitive className value =
795 MethodInv $ TypeMethodCall (J.Name [Ident className])
796 []
797 (Ident "valueOf")
798 [Lit $ value]
800mkClass :: ClassType -> Exp
801mkClass classType =
802 ClassLit . Just . RefType .ClassRefType $ classType
804mkBinOpExp :: ClassType -> Op -> [LVar] -> CodeGeneration Exp
805mkBinOpExp castTo op (var:vars) = do
806 start <- mkVarAccess (Just castTo) var
807 foldM (\ exp var -> BinOp exp op <$> mkVarAccess (Just castTo) var) start vars
809mkBinOpExpTrans :: (Exp -> Exp) -> (Exp -> Exp) -> ClassType -> Op -> [LVar] -> CodeGeneration Exp
810mkBinOpExpTrans opTransformation resultTransformation castTo op (var:vars) = do
811 start <- (mkVarAccess (Just castTo) var)
812 foldM (\ exp var -> resultTransformation
813 . BinOp (opTransformation exp) op
814 . opTransformation
815 <$> mkVarAccess (Just castTo) var)
816 start
817 vars
819mkBinOpExpConv :: String -> PrimType -> ClassType -> Op -> [LVar] -> CodeGeneration Exp
820mkBinOpExpConv fromMethodName toType fromType@(ClassType [(cls@(Ident _), [])]) op args =
821 mkBinOpExpTrans (\ exp -> MethodInv $ TypeMethodCall (J.Name [cls])
822 []
823 (Ident fromMethodName)
824 [exp]
825 )
826 (\ exp -> MethodInv $ TypeMethodCall (J.Name [cls])
827 []
828 (Ident "valueOf")
829 [Cast (PrimType $ toType) exp]
830 )
831 fromType
832 op
833 args
835mkLogicalBinOpExp :: ClassType -> Op -> [LVar] -> CodeGeneration Exp
836mkLogicalBinOpExp castTo op (var:vars) = do
837 start <- mkVarAccess (Just castTo) var
838 foldM (\ exp var -> mkBoolToNumber castTo . BinOp exp op <$> mkVarAccess (Just castTo) var)
839 start
840 vars
842mkMethodOpChain1 :: (Exp -> Exp) -> ClassType -> String -> [LVar] -> CodeGeneration Exp
843mkMethodOpChain1 = mkMethodOpChain id
845mkMethodOpChain :: (Exp -> Exp) -> (Exp -> Exp) -> ClassType -> String -> [LVar] -> CodeGeneration Exp
846mkMethodOpChain initialTransformation resultTransformation castTo method (arg:args) = do
847 start <- initialTransformation <$> mkVarAccess (Just $ castTo) arg
848 foldM (\ exp arg' ->
849 resultTransformation
850 . MethodInv
851 . PrimaryMethodCall exp [] (Ident method)
852 . (:[])
853 <$> mkVarAccess (Just $ castTo) arg'
854 )
855 start
856 args
858mkBoolToNumber :: ClassType -> Exp -> Exp
859mkBoolToNumber (ClassType [(Ident name, [])]) boolExp =
860 Cond boolExp (mkPrimitive name (Int 1)) (mkPrimitive name (Int 0))
862mkZeroExt :: String -> Int -> ClassType -> ClassType -> LVar -> CodeGeneration Exp
863mkZeroExt toMethod bits fromType toType@(ClassType [(toTypeName, [])]) var = do
864 (\ var sext ->
865 MethodInv $ TypeMethodCall (J.Name [toTypeName])
866 []
867 (Ident "valueOf")
868 [ Cond ( BinOp (var)
869 LThan
870 (Lit $ Int 0)
871 )
872 ( BinOp (Lit $ Int (2^bits))
873 Add
874 (sext)
875 )
876 sext
877 ]
878 )
879 <$> mkVarAccess (Just $ fromType) var
880 <*> mkSignedExt' toMethod fromType var
882mkSignedExt :: String -> ClassType -> ClassType -> LVar -> CodeGeneration Exp
883mkSignedExt toMethod fromType (ClassType [(toTypeName, [])]) var =
884 (\ sext -> MethodInv $ TypeMethodCall (J.Name [toTypeName])
885 []
886 (Ident "valueOf")
887 [ sext ]
888 )
889 <$> mkSignedExt' toMethod fromType var
891mkSignedExt' :: String -> ClassType -> LVar -> CodeGeneration Exp
892mkSignedExt' toMethod fromType var =
893 (\ var -> MethodInv $ PrimaryMethodCall (var)
894 []
895 (Ident toMethod)
896 []
897 )
898 <$> mkVarAccess (Just $ fromType) var
900data SPartialOrder
901 = SLt
902 | SLe
903 | SEq
904 | SGe
905 | SGt
907mkPartialOrder :: SPartialOrder -> Exp -> Exp
908mkPartialOrder SLt x = (BinOp (Lit $ Int (-1)) Equal x)
909mkPartialOrder SLe x =
910 BinOp (BinOp (Lit $ Int (-1)) Equal x)
911 COr
912 (BinOp (Lit $ Int 0) Equal x)
913mkPartialOrder SEq x = BinOp (Lit $ Int 0) Equal x
914mkPartialOrder SGe x =
915 BinOp (BinOp (Lit $ Int 1) Equal x)
916 COr
917 (BinOp (Lit $ Int 0) Equal x)
918mkPartialOrder SGt x = (BinOp (Lit $ Int 1) Equal x)
920varPos :: LVar -> CodeGeneration Integer
921varPos (Loc i) = return (toInteger i)
922varPos (Glob name) = do
923 positions <- globalVariablePositions <$> get
924 case lookup name positions of
925 (Just pos) -> return pos
926 Nothing -> T.lift . Left $ "Invalid global variable id: " ++ show name
928mkVarAccess :: Maybe ClassType -> LVar -> CodeGeneration Exp
929mkVarAccess Nothing var =
930 (\ pos -> ArrayAccess $ ArrayIndex (contextArray var) (Lit $ Int pos))
931 <$> varPos var
932mkVarAccess (Just castTo) var =
933 Cast (RefType . ClassRefType $ castTo) <$> (mkVarAccess Nothing var)
935mkPrimitiveCast :: ClassType -> ClassType -> LVar -> CodeGeneration Exp
936mkPrimitiveCast fromType (ClassType [(toType, [])]) var =
937 (\ var ->
938 MethodInv $ TypeMethodCall (J.Name [toType])
939 []
940 (Ident "valueOf")
941 [var]
942 )
943 <$> mkVarAccess (Just fromType) var
945mkToString :: ClassType -> LVar -> CodeGeneration Exp
946mkToString castTo var =
947 (\ var -> MethodInv $ PrimaryMethodCall (var)
948 []
949 (Ident "toString")
950 []
951 )
952 <$> mkVarAccess (Just castTo) var
953data Std = In | Out | Err
955instance Show Std where
956 show In = "in"
957 show Out = "out"
958 show Err = "err"
960mkSystemStd :: Std -> Exp
961mkSystemStd std = FieldAccess $ PrimaryFieldAccess (ExpName $ J.Name [Ident "System"]) (Ident $ show std)
963mkSystemOutPrint :: Exp -> Exp
964mkSystemOutPrint value =
965 MethodInv $ PrimaryMethodCall (mkSystemStd Out)
966 []
967 (Ident "print")
968 [value]
970mkMathFun :: String -> LVar -> CodeGeneration Exp
971mkMathFun funName var =
972 (\ var -> MethodInv $ TypeMethodCall (J.Name [Ident "Double"])
973 []
974 (Ident "valueOf")
975 [ MethodInv $ TypeMethodCall (J.Name [Ident "Math"])
976 []
977 (Ident funName)
978 [var]
979 ]
980 )
981 <$> mkVarAccess (Just doubleType) var
983mkStringAtIndex :: LVar -> Exp -> CodeGeneration Exp
984mkStringAtIndex var indexExp =
985 (\ var -> MethodInv $ TypeMethodCall (J.Name [Ident "Integer"])
986 []
987 (Ident "valueOf")
988 [ MethodInv $ PrimaryMethodCall (var)
989 []
990 (Ident "charAt")
991 [indexExp]
992 ]
993 )
994 <$> mkVarAccess (Just stringType) var
996mkForeignType :: FType -> Maybe ClassType
997mkForeignType (FInt ty) = return (intTyToClass ty)
998mkForeignType FChar = return integerType
999mkForeignType FString = return stringType
1000mkForeignType FPtr = return objectType
1001mkForeignType FDouble = return doubleType
1002mkForeignType FAny = return objectType
1003mkForeignType FUnit = Nothing
1005mkForeignVarAccess :: FType -> LVar -> CodeGeneration Exp
1006mkForeignVarAccess (FInt ty) var =
1007 (\ var -> MethodInv $ PrimaryMethodCall var
1008 []
1009 (Ident (intTyToMethod ty))
1010 []
1012 <$> mkVarAccess (Just $ intTyToClass ty) var
1013mkForeignVarAccess FChar var = Cast (PrimType CharT) <$> mkForeignVarAccess (FInt IT32) var
1014mkForeignVarAccess FDouble var =
1015 (\ var -> MethodInv $ PrimaryMethodCall (var)
1016 []
1017 (Ident "doubleValue")
1018 []
1020 <$> mkVarAccess (Just doubleType) var
1021mkForeignVarAccess otherType var = mkVarAccess (mkForeignType otherType) var
1023mkFromForeignType :: FType -> Exp -> Exp
1024mkFromForeignType (FInt ty) from =
1025 MethodInv $ TypeMethodCall (J.Name [intTyToIdent ty])
1026 []
1027 (Ident "valueOf")
1028 [from]
1029mkFromForeignType FChar from = mkFromForeignType (FInt IT32) from
1030mkFromForeignType FDouble from =
1031 MethodInv $ TypeMethodCall (J.Name [Ident "Double"])
1032 []
1033 (Ident "valueOf")
1034 [from]
1035mkFromForeignType _ from = from
1037mkForeignInvoke :: FType -> String -> [(FType, LVar)] -> CodeGeneration Exp
1038mkForeignInvoke fType method args =
1039 (\ foreignInvokeMeth ->
1040 MethodInv $ PrimaryMethodCall (InstanceCreation []
1041 objectType
1042 []
1043 (Just $ ClassBody [ MemberDecl $ foreignInvokeMeth ])
1045 []
1046 (Ident "foreignInvoke")
1047 []
1049 <$> mkForeignInvokeMethod fType method args
1052mkForeignInvokeMethod :: FType -> String -> [(FType, LVar)] -> CodeGeneration MemberDecl
1053mkForeignInvokeMethod fType method args =
1054 (\ tryBlock ->
1055 MethodDecl [Public, Final]
1056 []
1057 (Just . RefType $ ClassRefType objectType)
1058 (Ident "foreignInvoke")
1059 []
1060 []
1061 (MethodBody . Just $ Block
1062 [ BlockStmt
1063 $ Try tryBlock
1064 [ Catch (FormalParam []
1065 (RefType $ ClassRefType exceptionType)
1066 False
1067 (VarId $ Ident "ex")
1069 (Block [ BlockStmt
1070 . Throw
1071 $ InstanceCreation []
1072 runtimeExceptionType
1073 [ExpName $ J.Name [Ident "ex"]]
1074 Nothing
1078 Nothing
1082 <$> mkForeignInvokeTryBlock fType method args
1085mkForeignInvokeTryBlock :: FType -> String -> [(FType, LVar)] -> CodeGeneration Block
1086mkForeignInvokeTryBlock FUnit method args =
1087 (\ method args -> Block [ BlockStmt . ExpStmt . MethodInv $ MethodCall method args
1088 , BlockStmt $ Return (Just $ Lit Null)
1091 <$> ( T.lift $ left (\ err -> "Error parsing name \"" ++ method ++ "\" :" ++ (show err))
1092 (parser name method)
1094 <*> mapM (uncurry mkForeignVarAccess) args
1095mkForeignInvokeTryBlock fType method args =
1096 (\ method args -> Block [ BlockStmt . Return
1097 . Just
1098 . mkFromForeignType fType
1099 . MethodInv
1100 $ MethodCall method args
1103 <$> ( T.lift $ left (\ err -> "Error parsing name \"" ++ method ++ "\" :" ++ (show err))
1104 (parser name method)
1106 <*> mapM (uncurry mkForeignVarAccess) args
1108mkMethodClosure :: Name -> [LVar] -> CodeGeneration Exp
1109mkMethodClosure name args =
1110 (\ name args ->
1111 InstanceCreation []
1112 idrisClosureType
1113 [ (ExpName $ J.Name [Ident "context"]) ]
1114 ( Just
1115 $ ClassBody
1116 [ MemberDecl
1117 $ MethodDecl [Public, Final]
1118 []
1119 (Just . RefType $ ClassRefType objectType)
1120 (Ident "call")
1121 []
1122 []
1123 ( MethodBody
1124 . Just
1125 $ Block [ BlockStmt
1126 . Return
1127 . Just
1128 . MethodInv
1129 $ MethodCall (reverseNameSpace name)
1130 args
1136 <$> mkName name
1137 <*> mapM (mkExp . SV) args
1139mkThread :: LVar -> CodeGeneration Exp
1140mkThread arg =
1141 (\ eval ->
1142 MethodInv
1143 $ PrimaryMethodCall (InstanceCreation []
1144 (ClassType [(Ident "Thread", [])])
1145 [ eval ]
1146 ( Just
1147 $ ClassBody [ MemberDecl
1148 $ MethodDecl [Public, Final]
1149 []
1150 (Just . RefType $ ClassRefType objectType)
1151 (Ident "_start")
1152 []
1153 []
1154 ( MethodBody
1155 . Just
1156 $ Block [ BlockStmt
1157 . ExpStmt
1158 . MethodInv
1159 $ MethodCall (J.Name [Ident "start"])
1160 []
1161 , BlockStmt
1162 . Return
1163 . Just
1164 $ This
1170 []
1171 (Ident "_start")
1172 []
1174 <$> mkThreadBinding arg
1176mkThreadBinding :: LVar -> CodeGeneration Exp
1177mkThreadBinding var =
1178 (\ bindingMethod var ->
1179 MethodInv $ PrimaryMethodCall ( InstanceCreation []
1180 objectType
1181 []
1182 (Just $ ClassBody [MemberDecl $ bindingMethod])
1184 []
1185 (Ident "apply")
1186 [ var ]
1188 <$> mkThreadBindingMethod
1189 <*> mkVarAccess Nothing var
1192mkThreadBindingMethod :: CodeGeneration MemberDecl
1193mkThreadBindingMethod =
1194 (\ compute ->
1195 MethodDecl [Final, Public]
1196 []
1197 (Just . RefType $ ClassRefType idrisClosureType)
1198 (Ident "apply")
1199 [ FormalParam [Final] (RefType . ClassRefType $ objectType) False (VarId $ Ident "param") ]
1200 []
1201 (MethodBody . Just $ Block
1202 [ mkThreadBindingStack
1203 , BlockStmt . Return $ Just compute
1207 <$> mkBindingClosure (SUpdate (Loc 0) (SApp False (MN 0 "EVAL") [Loc 0]))
1210mkThreadBindingStack :: BlockStmt
1211mkThreadBindingStack =
1212 LocalVars [Final]
1213 objectArrayType
1214 [ VarDecl (VarDeclArray . VarId $ Ident "new_context")
1215 (Just . InitArray $ ArrayInit [InitExp . ExpName $ J.Name [Ident "param"]])
1219mkExp :: SExp -> CodeGeneration Exp
1220mkExp (SV var) = mkVarAccess Nothing var
1221mkExp (SApp False name args) =
1222 (\ methClosure ->
1223 MethodInv $ PrimaryMethodCall ( InstanceCreation []
1224 idrisTailCallClosureType
1225 [ methClosure ]
1226 Nothing
1228 []
1229 (Ident "call")
1230 []
1232 <$> mkMethodClosure name args
1233mkExp (SApp True name args) =
1234 (\ methClosure ->
1235 ( InstanceCreation []
1236 idrisTailCallClosureType
1237 [ methClosure ]
1238 Nothing
1241 <$> mkMethodClosure name args
1242mkExp (SLet var new old) =
1243 mkLet var old new
1244mkExp (SUpdate var exp) =
1245 (\ rhs varPos -> Assign (ArrayLhs $ ArrayIndex (contextArray var) (Lit $ Int varPos))
1246 EqualA
1247 rhs
1249 <$> mkExp exp
1250 <*> varPos var
1251mkExp (SCon conId name args) =
1252 (\ args -> InstanceCreation []
1253 idrisObjectType
1254 ((Lit $ Int (toInteger conId)):args)
1255 Nothing)
1256 <$> mapM (mkExp .SV) args
1257mkExp (SCase var alts) = mkCase False var alts
1258mkExp (SChkCase var alts) = mkCase True var alts
1259mkExp (SProj var i) = mkProjection var i
1260mkExp (SConst (I x)) =
1261 let x' :: Int32; x' = fromInteger (toInteger x) in
1262 return $ mkPrimitive "Integer" (Int (fromInteger (toInteger x')))
1263mkExp (SConst (BI x)) =
1264 return $ InstanceCreation []
1265 (ClassType [(Ident "BigInteger", [])])
1266 [Lit $ String (show x)]
1267 Nothing
1268mkExp (SConst (Fl x)) = return $ mkPrimitive "Double" (Double x)
1269mkExp (SConst (Ch x)) = return $ mkPrimitive "Integer" (Char x)
1270mkExp (SConst (Str x)) = return $ Lit $ String x
1271mkExp (SConst IType) = return $ mkClass integerType
1272mkExp (SConst BIType) = return $ mkClass bigIntegerType
1273mkExp (SConst FlType) = return $ mkClass doubleType
1274mkExp (SConst ChType) = return $ mkClass charType
1275mkExp (SConst StrType) = return $ mkClass stringType
1276mkExp (SConst (B8 x)) = return $ mkPrimitive "Byte" (String (show x))
1277mkExp (SConst (B16 x)) = return $ mkPrimitive "Short" (String (show x))
1278mkExp (SConst (B32 x)) = return $ mkPrimitive "Integer" (Int (toInteger x))
1279mkExp (SConst (B64 x)) = return $ mkPrimitive "Long" (String (show x))
1280mkExp (SConst (B8Type))= return $ mkClass byteType
1281mkExp (SConst (B16Type)) = return $ mkClass shortType
1282mkExp (SConst (B32Type)) = return $ mkClass integerType
1283mkExp (SConst (B64Type)) = return $ mkClass longType
1284mkExp (SConst (PtrType)) = return $ mkClass objectType
1285mkExp (SConst (VoidType)) = return $ mkClass voidType
1286mkExp (SConst (Forgot)) = return $ mkClass objectType
1287mkExp (SForeign _ fType meth args) = mkForeignInvoke fType meth args
1288mkExp (SOp (LPlus ITNative) args) = mkExp (SOp (LPlus IT32) args)
1289mkExp (SOp (LMinus ITNative) args) = mkExp (SOp (LMinus IT32) args)
1290mkExp (SOp (LTimes ITNative) args) = mkExp (SOp (LTimes IT32) args)
1291mkExp (SOp (LSDiv ITNative) args) = mkExp (SOp (LSDiv IT32) args)
1292mkExp (SOp (LSRem ITNative) args) = mkExp (SOp (LSRem IT32) args)
1293mkExp (SOp (LAnd ITNative) args) = mkExp (SOp (LAnd IT32) args)
1294mkExp (SOp (LOr ITNative) args) = mkExp (SOp (LOr IT32) args)
1295mkExp (SOp (LXOr ITNative) args) = mkExp (SOp (LXOr IT32) args)
1296mkExp (SOp (LCompl ITNative) args) = mkExp (SOp (LCompl IT32) args)
1297mkExp (SOp (LSHL ITNative) args) = mkExp (SOp (LSHL IT32) args)
1298mkExp (SOp (LASHR ITNative) args) = mkExp (SOp (LASHR IT32) args)
1299mkExp (SOp (LEq ITNative) args) = mkExp (SOp (LEq IT32) args)
1300mkExp (SOp (LLt ITNative) args) = mkExp (SOp (LLt IT32) args)
1301mkExp (SOp (LLe ITNative) args) = mkExp (SOp (LLe IT32) args)
1302mkExp (SOp (LGt ITNative) args) = mkExp (SOp (LGt IT32) args)
1303mkExp (SOp (LGe ITNative) args) = mkExp (SOp (LGe IT32) args)
1304mkExp (SOp LFPlus args) = mkBinOpExp doubleType Add args
1305mkExp (SOp LFMinus args) = mkBinOpExp doubleType Sub args
1306mkExp (SOp LFTimes args) = mkBinOpExp doubleType Mult args
1307mkExp (SOp LFDiv args) = mkBinOpExp doubleType Div args
1308mkExp (SOp LFEq args) =
1309 mkMethodOpChain1 (mkBoolToNumber doubleType) doubleType "equals" args
1310mkExp (SOp LFLt args) = mkLogicalBinOpExp integerType LThan args
1311mkExp (SOp LFLe args) = mkLogicalBinOpExp integerType LThanE args
1312mkExp (SOp LFGt args) = mkLogicalBinOpExp integerType GThan args
1313mkExp (SOp LFGe args) = mkLogicalBinOpExp integerType GThanE args
1314mkExp (SOp LBPlus args) = mkMethodOpChain1 id bigIntegerType "add" args
1315mkExp (SOp LBMinus args) = mkMethodOpChain1 id bigIntegerType "subtract" args
1316mkExp (SOp LBTimes args) = mkMethodOpChain1 id bigIntegerType "multiply" args
1317mkExp (SOp LBDiv args) = mkMethodOpChain1 id bigIntegerType "divide" args
1318mkExp (SOp LBMod args) = mkMethodOpChain1 id bigIntegerType "mod" args
1319mkExp (SOp LBEq args) =
1320 mkMethodOpChain1 (mkBoolToNumber bigIntegerType) bigIntegerType "equals" args
1321mkExp (SOp LBLt args) =
1322 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1323 . mkPartialOrder SLt
1324 )
1325 bigIntegerType
1326 "compareTo"
1327 args
1328mkExp (SOp LBLe args) =
1329 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1330 . mkPartialOrder SLe
1331 )
1332 bigIntegerType
1333 "compareTo"
1334 args
1335mkExp (SOp LBGt args) =
1336 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1337 . mkPartialOrder SGt
1338 )
1339 bigIntegerType
1340 "compareTo"
1341 args
1342mkExp (SOp LBGe args) =
1343 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1344 . mkPartialOrder SGe
1345 )
1346 bigIntegerType
1347 "compareTo"
1348 args
1349mkExp (SOp LStrConcat args) =
1350 mkMethodOpChain (\ exp -> InstanceCreation []
1351 (ClassType [(Ident "StringBuilder", [])])
1352 [exp]
1353 Nothing
1355 (\ exp -> MethodInv $ PrimaryMethodCall exp [] (Ident "toString") [])
1356 stringType
1357 "append"
1358 args
1359mkExp (SOp LStrLt args@[_, _]) =
1360 mkMethodOpChain1 ( mkBoolToNumber integerType
1361 . mkPartialOrder SLt
1363 stringType
1364 "compareTo"
1365 args
1366mkExp (SOp LStrEq args@[_, _]) =
1367 mkMethodOpChain1 ( mkBoolToNumber integerType)
1368 stringType
1369 "equals"
1370 args
1371mkExp (SOp LStrLen [arg]) =
1372 (\ var -> MethodInv $ PrimaryMethodCall var [] (Ident "length") [])
1373 <$> mkVarAccess (Just stringType) arg
1374mkExp (SOp LIntFloat [arg]) =
1375 mkPrimitiveCast integerType doubleType arg
1376mkExp (SOp LFloatInt [arg]) =
1377 mkPrimitiveCast doubleType integerType arg
1378mkExp (SOp LIntStr [arg]) =
1379 mkToString integerType arg
1380mkExp (SOp LStrInt [arg]) =
1381 mkPrimitiveCast stringType integerType arg
1382mkExp (SOp LFloatStr [arg]) =
1383 mkToString doubleType arg
1384mkExp (SOp LStrFloat [arg]) =
1385 mkPrimitiveCast doubleType stringType arg
1386mkExp (SOp LIntBig [arg]) =
1387 mkPrimitiveCast integerType bigIntegerType arg
1388mkExp (SOp LBigInt [arg]) =
1389 mkPrimitiveCast bigIntegerType integerType arg
1390mkExp (SOp LStrBig [arg]) =
1391 (\ var -> InstanceCreation [] bigIntegerType [var] Nothing)
1392 <$> mkVarAccess (Just stringType) arg
1393mkExp (SOp LBigStr [arg]) =
1394 mkToString bigIntegerType arg
1395mkExp (SOp LChInt [arg]) =
1396 mkVarAccess (Just integerType) arg
1397mkExp (SOp LIntCh [arg]) =
1398 mkVarAccess (Just integerType) arg
1399mkExp (SOp LPrintNum [arg]) =
1400 mkSystemOutPrint <$> (mkVarAccess Nothing arg)
1401mkExp (SOp LPrintStr [arg]) =
1402 mkSystemOutPrint <$> (mkVarAccess (Just stringType) arg)
1403mkExp (SOp LReadStr [arg]) = mkExp (SForeign LANG_C FString "idris_readStr" [(FPtr, arg)])
1404mkExp (SOp (LLt ty) args) = mkLogicalBinOpExp (intTyToClass ty) LThan args
1405mkExp (SOp (LLe ty) args) = mkLogicalBinOpExp (intTyToClass ty) LThanE args
1406mkExp (SOp (LEq ty) args) =
1407 mkMethodOpChain1 (mkBoolToNumber (intTyToClass ty)) (intTyToClass ty) "equals" args
1408mkExp (SOp (LGt ty) args) = mkLogicalBinOpExp (intTyToClass ty) GThan args
1409mkExp (SOp (LGe ty) args) = mkLogicalBinOpExp (intTyToClass ty) GThanE args
1410mkExp (SOp (LPlus ty) args) = mkBinOpExp (intTyToClass ty) Add args
1411mkExp (SOp (LMinus ty) args) = mkBinOpExp (intTyToClass ty) Sub args
1412mkExp (SOp (LTimes ty) args) = mkBinOpExp (intTyToClass ty) Mult args
1413mkExp (SOp (LUDiv IT64) (arg:args)) = do
1414 (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)
1415 return $ foldl (\ exp arg ->
1416 MethodInv $ PrimaryMethodCall
1417 ( MethodInv $ PrimaryMethodCall
1418 ( MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1419 []
1420 (Ident "valueOf")
1421 [ exp ]
1423 []
1424 (Ident "divide")
1425 [ MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1426 []
1427 (Ident "valueOf")
1428 [ arg ]
1431 []
1432 (Ident "longValue")
1433 []
1434 )
1435 arg
1436 args
1437mkExp (SOp (LUDiv ty) args) =
1438 mkBinOpExpConv (intTyToMethod $ nextIntTy ty)
1439 (intTyToPrimTy $ nextIntTy ty)
1440 (intTyToClass ty)
1441 Div
1442 args
1443mkExp (SOp (LSDiv ty) args) = mkBinOpExp (intTyToClass ty) Div args
1444mkExp (SOp (LURem IT64) (arg:args)) = do
1445 (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)
1446 return $ foldl (\ exp arg ->
1447 MethodInv $ PrimaryMethodCall
1448 ( MethodInv $ PrimaryMethodCall
1449 ( MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1450 []
1451 (Ident "valueOf")
1452 [ exp ]
1454 []
1455 (Ident "remainder")
1456 [ MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1457 []
1458 (Ident "valueOf")
1459 [ arg ]
1462 []
1463 (Ident "longValue")
1464 []
1465 )
1466 arg
1467 args
1468mkExp (SOp (LURem ty) args) =
1469 mkBinOpExpConv (intTyToMethod $ nextIntTy ty)
1470 (intTyToPrimTy $ nextIntTy ty)
1471 (intTyToClass ty)
1472 Rem
1473 args
1474mkExp (SOp (LSRem ty) args) = mkBinOpExp (intTyToClass ty) Rem args
1475mkExp (SOp (LSHL ty) args) = mkBinOpExp (intTyToClass ty) LShift args
1476mkExp (SOp (LLSHR ty) args) = mkBinOpExp (intTyToClass ty) RRShift args
1477mkExp (SOp (LASHR ty) args) = mkBinOpExp (intTyToClass ty) RShift args
1478mkExp (SOp (LAnd ty) args) = mkBinOpExp (intTyToClass ty) And args
1479mkExp (SOp (LOr ty) args) = mkBinOpExp (intTyToClass ty) Or args
1480mkExp (SOp (LXOr ty) args) = mkBinOpExp (intTyToClass ty) Xor args
1481mkExp (SOp (LCompl ty) [var]) = PreBitCompl <$> mkVarAccess (Just $ intTyToClass ty) var
1482mkExp (SOp (LZExt from to) [var])
1483 | intTyWidth from < intTyWidth to
1484 = mkZeroExt (intTyToMethod to) (intTyWidth from) (intTyToClass from) (intTyToClass to) var
1485mkExp (SOp (LSExt from to) [var])
1486 | intTyWidth from < intTyWidth to
1487 = mkSignedExt (intTyToMethod to) (intTyToClass from) (intTyToClass to) var
1488mkExp (SOp (LTrunc from to) [var])
1489 | intTyWidth from > intTyWidth to
1490 = (\ var -> MethodInv $
1491 TypeMethodCall (J.Name [intTyToIdent to])
1492 []
1493 (Ident "valueOf")
1494 [ MethodInv
1495 $ PrimaryMethodCall var [] (Ident (intTyToMethod to)) [] ]
1497 <$> mkVarAccess (Just $ intTyToClass from) var
1498mkExp (SOp LIntB8 [arg]) = mkExp (SOp (LTrunc IT32 IT8) [arg])
1499mkExp (SOp LIntB16 [arg]) = mkExp (SOp (LTrunc IT32 IT16) [arg])
1500mkExp (SOp LIntB32 [arg]) = mkExp (SV arg)
1501mkExp (SOp LIntB64 [arg]) = mkExp (SOp (LSExt IT32 IT64) [arg])
1502mkExp (SOp LB32Int [arg]) = mkExp (SV arg)
1503mkExp (SOp LFExp [arg]) = mkMathFun "exp" arg
1504mkExp (SOp LFLog [arg]) = mkMathFun "log" arg
1505mkExp (SOp LFSin [arg]) = mkMathFun "sin" arg
1506mkExp (SOp LFCos [arg]) = mkMathFun "cos" arg
1507mkExp (SOp LFTan [arg]) = mkMathFun "tan" arg
1508mkExp (SOp LFASin [arg]) = mkMathFun "asin" arg
1509mkExp (SOp LFACos [arg]) = mkMathFun "acos" arg
1510mkExp (SOp LFATan [arg]) = mkMathFun "atan" arg
1511mkExp (SOp LFSqrt [arg]) = mkMathFun "sqrt" arg
1512mkExp (SOp LFFloor [arg]) = mkMathFun "floor" arg
1513mkExp (SOp LFCeil [arg]) = mkMathFun "ceil" arg
1514mkExp (SOp LStrHead [arg]) = mkStringAtIndex arg (Lit $ Int 0)
1515mkExp (SOp LStrTail [arg]) =
1516 (\ var -> MethodInv $ PrimaryMethodCall (var)
1517 []
1518 (Ident "substring")
1519 [Lit $ Int 1]
1520 )
1521 <$> mkVarAccess (Just stringType) arg
1522mkExp (SOp LStrCons [c, cs]) =
1523 (\ cVar csVar -> MethodInv $
1524 PrimaryMethodCall ( MethodInv $ PrimaryMethodCall (InstanceCreation []
1525 (ClassType [(Ident "StringBuilder", [])])
1526 [csVar]
1527 Nothing
1529 []
1530 (Ident "insert")
1531 [ Lit $ Int 0,
1532 Cast (PrimType CharT)
1533 (MethodInv $ PrimaryMethodCall
1534 (cVar)
1535 []
1536 (Ident "intValue")
1537 []
1541 []
1542 (Ident "toString")
1543 []
1545 <$> mkVarAccess (Just integerType) c
1546 <*> mkVarAccess (Just stringType) cs
1547mkExp (SOp LStrIndex [str, i]) = mkVarAccess (Just integerType) i >>= mkStringAtIndex str
1548mkExp (SOp LStrRev [str]) =
1549 (\ var -> MethodInv $
1550 PrimaryMethodCall ( MethodInv $ PrimaryMethodCall (InstanceCreation []
1551 (ClassType [(Ident "StringBuffer", [])])
1552 [var]
1553 Nothing
1555 []
1556 (Ident "reverse")
1557 []
1559 []
1560 (Ident "toString")
1561 []
1563 <$> mkVarAccess (Just stringType) str
1564mkExp (SOp LStdIn []) = return $ mkSystemStd In
1565mkExp (SOp LStdOut []) = return $ mkSystemStd Out
1566mkExp (SOp LStdErr []) = return $ mkSystemStd Err
1567mkExp (SOp LFork [arg]) = mkThread arg
1568mkExp (SOp LPar [arg]) = mkExp (SV arg)
1569mkExp (SOp LVMPtr []) =
1570 return $ MethodInv $ TypeMethodCall (J.Name [Ident "Thread"]) [] (Ident "currentThread") []
1571mkExp (SOp LNoOp args) = mkExp . SV $ last args
1572mkExp (SNothing) = return $ Lit Null
1573mkExp (SError err) =
1574 return . MethodInv $
1575 PrimaryMethodCall (InstanceCreation []
1576 runtimeExceptionType
1577 [Lit $ String err]
1578 ( Just $ ClassBody
1579 [ MemberDecl $ MethodDecl [Public, Final]
1580 []
1581 (Just . RefType $ ClassRefType objectType)
1582 (Ident "throwSelf")
1583 []
1584 []
1585 ( MethodBody . Just $
1586 Block [ BlockStmt (Throw This) ]
1591 []
1592 (Ident "throwSelf")
1593 []
1594mkExp other = error (show other)