diff --git a/Elm.cabal b/Elm.cabal --- a/Elm.cabal +++ b/Elm.cabal @@ -1,6 +1,6 @@ Name: Elm -Version: 0.2.0.1 +Version: 0.3.0 Synopsis: The Elm language module. Description: Elm aims to make client-side web-development more pleasant. It is a statically/strongly typed, functional reactive @@ -21,7 +21,8 @@ Build-type: Simple ---Extra-source-files: README.md +Extra-source-files: changelog.txt +Data-files: elm-runtime-0.3.0.js Cabal-version: >=1.8 source-repository head @@ -31,19 +32,22 @@ Library exposed-modules: Language.Elm, Language.Elm.Quasi - Hs-Source-Dirs: src, src/Parse, src/Types + Hs-Source-Dirs: src, src/Parse, src/Types, src/Gen other-modules: Ast, CompileToJS, ExtractNoscript, GenerateHtml, Guid, + Optimize, Initialize, Rename, Binops, Patterns, Parser, ParseLib, + ParseExpr, ParseTypes, + ParseModules, Types, Constrain, Hints, @@ -64,19 +68,22 @@ Executable elm Main-is: Compiler.hs - Hs-Source-Dirs: src, src/Parse, src/Types + Hs-Source-Dirs: src, src/Parse, src/Types, src/Gen other-modules: Ast, CompileToJS, ExtractNoscript, GenerateHtml, Guid, + Optimize, Initialize, Rename, Binops, Patterns, Parser, ParseLib, + ParseExpr, ParseTypes, + ParseModules, Types, Constrain, Hints, @@ -90,4 +97,5 @@ parsec >= 3.1.1, blaze-html == 0.5.0.*, blaze-markup == 0.5.1.*, - deepseq + deepseq, + cmdargs diff --git a/changelog.txt b/changelog.txt new file mode 100644 --- /dev/null +++ b/changelog.txt @@ -0,0 +1,34 @@ +Release 0.3.0 +============= + +Major Changes (Read this part!) +------------------------------- + +* Add a basic module system. +* Elm's JavaScript runtime is now distributed with the elm package. + Previously it was available for download as an unversioned JavaScript + file (elm-mini.js). It is now installed with the elm compiler as + elm-runtime-0.3.0.js. Be sure to serve the Elm runtime system that matches + the version of the compiler used to generate JavaScript. When working + locally, the compiler will automatically use your local copy of this file. +* BREAKING CHANGE: rgb and rgba (in the color module) now take their red, + green, and blue components as integers between 0 and 255 inclusive. +* Improve error messages for parse errors and runtime errors. + + +New Functions and Other Additions +--------------------------------- + +* Add support for keyboard events: Keyboard.Raw +* Add buttons in Signal.Input: + button :: String -> (Element, Signal Bool) +* Add new basic element (an empty rectangle, good for adding spaces): + rectangle :: Int -> Int -> Element +* Add (an awkwardly named) way to display right justified text: rightedText +* Add two basic libraries: Data.Char and Data.Maybe +* Add some new colors: magenta, yellow, cyan, gray, grey +* Add functions to Data.List module: take, drop +* Add functions to Prelude (the default imports): + fst, snd, curry, uncurry, and a bunch of list functions +* Add --make, --separate-js, and --only-js flags to help compile + with the new module system. diff --git a/elm-runtime-0.3.0.js b/elm-runtime-0.3.0.js new file mode 100644 --- /dev/null +++ b/elm-runtime-0.3.0.js @@ -0,0 +1,54 @@ +var Guid=function(){var f=0;return{guid:function(){return f+=1}}}(),Value=function(){var f=function(a){a.replace('"',""");a.replace("&","&");a.replace("'","'");a.replace("<","<");a.replace(">",">");return a},b=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 c="",g=a.length;--g;)c=","+b(a[g])+c;","===c[0]&&(c=c.substring(1));return"("+c+")"}if("Cons"===a[0])for(var g="string"===typeof a[1]?'"':"]", +h="string"===typeof a[1]?"":",",c=("string"===typeof a[1]?'"':"[")+b(a[1]),a=a[2];;)if("Cons"===a[0])c+=h+b(a[1]),a=a[2];else return c+g;else{if("Nil"===a[0])return"[]";c="";for(g=a.length;--g;)c=" "+b(a[g])+c;c=a[0]+c;return 1=e)return["Nil"];if("Nil"===a[0])return a;"Cons"!==a[0]&&i("take");var d=["Cons",a[1],["Nil"]],b=d,a=a[2];for(--e;"Cons"===a[0]&&0this.width/this.height?(k=this.width*d/a,f=(this.height-k)/2):(g=this.height*a/d,h=(this.width-g)/2);b.drawImage(i,h,f,g,k,0,0,c.width,c.height)}};i.src=Data.String.toText(b);return c}}},video:function(a){var a=Data.String.toText(a),d=f("video");d.controls="controls";var b=f("source");b.src=a;b.type="video/"+a.substring(a.length-3,a.length);d.appendChild(b);d.isElmLeaf= +!0;return d},audio:function(a){var a=Data.String.toString(a),d=f("video");d.controls="controls";var b=f("source");b.src=a;b.type="audio/"+a.substring(a.length-3,a.length);d.appendChild(b);d.isElmLeaf=!0;return d},collage:function(a){return function(d){return function(b){var c=f("canvas");c.style.width=a+"px";c.style.height=d+"px";c.width=a;c.height=d;if(c.getContext){var i=c.getContext("2d");for(i.clearRect(0,0,c.width,c.height);"Cons"===b[0];)i=b[1](i),b=b[2];return c}c.innerHTML="Your browser does not support the canvas element."; +c.isElmLeaf=!0;return c}}},flow:m,layers:m(2),rectangle:function(a){return function(d){var b=f("div");b.isElmLeaf=!0;b.style.width=a+"px";b.style.height=d+"px";return b}},beside:function(a){return function(d){return m(4)(["Cons",a,["Cons",d,["Nil"]]])}},above:function(a){return function(d){return m(3)(["Cons",a,["Cons",d,["Nil"]]])}},below:function(a){return function(d){return m(0)(["Cons",a,["Cons",d,["Nil"]]])}},box:function(a){return function(d){d.style.position="absolute";d.style.margin="auto"; +var b=(a-1)%3,c=(a-1)/3;2>b&&(d.style.left=0);0c&&(d.style.top=0);0=b&&(a.style.width=i.getPropertyValue("width"));a.style.height=i.getPropertyValue("height");document.body.removeChild(c)}}}(),Text=function(){var f=function(a){if("string"===typeof a)return a;for(var b=[];"Cons"===a[0];)b.push(a[1]),a=a[2];return Data.String.properEscape(b.join(""))},b=function(a){return function(b){return"<"+ +a+">"+b+""}},a=function(a,b){return function(c){return""+c+""}},c=b("h1"),g=a("font-style","italic"),b=b("b"),h=a("text-decoration","underline"),j=a("text-decoration","overline"),l=a("text-decoration","line-through");return{fromString:f,toText:f,header:c,height:function(b){return a("font-size",b+"em")},italic:g,bold:b,underline:h,overline:j,strikeThrough:l,monospace:a("font-family","monospace"),color:function(b){return a("color",Color.Internal.extract(b))}, +link:function(a){return function(b){return""+b+""}}}}(),Shape=function(){var f=function(a,b,f,h){return{center:a,points:b,theta:f,scale:h}},b=function(a){return function(b){return function(f){return function(h){h.save();h.translate(f.center[0],f.center[1]);h.rotate(f.theta);h.scale(f.scale,f.scale);h.beginPath();var j=f.points;h.moveTo(j[0][0],j[0][1]);for(var l=j.length;l--;)h.lineTo(j[l][0],j[l][1]);h.closePath();a?(h.fillStyle=Color.Internal.extract(b),h.fill()):(h.strokeStyle= +Color.Internal.extract(b),h.stroke());h.restore();return h}}}};return{polygon:function(a){return function(b){for(var g=[];"Cons"===a[0];)g.push([a[1][1],a[1][2]]),a=a[2];b=[b[1],b[2]];return f(b,g,0,1)}},ngon:function(a){return function(b){return function(g){for(var h=[],j=a;j--;)h.push([b*Math.cos(2*Math.PI*j/a),b*Math.sin(2*Math.PI*j/a)]);g=[g[1],g[2]];return f(g,h,0,1)}}},rect:function(a){return function(b){return function(g){var h=[[-a/2,-b/2],[a/2,-b/2],[a/2,b/2],[-a/2,b/2]],g=[g[1],g[2]];return f(g, +h,0,1)}}},oval:function(a){return function(b){return function(g){for(var h=[],j=2*Math.PI;0 String -showErr err = "text(monospace(" ++ msg ++ "))" - where msg = show . concatMap (++"
") . lines $ err - -compile = (return . addMain . toJS) <=< initialize -compileToJS = addMain . either showErr toJS -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") - "==" -> "eq(" ++ e1 ++ "," ++ e2 ++ ")" - "/=" -> "not(eq(" ++ e1 ++ "," ++ e2 ++ "))" - _ -> e1 ++ (o:p) ++ e2 - -append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2) diff --git a/src/Compiler.hs b/src/Compiler.hs --- a/src/Compiler.hs +++ b/src/Compiler.hs @@ -1,49 +1,98 @@ +{-# LANGUAGE DeriveDataTypeable #-} module Main where -import Data.List (isPrefixOf) +import Data.Either (lefts, rights) +import Data.List (intersect, intercalate) +import Data.Maybe (fromMaybe) +import System.Console.CmdArgs +import Text.Blaze.Html.Renderer.String (renderHtml) + +import Ast +import Initialize import CompileToJS import GenerateHtml -import System.Environment -import Text.Blaze.Html.Renderer.String (renderHtml) +import Paths_Elm -main :: IO () -main = getArgs >>= parse -parse :: [String] -> IO () -parse ("--help":_) = putStrLn usage -parse ("--version":_) = putStrLn "The Elm Compiler 0.2.0.1" -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 +data ELM = + ELM { make :: Bool + , files :: [FilePath] + , runtime :: Maybe FilePath + , separate_js :: Bool + , only_js :: Bool +-- , verbose_js :: Bool + } + deriving (Data,Typeable,Show,Eq) -produceHtml :: String -> FilePath -> IO () -produceHtml libLoc file = do +elm = ELM { make = False &= help "automatically compile dependencies." + , files = def &= args &= typ "FILES" + , runtime = Nothing &= typ "FILE" &= + help "Specify a custom location for Elm's runtime system." + , separate_js = False &= help "Compile to separate HTML and JS files." + , only_js = False &= help "Compile only to JavaScript." +-- , verbose_js = False &= help "Produce JavaScript that may be easier to debug." + } &= + help "Compile Elm programs to HTML, CSS, and JavaScript." &= + summary "The Elm Compiler v0.3.0, (c) Evan Czaplicki" + +main = do + args <- cmdArgs elm + mini <- getDataFileName "elm-runtime-0.3.0.js" + compileArgs mini args + +compileArgs mini (ELM _ [] _ _ _) = + putStrLn "Usage: elm [OPTIONS] [FILES]\nFor more help: elm --help" +compileArgs mini (ELM make files rtLoc split only) = + mapM_ (fileTo get what $ fromMaybe mini rtLoc) files + where get = if make then getModules [] else getModule + what = if only then JS else + if split then Split else HTML + +data What = JS | HTML | Split + +fileTo get what rtLoc file = do + ems <- get file + case ems of + Left err -> putStrLn $ "Error while compiling " ++ file ++ ":\n" ++ err + Right ms -> + let name = reverse . tail . dropWhile (/='.') $ reverse file + js = name ++ ".js" + html = name ++ ".html" + in case what of + JS -> writeFile js $ concatMap jsModule ms + HTML -> writeFile html . renderHtml $ modulesToHtml rtLoc ms + Split -> do + writeFile html . renderHtml $ linkedHtml rtLoc js ms + writeFile js $ concatMap jsModule ms + +getModules :: [String] -> FilePath -> IO (Either String [Module]) +getModules uses 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 code + case initialize code of + Left err -> return . Left $ "Error in " ++ file ++ ":\n" ++ err + Right modul@(Module _ _ imports _) -> + let imps = filter (`notElem` builtInModules) $ map fst imports in + case intersect uses imps of + x:_ -> return . Left $ "Error: Cyclic dependency. Module " ++ + x ++ " depends on itself." + [] -> do + ems <- mapM (getModules (uses ++ imps) . toFilePath) imps + return $ case lefts ems of + [] -> Right $ concat (rights ems) ++ [modul] + errs -> Left $ intercalate "\n" errs -usageMini :: String -usageMini = - "Usage: elm [OPTIONS] FILE\n\ - \Try `elm --help' for more information." +getModule :: FilePath -> IO (Either String [Module]) +getModule file = do + code <- readFile file + return . fmap (:[]) $ initialize code -usage :: String -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: " +toFilePath :: String -> FilePath +toFilePath modul = map (\c -> if c == '.' then '/' else c) modul ++ ".elm" + +builtInModules = + concat [ map ("Data."++) [ "List", "Char", "Maybe" ] + , map ("Signal."++) [ "Mouse", "Keyboard.Raw" + , "Window", "Time", "HTTP", "Input", "Random" ] + , [ "Element", "Text", "Color", "Line" ] + , [ "Prelude" ] + ] diff --git a/src/ExtractNoscript.hs b/src/ExtractNoscript.hs deleted file mode 100644 --- a/src/ExtractNoscript.hs +++ /dev/null @@ -1,26 +0,0 @@ - -module ExtractNoscript (extract) where - -import Ast - -extract = concatMap (\s -> "

" ++ s ++ "

") . extract' - -extract' expr = - let f = extract' in - case expr of - Str s -> [s] - Binop op e1 e2 -> case (op, f e1, f e2) of - ("++", [s1], [s2]) -> [s1 ++ s2] - (_ , ss1 , ss2 ) -> ss1 ++ ss2 - Lambda v e -> f e - App (App (Var "link") src) txt -> - case (f src, f txt) of - ([s1],[s2]) -> [ "" ++ s2 ++ "" ] - ( ss1, ss2) -> ss1 ++ ss2 - App e1 e2 -> f e1 ++ f e2 - If eb et ef -> f et ++ f ef - Let defs e -> concatMap (f . snd) defs ++ f e - Var _ -> [] - Case e cases -> concatMap (f . snd) cases - Data _ es -> concatMap f es - _ -> [] diff --git a/src/Gen/CompileToJS.hs b/src/Gen/CompileToJS.hs new file mode 100644 --- /dev/null +++ b/src/Gen/CompileToJS.hs @@ -0,0 +1,145 @@ + +module CompileToJS (showErr, jsModule) where + +import Ast +import Control.Monad (liftM,(<=<),join) +import Data.Char (isAlpha,isDigit) +import Data.List (intercalate,sortBy,inits) +import Data.Map (toList) +import Data.Maybe (mapMaybe) + +import Initialize + +showErr :: String -> String +showErr err = mainEquals $ "text(monospace(" ++ msg ++ "))" + where msg = show . concatMap (++"
") . lines $ err + +parens = ("("++) . (++")") +braces = ("{"++) . (++"}") +jsList = ("["++) . (++"]") . intercalate "," +jsFunc args body = "function(" ++ args ++ "){" ++ body ++ "}" +assign x e = "\nvar " ++ x ++ "=" ++ e ++ ";" +ret e = "\nreturn "++ e ++";" +iff a b c = a ++ "?" ++ b ++ ":" ++ c + +mainEquals s = globalAssign "ElmCode.main" (jsFunc "" (ret s)) +globalAssign m s = "\n" ++ m ++ "=" ++ s ++ ";" + +tryBlock names e = + concat [ "\ntry{\n" ++ e ++ "\n\n} catch (e) {" + , "ElmCode.main=function() {" + , "var msg = ('

Your browser may not be supported. " ++ + "Are you using a modern browser?

' +" ++ + " '
Runtime Error in " ++ + intercalate "." names ++ " module:
' + e + '');" + , "document.body.innerHTML = Text.monospace(msg);" + , "throw e;" + , "};}" + ] + + +jsModule (Module names exports imports defs) = + tryBlock (tail modNames) $ concat + [ concatMap (\n -> globalAssign n $ n ++ " || {}") . map (intercalate ".") . drop 2 . inits $ take (length modNames - 1) modNames + , "\nif (" ++ modName ++ ") throw \"Module name collision, '" ++ intercalate "." (tail modNames) ++ "' is already defined.\"; " + , globalAssign modName $ jsFunc "" (includes ++ body ++ export) ++ "()" + , mainEquals $ modName ++ ".main" ] + where modNames = if null names then ["ElmCode", "Main"] else "ElmCode" : names + modName = intercalate "." modNames + includes = concatMap jsImport $ + map (\(x,y) -> ("ElmCode." ++ x,y)) imports + body = jsDefs defs + export = ret . braces . intercalate "," $ mapMaybe getNames defs + exps = if null exports then ["main"] else exports + getNames (x,_) = + let y = reverse . tail . dropWhile isDigit $ reverse x in + if y `elem` exps then Just $ y ++ ":" ++ x else Nothing + +jsImport (modul, how) = + concat [ "\ntry{" ++ modul ++ "} catch(e) {throw \"Module '" + , drop 1 (dropWhile (/='.') modul) + , "' is missing. Compile with --make flag or load missing " + , "module in a separate JavaScript file.\";}" ] ++ jsImport' (modul, how) + +jsImport' (modul, As name) = assign name modul +jsImport' (modul, Importing []) = jsImport' (modul, Hiding []) +jsImport' (modul, Importing vs) = + concatMap (\v -> assign v $ modul ++ "." ++ v) vs +jsImport' (modul, Hiding vs) = + concat [ "\nfor(var i in " ++ modul ++ "){" + , assign "hiddenVars" . jsList $ map (\v -> "'" ++ v ++ "'") vs + , "\nif (hiddenVars.indexOf(i) >= 0) continue;" + , globalAssign "this[i]" $ modul ++ "[i]" + , "}" ] + + +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 "" (jsDefs defs ++ ret (toJS e')) ++ "()" + +jsDefs defs = concatMap toDef $ sortBy f defs + where f a b = compare (isLambda a) (isLambda b) + isLambda (_, Lambda _ _) = 1 + isLambda _ = 0 + toDef (f, Lambda x e) = + "\nfunction " ++ 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") + "==" -> "eq(" ++ e1 ++ "," ++ e2 ++ ")" + "/=" -> "not(eq(" ++ e1 ++ "," ++ e2 ++ "))" + _ -> e1 ++ (o:p) ++ e2 + +append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2) diff --git a/src/Gen/ExtractNoscript.hs b/src/Gen/ExtractNoscript.hs new file mode 100644 --- /dev/null +++ b/src/Gen/ExtractNoscript.hs @@ -0,0 +1,35 @@ + +module ExtractNoscript (extract) where + +import Ast + +extract (Module _ _ _ defs) = + concatMap (\s -> "

" ++ s ++ "

") $ concatMap (extract' . snd) defs + +extract' expr = + let f = extract' in + case expr of + Str s -> [s] + Binop op e1 e2 -> case (op, f e1, f e2) of + ("++", [s1], [s2]) -> [s1 ++ s2] + (_ , ss1 , ss2 ) -> ss1 ++ ss2 + Lambda v e -> f e + App (App (Var "link") src) txt -> + case (f src, f txt) of + ([s1],[s2]) -> [ "" ++ s2 ++ "" ] + ( ss1, ss2) -> ss1 ++ ss2 + App (Var "header") e -> tag "h1" e + App (Var "bold") e -> tag "b" e + App (Var "italic") e -> tag "i" e + App (Var "monospace") e -> tag "code" e + App e1 e2 -> f e1 ++ f e2 + If eb et ef -> f et ++ f ef + Let defs e -> concatMap (f . snd) defs ++ f e + Var _ -> [] + Case e cases -> concatMap (f . snd) cases + Data _ es -> concatMap f es + _ -> [] + +tag t e = case extract' e of + [s] -> [ concat [ "<", t, ">", s, "" ] ] + ss -> ss diff --git a/src/Gen/GenerateHtml.hs b/src/Gen/GenerateHtml.hs new file mode 100644 --- /dev/null +++ b/src/Gen/GenerateHtml.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} +module GenerateHtml (generateHtml, + body, css, widgetBody, + modulesToHtml, linkedHtml + ) where + +import Data.List (intercalate) +import Text.Blaze (preEscapedToMarkup) +import Text.Blaze.Html (Html) +import qualified Text.Blaze.Html5 as H +import Text.Blaze.Html5 ((!)) +import qualified Text.Blaze.Html5.Attributes as A + +import Ast +import Initialize +import CompileToJS +import ExtractNoscript + +css = H.style ! A.type_ "text/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 :: Either String String -> H.Html +makeScript (Left s) = + H.script ! A.type_ "text/javascript" ! A.src (H.toValue s) $ "" +makeScript (Right s) = + H.script ! A.type_ "text/javascript" $ preEscapedToMarkup s + +-- |This function compiles Elm code into simple HTML. +-- +-- Usage example: +-- +-- > generateHtml "/elm-min.js" "Some title" [elmFile|elm-source/somePage.elm|] +generateHtml :: String -- ^ Location of elm-min.js as expected by the browser + -> String -- ^ The page title + -> String -- ^ The elm source code. + -> Html +generateHtml libLoc title source = + case initialize source of + Left err -> createHtml libLoc title (Right $ showErr err) (H.noscript "") + Right modul -> modulesToHtml libLoc [modul] + + +modulesToHtml libLoc modules = createHtml libLoc title js noscript + where title = (\(Module names _ _ _) -> intercalate "." names) $ last modules + js = Right $ concatMap jsModule modules + noscript = extract $ last modules + +linkedHtml rtLoc jsLoc modules = + createHtml rtLoc title (Left jsLoc) (H.noscript "") + where title = (\(Module names _ _ _) -> intercalate "." names) $ last modules + + +createHtml libLoc title js noscript = + H.docTypeHtml $ do + H.head $ do + H.meta ! A.charset "UTF-8" + H.title . H.toHtml $ title + makeScript (Left libLoc) + makeScript js + css + H.body $ body noscript + +body noscript = do + H.div ! A.id "widthChecker" ! A.style "width:100%; height:1px; position:absolute; top:-1px;" $ "" + H.div ! A.id "content" $ "" + H.script ! A.type_ "text/javascript" $ "Dispatcher.initialize()" + H.noscript $ preEscapedToMarkup noscript + +widgetBody noscript = do + H.div ! A.id "widthChecker" ! A.style "width:100%; height:1px; position:absolute; top:-1px;" $ "" + H.div ! A.id "content" $ "" + H.noscript $ preEscapedToMarkup noscript diff --git a/src/GenerateHtml.hs b/src/GenerateHtml.hs deleted file mode 100644 --- a/src/GenerateHtml.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module GenerateHtml (generateHtml, body, css, widgetBody) where - -import Text.Blaze (preEscapedToMarkup) -import Text.Blaze.Html (Html) -import qualified Text.Blaze.Html5 as H -import Text.Blaze.Html5 ((!)) -import qualified Text.Blaze.Html5.Attributes as A - -import Initialize -import CompileToJS -import ExtractNoscript - -css = H.style ! A.type_ "text/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) $ "" - --- |This function compiles Elm code into simple HTML. --- --- Usage example: --- --- > generateHtml "/elm-min.js" "Some title" [elmFile|elm-source/somePage.elm|] -generateHtml :: String -- ^ Location of elm-min.js as expected by the browser - -> String -- ^ The page title - -> String -- ^ The elm source code. - -> Html -generateHtml libLoc title source = - let expr = initialize source - js = compileToJS expr - noscript = either id extract expr - in - H.docTypeHtml $ do - H.head $ do - H.meta ! A.charset "UTF-8" - H.title . H.toHtml $ title - makeScript libLoc - H.script ! A.type_ "text/javascript" $ preEscapedToMarkup js - css - H.body $ body noscript - -body noscript = do - H.div ! A.id "widthChecker" ! A.style "width:100%; height:1px; position:absolute; top:-1px;" $ "" - H.span ! A.id "content" $ "" - H.script ! A.type_ "text/javascript" $ "Dispatcher.initialize()" - H.noscript $ preEscapedToMarkup noscript - -widgetBody noscript = do - H.div ! A.id "widthChecker" ! A.style "width:100%; height:1px; position:absolute; top:-1px;" $ "" - H.span ! A.id "content" $ "" - H.noscript $ preEscapedToMarkup noscript diff --git a/src/Initialize.hs b/src/Initialize.hs --- a/src/Initialize.hs +++ b/src/Initialize.hs @@ -1,100 +1,18 @@ module Initialize (initialize) where -import Ast -import Control.Arrow (first, second) -import Control.Monad -import Data.Char (isAlpha) -import Data.Maybe (mapMaybe) -import Data.Either (rights) - -import Parser (toDefs) -import Rename (rename) +import Control.Monad.Error -import Unify +import Ast +import Parser (parseProgram) import Hints - +import Unify +import Rename +import Optimize initialize str = do - (expr, hints') <- toDefs 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 -> 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 -> App (f e1) (f e2) - If e1 e2 e3 -> simp_if (f e1) (f e2) (f e3) - Let defs e -> Let (map (second f) defs) (f e) - Data name es -> Data name (map f es) - Case e cases -> Case (f e) (map (second f) cases) - _ -> expr - -simp_if (Boolean b) e2 e3 = if b then e2 else e3 -simp_if a b c = If a b c - -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 - | otherwise = binop str e1 e2 - -binop op (Number n) (Number m) = f n m - where f a b = case op of - { "+" -> Number $ (+) a b - ; "-" -> Number $ (-) a b - ; "*" -> Number $ (*) a b - --; "/" -> Number $ div a b - ; "<" -> Boolean $ a < b - ; ">" -> Boolean $ a < b - ; "<=" -> Boolean $ a <= b - ; ">=" -> Boolean $ a >= b - ; "==" -> Boolean $ a == b - ; "/=" -> Boolean $ a /= b - ; _ -> Binop op (Number n) (Number m) } - -binop "-" e (Number 0) = e -binop "+" (Number 0) e = e -binop "+" (Number n) (Binop "+" (Number m) e) = binop "+" (Number (n+m)) e -binop "+" (Number n) (Binop "+" e (Number m)) = binop "+" (Number (n+m)) e - -binop "/" e (Number 1) = e -binop "*" (Number 0) e = Number 0 -binop "*" (Number 1) e = e -binop "*" (Number n) (Binop "*" (Number m) e) = binop "*" (Number (n*m)) e -binop "*" (Number n) (Binop "*" e (Number m)) = binop "*" (Number (n*m)) e - -binop "+" e (Number n) = binop "+" (Number n) e -binop "*" e (Number n) = binop "*" (Number n) e - -binop op (Boolean n) (Boolean m) = f n m - where f a b = case op of { "&&" -> Boolean $ (&&) n m - ; "||" -> Boolean $ (||) n m - ; _ -> Binop op (Boolean n) (Boolean m) } - -binop "&&" (Boolean True) e = e -binop "&&" (Boolean False) e = Boolean False -binop "||" (Boolean True) e = Boolean True -binop "||" (Boolean False) e = e - -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] - -binop "$" e1 e2 = App e1 e2 - -binop op e1 e2 = Binop op e1 e2 ---} + (Module name ex im defs, tipes) <- parseProgram str + let expr = rename . Let defs $ Var "_" + subs <- unify (liftM2 (++) hints tipes) expr + let Let defs' _ = optimize expr + let im' = if any ((=="Prelude") . fst) im then im else ("Prelude", Importing []):im + return (subs `seq` Module name ex im' defs') diff --git a/src/Language/Elm.hs b/src/Language/Elm.hs --- a/src/Language/Elm.hs +++ b/src/Language/Elm.hs @@ -69,6 +69,6 @@ -- build helper to avoid boilerplate repetition toPartsHelper :: String -> (Html, Html, String) toPartsHelper source = (html, css, js) - where expr = initialize source - js = compileToJS expr - html = widgetBody $ either id extract expr + where modul = initialize source + js = either showErr jsModule modul + html = widgetBody $ either id extract modul diff --git a/src/Optimize.hs b/src/Optimize.hs new file mode 100644 --- /dev/null +++ b/src/Optimize.hs @@ -0,0 +1,84 @@ +module Optimize (optimize) where + +import Ast +import Control.Arrow (second) +import Data.Char (isAlpha) + + +optimize exp = if exp == exp' then exp' else optimize exp' + where exp' = simp exp + +simp expr = + let f = simp in + case expr of + 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 -> App (f e1) (f e2) + If e1 e2 e3 -> simp_if (f e1) (f e2) (f e3) + Let defs e -> Let (map (second f) defs) (f e) + Data name es -> Data name (map f es) + Case e cases -> Case (f e) (map (second f) cases) + _ -> expr + +simp_if (Boolean b) e2 e3 = if b then e2 else e3 +simp_if a b c = If a b c + +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 + | otherwise = binop str e1 e2 + +binop op (Number n) (Number m) = f n m + where f a b = case op of + { "+" -> Number $ (+) a b + ; "-" -> Number $ (-) a b + ; "*" -> Number $ (*) a b + --; "/" -> Number $ div a b + ; "<" -> Boolean $ a < b + ; ">" -> Boolean $ a < b + ; "<=" -> Boolean $ a <= b + ; ">=" -> Boolean $ a >= b + ; "==" -> Boolean $ a == b + ; "/=" -> Boolean $ a /= b + ; _ -> Binop op (Number n) (Number m) } + +binop "-" e (Number 0) = e +binop "+" (Number 0) e = e +binop "+" (Number n) (Binop "+" (Number m) e) = binop "+" (Number (n+m)) e +binop "+" (Number n) (Binop "+" e (Number m)) = binop "+" (Number (n+m)) e + +binop "/" e (Number 1) = e +binop "*" (Number 0) e = Number 0 +binop "*" (Number 1) e = e +binop "*" (Number n) (Binop "*" (Number m) e) = binop "*" (Number (n*m)) e +binop "*" (Number n) (Binop "*" e (Number m)) = binop "*" (Number (n*m)) e + +binop "+" e (Number n) = binop "+" (Number n) e +binop "*" e (Number n) = binop "*" (Number n) e + +binop op (Boolean n) (Boolean m) = f n m + where f a b = case op of { "&&" -> Boolean $ (&&) n m + ; "||" -> Boolean $ (||) n m + ; _ -> Binop op (Boolean n) (Boolean m) } + +binop "&&" (Boolean True) e = e +binop "&&" (Boolean False) e = Boolean False +binop "||" (Boolean True) e = Boolean True +binop "||" (Boolean False) e = e + +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] + +binop "$" e1 e2 = App e1 e2 + +binop op e1 e2 = Binop op e1 e2 +--} diff --git a/src/Parse/Binops.hs b/src/Parse/Binops.hs --- a/src/Parse/Binops.hs +++ b/src/Parse/Binops.hs @@ -1,69 +1,68 @@ -module Binops (binops) where - -import Ast -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) - -import Text.Parsec -import ParseLib - -data Assoc = L | N | R deriving (Eq,Show) - -table = [ (9, R, ".") - , (7, L, "*"), (7, L, "/"), (7, L, "mod") - , (6, L, "+"), (6, L, "-") - , (5, R, ":" ), (5, R, "++") - , (4, N, "<="), (4, N, ">="), (4, N, "<") - , (4, N, "=="), (4, N, "/="), (4, N, ">") - , (3, R, "&&") - , (2, R, "||") - , (0, R, "$") - ] - -sortOps = sortBy (\(i,_,_) (j,_,_) -> compare i j) - -binops term anyOp = do - e <- term - (ops,es) <- liftM unzip $ - many (try $ do { whitespace - ; op <- anyOp - ; whitespace - ; e <- term; return (op,e) }) - case binopOf Map.empty (sortOps table) ops (e:es) of - Right e -> return e - Left msg -> fail msg - -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 seen [] ops es = binopOf seen [(9,L,head ops)] ops 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 (assoc,op) seen) tbl i ops es - Just (assoc',op') -> - if assoc == assoc' && assoc /= N 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 Binops (binops) where + +import Ast +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) + +import Text.Parsec +import ParseLib + +data Assoc = L | N | R deriving (Eq,Show) + +table = [ (9, R, ".") + , (7, L, "*"), (7, L, "/"), (7, L, "mod") + , (6, L, "+"), (6, L, "-") + , (5, R, ":" ), (5, R, "++") + , (4, N, "<="), (4, N, ">="), (4, N, "<") + , (4, N, "=="), (4, N, "/="), (4, N, ">") + , (3, R, "&&") + , (2, R, "||") + , (0, R, "$") + ] + +sortOps = sortBy (\(i,_,_) (j,_,_) -> compare i j) + +binops term anyOp = do + e <- term + (ops,es) <- liftM unzip $ + many (commitIf (whitespace >> anyOp) $ do { whitespace ; op <- anyOp + ; whitespace ; e <- term + ; return (op,e) }) + case binopOf Map.empty (sortOps table) ops (e:es) of + Right e -> return e + Left msg -> fail msg + +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 seen [] ops es = binopOf seen [(9,L,head ops)] ops 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 (assoc,op) seen) tbl i ops es + Just (assoc',op') -> + if assoc == assoc' && assoc /= N 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/ParseExpr.hs b/src/Parse/ParseExpr.hs new file mode 100644 --- /dev/null +++ b/src/Parse/ParseExpr.hs @@ -0,0 +1,121 @@ +module ParseExpr (def) where + +import Ast +import Control.Applicative ((<$>), (<*>)) +import Control.Monad +import Data.Char (isSymbol, isDigit) +import Data.List (foldl') +import Text.Parsec hiding (newline,spaces) + +import ParseLib +import Patterns +import Binops + +import Guid +import Types (Type (VarT)) + + +-------- Basic Terms -------- + +numTerm :: (Monad m) => ParsecT [Char] u m Expr +numTerm = liftM (Number . read) (many1 digit) "number" + +strTerm :: (Monad m) => ParsecT [Char] u m Expr +strTerm = liftM Str . expecting "string" . betwixt '"' '"' . many $ + backslashed <|> satisfy (/='"') + +varTerm :: (Monad m) => ParsecT [Char] u m Expr +varTerm = toVar <$> var "variable" + +toVar v = case v of "True" -> Boolean True + "False" -> Boolean False + _ -> Var v + +chrTerm :: (Monad m) => ParsecT [Char] u m Expr +chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\'')) + "character" + + +-------- Complex Terms -------- + +listTerm = braces $ choice + [ try $ do { lo <- expr; whitespace; string ".." ; whitespace + ; Range lo <$> expr } + , list <$> commaSep expr + ] + +parensTerm = parens $ choice + [ do op <- anyOp + return . Lambda "x" . Lambda "y" $ Binop op (Var "x") (Var "y") + , do es <- commaSep expr + return $ case es of { [e] -> e; _ -> tuple es } + ] + +term = choice [ numTerm, strTerm, chrTerm + , accessible varTerm + , listTerm, parensTerm ] + "basic term (4, x, 'c', etc.)" + +-------- Applications -------- + +appExpr = do + tlist <- spaceSep1 term + return $ case tlist of + t:[] -> t + t:ts -> foldl' App t ts + +-------- Normal Expressions -------- + +binaryExpr = binops appExpr anyOp + +ifExpr = do reserved "if" ; whitespace ; e1 <- expr ; whitespace + reserved "then" ; whitespace ; e2 <- expr ; (whitespace "an 'else' branch") + reserved "else" "an 'else' branch" ; whitespace ; If e1 e2 <$> expr + +lambdaExpr = do char '\\' <|> char '\x03BB' "anonymous function" + whitespace + args <- spaceSep1 patternTerm + whitespace ; arrow ; whitespace + e <- expr + return $ makeFunction args e + +letExpr = do + reserved "let" + brace <- optionMaybe . try $ do + whitespace + char '{' "a set of definitions { x = ... ; y = ... }" + case brace of + Nothing -> do whitespace; ds <- assignExpr + whitespace; reserved "in"; whitespace; Let ds <$> expr + Just '{' -> do whitespace ; dss <- semiSep1 assignExpr ; whitespace + string "}" "closing bracket '}'" + whitespace; reserved "in"; whitespace; e <- expr + return $ Let (concat dss) e + +caseExpr = do + reserved "case"; whitespace; e <- expr; whitespace; reserved "of"; whitespace + Case e <$> brackets (semiSep1 (case_ "cases { x -> ... }")) + where case_ = do p <- patternExpr; whitespace; arrow; whitespace + (,) p <$> expr + +expr = choice [ ifExpr, letExpr, caseExpr + , lambdaExpr, binaryExpr ] "an expression" + +assignExpr = do + patterns <- + choice [ try $ do v <- PVar <$> lowVar + notFollowedBy (whitespace >> char ':') + (v:) <$> spacePrefix patternTerm + , (:[]) <$> patternExpr + ] "the definition of a variable (x = ...)" + whitespace; string "="; whitespace; exp <- expr + flattenPatterns patterns exp + + +def = do (fs,es) <- unzip <$> assignExpr + return (fs, es, mapM (\_ -> liftM VarT guid) fs) + +parseDef str = + case parse def "" str of + Right result -> Right result + Left err -> Left $ "Parse error at " ++ show err diff --git a/src/Parse/ParseLib.hs b/src/Parse/ParseLib.hs --- a/src/Parse/ParseLib.hs +++ b/src/Parse/ParseLib.hs @@ -1,136 +1,142 @@ - -module ParseLib where - -import Ast -import Control.Applicative ((<$>),(<*>)) -import Control.Monad -import Data.Char (isSymbol) -import Text.Parsec hiding (newline,spaces) - -reserveds = [ "if", "then", "else" - , "case", "of", "data" - , "let", "in" ] - -expecting = flip () - -backslashed :: (Monad m) => ParsecT [Char] u m Char -backslashed = do { char '\\'; c <- anyChar - ; return . read $ ['\'','\\',c,'\''] } - -var :: (Monad m) => ParsecT [Char] u m String -var = makeVar (letter <|> char '_' "variable") - -lowVar :: (Monad m) => ParsecT [Char] u m String -lowVar = makeVar (lower "lower case variable") -capVar :: (Monad m) => ParsecT [Char] u m String -capVar = makeVar (upper "upper case variable") - -innerVarChar :: (Monad m) => ParsecT [Char] u m Char -innerVarChar = alphaNum <|> char '_' <|> char '\'' "" - -makeVar p = do v <- (:) <$> p <*> many innerVarChar - guard (v `notElem` reserveds) - return v - -reserved word = - try (string word >> notFollowedBy innerVarChar) >> return word - "reserved word '" ++ word ++ "'" - -anyOp :: (Monad m) => ParsecT [Char] u m String -anyOp = betwixt '`' '`' var <|> - (do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!") - guard (op `notElem` [ "=", "..", "->", "--" ]) - return op) "infix operator (e.g. x + y)" - -arrow :: (Monad m) => ParsecT [Char] u m String -arrow = string "->" <|> string "\8594" "arrow (->)" - -commaSep :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a] -commaSep p = do - x <- optionMaybe p - case x of - Just a -> (a:) <$> many (try (whitespace >> (char ',' "comma ','")) >> - whitespace >> p) - Nothing -> return [] - -semiSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a] -semiSep1 p = do - a <- p - (a:) <$> many (try (whitespace >> (char ';' "semicolon ';'")) >> - whitespace >> p) - -pipeSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a] -pipeSep1 p = do - a <- p - (a:) <$> many (try (whitespace >> (char '|' "type divider '|'")) >> - whitespace >> p) - -consSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a] -consSep1 p = do - a <- p - (a:) <$> many (try (whitespace >> (char ':' "cons operator ':'")) >> - whitespace >> p) - -spaceSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a] -spaceSep1 p = (:) <$> p <*> spacePrefix p - -spacePrefix p = many (try (whitespace >> p)) - -betwixt a b c = do char a ; out <- c - char b "closing '" ++ [b] ++ "'" ; return out - -surround a z name p = do - char a ; whitespace ; a <- p ; whitespace - char z unwords ["closing", name, show z] - return a - -braces :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a -braces = surround '[' ']' "brace" - -parens :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a -parens = surround '(' ')' "paren" - -brackets :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a -brackets = surround '{' '}' "bracket" - -accessible expr = do - e <- expr - access <- optionMaybe . try $ - (do { char '.' ; notFollowedBy (char '.') } "field access (e.g. List.map)") - case access of - Just _ -> accessible (Access e `liftM` var "field access (e.g. List.map)") - Nothing -> return e - - -spaces :: (Monad m) => ParsecT [Char] u m String -spaces = many1 ((multiComment <|> string " " "") >> return ' ') "spaces" - -forcedWS :: (Monad m) => ParsecT [Char] u m [String] -forcedWS = try (do { spaces; many nl_space }) <|> try (many1 nl_space) - where nl_space = try $ many1 newline >> spaces - -whitespace :: (Monad m) => ParsecT [Char] u m () -whitespace = optional forcedWS "" - -freshLine :: (Monad m) => ParsecT [Char] u m [[String]] -freshLine = try (do { many1 newline; many space_nl }) <|> try (many1 space_nl) "" - where space_nl = try $ spaces >> many1 newline - -newline :: (Monad m) => ParsecT [Char] u m String -newline = simpleNewline <|> lineComment "" - -simpleNewline :: (Monad m) => ParsecT [Char] u m String -simpleNewline = try (string "\r\n") <|> string "\n" - -lineComment :: (Monad m) => ParsecT [Char] u m String -lineComment = do try (string "--") - manyTill anyChar $ simpleNewline <|> (eof >> return "\n") - -multiComment :: (Monad m) => ParsecT [Char] u m String -multiComment = do { try (string "{-"); closeComment } - -closeComment :: (Monad m) => ParsecT [Char] u m String -closeComment = manyTill anyChar . choice $ - [ try (string "-}") "close comment" - , do { try $ string "{-"; closeComment; closeComment } + +module ParseLib where + +import Ast +import Control.Applicative ((<$>),(<*>)) +import Control.Monad +import Data.Char (isSymbol) +import Text.Parsec hiding (newline,spaces) + +reserveds = [ "if", "then", "else" + , "case", "of", "data" + , "let", "in" + , "module", "where" + , "import", "as", "hiding" ] + +expecting = flip () + +backslashed :: (Monad m) => ParsecT [Char] u m Char +backslashed = do { char '\\'; c <- anyChar + ; return . read $ ['\'','\\',c,'\''] } + +var :: (Monad m) => ParsecT [Char] u m String +var = makeVar (letter <|> char '_' "variable") + +lowVar :: (Monad m) => ParsecT [Char] u m String +lowVar = makeVar (lower "lower case variable") +capVar :: (Monad m) => ParsecT [Char] u m String +capVar = makeVar (upper "upper case variable") + +innerVarChar :: (Monad m) => ParsecT [Char] u m Char +innerVarChar = alphaNum <|> char '_' <|> char '\'' "" + +makeVar p = do v <- (:) <$> p <*> many innerVarChar + guard (v `notElem` reserveds) + return v + +reserved word = + try (string word >> notFollowedBy innerVarChar) >> return word + "reserved word '" ++ word ++ "'" + +anyOp :: (Monad m) => ParsecT [Char] u m String +anyOp = betwixt '`' '`' var <|> + (do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!") + guard (op `notElem` [ "=", "..", "->", "--" ]) + return op) "infix operator (e.g. +, *, ||)" + +arrow :: (Monad m) => ParsecT [Char] u m String +arrow = string "->" <|> string "\8594" "arrow (->)" + + +commitIf check p = commit <|> try p + where commit = do (try $ lookAhead check) >> p + +spaceySepBy1 :: (Monad m) => ParsecT [Char] u m b -> ParsecT [Char] u m a -> ParsecT [Char] u m [a] +spaceySepBy1 sep p = do + a <- p + (a:) <$> many (commitIf (whitespace >> sep) (whitespace >> sep >> whitespace >> p)) + + +commaSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a] +commaSep1 = spaceySepBy1 (char ',' "comma ','") + +commaSep :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a] +commaSep = option [] . commaSep1 + +semiSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a] +semiSep1 = spaceySepBy1 (char ';' "semicolon ';'") + +pipeSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a] +pipeSep1 = spaceySepBy1 (char '|' "type divider '|'") + +consSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a] +consSep1 = spaceySepBy1 (char ':' "cons operator ':'") + +dotSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a] +dotSep1 p = (:) <$> p <*> many (try (char '.') >> p) + +spaceSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a] +spaceSep1 p = (:) <$> p <*> spacePrefix p + +spacePrefix p = many (commitIf (whitespace >> (char '[' <|> char '(')) (whitespace >> p)) + +followedBy a b = do x <- a ; b ; return x + +betwixt a b c = do char a ; out <- c + char b "closing '" ++ [b] ++ "'" ; return out + +surround a z name p = do + char a ; whitespace ; a <- p ; whitespace + char z unwords ["closing", name, show z] + return a + +braces :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a +braces = surround '[' ']' "brace" + +parens :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a +parens = surround '(' ')' "paren" + +brackets :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a +brackets = surround '{' '}' "bracket" + +accessible expr = do + e <- expr + access <- optionMaybe . try $ + (do { char '.' ; notFollowedBy (char '.') } "field access (e.g. List.map)") + case access of + Just _ -> accessible (Access e `liftM` var "field access (e.g. List.map)") + Nothing -> return e + + +spaces :: (Monad m) => ParsecT [Char] u m String +spaces = many1 ((multiComment <|> string " " "") >> return ' ') "spaces" + +forcedWS :: (Monad m) => ParsecT [Char] u m [String] +forcedWS = try (do { spaces; many nl_space }) <|> try (many1 nl_space) + where nl_space = try $ many1 newline >> spaces + +whitespace :: (Monad m) => ParsecT [Char] u m () +whitespace = optional forcedWS "" + +freshLine :: (Monad m) => ParsecT [Char] u m [[String]] +freshLine = try (do { many1 newline; many space_nl }) <|> try (many1 space_nl) "" + where space_nl = try $ spaces >> many1 newline + +newline :: (Monad m) => ParsecT [Char] u m String +newline = simpleNewline <|> lineComment "" + +simpleNewline :: (Monad m) => ParsecT [Char] u m String +simpleNewline = try (string "\r\n") <|> string "\n" + +lineComment :: (Monad m) => ParsecT [Char] u m String +lineComment = do try (string "--") + manyTill anyChar $ simpleNewline <|> (eof >> return "\n") + +multiComment :: (Monad m) => ParsecT [Char] u m String +multiComment = do { try (string "{-"); closeComment } + +closeComment :: (Monad m) => ParsecT [Char] u m String +closeComment = manyTill anyChar . choice $ + [ try (string "-}") "close comment" + , do { try $ string "{-"; closeComment; closeComment } ] diff --git a/src/Parse/ParseModules.hs b/src/Parse/ParseModules.hs new file mode 100644 --- /dev/null +++ b/src/Parse/ParseModules.hs @@ -0,0 +1,44 @@ + +module ParseModules (moduleDef, imports) where + +import Control.Applicative ((<$>), (<*>)) +import Data.List (intercalate) +import Text.Parsec hiding (newline,spaces) + +import Ast +import ParseLib + +moduleDef :: (Monad m) => ParsecT [Char] u m ([String], [String]) +moduleDef = do + try (reserved "module") + whitespace "name of module" + names <- dotSep1 capVar + whitespace + exports <- option [] . parens $ commaSep var + whitespace "reserved word 'where'" + reserved "where" + return (names, exports) + +imports :: (Monad m) => ParsecT [Char] u m Imports +imports = option [] ((:) <$> import' <*> many (try (freshLine >> import'))) + + +import' :: (Monad m) => ParsecT [Char] u m (String, ImportMethod) +import' = do + reserved "import" + whitespace + name <- intercalate "." <$> dotSep1 capVar + method <- option (Importing []) $ try (whitespace >> + (as' <|> hiding' <|> importing')) + return (name, method) + + +as' :: (Monad m) => ParsecT [Char] u m ImportMethod +as' = reserved "as" >> whitespace >> As <$> capVar "alias for module" + +hiding' :: (Monad m) => ParsecT [Char] u m ImportMethod +hiding' = reserved "hiding" >> whitespace >> + Hiding <$> parens (commaSep1 var) "listing of hidden values" + +importing' :: (Monad m) => ParsecT [Char] u m ImportMethod +importing' = Importing <$> parens (commaSep1 var) "listing of imported values (x,y,z)" diff --git a/src/Parse/ParseTypes.hs b/src/Parse/ParseTypes.hs --- a/src/Parse/ParseTypes.hs +++ b/src/Parse/ParseTypes.hs @@ -1,83 +1,83 @@ -module ParseTypes where - -import Ast -import Control.Applicative ((<$>),(<*>)) -import Control.Monad (liftM) -import Data.Char (isUpper,isLower) -import Data.Maybe (fromMaybe) -import Data.List (lookup) -import Text.Parsec - -import ParseLib -import Types hiding (string,parens) -import Guid - -data ParseType = VarPT String - | LambdaPT ParseType ParseType - | ADTPT String [ParseType] - -listPT t = ADTPT "List" [t] -tuplePT ts = ADTPT ("Tuple" ++ show (length ts)) ts - -typeVar :: (Monad m) => ParsecT [Char] u m ParseType -typeVar = VarPT <$> lowVar "type variable" - -typeList :: (Monad m) => ParsecT [Char] u m ParseType -typeList = listPT <$> braces typeExpr - -typeTuple :: (Monad m) => ParsecT [Char] u m ParseType -typeTuple = do ts <- parens (commaSep typeExpr) - return $ case ts of { [t] -> t ; _ -> tuplePT ts } - -typeUnambiguous :: (Monad m) => ParsecT [Char] u m ParseType -typeUnambiguous = typeList <|> typeTuple - -typeSimple :: (Monad m) => ParsecT [Char] u m ParseType -typeSimple = VarPT <$> var - -typeApp :: (Monad m) => ParsecT [Char] u m ParseType -typeApp = do name <- capVar - args <- spacePrefix (typeUnambiguous <|> typeSimple) - return $ case args of - [] -> VarPT name - _ -> ADTPT name args - -typeExpr :: (Monad m) => ParsecT [Char] u m ParseType -typeExpr = do - t1 <- typeVar <|> typeApp <|> typeUnambiguous - whitespace ; arr <- optionMaybe arrow ; whitespace - case arr of Just _ -> LambdaPT t1 <$> typeExpr - Nothing -> return t1 - -typeConstructor :: (Monad m) => ParsecT [Char] u m (String, [ParseType]) -typeConstructor = (,) <$> capVar <*> spacePrefix (typeSimple <|> typeUnambiguous) - -datatype :: (Monad m) => ParsecT [Char] u m ([String], [Expr], GuidCounter [Type]) -datatype = do - reserved "data" "datatype definition (data T = A | B | ...)" - forcedWS ; name <- capVar ; args <- spacePrefix lowVar - whitespace ; string "=" ; whitespace - tcs <- pipeSep1 typeConstructor - return $ (map fst tcs , map toFunc tcs , toTypes name args tcs) - -beta = liftM VarT 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 [] +module ParseTypes where + +import Ast +import Control.Applicative ((<$>),(<*>)) +import Control.Monad (liftM) +import Data.Char (isUpper,isLower) +import Data.Maybe (fromMaybe) +import Data.List (lookup) +import Text.Parsec + +import ParseLib +import Types hiding (string,parens) +import Guid + +data ParseType = VarPT String + | LambdaPT ParseType ParseType + | ADTPT String [ParseType] + +listPT t = ADTPT "List" [t] +tuplePT ts = ADTPT ("Tuple" ++ show (length ts)) ts + +typeVar :: (Monad m) => ParsecT [Char] u m ParseType +typeVar = VarPT <$> lowVar "type variable" + +typeList :: (Monad m) => ParsecT [Char] u m ParseType +typeList = listPT <$> braces typeExpr + +typeTuple :: (Monad m) => ParsecT [Char] u m ParseType +typeTuple = do ts <- parens (commaSep typeExpr) + return $ case ts of { [t] -> t ; _ -> tuplePT ts } + +typeUnambiguous :: (Monad m) => ParsecT [Char] u m ParseType +typeUnambiguous = typeList <|> typeTuple + +typeSimple :: (Monad m) => ParsecT [Char] u m ParseType +typeSimple = VarPT <$> var + +typeApp :: (Monad m) => ParsecT [Char] u m ParseType +typeApp = do name <- capVar "type constructor" + args <- spacePrefix (typeUnambiguous <|> typeSimple) + return $ case args of + [] -> VarPT name + _ -> ADTPT name args + +typeExpr :: (Monad m) => ParsecT [Char] u m ParseType +typeExpr = do + t1 <- typeVar <|> typeApp <|> typeUnambiguous + whitespace ; arr <- optionMaybe arrow ; whitespace + case arr of Just _ -> LambdaPT t1 <$> typeExpr + Nothing -> return t1 + +typeConstructor :: (Monad m) => ParsecT [Char] u m (String, [ParseType]) +typeConstructor = (,) <$> (capVar "another type constructor") <*> spacePrefix (typeSimple <|> typeUnambiguous) + +datatype :: (Monad m) => ParsecT [Char] u m ([String], [Expr], GuidCounter [Type]) +datatype = do + reserved "data" "datatype definition (data T = A | B | ...)" + forcedWS ; name <- capVar "name of data-type" ; args <- spacePrefix lowVar + whitespace ; string "=" ; whitespace + tcs <- pipeSep1 typeConstructor + return $ (map fst tcs , map toFunc tcs , toTypes name args tcs) + +beta = liftM VarT 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,4 +1,4 @@ -module Parser (toDefs) where +module Parser (parseProgram) where import Ast import Control.Applicative ((<$>), (<*>)) @@ -8,122 +8,32 @@ import Text.Parsec hiding (newline,spaces) import ParseLib -import Patterns -import Binops +import ParseExpr import ParseTypes - -import Guid -import Types (Type (VarT)) - --------- Basic Terms -------- - -numTerm :: (Monad m) => ParsecT [Char] u m Expr -numTerm = liftM (Number . read) (many1 digit) "number" - -strTerm :: (Monad m) => ParsecT [Char] u m Expr -strTerm = liftM Str . expecting "string" . betwixt '"' '"' . many $ - backslashed <|> satisfy (/='"') - -varTerm :: (Monad m) => ParsecT [Char] u m Expr -varTerm = toVar <$> var "variable" - -toVar v = case v of "True" -> Boolean True - "False" -> Boolean False - _ -> Var v - -chrTerm :: (Monad m) => ParsecT [Char] u m Expr -chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\'')) - "character" - - --------- Complex Terms -------- - -listTerm = braces $ choice - [ try $ do { lo <- expr; whitespace; string ".." ; whitespace - ; Range lo <$> expr } - , list <$> commaSep expr - ] - -parensTerm = parens $ choice - [ do op <- anyOp - return . Lambda "x" . Lambda "y" $ Binop op (Var "x") (Var "y") - , do es <- commaSep expr - return $ case es of { [e] -> e; _ -> tuple es } - ] - -term = choice [ numTerm, strTerm, chrTerm - , accessible varTerm - , listTerm, parensTerm ] - "basic term (4, x, 'c', etc.)" - --------- Applications -------- - -appExpr = do - tlist <- spaceSep1 term - return $ case tlist of - t:[] -> t - t:ts -> foldl' App t ts - --------- Normal Expressions -------- - -binaryExpr = binops appExpr anyOp - -ifExpr = do reserved "if" ; whitespace ; e1 <- expr ; whitespace - reserved "then" ; whitespace ; e2 <- expr ; (whitespace "an 'else' branch") - reserved "else" "an 'else' branch" ; whitespace ; If e1 e2 <$> expr - -lambdaExpr = do char '\\' <|> char '\x03BB' "anonymous function" - whitespace - args <- spaceSep1 patternTerm - whitespace ; arrow ; whitespace - e <- expr - return $ makeFunction args e - -assignExpr = do - patterns <- - choice [ try $ do v <- PVar <$> lowVar - notFollowedBy (whitespace >> char ':') - (v:) <$> spacePrefix patternTerm - , (:[]) <$> patternExpr - ] "the definition of a variable (x = ...)" - whitespace; string "="; whitespace; exp <- expr - flattenPatterns patterns exp - -letExpr = do - reserved "let" - brace <- optionMaybe . try $ do - whitespace - char '{' "a set of definitions { x = ... ; y = ... }" - case brace of - Nothing -> do whitespace; ds <- assignExpr - whitespace; reserved "in"; whitespace; Let ds <$> expr - Just '{' -> do whitespace ; dss <- semiSep1 assignExpr ; whitespace - string "}" "closing bracket '}'" - whitespace; reserved "in"; whitespace; e <- expr - return $ Let (concat dss) e - -caseExpr = do - reserved "case"; whitespace; e <- expr; whitespace; reserved "of"; whitespace - Case e <$> brackets (semiSep1 (case_ "cases { x -> ... }")) - where case_ = do p <- patternExpr; whitespace; arrow; whitespace - (,) p <$> expr +import ParseModules -expr = choice [ ifExpr, letExpr, caseExpr, lambdaExpr, binaryExpr ] "expression" - -def = do (fs,es) <- unzip <$> assignExpr - return (fs, es, mapM (\_ -> liftM VarT guid) fs) +freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do + freshLine + datatype <|> def "another datatype or variable definition" -defs1 = do optional freshLine - d <- datatype <|> def - (d:) <$> many (try (try freshLine >> (datatype <|> def))) +defs1 = do d <- datatype <|> def "at least one datatype or variable definition" + (d:) <$> many freshDef defs = do (fss,ess,tss) <- unzip3 <$> defs1 - let (fs,es,ts) = (concat fss, concat ess, concat `liftM` sequence tss) + return (concat fss, concat ess, concat `liftM` sequence tss) + +program = do + optional freshLine + (names,exports) <- option ([],[]) (moduleDef `followedBy` freshLine) + is <- (do try (lookAhead $ reserved "import") + imports `followedBy` freshLine) <|> return [] + (vs,es,ts) <- defs optional freshLine ; optional spaces ; eof - return (Let (zip fs es) (Var "main"), liftM (zip fs) ts) + return (Module names exports is $ zip vs es, zip vs `liftM` ts) -toDefs source = case parse defs "" source of - Right result -> Right result - Left err -> Left $ "Parse error at " ++ show err +parseProgram source = + case parse program "" source of + Right result -> Right result + Left err -> Left $ "Parse error at " ++ show err diff --git a/src/Parse/Patterns.hs b/src/Parse/Patterns.hs --- a/src/Parse/Patterns.hs +++ b/src/Parse/Patterns.hs @@ -1,53 +1,53 @@ -module Patterns (patternTerm, patternExpr, makeFunction, flattenPatterns) where - -import Ast -import Data.Char (isUpper) -import Control.Applicative ((<$>)) -import Control.Monad -import Text.Parsec -import ParseLib - -patternBasic :: Monad m => ParsecT [Char] u m Pattern -patternBasic = - choice [ char '_' >> return PAnything - , do x@(c:_) <- var - if isUpper c then PData x <$> spacePrefix patternTerm - else return $ PVar x - ] - -patternTuple :: Monad m => ParsecT [Char] u m Pattern -patternTuple = do ps <- parens (commaSep patternExpr) - return $ case ps of { [p] -> p; _ -> ptuple ps } - -patternList :: Monad m => ParsecT [Char] u m Pattern -patternList = plist <$> braces (commaSep patternExpr) - -patternTerm :: Monad m => ParsecT [Char] u m Pattern -patternTerm = patternTuple <|> patternList <|> patternBasic "pattern" - -patternExpr :: Monad m => ParsecT [Char] u m Pattern -patternExpr = foldl1 pcons <$> consSep1 patternTerm "pattern" - - - -makeFunction args body = foldr func body args - where func PAnything e = Lambda "_" e - func (PVar x) e = Lambda x e - func p e = "t" `Lambda` Case (Var "t") [(p,e)] - -flattenPatterns (PVar f : args) exp = return [(f, makeFunction args exp)] -flattenPatterns [p] exp = return $ matchSingle p exp p -flattenPatterns ps _ = - fail $ "Pattern (" ++ unwords (map show ps) ++ - ") cannot be used on the left-hand side of an assign statement." - -matchSingle pat exp p@(PData _ ps) = - (v, exp) : concatMap (matchSingle p $ Var v) ps - where v = "'" ++ getName p -matchSingle pat exp (PVar x) = [ (x, Case exp [(pat,Var x)]) ] -matchSingle pat exp PAnything = [] - -getName (PData n ps) = n ++ concatMap getName ps -getName (PAnything) = "_" -getName (PVar x) = x - +module Patterns (patternTerm, patternExpr, makeFunction, flattenPatterns) where + +import Ast +import Data.Char (isUpper) +import Control.Applicative ((<$>)) +import Control.Monad +import Text.Parsec +import ParseLib + +patternBasic :: Monad m => ParsecT [Char] u m Pattern +patternBasic = + choice [ char '_' >> return PAnything + , do x@(c:_) <- var + if isUpper c then PData x <$> spacePrefix patternTerm + else return $ PVar x + ] + +patternTuple :: Monad m => ParsecT [Char] u m Pattern +patternTuple = do ps <- parens (commaSep patternExpr) + return $ case ps of { [p] -> p; _ -> ptuple ps } + +patternList :: Monad m => ParsecT [Char] u m Pattern +patternList = plist <$> braces (commaSep patternExpr) + +patternTerm :: Monad m => ParsecT [Char] u m Pattern +patternTerm = patternTuple <|> patternList <|> patternBasic "pattern" + +patternExpr :: Monad m => ParsecT [Char] u m Pattern +patternExpr = foldl1 pcons <$> consSep1 patternTerm "pattern" + + + +makeFunction args body = foldr func body args + where func PAnything e = Lambda "_" e + func (PVar x) e = Lambda x e + func p e = "t" `Lambda` Case (Var "t") [(p,e)] + +flattenPatterns (PVar f : args) exp = return [(f, makeFunction args exp)] +flattenPatterns [p] exp = return $ matchSingle p exp p +flattenPatterns ps _ = + fail $ "Pattern (" ++ unwords (map show ps) ++ + ") cannot be used on the left-hand side of an assign statement." + +matchSingle pat exp p@(PData _ ps) = + (v, exp) : concatMap (matchSingle p $ Var v) ps + where v = "'" ++ getName p +matchSingle pat exp (PVar x) = [ (x, Case exp [(pat,Var x)]) ] +matchSingle pat exp PAnything = [] + +getName (PData n ps) = n ++ concatMap getName ps +getName (PAnything) = "_" +getName (PVar x) = x +