diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -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 diff --git a/haskelm.cabal b/haskelm.cabal new file mode 100644 --- /dev/null +++ b/haskelm.cabal @@ -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 diff --git a/src/Haskelm.hs b/src/Haskelm.hs new file mode 100644 --- /dev/null +++ b/src/Haskelm.hs @@ -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 diff --git a/src/Language/Elm/TH.hs b/src/Language/Elm/TH.hs new file mode 100644 --- /dev/null +++ b/src/Language/Elm/TH.hs @@ -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 diff --git a/src/Language/Elm/TH/HToE.hs b/src/Language/Elm/TH/HToE.hs new file mode 100644 --- /dev/null +++ b/src/Language/Elm/TH/HToE.hs @@ -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 diff --git a/src/Language/Elm/TH/Json.hs b/src/Language/Elm/TH/Json.hs new file mode 100644 --- /dev/null +++ b/src/Language/Elm/TH/Json.hs @@ -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 diff --git a/src/Language/Elm/TH/Util.hs b/src/Language/Elm/TH/Util.hs new file mode 100644 --- /dev/null +++ b/src/Language/Elm/TH/Util.hs @@ -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? + diff --git a/src/SourceSyntax/Declaration.hs b/src/SourceSyntax/Declaration.hs new file mode 100644 --- /dev/null +++ b/src/SourceSyntax/Declaration.hs @@ -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 " + + 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) diff --git a/src/SourceSyntax/Expression.hs b/src/SourceSyntax/Expression.hs new file mode 100644 --- /dev/null +++ b/src/SourceSyntax/Expression.hs @@ -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 $ "" + + 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 diff --git a/src/SourceSyntax/Helpers.hs b/src/SourceSyntax/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/SourceSyntax/Helpers.hs @@ -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 "+-/*=.$<>:&|^?%#@~!" diff --git a/src/SourceSyntax/Literal.hs b/src/SourceSyntax/Literal.hs new file mode 100644 --- /dev/null +++ b/src/SourceSyntax/Literal.hs @@ -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) diff --git a/src/SourceSyntax/Location.hs b/src/SourceSyntax/Location.hs new file mode 100644 --- /dev/null +++ b/src/SourceSyntax/Location.hs @@ -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 + diff --git a/src/SourceSyntax/Module.hs b/src/SourceSyntax/Module.hs new file mode 100644 --- /dev/null +++ b/src/SourceSyntax/Module.hs @@ -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) diff --git a/src/SourceSyntax/Pattern.hs b/src/SourceSyntax/Pattern.hs new file mode 100644 --- /dev/null +++ b/src/SourceSyntax/Pattern.hs @@ -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 diff --git a/src/SourceSyntax/PrettyPrint.hs b/src/SourceSyntax/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/src/SourceSyntax/PrettyPrint.hs @@ -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, " ") diff --git a/src/SourceSyntax/Type.hs b/src/SourceSyntax/Type.hs new file mode 100644 --- /dev/null +++ b/src/SourceSyntax/Type.hs @@ -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" diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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 ()