git.iko.soy/gogol
on develop help sign in
Parsing service outline
b6a29afBrendan Hay
gen/gozen-gen.cabal+4−1
compare with develop
unifiedsplit
@@ -23,6 +23,8 @@ executable gozen-gen
23 other-modules:
23 other-modules:
24 Gen.IO
24 Gen.IO
25 , Gen.Types
25 , Gen.Types
26+ , Gen.Formatting
27+ , Gen.JSON
26
28
27 ghc-options: -Wall -threaded
29 ghc-options: -Wall -threaded
28
30
@@ -40,4 +42,5 @@ executable gozen-gen
40 , errors
42 , errors
41 , formatting
43 , formatting
42 , unordered-containers
44 , unordered-containers
43− , attoparsec
45+ , attoparsec
46+ , bifunctors
gen/src/Gen/JSON.hsnew file+63
@@ -0,0 +1,63 @@
1+{-# LANGUAGE FlexibleInstances #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+
4+-- Module : Gen.JSON
5+-- Copyright : (c) 2015 Brendan Hay
6+-- License : Mozilla Public License, v. 2.0.
7+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
8+-- Stability : provisional
9+-- Portability : non-portable (GHC extensions)
10+
11+module Gen.JSON where
12+
13+import Control.Error
14+import Control.Monad.Except
15+import Data.Aeson hiding (decode)
16+import Data.Aeson.Types
17+import Data.Bifunctor
18+import Data.ByteString (ByteString)
19+import qualified Data.ByteString.Lazy as LBS
20+import Data.Char
21+import qualified Data.HashMap.Strict as Map
22+import Data.List
23+import qualified Data.Text.Lazy as LText
24+import qualified Text.EDE as EDE
25+
26+decode :: (Monad m, FromJSON a) => ByteString -> ExceptT LText.Text m a
27+decode = hoistEither . first LText.pack . eitherDecode' . LBS.fromStrict
28+
29+js :: String -> Options
30+js pre = defaultOptions
31+ { constructorTagModifier = map toLower
32+ , fieldLabelModifier = \s ->
33+ let x:xs = drop (length pre) s
34+ in toLower x : xs
35+ }
36+
37+-- optional :: MonadIO m => Path -> ExceptT Error m Object
38+-- optional f = readBSFile f `catchError` const (return "{}")
39+-- >>= hoistEither . decode
40+
41+-- objectErr :: ToJSON a => String -> a -> Either Error Object
42+-- objectErr n =
43+-- note (format ("Failed to extract JSON object from value " % string) n)
44+-- . EDE.fromValue
45+-- . toJSON
46+
47+-- decode :: FromJByteString -> Either Error a
48+-- decode = first LText.pack . eitherDecode' . LBS.fromStrict
49+
50+-- parse :: FromJSON a => Object -> Either Error a
51+-- parse = first LText.pack . parseEither parseJSON . Object
52+
53+-- merge :: [Object] -> Object
54+-- merge = foldl' go mempty
55+-- where
56+-- go :: Object -> Object -> Object
57+-- go = Map.unionWith value
58+
59+-- value :: Value -> Value -> Value
60+-- value l r =
61+-- case (l, r) of
62+-- (Object x, Object y) -> Object (x `go` y)
63+-- (_, _) -> l
gen/src/Gen/Types.hs+47−3
@@ -1,6 +1,8 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE KindSignatures #-}
2{-# LANGUAGE KindSignatures #-}
3+{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE TemplateHaskell #-}
4
6
5-- Module : Gen.Types
7-- Module : Gen.Types
6-- Copyright : (c) 2015 Brendan Hay
8-- Copyright : (c) 2015 Brendan Hay
@@ -11,7 +13,10 @@
11
13
12module Gen.Types where
14module Gen.Types where
13
15
16+import Data.Aeson
17+import Data.Aeson.TH
14import qualified Data.Attoparsec.Text as A
18import qualified Data.Attoparsec.Text as A
19+import Data.Char
15import Data.Function (on)
20import Data.Function (on)
16import qualified Data.HashMap.Strict as Map
21import qualified Data.HashMap.Strict as Map
17import Data.List (nub, sort)
22import Data.List (nub, sort)
@@ -21,6 +26,7 @@ import Data.Text (Text)
21import qualified Data.Text as Text
26import qualified Data.Text as Text
22import qualified Data.Text.Lazy as LText
27import qualified Data.Text.Lazy as LText
23import qualified Filesystem.Path.CurrentOS as Path
28import qualified Filesystem.Path.CurrentOS as Path
29+import Gen.JSON
24import GHC.TypeLits
30import GHC.TypeLits
25import Text.EDE (Template)
31import Text.EDE (Template)
26
32
@@ -69,12 +75,50 @@ instance Ord Spec where
69 <> on compare (Down . _specVersion) a b
75 <> on compare (Down . _specVersion) a b
70
76
71specFromPath :: Path -> Spec
77specFromPath :: Path -> Spec
72−specFromPath x = Spec (n <> v) p v x
78+specFromPath x = Spec n p v x
73 where
79 where
80+ -- FIXME:
81+ n = Text.init
74− n = Text.intercalate "/"
82+ . Text.intercalate "/"
75− . drop 1
83+ . drop 2
76 . dropWhile (/= "model")
84 . dropWhile (/= "model")
77 $ Text.split (== '/') p
85 $ Text.split (== '/') p
78
86
79 p = toTextIgnore (Path.parent (Path.parent x))
87 p = toTextIgnore (Path.parent (Path.parent x))
80 v = toTextIgnore (Path.dirname x)
88 v = toTextIgnore (Path.dirname x)
89+
90+data Protocol = REST
91+ deriving (Eq, Show)
92+
93+instance FromJSON Protocol where
94+ parseJSON = withText "protocol" $ \case
95+ "rest" -> pure REST
96+ e -> fail $ "Unable to parse protocol from " ++ Text.unpack e
97+
98+data Service = Service
99+ { _svcKind :: Text
100+ , _svcEtag :: Text
101+ , _svcDiscoveryVersion :: Text
102+ , _svcId :: Text
103+ , _svcName :: Text
104+ , _svcCanonicalName :: Maybe Text
105+ , _svcTitle :: Text
106+ , _svcVersion :: Text
107+ , _svcRevision :: Maybe Text
108+ , _svcDescription :: Text
109+ , _svcOwnerDomain :: Text
110+ , _svcOwnerName :: Text
111+ , _svcPackagePath :: Maybe Text
112+ , _svcIcons :: Object
113+ , _svcDocumentationLink :: Text
114+ , _svcProtocol :: Protocol
115+ , _svcBaseUrl :: Text
116+ , _svcRootUrl :: Text
117+ , _svcServicePath :: Text
118+ , _svcBatchPath :: Text
119+ , _svcParameters :: Object
120+ , _svcAuth :: Maybe Object
121+ , _svcSchemas :: Object
122+ } deriving (Show)
123+
124+deriveFromJSON (js "_svc") ''Service
gen/src/Main.hs+8−5
@@ -23,6 +23,7 @@ import qualified Filesystem as FS
23import Filesystem.Path.CurrentOS
23import Filesystem.Path.CurrentOS
24import Gen.Formatting
24import Gen.Formatting
25import Gen.IO
25import Gen.IO
26+import qualified Gen.JSON as JS
26import Gen.Types
27import Gen.Types
27import Options.Applicative
28import Options.Applicative
28
29
@@ -128,17 +129,19 @@ main = do
128 say ("Found " % int % " model specifications.") (length _optModels)
129 say ("Found " % int % " model specifications.") (length _optModels)
129 say ("Selected " % int % " newest models.") (length ss)
130 say ("Selected " % int % " newest models.") (length ss)
130
131
131− forM_ (zip [1..] ss) $ \(j, s) -> do
132+ forM_ (zip [1..] ss) $ \(j, Spec{..}) -> do
132 title ("[" % int % "/" % int % "] model:" % stext)
133 title ("[" % int % "/" % int % "] model:" % stext)
133− (j :: Int) (length ss) (_specName s)
134+ (j :: Int) (length ss) _specName
134
135
135− -- m <- listDir f >>= hoistEither . loadModel f
136−
137− -- say ("Using version " % dateDash) (m ^. modelVersion)
136+ say ("Using version " % stext) _specVersion
138
137
139 -- cfg <- JS.required (_optConfigs </> (m ^. configFile))
138 -- cfg <- JS.required (_optConfigs </> (m ^. configFile))
140 -- >>= hoistEither . JS.parse
139 -- >>= hoistEither . JS.parse
141
140
141+ svc <- readBSFile _specPath >>= JS.decode
142+
143+ say ("Service: " % string) (show (svc :: Service))
144+
142 -- api <- sequence
145 -- api <- sequence
143 -- [ JS.optional (_optAnnexes </> (m ^. annexFile))
146 -- [ JS.optional (_optAnnexes </> (m ^. annexFile))
144 -- , JS.required (m ^. serviceFile)
147 -- , JS.required (m ^. serviceFile)