module Rest.Gen.Haskell.Generate where
import Control.Applicative
import Control.Arrow (first)
import Control.Category
import Control.Monad
import Data.Label (mkLabels, modify, set)
import Data.List
import Data.Maybe
import Prelude hiding (id, (.))
import Safe
import System.Directory
import System.FilePath
import qualified Distribution.ModuleName as Cabal
import qualified Distribution.Package as Cabal
import qualified Distribution.PackageDescription as Cabal
import qualified Distribution.PackageDescription.Parse as Cabal
import qualified Distribution.PackageDescription.PrettyPrint as Cabal
import qualified Distribution.Simple.Utils as Cabal
import qualified Distribution.Verbosity as Cabal
import qualified Distribution.Version as Cabal
import Code.Build
import Code.Build.Haskell
import Rest.Api (Router, Version)
import Rest.Gen.Base
import Rest.Gen.Utils
import qualified Rest.Gen.Base.ActionInfo.Ident as Ident
$(mkLabels[''Cabal.GenericPackageDescription, ''Cabal.CondTree, ''Cabal.Library])
data HaskellContext =
HaskellContext
{ apiVersion :: Version
, targetPath :: String
, wrapperName :: String
, includePrivate :: Bool
, sources :: [String]
, imports :: [String]
, rewrites :: [(String, String)]
, namespace :: [String]
}
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
mkCabalFile :: HaskellContext -> ApiResource -> IO ()
mkCabalFile ctx tree =
do cabalExists <- doesFileExist cabalFile
gpkg <-
if cabalExists
then updateExposedModules modules <$> Cabal.readPackageDescription Cabal.normal cabalFile
else return (mkGenericPackageDescription (wrapperName ctx) modules)
writeCabalFile cabalFile gpkg
where
cabalFile = targetPath ctx </> wrapperName ctx ++ ".cabal"
modules = map Cabal.fromString (sources ctx)
++ map (Cabal.fromString . qualModName . (namespace ctx ++)) (allSubResourceIds tree)
writeCabalFile :: FilePath -> Cabal.GenericPackageDescription -> IO ()
writeCabalFile path = Cabal.writeUTF8File path . unlines . filter emptyField . lines . Cabal.showGenericPackageDescription
where emptyField = (/= "\"\" ") . takeWhile (/= ':') . reverse
updateExposedModules :: [Cabal.ModuleName] -> Cabal.GenericPackageDescription -> Cabal.GenericPackageDescription
updateExposedModules modules = modify lCondLibrary (Just . maybe (mkCondLibrary modules) (set (lExposedModules . lCondTreeData) modules))
mkGenericPackageDescription :: String -> [Cabal.ModuleName] -> Cabal.GenericPackageDescription
mkGenericPackageDescription name modules = Cabal.GenericPackageDescription pkg [] (Just (mkCondLibrary modules)) [] [] []
where
pkg = Cabal.emptyPackageDescription
{ Cabal.package = Cabal.PackageIdentifier (Cabal.PackageName name) (Cabal.Version [0, 1] [])
, Cabal.buildType = Just Cabal.Simple
, Cabal.specVersionRaw = Right (Cabal.orLaterVersion (Cabal.Version [1, 8] []))
}
mkCondLibrary :: [Cabal.ModuleName] -> Cabal.CondTree Cabal.ConfVar [Cabal.Dependency] Cabal.Library
mkCondLibrary modules = Cabal.CondNode
{ Cabal.condTreeData = Cabal.Library modules True Cabal.emptyBuildInfo
, Cabal.condTreeConstraints = []
, Cabal.condTreeComponents = []
}
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)
mkRes :: HaskellContext -> ApiResource -> String
mkRes ctx node =
showCode $
"{-# LANGUAGE OverloadedStrings #-}\n{-# OPTIONS_GHC -fno-warn-unused-imports #-}\n{- Warning!! This is automatically generated code, do not modify! -}"
<-> hsModule (qualModName $ namespace ctx ++ resId node)
[ mkImports ctx node rewrittenMods
, idData node
, mkStack funcs
]
where
(funcs, mods) = unzip $ map (mkFunction (apiVersion ctx) $ resName node) $ resItems node
rewrittenMods = rewriteModules (rewrites ctx) $ nub $ concat mods
mkImports :: HaskellContext -> ApiResource -> [String] -> Code
mkImports ctx node datImp =
mkStack
[ code "import Rest.Client.Internal"
, extraImports
, parentImports
, dataImports
]
where
extraImports = mkStack . map ("import " <+>) $ imports ctx
parentImports = mkStack . map mkImport . tail . inits . resParents $ node
dataImports = mkStack . map ("import qualified " <+>) $ datImp
mkImport p = "import qualified" <++> qualModName (namespace ctx ++ p) <++> "as" <++> modName (last p)
mkFunction :: Version -> String -> ApiAction -> (Code, [String])
mkFunction ver res (ApiAction _ lnk ai) =
let mInp = fmap inputInfo $ chooseType $ inputs ai
identMod = maybe [] Ident.haskellModule (ident ai)
defaultErrorConversion = if fmap dataType (chooseType (outputs ai)) == Just JSON then "fromJSON" else "fromXML"
(oMod, oType, oCType, oFunc) = maybe ([], "()", "text/plain", "(const ())") outputInfo $ chooseType $ outputs ai
(eMod, eType, eFunc) = headDef (([], "()", defaultErrorConversion))
. map errorInfo
. catMaybes
. map (\v -> find ((v ==) . dataType) $ errors ai)
$ maybeToList (fmap dataType $ chooseType (outputs ai)) ++ [XML, JSON]
(lUrl, lPars) = linkToURL res lnk
url = string ("v" <+> show ver <+> "/") <++> "++" <++> lUrl
fParams = map (hsName . cleanName) lPars
++ maybe [] ((:[]) . hsName . cleanName . description) (ident ai)
++ maybe [] (const ["input"]) mInp
++ (if null (params ai) then [] else ["pList"])
fType = "ApiStateC m => "
++ (hsType $ map (\p -> (if p == res then "" else modName p ++ ".") ++ "Identifier") lPars
++ maybe [] (return . Ident.haskellType) (ident ai)
++ maybe [] (\(_,v,_,_) -> [v]) mInp
++ (if null (params ai) then [] else ["[(String, String)]"])
++ ["m (ApiResponse (" ++ eType ++ ") (" ++ oType ++ "))"])
in ( mkStack $
[ function (mkHsName ai) fType
, hsDecl (mkHsName ai) fParams $
hsLet
[ "rHeaders" .=. hsArray [ hsTuple [code "hAccept", string oCType]
, hsTuple [code "hContentType", string (maybe "text/plain" (\(_,_,v,_) -> v) mInp)]
]
, "request" .=. "ApiRequest"
<++> string (show (method ai))
<++> parenthesis url
<++> (if null (params ai) then "[]" else "pList")
<++> "rHeaders"
<++> "$"
<++> maybe "\"\"" ((++ " input") . (\(_,_,_,v) -> v)) mInp
]
$ "liftM (parseResult" <++> eFunc <++> oFunc <+> ") . doRequest $ request"
]
, eMod ++ oMod ++ identMod ++ maybe [] (\(m,_,_,_) -> m) mInp
)
linkToURL :: String -> Link -> (Code, [String])
linkToURL res lnk = first (\v -> "intercalate" <++> string "/" <++> parenthesis ("map encode $ concat" <++> hsArray v)) $ urlParts res lnk ([], [])
urlParts :: String -> Link -> ([Code], [String]) -> ([Code], [String])
urlParts res lnk ac@(rlnk, pars) =
case lnk of
[] -> ac
(LResource r : a@(LAccess _) : xs) | not (hasParam a) -> urlParts res xs (rlnk ++ [hsArray [string r]], pars)
| otherwise ->
urlParts res xs
( rlnk ++ [ hsArray [string r]
, (if r == res then noCode else modName r <+> ".") <+> "readId" <++> hsName (cleanName r)
]
, pars ++ [r]
)
(LParam p : xs) -> urlParts res xs (rlnk ++ [hsArray ["showUrl" <++> hsName (cleanName p)]], pars)
(i : xs) -> urlParts res xs (rlnk ++ [hsArray [string $ itemString i]], pars)
idData :: ApiResource -> Code
idData node =
let items = filter isAccessor $ map itemInfo $ resItems node
mkCons = dataName . resDir
in case items of
[] -> noCode
[x] -> maybe noCode
(\i -> mkStack
[ code "type Identifier = " <++> Ident.haskellType i
, function "readId" "Identifier -> [String]"
, hsDecl "readId" ["x"] (hsArray $ if resDir x /= "" then [string $ resDir x, code "showUrl x"] else [code "showUrl x"])
]
)
(ident x)
ls -> mkStack $
[ hsData "Identifier" $ map (\i -> mkCons i ++ maybe "" (\x -> " (" ++ Ident.haskellType x ++ ")") (ident i)) ls
, function "readId" "Identifier -> [String]"
, mkStack $
map (\i ->
if isJust (ident i)
then hsDecl "readId" ["(" ++ mkCons i ++ " x" ++ ")"] $ hsArray [string (resDir i), code "showUrl x"]
else hsDecl "readId" [mkCons i] $ hsArray [string (resDir i)]
) ls
]
mkHsName :: ActionInfo -> String
mkHsName ai = hsName $ concatMap cleanName parts
where
parts = case actionType ai of
Retrieve -> let nm = get ++ by ++ target
in if null nm then ["access"] else nm
Create -> ["create"] ++ by ++ target
Delete -> ["remove"] ++ by ++ target
DeleteMany -> ["removeMany"] ++ by ++ target
List -> ["list"] ++ by ++ target
Update -> ["save"] ++ by ++ target
UpdateMany -> ["saveMany"] ++ by ++ target
Modify -> if resDir ai == "" then ["do"] else [resDir ai]
target = if resDir ai == "" then maybe [] ((:[]) . description) (ident ai) else [resDir ai]
by = if target /= [] && (isJust (ident ai) || actionType ai == UpdateMany) then ["by"] else []
get = if isAccessor ai then [] else ["get"]
rewriteModules :: [(String, String)] -> [String] -> [String]
rewriteModules _ [] = []
rewriteModules rw (v : vs) = maybe v (++ (" as " ++ v)) (lookup v rw) : rewriteModules rw vs
hsName :: [String] -> String
hsName [] = ""
hsName (x : xs) = clean $ downFirst x ++ concatMap upFirst xs
where
clean s = if s `elem` reservedNames then s ++ "_" else s
reservedNames =
["as","case","class","data","instance","default","deriving","do"
,"foreign","if","then","else","import","infix","infixl","infixr","let"
,"in","module","newtype","of","qualified","type","where"]
qualModName :: ResourceId -> String
qualModName = intercalate "." . map modName
modPath :: ResourceId -> String
modPath = intercalate "/" . map modName
modName :: String -> String
modName = concatMap upFirst . cleanName
dataName :: String -> String
dataName = modName
inputInfo :: DataDescription -> ([String], String, String, String)
inputInfo ds =
case dataType ds of
String -> ([], "String", "text/plain", "fromString")
XML -> (haskellModule ds, haskellType ds, "text/xml", "toXML")
JSON -> (haskellModule ds, haskellType ds, "text/json", "toJSON")
File -> ([], "ByteString", "application/octet-stream", "id")
Other -> ([], "ByteString", "text/plain", "id")
outputInfo :: DataDescription -> ([String], String, String, String)
outputInfo ds =
case dataType ds of
String -> ([], "String", "text/plain", "toString")
XML -> (haskellModule ds, haskellType ds, "text/xml", "fromXML")
JSON -> (haskellModule ds, haskellType ds, "text/json", "fromJSON")
File -> ([], "ByteString", "*", "id")
Other -> ([], "ByteString", "text/plain", "id")
errorInfo :: DataDescription -> ([String], String, String)
errorInfo ds =
case dataType ds of
String -> (haskellModule ds, haskellType ds, "fromXML")
XML -> (haskellModule ds, haskellType ds, "fromXML")
JSON -> (haskellModule ds, haskellType ds, "fromJSON")
File -> (haskellModule ds, haskellType ds, "fromXML")
Other -> (haskellModule ds, haskellType ds, "fromXML")