Skip to content

Commit 991789e

Browse files
SoupstrawSoupstraw
committed
WIP
1 parent 010d860 commit 991789e

File tree

1 file changed

+83
-94
lines changed

1 file changed

+83
-94
lines changed

‎src/Codec/CBOR/Cuddle/CDDL/Resolve.hs‎

Lines changed: 83 additions & 94 deletions
Original file line numberDiff line numberDiff line change
@@ -68,17 +68,16 @@ import Codec.CBOR.Cuddle.CDDL (
6868
cddlTopLevel,
6969
)
7070
import Codec.CBOR.Cuddle.CDDL.Postlude (PTerm (..))
71+
import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..))
7172
import Control.Monad.Except (ExceptT (..), runExceptT)
7273
import Control.Monad.Reader (Reader, ReaderT (..), runReader)
7374
import Control.Monad.State.Strict (StateT (..))
75+
import Data.Bifunctor (Bifunctor (..))
76+
import Data.Foldable (Foldable (..))
7477
import Data.Generics.Product
7578
import Data.Generics.Sum
7679
import Data.Hashable
77-
#if __GLASGOW_HASKELL__ < 910
78-
import Data.List (foldl')
79-
#endif
80-
import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..))
81-
import Data.Bifunctor (Bifunctor (..))
80+
import Data.List.NonEmpty (NonEmpty (..))
8281
import Data.List.NonEmpty qualified as NE
8382
import Data.Map.Strict qualified as Map
8483
import Data.Text qualified as T
@@ -168,7 +167,9 @@ newtype instance XXTopLevel OrReferenced = OrReferencedXXTopLevel Void
168167
-- | Indicates that an item may be referenced rather than defined.
169168
data instance XXType2 OrReferenced
170169
= -- | Reference to another node with possible generic arguments supplied
171-
Ref (Name OrReferenced) [TypeOrGroup OrReferenced]
170+
-- The boolean field determines whether the reference should be unwrapped
171+
Ref Bool (Name OrReferenced) [Type1 OrReferenced]
172+
| OrPostlude PTerm
172173
deriving (Eq, Show)
173174

174175
type RefCTree = PartialCTreeRoot OrReferenced
@@ -184,42 +185,45 @@ buildRefCTree rules = PartialCTreeRoot $ bimap mapIndex toCTreeRule rules
184185
toCTreeRule ::
185186
ProvidedParameters i ->
186187
ProvidedParameters OrReferenced
187-
toCTreeRule (ProvidedParameters ns t) = ProvidedParameters (undefined <$> ns) (toCTreeTOG t)
188+
toCTreeRule (ProvidedParameters ns t) = ProvidedParameters (mapIndex <$> ns) (toCTreeTOG t)
188189

189190
toCTreeTOG :: TypeOrGroup i -> TypeOrGroup OrReferenced
190191
toCTreeTOG (TOGType t0) = TOGType $ toCTreeT0 t0
191192
toCTreeTOG (TOGGroup ge) = TOGGroup $ toCTreeGroupEntry ge
192193

193194
toCTreeT0 :: Type0 i -> Type0 OrReferenced
194-
toCTreeT0 (Type0 ts) = Type0 $ toCTreeT1 <$> ts
195-
196-
toCTreeT1 :: Type1 i -> Type1 OrReferenced
197-
toCTreeT1 (Type1 t mr e) = Type1 (toCTreeT2 t) (second toCTreeT2 <$> mr) (mapIndex e)
195+
toCTreeT0 (Type0 xs) = foldMap (Type0 . toCTreeT1) xs
198196

199-
toCTreeT2 :: Type2 i -> Type2 OrReferenced
200-
toCTreeT2 (T2Value v) = T2Value v
201-
toCTreeT2 (T2Name n garg) = XXType2 $ Ref (mapIndex n) (fromGenArgs garg)
197+
toCTreeT1 :: Type1 i -> NonEmpty (Type1 OrReferenced)
198+
toCTreeT1 (Type1 t mr _) = (\x y -> Type1 x y mempty) <$> t' <*> r'
199+
where
200+
t' = toCTreeT2 t
201+
r' = case mr of
202+
Just (op, x) -> Just . (op,) <$> toCTreeT2 x
203+
Nothing -> NE.singleton Nothing
204+
205+
toCTreeT2 :: Type2 i -> NonEmpty (Type2 OrReferenced)
206+
toCTreeT2 (T2Value v) = NE.singleton $ T2Value v
207+
toCTreeT2 (T2Name n garg) = NE.singleton . XXType2 $ Ref False (mapIndex n) (fromGenArgs garg)
202208
toCTreeT2 (T2Group t0) =
203209
-- This behaviour seems questionable, but I don't really see how better to
204210
-- interpret the spec here.
205-
T2Group $ toCTreeT0 t0
206-
toCTreeT2 (T2Map g) = T2Map $ toCTreeMap g
207-
toCTreeT2 (T2Array g) = T2Array $ toCTreeArray g
211+
NE.singleton . T2Group $ toCTreeT0 t0
212+
toCTreeT2 (T2Map g) = liftChoice T2Map g
213+
toCTreeT2 (T2Array g) = liftChoice T2Map g
208214
toCTreeT2 (T2Unwrapped n margs) =
209-
undefined
210-
-- CTree.Unwrap . CTreeE $
211-
-- Ref n (fromGenArgs margs)
212-
toCTreeT2 (T2Enum g) = T2Enum $ toCTreeEnum g
213-
toCTreeT2 (T2EnumRef n margs) = XXType2 . Ref (mapIndex n) $ fromGenArgs margs
215+
NE.singleton . XXType2 $ Ref True (mapIndex n) (fromGenArgs margs)
216+
toCTreeT2 (T2Enum g) = NE.singleton . T2Enum $ toCTreeEnum g
217+
toCTreeT2 (T2EnumRef n margs) = NE.singleton . XXType2 . Ref False (mapIndex n) $ fromGenArgs margs
214218
toCTreeT2 (T2Tag mtag t0) =
215219
-- Currently not validating tags
216-
T2Tag mtag $ toCTreeT0 t0
220+
NE.singleton . T2Tag mtag $ toCTreeT0 t0
217221
toCTreeT2 (T2DataItem 7 (Just mmin)) =
218-
toCTreeDataItem mmin
222+
NE.singleton $ toCTreeDataItem mmin
219223
toCTreeT2 (T2DataItem _maj _mmin) =
220224
-- We don't validate numerical items yet
221-
T2Any
222-
toCTreeT2 T2Any = T2Any
225+
NE.singleton T2Any
226+
toCTreeT2 T2Any = NE.singleton T2Any
223227
toCTreeT2 (XXType2 x) = undefined
224228

225229
toCTreeDataItem :: Word64 -> Type2 OrReferenced
@@ -228,13 +232,13 @@ buildRefCTree rules = PartialCTreeRoot $ bimap mapIndex toCTreeRule rules
228232
toCTreeDataItem 21 =
229233
T2Value $ Value (VBool True) mempty
230234
toCTreeDataItem 25 =
231-
CTree.Postlude PTHalf
235+
XXType2 $ OrPostlude PTHalf
232236
toCTreeDataItem 26 =
233-
CTree.Postlude PTFloat
237+
XXType2 $ OrPostlude PTFloat
234238
toCTreeDataItem 27 =
235-
CTree.Postlude PTDouble
239+
XXType2 $ OrPostlude PTDouble
236240
toCTreeDataItem 23 =
237-
CTree.Postlude PTUndefined
241+
XXType2 $ OrPostlude PTUndefined
238242
toCTreeDataItem _ =
239243
T2Any
240244

@@ -259,25 +263,24 @@ buildRefCTree rules = PartialCTreeRoot $ bimap mapIndex toCTreeRule rules
259263
-- }
260264
-- toCTreeGroupEntry (GroupEntry Nothing (GEGroup g) _) = groupToGroup g
261265

262-
fromGenArgs :: Maybe (GenericArg i) -> [TypeOrGroup OrReferenced]
263-
fromGenArgs = maybe [] (\(GenericArg xs) -> NE.toList $ fmap (undefined . toCTreeT1) xs)
266+
fromGenArgs :: Maybe (GenericArg i) -> [Type1 OrReferenced]
267+
fromGenArgs = maybe [] (\(GenericArg xs) -> NE.toList $ foldMap toCTreeT1 xs)
264268

265269
-- Interpret a group as an enumeration. Note that we float out the
266270
-- choice options
267271
toCTreeEnum :: Group i -> Group OrReferenced
268-
toCTreeEnum (Group (a NE.:| [])) =
269-
undefined -- CTree.Enum . CTree.Group $ toCTreeGroupEntry <$> gcGroupEntries a
270-
toCTreeEnum (Group xs) =
271-
undefined -- CTree.Choice $ CTree.Enum . CTree.Group . fmap toCTreeGroupEntry <$> groupEntries
272-
where
273-
groupEntries = fmap gcGroupEntries xs
272+
toCTreeEnum g = undefined $ liftChoice T2Enum g
273+
-- CTree.Enum . CTree.Group $ toCTreeGroupEntry <$> gcGroupEntries a
274+
-- CTree.Choice $ CTree.Enum . CTree.Group . fmap toCTreeGroupEntry <$> groupEntries
275+
-- where
276+
-- groupEntries = fmap gcGroupEntries xs
274277

275278
-- Embed a group in another group, again floating out the choice options
276279
groupToGroup :: Group i -> Group OrReferenced
277-
groupToGroup (Group (a NE.:| [])) =
278-
undefined -- Group $ fmap toCTreeGroupEntry (gcGroupEntries a)
279-
groupToGroup (Group xs) =
280-
undefined -- CTree.Choice $ fmap (Group . fmap toCTreeGroupEntry) (gcGroupEntries <$> xs)
280+
groupToGroup g =
281+
Group . fmap (\x -> GrpChoice [GroupEntry Nothing undefined mempty] mempty) $
282+
liftChoice undefined g
283+
281284
toKVPair :: Maybe (MemberKey i) -> Type0 i -> TypeOrGroup OrReferenced
282285
toKVPair = undefined
283286
-- toKVPair Nothing t0 = toCTreeT0 t0
@@ -290,37 +293,15 @@ buildRefCTree rules = PartialCTreeRoot $ bimap mapIndex toCTreeRule rules
290293
-- }
291294

292295
-- Interpret a group as a map. Note that we float out the choice options
293-
toCTreeMap :: Group i -> Type0 OrReferenced
294-
-- toCTreeMap (Group (a NE.:| [])) = CTree.Map $ fmap toCTreeGroupEntry (gcGroupEntries a)
295-
toCTreeMap (Group xs) =
296-
Type0 $
297-
xs <&> \(GrpChoice ges c) ->
298-
Type1
299-
(T2Map . Group . NE.singleton $ GrpChoice (toCTreeGroupEntry <$> ges) (mapIndex c))
300-
Nothing
301-
mempty
302-
-- fmap (CTree.Map . fmap toCTreeGroupEntry . gcGroupEntries) xs
303-
304-
-- Interpret a group as an array. Note that we float out the choice
305-
-- options
306-
toCTreeArray :: Group i -> Type0 OrReferenced
307-
toCTreeArray (Group xs) =
308-
Type0 $
309-
xs <&> \(GrpChoice ges c) ->
310-
Type1
311-
(T2Array . Group . NE.singleton $ GrpChoice (toCTreeGroupEntry <$> ges) (mapIndex c))
312-
Nothing
313-
mempty
314-
-- toCTreeArray (Group (a NE.:| [])) =
315-
-- CTree.Array $ fmap toCTreeGroupEntry (gcGroupEntries a)
316-
-- toCTreeArray (Group xs) =
317-
-- CTree.Choice $
318-
-- fmap (CTree.Array . fmap toCTreeGroupEntry) (gcGroupEntries <$> xs)
319-
320-
toCTreeMemberKey :: MemberKey i -> Type2 OrReferenced
321-
toCTreeMemberKey (MKValue v) = T2Value v
322-
toCTreeMemberKey (MKBareword (Name n _)) = T2Value (Value (VText n) mempty)
323-
toCTreeMemberKey (MKType t1) = undefined . MKType $ toCTreeT1 t1
296+
liftChoice :: (Group OrReferenced -> Type2 OrReferenced) -> Group i -> NonEmpty (Type2 OrReferenced)
297+
liftChoice f (Group xs) =
298+
xs <&> \(GrpChoice ges c) ->
299+
f . Group . NE.singleton $ GrpChoice (toCTreeGroupEntry <$> ges) (mapIndex c)
300+
301+
toCTreeMemberKey :: MemberKey i -> MemberKey OrReferenced
302+
toCTreeMemberKey (MKValue v) = MKValue v
303+
toCTreeMemberKey (MKBareword n) = MKBareword $ mapIndex n
304+
toCTreeMemberKey (MKType t1) = undefined $ MKType <$> toCTreeT1 t1
324305

325306
--------------------------------------------------------------------------------
326307
-- 3. Name resolution
@@ -356,7 +337,7 @@ postludeBinding =
356337
data BindingEnv i j = BindingEnv
357338
{ global :: Map.Map (Name i) (ProvidedParameters i)
358339
-- ^ Global name bindings via 'RuleDef'
359-
, local :: Map.Map (Name j) (TypeOrGroup j)
340+
, local :: Map.Map (Name j) (Type1 j)
360341
-- ^ Local bindings for generic parameters
361342
}
362343
deriving (Generic)
@@ -377,6 +358,7 @@ data instance XXType2 DistReferenced
377358
GenericRef (Name DistReferenced)
378359
| -- | Reference to a rule definition, possibly with generic arguments
379360
RuleRef (Name DistReferenced) [TypeOrGroup DistReferenced]
361+
| DistPostlude PTerm
380362
deriving (Eq, Generic, Show)
381363

382364
instance Hashable (TypeOrGroup DistReferenced)
@@ -391,29 +373,36 @@ resolveRef ::
391373
BindingEnv OrReferenced OrReferenced ->
392374
XXType2 OrReferenced ->
393375
Either NameResolutionFailure (TypeOrGroup DistReferenced)
394-
resolveRef env (Ref n args) = case Map.lookup n postludeBinding of
395-
Just pterm -> case args of
396-
[] -> Right $ CTree.Postlude pterm
397-
xs -> Left $ ArgsToPostlude pterm xs
398-
Nothing -> case Map.lookup n (global env) of
399-
Just (parameters -> params') ->
400-
if length params' == length args
401-
then
402-
let localBinds = Map.fromList $ zip params' args
403-
newEnv = env & #local %~ Map.union localBinds
404-
in Right . TOGType . Type0 . NE.singleton $
405-
Type1
406-
(XXType2 . RuleRef (mapIndex n) <$> traverse (resolveCTree newEnv) args)
407-
undefined
408-
undefined
409-
else Left $ MismatchingArgs n params'
410-
Nothing -> case Map.lookup n (local env) of
411-
Just _ -> Right . CTreeE $ GenericRef n
412-
Nothing -> Left $ UnboundReference n
376+
resolveRef env = \case
377+
Ref unwrap n args -> resolveRef_ unwrap n args
378+
OrPostlude t -> undefined t
379+
where
380+
resolveRef_ ::
381+
Bool ->
382+
Name OrReferenced ->
383+
[Type1 OrReferenced] ->
384+
Either NameResolutionFailure (TypeOrGroup DistReferenced)
385+
resolveRef_ unwrap n args = case Map.lookup n postludeBinding of
386+
Just pterm -> case args of
387+
[] -> Right . undefined . XXType2 $ DistPostlude pterm
388+
xs -> Left $ ArgsToPostlude pterm $ undefined xs
389+
Nothing -> case Map.lookup n (global env) of
390+
Just (parameters -> params') ->
391+
if length params' == length args
392+
then do
393+
let localBinds = Map.fromList $ zip params' args
394+
newEnv = env & #local %~ Map.union localBinds
395+
ref <- XXType2 . RuleRef (mapIndex n) <$> traverse (resolveCTree newEnv) args
396+
Right . TOGType . Type0 . NE.singleton $
397+
Type1 ref Nothing mempty
398+
else Left $ MismatchingArgs n params'
399+
Nothing -> case Map.lookup n (local env) of
400+
Just _ -> Right . undefined . XXType2 $ GenericRef (mapIndex n)
401+
Nothing -> Left $ UnboundReference n
413402

414403
resolveCTree ::
415404
BindingEnv OrReferenced OrReferenced ->
416-
TypeOrGroup OrReferenced ->
405+
Type1 OrReferenced ->
417406
Either NameResolutionFailure (TypeOrGroup DistReferenced)
418407
resolveCTree e = CTree.traverseCTree (resolveRef e) (resolveCTree e)
419408

0 commit comments

Comments
 (0)