├── .editorconfig ├── .gitignore ├── LICENSE ├── README.md ├── idris-codegen-es.cabal ├── package.json ├── src ├── IRTS │ ├── CodegenEs.hs │ └── CodegenEs │ │ ├── JsAST.hs │ │ ├── JsName.hs │ │ ├── LangTransforms.hs │ │ └── Specialize.hs └── Main.hs ├── stack.yaml ├── test.js └── tests ├── pythag.idr ├── pythag.testres ├── t1.idr ├── t1.testres ├── t10.idr ├── t10.testres ├── t11.idr ├── t11.testres ├── t12.idr ├── t12.testres ├── t13.idr ├── t13.testres ├── t2.idr ├── t2.testres ├── t3.idr ├── t3.testres ├── t4.idr ├── t4.testres ├── t5.idr ├── t5.testres ├── t6.idr ├── t6.testres ├── t7.idr ├── t7.testres ├── t8.idr ├── t8.testres ├── t9.idr ├── t9.testres ├── tarai.idr └── tarai.testres /.editorconfig: -------------------------------------------------------------------------------- 1 | root = true 2 | 3 | [*] 4 | end_of_line = lf 5 | insert_final_newline = true 6 | charset = utf-8 7 | indent_style = tab 8 | indent_size = 4 9 | trim_trailing_whitespace = true 10 | 11 | [**.{cmd,bat,ps1}] 12 | end_of_line = crlf 13 | insert_final_newline = false 14 | 15 | [**.hs] 16 | indent_style = space 17 | indent_size = 2 18 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | *.ibc 3 | *.js.LDecls 4 | node_modules 5 | lib/tests/*.js 6 | rts/browser_lib_b.js 7 | examples/*.js 8 | tests/*.js 9 | lib/js_doc 10 | .cabal-sandbox 11 | .stack-work 12 | cabal.sandbox.config -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | For Portions from idrisjs, Copyright (c) 2015 Rui Barreiro 4 | Copyright (c) 2017 Belleve Invis (Renzhi Li), Shao Cheng, et al. 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy 7 | of this software and associated documentation files (the "Software"), to deal 8 | in the Software without restriction, including without limitation the rights 9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | copies of the Software, and to permit persons to whom the Software is 11 | furnished to do so, subject to the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be included in 14 | all copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 21 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 22 | THE SOFTWARE. 23 | 24 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # idris-codegen-es 2 | 3 | Optimized JavaScript codegen for Idris. 4 | 5 | Originally based on the codegen in https://github.com/rbarreiro/idrisjs. 6 | 7 | Objective: 8 | 9 | - Fast & reasonable JS output. 10 | - Compatible with official JS FFI. 11 | 12 | To build: 13 | 14 | ```bash 15 | stack build 16 | ``` 17 | 18 | To test: with [Ava](https://github.com/avajs/ava) and [JS Bindings](https://github.com/rbarreiro/idrisjs) installed, 19 | 20 | ```bash 21 | npm install 22 | npm test 23 | ``` 24 | -------------------------------------------------------------------------------- /idris-codegen-es.cabal: -------------------------------------------------------------------------------- 1 | name: idris-codegen-es 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | license: MIT 6 | license-file: LICENSE 7 | author: Rui Barreiro, Belleve Invis, Shao Cheng 8 | maintainer: rui.barreiro@gmail.com, belleve@typeof.net 9 | -- copyright: 10 | category: Web 11 | build-type: Simple 12 | -- extra-source-files: 13 | cabal-version: >=1.18 14 | 15 | Executable idris-codegen-es 16 | default-language: Haskell2010 17 | Main-is: Main.hs 18 | hs-source-dirs: src 19 | 20 | Build-depends: idris >= 0.99.1 21 | , base 22 | , containers 23 | , directory 24 | , filepath 25 | , haskeline >= 0.7 26 | , mtl 27 | , transformers 28 | , text 29 | , uniplate 30 | , deepseq 31 | 32 | other-modules: IRTS.CodegenEs 33 | 34 | if os(linux) 35 | cpp-options: -DLINUX 36 | build-depends: unix < 2.8 37 | if os(freebsd) 38 | cpp-options: -DFREEBSD 39 | build-depends: unix < 2.8 40 | if os(dragonfly) 41 | cpp-options: -DDRAGONFLY 42 | build-depends: unix < 2.8 43 | if os(darwin) 44 | cpp-options: -DMACOSX 45 | build-depends: unix < 2.8 46 | if os(windows) 47 | cpp-options: -DWINDOWS 48 | build-depends: Win32 < 2.4 49 | 50 | ghc-prof-options: -auto-all -caf-all 51 | ghc-options: -threaded -rtsopts -funbox-strict-fields 52 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "scripts": { 3 | "test": "ava" 4 | }, 5 | "devDependencies": { 6 | "ava": "^0.19.1", 7 | "ava-spec": "^1.1.0" 8 | }, 9 | "dependencies": { 10 | "child-process-promise": "^2.2.1", 11 | "co": "^4.6.0", 12 | "glob-promise": "^3.1.0", 13 | "throat": "^3.0.0" 14 | } 15 | } 16 | -------------------------------------------------------------------------------- /src/IRTS/CodegenEs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE PatternGuards #-} 3 | 4 | module IRTS.CodegenEs 5 | ( codegenJs 6 | ) where 7 | 8 | import Control.DeepSeq 9 | import IRTS.CodegenCommon 10 | import IRTS.Lang 11 | import IRTS.LangOpts 12 | import Idris.Core.TT 13 | 14 | import IRTS.CodegenEs.JsAST 15 | import IRTS.CodegenEs.JsName 16 | import IRTS.CodegenEs.LangTransforms 17 | import IRTS.CodegenEs.Specialize 18 | 19 | import Control.Monad.Trans.State 20 | import Data.Char 21 | import Data.List (nub) 22 | import Data.Map.Strict (Map) 23 | import qualified Data.Map.Strict as Map 24 | import Data.Maybe (fromJust) 25 | import Data.Set (Set) 26 | import qualified Data.Set as Set 27 | import Data.Text (Text) 28 | import qualified Data.Text as T 29 | import qualified Data.Text.IO as TIO 30 | import System.Directory (doesFileExist) 31 | import System.Environment 32 | import System.FilePath (combine) 33 | 34 | import Data.Data 35 | import Data.Generics.Uniplate.Data 36 | import Data.List 37 | import GHC.Generics (Generic) 38 | 39 | import Debug.Trace 40 | 41 | get_include :: FilePath -> IO Text 42 | get_include p = TIO.readFile p 43 | 44 | get_includes :: [FilePath] -> IO Text 45 | get_includes l = do 46 | incs <- mapM get_include l 47 | return $ T.intercalate "\n\n" incs 48 | 49 | isYes :: Maybe String -> Bool 50 | isYes (Just "Y") = True 51 | isYes (Just "y") = True 52 | isYes _ = False 53 | 54 | type ArityMap = Map.Map Text Int 55 | 56 | codegenJs :: CodeGenerator 57 | codegenJs ci = do 58 | optim <- isYes <$> lookupEnv "IDRISJS_OPTIM" 59 | debug <- isYes <$> lookupEnv "IDRISJS_DEBUG" 60 | {- 61 | if optim 62 | then putStrLn "compiling with idris-js optimizations" 63 | else putStrLn "compiling without idris-js optimizations" 64 | -} 65 | let defs = addAlist (liftDecls ci) emptyContext -- Map.fromList $ liftDecls ci 66 | let used = used_decls defs [sMN 0 "runMain"] --removeUnused dcls dclsMap [sMN 0 "runMain"] 67 | used `deepseq` 68 | if debug 69 | then do 70 | putStrLn $ "Finished calculating used" 71 | writeFile (outputFile ci ++ ".LDecls") $ 72 | (unlines $ intersperse "" $ map show used) ++ "\n\n\n" 73 | else pure () 74 | --let inlined = if optim then inline used else used -- <- if optim then inline debug used else pure used 75 | --inlined `deepseq` if debug then putStrLn $ "Finished inlining" else pure () 76 | let out = T.intercalate "\n" $ map (doCodegen defs) used 77 | out `deepseq` 78 | if debug 79 | then putStrLn $ "Finished generating code" 80 | else pure () 81 | includes <- get_includes $ includes ci 82 | TIO.writeFile (outputFile ci) $ 83 | T.concat 84 | ["\"use strict\";\n\n", includes, "\n", js_aux_defs, "\n", out, "\n"] 85 | 86 | doCodegen :: LDefs -> LDecl -> Text 87 | doCodegen defs dd@(LFun _ n args def) = jsStmt2Text $ cgFun defs n args def 88 | doCodegen defs (LConstructor n i sz) = "" 89 | 90 | seqJs :: [JsStmt] -> JsStmt 91 | seqJs [] = JsEmpty 92 | seqJs (JsEmpty:xs) = seqJs xs 93 | seqJs (x:xs) = JsSeq x (seqJs xs) 94 | 95 | data CGBodyState = CGBodyState 96 | { defs :: LDefs 97 | , lastIntName :: Int 98 | , reWrittenNames :: Map.Map Name JsExpr 99 | , currentFnNameAndArgs :: (Text, [Text]) 100 | , isTailRec :: Bool 101 | } 102 | 103 | getNewCGName :: State CGBodyState Text 104 | getNewCGName = do 105 | st <- get 106 | let v = lastIntName st + 1 107 | put $ st {lastIntName = v} 108 | return $ jsNameGenerated v 109 | 110 | getConsId :: Name -> State CGBodyState (Int, Int) 111 | getConsId n = do 112 | st <- get 113 | case lookupCtxtExact n (defs st) of 114 | Just (LConstructor _ conId arity) -> pure (conId, arity) 115 | _ -> error $ "ups " ++ (T.unpack $ jsName n) 116 | 117 | data BodyResTarget 118 | = ReturnBT 119 | | DecVarBT Text 120 | | SetVarBT Text 121 | | GetExpBT 122 | 123 | cgFun :: LDefs -> Name -> [Name] -> LExp -> JsStmt 124 | cgFun dfs n args def = 125 | let fnName = jsName n 126 | argNames = map jsName args 127 | ((decs, res), st) = 128 | runState 129 | (cgBody ReturnBT def) 130 | (CGBodyState 131 | { defs = dfs 132 | , lastIntName = 0 133 | , reWrittenNames = Map.empty 134 | , currentFnNameAndArgs = (fnName, argNames) 135 | , isTailRec = False 136 | }) 137 | body = 138 | if isTailRec st 139 | then JsForever $ (seqJs decs) `JsSeq` res `JsSeq` JsBreak 140 | else JsSeq (seqJs decs) res 141 | in if (length argNames > 0) 142 | then JsFun fnName argNames body 143 | else JsDecConst fnName $ JsApp (JsLambda [] body) [] 144 | 145 | addRT :: BodyResTarget -> JsExpr -> JsStmt 146 | addRT ReturnBT x = JsReturn x 147 | addRT (DecVarBT n) x = JsDecLet n x 148 | addRT (SetVarBT n) x = JsSet (JsVar n) x 149 | addRT GetExpBT x = JsExprStmt x 150 | 151 | cgName :: Name -> State CGBodyState JsExpr 152 | cgName b = do 153 | st <- get 154 | case Map.lookup b (reWrittenNames st) of 155 | Just e -> pure e 156 | _ -> pure $ JsVar $ jsName b 157 | 158 | cgBinOP :: Text 159 | -> BodyResTarget 160 | -> LExp 161 | -> LExp 162 | -> State CGBodyState ([JsStmt], JsStmt) 163 | cgBinOP op rt x y = do 164 | (d, v) <- cgBody GetExpBT x 165 | (d', v') <- cgBody GetExpBT y 166 | pure $ (d ++ d', addRT rt $ JsBinOp op (jsStmt2Expr v) (jsStmt2Expr v')) 167 | 168 | cgBody :: BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt) 169 | cgBody' :: BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt) 170 | -- rewriteing 171 | cgBody rt expr = 172 | case expr of 173 | (LCase _ (LOp oper [x, y]) [LConstCase (I 0) (LCon _ _ ff []), LDefaultCase (LCon _ _ tt [])]) 174 | | (ff == qualifyN "Prelude.Bool" "False" && 175 | tt == qualifyN "Prelude.Bool" "True") -> 176 | case (primOpToJsOperator oper) of 177 | Just txt -> cgBinOP txt rt x y 178 | _ -> cgBody' rt expr 179 | (LCase f e [LConCase nf ff [] alt, LConCase nt tt [] conseq]) 180 | | (ff == qualifyN "Prelude.Bool" "False" && 181 | tt == qualifyN "Prelude.Bool" "True") -> 182 | cgBody' rt $ LCase f e [LConCase nt tt [] conseq, LConCase nf ff [] alt] 183 | expr -> cgBody' rt expr 184 | 185 | -- ordinary 186 | cgBody' rt (LV n) = do 187 | st <- get 188 | case (lookupCtxtExact n (defs st)) of 189 | Just (LFun _ _ [a] d) -> do 190 | nm <- cgName n 191 | pure $ ([], addRT rt nm) 192 | _ -> cgBody rt (LApp False (LV n) []) -- recurry 193 | cgBody' rt (LApp _ (LV fn) args) = do 194 | let fname = jsName fn 195 | st <- get 196 | let (currFn, argN) = currentFnNameAndArgs st 197 | z <- mapM (cgBody GetExpBT) args 198 | let preDecs = concat $ map fst z 199 | case (fname == currFn, rt) of 200 | (True, ReturnBT) -> do 201 | put $ st {isTailRec = True} 202 | vars <- sequence $ map (\_ -> getNewCGName) argN 203 | let calcs = 204 | map 205 | (\(n, v) -> JsDecConst n v) 206 | (zip vars (map (jsStmt2Expr . snd) z)) 207 | let calcsToArgs = 208 | map (\(n, v) -> JsSet (JsVar n) (JsVar v)) (zip argN vars) 209 | pure (preDecs ++ calcs ++ calcsToArgs, JsContinue) 210 | _ -> do 211 | app <- formApp fn (map (jsStmt2Expr . snd) z) 212 | pure $ (preDecs, addRT rt app) 213 | cgBody' rt (LForce (LLazyApp n args)) = 214 | cgBody rt (LApp False (LV n) args) 215 | cgBody' rt (LLazyApp fn args) = do 216 | st <- get 217 | z <- mapM (cgBody GetExpBT) args 218 | let preDecs = concat $ map fst z 219 | let na = map (T.pack . ("$" ++) . show) $ take (length z) [1 ..] 220 | app <- formApp fn (map JsVar na) 221 | pure 222 | ( preDecs 223 | , addRT rt $ 224 | JsApp (JsLambda (na) $ JsReturn $ jsLazy app) (map (jsStmt2Expr . snd) z)) 225 | cgBody' rt (LForce e) = do 226 | (d, v) <- cgBody GetExpBT e 227 | pure (d, addRT rt $ JsForce $ jsStmt2Expr v) 228 | cgBody' rt (LLet n v sc) = do 229 | (d1, v1) <- cgBody (DecVarBT $ jsName n) v 230 | (d2, v2) <- cgBody rt sc 231 | pure $ ((d1 ++ v1 : d2), v2) 232 | cgBody' rt (LProj e i) = do 233 | (d, v) <- cgBody GetExpBT e 234 | pure $ (d, addRT rt $ JsProp (jsStmt2Expr v) (T.pack $ "$" ++ (show $ i + 1))) 235 | cgBody' rt (LCon _ conId n args) = do 236 | z <- mapM (cgBody GetExpBT) args 237 | con <- formCon n (map (jsStmt2Expr . snd) z) 238 | pure $ (concat $ map fst z, addRT rt con) 239 | cgBody' rt (LCase _ e alts) = do 240 | (d, v) <- cgBody GetExpBT e 241 | resName <- getNewCGName 242 | (decSw, entry) <- 243 | case (all altHasNoProj alts && length alts <= 2, v) of 244 | (True, _) -> pure (JsEmpty, jsStmt2Expr v) 245 | (False, JsExprStmt (JsVar n)) -> pure (JsEmpty, jsStmt2Expr v) 246 | _ -> do 247 | swName <- getNewCGName 248 | pure (JsDecConst swName $ jsStmt2Expr v, JsVar swName) 249 | sw' <- cgIfTree rt resName entry alts 250 | let sw = 251 | case sw' of 252 | (Just x) -> x 253 | Nothing -> JsExprStmt JsNull 254 | case rt of 255 | ReturnBT -> pure (d ++ [decSw], sw) 256 | (DecVarBT nvar) -> pure (d ++ [decSw, JsDecLet nvar JsNull], sw) 257 | (SetVarBT nvar) -> pure (d ++ [decSw], sw) 258 | GetExpBT -> 259 | pure 260 | (d ++ [decSw, JsDecLet resName JsNull, sw], JsExprStmt $ JsVar resName) 261 | cgBody' rt (LConst c) = pure ([], (addRT rt) $ cgConst c) 262 | cgBody' rt (LOp op args) = do 263 | z <- mapM (cgBody GetExpBT) args 264 | pure $ (concat $ map fst z, addRT rt $ cgOp op (map (jsStmt2Expr . snd) z)) 265 | cgBody' rt LNothing = pure ([], addRT rt JsNull) 266 | cgBody' rt (LError x) = pure ([JsError $ JsStr $ T.pack $ x], addRT rt JsNull) 267 | cgBody' rt x@(LForeign dres (FStr code) args) = do 268 | z <- mapM (cgBody GetExpBT) (map snd args) 269 | let jsArgs = map cgForeignArg (zip (map fst args) (map (jsStmt2Expr . snd) z)) 270 | pure $ 271 | ( concat $ map fst z 272 | , addRT rt $ cgForeignRes dres $ JsForeign (T.pack code) jsArgs) 273 | cgBody' _ x = error $ "Instruction " ++ show x ++ " not compilable yet" 274 | 275 | formCon :: Name -> [JsExpr] -> State CGBodyState JsExpr 276 | formCon n args = do 277 | case specialCased n of 278 | Just (ctor, test, match) -> pure $ ctor args 279 | Nothing -> do 280 | (conId, arity) <- getConsId n 281 | if (arity > 0) 282 | then pure $ 283 | JsObj $ 284 | (T.pack "type", JsInt conId) : 285 | zip (map (\i -> T.pack $ "$" ++ show i) [1 ..]) args 286 | else pure $ JsInt conId 287 | 288 | formConTest :: Name -> JsExpr -> State CGBodyState JsExpr 289 | formConTest n x = do 290 | case specialCased n of 291 | Just (ctor, test, match) -> pure $ test x 292 | Nothing -> do 293 | (conId, arity) <- getConsId n 294 | if (arity > 0) 295 | then pure $ JsBinOp "===" (JsProp x (T.pack "type")) (JsInt conId) 296 | else pure $ JsBinOp "===" x (JsInt conId) 297 | 298 | formApp :: Name -> [JsExpr] -> State CGBodyState JsExpr 299 | formApp fn argsJS = do 300 | st <- get 301 | let alen = length argsJS 302 | fname <- cgName fn 303 | case (specialCall fn, lookupCtxtExact fn $ defs st) of 304 | (Just (arity, g), _) 305 | | arity == length argsJS -> pure $ g argsJS 306 | (_, Just (LFun _ _ ps _)) 307 | | (length ps) == 0 && alen == 0 -> pure fname 308 | | (length ps) == 0 && alen > 0 -> 309 | pure $ jsCurryApp (fname) (drop (length ps) argsJS) 310 | | (length ps) == alen -> pure $ JsApp fname argsJS 311 | | (length ps) < alen -> 312 | pure $ 313 | jsCurryApp 314 | (JsApp fname (take (length ps) argsJS)) 315 | (drop (length ps) argsJS) 316 | -- underapplication 317 | | (length ps) > alen -> do 318 | let existings = map (T.pack . ("$h" ++) . show) $ take alen [1 ..] 319 | let missings = 320 | map (T.pack . ("$m" ++) . show) $ take ((length ps) - alen) [1 ..] 321 | case (alen, length ps) of 322 | (0, 1) -> pure fname 323 | (0, n) -> 324 | pure $ 325 | jsCurryLam missings $ 326 | JsApp fname (map JsVar existings ++ map JsVar missings) 327 | (m, n) -> 328 | pure $ 329 | JsApp 330 | (JsLambda existings $ 331 | JsReturn $ 332 | jsCurryLam missings $ 333 | JsApp fname (map JsVar existings ++ map JsVar missings)) 334 | argsJS 335 | _ -> pure $ jsCurryApp fname argsJS 336 | 337 | altHasNoProj :: LAlt -> Bool 338 | altHasNoProj (LConCase _ _ args _) = args == [] 339 | altHasNoProj _ = True 340 | 341 | formProj :: Name -> JsExpr -> Int -> JsExpr 342 | formProj n v i = 343 | case specialCased n of 344 | Just (ctor, test, proj) -> proj v i 345 | Nothing -> JsProp v (T.pack $ "$" ++ show i) 346 | 347 | altsRT :: Text -> BodyResTarget -> BodyResTarget 348 | altsRT rn ReturnBT = ReturnBT 349 | altsRT rn (DecVarBT n) = SetVarBT n 350 | altsRT rn (SetVarBT n) = SetVarBT n 351 | altsRT rn GetExpBT = SetVarBT rn 352 | 353 | smartif :: JsExpr -> JsStmt -> Maybe JsStmt -> JsStmt 354 | smartif cond conseq (Just alt) = JsIf cond conseq (Just alt) 355 | smartif cond conseq Nothing = conseq 356 | 357 | cgIfTree :: BodyResTarget 358 | -> Text 359 | -> JsExpr 360 | -> [LAlt] 361 | -> State CGBodyState (Maybe JsStmt) 362 | cgIfTree _ _ _ [] = pure Nothing 363 | cgIfTree rt resName scrvar ((LConstCase t exp):r) = do 364 | (d, v) <- cgBody (altsRT resName rt) exp 365 | alternatives <- cgIfTree rt resName scrvar r 366 | pure $ 367 | Just $ 368 | smartif (JsBinOp "===" scrvar (cgConst t)) (JsSeq (seqJs d) v) alternatives 369 | cgIfTree rt resName scrvar ((LDefaultCase exp):r) = do 370 | (d, v) <- cgBody (altsRT resName rt) exp 371 | pure $ Just $ JsSeq (seqJs d) v 372 | cgIfTree rt resName scrvar ((LConCase _ n args exp):r) = do 373 | alternatives <- cgIfTree rt resName scrvar r 374 | test <- formConTest n scrvar 375 | st <- get 376 | let rwn = reWrittenNames st 377 | put $ 378 | st 379 | { reWrittenNames = 380 | foldl 381 | (\m (n, j) -> Map.insert n (formProj n scrvar j) m) 382 | rwn 383 | (zip args [1 ..]) 384 | } 385 | (d, v) <- cgBody (altsRT resName rt) exp 386 | st1 <- get 387 | put $ st1 {reWrittenNames = rwn} 388 | let branchBody = JsSeq (seqJs d) v 389 | pure $ Just $ smartif test branchBody alternatives 390 | 391 | cgForeignArg :: (FDesc, JsExpr) -> JsExpr 392 | cgForeignArg (FApp (UN "JS_IntT") _, v) = v 393 | cgForeignArg (FCon (UN "JS_Str"), v) = v 394 | cgForeignArg (FCon (UN "JS_Ptr"), v) = v 395 | cgForeignArg (FCon (UN "JS_Unit"), v) = v 396 | cgForeignArg (FApp (UN "JS_FnT") [_, FApp (UN "JS_Fn") [_, _, a, FApp (UN "JS_FnBase") [_, b]]], f) = 397 | f 398 | cgForeignArg (FApp (UN "JS_FnT") [_, FApp (UN "JS_Fn") [_, _, a, FApp (UN "JS_FnIO") [_, _, b]]], f) = 399 | JsLambda ["x"] $ 400 | JsReturn $ 401 | cgForeignRes b $ 402 | jsCurryApp (jsCurryApp f [cgForeignArg (a, JsVar "x")]) [JsNull] 403 | cgForeignArg (desc, _) = 404 | error $ "Foreign arg type " ++ show desc ++ " not supported yet." 405 | 406 | cgForeignRes :: FDesc -> JsExpr -> JsExpr 407 | cgForeignRes (FApp (UN "JS_IntT") _) x = x 408 | cgForeignRes (FCon (UN "JS_Unit")) x = x 409 | cgForeignRes (FCon (UN "JS_Str")) x = x 410 | cgForeignRes (FCon (UN "JS_Ptr")) x = x 411 | cgForeignRes (FCon (UN "JS_Float")) x = x 412 | cgForeignRes desc val = 413 | error $ "Foreign return type " ++ show desc ++ " not supported yet." 414 | 415 | cgConst :: Const -> JsExpr 416 | cgConst (I i) = JsInt i 417 | cgConst (BI i) = JsInteger i 418 | cgConst (Ch c) = JsInt $ ord c 419 | cgConst (Str s) = JsStr $ T.pack s 420 | cgConst (Fl f) = JsDouble f 421 | cgConst (B8 x) = error "error B8" 422 | cgConst (B16 x) = error "error B16" 423 | cgConst (B32 x) = error "error B32" 424 | cgConst (B64 x) = error "error B64" 425 | cgConst x 426 | | isTypeConst x = JsInt 0 427 | cgConst x = error $ "Constant " ++ show x ++ " not compilable yet" 428 | 429 | primOpToJsOperator :: PrimFn -> Maybe Text 430 | primOpToJsOperator (LEq _) = Just "===" 431 | primOpToJsOperator (LSLt _) = Just "<" 432 | primOpToJsOperator (LSLe _) = Just "<=" 433 | primOpToJsOperator (LSGt _) = Just ">" 434 | primOpToJsOperator (LSGe _) = Just ">=" 435 | primOpToJsOperator LStrEq = Just "===" 436 | primOpToJsOperator LStrLt = Just "<" 437 | primOpToJsOperator _ = Nothing 438 | 439 | cgOp :: PrimFn -> [JsExpr] -> JsExpr 440 | cgOp (LPlus _) [l, r] = JsBinOp "+" l r 441 | cgOp (LMinus _) [l, r] = JsBinOp "-" l r 442 | cgOp (LTimes _) [l, r] = JsBinOp "*" l r 443 | cgOp (LEq _) [l, r] = JsB2I $ JsBinOp "===" l r 444 | cgOp (LSLt _) [l, r] = JsB2I $ JsBinOp "<" l r 445 | cgOp (LSLe _) [l, r] = JsB2I $ JsBinOp "<=" l r 446 | cgOp (LSGt _) [l, r] = JsB2I $ JsBinOp ">" l r 447 | cgOp (LSGe _) [l, r] = JsB2I $ JsBinOp ">=" l r 448 | cgOp LStrEq [l, r] = JsB2I $ JsBinOp "===" l r 449 | cgOp LStrLen [x] = JsForeign "%0.length" [x] 450 | cgOp LStrHead [x] = JsMethod x "charCodeAt" [JsInt 0] 451 | cgOp LStrIndex [x, y] = JsMethod x "charCodeAt" [y] 452 | cgOp LStrTail [x] = JsMethod x "slice" [JsInt 1] 453 | cgOp LStrLt [l, r] = JsB2I $ JsBinOp "<" l r 454 | cgOp (LFloatStr) [x] = JsBinOp "+" x (JsStr "") 455 | cgOp (LIntStr _) [x] = JsBinOp "+" x (JsStr "") 456 | cgOp (LFloatInt _) [x] = jsAppN "Math.trunc" [x] 457 | cgOp (LStrInt _) [x] = JsBinOp "||" (jsAppN "parseInt" [x]) (JsInt 0) 458 | cgOp (LStrFloat) [x] = JsBinOp "||" (jsAppN "parseFloat" [x]) (JsInt 0) 459 | cgOp (LChInt _) [x] = x 460 | cgOp (LIntCh _) [x] = x 461 | cgOp (LSExt _ _) [x] = x 462 | cgOp (LZExt _ _) [x] = x 463 | cgOp (LIntFloat _) [x] = x 464 | cgOp (LSDiv _) [x, y] = JsBinOp "/" x y 465 | cgOp LWriteStr [_, str] = jsAppN "process.stdout.write" [str] 466 | cgOp LStrConcat [l, r] = JsBinOp "+" l r 467 | cgOp LStrCons [l, r] = JsForeign "String.fromCharCode(%0) + %1" [l, r] 468 | cgOp (LSRem (ATInt _)) [l, r] = JsBinOp "%" l r 469 | cgOp LCrash [l] = JsErrorExp l 470 | cgOp op exps = error ("Operator " ++ show (op, exps) ++ " not implemented") 471 | -------------------------------------------------------------------------------- /src/IRTS/CodegenEs/JsAST.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} 2 | 3 | module IRTS.CodegenEs.JsAST 4 | ( JsExpr(..) 5 | , JsStmt(..) 6 | , jsAst2Text 7 | , jsStmt2Text 8 | , jsLazy 9 | , jsCurryLam 10 | , jsCurryApp 11 | , jsAppN 12 | , js_aux_defs 13 | , jsExpr2Stmt 14 | , jsStmt2Expr 15 | ) where 16 | 17 | import Data.Data 18 | import Data.Text (Text) 19 | import qualified Data.Text as T 20 | 21 | data JsStmt 22 | = JsEmpty 23 | | JsExprStmt JsExpr 24 | | JsFun Text 25 | [Text] 26 | JsStmt 27 | | JsSeq JsStmt 28 | JsStmt 29 | | JsReturn JsExpr 30 | | JsDecVar Text 31 | JsExpr 32 | | JsDecConst Text 33 | JsExpr 34 | | JsDecLet Text 35 | JsExpr 36 | | JsSet JsExpr 37 | JsExpr 38 | | JsIf JsExpr 39 | JsStmt 40 | (Maybe JsStmt) 41 | | JsSwitchCase JsExpr 42 | [(JsExpr, JsStmt)] 43 | (Maybe JsStmt) 44 | | JsError JsExpr 45 | | JsForever JsStmt 46 | | JsContinue 47 | | JsBreak 48 | deriving (Show, Eq, Data, Typeable) 49 | 50 | data JsExpr 51 | = JsNull 52 | | JsUndefined 53 | | JsThis 54 | | JsLambda [Text] 55 | JsStmt 56 | | JsApp JsExpr 57 | [JsExpr] 58 | | JsPart JsExpr 59 | Text 60 | | JsMethod JsExpr 61 | Text 62 | [JsExpr] 63 | | JsVar Text 64 | | JsArrayProj JsExpr 65 | JsExpr 66 | | JsObj [(Text, JsExpr)] 67 | | JsProp JsExpr 68 | Text 69 | | JsInt Int 70 | | JsBool Bool 71 | | JsInteger Integer 72 | | JsDouble Double 73 | | JsStr Text 74 | | JsArray [JsExpr] 75 | | JsErrorExp JsExpr 76 | | JsUniOp Text 77 | JsExpr 78 | | JsBinOp Text 79 | JsExpr 80 | JsExpr 81 | | JsForeign Text 82 | [JsExpr] 83 | | JsB2I JsExpr 84 | | JsComment Text 85 | | JsForce JsExpr 86 | deriving (Show, Eq, Data, Typeable) 87 | 88 | indent :: Text -> Text 89 | indent x = 90 | let l = T.lines x 91 | il = map (\y -> T.replicate 4 " " `T.append` y) l 92 | in T.unlines il 93 | 94 | jsCurryLam :: [Text] -> JsExpr -> JsExpr 95 | jsCurryLam [] body = body 96 | jsCurryLam (x:xs) body = JsLambda [x] $ JsReturn $ jsCurryLam xs body 97 | 98 | jsCurryApp :: JsExpr -> [JsExpr] -> JsExpr 99 | jsCurryApp fn [] = fn 100 | jsCurryApp fn args = foldl (\ff aa -> JsApp ff [aa]) fn args 101 | 102 | jsAppN :: Text -> [JsExpr] -> JsExpr 103 | jsAppN fn args = JsApp (JsVar fn) args 104 | 105 | jsStmt2Text :: JsStmt -> Text 106 | jsStmt2Text JsEmpty = "" 107 | jsStmt2Text (JsExprStmt e) = T.concat [jsAst2Text e, ";"] 108 | jsStmt2Text (JsReturn x) = T.concat ["return ", jsAst2Text x, ";"] 109 | jsStmt2Text (JsDecVar name exp) = 110 | T.concat ["var ", name, " = ", jsAst2Text exp, ";"] 111 | jsStmt2Text (JsDecConst name exp) = 112 | T.concat ["const ", name, " = ", jsAst2Text exp, ";"] 113 | jsStmt2Text (JsDecLet name exp) = 114 | T.concat ["let ", name, " = ", jsAst2Text exp, ";"] 115 | jsStmt2Text (JsFun name args body) = 116 | T.concat 117 | [ "function " 118 | , name 119 | , "(" 120 | , T.intercalate ", " args 121 | , "){\n" 122 | , indent $ jsStmt2Text body 123 | , "}\n" 124 | ] 125 | jsStmt2Text (JsIf cond conseq (Just next@(JsIf _ _ _))) = 126 | T.concat 127 | [ "if(" 128 | , jsAst2Text cond 129 | , ") {\n" 130 | , indent $ jsStmt2Text conseq 131 | , "} else " 132 | , jsStmt2Text next 133 | ] 134 | jsStmt2Text (JsIf cond conseq (Just alt)) = 135 | T.concat 136 | [ "if(" 137 | , jsAst2Text cond 138 | , ") {\n" 139 | , indent $ jsStmt2Text conseq 140 | , "} else {\n" 141 | , indent $ jsStmt2Text alt 142 | , "}\n" 143 | ] 144 | jsStmt2Text (JsIf cond conseq Nothing) = 145 | T.concat ["if(", jsAst2Text cond, ") {\n", indent $ jsStmt2Text conseq, "}\n"] 146 | jsStmt2Text (JsSwitchCase exp l d) = 147 | T.concat 148 | [ "switch(" 149 | , jsAst2Text exp 150 | , "){\n" 151 | , indent $ T.concat $ map case2Text l 152 | , indent $ default2Text d 153 | , "}\n" 154 | ] 155 | where 156 | case2Text :: (JsExpr, JsStmt) -> Text 157 | case2Text (x, y) = 158 | T.concat 159 | [ "case " 160 | , jsAst2Text x 161 | , ":\n" 162 | , indent $ T.concat [jsStmt2Text y, ";\nbreak;\n"] 163 | ] 164 | default2Text :: Maybe JsStmt -> Text 165 | default2Text Nothing = "" 166 | default2Text (Just z) = 167 | T.concat ["default:\n", indent $ T.concat [jsStmt2Text z, ";\nbreak;\n"]] 168 | jsStmt2Text (JsError t) = T.concat ["throw new Error( ", jsAst2Text t, ");"] 169 | jsStmt2Text (JsForever x) = 170 | T.concat ["for(;;) {\n", indent $ jsStmt2Text x, "}\n"] 171 | jsStmt2Text JsContinue = "continue;" 172 | jsStmt2Text JsBreak = "break;" 173 | jsStmt2Text (JsSeq JsEmpty y) = jsStmt2Text y 174 | jsStmt2Text (JsSeq x JsEmpty) = jsStmt2Text x 175 | jsStmt2Text (JsSeq x y) = T.concat [jsStmt2Text x, "\n", jsStmt2Text y] 176 | jsStmt2Text (JsSet term exp) = 177 | T.concat [jsAst2Text term, " = ", jsAst2Text exp, ";"] 178 | 179 | jsAst2Text :: JsExpr -> Text 180 | jsAst2Text JsNull = "null" 181 | jsAst2Text JsUndefined = "(void 0)" 182 | jsAst2Text JsThis = "this" 183 | jsAst2Text (JsLambda args body) = 184 | T.concat 185 | [ "(function" 186 | , "(" 187 | , T.intercalate ", " args 188 | , "){\n" 189 | , indent $ jsStmt2Text body 190 | , "})" 191 | ] 192 | jsAst2Text (JsApp fn args) = 193 | T.concat [jsAst2Text fn, "(", T.intercalate ", " $ map jsAst2Text args, ")"] 194 | jsAst2Text (JsMethod obj name args) = 195 | T.concat 196 | [ jsAst2Text obj 197 | , "." 198 | , name 199 | , "(" 200 | , T.intercalate ", " $ map jsAst2Text args 201 | , ")" 202 | ] 203 | jsAst2Text (JsPart obj name) = 204 | T.concat [jsAst2Text obj, "[", T.pack (show name), "]"] 205 | jsAst2Text (JsVar x) = x 206 | jsAst2Text (JsObj props) = 207 | T.concat 208 | [ "({" 209 | , T.intercalate 210 | ", " 211 | (map (\(name, val) -> T.concat [name, ": ", jsAst2Text val]) props) 212 | , "})" 213 | ] 214 | jsAst2Text (JsProp object name) = T.concat [jsAst2Text object, ".", name] 215 | jsAst2Text (JsArrayProj i exp) = 216 | T.concat [jsAst2Text exp, "[", jsAst2Text i, "]"] 217 | jsAst2Text (JsInt i) = T.pack $ show i 218 | jsAst2Text (JsBool True) = T.pack "true" 219 | jsAst2Text (JsBool False) = T.pack "false" 220 | jsAst2Text (JsDouble d) = T.pack $ show d 221 | jsAst2Text (JsInteger i) = T.pack $ show i 222 | jsAst2Text (JsStr s) = T.pack $ show s 223 | jsAst2Text (JsArray l) = 224 | T.concat ["[", T.intercalate ", " (map jsAst2Text l), "]"] 225 | jsAst2Text (JsErrorExp t) = 226 | T.concat ["js_idris_throw2(new Error( ", jsAst2Text t, "))"] 227 | jsAst2Text (JsBinOp op a1 a2) = 228 | T.concat ["(", jsAst2Text a1, " ", op, " ", jsAst2Text a2, ")"] 229 | jsAst2Text (JsUniOp op a) = T.concat ["(", op, jsAst2Text a, ")"] 230 | jsAst2Text (JsForeign code args) = 231 | let args_repl c i [] = c 232 | args_repl c i (t:r) = 233 | args_repl (T.replace ("%" `T.append` T.pack (show i)) t c) (i + 1) r 234 | in T.concat ["(", args_repl code 0 (map jsAst2Text args), ")"] 235 | jsAst2Text (JsB2I x) = jsAst2Text $ JsBinOp "+" x (JsInt 0) 236 | jsAst2Text (JsComment c) = T.concat ["/*", c, "*/"] 237 | jsAst2Text (JsForce e) = T.concat ["js_idris_force(", jsAst2Text e, ")"] 238 | 239 | jsLazy :: JsExpr -> JsExpr 240 | jsLazy e = JsObj [("js_idris_lazy_calc", (JsLambda [] $ JsReturn e))] 241 | 242 | throw2 = 243 | T.concat ["var js_idris_throw2 = function (x){\n", " throw x;\n", "}\n"] 244 | 245 | force = 246 | T.concat 247 | [ "var js_idris_force = function (x){\n" 248 | , " if(x.js_idris_lazy_calc === undefined){\n" 249 | , " return x\n" 250 | , " }else{\n" 251 | , " if(x.js_idris_lazy_val === undefined){\n" 252 | , " x.js_idris_lazy_val = x.js_idris_lazy_calc()\n" 253 | , " }\n" 254 | , " return x.js_idris_lazy_val\n" 255 | , " }\n" 256 | , "}\n" 257 | ] 258 | 259 | js_aux_defs = T.concat [throw2, force] 260 | 261 | jsExpr2Stmt :: JsExpr -> JsStmt 262 | jsExpr2Stmt = JsExprStmt 263 | 264 | jsStmt2Expr :: JsStmt -> JsExpr 265 | jsStmt2Expr (JsExprStmt x) = x 266 | jsStmt2Expr x = JsApp (JsLambda [] x) [] 267 | -------------------------------------------------------------------------------- /src/IRTS/CodegenEs/JsName.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE PatternGuards #-} 3 | 4 | module IRTS.CodegenEs.JsName 5 | ( jsName 6 | , jsNameGenerated 7 | ) where 8 | 9 | import Data.Char 10 | import Data.List 11 | import qualified Data.Map.Strict as Map 12 | import Data.Text (Text) 13 | import qualified Data.Text as T 14 | import IRTS.CodegenEs.JsAST 15 | import Idris.Core.TT 16 | 17 | jsEscape :: String -> String 18 | jsEscape = concatMap jschar 19 | where 20 | jschar x 21 | | isAlpha x || isDigit x = [x] 22 | | x == '.' = "__" 23 | | otherwise = "_" ++ show (fromEnum x) ++ "_" 24 | 25 | showCGJS :: Name -> String 26 | showCGJS (UN n) = T.unpack n 27 | showCGJS (NS n s) = showSep "." (map T.unpack (reverse s)) ++ "." ++ showCGJS n 28 | showCGJS (MN _ u) 29 | | u == txt "underscore" = "_" 30 | showCGJS (MN i s) = "{" ++ T.unpack s ++ "_" ++ show i ++ "}" 31 | showCGJS (SN s) = showCGJS' s 32 | where 33 | showCGJS' (WhereN i p c) = 34 | "where{" ++ showCGJS p ++ ";" ++ showCGJS c ++ ";" ++ show i ++ "}" 35 | showCGJS' (WithN i n) = "_" ++ "with{" ++ showCGJS n ++ ";" ++ show i ++ "}" 36 | showCGJS' (ImplementationN cl impl) = 37 | "impl{" ++ showCGJS cl ++ ";" ++ showSep ";" (map T.unpack impl) ++ "}" 38 | showCGJS' (MethodN m) = "meth{" ++ showCGJS m ++ "}" 39 | showCGJS' (ParentN p c) = "par{" ++ showCGJS p ++ ";" ++ show c ++ "}" 40 | showCGJS' (CaseN fc c) = "case{" ++ showCGJS c ++ ";" ++ showFC' fc ++ "}" 41 | showCGJS' (ImplementationCtorN n) = "ictor{" ++ showCGJS n ++ "}" 42 | showCGJS' (MetaN parent meta) = 43 | "meta{" ++ showCGJS parent ++ ";" ++ showCGJS meta ++ "}" 44 | showFC' (FC' NoFC) = "" 45 | showFC' (FC' (FileFC f)) = "_" ++ cgFN f 46 | showFC' (FC' (FC f s e)) 47 | | s == e = "_" ++ cgFN f ++ "_" ++ show (fst s) ++ "_" ++ show (snd s) 48 | | otherwise = 49 | "_" ++ 50 | cgFN f ++ 51 | "_" ++ 52 | show (fst s) ++ 53 | "_" ++ show (snd s) ++ "_" ++ show (fst e) ++ "_" ++ show (snd e) 54 | cgFN = 55 | concatMap 56 | (\c -> 57 | if not (isDigit c || isLetter c) 58 | then "__" 59 | else [c]) 60 | showCGJS (SymRef i) = error "can't do codegen for a symbol reference" 61 | 62 | jsName :: Name -> Text 63 | jsName n = 64 | let name = showCGJS n 65 | in T.pack $ jsEscape name 66 | 67 | jsNameGenerated :: Int -> Text 68 | jsNameGenerated v = T.pack $ "$idris_" ++ show v 69 | -------------------------------------------------------------------------------- /src/IRTS/CodegenEs/LangTransforms.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, 2 | OverloadedStrings, DeriveGeneric, DeriveAnyClass, FlexibleInstances 3 | #-} 4 | 5 | module IRTS.CodegenEs.LangTransforms 6 | ( used_decls 7 | ) where 8 | 9 | import Control.DeepSeq 10 | import Control.Monad.Trans.State 11 | import Data.List 12 | import Data.Map.Strict (Map) 13 | import qualified Data.Map.Strict as Map 14 | import Data.Maybe 15 | import Data.Set (Set) 16 | import qualified Data.Set as Set 17 | import Data.Text (Text) 18 | import qualified Data.Text as T 19 | import IRTS.Lang 20 | import Idris.Core.CaseTree 21 | import Idris.Core.TT 22 | 23 | import Data.Data 24 | import Data.Generics.Uniplate.Data 25 | import GHC.Generics (Generic) 26 | 27 | deriving instance Typeable (LAlt' LExp) 28 | 29 | deriving instance Typeable FDesc 30 | 31 | deriving instance Data FDesc 32 | 33 | deriving instance Typeable LVar 34 | 35 | deriving instance Data LVar 36 | 37 | deriving instance Typeable PrimFn 38 | 39 | deriving instance Data PrimFn 40 | 41 | deriving instance Typeable CaseType 42 | 43 | deriving instance Data CaseType 44 | 45 | deriving instance Typeable LExp 46 | 47 | deriving instance Data LExp 48 | 49 | deriving instance Typeable LDecl 50 | 51 | deriving instance Data LDecl 52 | 53 | deriving instance Typeable LOpt 54 | 55 | deriving instance Data LOpt 56 | 57 | deriving instance NFData FC 58 | 59 | deriving instance NFData FC' 60 | 61 | deriving instance NFData SpecialName 62 | 63 | deriving instance NFData Name 64 | 65 | deriving instance Generic LDecl 66 | 67 | deriving instance NFData LDecl 68 | 69 | deriving instance Generic LOpt 70 | 71 | deriving instance NFData LOpt 72 | 73 | deriving instance Generic LExp 74 | 75 | deriving instance NFData LExp 76 | 77 | deriving instance NFData FDesc 78 | 79 | deriving instance Generic FDesc 80 | 81 | deriving instance NFData ArithTy 82 | 83 | deriving instance NFData PrimFn 84 | 85 | deriving instance Generic LVar 86 | 87 | deriving instance NFData LVar 88 | 89 | deriving instance NFData IntTy 90 | 91 | deriving instance NFData NativeTy 92 | 93 | deriving instance NFData Const 94 | 95 | deriving instance NFData CaseType 96 | 97 | deriving instance NFData (LAlt' LExp) 98 | 99 | deriving instance Generic (LAlt' e) 100 | 101 | --data Fun = Fun Name [Name] LExp deriving (Data, Typeable) 102 | --data Con = Con Name Int Int deriving (Data, Typeable) 103 | restrictKeys 104 | :: Ord k 105 | => Map k a -> Set k -> Map k a 106 | restrictKeys m s = Map.filterWithKey (\k _ -> k `Set.member` s) m 107 | 108 | mapMapListKeys 109 | :: Ord k 110 | => (a -> a) -> [k] -> Map k a -> Map k a 111 | mapMapListKeys _ [] x = x 112 | mapMapListKeys f (t:r) x = mapMapListKeys f r $ Map.adjust f t x 113 | 114 | memberCtx :: Name -> Ctxt a -> Bool 115 | memberCtx n ctx = 116 | case lookupCtxtExact n ctx of 117 | Nothing -> False 118 | Just _ -> True 119 | 120 | {- 121 | getFunctionCallsInExp :: LExp -> [Name] 122 | getFunctionCallsInExp e = [ n | LApp _ n _ <- universe e] ++ [ n | LLazyApp Name [LExp] <- universe e] 123 | -} 124 | {- 125 | used_functions :: Map Name LDecl -> [Name] -> [Name] 126 | used_functions _ [] = [] 127 | used_functions alldefs (next_name:rest) = 128 | let new_names = case Map.lookup next_name alldefs of 129 | Just e -> filter (\x -> Map.member x alldefs) (universeBi e) --filter (\x -> Map.member x alldefs) $ getFunctionCallsInExp e 130 | _ -> [] 131 | in next_name : used_functions (Map.delete next_name alldefs) (rest ++ new_names) 132 | -} 133 | extract_globs :: LDefs -> LDecl -> [Name] 134 | extract_globs defs (LConstructor _ _ _) = [] 135 | extract_globs defs (LFun _ _ _ e) = 136 | let f (LV x) = Just x 137 | f (LLazyApp x _) = Just x 138 | f _ = Nothing 139 | in [x | Just x <- map f $ universe e, memberCtx x defs] 140 | 141 | used_functions :: LDefs -> Set Name -> [Name] -> [Name] 142 | used_functions _ _ [] = [] 143 | used_functions alldefs done names = 144 | let decls = catMaybes $ map (\x -> lookupCtxtExact x alldefs) names 145 | used_names = (nub $ concat $ map (extract_globs alldefs) decls) \\ names 146 | new_names = filter (\x -> not $ Set.member x done) used_names 147 | in used_names ++ 148 | used_functions alldefs (Set.union done $ Set.fromList new_names) new_names 149 | 150 | used_decls :: LDefs -> [Name] -> [LDecl] 151 | used_decls dcls start = 152 | let used = reverse $ start ++ used_functions dcls (Set.fromList start) start 153 | in catMaybes $ map (\x -> lookupCtxtExact x dcls) used 154 | -------------------------------------------------------------------------------- /src/IRTS/CodegenEs/Specialize.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE PatternGuards #-} 3 | 4 | module IRTS.CodegenEs.Specialize 5 | ( SCtor 6 | , STest 7 | , SProj 8 | , specialCased 9 | , specialCall 10 | , qualifyN 11 | ) where 12 | 13 | import Data.Char 14 | import Data.List 15 | import qualified Data.Map.Strict as Map 16 | import Data.Text (Text) 17 | import qualified Data.Text as T 18 | import IRTS.CodegenEs.JsAST 19 | import Idris.Core.TT 20 | 21 | split :: Char -> String -> [String] 22 | split c "" = [""] 23 | split c (x:xs) 24 | | c == x = "" : split c xs 25 | | otherwise = 26 | let ~(h:t) = split c xs 27 | in ((x : h) : t) 28 | 29 | qualify :: String -> Name -> Name 30 | qualify "" n = n 31 | qualify ns n = sNS n (reverse $ split '.' ns) 32 | 33 | qualifyN :: String -> String -> Name 34 | qualifyN ns n = qualify ns $ sUN n 35 | 36 | -- special-cased constructors 37 | type SCtor = [JsExpr] -> JsExpr 38 | 39 | type STest = JsExpr -> JsExpr 40 | 41 | type SProj = JsExpr -> Int -> JsExpr 42 | 43 | constructorOptimizeDB :: Map.Map Name (SCtor, STest, SProj) 44 | constructorOptimizeDB = 45 | Map.fromList 46 | [ item "Prelude.Bool" "True" (const $ JsBool True) id cantProj 47 | , item "Prelude.Bool" "False" (const $ JsBool False) falseTest cantProj 48 | -- , item "Prelude.List" "::" cons fillList uncons 49 | -- , item "Prelude.List" "Nil" nil emptyList cantProj 50 | -- , item "Prelude.Maybe" "Just" (\[x] -> x) notNoneTest justProj 51 | -- , item "Prelude.Maybe" "Nothing" (const $ JsUndefined) noneTest cantProj 52 | ] 53 | -- constructors 54 | where 55 | nil = const $ JsArray [] 56 | cons [h, t] = JsMethod (JsArray [h]) "concat" [t] 57 | -- tests 58 | falseTest e = JsUniOp (T.pack "!") e 59 | emptyList e = JsBinOp "===" (JsProp e "length") (JsInt 0) 60 | fillList e = JsBinOp ">" (JsProp e "length") (JsInt 0) 61 | noneTest e = JsBinOp "===" e JsUndefined 62 | notNoneTest e = JsBinOp "!==" e JsUndefined 63 | -- projections 64 | justProj x n = x 65 | uncons x 1 = JsArrayProj (JsInt 0) x 66 | uncons x 2 = JsMethod x "slice" [JsInt 1] 67 | cantProj x j = error $ "This type should be projected" 68 | item :: String 69 | -> String 70 | -> SCtor 71 | -> STest 72 | -> SProj 73 | -> (Name, (SCtor, STest, SProj)) 74 | item ns n ctor test match = (qualifyN ns n, (ctor, test, match)) 75 | 76 | specialCased :: Name -> Maybe (SCtor, STest, SProj) 77 | specialCased n = Map.lookup n constructorOptimizeDB 78 | 79 | -- special functions 80 | type SSig = (Int, [JsExpr] -> JsExpr) 81 | 82 | callSpecializeDB :: Map.Map Name (SSig) 83 | callSpecializeDB = 84 | Map.fromList 85 | [ qb "Eq" "Int" "==" "===" 86 | , qb "Ord" "Int" "<" "<" 87 | , qb "Ord" "Int" ">" ">" 88 | , qb "Ord" "Int" "<=" "<=" 89 | , qb "Ord" "Int" ">=" ">=" 90 | , qb "Eq" "Double" "==" "===" 91 | , qb "Ord" "Double" "<" "<" 92 | , qb "Ord" "Double" ">" ">" 93 | , qb "Ord" "Double" "<=" "<=" 94 | , qb "Ord" "Double" ">=" ">=" 95 | ] 96 | where 97 | qb intf ty op jsop = 98 | ( qualify "Prelude.Interfaces" $ 99 | SN $ 100 | WhereN 101 | 0 102 | (qualify "Prelude.Interfaces" $ 103 | SN $ ImplementationN (qualifyN "Prelude.Interfaces" intf) [ty]) 104 | (SN $ MethodN $ UN op) 105 | , (2, \[x, y] -> JsBinOp jsop x y)) 106 | 107 | specialCall :: Name -> Maybe SSig 108 | specialCall n = Map.lookup n callSpecializeDB 109 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Idris.AbsSyntax 4 | import Idris.Core.TT 5 | import Idris.ElabDecls 6 | import Idris.Main 7 | import Idris.Options 8 | 9 | import IRTS.CodegenEs 10 | import IRTS.Compiler 11 | 12 | import System.Environment 13 | import System.Exit 14 | 15 | import Control.Monad 16 | 17 | import Paths_idris_codegen_es 18 | 19 | data Opts = Opts 20 | { inputs :: [FilePath] 21 | , output :: FilePath 22 | } 23 | 24 | showUsage = do 25 | putStrLn 26 | "A code generator which is intended to be called by the compiler, not by a user." 27 | putStrLn "Usage: idris-codegen-es [-o ]" 28 | exitWith ExitSuccess 29 | 30 | getOpts :: IO Opts 31 | getOpts = do 32 | xs <- getArgs 33 | return $ process (Opts [] "a.out") xs 34 | where 35 | process opts ("-o":o:xs) = process (opts {output = o}) xs 36 | process opts (x:xs) = process (opts {inputs = x : inputs opts}) xs 37 | process opts [] = opts 38 | 39 | js_main :: Opts -> Idris () 40 | js_main opts = do 41 | elabPrims 42 | loadInputs (inputs opts) Nothing 43 | mainProg <- elabMain 44 | ir <- compile (Via IBCFormat "es") (output opts) (Just mainProg) 45 | runIO $ codegenJs ir 46 | 47 | main :: IO () 48 | main = do 49 | opts <- getOpts 50 | if (null (inputs opts)) 51 | then showUsage 52 | else runMain (js_main opts) 53 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2017-04-24 2 | extra-deps: 3 | - mintty-0.1.1 4 | flags: 5 | mintty: 6 | win32-2-5: false 7 | -------------------------------------------------------------------------------- /test.js: -------------------------------------------------------------------------------- 1 | const os = require('os'); 2 | const test = require('ava-spec').test; 3 | const co = require('co'); 4 | const cpp = require('child-process-promise'); 5 | const fsp = require('fs-promise'); 6 | const glob = require('glob-promise'); 7 | const throat = require('throat')(os.cpus().length); 8 | 9 | function compareText(a, b) { 10 | let a1 = a.trim().split(/\r?\n/g).join('\n'); 11 | let b1 = b.trim().split(/\r?\n/g).join('\n'); 12 | return a1 === b1; 13 | } 14 | 15 | test('Test framework actually works.', t => t.pass()); 16 | 17 | test.group("Idris-codegen-js", test => co(function* () { 18 | let files = yield glob('tests/*.idr'); 19 | for (let idr of files) { 20 | test(idr, function* (t) { 21 | const jspath = idr.replace(/\.idr$/, '.js') 22 | const trpath = idr.replace(/\.idr$/, '.testres') 23 | const compile = yield throat(() => cpp.spawn('idris', [ 24 | '--codegen', 'es', 25 | '-p', 'effects', 26 | '-p', 'js', 27 | '-o', jspath, 28 | idr 29 | ])); 30 | const run = yield cpp.spawn(process.argv[0], [jspath], { capture: ['stdout'] }); 31 | const tr = yield fsp.readFile(trpath, 'utf-8'); 32 | t.true(compareText(run.stdout, tr)); 33 | }) 34 | } 35 | })); 36 | -------------------------------------------------------------------------------- /tests/pythag.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | pythag : Int -> List (Int, Int, Int) 4 | pythag max = [(x, y, z) | z <- [1..max], y <- [1..z], x <- [1..y], 5 | x * x + y *y == z * z] 6 | 7 | main : IO () 8 | main = print (pythag 100) 9 | -------------------------------------------------------------------------------- /tests/pythag.testres: -------------------------------------------------------------------------------- 1 | [(3, (4, 5)), (6, (8, 10)), (5, (12, 13)), (9, (12, 15)), (8, (15, 17)), (12, (16, 20)), (15, (20, 25)), (7, (24, 25)), (10, (24, 26)), (20, (21, 29)), (18, (24, 30)), (16, (30, 34)), (21, (28, 35)), (12, (35, 37)), (15, (36, 39)), (24, (32, 40)), (9, (40, 41)), (27, (36, 45)), (30, (40, 50)), (14, (48, 50)), (24, (45, 51)), (20, (48, 52)), (28, (45, 53)), (33, (44, 55)), (40, (42, 58)), (36, (48, 60)), (11, (60, 61)), (39, (52, 65)), (33, (56, 65)), (25, (60, 65)), (16, (63, 65)), (32, (60, 68)), (42, (56, 70)), (48, (55, 73)), (24, (70, 74)), (45, (60, 75)), (21, (72, 75)), (30, (72, 78)), (48, (64, 80)), (18, (80, 82)), (51, (68, 85)), (40, (75, 85)), (36, (77, 85)), (13, (84, 85)), (60, (63, 87)), (39, (80, 89)), (54, (72, 90)), (35, (84, 91)), (57, (76, 95)), (65, (72, 97)), (60, (80, 100)), (28, (96, 100))] 2 | -------------------------------------------------------------------------------- /tests/t1.idr: -------------------------------------------------------------------------------- 1 | 2 | main : JS_IO () 3 | main = putStr' "ola" 4 | -------------------------------------------------------------------------------- /tests/t1.testres: -------------------------------------------------------------------------------- 1 | ola 2 | -------------------------------------------------------------------------------- /tests/t10.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | rec : Int -> Int -> Int 4 | rec 0 y = y 5 | rec 1 y = y 6 | rec x y = 7 | rec (y-1) (x-2) 8 | 9 | main : JS_IO () 10 | main = putStr' $ show $ rec 10 10 11 | -------------------------------------------------------------------------------- /tests/t10.testres: -------------------------------------------------------------------------------- 1 | 1 2 | -------------------------------------------------------------------------------- /tests/t11.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | main : JS_IO () 4 | main = putStr' $ show $ take 5 $ repeat 1 5 | -------------------------------------------------------------------------------- /tests/t11.testres: -------------------------------------------------------------------------------- 1 | [1, 1, 1, 1, 1] 2 | -------------------------------------------------------------------------------- /tests/t12.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | range : Int 4 | range = 1000 5 | 6 | testProg : Int -> Int 7 | testProg n = loop n 8 | where 9 | lmt : Int 10 | lmt = min (n + 100) range 11 | 12 | loop : Int -> Int 13 | loop i = if i >= lmt then i else loop (i + 1) 14 | 15 | main : IO() 16 | main = printLn $ testProg 0 -------------------------------------------------------------------------------- /tests/t12.testres: -------------------------------------------------------------------------------- 1 | 100 2 | -------------------------------------------------------------------------------- /tests/t13.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | rec : Int -> Int -> Int 4 | rec 0 y = y 5 | rec 1 y = y 6 | rec x y = 7 | rec (y-1) (x-2) 8 | 9 | f : (Int -> Int -> Int) -> Int -> Int -> Int 10 | f op x y = op x y 11 | 12 | main : IO () 13 | main = do 14 | fn <- pure rec 15 | print (f fn 10 5) -------------------------------------------------------------------------------- /tests/t13.testres: -------------------------------------------------------------------------------- 1 | 5 2 | -------------------------------------------------------------------------------- /tests/t2.idr: -------------------------------------------------------------------------------- 1 | import Js.ASync 2 | 3 | ffn : Int -> JS_IO Int 4 | ffn x = 5 | jscall 6 | "(%0 + 1)" 7 | (Int -> JS_IO Int) 8 | x 9 | 10 | main : JS_IO () 11 | main = do 12 | v <- ffn 1 13 | putStrLn' $ show v 14 | -------------------------------------------------------------------------------- /tests/t2.testres: -------------------------------------------------------------------------------- 1 | 2 2 | 3 | -------------------------------------------------------------------------------- /tests/t3.idr: -------------------------------------------------------------------------------- 1 | import Js.ASync 2 | 3 | p : Int -> Int 4 | p x = x + 1 5 | 6 | 7 | call_fn : (Int -> Int) -> Int -> JS_IO Int 8 | call_fn f x = 9 | jscall 10 | "%0(%1)" 11 | ((JsFn (Int -> Int)) -> Int -> JS_IO Int) 12 | (MkJsFn f) 13 | x 14 | 15 | main : JS_IO () 16 | main = do 17 | v <- call_fn p 1 18 | putStrLn' $ show v 19 | -------------------------------------------------------------------------------- /tests/t3.testres: -------------------------------------------------------------------------------- 1 | 2 2 | 3 | -------------------------------------------------------------------------------- /tests/t4.idr: -------------------------------------------------------------------------------- 1 | import Js.ASync 2 | 3 | p : Int -> JS_IO Int 4 | p x = do 5 | putStrLn' "ola" 6 | pure $ x + 1 7 | 8 | 9 | call_fn : (Int -> JS_IO Int) -> Int -> JS_IO Int 10 | call_fn f x = 11 | jscall 12 | "%0(%1)" 13 | ((JsFn (Int -> JS_IO Int)) -> Int -> JS_IO Int) 14 | (MkJsFn f) 15 | x 16 | 17 | 18 | main : JS_IO () 19 | main = do 20 | v <- call_fn p 73 21 | putStrLn' $ show v 22 | -------------------------------------------------------------------------------- /tests/t4.testres: -------------------------------------------------------------------------------- 1 | ola 2 | 74 3 | 4 | -------------------------------------------------------------------------------- /tests/t5.idr: -------------------------------------------------------------------------------- 1 | import Js.ASync 2 | 3 | 4 | tst : String 5 | tst = 6 | let x = ("stra", "strb") 7 | (y,z) = x 8 | in y 9 | 10 | main : JS_IO () 11 | main = do 12 | putStr' $ show tst 13 | -------------------------------------------------------------------------------- /tests/t5.testres: -------------------------------------------------------------------------------- 1 | "stra" 2 | -------------------------------------------------------------------------------- /tests/t6.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Js.ASync 4 | 5 | main : JS_IO () 6 | main = do 7 | let f = the ((String,String) -> String -> (String, Maybe String )) (\(_, s),y => (s, Just s)) 8 | case snd $ f ("t", "tst") "cenas" of 9 | Just z => putStr' z 10 | -------------------------------------------------------------------------------- /tests/t6.testres: -------------------------------------------------------------------------------- 1 | tst 2 | -------------------------------------------------------------------------------- /tests/t7.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | 4 | mutual 5 | %inline 6 | is_even : Int -> Int 7 | is_even n = 8 | if n == 0 then 1 else is_odd $ n-1 9 | 10 | is_odd : Int -> Int 11 | is_odd n = 12 | if n == 0 then 0 else is_even $ n-1 13 | 14 | main : JS_IO () 15 | main = do 16 | putStr' $ show $ is_even 100001 17 | -------------------------------------------------------------------------------- /tests/t7.testres: -------------------------------------------------------------------------------- 1 | 0 2 | -------------------------------------------------------------------------------- /tests/t8.idr: -------------------------------------------------------------------------------- 1 | import Js.ASync 2 | 3 | export 4 | data ServiceM : Type -> Type where 5 | PureServ : a -> ServiceM a 6 | 7 | 8 | get_jsio : ServiceM a -> JS_IO (Either String a) 9 | get_jsio (PureServ x) = do 10 | pure $ Right x 11 | 12 | export 13 | mytst : String -> ServiceM String 14 | mytst x = PureServ $ "ola " 15 | 16 | call_fn : (String -> JS_IO String) -> String -> JS_IO String 17 | call_fn f x = jscall 18 | "%0(%1)" 19 | ((JsFn (String -> JS_IO String)) -> String -> JS_IO String) 20 | (MkJsFn f) 21 | x 22 | 23 | mytstJs : String -> JS_IO String 24 | mytstJs x = do 25 | r <- get_jsio $ mytst "arst" 26 | case r of 27 | Right k => pure k 28 | 29 | tst2 : JS_IO String 30 | tst2 = call_fn mytstJs "inputmytst" 31 | 32 | export 33 | main : JS_IO () 34 | main = do 35 | putStrLn' "start" 36 | r <- tst2 37 | putStrLn' "olare" 38 | putStrLn' r 39 | -------------------------------------------------------------------------------- /tests/t8.testres: -------------------------------------------------------------------------------- 1 | start 2 | olare 3 | ola 4 | -------------------------------------------------------------------------------- /tests/t9.idr: -------------------------------------------------------------------------------- 1 | 2 | main : JS_IO () 3 | main = putStr' $ show 66 4 | -------------------------------------------------------------------------------- /tests/t9.testres: -------------------------------------------------------------------------------- 1 | 66 2 | -------------------------------------------------------------------------------- /tests/tarai.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | tarai : Int -> Int -> Int -> Int 4 | tarai x y z = if x <= y 5 | then y 6 | else tarai (tarai (x - 1) y z) (tarai (y - 1) z x) (tarai (z - 1) x y) 7 | 8 | main : JS_IO () 9 | main = do 10 | putStr' $ show (tarai 11 5 0) 11 | -------------------------------------------------------------------------------- /tests/tarai.testres: -------------------------------------------------------------------------------- 1 | 11 2 | --------------------------------------------------------------------------------