├── .gitignore ├── .travis.yml ├── LICENSE ├── README.markdown ├── Setup.hs ├── deps.sh ├── forml.cabal ├── lib ├── css │ ├── coda.css │ ├── jasmine.css │ └── prettify.css └── js │ ├── jasmine-1.0.1 │ ├── jasmine-html.js │ └── jasmine.js │ ├── jquery.js │ ├── lang-hs.js │ └── prettify.js ├── prelude.obj └── src ├── css └── styles.css ├── forml ├── formalz.forml ├── parsec.forml ├── prelude.forml ├── readme.forml ├── server.forml ├── tests.forml └── tetris.forml ├── hs ├── lib │ └── Forml │ │ ├── CLI.hs │ │ ├── Closure.hs │ │ ├── Deps.hs │ │ ├── Doc.hs │ │ ├── Exec.hs │ │ ├── Javascript.hs │ │ ├── Javascript │ │ ├── Backend.hs │ │ ├── Test.hs │ │ └── Utils.hs │ │ ├── Optimize.hs │ │ ├── Optimize │ │ ├── Inline.hs │ │ ├── Optimizer.hs │ │ └── TailCall.hs │ │ ├── Parser.hs │ │ ├── Parser │ │ └── Utils.hs │ │ ├── Static.hs │ │ ├── TypeCheck.hs │ │ ├── TypeCheck │ │ └── Types.hs │ │ └── Types │ │ ├── Axiom.hs │ │ ├── Definition.hs │ │ ├── Expression.hs │ │ ├── Literal.hs │ │ ├── Namespace.hs │ │ ├── Pattern.hs │ │ ├── Statement.hs │ │ ├── Symbol.hs │ │ ├── Type.hs │ │ └── TypeDefinition.hs ├── main │ └── Main.hs └── test │ ├── MainSpec.hs │ └── Spec.hs ├── html └── template.html └── js └── FormlReporter.js /.gitignore: -------------------------------------------------------------------------------- 1 | cabal-dev 2 | dist 3 | *.swn 4 | *.swo 5 | *.swp 6 | .dist-buildwrapper 7 | .externalToolBuilders 8 | 9 | .project 10 | .settings 11 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | install: cabal install --only-dependencies --enable-tests --force-reinstalls -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c)2011, Andrew Stein 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Andrew Stein nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | [http://texodus.github.com/forml](http://texodus.github.com/forml) 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | import Distribution.Simple.Compiler hiding (Flag) 4 | import Distribution.Simple.UserHooks 5 | import Distribution.Package 6 | import Distribution.PackageDescription 7 | ( PackageDescription(..), GenericPackageDescription 8 | , updatePackageDescription, hasLibs 9 | , HookedBuildInfo, emptyHookedBuildInfo ) 10 | import Distribution.PackageDescription.Parse 11 | ( readPackageDescription, readHookedBuildInfo ) 12 | import Distribution.PackageDescription.Configuration 13 | ( flattenPackageDescription ) 14 | import Distribution.Simple.Program 15 | ( defaultProgramConfiguration, addKnownPrograms, builtinPrograms 16 | , restoreProgramConfiguration, reconfigurePrograms ) 17 | import Distribution.Simple.PreProcess (knownSuffixHandlers, PPSuffixHandler) 18 | import Distribution.Simple.Setup 19 | import Distribution.Simple.Command 20 | 21 | import Distribution.Simple.Build ( build ) 22 | import Distribution.Simple.SrcDist ( sdist ) 23 | import Distribution.Simple.Register 24 | ( register, unregister ) 25 | 26 | import Distribution.Simple.Configure 27 | ( getPersistBuildConfig, maybeGetPersistBuildConfig 28 | , writePersistBuildConfig, checkPersistBuildConfigOutdated 29 | , configure, checkForeignDeps ) 30 | 31 | import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) 32 | import Distribution.Simple.BuildPaths ( srcPref) 33 | import Distribution.Simple.Test (test) 34 | import Distribution.Simple.Install (install) 35 | import Distribution.Simple.Haddock (haddock, hscolour) 36 | import Distribution.Simple.Utils 37 | (die, notice, info, warn, setupMessage, chattyTry, 38 | defaultPackageDesc, defaultHookedPackageDesc, 39 | rawSystemExitWithEnv, cabalVersion, topHandler ) 40 | import Distribution.System 41 | ( OS(..), buildOS ) 42 | import Distribution.Verbosity 43 | import Language.Haskell.Extension 44 | import Distribution.Version 45 | import Distribution.License 46 | import Distribution.Text 47 | ( display ) 48 | 49 | import System.Process 50 | import System.Directory 51 | import System.Exit 52 | import Control.Monad (when) 53 | import Data.List (intersperse, unionBy) 54 | 55 | 56 | 57 | main = defaultMainWithHooks 58 | simpleUserHooks { preBuild = preHook 59 | , postBuild = postHook } 60 | 61 | alert msg = do 62 | putStrLn "" 63 | putStrLn "*************************************************************************************" 64 | putStrLn "****" 65 | putStrLn $ "**** " ++ msg 66 | putStrLn "" 67 | 68 | 69 | preHook _ _ = do 70 | exists <- doesFileExist "prelude.obj" 71 | if exists then removeFile "prelude.obj" else return () 72 | system "touch prelude.obj" 73 | alert "Building prelude-less compiler" 74 | return emptyHookedBuildInfo 75 | 76 | postHook _ flags pkg_descr localbuildinfo = do 77 | --build pkg_descr localbuildinfo flags (allSuffixHandlers hooks) 78 | alert "Building prelude" 79 | retCode <- rawSystem "dist/build/Forml/forml" ["-no-test", "-no-prelude", "src/forml/prelude.forml"] 80 | case retCode of 81 | ExitFailure msg -> do 82 | alert "FAILED" 83 | putStrLn (show msg) 84 | ExitSuccess -> do 85 | alert "Building compiler" 86 | build pkg_descr localbuildinfo flags allSuffixHandlers 87 | 88 | allSuffixHandlers :: [PPSuffixHandler] 89 | allSuffixHandlers = 90 | knownSuffixHandlers 91 | where 92 | overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler] 93 | overridesPP = unionBy (\x y -> fst x == fst y) -------------------------------------------------------------------------------- /deps.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | mkdir lib 4 | curl http://closure-compiler.googlecode.com/files/compiler-latest.zip -o ./lib/compiler.zip 5 | cd lib 6 | unzip compiler.zip 7 | git clone https://github.com/mhevery/jasmine-node.git 8 | cd .. 9 | 10 | cabal install -------------------------------------------------------------------------------- /forml.cabal: -------------------------------------------------------------------------------- 1 | Name: forml 2 | Version: 0.2 3 | Synopsis: A statically typed, functional programming language 4 | License: MIT 5 | Author: Andrew Stein 6 | Maintainer: steinlink@gmail.com 7 | Stability: Experimental 8 | Category: Compiler 9 | Build-type: Simple 10 | Cabal-version: >=1.8 11 | data-files: 12 | lib/css/jasmine.css, 13 | lib/css/prettify.css, 14 | lib/css/coda.css, 15 | lib/js/jasmine-1.0.1/jasmine-html.js, 16 | lib/js/jasmine-1.0.1/jasmine.js, 17 | lib/js/jquery.js, 18 | lib/js/lang-hs.js, 19 | lib/js/prettify.js, 20 | src/forml/parsec.forml, 21 | src/forml/prelude.forml, 22 | src/forml/tests.forml, 23 | src/forml/readme.forml, 24 | src/css/styles.css 25 | src/html/template.html, 26 | src/js/FormlReporter.js 27 | homepage: http://texodus.github.com/forml 28 | 29 | Library 30 | hs-source-dirs: src/hs/lib 31 | Build-depends: 32 | base >= 4 && <= 5, 33 | parsec, 34 | indents == 0.3.3, 35 | GraphSCC >= 1.0.2 && <1.1, 36 | sundown == 0.5.0.1, 37 | jmacro >= 0.6.4 && <0.7, 38 | transformers >= 0.3 && <0.4, 39 | MissingH, 40 | interpolatedstring-perl6, 41 | text, 42 | ansi-terminal, 43 | HTTP, 44 | network, 45 | urlencoded, 46 | file-embed, 47 | process, 48 | directory, 49 | utf8-string >= 0.3.7 && <0.4, 50 | ghc-prim, 51 | zlib >= 0.5.4.0 && <0.6, 52 | cereal >= 0.3.5.2 && <0.4, 53 | hslogger >= 1.2.1 && <1.3, 54 | HStringTemplate == 0.6.12 55 | 56 | -- latest haskell platform, or modern 57 | if impl(ghc <= 7.4.2) 58 | Build-depends: 59 | mtl >= 2.1.2 && < 2.2, 60 | bytestring >= 0.9.1 && <0.10, 61 | containers >= 0.4.2.1 && <0.5, 62 | mtl >= 2.1.2 && < 2.2 63 | else 64 | Build-depends: 65 | mtl, 66 | bytestring >= 0.10.0 && <0.11, 67 | containers >= 0.5.0.0 && <0.6 68 | 69 | if impl(ghc >= 6.12.0) 70 | ghc-options: -Wall -fwarn-tabs -funbox-strict-fields 71 | -fno-warn-unused-do-bind -threaded 72 | -funfolding-use-threshold=16 -fexcess-precision 73 | -optc-O3 -optc-ffast-math 74 | else 75 | ghc-options: -Wall -fwarn-tabs -funbox-strict-fields 76 | 77 | exposed-modules: 78 | Forml.Javascript, 79 | Forml.Javascript.Backend, 80 | Forml.Javascript.Utils, 81 | Forml.Optimize, 82 | Forml.Optimize.Optimizer, 83 | Forml.Optimize.Inline, 84 | Forml.Optimize.TailCall, 85 | Forml.Parser, 86 | Forml.Parser.Utils, 87 | Forml.TypeCheck, 88 | Forml.TypeCheck.Types, 89 | Forml.Types.Axiom, 90 | Forml.Types.Definition, 91 | Forml.Types.Expression, 92 | Forml.Types.Literal, 93 | Forml.Types.Namespace, 94 | Forml.Types.Pattern, 95 | Forml.Types.Statement, 96 | Forml.Types.Symbol, 97 | Forml.Types.Type, 98 | Forml.Types.TypeDefinition, 99 | Forml.Closure, 100 | Forml.CLI, 101 | Forml.Doc, 102 | Forml.Deps, 103 | Forml.Static, 104 | Forml.Javascript.Test, 105 | Forml.Exec 106 | 107 | Executable forml 108 | hs-source-dirs: src/hs/main 109 | main-is: Main.hs 110 | 111 | Build-depends: 112 | forml, 113 | base >= 4 && <= 5 114 | 115 | if impl(ghc >= 6.12.0) 116 | ghc-options: -Wall -fwarn-tabs -funbox-strict-fields 117 | -fno-warn-unused-do-bind -threaded 118 | -funfolding-use-threshold=16 -fexcess-precision 119 | -optc-O3 -optc-ffast-math 120 | else 121 | ghc-options: -Wall -fwarn-tabs -funbox-strict-fields 122 | 123 | Test-Suite spec 124 | Type: exitcode-stdio-1.0 125 | Hs-Source-Dirs: src/hs/test 126 | Ghc-Options: -Wall 127 | Main-Is: Spec.hs 128 | Build-Depends: base 129 | , hspec >= 1.3 130 | , silently >= 1.2.0.2 && <1.3 131 | , QuickCheck 132 | , HUnit 133 | , forml 134 | if impl(ghc <= 7.4.2) 135 | Build-Depends: bytestring >= 0.9.1 && <0.10 136 | else 137 | Build-Depends: bytestring >= 0.10.0 && <0.11 138 | -------------------------------------------------------------------------------- /lib/css/coda.css: -------------------------------------------------------------------------------- 1 | /* Coda scheme ported from TextMate to google prettify */ 2 | 3 | pre.prettyprint { padding: 5px; border-left: 5px solid #939393; 4 | border-width: 0 0 0 5px !important;} 5 | pre .nocode { background-color: none; color: #000 } 6 | pre .str { color: #731318; } /* string */ 7 | pre .kwd { color: #8C1751;} /* keyword */ 8 | pre .com { color: #256D24; } /* comment */ 9 | pre .typ { color: #000; } /* type */ 10 | pre .lit { color: #000;} /* literal */ 11 | pre .pun { color: #000 } /* punctuation */ 12 | pre .pln { color: #000 } /* plaintext */ 13 | pre .tag { color: #861681;} /* html/xml tag */ 14 | pre .atn { color: #C5680C;} /* attribute name */ 15 | pre .atv { color: #221AA6;} /* attribute value */ 16 | pre .dec { color: #1F00FF; } /* decimal */ 17 | 18 | /* Specify class=linenums on a pre to get line numbering */ 19 | ol.linenums { margin-top: 0; margin-bottom: 0; 20 | color: #333; } 21 | /* IE indents via margin-left */ 22 | li.L0,li.L1,li.L2,li.L3,li.L5,li.L6,li.L7,li.L8 { 23 | list-style-type: none } 24 | /* Alternate shading for lines */ 25 | li.L1,li.L3,li.L5,li.L7,li.L9 {background: #eee;} -------------------------------------------------------------------------------- /lib/css/jasmine.css: -------------------------------------------------------------------------------- 1 | 2 | .jasmine_reporter a:visited, .jasmine_reporter a { 3 | color: #303; 4 | } 5 | 6 | .jasmine_reporter a:hover, .jasmine_reporter a:active { 7 | color: blue; 8 | } 9 | 10 | .run_spec { 11 | float:right; 12 | padding-right: 5px; 13 | font-size: .8em; 14 | text-decoration: none; 15 | } 16 | 17 | .jasmine_reporter { 18 | margin: 0px 0px 40px 0px; 19 | } 20 | 21 | .banner { 22 | color: #303; 23 | padding: 5px; 24 | } 25 | 26 | .runner.failed { 27 | background-color: #fdd; 28 | } 29 | 30 | .runner.passed { 31 | background-color: #dfd; 32 | } 33 | 34 | 35 | .logo { 36 | float: left; 37 | font-size: 1.1em; 38 | padding-left: 5px; 39 | } 40 | 41 | .logo .version { 42 | font-size: .6em; 43 | padding-left: 1em; 44 | } 45 | 46 | .runner.running { 47 | background-color: yellow; 48 | } 49 | 50 | 51 | .options { 52 | text-align: right; 53 | font-size: .8em; 54 | } 55 | 56 | 57 | 58 | 59 | .suite { 60 | margin: 5px 0px 5px 5px; 61 | padding-left: 1em; 62 | padding-top: 2px; 63 | padding-bottom: 2px; 64 | } 65 | 66 | .suite .suite { 67 | margin: 5px 0px 5px 5px; 68 | } 69 | 70 | .suite.passed { 71 | background-color: #dfd; 72 | } 73 | 74 | .suite.failed { 75 | background-color: #fdd; 76 | } 77 | 78 | .spec { 79 | margin: 5px 0px 5px 5px; 80 | padding-left: 1em; 81 | clear: both; 82 | } 83 | 84 | .spec.failed, .spec.passed, .spec.skipped { 85 | padding-bottom: 5px; 86 | } 87 | 88 | .spec.failed { 89 | background-color: #fbb; 90 | border-color: red; 91 | } 92 | 93 | .spec.passed { 94 | background-color: #bfb; 95 | border-color: green; 96 | } 97 | 98 | .spec.skipped { 99 | background-color: #bbb; 100 | } 101 | 102 | .messages { 103 | border-left: 1px dashed gray; 104 | padding-left: 1em; 105 | padding-right: 1em; 106 | } 107 | 108 | .passed { 109 | /* background-color: #cfc; */ 110 | display: none; 111 | } 112 | 113 | /* 114 | .failed { 115 | background-color: #fbb; 116 | } 117 | */ 118 | .skipped { 119 | color: #777; 120 | background-color: #eee; 121 | display: none; 122 | } 123 | 124 | 125 | /*.resultMessage {*/ 126 | /*white-space: pre;*/ 127 | /*}*/ 128 | 129 | .resultMessage span.result { 130 | display: block; 131 | line-height: 2em; 132 | color: black; 133 | } 134 | 135 | .resultMessage .mismatch { 136 | color: black; 137 | } 138 | 139 | .stackTrace { 140 | white-space: pre; 141 | font-size: .8em; 142 | margin-left: 10px; 143 | max-height: 5em; 144 | overflow: auto; 145 | border: 1px inset red; 146 | padding: 1em; 147 | background: #eef; 148 | } 149 | 150 | .finished-at { 151 | padding-left: 1em; 152 | font-size: .6em; 153 | } 154 | 155 | .show-passed .passed, 156 | .show-skipped .skipped { 157 | display: block; 158 | } 159 | 160 | 161 | #jasmine_content { 162 | position:fixed; 163 | right: 100%; 164 | } 165 | 166 | .runner { 167 | display: block; 168 | margin: 5px 0px -5px 5px; 169 | padding: 2px 0 2px 10px; 170 | } 171 | 172 | -------------------------------------------------------------------------------- /lib/css/prettify.css: -------------------------------------------------------------------------------- 1 | .pln{color:#000}@media screen{.str{color:#080}.kwd{color:#008}.com{color:#800}.typ{color:#606}.lit{color:#066}.pun,.opn,.clo{color:#660}.tag{color:#008}.atn{color:#606}.atv{color:#080}.dec,.var{color:#606}.fun{color:red}}@media print,projection{.str{color:#060}.kwd{color:#006;font-weight:bold}.com{color:#600;font-style:italic}.typ{color:#404;font-weight:bold}.lit{color:#044}.pun,.opn,.clo{color:#440}.tag{color:#006;font-weight:bold}.atn{color:#404}.atv{color:#060}}pre.prettyprint{padding:2px;border:1px solid #888}ol.linenums{margin-top:0;margin-bottom:0}li.L0,li.L1,li.L2,li.L3,li.L5,li.L6,li.L7,li.L8{list-style-type:none}li.L1,li.L3,li.L5,li.L7,li.L9{background:#eee} 2 | 3 | /* GitHub Theme */ 4 | /* Pretty printing styles. Used with prettify.js. */ 5 | /* SPAN elements with the classes below are added by prettyprint. */ 6 | /* plain text */ 7 | .pln { 8 | color: #333333; } 9 | 10 | @media screen { 11 | 12 | /* string content */ 13 | .str { 14 | color: #dd1144; } 15 | 16 | /* a keyword */ 17 | .kwd { 18 | color: purple; } 19 | 20 | /* a comment */ 21 | .com { 22 | color: #999988; } 23 | 24 | /* a type name */ 25 | .typ { 26 | color: #445588; } 27 | 28 | /* a literal value */ 29 | .lit { 30 | color: #4455ff; } 31 | 32 | /* punctuation */ 33 | .pun { 34 | color: #999999; } 35 | 36 | /* lisp open bracket */ 37 | .opn { 38 | color: #333333; } 39 | 40 | /* lisp close bracket */ 41 | .clo { 42 | color: #333333; } 43 | 44 | /* a markup tag name */ 45 | .tag { 46 | color: navy; } 47 | 48 | /* a markup attribute name */ 49 | .atn { 50 | color: teal; } 51 | 52 | /* a markup attribute value */ 53 | .atv { 54 | color: #dd1144; } 55 | 56 | /* a declaration */ 57 | .dec { 58 | color: #333333; } 59 | 60 | /* a variable name */ 61 | .var { 62 | color: teal; } 63 | 64 | /* a function name */ 65 | .fun { 66 | color: #990000; } } 67 | /* Use higher contrast and text-weight for printable form. */ 68 | @media print, projection { 69 | .str { 70 | color: #060; } 71 | 72 | .kwd { 73 | color: #006; 74 | font-weight: bold; } 75 | 76 | .com { 77 | color: #600; 78 | font-style: italic; } 79 | 80 | .typ { 81 | color: #404; 82 | font-weight: bold; } 83 | 84 | .lit { 85 | color: #00f; } 86 | 87 | .pun, .opn, .clo { 88 | color: #440; } 89 | 90 | .tag { 91 | color: #006; 92 | font-weight: bold; } 93 | 94 | .atn { 95 | color: #404; } 96 | 97 | .atv { 98 | color: #060; } } 99 | /* Style */ 100 | pre.prettyprint { 101 | background: white; 102 | font-family: Menlo, Monaco, Consolas, monospace; 103 | font-size: 12px; 104 | line-height: 1.5; 105 | padding: 15px 10px; 106 | border: 1px solid #ccc; 107 | border-width: 1px 1px 1px 1px !important;} 108 | } 109 | 110 | /* Specify class=linenums on a pre to get line numbering */ 111 | ol.linenums { 112 | margin-top: 0; 113 | margin-bottom: 0; } 114 | 115 | /* IE indents via margin-left */ 116 | li.L0, 117 | li.L1, 118 | li.L2, 119 | li.L3, 120 | li.L4, 121 | li.L5, 122 | li.L6, 123 | li.L7, 124 | li.L8, 125 | li.L9 { 126 | /* */ } 127 | 128 | /* Alternate shading for lines */ 129 | li.L1, 130 | li.L3, 131 | li.L5, 132 | li.L7, 133 | li.L9 { 134 | /* */ } 135 | 136 | -------------------------------------------------------------------------------- /lib/js/jasmine-1.0.1/jasmine-html.js: -------------------------------------------------------------------------------- 1 | jasmine.TrivialReporter=function(a){this.document=a||document;this.suiteDivs={};this.logRunningSpecs=!1};jasmine.TrivialReporter.prototype.createDom=function(a,b,c){for(var d=document.createElement(a),e=2;e> Jasmine Running "+a.suite.description+" "+a.description+"...")}; 6 | jasmine.TrivialReporter.prototype.reportSpecResults=function(a){var b=a.results(),c=b.passed()?"passed":"failed";b.skipped&&(c="skipped");for(var c=this.createDom("div",{className:"spec "+c},this.createDom("a",{className:"run_spec",href:"?spec="+encodeURIComponent(a.getFullName())},""),this.createDom("a",{className:"description",href:"?spec="+encodeURIComponent(a.getFullName()),title:a.getFullName()},a.description.split("__::__")[1])),b=b.getItems(),d=this.createDom("div",{className:"messages"}), 7 | e=0;e122||(d<65||j>90||b.push([Math.max(65,j)|32,Math.min(d,90)|32]),d<97||j>122||b.push([Math.max(97,j)&-33,Math.min(d,122)&-33]))}}b.sort(function(a,f){return a[0]-f[0]||f[1]-a[1]});f=[];j=[NaN,NaN];for(c=0;ci[0]&&(i[1]+1>i[0]&&b.push("-"),b.push(e(i[1])));b.push("]");return b.join("")}function y(a){for(var f=a.source.match(/\[(?:[^\\\]]|\\[\S\s])*]|\\u[\dA-Fa-f]{4}|\\x[\dA-Fa-f]{2}|\\\d+|\\[^\dux]|\(\?[!:=]|[()^]|[^()[\\^]+/g),b=f.length,d=[],c=0,i=0;c=2&&a==="["?f[c]=h(j):a!=="\\"&&(f[c]=j.replace(/[A-Za-z]/g,function(a){a=a.charCodeAt(0);return"["+String.fromCharCode(a&-33,a|32)+"]"}));return f.join("")}for(var t=0,s=!1,l=!1,p=0,d=a.length;p=5&&"lang-"===b.substring(0,5))&&!(o&&typeof o[1]==="string"))c=!1,b="src";c||(r[f]=b)}i=d;d+=f.length;if(c){c=o[1];var j=f.indexOf(c),k=j+c.length;o[2]&&(k=f.length-o[2].length,j=k-c.length);b=b.substring(5);B(l+i,f.substring(0,j),e,p);B(l+i+j,c,C(b,c),p);B(l+i+k,f.substring(k),e,p)}else p.push(l+i,b)}a.e=p}var h={},y;(function(){for(var e=a.concat(m), 9 | l=[],p={},d=0,g=e.length;d=0;)h[n.charAt(k)]=r;r=r[1];n=""+r;p.hasOwnProperty(n)||(l.push(r),p[n]=q)}l.push(/[\S\s]/);y=L(l)})();var t=m.length;return e}function u(a){var m=[],e=[];a.tripleQuotedStrings?m.push(["str",/^(?:'''(?:[^'\\]|\\[\S\s]|''?(?=[^']))*(?:'''|$)|"""(?:[^"\\]|\\[\S\s]|""?(?=[^"]))*(?:"""|$)|'(?:[^'\\]|\\[\S\s])*(?:'|$)|"(?:[^"\\]|\\[\S\s])*(?:"|$))/,q,"'\""]):a.multiLineStrings?m.push(["str",/^(?:'(?:[^'\\]|\\[\S\s])*(?:'|$)|"(?:[^"\\]|\\[\S\s])*(?:"|$)|`(?:[^\\`]|\\[\S\s])*(?:`|$))/, 10 | q,"'\"`"]):m.push(["str",/^(?:'(?:[^\n\r'\\]|\\.)*(?:'|$)|"(?:[^\n\r"\\]|\\.)*(?:"|$))/,q,"\"'"]);a.verbatimStrings&&e.push(["str",/^@"(?:[^"]|"")*(?:"|$)/,q]);var h=a.hashComments;h&&(a.cStyleComments?(h>1?m.push(["com",/^#(?:##(?:[^#]|#(?!##))*(?:###|$)|.*)/,q,"#"]):m.push(["com",/^#(?:(?:define|elif|else|endif|error|ifdef|include|ifndef|line|pragma|undef|warning)\b|[^\n\r]*)/,q,"#"]),e.push(["str",/^<(?:(?:(?:\.\.\/)*|\/?)(?:[\w-]+(?:\/[\w-]+)+)?[\w-]+\.h|[a-z]\w*)>/,q])):m.push(["com",/^#[^\n\r]*/, 11 | q,"#"]));a.cStyleComments&&(e.push(["com",/^\/\/[^\n\r]*/,q]),e.push(["com",/^\/\*[\S\s]*?(?:\*\/|$)/,q]));a.regexLiterals&&e.push(["lang-regex",/^(?:^^\.?|[!+-]|!=|!==|#|%|%=|&|&&|&&=|&=|\(|\*|\*=|\+=|,|-=|->|\/|\/=|:|::|;|<|<<|<<=|<=|=|==|===|>|>=|>>|>>=|>>>|>>>=|[?@[^]|\^=|\^\^|\^\^=|{|\||\|=|\|\||\|\|=|~|break|case|continue|delete|do|else|finally|instanceof|return|throw|try|typeof)\s*(\/(?=[^*/])(?:[^/[\\]|\\[\S\s]|\[(?:[^\\\]]|\\[\S\s])*(?:]|$))+\/)/]);(h=a.types)&&e.push(["typ",h]);a=(""+a.keywords).replace(/^ | $/g, 12 | "");a.length&&e.push(["kwd",RegExp("^(?:"+a.replace(/[\s,]+/g,"|")+")\\b"),q]);m.push(["pln",/^\s+/,q," \r\n\t\xa0"]);e.push(["lit",/^@[$_a-z][\w$@]*/i,q],["typ",/^(?:[@_]?[A-Z]+[a-z][\w$@]*|\w+_t\b)/,q],["pln",/^[$_a-z][\w$@]*/i,q],["lit",/^(?:0x[\da-f]+|(?:\d(?:_\d+)*\d*(?:\.\d*)?|\.\d\+)(?:e[+-]?\d+)?)[a-z]*/i,q,"0123456789"],["pln",/^\\[\S\s]?/,q],["pun",/^.[^\s\w"-$'./@\\`]*/,q]);return x(m,e)}function D(a,m){function e(a){switch(a.nodeType){case 1:if(k.test(a.className))break;if("BR"===a.nodeName)h(a), 13 | a.parentNode&&a.parentNode.removeChild(a);else for(a=a.firstChild;a;a=a.nextSibling)e(a);break;case 3:case 4:if(p){var b=a.nodeValue,d=b.match(t);if(d){var c=b.substring(0,d.index);a.nodeValue=c;(b=b.substring(d.index+d[0].length))&&a.parentNode.insertBefore(s.createTextNode(b),a.nextSibling);h(a);c||a.parentNode.removeChild(a)}}}}function h(a){function b(a,d){var e=d?a.cloneNode(!1):a,f=a.parentNode;if(f){var f=b(f,1),g=a.nextSibling;f.appendChild(e);for(var h=g;h;h=g)g=h.nextSibling,f.appendChild(h)}return e} 14 | for(;!a.nextSibling;)if(a=a.parentNode,!a)return;for(var a=b(a.nextSibling,0),e;(e=a.parentNode)&&e.nodeType===1;)a=e;d.push(a)}var k=/(?:^|\s)nocode(?:\s|$)/,t=/\r\n?|\n/,s=a.ownerDocument,l;a.currentStyle?l=a.currentStyle.whiteSpace:window.getComputedStyle&&(l=s.defaultView.getComputedStyle(a,q).getPropertyValue("white-space"));var p=l&&"pre"===l.substring(0,3);for(l=s.createElement("LI");a.firstChild;)l.appendChild(a.firstChild);for(var d=[l],g=0;g=0;){var h=m[e];A.hasOwnProperty(h)?window.console&&console.warn("cannot override language handler %s",h):A[h]=a}}function C(a,m){if(!a||!A.hasOwnProperty(a))a=/^\s*=o&&(h+=2);e>=c&&(a+=2)}}catch(w){"console"in window&&console.log(w&&w.stack?w.stack:w)}}var v=["break,continue,do,else,for,if,return,while"],w=[[v,"auto,case,char,const,default,double,enum,extern,float,goto,int,long,register,short,signed,sizeof,static,struct,switch,typedef,union,unsigned,void,volatile"], 18 | "catch,class,delete,false,import,new,operator,private,protected,public,this,throw,true,try,typeof"],F=[w,"alignof,align_union,asm,axiom,bool,concept,concept_map,const_cast,constexpr,decltype,dynamic_cast,explicit,export,friend,inline,late_check,mutable,namespace,nullptr,reinterpret_cast,static_assert,static_cast,template,typeid,typename,using,virtual,where"],G=[w,"abstract,boolean,byte,extends,final,finally,implements,import,instanceof,null,native,package,strictfp,super,synchronized,throws,transient"], 19 | H=[G,"as,base,by,checked,decimal,delegate,descending,dynamic,event,fixed,foreach,from,group,implicit,in,interface,internal,into,is,lock,object,out,override,orderby,params,partial,readonly,ref,sbyte,sealed,stackalloc,string,select,uint,ulong,unchecked,unsafe,ushort,var"],w=[w,"debugger,eval,export,function,get,null,set,undefined,var,with,Infinity,NaN"],I=[v,"and,as,assert,class,def,del,elif,except,exec,finally,from,global,import,in,is,lambda,nonlocal,not,or,pass,print,raise,try,with,yield,False,True,None"], 20 | J=[v,"alias,and,begin,case,class,def,defined,elsif,end,ensure,false,in,module,next,nil,not,or,redo,rescue,retry,self,super,then,true,undef,unless,until,when,yield,BEGIN,END"],v=[v,"case,done,elif,esac,eval,fi,function,in,local,set,then,until"],K=/^(DIR|FILE|vector|(de|priority_)?queue|list|stack|(const_)?iterator|(multi)?(set|map)|bitset|u?(int|float)\d*)/,N=/\S/,O=u({keywords:[F,H,w,"caller,delete,die,do,dump,elsif,eval,exit,foreach,for,goto,if,import,last,local,my,next,no,our,print,package,redo,require,sub,undef,unless,until,use,wantarray,while,BEGIN,END"+ 21 | I,J,v],hashComments:!0,cStyleComments:!0,multiLineStrings:!0,regexLiterals:!0}),A={};k(O,["default-code"]);k(x([],[["pln",/^[^]*(?:>|$)/],["com",/^<\!--[\S\s]*?(?:--\>|$)/],["lang-",/^<\?([\S\s]+?)(?:\?>|$)/],["lang-",/^<%([\S\s]+?)(?:%>|$)/],["pun",/^(?:<[%?]|[%?]>)/],["lang-",/^]*>([\S\s]+?)<\/xmp\b[^>]*>/i],["lang-js",/^]*>([\S\s]*?)(<\/script\b[^>]*>)/i],["lang-css",/^]*>([\S\s]*?)(<\/style\b[^>]*>)/i],["lang-in.tag",/^(<\/?[a-z][^<>]*>)/i]]), 22 | ["default-markup","htm","html","mxml","xhtml","xml","xsl"]);k(x([["pln",/^\s+/,q," \t\r\n"],["atv",/^(?:"[^"]*"?|'[^']*'?)/,q,"\"'"]],[["tag",/^^<\/?[a-z](?:[\w-.:]*\w)?|\/?>$/i],["atn",/^(?!style[\s=]|on)[a-z](?:[\w:-]*\w)?/i],["lang-uq.val",/^=\s*([^\s"'>]*(?:[^\s"'/>]|\/(?=\s)))/],["pun",/^[/<->]+/],["lang-js",/^on\w+\s*=\s*"([^"]+)"/i],["lang-js",/^on\w+\s*=\s*'([^']+)'/i],["lang-js",/^on\w+\s*=\s*([^\s"'>]+)/i],["lang-css",/^style\s*=\s*"([^"]+)"/i],["lang-css",/^style\s*=\s*'([^']+)'/i],["lang-css", 23 | /^style\s*=\s*([^\s"'>]+)/i]]),["in.tag"]);k(x([],[["atv",/^[\S\s]+/]]),["uq.val"]);k(u({keywords:F,hashComments:!0,cStyleComments:!0,types:K}),["c","cc","cpp","cxx","cyc","m"]);k(u({keywords:"null,true,false"}),["json"]);k(u({keywords:H,hashComments:!0,cStyleComments:!0,verbatimStrings:!0,types:K}),["cs"]);k(u({keywords:G,cStyleComments:!0}),["java"]);k(u({keywords:v,hashComments:!0,multiLineStrings:!0}),["bsh","csh","sh"]);k(u({keywords:I,hashComments:!0,multiLineStrings:!0,tripleQuotedStrings:!0}), 24 | ["cv","py"]);k(u({keywords:"caller,delete,die,do,dump,elsif,eval,exit,foreach,for,goto,if,import,last,local,my,next,no,our,print,package,redo,require,sub,undef,unless,until,use,wantarray,while,BEGIN,END",hashComments:!0,multiLineStrings:!0,regexLiterals:!0}),["perl","pl","pm"]);k(u({keywords:J,hashComments:!0,multiLineStrings:!0,regexLiterals:!0}),["rb"]);k(u({keywords:w,cStyleComments:!0,regexLiterals:!0}),["js"]);k(u({keywords:"all,and,by,catch,class,else,extends,false,finally,for,if,in,is,isnt,loop,new,no,not,null,of,off,on,or,return,super,then,true,try,unless,until,when,while,yes", 25 | hashComments:3,cStyleComments:!0,multilineStrings:!0,tripleQuotedStrings:!0,regexLiterals:!0}),["coffee"]);k(x([],[["str",/^[\S\s]+/]]),["regex"]);window.prettyPrintOne=function(a,m,e){var h=document.createElement("PRE");h.innerHTML=a;e&&D(h,e);E({g:m,i:e,h:h});return h.innerHTML};window.prettyPrint=function(a){function m(){for(var e=window.PR_SHOULD_USE_CONTINUATION?l.now()+250:Infinity;p=0){var k=k.match(g),f,b;if(b= 26 | !k){b=n;for(var o=void 0,c=b.firstChild;c;c=c.nextSibling)var i=c.nodeType,o=i===1?o?b:c:i===3?N.test(c.nodeValue)?b:o:o;b=(f=o===b?void 0:o)&&"CODE"===f.tagName}b&&(k=f.className.match(g));k&&(k=k[1]);b=!1;for(o=n.parentNode;o;o=o.parentNode)if((o.tagName==="pre"||o.tagName==="code"||o.tagName==="xmp")&&o.className&&o.className.indexOf("prettyprint")>=0){b=!0;break}b||((b=(b=n.className.match(/\blinenums\b(?::(\d+))?/))?b[1]&&b[1].length?+b[1]:!0:!1)&&D(n,b),d={g:k,h:n,i:b},E(d))}}p .suite, .jasmine_reporter > .runner { 145 | padding-left: 1950px; 146 | } 147 | } 148 | 149 | @media (max-width: 979px) and (min-width: 768px) { 150 | header { 151 | margin-top: -20px; 152 | } 153 | } 154 | 155 | @media (min-width: 980px) { 156 | header { 157 | margin-top: 40px; 158 | } 159 | #test_suite { 160 | width: 2270px; 161 | margin-top: -5px; 162 | } 163 | } 164 | 165 | 166 | 167 | @media (min-width: 1200px) { 168 | #test_suite { 169 | width: 2370px; 170 | margin-top: -5px; 171 | } 172 | } 173 | 174 | #docs { 175 | position: relative; 176 | background: white; 177 | z-index: 1000; 178 | margin-left: -20px; 179 | padding-left: 30px; 180 | padding-top: 50px; 181 | } 182 | 183 | #docs ol, #docs ul { 184 | padding-left: 20px; 185 | } 186 | 187 | footer { 188 | background: #1b1b1b; 189 | color: white; 190 | position: relative; 191 | z-index: 10; 192 | } 193 | 194 | -------------------------------------------------------------------------------- /src/forml/formalz.forml: -------------------------------------------------------------------------------- 1 | -- FormlZ 2 | -- ------- 3 | -- Demonstration of some classic FP data structures. This form of polymorphism can 4 | -- be simulated in Forml the same way they are implemented in Haskell - as a function 5 | -- dictionary, the only difference being that you must explicitly bind the dictionary 6 | -- instance to a symbol (as opposed to it being referenced by the type variable's 7 | -- instantiation). 8 | 9 | module "Forml Z" 10 | 11 | open list 12 | 13 | Functor f = 14 | 15 | { map: (a -> b) -> f a -> f b } 16 | 17 | Monad m = 18 | 19 | { (>>=): m a -> (a -> m b) -> m b 20 | ret: a -> m a } 21 | 22 | map z x f = z.map f x 23 | 24 | bind { ret: f, _ } x = f x 25 | 26 | list_functor = 27 | 28 | { map _ {nil} = {nil} 29 | | f { head: x, tail: xs } = 30 | { head: f x 31 | tail: list_functor.map f xs }} 32 | 33 | list_monad = 34 | 35 | { (>>=) x g = concat_map g x 36 | return x = [:x] } 37 | 38 | js_monad = 39 | 40 | { (>>=) x f = x >>= f 41 | return x = return x } 42 | 43 | let (>>>=) x g = concat_map g x 44 | z = 1 .. 3 >>>= λx = [:x, x + 1, x + 2] 45 | 46 | z == [:1,2,3,2,3,4,3,4,5] 47 | -------------------------------------------------------------------------------- /src/forml/parsec.forml: -------------------------------------------------------------------------------- 1 | -- Parsec 2 | -- ------ 3 | 4 | module parsec 5 | 6 | open prelude 7 | open prelude.option 8 | open prelude.string 9 | open prelude.html 10 | open prelude.array 11 | 12 | 13 | 14 | Parser a = {parser: String -> {rest: String, parsed: Option a}} 15 | 16 | 17 | 18 | -- Runs a parser over a text argument and throws away the leftover text. 19 | 20 | inline run_parser: 21 | 22 | Parser p -> String -> Option p 23 | | {parser = p} x = p x |> λ {parsed = {some = y}, _} = {some = y} 24 | | _ = {none} 25 | 26 | 27 | 28 | -- Applies a function to the parse result, only if the parse was 29 | -- successful. 30 | 31 | (<$>): 32 | 33 | (a -> b) -> Parser a -> Parser b 34 | f <$> {parser = z} = 35 | 36 | { parser s = 37 | z s |> λ {parsed = {some: x}, rest = ss} = 38 | {parsed = {some = f x}, rest = ss} 39 | | {parsed = {none}, rest = x} = 40 | {parsed = {none}, rest = x} } 41 | 42 | 43 | 44 | -- Allows functions that take multiple arguments to be applied 45 | -- sequentially to a sequence of parsed values. 46 | 47 | inline (<*>): 48 | 49 | Parser (a -> b) -> Parser a -> Parser b 50 | {parser = fp} <*> {parser = p} = 51 | 52 | { parser s = 53 | fp s |> λ {parsed = {some: f}, rest = rr} = 54 | p rr |> λ {parsed = {some = x}, rest = z} = 55 | {parsed = {some = f x}, rest = z} 56 | | {parsed = {none}, rest = x} = 57 | {parsed = {none}, rest = x} 58 | | {parsed: {none}, rest: x} = 59 | {parsed: {none}, rest: x} } 60 | 61 | 62 | 63 | 64 | 65 | -- Applies two parsers in sequence, throwing out the result 66 | -- of the first. 67 | 68 | inline (*>): 69 | 70 | Parser a -> Parser b -> Parser b 71 | {parser = f} *> {parser = g} = 72 | 73 | { parser s = 74 | f s |> λ {parsed = {some = x}, rest = zz} = g zz 75 | | {parsed = {none}, rest = x} = 76 | {parsed = {none}, rest = x} } 77 | 78 | private inline lift(g, {parser: f}) = 79 | { parser text = 80 | let f' = f text 81 | in g { text: text 82 | f: f 83 | parsed: f'.parsed 84 | rest: f'.rest 85 | f': f' }} 86 | 87 | 88 | 89 | 90 | -- Alternative will try the first parser, and applies the second only if 91 | -- the first fails *and* consumes no input from the text. 92 | 93 | inline (<|>): 94 | 95 | Parser a -> Parser a -> Parser a 96 | {parser = f} <|> {parser = g} = 97 | 98 | let h text {parsed = {none}, rest = textt} when text == textt = 99 | g text 100 | | _ x = x 101 | 102 | in {parser text = h text (f text)} 103 | 104 | 105 | 106 | -- Tries to apply a parser, but restores the parser state in the case 107 | -- of a failure. This is useful with combinators that check the 108 | -- state of the consumed text, like `<|>` 109 | 110 | inline try': 111 | 112 | Parser a -> Parser a 113 | = lift λ (x & {_, parsed: {none}}) = 114 | {parsed: {none}, rest: x.text} 115 | | x = x.f' 116 | 117 | 118 | 119 | -- A parser that matches a string. Unlike Haskell's Parsec library, 120 | -- parsec.forml will not consume any input if the entire string 121 | -- doesn't match. This is for efficiency reasons currently, but 122 | -- may change in the future. 123 | 124 | inline string: 125 | 126 | String -> Parser String 127 | | x = { parser y = 128 | let sub = do! `y.substring(0, x.length)` 129 | if (sub == x) 130 | { rest = do! `y.substring(x.length)` 131 | parsed = {some = x} } 132 | else {rest = y, parsed = {none}} } 133 | 134 | 135 | 136 | -- Applies a parser repeatedly, until parsing fails. 137 | 138 | many: 139 | 140 | Parser a -> Parser (Array a) 141 | = lift λ (x & {_, parsed: {none}}) = 142 | {parsed: {some: []}, rest = x.rest} 143 | | (y & {_, parsed: {some: x}}) = 144 | (push! x <$> many {parser: y.f}).parser y.rest 145 | 146 | 147 | 148 | module "Testing" 149 | 150 | {some = "ten"} == run_parser (string "ten") "tens" 151 | {some = "tenten"} == run_parser ((λx = x +++ x) <$> string "ten") "tenfingers" 152 | 153 | {parsed = {some = "tenten"}, rest = "fingers"} 154 | == ((λx = x +++ x) <$> string "ten").parser "tenfingers" 155 | 156 | var result = run_parser ((λx y = y +++ x) <$> string "ten" <*> string "fingers") "tenfingers" 157 | result == {some: "fingersten"} 158 | 159 | var result = run_parser (string "ten" <|> string "eleven") "eleven" 160 | result == {some: "eleven"} 161 | 162 | var result = run_parser (string "ten" *> string "fingers") "tenfingers" 163 | result == {some: "fingers"} 164 | 165 | var parser = (string "ten" *> string "fingers") <|> string "tentoes" 166 | result = run_parser parser "tentoes" 167 | result == {none} 168 | 169 | var parser = try' (string "ten" *> string "fingers") <|> string "tentoes" 170 | result = run_parser parser "tentoes" 171 | result == {some: "tentoes"} 172 | 173 | var parser = many (string "ten") 174 | result = run_parser parser "tententententen" 175 | result == {some: ["ten", "ten", "ten", "ten", "ten"]} 176 | 177 | 178 | 179 | 180 | -------------------------------------------------------------------------------- /src/forml/readme.forml: -------------------------------------------------------------------------------- 1 | -- Forml 2 | -- ===== 3 | -- A contemporary programming language for the discriminating 4 | -- programmer, intended to approximate the safety of [Haskell](http://www.haskell.org) and 5 | -- the expressiveness of [Ruby](http://www.ruby.org). Should such an approximation turn out 6 | -- to exist. 7 | --
8 | -- [![Build Status](https://travis-ci.org/texodus/forml.png?branch=master)](https://travis-ci.org/texodus/forml) 9 | 10 | -- Features 11 | -- ======== 12 | 13 | -- * Buzzwords: functional, strict, expressive, pure(ish), static(y), 14 | -- inferred, fast, fun. 15 | -- Strong like a gorilla, yet soft and yielding like a Nerf ball. 16 | 17 | -- * Targets Javascript, but please regard this as an implementation detail - 18 | -- forml is not intended as an answer to "the Javascript problem." Simple 19 | -- foreign function interface, which allows the 20 | -- introduction of untyped values for quick & dirty 21 | -- code integration, which can later be restricted via explicit typing. 22 | 23 | -- * Type system which is designed to be simple and catch obvious errors, 24 | -- not entirely exhaustive, dictatorial and somewhat combative (I'm looking 25 | -- at you, Haskell). Inferred, strucural types, partials records, 26 | -- ability to introduce unrestricted types via FFI. 27 | 28 | -- * Fast. Automatic tail call optimization, 29 | -- inline functions, designed for use with 30 | -- [Google Closure Compiler](https://developers.google.com/closure/) 31 | -- advanced optimizations mode. See 32 | -- [Tests]((http://texodus.github.com/forml/prelude.html) for some 33 | -- simple benchmarks. 34 | 35 | -- * Flexible, expressive syntax. Lots of sugar for obvious tasks. 36 | 37 | -- * Inline testing, compiles to a 38 | -- [Jasmine](http://pivotal.github.com/jasmine) suite. 39 | 40 | -- * Heavily inspired by 41 | -- [Haskell](http://www.haskell.org/haskellwiki/Haskell) 42 | -- , [F#](http://msdn.microsoft.com/en-us/vstudio/hh388569.aspx) 43 | -- , [Coffeescript](http://coffeescript.org/). 44 | -- , ([_](http://en.wikipedia.org/wiki/Category:ML_programming_language_family))([S](http://www.smlnj.org/))([OCA](http://caml.inria.fr/))ML 45 | -- , [Clojure](http://clojure.org/) 46 | -- , [JMacro](http://www.haskell.org/haskellwiki/Jmacro) 47 | -- , [Ruby](http://www.ruby-lang.org/en/) 48 | 49 | -- Examples 50 | -- ======== 51 | -- * [Tetris](http://texodus.github.com/forml/tetris.html) 52 | -- * [Prelude](http://texodus.github.com/forml/prelude.html) 53 | -- * [Parsec](http://texodus.github.com/forml/parsec.html) 54 | 55 | -- Installation 56 | -- ============ 57 | -- (tested on Snow Leopard, Lion, Ubuntu). Note that Forml also requires 58 | -- [Closure](https://developers.google.com/closure/) for optimizations and 59 | -- either [Phantom.js](http://phantomjs.org) or [Node.js](http://nodejs.org) 60 | 61 | -- Install the 62 | -- [Haskell Platform](http://hackage.haskell.org/platform/index.html), then 63 | 64 | -- 
$ cabal install forml
65 | 66 | -- To compile some forml files: 67 | 68 | -- 
$ forml -o app test.forml test2.forml
69 | 70 | -- will create an app.js and app.spec.js with the compiled code and 71 | -- test suite respectively. 72 | 73 | -- Forml will by default try to minify/optimize your code with Closure, via the 74 | -- $CLOSURE environment variable, which should point to the closure jar. Failing this, 75 | -- forml will attempt to post your code to the Closure web service. 76 | 77 | -- Additionally, forml will attempt to run the test suite with the phantomjs binary, 78 | -- which it expects to find on your PATH. You may optionally specifiy to run your suite 79 | -- via node.js with 80 | 81 | -- 
$ forml -node-test test.forml
82 | 83 | -- To compile literate 84 | -- forml (eg, Forml code embedded in Markdown): 85 | 86 | -- 
$ forml test.lforml
87 | 88 | -- To see the inferred types: 89 | 90 | -- 
$ forml -t test.forml
91 | 92 | -- To turn off optimizing (eg, Closure) or testing: 93 | 94 | -- 
$ forml -no-test -no-opt test.forml
95 | 96 | -- To watch a file for changes and incrementally compile: 97 | 98 | -- 
$ forml -w test.forml
99 | 100 | -- To generate documentation and test runner (like this file): 101 | 102 | -- 
$ forml -docs test.forml
103 | 104 | -- Be sure to check out [forml-mode](https://github.com/jvshahid/forml-mode) if you're into EMACS. 105 | 106 | 107 | -- Tutorial 108 | -- ======== 109 | -- This is unfortunately not comprehensive, and presumes some working knowledge of 110 | -- ML or Haskell. Forml supports a flexible, forgiving syntax that supports many synonymous forms. 111 | -- This will be illustrated by adherring to an entirely random, arbitrary style throughout. 112 | 113 | -- The basic unit of code organization in forml is the `module`, which is simply 114 | -- a collection of definitions in a namespace. 115 | 116 | module readme 117 | 118 | -- Within a module, the compiler recognizes strictly ordered logical sections divided by 119 | -- `open` statements and sub modules; within a section, however, declarations 120 | -- can be in any order. `open` statements create local aliases for their own public definitions, which will shadow previously defined symbols. 121 | 122 | open prelude 123 | open prelude.string 124 | 125 | -- Definitions 126 | -- ----------- 127 | -- Simple functions. Forml allows function application via spaces as in 128 | -- ML, or via `()`'s in a more traditional c style - 129 | 130 | square x = x * x 131 | 132 | add(x, y) = x + y 133 | 134 | -- With pattern matching 135 | 136 | fib 0 = 0 | 1 = 1 | n = fib (n - 1) + fib (n - 2) 137 | 138 | -- Patterns can be separated with `|`, or by repeating the definition's 139 | -- name ala Haskell. Definitions can have optional type annotations, which 140 | -- may restrict the inferred type of the definition, but must not be 141 | -- more general 142 | 143 | private 144 | 145 | fib' : Num -> Num 146 | 147 | fib' 0 = 0 148 | fib' 1 = 1 149 | fib' n = fib' (n - 1) + fib' (n - 2) 150 | 151 | -- Operators can be defined much like in Haskell. Precedence is currently 152 | -- fixed, 153 | -- though you can declare right associative operators by ending them with 154 | -- a `:` character. 155 | 156 | -- Testing 157 | -- ------- 158 | 159 | -- Tests are a first class concept in forml - any unbound in a module (or in other words, 160 | -- any expression which isn't part of a definition), which is inferred as type `Bool`, 161 | -- is treated as a test, and is compiled 162 | -- to a [Jasmine](http://pivotal.github.com/jasmine) suite in a separate file from 163 | -- your definitions. 164 | 165 | fib' 7 == 13 166 | fib' 0 == 0 167 | 168 | 169 | -- For example, this file is the result of running the forml compiler with the `-docs` 170 | -- flag for [readme.forml](https://github.com/texodus/forml/blob/master/src/forml/readme.forml), 171 | -- and incorporates both the compiled output and the Jasmine suite. You can execute 172 | -- this suite by clicking the `RUN TESTS` button, which will highlight the test 173 | -- results in this document 174 | 175 | 176 | -- Modules 177 | -- ------- 178 | -- Namespaces are not symbols, so this won't work: 179 | 180 | -- 
    prelude.log "Hello, World!"    -- Won't compile!
181 | 182 | -- Instead, you must qualify the import and supply 183 | -- a symbol name to bind to. The alias will be typed 184 | -- to a record whose fields are the first-class 185 | -- definitions in the module. 186 | 187 | open prelude.array as array 188 | 189 | array.map fib [3,4,5] == [2,3,5] 190 | 191 | -- Notice this means aliased modules can be passed as arguments 192 | 193 | mmap dict f xs = dict.map f xs 194 | 195 | mmap array fib [3,4,5] == [2,3,5] 196 | 197 | 198 | -- Records 199 | -- ------- 200 | -- Forml has the basic primative types from Javascript: Num, String, 201 | -- Bool; plus 202 | -- a record, which is structurally typed (and implemented as a simple 203 | -- Javascript object, for the curious). 204 | 205 | person name address = { 206 | name = name 207 | address = address 208 | message = "`name` lives at `address`" 209 | say msg = "`name` says '`msg`'" 210 | } 211 | 212 | person("Andrew", "123 Fake St.").message 213 | is "Andrew lives at 123 Fake St." 214 | 215 | point = {x: 10, y: 10} 216 | 217 | 20 == point.x + point.y 218 | 219 | -- The sugared syntax `.field` represents an anonymous accessor function 220 | -- for convenient piping. 221 | 222 | person "Wilfred" "couch" 223 | |> .say "I'm lazy" 224 | 225 | == "Wilfred says 'I'm lazy'" 226 | 227 | var people = [ 228 | person "Josh" "Jersey" 229 | person "John" "Egypt" 230 | ] in 231 | 232 | people 'map (.name) == [ "Josh", "John" ] 233 | 234 | -- Records can be destructured in function argumentsn and can partially match 235 | -- with the `_` character. This type of function will apply to 236 | -- any record with at least the keys in the partial match. 237 | 238 | magnitude {x: x, y: y, _} = sqrt (square x + square y) 239 | 240 | magnitude {x: 3, y: 4, other: "test"} == 5 241 | magnitude {x: 4, y: 3, test: "other"} == 5 242 | 243 | -- Functions 244 | -- --------- 245 | -- Anonymous functions also follow Haskell, can be written with `\` or 246 | -- `λ`, and allows pattern seperation via `|` 247 | 248 | map: (a -> b) -> Array a -> Array b 249 | map f xs = do! `xs.map(f)` 250 | 251 | let fil = 252 | 253 | λ x when x > 5 = x 254 | | 5 = 0 255 | | x = 5 256 | 257 | map fil [2, 6, 3, 7, 5] is [5, 6, 5, 7, 0] 258 | 259 | -- All functions are curried, and can be partiall applied - even 260 | -- operators. 261 | 262 | x +* y = (2 * x) + (2 * y) 263 | 264 | [1, 2, 3] 'map ((+*) 2) == [6, 8, 10] 265 | 266 | add_twelve x y = x + y + 12 267 | 268 | let f = add_twelve 5 269 | f 10 == 27 270 | 271 | -- Interop & Side Effects 272 | -- ---------------------- 273 | -- Forml technically allows unrestricted side effects, but by default 274 | -- wraps them in a `JS a` type, which can be composed with the 275 | -- `>>=` and `>>` operators, or a variation of Haskell's `do` notation. 276 | 277 | hello_world = do 278 | 279 | `console.log("Hello World")` -- Calls to Javascript always return type `JS a` 280 | x <- `Math.sqrt(9)` -- `x` is inferred to be the unrestricted type `a` 281 | let z = x + 1 -- `x` is now restricted to type `Num` 282 | return (z + 1) -- type of `hello_world` is inferred to be `JS Num` 283 | 284 | 8 == do! hello_world >>= λx = `x + 3` 285 | 286 | -- Though this function is inferred to be `a -> b`, you can restrict it with 287 | -- a signature. 288 | 289 | inline 290 | sqrt: Num -> Num 291 | sqrt x = do! `Math.sqrt(x)` -- `do!` realizes its argument immediately 292 | 293 | -- Forml also supports additional keywords `lazy` and `yield`. Both take 294 | -- expressions as arguments (as opposed to `do` syntax), but return an 295 | -- unrealized type `JS a`, the difference being that `lazy` will only 296 | -- evaluate it's arguments once, then cache the result. 297 | 298 | let x = 0 299 | test = lazy do! `x = x + 1; x` 300 | 301 | in 1 == do! test >> test >> test >> test 302 | 303 | -- Tail Call Optimization 304 | -- ---------------------- 305 | -- This example will compile to a `for` loop, as it is 306 | -- [tail recursive](http://en.wikipedia.org/wiki/Tail_call). 307 | -- `var` is a synonym for `let`, and `in` is an optional binding 308 | -- separator. 309 | 310 | (**): 311 | 312 | String -> Num -> String 313 | text ** n = 314 | 315 | var f(_, 0, acc) = acc 316 | f(text, n, acc) = 317 | f(text, n - 1, acc +++ text) 318 | 319 | in f(text, n, "") 320 | 321 | "hello" ** 3 == "hellohellohello" 322 | length ("a" ** 10000) == 10000 323 | 324 | -- Inlines 325 | -- ------- 326 | -- Function inlining allows for macro like behavior, like lazy 327 | -- & conditional evaluation (the `'` operator here is equivalent 328 | -- is "left-pipe" application, `x |> f == x 'f`). 329 | 330 | inline whenever x f = 331 | 332 | if x then f else true 333 | 334 | "I am executed conditionally" 'error 'whenever (6 < 5) 335 | 336 | -- Arguments to an inline can be repeated, nested in yields, ifs or 337 | -- anonymous functions, even removed entirely from the code. Inlines 338 | -- can be used inside let bindings, too! 339 | 340 | let inline comment _ = true 341 | 342 | in comment <: error "I'm compiled away" 343 | 344 | 345 | 346 | -- Types, Aliases & Unions 347 | -- ----------------------- 348 | -- Forml is strong, statically typed, and types are inferred and 349 | -- checked at compile time. Unlike in traditional Hindley Milner style 350 | -- inferrence, forml allows you to break the rules with some explicit 351 | -- type annotations. 352 | 353 | num_or_string: 354 | 355 | (Num | String) -> String 356 | | x when num? x = "Num" 357 | | _ = "String" 358 | 359 | -- Structural types look just like the records they represent. 360 | 361 | unwrap: {box: a} -> a 362 | unwrap {box: x} = x 363 | 364 | -- Algebraic data types and type aliases are declared the same way 365 | -- (where the `type` keyword is optional). `{nothing}` here is 366 | -- shorthand for the record type {nothing: {}}, useful for enum types. 367 | 368 | Maybe a = {just: a} | {nothing} 369 | 370 | -- Notice there are no explicit type constructors - in forml, types 371 | -- constructor functions are inferred from the fields of a record 372 | -- and applied automatically. 373 | -- For example, when `Maybe a` is in scope, any record type with the `just` 374 | -- or `nothing` keys will be inferred to be a type `Maybe a`. 375 | 376 | maybe x {just: y} = y 377 | maybe x {nothing} = x 378 | 379 | maybe 3 {just: 4} == 4 380 | maybe 3 {nothing} == 3 381 | 382 | type Tree a = 383 | 384 | {left_tree: Tree a, right_tree: Tree a} 385 | | {leaf: a} 386 | 387 | type List a = { head: a, tail: List a } | { nil } 388 | 389 | sum: List Num -> Num 390 | sum { head: x, tail: xs } = x + sum xs 391 | sum { nil } = 0 392 | 393 | sum { head: 2 394 | tail: { head: 3 395 | tail: { nil } } } 396 | == 5 397 | 398 | -- Lists have a syntax sugar as well. 399 | 400 | sum [: 3, 4, 5 ] == 12 401 | 402 | -- In case this sort of things floats your boat, you can also declare 403 | -- polymorphic types in "java" style, with `< >`. 404 | 405 | has_value: Maybe -> Bool 406 | has_value {just: _} = true 407 | has_value _ = false 408 | 409 | has_value {just: 4} 410 | not (has_value {nothing}) 411 | 412 | -- Changes 413 | -- ======= 414 | 415 | -- 0.2 416 | 417 | -- * Incremental compilation, increased compilation speed 418 | -- * Made inlines inline their arguments as well when fully applied, 419 | -- like a macro. Code generator works better with Closure, resulting 420 | -- in smaller, more optimized JS. 421 | -- * One-sided `if` expressions. 422 | -- * `where` expressions. 423 | -- * Silent mode 424 | -- * Fixed namespace rendering error. 425 | -- * Fixed definition ordering in let bindings. 426 | -- * Fixed indentation error 427 | 428 | -- 0.1.3 429 | 430 | -- * Fixed many parsing bugs, including negative numbers, indentation 431 | -- on anonymous functions & do blocks, string-escaping, `isnt`, 432 | -- accessor ordering. 433 | -- * Operator partials ala Haskell, `sum = reduce (+)` 434 | -- * Fixed type checking of mutually recursive definitions. 435 | -- * Fixed Node.js test suite to work nearly-identically to Phantom.js 436 | -- * Fixed output to use sensible filenames, and respect the `-o` option. 437 | -- * [Tetris!](http://texodus.github.com/forml/tetris.html) 438 | 439 | -- 0.1.2 440 | 441 | -- * Added accessor function syntax for treating record fields 442 | -- as functions (eg `x.map f == x |> .map f`) 443 | -- * Added `_` as valid type variable for throwaway unique types. 444 | -- * Module aliases allow binding a module to 445 | -- a structurally typed symbol (eg `open prelude.list as list`). 446 | -- * Prelude expanded, with special attention to the `array` module. 447 | -- * Embedded prelude tests are skipped. 448 | -- * Bug fixes. 449 | 450 | -- 0.1.1 451 | 452 | -- * Documentation generation has been greatly improved. Better styling, generates individual pages for each file. 453 | -- * The prelude is now embedded in the compiler. Simply import it via `open prelude` - the compiler will include 454 | -- the code automatically. Currently weighs in at ~11k, if you care about that sort of thing. 455 | -- * Command line interface is more pleasant to work with 456 | 457 | -- Contributors 458 | -- ============ 459 | -- A special thanks to everyone who has contributed to forml! 460 | 461 | -- * [jvshahid](https://github.com/jvshahid) 462 | -- * [jhawk](https://github.com/JHawk) 463 | -- * [mightybyte](https://github.com/mightybyte) 464 | -- * [taku0](https://github.com/taku0) 465 | -- * [brow](https://github.com/brow) 466 | -- * [dignati](https://github.com/dignati) 467 | 468 | 469 | 470 | 471 | 472 | 473 | 474 | 475 | 476 | 477 | 478 | 479 | 480 | 481 | 482 | 483 | 484 | 485 | 486 | -------------------------------------------------------------------------------- /src/forml/server.forml: -------------------------------------------------------------------------------- 1 | -- Server 2 | -- ====== 3 | -- The `server` module 4 | 5 | 6 | module server 7 | 8 | open prelude 9 | 10 | require: String -> a 11 | 12 | http = require "http" 13 | 14 | inline untuple f = 15 | do! `function(x, y) { f(x)(y) }` 16 | 17 | main = 18 | .listen 3000 19 | <: http.createServer 20 | <: untuple \ req res = do! 21 | yield res.write "YO" 22 | res.end 23 | -------------------------------------------------------------------------------- /src/forml/tests.forml: -------------------------------------------------------------------------------- 1 | 2 | -- Tests 3 | -- ----- 4 | -- A collection of tests for compiler bugs, benchmarking, etc. 5 | 6 | -- Benchmarks 7 | -- ---------- 8 | -- A collection of simple benchmarks. You can view the results 9 | -- by opening your browser's terminal. 10 | 11 | module "Benchmarks for the prelude" 12 | 13 | open prelude 14 | open prelude.speedtest 15 | open prelude.list 16 | open prelude.string 17 | 18 | title x = 19 | do log "\r " 20 | log x 21 | return true 22 | 23 | -- Here we have 5 implementations of 24 | -- (Project Euler problem #1)[http://projecteuler.net/problem=1]. 25 | -- The first is simply a native JS implementation. 26 | 27 | euler_1 x = `var sum = 0; 28 | for (var i = 1; i < x; i++) { 29 | if (i % 3 == 0 || i % 5 == 0) sum += i; 30 | }; 31 | return sum;` 32 | 33 | -- The second is a tail recursive. The forml compiler will 34 | -- optimize simple functions which are tail recursive into 35 | -- javascript `for` loops automatically, making them 36 | -- much faster. 37 | 38 | euler_2 x y when x < 3 = y 39 | | x y when x % 3 == 0 || x % 5 == 0 = 40 | euler_2 (x - 1) (y + 1) 41 | | x y = euler_2 (x - 1) y 42 | 43 | euler_3 x when x < 3 = 0 44 | euler_3 x = if x % 3 == 0 || x % 5 == 0 45 | then 1 + euler_3 (x - 1) 46 | else euler_3 (x - 1) 47 | 48 | euler_4 z = yield 1 .. z 49 | |> filter (λx = x % 3 == 0 || x % 5 == 0) 50 | |> sum 51 | 52 | euler_5 x y when x < 3 = y 53 | | x y when do! `x % 3 == 0 || x % 5 == 0` = 54 | euler_5 (x - 1) (y + 1) 55 | | x y = euler_5 (x - 1) y 56 | 57 | do! title "Relative Speeds (10k)" 58 | 59 | w <- time (euler_1 10000) 60 | x <- time yield euler_2 10000 0 61 | y <- time yield euler_3 10000 62 | z <- time (euler_4 10000) 63 | q <- time yield euler_5 10000 0 64 | 65 | log " Native JS: `w / 1000`s" 66 | log " Forml TCO Unboxed: `q / 1000`s" 67 | log " Forml TCO: `x / 1000`s" 68 | log " Forml Recursive: `y / 1000`s" 69 | log " Forml list: `z / 1000`s" 70 | 71 | return <| (abs (x - y) <= 100 && y < z) 72 | 73 | string? (err yield euler_3(250000)).message 74 | 75 | do! title "Relative Speeds (2.5M)" 76 | 77 | w <- time (euler_1 2500000) 78 | x <- time yield euler_2 2500000 0 79 | y <- time yield euler_5 2500000 0 80 | 81 | log " Native JS: `w / 1000`s" 82 | log " Forml TCO Unboxed: `y / 1000`s" 83 | log " Forml TCO: `x / 1000`s" 84 | log " Forml Recursive: `err yield euler_3(250000)`" 85 | log " Forml list: `err (euler_4 250000)`" 86 | 87 | log "" 88 | 89 | return <| (w < x) 90 | 91 | 92 | module "Tests for partial records" 93 | 94 | open prelude 95 | 96 | var f {a: x, b: y, _ } = x + y 97 | f { a: 5, b: 5, c: 5 } == f { a: 5, b: 5, d: 5 } 98 | 99 | var f {a: 1, b: 1, _ } = 2 100 | f {b: 2, c: 2, _ } = 2 101 | f {a:1,b:1,c:3,d:5} + f {a:1,b:2,c:2,e:5} == 4 102 | 103 | var f { a = 1, b = 2, _ } = 1 104 | g { b = 2, c = 3, _ } = 2 105 | x = { a = 1, b = 2, c = 3, d = 4 } 106 | f x + 1 == g x 107 | 108 | module "Tests for TCO bugs" 109 | 110 | open prelude 111 | open prelude.list 112 | 113 | rev_1 y = 114 | var r rest [:] = rest 115 | | rest { head: x, tail: xs } = 116 | r (x :: rest) xs 117 | 118 | r {nil} y 119 | 120 | rev_2 = 121 | var rrr rest [:] = rest 122 | rrr rest { head: x, tail: xs } = 123 | rrr (x :: rest) xs 124 | 125 | rrr {nil} 126 | 127 | rev_2 [: 1, 2, 3, 4 ] == [: 4, 3, 2, 1 ] 128 | 129 | test_x = [: 1, 2, 3, 4, 5, 6, 7 ] 130 | 131 | rev_2 test_x == rev_1 test_x 132 | rev_1 test_x == reverse test_x 133 | length (rev_2 test_x) == length (rev_1 test_x) 134 | length (rev_2 test_x) == length test_x 135 | length (rev_1 test_x) == length (reverse test_x) 136 | 137 | 138 | 139 | module "Tests for typing bugs" 140 | 141 | open prelude 142 | 143 | ff x = gg x + 1 144 | gg x = ff x - 1 145 | 146 | 147 | 148 | module "Tests for parser bugs" 149 | 150 | open prelude 151 | open prelude.string 152 | open prelude.html 153 | 154 | var x = do! `[ {x: 1}, {x: 2}, {x: 3} ]` 155 | stringify (x !! 0).x == "1" 156 | 157 | 158 | 159 | module underscores_in_module_names_are_valid 160 | open prelude 161 | 162 | add1 x = x + 1 163 | 164 | module nested_module 165 | 166 | sub1 x = x - 1 167 | 168 | 169 | 170 | module opening_the_underscored_module 171 | 172 | open prelude 173 | open underscores_in_module_names_are_valid as uimnav 174 | open underscores_in_module_names_are_valid.nested_module 175 | 176 | same = uimnav.add1 .: sub1 177 | same 2 is 2 178 | 179 | 180 | 181 | module "Test that definition starting with as parses correctly after an open" 182 | open prelude 183 | 184 | assume_this_would_parse n = n 185 | 186 | 187 | 188 | module "Test that definition names dont collide with namespaces" 189 | 190 | open prelude 191 | 192 | module nametest 193 | 194 | x = 1 195 | 196 | nametest = {} 197 | 198 | module "Seperator" 199 | 200 | open nametest 201 | 202 | x == 1 203 | 204 | module "Test inlines" 205 | 206 | open prelude 207 | open prelude.array 208 | 209 | let x = [ 1, 2, 3, 4 ] 210 | _ = do! x[0] := 4 211 | 212 | x == [ 4, 2, 3, 4 ] 213 | 214 | 215 | 216 | let y = [[ 1, 2, 3 ]] 217 | _ = do! y[0, 0] := 3 218 | 219 | y == [[ 3, 2, 3 ]] 220 | 221 | 222 | 223 | let f x = x[0] 224 | 225 | f [0] == 0 226 | 227 | [{x = [0]}][0].x[0] == 0 228 | 229 | 230 | 231 | 232 | 233 | 234 | -------------------------------------------------------------------------------- /src/hs/lib/Forml/CLI.hs: -------------------------------------------------------------------------------- 1 | module Forml.CLI where 2 | 3 | import Control.Monad.State hiding (lift) 4 | import Control.Monad.Trans.Error (ErrorT(..)) 5 | 6 | import System.Console.ANSI 7 | import System.Exit 8 | import System.Info 9 | import System.IO 10 | import System.Process 11 | 12 | import Data.String.Utils 13 | 14 | 15 | data TestMode = NoTest | Node | Phantom 16 | 17 | data RunConfig = RunConfig { inputs :: [String] 18 | , output :: String 19 | , show_types :: Bool 20 | , optimize :: Bool 21 | , silent :: Bool 22 | , flush :: Bool 23 | , remote :: Bool 24 | , pretty :: Bool 25 | , run_tests :: TestMode 26 | , write_docs :: Bool 27 | , implicit_prelude :: Bool 28 | , watch :: Bool } 29 | 30 | 31 | parseArgs :: [String] -> RunConfig 32 | parseArgs = fst . runState argsParser 33 | where argsParser = do args <- get 34 | case args of 35 | [] -> return $ RunConfig [] "default" False True False False False False Phantom False True False 36 | (x':xs) -> do put xs 37 | case x' of 38 | "-w" -> do x <- argsParser 39 | return $ x { watch = True } 40 | "-docs" -> do x <- argsParser 41 | return $ x { write_docs = True } 42 | "-t" -> do x <- argsParser 43 | return $ x { show_types = True } 44 | "-no-prelude" -> do x <- argsParser 45 | return $ x { implicit_prelude = False } 46 | "-no-opt" -> do x <- argsParser 47 | return $ x { optimize = False } 48 | "-silent" -> do x <- argsParser 49 | return $ x { silent = True } 50 | "-flush" -> do x <- argsParser 51 | return $ x { flush = True } 52 | "-remote" -> do x <- argsParser 53 | return $ x { remote = True } 54 | "-pretty" -> do x <- argsParser 55 | return $ x { pretty = True } 56 | "-no-test" -> do x <- argsParser 57 | return $ x { run_tests = NoTest } 58 | "-node-test" -> do x <- argsParser 59 | return $ x { run_tests = Node } 60 | "-o" -> do (name:ys) <- get 61 | put ys 62 | RunConfig a _ c d e f g h i j k l <- argsParser 63 | return $ RunConfig a name c d e f g h i j k l 64 | ('-':_) -> error "Could not parse options" 65 | z -> do RunConfig a _ c d e f g h i j k l <- argsParser 66 | let b = last $ split "/" $ head $ split "." z 67 | return $ RunConfig (x':a) b c d e f g h i j k l 68 | 69 | type StatusLogger a = String -> a -> IO a 70 | 71 | status_logger :: [SGR] -> String -> StatusLogger a 72 | status_logger sgrs rep = 73 | let logger str out = 74 | colors ((putStrLn $ "[" ++ rep ++ "] " ++ str) >> return out) $ 75 | do putStr "\r[" 76 | setSGR sgrs 77 | putStr rep 78 | setSGR [Reset] 79 | putStrLn$ "] " ++ str 80 | return out in 81 | logger 82 | 83 | success :: String -> a -> IO a 84 | success = status_logger [SetColor Foreground Dull Green] "*" 85 | 86 | warn :: String -> a -> IO a 87 | warn = status_logger [SetColor Foreground Dull Yellow] "-" 88 | 89 | failure :: String -> a -> IO a 90 | failure = status_logger [SetColor Foreground Dull Red] "X" 91 | 92 | colors :: IO a -> IO a -> IO a 93 | colors failure success = 94 | if os == "mingw32" 95 | then success 96 | else do 97 | (_, Just std_out', _, p) <- 98 | createProcess (shell "tput colors 2> /dev/null") { std_out = CreatePipe } 99 | waitForProcess p 100 | c <- hGetContents std_out' 101 | case reads (strip c) of 102 | [(x, "")] | x > (2 :: Integer) -> success 103 | _ -> failure 104 | 105 | type Runner a = String -> IO (Either [String] a) -> IO a 106 | 107 | singleError :: ErrorT String IO a -> IO (Either [String] a) 108 | singleError = liftM (either (Left . (:[])) Right) . runErrorT 109 | 110 | run_silent :: Runner a 111 | run_silent _ d = 112 | do d' <- d 113 | case d' of 114 | Right y -> do return y 115 | Left y -> do exitFailure 116 | 117 | monitor :: Runner a 118 | monitor x d = do colors (return ()) $ putStr $ "[ ] " ++ x 119 | hFlush stdout 120 | d' <- d 121 | case d' of 122 | Right y -> success x y 123 | Left y -> do failure x y 124 | if length y <= 5 125 | then mapM putStrLn y >> return () 126 | else mapM putStrLn (take 5 y) >> putStrLn ("\n" ++ show (length y - 5) ++ " additional errors") 127 | exitFailure 128 | -------------------------------------------------------------------------------- /src/hs/lib/Forml/Closure.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE QuasiQuotes #-} 8 | {-# LANGUAGE OverlappingInstances #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE TupleSections #-} 11 | 12 | module Forml.Closure ( 13 | CompilationLevel(..), 14 | closure, 15 | ) where 16 | 17 | import Control.Applicative 18 | import Control.Monad (MonadPlus, mplus) 19 | import Control.Monad.Trans.Class 20 | import Control.Monad.Trans.Error 21 | 22 | import System.IO 23 | import System.Environment 24 | import System.Exit (ExitCode(ExitSuccess)) 25 | import System.Directory 26 | import System.Process 27 | 28 | import Network.HTTP 29 | import Network.URI 30 | 31 | import Data.List as L 32 | import Data.URLEncoded 33 | import Data.Maybe (fromMaybe) 34 | 35 | data CompilationLevel = Advanced | Simple 36 | 37 | infix 1 `guardM` 38 | guardM :: (Error e, Monad m) => m Bool -> String -> ErrorT e m () 39 | guardM q msg = guard' =<< lift q 40 | where guard' True = return () 41 | guard' False = throwError (strMsg msg) 42 | 43 | compilationLevel :: CompilationLevel -> String 44 | compilationLevel Advanced = "ADVANCED_OPTIMIZATIONS" 45 | compilationLevel Simple = "SIMPLE_OPTIMIZATIONS" 46 | 47 | closure_local, closure_remote 48 | :: (Error e) => String -> CompilationLevel -> ErrorT e IO String 49 | 50 | closure_local x y = 51 | do closureEnv <- ErrorT $ maybe (Left $ strMsg "$CLOSURE unset") return 52 | . L.lookup "CLOSURE" <$> getEnvironment 53 | doesFileExist closureEnv `guardM` closureEnv ++ " not found" 54 | lift $ hFlush stdout >> writeFile "temp.js" x 55 | retCode <- lift . rawSystem "java" $ 56 | ["-jar", closureEnv, 57 | "--compilation_level", compilationLevel y, 58 | -- ["--formatting=pretty_print", "--formatting=print_input_delimiter"], 59 | "--js", "temp.js", "--js_output_file", "temp.compiled.js", 60 | "--warning_level", "QUIET"] 61 | return (retCode == ExitSuccess) `guardM` "local closure compiler failed" 62 | doesFileExist "temp.compiled.js" `guardM` "temp.compiled.js not found" 63 | js <- lift $ readFile "temp.compiled.js" 64 | length js `seq` 65 | lift (removeFile "temp.js" >> removeFile "temp.compiled.js") 66 | return js 67 | 68 | closure_remote x z = 69 | let uri = fromMaybe undefined $ parseURI "http://closure-compiler.appspot.com/compile" 70 | y = export$ importList [ ("output_format", "text") 71 | , ("output_info", "compiled_code") 72 | , ("compilation_level", compilationLevel z) 73 | , ("js_code", x) ] 74 | args = [ mkHeader HdrContentLength (show$ length y) 75 | , mkHeader HdrContentType "application/x-www-form-urlencoded" ] 76 | in lift $ simpleHTTP (Request uri POST args y) 77 | >>= getResponseBody 78 | 79 | closure :: (Error e) => Bool -> String -> CompilationLevel -> ErrorT e IO String 80 | closure remote x z = 81 | closure_local x z `mplus` 82 | if remote then closure_remote x z 83 | else throwError (strMsg "Local Closure unavailable; pass -remote option to use public server") 84 | -------------------------------------------------------------------------------- /src/hs/lib/Forml/Deps.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE KindSignatures #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE NamedFieldPuns #-} 9 | {-# LANGUAGE OverlappingInstances #-} 10 | {-# LANGUAGE QuasiQuotes #-} 11 | {-# LANGUAGE RankNTypes #-} 12 | {-# LANGUAGE RecordWildCards #-} 13 | {-# LANGUAGE ScopedTypeVariables #-} 14 | {-# LANGUAGE TemplateHaskell #-} 15 | {-# LANGUAGE TypeSynonymInstances #-} 16 | {-# LANGUAGE UndecidableInstances #-} 17 | {-# LANGUAGE ViewPatterns #-} 18 | 19 | module Forml.Deps where 20 | 21 | import qualified Data.Map as M 22 | 23 | import Data.List 24 | 25 | import Forml.Types.Axiom 26 | import Forml.Types.Definition 27 | import Forml.Types.Expression 28 | import Forml.Types.Statement 29 | import Forml.Types.Namespace hiding (Module) 30 | import Forml.Types.Pattern 31 | import Forml.Parser.Utils 32 | 33 | 34 | import Data.Graph (graphFromEdges, SCC(..)) 35 | import Data.Graph.SCC (sccList) 36 | 37 | import Language.Javascript.JMacro 38 | 39 | 40 | sort_dep :: [[Definition]] -> [[Definition]] 41 | sort_dep [] = [] 42 | sort_dep (concat -> xs) = unwrap `map` sccList graph 43 | 44 | where (graph, reverse_lookup, _) = graphFromEdges . map to_node $ xs 45 | 46 | unwrap (AcyclicSCC v) = [ get_node . reverse_lookup $ v ] 47 | unwrap (CyclicSCC v) = map (get_node . reverse_lookup) v 48 | 49 | get_node (d, _, _) = d 50 | 51 | to_node :: Definition -> (Definition, String, [String]) 52 | to_node def @ (Definition _ _ n as) = 53 | (def, show n, concat . map get_symbols . get_expressions $ as) 54 | 55 | get_expressions [] = [] 56 | get_expressions (TypeAxiom _: xs') = get_expressions xs' 57 | get_expressions (EqualityAxiom (Match _ (Just y)) (Addr _ _ x): xs') = y : x : get_expressions xs' 58 | get_expressions (EqualityAxiom _ (Addr _ _ x): xs') = x : get_expressions xs' 59 | 60 | get_symbols (RecordExpression (unzip . M.toList -> (_, xs))) = concat (map get_symbols xs) 61 | get_symbols (AccessorExpression (Addr _ _ x) _) = get_symbols x 62 | get_symbols (ApplyExpression a b) = get_symbols a ++ concat (map get_symbols b) 63 | get_symbols (IfExpression a b (Just c)) = get_symbols a ++ get_symbols b ++ get_symbols c 64 | get_symbols (IfExpression a b Nothing) = get_symbols a ++ get_symbols b 65 | get_symbols (LiteralExpression _) = [] 66 | get_symbols (SymbolExpression x) = [show x] 67 | get_symbols (JSExpression x) = get_jexpr x 68 | get_symbols (LazyExpression (Addr _ _ x) _) = get_symbols x 69 | get_symbols (FunctionExpression as) = concat$ map get_symbols$ get_expressions as 70 | get_symbols (LetExpression xs x) = (concat . map get_symbols . concat . map get_expressions . map (\(Definition _ _ _ as) -> as) $ xs) ++ get_symbols x 71 | get_symbols (ListExpression x) = concat (map get_symbols x) 72 | get_symbols _ = error "Unimplemented TypeCheck 544" 73 | 74 | get_stat (ReturnStat x) = (get_jexpr x) 75 | get_stat (IfStat a b c) = (get_jexpr a) ++ (get_stat b) ++ (get_stat c) 76 | get_stat (WhileStat a b c) = (get_jexpr b) ++ (get_stat c) 77 | get_stat (ForInStat a b c d) = (get_jexpr c) ++ (get_stat d) 78 | get_stat (SwitchStat a b c) = (get_jexpr a) ++ (get_stat c) 79 | get_stat (TryStat a b c d) = (get_stat a) ++ (get_stat c) ++ (get_stat d) 80 | get_stat (BlockStat xs) = concat (get_stat `map` xs) 81 | get_stat (ApplStat a b) = (get_jexpr a) ++ concat (get_jexpr `map` b) 82 | get_stat (PPostStat a b c) = (get_jexpr c) 83 | get_stat (AssignStat a b) = (get_jexpr a) ++ (get_jexpr b) 84 | get_stat (UnsatBlock a) = [] --(get_stat `fmap` a) 85 | get_stat (DeclStat v t) = [] 86 | get_stat (UnsatBlock ident_supply) = [] --get_stat `fmap` ident_supply 87 | get_stat (AntiStat s) = [] 88 | get_stat (ForeignStat s t) = [] 89 | get_stat (BreakStat s) = [] 90 | 91 | get_jval (JList xs) = concat $ get_jexpr `map` xs 92 | get_jval (JHash m) = concat $ M.elems $ M.map get_jexpr m 93 | get_jval (JFunc xs x) = get_stat x 94 | get_jval (UnsatVal x) = [] -- get_jexpr `fmap` x 95 | get_jval x@(JDouble _) = [] 96 | get_jval x@(JInt _) = [] 97 | get_jval x@(JStr _) = [] 98 | get_jval x@(JRegEx _) = [] 99 | get_jval (JVar (StrI x)) = [x] 100 | 101 | 102 | get_jexpr (SelExpr e (StrI i)) = get_jexpr e 103 | get_jexpr (IdxExpr a b) = get_jexpr a ++ get_jexpr b 104 | get_jexpr (InfixExpr a b c) = get_jexpr b ++ get_jexpr c 105 | get_jexpr (PPostExpr a b c) = get_jexpr c 106 | get_jexpr (IfExpr a b c) = get_jexpr a ++ get_jexpr b ++ get_jexpr c 107 | get_jexpr (NewExpr a) = get_jexpr a 108 | get_jexpr (ApplExpr a b) = get_jexpr a ++ concat (get_jexpr `map` b) 109 | get_jexpr (TypeExpr a b c) = get_jexpr b 110 | get_jexpr (ValExpr a) = get_jval a 111 | get_jexpr (UnsatExpr a) = [] --get_jexpr `fmap` a 112 | 113 | 114 | 115 | 116 | sorted_defs :: [Statement] -> [Statement] 117 | sorted_defs [] = [] 118 | sorted_defs xs = 119 | 120 | case takeWhile not_module xs of 121 | [] -> (take 1 xs) ++ sorted_defs (drop 1 xs) 122 | yx -> sort_deps yx ++ sorted_defs (dropWhile not_module xs) 123 | 124 | where 125 | 126 | sort_deps ys = 127 | 128 | rejoin (concat $ sort_dep (get_defs ys)) ys 129 | 130 | where get_defs (DefinitionStatement d : xs) = [d] : get_defs xs 131 | get_defs (x : xs) = get_defs xs 132 | get_defs [] = [] 133 | 134 | rejoin (x:xs) (DefinitionStatement _ : ys) = DefinitionStatement x : rejoin xs ys 135 | rejoin xs (y:ys) = y : rejoin xs ys 136 | rejoin [] [] = [] 137 | rejoin _ _ = error "Error sorting dependencies" 138 | 139 | 140 | 141 | not_module (ModuleStatement _ _) = False 142 | not_module _ = True 143 | 144 | 145 | 146 | 147 | 148 | data BindGroup = 149 | 150 | Scope { 151 | imports :: [(Namespace, Maybe String)], 152 | statements :: [Statement], 153 | explicits :: [Definition], 154 | implicits :: [[Definition]], 155 | tests :: [Addr (Expression Definition)] 156 | } 157 | 158 | | Module String [BindGroup] 159 | 160 | deriving (Show) 161 | 162 | 163 | to_group :: [Statement] -> [BindGroup] 164 | to_group [] = [] 165 | to_group xs = 166 | 167 | case takeWhile not_module xs of 168 | [] -> to_group' xs 169 | yx -> sort_deps (foldl f (Scope [] [] [] [] []) yx) 170 | : to_group' (dropWhile not_module xs) 171 | 172 | where to_group' [] = [] 173 | to_group' (ModuleStatement x y:ys) = Module (show x) (to_group y) : to_group ys 174 | to_group' _ = error "Unexpected" 175 | 176 | sort_deps s @ Scope { implicits = b } = s { implicits = sort_dep b } 177 | 178 | not_module (ModuleStatement _ _) = False 179 | not_module _ = True 180 | 181 | f s @ Scope { implicits = b} (DefinitionStatement x @ (Definition _ _ _ (EqualityAxiom _ _:_))) = 182 | s { implicits = b ++ [[x]] } 183 | f s @ Scope { explicits = a} (DefinitionStatement x @ (Definition _ _ _ (TypeAxiom _:_))) = 184 | s { explicits = a ++ [x] } 185 | f s @ Scope { tests = c } (ExpressionStatement x) = s { tests = c ++ [x] } 186 | f s @ Scope { imports = i } (ImportStatement ns Nothing) = s { imports = i ++ [(ns, Nothing)] } 187 | f s @ Scope { imports = i } (ImportStatement ns (Just alias)) = s { imports = i ++ [(ns, Just alias)] } 188 | f s @ Scope { statements = t } x @ (TypeStatement _ _) = s { statements = t ++ [x] } 189 | f x _ = x 190 | 191 | 192 | -------------------------------------------------------------------------------- /src/hs/lib/Forml/Doc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE OverlappingInstances #-} 4 | {-# LANGUAGE QuasiQuotes #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | {-# LANGUAGE TupleSections #-} 9 | {-# LANGUAGE ViewPatterns #-} 10 | 11 | 12 | module Forml.Doc where 13 | 14 | import Text.InterpolatedString.Perl6 15 | import Text.Sundown.Html.String 16 | 17 | import Data.Char (isAscii, ord) 18 | import Data.String.Utils 19 | 20 | 21 | import Text.StringTemplate 22 | 23 | import Forml.Parser 24 | import Forml.Static 25 | import Forml.CLI 26 | 27 | type Source = String 28 | type Title = String 29 | type Error = String 30 | type Filename = String 31 | 32 | toEntities :: String -> String 33 | toEntities [] = "" 34 | toEntities (c:cs) | isAscii c = c : toEntities cs 35 | | otherwise = [qq|&#{ord c};{toEntities cs}|] 36 | 37 | toHTML :: String -> String 38 | toHTML input = renderHtml input allExtensions noHtmlModes True Nothing 39 | 40 | 41 | to_literate :: String -> String -> String 42 | to_literate "(Prelude)" = id 43 | to_literate filename 44 | | (head . reverse . split "." $ filename) == "lformal" = id 45 | | otherwise = unlines . map l . lines 46 | 47 | where l (lstrip -> '-':'-':xs) = lstrip xs 48 | l x = " " ++ x 49 | 50 | 51 | get_title :: String -> String -> (String, String, String) 52 | get_title d x = case lines x of 53 | z @ ((strip -> ('-':'-':_:x')):('-':'-':_:'-':_):_) -> 54 | let description = get_description (drop 2 z) in 55 | (x', unlines description, unlines $ drop (2 + length description) z) 56 | z @ ((strip -> ('-':'-':_:x')):('-':'-':_:'=':_):_) -> 57 | let description = get_description (drop 2 z) in 58 | (x', unlines description, unlines $ drop (2 + length description) z) 59 | _ -> (d, "", x) 60 | 61 | where 62 | get_description (('-':'-':_:x):xs) = x : get_description xs 63 | get_description _ = [] 64 | 65 | 66 | docs :: String -> [String] -> [String] -> [Title] -> [String] -> [Program] -> [Source] -> IO () 67 | docs _ [] [] [] [] [] [] = return () 68 | docs js (tests:testses) (filename':filenames) (title:titles) (desc:descs) (program @ (Program xs):programs) (source:sources) = 69 | 70 | let html' = highlight (get_tests xs) $ toHTML (annotate_tests source program) 71 | 72 | filename = [qq|$filename'.html|] 73 | compiled = [qq||] 74 | 75 | template = newSTMP html_template :: StringTemplate String 76 | html = render $ 77 | setAttribute "html" (html' :: String) $ 78 | setAttribute "scripts" (scripts) $ 79 | setAttribute "javascript" (compiled :: String) $ 80 | setAttribute "css" (css' :: String) $ 81 | setAttribute "title" title $ 82 | setAttribute "desc" (toHTML desc) $ 83 | template 84 | 85 | in do monitor [qq|Docs {filename}|] $ 86 | do writeFile filename html 87 | return $ Right () 88 | 89 | docs js testses filenames titles descs programs sources 90 | 91 | docs _ _ _ _ _ _ _ = error "Paradox: `docs` called with non equivalent arguments" 92 | -------------------------------------------------------------------------------- /src/hs/lib/Forml/Exec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE NamedFieldPuns #-} 4 | {-# LANGUAGE OverlappingInstances #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE QuasiQuotes #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE RecordWildCards #-} 9 | {-# LANGUAGE TemplateHaskell #-} 10 | {-# LANGUAGE TupleSections #-} 11 | 12 | module Forml.Exec where 13 | 14 | import Text.InterpolatedString.Perl6 15 | 16 | import Control.Concurrent 17 | import Control.Monad.State hiding (lift) 18 | 19 | import System.Directory 20 | import System.Environment 21 | import System.Info 22 | import System.IO 23 | import System.IO.Unsafe 24 | import System.Log.Logger 25 | import System.Log.Handler.Syslog 26 | 27 | import qualified Data.ByteString as B 28 | import qualified Data.ByteString.Lazy as BL 29 | import Data.List as L 30 | import qualified Data.Serialize as S 31 | import Data.String.Utils (split) 32 | 33 | import GHC.Generics 34 | import GHC.IO.Encoding 35 | 36 | import Forml.CLI 37 | import Forml.Closure 38 | import Forml.Doc 39 | import Forml.Javascript 40 | import Forml.Javascript.Backend 41 | import Forml.Javascript.Test 42 | import Forml.Javascript.Utils (prelude) 43 | import qualified Forml.Optimize as O 44 | import Forml.Optimize.Optimizer as OP 45 | import Forml.Parser 46 | import Forml.Static 47 | import Forml.TypeCheck 48 | import Forml.Parser.Utils 49 | 50 | import qualified Codec.Compression.GZip as G 51 | 52 | to_parsed :: Title -> Source -> TypeSystem -> Either [Error] (TypeSystem, Program) 53 | to_parsed name src env = case parseForml name src of 54 | Left x -> Left [show x] 55 | Right x -> case tiProgram x env of 56 | (as, []) -> Right (as, x) 57 | (_, y) -> Left y 58 | 59 | file_sep = if os == "mingw32" then "\\" else "/" 60 | to_filename = head . split "." . last . split file_sep 61 | 62 | data Compiled = Compiled { filename :: Filename 63 | , types :: TypeSystem 64 | , program :: Program 65 | , source :: Source 66 | , title :: Title 67 | , js :: String 68 | , opt_st :: OptimizeState 69 | , tests :: String 70 | , desc :: String } deriving (Generic, Show) 71 | 72 | instance S.Serialize Compiled 73 | 74 | parse_forml :: [Filename] -> Compiled -> Runner (TypeSystem, Program) -> IO [Compiled] 75 | parse_forml filenames compiled runner = do 76 | sources <- mapM get_source filenames 77 | foldM parse' [compiled] (sources `zip` filenames) 78 | 79 | where 80 | parse' acc (src'', filename) = do 81 | let Compiled { types = ts, opt_st = opt } = last acc 82 | let (title, desc, src) = get_title (to_filename filename) src'' 83 | let src' = to_literate filename . (++ "\n") $ src 84 | 85 | (ts', ast) <- runner [qq|Loading {filename}|] $ return $ to_parsed filename src' ts 86 | 87 | let (opt', opt_ast) = run_optimizer ast (opt { OP.assumptions = ts'}) 88 | let (js', tests') = gen_js src' (opt_ast) (whole_program $ map program acc ++ [opt_ast]) 89 | 90 | return $ acc ++ [Compiled (to_filename filename) ts' opt_ast src' title js' opt' tests' desc] 91 | 92 | get_source filename = do 93 | hFile <- openFile filename ReadMode 94 | hGetContents hFile 95 | 96 | whole_program p = Program $ get_program p 97 | 98 | get_program (Program ss: ps) = ss ++ get_program ps 99 | get_program [] = [] 100 | 101 | gen_js :: Source -> Program -> Program -> (String, String) 102 | gen_js src p whole_program = 103 | (unserialize g, unserialize h) 104 | where 105 | g = render whole_program src p 106 | h = render_spec whole_program src p 107 | unserialize x = compress $ read' x 108 | 109 | read' xs @ ('"':_) = read xs 110 | read' x = x 111 | 112 | exec :: IO () 113 | exec = do 114 | args <- getArgs 115 | if silent $ parseArgs args 116 | then updateGlobalLogger "Global" (setLevel ERROR) 117 | else updateGlobalLogger "Global" (setLevel INFO) 118 | main' $ parseArgs args 119 | 120 | main' :: RunConfig -> IO () 121 | main' rc' = 122 | if watch rc' 123 | then watch' rc' 124 | else compile rc' 125 | 126 | where f (x, y) = show x ++ "\n " ++ concat (L.intersperse "\n " (map show y)) ++ "\n\n " 127 | 128 | runner = if silent rc' then run_silent else monitor 129 | 130 | watch' rc = 131 | do x <- mapM getModificationTime . inputs $ rc 132 | compile rc 133 | infoM "Global" "Waiting ..." 134 | wait rc x 135 | 136 | wait rc x = 137 | do threadDelay 1000 138 | x' <- mapM getModificationTime . inputs $ rc 139 | if x /= x' then do infoM "Global" "\r" 140 | watch' rc 141 | else wait rc x 142 | empty_state = 143 | Compiled "" [] (Program []) "" "" [] (OP.gen_state []) [] "" 144 | 145 | compile rc = 146 | 147 | do setLocaleEncoding utf8 148 | setFileSystemEncoding utf8 149 | setForeignEncoding utf8 150 | state <- if implicit_prelude rc 151 | then return $ case S.decode prelude' of 152 | Left x -> error x 153 | Right x -> x 154 | else return $ empty_state 155 | 156 | compiled <- drop 1 `fmap` parse_forml (inputs rc) state runner 157 | 158 | _ <- mapM (\ c @ (Compiled { .. }) -> 159 | runner [qq|Compiling {filename}.obj |] $ fmap Right $ 160 | B.writeFile (filename ++ ".obj") $ B.concat $ BL.toChunks $ G.compress $ BL.fromChunks [S.encode c]) 161 | compiled 162 | 163 | let js'' = read' prelude ++ "\n" 164 | ++ if implicit_prelude rc then js state ++ (concatMap js compiled) else concatMap js compiled 165 | js' <- case rc of 166 | RunConfig { optimize = True } -> 167 | runner [qq|Closure {output rc}.js |] . singleError $ closure (remote rc) js'' Advanced 168 | RunConfig { silent = False } -> 169 | do warn "Closure [libs]" js'' 170 | _ -> do return js'' 171 | 172 | tests' <- case rc of 173 | RunConfig { optimize = True } -> 174 | zipWithM (\title t -> runner [qq|Closure {title}.spec.js |] . singleError $ closure (remote rc) t Simple) 175 | (map filename compiled) 176 | (map ((read' prelude ++) . tests) compiled) 177 | RunConfig { silent = False } -> 178 | warn "Closure [tests]" (map tests compiled) 179 | _ -> do return (map tests compiled) 180 | 181 | if flush rc 182 | then putStr js' >> hFlush stdout 183 | else writeFile (output rc ++ ".js") js' 184 | 185 | _ <- zipWithM writeFile (map (++ ".spec.js") (map filename compiled)) tests' 186 | 187 | if write_docs rc 188 | then docs js' 189 | tests' 190 | (map filename compiled) 191 | (map title compiled) 192 | (map desc compiled) 193 | (map program compiled) 194 | (map source compiled) 195 | else runner "Docs" $ return $ Right () 196 | 197 | _ <- sequence (zipWith (test rc js') (map filename compiled) tests') 198 | 199 | if (show_types rc) 200 | then putStrLn $ ("\nTypes\n\n " ++ concatMap (concatMap f . types) compiled) 201 | else return () 202 | -------------------------------------------------------------------------------- /src/hs/lib/Forml/Javascript.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, 2 | MultiParamTypeClasses, NamedFieldPuns, OverlappingInstances, 3 | QuasiQuotes, RankNTypes, RecordWildCards, TypeSynonymInstances, 4 | UndecidableInstances #-} 5 | 6 | module Forml.Javascript (render, render_spec) where 7 | 8 | import Prelude hiding (curry, (++)) 9 | 10 | import qualified Data.Map as M 11 | 12 | import Language.Javascript.JMacro 13 | 14 | import Forml.Javascript.Backend 15 | import Forml.Types.Statement 16 | import Forml.Parser 17 | 18 | 19 | render :: Program -> String -> Program -> String 20 | render (Program ys) src (Program xs) = 21 | show . renderJs . runJS src . toJS . map (empty_meta Library ys) $ xs 22 | 23 | render_spec :: Program -> String -> Program -> String 24 | render_spec (Program ys) src (Program xs) = 25 | show . renderJs . wrap . runJS src . toJS . map (empty_meta Test ys) $ xs 26 | where wrap x = [jmacro| describe("", function() { `(x)`; }); |] 27 | 28 | 29 | 30 | -------------------------------------------------------------------------------- /src/hs/lib/Forml/Javascript/Backend.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE QuasiQuotes #-} 8 | {-# LANGUAGE OverlappingInstances #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE FlexibleInstances #-} 11 | {-# LANGUAGE FunctionalDependencies #-} 12 | {-# LANGUAGE TypeSynonymInstances #-} 13 | {-# LANGUAGE MultiParamTypeClasses #-} 14 | {-# LANGUAGE GADTs #-} 15 | {-# LANGUAGE ScopedTypeVariables #-} 16 | {-# LANGUAGE UndecidableInstances, KindSignatures #-} 17 | 18 | module Forml.Javascript.Backend where 19 | 20 | import Forml.Types.Namespace 21 | import Forml.TypeCheck.Types 22 | import Forml.Parser.Utils 23 | 24 | import Data.Monoid 25 | import Data.String.Utils 26 | import Text.Parsec (sourceLine) 27 | 28 | type TypeSystem = [(Namespace, [Assumption])] 29 | 30 | data JSState = JSState { src :: String 31 | , assumptions :: TypeSystem } 32 | 33 | newtype JS a = JS (JSState -> (JSState, a)) 34 | 35 | instance Monad JS where 36 | fail x = JS (\_ -> error$ x) 37 | return x = JS (\y -> (y, x)) 38 | JS f >>= g = JS (\x -> case f x of 39 | (y, x') -> let JS gx = g x' 40 | in gx y) 41 | 42 | instance Functor JS where 43 | fmap f y = y >>= (\x -> JS (\x' -> (x', f x))) 44 | 45 | class Javascript e t | e -> t where toJS :: e -> JS t 46 | 47 | runJS :: String -> JS t -> t 48 | runJS src (JS f) = snd . f $ JSState src [] 49 | 50 | instance (Javascript a b, Monoid b) => Javascript [a] b where 51 | 52 | toJS [] = return mempty 53 | toJS (x:xs) = do x' <- toJS x 54 | xs' <- toJS xs 55 | return $ mappend x' xs' 56 | 57 | get_error :: Addr a -> String -> String 58 | get_error (Addr (sourceLine -> x) (sourceLine -> y) _) = 59 | 60 | rstrip . unlines . lines . rstrip . unlines . take ((y - x) + 1) . drop (x - 1) . lines 61 | 62 | -------------------------------------------------------------------------------- /src/hs/lib/Forml/Javascript/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE OverlappingInstances #-} 4 | {-# LANGUAGE QuasiQuotes #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | {-# LANGUAGE TupleSections #-} 9 | 10 | module Forml.Javascript.Test where 11 | 12 | import Text.InterpolatedString.Perl6 13 | 14 | import Control.Concurrent 15 | 16 | import System.Exit 17 | import System.IO 18 | import System.Process 19 | import System.Directory 20 | 21 | 22 | import Forml.CLI 23 | import Forml.Static 24 | 25 | test :: RunConfig -> String -> String -> String -> IO () 26 | test rc @ RunConfig { run_tests = Node } js title tests = 27 | let runner = if silent rc then run_silent else monitor in 28 | 29 | runner [qq|Testing {title}.js [Node.js]|] $ 30 | do (Just std_in, Just std_out, _, p) <- 31 | createProcess (proc "node" []) { std_in = CreatePipe, std_out = CreatePipe } 32 | 33 | forkIO $ do errors <- hGetContents std_out 34 | putStr errors 35 | hFlush stdout 36 | 37 | hPutStrLn std_in$ jasmine 38 | hPutStrLn std_in$ js ++ "\n\n" 39 | hPutStrLn std_in$ tests 40 | hPutStrLn std_in$ console 41 | 42 | z <- waitForProcess p 43 | 44 | case z of 45 | ExitFailure _ -> return$ Left [] 46 | ExitSuccess -> return$ Right () 47 | 48 | test rc @ RunConfig { run_tests = Phantom } js title tests = 49 | let runner = if silent rc then run_silent else monitor in 50 | 51 | runner [qq|Testing {title}.js [Phantom.js]|] $ 52 | do writeFile (output rc ++ ".phantom.js") 53 | (jquery ++ jasmine ++ js ++ tests ++ console) 54 | 55 | (Just std_in, Just std_out, _, p) <- 56 | createProcess (proc "phantomjs" [output rc ++ ".phantom.js"]) { std_in = CreatePipe, std_out = CreatePipe } 57 | 58 | forkIO $ do errors <- hGetContents std_out 59 | putStr errors 60 | hFlush stdout 61 | 62 | z <- waitForProcess p 63 | 64 | removeFile $ output rc ++ ".phantom.js" 65 | 66 | case z of 67 | ExitFailure _ -> return$ Left [] 68 | ExitSuccess -> return$ Right () 69 | 70 | test rc _ _ _ = if silent rc then do return () else warn "Testing" () 71 | -------------------------------------------------------------------------------- /src/hs/lib/Forml/Javascript/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | {-# LANGUAGE OverlappingInstances #-} 9 | 10 | {-# LANGUAGE ViewPatterns #-} 11 | {-# LANGUAGE NamedFieldPuns #-} 12 | {-# LANGUAGE RecordWildCards #-} 13 | 14 | module Forml.Javascript.Utils where 15 | 16 | 17 | import Text.InterpolatedString.Perl6 18 | import Language.Javascript.JMacro 19 | import Data.Monoid 20 | import Data.String.Utils 21 | 22 | import Prelude hiding (curry, (++), error) 23 | 24 | 25 | prelude :: String 26 | prelude = show $ renderJs 27 | [jmacro| function !is_array(x) { 28 | return `(InfixExpr "instanceof" x (ref "Array"))`; 29 | } 30 | 31 | var !__undefined__ = "undefined"; 32 | 33 | function !run(x) { return x(); } 34 | 35 | function !error(x) { throw x; } 36 | 37 | function !exhaust() { error("Pattern Match Exhausted"); } 38 | 39 | function !__check(x, y) { 40 | return x.hasOwnProperty(y); 41 | } |] 42 | 43 | instance (ToStat a) => ToStat [a] where 44 | toStat [] = mempty 45 | toStat x = foldl1 mappend . map toStat $ x 46 | 47 | -------------------------------------------------------------------------------- 48 | ---- 49 | ---- Metadata 50 | 51 | 52 | -------------------------------------------------------------------------------- 53 | ---- 54 | ---- Utilities 55 | 56 | (++) :: Monoid a => a -> a -> a 57 | (++) = mappend 58 | 59 | end :: forall a. [a] -> [a] 60 | end (reverse -> x : xs) = x : reverse xs 61 | end _ = fail "End is not defined for empty lists" 62 | 63 | ref :: String -> JExpr 64 | ref name = ValExpr (JVar (StrI name)) 65 | 66 | func :: String -> JStat -> JStat 67 | func var ex = ReturnStat (ValExpr (JFunc [StrI var] (BlockStat [ex]))) 68 | 69 | declare_this :: forall a. ToJExpr a => [Char] -> a -> JStat 70 | declare_this name expr = 71 | 72 | [jmacro| `(declare (replace " " "_" name) expr)`; 73 | this[`(replace " " "_" name)`] = `(ref (replace " " "_" name))`; |] 74 | 75 | declare_window :: forall a. ToJExpr a => [Char] -> a -> JStat 76 | declare_window name expr = 77 | 78 | [jmacro| `(declare (replace " " "_" name) expr)`; 79 | (typeof global == "undefined" ? window : global)[`((replace " " "_" name))`] = `(ref (replace " " "_" name))`; |] 80 | declare :: forall a. ToJExpr a => [Char] -> a -> JStat 81 | 82 | declare name expr = 83 | [jmacro| `(DeclStat (StrI (replace " " "_" name)) Nothing)`; 84 | `(ref (replace " " "_" name))` = `(expr)`; |] 85 | 86 | declare_scope :: String -> JExpr -> JStat -> JStat 87 | declare_scope name expr stat = 88 | 89 | BlockStat [ReturnStat (ApplExpr (ValExpr (JFunc [StrI name] stat)) [expr])] 90 | 91 | curry :: Int -> (String -> String) -> JStat -> JStat 92 | curry 0 _ jexpr = jexpr 93 | curry n f jexpr = func (f $ local_pool $ n - 1) (curry (n - 1) f jexpr) 94 | 95 | local_pool :: Int -> String 96 | local_pool n = [qq|__{ "abcdefghijklmnopqrstuvqxyz" !! n }__|] 97 | 98 | scope :: forall a. ToStat a => a -> JExpr 99 | scope x = [jmacroE| (function() { `(x)`; })() |] 100 | -------------------------------------------------------------------------------- /src/hs/lib/Forml/Optimize.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE NamedFieldPuns #-} 8 | {-# LANGUAGE OverlappingInstances #-} 9 | {-# LANGUAGE QuasiQuotes #-} 10 | {-# LANGUAGE RankNTypes #-} 11 | {-# LANGUAGE RecordWildCards #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE TemplateHaskell #-} 14 | {-# LANGUAGE TypeSynonymInstances #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | {-# LANGUAGE ViewPatterns #-} 17 | {-# LANGUAGE DeriveGeneric #-} 18 | 19 | module Forml.Optimize where 20 | import System.IO.Unsafe () 21 | 22 | import Control.Applicative 23 | import Control.Monad 24 | 25 | import qualified Data.Map as M 26 | import qualified Data.List as L 27 | 28 | import Data.Monoid 29 | 30 | import Forml.Types.Axiom 31 | import Forml.Types.Definition 32 | import Forml.Types.Expression 33 | import Forml.Types.Namespace hiding (Module) 34 | import Forml.Types.Pattern 35 | import Forml.Types.Statement hiding (Test, find, modules, namespace) 36 | import Forml.Types.Symbol 37 | import Forml.Deps 38 | 39 | import Forml.Parser 40 | import Forml.Parser.Utils 41 | 42 | import Forml.Optimize.TailCall 43 | import Forml.Optimize.Inline 44 | import Forml.Optimize.Optimizer 45 | 46 | import Prelude hiding (curry) 47 | import Text.Parsec.Pos (newPos) 48 | 49 | instance Optimize (Expression Definition) where 50 | 51 | optimize (ApplyExpression (ApplyExpression a b) c) = 52 | optimize (ApplyExpression a (b ++ c)) 53 | 54 | optimize (ApplyExpression (SymbolExpression s) args) = do 55 | is <- get_env 56 | case (InlineSymbol s) `lookup` is of 57 | Just ((Match pss z), ex) 58 | | length pss == length args -> do 59 | args' <- mapM optimize args 60 | optimize $ inline_apply pss args args' ex 61 | | length pss > length args -> do 62 | args' <- mapM optimize args 63 | optimize (FunctionExpression 64 | [ EqualityAxiom 65 | (Match (drop (length args) pss) z) 66 | (Addr undefined undefined (inline_apply (take (length args) pss) args args' ex)) ]) 67 | 68 | _ -> ApplyExpression <$> optimize (SymbolExpression s) <*> mapM optimize args 69 | 70 | optimize (ApplyExpression f' args ) = 71 | ApplyExpression <$> optimize f' <*> mapM optimize args 72 | 73 | optimize a @ (AccessorExpression x xs) = 74 | 75 | do is <- get_env 76 | case (InlineRecord a) `lookup` is of 77 | Just (m @ (Match pss _), ex) -> 78 | 79 | do ex' <- optimize ex 80 | m' <- optimize m 81 | return $ FunctionExpression [EqualityAxiom m' (Addr undefined undefined ex')] 82 | 83 | _ -> flip AccessorExpression xs <$> optimize x 84 | 85 | optimize (SymbolExpression f) = 86 | 87 | do is <- get_env 88 | case (InlineSymbol f) `lookup` is of 89 | Just (m @ (Match pss _), ex) -> 90 | 91 | do ex' <- optimize ex 92 | m' <- optimize m 93 | return $ FunctionExpression [EqualityAxiom m' (Addr undefined undefined ex')] 94 | 95 | _ -> return $ SymbolExpression f 96 | 97 | optimize (ApplyExpression f args) = ApplyExpression <$> optimize f <*> mapM optimize args 98 | optimize (IfExpression a b c) = IfExpression <$> optimize a <*> optimize b <*> optimize c 99 | optimize (LazyExpression x l) = flip LazyExpression l <$> optimize x 100 | optimize (FunctionExpression xs) = FunctionExpression <$> mapM optimize xs 101 | optimize (ListExpression ex) = ListExpression <$> mapM optimize ex 102 | 103 | optimize (LetExpression ds ex) = do 104 | 105 | stmts' <- mapM optimize (sorted_defs . map DefinitionStatement $ ds) 106 | let stmts = map (\(DefinitionStatement d) -> d) stmts' 107 | LetExpression (filter is_inline stmts) <$> optimize ex 108 | 109 | where 110 | 111 | is_inline (Definition _ True _ _) = False 112 | is_inline _ = True 113 | 114 | optimize (RecordExpression (M.toList -> xs)) = 115 | 116 | let (keys, vals) = unzip xs 117 | in RecordExpression . M.fromList . zip keys <$> mapM optimize vals 118 | 119 | optimize (JSExpression x) = return $ JSExpression x 120 | optimize (LiteralExpression x) = return $ LiteralExpression x 121 | 122 | 123 | -- TODO wrong 124 | instance Optimize (Match (Expression Definition)) where 125 | 126 | optimize (Match ms (Just ex)) = Match ms . Just <$> optimize ex 127 | optimize x = return x 128 | 129 | instance Optimize (Axiom (Expression Definition)) where 130 | 131 | optimize t @ (TypeAxiom _) = return t 132 | optimize (EqualityAxiom m ex) = 133 | 134 | do m' <- optimize m 135 | ex' <- optimize ex 136 | return (EqualityAxiom m' ex') 137 | 138 | instance Optimize Definition where 139 | 140 | optimize (Definition a True name [eq @ (EqualityAxiom m ex)]) = 141 | 142 | do eq <- optimize eq 143 | is <- get_inline 144 | e <- get_env 145 | ns <- get_namespace 146 | set_inline (((ns, (InlineSymbol name)), (m, get_addr ex)) : is) 147 | set_env ((InlineSymbol name, (m, get_addr ex)) : e) 148 | return (Definition a True name [eq]) 149 | 150 | optimize (Definition a True c (TypeAxiom _ : x)) = optimize (Definition a True c x) 151 | optimize (Definition _ True name _) = fail$ "Illegal inline definition '" ++ show name ++ "'" 152 | 153 | optimize (Definition a b name xs) | is_recursive name xs = 154 | 155 | do xs' <- mapM optimize xs 156 | add_tco $ show name 157 | return $ Definition a b name (tail_call_optimize name xs') 158 | 159 | optimize (Definition a b c xs) = Definition a b c <$> mapM optimize xs 160 | 161 | instance Optimize Statement where 162 | 163 | optimize (DefinitionStatement d) = DefinitionStatement <$> optimize d 164 | optimize (ExpressionStatement (Addr s e x)) = ExpressionStatement . Addr s e <$> optimize x 165 | optimize (ModuleStatement x xs) = do 166 | ns <- get_namespace 167 | set_namespace$ ns `mappend` x 168 | xs' <- with_env$ optimize xs 169 | set_namespace ns 170 | return$ ModuleStatement x xs' 171 | 172 | where 173 | get_defs [] = [] 174 | get_defs (DefinitionStatement d : xs) = [d] : get_defs xs 175 | get_defs (_ : xs) = get_defs xs 176 | 177 | optimize ss @ (ImportStatement (Namespace x) (Just alias)) = do 178 | is <- get_inline 179 | e <- get_env 180 | n <- get_namespace 181 | rfind n is e 182 | 183 | where rfind (Namespace n) is e = 184 | 185 | case lookup' (Namespace x) is of 186 | 187 | [] -> 188 | 189 | if length n > 0 && head n /= head x 190 | then do optimize (ImportStatement (Namespace (head n : x)) Nothing) 191 | return ss 192 | else return ss 193 | 194 | zs -> 195 | 196 | do set_env $ cc zs ++ e 197 | return ss 198 | 199 | cc (((_, s), ex): zs) = (s, ex) : cc zs 200 | cc [] = [] 201 | 202 | lookup' x (((y, (InlineSymbol z)), w):ys) 203 | | x == y = (((y, (InlineRecord (AccessorExpression (Addr (newPos "Optimizer" 0 0) (newPos "Optimizer" 0 0) (SymbolExpression (Symbol alias))) [z]))), w) : lookup' x ys) 204 | | otherwise = lookup' x ys 205 | lookup' _ [] = [] 206 | 207 | 208 | optimize ss @ (ImportStatement (Namespace x) Nothing) = 209 | 210 | do is <- get_inline 211 | e <- get_env 212 | n <- get_namespace 213 | rfind n is e 214 | 215 | where rfind (Namespace n) is e = 216 | 217 | case lookup' (Namespace x) is of 218 | 219 | [] -> 220 | 221 | if length n > 0 && head n /= head x 222 | then do optimize (ImportStatement (Namespace (head n : x)) Nothing) 223 | return ss 224 | else return ss 225 | 226 | zs -> 227 | 228 | do set_env $ cc zs ++ e 229 | return ss 230 | 231 | cc (((_, s), ex): zs) = (s, ex) : cc zs 232 | cc [] = [] 233 | 234 | lookup' x (((y, z), w):ys) 235 | | x == y = (((y, z), w) : lookup' x ys) 236 | | otherwise = lookup' x ys 237 | lookup' _ [] = [] 238 | 239 | optimize x = return x 240 | 241 | instance Optimize [Statement] where 242 | 243 | optimize xs = do 244 | let (tests, defs) = L.partition is_expression xs 245 | xs <- mapM optimize (sorted_defs defs) 246 | ys <- mapM optimize tests 247 | return (xs ++ ys) 248 | 249 | where 250 | is_expression (ExpressionStatement _) = True 251 | is_expression _ = False 252 | 253 | instance Optimize Program where 254 | 255 | optimize (Program xs) = Program <$> optimize xs 256 | -------------------------------------------------------------------------------- /src/hs/lib/Forml/Optimize/Inline.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE NamedFieldPuns #-} 9 | {-# LANGUAGE OverlappingInstances #-} 10 | {-# LANGUAGE QuasiQuotes #-} 11 | {-# LANGUAGE RankNTypes #-} 12 | {-# LANGUAGE RecordWildCards #-} 13 | {-# LANGUAGE ScopedTypeVariables #-} 14 | {-# LANGUAGE TemplateHaskell #-} 15 | {-# LANGUAGE TypeSynonymInstances #-} 16 | {-# LANGUAGE UndecidableInstances #-} 17 | 18 | module Forml.Optimize.Inline (inline_apply, Inlines, Inline, Inlineable(..)) where 19 | import System.IO.Unsafe () 20 | import Prelude hiding (curry) 21 | import GHC.Generics 22 | 23 | import qualified Data.Map as M 24 | import Data.Serialize 25 | 26 | import Language.Javascript.JMacro 27 | 28 | import Forml.Parser.Utils 29 | import Forml.Types.Axiom 30 | import Forml.Types.Definition 31 | import Forml.Types.Expression 32 | import Forml.Types.Namespace hiding (Module) 33 | import Forml.Types.Pattern 34 | import Forml.Types.Symbol 35 | 36 | data Inlineable = InlineSymbol Symbol | InlineRecord (Expression Definition) deriving (Eq, Generic, Show) 37 | 38 | type Inlines = [((Namespace, Inlineable), (Match (Expression Definition), Expression Definition))] 39 | type Inline = [(Inlineable, (Match (Expression Definition), Expression Definition))] 40 | 41 | instance Serialize Inlineable 42 | 43 | afmap :: 44 | [(String, Expression Definition)] -> 45 | (Symbol -> Expression Definition) -> 46 | Axiom (Expression Definition) -> 47 | Axiom (Expression Definition) 48 | 49 | afmap d f (EqualityAxiom (Match pss cond) expr) = 50 | EqualityAxiom (Match pss (fmap (replace_expr d f) cond)) (fmap (replace_expr d f) expr) 51 | 52 | afmap _ _ t = t 53 | 54 | dfmap d f (Definition a b c as) = 55 | Definition a b c (fmap (afmap d f) as) 56 | 57 | replace_expr d f (ApplyExpression a b) = 58 | ApplyExpression (replace_expr d f a) (replace_expr d f `map` b) 59 | replace_expr d f (IfExpression a b Nothing) = 60 | IfExpression (replace_expr d f a) (replace_expr d f b) Nothing 61 | replace_expr d f (IfExpression a b (Just c)) = 62 | IfExpression (replace_expr d f a) (replace_expr d f b) (Just (replace_expr d f c)) 63 | replace_expr d f (LiteralExpression x) = 64 | LiteralExpression x 65 | replace_expr d f (JSExpression j) = 66 | JSExpression (replace_jexpr d j) 67 | replace_expr d f (LazyExpression a b) = 68 | LazyExpression (fmap (replace_expr d f) a) b 69 | replace_expr d f (FunctionExpression as) = 70 | FunctionExpression (map (afmap d f) as) 71 | replace_expr d f (RecordExpression vs) = 72 | RecordExpression (fmap (replace_expr d f) vs) 73 | replace_expr d f (LetExpression ds e) = 74 | LetExpression (dfmap d f `map` ds) (replace_expr d f e) 75 | replace_expr d f (ListExpression xs) = 76 | ListExpression (map (replace_expr d f) xs) 77 | replace_expr d f (AccessorExpression a ss) = 78 | AccessorExpression (fmap (replace_expr d f) a) ss 79 | replace_expr d f (SymbolExpression (Symbol s)) = f (Symbol s) 80 | replace_expr d f (SymbolExpression s) = SymbolExpression s 81 | 82 | replace_expr _ _ s = s 83 | 84 | 85 | 86 | replace_stat dict (ReturnStat x) = ReturnStat (replace_jexpr dict x) 87 | replace_stat dict (IfStat a b c) = IfStat (replace_jexpr dict a) (replace_stat dict b) (replace_stat dict c) 88 | replace_stat dict (WhileStat a b c) = WhileStat a (replace_jexpr dict b) (replace_stat dict c) 89 | replace_stat dict (ForInStat a b c d) = ForInStat a b (replace_jexpr dict c) (replace_stat dict d) 90 | replace_stat dict (SwitchStat a b c) = SwitchStat (replace_jexpr dict a) b (replace_stat dict c) 91 | replace_stat dict (TryStat a b c d) = TryStat (replace_stat dict a) b (replace_stat dict c) (replace_stat dict d) 92 | replace_stat dict (BlockStat xs) = BlockStat (replace_stat dict `map` xs) 93 | replace_stat dict (ApplStat a b) = ApplStat (replace_jexpr dict a) (replace_jexpr dict `map` b) 94 | replace_stat dict (PPostStat a b c) = PPostStat a b (replace_jexpr dict c) 95 | replace_stat dict (AssignStat a b) = AssignStat (replace_jexpr dict a) (replace_jexpr dict b) 96 | replace_stat dict (UnsatBlock a) = UnsatBlock (replace_stat dict `fmap` a) 97 | 98 | replace_stat dict (DeclStat v t) = DeclStat v t 99 | replace_stat dict (UnsatBlock ident_supply) = UnsatBlock (replace_stat dict `fmap` ident_supply) 100 | replace_stat dict (AntiStat s) = AntiStat s 101 | replace_stat dict (ForeignStat s t) = ForeignStat s t 102 | replace_stat dict (BreakStat s) = (BreakStat s) 103 | 104 | replace_jval dict (JList xs) = JList (replace_jexpr dict `map` xs) 105 | replace_jval dict (JHash m) = JHash (M.map (replace_jexpr dict) m) 106 | replace_jval dict (JFunc xs x) = JFunc xs (replace_stat dict x) 107 | replace_jval dict (UnsatVal x) = UnsatVal (replace_jval dict `fmap` x) 108 | replace_jval dict x@(JDouble _) = x 109 | replace_jval dict x@(JInt _) = x 110 | replace_jval dict x@(JStr _) = x 111 | replace_jval dict x@(JRegEx _) = x 112 | replace_jval dict (JVar (StrI y)) = 113 | case y `lookup` dict of 114 | Just y' -> JVar . StrI . show . jsToDoc . toJExpr $ y' 115 | Nothing -> JVar (StrI y) 116 | replace_jval _ (JVar x) = JVar x 117 | 118 | 119 | replace_jexpr dict (SelExpr e (StrI i)) = IdxExpr (replace_jexpr dict e) (ValExpr (JStr i)) -- Closure fix - advanced mode nukes these 120 | replace_jexpr dict (IdxExpr a b) = IdxExpr (replace_jexpr dict a) (replace_jexpr dict b) 121 | replace_jexpr dict (InfixExpr a b c) = InfixExpr a (replace_jexpr dict b) (replace_jexpr dict c) 122 | replace_jexpr dict (PPostExpr a b c) = PPostExpr a b (replace_jexpr dict c) 123 | replace_jexpr dict (IfExpr a b c) = IfExpr (replace_jexpr dict a) (replace_jexpr dict b) (replace_jexpr dict c) 124 | replace_jexpr dict (NewExpr a) = NewExpr (replace_jexpr dict a) 125 | replace_jexpr dict (ApplExpr a b) = ApplExpr (replace_jexpr dict a) (replace_jexpr dict `map` b) 126 | replace_jexpr dict (TypeExpr a b c) = TypeExpr a (replace_jexpr dict b) c 127 | replace_jexpr dict (ValExpr a) = ValExpr (replace_jval dict a) 128 | replace_jexpr dict (UnsatExpr a) = UnsatExpr (replace_jexpr dict `fmap` a) 129 | 130 | inline_apply :: 131 | [Pattern t] -> -- Function being inlined's patterns 132 | [Expression Definition] -> -- Arguments to this function 133 | [Expression Definition] -> -- Optimized arguments to this functions 134 | Expression Definition -> -- Expression of the funciton being inline 135 | Expression Definition -- Resulting inlined expression 136 | 137 | inline_apply pss args opt_args ex = do 138 | 139 | replace_expr (concat $ zipWith gen_expr pss opt_args) (gen_exprs args pss) ex 140 | 141 | where 142 | gen_exprs args' pats (Symbol s) = 143 | case s `lookup` (concat $ zipWith gen_expr pats args') of 144 | Just ex -> ex 145 | Nothing -> (SymbolExpression (Symbol s)) 146 | 147 | gen_exprs _ _ s = SymbolExpression s 148 | 149 | gen_expr (VarPattern x) y = 150 | [(x, y)] 151 | gen_expr (RecordPattern xs _) y = 152 | concat $ zipWith gen_expr (M.elems xs) (map (to_accessor y) $ M.keys xs) 153 | gen_expr (ListPattern xs) y = 154 | concat $ zipWith gen_expr xs (map (to_array y) [0..]) 155 | gen_expr (AliasPattern xs) y = 156 | concatMap (flip gen_expr y) xs 157 | gen_expr _ _ = 158 | [] 159 | 160 | to_array expr idx = 161 | JSExpression [jmacroE| `(expr)`[idx] |] 162 | 163 | to_accessor expr sym = 164 | AccessorExpression (Addr undefined undefined expr) [sym] -------------------------------------------------------------------------------- /src/hs/lib/Forml/Optimize/Optimizer.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE NamedFieldPuns #-} 8 | {-# LANGUAGE OverlappingInstances #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE TypeSynonymInstances #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | {-# LANGUAGE ViewPatterns #-} 14 | 15 | module Forml.Optimize.Optimizer where 16 | import System.IO.Unsafe () 17 | 18 | import Control.Applicative 19 | import Control.Monad 20 | 21 | import Data.Serialize 22 | 23 | import Forml.Optimize.Inline 24 | import Forml.Parser.Utils 25 | import Forml.TypeCheck.Types hiding (get_namespace) 26 | import Forml.Types.Namespace hiding (Module) 27 | 28 | import Prelude hiding (curry) 29 | 30 | import GHC.Generics 31 | 32 | data OptimizeState = OptimizeState { ns :: Namespace 33 | , assumptions :: [(Namespace, [Assumption])] 34 | , inlines :: Inlines 35 | , tco :: [String] 36 | , env :: Inline } deriving (Eq, Generic, Show) 37 | 38 | data Optimizer a = Optimizer (OptimizeState -> (OptimizeState, a)) 39 | 40 | instance Serialize OptimizeState 41 | 42 | instance Monad Optimizer where 43 | 44 | fail x = Optimizer (\_ -> error x) 45 | return x = Optimizer (\y -> (y, x)) 46 | 47 | Optimizer f >>= g = 48 | Optimizer (\x -> case f x of (y, x) -> let Optimizer gx = g x in gx y) 49 | 50 | instance Functor Optimizer where 51 | 52 | fmap f (Optimizer g) = Optimizer (\x -> case g x of (y, x) -> (y, f x)) 53 | 54 | instance Applicative Optimizer where 55 | 56 | pure = return 57 | x <*> y = x >>= flip fmap y 58 | 59 | class Optimize a where 60 | 61 | optimize :: a -> Optimizer a 62 | 63 | set_namespace :: Namespace -> Optimizer () 64 | set_namespace ns' = Optimizer (\x -> (x { ns = ns' }, ())) 65 | 66 | get_namespace :: Optimizer Namespace 67 | get_namespace = Optimizer (\x -> (x, ns x)) 68 | 69 | set_inline :: Inlines -> Optimizer () 70 | set_inline ns' = Optimizer (\x -> (x { inlines = ns' }, ())) 71 | 72 | get_inline :: Optimizer Inlines 73 | get_inline = Optimizer (\x -> (x, inlines x)) 74 | 75 | set_env :: Inline -> Optimizer () 76 | set_env ns' = Optimizer (\x -> (x { env = ns' }, ())) 77 | 78 | get_env :: Optimizer Inline 79 | get_env = Optimizer (\x -> (x, env x)) 80 | 81 | add_tco :: String -> Optimizer () 82 | add_tco x = Optimizer (\y -> (y { tco = x : tco y }, ())) 83 | 84 | with_env :: forall b. Optimizer b -> Optimizer b 85 | with_env xs = do 86 | e <- get_env 87 | xs' <- xs 88 | set_env e 89 | return xs' 90 | 91 | gen_state as = OptimizeState (Namespace []) as [] [] [] 92 | 93 | run_optimizer :: (Optimize a) => a -> OptimizeState -> (OptimizeState, a) 94 | run_optimizer p @ (optimize -> Optimizer f) as = f as 95 | 96 | 97 | instance (Optimize a) => Optimize (Maybe a) where 98 | 99 | optimize (Just x) = Just <$> optimize x 100 | optimize Nothing = return Nothing 101 | 102 | instance (Optimize a) => Optimize (Addr a) where 103 | 104 | optimize (Addr s e a) = Addr s e <$> optimize a 105 | 106 | 107 | 108 | -------------------------------------------------------------------------------- /src/hs/lib/Forml/Optimize/TailCall.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE NamedFieldPuns #-} 8 | {-# LANGUAGE OverlappingInstances #-} 9 | {-# LANGUAGE QuasiQuotes #-} 10 | {-# LANGUAGE RankNTypes #-} 11 | {-# LANGUAGE RecordWildCards #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE TemplateHaskell #-} 14 | {-# LANGUAGE TypeSynonymInstances #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | {-# LANGUAGE ViewPatterns #-} 17 | {-# LANGUAGE DeriveGeneric #-} 18 | 19 | module Forml.Optimize.TailCall where 20 | import System.IO.Unsafe () 21 | 22 | import Control.Monad 23 | 24 | import qualified Data.Map as M 25 | 26 | import Data.Monoid 27 | 28 | import Language.Javascript.JMacro 29 | 30 | import Forml.Types.Symbol 31 | import Forml.Types.Axiom 32 | import Forml.Types.Expression 33 | import Forml.Types.Definition 34 | import Forml.Types.Pattern 35 | import Forml.Parser.Utils 36 | import qualified Forml.Javascript.Utils as J 37 | 38 | import Prelude hiding (curry) 39 | 40 | get_addr :: Addr a -> a 41 | get_addr (Addr _ _ x) = x 42 | 43 | is_recursive name (TypeAxiom _: xs') = is_recursive name xs' 44 | is_recursive name (EqualityAxiom _ x: xs') = is_recursive' name (get_addr x) || is_recursive name xs' 45 | is_recursive name [] = False 46 | 47 | is_recursive' name (ApplyExpression (SymbolExpression x) _) | name == x = True 48 | is_recursive' name (LetExpression _ e) = is_recursive' name e 49 | is_recursive' name (IfExpression _ a (Just b)) = is_recursive' name a || is_recursive' name b 50 | is_recursive' name (IfExpression _ a _) = is_recursive' name a 51 | is_recursive' name _ = False 52 | 53 | 54 | tail_call_optimize :: 55 | Symbol -> [Axiom (Expression Definition)] -> [Axiom (Expression Definition)] 56 | 57 | tail_call_optimize name (t @ (TypeAxiom _): xs) = 58 | t : tail_call_optimize name xs 59 | 60 | tail_call_optimize name xs' = 61 | [EqualityAxiom (Match [] Nothing) (Addr undefined undefined (JSExpression (to_trampoline xs')))] 62 | 63 | where 64 | to_trampoline xs @ (EqualityAxiom (Match ps _) _ : _) = 65 | opt . J.scope . J.curry (length ps) ("_V"++) . to_trampoline' ps $ xs 66 | 67 | to_trampoline' ps xs = 68 | 69 | [jmacro| var __result = undefined; 70 | `(def_local (reverse . take (length ps) . map J.local_pool $ [0 .. 26]) local_var_names)`; 71 | while (typeof __result == "undefined") { 72 | `(to_trampoline'' xs __result)`; 73 | 74 | } 75 | return __result; |] 76 | 77 | where to_trampoline'' [] _ = [jmacro| exhaust(); |] 78 | to_trampoline'' (EqualityAxiom (Match pss cond) (Addr _ _ ex) : xss) result = 79 | 80 | [jmacro| `(declare_bindings var_names pss)`; 81 | if (`(pss)` && `(cond)`) { 82 | `(result)` = `(replace pss ex)`; 83 | } else `(to_trampoline'' xss result)`; |] 84 | 85 | var_names = map J.ref . reverse . take (length ps) . map J.local_pool $ [0 .. 26] 86 | 87 | local_var_names = map J.ref . map ("_V"++) . reverse . take (length ps) . map J.local_pool $ [0 .. 26] 88 | 89 | declare_bindings (name : names) (VarPattern x : zs) = 90 | 91 | [jmacro| `(J.declare x name)`; |] `mappend` declare_bindings names zs 92 | 93 | declare_bindings (name : names) (RecordPattern x _: zs) = 94 | let (ns, z) = unzip . M.toList $ x 95 | in declare_bindings (map (acc name) ns) z `mappend` declare_bindings names zs 96 | 97 | declare_bindings (_ : names) (_ : zs) = declare_bindings names zs 98 | declare_bindings _ _ = mempty 99 | 100 | acc n ns = [jmacroE| `(n)`[`(ns)`] |] 101 | 102 | replace _ (ApplyExpression (SymbolExpression x) args) | name == x = 103 | 104 | JSExpression [jmacroE| (function() { 105 | `(bind_local (reverse . take (length ps) . map J.local_pool $ [0 .. 26]) args)`; 106 | return undefined; 107 | })() |] 108 | 109 | replace pss (LetExpression x e) = LetExpression x (replace pss e) 110 | replace pss (IfExpression x a b) = IfExpression x (replace pss a) (replace pss `fmap` b) 111 | replace _ x = x 112 | 113 | bind_local :: ToJExpr a => [String] -> [a] -> JStat 114 | bind_local (x:xs) (y:ys) = [jmacro| `(J.ref x)` = `(y)`; |] `mappend` bind_local xs ys 115 | bind_local _ _ = mempty 116 | 117 | def_local :: [String] -> [JExpr] -> JStat 118 | def_local (x:xs) (y:ys) = [jmacro| `(J.declare x y)`; |] `mappend` def_local xs ys 119 | def_local _ _ = mempty 120 | -------------------------------------------------------------------------------- /src/hs/lib/Forml/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE OverlappingInstances #-} 4 | {-# LANGUAGE QuasiQuotes #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | {-# LANGUAGE DeriveGeneric #-} 9 | 10 | module Forml.Parser where 11 | 12 | import Control.Applicative 13 | import Data.String.Utils 14 | import qualified Data.Serialize as S 15 | import GHC.Generics 16 | import Forml.Parser.Utils hiding (spaces) 17 | import Text.Parsec hiding (State, label, many, parse, (<|>)) 18 | 19 | import Forml.Types.Statement 20 | 21 | -- Parsing 22 | -- ----------------------------------------------------------------------------- 23 | -- A Forml program is represented by a set of statements 24 | 25 | parseForml :: String -> String -> Either ParseError Program 26 | parseForml name src = case parse ((comment <|> return "\n") `manyTill` eof) "Cleaning comments" src of 27 | Right x -> parse syntax name (concat x) 28 | Left y -> error $ show y 29 | 30 | 31 | compress :: String -> String 32 | compress = run var 33 | 34 | where run x src' = case parse ((try x <|> ((:[]) <$> anyChar)) `manyTill` eof) "Compressing" src' of 35 | Right z -> concat z 36 | Left z -> error $ show z 37 | 38 | var = do string "var" 39 | spaces 40 | name <- many1 (alphaNum <|> char '_') 41 | string ";" 42 | spaces 43 | string name 44 | return $ "var " ++ name 45 | 46 | get_tests :: [Statement] -> [(SourcePos, SourcePos)] 47 | get_tests [] = [] 48 | get_tests (ExpressionStatement (Addr x y _): xs) = (x,y) : get_tests xs 49 | get_tests (ModuleStatement _ x: xs) = get_tests x ++ get_tests xs 50 | get_tests (_: xs) = get_tests xs 51 | 52 | annotate_tests :: String -> Program -> String 53 | annotate_tests zz (Program xs) = annotate_tests' zz (get_tests xs) 54 | where annotate_tests' x [] = x 55 | annotate_tests' x' ((a, b):ys) = 56 | annotate_tests' marked ys 57 | where marked = mark (mark x' (serial a b ++ "--") row' col') ("--" ++ serial a b) row col 58 | 59 | mark str tk x y = 60 | let str' = lines str 61 | in unlines $ take x str' 62 | ++ [take y (str' !! x) ++ tk ++ drop y (str' !! x)] 63 | ++ drop (x + 1) str' 64 | 65 | row = sourceLine a - 1 66 | col = sourceColumn a - 1 67 | 68 | row' = sourceLine b - 1 69 | col' = sourceColumn b +1 70 | 71 | 72 | highlight :: [(SourcePos, SourcePos)] -> String -> String 73 | highlight [] x = x 74 | highlight ((a, b):xs) y = highlight xs (replace ("--" ++ serial a b) ("") (replace (serial a b ++ "--") "" y)) 75 | 76 | 77 | newtype Program = Program [Statement] deriving (Generic) 78 | 79 | instance S.Serialize Program 80 | 81 | instance Show Program where 82 | show (Program ss) = sep_with "\n\n" ss 83 | 84 | instance Syntax Program where 85 | syntax = Program <$> many (many (string "\n") >> syntax) <* eof 86 | -------------------------------------------------------------------------------- /src/hs/lib/Forml/Parser/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE QuasiQuotes #-} 8 | {-# LANGUAGE OverlappingInstances #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} 11 | {-# OPTIONS_GHC -fno-warn-orphans #-} 12 | {-# LANGUAGE TypeSynonymInstances #-} 13 | {-# LANGUAGE DeriveGeneric #-} 14 | {-# LANGUAGE StandaloneDeriving #-} 15 | 16 | 17 | 18 | module Forml.Parser.Utils where 19 | 20 | import Control.Applicative 21 | import Control.Monad.Identity 22 | import Control.Monad.State hiding (lift) 23 | 24 | import Text.Parsec hiding ((<|>), State, many, spaces, parse, label) 25 | import Text.Parsec.Pos 26 | import qualified Text.Parsec as P 27 | import Text.Parsec.Indent hiding (same) 28 | 29 | import qualified Data.Map as M 30 | import qualified Data.List as L 31 | 32 | import Data.String.Utils 33 | import qualified Data.Serialize as S 34 | 35 | import GHC.Generics 36 | 37 | import qualified Data.Text as T 38 | import System.IO.Unsafe (unsafePerformIO) 39 | 40 | 41 | 42 | 43 | data Addr a = Addr SourcePos SourcePos a deriving (Eq, Generic) 44 | 45 | instance (S.Serialize a) => S.Serialize (Addr a) 46 | instance S.Serialize SourcePos where 47 | 48 | get = return $ newPos "Serialized Optimization" 0 0 49 | put _ = return () 50 | 51 | 52 | instance Functor Addr where 53 | 54 | fmap f (Addr s e a) = Addr s e $ f a 55 | 56 | addr :: Parser a -> Parser (Addr a) 57 | addr p = do x <- getPosition 58 | y <- p 59 | z <- getPosition 60 | return$ Addr x z y 61 | 62 | 63 | instance (Show a) => Show (Addr a) where 64 | show (Addr _ _ x) = show x 65 | 66 | instance (Monad m) => Stream T.Text m Char where 67 | uncons = return . T.uncons 68 | 69 | type Parser a = ParsecT T.Text () (StateT SourcePos Identity) a 70 | 71 | class Syntax a where 72 | syntax :: Parser a 73 | 74 | instance Syntax Double where 75 | syntax = read <$> do x <- many1 digit 76 | string "." 77 | y <- many1 digit 78 | return $ x ++ "." ++ y 79 | 80 | instance Syntax Int where 81 | syntax = read <$> many1 digit 82 | 83 | instance Syntax String where 84 | syntax = do char '"' 85 | (escaped_char <|> anyChar) `manyTill` char '"' 86 | 87 | where escaped_char = do char '\\' 88 | x <- oneOf "tnr\\" 89 | case x of 90 | 'r' -> return '\r' 91 | 'n' -> return '\n' 92 | 't' -> return '\t' 93 | '\\' -> return '\\' 94 | _ -> error "Unimplemented" 95 | 96 | 97 | parse :: Parser a -> SourceName -> String -> Either ParseError a 98 | parse parser sname input = runIndent sname $ runParserT parser () sname (T.pack input) 99 | 100 | whitespace :: Parser String 101 | whitespace = many $ oneOf "\t " 102 | 103 | whitespace1 :: Parser String 104 | whitespace1 = space >> whitespace 105 | 106 | same :: Parser () 107 | same = spaces >> do pos <- getPosition 108 | s <- get 109 | if (sourceColumn pos) /= (sourceColumn s) 110 | then parserFail $ "indented to exactly " ++ show (sourceColumn s + 1) 111 | else do put $ setSourceLine s (sourceLine pos) 112 | return () 113 | 114 | set_indentation :: (Int -> Int) -> Parser () 115 | set_indentation f = do s <- get 116 | put$ setSourceColumn s (f (sourceColumn s)) 117 | 118 | spaces :: Parser () 119 | spaces = try emptyline `manyTill` try line_start >> return () 120 | 121 | where emptyline = whitespace >> newline 122 | line_start = whitespace >> notFollowedBy newline >> in_block 123 | 124 | in_block = do pos <- getPosition 125 | s <- get 126 | if (sourceColumn pos) < (sourceColumn s) 127 | then parserFail $ "indented to at least " ++ show (sourceColumn s + 1) 128 | else do put $ setSourceLine s (sourceLine pos) 129 | return () 130 | 131 | 132 | comment :: Parser String 133 | comment = try empty_line <|> try commented_code <|> try code <|> markdown_comment 134 | 135 | where markdown_comment = anyChar `manyTill` newline *> return "\n" 136 | empty_line = whitespace *> newline *> return "\n" 137 | code = (\x y -> x ++ rstrip y ++ "\n") 138 | <$> string " " <*> (anyChar `manyTill` newline) 139 | 140 | commented_code = do 141 | 142 | string " " 143 | x <- noneOf "\n" `manyTill` try (string "--") 144 | anyChar `manyTill` newline 145 | return $ if length (strip x) > 0 146 | then " " ++ rstrip x ++ "\n" 147 | else "\n" 148 | 149 | sep_with :: Show a => String -> [a] -> String 150 | sep_with x = concat . L.intersperse x . fmap show 151 | 152 | unsep_with :: forall a b. (Show a, Show b) => String -> (M.Map b a) -> String 153 | unsep_with z = concat . L.intersperse ", " . fmap (\(x, y) -> concat [show x, z, show y]) . M.toAscList 154 | 155 | (<:>) :: Parser a -> Parser [a] -> Parser [a] 156 | (<:>) x y = (:) <$> x <*> y 157 | 158 | operator_dict :: M.Map Char String 159 | operator_dict = M.fromList [ ('!', "_bang"), 160 | ('@', "_at"), 161 | ('#', "_hash"), 162 | ('$', "$"), 163 | ('%', "_perc"), 164 | ('^', "_exp"), 165 | ('&', "_and"), 166 | ('|', "_or"), 167 | ('<', "_less"), 168 | ('>', "_grea"), 169 | ('?', "_ques"), 170 | ('/', "_forw"), 171 | ('=', "_eq"), 172 | (':', "_col"), 173 | ('\\', "_back"), 174 | ('~', "_tild"), 175 | ('+', "_plus"), 176 | ('-', "_minu"), 177 | ('\'', "_tick"), 178 | ('*', "_star"), 179 | (',', "_comm"), 180 | ('\'', "_apos"), 181 | ('.', "_comp") ] 182 | 183 | operator :: Parser Char 184 | operator = oneOf (fst . unzip . M.toList $ operator_dict) 185 | 186 | not_reserved :: Parser String -> Parser String 187 | not_reserved x = do y <- x 188 | if y `elem` reserved_words 189 | then parserFail "non-reserved word" 190 | else return y 191 | 192 | where reserved_words = [ "if", "then", "else", "let", "when", "with", "and", "or", "do", "do!", "var", 193 | "module", "open", "yield", "lazy", "inline", "in", "is", "isnt", "where", 194 | "|", "\\", "=", ":", ",", "->", "<-" ] 195 | 196 | not_system :: Parser String -> Parser String 197 | not_system x = not_reserved$ do y <- x 198 | if y `elem` reserved_words 199 | then parserFail "non-reserved word" 200 | else return y 201 | 202 | where reserved_words = [ "==", "<=", ">=", "!=", "<", ">", "||", "&&", ".", "," ] 203 | 204 | valid_partial_op :: Parser String -> Parser String 205 | valid_partial_op x = not_reserved$ 206 | 207 | do y <- x 208 | if y `elem` reserved_words 209 | then parserFail "non-reserved word" 210 | else return y 211 | 212 | where reserved_words = [ ".", "," ] 213 | 214 | 215 | type_sep :: Parser Char 216 | indentPairs :: String -> Parser a -> String -> Parser a 217 | not_comma :: Parser () 218 | comma :: Parser () 219 | optional_sep :: ParsecT T.Text () (StateT SourcePos Identity) () 220 | 221 | type_sep = try (spaces *> char '|' <* whitespace) 222 | not_comma = whitespace >> newline >> spaces >> notFollowedBy (string "}") 223 | comma = P.spaces *> string "," *> P.spaces 224 | optional_sep = try (try comma <|> not_comma) 225 | 226 | indentPairs a p b = string a *> P.spaces *> (try p <|> withPosTemp p) <* P.spaces <* string b 227 | 228 | indentAsymmetricPairs :: String -> Parser a -> Parser b -> Parser a 229 | indentAsymmetricPairs a p b = string a *> P.spaces *> withPosTemp p <* P.spaces <* b 230 | 231 | withPosTemp :: Parser a -> Parser a 232 | withPosTemp p = do x <- get 233 | p' <- try (Just <$> withPos p) <|> return Nothing 234 | put x 235 | case p' of 236 | Just p' -> return p' 237 | Nothing -> parserFail ("expression continuation indented to " ++ show x) 238 | 239 | 240 | db :: Show a => a -> a 241 | db x = unsafePerformIO $ do putStrLn$ "-- " ++ (show x) 242 | return x 243 | 244 | -------------------------------------------------------------------------------- /src/hs/lib/Forml/Static.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE OverlappingInstances #-} 4 | {-# LANGUAGE QuasiQuotes #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | {-# LANGUAGE TupleSections #-} 9 | {-# LANGUAGE ViewPatterns #-} 10 | 11 | module Forml.Static where 12 | 13 | import Text.InterpolatedString.Perl6 14 | 15 | import qualified Data.ByteString.UTF8 as B 16 | import qualified Data.ByteString.Lazy as BL 17 | import qualified Data.ByteString as BS 18 | import Data.FileEmbed 19 | import Data.Monoid 20 | 21 | import Control.Arrow 22 | 23 | import qualified Codec.Compression.GZip as G 24 | 25 | 26 | console = "$prelude.$html.console_runner()" 27 | 28 | find key = 29 | maybe (error key) id (lookup key statics) 30 | where 31 | conv = fmap (second B.toString) 32 | statics = 33 | conv $(embedDir "lib") 34 | ++ conv $(embedDir "src/html") 35 | ++ conv $(embedDir "src/css") 36 | ++ conv $(embedDir "src/js") 37 | 38 | 39 | prelude' = BS.concat . BL.toChunks . G.decompress $ BL.fromChunks [$(embedFile "prelude.obj")] 40 | 41 | jquery = find "js/jquery.js" 42 | report = find "FormlReporter.js" 43 | 44 | html_template = find "template.html" 45 | 46 | scripts :: String 47 | scripts = [qq||] 48 | 49 | 50 | jasmine = find "js/jasmine-1.0.1/jasmine.js" 51 | `mappend` find "js/jasmine-1.0.1/jasmine-html.js" 52 | 53 | 54 | prettify = find "js/prettify.js" 55 | `mappend` find "js/lang-hs.js" 56 | 57 | 58 | css = find "css/jasmine.css" 59 | `mappend` find "css/prettify.css" 60 | `mappend` find "styles.css" 61 | 62 | css' :: String 63 | css' = [qq||] 64 | 65 | -------------------------------------------------------------------------------- /src/hs/lib/Forml/TypeCheck.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE KindSignatures #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE NamedFieldPuns #-} 9 | {-# LANGUAGE OverlappingInstances #-} 10 | {-# LANGUAGE QuasiQuotes #-} 11 | {-# LANGUAGE RankNTypes #-} 12 | {-# LANGUAGE RecordWildCards #-} 13 | {-# LANGUAGE ScopedTypeVariables #-} 14 | {-# LANGUAGE TemplateHaskell #-} 15 | {-# LANGUAGE TypeSynonymInstances #-} 16 | {-# LANGUAGE UndecidableInstances #-} 17 | {-# LANGUAGE ViewPatterns #-} 18 | 19 | module Forml.TypeCheck where 20 | 21 | import Data.List (intersect, partition, 22 | union, (\\), reverse) 23 | 24 | import qualified Data.List as L 25 | import qualified Data.Map as M 26 | import qualified Data.Set as S 27 | 28 | import Text.ParserCombinators.Parsec 29 | 30 | import Forml.Types.Axiom 31 | import Forml.Types.Definition 32 | import Forml.Types.Expression 33 | import Forml.Types.Namespace hiding (Module) 34 | import Forml.Types.Pattern 35 | import Forml.Types.Statement hiding (Test, find, modules, 36 | namespace) 37 | import Forml.Types.Symbol 38 | 39 | import Forml.Types.Type 40 | import Forml.Types.TypeDefinition 41 | 42 | import Forml.Parser 43 | import Forml.Parser.Utils 44 | 45 | import Forml.TypeCheck.Types 46 | 47 | import Forml.Deps 48 | 49 | import Data.Graph (graphFromEdges, SCC(..)) 50 | import Data.Graph.SCC (sccList) 51 | 52 | 53 | -- Type Inference 54 | -- -------------------------------------------------------------------------------- 55 | 56 | 57 | instance Infer (Expression Definition) Type where 58 | infer (ApplyExpression _ []) = fail "This should not be" 59 | infer (ApplyExpression e (x:[])) = 60 | 61 | do te <- infer e 62 | tx <- infer x 63 | t <- newTVar Star 64 | unify (tx `fn` t) te 65 | return t 66 | 67 | infer (ApplyExpression e (x:xs)) = infer (ApplyExpression (ApplyExpression e (x:[])) xs) 68 | 69 | infer (IfExpression a b (Just c)) = 70 | 71 | do ta <- infer a 72 | tb <- infer b 73 | tc <- infer c 74 | t <- newTVar Star 75 | unify ta bool_type 76 | unify t tb 77 | unify t tc 78 | return t 79 | 80 | infer (IfExpression a b Nothing) = 81 | 82 | do ta <- infer a 83 | tb <- infer b 84 | t <- newTVar Star 85 | unify ta bool_type 86 | unify t tb 87 | is_js <- t `can_unify` TypeRecord (TRecord M.empty TComplete Star) 88 | if is_js 89 | then t `unify` TypeRecord (TRecord M.empty TComplete Star) 90 | else t `unify` TypeApplication (Type (TypeConst "JS" (KindFunction Star Star))) (TypeRecord (TRecord M.empty TComplete Star)) 91 | return t 92 | 93 | 94 | infer (LiteralExpression s) = infer s 95 | 96 | infer (SymbolExpression i) = 97 | 98 | do sc <- find (show i) 99 | t <- freshInst sc 100 | return t 101 | 102 | infer (JSExpression _) = 103 | 104 | do t <- newTVar Star 105 | return (TypeApplication (Type (TypeConst "JS" (KindFunction Star Star))) t) 106 | 107 | infer (LazyExpression x _) = 108 | 109 | do t <- newTVar Star 110 | t' <- infer x 111 | unify t t' 112 | return (TypeApplication (Type (TypeConst "JS" (KindFunction Star Star))) t) 113 | 114 | 115 | -- TODO this may be removeable at no perf cost? 116 | infer (FunctionExpression rs) = 117 | 118 | do t <- newTVar Star 119 | as <- get_assumptions 120 | [_ :>: q] <- with_scope$ ims as 121 | t' <- freshInst q 122 | unify t t' 123 | return t 124 | 125 | where ims as = 126 | 127 | do infer [Definition Public False (Symbol "") rs] 128 | as'' <- get_assumptions 129 | return$ as'' \\ as 130 | 131 | infer (AccessorExpression (Addr s f x) y) = infer (acc $ reverse y) 132 | 133 | where acc :: [Symbol] -> Expression Definition 134 | acc [] = x 135 | acc (y:ys) = --Addr undefined undefined $ 136 | ApplyExpression 137 | (FunctionExpression 138 | [ EqualityAxiom 139 | (Match [RecordPattern (M.fromList [(y, VarPattern "__x__")]) Partial] Nothing) 140 | (Addr s f (SymbolExpression (Symbol "__x__"))) ] ) 141 | [acc ys] 142 | 143 | infer (RecordExpression (unzip . M.toList -> (names, xs))) = 144 | 145 | do ts <- mapM infer xs 146 | let r = TypeRecord (TRecord (M.fromList (zip (map f names) ts)) TComplete Star) 147 | t' <- newTVar Star 148 | sc <- find $ quantify (tv r) r 149 | case sc of 150 | Nothing -> 151 | do unify t' r 152 | return t' 153 | Just (Forall _ scr, sct) -> 154 | do t'' <- freshInst sct 155 | t''' <- return$ inst (map TypeVar$ tv t'') (scr) 156 | t <- freshInst (quantify (tv t''' \\ tv t'') t''') 157 | unify t r 158 | unify t' t'' 159 | return t' 160 | 161 | where f (Symbol x) = x 162 | f (Operator x) = x 163 | 164 | infer (LetExpression xs x) = 165 | 166 | with_scope$ do mapM_ ((>>= assume) . infer) defs 167 | infer x 168 | 169 | where defs = to_group (map DefinitionStatement xs) 170 | 171 | infer (ListExpression x) = 172 | 173 | do t <- newTVar Star 174 | ts <- mapM infer x 175 | mapM (unify t) ts 176 | t' <- newTVar Star 177 | unify t' (TypeApplication (Type (TypeConst "Array" (KindFunction Star Star))) t) 178 | return t' 179 | 180 | infer x = error $ "Unimplemented: " ++ show x 181 | 182 | -- Axioms 183 | 184 | instance (Infer a t) => Infer (Addr a) t where 185 | 186 | infer (Addr s _ x) = do m <- get_msg 187 | set_msg new_msg 188 | z <- infer x 189 | set_msg m 190 | return z 191 | 192 | where new_msg = " at line " ++ show (sourceLine s) ++ ", column " ++ show (sourceColumn s) ++ "\n" 193 | 194 | instance Infer (Axiom (Expression Definition)) Type where 195 | 196 | infer (EqualityAxiom (Match y z) x) = 197 | 198 | do ts <- mapM infer y 199 | case z of 200 | (Just q) -> infer q >>= (flip unify) bool_type 201 | _ -> return () 202 | t <- infer x 203 | return (foldr fn t ts) 204 | 205 | infer _ = newTVar Star 206 | 207 | 208 | 209 | 210 | 211 | instance Infer [Definition] () where 212 | infer bs = 213 | 214 | do def_types <- mapM (\_ -> newTVar Star) bs 215 | 216 | let is = map get_name bs 217 | scs = map toScheme def_types 218 | altss = map get_axioms bs 219 | 220 | axiom_types <- with_scope$ 221 | do assume $ zipWith (:>:) is scs 222 | mapM (mapM (with_scope . infer)) altss 223 | 224 | let f _ [] = return () 225 | f g (x:xs) = do s <- get_substitution 226 | g x 227 | g (apply s x) 228 | f g xs 229 | 230 | mapM (\(t, as) -> f (unify t) as) (zip def_types axiom_types) 231 | 232 | as <- get_assumptions 233 | ss <- get_substitution 234 | fs' <- substitute as 235 | 236 | let ts' = apply ss def_types 237 | fs = tv fs' 238 | vss = map tv ts' 239 | gs = foldr1 union vss \\ fs 240 | 241 | if restricted then 242 | let scs' = map (quantify gs) ts' 243 | in do assume (zipWith (:>:) is scs') 244 | return () 245 | else 246 | let scs' = map (quantify gs) ts' 247 | in do assume (zipWith (:>:) is scs') 248 | return () 249 | 250 | where get_name (Definition _ _ (Symbol x) _) = x 251 | get_name (Definition _ _ (Operator x) _) = x 252 | get_axioms (Definition _ _ _ x) = x 253 | 254 | restricted = any simple bs 255 | simple (Definition _ _ _ axs) = any (null . f) axs 256 | 257 | f (EqualityAxiom (Match p _) _) = p 258 | f _ = error "Fatal error occurred while reticulating splines" 259 | 260 | 261 | instance Infer Definition () where 262 | 263 | infer (Definition _ _ name axs) = 264 | 265 | do sc <- find$ f name 266 | t <- freshInst sc 267 | axiom_types <- with_scope$ mapM (with_scope . infer) axs 268 | 269 | s <- get_substitution 270 | mapM (flip unify t) axiom_types -- TODO apply sub to axiom_types? 271 | 272 | as <- get_assumptions 273 | 274 | let t' = apply s t 275 | fs = tv (apply s as) 276 | gs = tv t' \\ fs 277 | sc' = quantify gs t' 278 | 279 | 280 | if sc /= sc' then 281 | add_error$ "Signature too general\n\n Expected: " ++ show sc ++ "\n Actual: " ++ show sc' 282 | else 283 | assume (f name :>: sc) 284 | 285 | return () 286 | 287 | where f (Symbol x) = x 288 | f (Operator x) = x 289 | 290 | instance Infer Test () where 291 | 292 | infer (Test ex) = do t <- newTVar Star 293 | x <- infer ex 294 | unify t x 295 | unify t bool_type 296 | 297 | newtype Test = Test (Addr (Expression Definition)) 298 | 299 | instance Infer BindGroup [Assumption] where 300 | infer (Scope imps tts es iss ts) = 301 | 302 | do --as <- get_assumptions 303 | mapM import' imps 304 | as' <- get_assumptions 305 | infer tts 306 | mapM assume$ sigs es 307 | mapM infer iss 308 | with_scope$ mapM infer es 309 | mapM infer (map Test ts) 310 | as'' <- get_assumptions 311 | set_assumptions as' 312 | return (as'' \\ as') 313 | 314 | where f (TypeAxiom t) = True 315 | f _ = False 316 | 317 | g name (TypeAxiom t) = [ name :>: to_scheme' t' | t' <- enumerate_types t ] 318 | 319 | to_scheme' :: Type -> Scheme 320 | to_scheme' t = quantify (tv t) t 321 | 322 | sigs :: [Definition] -> [Assumption] 323 | sigs [] = [] 324 | sigs (Definition _ _ name as:xs) = 325 | case L.find f as of 326 | Nothing -> sigs xs 327 | Just x -> g (h name) x ++ sigs xs 328 | 329 | import' (Namespace ns, Nothing) = 330 | 331 | do z <- get_modules 332 | a <- get_assumptions 333 | (Namespace ns') <- get_namespace 334 | case Namespace ns `lookup` z of 335 | Just z' -> assume$ a ++ z' 336 | Nothing -> if length ns' > 0 && head ns' /= head ns 337 | then import' (Namespace (head ns' : ns), Nothing) 338 | else add_error$ "Unknown namespace " ++ show (Namespace ns) 339 | 340 | import' (Namespace ns, Just alias) = 341 | 342 | do z <- get_modules 343 | a <- get_assumptions 344 | (Namespace ns') <- get_namespace 345 | case Namespace ns `lookup` z of 346 | Just z' -> 347 | do record <- to_record z' 348 | assume $ alias :>: record 349 | Nothing -> if length ns' > 0 && head ns' /= head ns 350 | then import' (Namespace (head ns' : ns), Just alias) 351 | else add_error$ "Unknown namespace " ++ show (Namespace ns) 352 | 353 | to_record assumptions = 354 | 355 | let f (_ :>: scheme) = 356 | 357 | [ do t <- freshInst scheme 358 | return t ] 359 | 360 | f _ = [] 361 | 362 | g (i :>: _) = [i] 363 | g _ = [] 364 | 365 | in do schemes <- sequence $ concat $ map f assumptions 366 | let symbols = concat $ map g assumptions 367 | let rec = TypeRecord (TRecord (M.fromList (zip symbols schemes)) TComplete Star) 368 | return $ quantify (tv rec) rec 369 | 370 | 371 | h (Symbol x) = x 372 | h (Operator x) = x 373 | 374 | infer (Module name bgs) = 375 | 376 | do as <- get_assumptions 377 | with_module name$ infer' bgs 378 | set_assumptions as 379 | return [] 380 | 381 | where infer' [] = return [] 382 | infer' (x:xs) = 383 | 384 | do a <- infer x 385 | assume a 386 | as' <- infer' xs 387 | return$ a ++ as' 388 | 389 | 390 | 391 | to_scheme :: TypeDefinition -> UnionType -> [Assumption] 392 | to_scheme (TypeDefinition n vs) t = [ quantify (vars y) y :>>: def_type y 393 | | y <- enumerate_types t ] 394 | 395 | where vars y = map (\x -> TVar x (infer_kind x y)) vs 396 | 397 | def_type y = quantify (vars y) (foldl app poly_type (map TypeVar (vars y))) 398 | 399 | poly_type = Type (TypeConst n (to_kind (length vs))) 400 | 401 | to_kind 0 = Star 402 | to_kind n = KindFunction Star (to_kind$ n - 1) 403 | 404 | app :: Type -> Type -> Type 405 | app y x = TypeApplication y x 406 | 407 | -- TODO this is still wrong - have to check for all enumerated types 408 | 409 | infer_kind x y = let ks = infer_kinds x y 410 | in if ks == [] 411 | then Star 412 | else if all (\x -> x == head ks) ks 413 | then head ks 414 | else error "Kind mismatch in scheme" 415 | 416 | infer_kinds x (TypeApplication a b) = infer_kinds x a ++ infer_kinds x b 417 | infer_kinds x (TypeVar (TVar y k)) | x == y = [k] 418 | infer_kinds x (TypeRecord (TRecord m _ _)) = concat$ map (infer_kinds x) (M.elems m) 419 | infer_kinds _ _ = [] 420 | 421 | -- | Computes all possible types from a type signature AST. 422 | 423 | enumerate_types :: UnionType -> [Type] 424 | enumerate_types (UnionType types) = to_unit . concat . map enumerate_type . S.toList $ types 425 | 426 | where term_type (VariableType x) = [ TypeVar (TVar x Star) ] 427 | term_type (SymbolType x) = [ Type (TypeConst (show x) Star) ] 428 | term_type (PolymorphicType a b) = [ foldl TypeApplication a' b' 429 | | b' <- map enumerate_types b 430 | , a' <- to_kind' (length b')$ term_type a ] 431 | 432 | to_kind 0 = Star 433 | to_kind n = KindFunction Star (to_kind$ n - 1) 434 | 435 | to_unit [] = [TypeRecord (TRecord M.empty TComplete Star)] 436 | to_unit x = x 437 | 438 | to_kind' _ [] = [] 439 | to_kind' n (TypeVar (TVar x _) : xs) = TypeVar (TVar x (to_kind n)) : to_kind' n xs 440 | to_kind' n (Type (TypeConst x _) : xs) = Type (TypeConst x (to_kind n)) : to_kind' n xs 441 | 442 | enumerate_type (SimpleType x) = term_type x 443 | 444 | enumerate_type (FunctionType a b) = 445 | [ a' `fn` b' | a' <- enumerate_types a, b' <- enumerate_types b ] 446 | 447 | enumerate_type (RecordType (unzip . M.toList -> (names, types'))) = 448 | 449 | map f permutations 450 | 451 | where f = TypeRecord . (\x -> TRecord x TComplete Star) . M.fromList . zip (map show names) 452 | permutations = permutations' . map enumerate_types $ types' 453 | 454 | where permutations' [] = [] 455 | permutations' (x:[]) = [ x ] 456 | permutations' (x:xs) = [ x' : xs' | x' <- x, xs' <- permutations' xs ] 457 | 458 | 459 | 460 | 461 | 462 | instance Infer [Statement] () where 463 | 464 | infer [] = return () 465 | infer (TypeStatement t c : xs) = 466 | 467 | do assume $ to_scheme t c 468 | infer xs 469 | 470 | infer (_ : xs) = infer xs 471 | 472 | 473 | js_type :: Type 474 | js_type = Type (TypeConst "JS" (KindFunction Star Star)) 475 | 476 | tiProgram :: Program -> [(Namespace, [Assumption])] -> ([(Namespace, [Assumption])], [String]) 477 | tiProgram (Program bgs) env = 478 | 479 | runTI $ do TI (\x -> (x { modules = env }, ())) 480 | assume$ "true" :>: (Forall [] (Type (TypeConst "Bool" Star))) 481 | assume$ "false" :>: (Forall [] (Type (TypeConst "Bool" Star))) 482 | assume$ "error" :>: (Forall [Star] (TypeGen 0)) 483 | assume$ "run" :>: (Forall [Star] (TypeApplication js_type (TypeGen 0) -:> TypeGen 0)) 484 | infer'$ to_group bgs 485 | s <- get_substitution 486 | ms <- TI (\y -> (y, modules y)) 487 | e <- get_errors 488 | return ((apply s ms), S.toList . S.fromList $ e) 489 | 490 | where infer' [] = return () 491 | infer' (x:xs) = 492 | 493 | do a <- infer x 494 | assume a 495 | infer' xs 496 | 497 | 498 | -------------------------------------------------------------------------------- /src/hs/lib/Forml/Types/Axiom.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE QuasiQuotes #-} 8 | {-# LANGUAGE OverlappingInstances #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE FlexibleInstances #-} 11 | {-# LANGUAGE GADTs #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE DeriveGeneric #-} 14 | 15 | module Forml.Types.Axiom where 16 | 17 | import Text.InterpolatedString.Perl6 18 | import Language.Javascript.JMacro 19 | 20 | import qualified Data.Map as M 21 | 22 | import Forml.Parser.Utils 23 | import Forml.Javascript.Utils 24 | 25 | import Forml.Types.Type 26 | import Forml.Types.Pattern 27 | 28 | import GHC.Generics 29 | 30 | import Data.Serialize 31 | import Data.Monoid 32 | 33 | import Prelude hiding (curry, (++)) 34 | 35 | 36 | -- Axiom 37 | -- -------------------------------------------------------------------------------- 38 | 39 | data Axiom a = TypeAxiom UnionType 40 | | EqualityAxiom (Match a) (Addr a) 41 | deriving (Eq, Generic) 42 | 43 | instance (Serialize a) => Serialize (Axiom a) 44 | 45 | instance (Show a) => Show (Axiom a) where 46 | show (TypeAxiom x) = ": " ++ show x 47 | show (EqualityAxiom ps ex) = [qq|$ps = $ex|] 48 | 49 | instance (Show a, ToJExpr a) => ToJExpr [Axiom a] where 50 | toJExpr [] = toJExpr . scope $ (Curried [] :: Curried a) 51 | toJExpr (TypeAxiom _:xs) = toJExpr xs 52 | toJExpr xs @ (EqualityAxiom (Match ps _) _ : _) = scope . curry (length ps) id . toStat . Curried $ xs 53 | 54 | newtype Curried a = Curried [Axiom a] 55 | 56 | instance (Show a, ToJExpr a) => ToStat (Curried a) where 57 | 58 | toStat (Curried []) = [jmacro| exhaust(); |] 59 | 60 | toStat (Curried (EqualityAxiom (Match [] Nothing) (Addr _ _ ex) : xss)) = 61 | 62 | [jmacro| return `(ex)`; |] 63 | 64 | toStat (Curried (EqualityAxiom (Match pss Nothing) (Addr _ _ ex) : xss)) = 65 | 66 | [jmacro| `(declare_bindings (var_names pss) pss)`; 67 | if (`(pss)`) return `(ex)`; 68 | `(Curried xss)`; |] 69 | 70 | toStat (Curried (EqualityAxiom (Match [] cond) (Addr _ _ ex) : xss)) = 71 | 72 | [jmacro| if (`(cond)`) return `(ex)`; |] 73 | 74 | 75 | toStat (Curried (EqualityAxiom (Match pss cond) (Addr _ _ ex) : xss)) = 76 | 77 | [jmacro| `(declare_bindings (var_names pss) pss)`; 78 | if (`(pss)` && `(cond)`) return `(ex)`; 79 | `(Curried xss)`; |] 80 | 81 | 82 | declare_bindings (name : names) (AliasPattern x : zs) = 83 | 84 | declare_bindings (take (length x) (repeat name)) x ++ declare_bindings names zs 85 | 86 | declare_bindings (name : names) (VarPattern x : zs) = 87 | 88 | [jmacro| `(declare x name)`; |] ++ declare_bindings names zs 89 | 90 | declare_bindings (name : names) (RecordPattern x _: zs) = 91 | let (ns, z) = unzip . M.toList $ x 92 | in declare_bindings (map (acc name) ns) z ++ declare_bindings names zs 93 | 94 | declare_bindings (_ : names) (_ : zs) = declare_bindings names zs 95 | declare_bindings [] [] = mempty 96 | 97 | var_names :: forall a. [a] -> [JExpr] 98 | var_names pss = map ref . reverse . take (length pss) . map local_pool $ [0 .. 26] 99 | 100 | acc n ns = [jmacroE| `(n)`[`(ns)`] |] 101 | 102 | 103 | instance (ToJExpr a) => ToJExpr (Maybe a) where 104 | toJExpr = maybe (toJExpr True) toJExpr 105 | -------------------------------------------------------------------------------- /src/hs/lib/Forml/Types/Definition.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE QuasiQuotes #-} 8 | {-# LANGUAGE OverlappingInstances #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE FlexibleInstances #-} 11 | {-# LANGUAGE GADTs #-} 12 | {-# LANGUAGE DeriveGeneric #-} 13 | {-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses #-} 14 | 15 | module Forml.Types.Definition where 16 | 17 | import Text.InterpolatedString.Perl6 18 | import Language.Javascript.JMacro 19 | 20 | import Control.Applicative 21 | import Control.Monad 22 | import Data.Monoid 23 | import Data.Serialize 24 | 25 | import Text.Parsec hiding ((<|>), State, many, spaces, parse, label) 26 | import qualified Text.Parsec as P 27 | import Text.Parsec.Indent hiding (same) 28 | 29 | import Forml.Parser.Utils 30 | import Forml.Javascript.Utils 31 | import Forml.Javascript.Backend 32 | 33 | import Forml.Types.Type 34 | import Forml.Types.Symbol 35 | import Forml.Types.Pattern 36 | import Forml.Types.Axiom 37 | import Forml.Types.Expression 38 | 39 | import Prelude hiding (curry, (++)) 40 | 41 | import GHC.Generics 42 | 43 | 44 | 45 | -- Definition 46 | -- -------------------------------------------------------------------------------- 47 | 48 | data Visibility = Public | Private deriving (Eq, Generic) 49 | 50 | data Definition = Definition Visibility Bool Symbol [Axiom (Expression Definition)] deriving (Eq, Generic) 51 | 52 | instance Serialize Definition 53 | instance Serialize Visibility 54 | 55 | instance Show Definition where 56 | show (Definition Public _ name ax) =[qq|$name {sep_with "\\n" ax}|] 57 | show (Definition Private _ name ax) =[qq|private $name {sep_with "\\n" ax}|] 58 | 59 | instance Syntax Definition where 60 | 61 | syntax = do whitespace 62 | vis <- option Public (try (string "private" >> spaces >> return Private)) 63 | inl <- option False (try (string "inline" >> spaces >> return True)) 64 | (x, y) <- try prefix <|> try infix'' 65 | return $ Definition vis inl x y 66 | 67 | where where' = do 68 | string "where" 69 | whitespace1 70 | P.spaces 71 | Just <$> withPosTemp (syntax `sepBy1` (try comma <|> try (spaces *> same))) 72 | 73 | where_clause ex = do 74 | where'' <- option Nothing (try where') 75 | return $ case where'' of 76 | Just defs -> LetExpression defs ex 77 | Nothing -> ex 78 | 79 | infix'' = 80 | 81 | do whitespace 82 | first_arg <- try syntax 83 | whitespace 84 | op <- not_reserved $ many1 operator 85 | whitespace 86 | Match pss cond <- syntax 87 | ax <- no_args_eq_axiom $ Match (first_arg:pss) cond 88 | axs <- try (prefix' $ Operator op) <|> return [] 89 | return (Operator op, ax:axs) 90 | 91 | where no_args_eq_axiom patterns = 92 | 93 | do whitespace *> string "=" *> spaces *> indented 94 | (Addr a b ex') <- withPosTemp (addr syntax) 95 | P.spaces 96 | ex <- where_clause ex' 97 | return $ EqualityAxiom patterns (Addr a b ex) 98 | 99 | prefix = 100 | 101 | do name <- try syntax <|> (Symbol <$> many1 (char '_')) 102 | y <- prefix' name 103 | return (name, y) 104 | 105 | prefix' name = 106 | 107 | do sig <- first 108 | eqs <- (try $ spaces *> (withPos . many . try $ try infix_axiom <|> eq_axiom)) <|> return [] 109 | whitespace 110 | if length sig == 0 && length eqs == 0 111 | then parserFail "Definition Axioms" 112 | else return (sig ++ eqs) 113 | 114 | where first = try type_or_first 115 | <|> ((:[]) <$> try naked_eq_axiom) 116 | <|> ((:[]) <$> (whitespace *> infix_axiom)) 117 | <|> return [] 118 | 119 | type_or_first = (:) <$> type_axiom <*> second 120 | 121 | second = option [] ((:[]) <$> try (no_args_eq_axiom (Match [] Nothing))) 122 | 123 | eq_axiom = 124 | 125 | do P.spaces 126 | string "|" <|> try (string name' <* notFollowedBy (digit <|> letter)) 127 | naked_eq_axiom 128 | 129 | where name' = case name of 130 | (Symbol name'') -> name'' 131 | (Operator name'') -> "(" ++ name'' ++ ")" 132 | 133 | naked_eq_axiom = 134 | 135 | do whitespace 136 | patterns <- syntax 137 | no_args_eq_axiom patterns 138 | 139 | no_args_eq_axiom patterns = 140 | 141 | do P.spaces *> string "=" *> P.spaces 142 | (Addr a b ex') <- withPosTemp (addr syntax) 143 | P.spaces 144 | ex <- where_clause ex' 145 | return $ EqualityAxiom patterns (Addr a b ex) 146 | 147 | infix_axiom = 148 | 149 | case name of 150 | (Symbol _) -> parserFail "Infix Definition" 151 | (Operator name'') -> do first_arg <- syntax 152 | whitespace 153 | string name'' 154 | whitespace 155 | Match pss cond <- syntax 156 | no_args_eq_axiom $ Match (first_arg:pss) cond 157 | 158 | type_axiom = 159 | 160 | do spaces 161 | indented 162 | string ":" 163 | spaces 164 | indented 165 | TypeAxiom <$> withPos type_axiom_signature 166 | 167 | -- TODO Visibility should be more than skin deep? 168 | 169 | instance Javascript Definition JStat where 170 | toJS (Definition _ _ _ (TypeAxiom _: [])) = 171 | return mempty 172 | toJS (Definition _ _ name as) = 173 | return [jmacro| `(declare_this (to_name name) $ toJExpr as)`; |] 174 | 175 | instance ToLocalStat Definition where 176 | toLocal (Definition _ _ _ (TypeAxiom _: [])) = 177 | mempty 178 | toLocal (Definition _ _ name as) = 179 | [jmacro| `(declare (to_name name) $ toJExpr as)`; |] 180 | -------------------------------------------------------------------------------- /src/hs/lib/Forml/Types/Literal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | 4 | 5 | module Forml.Types.Literal where 6 | 7 | import Language.Javascript.JMacro 8 | 9 | import Control.Applicative 10 | import Text.Parsec hiding ((<|>), State, many, spaces, parse, label) 11 | 12 | import Forml.Parser.Utils 13 | import Forml.TypeCheck.Types 14 | 15 | import GHC.Generics 16 | import Data.Serialize 17 | 18 | data Literal = StringLiteral String | IntLiteral Int | DoubleLiteral Double deriving (Eq, Generic) 19 | 20 | instance Serialize Literal 21 | 22 | instance Show Literal where 23 | show (StringLiteral x) = show x 24 | show (IntLiteral x) = show x 25 | show (DoubleLiteral x) = show x 26 | 27 | instance Syntax Literal where 28 | 29 | syntax = try flt <|> try num <|> try str 30 | 31 | where flt = DoubleLiteral <$> syntax 32 | num = IntLiteral <$> syntax 33 | str = StringLiteral <$> syntax 34 | 35 | instance ToJExpr Literal where 36 | toJExpr (StringLiteral s) = toJExpr s 37 | toJExpr (IntLiteral s) = toJExpr s 38 | toJExpr (DoubleLiteral s) = toJExpr s 39 | 40 | instance Infer Literal Type where 41 | infer (StringLiteral _) = return (Type (TypeConst "String" Star)) 42 | infer (IntLiteral _) = return (Type (TypeConst "Num" Star)) 43 | infer (DoubleLiteral _) = return (Type (TypeConst "Num" Star)) 44 | -------------------------------------------------------------------------------- /src/hs/lib/Forml/Types/Namespace.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE QuasiQuotes #-} 8 | {-# LANGUAGE OverlappingInstances #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE TypeSynonymInstances #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | {-# LANGUAGE DeriveGeneric #-} 13 | 14 | module Forml.Types.Namespace where 15 | 16 | import Language.Javascript.JMacro 17 | 18 | import Control.Applicative 19 | 20 | import Text.Parsec hiding ((<|>), State, many, spaces, parse, label) 21 | import Data.Monoid 22 | import qualified Data.List as L 23 | import Data.Serialize 24 | 25 | import GHC.Generics 26 | 27 | import Forml.Parser.Utils 28 | import Forml.Javascript.Utils 29 | 30 | import Prelude hiding (curry, (++)) 31 | 32 | newtype Namespace = Namespace [String] deriving (Eq, Ord, Generic) 33 | 34 | instance Serialize Namespace 35 | 36 | instance Monoid Namespace where 37 | mempty = Namespace [] 38 | mappend (Namespace x) (Namespace y) = Namespace (x ++ y) 39 | 40 | instance Show Namespace where 41 | show (Namespace []) = "global" 42 | show (Namespace x) = concat $ L.intersperse "." x 43 | 44 | instance Syntax Namespace where 45 | syntax = Namespace <$> (many1 (lower <|> char '_') `sepBy1` char '.') 46 | 47 | instance ToJExpr Namespace where 48 | toJExpr (Namespace []) = [jmacroE| (typeof global == "undefined" ? window : global) |] 49 | toJExpr (Namespace (end -> x : xs)) = [jmacroE| `(Namespace xs)`["$" ++ `(x)`] |] 50 | 51 | data Module = Module Namespace [Module] 52 | | Var String 53 | 54 | instance Show Module where 55 | show (Module (Namespace (reverse -> (x:_))) _) = x 56 | show (Var s) = s 57 | 58 | -------------------------------------------------------------------------------- /src/hs/lib/Forml/Types/Pattern.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE QuasiQuotes #-} 8 | {-# LANGUAGE OverlappingInstances #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE FlexibleInstances #-} 11 | {-# LANGUAGE GADTs #-} 12 | {-# LANGUAGE DeriveGeneric #-} 13 | {-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses #-} 14 | 15 | module Forml.Types.Pattern where 16 | 17 | import Text.InterpolatedString.Perl6 18 | import Data.Maybe 19 | import Language.Javascript.JMacro 20 | 21 | import Control.Applicative 22 | import Control.Monad 23 | 24 | import Text.Parsec hiding ((<|>), State, many, spaces, parse, label) 25 | import qualified Text.Parsec as P 26 | import qualified Data.List as L 27 | import Text.Parsec.Indent hiding (same) 28 | 29 | import qualified Data.Map as M 30 | 31 | import Forml.Parser.Utils 32 | import Forml.Javascript.Utils 33 | 34 | import Forml.Types.Literal 35 | import Forml.Types.Type 36 | import Forml.Types.Symbol 37 | import Forml.TypeCheck.Types 38 | 39 | import Prelude hiding (curry, (++)) 40 | import System.IO.Unsafe (unsafePerformIO) 41 | import Data.Monoid (mappend) 42 | import qualified Data.Serialize as S 43 | 44 | import GHC.Generics 45 | 46 | 47 | 48 | 49 | 50 | -- Pattern 51 | -- -------------------------------------------------------------------------------- 52 | 53 | data Match a = Match [Pattern a] (Maybe a) deriving (Eq, Generic) 54 | data Pattern a = VarPattern String 55 | | AnyPattern 56 | | LiteralPattern Literal 57 | | RecordPattern (M.Map Symbol (Pattern a)) Partial 58 | | ListPattern [Pattern a] 59 | | ViewPattern a (Pattern a) 60 | | AliasPattern [Pattern a] 61 | deriving (Eq, Generic) 62 | 63 | instance (S.Serialize a) => S.Serialize (Match a) 64 | instance (S.Serialize a) => S.Serialize (Pattern a) 65 | 66 | instance (Show a) => Show (Match a) where 67 | show (Match p Nothing) = sep_with " " p 68 | show (Match p (Just x)) = [qq|{sep_with " " p} when $x|] 69 | 70 | instance (Syntax a, Show a) => Syntax (Match a) where 71 | 72 | syntax = try conditional <|> ((\x -> Match x Nothing) <$> (try jStyle <|> hStyle)) 73 | 74 | where 75 | 76 | jStyle = do x <- indentPairs "(" (syntax `sepBy1` comma) ")" 77 | spaces 78 | if length x > 1 then return x else fail "Java-style arguments" 79 | 80 | hStyle = syntax `sepEndBy` whitespace1 81 | 82 | conditional = do x <- try jStyle <|> try hStyle 83 | string "when" 84 | whitespace1 85 | spaces 86 | ex <- syntax 87 | spaces 88 | return $ Match x (Just ex) 89 | 90 | newtype Condition = Condition JExpr 91 | 92 | instance ToJExpr [Condition] where 93 | toJExpr [] = toJExpr True 94 | toJExpr (Condition x : []) = [jmacroE| `(x)` |] 95 | toJExpr (Condition x : xs) = [jmacroE| `(x)` && `(xs)` |] 96 | 97 | data PatternMatch a = PM String (Pattern a) 98 | 99 | instance (Show a) => ToJExpr [PatternMatch a] where 100 | toJExpr [] = toJExpr True 101 | toJExpr (x:[]) = [jmacroE| `(x)` |] 102 | toJExpr (x:xs) = [jmacroE| `(x)` && `(xs)` |] 103 | 104 | instance (Show a) => ToJExpr (PatternMatch a) where 105 | 106 | toJExpr (PM n (AliasPattern xs)) = toJExpr $ filter fil $ map (PM n) xs 107 | 108 | toJExpr (PM n (LiteralPattern x)) = 109 | 110 | [jmacroE| `(ref n)` === `(x)` |] 111 | 112 | toJExpr (PM n (RecordPattern (M.toList -> xs) _)) = 113 | 114 | [jmacroE| `(map g xs)` && `(filter fil $ map f xs)` |] 115 | where f (key, val) = PM (n ++ "[\"" ++ to_name key ++ "\"]") val 116 | g (key, _) = Condition [jmacroE| __check(`(ref n)`, `(to_name key)`) |] 117 | 118 | toJExpr (PM n (ListPattern [])) = 119 | [jmacroE| equals(`(n)`)([]) |] 120 | toJExpr (PM n (ListPattern xs)) = 121 | let x = toJExpr (map f (zip [(0 :: Int) ..] xs)) 122 | f (index, val) = toJExpr (PM (n ++ "[" ++ show index ++ "]") val) 123 | in [jmacroE| `(x)` && `(ref n)`.length == `(length xs)` |] 124 | toJExpr (PM _ x) = error $ "Unimplemented " ++ show x 125 | 126 | data Partial = Partial | Complete deriving (Eq, Show, Generic) 127 | 128 | instance S.Serialize Partial 129 | 130 | instance (Show a) => Show (Pattern a) where 131 | show (VarPattern x) = x 132 | show AnyPattern = "_" 133 | show (LiteralPattern x) = show x 134 | show (ListPattern x) = [qq|[ {sep_with ", " x} ]|] 135 | show (ViewPattern x y) = [qq|($x -> $y)|] 136 | show (RecordPattern m Complete) = [qq|\{ {unsep_with " = " m} \}|] 137 | show (RecordPattern m Partial) = [qq|\{ {unsep_with " = " m}, _ \}|] 138 | show (AliasPattern a) = sep_with " & " a 139 | 140 | instance (Show a, ToJExpr a) => ToJExpr [Pattern a] where 141 | 142 | toJExpr ps = toJExpr$ filter fil $ zipWith PM (reverse . take (length ps) . map local_pool $ [0 .. 26]) ps 143 | 144 | fil (PM _ (VarPattern _)) = False 145 | fil (PM _ AnyPattern) = False 146 | fil (PM _ (RecordPattern (M.toList -> []) Complete)) = False 147 | fil _ = True 148 | 149 | instance (Syntax a, Show a) => Syntax (Pattern a) where 150 | 151 | syntax = try literal 152 | <|> try var 153 | <|> any' 154 | <|> try record 155 | <|> naked_apply 156 | <|> array 157 | <|> list 158 | <|> indentPairs "(" (try alias <|> syntax) ")" 159 | 160 | where alias = let sep = P.spaces <* string "&" <* P.spaces 161 | in AliasPattern <$> ((:) <$> syntax <* sep <*> sepBy1 syntax sep) 162 | 163 | var = 164 | 165 | do (Symbol x) <- syntax 166 | return (VarPattern x) 167 | 168 | literal = LiteralPattern <$> syntax 169 | any' = many1 (string "_") *> return AnyPattern 170 | naked_apply = 171 | 172 | do x <- indentPairs "{" (many1 letter) "}" 173 | return $ RecordPattern (M.fromList [(Symbol x, AnyPattern )]) Complete 174 | 175 | record = indentPairs "{" any_record "}" 176 | 177 | 178 | where pairs = (try key_eq_val <|> (many1 (char '_') >> return Nothing)) `sepEndBy` optional_sep 179 | 180 | any_record = 181 | 182 | do ps <- pairs 183 | let ps' = catMaybes ps 184 | return $ 185 | case (length ps, (not . isJust) `filter` ps) of 186 | (0, _) -> RecordPattern M.empty Complete 187 | (_, (Nothing:_)) -> RecordPattern (M.fromList ps') Partial 188 | _ -> RecordPattern (M.fromList ps') Complete 189 | 190 | key_eq_val = do key <- syntax 191 | spaces 192 | string "=" <|> string ":" 193 | spaces 194 | value <- syntax 195 | return$ Just (key, value) 196 | 197 | list = ListPattern <$> indentPairs "[" (syntax `sepBy` optional_sep) "]" 198 | 199 | array = f <$> indentAsymmetricPairs "[:" v (try (string ":]") <|> string "]") 200 | 201 | where v = do whitespace 202 | withPosTemp (syntax `sepBy` optional_sep) 203 | 204 | f [] = RecordPattern (M.fromList [(Symbol "nil", AnyPattern)]) Complete 205 | f (x:xs) = RecordPattern (M.fromList [(Symbol "head", x), (Symbol "tail", f xs)]) Complete 206 | 207 | 208 | 209 | instance (Show b) => Infer (Pattern b) Type where 210 | 211 | infer (AliasPattern (x:[])) = infer x 212 | 213 | infer (AliasPattern (x:xs)) = 214 | do z <- infer x 215 | z' <- infer (AliasPattern xs) 216 | unify z z' 217 | return z' 218 | 219 | infer (VarPattern i) = do v <- newTVar Star 220 | assume (i :>: toScheme v) 221 | return v 222 | 223 | infer AnyPattern = newTVar Star 224 | 225 | infer (LiteralPattern x) = infer x 226 | 227 | infer (ListPattern xs) = do ts <- mapM infer xs 228 | t' <- newTVar Star 229 | t <- freshInst list_scheme 230 | mapM_ (unify t') ts 231 | return t 232 | 233 | infer (RecordPattern (unzip . M.toList -> (names, patterns)) p) = 234 | 235 | do ts <- mapM infer patterns 236 | p' <- case p of 237 | Complete -> return TComplete 238 | Partial -> do t <- newTVar Star 239 | return$ TPartial t 240 | 241 | let r = TypeRecord (TRecord (M.fromList (zip (map f names) ts)) p' Star) 242 | t' <- newTVar Star 243 | sc <- find $ quantify (tv r) r 244 | case sc of 245 | Nothing -> 246 | do unify t' r 247 | return t' 248 | Just (Forall _ scr, sct) -> 249 | do t'' <- freshInst sct 250 | t''' <- return$ inst (map TypeVar$ tv t'') scr 251 | t <- freshInst (quantify (tv t''' L.\\ tv t'') t''') 252 | unify t r 253 | unify t' t'' 254 | s <- get_substitution 255 | let t''' = apply s t 256 | r''' = apply s r 257 | qt = quantify (tv t''') t''' 258 | rt = quantify (tv r''') r''' 259 | if qt /= rt 260 | then do add_error$ "Object constructor does not match signature\n" 261 | ++ " Expected: " ++ show qt ++ "\n" 262 | ++ " Actual: " ++ show rt 263 | return t' 264 | else return t' 265 | 266 | where f (Symbol x) = x 267 | f (Operator x) = x 268 | -------------------------------------------------------------------------------- /src/hs/lib/Forml/Types/Statement.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE KindSignatures #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE NamedFieldPuns #-} 9 | {-# LANGUAGE OverlappingInstances #-} 10 | {-# LANGUAGE QuasiQuotes #-} 11 | {-# LANGUAGE RankNTypes #-} 12 | {-# LANGUAGE RecordWildCards #-} 13 | {-# LANGUAGE ScopedTypeVariables #-} 14 | {-# LANGUAGE TemplateHaskell #-} 15 | {-# LANGUAGE TypeSynonymInstances #-} 16 | {-# LANGUAGE UndecidableInstances #-} 17 | {-# LANGUAGE ViewPatterns #-} 18 | 19 | module Forml.Types.Statement where 20 | 21 | import Text.InterpolatedString.Perl6 22 | 23 | import Language.Javascript.JMacro 24 | 25 | import Control.Applicative 26 | 27 | import Text.Parsec hiding (State, label, many, 28 | parse, spaces, (<|>)) 29 | import Text.Parsec.Indent hiding (same) 30 | 31 | import qualified Data.List as L 32 | import Data.Monoid 33 | import qualified Data.Serialize as S 34 | import Data.String.Utils 35 | 36 | import GHC.Generics 37 | 38 | import Forml.Parser.Utils 39 | 40 | import Forml.Types.Axiom 41 | import Forml.Types.Definition 42 | import Forml.Types.Expression 43 | import Forml.Types.Namespace 44 | import Forml.Types.Symbol 45 | import Forml.Types.Type 46 | import Forml.Types.TypeDefinition 47 | 48 | import Forml.Javascript.Backend 49 | import Forml.Javascript.Utils 50 | 51 | import Prelude hiding (curry, (++)) 52 | import System.IO.Unsafe (unsafePerformIO) 53 | 54 | 55 | 56 | -------------------------------------------------------------------------------- 57 | ---- 58 | ---- Statement 59 | 60 | data Statement = TypeStatement TypeDefinition UnionType 61 | | DefinitionStatement Definition 62 | | ExpressionStatement (Addr (Expression Definition)) 63 | | ImportStatement Namespace (Maybe String) 64 | | ModuleStatement Namespace [Statement] 65 | deriving (Generic) 66 | 67 | instance S.Serialize Statement 68 | 69 | instance Show Statement where 70 | show (TypeStatement t c) = [qq|type $t = $c|] 71 | show (DefinitionStatement d) = show d 72 | show (ExpressionStatement (Addr _ _ x)) = show x 73 | show (ImportStatement x Nothing) = [qq|open $x|] 74 | show (ImportStatement x (Just a)) = [qq|open $x as $a|] 75 | show (ModuleStatement x xs) = replace "\n |" "\n |" 76 | $ replace "\n\n" "\n\n " 77 | $ "module " 78 | ++ show x ++ "\n\n" ++ sep_with "\n\n" xs 79 | 80 | instance Syntax Statement where 81 | 82 | syntax = whitespace >> withPos statement_types <* many newline 83 | 84 | where statement_types = 85 | 86 | (type_statement "Type Definition") 87 | <|> (try import_statement "Import Statement") 88 | <|> (module_statement "Module Declaration") 89 | <|> (def_statement "Symbol Definition") 90 | <|> (expression_statement "Assertion") 91 | 92 | def_statement = DefinitionStatement <$> syntax 93 | 94 | import_statement = 95 | 96 | do string "open" 97 | whitespace 98 | imports <- syntax 99 | alias <- try alias_statement <|> return Nothing 100 | return $ ImportStatement imports alias 101 | 102 | where alias_statement = 103 | 104 | do many1 (char ' ') 105 | string "as" 106 | many1 $ (char ' ') 107 | (Symbol x) <- syntax 108 | return (Just x) 109 | 110 | 111 | module_statement = do try (string "module") 112 | whitespace1 113 | name <- try syntax <|> (char '"' *> (Namespace . (:[]) <$> (anyChar `manyTill` char '"'))) 114 | whitespace *> newline 115 | spaces *> (indented <|> same) 116 | ModuleStatement name <$> withPos (many1 ((spaces >> same >> syntax))) 117 | 118 | type_statement = do try (string "type" >> spaces) <|> return () 119 | def <- syntax 120 | set_indentation (+1) 121 | whitespace 122 | sig <- try (string "=" >> spaces >> (string "|" >> type_definition_signature)) 123 | <|> (string "=" >> spaces >> type_definition_signature) 124 | whitespace 125 | set_indentation (+(-1)) 126 | return $ TypeStatement def sig 127 | 128 | expression_statement = do try (string "test" >> spaces) <|> return () 129 | whitespace 130 | x <- getPosition 131 | y <- withPos$ addr syntax 132 | z <- getPosition 133 | return $ ExpressionStatement y 134 | 135 | 136 | 137 | 138 | -------------------------------------------------------------------------------- 139 | ---- 140 | ---- Meta 141 | 142 | data Meta = Meta { target :: Target, 143 | namespace :: Namespace, 144 | modules :: [Module], 145 | expr :: Statement } deriving (Show) 146 | 147 | data Target = Test | Library 148 | deriving (Show) 149 | 150 | serial :: SourcePos -> SourcePos -> String 151 | serial a b = show (sourceLine a - 1) ++ "_" ++ show (sourceLine b - 1) ++ (if sourceLine a /= sourceLine b then "multi" else "") 152 | 153 | get_code :: forall a. Addr a -> JS String 154 | get_code a = do src <- JS (\s @ JSState {src = src} -> (s, src)) 155 | return $ get_error a src 156 | 157 | instance Javascript Meta JStat where 158 | 159 | -- Expressions are ignored for Libraries, and rendered as tests for Test 160 | toJS (Meta { target = Library, expr = ExpressionStatement _ }) = return mempty 161 | toJS (Meta { target = Test, expr = ExpressionStatement a' @ (Addr a b e) }) = 162 | 163 | do message <- get_code a' 164 | return [jmacro| it(`(serial a b ++ "__::__" ++ message)`, function() { 165 | `(Jasmine e)`; 166 | }); |] 167 | 168 | -- Imports work identically for both targets 169 | toJS (Meta { modules, 170 | namespace = Namespace [], 171 | expr = ImportStatement target_namespace @ (find modules -> Nothing) _ }) = 172 | 173 | fail [qq| Could not resolve namespace $target_namespace |] 174 | 175 | toJS (Meta { modules, 176 | expr = ImportStatement target_namespace Nothing, 177 | namespace = (find modules . (++ target_namespace) -> Just y) }) = 178 | 179 | return $ open target_namespace y 180 | 181 | toJS (Meta { modules, 182 | expr = ImportStatement target_namespace @ (Namespace ns) (Just alias), 183 | namespace = (find modules . (++ target_namespace) -> Just y) }) = 184 | 185 | return $ declare alias (Namespace $ ns) 186 | 187 | toJS meta @ (Meta { expr = ImportStatement _ _, .. }) = 188 | 189 | let slice (Namespace ns) = Namespace . take (length ns - 1) $ ns 190 | in toJS (meta { namespace = slice namespace }) 191 | 192 | 193 | -- Modules in test mode must open the contents of the Library 194 | 195 | toJS meta @ (Meta { target = Library, namespace = Namespace [], expr = ModuleStatement ns xs, .. }) = 196 | 197 | do xs' <- toJS $ fmap (\z -> meta { namespace = ns, expr = z }) xs 198 | return $ declare_window (render_ns ns) 199 | [jmacroE| new (function() { 200 | `(xs')`; 201 | }) |] 202 | 203 | toJS meta @ (Meta { target = Library, expr = ModuleStatement ns xs, .. }) = 204 | 205 | do xs' <- toJS $ fmap (\z -> meta { namespace = namespace ++ ns, expr = z }) xs 206 | return $ declare_this (render_ns ns) 207 | [jmacroE| new (function() { 208 | `(xs')`; 209 | }) |] 210 | 211 | 212 | toJS meta @ (Meta { target = Test, expr = ModuleStatement ns xs, .. }) = 213 | 214 | let (imports, rest) = L.partition f xs 215 | f (ImportStatement _ _) = True 216 | f _ = False in 217 | 218 | do imports' <- toJS $ map (\z -> meta { namespace = namespace ++ ns, expr = z }) imports 219 | rest' <- toJS $ map (\z -> meta { namespace = namespace ++ ns, expr = z }) rest 220 | 221 | return [jmacro| describe(`(show ns)`, function() { 222 | `(open (namespace ++ ns) xs)`; 223 | `(imports')`; 224 | `(open (namespace ++ ns) xs)`; 225 | 226 | var x = new (function { 227 | `(rest')`; 228 | }()); 229 | }); |] 230 | 231 | 232 | 233 | -- Definitions are ignored for the Test target 234 | 235 | toJS (Meta { target = Library, expr = DefinitionStatement d }) = toJS d 236 | toJS (Meta { target = Test, expr = DefinitionStatement _ }) = return mempty 237 | 238 | toJS (Meta { expr = TypeStatement _ _ }) = return mempty 239 | -- toJS x = fail $ "Unimplemented " ++ show x 240 | 241 | 242 | 243 | empty_meta :: Target -> [Statement] -> Statement -> Meta 244 | empty_meta x = Meta x (Namespace []) . build_modules 245 | 246 | where build_modules (ModuleStatement n ns : xs) = Module n (build_modules ns) : build_modules xs 247 | build_modules (DefinitionStatement (Definition _ _ n _): xs) = Var (to_name n) : build_modules xs 248 | build_modules (_ : xs) = build_modules xs 249 | build_modules [] = [] 250 | 251 | find :: [Module] -> Namespace -> Maybe [String] 252 | find (Var s : ss) n @ (Namespace []) = Just [s] ++ find ss n 253 | find (Var _: xs) ns = find xs ns 254 | find [] (Namespace []) = Just [] 255 | find [] _ = Nothing 256 | 257 | find (Module _ xs : ms) n @ (Namespace []) = find ms n 258 | find (Module (Namespace ys) x : zs) n @ (Namespace xs) 259 | | length xs >= length ys && take (length ys) xs == ys = 260 | find x (Namespace $ drop (length ys) xs) 261 | | otherwise = find zs n 262 | 263 | 264 | 265 | -------------------------------------------------------------------------------- 266 | ---- 267 | ---- Open 268 | 269 | class Open a where open :: Namespace -> [a] -> JStat 270 | 271 | instance Open Statement where 272 | open _ [] = mempty 273 | open ns (DefinitionStatement (Definition _ _ _ (TypeAxiom _: [])) : xs) = open ns xs 274 | open ns (DefinitionStatement (Definition _ _ n _) : xs) = 275 | 276 | let f = ref . render_ns 277 | x = [jmacroE| `(f ns)`[`(n)`] |] in 278 | 279 | [jmacro| `(declare (replace " " "_" $ to_name n) x)`; 280 | `(open ns xs)`; |] 281 | 282 | open nss (ModuleStatement ns @ (Namespace (n:_)) _:xs) = 283 | 284 | [jmacro| `(declare (clean_ns n) (ref . render_ns $ nss ++ ns))`; 285 | `(open nss xs)`; |] 286 | 287 | open ns (_ : xs) = open ns xs 288 | 289 | instance Open String where 290 | open _ [] = mempty 291 | open (Namespace ns) (x:xs) = 292 | 293 | let print' [] = error "Empty Namespace" 294 | print' (y:[]) = [jmacroE| `(ref $ clean_ns y)` |] 295 | print' (y:ys) = [jmacroE| `(print' ys)`[`(clean_ns y)`] |] 296 | 297 | in declare x [jmacroE| `(print' $ reverse ns)`[`(x)`] || (typeof global == "undefined" ? window : global)[`(x)`] |] ++ open (Namespace ns) xs 298 | 299 | render_ns :: Namespace -> String 300 | render_ns (Namespace xs) = 301 | 302 | concat . L.intersperse "." . map clean_ns $ xs 303 | 304 | 305 | clean_ns = ("$" ++) . replace " " "_" 306 | 307 | 308 | 309 | 310 | -------------------------------------------------------------------------------- 311 | ---- 312 | ---- Jasmine 313 | 314 | newtype Jasmine = Jasmine (Expression Definition) 315 | 316 | instance ToStat Jasmine where 317 | 318 | toStat (Jasmine (ApplyExpression (SymbolExpression (Operator "==")) [x, y])) = 319 | 320 | [jmacro| expect(`(x)`).toEqual(`(y)`); |] 321 | 322 | toStat (Jasmine (ApplyExpression (SymbolExpression (Operator "!=")) [x, y])) = 323 | 324 | [jmacro| expect(`(x)`).toNotEqual(`(y)`); |] 325 | 326 | toStat (Jasmine e) = 327 | 328 | [jmacro| expect((function() { 329 | try { 330 | return `(e)`; 331 | } catch (ex) { 332 | return { error: ex }; 333 | } 334 | })()).toEqual(true); |] 335 | 336 | 337 | -------------------------------------------------------------------------------- /src/hs/lib/Forml/Types/Symbol.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | module Forml.Types.Symbol where 4 | 5 | import Language.Javascript.JMacro 6 | 7 | import Control.Applicative 8 | 9 | import Text.Parsec hiding ((<|>), State, many, spaces, parse, label) 10 | 11 | import Forml.Parser.Utils 12 | 13 | import qualified Data.Map as M 14 | import Data.String.Utils 15 | import Data.Serialize 16 | 17 | import GHC.Generics 18 | 19 | data Symbol = Symbol String 20 | | Operator String 21 | deriving (Ord, Eq, Generic) 22 | 23 | instance Serialize Symbol 24 | 25 | instance Show Symbol where 26 | show (Symbol s) = s 27 | show (Operator x) = x 28 | 29 | instance Syntax Symbol where 30 | syntax = (Symbol <$> not_reserved (oneOf "abscdefghijklmnopqrstuvwxyz" <:> many (alphaNum <|> oneOf "_'!$" <|> (string "?" >> return '_')))) 31 | <|> (Operator <$> not_reserved imp_infix) 32 | where imp_infix = string "(" *> many1 operator <* option "" (try (string ":")) <* string ")" 33 | 34 | instance ToJExpr Symbol where 35 | toJExpr = toJExpr . to_name 36 | 37 | to_name :: Symbol -> String 38 | to_name (Symbol "return") = "_return_" 39 | to_name (Symbol "new") = "_new_" 40 | to_name (Symbol "while") = "_while_" 41 | 42 | 43 | to_name (Symbol x) = replace "!" "_excl" $ replace " " "_" $ replace "'" "_apos" x 44 | to_name (Operator op) = concat . map (\x -> M.findWithDefault "_" x operator_dict) $ op 45 | 46 | -------------------------------------------------------------------------------- /src/hs/lib/Forml/Types/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, NamedFieldPuns, OverlappingInstances, 2 | QuasiQuotes, RankNTypes, RecordWildCards, TemplateHaskell, 3 | ViewPatterns, DeriveGeneric #-} 4 | 5 | module Forml.Types.Type where 6 | 7 | import Control.Applicative 8 | 9 | import Text.InterpolatedString.Perl6 10 | import Text.Parsec hiding (State, label, many, parse, spaces, (<|>)) 11 | import Text.Parsec.Indent hiding (same) 12 | 13 | import qualified Data.Map as M 14 | import qualified Data.Set as S 15 | 16 | import Forml.Parser.Utils 17 | import Forml.Types.Symbol 18 | 19 | import Data.Serialize 20 | 21 | import GHC.Generics 22 | 23 | data UnionType = UnionType (S.Set ComplexType) 24 | deriving (Ord, Eq, Generic) 25 | 26 | data ComplexType = RecordType (M.Map Symbol UnionType) 27 | | InheritType SimpleType (M.Map Symbol UnionType) 28 | | FunctionType UnionType UnionType 29 | | SimpleType SimpleType 30 | deriving (Eq, Ord, Generic) 31 | 32 | data SimpleType = PolymorphicType SimpleType [UnionType] 33 | | SymbolType Symbol 34 | | VariableType String 35 | deriving (Ord, Eq, Generic) 36 | 37 | instance Serialize SimpleType 38 | instance Serialize UnionType 39 | instance Serialize ComplexType 40 | 41 | instance Show UnionType where 42 | show (UnionType xs) = [qq|{sep_with " | " $ S.toList xs}|] 43 | 44 | instance Show ComplexType where 45 | show (SimpleType y) = [qq|$y|] 46 | show (InheritType n m) = [qq|\{ $n with {unsep_with ": " m} \}|] 47 | show (RecordType m) = [qq|\{ {unsep_with ": " m} \}|] 48 | 49 | show (FunctionType g @ (UnionType (S.toList -> ((FunctionType _ _):[]))) h) = 50 | [qq|($g -> $h)|] 51 | 52 | show (FunctionType g h) = [qq|$g -> $h|] 53 | 54 | instance Show SimpleType where 55 | show (PolymorphicType x y) = [qq|($x {sep_with " " y})|] 56 | show (SymbolType x) = show x 57 | show (VariableType x) = x 58 | 59 | 60 | 61 | -- Type Signatures 62 | -- ----------------------------------------------------------------------------- 63 | -- TODO ! (IO type) 64 | -- TODO type axioms need nominative types? 65 | -- ? TODO List, Map, Set shorthand? 66 | 67 | -- The type algebra of Sonnet is broken into 3 types to preserve the 68 | -- associativity of UnionTypes: (x | y) | z == x | y | z 69 | 70 | 71 | 72 | -- Where a type signature may be used in Sonnet had two slightly different parsers 73 | -- in order to allow for somewhat overloaded surrounding characters (eg "|" - when 74 | -- declaring the type of an axiom, one must be careful to disambiguate UnionTypes 75 | -- and sets of EqualityAxioms). However, these types are otherwise equivalent, 76 | -- and any type that may be declared in a TypeDefinition may also be the explicit 77 | -- type of a Definition (Note, however, that in the case of NamedTypes, the 78 | -- names introduced into scope will be inaccessible in the case of a Definition). 79 | 80 | 81 | type_axiom_signature :: Parser UnionType 82 | type_definition_signature :: Parser UnionType 83 | 84 | type_axiom_signature = do option "" (string "|" <* whitespace) 85 | t <- (u $ try function_type) <|> try nested_union_type <|> u inner_type 86 | whitespace 87 | return t 88 | 89 | where u = (<$>) $ UnionType . S.fromList . (:[]) 90 | 91 | type_definition_signature = UnionType . S.fromList <$> types <* whitespace 92 | where types = (try function_type <|> inner_type) `sepBy1` type_sep 93 | 94 | 95 | -- Through various complexities of the recursive structure of these types, we will 96 | -- need a few mutually recursive parsers to express these slightly different 97 | -- signature parsers. 98 | 99 | inner_type :: Parser ComplexType 100 | nested_function :: Parser ComplexType 101 | nested_union_type :: Parser UnionType 102 | 103 | inner_type = nested_function 104 | <|> try record_type 105 | <|> try named_type 106 | <|> try poly_type 107 | <|> var_type 108 | <|> symbol_type 109 | 110 | nested_function = indentPairs "(" (try function_type <|> inner_type) ")" 111 | nested_union_type = indentPairs "(" type_definition_signature ")" 112 | 113 | 114 | -- Now that we've expressed the possible parses of a UnionType, we can move on to 115 | -- parsing the ComplexType and SimpleType layers. While these are also mutually 116 | -- recursive, the recursion is uniform, as the various allowable combinations 117 | -- have already been defined above. 118 | 119 | function_type :: Parser ComplexType 120 | poly_type :: Parser ComplexType 121 | record_type :: Parser ComplexType 122 | named_type :: Parser ComplexType 123 | symbol_type :: Parser ComplexType 124 | var_type :: Parser ComplexType 125 | 126 | function_type = do x <- try nested_union_type <|> unionize inner_type 127 | spaces 128 | string "->" <|> string "→" 129 | spaces 130 | y <- (unionize $ try function_type) <|> try nested_union_type <|> unionize inner_type 131 | return $ FunctionType x y 132 | 133 | poly_type = do name <- (SymbolType <$> type_name) <|> (VariableType <$> try type_var) 134 | whitespace 135 | SimpleType . PolymorphicType name <$> (j_style <|> h_style) 136 | 137 | where rvs = record_type <|> var_type <|> symbol_type 138 | h_style = (try nested_union_type <|> unionize (try rvs)) `sepEndBy1` whitespace 139 | j_style = indentPairs "<" ((try nested_union_type <|> unionize (try rvs)) `sepBy1` optional_sep) ">" 140 | 141 | record_type = let key_value = (,) <$> syntax <* div' <*> type_definition_signature 142 | div' = spaces <* string ":" <* spaces 143 | pairs = key_value `sepEndBy` optional_sep 144 | inner = RecordType . M.fromList <$> pairs 145 | inherit = do SimpleType n <- try poly_type <|> try symbol_type <|> var_type 146 | spaces 147 | indented 148 | string "with" 149 | spaces *> indented 150 | InheritType n . M.fromList <$> pairs 151 | 152 | in indentPairs "{" (try inherit <|> inner) "}" 153 | 154 | named_type = do x <- indentPairs "{" name "}" 155 | 156 | -- named_type = do x <- name 157 | -- y <- option bool (try nested_union_type <|> unionize inner_type) 158 | 159 | return $ RecordType (M.fromList [(Symbol x, bool)]) 160 | 161 | where name = type_var 162 | bool = UnionType (S.fromList [(SimpleType (SymbolType (Symbol "Bool")))]) 163 | 164 | symbol_type = SimpleType . SymbolType <$> type_name 165 | var_type = SimpleType . VariableType <$> type_var 166 | 167 | unionize :: Parser ComplexType -> Parser UnionType 168 | unionize = fmap $ UnionType . S.fromList . (:[]) 169 | 170 | 171 | type_name :: Parser Symbol 172 | type_var :: Parser String 173 | 174 | type_name = Symbol <$> not_reserved (upper <:> many (alphaNum <|> oneOf "_'")) 175 | 176 | type_var = 177 | not_reserved (oneOf "_abscdefghijklmnopqrstuvwxyz" <:> many (alphaNum <|> oneOf "_'")) >>= f 178 | 179 | where f "_" = do x <- getPosition 180 | return $ "_" ++ show (sourceLine x * sourceColumn x) 181 | f x = return x 182 | 183 | 184 | -------------------------------------------------------------------------------- /src/hs/lib/Forml/Types/TypeDefinition.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE OverlappingInstances #-} 4 | {-# LANGUAGE QuasiQuotes #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | {-# LANGUAGE DeriveGeneric #-} 9 | 10 | module Forml.Types.TypeDefinition where 11 | 12 | 13 | 14 | import Control.Applicative 15 | 16 | import qualified Data.List as L 17 | import Text.Parsec hiding (State, label, many, parse, spaces, 18 | (<|>)) 19 | 20 | import GHC.Generics 21 | import Data.Serialize 22 | 23 | import Forml.Parser.Utils 24 | 25 | 26 | data TypeDefinition = TypeDefinition String [String] deriving (Generic) 27 | 28 | instance Serialize TypeDefinition 29 | 30 | 31 | instance Show TypeDefinition where 32 | show (TypeDefinition name vars) = concat . L.intersperse " " $ name : vars 33 | 34 | 35 | instance Syntax TypeDefinition where 36 | 37 | syntax = do name <- (:) <$> upper <*> many alphaNum 38 | vars <- try vars' <|> return [] 39 | return $ TypeDefinition name vars 40 | 41 | where vars' = do many1 $ oneOf "\t " 42 | let var = (:) <$> lower <*> many alphaNum 43 | var `sepEndBy` whitespace 44 | -------------------------------------------------------------------------------- /src/hs/main/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE NamedFieldPuns #-} 4 | {-# LANGUAGE OverlappingInstances #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE QuasiQuotes #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE RecordWildCards #-} 9 | {-# LANGUAGE TemplateHaskell #-} 10 | {-# LANGUAGE TupleSections #-} 11 | 12 | module Main(main) where 13 | 14 | import Forml.Exec 15 | 16 | main = exec -------------------------------------------------------------------------------- /src/hs/test/MainSpec.hs: -------------------------------------------------------------------------------- 1 | 2 | module MainSpec where 3 | 4 | import System.IO.Silently 5 | 6 | import Control.Exception 7 | 8 | import Data.ByteString (pack) 9 | import Data.Char (ord) 10 | 11 | import Test.Hspec 12 | import Test.Hspec.HUnit 13 | import Test.Hspec.QuickCheck (prop) 14 | 15 | import Test.HUnit 16 | import Test.QuickCheck hiding ((.&.), output) 17 | 18 | import Forml.Exec 19 | import Forml.CLI 20 | 21 | spec = do 22 | 23 | describe "Forml Compiler" $ do 24 | it "should compile the prelude.forml & the tests suite" $ do 25 | (std_out, output) <- capture $ try (main' test_config) 26 | case (output :: Either SomeException ()) of 27 | Left x -> assertFailure $ 28 | "\nException during compilation\n\n" 29 | ++ show x 30 | ++ "\n\nResults: (" ++ (show $ length std_out) 31 | ++ " chars):\n\n" ++ std_out 32 | Right _ -> 33 | if length std_out > 1860 && length std_out < 1920 34 | then return () 35 | else assertFailure $ 36 | "\nResults: (" ++ (show $ length std_out) 37 | ++ " chars):\n\n" ++ std_out 38 | 39 | src_files :: [[Char]] 40 | src_files = [ "src/forml/prelude.forml" 41 | , "src/forml/tests.forml" 42 | , "src/forml/readme.forml" 43 | , "src/forml/tetris.forml" ] 44 | 45 | test_config :: RunConfig 46 | test_config = 47 | 48 | RunConfig { inputs = src_files 49 | , output = "default.js" 50 | , show_types = False 51 | , optimize = True 52 | , silent = False 53 | , flush = False 54 | , run_tests = Phantom 55 | , write_docs = True 56 | , implicit_prelude = False 57 | , remote = True 58 | , watch = False } 59 | 60 | 61 | -------------------------------------------------------------------------------- /src/hs/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /src/html/template.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | $title$ 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | $ css $ 16 | 17 | 18 | 19 | 20 | 21 | $ scripts $ 22 | $ javascript $ 23 | 24 | 25 | 26 | 27 | 28 | 30 |
31 |
32 |
33 | 38 |
39 | 70 |
71 |
72 |
73 |
74 | 75 | 77 |
78 |
79 |

$title$

80 |

$desc$

81 |
82 |
83 | 84 | 85 |
86 | 87 | 89 |
90 |
91 |
92 |
93 |
94 |
95 |
96 | $html$ 97 |
98 |
99 | 100 |
101 | 102 | 104 |
105 |
106 |
107 |
108 | 109 | 132 | 133 | 134 | 135 | -------------------------------------------------------------------------------- /src/js/FormlReporter.js: -------------------------------------------------------------------------------- 1 | (function(){jasmine.FormlReporter=function(a){this.document=a||document;this.suiteDivs={};this.logRunningSpecs=!1};jasmine.FormlReporter.prototype.createDom=function(){};jasmine.FormlReporter.prototype.reportRunnerStarting=function(a){a=a.suites();for(var b=0;b PASS ")):(c.indexOf("multi"),$(c).before(" FAIL "))};jasmine.FormlReporter.prototype.log=function(){};jasmine.FormlReporter.prototype.getLocation=function(){return this.document.location}; 4 | jasmine.FormlReporter.prototype.specFilter=function(a){for(var b={},c=this.getLocation().search.substring(1).split("&"),d=0;d