haskelm (empty) → 0.0.2
raw patch · 18 files changed
+2741/−0 lines, 18 filesdep +Elmdep +aesondep +basesetup-changed
Dependencies added: Elm, aeson, base, binary, containers, directory, haskell-src-exts, haskell-src-meta, mtl, parsec, pretty, shakespeare, split, template-haskell, temporary, text, th-desugar, unordered-containers, vector
Files
- LICENSE +27/−0
- Setup.hs +179/−0
- haskelm.cabal +124/−0
- src/Haskelm.hs +19/−0
- src/Language/Elm/TH.hs +208/−0
- src/Language/Elm/TH/HToE.hs +754/−0
- src/Language/Elm/TH/Json.hs +468/−0
- src/Language/Elm/TH/Util.hs +187/−0
- src/SourceSyntax/Declaration.hs +122/−0
- src/SourceSyntax/Expression.hs +203/−0
- src/SourceSyntax/Helpers.hs +18/−0
- src/SourceSyntax/Literal.hs +21/−0
- src/SourceSyntax/Location.hs +58/−0
- src/SourceSyntax/Module.hs +116/−0
- src/SourceSyntax/Pattern.hs +65/−0
- src/SourceSyntax/PrettyPrint.hs +34/−0
- src/SourceSyntax/Type.hs +90/−0
- tests/Main.hs +48/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2014, JoeyEremondi+All rights reserved.++Redistribution and use in source and binary forms, with or without modification,+are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice, this+ list of conditions and the following disclaimer in the documentation and/or+ other materials provided with the distribution.++* Neither the name of the {organization} nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,179 @@+import Distribution.Simple+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Setup+import Distribution.PackageDescription++import System.Cmd+import System.Directory+import System.FilePath+import System.IO+import System.Process++import Control.Monad+import qualified Data.Binary as Binary+import qualified Data.ByteString.Lazy as BS+import qualified Data.List as List++-- Part 1+-- ------+-- Add a build callout+-- We need to build elm-doc and run it because that generates the file "docs.json"+-- needs by Libraries.hs which is part of the elm library and executable+-- Unfort. there seems to be no way to tell cabal that:+-- (a) elm-doc generates docs.json, and+-- (b) elm (library) depends on docs.json+-- Therefore, we either use make instead (or a script), or hack around in cabal++-- Part 2+-- ------+-- Add a post-build callout.+-- We need to build the runtime.js after we've built elm (because we use elm to generate some of the JavaScript),+-- but before cabal does the install file copy step++-- Assumptions+-- Elm.cabal expects the generated files to end up in dist/data+-- git won't look in dist + cabal will clean it+rtsDir :: LocalBuildInfo -> FilePath+rtsDir lbi = "data"++tempDir :: LocalBuildInfo -> FilePath+tempDir lbi = "temp"++-- The runtime is called:+rts :: LocalBuildInfo -> FilePath+rts lbi = rtsDir lbi </> "elm-runtime.js"++-- The runtime is called:+docs :: LocalBuildInfo -> FilePath+docs lbi = rtsDir lbi </> "docs.json"++-- The interfaces for the Standard Libraries live in:+interfaces :: LocalBuildInfo -> FilePath+interfaces lbi = rtsDir lbi </> "interfaces.data"++elm :: LocalBuildInfo -> FilePath+elm lbi = buildDir lbi </> "elm" </> "elm"++document :: LocalBuildInfo -> FilePath+document lbi = buildDir lbi </> "elm-doc" </> "elm-doc"++-- Care! This appears to be based on an unstable API+-- See: http://www.haskell.org/cabal/release/cabal-latest/doc/API/Cabal/Distribution-Simple.html#2+++main :: IO ()+main = defaultMainWithHooks simpleUserHooks { postBuild = myPostBuild }+++-- Build++-- note(1): We use to include docs.json directly into LoadLibraries at compile time+-- If docs.json is used in other (template) haskell files, they should be copied+-- and compiled in a separate directory (eg, dist/copiedSrc).+-- This is to make sure they are re-compiled on docs.json changes.+-- Copying is a better solution than 'touch'ing the source files+-- (touch is non-portable and confusing wrt RCS).++-- In the PackageDescription, the list of stuff to build is held in library+-- (in a Maybe) and the executables list. We want a PackageDescription that+-- only mentions the executable 'name'+filterExe :: String -> PackageDescription -> PackageDescription+filterExe name pd = pd {+ library = Nothing,+ executables = filter (\x -> (exeName x == name)) (executables pd)+ }+++-- Post Build++myPostBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()+myPostBuild as bfs pd lbi = do+ putStrLn "Custom build step: compiling standard libraries"+ (elmos, elmis) <- compileLibraries lbi+ putStrLn "Custom build step: build interfaces.data"+ buildInterfaces lbi elmis+ putStrLn "Custom build step: build elm-runtime.js"+ buildRuntime lbi elmos+ putStrLn "Custom build step: build docs.json"+ buildDocs lbi+ removeDirectoryRecursive (tempDir lbi)+ removeDirectoryRecursive ("libraries" </> "docs")+ postBuild simpleUserHooks as bfs pd lbi+++compileLibraries lbi = do+ let temp = tempDir lbi -- temp+ rts = rtsDir lbi -- data+ createDirectoryIfMissing True temp+ createDirectoryIfMissing True rts+ out_c <- canonicalizePath temp -- temp (root folder)+ elm_c <- canonicalizePath (elm lbi) -- dist/build/elm/elm+ doc_c <- canonicalizePath (document lbi) -- dist/build/elm-doc/elm-doc+ rtd_c <- canonicalizePath rts -- data++ let make file = do+ -- replace 'system' call with 'runProcess' which handles args better+ -- and allows env variable "Elm_datadir" which is used by LoadLibraries+ -- to find docs.json+ let args = [ "--only-js", "--make", "--no-prelude"+ , "--cache-dir="++out_c, "--build-dir="++out_c, file ]+ arg = Just [("Elm_datadir", rtd_c)]+ handle <- runProcess elm_c args Nothing arg Nothing Nothing Nothing+ exitCode <- waitForProcess handle+ return ( out_c </> replaceExtension file "elmo"+ , out_c </> replaceExtension file "elmi")++ setCurrentDirectory "libraries"+ paths <- getFiles ".elm" "."+ files <- unzip `fmap` mapM make paths+ mapM_ (\path -> rawSystem doc_c [path]) paths+ setCurrentDirectory ".."+ return files++buildInterfaces :: LocalBuildInfo -> [FilePath] -> IO ()+buildInterfaces lbi elmis = do+ createDirectoryIfMissing True (rtsDir lbi)+ let ifaces = interfaces lbi+ ifaceHandle <- openBinaryFile ifaces WriteMode+ BS.hPut ifaceHandle (Binary.encode (length elmis))+ let append file = do+ handle <- openBinaryFile file ReadMode+ bits <- hGetContents handle+ length bits `seq` hPutStr ifaceHandle bits+ hClose handle+ mapM_ append elmis+ hClose ifaceHandle++buildRuntime :: LocalBuildInfo -> [FilePath] -> IO ()+buildRuntime lbi elmos = do+ createDirectoryIfMissing True (rtsDir lbi)+ let rts' = rts lbi+ writeFile rts' "var Elm = {}; Elm.Native = {}; Elm.Native.Graphics = {};\n\+ \var ElmRuntime = {}; ElmRuntime.Render = {};\n"+ mapM_ (appendTo rts') =<< getFiles ".js" "libraries"+ mapM_ (appendTo rts') elmos+ mapM_ (appendTo rts') =<< getFiles ".js" "runtime"++buildDocs :: LocalBuildInfo -> IO ()+buildDocs lbi = do+ createDirectoryIfMissing True (rtsDir lbi)+ let docs' = docs lbi+ writeFile docs' "[\n"+ json <- getFiles ".json" ("libraries" </> "docs")+ let appends = map (appendTo docs') json+ addCommas = List.intersperse (appendFile docs' ",\n")+ sequence_ (addCommas appends)+ appendFile docs' "\n]"++getFiles ext dir = do+ contents <- map (dir </>) `fmap` getDirectoryContents dir+ let files = filter (\f -> takeExtension f == ext) contents+ dirs = filter (not . hasExtension) contents+ filess <- mapM (getFiles ext) dirs+ return (files ++ concat filess)++appendTo :: FilePath -> FilePath -> IO ()+appendTo destination source = do+ str <- readFile source+ length str `seq` return ()+ appendFile destination str
+ haskelm.cabal view
@@ -0,0 +1,124 @@+Name: haskelm+Version: 0.0.2+Synopsis: Elm to Haskell translation+Description: Library and binary to translate Haskell code into Elm code+Homepage: http://github.com/JoeyEremondi/haskelm++License: BSD3+License-file: LICENSE++build-type: Simple+author: Joey Eremondi+Maintainer: joey@eremondi.com+Copyright: Copyright: (c) 2014 Joey Eremondi++Category: Compiler, Language+Cabal-version: >=1.9++source-repository head+ type: git+ location: git://github.com/JoeyEremondi/haskelm+ +Library+ exposed-modules: Language.Elm.TH+ --Language.Elm.BuildString+ hs-Source-Dirs: src+ other-modules: SourceSyntax.Declaration,+ SourceSyntax.Expression,+ SourceSyntax.Helpers,+ SourceSyntax.Literal,+ SourceSyntax.Location,+ SourceSyntax.Module,+ SourceSyntax.Pattern,+ SourceSyntax.PrettyPrint,+ SourceSyntax.Type,+ Language.Elm.TH.HToE+ Language.Elm.TH.Json+ Language.Elm.TH.Util++ Build-depends: aeson,+ base >=4.2 && <5,+ containers >= 0.3,+ directory,+ mtl >= 2,+ parsec >= 3.1.1,+ pretty,+ text,+ unordered-containers,+ shakespeare,+ template-haskell,+ haskell-src-meta,+ vector,+ th-desugar,+ temporary,+ split,+ Elm,+ --elm-build-lib,+ binary,+ haskell-src-exts+++Executable haskelm+ Main-is: Haskelm.hs+ hs-Source-Dirs: src+ other-modules: SourceSyntax.Declaration,+ SourceSyntax.Expression,+ SourceSyntax.Helpers,+ SourceSyntax.Literal,+ SourceSyntax.Location,+ SourceSyntax.Module,+ SourceSyntax.Pattern,+ SourceSyntax.PrettyPrint,+ SourceSyntax.Type,+ Language.Elm.TH.HToE+ Language.Elm.TH.Json+ Language.Elm.TH.Util+ Language.Elm.TH+ --Language.Elm.BuildString+ + Build-depends: aeson,+ base >=4.2 && <5,+ containers >= 0.3,+ directory,+ mtl >= 2,+ parsec >= 3.1.1,+ pretty,+ text,+ unordered-containers,+ shakespeare,+ template-haskell,+ haskell-src-meta,+ vector,+ th-desugar,+ temporary,+ split,+ Elm,+ --elm-build-lib,+ binary,+ haskell-src-exts++Test-Suite test-haskelm+ Type: exitcode-stdio-1.0+ Hs-Source-Dirs: tests, src+ Main-is: Main.hs+ Build-depends: aeson,+ base >=4.2 && <5,+ containers >= 0.3,+ directory,+ mtl >= 2,+ parsec >= 3.1.1,+ pretty,+ text,+ unordered-containers,+ shakespeare,+ template-haskell,+ haskell-src-meta,+ vector,+ th-desugar,+ temporary,+ split,+ Elm,+ --elm-build-lib,+ binary,+ haskell-src-exts+ ghc-options: -ddump-splices
+ src/Haskelm.hs view
@@ -0,0 +1,19 @@+module Main( main ) where++import System.Environment( getArgs )++import Language.Elm.TH+import Language.Haskell.TH+++++main = do+ (infile:_) <- getArgs+ source <- readFile infile+ result <- runQ $ do+ let decs = decsFromString source+ let options = Options True False [] "Main" ""+ LitE (StringL str) <- elmStringExp options decs+ return str+ putStrLn result
+ src/Language/Elm/TH.hs view
@@ -0,0 +1,208 @@+{-|+## Library+You can also use Haskelm within a Haskell program, via Template Haskell.+These functions are delcared in Language.Elm.TH++There are two stages to translation: converting a Haskell file into a list of+Template Haskell declarations (type DecsQ),+and translation those declarations.++There are 5 ways you can get Haskell declarations+1. Using TemplateHaskell [d| ... |] brackets+2. From a string which contains a list of declarations (no `module` or `import` statements)+3. From a file containin declarations as in (2)+4. From a string which contains a Haskell module (`module` and `import` statements are discarded but allowed)+5. From a file containing a module as in (4)++It's reccomended that you use (5) for files which are already in your+Haskell project, and that whenever you use (4) or (5), you do NOT+splice the Haskell declarations into your code (see below).+The imports are ignored, so this is ideal for simply reading in a Haskell+file which gets compiled into your project (without Template Haskell).++If you would like to simultaneously add Haskell and Elm definitions to+your project, you should use (1), (2) or (3), since they will read in declarations+without any import or module statements. You can then use `declareTranslation`+with `declareHaskell=True` to splice the Haskell definitions in, as well as+a definition for a variable containing the translated Elm string.++Once you have a list of declarations, you can then translate them into elm.+To translate them as an expression, use++ elmString1 = $(elmStringExp defaultOptions $ decsFromModuleFile "myfile.hs")++Then, elmString1 will be a String variable which you can use in your Haskell code.+Note that the Haskell declarations can NOT be spliced into code using this method,+even if the declareHaskell option is set to True.+ +To simultaneously declare Haskell and your translated Elm, use+ $(declareTranslation defaultOptions $ decsFromFile "mydecs.hs")+ +In this case, the Haskell declarations can refer to anything imported by+the module in which you call declareTranslation. Thus it is reccomended that+you don't use `decsFromModuleFile` or `decsFromModule`, since any imports will be discarded.+ +Note that in either case,+`defaultOptions` is a record, so you can modify any of its values in the call.+++## Translation++Haskelm can currently translate most basic Haskell, including functions, algebraic data types, newtypes, and type synonyms.+Support is now in place for records, guarded-function-bodies, list-ranges, where-declarations, as-patterns, +and multi-clause function definitions (pattern matching).++Translation of class or instance declarations is not supported, and will not likely be supported in the near future,+as Elm does not support Type classes.++Most GHC extensions are unsupported, with the exception of Multi-Way-If statements,+since they have a direct translation into Elm.++## Json++Haskelm currently derivies toJson and fromJson functions for all Data declarations.+To get around the lack of TypeClasses in Elm, each translated module contains a +sum type, called BoxedJson, which wraps around any types defined in the module,+as well as lists, integers, floats, bools, and null.++Values of type `FOO` can be boxed using the constructor `BoxedJsonFOO`.+This also applies to `Int`, `Float`, and `String`.+Note that `BoxedJson_List` wraps a list of type `BoxedJson`.++The Haskell versions of these functions will lbe avaliable soon.+A short-term goal of mine is to switch this format to be compatible with Aeson,+or to use a more efficient binary serialization format such as BSON+or Protocol Buffers.++Json translation can be turned off using the options parameter.+Switching off JSON translations in the Haskelm executable will be supported soon.++-}++module Language.Elm.TH+ ( + declareTranslation,+ elmStringExp,+ decsFromString,+ decsFromFile,+ TranslateOptions (..),+ defaultOptions,+ decsFromModuleString,+ decsFromModuleFile,+ toElmString++ ) where++import Language.Haskell.TH.Syntax+import Language.Haskell.TH+import qualified Data.Text as TS+import SourceSyntax.Declaration as D+import SourceSyntax.Module as M+import Language.Elm.TH.BaseDecs+import Language.Haskell.TH.Lib+import qualified Language.Elm.TH.HToE as HToE+import qualified Language.Elm.TH.Json as Json+import qualified Language.Elm.TH.Util as Util+import Data.List (intercalate)+import SourceSyntax.PrettyPrint as Pretty+import Control.Monad.State (evalStateT)+import Control.Applicative ((<$>))+--source parser+import Language.Haskell.Meta.Parse+import Language.Haskell.Exts.Pretty (prettyPrint)+import qualified Language.Haskell.Exts.Syntax as Exts++data TranslateOptions = Options {+ makeJson :: Bool,+ declareHaskell :: Bool,+ elmImports :: [String],+ moduleName :: String,+ varName :: String + +}++defaultOptions = Options True False [] "Main" "var"+++-- | 'toElm' takes a 'String' module name and a list of Template Haskell declarations+-- and generates a translated Elm AST module+toElm :: TranslateOptions -> [Dec] -> Q (M.Module D.Declaration)+toElm options decs = do+ let doJson = makeJson options+ fromJsonDecs <- if doJson then evalStateT (Json.makeFromJson decs) Util.defaultState else return []+ toJsonDecs <- if doJson then evalStateT (Json.makeToJson decs) Util.defaultState else return []+ let jsonDecs = fromJsonDecs ++ toJsonDecs+ sumDecs <- evalStateT (Json.giantSumType decs) Util.defaultState+ elmDecs <- evalStateT (concat <$> translateDecs (decs ++ jsonDecs ++ sumDecs) ) Util.defaultState+ return $ M.Module [moduleName options] [] (map (\im->(im, Importing [])) $ elmImports options) elmDecs ++--Single stateful computation to store record state information +translateDecs decs = do+ HToE.findRecords decs+ mapM HToE.translateDec decs+ +-- | Given a module name and a list of template-haskell declarations+-- | translate the declarations into Elm and return the string of the translated module+toElmString :: TranslateOptions -> [Dec] -> Q String+toElmString options decs = elmModuleToString <$> toElm options decs+ +++-- | Translate a Haskell string into a list of Template-Haskell declarations+decsFromString :: String -> Q [Dec]+decsFromString s = case parseDecs s of+ Left e -> error $ "Failed to parse module\n" ++ e+ Right decs -> return decs+++-- | Given a file containing Haskell declarations, splice them and+-- into the haskell code, while also translating them into an Elm module+decsFromFile :: String -> DecsQ+decsFromFile filePath = do+ decString <- runIO $ readFile filePath+ decsFromString decString+ +--TODO also generate options?+decsFromModuleString :: String -> DecsQ+decsFromModuleString source = case parseHsModule source of+ Left e -> error $ "Failed to parse module\n" ++ e+ Right (Exts.Module _ _ _ _ _ _ decs) -> do+ let decString = intercalate "\n" $ map prettyPrint decs+ decsFromString decString++decsFromModuleFile :: String -> DecsQ+decsFromModuleFile filePath = do+ decString <- runIO $ readFile filePath+ decsFromModuleString decString++++elmModuleToString (Module [name] exports imports elmDecs ) =+ let allDecs = baseDecs ++ elmDecs + allImports = imports ++ [("Json", M.As "Json"), ("Dict", M.As "Dict")]+ newModule = Module [name] exports allImports allDecs+ modString = show $ Pretty.pretty newModule+ in modString + +-- | Given haskell declarations wrapped in '[d| ... |]', splice them and+-- into the haskell code, while also translating them into an Elm module+-- stored with the given varName+declareTranslation :: TranslateOptions -> DecsQ -> DecsQ+declareTranslation options dq = do+ decs <- dq+ elmString <- toElmString options decs+ let elmExp = liftString elmString+ let pat = varP (mkName $ varName options)+ let body = normalB elmExp+ elmDec <- valD pat body []+ --let modul = moduleFromString (TS.pack $ moduleName options) (TS.pack elmString )+ --js <- runIO $ buildModules modul []++ return $ if (declareHaskell options) then decs ++ [elmDec] else [elmDec]+ ++elmStringExp :: TranslateOptions -> DecsQ -> ExpQ+elmStringExp options decsQ = do+ decs <- decsQ+ elmString <- toElmString options decs+ liftString elmString
+ src/Language/Elm/TH/HToE.hs view
@@ -0,0 +1,754 @@+-----------------------------------------------------------------------------+--+-- Module : Language.Elm.TH.HToE+-- Copyright : Copyright: (c) 2011-2013 Joey Eremondi+-- License : BSD3+--+-- Maintainer : joey.eremondi@usask.ca+-- Stability : experimental+-- Portability : portable+--+-- |+--+-----------------------------------------------------------------------------+module Language.Elm.TH.HToE where++{-# LANGUAGE TemplateHaskell, QuasiQuotes, MultiWayIf #-}++import Language.Haskell.TH.Syntax++import Data.Aeson.TH+++import qualified SourceSyntax.Module as M+import qualified SourceSyntax.Declaration as D+import qualified SourceSyntax.Expression as E+import qualified SourceSyntax.Literal as L+import qualified SourceSyntax.Location as Lo+import qualified SourceSyntax.Pattern as P+import qualified SourceSyntax.Type as T++import Data.List (isPrefixOf)++import Language.Haskell.TH.Desugar.Sweeten+import Language.Haskell.TH.Desugar++import Language.Elm.TH.Util+--import Parse.Expression (makeFunction)++import Control.Applicative++import Data.List.Split (splitOn)++import Control.Monad.State (StateT)+import qualified Control.Monad.State as S++import qualified Data.Map as Map+import Data.List (intercalate)++import Debug.Trace (trace)++{-|+Haskell to Elm Translations+Most of these functions operate in the SQ monad, so that we can+compare against Haskell expressions or types in quotes (see isIntType etc.)++The return value is a list of Elm declarations+-}++++findRecords :: [Dec] -> SQ ()+findRecords decs = + do+ mapM processDec decs+ return ()+ where+ processDec :: Dec -> SQ ()+ processDec (DataD _ _ _ ctors _) = do+ mapM_ processCtor ctors+ return ()+ processDec (NewtypeD _ _ _ ctor _) = processCtor ctor+ processDec _ = return ()+ processCtor :: Con -> SQ ()+ processCtor (RecC name vstList) = do+ let str = (nameToString name) :: String+ let (nameList, _, _) = unzip3 vstList+ let names = map nameToString nameList+ oldState <- S.get+ let newState = oldState {records = Map.insert str names (records oldState) }+ S.put newState+ return ()+ processCtor _ = return ()++++-- |Translate a constructor into a list of Strings and type-lists,+-- Which Elm uses for its internal representation of constructors+--Also returns declarations associated with records+translateCtor :: Con -> SQ ( (String,[T.Type]), [D.Declaration])+translateCtor (NormalC name strictTyList) = do+ let sndList = map snd strictTyList+ tyList <- mapM translateType sndList+ return ( (nameToElmString name, tyList), [])++translateCtor (RecC name vstList) = do+ --ignore strictness+ let nameTypes = map (\(a,_,b)->(a,b)) vstList+ recordTy <- translateRecord nameTypes+ let recordDecs = map (accessorDec . fst) nameTypes+ let makerDec = recordMakerDec (nameToElmString name) (map (nameToElmString . fst) nameTypes)+ let unboxDec = recordUnboxDec (nameToElmString name)+ return ( (nameToElmString name, [recordTy]), (makerDec:unboxDec:recordDecs)) --TODO add decs ++--Elm has no concept of infix constructor+translateCtor (InfixC t1 name t2) = translateCtor $ NormalC name [t1, t2]++translateCtor (ForallC _ _ _) = unImplemented "forall constructors"++-- | Take a list of declarations and a body+-- and put it in a let only if the declarations list is non-empty+maybeLet :: [E.Def] -> E.Expr -> E.Expr +maybeLet eWhere eBody = + if null eWhere+ then eBody+ else E.Let eWhere (Lo.none eBody)++--------------------------------------------------------------------------+-- | Helper to get the fields of the Clause type+unClause :: Clause -> ([Pat], Body, [Dec])+unClause (Clause p b d) = (p, b, d)++-- |Helper for putting elements in a list+single :: a -> [a]+single a = [a]++{-|Translate a Haskell declaration into an Elm Declaration+ Currently implemented:+ ADTs+ Functions+ Value declarations+ Type synonyms++-}++translateDec:: Dec -> SQ [D.Declaration]++--TODO translate where decs into elm let-decs+--TODO what about when more than one clause?+translateDec (FunD name [Clause patList body whereDecs]) = do+ let eName = nameToElmString name+ (ePats, asDecList) <- unzip <$> mapM translatePattern patList+ let asDecs = concat asDecList+ eWhere <- mapM translateDef whereDecs+ let eDecs = asDecs ++ eWhere+ fnBody <- translateBody body+ let eBody = maybeLet eDecs fnBody+ return $ single $ D.Definition $ E.Definition (P.PVar eName) (makeFunction ePats (Lo.none eBody)) Nothing --TODO what is maybe arg?+ +--multi-clause case i.e. pattern matching+--Convert to a single-clause function with a case statement+translateDec (FunD name clauseList) = do+ let ((Clause patList _ _):_) = clauseList+ let numArgs = length patList+ let argStrings = map (("arg" ++) . show) [1..numArgs]+ argNames <- mapM liftNewName argStrings+ let argPatList = map VarP argNames+ + let argTuple = TupE $ map VarE argNames+ cases <- mapM clauseToCase clauseList+ let newBody = NormalB $ CaseE argTuple cases+ let singleClause = Clause argPatList newBody []+ translateDec $ FunD name [singleClause]+ where+ clauseToCase (Clause patList body whereDecs) = do+ let leftSide = TupP patList+ return $ Match leftSide body whereDecs+ ++translateDec (ValD pat body whereDecs) = do+ (ePat, asDecs) <- translatePattern pat+ valBody <- translateBody body+ eWhere <- (asDecs ++) <$> mapM translateDef whereDecs+ let eBody = maybeLet eWhere valBody+ + return $ single $ D.Definition $ E.Definition ePat (Lo.none eBody) Nothing --TODO what is maybe arg?+++translateDec dec@(DataD [] name tyBindings ctors names) = do+ --jsonDecs <- deriveFromJSON defaultOptions name+ (eCtors, extraDecLists) <- unzip <$> mapM translateCtor ctors+ return $ [ D.Datatype eName eTyVars eCtors []] ++ (concat extraDecLists) --TODO derivations?+ where+ eName = nameToElmString name+ eTyVars = map (nameToElmString . tyVarToName) tyBindings+++--TODO data case for non-empty context?+translateDec (DataD cxt name tyBindings ctors names) = + doEmitWarning "Data declarations with TypeClass context"++--We just translate newTypes as Data definitions+--TODO: what about when record notation is used?+translateDec (NewtypeD cxt name tyBindings ctor nameList) = + translateDec $ DataD cxt name tyBindings [ctor] nameList++translateDec (TySynD name tyBindings ty) = do+ let eName = nameToElmString name+ let eTyVars = map (nameToElmString . tyVarToName) tyBindings+ eTy <- translateType ty+ return $ single $ D.TypeAlias eName eTyVars eTy []++translateDec (ClassD cxt name tyBindings funDeps decs ) = doEmitWarning "Class definitions"+translateDec (InstanceD cxt ty decs) = doEmitWarning "Instance declarations"++--TODO fix signatures+translateDec (SigD name ty) = return []--(single . D.Definition . (E.TypeAnnotation (nameToString name)) ) <$> translateType ty+translateDec (ForeignD frn) = doEmitWarning "FFI declarations"+++translateDec (PragmaD pragma) = doEmitWarning "Haskell Pragmas"+++translateDec (FamilyD famFlavour name [tyVarBndr] mKind) = doEmitWarning "Type families"++translateDec (DataInstD cxt name types ctors names) = doEmitWarning "Data instances"+++translateDec (NewtypeInstD cxt name types ctor names) = doEmitWarning "Newtypes instances"++translateDec (TySynInstD name types theTy) = doEmitWarning "Type synonym instances"++--------------------------------------------------------------------------+-- | Convert a declaration to an elm Definition+-- Only works on certain types of declarations TODO document which++translateDef :: Dec -> SQ E.Def++--TODO functions+translateDef (ValD pat body whereDecs) = do+ (ePat, asDecs) <- translatePattern pat+ eWhere <- (asDecs ++ ) <$> mapM translateDef whereDecs+ decBody <- translateBody body+ let eBody = maybeLet eWhere decBody+ return $ E.Definition ePat (Lo.none eBody) Nothing++--To do functions, we translate them into an Elm declaration+--Then we convert+translateDef (funD@(FunD _ _)) = do+ elmDec <- translateDec funD+ case elmDec of+ [D.Definition elmDef] -> return elmDef+ _ -> unImplemented "Function can't be converted to a declaration"+ ++translateDef d = unImplemented "Non-simple function/value definitions"++-- | Helper to put an object in a tuple with an empty list as snd+unFst x = (x, [])++--------------------------------------------------------------------------+-- |Translate a pattern match from Haskell to Elm++translatePattern :: Pat -> SQ (P.Pattern, [E.Def])+--Special case for As, to carry over the name+translatePattern (AsP name initPat) = do+ (pat, patExp) <- patToExp initPat+ (retPat, subDecs) <- translatePattern $ pat+ + dec <- translateDef $ ValD (VarP name) (NormalB patExp) []+ return (retPat, [dec] ++ subDecs)+{-+translatePattern p = do+ runIO $ putStrLn $ show p+ ret <-translatePattern' p+ return (ret, [])+ -}++translatePattern (LitP lit) = (unFst . P.PLiteral) <$> translateLiteral lit++translatePattern (VarP name) = return $ unFst $ P.PVar $ nameToElmString name++--Special case: if only one pattern in tuple, don't treat as tuple+--TODO why do we need this?+translatePattern (TupP [pat]) = translatePattern pat++translatePattern (TupP patList) = do+ (patList, allAsDecs) <- unzip <$> mapM translatePattern patList+ return (P.tuple patList, concat allAsDecs)++--Treat unboxed tuples like tuples+translatePattern (UnboxedTupP patList) = translatePattern $ TupP patList ++translatePattern (ConP name patList) = do+ let str = nameToString name+ (patList, allAsDecs) <- unzip <$> mapM translatePattern patList+ recMap <- records <$> S.get+ if (Map.member str recMap )+ then do+ let varNames = recMap Map.! str+ let decs = map makeDef $ zip patList varNames+ return (P.PData str $ [P.PRecord varNames], decs ++ (concat allAsDecs))+ + else do+ return (P.PData (nameToElmString name) patList, concat allAsDecs) + where + makeDef :: (P.Pattern, String) -> E.Def+ makeDef (pat, varString) = E.Definition pat (Lo.none $ E.Var varString) Nothing+ ++--Just pass through parentheses+translatePattern (ParensP p) = translatePattern p+ +--TODO Infix, tilde, bang, as, record, view+++translatePattern WildP = return $ unFst P.PAnything++--Ignore the type signature if theres one in the pattern+translatePattern (SigP pat _) = translatePattern pat++translatePattern (ListP patList) = do+ (patList, allAsDecs) <- unzip <$> mapM translatePattern patList+ return (P.list patList, concat allAsDecs)++--Convert infix patterns to Data patterns, then let Elm decide+-- how it translates them (i.e. cons is a special case) +translatePattern (InfixP p1 name p2) = translatePattern $ ConP name [p1,p2]+--treat unboxed infix like infix+translatePattern (UInfixP p1 name p2) = translatePattern $ InfixP p1 name p2++--TODO implement records+translatePattern (RecP _ _) = unImplemented "Record patterns"++++translatePattern (TildeP _) = unImplemented "Tilde patterns/laziness notation"+translatePattern (BangP _) = unImplemented "Baing patterns/strictness notation"++translatePattern (ViewP _ _) = unImplemented "View patterns"++--translatePattern p = unImplemented $ "Misc patterns " ++ show p++-------------------------------------------------------------------------+-- | Convert a pattern into an expression+-- Useful for as patterns, so we can do pattern checking as well as multiple naming+patToExp :: Pat -> SQ (Pat, Exp)+patToExp p = do+ noWild <- removeWildcards [1..] p+ return (noWild, patToExp' noWild)+ + where+ patToExp' (LitP l) = LitE l+ patToExp' (VarP n) = VarE n+ patToExp' (TupP l) = TupE $ map patToExp' l+ patToExp' (UnboxedTupP l) = UnboxedTupE $ map patToExp' l+ patToExp' (ConP n pl) = foldl AppE (VarE n) (map patToExp' pl) --Apply constructor to each subexp+ patToExp' (InfixP p1 n p2) = InfixE (Just $ patToExp' p1) (VarE n) (Just $ patToExp' p2)+ patToExp' (UInfixP p1 n p2) = UInfixE (patToExp' p1) (VarE n) (patToExp' p2)+ patToExp' (ParensP p) = ParensE $ patToExp' p+ patToExp' (AsP n p) = patToExp' p --TODO ignore name? Should get covered by other translation+ patToExp' WildP = error "Can't use wildcard in expression"+ patToExp' (ListP pList) = ListE $ map patToExp' pList+ patToExp' _ = unImplemented "Complex as-patterns"++doWithNames nameList patList = do+ let nameLists = splitListN (length patList) nameList+ let fnsToApply = [removeWildcards nl | nl <- nameLists]+ let tuples = zip fnsToApply patList+ mapM (\(f,x)-> f $ x) tuples+ +-- | Recursively replace wildcards in an exp with new names+-- Useful for as patterns, so we can unbox patterns and re-pack them with a new name+--Assumes we have an infinite list of names to take+removeWildcards :: [Int] -> Pat -> SQ Pat+removeWildcards (i:_) WildP = do+ name <- liftNewName $ ("arg_" ++ ( show i))+ return $ VarP name+removeWildcards nameList (TupP l) = do+ TupP <$> doWithNames nameList l+removeWildcards nameList (UnboxedTupP l) = UnboxedTupP <$> doWithNames nameList l+removeWildcards nameList (ConP n pl) = (ConP n) <$> doWithNames nameList pl+removeWildcards nameList (InfixP p1 n p2) = do+ let (l1, l2) = splitList nameList+ ret1 <- removeWildcards l1 p1+ ret2 <- removeWildcards l2 p2+ return $ InfixP ret1 n ret2+removeWildcards nameList (UInfixP p1 n p2) = do+ let (l1, l2) = splitList nameList+ ret1 <- removeWildcards l1 p1+ ret2 <- removeWildcards l2 p2+ return $ UInfixP ret1 n ret2+removeWildcards nameList (ParensP p) = ParensP <$> removeWildcards nameList p+removeWildcards nameList (AsP n p) = AsP n <$> removeWildcards nameList p --TODO ignore name? Should get covered by other translation+removeWildcards nameList (ListP pList) = ListP <$> doWithNames nameList pList+removeWildcards nameList p = return p --All other cases, nothing to remove, either simple or unsupported++--------------------------------------------------------------------------+-- |Translate a function body into Elm+translateBody :: Body -> SQ E.Expr+translateBody (NormalB e) = translateExpression e+--Just convert to a multi-way If statement+translateBody (GuardedB guardExpList) = translateExpression $ MultiIfE guardExpList+ +++-- | Expression helper function to convert a Var to a String+expressionToString (VarE name) = nameToElmString name++-- | Generic elm expression for "otherwise"+elmOtherwise = E.Var "otherwise"++-- | Translate a guard into an Elm expression+translateGuard (NormalG exp) = translateExpression exp+translateGuard _ = unImplemented "Pattern-match guards"+--------------------------------------------------------------------------+{-|Translate a haskell Expression into Elm+Currently supported:+ Variables+ Literals+ Lambdas+ Constructors+ Function Application+ Parenthises+ tuples+ Conditionals+ Multi-way If statements+ Let-expressions+ Case expressions+ List literals+ Infix operations+ +Supported but not translated:+ Type signatures+-}+translateExpression :: Exp -> SQ E.Expr++--TODO multi pattern exp?+translateExpression (LamE [pat] expBody) = do+ (ePat, asDecs) <- translatePattern pat+ lambdaBody <- translateExpression expBody+ let eBody = maybeLet asDecs lambdaBody+ return $ E.Lambda ePat (Lo.none eBody)++translateExpression (VarE name) = return $ E.Var $ nameToElmString name++--Just treat constructor as variable --TODO is this okay?+translateExpression (ConE name) = return $ E.Var $ nameToElmString name++translateExpression (LitE lit) = E.Literal <$> translateLiteral lit++--Lo.none converts expressions to located expressions with no location++--Special case for records, we need a curry-able function to construct records in Elm+translateExpression (AppE fun@(ConE ctor) arg) = do+ recMap <- records <$> S.get+ let str = nameToString ctor+ if Map.member str recMap+ then do+ let recordFunc = mkName $ recordMakerName (nameToString ctor)+ translateExpression (AppE (VarE recordFunc) arg)+ else do+ eFun <- translateExpression fun+ eArg <- translateExpression arg+ return $ E.App (Lo.none eFun) (Lo.none eArg)++translateExpression (AppE fun arg) = do+ eFun <- translateExpression fun+ eArg <- translateExpression arg+ return $ E.App (Lo.none eFun) (Lo.none eArg)++--TODO infix stuff, ranges, record con, record update++translateExpression (ParensE e) = translateExpression e++translateExpression (TupE es) = (E.tuple . map Lo.none) <$> mapM translateExpression es++translateExpression (CondE cond th el) = do+ eCond <- Lo.none <$> translateExpression cond+ eTh <- Lo.none <$> translateExpression th+ eEl <- Lo.none <$> translateExpression el+ let loOtherwise = Lo.none elmOtherwise+ return $ E.MultiIf [(eCond, eTh), (loOtherwise, eEl)]++translateExpression (MultiIfE guardExpList) = do+ expPairs <- mapM transPair guardExpList + return $ E.MultiIf expPairs+ where+ transPair (guard, exp) = do+ eGuard <- translateGuard guard+ eExp <- translateExpression exp+ return (Lo.none eGuard, Lo.none eExp)++translateExpression (LetE decList exp) = do+ eDecs <- mapM translateDef decList+ eExp <- translateExpression exp+ return $ E.Let eDecs (Lo.none eExp)++--TODO deal with Where+translateExpression (CaseE exp matchList) = do+ eExp <- translateExpression exp+ eMatch <- mapM getMatch matchList+ return $ E.Case (Lo.none eExp) eMatch+ where+ getMatch (Match pat body whereDecs) = do+ (ePat, asDecs) <- translatePattern pat+ eWhere <- (asDecs ++ ) <$> mapM translateDef whereDecs+ matchBody <- translateBody body + let eBody = maybeLet eWhere matchBody+ return (ePat, Lo.none eBody)++translateExpression (ListE exps) = (E.ExplicitList . map Lo.none) <$> mapM translateExpression exps++--Unboxed infix expression+translateExpression (UInfixE e1 op e2) = do+ eE1 <- translateExpression e1+ eE2 <- translateExpression e2+ let eOp = expressionToString op+ return $ E.Binop eOp (Lo.none eE1) (Lo.none eE2)++--Infix where we have all the parts, i.e. not a section+--Just translate as unboxed+translateExpression (InfixE (Just e1) op (Just e2)) = + translateExpression $ UInfixE e1 op e2++translateExpression e@(RecConE name nameExpList ) = do+ let (names, expList) = unzip nameExpList+ eExps <- mapM translateExpression expList+ let stringList = map nameToString names+ let lexps = map Lo.none eExps+ return $ E.App (Lo.none $ E.Var $ nameToString name) (Lo.none $ E.Record $ zip stringList lexps)++translateExpression e@(RecUpdE recExp nameExpList ) = do+ let (names, expList) = unzip nameExpList+ eExps <- mapM translateExpression expList+ let lexps = map Lo.none eExps+ let varStrings = map nameToString names+ eRec <- translateExpression recExp+ recMap <- records <$> S.get+ recName <- nameToString <$> liftNewName "rec"+ let ctor = recordWithFields recMap (map nameToString names)+ let internalRecDef = E.Definition (P.PVar recName) (Lo.none $ E.App (Lo.none $ E.Var $ unboxRecordName ctor) (Lo.none eRec)) Nothing+ return $ E.Let [internalRecDef] $ Lo.none $ E.App (Lo.none $ E.Var ctor) (Lo.none $ E.Modify (Lo.none $ E.Var recName) ( zip varStrings lexps) )+ +translateExpression (InfixE _ _ _) = unImplemented "Operator sections i.e. (+3)" + +--Just ignore signature+translateExpression (SigE exp _) = translateExpression exp++translateExpression e@(ArithSeqE r) = translateRange r++translateExpression e@(LamCaseE _) = unImplemented $ "Lambda case expressions: " ++ show e+++translateExpression e@(DoE _) = unImplemented $ "Sugared do notation: " ++ show e++translateExpression e@(CompE _) = unImplemented $ "List comprehensions: " ++ show e++++++translateExpression e = unImplemented $ "Misc expression " ++ show e++--------------------------------------------------------------------------+-- |Translate a literal value from Haskell to Elm+-- Strings are translated into strings, not char lists++translateLiteral :: Lit-> SQ L.Literal+translateLiteral = return . noQTrans where+ noQTrans (CharL c) = L.Chr c++ noQTrans (StringL s) = L.Str s++ noQTrans (IntegerL i) = L.IntNum $ fromInteger i++ noQTrans (IntPrimL i) = L.IntNum $ fromInteger i+ + noQTrans (WordPrimL i) = L.IntNum $ fromInteger i++ noQTrans (FloatPrimL f) = L.FloatNum $ fromRational f++ noQTrans (DoublePrimL f) = L.FloatNum $ fromRational f++ noQTrans (RationalL f) = L.FloatNum $ fromRational f++ noQTrans (StringPrimL _) = unImplemented "C-string literals"+++-- | Translate a Haskell range. Infinite lists not supported, since Elm is strict+translateRange :: Range -> SQ E.Expr+translateRange (FromToR start end) = do+ e1 <- Lo.none <$> translateExpression start+ e2 <- Lo.none <$> translateExpression end+ return $ E.Range e1 e2+ +translateRange _ = unImplemented "Infinite ranges, or ranges with steps not equal to 1"++++--------------------------------------------------------------------------+{-|+Translate a Haskell type into an Elm type+Currently translates primitive types, lists, tuples and constructors (ADTs)+Doesn't support type classes or fancier types+-}+translateType :: Type -> SQ T.Type++translateType (ForallT _ _ _ ) = unImplemented "forall types"+translateType (PromotedT _ ) = unImplemented "promoted types"+translateType (PromotedTupleT _ ) = unImplemented "promoted tuple types"+translateType (PromotedNilT ) = unImplemented "promoted nil types"+translateType (PromotedConsT ) = unImplemented "promoted cons types"+translateType (StarT) = unImplemented "star types"+translateType (UnboxedTupleT i ) = translateType $ TupleT i+translateType ArrowT = error "Arrow type: Should never recurse this far down"+translateType ListT = error "List type: Should never recurse this far down"+translateType ConstraintT = unImplemented "Type constraints"+translateType (LitT _) = error "Type literals"+++--TODO fill in other cases, esp records+--Cases which aren't captured by basic pattern matching+translateType t = do+ --Unbox some Monad information that we need+ isInt <- S.lift $ isIntType t+ isString <- S.lift $ isStringType t+ isFloat <- S.lift $ isFloatType t+ isBool <- S.lift $ isBoolType t+ generalTranslate isInt isString isFloat isBool --TODO get these in scope+ where+ generalTranslate :: Bool -> Bool -> Bool -> Bool -> SQ T.Type+ generalTranslate isInt isString isFloat isBool+ | isInt = return $ T.Data "Int" []+ | isString = return $ T.Data "String" []+ | isFloat = return $ T.Data "Float" []+ | isBool = return $ T.Data "Bool" []+ | isTupleType t = do+ tyList <- mapM translateType (tupleTypeToList t)+ return $ T.tupleOf tyList+ | otherwise = case t of+ --type variables+ (VarT name) -> return $ T.Var (nameToElmString name)+ --sum types/ADTs+ (ConT name) -> return $ T.Data (nameToElmString name) [] --TODO what is this list param?+ --functions+ (AppT (AppT ArrowT a) b) -> do+ ea <- translateType a+ eb <- translateType b+ return $ T.Lambda ea eb++ --empty tuple/record+ (TupleT 0) -> return $ T.recordOf []+ --Lists and tuples, just Data in Elm+ (AppT ListT t) -> do+ et <- translateType t+ return $ T.listOf et+ --Type variable application: get type to apply to as Data+ --then add this type to the list of applied types+ (AppT subt tvar) -> do+ etvar <- translateType tvar+ T.Data ctor varList <- translateType subt+ return $ T.Data ctor (varList ++ [etvar]) +++ +-- | Special record type translation+translateRecord :: [(Name, Type)] -> SQ T.Type+translateRecord nameTyList = do+ let (nameList, tyList) = unzip nameTyList+ let eNames = map nameToElmString nameList+ eTypes <- mapM translateType tyList+ return $ T.recordOf $ zip eNames eTypes+ +--Generate the function declarations associated with a record type+accessorDec :: Name -> D.Declaration+--Names are always local+accessorDec name = + let+ nameString = nameToString name+ var = "rec"+ varExp = E.Var var+ varPat = P.PVar var+ funBody = E.Access (Lo.none $ varExp) nameString+ fun = E.Lambda varPat (Lo.none funBody)+ in D.Definition $ E.Definition (P.PVar nameString) (Lo.none fun) Nothing++recordMakerDec :: String -> [String] -> D.Declaration+recordMakerDec ctor vars =+ let+ argNames = map (("arg" ++) . show) [1 .. (length vars)]+ patList = map P.PVar argNames+ expList = map (Lo.none . E.Var) argNames+ recordCons = Lo.none $ E.Record $ zip vars expList+ funBody = E.App (Lo.none $ E.Var ctor) recordCons+ fun = makeCurry patList funBody + in D.Definition $ E.Definition (P.PVar $ recordMakerName ctor) (Lo.none fun) Nothing+ where makeCurry argPats body = foldr (\pat body-> E.Lambda pat (Lo.none body) ) body argPats++recordUnboxDec :: String -> D.Declaration+recordUnboxDec ctor =+ let+ pat = P.PData ctor [P.PVar "x"]+ body = E.Var "x"+ fun = E.Lambda pat (Lo.none body)+ in D.Definition $ E.Definition (P.PVar $ unboxRecordName ctor) (Lo.none fun) Nothing+ +recordMakerName name = "makeRecord__" ++ name+unboxRecordName name = "unboxRecord__" ++ name +--------------------------------------------------------------------------+{-|+Conversion from Haskell namespaces and prelude names+to Elm base names+-}++nameToElmString :: Name -> String+nameToElmString = getElmName . nameToString++getElmName :: String -> String++getElmName "$" = "<|"++--Cons should get translated automatically, but just in case+getElmName ":" = "::"++--Not a change, but lets us search for . in module names+getElmName "." = "."++--Specific cases+getElmName s+ | length partList > 1 = getElmModuleName modul name+ --Default: don't change the string+ | otherwise = s+ where + name = last partList+ modul = init partList+ partList = (splitOn "." s)++--modules that are supported by Elm+elmHasFunction :: String -> String -> Bool+elmHasFunction "Dict" s = s `elem` ["empty", "singleton", "insert", "update", "remove", "member", "lookup", "findWithDefault",+ "union", "intersect", "diff", "keys", "values", "toList", "fromList", "map", "foldl", "foldr"]++elmHasFunction "Json" s = s `elem` ["String", "Number", "Boolean", "Null", "Array", "Object"] ++elmHasFunction _ _ = False ++directTranslate "Dict" s = + case Map.lookup s m of+ Just ret -> ret+ Nothing -> error $ "Elm Dictionary operation not supported: " ++ s+ where m = Map.fromList [("Map", "Dict")] --TODO more+ +getElmModuleName :: [String] -> String -> String +--TODO fix infix? +getElmModuleName ["Data", "Map"] name = "Dict." ++ case name of --TODO are there any special cases?+ _ -> if (elmHasFunction "Dict" name)+ then name+ else directTranslate "Dict" name++getElmModuleName ["Data", "Aeson"] s = "Json." ++ case s of+ _ -> if (elmHasFunction "Json" s) + then s+ else error "Elm Dictionary doesn't support operation " ++ s+getElmModuleName m s = (intercalate "." m) ++ "." ++ s
+ src/Language/Elm/TH/Json.hs view
@@ -0,0 +1,468 @@+-----------------------------------------------------------------------------+--+-- Module : Language.Elm.TH.Json+-- Copyright : Copyright: (c) 2011-2013 Joey Eremondi+-- License : BSD3+--+-- Maintainer : joey.eremondi@usask.ca+-- Stability : experimental+-- Portability : portable+--+-- |+--+-----------------------------------------------------------------------------+module Language.Elm.TH.Json where++{-# LANGUAGE TemplateHaskell, QuasiQuotes, MultiWayIf #-}++import Language.Haskell.TH.Syntax++import Data.Aeson.TH+++import qualified SourceSyntax.Module as M+import qualified SourceSyntax.Declaration as D+import qualified SourceSyntax.Expression as E+import qualified SourceSyntax.Literal as L+import qualified SourceSyntax.Location as Lo+import qualified SourceSyntax.Pattern as P+import qualified SourceSyntax.Type as T++import Data.List (isPrefixOf)++import Language.Haskell.TH.Desugar.Sweeten+import Language.Haskell.TH.Desugar++import Language.Elm.TH.Util+++--import Parse.Expression (makeFunction)++import Control.Applicative++import Control.Monad.State (StateT)+import qualified Control.Monad.State as S+++------------------------------------------------------------------------------------+--Helpers to make to and fromJson functions++-- | Build the AST for the base-cases, translating primitive types, lists, tuples, etc.+makeJsonCase0 (jCtor, ctorName) = Match (ConP (mkName jCtor) [] ) (NormalB $ ConE (mkName ctorName) ) [] +makeJsonCase1 (jCtor, varName, ctorName) = Match (ConP (mkName jCtor) [VarP (mkName varName)]) (NormalB $ AppE (ConE (mkName ctorName)) (VarE (mkName varName))) [] ++-- | A list of Match values representing the "base cases" for toJson+-- | These are checked before ADT conversion is performed+unJsonCase :: [Match]+unJsonCase = map makeJsonCase1 list1 ++ map makeJsonCase0 list0 ++ [intCase]+ where+ list1 = [--("Array", "lst", "FromJSON_List"), --TODO can do types?+ ( sumTypePrefix ++"_Float", "n", "Json.Number"),+ (sumTypePrefix ++"_String", "s", "Json.String"),+ (sumTypePrefix ++"_Bool", "b", "Json.Boolean")]+ list0 = [(sumTypePrefix ++ "_Null", "Json.Null")]+ intCase = Match (ConP (mkName $ sumTypePrefix ++"_Int") [VarP (mkName "i")]) (NormalB $ AppE (ConE (mkName "Json.Number")) (AppE (VarE $ mkName "toFloat")(VarE (mkName "i")) ) ) []+ --Can't encode lists directly+ --listCase = Match (ConP (mkName "Json.Array") [VarP (mkName "l")]) (NormalB $ AppE (ConE (mkName "FromJSON_List")) (AppE (AppE (VarE (mkName "map")) (VarE (mkName "fromJson"))) (VarE (mkName "l")) )) [] ++-- | A list of Match values representing the "base cases" for fromJson+-- | These are checked before ADT conversion is attempted +jsonCase :: [Match]+jsonCase = map makeJsonCase1 list1 ++ map makeJsonCase0 list0 ++ [listCase]+ where+ list1 = [--("Array", "lst", "FromJSON_List"), --TODO can do types?+ ("Json.Number", "n", sumTypePrefix ++"_Float"),+ ("Json.String", "s", sumTypePrefix ++"_String"),+ ("Json.Boolean", "b", sumTypePrefix ++"_Bool")]+ list0 = [("Json.Null", sumTypePrefix ++"_Null")]+ listCase = Match (ConP (mkName "Json.Array") [VarP (mkName "l")]) (NormalB $ AppE (ConE (mkName $ sumTypePrefix ++"_List")) (AppE (AppE (VarE (mkName "map")) (VarE (mkName "fromJson"))) (VarE (mkName "l")) )) [] + ++-- | Filter function to test if a dec is a data+-- Also filters out decs which types that can't be serialized, such as functions+isData :: Dec -> Bool+isData dec = (isData' dec) && (canSerial dec) + where+ isData' DataD{} = True+ isData' NewtypeD{} = True+ isData' TySynD{} = True+ isData' _ = False+ + canSerial (DataD _ _ _ ctors _) = all canSerialCtor ctors+ canSerial (NewtypeD _ _ _ ctor _) = canSerialCtor ctor+ canSerial (TySynD _ _ ty) = canSerialType ty+ --can't serialize if type variables --TODO is this true?+ canSerial _ = False+ + canSerialCtor (NormalC _ types) = all (canSerialType) (map snd types)+ canSerialCtor (RecC _ types) = all (canSerialType) (map (\(_,_,c)->c) types)+ + canSerialType (ArrowT) = False+ canSerialType t = all canSerialType (subTypes t)++-- | Expression for the fromJson function+fromJson :: Exp+fromJson = VarE (mkName "fromJson")++-- | Expression for the toJson function+toJson :: Exp+toJson = VarE (mkName "toJson")++-- | The variable representing the current Json argument+json :: Exp+json = VarE (mkName "json")++-- | Pattern for an argument named 'json'+jsonPat :: Pat+jsonPat = VarP (mkName "json") ++-- | Variable for the getter function getting the nth variable from a Json+varNamed :: Exp+varNamed = VarE (mkName "varNamed")++-- | Variable for the getter function getting the nth variable from a Json+jsonType :: Exp+jsonType = VarE (mkName "getType")++-- | Variable for the getter function getting the nth variable from a Json+jsonCtor :: Exp+jsonCtor = VarE (mkName "getCtor")++-- | Expression getting the nth subvariable from a JSON object+getVarNamed :: String -> Exp+getVarNamed nstr = AppE (AppE varNamed json ) (LitE $ StringL nstr)++-- | Expression to access the "type" field of a JSON object+getType :: Exp+getType = AppE jsonType json ++-- | Expression to access the constructor field of a JSON object+getCtor :: Exp+getCtor = AppE jsonCtor json ++-- | Expression representing function composition+fnComp :: Exp+fnComp = VarE $ mkName "."++-- | The string prefix for the massive JSON sum type+sumTypePrefix :: String+sumTypePrefix = "BoxedJson"++-- |The String argument of the massive JSON sum type property denoting a given ADT+typeString :: Name -> SQ String+typeString name = return $ sumTypePrefix ++ "_" ++ nameToString name+++-- |The Pattern to unbox a value into its type from the massive sum type+-- | the second argument is the name to bind the value to+unJsonPat :: Name -> Name -> SQ Pat+unJsonPat typeName nameToBind = do+ typeCtor <- mkName <$> typeString typeName+ return $ ConP typeCtor [VarP nameToBind]++-- | The name of the constructor which wraps+-- the type with the given name into the giant sum type+sumTypeCtor :: Name -> SQ Name+sumTypeCtor name = mkName <$> typeString name++-- | Recursively generates an expression for the function which takes an argument of type BoxedJson+-- and converts it, while also extracting it from the BoxedJson type+unJsonType :: Type -> SQ Exp+unJsonType (ConT name) = do+ argName <- liftNewName "x"+ lambdaPat <- unJsonPat name argName+ let unCtor = LamE [lambdaPat] (VarE argName)+ return $ InfixE (Just unCtor) fnComp (Just fromJson)+ where+ fnComp = VarE $ mkName "."++unJsonType (AppT ListT t) = do+ subFun <- unJsonType t+ let mapVar = VarE $ mkName "mapJson"+ return $ AppE mapVar subFun+++ +--Unpack JSON into a tuple type+--We convert the JSON to a list+--We make a lambda expression which applies the UnFromJSON function to each element of the tuple+unJsonType t+ | isTupleType t = do+ + let tList = tupleTypeToList t+ let n = length tList+ --Generate the lambda to convert the list into a tuple+ subFunList <- mapM unJsonType tList+ argNames <- mapM (liftNewName . ("x" ++) . show) [1 .. n]+ let argValues = map VarE argNames+ let argPat = ListP $ map VarP argNames+ let lambdaBody = TupE $ zipWith AppE subFunList argValues+ let lambda = LamE [argPat] lambdaBody+ let makeList = VarE $ mkName "makeList"+ + return $ InfixE (Just lambda) fnComp (Just makeList)+ --For a maybe, we construct a function that returns Nothing if it reads null+ -- or Just (unboxed fromJson val) if it is not null+ + | isMaybeType t = do+ let (AppT _ innerT) = t+ argName <- liftNewName "maybeArg"+ subFn <- unJsonType innerT+ let nothingMatch = Match (ConP (mkName "Json.Null") []) (NormalB $ VarE $ mkName "Nothing") []+ let otherMatch = Match (WildP) (NormalB $ AppE (VarE $ mkName "Just") (AppE subFn (VarE argName))) []+ return $ LamE [VarP argName] (CaseE (VarE argName) [nothingMatch, otherMatch]) + | isMapType t = do+ let (AppT (AppT (ConT _name) keyT) valT) = t+ tupleFun <- unJsonType (AppT ListT (AppT (AppT (TupleT 2) keyT) valT))+ return $ InfixE (Just $ VarE $ mkName "Data.Map.fromList") fnComp (Just tupleFun) --TODO make variable+ | otherwise = do+ test <- S.lift $ isIntType t+ case test of+ True -> do+ argName <- liftNewName "x"+ lambdaPat <- unJsonPat (mkName "Int") argName+ let unCtor = LamE [lambdaPat] (AppE (VarE (mkName "round")) (VarE argName) )+ return $ InfixE (Just unCtor) fnComp (Just fromJson)+ _ -> unImplemented $ "Can't un-json type " ++ show t+ +-- | Generate a declaration, and a name bound in that declaration,+-- Which unpacks a value of the given type from the nth field of a JSON object+getSubJson :: (String, Type) -> SQ (Name, Dec)+-- We need special cases for lists and tuples, to unpack them+--TODO recursive case+getSubJson (field, t) = do+ funToApply <- unJsonType t+ subName <- liftNewName "subVar"+ let subLeftHand = VarP subName+ let subRightHand = NormalB $ AppE funToApply (getVarNamed field)+ return (subName, ValD subLeftHand subRightHand [])+++-- | Given a type constructor, generate the match which matches the "ctor" field of a JSON object+-- | to apply the corresponding constructor to the proper arguments, recursively extracted from the JSON+fromMatchForCtor :: Con -> SQ Match +fromMatchForCtor (NormalC name types) = do+ let matchPat = LitP $ StringL $ nameToString name+ (subNames, subDecs) <- unzip <$> mapM getSubJson (zip (map show [1,2..] ) (map snd types) )+ let body = NormalB $ if null subNames+ then applyArgs subNames ctorExp+ else LetE subDecs (applyArgs subNames ctorExp)+ return $ Match matchPat body []+ where+ ctorExp = ConE name+ applyArgs t accum = foldl (\ accum h -> AppE accum (VarE h)) accum t ++fromMatchForCtor (RecC name vstList) = do+ let nameTypes = map (\(a,_,b)->(nameToString a,b)) vstList+ let matchPat = LitP $ StringL $ nameToString name+ (subNames, subDecs) <- unzip <$> mapM getSubJson nameTypes+ let body = NormalB $ if null subNames+ then applyArgs subNames ctorExp+ else LetE subDecs (applyArgs subNames ctorExp)+ return $ Match matchPat body []+ where+ ctorExp = ConE name+ applyArgs t accum = foldl (\ accum h -> AppE accum (VarE h)) accum t+ +-- | Given a type delcaration, generate the match which matches the "type" field of a JSON object+-- and then defers to a case statement on constructors for that type+fromMatchForType :: Dec -> SQ Match+fromMatchForType dec@(DataD _ name _ ctors _deriving) = do+ let matchPat = LitP $ StringL $ nameToString name+ ctorMatches <- mapM fromMatchForCtor ctors+ let typeBody = NormalB $ CaseE getCtor ctorMatches+ jsonName <- liftNewName "typedJson"+ typeCtor <- sumTypeCtor name+ let typeBodyDec = ValD (VarP jsonName) typeBody []+ let ret = AppE (ConE typeCtor) (VarE jsonName)+ let body = NormalB $ LetE [typeBodyDec] ret+ return $ Match matchPat body []++fromMatchForType (NewtypeD cxt name tyBindings ctor nameList) = + fromMatchForType $ DataD cxt name tyBindings [ctor] nameList ++fromMatchForType dec@(TySynD name _tyvars ty) = do+ let matchPat = WildP+ typeCtor <- sumTypeCtor name+ funToApply <- unJsonType ty+ let body = NormalB $ AppE (ConE typeCtor) (AppE (funToApply) json)+ return $ Match matchPat body []++fromMatchForType t = unImplemented $ "types other than Data, Type or Newtype " ++ show t + +-- |Given a list of declarations, generate the fromJSON function for all+-- types defined in the declaration list+makeFromJson :: [Dec] -> SQ [Dec]+makeFromJson allDecs = do+ let decs = filter isData allDecs+ typeMatches <- mapM fromMatchForType decs+ let objectBody = NormalB $ CaseE getType typeMatches+ let objectMatch = Match WildP objectBody []+ let body = NormalB $ CaseE json (jsonCase ++ [objectMatch])+ return [ FunD (mkName "fromJson") [Clause [jsonPat] body []] ]++ +-----------------------------------------------------------------------+-- |Given a list of declarations, generate the toJSON function for all+-- types defined in the declaration list+makeToJson :: [Dec] -> SQ [Dec]+makeToJson allDecs = do+ let decs = filter isData allDecs+ typeMatches <- mapM toMatchForType decs+ --TODO remove jsonCase, put in equivalent+ let body = NormalB $ CaseE json (unJsonCase ++ typeMatches)+ return [ FunD (mkName "toJson") [Clause [jsonPat] body []] ]++-- | Helper function to generate a the names X1 .. Xn with some prefix X +nNames :: Int -> String -> SQ [Name]+nNames n base = do+ let varStrings = map (\n -> base ++ show n) [1..n]+ mapM liftNewName varStrings++--Generate the Match which matches against the given constructor+--then packs its argument into a JSON with the proper type, ctor and argument data+toMatchForCtor :: Name -> Con -> SQ Match +toMatchForCtor typeName (NormalC name types) = do+ let n = length types+ adtNames <- nNames n "adtVar"+ jsonNames <- nNames n "jsonVar"+ let adtPats = map VarP adtNames+ let matchPat = ConP name adtPats+ jsonDecs <- mapM makeSubJson (zip3 (map snd types) adtNames jsonNames)+ dictName <- liftNewName "objectDict"+ dictDec <- makeDict typeName name dictName jsonNames+ let ret = AppE (VarE $ mkName "Json.Object") (VarE dictName)+ let body = NormalB $ LetE (jsonDecs ++ [dictDec]) ret+ return $ Match matchPat body []++toMatchForCtor typeName (RecC name vstList) = do+ let (adtNames, _, types) = unzip3 vstList+ let n = length types+ jsonNames <- nNames n "jsonVar"+ let adtPats = map VarP adtNames+ let matchPat = ConP name adtPats+ jsonDecs <- mapM makeSubJson (zip3 types adtNames jsonNames)+ dictName <- liftNewName "objectDict"+ dictDec <- makeDict typeName name dictName jsonNames+ let ret = AppE (VarE $ mkName "Json.Object") (VarE dictName)+ let body = NormalB $ LetE (jsonDecs ++ [dictDec]) ret+ return $ Match matchPat body [] + +-- | Generate the declaration of a dictionary mapping field names to values+-- to be used with the JSON Object constructor+makeDict :: Name -> Name -> Name -> [Name] -> SQ Dec +makeDict typeName ctorName dictName jsonNames = do+ let leftSide = VarP dictName+ let jsonExps = map VarE jsonNames+ let fieldNames = map (LitE . StringL . show) [1 .. (length jsonNames)]+ let tuples = map (\(field, json) -> TupE [field, json]) (zip fieldNames jsonExps)+ let typeExp = LitE $ StringL $ nameToString typeName+ let ctorExp = LitE $ StringL $ nameToString ctorName+ let typeTuple = TupE [LitE $ StringL "type", AppE (VarE (mkName "Json.String")) typeExp ]+ let ctorTuple = TupE [LitE $ StringL "ctor", AppE (VarE (mkName "Json.String")) ctorExp ]+ let tupleList = ListE $ [typeTuple, ctorTuple] ++ tuples+ let rightSide = NormalB $ AppE (VarE $ mkName "Data.Map.fromList") tupleList+ return $ ValD leftSide rightSide []+ + -- |Generate the Match which matches against the BoxedJson constructor+ -- to properly encode a given type+toMatchForType :: Dec -> SQ Match+toMatchForType dec@(DataD _ name _ ctors _derive) = do+ varName <- liftNewName "adt"+ matchPat <- unJsonPat name varName+ ctorMatches <- mapM (toMatchForCtor name) ctors+ let body = NormalB $ CaseE (VarE varName) ctorMatches+ return $ Match matchPat body [] ++toMatchForType (NewtypeD cxt name tyBindings ctor nameList) = + toMatchForType $ DataD cxt name tyBindings [ctor] nameList+ +--Type synonym, just get the unJson function, no cases to handle +toMatchForType (TySynD name _tyVars ty) = do+ varName <- liftNewName "adt"+ matchPat <- unJsonPat name varName+ funToApply <- pureJsonType ty+ let body = NormalB $ AppE (funToApply) (VarE varName)+ return $ Match matchPat body [] + +-- | Generate the declaration of a value converted to Json+-- given the name of an ADT value to convert+makeSubJson :: (Type, Name, Name) -> SQ Dec+-- We need special cases for lists and tuples, to unpack them+--TODO recursive case+makeSubJson (t, adtName, jsonName) = do+ funToApply <- pureJsonType t+ let subLeftHand = VarP jsonName+ let subRightHand = NormalB $ AppE funToApply (VarE adtName)+ return $ ValD subLeftHand subRightHand []++-- | For a type, generate the expression for the function which takes a value of that type+-- and converts it to JSON+-- used to recursively convert the data of ADTs+pureJsonType :: Type -> SQ Exp+--Base case: if an ADT, just call toJson with the appropriate constructor+pureJsonType (ConT name) = do+ argName <- liftNewName "adt"+ typeCtor <- sumTypeCtor name+ lambdaPat <- unJsonPat name argName+ let addCtor = LamE [VarP argName] (AppE (ConE typeCtor) (VarE argName))+ return $ InfixE (Just toJson) fnComp (Just addCtor)+ where+ fnComp = VarE $ mkName "."++pureJsonType (AppT ListT t) = do+ subFun <- pureJsonType t+ let listCtor = VarE $ mkName "Json.Array"+ let mapVar = VarE $ mkName "map"+ return $ InfixE (Just listCtor ) fnComp (Just (AppE mapVar subFun))+ where+ fnComp = VarE $ mkName "."++--Unpack JSON into a tuple type+--We convert the JSON to a list+--We make a lambda expression which applies the UnFromJSON function to each element of the tuple+pureJsonType t+ | isTupleType t = do+ let tList = tupleTypeToList t+ let n = length tList+ --Generate the lambda to convert the list into a tuple+ subFunList <- mapM pureJsonType tList+ argNames <- mapM (liftNewName . ("x" ++) . show) [1 .. n]+ let argValues = map VarE argNames+ let argPat = TupP $ map VarP argNames+ --Get each tuple element as Json, then wrap them in a Json Array+ let listExp = AppE (VarE $ mkName "Json.Array") (ListE $ zipWith AppE subFunList argValues)+ return $ LamE [argPat] listExp + | isMaybeType t = do+ let (AppT _ innerT) = t+ argName <- liftNewName "maybeArg"+ justArg<- liftNewName "justArg"+ subFn <- pureJsonType innerT+ let nothingMatch = Match (ConP (mkName "Nothing") []) (NormalB $ VarE $ mkName "Json.Null") []+ let otherMatch = Match (ConP (mkName "Just") [VarP justArg]) (NormalB $ AppE subFn (VarE justArg)) []+ return $ LamE [VarP argName] (CaseE (VarE argName) [nothingMatch, otherMatch])+ | isMapType t = do+ let (AppT (AppT (ConT _name) keyT) valT) = t+ tupleFun <- pureJsonType (AppT ListT (AppT (AppT (TupleT 2) keyT) valT))+ return $ InfixE (Just tupleFun) fnComp (Just $ VarE $ mkName "Data.Map.toList") --TODO make variable+ --Don't need special int case, that happens when actually boxing the Json+-----------------------------------------------------------------------++-- | Generate a giant sum type representing all of the types within this module+-- this allows us to use toJson and fromJson without having typeClasses+giantSumType :: [Dec] -> SQ [Dec]+giantSumType allDecs = do+ let decs = filter isData allDecs+ let typeNames = map getTypeName decs ++ map mkName ["Int", "Float", "Bool", "String"] --TODO lists?+ + ctorStrings <- mapM typeString typeNames+ let ctorNames = zip typeNames (map mkName ctorStrings)+ let nullCtor = NormalC (mkName $ sumTypePrefix ++ "_Null") []+ let listCtor = NormalC (mkName $ sumTypePrefix ++ "_List") [(NotStrict, AppT ListT (ConT $ mkName sumTypePrefix)) ]+ let ctors = map (\ (typeName, ctorName) -> NormalC ctorName [(NotStrict, ConT typeName)] ) ctorNames+ return [ DataD [] (mkName sumTypePrefix) [] (ctors ++ [nullCtor, listCtor]) [] ]+ where + getTypeName :: Dec -> Name+ getTypeName (DataD _ name _ _ _ ) = name+ getTypeName (NewtypeD _ name _tyBindings _ctor _nameList) = name+ getTypeName (TySynD name _ _) = name
+ src/Language/Elm/TH/Util.hs view
@@ -0,0 +1,187 @@+-----------------------------------------------------------------------------+--+-- Module : Language.Elm.TH.Util+-- Copyright : Copyright: (c) 2011-2013 Joey Eremondi+-- License : BSD3+--+-- Maintainer : joey.eremondi@usask.ca+-- Stability : experimental+-- Portability : portable+--+-- |+--+-----------------------------------------------------------------------------+{-# LANGUAGE TemplateHaskell, QuasiQuotes, MultiWayIf #-}++module Language.Elm.TH.Util where+++import Language.Haskell.TH.Syntax++import Data.Aeson.TH+++import qualified SourceSyntax.Module as M+import qualified SourceSyntax.Declaration as D+import qualified SourceSyntax.Expression as E+import qualified SourceSyntax.Literal as L+import qualified SourceSyntax.Location as Lo+import qualified SourceSyntax.Pattern as P+import qualified SourceSyntax.Type as T++import Data.List (isPrefixOf)++import Language.Haskell.TH.Desugar.Sweeten+import Language.Haskell.TH.Desugar+++--import Parse.Expression (makeFunction)++import Control.Applicative++import Control.Monad.State (StateT)+import qualified Control.Monad.State as S++import qualified Data.Map as Map++--translate newName into our new monad+liftNewName :: String -> SQ Name+liftNewName s = do+ oldState <- S.get+ let num = currentNum oldState+ name <- S.lift $ newName $ s ++ "__xxfreshxx__" ++ show num+ S.put $ oldState {currentNum = num + 1}+ return name++ +doEmitWarning :: String -> SQ [a]+doEmitWarning s = S.lift $ emitWarning s+++--State information++type SQ a = StateT TranslationState Q a++--Enum for the different state vars we can access+data TranslationState = TranslationState {+ records :: Map.Map String [String],+ currentNum :: Int+ }+ +defaultState = TranslationState (Map.fromList []) 1 +++++-- | General error function for unimplemented features+unImplemented s = error $ "Translation of the The following haskell feature is not yet implemented: " ++ s++emitWarning :: String -> Q [a]+emitWarning s = do+ runIO $ putStrLn $ "Warning! Ignoring feature in Haskell source: " ++ s+ return []+++-- |Stolen from Parse.Expression so we don't have to change any internal Elm code+makeFunction :: [P.Pattern] -> E.LExpr -> E.LExpr+makeFunction args body@(Lo.L s _) =+ foldr (\arg body' -> Lo.L s $ E.Lambda arg body') body args++-- |Translate a type variable to a name, ignoring its kind+tyVarToName :: TyVarBndr -> Name+tyVarToName (PlainTV n) = n+tyVarToName (KindedTV n _ ) = n++--Abstract out the translation of names to strings+--So that we can modify if need be+--Right now is just a synonym+nameToString :: Name -> String+nameToString name = + case nameModule name of+ Nothing -> nameBase name--TODO fancier?+ Just base -> if "GHC." `isPrefixOf` base+ then nameBase name+ else showName name++--Split a list into two alternating lists+--from http://www.haskell.org/haskellwiki/Blow_your_mind+splitList :: [a] -> ([a], [a])+splitList = foldr (\a ~(x,y) -> (a:y,x)) ([],[])++splitListN :: Int -> [a] -> [[a]]+splitListN 0 l = []+splitListN 1 l = [l]+splitListN 2 l = let (l1, l2) = splitList l+ in [l1, l2]+splitListN n l+ | even n = let (l1, l2) = splitList l+ in (splitListN (quot n 2) l1) ++ (splitListN (quot n 2) l2)+ | otherwise = let (l1, l2) = splitList l+ in [l1] ++ (splitListN (n-1) l2)+ +--------------------------------------------------------------------------+-- |Type helper functions+-- We use these, since String comparison is insufficients:+-- Template Haskell returns GHC.Types.Int instead of Inst++int = [t| Int |]+string = [t| String |]+float = [t| Float |]+bool = [t| Bool |]++isIntType t = do+ tint <- int+ --runIO $ putStrLn $ "Checking if int " ++ (show (t == tint))+ return (t == tint)++isStringType t = do+ tstr <- string+ return (t == tstr)++isFloatType t = do+ tfloat <- float+ return (t == tfloat)++isBoolType t = do+ tbool <- bool+ return (t == tbool)++-- | Helper function to traverse a tree of AppTs and check if a type is a tuple all the way down +isTupleType (AppT (TupleT _arity) _) = True+isTupleType (AppT t1 t2) = isTupleType t1+isTupleType _ = False++isMaybeType (AppT (ConT name) _) = (nameToString name) == "Maybe"+isMaybeType _ = False++isMapType (AppT (AppT (ConT name) _) _) = (nameToString name) `elem` ["Map", "Data.Map.Map", "Map.Map"] --TODO deeper comparison+isMapType _ = False++-- | Helper function to linearize the AppT of tuple types+tupleTypeToList (AppT (TupleT _arity) t) = [t]+tupleTypeToList (AppT t1 t2) = tupleTypeToList t1 ++ [t2]++-- | Given a record dictionary, find constructor for one containing all the given fields+recordWithFields :: Map.Map String [String] -> [String] -> String+recordWithFields recMap fields = + case ctors of+ [] -> unImplemented $ "Records from other modules\n" ++ (show recMap) ++ "\n" ++ (show fields)+ [(ctor, _)] -> ctor+ _ -> unImplemented "Records sharing field names"+ where+ recList = Map.toList recMap+ hasFields (_, fieldsInRecord) = not $ null (filter (`elem` fields) fieldsInRecord)+ ctors = filter hasFields recList+ +-- | Helper to get all subtypes of a type+subTypes :: Type -> [Type]+subTypes (ForallT _ _ t) = [t] +subTypes (VarT _) = []+subTypes (ConT _) = []+subTypes (TupleT _) = []+subTypes ArrowT = [] +subTypes ListT = [] +subTypes (AppT t1 t2) = [t1, t2]+subTypes (SigT t _) = [t]+subTypes _ = [] --TODO better catch-all?+
+ src/SourceSyntax/Declaration.hs view
@@ -0,0 +1,122 @@+{-# OPTIONS_GHC -Wall #-}+module SourceSyntax.Declaration where++import Data.Binary+import qualified SourceSyntax.Expression as Expr+import qualified SourceSyntax.Type as T+import SourceSyntax.PrettyPrint+import Text.PrettyPrint as P++data Declaration' port def+ = Definition def+ | Datatype String [String] [(String,[T.Type])] [Derivation]+ | TypeAlias String [String] T.Type [Derivation]+ | Port port+ | Fixity Assoc Int String+ deriving (Show)++data Assoc = L | N | R+ deriving (Eq)++data Derivation = Json | JS | Binary | New+ deriving (Eq, Show)++data ParsePort+ = PPAnnotation String T.Type+ | PPDef String Expr.LParseExpr+ deriving (Show)++data Port+ = Out String Expr.LExpr T.Type+ | In String T.Type+ deriving (Show)++type ParseDeclaration = Declaration' ParsePort Expr.ParseDef+type Declaration = Declaration' Port Expr.Def++instance Binary Derivation where+ get = do n <- getWord8+ return $ case n of+ 0 -> Json+ 1 -> JS+ 2 -> Binary+ 3 -> New+ _ -> error "Unable to decode Derivation. You may have corrupted binary files,\n\+ \so please report an issue at <https://github.com/evancz/Elm/issues>"++ put derivation =+ putWord8 $ case derivation of+ Json -> 0+ JS -> 1+ Binary -> 2+ New -> 3++instance Show Assoc where+ show assoc =+ case assoc of+ L -> "left"+ N -> "non"+ R -> "right"++instance Binary Assoc where+ get = do n <- getWord8+ return $ case n of+ 0 -> L+ 1 -> N+ 2 -> R+ _ -> error "Error reading valid associativity from serialized string"++ put assoc = putWord8 $ case assoc of { L -> 0 ; N -> 1 ; R -> 2 }++instance (Pretty port, Pretty def) => Pretty (Declaration' port def) where+ pretty decl =+ case decl of+ Definition def -> pretty def++ Datatype tipe tvars ctors deriveables ->+ P.hang (P.text "data" <+> P.text tipe <+> P.hsep (map P.text tvars)) 4+ (P.sep $ zipWith join ("=" : repeat "|") ctors) <+> prettyDeriving deriveables+ where+ join c ctor = P.text c <+> prettyCtor ctor+ prettyCtor (name, tipes) =+ P.hang (P.text name) 2 (P.sep (map T.prettyParens tipes))++ TypeAlias name tvars tipe deriveables ->+ alias <+> prettyDeriving deriveables+ where+ name' = P.text name <+> P.hsep (map P.text tvars)+ alias = P.hang (P.text "type" <+> name' <+> P.equals) 4 (pretty tipe)++ Port port -> pretty port++ Fixity assoc prec op -> P.text "infix" <> assoc' <+> P.int prec <+> P.text op+ where+ assoc' = case assoc of+ L -> P.text "l"+ N -> P.empty+ R -> P.text "r"++instance Pretty ParsePort where+ pretty port =+ case port of+ PPAnnotation name tipe -> prettyPort name ":" tipe+ PPDef name expr -> prettyPort name "=" expr++instance Pretty Port where+ pretty port =+ case port of+ In name tipe -> prettyPort name ":" tipe+ Out name expr tipe -> P.vcat [ prettyPort name ":" tipe+ , prettyPort name "=" expr ]+ ++prettyPort :: (Pretty a) => String -> String -> a -> Doc+prettyPort name op e = P.text "port" <+> P.text name <+> P.text op <+> pretty e++prettyDeriving :: [Derivation] -> Doc+prettyDeriving deriveables =+ case deriveables of+ [] -> P.empty+ [d] -> P.text "deriving" <+> P.text (show d)+ ds -> P.text "deriving" <+>+ P.parens (P.hsep $ P.punctuate P.comma $ map (P.text . show) ds)
+ src/SourceSyntax/Expression.hs view
@@ -0,0 +1,203 @@+{-# OPTIONS_GHC -Wall #-}+module SourceSyntax.Expression where+{-| The Abstract Syntax Tree (AST) for expressions comes in a couple formats.+The first is the fully general version and is labeled with a prime (Expr').+The others are specialized versions of the AST that represent specific phases+of the compilation process. I expect there to be more phases as we begin to+enrich the AST with more information.+-}+++import SourceSyntax.PrettyPrint+import Text.PrettyPrint as P+import qualified SourceSyntax.Helpers as Help+import qualified SourceSyntax.Location as Location+import qualified SourceSyntax.Pattern as Pattern+import qualified SourceSyntax.Type as SrcType+import qualified SourceSyntax.Literal as Literal++---- GENERAL AST ----++{-| This is a located expression, meaning it is tagged with info about where it+came from in the source code. Expr' is defined in terms of LExpr' so that the+location information does not need to be an extra field on every constructor.+-}+type LExpr' def = Location.Located (Expr' def)++{-| This is a fully general Abstract Syntax Tree (AST) for expressions. It has+"type holes" that allow us to enrich the AST with additional information as we+move through the compilation process. The type holes let us show these+structural changes in the types. The only type hole right now is:++ def: Parsing allows two kinds of definitions (type annotations or definitions),+ but later checks will see that they are well formed and combine them.++-}+data Expr' def+ = Literal Literal.Literal+ | Var String+ | Range (LExpr' def) (LExpr' def)+ | ExplicitList [LExpr' def]+ | Binop String (LExpr' def) (LExpr' def)+ | Lambda Pattern.Pattern (LExpr' def)+ | App (LExpr' def) (LExpr' def)+ | MultiIf [(LExpr' def,LExpr' def)]+ | Let [def] (LExpr' def)+ | Case (LExpr' def) [(Pattern.Pattern, LExpr' def)]+ | Data String [LExpr' def]+ | Access (LExpr' def) String+ | Remove (LExpr' def) String+ | Insert (LExpr' def) String (LExpr' def)+ | Modify (LExpr' def) [(String, LExpr' def)]+ | Record [(String, LExpr' def)]+ | Markdown String String [LExpr' def]+ -- for type checking and code gen only+ | PortIn String SrcType.Type+ | PortOut String SrcType.Type (LExpr' def)+++---- SPECIALIZED ASTs ----++{-| Expressions created by the parser. These use a split representation of type+annotations and definitions, which is how they appear in source code and how+they are parsed.+-}+type ParseExpr = Expr' ParseDef+type LParseExpr = LExpr' ParseDef++data ParseDef+ = Def Pattern.Pattern LParseExpr+ | TypeAnnotation String SrcType.Type+ deriving (Show)++{-| "Normal" expressions. When the compiler checks that type annotations and+ports are all paired with definitions in the appropriate order, it collapses+them into a Def that is easier to work with in later phases of compilation.+-}+type LExpr = LExpr' Def+type Expr = Expr' Def++data Def = Definition Pattern.Pattern LExpr (Maybe SrcType.Type)+ deriving (Show)+++---- UTILITIES ----++tuple :: [LExpr' def] -> Expr' def+tuple es = Data ("_Tuple" ++ show (length es)) es++delist :: LExpr' def -> [LExpr' def]+delist (Location.L _ (Data "::" [h,t])) = h : delist t+delist _ = []++saveEnvName :: String+saveEnvName = "_save_the_environment!!!"++dummyLet :: Pretty def => [def] -> LExpr' def+dummyLet defs = + Location.none $ Let defs (Location.none $ Var saveEnvName)++instance Pretty def => Show (Expr' def) where+ show = render . pretty++instance Pretty def => Pretty (Expr' def) where+ pretty expr =+ case expr of+ Literal lit -> pretty lit+ Var x -> variable x+ Range e1 e2 -> P.brackets (pretty e1 <> P.text ".." <> pretty e2)+ ExplicitList es -> P.brackets (commaCat (map pretty es))+ Binop "-" (Location.L _ (Literal (Literal.IntNum 0))) e ->+ P.text "-" <> prettyParens e+ Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op', prettyParens e2 ]+ where op' = if Help.isOp op then op else "`" ++ op ++ "`"+ Lambda p e -> P.text "\\" <> args <+> P.text "->" <+> pretty body+ where+ (ps,body) = collectLambdas (Location.none $ Lambda p e)+ args = P.sep (map Pattern.prettyParens ps)+ App _ _ -> P.hang func 2 (P.sep args)+ where func:args = map prettyParens (collectApps (Location.none expr))+ MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)+ where+ iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)+ Let defs e ->+ P.sep [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))+ , P.text "in" <+> pretty e ]+ Case e pats ->+ P.hang pexpr 2 (P.vcat (map pretty' pats))+ where+ pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]+ pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b+ Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl+ Data "[]" [] -> P.text "[]"+ Data name es+ | Help.isTuple name -> P.parens (commaCat (map pretty es))+ | otherwise -> P.hang (P.text name) 2 (P.sep (map prettyParens es))+ Access e x -> prettyParens e <> P.text "." <> variable x+ Remove e x -> P.braces (pretty e <+> P.text "-" <+> variable x)+ Insert (Location.L _ (Remove e y)) x v ->+ P.braces (pretty e <+> P.text "-" <+> variable y <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)+ Insert e x v ->+ P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)++ Modify e fs ->+ P.braces $ P.hang (pretty e <+> P.text "|")+ 4+ (commaSep $ map field fs)+ where+ field (k,v) = variable k <+> P.text "<-" <+> pretty v++ Record fs ->+ P.braces $ P.nest 2 (commaSep $ map field fs)+ where+ field (x,e) = variable x <+> P.equals <+> pretty e++ Markdown _ _ _ -> P.text "[markdown| ... |]"++ PortIn name _ -> P.text $ "<port:" ++ name ++ ">"++ PortOut _ _ signal -> pretty signal++instance Pretty ParseDef where+ pretty def =+ case def of+ TypeAnnotation name tipe ->+ variable name <+> P.colon <+> pretty tipe+ Def pattern expr ->+ pretty pattern <+> P.equals <+> pretty expr++instance Pretty Def where+ pretty (Definition pattern expr maybeTipe) =+ P.vcat [ annotation, definition ]+ where+ definition = pretty pattern <+> P.equals <+> pretty expr+ annotation = case maybeTipe of+ Nothing -> P.empty+ Just tipe -> pretty pattern <+> P.colon <+> pretty tipe++collectApps :: LExpr' def -> [LExpr' def]+collectApps lexpr@(Location.L _ expr) =+ case expr of+ App a b -> collectApps a ++ [b]+ _ -> [lexpr]++collectLambdas :: LExpr' def -> ([Pattern.Pattern], LExpr' def)+collectLambdas lexpr@(Location.L _ expr) =+ case expr of+ Lambda pattern body -> (pattern : ps, body')+ where (ps, body') = collectLambdas body+ _ -> ([], lexpr)++prettyParens :: (Pretty def) => LExpr' def -> Doc+prettyParens (Location.L _ expr) = parensIf needed (pretty expr)+ where+ needed =+ case expr of+ Binop _ _ _ -> True+ Lambda _ _ -> True+ App _ _ -> True+ MultiIf _ -> True+ Let _ _ -> True+ Case _ _ -> True+ Data name (_:_) -> name /= "::"+ _ -> False
+ src/SourceSyntax/Helpers.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS_GHC -Wall #-}+module SourceSyntax.Helpers where++import qualified Data.Char as Char++brkt :: String -> String+brkt s = "{ " ++ s ++ " }"++isTuple :: String -> Bool+isTuple name =+ take 6 name == "_Tuple" && all Char.isDigit (drop 6 name)++isOp :: String -> Bool+isOp = all isSymbol++isSymbol :: Char -> Bool+isSymbol c =+ Char.isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!"
+ src/SourceSyntax/Literal.hs view
@@ -0,0 +1,21 @@+{-# OPTIONS_GHC -Wall #-}+module SourceSyntax.Literal where++import SourceSyntax.PrettyPrint+import qualified Text.PrettyPrint as PP++data Literal = IntNum Int+ | FloatNum Double+ | Chr Char+ | Str String+ | Boolean Bool+ deriving (Eq, Ord, Show)++instance Pretty Literal where+ pretty literal =+ case literal of+ IntNum n -> PP.int n+ FloatNum n -> PP.double n+ Chr c -> PP.text . show $ c+ Str s -> PP.text . show $ s+ Boolean bool -> PP.text (show bool)
+ src/SourceSyntax/Location.hs view
@@ -0,0 +1,58 @@+module SourceSyntax.Location where++import Text.PrettyPrint+import SourceSyntax.PrettyPrint+import qualified Text.Parsec.Pos as Parsec++data SrcPos = Pos { line :: Int, column :: Int }+ deriving (Eq, Ord)++data SrcSpan = Span SrcPos SrcPos String | NoSpan String+ deriving (Eq, Ord)++data Located e = L SrcSpan e+ deriving (Eq, Ord)++none e = L (NoSpan (render $ pretty e)) e+noneNoDocs = L (NoSpan "")++at start end e = L (Span (Pos (Parsec.sourceLine start) (Parsec.sourceColumn start))+ (Pos (Parsec.sourceLine end ) (Parsec.sourceColumn end ))+ (render $ pretty e)) e++merge (L s1 _) (L s2 _) e = L (span (render $ pretty e)) e+ where span = case (s1,s2) of+ (Span start _ _, Span _ end _) -> Span start end+ (Span start end _, _) -> Span start end+ (_, Span start end _) -> Span start end+ (_, _) -> NoSpan++mergeOldDocs (L s1 _) (L s2 _) e = L span e+ where span = case (s1,s2) of+ (Span start _ d1, Span _ end d2) -> Span start end (d1 ++ "\n\n" ++ d2)+ (Span _ _ _, _) -> s1+ (_, Span _ _ _) -> s2+ (_, _) -> NoSpan ""++sameAs (L s _) = L s+++instance Show SrcPos where+ show (Pos r c) = show r ++ "," ++ show c++instance Show SrcSpan where+ show span = + case span of+ NoSpan _ -> ""+ Span start end _ ->+ case line start == line end of+ False -> "between lines " ++ show (line start) ++ " and " ++ show (line end)+ True -> "on line " ++ show (line end) ++ ", column " +++ show (column start) ++ " to " ++ show (column end)++instance Show e => Show (Located e) where+ show (L _ e) = show e++instance Pretty a => Pretty (Located a) where+ pretty (L _ e) = pretty e+
+ src/SourceSyntax/Module.hs view
@@ -0,0 +1,116 @@+{-# OPTIONS_GHC -Wall #-}+module SourceSyntax.Module where++import Data.Binary+import qualified Data.Map as Map+import Control.Applicative ((<$>), (<*>))++import SourceSyntax.Expression (LExpr)+import SourceSyntax.Declaration+import SourceSyntax.Type++import SourceSyntax.PrettyPrint+import Text.PrettyPrint as P++import Data.List (intercalate)++import qualified Elm.Internal.Version as Version++data Module def =+ Module [String] Exports Imports [def]+ deriving (Show)++type Exports = [String]++type Imports = [(String, ImportMethod)]+data ImportMethod = As String | Importing [String] | Hiding [String]+ deriving (Eq, Ord, Show)++ +instance (Pretty def ) => Pretty (Module def) where+ pretty (Module modNames exportList importList decs) = + let + exportPret = case exportList of + [] -> P.text " "+ _ -> P.parens $ commaCat $ map P.text exportList+ + decPret = P.sep $ map pretty decs+ modName = P.text $ intercalate "." modNames+ modPret = (P.text "module" <+> modName <+> exportPret <+> P.text "where")+ + + importPret = P.vcat $ map prettyImport importList+ + prettyImport (name, method) = + case method of+ As s -> if name == s + then P.text $ "import " ++ name + else P.text $ "import " ++ name ++ " as " ++ s+ Importing strs -> (P.text $ "import " ++ name ++ " ") <+> (commaCat $ map P.text strs)+ Hiding [] -> (P.text $ "import open " ++ name ++ " ")+ Hiding strs -> (P.text $ "import open " ++ name ++ " ") <+> (commaCat $ map P.text strs)++ in P.sep [modPret, importPret, decPret] + + +instance Binary ImportMethod where+ put method =+ let put' n info = putWord8 n >> put info in+ case method of+ As s -> put' 0 s+ Importing ss -> put' 1 ss+ Hiding ss -> put' 2 ss++ get = do tag <- getWord8+ case tag of+ 0 -> As <$> get+ 1 -> Importing <$> get+ 2 -> Hiding <$> get+ _ -> error "Error reading valid ImportMethod type from serialized string"++data MetadataModule =+ MetadataModule+ { names :: [String]+ , path :: FilePath+ , exports :: [String]+ , imports :: [(String, ImportMethod)]+ , program :: LExpr+ , types :: Map.Map String Type+ , fixities :: [(Assoc, Int, String)]+ , aliases :: [Alias]+ , datatypes :: [ADT]+ } deriving Show++type Interfaces = Map.Map String ModuleInterface+type ADT = (String, [String], [(String,[Type])], [Derivation])+type Alias = (String, [String], Type, [Derivation])++data ModuleInterface = ModuleInterface {+ iVersion :: Version.Version,+ iTypes :: Map.Map String Type,+ iImports :: [(String, ImportMethod)],+ iAdts :: [ADT],+ iAliases :: [Alias],+ iFixities :: [(Assoc, Int, String)]+} deriving Show++metaToInterface :: MetadataModule -> ModuleInterface+metaToInterface metaModule =+ ModuleInterface+ { iVersion = Version.elmVersion+ , iTypes = types metaModule+ , iImports = imports metaModule+ , iAdts = datatypes metaModule+ , iAliases = aliases metaModule+ , iFixities = fixities metaModule+ }++instance Binary ModuleInterface where+ get = ModuleInterface <$> get <*> get <*> get <*> get <*> get <*> get+ put modul = do+ put (iVersion modul)+ put (iTypes modul)+ put (iImports modul)+ put (iAdts modul)+ put (iAliases modul)+ put (iFixities modul)
+ src/SourceSyntax/Pattern.hs view
@@ -0,0 +1,65 @@+{-# OPTIONS_GHC -Wall #-}+module SourceSyntax.Pattern where++import qualified SourceSyntax.Helpers as Help+import SourceSyntax.PrettyPrint+import Text.PrettyPrint as PP+import qualified Data.Set as Set+import SourceSyntax.Literal as Literal++data Pattern = PData String [Pattern]+ | PRecord [String]+ | PAlias String Pattern+ | PVar String+ | PAnything+ | PLiteral Literal.Literal+ deriving (Eq, Ord, Show)++cons :: Pattern -> Pattern -> Pattern+cons h t = PData "::" [h,t]++nil :: Pattern+nil = PData "[]" []++list :: [Pattern] -> Pattern+list = foldr cons nil++tuple :: [Pattern] -> Pattern+tuple es = PData ("_Tuple" ++ show (length es)) es++boundVars :: Pattern -> Set.Set String+boundVars pattern =+ case pattern of+ PVar x -> Set.singleton x+ PAlias x p -> Set.insert x (boundVars p)+ PData _ ps -> Set.unions (map boundVars ps)+ PRecord fields -> Set.fromList fields+ PAnything -> Set.empty+ PLiteral _ -> Set.empty+++instance Pretty Pattern where+ pretty pattern =+ case pattern of+ PVar x -> variable x+ PLiteral lit -> pretty lit+ PRecord fs -> PP.braces (commaCat $ map variable fs)+ PAlias x p -> prettyParens p <+> PP.text "as" <+> variable x+ PAnything -> PP.text "_"+ PData "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl+ where isCons = case hd of+ PData "::" _ -> True+ _ -> False+ PData name ps ->+ if Help.isTuple name then+ PP.parens . commaCat $ map pretty ps+ else hsep (PP.text name : map prettyParens ps)++prettyParens :: Pattern -> Doc+prettyParens pattern = parensIf needsThem (pretty pattern)+ where+ needsThem =+ case pattern of+ PData name (_:_) | not (Help.isTuple name) -> True+ PAlias _ _ -> True+ _ -> False
+ src/SourceSyntax/PrettyPrint.hs view
@@ -0,0 +1,34 @@++module SourceSyntax.PrettyPrint where++import Text.PrettyPrint+import qualified SourceSyntax.Helpers as Help++class Pretty a where+ pretty :: a -> Doc++instance Pretty () where+ pretty () = empty++commaCat docs = cat (punctuate comma docs)+commaSep docs = sep (punctuate comma docs)++parensIf bool doc = if bool then parens doc else doc++variable x =+ if Help.isOp x then parens (text x)+ else text (reprime x)++reprime :: String -> String+reprime = map (\c -> if c == '$' then '\'' else c)++eightyCharLines :: Int -> String -> String+eightyCharLines indent message = answer+ where+ (answer,_,_) = foldl step (spaces, indent-1, "") chunks++ chunks = map (\w -> (w, length w)) (words message)+ spaces = replicate indent ' '+ step (sentence, slen, space) (word, wlen)+ | slen + wlen > 79 = (sentence ++ "\n" ++ spaces ++ word, indent + wlen, " ")+ | otherwise = (sentence ++ space ++ word, slen + wlen + length space, " ")
+ src/SourceSyntax/Type.hs view
@@ -0,0 +1,90 @@+{-# OPTIONS_GHC -W #-}+module SourceSyntax.Type where++import Data.Binary+import qualified Data.Map as Map+import qualified SourceSyntax.Helpers as Help+import Control.Applicative ((<$>), (<*>))+import SourceSyntax.PrettyPrint+import Text.PrettyPrint as P++data Type = Lambda Type Type+ | Var String+ | Data String [Type]+ | Record [(String,Type)] (Maybe String)+ deriving (Eq, Show)++fieldMap :: [(String,a)] -> Map.Map String [a]+fieldMap fields =+ foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields++recordOf :: [(String,Type)] -> Type+recordOf fields = Record fields Nothing++listOf :: Type -> Type+listOf t = Data "_List" [t]++tupleOf :: [Type] -> Type+tupleOf ts = Data ("_Tuple" ++ show (length ts)) ts+++instance Pretty Type where+ pretty tipe =+ case tipe of+ Lambda _ _ -> P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]+ where+ t:ts = map prettyLambda (collectLambdas tipe)+ prettyLambda t = case t of+ Lambda _ _ -> P.parens (pretty t)+ _ -> pretty t++ Var x -> P.text x+ Data "_List" [t] -> P.brackets (pretty t)+ Data name tipes+ | Help.isTuple name -> P.parens . P.sep . P.punctuate P.comma $ map pretty tipes+ | otherwise -> P.hang (P.text name) 2 (P.sep $ map prettyParens tipes)+ Record fields ext ->+ P.braces $ case ext of+ Nothing -> prettyFields+ Just x -> P.hang (P.text x <+> P.text "|") 4 prettyFields+ where+ prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t+ prettyFields = commaSep . map prettyField $ fields++collectLambdas :: Type -> [Type]+collectLambdas tipe =+ case tipe of+ Lambda arg body -> arg : collectLambdas body+ _ -> [tipe]++prettyParens :: Type -> Doc+prettyParens tipe = parensIf needed (pretty tipe)+ where+ needed =+ case tipe of+ Lambda _ _ -> True+ Data "_List" [_] -> False+ Data _ [] -> False+ Data _ _ -> True+ _ -> False++instance Binary Type where+ put tipe =+ case tipe of+ Lambda t1 t2 ->+ putWord8 0 >> put t1 >> put t2+ Var x ->+ putWord8 1 >> put x+ Data ctor tipes ->+ putWord8 2 >> put ctor >> put tipes+ Record fs ext ->+ putWord8 3 >> put fs >> put ext++ get = do+ n <- getWord8+ case n of+ 0 -> Lambda <$> get <*> get+ 1 -> Var <$> get+ 2 -> Data <$> get <*> get+ 3 -> Record <$> get <*> get+ _ -> error "Error reading a valid type from serialized string"
+ tests/Main.hs view
@@ -0,0 +1,48 @@+{-|+Haskelm test suite+For the moment, just contains some basic tests+This file also serves as an example of how to +translate Elm from different sources+-}++{-# LANGUAGE TemplateHaskell, QuasiQuotes, MultiWayIf #-}++import Language.Elm.TH+import Data.List (intercalate)+import Control.Monad++-- We can get the string for the Elm source of a translation+-- using ElmStringExp+-- We use decsFromString to convert the string into a Haskell expression+elmString1 = $(elmStringExp defaultOptions $ decsFromString $ intercalate "\n" ["x = 3",+ "y = 4",+ "fun x = x + 1"])+ +-- | If we want to include the Haskell declarations as well as the elm String,+-- we use declareTranslation+-- This module will contain a Haskell variable named "elmString2"+-- As well as the decs for Local1 and Local2+-- The templateHaskell declaration brackets [d| |] mean we don't need to use decsFromString+$(declareTranslation + (Options {makeJson = True,+ declareHaskell=True,+ elmImports = [],+ moduleName="Main",+ varName="elmString2" }) + [d| data Local1 = Local1 Int+ data Local2 = Local2 String+ |])++-- | Similarly, we can load a module from a file+$(declareTranslation+ (defaultOptions {moduleName="Foo", varName="elmString3"})+ (decsFromModuleFile "tests/files/module1.hs" ))+ +-- |We can now get at our declared Haskell code+accessDecs (Local1 x) = Local2 (show x)++-- | We can now access the elm strings we declared+main = do+ putStrLn "Generated elm strings:"+ mapM_ putStrLn [elmString1, elmString2, elmString3]+ return ()