haskelm 0.0.5 → 0.1.12.0
raw patch · 9 files changed
+368/−550 lines, 9 files
Files
- haskelm.cabal +1/−1
- src/Haskelm.hs +2/−4
- src/Language/Elm/TH.hs +92/−123
- src/Language/Elm/TH/BaseDecs.hs +7/−60
- src/Language/Elm/TH/HToE.hs +9/−5
- src/Language/Elm/TH/Json.hs +246/−325
- src/SourceSyntax/Expression.hs +4/−2
- src/SourceSyntax/Module.hs +2/−2
- tests/Main.hs +5/−28
haskelm.cabal view
@@ -1,5 +1,5 @@ Name: haskelm-Version: 0.0.5+Version: 0.1.12.0 Synopsis: Elm to Haskell translation Description: Library and binary to translate Haskell code into Elm code Homepage: http://github.com/JoeyEremondi/haskelm
src/Haskelm.hs view
@@ -10,10 +10,8 @@ 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+ let options = Options True [] [] "Main"+ LitE (StringL str) <- translateToElm options infile return str putStrLn result
src/Language/Elm/TH.hs view
@@ -1,95 +1,55 @@-{-|-## 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.+-- |+-- Module: Language.Elm.TH+-- Copyright: (c) 2014 Joey Eremondi+-- License: BSD3+-- Maintainer: Joey Eremondi <jmitdase@gmail.com>+-- Stability: experimental+-- Portability: portable+-- +-- The given functions can be used to convert Haskell source code+-- into Elm source code.+-- +-- Example usage:+-- +-- > elmSource = $(translateToElm defaultOptions "path/to/myFile.hs")+-- +-- Here, `elmString1` will be a String variable which you can use in your Haskell code.+-- Note that the Haskell functions in the file you give are not imported.+-- If you would like to use them, you must import them the normal way.+-- +-- 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.+-- However, if your Haskell code contains Class or Instance declarations,+-- they will simply be ignored by Haskelm.+-- +-- Most GHC extensions are unsupported, with the exception of Multi-Way-If statements,+-- since they have a direct translation into Elm.+-- +-- +-- If JSON deriving is enabled, in addition to translating Haskell functions and types,+-- Elm functions will be generated to transform data to and from the JSON format.+-- This follows the format used by Data.Aeson.TH, so you can automatically derive your Haskell JSON definitions.+-- For a type FOO, the functions `toJson_FOO` and `fromJson_FOO` will be added to the Elm code+-- Returning and taking values of type Json.JsonValue respectively.+--+-- The module contains instances of ToJSON and FromJSON for `Data.Map.Map`+-- which match the format used by Elm's JsonUtils+-- +-- If you use the JSON functionality, the generated Elm code will depend on the `JsonUtils` library,+-- which can be obtained from <http://library.elm-lang.org>. -## 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,+ translateToElm, TranslateOptions (..),+ ToJSON (..),+ FromJSON (..), defaultOptions,- decsFromModuleString,- decsFromModuleFile,- toElmString ) where @@ -111,19 +71,34 @@ import Language.Haskell.Meta.Parse import Language.Haskell.Exts.Pretty (prettyPrint) import qualified Language.Haskell.Exts.Syntax as Exts+import Data.Aeson (ToJSON, FromJSON, parseJSON, toJSON, fromJSON)+import qualified Data.Map +-- | Options for how to generate Elm source code data TranslateOptions = Options {+ -- makeJson :: Bool,- declareHaskell :: Bool,- elmImports :: [String],- moduleName :: String,- varName :: String - + -- ^ When true, generates `toJson` and `fromJson` for translated type declarations.+ -- The format used by the Json is the same as the one used by Data.Aeson.TH.+ -- This is handy for passing data between a Haskell server and an Elm client.+ qualifiedImports :: [String],+ -- ^ Each module name given will be imported in Elm by `import Module`+ openImports :: [String],+ -- ^ Each module name given will be imported in Elm by `import Module (..)`+ moduleName :: String+ -- ^ The name of the elm module generated. i.e. prepends `module ModuleName` to the generated Elm source. } -defaultOptions = Options True False [] "Main" "var"+{- |+Default options for translation:+Generates `toJson` and `fromJson` functions,+has no open or qualified imports, and has+module name `Main`. +-}+defaultOptions = Options True [] [] "Main" + -- | '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)@@ -132,9 +107,11 @@ 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 + --sumDecs <- evalStateT (Json.giantSumType decs) Util.defaultState+ elmDecs <- evalStateT (concat <$> translateDecs (decs ++ jsonDecs) ) Util.defaultState+ let importList = map (\im->(im, Importing [])) $ qualifiedImports options+ let openImportList = map (\im->(im, Hiding [])) $ openImports options+ return $ M.Module [moduleName options] [] (importList ++ openImportList) elmDecs --Single stateful computation to store record state information translateDecs decs = do@@ -147,20 +124,12 @@ 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@@ -179,30 +148,30 @@ elmModuleToString (Module [name] exports imports elmDecs ) = let allDecs = baseDecs ++ elmDecs - allImports = imports ++ [("Json", M.As "Json"), ("Dict", M.As "Dict")]+ allImports = imports ++ [("Json", M.As "Json"), ("Dict", M.As "Dict"), ("JsonUtil", M.As "JsonUtil"), ("Error", M.As "Error")] 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+-- | Given options for translation, and the file path of a Haskell module,+-- generate the String literal which is the corresponding Elm source code.+-- This must be invoked using Template Haskell+-- For example: +--+-- > elmSource = $(translateToElm defaultOptions "path/to/myFile.hs")+translateToElm :: TranslateOptions -> FilePath -> ExpQ+translateToElm options filePath = do+ decs <- decsFromModuleFile filePath elmString <- toElmString options decs liftString elmString++++-- | ToJSON instance for Data.Map which matches the format used by Elm's JsonUtils +instance (ToJSON a, ToJSON b, Ord a) => ToJSON (Data.Map.Map a b) where+ toJSON m = toJSON $ Data.Map.toList m+ +-- | FromJSON instance for Data.Map which matches the format used by Elm's JsonUtils +instance (FromJSON a, FromJSON b, Ord a) => FromJSON (Data.Map.Map a b) where+ parseJSON json = Data.Map.fromList <$> parseJSON json
src/Language/Elm/TH/BaseDecs.hs view
@@ -7,62 +7,9 @@ import SourceSyntax.Pattern import SourceSyntax.Location -+--TODO add NthVar to unpack ADTs baseDecs = [SourceSyntax.Declaration.Definition- (SourceSyntax.Expression.Definition- (SourceSyntax.Pattern.PVar "getType")- (SourceSyntax.Location.L- (SourceSyntax.Location.Span- (SourceSyntax.Location.Pos (1) (1))- (SourceSyntax.Location.Pos (1) (1)) (""))- (SourceSyntax.Expression.Lambda- (SourceSyntax.Pattern.PData- "Object" [SourceSyntax.Pattern.PVar "d"])- (SourceSyntax.Location.L- (SourceSyntax.Location.Span- (SourceSyntax.Location.Pos (1) (1))- (SourceSyntax.Location.Pos (1) (1)) (""))- (SourceSyntax.Expression.Case- (SourceSyntax.Location.L- (SourceSyntax.Location.NoSpan "")- (SourceSyntax.Expression.App- (SourceSyntax.Location.L- (SourceSyntax.Location.NoSpan "")- (SourceSyntax.Expression.App- (SourceSyntax.Location.L- (SourceSyntax.Location.Span- (SourceSyntax.Location.Pos (1) (1))- (SourceSyntax.Location.Pos (1) (1))- (""))- (SourceSyntax.Expression.Var "Dict.lookup"))- (SourceSyntax.Location.L- (SourceSyntax.Location.Span- (SourceSyntax.Location.Pos (1) (1))- (SourceSyntax.Location.Pos (1) (1))- (""))- (SourceSyntax.Expression.Literal- (SourceSyntax.Literal.Str "__type")))))- (SourceSyntax.Location.L- (SourceSyntax.Location.Span- (SourceSyntax.Location.Pos (1) (1))- (SourceSyntax.Location.Pos (1) (1))- (""))- (SourceSyntax.Expression.Var "d"))))- [(SourceSyntax.Pattern.PData- "Just"- [SourceSyntax.Pattern.PData- "Json.String"- [SourceSyntax.Pattern.PVar "t"]],SourceSyntax.Location.L- (SourceSyntax.Location.Span- (SourceSyntax.Location.Pos- (1) (1))- (SourceSyntax.Location.Pos- (1) (1))- (""))- (SourceSyntax.Expression.Var- "t"))]))))- Nothing),- SourceSyntax.Declaration.Definition+ (SourceSyntax.Expression.Definition (SourceSyntax.Pattern.PVar "getCtor") (SourceSyntax.Location.L@@ -71,7 +18,7 @@ (SourceSyntax.Location.Pos (1) (1)) ("")) (SourceSyntax.Expression.Lambda (SourceSyntax.Pattern.PData- "Object" [SourceSyntax.Pattern.PVar "d"])+ "Json.Object" [SourceSyntax.Pattern.PVar "d"]) (SourceSyntax.Location.L (SourceSyntax.Location.Span (SourceSyntax.Location.Pos (1) (1))@@ -95,7 +42,7 @@ (SourceSyntax.Location.Pos (1) (1)) ("")) (SourceSyntax.Expression.Literal- (SourceSyntax.Literal.Str "__ctor")))))+ (SourceSyntax.Literal.Str "tag"))))) (SourceSyntax.Location.L (SourceSyntax.Location.Span (SourceSyntax.Location.Pos (1) (1))@@ -125,7 +72,7 @@ (SourceSyntax.Location.Pos (1) (1)) ("")) (SourceSyntax.Expression.Lambda (SourceSyntax.Pattern.PData- "Object" [SourceSyntax.Pattern.PVar "d"])+ "Json.Object" [SourceSyntax.Pattern.PVar "d"]) (SourceSyntax.Location.L (SourceSyntax.Location.Span (SourceSyntax.Location.Pos (1) (1))@@ -198,7 +145,7 @@ (SourceSyntax.Location.NoSpan "") (SourceSyntax.Expression.Lambda (SourceSyntax.Pattern.PData- "Array" [SourceSyntax.Pattern.PVar "l"])+ "Json.Array" [SourceSyntax.Pattern.PVar "l"]) (SourceSyntax.Location.L (SourceSyntax.Location.NoSpan "") (SourceSyntax.Expression.App@@ -234,7 +181,7 @@ ("")) (SourceSyntax.Expression.Lambda (SourceSyntax.Pattern.PData- "Array" [SourceSyntax.Pattern.PVar "l"])+ "Json.Array" [SourceSyntax.Pattern.PVar "l"]) (SourceSyntax.Location.L (SourceSyntax.Location.Span (SourceSyntax.Location.Pos (1) (1))
src/Language/Elm/TH/HToE.hs view
@@ -96,7 +96,7 @@ --ignore strictness let nameTypes = map (\(a,_,b)->(a,b)) vstList recordTy <- translateRecord nameTypes- let recordDecs = map (accessorDec . fst) nameTypes+ let recordDecs = map ((accessorDec name). 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 @@ -662,14 +662,14 @@ return $ T.recordOf $ zip eNames eTypes --Generate the function declarations associated with a record type-accessorDec :: Name -> D.Declaration+accessorDec :: Name -> Name -> D.Declaration --Names are always local-accessorDec name = +accessorDec ctor name = let nameString = nameToString name var = "rec" varExp = E.Var var- varPat = P.PVar var+ varPat = P.PData (nameToString ctor) [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@@ -715,6 +715,8 @@ --Not a change, but lets us search for . in module names getElmName "." = "." +getElmName "error" = "Error.raise"+ --Specific cases getElmName s | length partList > 1 = getElmModuleName modul name@@ -730,7 +732,9 @@ 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 "Json" s = s `elem` ["String", "Number", "Boolean", "Null", "Array", "Object"] ++elmHasFunction "Error" s = s `elem` ["raise"] elmHasFunction _ _ = False
src/Language/Elm/TH/Json.hs view
@@ -40,43 +40,30 @@ import Control.Applicative +import Control.Monad+ import Control.Monad.State (StateT) import qualified Control.Monad.State as S -----------------------------------------------------------------------------------------Helpers to make to and fromJson functions+-- |Helper function to apply arguments to a function+applyArgs :: Exp -> [Exp] -> Exp+applyArgs fun args = foldl (\ accumFun nextArg -> AppE accumFun nextArg) fun args --- | 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))) [] +fnComp = VarE $ mkName "." --- | 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")) )) [] +-- | 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 --- | 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")) )) [] - +-- | Variable for the getter function getting the nth variable from a Json+varNamed :: Exp+varNamed = VarE (mkName "JsonUtil.varNamed")+ +-- | Expression getting a named subvariable from a JSON object+getVarNamed :: String -> Exp+getVarNamed nstr = AppE (AppE varNamed jsonArgExp ) (LitE $ StringL nstr) -- | Filter function to test if a dec is a data -- Also filters out decs which types that can't be serialized, such as functions@@ -100,162 +87,138 @@ 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 +--General helper functions+jsonArgName :: Name+jsonArgName = mkName "jsonArg" --- | Expression to access the constructor field of a JSON object-getCtor :: Exp-getCtor = AppE jsonCtor json +jsonArgPat :: Pat+jsonArgPat = VarP jsonArgName --- | Expression representing function composition-fnComp :: Exp-fnComp = VarE $ mkName "."+jsonArgExp :: Exp+jsonArgExp = VarE jsonArgName --- | The string prefix for the massive JSON sum type-sumTypePrefix :: String-sumTypePrefix = "BoxedJson"+fromJsonName :: Name -> Name+fromJsonName name = mkName $ "fromJson_" ++ nameToString name --- |The String argument of the massive JSON sum type property denoting a given ADT-typeString :: Name -> SQ String-typeString name = return $ sumTypePrefix ++ "_" ++ nameToString name+toJsonName :: Name -> Name+toJsonName name = mkName $ "toJson_" ++ 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 "."+makeFromJson :: [Dec] -> SQ [Dec]+makeFromJson allDecs = do+ let decs = filter isData allDecs+ mapM fromJsonForDec decs -unJsonType (AppT ListT t) = do- subFun <- unJsonType t- let mapVar = VarE $ mkName "mapJson"- return $ AppE mapVar subFun+-- | Given a type, and an expression for an argument of type Json+-- return the expression which applies the proper fromJson function to that expression+fromJsonForType :: Type -> SQ Exp +--Type name not covered by Prelude+fromJsonForType (ConT name) = case (nameToString name) of+ "Int" -> return $ VarE $ mkName "JsonUtil.intFromJson"+ "Bool" -> return $ VarE $ mkName "JsonUtil.boolFromJson"+ "Float" -> return $ VarE $ mkName "JsonUtil.floatFromJson"+ "Double" -> return $ VarE $ mkName "JsonUtil.floatFromJson"+ "String" -> return $ VarE $ mkName "JsonUtil.stringFromJson"+ _ -> return $ VarE $ fromJsonName name +fromJsonForType (AppT ListT t) = do+ subExp <- fromJsonForType t+ return $ AppE (VarE $ mkName "JsonUtil.listFromJson") subExp ---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+fromJsonForType (AppT (ConT name) t) = do+ subExp <- fromJsonForType t+ case (nameToString name) of+ "Maybe" -> return $ AppE (VarE $ mkName "JsonUtil.maybeFromJson") subExp+ +fromJsonForType (AppT (AppT (ConT name) t1) t2) = do+ sub1 <- fromJsonForType t1+ sub2 <- fromJsonForType t2+ case (nameToString name) of+ "Data.Map.Map" -> return $ applyArgs (VarE $ mkName "JsonUtil.dictFromJson") [sub1, sub2]+ s -> error $ "Unsupported json type " ++ s+ +fromJsonForType 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+ subFunList <- mapM fromJsonForType 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+ | otherwise = error $ "Can't make Json for type " ++ (show t) ++-- |Given a type declaration, generate the function declaration+-- Which takes a Json object to a value of that type+fromJsonForDec :: Dec -> SQ Dec++--Special case: we only have one ctor, so we don't use a tag+fromJsonForDec dec@(DataD _ name _ [ctor] _deriving) = do+ Match _pat fnBody _decs <- fromMatchForCtor 1 ctor+ let argPat = jsonArgPat+ let fnName = fromJsonName name+ let fnClause = Clause [argPat] fnBody []+ return $ FunD fnName [fnClause] - | 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 [])+ +fromJsonForDec dec@(DataD _ name _ ctors _deriving) = do+ let argTagExpression = AppE (VarE $ mkName "JsonUtil.getTag") jsonArgExp+ let numCtors = length ctors+ ctorMatches <- mapM (fromMatchForCtor numCtors) ctors+ let fnExp = CaseE argTagExpression ctorMatches+ let argPat = jsonArgPat+ let fnName = fromJsonName name+ let fnBody = NormalB fnExp+ let fnClause = Clause [argPat] fnBody []+ return $ FunD fnName [fnClause] --- | 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 +fromJsonForDec (NewtypeD cxt name tyBindings ctor nameList) = + fromJsonForDec $ DataD cxt name tyBindings [ctor] nameList+ +fromJsonForDec dec@(TySynD name _tyvars ty) = do+ let fnName = fromJsonName name+ fnBody <- NormalB <$> fromJsonForType ty+ let fnClause = Clause [] fnBody []+ return $ FunD fnName [fnClause]+ + +fromMatchForCtor :: Int -> Con -> SQ Match -fromMatchForCtor (RecC name vstList) = do+fromMatchForCtor numCtors (NormalC name strictTypes) = do+ let types = map snd strictTypes+ let leftHandSide = LitP $ StringL $ nameToString name+ + let ctorExp = VarE name+ + --Exp in TH, list in Haskell+ contentListExpr <- NormalB <$> unpackContents numCtors jsonArgExp+ + fromJsonFunctions <- mapM fromJsonForType types+ let intNames = map (("subVar" ++) . show) [1 .. length types]+ subDataNames <- mapM liftNewName intNames+ --We unpack each json var into its own named variable, so we can unpack them into different types+ let subDataListPattern = ListP $ map VarP subDataNames+ + --let subDataExprs = map VarE subDataNames+ + let unJsonedExprList = zipWith AppE fromJsonFunctions (map VarE subDataNames)+ + let letExp = LetE [ValD subDataListPattern contentListExpr []] (applyArgs ctorExp unJsonedExprList)+ + let rightHandSide = NormalB $ letExp+ return $ Match leftHandSide rightHandSide []+ ++fromMatchForCtor _numCtors (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+ (subNames, subDecs) <- unzip <$> mapM getSubJsonRecord nameTypes let body = NormalB $ if null subNames then applyArgs subNames ctorExp else LetE subDecs (applyArgs subNames ctorExp)@@ -264,205 +227,163 @@ 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 +-- | 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+getSubJsonRecord :: (String, Type) -> SQ (Name, Dec)+-- We need special cases for lists and tuples, to unpack them+--TODO recursive case+getSubJsonRecord (field, t) = do+ funToApply <- fromJsonForType t+ subName <- liftNewName "subVar"+ let subLeftHand = VarP subName+ let subRightHand = NormalB $ AppE funToApply (getVarNamed field)+ return (subName, ValD subLeftHand subRightHand [])+ +unpackContents :: Int -> Exp -> SQ Exp+unpackContents numCtors jsonValue = return $ applyArgs (VarE $ mkName "JsonUtil.unpackContents") [LitE $ IntegerL $ toInteger numCtors, jsonValue] -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 []] ]+ mapM toJsonForDec decs --- | 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+toJsonForType :: Type -> SQ Exp+toJsonForType (ConT name) = case (nameToString name) of+ "Int" -> return $ VarE $ mkName "JsonUtil.intToJson"+ "Bool" -> return $ VarE $ mkName "JsonUtil.boolToJson"+ "Float" -> return $ VarE $ mkName "JsonUtil.floatToJson"+ "Double" -> return $ VarE $ mkName "JsonUtil.floatToJson"+ "String" -> return $ VarE $ mkName "JsonUtil.stringToJson"+ _ -> return $ VarE $ toJsonName name+ +toJsonForType (AppT (AppT (ConT name) t1) t2) = do+ sub1 <- toJsonForType t1+ sub2 <- toJsonForType t2+ case (nameToString name) of+ "Data.Map.Map" -> return $ applyArgs (VarE $ mkName "JsonUtil.dictToJson") [sub1, sub2]+ s -> error $ "Unsupported json type " ++ s+ + +toJsonForType (AppT ListT t) = do+ subExp <- toJsonForType t+ return $ AppE (VarE $ mkName "JsonUtil.listToJson") subExp + +toJsonForType (AppT (ConT name) t) = do+ subExp <- toJsonForType t+ case (nameToString name) of+ "Maybe" -> return $ AppE (VarE $ mkName "JsonUtil.maybeToJson") subExp ---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 []+toJsonForType t + | isTupleType t = do+ let tList = tupleTypeToList t+ let n = length tList+ --Generate the lambda to convert the list into a tuple+ subFunList <- mapM toJsonForType 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 -toMatchForCtor typeName (RecC name vstList) = do+toJsonForDec :: Dec -> SQ Dec+toJsonForDec dec@(DataD _ name _ ctors _deriving) = do+ let argPat = jsonArgPat+ let argExp = jsonArgExp+ let numCtors = length ctors + ctorMatches <- mapM (toMatchForCtor numCtors) ctors+ + let fnExp = CaseE jsonArgExp ctorMatches+ + let fnName = toJsonName name+ let fnBody = NormalB fnExp+ let fnClause = Clause [argPat] fnBody []+ return $ FunD fnName [fnClause]+ +toJsonForDec (NewtypeD cxt name tyBindings ctor nameList) = + toJsonForDec $ DataD cxt name tyBindings [ctor] nameList+ +toJsonForDec dec@(TySynD name _tyvars ty) = do+ let fnName = toJsonName name+ fnBody <- NormalB <$> toJsonForType ty+ let fnClause = Clause [] fnBody []+ return $ FunD fnName [fnClause]+ +toJsonForDec dec = error $ "Unknown dec type" ++ (show dec)++ +toMatchForCtor :: Int -> Con -> SQ Match+toMatchForCtor numCtors (NormalC name strictTypes) = do+ let types = map snd strictTypes+ let numStrings = map (("subVar_" ++) . show) [1 .. length types]+ subDataNames <- mapM liftNewName numStrings+ let subDataPats = map VarP subDataNames+ + let leftHandSide = ConP name subDataPats+ + let subDataExprs = map VarE subDataNames+ + toJsonFunctions <- mapM toJsonForType types+ + let contentsList = ListE $ zipWith AppE toJsonFunctions subDataExprs+ + jsonValueExp <- packContents numCtors name contentsList+ let rightHandSide = NormalB jsonValueExp+ + return $ Match leftHandSide rightHandSide []++--TODO is there ever a record with 0 args?+toMatchForCtor _numCtors (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)+ jsonDecs <- mapM makeSubJsonRecord (zip3 types adtNames jsonNames) dictName <- liftNewName "objectDict"- dictDec <- makeDict typeName name dictName jsonNames+ dictDec <- makeRecordDict name dictName jsonNames let ret = AppE (VarE $ mkName "Json.Object") (VarE dictName) let body = NormalB $ LetE (jsonDecs ++ [dictDec]) ret- return $ Match matchPat body [] - + 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+makeRecordDict :: Name -> Name -> [Name] -> SQ Dec++makeRecordDict 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 ctorTuple = TupE [LitE $ StringL "tag", AppE (VarE (mkName "Json.String")) ctorExp ]+ let tupleList = ListE $ [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+makeSubJsonRecord :: (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+makeSubJsonRecord (t, adtName, jsonName) = do+ funToApply <- toJsonForType 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+packContents :: Int -> Name -> Exp -> SQ Exp+packContents numCtors name contentList = do+ return $ applyArgs (VarE $ mkName "JsonUtil.packContents") [LitE $ IntegerL $ toInteger numCtors, LitE $ StringL $ nameToString name, contentList]+ +
src/SourceSyntax/Expression.hs view
@@ -1,13 +1,15 @@ {-# 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. -}+module SourceSyntax.Expression where + import SourceSyntax.PrettyPrint import Text.PrettyPrint as P import qualified SourceSyntax.Helpers as Help@@ -170,7 +172,7 @@ pretty (Definition pattern expr maybeTipe) = P.vcat [ annotation, definition ] where- definition = pretty pattern <+> P.equals <+> pretty expr+ definition = (P.parens $ pretty pattern) <+> P.equals <+> pretty expr annotation = case maybeTipe of Nothing -> P.empty Just tipe -> pretty pattern <+> P.colon <+> pretty tipe
src/SourceSyntax/Module.hs view
@@ -45,8 +45,8 @@ 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)+ Hiding [] -> (P.text $ "import " ++ name ++ "(..) ")+ Hiding strs -> (P.text $ "import " ++ name ++ " ") <+> P.parens (commaCat $ map P.text strs) in P.sep [modPret, importPret, decPret]
tests/Main.hs view
@@ -11,38 +11,15 @@ 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)+elmString = $(translateToElm+ (defaultOptions {moduleName="Foo"})+ ("tests/files/module1.hs" ) ) -- | We can now access the elm strings we declared main = do putStrLn "Generated elm strings:"- mapM_ putStrLn [elmString1, elmString2, elmString3]+ mapM_ putStrLn [elmString]+ writeFile "src/Test.elm" elmString return ()