diff --git a/Elm.cabal b/Elm.cabal --- a/Elm.cabal +++ b/Elm.cabal @@ -1,6 +1,6 @@ Name: Elm -Version: 0.1.0 +Version: 0.1.1 Synopsis: The Elm compiler and server. Description: Elm aims to make client-side web-development more pleasant. It is a statically/strongly typed, functional reactive @@ -16,11 +16,11 @@ Maintainer: info@elm-lang.org Copyright: Copyright: (c) 2011-2012 Evan Czaplicki -Category: Compiler +Category: Compiler, Language Build-type: Simple -Extra-source-files: README, elm-mini.js +Extra-source-files: README.md Cabal-version: >=1.6 source-repository head @@ -30,29 +30,41 @@ Executable elm -- .hs or .lhs file containing the Main module. Main-is: Elm.hs - Hs-Source-Dirs: src, src/Parse, src/Types - other-modules: Ast, CompileToJS, FreeVar, GenerateHtml, Initialize, - Rename, Replace, ToHtml, Binop, Combinators, Lexer, + Hs-Source-Dirs: src, src/Parse, src/Types, src/Language + other-modules: Ast, CompileToJS, GenerateHtml, Initialize, + Rename, Language.Elm, Binop, Combinators, Lexer, ParsePatterns, Parser, ParserLib, ParseTypes, Tokens, - Types + Types, Constrain, Hints, Types, Unify -- Packages needed in order to build this package. - Build-depends: base >=4.2 && <5, containers >= 0.3, transformers >= 0.2, - mtl >= 2, parsec >= 3.1.1, blaze-html >=0.4 && <0.5 + ghc-options: -O3 -rtsopts -auto-all -caf-all + Build-depends: base >=4.2 && <5, containers >= 0.3, + transformers >= 0.2, mtl >= 2, parsec >= 3.1.1, + blaze-html == 0.5.0.*, blaze-markup == 0.5.1.*, deepseq -- Modules not exported by this package. -- Other-modules: -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. -- Build-tools: - + + Executable elm-server Main-is: Server.hs Hs-Source-Dirs: src, src/Parse, src/Types - other-modules: Ast, CompileToJS, FreeVar, GenerateHtml, Initialize, - Rename, Replace, ToHtml, Binop, Combinators, Lexer, + other-modules: Ast, CompileToJS, GenerateHtml, Initialize, + Rename, Language.Elm, Binop, Combinators, Lexer, ParsePatterns, Parser, ParserLib, ParseTypes, Tokens, - Types + Types, Constrain, Hints, Types, Unify + ghc-options: -O3 -rtsopts -auto-all -caf-all Build-depends: base >=4.2 && <5, containers >= 0.3, transformers >= 0.2, - mtl >= 2, parsec >= 3.1.1, blaze-html >=0.4 && <0.5, - HTTP >= 4000, happstack-server >= 6.2.4 + mtl >= 2, parsec >= 3.1.1, blaze-html == 0.5.0.*, + HTTP >= 4000, happstack-server == 7.0.2 + +Library + exposed-modules: Language.Elm + Hs-Source-Dirs: src, src/Parse, src/Types + other-modules: Ast, CompileToJS, GenerateHtml, Initialize, + Rename, Binop, Combinators, Lexer, + ParsePatterns, Parser, ParserLib, ParseTypes, Tokens, + Types, Constrain, Hints, Types, Unify diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,1 +0,0 @@ -TODO. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,51 @@ +Elm +=== + +This is the Elm compiler and server, allowing you to develop Elm applications that run in any modern browser. + +Installation Process +-------------------- + +Download the [Haskell Platform](http://hackage.haskell.org/platform/). This will give you access to the Haskell compiler (needed to build Elm) and Haskell's package distribution system (to make installation of Elm easier). Once installed (even if it already was), you must update your listing of Haskell packages with: + + cabal update + +This will ensure that the elm package is available. Then install Elm with: + + cabal install elm + +Assuming everything goes correctly (potential problems are discussed later), this will build two executables on your machine: + +* `elm` is a standard compiler that takes `.elm` files and produces `.html` files. You can then use these HTML files with your favorite web-framework. + +* `elm-server` is both a compiler and server, allowing you to develop without designing and setting up a server yourself. Running `elm-server` starts a server in the current directory. It will compile and serve any `.elm` files in the current directory and its sub-directories. This is how I prefer to develop Elm programs. + +To use these executables you need to add a new directory to your PATH. For me, the executables were placed in /home/evan/.cabal/bin which I appended to the end of my PATH variable in my .bashrc file. Cabal should tell you where your executables are located, so you can make a similar addition (see this tutorial if you are new to changing your PATH in [Unix/Linux](http://www.cyberciti.biz/faq/unix-linux-adding-path/)). + +That is almost everything. Now, we will create a simple Elm project. The following commands will set-up a very basic project and start the Elm server. + + mkdir helloElm + cd helloElm + wget https://raw.github.com/evancz/Elm/master/elm-mini.js + echo main = lift asText Mouse.position > main.elm + elm-server + +The first two commands create a new directory and navigate into it. Then next command (`wget`) downloads the [elm-mini.js](https://raw.github.com/evancz/Elm/master/elm-mini.js) file which is the Elm runtime system and must be in the root directory of your Elm project. If you do not have wget, just follow [this link](https://raw.github.com/evancz/Elm/master/elm-mini.js) and download it directly. The `echo` command places a simple program into `main.elm`. The final command starts the Elm server at [localhost](http://localhost:8000/), allowing you to navigate to `main.elm` and see your first program in action. + + +Potential problems and their solutions: +--------------------------------------- + +* Install errors having to do with `happstack-server-7.0.2`. This version of `happstack-server` has stricter dependency restrictions that conflict with other libraries required by Elm. Try installing with an earlier version of `happstack-server` with the following command: `cabal install elm --constrain="happstack-server<7.0.2"` +* When installing on Debian, `blaze-html-0.4.3.2` fails to compile. You must install `blaze-html-0.4.3.1` instead. +* Elm does not appear to work with the latest versions of `containers` (i.e. 0.4.2.*). I know it works with earlier versions of containers, so to avoid this problem, you can try: `cabal install elm --constrain="containers==0.4.1.0" --force-reinstall` +* On Windows, HAppStack has trouble installing because of issues with the "network" package. I struggled with this problem on Windows 7 until I found the suggestion at the bottom of [this page](http://hackage.haskell.org/trac/ghc/ticket/5159). +* Likely more to come... + + +Areas for further work: +----------------------- + +Error messages need work in general. Syntax and Parsing errors are reported, but the messages are not very helpful. Type errors currently go unreported. I hope to fix this as soon as possible. + +If you are interested in making a large contribution, please contact me at `info (at) elm-lang (dot) org` so that we do not duplicate any work! diff --git a/elm-mini.js b/elm-mini.js deleted file mode 100644 --- a/elm-mini.js +++ /dev/null @@ -1,45 +0,0 @@ -var Guid=function(){var c=0;return{guid:function(){return c+=1}}}(),Value=function(){var c=function(a){if("boolean"===typeof a)return a?"True":"False";if("number"!==typeof a&&a[0]){if("Tuple"===a[0].substring(0,5)){for(var d="",b=a.length;--b;)d=","+c(a[b])+d;","===d[0]&&(d=d.substring(1));return"("+d+")"}if("Cons"===a[0])for(var b="string"===typeof a[1]?'"':"]",e="string"===typeof a[1]?"":",",d=("string"===typeof a[1]?'"':"[")+c(a[1]),a=a[2];;)if("Cons"===a[0])d+=e+c(a[1]),a=a[2];else return d+b; -else{if("Nil"===a[0])return"[]";d="";for(b=a.length;--b;)d=" "+c(a[b])+d;d=a[0]+d;return 1",">");return c}}}(),Color=function(){var c=function(a,d,b,c){return{r:Math.round(255*a),g:Math.round(255*d),b:Math.round(255*b),a:c}};return{black:c(0,0,0,1),white:c(1,1,1,1),red:c(1,0,0, -1),green:c(0,1,0,1),blue:c(0,0,1,1),rgba:function(a){return function(d){return function(b){return function(e){return c(a,d,b,e)}}}},rgb:function(a){return function(d){return function(b){return c(a,d,b,1)}}},Internal:{extract:function(a){return 1===a.a?"rgb("+a.r+","+a.g+","+a.b+")":"rgba("+a.r+","+a.g+","+a.b+","+a.a+")"}}}}(),Element=function(){var c=function(a){a=document.createElement(a);a.id=Guid.guid();return a},a=function(a){var b=c("div");b.appendChild(a);return b},d=function(a){return function(b){return function(d){var e= -c("div");e.isElmText=!0;e.innerHTML=d;e.style.textAlign=b;0=a&&(e.style.width=d.getPropertyValue("width"));e.style.height=d.getPropertyValue("height");document.body.removeChild(e);e.style.visibility="visible";e.style.styleFloat="none";e.style.cssFloat="none";return e}}},b=d(0)("left"),e=d(0)("justify"),f=d(0)("center"), -g=function(b){return"DIV"===b.tagName?b:a(b)},h=function(a){a.style.styleFloat="left";a.style.cssFloat="left";return a},j=function(a){a.style.position="absolute";return a},i=function(a,b,d){for(var e=c("div"),f=d.length;f--;){var j=b(d[f]);e.appendChild(j)}e.elmFlowDirection=a;return e},k=function(a){return function(b){for(var d=[];"Cons"===b[0];)d.push(b[1]),b=b[2];3<=a&&d.reverse();b=a%3;if(0==b)return i("Y",g,d);if(1==b)return i("X",h,d);if(2==b)return i("Z",j,d)}},l=function(a){return function(b){if("A"=== -b.tagName)return l(a)(b.firstChild),b;if(b.hasOwnProperty("isElmText")){var e=d(a)(b.style.textAlign)(b.innerHTML);b.style.height=e.style.height}b.style.width=a+"px";return b}};return{text:b,image:function(a){var b=c("img");b.isElmLeaf=!0;b.onload=function(){""===b.style.width&&0d&&(a.style.left=0);0e&&(a.style.top=0);0"+a+""}},d=function(b,a){return function(d){return""+d+""}},b=a("h1"),e=d("font-style","italic"),a=a("b"),f=d("text-decoration","underline"),g=d("text-decoration","overline"),h=d("text-decoration","line-through");return{fromString:c,toText:c,header:b,height:function(b){return d("font-size",b+"em")},italic:e,bold:a,underline:f,overline:g,strikeThrough:h,monospace:d("font-family","monospace"),color:function(b){return d("color", -Color.Internal.extract(b))},link:function(b){return function(a){return""+a+""}}}}(),Shape=function(){var c=function(a,b,e,c){return{center:a,points:b,theta:e,scale:c}},a=function(a){return function(b){return function(e){return function(c){c.save();c.translate(e.center[0],e.center[1]);c.rotate(e.theta);c.scale(e.scale,e.scale);c.beginPath();var g=e.points;c.moveTo(g[0][0],g[0][1]);for(var h=g.length;h--;)c.lineTo(g[h][0],g[h][1]);c.closePath();a?(c.fillStyle=Color.Internal.extract(b), -c.fill()):(c.strokeStyle=Color.Internal.extract(b),c.stroke());c.restore();return c}}}};return{polygon:function(a){return function(b){for(var e=[];"Cons"===a[0];)e.push([a[1][1],a[1][2]]),a=a[2];b=[b[1],b[2]];return c(b,e,0,1)}},ngon:function(a){return function(b){return function(e){for(var f=[],g=a;g--;)f.push([b*Math.cos(2*Math.PI*g/a),b*Math.sin(2*Math.PI*g/a)]);e=[e[1],e[2]];return c(e,f,0,1)}}},rect:function(a){return function(b){return function(e){var f=[[-a/2,-b/2],[a/2,-b/2],[a/2,b/2],[-a/ -2,b/2]],e=[e[1],e[2]];return c(e,f,0,1)}}},oval:function(a){return function(b){return function(e){for(var f=[],g=2*Math.PI;0 "text('"++err++"')") toJS . initialize -addMain body = "function main(){return " ++ body ++ ";}" - -parens = ("("++) . (++")") -braces = ("{"++) . (++"}") -jsList = ("["++) . (++"]") . intercalate "," -jsFunc args body = "function(" ++ args ++ "){" ++ body ++ "}" -assign x e = "var " ++ x ++ "=" ++ e ++ ";" -ret e = "return "++ e ++";" -iff a b c = a ++ "?" ++ b ++ ":" ++ c - -toJS expr = - case expr of - Number n -> show n - Var x -> x - Chr c -> show c - Boolean b -> if b then "true" else "false" - Range lo hi -> jsRange (toJS lo) (toJS hi) - Access e lbl -> toJS e ++ "." ++ lbl - Binop op e1 e2 -> binop op (toJS e1) (toJS e2) - If eb et ef -> parens $ iff (toJS eb) (toJS et) (toJS ef) - Lambda v e -> jsFunc v $ ret (toJS e) - App e1 e2 -> toJS e1 ++ parens (toJS e2) - Let defs e -> jsLet defs e - Case e cases -> jsCase e cases - Data name es -> jsList $ show name : map toJS es - -jsLet defs e' = jsFunc "" (defs' ++ ret (toJS e')) ++ "()" - where defs' = concatMap toDef $ sortBy f defs - f a b = compare (isLambda a) (isLambda b) - isLambda (_, Lambda _ _) = 1 - isLambda _ = 0 - toDef (f, Lambda x e) = - "function " ++ f ++ parens x ++ braces (ret $ toJS e) ++ ";" - toDef (x, e) = assign x (toJS e) - -jsCase e [c] = jsMatch c ++ parens (toJS e) -jsCase e cases = "(function(){" ++ - assign "v" (toJS e) ++ - assign "c" jsCases ++ - "for(var i=c.length;i--;){" ++ - assign "r" "c[i](v)" ++ - "if(r!==undefined){return r;}}}())" - where jsCases = jsList $ map jsMatch (reverse cases) - -jsMatch (p,e) = jsFunc "v" . match p "v" . ret $ toJS e -match p v hole = - case p of - PAnything -> hole - PVar x -> assign x v ++ hole - PData name ps -> - "if(" ++ show name ++ "!==" ++ v ++ - "[0]){return undefined;}else{"++body++"}" - where matches = zipWith match ps vs - vs = map (\i -> v++"["++show (i+1)++"]") [0..length ps-1] - body = foldr ($) hole matches - -jsNil = "[\"Nil\"]" -jsCons e1 e2 = jsList [ show "Cons", e1, e2 ] -jsRange e1 e2 = (++"()") . jsFunc "" $ - assign "lo" e1 ++ assign "hi" e2 ++ assign "lst" jsNil ++ - "do{" ++ assign "lst" (jsCons "hi" "lst") ++ "}while(hi-->lo)" ++ - ret "lst" - -binop (o:p) e1 e2 - | (o:p) == "mod" = e1 ++ "%" ++ e2 - | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2 - | otherwise = case o:p of - ":" -> jsCons e1 e2 - "++" -> append e1 e2 - "$" -> e1 ++ parens e2 - "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x") - "/=" -> e1 ++ "!==" ++ e2 - _ -> e1 ++ (o:p) ++ e2 - + +module CompileToJS (compile, compileToJS) where + +import Ast +import Control.Monad (liftM,(<=<),join) +import Data.Char (isAlpha) +import Data.List (intercalate,sortBy) +import Data.Map (toList) + +import Initialize + + +compile = (return . addMain . toJS) <=< initialize +compileToJS = addMain . either (\err -> "text('"++err++"')") toJS . initialize +addMain body = "function main(){return " ++ body ++ ";}" + +parens = ("("++) . (++")") +braces = ("{"++) . (++"}") +jsList = ("["++) . (++"]") . intercalate "," +jsFunc args body = "function(" ++ args ++ "){" ++ body ++ "}" +assign x e = "var " ++ x ++ "=" ++ e ++ ";" +ret e = "return "++ e ++";" +iff a b c = a ++ "?" ++ b ++ ":" ++ c + +toJS expr = + case expr of + Number n -> show n + Var x -> x + Chr c -> show c + Str s -> toJS . list $ map Chr s + Boolean b -> if b then "true" else "false" + Range lo hi -> jsRange (toJS lo) (toJS hi) + Access e lbl -> toJS e ++ "." ++ lbl + Binop op e1 e2 -> binop op (toJS e1) (toJS e2) + If eb et ef -> parens $ iff (toJS eb) (toJS et) (toJS ef) + Lambda v e -> jsFunc v $ ret (toJS e) + App (Var "toText") (Str s) -> show s + App (Var "link") (Str s) -> "link(" ++ show s ++ ")" + App (Var "plainText") (Str s) -> "plainText(" ++ show s ++ ")" + App e1 e2 -> toJS e1 ++ parens (toJS e2) + Let defs e -> jsLet defs e + Case e cases -> jsCase e cases + Data name es -> jsList $ show name : map toJS es + +jsLet defs e' = jsFunc "" (defs' ++ ret (toJS e')) ++ "()" + where defs' = concatMap toDef $ sortBy f defs + f a b = compare (isLambda a) (isLambda b) + isLambda (_, Lambda _ _) = 1 + isLambda _ = 0 + toDef (f, Lambda x e) = + "function " ++ f ++ parens x ++ braces (ret $ toJS e) ++ ";" + toDef (x, e) = assign x (toJS e) + +jsCase e [c] = jsMatch c ++ parens (toJS e) +jsCase e cases = "(function(){" ++ + assign "v" (toJS e) ++ + assign "c" jsCases ++ + "for(var i=c.length;i--;){" ++ + assign "r" "c[i](v)" ++ + "if(r!==undefined){return r;}}}())" + where jsCases = jsList $ map jsMatch (reverse cases) + +jsMatch (p,e) = jsFunc "v" . match p "v" . ret $ toJS e +match p v hole = + case p of + PAnything -> hole + PVar x -> assign x v ++ hole + PData name ps -> + "if(" ++ show name ++ "!==" ++ v ++ + "[0]){return undefined;}else{"++body++"}" + where matches = zipWith match ps vs + vs = map (\i -> v++"["++show (i+1)++"]") [0..length ps-1] + body = foldr ($) hole matches + +jsNil = "[\"Nil\"]" +jsCons e1 e2 = jsList [ show "Cons", e1, e2 ] +jsRange e1 e2 = (++"()") . jsFunc "" $ + assign "lo" e1 ++ assign "hi" e2 ++ assign "lst" jsNil ++ + "do{" ++ assign "lst" (jsCons "hi" "lst") ++ "}while(hi-->lo)" ++ + ret "lst" + +binop (o:p) e1 e2 + | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2 + | otherwise = case o:p of + ":" -> jsCons e1 e2 + "++" -> append e1 e2 + "$" -> e1 ++ parens e2 + "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x") + "/=" -> e1 ++ "!==" ++ e2 + _ -> e1 ++ (o:p) ++ e2 + append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2) diff --git a/src/Elm.hs b/src/Elm.hs deleted file mode 100644 --- a/src/Elm.hs +++ /dev/null @@ -1,45 +0,0 @@ - -module Main where - -import System.Environment -import CompileToJS -import Data.List (isPrefixOf) -import GenerateHtml -import Text.Blaze.Renderer.String - -main = getArgs >>= parse - -parse ("--help":_) = putStrLn usage -parse ("--version":_) = putStrLn "The Elm Compiler 0.1.0" -parse [loc,file] - | "--runtime-location=" `isPrefixOf` loc = - produceHtml (tail $ dropWhile (/='=') loc) file - | otherwise = putStrLn usageMini -parse [file] = produceHtml "elm-mini.js" file -parse _ = putStrLn usageMini - -produceHtml libLoc file = do - code <- readFile file - let name = takeWhile (/='.') file - case compile code of - Left err -> putStrLn err - Right jsCode -> writeFile (name ++ ".html") . renderHtml $ - generateHtml libLoc name jsCode - -usageMini = - "Usage: elm [OPTIONS] FILE\n\ - \Try `elm --help' for more information." - -usage = - "Usage: elm [OPTIONS] FILE\n\ - \Compile .elm files to .html files.\n\ - \Example: elm --runtime-location=../elm-mini.js main.elm\n\ - \\n\ - \Resource Locations:\n\ - \ --runtime-location set the location of the Elm runtime (elm-mini.js)\n\ - \\n\ - \Compiler Information:\n\ - \ --version print the version information and exit\n\ - \ --help display this help and exit\n\ - \\n\ - \Elm home page: " diff --git a/src/FreeVar.hs b/src/FreeVar.hs deleted file mode 100644 --- a/src/FreeVar.hs +++ /dev/null @@ -1,30 +0,0 @@ -module FreeVar (freeIn) where - -import Ast -import Data.Set hiding (map) - -x `freeIn` expr = member x $ freeVars expr - -freeVars expr = - let f = freeVars in - case expr of - Range e1 e2 -> union (f e1) (f e2) - Binop op e1 e2 -> union (f e1) (f e2) - Lambda x e -> delete x (f e) - App e1 e2 -> union (f e1) (f e2) - If e1 e2 e3 -> unions $ map f [e1,e2,e3] - Lift e es -> unions $ map f es - Fold e1 e2 e3 -> unions $ map f [e1,e2,e3] - Async e -> f e - Let defs e -> foldr delete (unions (f e : map f es)) vs - where (vs,es) = unzip defs - Var x -> singleton x - Data name es -> unions (map f es) - Case e cases -> union (f e) (unions $ map caseFreeVars cases) - _ -> empty - -caseFreeVars (p,e) = difference (freeVars e) (pvars p) - where pvars p = case p of - PAnything -> empty - PVar x -> singleton x - PData _ ps -> unions (map pvars ps) diff --git a/src/GenerateHtml.hs b/src/GenerateHtml.hs --- a/src/GenerateHtml.hs +++ b/src/GenerateHtml.hs @@ -1,32 +1,33 @@ {-# LANGUAGE OverloadedStrings #-} module GenerateHtml (generateHtml) where -import Text.Blaze.Html5 hiding (map) +import Text.Blaze (preEscapedToMarkup) import qualified Text.Blaze.Html5 as H -import Text.Blaze.Html5.Attributes +import Text.Blaze.Html5 ((!)) import qualified Text.Blaze.Html5.Attributes as A -css = preEscapedString "* { padding:0; margin:0; \ - \hyphens: auto; -moz-hyphens: auto;\ - \ -webkit-hyphens: auto; -ms-hyphens: auto; }\ - \body { font-family: Arial; }\ - \a:link {text-decoration: none}\ - \a:visited {text-decoration: none}\ - \a:active {text-decoration: none}\ - \a:hover {text-decoration: underline; color: #ff8f12;}" - -makeScript :: String -> Html -makeScript s = script ! type_ "text/javascript" ! src (toValue s) $ "" +css = preEscapedToMarkup $ + ("* { padding:0; margin:0; \ + \hyphens: auto; -moz-hyphens: auto;\ + \ -webkit-hyphens: auto; -ms-hyphens: auto; }\ + \body { font-family: Arial; }\ + \a:link {text-decoration: none}\ + \a:visited {text-decoration: none}\ + \a:active {text-decoration: none}\ + \a:hover {text-decoration: underline; color: #ff8f12;}" :: String) +makeScript :: String -> H.Html +makeScript s = H.script ! A.type_ "text/javascript" ! A.src (H.toValue s) $ "" + generateHtml libLoc title source = - docTypeHtml $ do + H.docTypeHtml $ do H.head $ do - meta ! charset "UTF-8" - H.title . toHtml $ title + H.meta ! A.charset "UTF-8" + H.title . H.toHtml $ title makeScript libLoc - (script ! type_ "text/javascript") . preEscapedString $ source - H.style ! type_ "text/css" $ css - body $ do + (H.script ! A.type_ "text/javascript") . preEscapedToMarkup $ source + H.style ! A.type_ "text/css" $ css + H.body $ do H.div ! A.id "widthChecker" ! A.style "width:100%; height:1px; position:absolute; top:-1px;" $ "" H.span ! A.id "content" $ "" - script ! type_ "text/javascript" $ "Dispatcher.initialize()" + H.script ! A.type_ "text/javascript" $ "Dispatcher.initialize()" diff --git a/src/Initialize.hs b/src/Initialize.hs --- a/src/Initialize.hs +++ b/src/Initialize.hs @@ -1,106 +1,56 @@ module Initialize (initialize) where import Ast -import Control.Arrow (first) +import Control.Arrow (first, second) import Control.Monad import Data.Char (isAlpha) import Data.Maybe (mapMaybe) import Data.Either (rights) -import FreeVar import Lexer import Parser (toExpr,toDefs) import Rename (rename) -import Replace -import System.IO.Unsafe -initialize str = do - expr <- toDefs =<< tokenize str --- let rexpr = rename expr --- let init = simp_loop rexpr --- return $ if depth init < depth rexpr then init else rexpr - return $ rename expr +import Unify +import Hints + {-- +initialize str = do + (expr, hints') <- toDefs =<< tokenize str + let expr' = rename expr + subs <- unify (liftM2 (++) hints hints') expr' + return (seq subs expr') +--} + +initialize str = do + (expr, hints') <- toDefs =<< tokenize str + let expr' = rename expr + subs <- unify (liftM2 (++) hints hints') expr' + let init = simp_loop expr' + return (seq subs init) + simp_loop exp = if exp == exp' then exp' else simp_loop exp' where exp' = simp exp simp expr = let f = simp in case expr of - Range e1 e2 -> simp_range (f e1) (f e2) + Range e1 e2 -> Range (f e1) (f e2) Binop op e1 e2 -> simp_binop op (f e1) (f e2) Lambda x e -> Lambda x (f e) - App e1 e2 -> simp_app (f e1) (f e2) + App e1 e2 -> App (f e1) (f e2) If e1 e2 e3 -> simp_if (f e1) (f e2) (f e3) - Lift e es -> Lift (f e) $ map f es - Fold e1 e2 e3 -> Fold (f e1) (f e2) (f e3) - Async e -> Async (f e) - Let x e1 e2 -> simp_let x (f e1) (f e2) + Let defs e -> Let (map (second f) defs) (f e) Data name es -> Data name (map f es) - Case e cases -> simp_case (f e) cases + Case e cases -> Case (f e) (map (second f) cases) _ -> expr -data Status = NoMatch | Quit deriving (Show,Eq) - -simp_case v cases = - case v of - Data _ _ -> case rights $ map (\(p,e) -> match p v e) cases of - { v:_ -> v; _ -> Case v cases } - _ -> Case v cases - -match p v hole = - case p of PAnything -> return hole - PVar x -> return $ Let x v hole - PData pn ps -> - case v of - Data vn vs -> if pn /= vn then Left NoMatch else - foldM (flip ($)) hole (zipWith match ps vs) - _ -> Left Quit - -simp_let x e1 e2 - | not (x `freeIn` e2) = e2 - | isValue e1 = Let x e1 (replace x e1 e2) - | otherwise = Let x e1 e2 - -simp_app e1 e2 = - case e1 of - Let x s e -> if x `freeIn` e2 then error "Overlapping names!" else - Let x s (App e e2) - Lambda x e -> Let x e2 e -{-- - Var "constant" -> App (Lambda "v" (Lift (Var "v") [])) e2 - Var "async" -> Async e2 - Var "foldp" -> Lambda "b" . Lambda "s" $ (Fold e2 (Var "b") (Var "s")) - Var "lift" -> Lambda "s" (Lift e2 [Var "s"]) - Var "lift2" -> Lambda "s1" . Lambda "s2" $ (Lift e2 [Var "s1",Var "s2"]) ---} - _ -> App e1 e2 - simp_if (Boolean b) e2 e3 = if b then e2 else e3 simp_if a b c = If a b c -isValue expr = - case expr of - Number _ -> True - Chr _ -> True - Boolean _ -> True - Range _ _ -> True - Lambda _ _ -> True - Data _ _ -> True - Var _ -> True - _ -> False - -simp_range lo hi = toAST (parse code) - where toAST = either (error "Compilation Failure") (\f -> App (App f lo) hi) - parse str = toExpr =<< tokenize str - code = "let range xs lo hi = \ - \if hi < lo then xs else range (hi:xs) lo (hi-1) in\ - \ \\x y -> range [] x y" - simp_binop "mod" (Number n) (Number m) = Number (mod n m) simp_binop "mod" e1 e2 = Binop "mod" e1 e2 simp_binop str e1 e2 - | isAlpha (head str) || '_' == head str = - App (App (Var str) e1) e2 + | isAlpha (head str) || '_' == head str = App (App (Var str) e1) e2 | otherwise = binop str e1 e2 binop op (Number n) (Number m) = f n m @@ -144,6 +94,9 @@ binop op e (Boolean n) = binop op (Boolean n) e binop ":" h t = cons h t +binop "++" (Str s1) (Str s2) = Str $ s1 ++ s2 +binop "++" (Str s1) (Binop "++" (Str s2) e) = Binop "++" (Str $ s1 ++ s2) e +binop "++" (Binop "++" e (Str s1)) (Str s2) = Binop "++" e (Str $ s1 ++ s2) binop "++" (Data "Nil" []) e = e binop "++" e (Data "Nil" []) = e binop "++" (Data "Cons" [h,t]) e = Data "Cons" [h, binop "++" t e] diff --git a/src/Language/Elm.hs b/src/Language/Elm.hs new file mode 100644 --- /dev/null +++ b/src/Language/Elm.hs @@ -0,0 +1,10 @@ + +module Language.Elm where + +import CompileToJS +import GenerateHtml +import Text.Blaze.Html (Html) + +compileToHtml :: String -> String -> String -> Html +compileToHtml libLoc fileName source = + generateHtml libLoc fileName (compileToJS source) diff --git a/src/Parse/Binop.hs b/src/Parse/Binop.hs --- a/src/Parse/Binop.hs +++ b/src/Parse/Binop.hs @@ -1,64 +1,64 @@ -module Binop (binops) where - -import Ast -import Combinators -import Control.Monad (liftM,guard) -import Control.Monad.Error -import Data.List (foldl',splitAt,elemIndices,group,groupBy,sortBy,find) -import Data.Map as Map -import Data.Maybe (mapMaybe) - -data Assoc = L | Non | R deriving (Eq,Show) - -table = [ (9, R, ".") - , (7, L, "*"), (7, L, "/"), (7, L, "mod") - , (6, L, "+"), (6, L, "-") - , (5, R, ":" ), (5, R, "++") - , (4, Non, "<="), (4, Non, ">="), (4, Non, "<") - , (4, Non, "=="), (4, Non, "/="), (4, Non, ">") - , (3, R, "&&") - , (2, R, "||") - , (0, R, "$") - ] - -sortOps = sortBy (\(i,_,_) (j,_,_) -> compare i j) - -binops term anyOp = do - e <- term - (ops,es) <- liftM unzip $ star (do { op <- anyOp; e <- term; return (op,e) }) - case binopOf (Map.empty) (sortOps table) ops (e:es) of - Right e -> return e - Left msg -> zero - -binopSplit seen opTable i ops es = - case (splitAt i ops, splitAt (i+1) es) of - ((befores, op:afters), (pres, posts)) -> - do e1 <- binopOf seen opTable befores pres - e2 <- binopOf seen opTable afters posts - return $ Binop op e1 e2 - -binopOf _ _ _ [e] = return e -binopOf _ [] ops es = - return $ foldl (flip ($)) (head es) $ zipWith Binop ops (tail es) - -binopOf seen (tbl@((lvl, L, op):rest)) ops es = - case elemIndices op ops of - [] -> binopOf seen rest ops es - is -> case Map.lookup lvl seen of - Nothing -> binopSplit (insert lvl (L,op) seen) tbl (last is) ops es - Just (L,_) -> binopSplit seen tbl (last is) ops es - Just (assoc,op') -> Left $ errorMessage lvl op L op' assoc -binopOf seen (tbl@((lvl, assoc, op):rest)) ops es = - case elemIndices op ops of - [] -> binopOf seen rest ops es - i:_ -> case Map.lookup lvl seen of - Nothing -> binopSplit (insert lvl (R,op) seen) tbl i ops es - Just (assoc',op') -> - if assoc == assoc' && assoc /= Non then - binopSplit seen tbl i ops es - else Left $ errorMessage lvl op assoc op' assoc' - -errorMessage lvl op1 assoc1 op2 assoc2 = - "Cannot have (" ++ op1 ++ ") with [" ++ show assoc1 ++ " " ++ - show lvl ++ "] and (" ++ op2 ++ ") with [" ++ show assoc2 ++ " " ++ - show lvl ++ "]" +module Binop (binops) where + +import Ast +import Combinators +import Control.Monad (liftM,guard) +import Control.Monad.Error +import Data.List (foldl',splitAt,elemIndices,group,groupBy,sortBy,find) +import qualified Data.Map as Map +import Data.Maybe (mapMaybe) + +data Assoc = L | Non | R deriving (Eq,Show) + +table = [ (9, R, ".") + , (7, L, "*"), (7, L, "/"), (7, L, "mod") + , (6, L, "+"), (6, L, "-") + , (5, R, ":" ), (5, R, "++") + , (4, Non, "<="), (4, Non, ">="), (4, Non, "<") + , (4, Non, "=="), (4, Non, "/="), (4, Non, ">") + , (3, R, "&&") + , (2, R, "||") + , (0, R, "$") + ] + +sortOps = sortBy (\(i,_,_) (j,_,_) -> compare i j) + +binops term anyOp = do + e <- term + (ops,es) <- liftM unzip $ star (do { op <- anyOp; e <- term; return (op,e) }) + case binopOf Map.empty (sortOps table) ops (e:es) of + Right e -> return e + Left msg -> zero + +binopSplit seen opTable i ops es = + case (splitAt i ops, splitAt (i+1) es) of + ((befores, op:afters), (pres, posts)) -> + do e1 <- binopOf seen opTable befores pres + e2 <- binopOf seen opTable afters posts + return $ Binop op e1 e2 + +binopOf _ _ _ [e] = return e +binopOf _ [] ops es = + return $ foldl' (flip ($)) (head es) $ zipWith Binop ops (tail es) + +binopOf seen (tbl@((lvl, L, op):rest)) ops es = + case elemIndices op ops of + [] -> binopOf seen rest ops es + is -> case Map.lookup lvl seen of + Nothing -> binopSplit (Map.insert lvl (L,op) seen) tbl (last is) ops es + Just (L,_) -> binopSplit seen tbl (last is) ops es + Just (assoc,op') -> Left $ errorMessage lvl op L op' assoc +binopOf seen (tbl@((lvl, assoc, op):rest)) ops es = + case elemIndices op ops of + [] -> binopOf seen rest ops es + i:_ -> case Map.lookup lvl seen of + Nothing -> binopSplit (Map.insert lvl (R,op) seen) tbl i ops es + Just (assoc',op') -> + if assoc == assoc' && assoc /= Non then + binopSplit seen tbl i ops es + else Left $ errorMessage lvl op assoc op' assoc' + +errorMessage lvl op1 assoc1 op2 assoc2 = + "Cannot have (" ++ op1 ++ ") with [" ++ show assoc1 ++ " " ++ + show lvl ++ "] and (" ++ op2 ++ ") with [" ++ show assoc2 ++ " " ++ + show lvl ++ "]" diff --git a/src/Parse/Combinators.hs b/src/Parse/Combinators.hs --- a/src/Parse/Combinators.hs +++ b/src/Parse/Combinators.hs @@ -1,82 +1,82 @@ -module Combinators where -import Control.Monad -import Data.Char -import Data.List (sortBy) - -newtype Parser from to = Parser ([from] -> [(to,[from])]) ---newtype Parser a = Parser (String -> [(a,String)]) - -parse (Parser p) = p - -instance Monad (Parser from) where - return a = Parser (\cs -> [(a,cs)]) - p >>= f = Parser (\cs -> concat [parse (f a) cs' | (a,cs') <- parse p cs]) - -instance MonadPlus (Parser from) where - mzero = Parser (\cs -> []) - mplus p q = Parser (\cs -> parse p cs ++ parse q cs) - --- True recursive descent, tries everything. -p +++ q = mplus p q - --- Get the first parse. -p +|+ q = Parser (\cs -> case parse (mplus p q) cs of - [] -> [] - (x:xs) -> [x]) - -zero = Parser (\cs -> []) - -item = Parser (\cs -> case cs of - [] -> [] - (c:cs) -> [(c,cs)]) - -sat p = do {c <- item; if p c then return c else mzero} - -char c = sat (c ==) - -string "" = return "" -string (c:cs) = do {char c; string cs; return (c:cs)} - -star p = plus p +++ return [] -plus p = do {a <- p; as <- star p; return (a:as)} - -optional p = do { p >>= return . Just } +++ return Nothing - -nospace = guard . (==0) . length =<< space -space = star $ sat isSpace -space1 = plus $ sat isSpace -newline = do - star $ char ' ' +++ char '\t' - char '\n' - space - return "" - -digit = do {x <- sat isDigit; return (ord x - ord '0')} -integer = do {i <- plus digit; return $ foldl (\a d -> 10 * a + d) 0 i} - -variable = do - shd <- sat isLower; - stl <- star $ sat (\c -> isAlphaNum c || c == '_') - return $ shd:stl - -sepBy sep p = sepBy1 sep p +++ return [] - -sepBy1 sep p = do - x <- p - xs <- star (sep >> p) - return $ x:xs - -select ps = foldl1 (+|+) ps - -chainl p op a = (chainl1 p op) +++ return a -chainl1 p op = do {a <- p; rest a} - where - rest a = (do f <- op - b <- p - rest (f a b)) +++ return a - -extractResult err parse = - case parse of - (r,[]) : _ -> Right r - _ : rest -> extractResult err rest +module Combinators where +import Control.Monad +import Data.Char +import Data.List (sortBy,foldl',foldl1') + +newtype Parser from to = Parser ([from] -> [(to,[from])]) +--newtype Parser a = Parser (String -> [(a,String)]) + +parse (Parser p) = p + +instance Monad (Parser from) where + return a = Parser (\cs -> [(a,cs)]) + p >>= f = Parser (\cs -> concat [parse (f a) cs' | (a,cs') <- parse p cs]) + +instance MonadPlus (Parser from) where + mzero = Parser $ const [] + mplus p q = Parser (\cs -> parse p cs ++ parse q cs) + +-- True recursive descent, tries everything. +p +++ q = mplus p q + +-- Get the first parse. +p +|+ q = Parser (\cs -> case parse (mplus p q) cs of + [] -> [] + (x:xs) -> [x]) + +zero = Parser $ const [] + +item = Parser (\cs -> case cs of + [] -> [] + (c:cs) -> [(c,cs)]) + +sat p = do {c <- item; if p c then return c else mzero} + +char c = sat (c ==) + +string "" = return "" +string (c:cs) = do {char c; string cs; return (c:cs)} + +star p = plus p +++ return [] +plus p = do {a <- p; as <- star p; return (a:as)} + +optional p = (Just `liftM` p) +++ return Nothing + +nospace = guard . (==0) . length =<< space +space = star $ sat isSpace +space1 = plus $ sat isSpace +newline = do + star $ char ' ' +++ char '\t' + char '\n' + space + return "" + +digit = do {x <- sat isDigit; return (ord x - ord '0')} +integer = do {i <- plus digit; return $ foldl' (\a d -> 10 * a + d) 0 i} + +variable = do + shd <- sat isLower; + stl <- star $ sat (\c -> isAlphaNum c || c == '_') + return $ shd:stl + +sepBy sep p = sepBy1 sep p +++ return [] + +sepBy1 sep p = do + x <- p + xs <- star (sep >> p) + return $ x:xs + +select = foldl1' (+|+) + +chainl p op a = chainl1 p op +++ return a +chainl1 p op = do {a <- p; rest a} + where + rest a = (do f <- op + b <- p + rest (f a b)) +++ return a + +extractResult err parse = + case parse of + (r,[]) : _ -> Right r + _ : rest -> extractResult err rest [] -> Left err diff --git a/src/Parse/Lexer.hs b/src/Parse/Lexer.hs --- a/src/Parse/Lexer.hs +++ b/src/Parse/Lexer.hs @@ -1,73 +1,84 @@ - -module Lexer (tokenize) where - -import Data.Char (isSymbol) -import Text.Parsec.Char -import Text.Parsec.Combinator -import Text.ParserCombinators.Parsec.Prim (parse,(<|>),many,try) -import Tokens - -token = do { integer >>= return . NUMBER } - <|> whitespace - <|> chrs [ ('(',LPAREN) , (')',RPAREN) - , ('{',LBRACE) , ('}',RBRACE) - , ('[',LBRACKET), (']',RBRACKET) - , (',',COMMA) , (';',SEMI), ('_',UNDERSCORE) - , ('\\',LAMBDA) , ('\x03BB',LAMBDA) ] - <|> reserveds [ ("True",TRUE), ("False",FALSE) - , ("if",IF), ("then",THEN), ("else",ELSE) - , ("case",CASE), ("of",OF), ("data", DATA) - , ("let",LET), ("in",IN) ] - <|> do { char '`'; v <- variable; char '`'; return $ OP v } - <|> anyOp - <|> do { char '"'; s <- many $ backslashed <|> satisfy (/='"'); char '"' - ; return $ STRING s} - <|> do { char '\''; c <- backslashed <|> satisfy (/='\''); char '\'' - ; return $ CHAR c} - <|> do { variable >>= return . ID } - <|> typeVar - <|> do { try $ string "\r\n" <|> string "\n"; return NEWLINE } - -str s t = do { try $ string s; return t } -chrs = choice . map (uncurry chr) -chr c t = do { char c; return t } -reserveds = choice . map (uncurry reserved) -reserved str token = - try $ do {string str; notFollowedBy $ alphaNum <|> char '_'; return token } -anyOp = do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!") - case op of { ".." -> return DOT2 - ; "->" -> return ARROW; "\8594" -> return ARROW - ; _ -> return $ OP op } - -backslashed = do { char '\\'; c <- satisfy (\x -> True) - ; return . read $ ['\'','\\',c,'\''] } - -integer = return . read =<< many1 digit -variable = do - shd <- letter <|> char '_' - stl <- many $ alphaNum <|> char '_' <|> char '\'' - return $ shd:stl -typeVar = do - shd <- upper - stl <- many $ alphaNum <|> char '_' <|> char '\'' - return . TYPE $ shd:stl - - ----- White Space and comments ---- - -whitespace = (lineComment >> return NEWLINE) <|> - (many1 (multiComment <|> many1 (char ' ')) >> return SPACES) -lineComment = do try $ string "--" - manyTill anyChar $ newline <|> (eof >> return '\n') - -multiComment = do { try $ string "{-"; closeComment } -closeComment = manyTill anyChar . choice $ - [ try $ string "-}" - , do { try $ string "{-"; closeComment; closeComment } - ] - -token_parser = many1 token - -tokenize s = case parse token_parser "" s of - Right ts -> Right ts - Left err -> Left $ "Syntax error: " ++ show err + +module Lexer (tokenize) where + +import Control.Applicative ((<|>), (<$>), (<*>)) +import Data.Char (isSymbol) +import Text.Parsec (Parsec, alphaNum, anyChar, char, choice, digit, eof, letter, + many, many1, manyTill, newline, notFollowedBy, oneOf, parse, + satisfy, string, try, upper) +import Tokens +import Control.Monad (liftM) + +token :: Parsec String u Token +token = NUMBER <$> integer + <|> whitespace + <|> chrs [ ('(',LPAREN) , (')',RPAREN) + , ('{',LBRACE) , ('}',RBRACE) + , ('[',LBRACKET), (']',RBRACKET) + , (',',COMMA) , (';',SEMI), ('_',UNDERSCORE) + , ('\\',LAMBDA) , ('\x03BB',LAMBDA) ] + <|> reserveds [ ("True",TRUE), ("False",FALSE) + , ("if",IF), ("then",THEN), ("else",ELSE) + , ("case",CASE), ("of",OF), ("data", DATA) + , ("let",LET), ("in",IN) ] + <|> do { char '`'; v <- variable; char '`'; return $ OP v } + <|> anyOp + <|> do { char '"'; s <- many $ backslashed <|> satisfy (/='"'); char '"' + ; return $ STRING s} + <|> do { char '\''; c <- backslashed <|> satisfy (/='\''); char '\'' + ; return $ CHAR c} + <|> (ID <$> variable) + <|> typeVar + <|> do { try $ string "\r\n" <|> string "\n"; return NEWLINE } + +chrs :: [(Char, Token)] -> Parsec String u Token +chrs = choice . map chr + where chr (c, t) = char c >> return t + +reserveds :: [(String, Token)] -> Parsec String u Token +reserveds = choice . map reserved + where reserved (s, t) = try $ string s >> + notFollowedBy (alphaNum <|> char '_') >> + return t + +anyOp = do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!") + case op of { ".." -> return DOT2 + ; "->" -> return ARROW; "\8594" -> return ARROW + ; _ -> return $ OP op } + +backslashed :: Parsec String u Char +backslashed = do { char '\\'; c <- anyChar + ; return . read $ ['\'','\\',c,'\''] } + +integer :: Parsec String u Int +integer = read <$> many1 digit + +variable :: Parsec String u String +variable = identifier $ letter <|> char '_' + +typeVar :: Parsec String u Token +typeVar = TYPE <$> identifier upper + +identifier :: Parsec String u Char -> Parsec String u String +identifier c = (:) <$> c <*> (many $ alphaNum <|> oneOf "_\'") + +---- White Space and comments ---- + +whitespace = (lineComment >> return NEWLINE) <|> + (many1 (multiComment <|> many1 (char ' ')) >> return SPACES) +lineComment = do try $ string "--" + manyTill anyChar $ newline <|> (eof >> return '\n') + +multiComment = do { try $ string "{-"; closeComment } +closeComment = manyTill anyChar . choice $ + [ try $ string "-}" + , do { try $ string "{-"; closeComment; closeComment } + ] + +tokenParser :: Parsec String u [Token] +tokenParser = many1 token + +tokenize :: String -> Either String [Token] +tokenize s = case parse tokenParser "" s of + Right ts -> Right ts + Left err -> Left $ "Syntax error: " ++ show err diff --git a/src/Parse/ParsePatterns.hs b/src/Parse/ParsePatterns.hs --- a/src/Parse/ParsePatterns.hs +++ b/src/Parse/ParsePatterns.hs @@ -1,30 +1,31 @@ -module ParsePatterns (pattern_term, pattern_expr) where +module ParsePatterns (patternTerm, patternExpr) where import Ast import Combinators import Data.Char (isUpper) import ParserLib import Tokens +import Control.Monad (liftM) -pattern_basic = +patternBasic = (t UNDERSCORE >> return PAnything) +|+ (do { x@(c:_) <- var ; - if isUpper c then star pattern_term >>= return . PData x + if isUpper c then PData x `liftM` star patternTerm else return $ PVar x }) -pattern_tuple = do - t LPAREN; ps <- sepBy1 (t COMMA) pattern_expr; t RPAREN +patternTuple = do + t LPAREN; ps <- sepBy1 (t COMMA) patternExpr; t RPAREN return $ case ps of { [p] -> p; _ -> ptuple ps } -pattern_cons = do - p <- pattern_term - colon <- optional $ op_parser (==":") +patternCons = do + p <- patternTerm + colon <- optional $ opParser (==":") case colon of - Just ":" -> pattern_expr >>= return . pcons p + Just ":" -> pcons p `liftM` patternExpr Nothing -> return p -pattern_list = do - t LBRACKET; ps <- sepBy (t COMMA) pattern_expr; t RBRACKET; return (plist ps) +patternList = do + t LBRACKET; ps <- sepBy (t COMMA) patternExpr; t RBRACKET; return (plist ps) -pattern_term = pattern_tuple +|+ pattern_list +|+ pattern_basic -pattern_expr = pattern_tuple +|+ pattern_list +|+ pattern_cons +patternTerm = patternTuple +|+ patternList +|+ patternBasic +patternExpr = patternTuple +|+ patternList +|+ patternCons diff --git a/src/Parse/ParseTypes.hs b/src/Parse/ParseTypes.hs --- a/src/Parse/ParseTypes.hs +++ b/src/Parse/ParseTypes.hs @@ -1,56 +1,69 @@ -module ParseTypes where - -import Ast -import Combinators -import Data.Char (isUpper) -import ParserLib -import Tokens -import Types - -type_var = do whitespace; t <- item - case t of - ID "Int" -> return IntT - ID "String" -> return StringT - ID "Char" -> return CharT - ID "Bool" -> return BoolT - ID (v:vs) -> return (if isUpper v then ADT (v:vs) [] - else VarT (v:vs)) - _ -> zero - -type_list = do t LBRACKET; ti <- type_expr; t RBRACKET; return $ ADT "List" [] -type_tuple = do { t LPAREN; ts <- sepBy (t COMMA) type_expr; t RPAREN - ; return $ case ts of { [t] -> t; _ -> ADT "Tuple" [] } } - -type_unamb = type_list +|+ type_tuple - -type_term = type_app +|+ type_unamb - -type_app = do - tipe <- type_var - case tipe of - ADT name _ -> star type_term >>= return . AppT name - _ -> return tipe - -type_expr = do t1 <- type_term - arrow <- optional $ t ARROW - case arrow of - Just ARROW -> type_term >>= return . LambdaT t1 - Nothing -> return t1 - -type_constr = do - name <- cap_var - args <- star (type_var +|+ type_unamb) - return (Constructor name args) - -constr (Constructor name args) = - (name, foldr Lambda (Data name (map Var argNames)) argNames) - where argNames = map (("arg"++) . show) [1..length args] - -datatype = do - t DATA - adt <- cap_var - vs <- star var - assign - ts <- sepBy1 (op_parser (=="|")) type_constr - -- (adt, foldr ForallT (ADT adt ts) vs) - return (map constr ts) +module ParseTypes where + +import Ast +import Combinators +import Data.Char (isUpper,isLower) +import Data.Maybe (fromMaybe) +import Data.List (lookup) +import ParserLib +import Tokens +import Types +import Guid +import Control.Monad (liftM) + +data ParseType = VarPT String + | LambdaPT ParseType ParseType + | ADTPT String [ParseType] + +listPT t = ADTPT "List" [t] +tuplePT ts = ADTPT ("Tuple" ++ show (length ts)) ts + +typeVar = liftM VarPT lowVar +typeList = do t LBRACKET; te <- typeExpr; t RBRACKET; return $ listPT te +typeTuple = do { t LPAREN; ts <- sepBy (t COMMA) typeExpr; t RPAREN + ; return $ case ts of { [t] -> t ; _ -> tuplePT ts } } +typeUnambiguous = typeList +|+ typeTuple + +typeSimple = liftM VarPT var +typeApp = do name <- capVar + args <- star (typeSimple +|+ typeUnambiguous) + return $ case args of + [] -> VarPT name + _ -> ADTPT name args + +typeExpr = do + t1 <- typeVar +|+ typeApp +|+ typeUnambiguous + arrow <- optional $ t ARROW + case arrow of Just ARROW -> LambdaPT t1 `liftM` typeExpr + Nothing -> return t1 + +typeConstructor = do name <- capVar + args <- star (typeSimple +|+ typeUnambiguous) + return $ (,) name args + +datatype = do + t DATA ; name <- capVar ; args <- star lowVar ; assign + tcs <- sepBy1 (opParser (=="|")) typeConstructor + return $ (map fst tcs , map toFunc tcs , toTypes name args tcs) + +beta = VarT `liftM` guid + +toFunc (name,args) = foldr Lambda (Data name $ map Var argNames) argNames + where argNames = map (("a"++) . show) [1..length args] + +toTypes name args constructors = do + pairs <- mapM (\x -> (,) x `liftM` guid) args + return $ map (toType pairs . ADT name $ map (VarT . snd) pairs) constructors + +toType pairs outType (name,args) = + foldr (==>) outType (map toT args) + where toT (LambdaPT t1 t2) = toT t1 ==> toT t2 + toT (ADTPT name args) = ADT name $ map toT args + toT (VarPT x@(c:_)) + | isLower c = VarT . fromMaybe (-1) $ lookup x pairs + | otherwise = case x of "Int" -> IntT + "Number" -> IntT + "String" -> StringT + "Char" -> CharT + "Bool" -> BoolT + _ -> ADT x [] diff --git a/src/Parse/Parser.hs b/src/Parse/Parser.hs --- a/src/Parse/Parser.hs +++ b/src/Parse/Parser.hs @@ -1,116 +1,121 @@ -module Parser where - -import Ast -import Binop (binops) -import Combinators -import Data.List (foldl') -import Lexer -import ParserLib -import ParseTypes (datatype) -import ParsePatterns -import Tokens - --------- Basic Terms -------- - -num_term = do { whitespace; t <- item - ; case t of { NUMBER n -> return $ Number n; _ -> zero } } -str_term = do { whitespace; t <- item - ; case t of { STRING cs -> return . list $ map Chr cs - ; _ -> zero } } - -var_term = do var >>= return . Var -chr_term = do chr >>= return . Chr - -true_term = do { t TRUE; return $ Boolean True } -false_term = do { t FALSE; return $ Boolean False } - - --------- Complex Terms -------- - -list_term = (do { t LBRACKET; start <- expr; t DOT2; end <- expr; t RBRACKET - ; return $ Range start end }) +|+ - (do { t LBRACKET; es <- sepBy (t COMMA) expr; t RBRACKET - ; return $ list es }) - -parens_term = (do { t LPAREN; op <- anyOp; t RPAREN - ; return . Lambda "x" . Lambda "y" $ - Binop op (Var "x") (Var "y") }) +|+ - (do { t LPAREN; es <- sepBy (t COMMA) expr; t RPAREN - ; return $ case es of { [e] -> e; _ -> tuple es } }) - -term = select [ num_term - , str_term - , accessible var_term - , chr_term - , true_term - , false_term - , list_term - , accessible parens_term - ] - --------- Applications -------- - -app_expr = do - tlist <- plus term - return $ case tlist of - t:[] -> t - t:ts -> foldl' App t ts - - --------- Expressions with infix operators -------- - -binary_expr = binops app_expr anyOp - - --------- Normal Expressions -------- - -if_expr = do { t IF; e1 <- expr; t THEN; e2 <- expr; t ELSE; e3 <- expr - ; return $ If e1 e2 e3 } - -lambda_expr = do { t LAMBDA; vs <- plus var; t ARROW; e <- expr - ; return $ foldr (\x e -> Lambda x e) e vs } - -assign_expr = whitespace >> assign_expr_nospace -assign_expr_nospace = do - p:ps <- plus pattern_term; assign; e <- expr - case p:ps of - PVar x : _ -> return (x, foldr func e ps) - where func PAnything e' = Lambda "_" e' - func (PVar x) e' = Lambda x e' - func p' e' = Lambda "_temp" (Case (Var "_temp") [(p', e')]) --- _ : [] -> return $ \hole -> Case e [(p,hole)] - _ -> zero - -let_expr = do - t LET; brace <- optional $ t LBRACE - case brace of - Nothing -> do f <- assign_expr; t IN; e <- expr; return (Let [f] e) - Just LBRACE -> do fs <- sepBy1 (t SEMI) assign_expr; t RBRACE; t IN; - e <- expr; return (Let fs e) - -case_expr = do - t CASE; e <- expr; t OF; t LBRACE - cases <- sepBy1 (t SEMI) - (do { p <- pattern_expr; t ARROW; e <- expr; return (p,e) }) - t RBRACE - return $ Case e cases - --------- All Expressions -------- - -expr = select [ let_expr - , binary_expr - , if_expr - , case_expr - , lambda_expr - ] - -def = assign_expr_nospace >>= return . (:[]) - -defs = do - ds <- plus (whitespace >> plus (sat (==NEWLINE)) >> def +|+ datatype) - star $ sat (==NEWLINE) +|+ sat (==SPACES) - return $ Let (concat ds) (Var "main") - -err = "Parse Error: Better error messages to come!" -toExpr = extractResult err . parse expr -toDefs = extractResult err . parse defs . (NEWLINE:) +module Parser where + +import Ast +import Binop (binops) +import Combinators +import Control.Monad (liftM) +import Data.List (foldl') +import Guid +import Lexer +import ParserLib +import ParseTypes (datatype) +import ParsePatterns +import Tokens +import Types (Type (VarT)) + +-------- Basic Terms -------- + +numTerm = do { whitespace; t <- item + ; case t of { NUMBER n -> return $ Number n; _ -> zero } } +strTerm = do { whitespace; t <- item + ; case t of { STRING cs -> return $ Str cs + ; _ -> zero } } + +varTerm = Var `liftM` var +chrTerm = Chr `liftM` chr + +trueTerm = do { t TRUE; return $ Boolean True } +falseTerm = do { t FALSE; return $ Boolean False } + + +-------- Complex Terms -------- + +listTerm = (do { t LBRACKET; start <- expr; t DOT2; end <- expr; t RBRACKET + ; return $ Range start end }) +|+ + (do { t LBRACKET; es <- sepBy (t COMMA) expr; t RBRACKET + ; return $ list es }) + +parensTerm = (do { t LPAREN; op <- anyOp; t RPAREN + ; return . Lambda "x" . Lambda "y" $ + Binop op (Var "x") (Var "y") }) +|+ + (do { t LPAREN; es <- sepBy (t COMMA) expr; t RPAREN + ; return $ case es of { [e] -> e; _ -> tuple es } }) + +term = select [ numTerm + , strTerm + , accessible varTerm + , chrTerm + , trueTerm + , falseTerm + , listTerm + , accessible parensTerm + ] + +-------- Applications -------- + +appExpr = do + tlist <- plus term + return $ case tlist of + t:[] -> t + t:ts -> foldl' App t ts + + +-------- Expressions with infix operators -------- + +binaryExpr = binops appExpr anyOp + + +-------- Normal Expressions -------- + +ifExpr = do { t IF; e1 <- expr; t THEN; e2 <- expr; t ELSE; e3 <- expr + ; return $ If e1 e2 e3 } + +lambdaExpr = do { t LAMBDA; vs <- plus var; t ARROW; e <- expr + ; return $ foldr Lambda e vs } + +assignExpr = whitespace >> assignExprNospace +assignExprNospace = do + p:ps <- plus patternTerm; assign; e <- expr + case p:ps of + PVar x : _ -> return (x, foldr func e ps) + where func PAnything e' = Lambda "_" e' + func (PVar x) e' = Lambda x e' + func p' e' = Lambda "_temp" (Case (Var "_temp") [(p', e')]) +-- _ : [] -> return $ \hole -> Case e [(p,hole)] + _ -> zero + +letExpr = do + t LET; brace <- optional $ t LBRACE + case brace of + Nothing -> do f <- assignExpr; t IN; e <- expr; return (Let [f] e) + Just LBRACE -> do fs <- sepBy1 (t SEMI) assignExpr; t RBRACE; t IN; + e <- expr; return (Let fs e) + +caseExpr = do + t CASE; e <- expr; t OF; t LBRACE + cases <- sepBy1 (t SEMI) + (do { p <- patternExpr; t ARROW; e <- expr; return (p,e) }) + t RBRACE + return $ Case e cases + +-------- All Expressions -------- + +expr = select [ letExpr + , binaryExpr + , ifExpr + , caseExpr + , lambdaExpr + ] + +def = do (f,e) <- assignExprNospace + return ([f], [e], guid >>= \x -> return [VarT x]) + +defs = do + (fss,ess,tss) <- unzip3 `liftM` plus (whitespace >> plus (sat (==NEWLINE)) >> def +|+ datatype) + let (fs,es,ts) = (concat fss, concat ess, concat `liftM` sequence tss) + star $ sat (==NEWLINE) +|+ sat (==SPACES) + return (Let (zip fs es) (Var "main"), liftM (zip fs) ts) + +err = "Parse Error: Better error messages to come!" +toExpr = extractResult err . parse expr +toDefs = extractResult err . parse defs . (NEWLINE:) diff --git a/src/Parse/ParserLib.hs b/src/Parse/ParserLib.hs --- a/src/Parse/ParserLib.hs +++ b/src/Parse/ParserLib.hs @@ -1,36 +1,38 @@ -module ParserLib where - -import Ast -import Combinators -import Data.Char (isUpper) -import Tokens - -var_noSpace = do { t <- item; case t of { ID v -> return v; _ -> zero } } -var = whitespace >> var_noSpace -cap_var = do - whitespace; t <- item - case t of { ID (v:vs) -> if isUpper v then return (v:vs) else zero } - -chr = do { whitespace; t <- item; case t of { CHAR c -> return c; _ -> zero } } - -t_noSpace token = sat (==token) -t_withSpace token = forcedWS >> sat (==token) -t token = whitespace >> sat (==token) - -forcedWS = do { sat (==SPACES); star nl_space } +|+ plus nl_space - where nl_space = plus (sat (==NEWLINE)) >> sat (==SPACES) -whitespace = optional forcedWS - -accessible exp = do - e <- exp - access <- optional $ op_parser_nospace (==".") - case access of - Just "." -> accessible (var >>= return . Access e) - Nothing -> return e - -op_parser_nospace pred = - do { t <- item - ; case t of { OP op -> if pred op then return op else zero; _ -> zero } } -op_parser pred = whitespace >> op_parser_nospace pred -anyOp = op_parser (const True) -assign = op_parser (=="=") +module ParserLib where + +import Ast +import Combinators +import Data.Char (isUpper,isLower) +import Control.Monad (liftM,guard) +import Tokens + +varNoSpace = do { t <- item; case t of { ID v -> return v; _ -> zero } } +var = whitespace >> varNoSpace +capVar = do whitespace; t <- item + case t of { ID (v:vs) -> guard (isUpper v) >> return (v:vs) ; _ -> zero } +lowVar = do whitespace; t <- item + case t of { ID (v:vs) -> guard (isLower v) >> return (v:vs) ; _ -> zero } + +chr = do { whitespace; t <- item; case t of { CHAR c -> return c; _ -> zero } } + +tNoSpace token = sat (==token) +tWithSpace token = forcedWS >> sat (==token) +t token = whitespace >> sat (==token) + +forcedWS = do { sat (==SPACES); star nl_space } +|+ plus nl_space + where nl_space = plus (sat (==NEWLINE)) >> sat (==SPACES) +whitespace = optional forcedWS + +accessible exp = do + e <- exp + access <- optional $ opParserNospace (==".") + case access of + Just "." -> accessible (Access e `liftM` var) + Nothing -> return e + +opParserNospace pred = + do { t <- item + ; case t of { OP op -> if pred op then return op else zero; _ -> zero } } +opParser pred = whitespace >> opParserNospace pred +anyOp = opParser (const True) +assign = opParser (=="=") diff --git a/src/Rename.hs b/src/Rename.hs --- a/src/Rename.hs +++ b/src/Rename.hs @@ -1,73 +1,88 @@ -module Rename (rename) where - -import Ast -import Control.Arrow (first) -import Control.Monad.State -import Data.Char (isLower) -import Data.List (mapAccumL) -import Data.Functor.Identity - -rename expr = evalState (rename' id expr) 0 - -guid :: State Int Int -guid = do n <- get - put (n+1) - return n - -rename' env expr = - case expr of - Range e1 e2 -> do - re1 <- rename' env e1; re2 <- rename' env e2 - return $ Range re1 re2 - Access e x -> do - re <- rename' env e - return $ Access re x - Binop op e1 e2 -> - do let rop = if isLower (head op) || '_' == head op then env op else op - re1 <- rename' env e1; re2 <- rename' env e2 - return $ Binop rop re1 re2 - Lambda x e -> do (rx, env') <- extend env x - rename' env' e >>= return . Lambda rx - App e1 e2 -> do - re1 <- rename' env e1; re2 <- rename' env e2 - return $ App re1 re2 - If e1 e2 e3 -> do - re1 <- rename' env e1; re2 <- rename' env e2; re3 <- rename' env e3 - return $ If re1 re2 re3 - Lift e es -> do - re <- rename' env e - mapM (rename' env) es >>= return . Lift re - Fold e1 e2 e3 -> do - re1 <- rename' env e1; re2 <- rename' env e2; re3 <- rename' env e3 - return $ Fold re1 re2 re3 - Async e -> rename' env e >>= return . Async - Let defs e -> do - let (vs,es) = unzip defs - env' <- foldM (\acc x -> extend acc x >>= return . snd) env vs - es' <- mapM (rename' env') es; re <- rename' env' e - return $ Let (zip (map env' vs) es') re - Var x -> return . Var $ env x - Data name es -> mapM (rename' env) es >>= return . Data name - Case e cases -> do - re <- rename' env e - mapM (pattern_rename env) cases >>= return . (Case re) - _ -> return expr - -extend env x = do - n <- guid - let rx = x ++ "_" ++ show n - return (rx, (\y -> if y == x then rx else env y)) - -pattern_extend pattern env = - case pattern of - PAnything -> return (PAnything, env) - PVar x -> extend env x >>= return . first PVar - PData name ps -> - foldM f ([],env) ps >>= return . first (PData name . reverse) - where f (rps,env') p = do (rp,env'') <- pattern_extend p env' - return (rp:rps, env'') - -pattern_rename env (p,e) = do - (rp,env') <- pattern_extend p env - re <- rename' env' e +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Rename (rename) where + +import Ast +import Control.Arrow (first) +import Control.Monad (ap, liftM, foldM, mapM, Monad) +import Control.Monad.State (evalState, State, get, put) +import Data.Char (isLower) +import Guid + +rename :: Expr -> Expr +rename = run . rename' id + +rename' :: (String -> String) -> Expr -> GuidCounter Expr +rename' env expr = + case expr of + + Range e1 e2 -> Range `liftM` rnm e1 + `ap` rnm e2 + + Access e x -> Access `liftM` rnm e + `ap` return x + + Binop op@(h:_) e1 e2 -> + let rop = if isLower h || '_' == h + then env op + else op + in Binop rop `liftM` rnm e1 + `ap` rnm e2 + + Lambda x e -> do + (rx, env') <- extend env x + Lambda rx `liftM` rename' env' e + + App e1 e2 -> App `liftM` rnm e1 + `ap` rnm e2 + + If e1 e2 e3 -> If `liftM` rnm e1 + `ap` rnm e2 + `ap` rnm e3 + + Lift e es -> Lift `liftM` rnm e + `ap` mapM rnm es + + Fold e1 e2 e3 -> Fold `liftM` rnm e1 + `ap` rnm e2 + `ap` rnm e3 + + Async e -> Async `liftM` rnm e + + Let defs e -> do + let (vs,es) = unzip defs + env' <- foldM (\acc x -> snd `liftM` extend acc x) env vs + es' <- mapM (rename' env') es; re <- rename' env' e + return $ Let (zip (map env' vs) es') re + + Var x -> return . Var $ env x + + Data name es -> Data name `liftM` mapM rnm es + + Case e cases -> Case `liftM` rnm e + `ap` mapM (patternRename env) cases + + _ -> return expr + + where rnm = rename' env + +extend :: (String -> String) -> String -> GuidCounter (String, String -> String) +extend env x = do + n <- guid + let rx = x ++ "_" ++ show n + return (rx, \y -> if y == x then rx else env y) + +patternExtend :: Pattern -> (String -> String) -> GuidCounter (Pattern, String -> String) +patternExtend pattern env = + case pattern of + PAnything -> return (PAnything, env) + PVar x -> first PVar `liftM` extend env x + PData name ps -> + first (PData name . reverse) `liftM` foldM f ([], env) ps + where f (rps,env') p = do (rp,env'') <- patternExtend p env' + return (rp:rps, env'') + +patternRename :: (String -> String) -> (Pattern, Expr) -> GuidCounter (Pattern, Expr) +patternRename env (p,e) = do + (rp,env') <- patternExtend p env + re <- rename' env' e return (rp,re) diff --git a/src/Replace.hs b/src/Replace.hs deleted file mode 100644 --- a/src/Replace.hs +++ /dev/null @@ -1,50 +0,0 @@ -module Replace (replace, depth) where - -import Ast -import Data.Set (singleton,empty,unions,member) - -replace y v expr = - let f = replace y v in - case expr of - Range e1 e2 -> Range (f e1) (f e2) - Access e x -> Access (f e) x - Binop op e1 e2 -> Binop op (f e1) (f e2) - App e1 e2 -> App (f e1) (f e2) - If e1 e2 e3 -> If (f e1) (f e2) (f e3) - Lift e es -> Lift (f e) (map f es) - Fold e1 e2 e3 -> Fold (f e1) (f e2) (f e3) - Async e -> Async (f e) - Let defs e -> if elem y vs then Let defs e else Let (zip vs (map f es)) (f e) - where (vs,es) = unzip defs - Var x -> if x == y then v else Var x - Data name es -> Data name (map f es) - Case e cases -> Case (f e) $ map (case_replace y v) cases - _ -> expr - -case_replace y v (p,e) = - if member y (pattern_vars p) then (p,e) else (p, replace y v e) - -pattern_vars pattern = - case pattern of - PData _ ps -> unions (map pattern_vars ps) - PVar x -> singleton x - PAnything -> empty - -depth = depth' 0 -depth' d expr = - let f = depth' (d+1) in - case expr of - Range e1 e2 -> max (f e1) (f e2) - Access e x -> f e - Binop op e1 e2 -> max (f e1) (f e2) - Lambda x e -> f e - App e1 e2 -> max (f e1) (f e2) - If e1 e2 e3 -> maximum [f e1, f e2, f e3] - Lift e es -> maximum $ f e : map f es - Fold e1 e2 e3 -> maximum [f e1, f e2, f e3] - Async e -> f e - Let defs e -> let (_,es) = unzip defs in maximum $ f e : map f es - Data "Cons" es -> maximum $ map (depth' d) es - Data name es -> maximum $ 1 : map f es - Case e cases -> maximum $ f e : map (f . snd) cases - _ -> d diff --git a/src/Server.hs b/src/Server.hs --- a/src/Server.hs +++ b/src/Server.hs @@ -1,38 +1,37 @@ -{-# LANGUAGE OverloadedStrings #-} + module Main where -import Prelude hiding (head,span,id) import Control.Monad (msum,guard) import Control.Monad.Trans (MonadIO(liftIO)) import Data.List (isPrefixOf, isSuffixOf) -import Happstack.Server hiding (body) +import Happstack.Server import Happstack.Server.Compression import System.Environment -import Text.Blaze.Html5 hiding (map) -import Text.Blaze.Html5.Attributes hiding (title,span,dir,style) -import Text.Blaze.Internal -import ToHtml +import Language.Elm serve :: String -> IO () serve libLoc = do - putStrLn "Elm Server 0.1.0: running at " + putStrLn "Elm Server 0.1.1: running at " simpleHTTP nullConf $ do compressedResponseFilter msum [ uriRest (serveElm libLoc) , serveDirectory EnableBrowsing [] "." ] +pageTitle fp = + reverse . takeWhile (/='/') . drop 1 . dropWhile (/='.') $ reverse fp + serveElm libLoc fp = do let ('/':path) = fp guard (".elm" `isSuffixOf` path) content <- liftIO (readFile path) - ok . toResponse $ compileToHtml libLoc path content + ok . toResponse $ compileToHtml libLoc (pageTitle path) content main = getArgs >>= parse parse ("--help":_) = putStrLn usage -parse ("--version":_) = putStrLn "The Elm Server 0.1.0" +parse ("--version":_) = putStrLn "The Elm Server 0.1.1" parse [] = serve "/elm-mini.js" parse [arg] | "--runtime-location=" `isPrefixOf` arg = diff --git a/src/ToHtml.hs b/src/ToHtml.hs deleted file mode 100644 --- a/src/ToHtml.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module ToHtml (compileToHtml) where - -import CompileToJS -import Data.Monoid (mempty) -import GenerateHtml -import Network.HTTP.Base (urlEncode) -import Text.Blaze.Html5 hiding (map) -import qualified Text.Blaze.Html5 as H -import Text.Blaze.Html5.Attributes -import qualified Text.Blaze.Html5.Attributes as A - -pageTitle fp = - reverse . takeWhile (/='/') . drop 1 . dropWhile (/='.') $ reverse fp - - -compileToHtml :: String -> String -> String -> Html -compileToHtml libLoc fileName source = - generateHtml libLoc (pageTitle fileName) (compileToJS source) diff --git a/src/Types/Constrain.hs b/src/Types/Constrain.hs new file mode 100644 --- /dev/null +++ b/src/Types/Constrain.hs @@ -0,0 +1,77 @@ + +module Constrain where + +import Ast +import Types +import Data.List (foldl') +import qualified Data.Set as Set +import qualified Data.Map as Map +import Control.Monad (liftM,mapM) +import Control.Monad.State (evalState) +import Guid + +data Constraint = Type :=: Type + | Type :<: Type + | Type :<<: Scheme + deriving (Eq, Ord, Show) + +beta = VarT `liftM` guid +unionA = Map.unionWith (++) +unionsA = Map.unionsWith (++) + +constrain hints expr = do + (as,cs,t) <- inference expr + hs <- hints + let cMap = Map.intersectionWith (\t -> map (:<: t)) (Map.fromList hs) as + return $ Set.toList cs ++ (concat . map snd $ Map.toList cMap) + +inference (Var x) = + do b <- beta + return (Map.singleton x [b], Set.empty, b) +inference (App e1 e2) = + do (a1,c1,t1) <- inference e1 + (a2,c2,t2) <- inference e2 + b <- beta + return ( unionA a1 a2 + , Set.unions [c1,c2,Set.singleton $ t1 :=: (LambdaT t2 b)] + , b ) +inference (Lambda x e) = + do (a,c,t) <- inference e + b <- beta + return ( Map.delete x a + , Set.union c . Set.fromList . map (:=: b) $ + Map.findWithDefault [] x a + , LambdaT b t ) +inference (Let defs e) = + do (a,c,t) <- inference e + let (xs,es) = unzip defs + (as,cs,ts) <- unzip3 `liftM` mapM inference es + let assumptions = unionsA (a:as) + let f x t = map (:<: t) $ Map.findWithDefault [] x assumptions + let constraints = Set.fromList . concat $ zipWith f xs ts + return ( foldr Map.delete assumptions xs + , Set.unions $ c:constraints:cs + , t ) + +inference (If e1 e2 e3) = + do (a1,c1,t1) <- inference e1 + (a2,c2,t2) <- inference e2 + (a3,c3,t3) <- inference e3 + return ( unionsA [a1,a2,a3] + , Set.unions [c1,c2,c3, Set.fromList [ t1 :=: BoolT, t2 :=: t3 ] ] + , t2 ) + +inference (Data name es) = inference $ foldl' App (Var name) es +inference (Binop op e1 e2) = inference (Var op `App` e1 `App` e2) +inference (Access (Var x) y) = inference . Var $ x ++ "." ++ y +inference (Range e1 e2) = inference (Var "elmRange" `App` e1 `App` e2) + +inference other = + case other of + Number _ -> primitive IntT + Chr _ -> primitive CharT + Str _ -> primitive string + Boolean _ -> primitive BoolT + _ -> beta >>= primitive + +primitive t = return (Map.empty, Set.empty, t) diff --git a/src/Types/Hints.hs b/src/Types/Hints.hs new file mode 100644 --- /dev/null +++ b/src/Types/Hints.hs @@ -0,0 +1,157 @@ + +module Hints (hints) where + +import Control.Monad (liftM,mapM) +import Control.Arrow (first) +import Types +import Guid + + +-------- Text and Elements -------- + +str2elem = hasType (string ==> element) [ "image","video","plainText" ] + +textToText = [ "header", "italic", "bold", "underline" + , "overline", "strikeThrough", "monospace" ] + +textAttrs = [ "toText" -: string ==> text + , "link" -: string ==> text ==> text + , "Text.height" -: IntT ==> text ==> text + ] ++ hasType (text ==> text) textToText + +elements = let iee = IntT ==> element ==> element in + [ "flow" -: direction ==> listOf element ==> element + , "layers" -: listOf element ==> element + , "text" -: text ==> element + , "opacity" -: iee + , "width" -: iee + , "height" -: iee + , "size" -: IntT ==> iee + , "box" -: iee + , "centeredText" -: text ==> element + , "justifiedText" -: text ==> element + , "collage" -: IntT ==> IntT ==> listOf form ==> element + ] + +directions = hasType direction ["up","down","left","right","inward","outward"] +colors = [ "rgb" -: IntT ==> IntT ==> IntT ==> color + , "rgba" -: IntT ==> IntT ==> IntT ==> IntT ==> color + ] ++ hasType color ["red","green","blue","black","white"] + +lineTypes = [ "line" -: listOf point ==> line + , "customLine" -: listOf IntT ==> color ==> line ==> form + ] ++ hasType (color ==> line ==> form) ["solid","dashed","dotted"] + +shapes = [ "polygon" -: listOf point ==> point ==> shape + , "filled" -: color ==> shape ==> form + , "outlined" -: color ==> shape ==> form + , "customOutline" -: listOf IntT ==> color ==> shape ==> form + ] ++ hasType (IntT ==> IntT ==> point ==> shape) ["ngon","rect","oval"] + + +-------- Signals -------- + +sig ts = fn ts ==> fn (map signalOf ts) + where fn = foldr1 (==>) + +signals = sequence + [ do ts <- vars 1 ; "constant" -:: sig ts + , do ts <- vars 2 ; "lift" -:: sig ts + , do ts <- vars 3 ; "lift2" -:: sig ts + , do ts <- vars 4 ; "lift3" -:: sig ts + , do ts <- vars 5 ; "lift4" -:: sig ts + , do [a,b] <- vars 2 + "foldp" -:: (a ==> b ==> b) ==> b ==> signalOf a ==> signalOf b + ] + +concreteSignals = + [ "Mouse.position" -: signalOf point + , "Mouse.x" -: signalOf IntT + , "Mouse.y" -: signalOf IntT + , "Mouse.isDown" -: signalOf BoolT + , "Mouse.isClicked" -: signalOf BoolT + , "Window.dimensions" -: signalOf point + , "Window.width" -: signalOf IntT + , "Window.height" -: signalOf IntT + , "Input.textField" -: string ==> tupleOf [element, signalOf string] + , "Input.password" -: string ==> tupleOf [element, signalOf string] + , "Input.textArea" -: IntT ==> IntT ==> tupleOf [element, signalOf string] + , "Input.stringDropDown" -: listOf string ==> tupleOf [element, signalOf string] + ] + +-------- Math and Binops -------- + +iii = IntT ==> IntT ==> IntT +xxb x = x ==> x ==> BoolT + +math = + hasType (IntT ==> iii) ["clamp"] ++ + hasType iii ["+", "-", "*", "/","rem","mod","logBase","max","min"] ++ + hasType (IntT ==> IntT) ["sin","cos","tan","asin","acos","atan","sqrt","abs"] + +bool = + [ "not" -: BoolT ==> BoolT ] ++ + hasType (xxb BoolT) ["&&","||"] ++ + hasType (xxb IntT) ["==","/=","<",">","<=",">="] + + +-------- Polymorphic Functions -------- + +var = VarT `liftM` guid +vars n = mapM (const var) [1..n] + +infix 8 -:: +name -:: tipe = return $ name -: tipe + +funcs = sequence + [ do a <- var ; "id" -:: a ==> a + , do [a,b,c] <- vars 3 ; "flip" -:: (a ==> b ==> c) ==> (b ==> a ==> c) + , do [a,b,c] <- vars 3 ; "." -:: (b ==> c) ==> (a ==> b) ==> (a ==> c) + , do [a,b] <- vars 2 ; "$" -:: (a ==> b) ==> a ==> b + , do a <- var ; ":" -:: a ==> listOf a ==> listOf a + , do a <- var ; "++" -:: listOf a ==> listOf a ==> listOf a + , do a <- var ; "Cons" -:: a ==> listOf a ==> listOf a + , do a <- var ; "Nil" -:: listOf a + , do a <- var ; "Just" -:: a ==> ADT "Maybe" [a] + , do a <- var ; "Nothing" -:: ADT "Maybe" [a] + , "elmRange" -:: IntT ==> IntT ==> listOf IntT + ] + +ints = map (-: (listOf IntT ==> IntT)) [ "sum","product","maximum","minimum" ] + +lists = liftM (map (first ("List."++)) . (++ints)) . sequence $ + [ "and" -:: listOf BoolT ==> BoolT + , "or" -:: listOf BoolT ==> BoolT + , "sort" -:: listOf IntT ==> listOf IntT + , do a <- var ; "head" -:: listOf a ==> a + , do a <- var ; "tail" -:: listOf a ==> listOf a + , do a <- var ; "length" -:: listOf a ==> IntT + , do a <- var ; "filter" -:: (a ==> BoolT) ==> listOf a ==> listOf a + , do a <- var ; "foldr1" -:: (a ==> a ==> a) ==> listOf a ==> a + , do a <- var ; "foldl1" -:: (a ==> a ==> a) ==> listOf a ==> a + , do a <- var ; "scanl1" -:: (a ==> a ==> a) ==> listOf a ==> a + , do a <- var ; "forall" -:: (a ==> BoolT) ==> listOf a ==> BoolT + , do a <- var ; "exists" -:: (a ==> BoolT) ==> listOf a ==> BoolT + , do a <- var ; "concat" -:: listOf (listOf a) ==> listOf a + , do a <- var ; "reverse" -:: listOf a ==> listOf a + , do a <- var ; "intersperse" -:: a ==> listOf a ==> listOf a + , do a <- var ; "intercalate" -:: listOf a ==> listOf(listOf a) ==> listOf a + , do [a,b] <- vars 2 ; "zip" -:: listOf a ==>listOf b ==>listOf(tupleOf [a,b]) + , do [a,b] <- vars 2 ; "map" -:: (a ==> b) ==> listOf a ==> listOf b + , do [a,b] <- vars 2 ; "foldr" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b + , do [a,b] <- vars 2 ; "foldl" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b + , do [a,b] <- vars 2 ; "scanl" -:: (a==>b==>b)==>b==>listOf a==>listOf b + , do [a,b] <- vars 2 ; "concatMap" -:: (a==>listOf b)==>listOf a ==> listOf b + , do [a,b,c] <- vars 3 + "zipWith" -:: (a ==> b ==> c) ==> listOf a ==> listOf b ==> listOf c + ] + + +-------- Everything -------- + +hints = do + fs <- funcs ; ls <- lists ; ss <- signals + return $ concat [ fs, ls, ss, math, bool, str2elem, textAttrs + , elements, directions, colors, lineTypes, shapes + , concreteSignals + ] diff --git a/src/Types/Types.hs b/src/Types/Types.hs --- a/src/Types/Types.hs +++ b/src/Types/Types.hs @@ -1,34 +1,58 @@ - -module Types where - -import Data.List (intercalate) -import Data.IORef -import System.IO.Unsafe - -data Type = IntT - | StringT - | CharT - | BoolT - | LambdaT Type Type - | VarT String - | ForallT String Type - | AppT String [Type] - | ADT String [Type] - deriving (Eq) - -data Constructor = Constructor String [Type] deriving (Eq, Show) - -instance Show Type where - show t = - case t of - { IntT -> "Int" - ; StringT -> "String" - ; CharT -> "Char" - ; BoolT -> "Bool" - ; LambdaT t1 t2 -> show t1 ++ " -> " ++ show t2 - ; VarT x -> x - ; ForallT x t' -> "forall " ++ x ++ ". " ++ show t' - ; AppT name args -> name ++ " " ++ intercalate " " (map show args) - ; ADT name constrs -> - name ++ " = " ++ intercalate " | " (map show constrs) - } + +module Types where + +import Data.List (intercalate) +import qualified Data.Set as Set + +type X = Int + +data Type = IntT + | StringT + | CharT + | BoolT + | LambdaT Type Type + | VarT X + | ADT String [Type] + deriving (Eq, Ord) + +data Scheme = Forall (Set.Set X) Type deriving (Eq, Ord, Show) + +element = ADT "Element" [] +direction = ADT "Direction" [] + +form = ADT "Form" [] +line = ADT "Line" [] +shape = ADT "Shape" [] +color = ADT "Color" [] +text = ADT "List" [ADT "Text" []] +point = tupleOf [IntT,IntT] + +listOf t = ADT "List" [t] +signalOf t = ADT "Signal" [t] +tupleOf ts = ADT ("Tuple" ++ show (length ts)) ts +string = listOf CharT + +infixr ==> +t1 ==> t2 = LambdaT t1 t2 + +infix 8 -: +name -: tipe = (,) name tipe + +hasType t = map (-: t) + +parens = ("("++) . (++")") + +instance Show Type where + show t = + case t of + { IntT -> "Int" + ; StringT -> "String" + ; CharT -> "Char" + ; BoolT -> "Bool" + ; LambdaT t1@(LambdaT _ _) t2 -> parens (show t1) ++ " -> " ++ show t2 + ; LambdaT t1 t2 -> show t1 ++ " -> " ++ show t2 + ; VarT x -> show x + ; ADT "List" [tipe] -> "[" ++ show tipe ++ "]" + ; ADT name [] -> name + ; ADT name cs -> parens $ name ++ " " ++ unwords (map show cs) + } diff --git a/src/Types/Unify.hs b/src/Types/Unify.hs new file mode 100644 --- /dev/null +++ b/src/Types/Unify.hs @@ -0,0 +1,71 @@ + +module Unify where + +import Constrain +import Control.Arrow (second) +import Control.Monad (liftM) +import Data.List (foldl') +import qualified Data.Set as Set +import Guid +import Types + +import Control.DeepSeq + +unify hints expr = run $ do + cs <- constrain hints expr + solver cs [] + +solver [] subs = return $ Right subs + +-------- Destruct Type-constructors -------- + +solver ((t1@(ADT n1 ts1) :=: t2@(ADT n2 ts2)) : cs) subs = + if n1 /= n2 then uniError t1 t2 else + solver (zipWith (:=:) ts1 ts2 ++ cs) subs +solver ((LambdaT t1 t2 :=: LambdaT t1' t2') : cs) subs = + solver ([ t1 :=: t1', t2 :=: t2' ] ++ cs) subs + +-------- Type-equality -------- + +solver ((VarT x :=: t) : cs) subs = + solver (map (cSub x t) cs) . map (second $ tSub x t) $ (x,t):subs +solver ((t :=: VarT x) : cs) subs = + solver (map (cSub x t) cs) . map (second $ tSub x t) $ (x,t):subs +solver ((t1 :=: t2) : cs) subs = + if t1 /= t2 then uniError t1 t2 else solver cs subs + +-------- subtypes -------- + +solver ((t1 :<: t2) : cs) subs = do + let f x = do y <- guid ; return (x,VarT y) + pairs <- mapM f . Set.toList $ getVars t2 + let t2' = foldr (uncurry tSub) t2 pairs + solver ((t1 :=: t2') : cs) subs + + +cSub k v (t1 :=: t2) = force $ tSub k v t1 :=: tSub k v t2 +cSub k v (t1 :<: t2) = force $ tSub k v t1 :<: tSub k v t2 + +tSub k v t@(VarT x) = if k == x then v else t +tSub k v (LambdaT t1 t2) = force $ LambdaT (tSub k v t1) (tSub k v t2) +tSub k v (ADT name ts) = ADT name (map (force . tSub k v) ts) +tSub _ _ t = t + +getVars (VarT x) = Set.singleton x +getVars (LambdaT t1 t2) = Set.union (getVars t1) (getVars t2) +getVars (ADT name ts) = Set.unions $ map getVars ts +getVars _ = Set.empty + +uniError t1 t2 = + return . Left $ "Type error: " ++ show t1 ++ " is not equal to " ++ show t2 + +force x = x `deepseq` x + +instance NFData Constraint where + rnf (t1 :=: t2) = t1 `deepseq` t2 `deepseq` () + rnf (t1 :<: t2) = t1 `deepseq` t2 `deepseq` () + +instance NFData Type where + rnf (LambdaT t1 t2) = t1 `deepseq` t2 `deepseq` () + rnf (ADT _ ts) = foldl' (\acc x -> x `deepseq` acc) () ts + rnf t = t `seq` ()