github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-27 12:57:49 +03:00
Code Issues Projects Releases Wiki Activity

Wrap node returns up in Either.

Browse Source
This commit is contained in:
Rob Rix 2022-02-04 09:40:51 -05:00
parent 1a7a10dad5
commit 4f102fc8f5
No known key found for this signature in database
GPG Key ID: 2BE643E01DC032AE
1 changed files with 9 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
semantic-analysis/src/Analysis/Syntax.hs
View File

@ -148,20 +148,20 @@ parseFile path = do
parseGraph :: Syntax rep => A.Value -> A.Parser (IntMap.IntMap rep)
parseGraph = A.withArray "nodes" $ \ nodes -> do
untied <- IntMap.fromList <$> traverse (A.withObject "node" parseNode) (V.toList nodes)
pure $ fix (\ tied -> ($ tied) <$> untied)
pure $ fix (\ tied -> ($ tied) . either id id <$> untied)
parseNode :: Syntax rep => A.Object -> A.Parser (IntMap.Key, IntMap.IntMap rep -> rep)
parseNode :: Syntax rep => A.Object -> A.Parser (IntMap.Key, Either (IntMap.IntMap rep -> rep) (IntMap.IntMap rep -> rep))
parseNode o = do
edges <- o A..: pack "edges"
index <- o A..: pack "id"
let parseType attrs = attrs A..: pack "type" >>= \case
"string" -> const . string <$> attrs A..: pack "text"
"true" -> pure (const (bool True))
"false" -> pure (const (bool False))
"throw" -> fmap throw <$> resolve (head edges)
"if" -> liftA3 iff <$> findEdgeNamed "condition" <*> findEdgeNamed "consequence" <*> findEdgeNamed "alternative" <|> pure (const noop)
"block" -> fmap (foldr (\ (i, v) r -> let_ (nameI i) v (const r)) noop . zip [0..]) . sequenceA <$> traverse resolve edges
"module" -> fmap (foldr (\ (i, v) r -> let_ (nameI i) v (const r)) noop . zip [0..]) . sequenceA <$> traverse resolve edges
"string" -> Left . const . string <$> attrs A..: pack "text"
"true" -> pure (Left (const (bool True)))
"false" -> pure (Left (const (bool False)))
"throw" -> Left . fmap throw <$> resolve (head edges)
"if" -> (\ c t e -> Left (liftA3 iff c t e)) <$> findEdgeNamed "condition" <*> findEdgeNamed "consequence" <*> findEdgeNamed "alternative" <|> pure (Left (const noop))
"block" -> Left . fmap (foldr (\ (i, v) r -> let_ (nameI i) v (const r)) noop . zip [0..]) . sequenceA <$> traverse resolve edges
"module" -> Right . fmap (foldr (\ (i, v) r -> let_ (nameI i) v (const r)) noop . zip [0..]) . sequenceA <$> traverse resolve edges
t -> A.parseFail ("unrecognized type: " <> t)
resolve = resolveWith (const (pure ()))
resolveWith :: (A.Object -> A.Parser ()) -> A.Value -> A.Parser (IntMap.IntMap rep -> rep)