diff options
Diffstat (limited to 'src/Data/JLD.hs')
-rw-r--r-- | src/Data/JLD.hs | 83 |
1 files changed, 83 insertions, 0 deletions
diff --git a/src/Data/JLD.hs b/src/Data/JLD.hs new file mode 100644 index 0000000..d60e5a1 --- /dev/null +++ b/src/Data/JLD.hs | |||
@@ -0,0 +1,83 @@ | |||
1 | module Data.JLD ( | ||
2 | module Data.JLD.Mime, | ||
3 | module Data.JLD.Error, | ||
4 | module Data.JLD.Options, | ||
5 | JLDExpandParams (..), | ||
6 | expand, | ||
7 | ) where | ||
8 | |||
9 | import Data.JLD.Prelude | ||
10 | |||
11 | import Data.JLD.Context (buildActiveContext) | ||
12 | import Data.JLD.Control.Monad.RES (evalREST, runREST) | ||
13 | import Data.JLD.Error | ||
14 | import Data.JLD.Expansion (JLDEParams (..)) | ||
15 | import Data.JLD.Expansion qualified as E (expand) | ||
16 | import Data.JLD.Mime | ||
17 | import Data.JLD.Model.ActiveContext (ActiveContext (..), newActiveContext) | ||
18 | import Data.JLD.Model.Keyword (Keyword (..)) | ||
19 | import Data.JLD.Model.URI (uriToIri) | ||
20 | import Data.JLD.Monad (JLDEnv, JLDState, newEnv, newState) | ||
21 | import Data.JLD.Options | ||
22 | import Data.JLD.Util (flattenSingletonArray, valueToArray) | ||
23 | |||
24 | import Data.Aeson (Value (..)) | ||
25 | import Data.Aeson.KeyMap qualified as KM | ||
26 | import Data.Vector qualified as V (singleton) | ||
27 | import Text.URI (URI) | ||
28 | |||
29 | data JLDExpandParams e m = JLDExpandParams | ||
30 | { jldExpandParamsExpandContext :: Maybe Value | ||
31 | , jldExpandParamsFrameExpansion :: Bool | ||
32 | , jldExpandParamsEnv :: JLDEnv e m | ||
33 | , jldExpandParamsState :: JLDState | ||
34 | } | ||
35 | deriving (Show) | ||
36 | |||
37 | expand :: Monad m => Value -> URI -> (JLDExpandParams () m -> JLDExpandParams e m) -> m (Either (JLDError e) Value, JLDState) | ||
38 | expand document baseUrl paramsFn = do | ||
39 | let JLDExpandParams{..} = | ||
40 | paramsFn | ||
41 | JLDExpandParams | ||
42 | { jldExpandParamsExpandContext = Nothing | ||
43 | , jldExpandParamsFrameExpansion = False | ||
44 | , jldExpandParamsEnv = newEnv id | ||
45 | , jldExpandParamsState = newState id | ||
46 | } | ||
47 | |||
48 | activeContext = newActiveContext \ac -> ac{activeContextBaseUrl = Just baseUrl, activeContextBaseIri = uriToIri baseUrl} | ||
49 | expansionParams p = p{jldeParamsFrameExpansion = jldExpandParamsFrameExpansion} | ||
50 | |||
51 | -- 6. | ||
52 | let maybeExpandContext = | ||
53 | jldExpandParamsExpandContext <&> flattenSingletonArray .> \case | ||
54 | Array expandedContext -> Array expandedContext | ||
55 | (Object expandedContext) | Just ctx <- KM.lookup (show KeywordContext) expandedContext -> ctx | ||
56 | expandedContext -> Array <| V.singleton expandedContext | ||
57 | |||
58 | activeContext' <- case maybeExpandContext of | ||
59 | Just expandContext -> | ||
60 | buildActiveContext activeContext expandContext (Just baseUrl) id | ||
61 | |> evalREST jldExpandParamsEnv jldExpandParamsState | ||
62 | |> fmap (fromRight activeContext) | ||
63 | Nothing -> pure activeContext | ||
64 | |||
65 | -- 8. | ||
66 | (result, state') <- | ||
67 | E.expand activeContext' document baseUrl expansionParams | ||
68 | |> runREST jldExpandParamsEnv jldExpandParamsState | ||
69 | |||
70 | let result' = case result of | ||
71 | -- 8.1. | ||
72 | Right (Object expanded) | ||
73 | | KM.size expanded == 1 | ||
74 | , Just expanded' <- KM.lookup (show KeywordGraph) expanded -> | ||
75 | Right <. Array <| valueToArray expanded' | ||
76 | -- 8.2. | ||
77 | Right Null -> Right <| Array mempty | ||
78 | -- 8.3. | ||
79 | Right expanded -> Right <. Array <| valueToArray expanded | ||
80 | -- | ||
81 | Left err -> Left err | ||
82 | |||
83 | pure (result', state') | ||