typed-wire 0.2.1.3 → 0.3.0.0
raw patch · 16 files changed
+867/−56 lines, 16 filesdep +HTFdep +aesondep +bytestringdep −file-embeddep ~basedep ~directory
Dependencies added: HTF, aeson, bytestring, http-types, process, temporary
Dependencies removed: file-embed
Dependency ranges changed: base, directory
Files
- LICENSE +1/−1
- README.md +9/−6
- app/Main.hs +20/−9
- src/TW/Ast.hs +43/−0
- src/TW/BuiltIn.hs +10/−1
- src/TW/Check.hs +16/−7
- src/TW/CodeGen/Elm.hs +6/−10
- src/TW/CodeGen/Haskell.hs +111/−10
- src/TW/CodeGen/PureScript.hs +296/−0
- src/TW/Parser.hs +69/−5
- src/TW/Types.hs +9/−0
- src/TW/Utils.hs +22/−0
- test/TW/CodeGen/HaskellTest.hs +113/−0
- test/TW/CodeGen/PureScriptTest.hs +102/−0
- test/Test.hs +10/−0
- typed-wire.cabal +30/−7
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2015 Alexander Thiemann <mail@athiemann.net>+Copyright (c) 2015 - 2016 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
README.md view
@@ -1,14 +1,15 @@ typed-wire ===== -[](https://travis-ci.org/agrafix/typed-wire)+[](https://travis-ci.org/typed-wire/typed-wire) [](http://hackage.haskell.org/package/typed-wire) ## Intro Hackage: [typed-wire](http://hackage.haskell.org/package/typed-wire)+Stackage: [typed-wire](https://www.stackage.org/package/typed-wire) -WIP: Language idependent type-safe communication+Language idependent type-safe communication ## Cli Usage: twirec @@ -17,7 +18,7 @@ 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]+ [--hs-out DIR] [--elm-out DIR] [--purescript-out DIR] Language idependent type-safe communication Available options:@@ -28,14 +29,16 @@ Entrypoint for compiler --hs-out DIR Generate Haskell bindings to specified dir --elm-out DIR Generate Elm bindings to specified dir+ --purescript-out DIR Generate PureScript bindings to specified dir ``` ## Install * Using cabal: `cabal install typed-wire`-* 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`+* Using Stack: `stack install typed-wire`+* From Source (cabal): `git clone https://github.com/typed-wire/typed-wire.git && cd typed-wire && cabal install`+* From Source (stack): `git clone https://github.com/typed-wire/typed-wire.git && cd typed-wire && stack build` ## Misc@@ -47,4 +50,4 @@ ### License Released under the MIT license.-(c) 2015 Alexander Thiemann <mail@athiemann.net>+(c) 2015 - 2016 Alexander Thiemann <mail@athiemann.net>
app/Main.hs view
@@ -6,8 +6,10 @@ import TW.Check import TW.Loader import TW.Parser+import TW.Types import qualified TW.CodeGen.Elm as Elm import qualified TW.CodeGen.Haskell as HS+import qualified TW.CodeGen.PureScript as PS import qualified Paths_typed_wire as Meta @@ -27,6 +29,7 @@ , o_entryPoints :: [ModuleName] , o_hsOutDir :: Maybe FilePath , o_elmOutDir :: Maybe FilePath+ , o_psOutDir :: Maybe FilePath } optParser :: Parser Options@@ -37,6 +40,7 @@ <*> entryPointsP <*> hsOutP <*> elmOutP+ <*> psOutP sourceDirsP :: Parser [FilePath] sourceDirsP =@@ -63,6 +67,11 @@ optional $ strOption $ long "elm-out" <> metavar "DIR" <> help "Generate Elm bindings to specified dir" +psOutP :: Parser (Maybe FilePath)+psOutP =+ optional $ strOption $+ long "purescript-out" <> metavar "DIR" <> help "Generate PureScript bindings to specified dir"+ main :: IO () main = execParser opts >>= run@@ -103,19 +112,21 @@ Left err -> fail err Right readyModules -> do _ <- T.forM (o_hsOutDir opts) $ \dir ->- do storeLib dir HS.makeLibraryModule+ do T.putStrLn $+ "Required Haskell library is "+ <> li_name HS.libraryInfo <> "@" <> li_version HS.libraryInfo mapM_ (runner dir HS.makeModule HS.makeFileName) readyModules _ <- T.forM (o_elmOutDir opts) $ \dir ->- do storeLib dir Elm.makeLibraryModule+ do T.putStrLn $+ "Required Elm library is "+ <> li_name Elm.libraryInfo <> " version " <> li_version Elm.libraryInfo mapM_ (runner dir Elm.makeModule Elm.makeFileName) readyModules+ _ <- T.forM (o_psOutDir opts) $ \dir ->+ do T.putStrLn $+ "Required PureScript library is "+ <> li_name PS.libraryInfo <> " version " <> li_version PS.libraryInfo+ mapM_ (runner dir PS.makeModule PS.makeFileName) readyModules return ()--storeLib :: FilePath -> (FilePath, T.Text) -> IO ()-storeLib baseDir (baseLoc, content) =- do let loc = baseDir </> baseLoc- createDirectoryIfMissing True (takeDirectory loc)- putStrLn $ "Writing library " <> loc <> " ..."- T.writeFile loc content runner :: FilePath -> (Module -> T.Text) -> (ModuleName -> FilePath) -> Module -> IO () runner baseDir mkModule mkFilename m =
src/TW/Ast.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} module TW.Ast where +import Network.HTTP.Types.Method import qualified Data.Text as T newtype ModuleName@@ -30,6 +31,14 @@ = ChoiceName { unChoiceName :: T.Text } deriving (Show, Eq, Ord) +newtype ApiName+ = ApiName { unApiName :: T.Text }+ deriving (Show, Eq, Ord)++newtype EndpointName+ = EndpointName { unEndpointName :: T.Text }+ deriving (Show, Eq, Ord)+ data QualTypeName = QualTypeName { qtn_module :: ModuleName@@ -41,7 +50,41 @@ { m_name :: ModuleName , m_imports :: [ModuleName] , m_typeDefs :: [TypeDef]+ , m_apis :: [ApiDef] } deriving (Show, Eq)++data ApiDef+ = ApiDef+ { ad_name :: ApiName+ , ad_headers :: [ApiHeader]+ , ad_endpoints :: [ApiEndpointDef]+ } deriving (Show, Eq)++data ApiEndpointDef+ = ApiEndpointDef+ { aed_name :: EndpointName+ , aed_verb :: StdMethod+ , aed_route :: [ApiRouteComp]+ , aed_headers :: [ApiHeader]+ , aed_req :: Maybe Type+ , aed_resp :: Type+ } deriving (Show, Eq)++data ApiRouteComp+ = ApiRouteStatic T.Text+ | ApiRouteDynamic Type+ deriving (Show, Eq)++data ApiHeader+ = ApiHeader+ { ah_name :: T.Text+ , ah_value :: ApiHeaderValue+ } deriving (Show, Eq)++data ApiHeaderValue+ = ApiHeaderValueStatic T.Text+ | ApiHeaderValueDynamic+ deriving (Show, Eq) data TypeDef = TypeDefEnum EnumDef
src/TW/BuiltIn.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module TW.BuiltIn ( BuiltIn(..)- , allBuiltIns, isBuiltIn+ , allBuiltIns, isBuiltIn, builtInAsType, pathPieceTypes, isPathPiece , tyString, tyInt, tyFloat, tyBool, tyMaybe, tyBytes, tyList, tyDateTime, tyDate, tyTime ) where@@ -17,8 +17,17 @@ , bi_args :: [TypeVar] } deriving (Show, Eq) +builtInAsType :: BuiltIn -> Type+builtInAsType (BuiltIn qt args) = TyCon qt (map TyVar args)+ allBuiltIns :: [BuiltIn] allBuiltIns = [tyString, tyInt, tyFloat, tyBool, tyMaybe, tyBytes, tyList, tyDateTime, tyDate, tyTime]++pathPieceTypes :: [BuiltIn]+pathPieceTypes = [tyString, tyInt, tyFloat, tyBool]++isPathPiece :: Type -> Bool+isPathPiece t = t `elem` map builtInAsType pathPieceTypes isBuiltIn :: Type -> Maybe (BuiltIn, [Type]) isBuiltIn ty =
src/TW/Check.hs view
@@ -43,9 +43,8 @@ let isValidType args t = case t of TyVar tv ->- if tv `elem` args- then return ()- else throwError $ "Undefined type variable " ++ show tv ++ " in " ++ currentMStr+ unless (tv `elem` args) $+ throwError $ "Undefined type variable " ++ show tv ++ " in " ++ currentMStr TyCon qt qtArgs -> case M.lookup qt defTypes of Nothing ->@@ -55,16 +54,26 @@ when (length tvars /= length qtArgs) $ throwError $ "Type " ++ show qt ++ " got applied wrong number of arguments in " ++ currentMStr+ checkRoute r =+ case r of+ ApiRouteDynamic t ->+ unless (isPathPiece t) $+ throwError $+ "Invalid route parameter " ++ show t ++ ". Route parameters can only be primitive types!"+ _ -> return () 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+ forM_ (ec_arg ch) (isValidType (ed_args ed)) TypeDefStruct sd -> forM_ (sd_fields sd) $ \fld ->- do isValidType (sd_args sd) (sf_type fld)+ isValidType (sd_args sd) (sf_type fld)+ forM_ (m_apis m) $ \api ->+ forM_ (ad_endpoints api) $ \ep ->+ do mapM_ (isValidType []) (aed_req ep)+ isValidType [] (aed_resp ep)+ mapM_ checkRoute (aed_route ep) return m where getDefinedTypes m =
src/TW/CodeGen/Elm.hs view
@@ -1,16 +1,15 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-} module TW.CodeGen.Elm ( makeFileName, makeModule- , makeLibraryModule+ , libraryInfo ) where import TW.Ast import TW.BuiltIn import TW.JsonRepr+import TW.Types -import Data.FileEmbed import Data.Maybe import Data.Monoid import System.FilePath@@ -29,16 +28,13 @@ jsonDec :: T.Text -> T.Text jsonDec x = jsonDecQual <> "." <> x -makeLibraryModule :: (FilePath, T.Text)-makeLibraryModule =- ( "TW/Support/Lib.elm"- , $(embedStringFile "support/elm/Lib.elm")- )- makeFileName :: ModuleName -> FilePath makeFileName (ModuleName parts) = (L.foldl' (</>) "" $ map T.unpack parts) ++ ".elm" +libraryInfo :: LibraryInfo+libraryInfo = LibraryInfo "elm-typed-wire-utils" "1.0.0"+ makeModule :: Module -> T.Text makeModule m = T.unlines@@ -47,7 +43,7 @@ , "" , T.intercalate "\n" (map makeImport $ m_imports m) , ""- , "import TW.Support.Lib as ELib"+ , "import TypedWire as ELib" , "import List as L" , "import Json.Decode as " <> jsonDecQual , "import Json.Decode exposing ((:=))"
src/TW/CodeGen/Haskell.hs view
@@ -1,35 +1,33 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-} module TW.CodeGen.Haskell ( makeFileName, makeModule- , makeLibraryModule+ , libraryInfo ) where import TW.Ast import TW.BuiltIn import TW.JsonRepr+import TW.Types+import TW.Utils import Data.Char-import Data.FileEmbed import Data.Maybe import Data.Monoid import System.FilePath import qualified Data.List as L import qualified Data.Text as T +libraryInfo :: LibraryInfo+libraryInfo = LibraryInfo "typed-wire-utils" "0.1.0.0"+ aesonQual :: T.Text aesonQual = "Data_Aeson_Lib" aeson :: T.Text -> T.Text aeson x = aesonQual <> "." <> x -makeLibraryModule :: (FilePath, T.Text)-makeLibraryModule =- ( "TW/Support/Lib.hs"- , $(embedStringFile "support/haskell/Lib.hs")- )- makeFileName :: ModuleName -> FilePath makeFileName (ModuleName parts) = (L.foldl' (</>) "" $ map T.unpack parts) ++ ".hs"@@ -44,20 +42,123 @@ , "" , T.intercalate "\n" (map makeImport $ m_imports m) , ""- , "import qualified TW.Support.Lib as HLib"+ , "import qualified Text.TypedWire as HLib" , "import Control.Applicative" , "import Control.Monad (join)" , "import Data.Time" , "import qualified Data.Aeson as " <> aesonQual , "import qualified Data.Text as T" , "import qualified Data.Vector as V"+ , if not (null (m_apis m)) then "import Web.Spock\nimport Control.Monad.Trans" else "" , "" , T.intercalate "\n" (map makeTypeDef $ m_typeDefs m)+ , T.intercalate "\n" (map makeApiDef $ m_apis m) ] makeImport :: ModuleName -> T.Text makeImport m = "import qualified " <> printModuleName m++makeApiDef :: ApiDef -> T.Text+makeApiDef ad =+ T.unlines+ [ "data " <> handlerType <> " m"+ , " = " <> handlerType+ , " { " <> T.intercalate "\n , " (map makeEndPoint $ ad_endpoints ad)+ , " }"+ , fromMaybe "" $ makeHeaderDef apiHeaderType ahprefix (ad_headers ad)+ , T.intercalate "\n" (mapMaybe (\ep -> makeHeaderDef (headerType ep) (hprefix ep) (aed_headers ep)) $ ad_endpoints ad)+ , "wire" <> apiCapitalized <> " :: MonadIO m => " <> handlerType <> " (ActionCtxT ctx m) -> SpockCtxT ctx m ()"+ , "wire" <> apiCapitalized <> " handler ="+ , " do " <> T.intercalate "\n " (map makeEndPointImpl $ ad_endpoints ad)+ ]+ where+ apiCapitalized = capitalizeText (unApiName $ ad_name ad)+ handlerType = "ApiHandler" <> apiCapitalized+ apiHeaderType = handlerType <> "Headers"+ headerType ep = handlerType <> capitalizeText (unEndpointName (aed_name ep)) <> "Headers"+ hprefix ep = makeFieldPrefix $ TypeName (headerType ep)+ ahprefix = makeFieldPrefix $ TypeName apiHeaderType+ prefix = makeFieldPrefix $ TypeName handlerType+ makeHeaderDef tyName tyPrefix headerList =+ case headerList of+ [] -> Nothing+ _ ->+ Just $ T.unlines+ [ "data " <> tyName+ , " = " <> tyName+ , " { " <> T.intercalate "\n , " (mapMaybe makeHeaderField headerList)+ , " }"+ ]+ where+ makeHeaderField h =+ case ah_value h of+ ApiHeaderValueStatic _ -> Nothing+ ApiHeaderValueDynamic ->+ Just $+ tyPrefix <> makeSafePrefixedFieldName (ah_name h) <> " :: !T.Text"+ makeEndPoint ep =+ prefix <> unEndpointName (aed_name ep) <> " :: "+ <> (if not (null $ ad_headers ad) then apiHeaderType <> " -> " else "")+ <> (if not (null $ aed_headers ep) then headerType ep <> " -> " else "")+ <> T.intercalate " -> " (map makeType pathTypes)+ <> (if not (null pathTypes) then " -> " else "")+ <> maybe "" (\x -> makeType x <> " -> ") (aed_req ep)+ <> "m " <> makeType (aed_resp ep) <> ""+ where+ pathTypes =+ flip mapMaybe (aed_route ep) $ \x ->+ case x of+ ApiRouteDynamic dyn -> Just dyn+ _ -> Nothing+ makeHeaderLoader tyName headerList =+ "do {"+ <> T.intercalate "" (map makeGetter headerList)+ <> T.intercalate "" (mapMaybe makeChecker headerList)+ <> "return (" <> tyName <> " " <> T.intercalate " " (mapMaybe makeSetter headerList) <> ");"+ <> "}"+ where+ varName h = "hp" <> makeSafePrefixedFieldName (ah_name h)+ makeGetter h =+ varName h <> " <- header " <> T.pack (show (ah_name h)) <> " >>= maybe jumpNext return;"+ makeChecker h =+ case ah_value h of+ ApiHeaderValueStatic val ->+ Just $ "when (" <> varName h <> " /= " <> T.pack (show val) <> ") jumpNext; "+ _ -> Nothing+ makeSetter h =+ case ah_value h of+ ApiHeaderValueDynamic -> Just (varName h)+ _ -> Nothing+ makeEndPointImpl ep =+ "hookRoute " <> (T.pack $ show $ aed_verb ep) <> " ("+ <> T.intercalate " <//> " (map makePathComp $ aed_route ep) <> ") $ "+ <> (if not (null pathVars) then "\\" <> T.intercalate " " pathVars <> " -> " else "")+ <> "do {"+ <> (if not (null (ad_headers ad)) then "apiHeaders <- " <> makeHeaderLoader apiHeaderType (ad_headers ad) <> "; " else "")+ <> (if not (null (aed_headers ep)) then "localHeaders <- " <> makeHeaderLoader (headerType ep) (aed_headers ep) <> "; " else "")+ <> maybe "" (const "reqVal <- jsonBody';") (aed_req ep)+ <> "out <- " <> prefix <> unEndpointName (aed_name ep) <> " handler "+ <> (if not (null (ad_headers ad)) then "apiHeaders " else "")+ <> (if not (null (aed_headers ep)) then "localHeaders " else "")+ <> T.intercalate " " pathVars+ <> " "+ <> maybe "" (const "reqVal ") (aed_req ep)+ <> ";"+ <> "json out;"+ <> "}"+ where+ pathVars =+ map ((\(i :: Int) -> T.pack $ "pv" ++ show i) . snd) $+ flip zip [0..] $+ flip mapMaybe (aed_route ep) $ \x ->+ case x of+ ApiRouteDynamic _ -> Just ()+ _ -> Nothing+ makePathComp pc =+ case pc of+ ApiRouteStatic str -> T.pack (show str)+ ApiRouteDynamic _ -> "var" makeTypeDef :: TypeDef -> T.Text makeTypeDef td =
+ src/TW/CodeGen/PureScript.hs view
@@ -0,0 +1,296 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+module TW.CodeGen.PureScript+ ( makeFileName, makeModule+ , libraryInfo+ )+where++import TW.Ast+import TW.BuiltIn+import TW.JsonRepr+import TW.Types+import TW.Utils++import Data.Maybe+import Data.Monoid+import System.FilePath+import qualified Data.List as L+import qualified Data.Text as T++libraryInfo :: LibraryInfo+libraryInfo = LibraryInfo "purescript-typed-wire" "0.2.0"++makeFileName :: ModuleName -> FilePath+makeFileName (ModuleName parts) =+ (L.foldl' (</>) "" $ map T.unpack parts) ++ ".purs"++makeModule :: Module -> T.Text+makeModule m =+ T.unlines+ [ "module " <> printModuleName (m_name m) <> " where"+ , ""+ , T.intercalate "\n" (map makeImport $ m_imports m)+ , ""+ , "import Data.TypedWire.Prelude"+ , if not (null (m_apis m)) then "import Data.TypedWire.Api" else ""+ , ""+ , T.intercalate "\n" (map makeTypeDef $ m_typeDefs m)+ , T.intercalate "\n" (map makeApiDef $ m_apis m)+ ]++makeApiDef :: ApiDef -> T.Text+makeApiDef ad =+ T.unlines $+ catMaybes+ [ apiHeader+ , Just $ T.intercalate "\n" (map makeEndPoint (ad_endpoints ad))+ ]+ where+ apiHeader =+ case not (null (ad_headers ad)) of+ True -> Just $ makeHeaderType apiHeaderType (ad_headers ad)+ False -> Nothing+ apiCapitalized = capitalizeText (unApiName $ ad_name ad)+ handlerType = "ApiHandler" <> apiCapitalized+ apiHeaderType = handlerType <> "Headers"+ headerType ep = handlerType <> capitalizeText (unEndpointName (aed_name ep)) <> "Headers"+ makeHeaderName hdr = uncapitalizeText $ makeSafePrefixedFieldName (ah_name hdr)+ makeHeaderType ty headers =+ T.unlines+ [ "type " <> ty <> " = "+ , " { " <> T.intercalate "\n , " (map makeHeaderField headers)+ , " }"+ ]+ makeHeaderField hdr =+ makeHeaderName hdr <> " :: String"+ makeEndPoint ep =+ T.unlines $+ catMaybes+ [ epHeader+ , Just $ funName <> " :: forall m. (Monad m) => "+ <> (maybe "" (const $ apiHeaderType <> " -> ") apiHeader)+ <> (maybe "" (const $ headerType ep <> " -> ") epHeader)+ <> urlParamSig+ <> (maybe "" (\t -> makeType t <> " -> ") $ aed_req ep)+ <> "ApiCall m " <> (maybe "Unit" makeType $ aed_req ep) <> " " <> makeType (aed_resp ep)+ , Just $ funName+ <> " "+ <> (maybe "" (const "apiHeaders ") apiHeader)+ <> (maybe "" (const "endpointHeaders ") epHeader)+ <> urlParams+ <> (maybe "" (const "reqBody ") $ aed_req ep)+ <> "runRequest = do"+ , Just $ " let coreHeaders = [" <> T.intercalate ", " (map (headerPacker "apiHeaders") $ ad_headers ad) <> "]"+ , Just $ " let fullHeaders = coreHeaders ++ [" <> T.intercalate ", " (map (headerPacker "endpointHeaders") $ aed_headers ep) <> "]"+ , Just $ " let url = " <> T.intercalate " ++ \"/\" ++ " (map urlPacker routeInfo)+ , Just $ " let method = " <> T.pack (show $ aed_verb ep)+ , Just $ " let body = " <> (maybe "Nothing" (const "Just $ encodeJson reqBody") $ aed_req ep)+ , Just $ " let req = { headers: fullHeaders, method: method, body: body, url: url }"+ , Just $ " resp <- runRequest req"+ , Just $ " return $ if (resp.statusCode /= 200) then Left \"Return code was not 200\" else decodeJson resp.body"+ ]+ where+ urlPacker (r, p) =+ case r of+ ApiRouteStatic t -> T.pack (show t)+ ApiRouteDynamic _ -> "toPathPiece p" <> T.pack (show p) <> ""+ headerPacker apiVar hdr =+ "{ key: " <> T.pack (show $ ah_name hdr) <> ", value: " <> apiVar <> "." <> makeHeaderName hdr <> " }"+ funName = unApiName (ad_name ad) <> capitalizeText (unEndpointName $ aed_name ep)+ routeInfo = zip (aed_route ep) ([0..] :: [Int])+ urlParams =+ T.concat $ flip mapMaybe routeInfo $ \(r,p) ->+ case r of+ ApiRouteStatic _ -> Nothing+ ApiRouteDynamic _ -> Just $ "p" <> T.pack (show p) <> " "+ urlParamSig =+ T.concat $ flip mapMaybe (aed_route ep) $ \r ->+ case r of+ ApiRouteStatic _ -> Nothing+ ApiRouteDynamic ty -> Just (makeType ty <> " -> ")+ epHeader =+ case not (null (aed_headers ep)) of+ True -> Just $ makeHeaderType (headerType ep) (aed_headers ep)+ False -> Nothing++makeImport :: ModuleName -> T.Text+makeImport m =+ "import qualified " <> printModuleName m <> " as " <> printModuleName m++makeTypeDef :: TypeDef -> T.Text+makeTypeDef td =+ case td of+ TypeDefEnum ed ->+ makeEnumDef ed+ TypeDefStruct sd ->+ makeStructDef sd++decoderName :: TypeName -> T.Text+decoderName ty = "dec" <> unTypeName ty++encoderName :: TypeName -> T.Text+encoderName ty = "enc" <> unTypeName ty++eqName :: TypeName -> T.Text+eqName ty = "eq" <> unTypeName ty++showName :: TypeName -> T.Text+showName ty = "show" <> unTypeName ty++makeStructDef :: StructDef -> T.Text+makeStructDef sd =+ T.unlines+ [ "data " <> fullType+ , " = " <> unTypeName (sd_name sd)+ , " { " <> T.intercalate "\n , " (map makeStructField $ sd_fields sd)+ , " }"+ , ""+ , "instance " <> eqName (sd_name sd) <> " :: "+ <> tcPreds (sd_args sd) ["Eq"] <> "Eq (" <> fullType <> ") where "+ <> "eq (" <> justType <> " a) (" <> justType <> " b) = "+ <> T.intercalate " && " (map makeFieldEq (sd_fields sd))+ , "instance " <> showName (sd_name sd) <> " :: "+ <> tcPreds (sd_args sd) ["Show"] <> "Show (" <> fullType <> ") where "+ <> "show (" <> justType <> " a) = " <> T.pack (show justType) <> " ++ \"{\" ++ "+ <> T.intercalate " ++ " (map makeFieldShow (sd_fields sd))+ <> " ++ \"}\""+ , "instance " <> encoderName (sd_name sd) <> " :: "+ <> tcPreds (sd_args sd) ["EncodeJson"] <> "EncodeJson" <> " (" <> fullType <> ") where"+ , " encodeJson (" <> unTypeName (sd_name sd) <> " objT) ="+ , " " <> T.intercalate "\n ~> " (map makeToJsonFld $ sd_fields sd)+ , " ~> jsonEmptyObject"+ , "instance " <> decoderName (sd_name sd) <> " :: "+ <> tcPreds (sd_args sd) ["DecodeJson"] <> "DecodeJson" <> " (" <> fullType <> ") where"+ , " decodeJson jsonT = do"+ , " objT <- decodeJson jsonT"+ , " " <> T.intercalate "\n " (map makeFromJsonFld $ sd_fields sd)+ , " pure $ " <> unTypeName (sd_name sd) <> " { " <> T.intercalate ", " (map makeFieldSetter $ sd_fields sd) <> " }"+ ]+ where+ makeFieldShow fld =+ let name = unFieldName $ sf_name fld+ in T.pack (show name) <> " ++ \": \" ++ show a." <> name+ makeFieldEq fld =+ let name = unFieldName $ sf_name fld+ in "a." <> name <> " == " <> "b." <> name+ makeFieldSetter fld =+ let name = unFieldName $ sf_name fld+ in name <> " : " <> "v" <> name+ makeFromJsonFld fld =+ let name = unFieldName $ sf_name fld+ in case sf_type fld of+ (TyCon q _) | q == bi_name tyMaybe ->+ "v" <> name <> " <- objT .?? " <> T.pack (show name)+ _ ->+ "v" <> name <> " <- objT .? " <> T.pack (show name)+ makeToJsonFld fld =+ let name = unFieldName $ sf_name fld+ in T.pack (show name) <> " " <> ":=" <> " objT." <> name+ justType = unTypeName (sd_name 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)++tcPreds :: [TypeVar] -> [T.Text] -> T.Text+tcPreds args tyClasses =+ if null args+ then ""+ else let mkPred (TypeVar tv) =+ T.intercalate "," $ flip map tyClasses $ \tyClass -> 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)+ , ""+ , "instance " <> eqName (ed_name ed) <> " :: "+ <> tcPreds (ed_args ed) ["Eq"] <> "Eq (" <> fullType <> ") where "+ , " " <> T.intercalate "\n " (map makeChoiceEq $ ed_choices ed)+ , " eq _ _ = false"+ , "instance " <> showName (ed_name ed) <> " :: "+ <> tcPreds (ed_args ed) ["Show"] <> "Show (" <> fullType <> ") where "+ , " " <> T.intercalate "\n " (map makeChoiceShow $ ed_choices ed)+ , "instance " <> encoderName (ed_name ed) <> " :: "+ <> tcPreds (ed_args ed) ["EncodeJson"] <> "EncodeJson" <> " (" <> fullType <> ") where"+ , " encodeJson x ="+ , " case x of"+ , " " <> T.intercalate "\n " (map mkToJsonChoice $ ed_choices ed)+ , "instance " <> decoderName (ed_name ed) <> " :: "+ <> tcPreds (ed_args ed) ["DecodeJson"] <> "DecodeJson" <> " (" <> fullType <> ") where"+ , " decodeJson jsonT ="+ , " decodeJson jsonT >>= \\objT -> "+ , " " <> T.intercalate "\n <|> " (map mkFromJsonChoice $ ed_choices ed)+ ]+ where+ makeChoiceShow ec =+ let constr = unChoiceName $ ec_name ec+ in case ec_arg ec of+ Nothing -> "show (" <> constr <> ") = " <> T.pack (show constr)+ Just _ -> "show (" <> constr <> " a) = " <> T.pack (show constr) <> " ++ show a"+ makeChoiceEq ec =+ let constr = unChoiceName $ ec_name ec+ in case ec_arg ec of+ Nothing -> "eq (" <> constr <> ") (" <> constr <> ") = true"+ Just _ -> "eq (" <> constr <> " a) (" <> constr <> " b) = a == b"+ 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 <> " objT " <> ".?" <> " " <> 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 _ -> ("y", "y")+ in constr <> " " <> argParam <> " -> "+ <> " " <> T.pack (show tag) <> " " <> " := " <> " " <> argVal <> " ~> jsonEmptyObject"+ 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)++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 -> "Boolean"+ | bi == tyFloat -> "Number"+ | bi == tyMaybe -> "(Maybe " <> T.intercalate " " (map makeType tvars) <> ")"+ | bi == tyBytes -> "AsBase64"+ | bi == tyList -> "(Array " <> T.intercalate " " (map makeType tvars) <> ")"+ | bi == tyDateTime -> "DateTime"+ | bi == tyTime -> "TimeOfDay"+ | bi == tyDate -> "Day"+ | otherwise ->+ error $ "Haskell: 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/Parser.hs view
@@ -8,10 +8,14 @@ import TW.Ast +import Data.Either+import Data.Maybe import Control.Monad.Identity import Data.Char import Text.Parsec+import Network.HTTP.Types.Method import qualified Data.Text as T+import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import qualified Text.Parsec.Token as P @@ -41,8 +45,8 @@ moduleName <- parseModuleName _ <- semi imports <- many parseImport- tyDefs <- many parseTypeDef- return $ Module moduleName imports tyDefs+ tyDefs <- many ((Left <$> parseTypeDef) <|> (Right <$> parseApiDef))+ return $ Module moduleName imports (lefts tyDefs) (rights tyDefs) parseModuleName :: Parser ModuleName parseModuleName =@@ -56,6 +60,56 @@ _ <- semi return m +parseApiDef :: Parser ApiDef+parseApiDef =+ do reserved "api"+ name <- identifier+ (headers, endpoints) <-+ braces $+ do headers <-+ optionMaybe $ try $ brackets (commaSep1 parseApiHeader) <* semi+ ep <- many parseApiEndpoint+ return (fromMaybe [] headers, ep)+ return (ApiDef (ApiName $ T.pack name) headers endpoints)++parseApiEndpoint :: Parser ApiEndpointDef+parseApiEndpoint =+ do name <- identifier+ reservedOp "="+ verbStr <- identifier+ verb <-+ case parseMethod (T.encodeUtf8 $ T.toUpper $ T.pack verbStr) of+ Left _ -> fail $ "Unknown http verb: " ++ verbStr+ Right v -> return v+ route <- parens (slashSep1 parseRouteComp)+ headers <- optionMaybe $ try $ brackets (commaSep1 parseApiHeader)+ reservedOp ":"+ req <- optionMaybe $ try (parseType <* reservedOp "->")+ resp <- parseType+ _ <- semi+ return+ ApiEndpointDef+ { aed_name = EndpointName $ T.pack name+ , aed_verb = verb+ , aed_headers = fromMaybe [] headers+ , aed_route = route+ , aed_req = req+ , aed_resp = resp+ }++parseApiHeader :: Parser ApiHeader+parseApiHeader =+ do name <- stringLiteral+ val <-+ (reservedOp "=" *> (ApiHeaderValueStatic <$> (T.pack <$> stringLiteral))) <|>+ pure ApiHeaderValueDynamic+ return (ApiHeader (T.pack name) val)++parseRouteComp :: Parser ApiRouteComp+parseRouteComp =+ ApiRouteStatic <$> (T.pack <$> stringLiteral) <|>+ ApiRouteDynamic <$> parseType+ parseTypeDef :: Parser TypeDef parseTypeDef = TypeDefEnum <$> parseEnumDef <|>@@ -84,7 +138,7 @@ parseStructField :: Parser StructField parseStructField =- do name <- (FieldName . T.pack <$> identifier)+ do name <- FieldName . T.pack <$> identifier reservedOp ":" ty <- parseType _ <- semi@@ -138,20 +192,27 @@ , P.identLetter = alphaNum <|> oneOf "_" , P.opStart = oneOf ":!#$%&*+./<=>?@\\^|-~" , P.opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"- , P.reservedNames = ["module", "type", "enum", "import", "as"]- , P.reservedOpNames = [":", "->"]+ , P.reservedNames =+ [ "module", "type", "enum", "api", "import", "as" ]+ , P.reservedOpNames = [":", "->", "/", "="] , P.caseSensitive = False } lexer :: P.GenTokenParser T.Text () Identity lexer = P.makeTokenParser languageDef +stringLiteral :: Parser String+stringLiteral = P.stringLiteral lexer+ parens :: Parser a -> Parser a parens = P.parens lexer braces :: Parser a -> Parser a braces = P.braces lexer +brackets :: Parser a -> Parser a+brackets = P.brackets lexer+ angles :: Parser a -> Parser a angles = P.angles lexer @@ -175,6 +236,9 @@ dotSep1 :: Parser a -> Parser [a] dotSep1 p = sepBy p dot++slashSep1 :: Parser a -> Parser [a]+slashSep1 p = sepBy p (reservedOp "/") commaSep1 :: Parser a -> Parser [a] commaSep1 = P.commaSep1 lexer
+ src/TW/Types.hs view
@@ -0,0 +1,9 @@+module TW.Types where++import qualified Data.Text as T++data LibraryInfo+ = LibraryInfo+ { li_name :: T.Text+ , li_version :: T.Text+ }
+ src/TW/Utils.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings #-}+module TW.Utils where++import Data.Char+import qualified Data.Text as T++capitalizeText :: T.Text -> T.Text+capitalizeText =+ T.pack . go . T.unpack+ where+ go (x:xs) = toUpper x : xs+ go [] = []++uncapitalizeText :: T.Text -> T.Text+uncapitalizeText =+ T.pack . go . T.unpack+ where+ go (x:xs) = toLower x : xs+ go [] = []++makeSafePrefixedFieldName :: T.Text -> T.Text+makeSafePrefixedFieldName = T.filter isAlphaNum
+ test/TW/CodeGen/HaskellTest.hs view
@@ -0,0 +1,113 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+{-# LANGUAGE OverloadedStrings #-}+module TW.CodeGen.HaskellTest where++import TW.Ast+import TW.Check+import TW.Loader+import TW.Types+import qualified TW.CodeGen.Haskell as HS++import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.Monoid+import Test.Framework+import System.IO.Temp+import System.Directory+import System.FilePath+import System.Process+import System.Exit++mainTemplate :: T.Text+mainTemplate =+ T.unlines+ [ "module Main where"+ , "import Basic"+ , "import Data.Aeson"+ , "main :: IO ()"+ , "main = "+ , " do putStrLn \"Lauching self-check ...\""+ , " let b = Bar True 42"+ , " bEnc = encode b"+ , " bDec = decode' bEnc"+ , " if (Just b /= bDec) then fail \"Bar enc/dec check ... failed\" else putStrLn \"Bar enc/dec check ... ok\""+ ]++stackTemplate :: T.Text+stackTemplate =+ T.unlines+ [ "resolver: lts-3.10"+ , "packages:"+ , "- '.'"+ , "extra-deps:"+ , "- Spock-0.10.0.1"+ , "- " <> li_name HS.libraryInfo <> "-" <> li_version HS.libraryInfo+ ]++cabalTemplate :: T.Text+cabalTemplate =+ T.unlines+ [ "name: typed-wire-haskell-test"+ , "version: 0.1.0.0"+ , "synopsis: Just Testing..."+ , "description: Please see README.md"+ , "homepage: http://github.com/typed-wire/typed-wire#readme"+ , "license: MIT"+ , "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"+ , "cabal-version: >=1.10"+ , "tested-with: GHC==7.10.2"+ , "executable test"+ , " hs-source-dirs: src"+ , " main-is: Main.hs"+ , " other-modules:"+ , " Basic"+ , " , Other"+ , " ghc-options: -threaded -rtsopts -with-rtsopts=-N"+ , " build-depends:"+ , " base >= 4.7 && < 5"+ , " , aeson"+ , " , time"+ , " , text"+ , " , vector"+ , " , mtl"+ , " , Spock"+ , " , " <> li_name HS.libraryInfo <> " == " <> li_version HS.libraryInfo+ , " default-language: Haskell2010"+ ]++test_haskellCodeGen :: IO ()+test_haskellCodeGen =+ withSystemTempDirectory "haskellCodeGenX" $ \dir ->+ do let srcDir = dir </> "src"+ loaded <- loadModules ["samples"] [ModuleName ["Basic"]]+ allModules <- assertRight loaded+ checkedModules <- assertRight $ checkModules allModules+ mapM_ (runner srcDir HS.makeModule HS.makeFileName) checkedModules+ T.writeFile (dir </> "typed-wire-haskell-test.cabal") cabalTemplate+ T.writeFile (dir </> "stack.yaml") stackTemplate+ T.writeFile (srcDir </> "Main.hs") mainTemplate+ let p =+ (shell "stack build --pedantic")+ { cwd = Just dir+ }+ (_, _, _, handle) <- createProcess p+ ec <- waitForProcess handle+ assertEqual ExitSuccess ec+ let pRun =+ (shell "stack exec test")+ { cwd = Just dir+ }+ (_, _, _, hRun) <- createProcess pRun+ ecRun <- waitForProcess hRun+ assertEqual ExitSuccess ecRun++runner :: FilePath -> (Module -> T.Text) -> (ModuleName -> FilePath) -> Module -> IO ()+runner baseDir mkModule mkFilename m =+ let moduleSrc = mkModule m+ moduleFp = baseDir </> mkFilename (m_name m)+ in do createDirectoryIfMissing True (takeDirectory moduleFp)+ T.writeFile moduleFp moduleSrc
+ test/TW/CodeGen/PureScriptTest.hs view
@@ -0,0 +1,102 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+{-# LANGUAGE OverloadedStrings #-}+module TW.CodeGen.PureScriptTest where++import TW.Ast+import TW.Check+import TW.Loader+import TW.Types+import qualified TW.CodeGen.PureScript as PS++import Data.Aeson ((.=))+import System.Directory+import System.Exit+import System.FilePath+import System.IO.Temp+import System.Process+import Test.Framework+import qualified Data.Aeson as A+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.IO as T++mainTemplate :: T.Text+mainTemplate =+ T.unlines+ [ "module Main where"+ , "import Basic"+ , "import Data.Either"+ , "import Data.TypedWire.Prelude"+ , "import Control.Monad.Eff.Console"+ , "import Control.Monad.Eff"+ , ""+ , "main :: forall a. Eff (console :: CONSOLE | a) Unit"+ , "main = "+ , " do log \"Lauching self-check ...\""+ , " let b = Bar { someField: true, moreFields: 42 }"+ , " bEnc = encodeJson b"+ , " bDec = decodeJson bEnc"+ , " if (Right b /= bDec) then error \"Bar enc/dec check ... failed\" else log \"Bar enc/dec check ... ok\""+ ]++bowerTemplate :: T.Text+bowerTemplate =+ T.decodeUtf8 $+ BSL.toStrict $+ A.encode $+ A.object+ [ "name" .= T.pack "purescript-typed-wire-test"+ , "version" .= T.pack "0.1.0"+ , "moduleType" .= [T.pack "node"]+ , "ignore" .= map T.pack ["**/.*", "node_modules", "bower_components", "output"]+ , "dependencies" .=+ A.object+ [ (li_name PS.libraryInfo) .= (li_version PS.libraryInfo)+ , "purescript-console" .= T.pack "0.1.1"+ ]+ , "repository" .=+ A.object+ [ "type" .= T.pack "git"+ , "url" .= T.pack "git://github.com/typed-wire/purescript-typed-wire"+ ]+ ]++test_pureScriptCodeGen :: IO ()+test_pureScriptCodeGen =+ withSystemTempDirectory "purescriptCodeGenX" $ \dir ->+ do let srcDir = dir </> "src"+ loaded <- loadModules ["samples"] [ModuleName ["Basic"]]+ allModules <- assertRight loaded+ checkedModules <- assertRight $ checkModules allModules+ mapM_ (runner srcDir PS.makeModule PS.makeFileName) checkedModules+ T.writeFile (dir </> "bower.json") bowerTemplate+ T.writeFile (srcDir </> "Main.purs") mainTemplate+ let pDeps =+ (shell "pulp dep install")+ { cwd = Just dir+ }+ (_, _, _, hDeps) <- createProcess pDeps+ ecDeps <- waitForProcess hDeps+ assertEqual ExitSuccess ecDeps+ let p =+ (shell "pulp build")+ { cwd = Just dir+ }+ (_, _, _, handle) <- createProcess p+ ec <- waitForProcess handle+ assertEqual ExitSuccess ec+ let pRun =+ (shell "pulp run")+ { cwd = Just dir+ }+ (_, _, _, hRun) <- createProcess pRun+ ecRun <- waitForProcess hRun+ assertEqual ExitSuccess ecRun++runner :: FilePath -> (Module -> T.Text) -> (ModuleName -> FilePath) -> Module -> IO ()+runner baseDir mkModule mkFilename m =+ let moduleSrc = mkModule m+ moduleFp = baseDir </> mkFilename (m_name m)+ in do createDirectoryIfMissing True (takeDirectory moduleFp)+ T.writeFile moduleFp moduleSrc
+ test/Test.hs view
@@ -0,0 +1,10 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module Main where++import {-@ HTF_TESTS @-} TW.CodeGen.HaskellTest+import {-@ HTF_TESTS @-} TW.CodeGen.PureScriptTest++import Test.Framework++main :: IO ()+main = htfMain htf_importedTests
typed-wire.cabal view
@@ -1,13 +1,13 @@ name: typed-wire-version: 0.2.1.3-synopsis: WIP: Language idependent type-safe communication+version: 0.3.0.0+synopsis: Language idependent type-safe communication description: Please see README.md-homepage: http://github.com/agrafix/typed-wire#readme+homepage: http://github.com/typed-wire/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>+copyright: (c) 2015 - 2016 Alexander Thiemann <mail@athiemann.net> category: Web build-type: Simple extra-source-files:@@ -25,7 +25,10 @@ TW.BuiltIn, TW.JsonRepr, TW.CodeGen.Elm,- TW.CodeGen.Haskell+ TW.CodeGen.Haskell,+ TW.CodeGen.PureScript,+ TW.Types,+ TW.Utils build-depends: base >= 4.7 && < 5, text >= 1.2,@@ -34,7 +37,7 @@ containers >=0.5, directory >=1.2, filepath >=1.4,- file-embed >=0.0.9+ http-types >=0.8.6 default-language: Haskell2010 executable twirec@@ -51,6 +54,26 @@ directory >=1.2 default-language: Haskell2010 +test-suite typed-wire-tests+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Test.hs+ other-modules:+ TW.CodeGen.HaskellTest+ TW.CodeGen.PureScriptTest+ build-depends:+ base+ , aeson+ , typed-wire+ , HTF >=0.13+ , temporary >=1.1+ , text >=1.2+ , filepath >=1.4+ , directory >=1.2.2+ , process >=1.2+ , bytestring >=0.10+ default-language: Haskell2010+ source-repository head type: git- location: https://github.com/agrafix/typed-wire+ location: https://github.com/typed-wire/typed-wire