diff --git a/editor/Unison/Parser.elm b/editor/Unison/Parser.elm index c4bf7d7ae..64bc405b6 100644 --- a/editor/Unison/Parser.elm +++ b/editor/Unison/Parser.elm @@ -6,46 +6,92 @@ import Dict as M type Msg = [String] --- type P a --- type P a = J.Value -> Either Msg a --- type Parser a = { focus : Path, parser : P a } --- combinators like lift2 can merge common paths +type P a = J.Value -> Either Msg a -type Parser a = J.Value -> Either Msg a +data E = Key String | Index Int +type Path = [E] + +type Parser a = { focus : Path, parse : P a } -run : Parser a -> J.Value -> Either String a -run p v = case p v of - Left stack -> Left (join "\n" stack) - Right a -> Right a +safeIndex : Int -> [a] -> Maybe a +safeIndex i xs = case drop i xs of + [] -> Nothing + h :: t -> Just h + +getPath : Path -> J.Value -> Either Msg J.Value +getPath p v = + let + failure loc v = Left [ + "invalid path: " ++ show p, + "remainder: " ++ show loc, + "focus: " ++ J.toString "" v + ] + go loc v = case loc of + [] -> Right v + Key k :: t -> case v of + J.Object obj -> case M.get k obj of + Nothing -> failure loc v + Just v -> go t v + _ -> failure loc v + Index i :: t -> case v of + J.Array vs -> case safeIndex i vs of + Nothing -> failure loc v + Just v -> go t v + _ -> failure loc v + in go p v + +run : Parser a -> J.Value -> Either Msg a +run p v = either Left p.parse (getPath p.focus v) unit : a -> Parser a -unit a _ = Right a +unit a = { focus = [], parse = \v -> Right a } + +value : Parser J.Value +value = { focus = [], parse = Right } fail : String -> Parser a -fail msg _ = Left [msg] +fail msg = { focus = [], parse = \v -> Left [msg] } scope : String -> Parser a -> Parser a -scope msg p v = case p v of - Left stack -> Left (msg :: stack) - a -> a +scope msg p = + let focus = p.focus + parse v = case p.parse v of + Left stack -> Left (msg :: stack) + a -> a + in { focus = focus, parse = parse } bind : (a -> Parser b) -> Parser a -> Parser b -bind f p v = case p v of - Right a -> f a v - Left e -> Left e +bind f p = + let focus = p.focus + parse v = case p.parse v of + Right a -> run (f a) v + Left e -> Left e + in { focus = focus, parse = parse } infixl 3 >>= (>>=) : Parser a -> (a -> Parser b) -> Parser b a >>= f = bind f a map : (a -> b) -> Parser a -> Parser b -map f = bind (unit . f) +map f p = + let parse v = case p.parse v of + Left e -> Left e + Right a -> Right (f a) + in { p | parse <- parse } lift2 : (a -> b -> c) -> Parser a -> Parser b -> Parser c -lift2 f a b v = case (a v, b v) of - (Left e, _) -> Left e - (_, Left e) -> Left e - (Right a, Right b) -> Right (f a b) +lift2 f a b = + let common = a.focus `zip` b.focus + |> concatMap (\p -> if fst p == snd p then [fst p] else []) + restL = drop (length common) a.focus + restR = drop (length common) b.focus + parseL v = either Left a.parse (getPath restL v) + parseR v = either Left b.parse (getPath restR v) + parse v = case (parseL v, parseR v) of + (Left e, _) -> Left e + (_, Left e) -> Left e + (Right a, Right b) -> Right (f a b) + in { focus = common, parse = parse } apply : Parser (a -> b) -> Parser a -> Parser b apply f a = lift2 (<|) f a @@ -58,54 +104,30 @@ infixl 4 #| (#|) : (a -> b) -> Parser a -> Parser b f #| a = map f a -key : String -> Parser J.Value -key k v = case v of - J.Object obj -> M.get k obj - |> maybe (Left ["not found"]) Right - e -> Left ["not found: " ++ J.toString "" v] - string : Parser String -string v = case v of - J.String s -> Right s - _ -> Left ["not a string: " ++ J.toString "" v] +string = value >>= \v -> case v of + J.String s -> unit s + _ -> fail ("not a string: " ++ J.toString "" v) int : Parser Int -int v = case v of - J.Number v -> Right (floor v) - _ -> Left ["not a number: " ++ J.toString "" v] - -number : Parser Float -number v = case v of - J.Number v -> Right v - _ -> Left ["not a number: " ++ J.toString "" v] - -asString : Parser J.Value -> Parser String -asString p v = case v of - J.String s -> Right s - _ -> Left ["not a string: " ++ J.toString "" v] +int = value >>= \v -> case v of + J.Number v -> unit (floor v) + _ -> fail ("not a number: " ++ J.toString "" v) -atKey : String -> Parser a -> Parser a -atKey fld p = - let p2 v = case v of - J.Object obj -> M.get fld obj - |> maybe (Left ["not found"]) p - e -> Left ["not found: " ++ J.toString "" v] - in scope fld p2 +number : Parser Float +number = value >>= \v -> case v of + J.Number v -> unit v + _ -> fail ("not a number: " ++ J.toString "" v) + +atKey : String -> Parser a -> Parser a +atKey k p = { p | focus <- Key k :: p.focus } atIndex : Int -> Parser a -> Parser a -atIndex ind p = - let p2 v = case v of - J.Array vs -> - let sub = drop ind vs - in if isEmpty sub - then Left ["out of bounds: " ++ show ind ++ " " ++ J.toString "" v] - else p (head sub) - e -> Left ["not found: " ++ J.toString "" v] - in scope ("index: " ++ show ind) p2 +atIndex ind p = { p | focus <- Index ind :: p.focus } union : String -> String -> (String -> Parser a) -> Parser a union tag contents f = - asString (key tag) >>= \t -> atKey contents (f t) + atKey tag string >>= \t -> atKey contents (f t) union' : (String -> Parser a) -> Parser a union' = union "tag" "contents"