a8abc5a · Idris-dev · git.iko.soy

14import Control.Arrow

15import Data.Char

16import Data.List

17+import Data.Maybe

17import System.IO

18import System.IO

18import System.Directory

19import System.Directory

19

20

321translateDeclaration :: (String, SDecl) -> JS

322translateDeclaration :: (String, SDecl) -> JS

322translateDeclaration (path, SFun name params stackSize body)

323translateDeclaration (path, SFun name params stackSize body)

323 | (MN _ "APPLY") <- name =

324 | (MN _ "APPLY") <- name =

324− JSSeq [ JSRaw $ "/* " ++ translateName name ++ " */"

325+ let fun = translateExpression body in

325− , jsDecl (path ++ translateName name) $ translate params stackSize body

326+ jsDecl $ jsFun fun

326− ]

327 | (MN _ "EVAL") <- name

328 , (SChkCase var cases) <- body =

329− JSSeq [ JSRaw $ "/* " ++ translateName name ++ " */"

329+ let fun = translateExpression body in

330− , jsDecl (path ++ translateName name) $ translate params stackSize body

330+ JSSeq [ lookupTable var cases

331+ , jsDecl $ JSRaw $ concat [ "function(arg0){"

332+ , "if (arg0 instanceof __IDRRT__Con "

333+ , " && LOOKUPTABLE.hasOwnProperty(arg0.tag))"

334+ , "return LOOKUPTABLE[arg0.tag](arg0);"

335+ , "else "

336+ , "return arg0; }"

337+ ]

331− ]

338+ ]

332 | otherwise =

339 | otherwise =

333− jsDecl (path ++ translateName name) $ translate params stackSize body

340+ let fun = translateExpression body in

341+ jsDecl $ jsFun fun

342+

334 where

343 where

335− jsDecl :: String -> JS -> JS

344+ caseFun :: LVar -> SAlt -> JS

345+ caseFun var cse =

346+ jsFun (translateCase (Just (translateVariableName var)) cse)

347+

348+ getTag :: SAlt -> Maybe String

349+ getTag (SConCase _ tag _ _ _) = Just $ show tag

350+ getTag _ = Nothing

351+

352+ lookupTable :: LVar -> [SAlt] -> JS

353+ lookupTable var cases =

354+ JSAlloc "LOOKUPTABLE" $ Just $ JSObject $ catMaybes $ map (lookupEntry var) cases

355+

356+ lookupEntry :: LVar -> SAlt -> Maybe (String, JS)

357+ lookupEntry var alt = getTag alt >>= \tag -> Just (tag, caseFun var alt)

358+

359+ jsDecl :: JS -> JS

336− jsDecl name = JSAlloc name . Just

360+ jsDecl = JSAlloc (path ++ translateName name) . Just

337

361

338− translate :: [Name] -> Int -> SExp -> JS

362+ jsFun :: JS -> JS

339− translate params stackSize body =

363+ jsFun body =

340 JSFunction p (

364 JSFunction p (

341 JSSeq $

365 JSSeq $

342 zipWith assignVar [0..] p ++

366 zipWith assignVar [0..] p ++

343 map allocVar [numP .. (numP + stackSize - 1)] ++

367 map allocVar [numP .. (numP + stackSize - 1)] ++

344− [JSReturn $ translateExpression body]

368+ [JSReturn body]

345 )

369 )

346 where

370 where

347 numP :: Int

371 numP :: Int