translateDeclaration :: (String, SDecl) -> JS
translateDeclaration (path, SFun name params stackSize body)
  | (MN _ "APPLY")        <- name
  , (SLet var val next)   <- body
  , (SChkCase cvar cases) <- next =
    let lvar   = translateVariableName var
        lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in
        JSSeq [ lookupTable [(var, "chk")] var cases
              , jsDecl $ JSFunction ["fn0", "arg0"] (
                  JSSeq [ JSAlloc "__var_0" (Just $ JSRaw "fn0")
                        , JSReturn $ jsLet (translateVariableName var) (
                            translateExpression val
                          ) (JSTernary (
                               (JSVar var `jsInstanceOf` jsCon) `jsAnd`
                               (hasProp lookupTableName (translateVariableName var))
                            ) (JSRaw $
                                 lookupTableName ++ lookup
                              ) JSNull
                            )
                        ]
                )
              ]

  | (MN _ "EVAL")        <- name
  , (SChkCase var cases) <- body =
    JSSeq [ lookupTable [] var cases
          , jsDecl $ JSFunction ["arg0"] (JSReturn $
              JSTernary (
                (JSRaw "arg0" `jsInstanceOf` jsCon) `jsAnd`
                (hasProp lookupTableName "arg0")
              ) (JSRaw $ lookupTableName ++ "[arg0.tag](arg0)") (JSRaw "arg0")
            )
          ]
  | otherwise =
    let fun = translateExpression body in
        jsDecl $ jsFun fun

  where
    hasProp :: String -> String -> JS
    hasProp table var =
      jsMeth (JSRaw table) "hasOwnProperty" [JSRaw $ var ++ ".tag"]

    caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
    caseFun aux var cse =
      jsFunAux aux (translateCase (Just (translateVariableName var)) cse)

    getTag :: SAlt -> Maybe String
    getTag (SConCase _ tag _ _ _) = Just $ show tag
    getTag _                      = Nothing

    lookupTableName :: String
    lookupTableName = idrLTNamespace ++ translateName name

    lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS
    lookupTable aux var cases =
      JSAlloc lookupTableName $ Just (
        JSObject $ catMaybes $ map (lookupEntry aux var) cases
      )
      where
        lookupEntry :: [(LVar, String)] ->  LVar -> SAlt -> Maybe (String, JS)
        lookupEntry aux var alt = do
          tag <- getTag alt
          return (tag, caseFun aux var alt)

    jsDecl :: JS -> JS
    jsDecl = JSAlloc (path ++ translateName name) . Just

    jsFun body = jsFunAux [] body

    jsFunAux :: [(LVar, String)] -> JS -> JS
    jsFunAux aux body =
      JSFunction (p ++ map snd aux) (
        JSSeq $
        zipWith assignVar [0..] p ++
        map allocVar [numP .. (numP + stackSize - 1)] ++
        map assignAux aux ++
        [JSReturn body]
      )
      where
        numP :: Int
        numP = length params

        allocVar :: Int -> JS
        allocVar n = JSAlloc (jsVar n) Nothing

        assignVar :: Int -> String -> JS
        assignVar n s = JSAlloc (jsVar n)  (Just $ JSRaw s)

        assignAux :: (LVar, String) -> JS
        assignAux (var, val) = JSAssign (JSRaw $ translateVariableName var) (JSRaw val)

        p :: [String]
        p = map translateName params
translateDeclaration :: (String, SDecl) -> JS
translateDeclaration (path, SFun name params stackSize body)
  | (MN _ "APPLY")        <- name
  , (SLet var val next)   <- body
  , (SChkCase cvar cases) <- next =
    let lvar   = translateVariableName var
        lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in
        JSSeq [ lookupTable [(var, "chk")] var cases
              , jsDecl $ JSFunction ["fn0", "arg0"] (
                  JSSeq [ JSAlloc "__var_0" (Just $ JSRaw "fn0")
                        , JSReturn $ jsLet (translateVariableName var) (
                            translateExpression val
                          ) (JSTernary (
                               (JSVar var `jsInstanceOf` jsCon) `jsAnd`
                               (hasProp lookupTableName (translateVariableName var))
                            ) (JSRaw $
                                 lookupTableName ++ lookup
                              ) JSNull
                            )
                        ]
                )
              ]

  | (MN _ "EVAL")        <- name
  , (SChkCase var cases) <- body =
    JSSeq [ lookupTable [] var cases
          , jsDecl $ JSFunction ["arg0"] (JSReturn $
              JSTernary (
                (JSRaw "arg0" `jsInstanceOf` jsCon) `jsAnd`
                (hasProp lookupTableName "arg0")
              ) (JSRaw $ lookupTableName ++ "[arg0.tag](arg0)") (JSRaw "arg0")
            )
          ]
  | otherwise =
    let fun = translateExpression body in
        jsDecl $ jsFun fun

  where
    hasProp :: String -> String -> JS
    hasProp table var =
      jsMeth (JSRaw table) "hasOwnProperty" [JSRaw $ var ++ ".tag"]

    caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
    caseFun aux var cse =
      jsFunAux aux (translateCase (Just (translateVariableName var)) cse)

    getTag :: SAlt -> Maybe String
    getTag (SConCase _ tag _ _ _) = Just $ show tag
    getTag _                      = Nothing

    lookupTableName :: String
    lookupTableName = idrLTNamespace ++ translateName name

    lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS
    lookupTable aux var cases =
      JSAlloc lookupTableName $ Just (
        JSObject $ catMaybes $ map (lookupEntry aux var) cases
      )
      where
        lookupEntry :: [(LVar, String)] ->  LVar -> SAlt -> Maybe (String, JS)
        lookupEntry aux var alt = do
          tag <- getTag alt
          return (tag, caseFun aux var alt)

    jsDecl :: JS -> JS
    jsDecl = JSAlloc (path ++ translateName name) . Just

    jsFun body = jsFunAux [] body

    jsFunAux :: [(LVar, String)] -> JS -> JS
    jsFunAux aux body =
      JSFunction (p ++ map snd aux) (
        JSSeq $
        zipWith assignVar [0..] p ++
        map allocVar [numP .. (numP + stackSize - 1)] ++
        map assignAux aux ++
        [JSReturn body]
      )
      where
        numP :: Int
        numP = length params

        allocVar :: Int -> JS
        allocVar n = JSAlloc (jsVar n) Nothing

        assignVar :: Int -> String -> JS
        assignVar n s = JSAlloc (jsVar n)  (Just $ JSRaw s)

        assignAux :: (LVar, String) -> JS
        assignAux (var, val) = JSAssign (JSRaw $ translateVariableName var) (JSRaw val)

        p :: [String]
        p = map translateName params
translateDeclaration (path, SFun name params stackSize body)
  | (MN _ "APPLY")        <- name
  , (SLet var val next)   <- body
  , (SChkCase cvar cases) <- next =
    let lvar   = translateVariableName var
        lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in
        JSSeq [ lookupTable [(var, "chk")] var cases
              , jsDecl $ JSFunction ["fn0", "arg0"] (
                  JSSeq [ JSAlloc "__var_0" (Just $ JSRaw "fn0")
                        , JSReturn $ jsLet (translateVariableName var) (
                            translateExpression val
                          ) (JSTernary (
                               (JSVar var `jsInstanceOf` jsCon) `jsAnd`
                               (hasProp lookupTableName (translateVariableName var))
                            ) (JSRaw $
                                 lookupTableName ++ lookup
                              ) JSNull
                            )
                        ]
                )
              ]

  | (MN _ "EVAL")        <- name
  , (SChkCase var cases) <- body =
    JSSeq [ lookupTable [] var cases
          , jsDecl $ JSFunction ["arg0"] (JSReturn $
              JSTernary (
                (JSRaw "arg0" `jsInstanceOf` jsCon) `jsAnd`
                (hasProp lookupTableName "arg0")
              ) (JSRaw $ lookupTableName ++ "[arg0.tag](arg0)") (JSRaw "arg0")
            )
          ]
  | otherwise =
    let fun = translateExpression body in
        jsDecl $ jsFun fun

  where
    hasProp :: String -> String -> JS
    hasProp table var =
      jsMeth (JSRaw table) "hasOwnProperty" [JSRaw $ var ++ ".tag"]

    caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
    caseFun aux var cse =
      jsFunAux aux (translateCase (Just (translateVariableName var)) cse)

    getTag :: SAlt -> Maybe String
    getTag (SConCase _ tag _ _ _) = Just $ show tag
    getTag _                      = Nothing

    lookupTableName :: String
    lookupTableName = idrLTNamespace ++ translateName name

    lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS
    lookupTable aux var cases =
      JSAlloc lookupTableName $ Just (
        JSObject $ catMaybes $ map (lookupEntry aux var) cases
      )
      where
        lookupEntry :: [(LVar, String)] ->  LVar -> SAlt -> Maybe (String, JS)
        lookupEntry aux var alt = do
          tag <- getTag alt
          return (tag, caseFun aux var alt)

    jsDecl :: JS -> JS
    jsDecl = JSAlloc (path ++ translateName name) . Just

    jsFun body = jsFunAux [] body

    jsFunAux :: [(LVar, String)] -> JS -> JS
    jsFunAux aux body =
      JSFunction (p ++ map snd aux) (
        JSSeq $
        zipWith assignVar [0..] p ++
        map allocVar [numP .. (numP + stackSize - 1)] ++
        map assignAux aux ++
        [JSReturn body]
      )
      where
        numP :: Int
        numP = length params

        allocVar :: Int -> JS
        allocVar n = JSAlloc (jsVar n) Nothing

        assignVar :: Int -> String -> JS
        assignVar n s = JSAlloc (jsVar n)  (Just $ JSRaw s)

        assignAux :: (LVar, String) -> JS
        assignAux (var, val) = JSAssign (JSRaw $ translateVariableName var) (JSRaw val)

        p :: [String]
        p = map translateName params