typed-wire (empty) → 0.1.0.0
raw patch · 13 files changed
+1189/−0 lines, 13 filesdep +basedep +containersdep +directorysetup-changed
Dependencies added: base, containers, directory, filepath, gitrev, mtl, optparse-applicative, parsec, text, typed-wire
Files
- LICENSE +20/−0
- README.md +48/−0
- Setup.hs +2/−0
- app/Main.hs +121/−0
- src/TW/Ast.hs +100/−0
- src/TW/BuiltIn.hs +52/−0
- src/TW/Check.hs +85/−0
- src/TW/CodeGen/Elm.hs +265/−0
- src/TW/CodeGen/Haskell.hs +186/−0
- src/TW/JsonRepr.hs +18/−0
- src/TW/Loader.hs +57/−0
- src/TW/Parser.hs +180/−0
- typed-wire.cabal +55/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Alexander Thiemann <mail@athiemann.net>++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,48 @@+typed-wire+=====++[](https://travis-ci.org/agrafix/typed-wire)+++## Intro+++WIP: Language idependent type-safe communication++## Cli Usage: twirec++```sh+$ twirec --help+Generate bindings using typed-wire for different languages++Usage: twirec [--version] [-i|--include-dir DIR] [-e|--entrypoint MODULE-NAME]+ [--hs-out DIR] [--elm-out DIR]+ Language idependent type-safe communication++Available options:+ -h,--help Show this help text+ --version show version and exit+ -i,--include-dir DIR Directory to search for modules+ -e,--entrypoint MODULE-NAME+ Entrypoint for compiler+ --hs-out DIR Generate Haskell bindings to specified dir+ --elm-out DIR Generate Elm bindings to specified dir++```++## Install++* From Source (cabal): `git clone https://github.com/agrafix/typed-wire.git && cd typed-wire && cabal install`+* From Source (stack): `git clone https://github.com/agrafix/typed-wire.git && cd typed-wire && stack build`+++## Misc++### Supported GHC Versions++* 7.10.2++### License++Released under the MIT license.+(c) 2015 Alexander Thiemann <mail@athiemann.net>
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module Main where++import TW.Ast+import TW.Check+import TW.Loader+import TW.Parser+import qualified TW.CodeGen.Elm as Elm+import qualified TW.CodeGen.Haskell as HS++import qualified Paths_typed_wire as Meta++import Control.Monad+import Development.GitRev+import Options.Applicative+import System.Directory+import System.FilePath+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.Version as Vers++data Options+ = Options+ { o_showVersion :: Bool+ , o_sourceDirs :: [FilePath]+ , o_entryPoints :: [ModuleName]+ , o_hsOutDir :: Maybe FilePath+ , o_elmOutDir :: Maybe FilePath+ }++optParser :: Parser Options+optParser =+ Options+ <$> switch (long "version" <> help "show version and exit")+ <*> sourceDirsP+ <*> entryPointsP+ <*> hsOutP+ <*> elmOutP++sourceDirsP :: Parser [FilePath]+sourceDirsP =+ many $ strOption $+ long "include-dir" <> short 'i' <> metavar "DIR" <> help "Directory to search for modules"++entryPointsP :: Parser [ModuleName]+entryPointsP =+ many $ option (str >>= mkMod) $+ long "entrypoint" <> short 'e' <> metavar "MODULE-NAME" <> help "Entrypoint for compiler"+ where+ mkMod t =+ case makeModuleName (T.pack t) of+ Left _ -> fail $ "Can not parse " ++ t ++ " as module"+ Right x -> return x++hsOutP :: Parser (Maybe FilePath)+hsOutP =+ optional $ strOption $+ long "hs-out" <> metavar "DIR" <> help "Generate Haskell bindings to specified dir"++elmOutP :: Parser (Maybe FilePath)+elmOutP =+ optional $ strOption $+ long "elm-out" <> metavar "DIR" <> help "Generate Elm bindings to specified dir"++main :: IO ()+main =+ execParser opts >>= run+ where+ opts =+ info (helper <*> optParser)+ ( fullDesc+ <> progDesc "Language idependent type-safe communication"+ <> header "Generate bindings using typed-wire for different languages"+ )++showVersion :: IO ()+showVersion =+ T.putStrLn versionMessage+ where+ versionMessage =+ T.unlines+ [ "Version " <> T.pack (Vers.showVersion Meta.version)+ , "Git: " <> $(gitBranch) <> "@" <> $(gitHash)+ , " (" <> $(gitCommitCount) <> " commits in HEAD)"+ , if $(gitDirty) then " (includes uncommited changes)" else ""+ ]++run :: Options -> IO ()+run opts =+ if o_showVersion opts+ then showVersion+ else run' opts++run' :: Options -> IO ()+run' opts =+ do allModules <- loadModules (o_sourceDirs opts) (o_entryPoints opts)+ putStrLn "All modules loaded"+ case allModules of+ Left err -> fail err+ Right ok ->+ case checkModules ok of+ Left err -> fail err+ Right readyModules ->+ forM_ readyModules $ \m ->+ do case o_hsOutDir opts of+ Just dir ->+ runner m dir HS.makeModule HS.makeFileName+ Nothing -> return ()+ case o_elmOutDir opts of+ Just dir ->+ runner m dir Elm.makeModule Elm.makeFileName+ Nothing -> return ()++runner :: Module -> FilePath -> (Module -> T.Text) -> (ModuleName -> FilePath) -> IO ()+runner m baseDir mkModule mkFilename =+ let moduleSrc = mkModule m+ moduleFp = baseDir </> mkFilename (m_name m)+ in do createDirectoryIfMissing True (takeDirectory moduleFp)+ putStrLn $ "Writing " ++ moduleFp ++ " ..."+ T.writeFile moduleFp moduleSrc
+ src/TW/Ast.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+module TW.Ast where++import qualified Data.Text as T++newtype ModuleName+ = ModuleName { unModuleName :: [T.Text] }+ deriving (Show, Eq, Ord)++printModuleName :: ModuleName -> T.Text+printModuleName (ModuleName comps) = T.intercalate "." comps++printModuleNameS :: ModuleName -> String+printModuleNameS = T.unpack . printModuleName++newtype TypeName+ = TypeName { unTypeName :: T.Text }+ deriving (Show, Eq, Ord)++newtype TypeVar+ = TypeVar { unTypeVar :: T.Text }+ deriving (Show, Eq, Ord)++newtype FieldName+ = FieldName { unFieldName :: T.Text }+ deriving (Show, Eq, Ord)++newtype ChoiceName+ = ChoiceName { unChoiceName :: T.Text }+ deriving (Show, Eq, Ord)++data QualTypeName+ = QualTypeName+ { qtn_module :: ModuleName+ , qtn_type :: TypeName+ } deriving (Show, Eq, Ord)++data Module+ = Module+ { m_name :: ModuleName+ , m_imports :: [ModuleName]+ , m_typeDefs :: [TypeDef]+ } deriving (Show, Eq)++data TypeDef+ = TypeDefEnum EnumDef+ | TypeDefStruct StructDef+ deriving (Show, Eq)++data EnumDef+ = EnumDef+ { ed_name :: TypeName+ , ed_args :: [TypeVar]+ , ed_choices :: [EnumChoice]+ } deriving (Show, Eq)++data EnumChoice+ = EnumChoice+ { ec_name :: ChoiceName+ , ec_arg :: Maybe Type+ } deriving (Show, Eq)++data StructDef+ = StructDef+ { sd_name :: TypeName+ , sd_args :: [TypeVar]+ , sd_fields :: [StructField]+ } deriving (Show, Eq)++data StructField+ = StructField+ { sf_name :: FieldName+ , sf_type :: Type+ } deriving (Show, Eq)++data Type+ = TyVar TypeVar+ | TyCon QualTypeName [Type]+ deriving (Show, Eq)+++{-+module Basic;++type Foo {+ someField : Int;+ someOtherField : Maybe Int;+}++type Bar<T> {+ someField : T;+ moreFields : Int;+}++enum Psy {+ Simple;+ Tagged(Foo);+}+-}
+ src/TW/BuiltIn.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE OverloadedStrings #-}+module TW.BuiltIn+ ( BuiltIn(..)+ , allBuiltIns, isBuiltIn+ , tyString, tyInt, tyFloat, tyBool, tyMaybe+ )+where++import TW.Ast++import qualified Data.List as L+import qualified Data.Text as T++data BuiltIn+ = BuiltIn+ { bi_name :: QualTypeName+ , bi_args :: [TypeVar]+ } deriving (Show, Eq)++allBuiltIns :: [BuiltIn]+allBuiltIns = [tyString, tyInt, tyFloat, tyBool, tyMaybe]++isBuiltIn :: Type -> Maybe (BuiltIn, [Type])+isBuiltIn ty =+ case ty of+ TyVar _ -> Nothing+ TyCon qt args ->+ let r = flip L.find allBuiltIns $ \bi -> bi_name bi == qt && length (bi_args bi) == length args+ in case r of+ Just x -> Just (x, args)+ _ -> Nothing++builtIn :: T.Text -> BuiltIn+builtIn = flip builtInVars []++builtInVars :: T.Text -> [T.Text] -> BuiltIn+builtInVars x v = BuiltIn (QualTypeName (ModuleName []) (TypeName x)) (map TypeVar v)++tyString :: BuiltIn+tyString = builtIn "String"++tyInt :: BuiltIn+tyInt = builtIn "Int"++tyBool :: BuiltIn+tyBool = builtIn "Bool"++tyFloat :: BuiltIn+tyFloat = builtIn "Float"++tyMaybe :: BuiltIn+tyMaybe = builtInVars "Maybe" ["a"]
+ src/TW/Check.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE FlexibleContexts #-}+module TW.Check where++import TW.Ast+import TW.BuiltIn++import Control.Monad.Except+import qualified Data.Map as M++data DefinedType+ = DefinedType+ { dt_name :: QualTypeName+ , dt_args :: [TypeVar]+ } deriving (Show, Eq)++builtInToDefTy :: BuiltIn -> DefinedType+builtInToDefTy bi =+ DefinedType+ { dt_name = bi_name bi+ , dt_args = bi_args bi+ }++typeDefToDefTy :: Maybe ModuleName -> TypeDef -> DefinedType+typeDefToDefTy qualOwner td =+ let mkTy =+ case qualOwner of+ Nothing -> QualTypeName (ModuleName [])+ Just qt -> QualTypeName qt+ in case td of+ TypeDefEnum ed ->+ DefinedType (mkTy (ed_name ed)) (ed_args ed)+ TypeDefStruct sd ->+ DefinedType (mkTy (sd_name sd)) (sd_args sd)++checkModules :: [Module] -> Either String [Module]+checkModules modules =+ runExcept $+ forM modules $ \m ->+ do let currentMStr = printModuleNameS $ m_name m+ defTypes <-+ M.fromList . map (\dt -> (dt_name dt, dt_args dt)) <$>+ getDefinedTypes m+ let isValidType args t =+ case t of+ TyVar tv ->+ if tv `elem` args+ then return ()+ else throwError $ "Undefined type variable " ++ show tv ++ " in " ++ currentMStr+ TyCon qt qtArgs ->+ case M.lookup qt defTypes of+ Nothing ->+ throwError $ "Undefined type variable " ++ show qt ++ " in " ++ currentMStr+ Just tvars ->+ do forM_ qtArgs (isValidType args)+ when (length tvars /= length qtArgs) $+ throwError $+ "Type " ++ show qt ++ " got applied wrong number of arguments in " ++ currentMStr+ forM_ (m_typeDefs m) $ \td ->+ case td of+ TypeDefEnum ed ->+ forM_ (ed_choices ed) $ \ch ->+ case ec_arg ch of+ Nothing -> return ()+ Just ty -> isValidType (ed_args ed) ty+ TypeDefStruct sd ->+ forM_ (sd_fields sd) $ \fld ->+ do isValidType (sd_args sd) (sf_type fld)+ return m+ where+ getDefinedTypes m =+ do importedTypes <-+ forM (m_imports m) $ \im ->+ case M.lookup im moduleMap of+ Nothing ->+ throwError $+ "Unknown module " ++ printModuleNameS im+ ++ " referenced from " ++ (printModuleNameS $ m_name m)+ Just imModel ->+ return $ map (typeDefToDefTy (Just im)) $ m_typeDefs imModel+ return $ concat importedTypes+ ++ (map (typeDefToDefTy Nothing) $ m_typeDefs m)+ ++ map builtInToDefTy allBuiltIns+ moduleMap =+ M.fromList $+ map (\m -> (m_name m, m)) modules
+ src/TW/CodeGen/Elm.hs view
@@ -0,0 +1,265 @@+{-# LANGUAGE OverloadedStrings #-}+module TW.CodeGen.Elm+ ( makeFileName, makeModule )+where++import TW.Ast+import TW.BuiltIn+import TW.JsonRepr++import Data.Maybe+import Data.Monoid+import System.FilePath+import qualified Data.List as L+import qualified Data.Text as T++jsonEncQual :: T.Text+jsonEncQual = "JE"++jsonEnc :: T.Text -> T.Text+jsonEnc x = jsonEncQual <> "." <> x++jsonDecQual :: T.Text+jsonDecQual = "JD"++jsonDec :: T.Text -> T.Text+jsonDec x = jsonDecQual <> "." <> x++makeFileName :: ModuleName -> FilePath+makeFileName (ModuleName parts) =+ (L.foldl' (</>) "" $ map T.unpack parts) ++ ".elm"++makeModule :: Module -> T.Text+makeModule m =+ T.unlines+ [ "-- | This file was auto generated by typed-wire. Do not modify by hand"+ , "module " <> printModuleName (m_name m) <> " where"+ , ""+ , T.intercalate "\n" (map makeImport $ m_imports m)+ , ""+ , "import Json.Decode as " <> jsonDecQual+ , "import Json.Decode exposing ((:=))"+ , "import Json.Encode as " <> jsonEncQual+ , ""+ , T.intercalate "\n" (map makeTypeDef $ m_typeDefs m)+ ]++makeImport :: ModuleName -> T.Text+makeImport m =+ "import " <> printModuleName m++makeTypeDef :: TypeDef -> T.Text+makeTypeDef td =+ case td of+ TypeDefEnum ed ->+ makeEnumDef ed+ TypeDefStruct sd ->+ makeStructDef sd++makeStructDef :: StructDef -> T.Text+makeStructDef sd =+ T.unlines+ [ "type alias " <> fullType <> " ="+ , " { " <> T.intercalate "\n , " (map makeStructField $ sd_fields sd)+ , " }"+ , ""+ , "jenc" <> unTypeName (sd_name sd) <> " : " <> encTy <> fullType <> " -> " <> jsonEnc "Value"+ , "jenc" <> unTypeName (sd_name sd) <> " " <> encArgs <> " x ="+ , " let packMaybe enc y ="+ , " case y of"+ , " Just val -> enc y"+ , " Nothing -> " <> jsonEnc "null"+ , " in " <> jsonEnc "object"+ , " [ " <> T.intercalate "\n , " (map makeToJsonFld $ sd_fields sd)+ , " ]"+ , "jdec" <> unTypeName (sd_name sd) <> " : " <> jsonDec "Decoder" <> " (" <> fullType <> ")"+ , "jdec" <> unTypeName (sd_name sd) <> " ="+ , " " <> T.intercalate "\n " (map makeFromJsonFld $ sd_fields sd)+ , " " <> jsonDec "succeed" <> " (" <> unTypeName (sd_name sd) <> " " <> funArgs <> ")"+ ]+ where+ (encTy, encArgs) =+ case sd_args sd of+ [] -> ("", "")+ _ ->+ let mkEncTy (TypeVar v) =+ "(" <> v <> " -> " <> jsonEnc "Value" <> ")"+ in ( T.intercalate " -> " (map mkEncTy $ sd_args sd) <> " -> "+ , T.intercalate " " (map varEnc $ sd_args sd)+ )+ jArg fld = "j_" <> (unFieldName $ sf_name fld)+ makeFromJsonFld fld =+ let name = unFieldName $ sf_name fld+ arg = jArg fld+ (maybePrefix, decoder) =+ case isBuiltIn (sf_type fld) of+ Just (bi, [maybeArg]) | bi == tyMaybe ->+ ( jsonDec "maybe" <> " "+ , jsonDecFor maybeArg+ )+ _ -> ("", jsonDecFor $ sf_type fld)+ dec =+ maybePrefix <> "(" <> T.pack (show name) <> " := " <> decoder <> ")"+ in dec <> " `" <> jsonDec "andThen" <> "` \\" <> arg <> " -> "+ makeToJsonFld fld =+ let name = unFieldName $ sf_name fld+ encoder = jsonEncFor (sf_type fld)+ in "(" <> T.pack (show name) <> ", " <> encoder <> " x." <> name <> ")"+ funArgs =+ T.intercalate " " $ map jArg (sd_fields sd)+ fullType =+ unTypeName (sd_name sd) <> " " <> T.intercalate " " (map unTypeVar $ sd_args sd)++makeStructField :: StructField -> T.Text+makeStructField sf =+ (unFieldName $ sf_name sf) <> " : " <> (makeType $ sf_type sf)++makeEnumDef :: EnumDef -> T.Text+makeEnumDef ed =+ T.unlines+ [ "type " <> fullType+ , " = " <> T.intercalate "\n | " (map makeEnumChoice $ ed_choices ed)+ , ""+ , "jenc" <> unTypeName (ed_name ed) <> " : " <> encTy <> fullType <> " -> " <> jsonEnc "Value"+ , "jenc" <> unTypeName (ed_name ed) <> " " <> encArgs <> " x ="+ , " let packMaybe enc y ="+ , " case y of"+ , " Just val -> enc y"+ , " Nothing -> " <> jsonEnc "null"+ , " in case x of"+ , " " <> T.intercalate "\n " (map mkToJsonChoice $ ed_choices ed)+ , "jdec" <> unTypeName (ed_name ed) <> " : " <> jsonDec "Decoder" <> " (" <> fullType <> ")"+ , "jdec" <> unTypeName (ed_name ed) <> " ="+ , " " <> jsonDec "oneOf"+ , " [ " <> T.intercalate "\n , " (map mkFromJsonChoice $ ed_choices ed)+ , " ]"+ ]+ where+ (encTy, encArgs) =+ case ed_args ed of+ [] -> ("", "")+ _ ->+ let mkEncTy (TypeVar v) =+ "(" <> v <> " -> " <> jsonEnc "Value" <> ")"+ in ( T.intercalate " -> " (map mkEncTy $ ed_args ed) <> " -> "+ , T.intercalate " " (map varEnc $ ed_args ed)+ )+ mkFromJsonChoice ec =+ let constr = unChoiceName $ ec_name ec+ tag = camelTo2 '_' $ T.unpack constr+ (decoder, andThen) =+ case ec_arg ec of+ Nothing -> (jsonDec "bool", "\\_ -> " <> jsonDec "succeed" <> " " <> constr)+ Just arg -> (jsonDecFor arg, "\\z -> " <> jsonDec "succeed" <> " (" <> constr <> " z)")+ in "(" <> T.pack (show tag) <> " := " <> decoder <> ") `" <> jsonDec "andThen" <> "` " <> andThen+ mkToJsonChoice ec =+ let constr = unChoiceName $ ec_name ec+ tag = camelTo2 '_' $ T.unpack constr+ (argParam, argVal, encoder) =+ case ec_arg ec of+ Nothing -> ("", "True", jsonEnc "bool")+ Just arg -> ("x", "x", jsonEncFor arg)+ in constr <> " " <> argParam <> " -> "+ <> jsonEnc "object" <> "[(" <> T.pack (show tag) <> ", " <> encoder <> " " <> argVal <> ")]"+ fullType =+ unTypeName (ed_name ed) <> " " <> T.intercalate " " (map unTypeVar $ ed_args ed)++makeEnumChoice :: EnumChoice -> T.Text+makeEnumChoice ec =+ (unChoiceName $ ec_name ec) <> fromMaybe "" (fmap ((<>) " " . makeType) $ ec_arg ec)++jsonEncFor :: Type -> T.Text+jsonEncFor t =+ case isBuiltIn t of+ Nothing ->+ case t of+ TyVar v -> varEnc v+ TyCon qt args ->+ let ty = makeQualEnc qt+ in case args of+ [] -> ty+ _ -> "(" <> ty <> " " <> T.intercalate " " (map jsonEncFor args) <> ")"+ Just (bi, tvars)+ | bi == tyString -> jsonEnc "string"+ | bi == tyInt -> jsonEnc "int"+ | bi == tyBool -> jsonEnc "bool"+ | bi == tyFloat -> jsonEnc "float"+ | bi == tyMaybe ->+ case tvars of+ [arg] -> "packMaybe (" <> jsonEncFor arg <> ")"+ _ -> error $ "Elm: odly shaped Maybe value"+ | otherwise ->+ error $ "Elm: Missing jsonEnc for built in type: " ++ show t++jsonDecFor :: Type -> T.Text+jsonDecFor t =+ case isBuiltIn t of+ Nothing ->+ case t of+ TyVar v -> varDec v+ TyCon qt args ->+ let ty = makeQualDec qt+ in case args of+ [] -> ty+ _ -> "(" <> ty <> " " <> T.intercalate " " (map jsonDecFor args) <> ")"+ Just (bi, tvars)+ | bi == tyString -> jsonDec "string"+ | bi == tyInt -> jsonDec "int"+ | bi == tyBool -> jsonDec "bool"+ | bi == tyFloat -> jsonDec "float"+ | bi == tyMaybe ->+ case tvars of+ [arg] -> jsonDec "maybe" <> " (" <> jsonDecFor arg <> ")"+ _ -> error $ "Elm: odly shaped Maybe value"+ | otherwise ->+ error $ "Elm: Missing jsonDec for built in type: " ++ show t++varEnc :: TypeVar -> T.Text+varEnc (TypeVar x) = "enc_" <> x++varDec :: TypeVar -> T.Text+varDec (TypeVar x) = "dec_" <> x++makeType :: Type -> T.Text+makeType t =+ case isBuiltIn t of+ Nothing ->+ case t of+ TyVar (TypeVar x) -> x+ TyCon qt args ->+ let ty = makeQualTypeName qt+ in case args of+ [] -> ty+ _ -> "(" <> ty <> " " <> T.intercalate " " (map makeType args) <> ")"+ Just (bi, tvars)+ | bi == tyString -> "String"+ | bi == tyInt -> "Int"+ | bi == tyBool -> "Bool"+ | bi == tyFloat -> "Float"+ | bi == tyMaybe -> "(Maybe " <> T.intercalate " " (map makeType tvars) <> ")"+ | otherwise ->+ error $ "Elm: Unimplemented built in type: " ++ show t++makeQualTypeName :: QualTypeName -> T.Text+makeQualTypeName qtn =+ case unModuleName $ qtn_module qtn of+ [] -> ty+ _ -> printModuleName (qtn_module qtn) <> "." <> ty+ where+ ty = unTypeName $ qtn_type qtn++makeQualEnc :: QualTypeName -> T.Text+makeQualEnc qtn =+ case unModuleName $ qtn_module qtn of+ [] -> "jenc" <> ty+ _ -> printModuleName (qtn_module qtn) <> ".jenc" <> ty+ where+ ty = unTypeName $ qtn_type qtn++makeQualDec :: QualTypeName -> T.Text+makeQualDec qtn =+ case unModuleName $ qtn_module qtn of+ [] -> "jdec" <> ty+ _ -> printModuleName (qtn_module qtn) <> ".jdec" <> ty+ where+ ty = unTypeName $ qtn_type qtn
+ src/TW/CodeGen/Haskell.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE OverloadedStrings #-}+module TW.CodeGen.Haskell+ ( makeFileName, makeModule )+where++import TW.Ast+import TW.BuiltIn+import TW.JsonRepr++import Data.Char+import Data.Maybe+import Data.Monoid+import System.FilePath+import qualified Data.List as L+import qualified Data.Text as T++aesonQual :: T.Text+aesonQual = "Data_Aeson_Lib"++aeson :: T.Text -> T.Text+aeson x = aesonQual <> "." <> x++aesonTQual :: T.Text+aesonTQual = "Data_Aeson_Types"++aesonT :: T.Text -> T.Text+aesonT x = aesonTQual <> "." <> x++makeFileName :: ModuleName -> FilePath+makeFileName (ModuleName parts) =+ (L.foldl' (</>) "" $ map T.unpack parts) ++ ".hs"++makeModule :: Module -> T.Text+makeModule m =+ T.unlines+ [ "{-# LANGUAGE OverloadedStrings #-}"+ , "-- | This file was auto generated by typed-wire. Do not modify by hand"+ , "module " <> printModuleName (m_name m) <> " where"+ , ""+ , T.intercalate "\n" (map makeImport $ m_imports m)+ , ""+ , "import Control.Applicative"+ , "import Control.Monad (join)"+ , "import qualified Data.Aeson as " <> aesonQual+ , "import qualified Data.Aeson.Types as " <> aesonTQual+ , "import qualified Data.Text as T"+ , ""+ , T.intercalate "\n" (map makeTypeDef $ m_typeDefs m)+ ]++makeImport :: ModuleName -> T.Text+makeImport m =+ "import qualified " <> printModuleName m++makeTypeDef :: TypeDef -> T.Text+makeTypeDef td =+ case td of+ TypeDefEnum ed ->+ makeEnumDef ed+ TypeDefStruct sd ->+ makeStructDef sd++makeFieldPrefix :: TypeName -> T.Text+makeFieldPrefix (TypeName name) =+ (T.toLower $ T.filter isUpper name) <> "_"++makeStructDef :: StructDef -> T.Text+makeStructDef sd =+ T.unlines+ [ "data " <> fullType+ , " = " <> unTypeName (sd_name sd)+ , " { " <> T.intercalate "\n , " (map (makeStructField (makeFieldPrefix $ sd_name sd)) $ sd_fields sd)+ , " } deriving (Show, Eq, Ord)"+ , ""+ , "instance " <> aesonPreds (sd_args sd) (aeson "ToJSON") <> aeson "ToJSON" <> " (" <> fullType <> ") where"+ , " toJSON (" <> unTypeName (sd_name sd) <> " " <> funArgs <> ") ="+ , " " <> aeson "object"+ , " [ " <> T.intercalate "\n , " (map makeToJsonFld $ sd_fields sd)+ , " ]"+ , "instance " <> aesonPreds (sd_args sd) (aeson "FromJSON") <> aeson "FromJSON" <> " (" <> fullType <> ") where"+ , " parseJSON ="+ , " " <> aeson "withObject" <> " " <> T.pack (show $ unTypeName (sd_name sd)) <> " $ \\obj ->"+ , " " <> unTypeName (sd_name sd)+ , " <$> " <> T.intercalate "\n <*> " (map makeFromJsonFld $ sd_fields sd)+ ]+ where+ jArg fld = "j_" <> (unFieldName $ sf_name fld)+ makeFromJsonFld fld =+ let name = unFieldName $ sf_name fld+ in case sf_type fld of+ (TyCon q _) | q == (bi_name tyMaybe) ->+ "(join <$> (obj " <> aeson ".:?" <> " " <> T.pack (show name) <> "))"+ _ -> "obj " <> aeson ".:" <> " " <> T.pack (show name)+ makeToJsonFld fld =+ let name = unFieldName $ sf_name fld+ argName = jArg fld+ in "(" <> T.pack (show name) <> " " <> aeson ".=" <> " " <> argName <> ")"+ funArgs =+ T.intercalate " " $ map jArg (sd_fields sd)+ fullType =+ unTypeName (sd_name sd) <> " " <> T.intercalate " " (map unTypeVar $ sd_args sd)++aesonPreds :: [TypeVar] -> T.Text -> T.Text+aesonPreds args tyClass =+ if null args+ then ""+ else let mkPred (TypeVar tv) =+ tyClass <> " " <> tv+ in "(" <> T.intercalate "," (map mkPred args) <> ") => "++makeEnumDef :: EnumDef -> T.Text+makeEnumDef ed =+ T.unlines+ [ "data " <> fullType+ , " = " <> T.intercalate "\n | " (map makeEnumChoice $ ed_choices ed)+ , " deriving (Show, Eq, Ord)"+ , ""+ , "instance " <> aesonPreds (ed_args ed) (aeson "ToJSON") <> aeson "ToJSON" <> " (" <> fullType <> ") where"+ , " toJSON x ="+ , " case x of"+ , " " <> T.intercalate "\n " (map mkToJsonChoice $ ed_choices ed)+ , "instance " <> aesonPreds (ed_args ed) (aeson "FromJSON") <> aeson "FromJSON" <> " (" <> fullType <> ") where"+ , " parseJSON = "+ , " " <> aeson "withObject" <> " " <> T.pack (show $ unTypeName (ed_name ed)) <> " $ \\obj ->"+ , " " <> T.intercalate "\n <|> " (map mkFromJsonChoice $ ed_choices ed)+ , " where"+ , " eatBool :: Bool -> " <> aesonT "Parser" <> " ()"+ , " eatBool _ = return ()"+ ]+ where+ mkFromJsonChoice ec =+ let constr = unChoiceName $ ec_name ec+ tag = camelTo2 '_' $ T.unpack constr+ (op, opEnd) =+ case ec_arg ec of+ Nothing -> ("<$ (eatBool <$> (", "))")+ Just _ -> ("<$>", "")+ in "(" <> constr <> " " <> op <> " obj " <> (aeson ".:") <> " " <> T.pack (show tag) <> opEnd <> ")"+ mkToJsonChoice ec =+ let constr = unChoiceName $ ec_name ec+ tag = camelTo2 '_' $ T.unpack constr+ (argParam, argVal) =+ case ec_arg ec of+ Nothing -> ("", "True")+ Just _ -> ("x", "x")+ in constr <> " " <> argParam <> " -> " <> aeson "object"+ <> " [" <> T.pack (show tag) <> " " <> aeson ".=" <> " " <> argVal <> "]"+ fullType =+ unTypeName (ed_name ed) <> " " <> T.intercalate " " (map unTypeVar $ ed_args ed)++makeEnumChoice :: EnumChoice -> T.Text+makeEnumChoice ec =+ (unChoiceName $ ec_name ec) <> fromMaybe "" (fmap ((<>) " !" . makeType) $ ec_arg ec)+++makeStructField :: T.Text -> StructField -> T.Text+makeStructField prefix sf =+ prefix <> (unFieldName $ sf_name sf) <> " :: !" <> (makeType $ sf_type sf)++makeType :: Type -> T.Text+makeType t =+ case isBuiltIn t of+ Nothing ->+ case t of+ TyVar (TypeVar x) -> x+ TyCon qt args ->+ let ty = makeQualTypeName qt+ in case args of+ [] -> ty+ _ -> "(" <> ty <> " " <> T.intercalate " " (map makeType args) <> ")"+ Just (bi, tvars)+ | bi == tyString -> "T.Text"+ | bi == tyInt -> "Int"+ | bi == tyBool -> "Bool"+ | bi == tyFloat -> "Double"+ | bi == tyMaybe -> "(Maybe " <> T.intercalate " " (map makeType tvars) <> ")"+ | otherwise ->+ error $ "Elm: Unimplemented built in type: " ++ show t++makeQualTypeName :: QualTypeName -> T.Text+makeQualTypeName qtn =+ case unModuleName $ qtn_module qtn of+ [] -> ty+ _ -> printModuleName (qtn_module qtn) <> "." <> ty+ where+ ty = unTypeName $ qtn_type qtn
+ src/TW/JsonRepr.hs view
@@ -0,0 +1,18 @@+module TW.JsonRepr where++import Data.Char++-- | Better version of 'camelTo'. Example where it works better:+--+-- (taken from Aeson library)+--+-- > camelTo '_' 'CamelAPICase' == "camel_apicase"+-- > camelTo2 '_' 'CamelAPICase' == "camel_api_case"+camelTo2 :: Char -> String -> String+camelTo2 c = map toLower . go2 . go1+ where go1 "" = ""+ go1 (x:u:l:xs) | isUpper u && isLower l = x : c : u : l : go1 xs+ go1 (x:xs) = x : go1 xs+ go2 "" = ""+ go2 (l:u:xs) | isLower l && isUpper u = l : c : u : go2 xs+ go2 (x:xs) = x : go2 xs
+ src/TW/Loader.hs view
@@ -0,0 +1,57 @@+module TW.Loader where++import TW.Ast+import TW.Parser++import Control.Monad.Except+import Data.Maybe+import System.Directory+import System.FilePath+import qualified Data.List as L+import qualified Data.Set as S+import qualified Data.Text as T++loadModules :: [FilePath] -> [ModuleName] -> IO (Either String [Module])+loadModules srcDirs entryPoints =+ runExceptT $ loadLoop srcDirs S.empty (S.fromList entryPoints) []++loadLoop :: [FilePath] -> S.Set ModuleName -> S.Set ModuleName -> [Module] -> ExceptT String IO [Module]+loadLoop srcDirs visited queue accum =+ case S.toList queue of+ [] -> return accum+ (x:xs) ->+ do (correctModuleName, filePath) <- getModuleFp srcDirs x+ loaded <- loadModuleFp filePath+ unless (correctModuleName (m_name loaded)) $+ throwError $ "Wrong module name found in " ++ filePath ++ ": "+ ++ T.unpack (printModuleName $ m_name loaded)+ let visited' = S.insert (m_name loaded) visited+ queue' = S.fromList (m_imports loaded) `S.union` S.fromList xs+ loadLoop srcDirs visited' (queue' `S.difference` visited') (loaded : accum)++getModuleFp :: [FilePath] -> ModuleName -> ExceptT String IO (ModuleName -> Bool, FilePath)+getModuleFp srcDirs m@(ModuleName comps) =+ do let fileName = (L.foldl' (</>) "" $ map T.unpack comps) ++ ".tywi"+ discovered <-+ catMaybes <$>+ (forM srcDirs $ \srcDir ->+ do let fn = srcDir </> fileName+ isThere <- liftIO $ doesFileExist fn+ return $ if isThere then Just fn else Nothing)+ let errPrefix =+ "Can not resolve module " ++ T.unpack (printModuleName m) ++ ": "+ case discovered of+ [] ->+ throwError $ errPrefix ++ fileName ++ " not available in " ++ L.intercalate ", " srcDirs+ [x] ->+ return ((==) m, x)+ _ ->+ throwError $ errPrefix ++ "multiple possibilities found: " ++ L.intercalate ", " discovered+++loadModuleFp :: FilePath -> ExceptT String IO Module+loadModuleFp fp =+ do m <- liftIO $ moduleFromFile fp+ case m of+ Left err -> throwError err+ Right ok -> return ok
+ src/TW/Parser.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE OverloadedStrings #-}+module TW.Parser+ ( moduleFromText+ , moduleFromFile+ , makeModuleName+ )+where++import TW.Ast++import Control.Monad.Identity+import Data.Char+import Text.Parsec+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Text.Parsec.Token as P++type Parser = Parsec T.Text ()++makeModuleName :: T.Text -> Either String ModuleName+makeModuleName inp =+ case runParser (parseModuleName <* eof) () "<input>" inp of+ Left err -> Left (show err)+ Right m -> Right m++moduleFromText :: FilePath -> T.Text -> Either String Module+moduleFromText file t =+ case runParser (parseModule <* eof) () file t of+ Left err -> Left (show err)+ Right m -> Right m+++moduleFromFile :: FilePath -> IO (Either String Module)+moduleFromFile file =+ do input <- T.readFile file+ return $ moduleFromText file input++parseModule :: Parser Module+parseModule =+ do reserved "module"+ moduleName <- parseModuleName+ _ <- semi+ imports <- many parseImport+ tyDefs <- many parseTypeDef+ return $ Module moduleName imports tyDefs++parseModuleName :: Parser ModuleName+parseModuleName =+ lexeme $+ ModuleName <$> dotSep1 parseCapitalized++parseImport :: Parser ModuleName+parseImport =+ do reserved "import"+ m <- parseModuleName+ _ <- semi+ return m++parseTypeDef :: Parser TypeDef+parseTypeDef =+ TypeDefEnum <$> parseEnumDef <|>+ TypeDefStruct <$> parseStructDef++parseDef :: (TypeName -> [TypeVar] -> [fld] -> def) -> String -> Parser fld -> Parser def+parseDef constr resName parseFields =+ do reserved resName+ name <- parseTypeName+ args <- parseTypeArgs+ fields <- braces $ many parseFields+ return $ constr name args fields++parseEnumDef :: Parser EnumDef+parseEnumDef = parseDef EnumDef "enum" parseEnumChoice++parseStructDef :: Parser StructDef+parseStructDef = parseDef StructDef "type" parseStructField++parseEnumChoice :: Parser EnumChoice+parseEnumChoice =+ do name <- parseChoiceName+ arg <- option Nothing (Just <$> parens parseType)+ _ <- semi+ return $ EnumChoice name arg++parseStructField :: Parser StructField+parseStructField =+ do name <- (FieldName . T.pack <$> identifier)+ reservedOp ":"+ ty <- parseType+ _ <- semi+ return $ StructField name ty++parseType :: Parser Type+parseType =+ TyVar <$> parseTypeVar <|>+ TyCon <$> parseQualTypeName <*> parseTyArgs+ where+ parseTyArgs =+ option [] $ angles $ commaSep1 parseType++parseTypeArgs :: Parser [TypeVar]+parseTypeArgs =+ option [] $+ angles $+ commaSep1 parseTypeVar++parseTypeVar :: Parser TypeVar+parseTypeVar = TypeVar . T.pack <$> identifier++parseTypeName :: Parser TypeName+parseTypeName = lexeme (TypeName <$> parseCapitalized)++parseQualTypeName :: Parser QualTypeName+parseQualTypeName =+ do md <- unModuleName <$> parseModuleName+ case reverse md of+ [] -> fail "This should never happen"+ (x:xs) ->+ return $ QualTypeName (ModuleName $ reverse xs) (TypeName x)++parseChoiceName :: Parser ChoiceName+parseChoiceName = lexeme (ChoiceName <$> parseCapitalized)++parseCapitalized :: Parser T.Text+parseCapitalized =+ do first <- satisfy isUpper+ rest <- many (alphaNum <|> char '_')+ return $ T.pack (first : rest)++languageDef :: P.GenLanguageDef T.Text st Identity+languageDef =+ P.LanguageDef+ { P.commentStart = "/*"+ , P.commentEnd = "*/"+ , P.commentLine = "//"+ , P.nestedComments = True+ , P.identStart = satisfy isLower+ , P.identLetter = alphaNum <|> oneOf "_"+ , P.opStart = oneOf ":!#$%&*+./<=>?@\\^|-~"+ , P.opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"+ , P.reservedNames = ["module", "type", "enum", "import", "as"]+ , P.reservedOpNames = [":", "->"]+ , P.caseSensitive = False+ }++lexer :: P.GenTokenParser T.Text () Identity+lexer = P.makeTokenParser languageDef++parens :: Parser a -> Parser a+parens = P.parens lexer++braces :: Parser a -> Parser a+braces = P.braces lexer++angles :: Parser a -> Parser a+angles = P.angles lexer++lexeme :: Parser a -> Parser a+lexeme = P.lexeme lexer++identifier :: Parser String+identifier = P.identifier lexer++reserved :: String -> Parser ()+reserved = P.reserved lexer++reservedOp :: String -> Parser ()+reservedOp = P.reservedOp lexer++semi :: Parser String+semi = P.semi lexer++dot :: Parser String+dot = P.dot lexer++dotSep1 :: Parser a -> Parser [a]+dotSep1 p = sepBy p dot++commaSep1 :: Parser a -> Parser [a]+commaSep1 = P.commaSep1 lexer
+ typed-wire.cabal view
@@ -0,0 +1,55 @@+name: typed-wire+version: 0.1.0.0+synopsis: WIP: Language idependent type-safe communication+description: Please see README.md+homepage: http://github.com/agrafix/typed-wire#readme+license: MIT+license-file: LICENSE+author: Alexander Thiemann <mail@athiemann.net>+maintainer: Alexander Thiemann <mail@athiemann.net>+copyright: (c) 2015 Alexander Thiemann <mail@athiemann.net>+category: Web+build-type: Simple+extra-source-files:+ README.md+cabal-version: >=1.10+tested-with: GHC==7.10.2++library+ hs-source-dirs: src+ exposed-modules:+ TW.Parser,+ TW.Ast,+ TW.Loader,+ TW.Check,+ TW.BuiltIn,+ TW.JsonRepr,+ TW.CodeGen.Elm,+ TW.CodeGen.Haskell+ build-depends:+ base >= 4.7 && < 5,+ text >= 1.2,+ parsec >=3.1,+ mtl >=2.2,+ containers >=0.5,+ directory >=1.2,+ filepath >=1.4+ default-language: Haskell2010++executable twirec+ hs-source-dirs: app+ main-is: Main.hs+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >= 4.7 && < 5,+ typed-wire,+ text >= 1.2,+ optparse-applicative,+ filepath >=1.4,+ gitrev >=1.1,+ directory >=1.2+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/agrafix/typed-wire