From 14db1093c712647d265a9578ffdceb8cb88de7b8 Mon Sep 17 00:00:00 2001
From: Adam Bergmark <adam@bergmark.nl>
Date: Tue, 16 Jun 2015 16:30:43 +0200
Subject: [PATCH 1/9] Prefer application/json over text/json everywhere (fixes
 #116)

---
 rest-core/src/Rest/Driver/Perform.hs     | 1 -
 rest-core/tests/Runner.hs                | 4 ++--
 rest-gen/files/Javascript/base.js        | 3 ++-
 rest-gen/src/Rest/Gen/Base/ActionInfo.hs | 2 +-
 rest-gen/src/Rest/Gen/Haskell.hs         | 2 +-
 rest-gen/src/Rest/Gen/JavaScript.hs      | 2 +-
 rest-gen/src/Rest/Gen/Ruby.hs            | 2 +-
 7 files changed, 8 insertions(+), 8 deletions(-)

diff --git a/rest-core/src/Rest/Driver/Perform.hs b/rest-core/src/Rest/Driver/Perform.hs
index bc45ad9..f711c68 100644
--- a/rest-core/src/Rest/Driver/Perform.hs
+++ b/rest-core/src/Rest/Driver/Perform.hs
@@ -277,7 +277,6 @@ contentType c = setHeader "Content-Type" $
     XmlFormat  -> "application/xml; charset=UTF-8"
     _          -> "text/plain; charset=UTF-8"
 
-
 validator :: forall v m e. Rest m => Outputs v -> ExceptT (Reason e) m ()
 validator = tryOutputs try
   where
diff --git a/rest-core/tests/Runner.hs b/rest-core/tests/Runner.hs
index 1115ae3..6f1a2cc 100644
--- a/rest-core/tests/Runner.hs
+++ b/rest-core/tests/Runner.hs
@@ -11,7 +11,7 @@ import Test.Framework (defaultMain)
 import Test.Framework.Providers.HUnit (testCase)
 import Test.HUnit (Assertion, assertEqual, assertFailure)
 
-import qualified Data.HashMap.Strict   as H
+import qualified Data.HashMap.Strict as H
 
 import Rest.Api hiding (route)
 import Rest.Dictionary
@@ -206,5 +206,5 @@ allMethods = [GET, PUT, POST, DELETE]
 
 testAcceptHeaders :: Assertion
 testAcceptHeaders =
-  do fmt <- runRestM_ RestM.emptyInput { RestM.headers = H.singleton "Accept" "text/json" } accept
+  do fmt <- runRestM_ RestM.emptyInput { RestM.headers = H.singleton "Accept" "application/json" } accept
      assertEqual "Accept json format." [JsonFormat] fmt
diff --git a/rest-gen/files/Javascript/base.js b/rest-gen/files/Javascript/base.js
index 8d31a35..ff8f2b7 100644
--- a/rest-gen/files/Javascript/base.js
+++ b/rest-gen/files/Javascript/base.js
@@ -157,7 +157,8 @@ function nodeRequest (method, url, params, onSuccess, onError, contentType, acce
 
   function parse (response)
   {
-    if (acceptHeader.split(";").indexOf('text/json') >= 0)
+    var acceptHeaders = acceptHeader.split(";");
+    if (acceptHeaders.indexOf('text/json') >= 0 || acceptHeaders.indexOf('application/json') >= 0)
     {
       var r = response;
       try
diff --git a/rest-gen/src/Rest/Gen/Base/ActionInfo.hs b/rest-gen/src/Rest/Gen/Base/ActionInfo.hs
index cd6b059..60c3617 100644
--- a/rest-gen/src/Rest/Gen/Base/ActionInfo.hs
+++ b/rest-gen/src/Rest/Gen/Base/ActionInfo.hs
@@ -190,7 +190,7 @@ dataTypeToAcceptHeader :: DataType -> String
 dataTypeToAcceptHeader = \case
   String -> "text/plain"
   XML    -> "text/xml"
-  JSON   -> "text/json"
+  JSON   -> "application/json"
   File   -> "application/octet-stream"
   Other  -> "text/plain"
 
diff --git a/rest-gen/src/Rest/Gen/Haskell.hs b/rest-gen/src/Rest/Gen/Haskell.hs
index 849bbaf..580e906 100644
--- a/rest-gen/src/Rest/Gen/Haskell.hs
+++ b/rest-gen/src/Rest/Gen/Haskell.hs
@@ -373,7 +373,7 @@ inputInfo dsc =
     String -> InputInfo [] (haskellStringType) "text/plain" "fromString"
     -- TODO fromJusts
     XML    -> InputInfo (L.get haskellModules dsc) (L.get haskellType dsc) "text/xml" "toXML"
-    JSON   -> InputInfo (L.get haskellModules dsc) (L.get haskellType dsc) "text/json" "toJSON"
+    JSON   -> InputInfo (L.get haskellModules dsc) (L.get haskellType dsc) "application/json" "toJSON"
     File   -> InputInfo [] haskellByteStringType "application/octet-stream" "id"
     Other  -> InputInfo [] haskellByteStringType "text/plain" "id"
 
diff --git a/rest-gen/src/Rest/Gen/JavaScript.hs b/rest-gen/src/Rest/Gen/JavaScript.hs
index 327332e..bebd090 100644
--- a/rest-gen/src/Rest/Gen/JavaScript.hs
+++ b/rest-gen/src/Rest/Gen/JavaScript.hs
@@ -141,6 +141,6 @@ mkType dt =
   case dt of
     String -> ("text", "text/plain", id)
     XML    -> ("xml" , "text/xml", id)
-    JSON   -> ("json", "text/json", call "JSON.stringify")
+    JSON   -> ("json", "application/json", call "JSON.stringify")
     File   -> ("file", "application/octet-stream", id)
     Other  -> ("text", "text/plain", id)
diff --git a/rest-gen/src/Rest/Gen/Ruby.hs b/rest-gen/src/Rest/Gen/Ruby.hs
index 40e80c9..c289139 100644
--- a/rest-gen/src/Rest/Gen/Ruby.hs
+++ b/rest-gen/src/Rest/Gen/Ruby.hs
@@ -149,6 +149,6 @@ mkType dt =
   case dt of
     String -> ("data", "text/plain", id)
     XML    -> ("xml" , "text/xml", (<+> ".to_s"))
-    JSON   -> ("json", "text/json", call "mkJson")
+    JSON   -> ("json", "application/json", call "mkJson")
     File   -> ("file", "application/octet-stream", id)
     Other  -> ("data", "text/plain", id)

From 33ffb4c033121506061a5e0ed2622132176405bb Mon Sep 17 00:00:00 2001
From: Adam Bergmark <adam@bergmark.nl>
Date: Tue, 16 Jun 2015 16:51:07 +0200
Subject: [PATCH 2/9] rest-gen: Abstract content-type and datatype strings from
 JavaScript/Ruby clients

---
 rest-gen/src/Rest/Gen/Base/ActionInfo.hs | 53 +++++++++++++++---------
 rest-gen/src/Rest/Gen/Haskell.hs         | 25 +++++------
 rest-gen/src/Rest/Gen/JavaScript.hs      | 15 +++----
 rest-gen/src/Rest/Gen/Ruby.hs            | 15 +++----
 4 files changed, 62 insertions(+), 46 deletions(-)

diff --git a/rest-gen/src/Rest/Gen/Base/ActionInfo.hs b/rest-gen/src/Rest/Gen/Base/ActionInfo.hs
index 60c3617..7b42b9d 100644
--- a/rest-gen/src/Rest/Gen/Base/ActionInfo.hs
+++ b/rest-gen/src/Rest/Gen/Base/ActionInfo.hs
@@ -12,7 +12,12 @@ module Rest.Gen.Base.ActionInfo
   , ActionInfo (..)
   , ActionType (..)
   , ActionTarget (..)
+
   , DataType (..)
+  , dataTypesToAcceptHeader
+  , dataTypeToAcceptHeader
+  , dataTypeString
+
   , ResourceId
   , accessLink
   , accessors
@@ -34,7 +39,6 @@ module Rest.Gen.Base.ActionInfo
 
   , ResponseType (..)
   , responseAcceptType
-  , dataTypesToAcceptHeader
   , chooseResponseType
 
   , isAccessor
@@ -98,7 +102,34 @@ data ActionType = Retrieve | Create | Delete | DeleteMany | List | Update | Upda
 
 data ActionTarget = Self | Any deriving (Show, Eq)
 
-data DataType = String | XML | JSON | File | Other deriving (Show, Eq)
+data DataType = String | XML | JSON | File | Other
+  deriving (Show, Eq)
+
+dataTypeString :: DataType -> String
+dataTypeString = \case
+    String -> "text"
+    XML    -> "xml"
+    JSON   -> "json"
+    File   -> "file"
+    Other  -> "text"
+
+-- | First argument is the default accept header to use if there is no
+-- output or errors, must be XML or JSON.
+dataTypesToAcceptHeader :: DataType -> [DataType] -> String
+dataTypesToAcceptHeader def = \case
+  [] -> dataTypeToAcceptHeader def
+  xs -> intercalate "," . map dataTypeToAcceptHeader . (xs ++) $
+          if null (intersect xs [XML,JSON])
+            then [def]
+            else []
+
+dataTypeToAcceptHeader :: DataType -> String
+dataTypeToAcceptHeader = \case
+  String -> "text/plain"
+  XML    -> "text/xml"
+  JSON   -> "application/json"
+  File   -> "application/octet-stream"
+  Other  -> "text/plain"
 
 -- | Core information about the type of the input/output
 data DataDesc = DataDesc
@@ -176,24 +207,6 @@ responseAcceptType (ResponseType e o) = typs
         f :: Maybe DataDesc -> [DataType]
         f = maybeToList . fmap (L.get dataType)
 
--- | First argument is the default accept header to use if there is no
--- output or errors, must be XML or JSON.
-dataTypesToAcceptHeader :: DataType -> [DataType] -> String
-dataTypesToAcceptHeader def = \case
-  [] -> dataTypeToAcceptHeader def
-  xs -> intercalate "," . map dataTypeToAcceptHeader . (xs ++) $
-          if null (intersect xs [XML,JSON])
-            then [def]
-            else []
-
-dataTypeToAcceptHeader :: DataType -> String
-dataTypeToAcceptHeader = \case
-  String -> "text/plain"
-  XML    -> "text/xml"
-  JSON   -> "application/json"
-  File   -> "application/octet-stream"
-  Other  -> "text/plain"
-
 chooseResponseType :: ActionInfo -> ResponseType
 chooseResponseType ai = case (NList.nonEmpty $ outputs ai, NList.nonEmpty $ errors ai) of
   -- No outputs or errors defined
diff --git a/rest-gen/src/Rest/Gen/Haskell.hs b/rest-gen/src/Rest/Gen/Haskell.hs
index 580e906..e38be71 100644
--- a/rest-gen/src/Rest/Gen/Haskell.hs
+++ b/rest-gen/src/Rest/Gen/Haskell.hs
@@ -4,7 +4,6 @@
   , LambdaCase
   , PatternGuards
   , TemplateHaskell
-  , ViewPatterns
   #-}
 module Rest.Gen.Haskell
   ( HaskellContext (..)
@@ -287,10 +286,11 @@ idData node =
     ls ->
       let ctor (pth,mi) =
             H.QualConDecl noLoc [] [] (H.ConDecl (H.Ident (dataName pth)) $ maybe [] f mi)
+              where
 #if MIN_VERSION_haskell_src_exts(1,16,0)
-              where f ty = [Ident.haskellType ty]
+                f ty = [Ident.haskellType ty]
 #else
-              where f ty = [H.UnBangedTy $ Ident.haskellType ty]
+                f ty = [H.UnBangedTy $ Ident.haskellType ty]
 #endif
           fun (pth, mi) = [
                            H.FunBind [H.Match noLoc funName fparams Nothing rhs noBinds]]
@@ -370,12 +370,13 @@ data InputInfo = InputInfo
 inputInfo :: DataDesc -> InputInfo
 inputInfo dsc =
   case L.get dataType dsc of
-    String -> InputInfo [] (haskellStringType) "text/plain" "fromString"
-    -- TODO fromJusts
-    XML    -> InputInfo (L.get haskellModules dsc) (L.get haskellType dsc) "text/xml" "toXML"
-    JSON   -> InputInfo (L.get haskellModules dsc) (L.get haskellType dsc) "application/json" "toJSON"
-    File   -> InputInfo [] haskellByteStringType "application/octet-stream" "id"
-    Other  -> InputInfo [] haskellByteStringType "text/plain" "id"
+    String -> InputInfo []                         haskellStringType       dataTypeHeader "fromString"
+    XML    -> InputInfo (L.get haskellModules dsc) (L.get haskellType dsc) dataTypeHeader "toXML"
+    JSON   -> InputInfo (L.get haskellModules dsc) (L.get haskellType dsc) dataTypeHeader "toJSON"
+    File   -> InputInfo []                         haskellByteStringType   dataTypeHeader "id"
+    Other  -> InputInfo []                         haskellByteStringType   dataTypeHeader "id"
+  where
+    dataTypeHeader = dataTypeToAcceptHeader $ L.get dataType dsc
 
 data ResponseInfo = ResponseInfo
   { responseModules     :: [H.ModuleName]
@@ -388,11 +389,11 @@ outputInfo r =
   case outputType r of
     Nothing -> ResponseInfo [] haskellUnitType "(const ())"
     Just t -> case L.get dataType t of
-      String -> ResponseInfo [] haskellStringType "toString"
+      String -> ResponseInfo []                       haskellStringType     "toString"
       XML    -> ResponseInfo (L.get haskellModules t) (L.get haskellType t) "fromXML"
       JSON   -> ResponseInfo (L.get haskellModules t) (L.get haskellType t) "fromJSON"
-      File   -> ResponseInfo [] haskellByteStringType "id"
-      Other  -> ResponseInfo [] haskellByteStringType "id"
+      File   -> ResponseInfo []                       haskellByteStringType "id"
+      Other  -> ResponseInfo []                       haskellByteStringType "id"
 
 errorInfo :: ResponseType -> ResponseInfo
 errorInfo r =
diff --git a/rest-gen/src/Rest/Gen/JavaScript.hs b/rest-gen/src/Rest/Gen/JavaScript.hs
index bebd090..0268589 100644
--- a/rest-gen/src/Rest/Gen/JavaScript.hs
+++ b/rest-gen/src/Rest/Gen/JavaScript.hs
@@ -137,10 +137,11 @@ jsId []       = ""
 jsId (x : xs) = x ++ concatMap upFirst xs
 
 mkType :: DataType -> (String, String, Code -> Code)
-mkType dt =
-  case dt of
-    String -> ("text", "text/plain", id)
-    XML    -> ("xml" , "text/xml", id)
-    JSON   -> ("json", "application/json", call "JSON.stringify")
-    File   -> ("file", "application/octet-stream", id)
-    Other  -> ("text", "text/plain", id)
+mkType dt = (dataTypeString dt, dataTypeToAcceptHeader dt, fn)
+  where
+    fn = case dt of
+      String -> id
+      XML    -> id
+      JSON   -> call "JSON.stringify"
+      File   -> id
+      Other  -> id
diff --git a/rest-gen/src/Rest/Gen/Ruby.hs b/rest-gen/src/Rest/Gen/Ruby.hs
index c289139..99f8935 100644
--- a/rest-gen/src/Rest/Gen/Ruby.hs
+++ b/rest-gen/src/Rest/Gen/Ruby.hs
@@ -145,10 +145,11 @@ accessorName :: ResourceId -> String
 accessorName = concatMap upFirst . ("Access":) . concatMap cleanName
 
 mkType :: DataType -> (String, String, Code -> Code)
-mkType dt =
-  case dt of
-    String -> ("data", "text/plain", id)
-    XML    -> ("xml" , "text/xml", (<+> ".to_s"))
-    JSON   -> ("json", "application/json", call "mkJson")
-    File   -> ("file", "application/octet-stream", id)
-    Other  -> ("data", "text/plain", id)
+mkType dt = (dataTypeString dt, dataTypeToAcceptHeader dt, fn)
+  where
+    fn = case dt of
+      String -> id
+      XML    -> (<+> ".to_s")
+      JSON   -> call "mkJson"
+      File   -> id
+      Other  -> id

From 8eebc24f79fbfb2d2df657322ce5abc0d407dd99 Mon Sep 17 00:00:00 2001
From: Adam Bergmark <adam@bergmark.nl>
Date: Tue, 16 Jun 2015 17:52:52 +0200
Subject: [PATCH 3/9] rest-gen: Move functionality from the top level generate
 function into mkHsApi and writeDocs so they can be used standalone easier

---
 rest-gen/src/Rest/Gen.hs            | 97 +++++++++++++++++------------
 rest-gen/src/Rest/Gen/Docs.hs       | 14 +++--
 rest-gen/src/Rest/Gen/Haskell.hs    | 10 +--
 rest-gen/src/Rest/Gen/JavaScript.hs | 17 ++---
 rest-gen/src/Rest/Gen/Ruby.hs       | 14 +++--
 rest-gen/src/Rest/Gen/Utils.hs      | 14 +++++
 6 files changed, 103 insertions(+), 63 deletions(-)

diff --git a/rest-gen/src/Rest/Gen.hs b/rest-gen/src/Rest/Gen.hs
index 61e70ac..9d1145e 100644
--- a/rest-gen/src/Rest/Gen.hs
+++ b/rest-gen/src/Rest/Gen.hs
@@ -1,17 +1,11 @@
-module Rest.Gen
-  ( generate
-  ) where
+module Rest.Gen (generate) where
 
 import Data.Char
-import Data.Foldable
 import Data.Label
 import Data.Maybe
-import System.Directory
 import System.Exit
-import System.Process
-import qualified Language.Haskell.Exts.Syntax as H
 
-import Rest.Api (Api, Some1 (..), withVersion)
+import Rest.Api (Api, Router, Some1 (..), Version, withVersion)
 
 import Rest.Gen.Config
 import Rest.Gen.Docs (DocsContext (DocsContext), writeDocs)
@@ -20,51 +14,74 @@ import Rest.Gen.JavaScript (mkJsApi)
 import Rest.Gen.Ruby (mkRbApi)
 import Rest.Gen.Types
 import Rest.Gen.Utils
+import qualified Rest.Gen.Docs    as DCtx (DocsContext (..))
+import qualified Rest.Gen.Haskell as HCtx (HaskellContext (..))
 
-generate :: Config -> String -> Api m -> [H.ModuleName] -> [H.ImportDecl] -> [(H.ModuleName, H.ModuleName)] -> IO ()
+generate :: Config -> String -> Api m -> [ModuleName] -> [ImportDecl] -> [(ModuleName, ModuleName)] -> IO ()
 generate config name api sources imports rewrites =
   withVersion (get apiVersion config) api (putStrLn "Could not find api version" >> exitFailure) $ \ver (Some1 r) ->
      case get action config of
-       Just (MakeDocs root) ->
-         do loc <- getTargetDir config "./docs"
-            setupTargetDir config loc
-            let context = DocsContext root ver (fromMaybe "./templates" (getSourceLocation config))
-            writeDocs context r loc
-            exitSuccess
-       Just MakeJS          -> mkJsApi (overModuleName (++ "Api") moduleName) (get apiPrivate config) ver r >>= toTarget config
-       Just MakeRb          -> mkRbApi (overModuleName (++ "Api") moduleName) (get apiPrivate config) ver r >>= toTarget config
-       Just MakeHS          ->
-         do loc <- getTargetDir config "./client"
-            setupTargetDir config loc
-            let context = HaskellContext ver loc (packageName ++ "-client") (get apiPrivate config) sources imports rewrites [unModuleName moduleName, "Client"]
-            mkHsApi context r
-            exitSuccess
+       Just (MakeDocs root) -> makeDocs config ver r root >> exitSuccess
+       Just MakeJS          -> makeJS config ver r moduleName
+       Just MakeRb          -> makeRb config ver r moduleName
+       Just MakeHS          -> makeHS config ver r moduleName packageName sources imports rewrites >> exitSuccess
        Nothing              -> return ()
   where
     packageName = map toLower name
-    moduleName  = H.ModuleName $ upFirst packageName
+    moduleName  = ModuleName $ upFirst packageName
+
+makeDocs :: Config -> Version -> Router m s -> String -> IO ()
+makeDocs config ver r rootUrl = do
+  targetDir <- getTargetDir config "./docs"
+  writeDocs (context targetDir) r
+    where
+      context targetDir = DocsContext
+        { DCtx.rootUrl        = rootUrl
+        , DCtx.contextVersion = ver
+        , DCtx.templates      = "./templates" `fromMaybe` getSourceLocation config
+        , DCtx.targetDir      = targetDir
+        , DCtx.sourceDir      = getSourceLocation config
+        }
+
+makeJS :: Config -> Version -> Router m s -> ModuleName -> IO ()
+makeJS config ver r moduleName = mkJsApi moduleName (get apiPrivate config) ver r >>= toTarget config
+
+makeRb ::  Config -> Version -> Router m s -> ModuleName -> IO ()
+makeRb config ver r moduleName = mkRbApi moduleName (get apiPrivate config) ver r >>= toTarget config
+
+makeHS :: Config -> Version -> Router m s -> ModuleName -> String -> [ModuleName] -> [ImportDecl] -> [(ModuleName, ModuleName)] -> IO ()
+makeHS config ver r moduleName packageName sources imports rewrites = do
+  targetPath <- getTargetDir config "./client"
+  mkHsApi (context targetPath (getSourceLocation config)) r
+  where
+    context tp sourceDir = HaskellContext
+      { HCtx.apiVersion     = ver
+      , HCtx.targetPath     = tp
+      , HCtx.wrapperName    = packageName ++ "-client"
+      , HCtx.includePrivate = get apiPrivate config
+      , HCtx.sources        = sources
+      , HCtx.imports        = imports
+      , HCtx.rewrites       = rewrites
+      , HCtx.namespace      = [unModuleName moduleName, "Client"]
+      , HCtx.sourceDir      = sourceDir
+      }
 
 getTargetDir :: Config -> String -> IO String
 getTargetDir config str =
   case get target config of
-    Stream     -> putStrLn ("Cannot generate documentation to stdOut, generating to " ++ str) >> return str
-    Default    -> putStrLn ("Generating to " ++ str) >> return str
-    Location d -> putStrLn ("Generating to " ++ d) >> return d
-
-setupTargetDir :: Config -> String -> IO ()
-setupTargetDir config t =
-  do createDirectoryIfMissing True t
-     forM_ (getSourceLocation config) $ \s -> system $ "cp -rf " ++ s ++ " " ++ t
+    Stream     -> putStrLn ("Cannot generate file tree to stdOut, generating to " ++ str) >> return str
+    Default    -> putStrLn ("Generating to " ++ str)                                      >> return str
+    Location d -> putStrLn ("Generating to " ++ d)                                        >> return d
 
 toTarget :: Config -> String -> IO ()
-toTarget config code =
-  do let outf =
-           case get target config of
-             Stream     -> putStrLn
-             Default    -> putStrLn
-             Location l -> writeFile l
-     outf code
-     exitSuccess
+toTarget config code = do
+   outf code
+   exitSuccess
+  where
+    outf = case get target config of
+      Stream     -> putStrLn
+      Default    -> putStrLn
+      Location l -> writeFile l
 
 getSourceLocation :: Config -> Maybe String
 getSourceLocation config =
diff --git a/rest-gen/src/Rest/Gen/Docs.hs b/rest-gen/src/Rest/Gen/Docs.hs
index efb0e89..a4b0ee5 100644
--- a/rest-gen/src/Rest/Gen/Docs.hs
+++ b/rest-gen/src/Rest/Gen/Docs.hs
@@ -47,14 +47,16 @@ data DocsContext = DocsContext
   { rootUrl        :: String
   , contextVersion :: Version
   , templates      :: String
+  , targetDir      :: FilePath
+  , sourceDir      :: Maybe FilePath
   } deriving (Eq, Show)
 
-writeDocs :: DocsContext -> Router m s -> String -> IO ()
-writeDocs context router loc =
-  do createDirectoryIfMissing True loc
-     let tree = apiSubtrees router
-     mkAllResources context tree >>= writeFile (loc </> "index.html")
-     mapM_ (writeSingleResource context loc) $ allSubResources tree
+writeDocs :: DocsContext -> Router m s -> IO ()
+writeDocs context router = do
+  setupTargetDir (sourceDir context) (targetDir context)
+  let tree = apiSubtrees router
+  mkAllResources context tree >>= writeFile (targetDir context </> "index.html")
+  mapM_ (writeSingleResource context (targetDir context)) $ allSubResources tree
 
 writeSingleResource :: DocsContext -> String -> ApiResource -> IO ()
 writeSingleResource ctx loc r =
diff --git a/rest-gen/src/Rest/Gen/Haskell.hs b/rest-gen/src/Rest/Gen/Haskell.hs
index e38be71..924d162 100644
--- a/rest-gen/src/Rest/Gen/Haskell.hs
+++ b/rest-gen/src/Rest/Gen/Haskell.hs
@@ -55,13 +55,15 @@ data HaskellContext =
     , imports        :: [H.ImportDecl]
     , rewrites       :: [(H.ModuleName, H.ModuleName)]
     , namespace      :: [String]
+    , sourceDir      :: Maybe FilePath
     }
 
 mkHsApi :: HaskellContext -> Router m s -> IO ()
-mkHsApi ctx r =
-  do let tree = sortTree . (if includePrivate ctx then id else noPrivate) . apiSubtrees $ r
-     mkCabalFile ctx tree
-     mapM_ (writeRes ctx) $ allSubTrees tree
+mkHsApi ctx r = do
+  setupTargetDir (sourceDir ctx) (targetPath ctx)
+  let tree = sortTree . (if includePrivate ctx then id else noPrivate) . apiSubtrees $ r
+  mkCabalFile ctx tree
+  mapM_ (writeRes ctx) $ allSubTrees tree
 
 mkCabalFile :: HaskellContext -> ApiResource -> IO ()
 mkCabalFile ctx tree =
diff --git a/rest-gen/src/Rest/Gen/JavaScript.hs b/rest-gen/src/Rest/Gen/JavaScript.hs
index 0268589..fff0c8b 100644
--- a/rest-gen/src/Rest/Gen/JavaScript.hs
+++ b/rest-gen/src/Rest/Gen/JavaScript.hs
@@ -1,4 +1,7 @@
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE
+    ScopedTypeVariables
+  , ViewPatterns
+  #-}
 module Rest.Gen.JavaScript (mkJsApi) where
 
 import Prelude hiding ((.))
@@ -7,9 +10,8 @@ import Control.Category ((.))
 import Control.Monad
 import Data.Maybe
 import Text.StringTemplate
-import qualified Data.Label.Total             as L
-import qualified Data.List.NonEmpty           as NList
-import qualified Language.Haskell.Exts.Syntax as H
+import qualified Data.Label.Total   as L
+import qualified Data.List.NonEmpty as NList
 
 import Code.Build
 import Code.Build.JavaScript
@@ -18,15 +20,16 @@ import Rest.Gen.Base
 import Rest.Gen.Types
 import Rest.Gen.Utils
 
-mkJsApi :: H.ModuleName -> Bool -> Version -> Router m s -> IO String
-mkJsApi ns priv ver r =
+mkJsApi :: ModuleName -> Bool -> Version -> Router m s -> IO String
+mkJsApi (overModuleName (++ "Api") -> ns) priv ver r =
   do prelude <- liftM (render . setManyAttrib attrs . newSTMP) (readContent "Javascript/base.js")
      let cod = showCode $ mkStack
                 [ unModuleName ns ++ ".prototype.version" .=. string (show ver)
                 , mkJsCode (unModuleName ns) priv r
                 ]
      return $ mkJsModule (prelude ++ cod)
-  where attrs = [("apinamespace", unModuleName ns), ("dollar", "$")]
+  where
+    attrs = [("apinamespace", unModuleName ns), ("dollar", "$")]
 
 mkJsModule :: String -> String
 mkJsModule content = "(function (window) {\n\n" ++ content ++ "\n\n})(this);"
diff --git a/rest-gen/src/Rest/Gen/Ruby.hs b/rest-gen/src/Rest/Gen/Ruby.hs
index 99f8935..f0dbaf3 100644
--- a/rest-gen/src/Rest/Gen/Ruby.hs
+++ b/rest-gen/src/Rest/Gen/Ruby.hs
@@ -1,4 +1,7 @@
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE
+    ScopedTypeVariables
+  , ViewPatterns
+  #-}
 module Rest.Gen.Ruby (mkRbApi) where
 
 import Prelude hiding ((.))
@@ -8,9 +11,8 @@ import Data.Char
 import Data.List
 import Data.List.Split (splitOn)
 import Data.Maybe
-import qualified Data.Label.Total             as L
-import qualified Data.List.NonEmpty           as NList
-import qualified Language.Haskell.Exts.Syntax as H
+import qualified Data.Label.Total   as L
+import qualified Data.List.NonEmpty as NList
 
 import Code.Build
 import Code.Build.Ruby
@@ -19,8 +21,8 @@ import Rest.Gen.Base
 import Rest.Gen.Types
 import Rest.Gen.Utils
 
-mkRbApi :: H.ModuleName -> Bool -> Version -> Router m s -> IO String
-mkRbApi ns priv ver r =
+mkRbApi :: ModuleName -> Bool -> Version -> Router m s -> IO String
+mkRbApi (overModuleName (++ "Api") -> ns) priv ver r =
   do rawPrelude <- readContent "Ruby/base.rb"
      let prelude = replace "SilkApi" (unModuleName ns) rawPrelude
      let cod = showCode . mkRb (unModuleName ns) ver . sortTree . (if priv then id else noPrivate) . apiSubtrees $ r
diff --git a/rest-gen/src/Rest/Gen/Utils.hs b/rest-gen/src/Rest/Gen/Utils.hs
index f5daeb3..dbd7ab8 100644
--- a/rest-gen/src/Rest/Gen/Utils.hs
+++ b/rest-gen/src/Rest/Gen/Utils.hs
@@ -7,9 +7,18 @@ module Rest.Gen.Utils
   , upFirst
   , downFirst
   , mapHead
+  , setupTargetDir
   ) where
 
+import Prelude hiding (foldr)
+
 import Data.Char
+import Data.Foldable
+import Data.List.Split
+import System.Directory
+import System.FilePath
+import System.Process
+import Text.StringTemplate
 
 import Paths_rest_gen (getDataFileName)
 
@@ -41,3 +50,8 @@ downFirst = mapHead toLower
 mapHead :: (a -> a) -> [a] -> [a]
 mapHead _ [] = []
 mapHead f (x : xs) = f x : xs
+
+setupTargetDir :: Maybe FilePath -> FilePath -> IO ()
+setupTargetDir msource targetDir = do
+  createDirectoryIfMissing True targetDir
+  forM_ msource $ \source -> system $ "cp -rf " ++ source ++ " " ++ targetDir

From d884a5d5f8f49117517b731efd1297b9944efc43 Mon Sep 17 00:00:00 2001
From: Adam Bergmark <adam@bergmark.nl>
Date: Tue, 16 Jun 2015 18:25:48 +0200
Subject: [PATCH 4/9] rest-gen: Abstract `generate' into an inner function
 `runGenerate' which returns the result of generation but doesn't exit the
 program

---
 rest-gen/src/Rest/Gen.hs            | 85 ++++++++++++++++++++---------
 rest-gen/src/Rest/Gen/JavaScript.hs |  6 +-
 rest-gen/src/Rest/Gen/Ruby.hs       |  6 +-
 3 files changed, 61 insertions(+), 36 deletions(-)

diff --git a/rest-gen/src/Rest/Gen.hs b/rest-gen/src/Rest/Gen.hs
index 9d1145e..a4ce4d1 100644
--- a/rest-gen/src/Rest/Gen.hs
+++ b/rest-gen/src/Rest/Gen.hs
@@ -1,4 +1,13 @@
-module Rest.Gen (generate) where
+module Rest.Gen
+  ( generate
+  , runGenerate
+  , generateDocs
+  , generateHaskell
+  , generateJavaScript
+  , generateRuby
+  , GenerateError (..)
+  , Result (..)
+  ) where
 
 import Data.Char
 import Data.Label
@@ -17,23 +26,53 @@ import Rest.Gen.Utils
 import qualified Rest.Gen.Docs    as DCtx (DocsContext (..))
 import qualified Rest.Gen.Haskell as HCtx (HaskellContext (..))
 
+data GenerateError
+  = CouldNotFindApiVersion
+  | NoOp
+  deriving (Eq, Show)
+
+data Result
+  = Error GenerateError
+  | StdOut String
+  | FileOut FilePath
+  deriving (Eq, Show)
+
 generate :: Config -> String -> Api m -> [ModuleName] -> [ImportDecl] -> [(ModuleName, ModuleName)] -> IO ()
-generate config name api sources imports rewrites =
-  withVersion (get apiVersion config) api (putStrLn "Could not find api version" >> exitFailure) $ \ver (Some1 r) ->
-     case get action config of
-       Just (MakeDocs root) -> makeDocs config ver r root >> exitSuccess
-       Just MakeJS          -> makeJS config ver r moduleName
-       Just MakeRb          -> makeRb config ver r moduleName
-       Just MakeHS          -> makeHS config ver r moduleName packageName sources imports rewrites >> exitSuccess
-       Nothing              -> return ()
+generate config name api sources imports rewrites = do
+  res <- runGenerate config name api sources imports rewrites
+  case res of
+    Error _err -> exitFailure
+    _          -> exitSuccess
+
+runGenerate :: Config -> String -> Api m -> [ModuleName] -> [ImportDecl] -> [(ModuleName, ModuleName)] -> IO Result
+runGenerate config name api sources imports rewrites =
+  withVersion (get apiVersion config) api (return $ Error CouldNotFindApiVersion) m
   where
+    m :: Version -> Some1 (Router m) -> IO Result
+    m ver (Some1 r) = case get action config of
+      Just (MakeDocs root) -> generateDocs       config ver r root
+      Just MakeJS          -> generateJavaScript config ver r moduleName
+      Just MakeRb          -> generateRuby       config ver r moduleName
+      Just MakeHS          -> generateHaskell    config ver r moduleName packageName sources imports rewrites
+      Nothing              -> return $ Error NoOp
     packageName = map toLower name
     moduleName  = ModuleName $ upFirst packageName
 
-makeDocs :: Config -> Version -> Router m s -> String -> IO ()
-makeDocs config ver r rootUrl = do
+generateJavaScript :: Config -> Version -> Router m s -> ModuleName -> IO Result
+generateJavaScript config ver r moduleName = do
+  file <- mkJsApi (overModuleName (++ "Api") moduleName) (get apiPrivate config) ver r
+  toTarget config file
+
+generateRuby ::  Config -> Version -> Router m s -> ModuleName -> IO Result
+generateRuby config ver r moduleName = do
+  file <- mkRbApi (overModuleName (++ "Api") moduleName) (get apiPrivate config) ver r
+  toTarget config file
+
+generateDocs :: Config -> Version -> Router m s -> String -> IO Result
+generateDocs config ver r rootUrl = do
   targetDir <- getTargetDir config "./docs"
   writeDocs (context targetDir) r
+  return $ FileOut targetDir
     where
       context targetDir = DocsContext
         { DCtx.rootUrl        = rootUrl
@@ -43,16 +82,11 @@ makeDocs config ver r rootUrl = do
         , DCtx.sourceDir      = getSourceLocation config
         }
 
-makeJS :: Config -> Version -> Router m s -> ModuleName -> IO ()
-makeJS config ver r moduleName = mkJsApi moduleName (get apiPrivate config) ver r >>= toTarget config
-
-makeRb ::  Config -> Version -> Router m s -> ModuleName -> IO ()
-makeRb config ver r moduleName = mkRbApi moduleName (get apiPrivate config) ver r >>= toTarget config
-
-makeHS :: Config -> Version -> Router m s -> ModuleName -> String -> [ModuleName] -> [ImportDecl] -> [(ModuleName, ModuleName)] -> IO ()
-makeHS config ver r moduleName packageName sources imports rewrites = do
+generateHaskell :: Config -> Version -> Router m s -> ModuleName -> String -> [ModuleName] -> [ImportDecl] -> [(ModuleName, ModuleName)] -> IO Result
+generateHaskell config ver r moduleName packageName sources imports rewrites = do
   targetPath <- getTargetDir config "./client"
   mkHsApi (context targetPath (getSourceLocation config)) r
+  return $ FileOut targetPath
   where
     context tp sourceDir = HaskellContext
       { HCtx.apiVersion     = ver
@@ -73,15 +107,14 @@ getTargetDir config str =
     Default    -> putStrLn ("Generating to " ++ str)                                      >> return str
     Location d -> putStrLn ("Generating to " ++ d)                                        >> return d
 
-toTarget :: Config -> String -> IO ()
+toTarget :: Config -> String -> IO Result
 toTarget config code = do
-   outf code
-   exitSuccess
+  outf code
   where
-    outf = case get target config of
-      Stream     -> putStrLn
-      Default    -> putStrLn
-      Location l -> writeFile l
+    outf cd = case get target config of
+      Stream     -> putStrLn cd    >> return (StdOut cd)
+      Default    -> putStrLn cd    >> return (StdOut cd)
+      Location l -> writeFile l cd >> return (FileOut l)
 
 getSourceLocation :: Config -> Maybe String
 getSourceLocation config =
diff --git a/rest-gen/src/Rest/Gen/JavaScript.hs b/rest-gen/src/Rest/Gen/JavaScript.hs
index fff0c8b..a3538b3 100644
--- a/rest-gen/src/Rest/Gen/JavaScript.hs
+++ b/rest-gen/src/Rest/Gen/JavaScript.hs
@@ -1,7 +1,3 @@
-{-# LANGUAGE
-    ScopedTypeVariables
-  , ViewPatterns
-  #-}
 module Rest.Gen.JavaScript (mkJsApi) where
 
 import Prelude hiding ((.))
@@ -21,7 +17,7 @@ import Rest.Gen.Types
 import Rest.Gen.Utils
 
 mkJsApi :: ModuleName -> Bool -> Version -> Router m s -> IO String
-mkJsApi (overModuleName (++ "Api") -> ns) priv ver r =
+mkJsApi ns priv ver r =
   do prelude <- liftM (render . setManyAttrib attrs . newSTMP) (readContent "Javascript/base.js")
      let cod = showCode $ mkStack
                 [ unModuleName ns ++ ".prototype.version" .=. string (show ver)
diff --git a/rest-gen/src/Rest/Gen/Ruby.hs b/rest-gen/src/Rest/Gen/Ruby.hs
index f0dbaf3..a55220f 100644
--- a/rest-gen/src/Rest/Gen/Ruby.hs
+++ b/rest-gen/src/Rest/Gen/Ruby.hs
@@ -1,7 +1,3 @@
-{-# LANGUAGE
-    ScopedTypeVariables
-  , ViewPatterns
-  #-}
 module Rest.Gen.Ruby (mkRbApi) where
 
 import Prelude hiding ((.))
@@ -22,7 +18,7 @@ import Rest.Gen.Types
 import Rest.Gen.Utils
 
 mkRbApi :: ModuleName -> Bool -> Version -> Router m s -> IO String
-mkRbApi (overModuleName (++ "Api") -> ns) priv ver r =
+mkRbApi ns priv ver r =
   do rawPrelude <- readContent "Ruby/base.rb"
      let prelude = replace "SilkApi" (unModuleName ns) rawPrelude
      let cod = showCode . mkRb (unModuleName ns) ver . sortTree . (if priv then id else noPrivate) . apiSubtrees $ r

From e640201783e69358531511c2d5fe485433a078dd Mon Sep 17 00:00:00 2001
From: Adam Bergmark <adam@bergmark.nl>
Date: Sun, 21 Jun 2015 06:22:51 +0200
Subject: [PATCH 5/9] Add a function for postprocessing files before writing
 the result

---
 rest-gen/src/Rest/Gen.hs         | 55 +++++++++++++++++++-------------
 rest-gen/src/Rest/Gen/Docs.hs    | 31 ++++++++++--------
 rest-gen/src/Rest/Gen/Haskell.hs | 15 +++++----
 3 files changed, 58 insertions(+), 43 deletions(-)

diff --git a/rest-gen/src/Rest/Gen.hs b/rest-gen/src/Rest/Gen.hs
index a4ce4d1..951c4d4 100644
--- a/rest-gen/src/Rest/Gen.hs
+++ b/rest-gen/src/Rest/Gen.hs
@@ -13,6 +13,7 @@ import Data.Char
 import Data.Label
 import Data.Maybe
 import System.Exit
+import System.IO (hPutStrLn, stderr)
 
 import Rest.Api (Api, Router, Some1 (..), Version, withVersion)
 
@@ -37,41 +38,51 @@ data Result
   | FileOut FilePath
   deriving (Eq, Show)
 
-generate :: Config -> String -> Api m -> [ModuleName] -> [ImportDecl] -> [(ModuleName, ModuleName)] -> IO ()
-generate config name api sources imports rewrites = do
-  res <- runGenerate config name api sources imports rewrites
+data FileType
+  = HaskellFile
+  | JavaScriptFile
+  | RubyFile
+  | HtmlFile
+
+generate :: Config -> String -> Api m -> [ModuleName] -> [ImportDecl] -> [(ModuleName, ModuleName)] -> (FileType -> String -> IO String) -> IO ()
+generate config name api sources imports rewrites postProc = do
+  res <- runGenerate config name api sources imports rewrites postProc
   case res of
-    Error _err -> exitFailure
+    Error err -> do
+      case err of
+        CouldNotFindApiVersion -> hPutStrLn stderr "Could not find specified API version"
+        NoOp                   -> hPutStrLn stderr "Nothing to do"
+      exitFailure
     _          -> exitSuccess
 
-runGenerate :: Config -> String -> Api m -> [ModuleName] -> [ImportDecl] -> [(ModuleName, ModuleName)] -> IO Result
-runGenerate config name api sources imports rewrites =
+runGenerate :: Config -> String -> Api m -> [ModuleName] -> [ImportDecl] -> [(ModuleName, ModuleName)] -> (FileType -> String -> IO String) -> IO Result
+runGenerate config name api sources imports rewrites postProc =
   withVersion (get apiVersion config) api (return $ Error CouldNotFindApiVersion) m
   where
     m :: Version -> Some1 (Router m) -> IO Result
     m ver (Some1 r) = case get action config of
-      Just (MakeDocs root) -> generateDocs       config ver r root
-      Just MakeJS          -> generateJavaScript config ver r moduleName
-      Just MakeRb          -> generateRuby       config ver r moduleName
-      Just MakeHS          -> generateHaskell    config ver r moduleName packageName sources imports rewrites
+      Just (MakeDocs root) -> generateDocs       config ver r postProc root
+      Just MakeJS          -> generateJavaScript config ver r postProc moduleName
+      Just MakeRb          -> generateRuby       config ver r postProc moduleName
+      Just MakeHS          -> generateHaskell    config ver r postProc moduleName packageName sources imports rewrites
       Nothing              -> return $ Error NoOp
     packageName = map toLower name
     moduleName  = ModuleName $ upFirst packageName
 
-generateJavaScript :: Config -> Version -> Router m s -> ModuleName -> IO Result
-generateJavaScript config ver r moduleName = do
-  file <- mkJsApi (overModuleName (++ "Api") moduleName) (get apiPrivate config) ver r
+generateJavaScript :: Config -> Version -> Router m s -> (FileType -> String -> IO String) -> ModuleName -> IO Result
+generateJavaScript config ver r postProc moduleName = do
+  file <- postProc JavaScriptFile =<< mkJsApi (overModuleName (++ "Api") moduleName) (get apiPrivate config) ver r
   toTarget config file
 
-generateRuby ::  Config -> Version -> Router m s -> ModuleName -> IO Result
-generateRuby config ver r moduleName = do
-  file <- mkRbApi (overModuleName (++ "Api") moduleName) (get apiPrivate config) ver r
+generateRuby ::  Config -> Version -> Router m s -> (FileType -> String -> IO String) -> ModuleName -> IO Result
+generateRuby config ver r postProc moduleName = do
+  file <- postProc RubyFile =<< mkRbApi (overModuleName (++ "Api") moduleName) (get apiPrivate config) ver r
   toTarget config file
 
-generateDocs :: Config -> Version -> Router m s -> String -> IO Result
-generateDocs config ver r rootUrl = do
+generateDocs :: Config -> Version -> Router m s -> (FileType -> String -> IO String) -> String -> IO Result
+generateDocs config ver r postProc rootUrl = do
   targetDir <- getTargetDir config "./docs"
-  writeDocs (context targetDir) r
+  writeDocs (context targetDir) (postProc HtmlFile) r
   return $ FileOut targetDir
     where
       context targetDir = DocsContext
@@ -82,10 +93,10 @@ generateDocs config ver r rootUrl = do
         , DCtx.sourceDir      = getSourceLocation config
         }
 
-generateHaskell :: Config -> Version -> Router m s -> ModuleName -> String -> [ModuleName] -> [ImportDecl] -> [(ModuleName, ModuleName)] -> IO Result
-generateHaskell config ver r moduleName packageName sources imports rewrites = do
+generateHaskell :: Config -> Version -> Router m s -> (FileType -> String -> IO String) -> ModuleName -> String -> [ModuleName] -> [ImportDecl] -> [(ModuleName, ModuleName)] -> IO Result
+generateHaskell config ver r postProc moduleName packageName sources imports rewrites = do
   targetPath <- getTargetDir config "./client"
-  mkHsApi (context targetPath (getSourceLocation config)) r
+  mkHsApi (context targetPath (getSourceLocation config)) (postProc HaskellFile) r
   return $ FileOut targetPath
   where
     context tp sourceDir = HaskellContext
diff --git a/rest-gen/src/Rest/Gen/Docs.hs b/rest-gen/src/Rest/Gen/Docs.hs
index a4b0ee5..f3d2ee1 100644
--- a/rest-gen/src/Rest/Gen/Docs.hs
+++ b/rest-gen/src/Rest/Gen/Docs.hs
@@ -31,9 +31,8 @@ import Data.List hiding (head, span)
 import Data.String
 import System.Directory
 import System.FilePath
-import Text.Blaze.Html
-import Text.Blaze.Html5 hiding (map, meta, style)
-import Text.Blaze.Html5.Attributes hiding (method, span, title)
+import Text.Blaze.Html5 hiding (contents, map, meta, style)
+import Text.Blaze.Html5.Attributes hiding (dir, method, span, title)
 import Text.Blaze.Html.Renderer.String
 import Text.StringTemplate
 import qualified Data.Label.Total as L
@@ -51,18 +50,22 @@ data DocsContext = DocsContext
   , sourceDir      :: Maybe FilePath
   } deriving (Eq, Show)
 
-writeDocs :: DocsContext -> Router m s -> IO ()
-writeDocs context router = do
-  setupTargetDir (sourceDir context) (targetDir context)
+writeDocs :: DocsContext -> (String -> IO String) -> Router m s -> IO ()
+writeDocs ctx postProc router = do
+  setupTargetDir (sourceDir ctx) (targetDir ctx)
   let tree = apiSubtrees router
-  mkAllResources context tree >>= writeFile (targetDir context </> "index.html")
-  mapM_ (writeSingleResource context (targetDir context)) $ allSubResources tree
-
-writeSingleResource :: DocsContext -> String -> ApiResource -> IO ()
-writeSingleResource ctx loc r =
-  do let dr = loc </> intercalate "/" (resId r)
-     createDirectoryIfMissing True dr
-     mkSingleResource ctx r >>= writeFile (dr </> "index.html")
+  mkAllResources ctx tree >>= postProc >>= writeIndex (targetDir ctx)
+  forM_ (allSubResources tree) $ writeSingleResource ctx postProc
+
+writeSingleResource :: DocsContext -> (String -> IO String) -> ApiResource -> IO ()
+writeSingleResource ctx postProc r = do
+  let dir = targetDir ctx </> intercalate "/" (resId r)
+  mkSingleResource ctx r >>= postProc >>= writeIndex dir
+
+writeIndex :: FilePath -> String -> IO ()
+writeIndex dir contents = do
+  createDirectoryIfMissing True dir
+  writeFile (dir </> "index.html") contents
 
 mkAllResources :: DocsContext -> ApiResource -> IO String
 mkAllResources ctx tree =
diff --git a/rest-gen/src/Rest/Gen/Haskell.hs b/rest-gen/src/Rest/Gen/Haskell.hs
index 924d162..d910f58 100644
--- a/rest-gen/src/Rest/Gen/Haskell.hs
+++ b/rest-gen/src/Rest/Gen/Haskell.hs
@@ -58,12 +58,12 @@ data HaskellContext =
     , sourceDir      :: Maybe FilePath
     }
 
-mkHsApi :: HaskellContext -> Router m s -> IO ()
-mkHsApi ctx r = do
+mkHsApi :: HaskellContext -> (String -> IO String) -> Router m s -> IO ()
+mkHsApi ctx postProc r = do
   setupTargetDir (sourceDir ctx) (targetPath ctx)
   let tree = sortTree . (if includePrivate ctx then id else noPrivate) . apiSubtrees $ r
   mkCabalFile ctx tree
-  mapM_ (writeRes ctx) $ allSubTrees tree
+  mapM_ (writeRes ctx postProc) $ allSubTrees tree
 
 mkCabalFile :: HaskellContext -> ApiResource -> IO ()
 mkCabalFile ctx tree =
@@ -112,10 +112,11 @@ cabalLibrary mods = Cabal.Library mods [] [] [] True Cabal.emptyBuildInfo { Caba
 cabalLibrary mods = Cabal.Library mods True Cabal.emptyBuildInfo { Cabal.hsSourceDirs = ["src"] }
 #endif
 
-writeRes :: HaskellContext -> ApiResource -> IO ()
-writeRes ctx node =
-  do createDirectoryIfMissing True (targetPath ctx </> "src" </> modPath (namespace ctx ++ resParents node))
-     writeFile (targetPath ctx </> "src" </> modPath (namespace ctx ++ resId node) ++ ".hs") (mkRes ctx node)
+writeRes :: HaskellContext -> (String -> IO String) -> ApiResource -> IO ()
+writeRes ctx postProc node = do
+  createDirectoryIfMissing True (targetPath ctx </> "src" </> modPath (namespace ctx ++ resParents node))
+  contents <- postProc $ mkRes ctx node
+  writeFile (targetPath ctx </> "src" </> modPath (namespace ctx ++ resId node) ++ ".hs") contents
 
 mkRes :: HaskellContext -> ApiResource -> String
 mkRes ctx node = H.prettyPrint $ buildHaskellModule ctx node pragmas Nothing

From 0376aacf0b4065b4436fa2e8421d837e975936aa Mon Sep 17 00:00:00 2001
From: Adam Bergmark <adam@bergmark.nl>
Date: Wed, 24 Jun 2015 12:32:13 +0200
Subject: [PATCH 6/9] Partially apply post processing function as early as
 possible

---
 rest-gen/src/Rest/Gen.hs | 24 ++++++++++++------------
 1 file changed, 12 insertions(+), 12 deletions(-)

diff --git a/rest-gen/src/Rest/Gen.hs b/rest-gen/src/Rest/Gen.hs
index 951c4d4..3e84577 100644
--- a/rest-gen/src/Rest/Gen.hs
+++ b/rest-gen/src/Rest/Gen.hs
@@ -61,28 +61,28 @@ runGenerate config name api sources imports rewrites postProc =
   where
     m :: Version -> Some1 (Router m) -> IO Result
     m ver (Some1 r) = case get action config of
-      Just (MakeDocs root) -> generateDocs       config ver r postProc root
-      Just MakeJS          -> generateJavaScript config ver r postProc moduleName
-      Just MakeRb          -> generateRuby       config ver r postProc moduleName
-      Just MakeHS          -> generateHaskell    config ver r postProc moduleName packageName sources imports rewrites
+      Just (MakeDocs root) -> generateDocs       config ver r (postProc HtmlFile      ) root
+      Just MakeJS          -> generateJavaScript config ver r (postProc JavaScriptFile) moduleName
+      Just MakeRb          -> generateRuby       config ver r (postProc RubyFile      ) moduleName
+      Just MakeHS          -> generateHaskell    config ver r (postProc HaskellFile   ) moduleName packageName sources imports rewrites
       Nothing              -> return $ Error NoOp
     packageName = map toLower name
     moduleName  = ModuleName $ upFirst packageName
 
-generateJavaScript :: Config -> Version -> Router m s -> (FileType -> String -> IO String) -> ModuleName -> IO Result
+generateJavaScript :: Config -> Version -> Router m s -> (String -> IO String) -> ModuleName -> IO Result
 generateJavaScript config ver r postProc moduleName = do
-  file <- postProc JavaScriptFile =<< mkJsApi (overModuleName (++ "Api") moduleName) (get apiPrivate config) ver r
+  file <- postProc =<< mkJsApi (overModuleName (++ "Api") moduleName) (get apiPrivate config) ver r
   toTarget config file
 
-generateRuby ::  Config -> Version -> Router m s -> (FileType -> String -> IO String) -> ModuleName -> IO Result
+generateRuby ::  Config -> Version -> Router m s -> (String -> IO String) -> ModuleName -> IO Result
 generateRuby config ver r postProc moduleName = do
-  file <- postProc RubyFile =<< mkRbApi (overModuleName (++ "Api") moduleName) (get apiPrivate config) ver r
+  file <- postProc =<< mkRbApi (overModuleName (++ "Api") moduleName) (get apiPrivate config) ver r
   toTarget config file
 
-generateDocs :: Config -> Version -> Router m s -> (FileType -> String -> IO String) -> String -> IO Result
+generateDocs :: Config -> Version -> Router m s -> (String -> IO String) -> String -> IO Result
 generateDocs config ver r postProc rootUrl = do
   targetDir <- getTargetDir config "./docs"
-  writeDocs (context targetDir) (postProc HtmlFile) r
+  writeDocs (context targetDir) postProc r
   return $ FileOut targetDir
     where
       context targetDir = DocsContext
@@ -93,10 +93,10 @@ generateDocs config ver r postProc rootUrl = do
         , DCtx.sourceDir      = getSourceLocation config
         }
 
-generateHaskell :: Config -> Version -> Router m s -> (FileType -> String -> IO String) -> ModuleName -> String -> [ModuleName] -> [ImportDecl] -> [(ModuleName, ModuleName)] -> IO Result
+generateHaskell :: Config -> Version -> Router m s -> (String -> IO String) -> ModuleName -> String -> [ModuleName] -> [ImportDecl] -> [(ModuleName, ModuleName)] -> IO Result
 generateHaskell config ver r postProc moduleName packageName sources imports rewrites = do
   targetPath <- getTargetDir config "./client"
-  mkHsApi (context targetPath (getSourceLocation config)) (postProc HaskellFile) r
+  mkHsApi (context targetPath (getSourceLocation config)) postProc r
   return $ FileOut targetPath
   where
     context tp sourceDir = HaskellContext

From 407026a0347bea6ae74fe3e675acc9eb3320391c Mon Sep 17 00:00:00 2001
From: Adam Bergmark <adam@bergmark.nl>
Date: Sat, 27 Jun 2015 20:12:50 +0200
Subject: [PATCH 7/9] Remove source and target from DocsContext, and add
 test-case for text/json accept header.

Conflicts:
	rest-gen/src/Rest/Gen.hs
---
 rest-core/tests/Runner.hs                      |  7 +++++++
 rest-example/generate/Main.hs                  |  1 +
 rest-gen/src/Rest/Gen.hs                       |  6 ++----
 rest-gen/src/Rest/Gen/Docs.hs                  | 18 ++++++++----------
 rest-gen/src/Rest/Gen/Utils.hs                 |  3 ---
 .../src/Rest/Driver/Happstack/Docs.hs          | 14 ++++++++++----
 6 files changed, 28 insertions(+), 21 deletions(-)

diff --git a/rest-core/tests/Runner.hs b/rest-core/tests/Runner.hs
index 6f1a2cc..9b5b043 100644
--- a/rest-core/tests/Runner.hs
+++ b/rest-core/tests/Runner.hs
@@ -2,6 +2,7 @@
     OverloadedStrings
   , ScopedTypeVariables
   #-}
+module Main (main) where
 
 import Control.Applicative
 import Control.Monad
@@ -44,6 +45,7 @@ main = do
               , testCase "Multi-PUT." testMultiPut
               , testCase "Multi-POST" testMultiPost
               , testCase "Accept headers." testAcceptHeaders
+              , testCase "text/json accept header" testTextJsonHeader
               ]
 
 testListing :: Assertion
@@ -208,3 +210,8 @@ testAcceptHeaders :: Assertion
 testAcceptHeaders =
   do fmt <- runRestM_ RestM.emptyInput { RestM.headers = H.singleton "Accept" "application/json" } accept
      assertEqual "Accept json format." [JsonFormat] fmt
+
+testTextJsonHeader :: Assertion
+testTextJsonHeader =
+  do fmt <- runRestM_ RestM.emptyInput { RestM.headers = H.singleton "Accept" "application/json" } accept
+     assertEqual "Accept json format." [JsonFormat] fmt
diff --git a/rest-example/generate/Main.hs b/rest-example/generate/Main.hs
index 230cd0e..5d95f25 100644
--- a/rest-example/generate/Main.hs
+++ b/rest-example/generate/Main.hs
@@ -19,3 +19,4 @@ main = do
     -- these are re-exported from an internal module they can be
     -- rewritten to something more stable.
     [(ModuleName "Data.Text.Internal", ModuleName "Data.Text")]
+    (const return)
diff --git a/rest-gen/src/Rest/Gen.hs b/rest-gen/src/Rest/Gen.hs
index 3e84577..3578ef8 100644
--- a/rest-gen/src/Rest/Gen.hs
+++ b/rest-gen/src/Rest/Gen.hs
@@ -82,15 +82,13 @@ generateRuby config ver r postProc moduleName = do
 generateDocs :: Config -> Version -> Router m s -> (String -> IO String) -> String -> IO Result
 generateDocs config ver r postProc rootUrl = do
   targetDir <- getTargetDir config "./docs"
-  writeDocs (context targetDir) postProc r
+  writeDocs (getSourceLocation config) targetDir context postProc r
   return $ FileOut targetDir
     where
-      context targetDir = DocsContext
+      context = DocsContext
         { DCtx.rootUrl        = rootUrl
         , DCtx.contextVersion = ver
         , DCtx.templates      = "./templates" `fromMaybe` getSourceLocation config
-        , DCtx.targetDir      = targetDir
-        , DCtx.sourceDir      = getSourceLocation config
         }
 
 generateHaskell :: Config -> Version -> Router m s -> (String -> IO String) -> ModuleName -> String -> [ModuleName] -> [ImportDecl] -> [(ModuleName, ModuleName)] -> IO Result
diff --git a/rest-gen/src/Rest/Gen/Docs.hs b/rest-gen/src/Rest/Gen/Docs.hs
index f3d2ee1..2fef60f 100644
--- a/rest-gen/src/Rest/Gen/Docs.hs
+++ b/rest-gen/src/Rest/Gen/Docs.hs
@@ -46,20 +46,18 @@ data DocsContext = DocsContext
   { rootUrl        :: String
   , contextVersion :: Version
   , templates      :: String
-  , targetDir      :: FilePath
-  , sourceDir      :: Maybe FilePath
   } deriving (Eq, Show)
 
-writeDocs :: DocsContext -> (String -> IO String) -> Router m s -> IO ()
-writeDocs ctx postProc router = do
-  setupTargetDir (sourceDir ctx) (targetDir ctx)
+writeDocs :: Maybe FilePath -> FilePath -> DocsContext -> (String -> IO String) -> Router m s -> IO ()
+writeDocs sourceDir targetDir ctx postProc router = do
+  setupTargetDir sourceDir targetDir
   let tree = apiSubtrees router
-  mkAllResources ctx tree >>= postProc >>= writeIndex (targetDir ctx)
-  forM_ (allSubResources tree) $ writeSingleResource ctx postProc
+  mkAllResources ctx tree >>= postProc >>= writeIndex targetDir
+  forM_ (allSubResources tree) $ writeSingleResource targetDir ctx postProc
 
-writeSingleResource :: DocsContext -> (String -> IO String) -> ApiResource -> IO ()
-writeSingleResource ctx postProc r = do
-  let dir = targetDir ctx </> intercalate "/" (resId r)
+writeSingleResource :: FilePath -> DocsContext -> (String -> IO String) -> ApiResource -> IO ()
+writeSingleResource targetDir ctx postProc r = do
+  let dir = targetDir </> intercalate "/" (resId r)
   mkSingleResource ctx r >>= postProc >>= writeIndex dir
 
 writeIndex :: FilePath -> String -> IO ()
diff --git a/rest-gen/src/Rest/Gen/Utils.hs b/rest-gen/src/Rest/Gen/Utils.hs
index dbd7ab8..36bdc2e 100644
--- a/rest-gen/src/Rest/Gen/Utils.hs
+++ b/rest-gen/src/Rest/Gen/Utils.hs
@@ -14,11 +14,8 @@ import Prelude hiding (foldr)
 
 import Data.Char
 import Data.Foldable
-import Data.List.Split
 import System.Directory
-import System.FilePath
 import System.Process
-import Text.StringTemplate
 
 import Paths_rest_gen (getDataFileName)
 
diff --git a/rest-happstack/src/Rest/Driver/Happstack/Docs.hs b/rest-happstack/src/Rest/Driver/Happstack/Docs.hs
index 3e74dc6..ff17e0b 100644
--- a/rest-happstack/src/Rest/Driver/Happstack/Docs.hs
+++ b/rest-happstack/src/Rest/Driver/Happstack/Docs.hs
@@ -5,15 +5,21 @@ import Control.Monad
 import Control.Monad.Trans
 import Happstack.Server
 import Rest.Api
+
 import Rest.Gen.Base
 import Rest.Gen.Docs
 
 -- | Web interface for documentation
 apiDocsHandler :: (ServerMonad m, MonadPlus m, FilterMonad Response m, MonadIO m) => String -> String -> Api a -> m Response
-apiDocsHandler rootURL tmpls api =
-  let mkCtx v ct = DocsContext (rootURL ++ ct ++ "/") v tmpls
-      serve ctx = serveDocs ctx . sortTree . noPrivate . (\(Some1 r) -> apiSubtrees r)
-  in path $ \i -> withVersion i api mzero $ \v -> serve (mkCtx v i)
+apiDocsHandler rootURL tmpls api = path $ \i -> withVersion i api mzero $ \v -> serve (mkCtx v i)
+  where
+    mkCtx :: Version -> String -> DocsContext
+    mkCtx v ct = DocsContext
+      { rootUrl         = rootURL ++ ct ++ "/"
+      , contextVersion  = v
+      , templates       = tmpls
+      }
+    serve ctx = serveDocs ctx . sortTree . noPrivate . (\(Some1 r) -> apiSubtrees r)
 
 serveDocs :: (ServerMonad m, MonadPlus m, FilterMonad Response m, MonadIO m) => DocsContext -> ApiResource -> m Response
 serveDocs ctx tree =

From 8286ef13ef22dde4430ce8a07ebedd6da2139036 Mon Sep 17 00:00:00 2001
From: Adam Bergmark <adam@bergmark.nl>
Date: Tue, 30 Jun 2015 11:59:09 +0200
Subject: [PATCH 8/9] Undo changes to Happstack.Docs.apiDocsHandler, nothing
 changed there

---
 rest-happstack/src/Rest/Driver/Happstack/Docs.hs | 14 ++++----------
 1 file changed, 4 insertions(+), 10 deletions(-)

diff --git a/rest-happstack/src/Rest/Driver/Happstack/Docs.hs b/rest-happstack/src/Rest/Driver/Happstack/Docs.hs
index ff17e0b..3e74dc6 100644
--- a/rest-happstack/src/Rest/Driver/Happstack/Docs.hs
+++ b/rest-happstack/src/Rest/Driver/Happstack/Docs.hs
@@ -5,21 +5,15 @@ import Control.Monad
 import Control.Monad.Trans
 import Happstack.Server
 import Rest.Api
-
 import Rest.Gen.Base
 import Rest.Gen.Docs
 
 -- | Web interface for documentation
 apiDocsHandler :: (ServerMonad m, MonadPlus m, FilterMonad Response m, MonadIO m) => String -> String -> Api a -> m Response
-apiDocsHandler rootURL tmpls api = path $ \i -> withVersion i api mzero $ \v -> serve (mkCtx v i)
-  where
-    mkCtx :: Version -> String -> DocsContext
-    mkCtx v ct = DocsContext
-      { rootUrl         = rootURL ++ ct ++ "/"
-      , contextVersion  = v
-      , templates       = tmpls
-      }
-    serve ctx = serveDocs ctx . sortTree . noPrivate . (\(Some1 r) -> apiSubtrees r)
+apiDocsHandler rootURL tmpls api =
+  let mkCtx v ct = DocsContext (rootURL ++ ct ++ "/") v tmpls
+      serve ctx = serveDocs ctx . sortTree . noPrivate . (\(Some1 r) -> apiSubtrees r)
+  in path $ \i -> withVersion i api mzero $ \v -> serve (mkCtx v i)
 
 serveDocs :: (ServerMonad m, MonadPlus m, FilterMonad Response m, MonadIO m) => DocsContext -> ApiResource -> m Response
 serveDocs ctx tree =

From fa9f853de3857be85dd61ff34f209f216858c4bb Mon Sep 17 00:00:00 2001
From: Adam Bergmark <adam@bergmark.nl>
Date: Tue, 30 Jun 2015 12:02:56 +0200
Subject: [PATCH 9/9] Change one of the accept header tests to use text/json,
 they were previously identical

---
 rest-core/tests/Runner.hs | 18 +++++++++---------
 1 file changed, 9 insertions(+), 9 deletions(-)

diff --git a/rest-core/tests/Runner.hs b/rest-core/tests/Runner.hs
index 9b5b043..42ae4e5 100644
--- a/rest-core/tests/Runner.hs
+++ b/rest-core/tests/Runner.hs
@@ -44,8 +44,8 @@ main = do
               , testCase "Root router is skipped." testRootRouter
               , testCase "Multi-PUT." testMultiPut
               , testCase "Multi-POST" testMultiPost
-              , testCase "Accept headers." testAcceptHeaders
-              , testCase "text/json accept header" testTextJsonHeader
+              , testCase "application/json accept header" testAppJsonAcceptHeader
+              , testCase "text/json accept header" testTextJsonAcceptHeader
               ]
 
 testListing :: Assertion
@@ -206,12 +206,12 @@ checkRouteSuccess method uri router =
 allMethods :: [Method]
 allMethods = [GET, PUT, POST, DELETE]
 
-testAcceptHeaders :: Assertion
-testAcceptHeaders =
+testAppJsonAcceptHeader :: Assertion
+testAppJsonAcceptHeader =
   do fmt <- runRestM_ RestM.emptyInput { RestM.headers = H.singleton "Accept" "application/json" } accept
-     assertEqual "Accept json format." [JsonFormat] fmt
+     assertEqual "Accept application/json format." [JsonFormat] fmt
 
-testTextJsonHeader :: Assertion
-testTextJsonHeader =
-  do fmt <- runRestM_ RestM.emptyInput { RestM.headers = H.singleton "Accept" "application/json" } accept
-     assertEqual "Accept json format." [JsonFormat] fmt
+testTextJsonAcceptHeader :: Assertion
+testTextJsonAcceptHeader =
+  do fmt <- runRestM_ RestM.emptyInput { RestM.headers = H.singleton "Accept" "text/json" } accept
+     assertEqual "Accept text/json format." [JsonFormat] fmt