├── .gitignore ├── ChangeLog.md ├── LICENSE ├── Main.wat ├── Setup.hs ├── app └── Main.hs ├── elm └── Main.elm ├── elmish-wasm.cabal ├── example.wat ├── package.yaml ├── readme.md ├── src ├── Data.hs ├── Data │ └── Module.hs ├── File.hs ├── Function.hs ├── Line.hs ├── Module.hs ├── Module │ └── Data.hs ├── Part.hs ├── Read.hs ├── Result.hs ├── Util.hs └── Write.hs ├── stack.yaml └── test └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | elmish-wasm.cabal 3 | *~ -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for elmish-wasm 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Main.wat: -------------------------------------------------------------------------------- 1 | ( module ( export "addThree" (func $addThree)) ( export "addTwo" (func $addTwo)) ) -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified System.Environment as System 4 | import qualified Data.ByteString as Byte 5 | import Flow 6 | import qualified Data.ByteString.Char8 as C 7 | import qualified Data.Module as Module 8 | import Result (Problem(..), Result(..)) 9 | import qualified Read 10 | import qualified Write 11 | 12 | 13 | -- MAIN -- 14 | 15 | 16 | main :: IO () 17 | main = do 18 | args <- System.getArgs 19 | handleArgs args 20 | 21 | 22 | handleArgs :: [ String ] -> IO () 23 | handleArgs [] = putStrLn "Error : No file was given. Try typing \"elmish fileName.elm\"" 24 | handleArgs (fn : _) = do 25 | file <- Byte.readFile fn 26 | file 27 | |> C.unpack 28 | |> Read.file 29 | |> handleResult 30 | 31 | 32 | handleResult :: Result Module.Model -> IO () 33 | handleResult result = 34 | case result of 35 | Problem problem -> 36 | putStrLn (handleProblem problem) 37 | 38 | Ok module_ -> 39 | Write.wat module_ 40 | 41 | 42 | handleProblem :: Problem -> String 43 | handleProblem problem = 44 | case problem of 45 | NoModuleName -> 46 | "Error : This file has no module name. The first line should start with the word \"module\" followed by the module name." 47 | 48 | InvalidExposedFunctions -> 49 | "Error : Modules expose functions, but there is something wrong with the syntax in how this modules exposed functions are set" 50 | 51 | FileIsEmpty -> 52 | "Error : This file looks to be totally empty" 53 | -------------------------------------------------------------------------------- /elm/Main.elm: -------------------------------------------------------------------------------- 1 | module Main exposing (addThree, addTwo) 2 | 3 | 4 | addTwo : Int -> Int -> Int 5 | addTwo a b = 6 | a + b 7 | 8 | 9 | addThree : Int -> Int -> Int -> Int 10 | addThree a b c = 11 | a + b + c 12 | -------------------------------------------------------------------------------- /elmish-wasm.cabal: -------------------------------------------------------------------------------- 1 | -- This file has been generated from package.yaml by hpack version 0.20.0. 2 | -- 3 | -- see: https://github.com/sol/hpack 4 | -- 5 | -- hash: ffffed75438c1733bd393bf0c9540f8b4844d3320c3f1e8321eaab24ea70e588 6 | 7 | name: elmish-wasm 8 | version: 0.1.0.0 9 | synopsis: Short description of your package 10 | description: Please see the README on Github at 11 | homepage: https://github.com/chadtech/elmish-wasm#readme 12 | bug-reports: https://github.com/chadtech/elmish-wasm/issues 13 | author: Chadtech 14 | maintainer: chadtech0@gmail.com 15 | copyright: 2017 Chadtech 16 | license: BSD3 17 | license-file: LICENSE 18 | build-type: Simple 19 | cabal-version: >= 1.10 20 | 21 | extra-source-files: 22 | ChangeLog.md 23 | README.md 24 | 25 | source-repository head 26 | type: git 27 | location: https://github.com/chadtech/elmish-wasm 28 | 29 | library 30 | hs-source-dirs: 31 | src 32 | build-depends: 33 | base >=4.7 && <5 34 | , bytestring 35 | , flow 36 | , ilist 37 | , regex-posix 38 | , split 39 | , text 40 | exposed-modules: 41 | Data 42 | Data.Module 43 | File 44 | Function 45 | Line 46 | Module 47 | Module.Data 48 | Part 49 | Read 50 | Result 51 | Util 52 | Write 53 | other-modules: 54 | Paths_elmish_wasm 55 | default-language: Haskell2010 56 | 57 | executable elmish-wasm-exe 58 | main-is: Main.hs 59 | hs-source-dirs: 60 | app 61 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 62 | build-depends: 63 | base >=4.7 && <5 64 | , bytestring 65 | , elmish-wasm 66 | , flow 67 | , ilist 68 | , regex-posix 69 | , split 70 | , text 71 | other-modules: 72 | Paths_elmish_wasm 73 | default-language: Haskell2010 74 | 75 | test-suite elmish-wasm-test 76 | type: exitcode-stdio-1.0 77 | main-is: Spec.hs 78 | hs-source-dirs: 79 | test 80 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 81 | build-depends: 82 | base >=4.7 && <5 83 | , bytestring 84 | , elmish-wasm 85 | , flow 86 | , ilist 87 | , regex-posix 88 | , split 89 | , text 90 | other-modules: 91 | Paths_elmish_wasm 92 | default-language: Haskell2010 93 | -------------------------------------------------------------------------------- /example.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (func $addTwo (param i32 i32) (result i32) 3 | get_local 0 4 | get_local 1 5 | i32.add 6 | ) 7 | (func $addThree (param i32 i32 i32) (result i32) 8 | get_local 0 9 | get_local 1 10 | i32.add 11 | get_local 2 12 | i32.add 13 | ) 14 | (export "addTwo" (func $addTwo)) 15 | (export "addThree" (func $addThree)) 16 | ) 17 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: elmish-wasm 2 | version: 0.1.0.0 3 | github: "chadtech/elmish-wasm" 4 | license: BSD3 5 | author: "Chadtech" 6 | maintainer: "chadtech0@gmail.com" 7 | copyright: "2017 Chadtech" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on Github at 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | - flow 25 | - text 26 | - regex-posix 27 | - split 28 | - bytestring 29 | - ilist 30 | 31 | library: 32 | source-dirs: src 33 | 34 | 35 | executables: 36 | elmish-wasm-exe: 37 | main: Main.hs 38 | source-dirs: app 39 | ghc-options: 40 | - -threaded 41 | - -rtsopts 42 | - -with-rtsopts=-N 43 | dependencies: 44 | - elmish-wasm 45 | 46 | tests: 47 | elmish-wasm-test: 48 | main: Spec.hs 49 | source-dirs: test 50 | ghc-options: 51 | - -threaded 52 | - -rtsopts 53 | - -with-rtsopts=-N 54 | dependencies: 55 | - elmish-wasm 56 | -------------------------------------------------------------------------------- /readme.md: -------------------------------------------------------------------------------- 1 | # Elmish Wasm Experiment 2 | 3 | 4 | # What is this all about? 5 | 6 | Web assembly is promising new web technology. Elm is a programming language. Lots of people in the Elm community expect Elm to one day compile to web assembly. This repo is an experiment to see what potential there is for Elm to compile to web assembly. 7 | 8 | # How can we make Elm compile to Web Assembly? 9 | 10 | I dont know. Thats a really big task. Lets start small. 11 | 12 | A lot of people talk about Web Assembly as if its C++ that runs in the browser. Thats not the case. Web Assembly (or "wasm") is human-unreadable bytecode. There is a human-readable version of wasm, called wat. It looks like this.. 13 | 14 | ``` 15 | ;; A function that adds two numbers 16 | (module 17 | (func $addTwo (param i32 i32) (result i32) 18 | get_local 0 19 | get_local 1 20 | i32.add 21 | ) 22 | (export "addTwo" (func $addTwo)) 23 | ) 24 | ``` 25 | 26 | Reading that code line by line, it goes something like this.. 27 | 28 | ``` 29 | Theres a function called addTwo it takes two int parameters and returns and int. 30 | First it gets the first parameter, 31 | then it gets the second parameter, 32 | and then it adds the parameters. 33 | Export addTwo into JavaScript world and name it "addTwo". 34 | ``` 35 | 36 | So to start small, lets make something that merely looks like Elm- we will call it "Elmish"- and compile it to wat. I imagine an Elmish program that compiles to the wat code above looking like this: 37 | 38 | ```elm 39 | module Main exposing (addTwo) 40 | 41 | 42 | addTwo : Int -> Int -> Int 43 | addTwo a b = 44 | a + b 45 | 46 | ``` 47 | 48 | Making a compiler that compiles Elmish to wat is what I am trying to do. 49 | 50 | 51 | ## Update : 20180217 52 | 53 | Much of what this repo did was reading Elm files with Haskell and Regex, and parsing out the syntax. Thats already what the Elm compiler does, so perhaps its not that valuable of work. Moving forward, one could just hack the Elm compiler to compile to a different target. But rather than that, maybe a different direction entirely is called for: See here: https://gist.github.com/Chadtech/c966d30613c588ef2dc45026a1e29731 54 | 55 | 56 | 57 | -------------------------------------------------------------------------------- /src/Data.hs: -------------------------------------------------------------------------------- 1 | module Data 2 | ( Type(..) ) 3 | where 4 | 5 | 6 | data Type 7 | = Int_ 8 | | Float_ 9 | | Bool_ 10 | 11 | 12 | -------------------------------------------------------------------------------- /src/Data/Module.hs: -------------------------------------------------------------------------------- 1 | module Data.Module 2 | ( Model(..) 3 | , Exposing(..) 4 | ) 5 | where 6 | 7 | import Part (Part(..)) 8 | import qualified Function 9 | 10 | 11 | data Model = 12 | Ctor 13 | { name :: String 14 | , exposing :: Exposing 15 | , parts :: [Part] 16 | } 17 | 18 | 19 | data Exposing 20 | = All 21 | | Only [String] 22 | 23 | 24 | -------------------------------------------------------------------------------- /src/File.hs: -------------------------------------------------------------------------------- 1 | module File 2 | ( Model(..) 3 | , fromString 4 | ) 5 | where 6 | 7 | 8 | import qualified Util 9 | import qualified Data.List as List 10 | import Result (Result(..), Problem(..)) 11 | import Data.List.Split (splitOn) 12 | import Flow 13 | import Line (Line) 14 | import qualified Line 15 | 16 | 17 | data Model = 18 | Ctor 19 | { module_ :: [Line] 20 | , imports :: [Line] 21 | , parts :: [Line] 22 | } 23 | 24 | 25 | fromString :: String -> Result Model 26 | fromString fileData = 27 | Ok (Ctor, Line.fromString fileData) 28 | |> construct readModule 29 | |> construct readImports 30 | |> construct readParts 31 | |> prepareResult 32 | 33 | 34 | prepareResult :: Result (Model, [Line]) -> Result Model 35 | prepareResult result = 36 | case result of 37 | Problem problem -> 38 | Problem problem 39 | 40 | Ok (model, lines) -> 41 | Ok model 42 | 43 | 44 | construct :: ([Line] -> Result (a, [Line])) -> Result ((a -> b), [Line]) -> Result (b, [Line]) 45 | construct reader step = 46 | case step of 47 | Problem problem -> 48 | Problem problem 49 | 50 | Ok (ctor, lines) -> 51 | case reader lines of 52 | Problem problem -> 53 | Problem problem 54 | 55 | Ok (part, remainingLines) -> 56 | Ok ((ctor part), remainingLines) 57 | 58 | 59 | -- READERS -- 60 | 61 | 62 | readImports :: [Line] -> Result ([Line], [Line]) 63 | readImports lines = 64 | readImportsHelper ([], lines) 65 | |> Ok 66 | 67 | 68 | readImportsHelper :: ([Line], [Line]) -> ([Line], [Line]) 69 | readImportsHelper (imports, lines) = 70 | case lines of 71 | first : rest -> 72 | case Line.firstWord first of 73 | Just "import" -> 74 | readImportsHelper (first : imports, rest) 75 | 76 | _ -> 77 | (imports, lines) 78 | 79 | [] -> 80 | (imports, lines) 81 | 82 | 83 | readParts :: [Line] -> Result ([Line], [Line]) 84 | readParts lines = 85 | Ok (lines, []) 86 | 87 | 88 | readModule :: [Line] -> Result ([Line], [Line]) 89 | readModule lines = 90 | case Line.getFirstBlock lines of 91 | Nothing -> 92 | Problem FileHasNoModuleSection 93 | 94 | Just (firstBlock, rest) -> 95 | case firstBlock of 96 | first : _ -> 97 | case Line.firstWord first of 98 | Just "module" -> 99 | Ok (firstBlock, rest) 100 | 101 | _ -> 102 | Problem FileHasNoModuleSection 103 | 104 | [] -> 105 | Problem FileIsEmpty 106 | 107 | 108 | -------------------------------------------------------------------------------- /src/Function.hs: -------------------------------------------------------------------------------- 1 | module Function 2 | ( Model(..) 3 | , read 4 | , write 5 | ) 6 | where 7 | 8 | import Data (Type(..)) 9 | import qualified Util as Util 10 | import Flow 11 | import Prelude hiding (read) 12 | import Result (Problem(..), Result(..)) 13 | import Line (Line) 14 | import qualified Data.List as List 15 | 16 | 17 | data Model = 18 | Ctor 19 | { name :: String } 20 | 21 | 22 | read :: String -> [Line] -> Result Model 23 | read name_ block = 24 | Ok (Ctor name_) 25 | 26 | 27 | write :: Model -> String 28 | write model = 29 | [ "(func" 30 | , "$" ++ name model 31 | , ")" 32 | ] 33 | |> List.intercalate " " 34 | -------------------------------------------------------------------------------- /src/Line.hs: -------------------------------------------------------------------------------- 1 | module Line 2 | ( Line 3 | , getIndex 4 | , getContent 5 | , fromString 6 | , toString 7 | , filterEmpties 8 | , firstWord 9 | , regex 10 | , getFirstBlock 11 | , toBlocks 12 | ) 13 | where 14 | 15 | import qualified Util as Util 16 | import qualified Data.List as List 17 | import Flow 18 | import Data.List.Index (indexed) 19 | import Data.List.Split (splitOn) 20 | 21 | 22 | data Line = 23 | Line Int String 24 | 25 | 26 | getIndex :: Line -> Int 27 | getIndex (Line index _) = 28 | index 29 | 30 | 31 | getContent :: Line -> String 32 | getContent (Line _ content) = 33 | content 34 | 35 | 36 | fromString :: String -> [Line] 37 | fromString str = 38 | str 39 | |> splitOn "\n" 40 | |> indexed 41 | |> List.map fromTuple 42 | 43 | 44 | toString :: [Line] -> String 45 | toString lines = 46 | lines 47 | |> List.map getContent 48 | |> List.intersperse "\n" 49 | |> concat 50 | 51 | 52 | fromTuple :: (Int, String) -> Line 53 | fromTuple (index, str) = 54 | Line index str 55 | 56 | 57 | filterEmpties :: [Line] -> [Line] 58 | filterEmpties = 59 | List.filter isntEmpty 60 | 61 | 62 | firstWord :: Line -> Maybe String 63 | firstWord line = 64 | getContent line |> Util.firstWord 65 | 66 | 67 | regex :: (String -> a) -> Line -> a 68 | regex r (Line _ str) = 69 | r str 70 | 71 | 72 | isntEmpty :: Line -> Bool 73 | isntEmpty (Line _ "") = False 74 | isntEmpty (Line _ _) = True 75 | 76 | 77 | startsWithSpace :: Line -> Bool 78 | startsWithSpace (Line _ (' ' : rest)) = True 79 | startsWithSpace _ = False 80 | 81 | 82 | getFirstBlock :: [Line] -> Maybe ([Line], [Line]) 83 | getFirstBlock lines = 84 | case lines of 85 | [] -> 86 | Nothing 87 | 88 | _ -> 89 | ([], lines) 90 | |> firstBlockHelper 91 | |> Just 92 | 93 | 94 | firstBlockHelper :: ([Line], [Line]) -> ([Line], [Line]) 95 | firstBlockHelper (firstBlock, lines) = 96 | case lines of 97 | first : rest -> 98 | if startsWithSpace first then 99 | (List.reverse firstBlock, lines) 100 | else 101 | firstBlockHelper (first : firstBlock, rest) 102 | 103 | [] -> 104 | (List.reverse firstBlock, []) 105 | 106 | 107 | toBlocks :: [Line] -> [[Line]] 108 | toBlocks lines = 109 | toBlocksHelper (lines, []) 110 | 111 | 112 | toBlocksHelper :: ([Line], [[Line]]) -> [[Line]] 113 | toBlocksHelper (lines, blocks) = 114 | case getFirstBlock lines of 115 | Just (firstBlock, rest) -> 116 | toBlocksHelper (rest, firstBlock : blocks) 117 | 118 | Nothing -> 119 | blocks 120 | 121 | -------------------------------------------------------------------------------- /src/Module.hs: -------------------------------------------------------------------------------- 1 | module Module 2 | ( readName 3 | , readExposedParts 4 | , readParts 5 | , write 6 | ) 7 | where 8 | 9 | 10 | import Line (Line) 11 | import Result (Result(..), Problem(..)) 12 | import qualified Result 13 | import qualified Line 14 | import qualified Part 15 | import Part (Part(..)) 16 | import Text.Regex.Posix 17 | import Data.List as List 18 | import Data.List.Split (splitOn) 19 | import Flow 20 | import qualified Util 21 | import qualified Function 22 | import Data.Module 23 | ( Model(..) 24 | , Exposing (..) 25 | ) 26 | 27 | 28 | -- READ -- 29 | 30 | 31 | readName :: [Line] -> Result String 32 | readName lines = 33 | case nameRegex (Line.toString lines) of 34 | ("", moduleName, _) -> 35 | Ok (List.drop 7 moduleName) 36 | 37 | _ -> 38 | Problem NoModuleName 39 | 40 | 41 | nameRegex :: String -> (String, String, String) 42 | nameRegex fileData = 43 | fileData =~ "module [A-Za-z]*" 44 | 45 | 46 | exposingRegex :: String -> Maybe String 47 | exposingRegex fileData = 48 | fileData =~~ "exposing[ \t\n]*\\(.*\\)" 49 | 50 | 51 | readExposedParts :: [Line] -> Result Exposing 52 | readExposedParts lines = 53 | case nameRegex (Line.toString lines) of 54 | ("", moduleName, after) -> 55 | case exposingRegex after of 56 | Just "(..)" -> 57 | Ok All 58 | 59 | Just functions -> 60 | functions 61 | |> List.drop 10 62 | |> reverse 63 | |> List.drop 1 64 | |> reverse 65 | |> splitOn "," 66 | |> List.map Util.trim 67 | |> Only 68 | |> Ok 69 | 70 | Nothing -> 71 | Problem InvalidExposedFunctions 72 | 73 | _ -> 74 | Problem NoModuleName 75 | 76 | 77 | readParts :: [Line] -> Result [Part] 78 | readParts lines = 79 | lines 80 | |> Line.filterEmpties 81 | |> Line.toBlocks 82 | |> List.map Part.read 83 | |> Result.flatten 84 | 85 | 86 | 87 | -- WRITE -- 88 | 89 | 90 | write :: Model -> String 91 | write model = 92 | "( module " ++ (writeBody model) ++ ")" 93 | 94 | 95 | writeBody :: Model -> String 96 | writeBody model = 97 | (writeParts model) ++ (writeExports model) 98 | 99 | 100 | writeParts :: Model -> String 101 | writeParts model = 102 | model 103 | |> Data.Module.parts 104 | |> List.map Part.write 105 | |> List.intercalate " " 106 | 107 | 108 | writeExports :: Model -> String 109 | writeExports model = 110 | case Data.Module.exposing model of 111 | All -> 112 | "" 113 | 114 | Only functionNames -> 115 | functionNames 116 | |> List.map writeExport 117 | |> concat 118 | 119 | 120 | writeExport :: String -> String 121 | writeExport functionName = 122 | [ "( export \"" 123 | , functionName 124 | , "\" (func $" 125 | , functionName 126 | , ")) " 127 | ] 128 | |> concat 129 | 130 | -------------------------------------------------------------------------------- /src/Module/Data.hs: -------------------------------------------------------------------------------- 1 | module Module.Data 2 | ( Model(..) 3 | , Part(..) 4 | , Exposing(..) 5 | ) 6 | where 7 | 8 | 9 | import qualified Function 10 | 11 | 12 | data Model = 13 | Ctor 14 | { name :: String 15 | , exposing :: Exposing 16 | , parts :: [ Part ] 17 | } 18 | 19 | 20 | data Exposing 21 | = All 22 | | Only [ String ] 23 | 24 | 25 | data Part 26 | = FunctionTypeSignature 27 | | Function Function.Model 28 | | UnionType 29 | 30 | 31 | 32 | -------------------------------------------------------------------------------- /src/Part.hs: -------------------------------------------------------------------------------- 1 | module Part 2 | ( Part(..) 3 | , read 4 | , write 5 | ) 6 | where 7 | 8 | 9 | import Text.Regex.Posix 10 | import Data.List.Split (splitOn) 11 | import qualified Function 12 | import Line (Line) 13 | import qualified Line 14 | import Result (Result(..), Problem(..)) 15 | import qualified Result 16 | import Prelude hiding (read) 17 | import qualified Util 18 | import qualified Data.List as List 19 | import Flow 20 | import Data (Type(..)) 21 | 22 | 23 | data Part 24 | = Function Function.Model 25 | | TypeSignature String [Type] 26 | 27 | 28 | read :: [Line] -> Result Part 29 | read block = 30 | case block of 31 | first : _ -> 32 | case Line.regex firstWord first of 33 | Just name -> 34 | if Line.regex isTypeSignature first then 35 | block 36 | |> readTypeSignature name 37 | else 38 | block 39 | |> Function.read name 40 | |> Result.map Function 41 | 42 | Nothing -> 43 | Problem BlockStartsWithOutFirstWord 44 | 45 | [] -> 46 | Problem BlockWasEmpty 47 | 48 | 49 | readTypeSignature :: String -> [Line] -> Result Part 50 | readTypeSignature name block = 51 | case getSignaturePart (Line.toString block) of 52 | (_, ":", signaturePart) -> 53 | signaturePart 54 | |> splitOn "->" 55 | |> List.map Util.trim 56 | |> List.map (readType block) 57 | |> Result.flatten 58 | |> Result.map (TypeSignature name) 59 | 60 | _ -> 61 | Problem (TypeSignatureSyntaxIsWrong block) 62 | 63 | 64 | readType :: [Line] -> String -> Result Type 65 | readType block str = 66 | case str of 67 | "Int" -> 68 | Ok Int_ 69 | 70 | "Float" -> 71 | Ok Float_ 72 | 73 | "Bool" -> 74 | Ok Bool_ 75 | 76 | _ -> 77 | Problem (UnrecognizedType block str) 78 | 79 | 80 | getSignaturePart :: String -> (String, String, String) 81 | getSignaturePart str = 82 | str =~ ":" 83 | 84 | 85 | firstWord :: String -> Maybe String 86 | firstWord str = 87 | str =~~ "[a-z][A-Za-z0-9]* " 88 | 89 | 90 | isTypeSignature :: String -> Bool 91 | isTypeSignature str = 92 | str =~ "[a-z][A-Za-z0-9]* *:" 93 | 94 | 95 | -- WRITE -- 96 | 97 | 98 | write :: Part -> String 99 | write part = 100 | case part of 101 | Function model -> 102 | Function.write model 103 | 104 | TypeSignature name types -> 105 | "" 106 | 107 | -------------------------------------------------------------------------------- /src/Read.hs: -------------------------------------------------------------------------------- 1 | module Read 2 | (file) 3 | where 4 | 5 | import qualified Data.Module as Module 6 | import qualified Module 7 | import Result (Result(..), Problem(..)) 8 | import Flow 9 | import Text.Regex.Posix 10 | import qualified Data.List as List 11 | import Data.List.Split (splitOn) 12 | import qualified File 13 | 14 | 15 | construct :: part -> (part -> Result a) -> Result (a -> b) -> Result b 16 | construct fileData reader step = 17 | case step of 18 | Problem problem -> 19 | Problem problem 20 | 21 | Ok ctor -> 22 | case reader fileData of 23 | Problem problem -> 24 | Problem problem 25 | 26 | Ok part -> 27 | Ok (ctor part) 28 | 29 | 30 | file :: String -> Result Module.Model 31 | file fileData = 32 | case File.fromString fileData of 33 | Ok file -> 34 | Ok Module.Ctor 35 | |> construct (File.module_ file) Module.readName 36 | |> construct (File.module_ file) Module.readExposedParts 37 | |> construct (File.parts file) Module.readParts 38 | 39 | Problem problem -> 40 | Problem problem 41 | 42 | -------------------------------------------------------------------------------- /src/Result.hs: -------------------------------------------------------------------------------- 1 | module Result 2 | ( Result(..) 3 | , Problem(..) 4 | , map 5 | , flatten 6 | ) 7 | where 8 | 9 | 10 | import Prelude hiding (map) 11 | import qualified Data.List as List 12 | import Line (Line) 13 | 14 | 15 | data Problem 16 | = NoModuleName 17 | | InvalidExposedFunctions 18 | | FileIsEmpty 19 | | BlockStartsWithOutFirstWord 20 | | BlockWasEmpty 21 | | FileHasNoModuleSection 22 | | UnrecognizedType [Line] String 23 | | TypeSignatureSyntaxIsWrong [Line] 24 | | None 25 | 26 | 27 | data Result a 28 | = Problem Problem 29 | | Ok a 30 | 31 | 32 | map :: (a -> b) -> Result a -> Result b 33 | map f result = 34 | case result of 35 | Ok x -> 36 | Ok (f x) 37 | 38 | Problem problem -> 39 | Problem problem 40 | 41 | 42 | flatten :: [Result a] -> Result [a] 43 | flatten results = 44 | flattenHelper ([], results) 45 | 46 | 47 | flattenHelper :: ([a], [Result a]) -> Result [a] 48 | flattenHelper (xs, results) = 49 | case results of 50 | Problem problem : _ -> 51 | Problem problem 52 | 53 | Ok x : rest -> 54 | flattenHelper (x : xs, rest) 55 | 56 | [] -> 57 | Ok (List.reverse xs) 58 | 59 | -------------------------------------------------------------------------------- /src/Util.hs: -------------------------------------------------------------------------------- 1 | module Util 2 | ( firstWord 3 | , trim 4 | , log_ 5 | ) 6 | where 7 | 8 | import Text.Regex.Posix 9 | import qualified Data.List as List 10 | import qualified Data.Char as Char 11 | import qualified Debug.Trace as Debug 12 | import Flow 13 | 14 | 15 | trim :: String -> String 16 | trim = 17 | List.dropWhileEnd Char.isSpace 18 | >> List.dropWhile Char.isSpace 19 | 20 | 21 | firstWord :: String -> Maybe String 22 | firstWord fileData = 23 | fileData =~~ "([^ ]+)" 24 | 25 | 26 | -- DEBUG -- 27 | 28 | 29 | log_ :: String -> (a -> String) -> a -> a 30 | log_ msg toString x = 31 | Debug.trace (msg ++ " : " ++ (toString x)) x 32 | 33 | -------------------------------------------------------------------------------- /src/Write.hs: -------------------------------------------------------------------------------- 1 | module Write where 2 | 3 | import qualified Module 4 | import qualified Data.Module as Module 5 | import qualified Data.List as List 6 | 7 | 8 | wat :: Module.Model -> IO () 9 | wat module_ = 10 | writeFile (fileName module_) (Module.write module_) 11 | 12 | 13 | fileName :: Module.Model -> String 14 | fileName module_ = 15 | "./" ++ (Module.name module_) ++ ".wat" 16 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-10.1 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - . 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | # extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.6" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | --------------------------------------------------------------------------------