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