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