0 | module Compiler.ES.Codegen

  2 | import Compiler.Common

  3 | import Core.CompileExpr

  4 | import Core.Directory

  5 | import Core.Env

  6 | import Data.String

  7 | import Data.SortedMap

  8 | import Compiler.ES.Ast

  9 | import Compiler.ES.Doc

 10 | import Compiler.ES.ToAst

 11 | import Compiler.ES.TailRec

 12 | import Compiler.ES.State

 13 | import Compiler.NoMangle

 14 | import Protocol.Hex

 15 | import Libraries.Data.String.Extra

 17 | import Idris.Pretty.Annotations

 18 | import Idris.Syntax

 19 | import Idris.Doc.String

 21 | import Data.Vect

 28 | breakDrop1 : Char -> String -> (String, String)

 29 | breakDrop1 c = mapSnd (drop 1) . break (== c)

 32 | stringList : List String -> String

 33 | stringList = fastConcat . intersperse "," . map show

 41 | jsString : String -> String

 42 | jsString s = "'" ++ (concatMap okchar (unpack s)) ++ "'"

 43 |   where

 44 |     okchar : Char -> String

 45 |     okchar c = if (c >= ' ') && (c /= '\\')

 46 |                   && (c /= '"') && (c /= '\'') && (c <= '~')

 47 |                   then cast c

 48 |                   else case c of

 49 |                             '\0' => "\\0"

 50 |                             '\'' => "\\'"

 51 |                             '"' => "\\\""

 52 |                             '\r' => "\\r"

 53 |                             '\n' => "\\n"

 54 |                             other => "\\u{" ++ asHex (cast c) ++ "}"

 57 | jsStringDoc : String -> Doc

 58 | jsStringDoc = Text . jsString

 62 | esName : String -> String

 63 | esName x = "_" ++ x

 67 | jsIdent : String -> String

 68 | jsIdent s = concatMap okchar (unpack s)

 69 |   where

 70 |     okchar : Char -> String

 71 |     okchar '_' = "_"

 72 |     okchar c = if isAlphaNum c

 73 |                   then cast c

 74 |                   else "x" ++ asHex (cast c)

 76 | jsReservedNames : List String

 77 | jsReservedNames =

 78 |   [ "await", "break", "case", "catch", "class", "const", "continue", "debugger"

 79 |   , "default", "delete", "do", "else", "enum", "export", "extends", "false"

 80 |   , "finally", "for", "function", "if", "implements", "import", "in"

 81 |   , "instanceof", "interface", "let", "new", "null", "package", "private"

 82 |   , "protected", "public", "return", "static", "super", "switch", "this"

 83 |   , "throw", "true", "try", "typeof", "var", "void", "while", "with", "yield"

 84 |   ]

 86 | keywordSafe : String -> String

 87 | keywordSafe s = if s `elem` jsReservedNames

 88 |   then s ++ "$"

 89 |   else s

 95 | jsUserName : UserName -> String

 96 | jsUserName (Basic n) = keywordSafe $ jsIdent n

 97 | jsUserName (Field n) = "rf__" ++ jsIdent n

 98 | jsUserName Underscore = keywordSafe $ jsIdent "_"

100 | jsMangleName : Name -> String

101 | jsMangleName (NS ns n) = jsIdent (showNSWithSep "_" ns) ++ "_" ++ jsMangleName n

102 | jsMangleName (UN n) = jsUserName n

103 | jsMangleName (MN n i) = jsIdent n ++ "_" ++ show i

104 | jsMangleName (PV n d) = "pat__" ++ jsMangleName n

105 | jsMangleName (DN _ n) = jsMangleName n

106 | jsMangleName (Nested (i, x) n) = "n__" ++ show i ++ "_" ++ show x ++ "_" ++ jsMangleName n

107 | jsMangleName (CaseBlock x y) = "case__" ++ jsIdent x ++ "_" ++ show y

108 | jsMangleName (WithBlock x y) = "with__" ++ jsIdent x ++ "_" ++ show y

109 | jsMangleName (Resolved i) = "fn__" ++ show i

111 | parameters (noMangle : NoMangleMap)

112 |   jsName : Name -> String

113 |   jsName n = case isNoMangle noMangle n of

114 |     Just name => name

115 |     Nothing => jsMangleName n

117 |   jsNameDoc : Name -> Doc

118 |   jsNameDoc = Text . jsName

120 | mainExpr : Name

121 | mainExpr = MN "__mainExpression" 0

127 | parameters (noMangle : NoMangleMap)

128 |   var : Var -> Doc

129 |   var (VName x) = jsNameDoc noMangle x

130 |   var (VLoc x)  = Text $ "$" ++ asHex (cast x)

131 |   var (VRef x)  = Text $ "$R" ++ asHex (cast x)

133 |   minimal : Minimal -> Doc

134 |   minimal (MVar v)          = var v

135 |   minimal (MProjection n v) = minimal v <+> ".a" <+> shown n

137 | tag2es : Tag -> (Doc, Maybe Doc)

138 | tag2es (DataCon i n)  = (shown i, Just (shown (dropNS n)))

139 | tag2es (TypeCon x) = (jsStringDoc $ show x, Nothing)

141 | constant : Doc -> Doc -> Doc

142 | constant n d = "const" <++> n <+> softEq <+> d <+> ";"

144 | applyList : (lparen : Doc) -> (rparen : Doc) -> (sep : Doc) -> List Doc -> Doc

145 | applyList l r sep ds = l <+> (concat $ intersperse sep ds) <+> r

147 | conTags : List Doc -> List Doc

148 | conTags as = zipWith (\i,a => hcat ["a",shown i,softColon,a]) [1..length as] as

150 | applyObj : (args : List Doc) -> Doc

151 | applyObj = applyList "{" "}" softComma

162 | applyCon : ConInfo -> (tag : Tag) -> (args : List Doc) -> Doc

163 | applyCon NIL     _ [] = "{h" <+> softColon <+> "0}"

164 | applyCon NOTHING _ [] = "{h" <+> softColon <+> "0}"

165 | applyCon CONS    _ as = applyObj (conTags as)

166 | applyCon JUST    _ as = applyObj (conTags as)

167 | applyCon RECORD  _ as = applyObj (conTags as)

168 | applyCon UNIT    _ [] = "undefined"

169 | applyCon _       t as = applyObj (mkCon (tag2es t) :: conTags as)

171 |   where

172 |     mkCon : (Doc, Maybe Doc) -> Doc

173 |     mkCon (t, Nothing) = "h" <+> softColon <+> t

174 |     mkCon (t, Just cmt) = "h" <+> softColon <+> t <++> comment cmt

177 | app : (fun : Doc) -> (args : List Doc) -> Doc

178 | app fun args = fun <+> applyList "(" ")" softComma args

182 | callFun : String -> List Doc -> Doc

183 | callFun = app . Text

186 | callFun1 : String -> Doc -> Doc

187 | callFun1 fun = callFun fun . pure

190 | jsCrashExp : (msg : Doc) -> Doc

191 | jsCrashExp = callFun1 (esName "crashExp")

198 | function : (name : Doc) -> (args : List Doc) -> (body : Doc) -> Doc

199 | function n args body =

200 |   "function" <++> app n args <+> SoftSpace <+> block body

206 | toBigInt : Doc -> Doc

207 | toBigInt = callFun1 "BigInt"

209 | fromBigInt : Doc -> Doc

210 | fromBigInt = callFun1 "Number"

214 | useBigInt' : Int -> Bool

215 | useBigInt' = (> 32)

218 | useBigInt : IntKind -> Bool

219 | useBigInt (Signed $ P x)     = useBigInt' x

220 | useBigInt (Signed Unlimited) = True

221 | useBigInt (Unsigned x)       = useBigInt' x

225 | jsBigIntOfString : Doc -> Doc

226 | jsBigIntOfString = callFun1 (esName "bigIntOfString")

230 | jsNumberOfString : Doc -> Doc

231 | jsNumberOfString = callFun1 (esName "numberOfString")

235 | jsIntOfString : IntKind -> Doc -> Doc

236 | jsIntOfString k =

237 |   if useBigInt k

238 |      then jsBigIntOfString

239 |      else callFun1 (esName "intOfString")

242 | binOp : (symbol : String) -> (lhs : Doc) -> (rhs : Doc) -> Doc

243 | binOp sym lhs rhs = hcat ["(", lhs, Text sym, rhs, ")"]

247 | toInt : IntKind -> Doc -> Doc

248 | toInt k = if useBigInt k then toBigInt else id

252 | fromInt : IntKind -> Doc -> Doc

253 | fromInt k = if useBigInt k then fromBigInt else id

257 | jsIntOfChar : IntKind -> Doc -> Doc

258 | jsIntOfChar k s = toInt k $ s <+> ".codePointAt(0)"

261 | jsIntOfDouble : IntKind -> Doc -> Doc

262 | jsIntOfDouble k = toInt k . callFun1 "Math.trunc"

264 | jsAnyToString : Doc -> Doc

265 | jsAnyToString s = "(''+" <+> s <+> ")"

269 | jsCharOfInt : IntKind -> Doc -> Doc

270 | jsCharOfInt k = callFun1 (esName "truncToChar") . fromInt k

281 | truncateSigned : (isBigInt : Bool) -> (bits : Int) -> (int : Doc) -> Doc

282 | truncateSigned isBigInt bits =

283 |    let add = if isBigInt then "BigInt" else "Int"

284 |     in callFun1 (esName "trunc" ++ add ++ show bits)

287 | truncateUnsigned : (isBigInt : Bool) -> (bits : Int) -> (int : Doc) -> Doc

288 | truncateUnsigned isBigInt bits =

289 |    let add = if isBigInt then "BigInt" else "Int"

290 |     in callFun1 (esName "truncU" ++ add ++ show bits)

292 | integerOp : (op : String) -> (lhs : Doc) -> (rhs : Doc) -> Doc

293 | integerOp op x y = callFun (fastConcat ["_", op, "BigInt"]) [x,y]

298 | boundedOp :  (suffix : String)

299 |           -> (bits : Int)

300 |           -> (op : String)

301 |           -> (lhs : Doc)

302 |           -> (rhs : Doc)

303 |           -> Doc

304 | boundedOp s bits o x y = callFun (fastConcat ["_", o, show bits, s]) [x,y]

307 | boundedIntOp : Int -> String -> Doc -> Doc -> Doc

308 | boundedIntOp = boundedOp "s"

311 | boundedUIntOp : Int -> String -> Doc -> Doc -> Doc

312 | boundedUIntOp = boundedOp "u"

315 | boolOp : (op : String) -> (lhs : Doc) -> (rhs : Doc) -> Doc

316 | boolOp o lhs rhs = "(" <+> binOp o lhs rhs <+> "?1:0)"

318 | jsPrimType : PrimType -> String

319 | jsPrimType _ = "#t"

322 | jsConstant : Constant -> String

323 | jsConstant (I i)    = show i

324 | jsConstant (I8 i)   = show i

325 | jsConstant (I16 i)  = show i

326 | jsConstant (I32 i)  = show i

327 | jsConstant (I64 i)  = show i ++ "n"

328 | jsConstant (BI i)   = show i ++ "n"

329 | jsConstant (B8 i)   = show i

330 | jsConstant (B16 i)  = show i

331 | jsConstant (B32 i)  = show i

332 | jsConstant (B64 i)  = show i ++ "n"

333 | jsConstant (Str s)  = jsString s

334 | jsConstant (Ch c)   = jsString $ singleton c

335 | jsConstant (Db f)   = show f

336 | jsConstant (PrT t)  = jsPrimType t

337 | jsConstant WorldVal = esName "idrisworld"

342 | arithOp :  Maybe IntKind

343 |         -> (sym : String) -- operator symbol (in case we can use the symbolic version)

344 |         -> (op  : String)  -- operation name (for operations on bounded integrals)

345 |         -> (lhs : Doc)

346 |         -> (rhs : Doc)

347 |         -> Doc

348 | arithOp (Just $ Signed $ P n)     _   op = boundedIntOp n op -- IntXY

349 | arithOp (Just $ Unsigned n)       _   op = boundedUIntOp n op -- BitsXY

350 | arithOp (Just $ Signed Unlimited) ""  op = integerOp op -- Integer

351 | arithOp _                         sym _  = binOp sym

354 | jsIntKind : PrimType -> Maybe IntKind

355 | jsIntKind IntType = Just . Signed $ P 32

356 | jsIntKind x       = intKind x

358 | jsMod : PrimType -> Doc -> Doc -> Doc

359 | jsMod ty x y = case jsIntKind ty of

360 |   (Just $ Signed $ P n) => case useBigInt' n of

361 |     True  => integerOp "mod" x y

362 |     False => callFun "_mod" [x,y]

363 |   (Just $ Unsigned n)   => binOp "%" x y

364 |   _                     => integerOp "mod" x y

369 | castInt : PrimType -> PrimType -> Doc -> Core Doc

370 | castInt from to x =

371 |   case ((from, jsIntKind from), (to, jsIntKind to)) of

372 |     ((CharType,_),  (_,Just k)) => truncInt (useBigInt k) k $ jsIntOfChar k x

373 |     ((StringType,_),(_,Just k)) => truncInt (useBigInt k) k (jsIntOfString k x)

374 |     ((DoubleType,_),(_,Just k)) => truncInt (useBigInt k) k $ jsIntOfDouble k x

375 |     ((_,Just k),(CharType,_))   => pure $ jsCharOfInt k x

376 |     ((_,Just k),(StringType,_)) => pure $ jsAnyToString x

377 |     ((_,Just k),(DoubleType,_)) => pure $ fromInt k x

378 |     ((_,Just k1),(_,Just k2))   => intImpl k1 k2

379 |     _ => errorConcat $ ["invalid cast: + ",show from," + ' -> ' + ",show to]

380 |   where

381 |     truncInt : (isBigInt : Bool) -> IntKind -> Doc -> Core Doc

382 |     truncInt b (Signed Unlimited) = pure

383 |     truncInt b (Signed $ P n)     = pure . truncateSigned b n

384 |     truncInt b (Unsigned n)       = pure . truncateUnsigned b n

386 |     shrink : IntKind -> IntKind -> Doc -> Doc

387 |     shrink k1 k2 = case (useBigInt k1, useBigInt k2) of

388 |                         (True, False) => fromBigInt

389 |                         _             => id

391 |     expand : IntKind -> IntKind -> Doc -> Doc

392 |     expand k1 k2 = case (useBigInt k1, useBigInt k2) of

393 |                         (False,True) => toBigInt

394 |                         _            => id

396 |     -- when going from BigInt to Number, we must make

397 |     -- sure to first truncate the BigInt, otherwise we

398 |     -- might get rounding issues

399 |     intImpl : IntKind -> IntKind -> Core Doc

400 |     intImpl k1 k2 =

401 |       let expanded = expand k1 k2 x

402 |           shrunk   = shrink k1 k2 <$> truncInt (useBigInt k1) k2 x

403 |        in case (k1,k2) of

404 |             (_, Signed Unlimited)    => pure $ expanded

405 |             (Signed m, Signed n)     =>

406 |               if n >= m then pure expanded else shrunk

408 |             (Signed _, Unsigned n)   =>

409 |               case (useBigInt k1, useBigInt k2) of

410 |                    (False,True)  => truncInt True k2 (toBigInt x)

411 |                    _             => shrunk

413 |             (Unsigned m, Unsigned n) =>

414 |               if n >= m then pure expanded else shrunk

416 |             -- Only if the precision of the target is greater

417 |             -- than the one of the source, there is no need to cast.

418 |             (Unsigned m, Signed n)   =>

419 |               if n > P m then pure expanded else shrunk

422 | jsOp : {0 arity : Nat} ->

423 |        PrimFn arity -> Vect arity Doc -> Core Doc

424 | jsOp (Add ty) [x, y] = pure $ arithOp (jsIntKind ty) "+" "add" x y

425 | jsOp (Sub ty) [x, y] = pure $ arithOp (jsIntKind ty) "-" "sub" x y

426 | jsOp (Mul ty) [x, y] = pure $ arithOp (jsIntKind ty) "*" "mul" x y

427 | jsOp (Div DoubleType) [x, y] = pure $ binOp "/" x y

428 | jsOp (Div ty) [x, y] = pure $ arithOp (jsIntKind ty) ""  "div" x y

429 | jsOp (Mod ty) [x, y] = pure $ jsMod ty x y

430 | jsOp (Neg ty) [x] = pure $ "(-(" <+> x <+> "))"

431 | jsOp (ShiftL Int32Type) [x, y] = pure $ binOp "<<" x y

432 | jsOp (ShiftL IntType) [x, y] = pure $ binOp "<<" x y

433 | jsOp (ShiftL ty) [x, y] = pure $ arithOp (jsIntKind ty) "<<" "shl" x y

434 | jsOp (ShiftR Int32Type) [x, y] = pure $ binOp ">>" x y

435 | jsOp (ShiftR IntType) [x, y] = pure $ binOp ">>" x y

436 | jsOp (ShiftR ty) [x, y] = pure $ arithOp (jsIntKind ty) ">>" "shr" x y

437 | jsOp (BAnd Bits32Type) [x, y] = pure $ boundedUIntOp 32 "and" x y

438 | jsOp (BOr Bits32Type) [x, y]  = pure $ boundedUIntOp 32 "or" x y

439 | jsOp (BXOr Bits32Type) [x, y] = pure $ boundedUIntOp 32 "xor" x y

440 | jsOp (BAnd ty) [x, y] = pure $ binOp "&" x y

441 | jsOp (BOr ty) [x, y] = pure $ binOp "|" x y

442 | jsOp (BXOr ty) [x, y] = pure $ binOp "^" x y

443 | jsOp (LT ty) [x, y] = pure $ boolOp "<" x y

444 | jsOp (LTE ty) [x, y] = pure $ boolOp "<=" x y

445 | jsOp (EQ ty) [x, y] = pure $ boolOp "===" x y

446 | jsOp (GTE ty) [x, y] = pure $ boolOp ">=" x y

447 | jsOp (GT ty) [x, y] = pure $ boolOp ">" x y

448 | jsOp StrLength [x] = pure $ x <+> ".length"

449 | jsOp StrHead [x] = pure $ "(" <+> x <+> ".charAt(0))"

450 | jsOp StrTail [x] = pure $ "(" <+> x <+> ".slice(1))"

451 | jsOp StrIndex [x, y] = pure $ "(" <+> x <+> ".charAt(" <+> y <+> "))"

452 | jsOp StrCons [x, y] = pure $ binOp "+" x y

453 | jsOp StrAppend [x, y] = pure $ binOp "+" x y

454 | jsOp StrReverse [x] = pure $ callFun1 (esName "strReverse") x

455 | jsOp StrSubstr [offset, len, str] =

456 |   pure $ callFun (esName "substr") [offset,len,str]

457 | jsOp DoubleExp [x]     = pure $ callFun1 "Math.exp" x

458 | jsOp DoubleLog [x]     = pure $ callFun1 "Math.log" x

459 | jsOp DoublePow [x, y]  = pure $ callFun "Math.pow" [x, y]

460 | jsOp DoubleSin [x]     = pure $ callFun1 "Math.sin" x

461 | jsOp DoubleCos [x]     = pure $ callFun1 "Math.cos" x

462 | jsOp DoubleTan [x]     = pure $ callFun1 "Math.tan" x

463 | jsOp DoubleASin [x]    = pure $ callFun1 "Math.asin" x

464 | jsOp DoubleACos [x]    = pure $ callFun1 "Math.acos" x

465 | jsOp DoubleATan [x]    = pure $ callFun1 "Math.atan" x

466 | jsOp DoubleSqrt [x]    = pure $ callFun1 "Math.sqrt" x

467 | jsOp DoubleFloor [x]   = pure $ callFun1 "Math.floor" x

468 | jsOp DoubleCeiling [x] = pure $ callFun1 "Math.ceil" x

470 | jsOp (Cast StringType DoubleType) [x] = pure $ jsNumberOfString x

471 | jsOp (Cast ty StringType) [x] = pure $ jsAnyToString x

472 | jsOp (Cast ty ty2) [x]        = castInt ty ty2 x

473 | jsOp BelieveMe [_,_,x] = pure x

474 | jsOp (Crash) [_, msg] = pure $ jsCrashExp msg

483 | readCCPart : String -> (String, String)

484 | readCCPart = breakDrop1 ':'

488 | searchForeign : List String -> List String -> Either (List String) String

489 | searchForeign knownBackends decls =

490 |   let pairs = map readCCPart decls

491 |       backends = Left $ map fst pairs

492 |    in maybe backends (Right. snd) $ find ((`elem` knownBackends) . fst) pairs

496 | makeForeign :  {auto d : Ref Ctxt Defs}

497 |             -> {auto c : Ref ESs ESSt}

498 |             -> {auto nm : Ref NoMangleMap NoMangleMap}

499 |             -> (name : Name)

500 |             -> (ffDecl : String)

501 |             -> Core Doc

502 | makeForeign n x = do

503 |   nd <- var !(get NoMangleMap) <$> getOrRegisterRef n

504 |   let (ty, def) = readCCPart x

505 |   case ty of

506 |     "lambda" => pure . constant nd . paren $ Text def

507 |     "support" => do

508 |       let (name, lib) = breakDrop1 ',' def

509 |       lib_code <- readDataFile ("js/" ++ lib ++ ".js")

510 |       addToPreamble lib lib_code

511 |       pure . constant nd . Text $ lib ++ "_" ++ name

512 |     "stringIterator" =>

513 |       case def of

514 |         "new"      => pure $ constant nd "__prim_stringIteratorNew"

515 |         "next"     => pure $ constant nd "__prim_stringIteratorNext"

516 |         "toString" => pure $ constant nd "__prim_stringIteratorToString"

517 |         _ => errorConcat

518 |                [ "Invalid string iterator function: ", def, ". "

519 |                , "Supported functions are: "

520 |                , stringList ["new","next","toString"], "."

521 |                ]

523 |     _ => errorConcat

524 |            [ "Invalid foreign type : ", ty, ". "

525 |            , "Supported types are: "

526 |            , stringList ["lambda", "support", "stringIterator"]

527 |            ]

531 | foreignDecl :  {auto d : Ref Ctxt Defs}

532 |             -> {auto c : Ref ESs ESSt}

533 |             -> {auto nm : Ref NoMangleMap NoMangleMap}

534 |             -> Name

535 |             -> List String

536 |             -> Core Doc

537 | foreignDecl n ccs = do

538 |   tys <- ccTypes <$> get ESs

539 |   case searchForeign tys ccs of

540 |     Right x        => makeForeign n x

541 |     Left  backends =>

542 |       errorConcat

543 |         [ "No supported backend found in the definition of ", show n, ". "

544 |         , "Supported backends: ", stringList tys, ". "

545 |         , "Backends in definition: ", stringList backends, "."

546 |         ]

549 | jsPrim : {auto c : Ref ESs ESSt} -> Name -> List Doc -> Core Doc

550 | jsPrim nm docs = case (dropAllNS nm, docs) of

551 |   (UN (Basic "prim__newIORef"), [_,v,_]) => pure $ hcat ["({value:", v, "})"]

552 |   (UN (Basic "prim__readIORef"), [_,r,_]) => pure $ hcat ["(", r, ".value)"]

553 |   (UN (Basic "prim__writeIORef"), [_,r,v,_]) => pure $ hcat ["(", r, ".value=", v, ")"]

554 |   (UN (Basic "prim__newArray"), [_,s,v,_]) => pure $ hcat ["(Array(", fromBigInt s, ").fill(", v, "))"]

555 |   (UN (Basic "prim__arrayGet"), [_,x,p,_]) => pure $ hcat ["(", x, "[", fromBigInt p, "])"]

556 |   (UN (Basic "prim__arraySet"), [_,x,p,v,_]) => pure $ hcat ["(", x, "[", fromBigInt p, "]=", v, ")"]

557 |   (UN (Basic "prim__codegen"), []) => do

558 |     (cg :: _) <- ccTypes <$> get ESs

559 |         | _ => pure "\"javascript\""

560 |     pure . Text $ jsString cg

563 |   (UN (Basic "prim__os"), []) => do

564 |     tys <- ccTypes <$> get ESs

565 |     case searchForeign tys ["node"] of

566 |       Right _ => do

567 |         addToPreamble "prim__os" $

568 |           "const _sysos = ((o => o === 'linux'?'unix':o==='win32'?'windows':o)" ++

569 |           "(require('os').platform()));"

570 |         pure $ Text $ esName "sysos"

571 |       Left  _ =>

572 |         throw $ InternalError $ "prim not implemented: prim__os"

574 |   _ => throw $ InternalError $ "prim not implemented: " ++ show nm

583 | isArg : CGMode -> Exp -> Bool

584 | isArg Pretty (ELam _ $ Block {})       = False

585 | isArg Pretty (ELam _ $ ConSwitch {})   = False

586 | isArg Pretty (ELam _ $ ConstSwitch {}) = False

587 | isArg Pretty (ELam _ $ Error {})       = False

588 | isArg _      _                         = True

592 | isFun : Exp -> Bool

593 | isFun (ELam {}) = False

594 | isFun _         = True

608 | switch :  (scrutinee : Doc)

609 |        -> (alts : List ((Doc,Maybe Doc),Doc)) -- match, comment, code

610 |        -> (def : Maybe Doc)

611 |        -> Doc

612 | switch sc alts def =

613 |   let stmt    = "switch" <+> paren sc <+> SoftSpace

614 |       defcase = concatMap (pure . anyCase "default" Nothing) def

615 |    in stmt <+> block (vcat $ map alt alts ++ defcase)

617 |   where anyCase : Doc -> Maybe Doc -> Doc -> Doc

618 |         anyCase s cmt d =

619 |           let b = if isMultiline d then block d else d in

620 |           case cmt of

621 |             Nothing => s <+> softColon <+> b

622 |             Just cmt => s <+> softColon <+> comment cmt <++> b

624 |         alt : ((Doc,Maybe Doc),Doc) -> Doc

625 |         alt ((e, c), d) = anyCase ("case" <++> e) c d

630 | lambdaArgs : (noMangle : NoMangleMap) -> List Var -> Doc

631 | lambdaArgs noMangle [] = "()" <+> lambdaArrow

632 | lambdaArgs noMangle xs = hcat $ (<+> lambdaArrow) . var noMangle <$> xs

634 | insertBreak : (r : Effect) -> (a, Doc) -> (a, Doc)

635 | insertBreak Returns x = x

636 | insertBreak (ErrorWithout _) (pat, exp) = (pat, vcat [exp, "break;"])

639 |   -- converts an `Exp` to JS code

640 |   exp :  {auto c : Ref ESs ESSt}

641 |       -> {auto nm : Ref NoMangleMap NoMangleMap}

642 |       -> Exp

643 |       -> Core Doc

644 |   exp (EMinimal x) = pure $ minimal !(get NoMangleMap) x

645 |   exp (ELam xs (Return y@(ECon {}))) = do

646 |      nm <- get NoMangleMap

647 |      map (\e => lambdaArgs nm xs <+> paren e) (exp y)

648 |   exp (ELam xs (Return y)) = do

649 |      nm <- get NoMangleMap

650 |      (lambdaArgs nm xs <+> ) <$> exp y

651 |   exp (ELam xs y) = do

652 |      nm <- get NoMangleMap

653 |      (lambdaArgs nm xs <+>) . block <$> stmt y

654 |   exp (EApp x xs) = do

655 |     o    <- exp x

656 |     args <- traverse exp xs

657 |     pure $ app o args

659 |   exp (ECon tag ci xs) = applyCon ci tag <$> traverse exp xs

661 |   exp (EOp x xs) = traverseVect exp xs >>= jsOp x

662 |   exp (EExtPrim x xs) = traverse exp xs >>= jsPrim x

663 |   exp (EPrimVal x) = pure . Text $ jsConstant x

664 |   exp EErased = pure "undefined"

666 |   -- converts a `Stmt e` to JS code.

667 |   stmt :  {e : _}

668 |        -> {auto c : Ref ESs ESSt}

669 |        -> {auto nm : Ref NoMangleMap NoMangleMap}

670 |        -> Stmt e

671 |        -> Core Doc

672 |   stmt (Return y) = (\e => "return" <++> e <+> ";") <$> exp y

673 |   stmt (Const v x) = do

674 |     nm <- get NoMangleMap

675 |     constant (var nm v) <$> exp x

676 |   stmt (Declare v s) = do

677 |     nm <- get NoMangleMap

678 |     (\d => vcat ["let" <++> var nm v <+> ";",d]) <$> stmt s

679 |   stmt (Assign v x) = do

680 |     nm <- get NoMangleMap

681 |     (\d => hcat [var nm v,softEq,d,";"]) <$> exp x

683 |   stmt (ConSwitch r sc alts def) = do

684 |     as <- traverse (map (insertBreak r) . alt) alts

685 |     d  <- traverseOpt stmt def

686 |     nm <- get NoMangleMap

687 |     pure $ switch (minimal nm sc <+> ".h") as d

688 |     where

689 |         alt : {r : _} -> EConAlt r -> Core ((Doc,Maybe Doc),Doc)

690 |         alt (MkEConAlt _ RECORD b)  = (("undefined",Just "record"),) <$> stmt b

691 |         alt (MkEConAlt _ NIL b)     = (("0",Just "nil"),) <$> stmt b

692 |         alt (MkEConAlt _ CONS b)    = (("undefined",Just "cons"),) <$> stmt b

693 |         alt (MkEConAlt _ NOTHING b) = (("0",Just "nothing"),) <$> stmt b

694 |         alt (MkEConAlt _ JUST b)    = (("undefined",Just "just"),) <$> stmt b

695 |         alt (MkEConAlt _ UNIT b)    = (("undefined",Just "unit"),) <$> stmt b

696 |         alt (MkEConAlt t _ b)       = (tag2es t,) <$> stmt b

698 |   stmt (ConstSwitch r sc alts def) = do

699 |     as <- traverse (map (insertBreak r) . alt) alts

700 |     d  <- traverseOpt stmt def

701 |     ex <- exp sc

702 |     pure $ switch ex as d

703 |     where

704 |         alt : EConstAlt r -> Core ((Doc,Maybe Doc),Doc)

705 |         alt (MkEConstAlt c b) = do

706 |             d <- stmt b

707 |             pure ((Text $ jsConstant c, Nothing), d)

709 |   stmt (Error x)   = pure $ jsCrashExp (jsStringDoc x) <+> ";"

710 |   stmt (Block ss s) = do

711 |     docs <- traverse stmt $ forget ss

712 |     doc  <- stmt s

713 |     pure $ vcat (docs ++ [doc])

717 | printDoc : CGMode -> Doc -> String

718 | printDoc Pretty y = pretty (y <+> LineBreak)

719 | printDoc Compact y = compact y

720 | printDoc Minimal y = compact y

723 | def :  {auto c : Ref Ctxt Defs}

724 |     -> {auto s : Ref Syn SyntaxInfo}

725 |     -> {auto e : Ref ESs ESSt}

726 |     -> {auto nm : Ref NoMangleMap NoMangleMap}

727 |     -> Function

728 |     -> Core String

729 | def (MkFunction n as body) = do

730 |   reset

731 |   defs <- get Ctxt

732 |   mty <- do log "compiler.javascript.doc" 50 $ "Looking up \{show n}"

733 |             Just gdef <- lookupCtxtExact n (gamma defs)

734 |               | Nothing => pure Nothing

735 |             let UN _ = dropNS n

736 |               | _ => pure Nothing

737 |             ty <- prettyType (const ()) gdef.type

738 |             pure (Just (shown ty))

739 |   ref  <- getOrRegisterRef n

740 |   args <- traverse registerLocal as

741 |   mde  <- mode <$> get ESs

742 |   b    <- stmt Returns body >>= stmt

743 |   let cmt = comment $ hsep (shown n :: toList ((":" <++>) <$> mty))

744 |   if null args && n /= mainExpr

745 |     -- zero argument toplevel functions are converted to

746 |     -- lazily evaluated constants (except the main expression).

747 |     then pure $ printDoc mde $ vcat

748 |           [ cmt

749 |           , constant (var !(get NoMangleMap) ref)

750 |                ("__lazy(" <+> function neutral [] b <+> ")") ]

751 |     else pure $ printDoc mde $ vcat

752 |           [ cmt

753 |           , function (var !(get NoMangleMap) ref)

754 |                (map (var !(get NoMangleMap)) args) b ]

757 | foreign :  {auto c : Ref ESs ESSt}

758 |         -> {auto d : Ref Ctxt Defs}

759 |         -> {auto nm : Ref NoMangleMap NoMangleMap}

760 |         -> (Name,FC,NamedDef)

761 |         -> Core (List String)

762 | foreign (n, _, MkNmForeign path _ _) = pure . pretty <$> foreignDecl n path

763 | foreign _                            = pure []

767 | tailRec : Name

768 | tailRec = UN $ Basic "__tailRec"

770 | validJSName : String -> Bool

771 | validJSName name =

772 |     not (name `elem` jsReservedNames)

773 |     && all validNameChar (unpack name)

774 |     && (case strM name of

775 |       StrNil => True

776 |       StrCons head _ => not $ isDigit head)

777 |   where

778 |     validNameChar : Char -> Bool

779 |     validNameChar c = isAlphaNum c || c == '_' || c == '$'

784 | compileToES : Ref Ctxt Defs -> Ref Syn SyntaxInfo ->

785 |               (cg : CG) -> ClosedTerm -> List String -> Core String

786 | compileToES c s cg tm ccTypes = do

787 |   _ <- initNoMangle ccTypes validJSName

789 |   cdata <- getCompileDataWith ccTypes False Cases tm

791 |   -- read a derive the codegen mode to use from

792 |   -- user defined directives for the

793 |   directives <- getDirectives cg

794 |   let mode = if "minimal" `elem` directives then Minimal

795 |              else if "compact" `elem` directives then Compact

796 |              else Pretty

798 |   -- initialize the state used in the code generator

799 |   s <- newRef ESs $ init mode (isArg mode) isFun ccTypes !(get NoMangleMap)

801 |   -- register the toplevel `__tailRec` function to make sure

802 |   -- it is not mangled in `Minimal` mode

803 |   addRef tailRec (VName tailRec)

805 |   -- the list of all toplevel definitions (including the main

806 |   -- function)

807 |   let allDefs =  (mainExpr, EmptyFC, MkNmFun [] $ forget cdata.mainExpr)

808 |               :: cdata.namedDefs

810 |       -- tail-call optimized set of toplevel functions

811 |       defs    = TailRec.functions tailRec allDefs

813 |   -- pretty printed toplevel function definitions

814 |   defDecls <- traverse def defs

816 |   -- pretty printed toplevel FFI definitions

817 |   foreigns <- concat <$> traverse foreign allDefs

819 |   -- lookup the (possibly mangled) name of the main function

820 |   mainName <- compact . var !(get NoMangleMap) <$> getOrRegisterRef mainExpr

822 |   -- main function and list of all declarations

823 |   let main =  "try{"

824 |            ++ mainName

825 |            ++ "()}catch(e){if(e instanceof IdrisError){console.log('ERROR: ' + e.message)}else{throw e} }"

827 |       allDecls = fastUnlines $ foreigns ++ defDecls

829 |   st <- get ESs

831 |   -- main preamble containing primops implementations

832 |   static_preamble <- readDataFile ("js/support.js")

834 |   -- complete preamble, including content from additional

835 |   -- support files (if any)

836 |   let pre = showSep "\n" $ static_preamble :: (values $ preamble st)

838 |   pure $ fastUnlines [pre,allDecls,main]