diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,10 +2,11 @@ ===== [![Build Status](https://travis-ci.org/agrafix/typed-wire.svg)](https://travis-ci.org/agrafix/typed-wire) - +[![Hackage](https://img.shields.io/hackage/v/typed-wire.svg)](http://hackage.haskell.org/package/typed-wire) ## Intro +Hackage: [typed-wire](http://hackage.haskell.org/package/typed-wire) WIP: Language idependent type-safe communication @@ -21,7 +22,7 @@ Available options: -h,--help Show this help text - --version show version and exit + --version Show version and exit -i,--include-dir DIR Directory to search for modules -e,--entrypoint MODULE-NAME Entrypoint for compiler @@ -32,6 +33,7 @@ ## 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` diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -11,13 +11,13 @@ 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.Traversable as T import qualified Data.Version as Vers data Options @@ -32,7 +32,7 @@ optParser :: Parser Options optParser = Options - <$> switch (long "version" <> help "show version and exit") + <$> switch (long "version" <> help "Show version and exit") <*> sourceDirsP <*> entryPointsP <*> hsOutP @@ -102,18 +102,23 @@ 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 () + do _ <- T.forM (o_hsOutDir opts) $ \dir -> + do storeLib dir HS.makeLibraryModule + mapM_ (runner dir HS.makeModule HS.makeFileName) readyModules + _ <- T.forM (o_elmOutDir opts) $ \dir -> + do storeLib dir Elm.makeLibraryModule + mapM_ (runner dir Elm.makeModule Elm.makeFileName) readyModules + return () -runner :: Module -> FilePath -> (Module -> T.Text) -> (ModuleName -> FilePath) -> IO () -runner m baseDir mkModule mkFilename = +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 = let moduleSrc = mkModule m moduleFp = baseDir mkFilename (m_name m) in do createDirectoryIfMissing True (takeDirectory moduleFp) diff --git a/src/TW/BuiltIn.hs b/src/TW/BuiltIn.hs --- a/src/TW/BuiltIn.hs +++ b/src/TW/BuiltIn.hs @@ -2,7 +2,7 @@ module TW.BuiltIn ( BuiltIn(..) , allBuiltIns, isBuiltIn - , tyString, tyInt, tyFloat, tyBool, tyMaybe + , tyString, tyInt, tyFloat, tyBool, tyMaybe, tyBytes, tyList, tyDateTime, tyDate, tyTime ) where @@ -18,7 +18,7 @@ } deriving (Show, Eq) allBuiltIns :: [BuiltIn] -allBuiltIns = [tyString, tyInt, tyFloat, tyBool, tyMaybe] +allBuiltIns = [tyString, tyInt, tyFloat, tyBool, tyMaybe, tyBytes, tyList, tyDateTime, tyDate, tyTime] isBuiltIn :: Type -> Maybe (BuiltIn, [Type]) isBuiltIn ty = @@ -50,3 +50,21 @@ tyMaybe :: BuiltIn tyMaybe = builtInVars "Maybe" ["a"] + +tyList :: BuiltIn +tyList = builtInVars "List" ["a"] + +tyBytes :: BuiltIn +tyBytes = builtIn "Bytes" + +-- | DateTime type, format: YYYY-MM-DD HH:MM:SS[Z|+XX|-XX] or YYYY-MM-DDTHH:MM:SS[Z|+XX|-XX] +tyDateTime :: BuiltIn +tyDateTime = builtIn "DateTime" + +-- | Date type, format: YYYY-MM-DD +tyDate :: BuiltIn +tyDate = builtIn "Date" + +-- | Time type, format: HH:MM:SS +tyTime :: BuiltIn +tyTime = builtIn "Time" diff --git a/src/TW/CodeGen/Elm.hs b/src/TW/CodeGen/Elm.hs --- a/src/TW/CodeGen/Elm.hs +++ b/src/TW/CodeGen/Elm.hs @@ -1,12 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module TW.CodeGen.Elm - ( makeFileName, makeModule ) + ( makeFileName, makeModule + , makeLibraryModule + ) where import TW.Ast import TW.BuiltIn import TW.JsonRepr +import Data.FileEmbed import Data.Maybe import Data.Monoid import System.FilePath @@ -25,6 +29,12 @@ 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" @@ -37,6 +47,7 @@ , "" , T.intercalate "\n" (map makeImport $ m_imports m) , "" + , "import TW.Support.Lib as ELib" , "import Json.Decode as " <> jsonDecQual , "import Json.Decode exposing ((:=))" , "import Json.Encode as " <> jsonEncQual @@ -65,13 +76,9 @@ , "" , "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) - , " ]" + , " " <> 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) @@ -122,12 +129,8 @@ , "" , "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) + , " 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" @@ -184,9 +187,17 @@ | bi == tyInt -> jsonEnc "int" | bi == tyBool -> jsonEnc "bool" | bi == tyFloat -> jsonEnc "float" + | bi == tyBytes -> "ELib.jencAsBase64" + | bi == tyDateTime -> "ELib.jencDateTime" + | bi == tyTime -> "ELib.jencTime" + | bi == tyDate -> "ELib.jencDate" + | bi == tyList -> + case tvars of + [arg] -> jsonEnc "list" <> " (" <> jsonEncFor arg <> ")" + _ -> error $ "Elm: odly shaped List value" | bi == tyMaybe -> case tvars of - [arg] -> "packMaybe (" <> jsonEncFor arg <> ")" + [arg] -> "ELib.packMaybe (" <> jsonEncFor arg <> ")" _ -> error $ "Elm: odly shaped Maybe value" | otherwise -> error $ "Elm: Missing jsonEnc for built in type: " ++ show t @@ -207,6 +218,14 @@ | bi == tyInt -> jsonDec "int" | bi == tyBool -> jsonDec "bool" | bi == tyFloat -> jsonDec "float" + | bi == tyBytes -> "ELib.jdecAsBase64" + | bi == tyDateTime -> "ELib.jdecDateTime" + | bi == tyTime -> "ELib.jdecTime" + | bi == tyDate -> "ELib.jdecDate" + | bi == tyList -> + case tvars of + [arg] -> jsonDec "list" <> " (" <> jsonDecFor arg <> ")" + _ -> error $ "Elm: odly shaped List value" | bi == tyMaybe -> case tvars of [arg] -> jsonDec "maybe" <> " (" <> jsonDecFor arg <> ")" @@ -236,7 +255,12 @@ | bi == tyInt -> "Int" | bi == tyBool -> "Bool" | bi == tyFloat -> "Float" + | bi == tyDateTime -> "ELib.DateTime" + | bi == tyTime -> "ELib.Time" + | bi == tyDate -> "ELib.Date" | bi == tyMaybe -> "(Maybe " <> T.intercalate " " (map makeType tvars) <> ")" + | bi == tyList -> "(List " <> T.intercalate " " (map makeType tvars) <> ")" + | bi == tyBytes -> "ELib.AsBase64" | otherwise -> error $ "Elm: Unimplemented built in type: " ++ show t diff --git a/src/TW/CodeGen/Haskell.hs b/src/TW/CodeGen/Haskell.hs --- a/src/TW/CodeGen/Haskell.hs +++ b/src/TW/CodeGen/Haskell.hs @@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module TW.CodeGen.Haskell - ( makeFileName, makeModule ) + ( makeFileName, makeModule + , makeLibraryModule + ) where import TW.Ast @@ -8,6 +11,7 @@ import TW.JsonRepr import Data.Char +import Data.FileEmbed import Data.Maybe import Data.Monoid import System.FilePath @@ -20,11 +24,11 @@ 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 +makeLibraryModule :: (FilePath, T.Text) +makeLibraryModule = + ( "TW/Support/Lib.hs" + , $(embedStringFile "support/haskell/Lib.hs") + ) makeFileName :: ModuleName -> FilePath makeFileName (ModuleName parts) = @@ -33,17 +37,20 @@ makeModule :: Module -> T.Text makeModule m = T.unlines - [ "{-# LANGUAGE OverloadedStrings #-}" + [ "{-# OPTIONS_GHC -fno-warn-unused-imports #-}" + , "{-# 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 qualified TW.Support.Lib as HLib" , "import Control.Applicative" , "import Control.Monad (join)" + , "import Data.Time" , "import qualified Data.Aeson as " <> aesonQual - , "import qualified Data.Aeson.Types as " <> aesonTQual , "import qualified Data.Text as T" + , "import qualified Data.Vector as V" , "" , T.intercalate "\n" (map makeTypeDef $ m_typeDefs m) ] @@ -123,9 +130,6 @@ , " 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 = @@ -133,7 +137,7 @@ tag = camelTo2 '_' $ T.unpack constr (op, opEnd) = case ec_arg ec of - Nothing -> ("<$ (eatBool <$> (", "))") + Nothing -> ("<$ (HLib.eatBool <$> (", "))") Just _ -> ("<$>", "") in "(" <> constr <> " " <> op <> " obj " <> (aeson ".:") <> " " <> T.pack (show tag) <> opEnd <> ")" mkToJsonChoice ec = @@ -142,7 +146,7 @@ (argParam, argVal) = case ec_arg ec of Nothing -> ("", "True") - Just _ -> ("x", "x") + Just _ -> ("y", "y") in constr <> " " <> argParam <> " -> " <> aeson "object" <> " [" <> T.pack (show tag) <> " " <> aeson ".=" <> " " <> argVal <> "]" fullType = @@ -174,8 +178,13 @@ | bi == tyBool -> "Bool" | bi == tyFloat -> "Double" | bi == tyMaybe -> "(Maybe " <> T.intercalate " " (map makeType tvars) <> ")" + | bi == tyBytes -> "HLib.AsBase64" + | bi == tyList -> "(V.Vector " <> T.intercalate " " (map makeType tvars) <> ")" + | bi == tyDateTime -> "UTCTime" + | bi == tyTime -> "TimeOfDay" + | bi == tyDate -> "Day" | otherwise -> - error $ "Elm: Unimplemented built in type: " ++ show t + error $ "Haskell: Unimplemented built in type: " ++ show t makeQualTypeName :: QualTypeName -> T.Text makeQualTypeName qtn = diff --git a/typed-wire.cabal b/typed-wire.cabal --- a/typed-wire.cabal +++ b/typed-wire.cabal @@ -1,5 +1,5 @@ name: typed-wire -version: 0.1.0.0 +version: 0.2.0.0 synopsis: WIP: Language idependent type-safe communication description: Please see README.md homepage: http://github.com/agrafix/typed-wire#readme @@ -33,7 +33,8 @@ mtl >=2.2, containers >=0.5, directory >=1.2, - filepath >=1.4 + filepath >=1.4, + file-embed >=0.0.9 default-language: Haskell2010 executable twirec