From 9ccf28482ac6545e70bd59719407bb572b092c1b Mon Sep 17 00:00:00 2001 From: Etherian Date: Sun, 10 Feb 2019 22:04:57 -0500 Subject: [PATCH 1/7] feat(std): add indexable and streamlike; replace parser --- std/indexable.glu | 11 ++ std/parser.glu | 364 +++++++++++---------------------------------- std/streamlike.glu | 303 +++++++++++++++++++++++++++++++++++++ 3 files changed, 403 insertions(+), 275 deletions(-) create mode 100644 std/indexable.glu create mode 100644 std/streamlike.glu diff --git a/std/indexable.glu b/std/indexable.glu new file mode 100644 index 0000000000..74d3eec550 --- /dev/null +++ b/std/indexable.glu @@ -0,0 +1,11 @@ +type Indexable ind = { + index : ind a -> Int -> a +} + +let index ?ind : [Indexable ind] -> ind a -> Int -> a = ind.index + +{ + Indexable, + + index, +} \ No newline at end of file diff --git a/std/parser.glu b/std/parser.glu index fd9efa2260..c799e22838 100644 --- a/std/parser.glu +++ b/std/parser.glu @@ -1,295 +1,109 @@ -//! A simple parser combinator library. +//! A simple parser combinator library let prelude = import! std.prelude -let { Functor, Applicative, Alternative, Monad } = prelude -let { id, flip } = import! std.function +let { Functor, Applicative, Alternative, Monad, (<>) } = prelude +let { id, flip, (>>), (<<), (|>), (<|) } = import! std.function + let { Bool } = import! std.bool -let char @ { ? } = import! std.char +let char @ { Char, ? } = import! std.char let int = import! std.int -let { Result } = import! std.result -let string = import! std.string -let { (<>) } = import! std.prelude let list @ { List } = import! std.list let { Option } = import! std.option - -type OffsetString = { start : Int, end : Int, buffer : String } -type Position = Int -type Error = { position : Position, message : String } -type ParseResult a = Result Error { value : a, buffer : OffsetString } - -/// `Parser` is a monad which parses a `String` into structured values -type Parser a = - OffsetString -> ParseResult a - -let parser : Parser a -> Parser a = id - -let functor : Functor Parser = { - map = \f m -> parser (\buffer -> - let result = parser m buffer - match result with - | Ok a -> Ok { value = f a.value, buffer = a.buffer } - | Err err -> Err err) -} - -let { map } = functor - -let applicative : Applicative Parser = { - functor, - - apply = \f m -> parser (\buffer -> - let result1 = parser f buffer - match result1 with - | Ok g -> - let result2 = parser m g.buffer - match result2 with - | Ok a -> Ok { value = g.value a.value, buffer = a.buffer } - | Err err -> Err err - | Err err -> Err err), - - wrap = \value -> parser (\buffer -> Ok { value, buffer }), -} - -let { (*>), (<*), wrap } = import! std.applicative - -let alternative : Alternative Parser = { - applicative, - - or = \l r -> parser (\stream -> - match parser l stream with - | Ok a -> Ok a - | Err _ -> parser r stream), - empty = parser (\stream -> Err { position = stream.start, message = "empty" }), -} - -let { (<|>) } = import! std.alternative - -let monad : Monad Parser = { - applicative, - - flat_map = \f m -> parser (\buffer -> - match parser m buffer with - | Ok a -> parser (f a.value) a.buffer - | Err err -> Err err), -} - -let { flat_map } = import! std.monad - -let uncons stream : OffsetString -> Option { char : Char, rest : OffsetString } = - if stream.start == stream.end then - None - else - let c = string.char_at stream.buffer stream.start - let char_len = char.len_utf8 c - Some { - char = c, - rest = { - start = stream.start + char_len, - end = stream.end, - buffer = stream.buffer, - }, - } - -let update_position c position : Char -> Position -> Position = - position + char.len_utf8 c - -/// Returns `message` as what was expected by `p` -#[infix(left, 0)] -let () p message : Parser a -> String -> Parser a = - parser (\stream -> - match p stream with - | Ok x -> Ok x - | Err _ -> Err { position = stream.start, message }) - -/// Parses any character. Only errors if the stream is out of input -let any : Parser Char = - parser (\stream -> - match uncons stream with - | Some record -> - let { char, rest } = record - Ok { value = char, buffer = rest } - | None -> Err { position = stream.start, message = "End of stream" }) - -/// Fails the parser with `message` as the cause -let fail message : String -> Parser a = - parser (\stream -> Err { position = stream.start, message }) - -/// Succeeds if `predicate` returns `Some`, fails if `None` is returned -let satisfy_map predicate : (Char -> Option a) -> Parser a = - let f c = - match predicate c with - | Some x -> wrap x - | None -> fail ("Unexpected character " <> char.show.show c) - flat_map f any - -/// Succeeds if `predicate` returns True, fails if `False` is returned -let satisfy predicate : (Char -> Bool) -> Parser Char = - satisfy_map (\c -> if predicate c then Some c else None) - -/// Succeeds if the next token is `expected` -let token expected : Char -> Parser Char = - satisfy (\c -> expected == c) - -/// Succeds if the next token is a letter -let letter : Parser Char = satisfy char.is_alphabetic "letter" - -/// Succeds if the next token is a digit -let digit : Parser Char = satisfy (flip char.is_digit 10) "digit" - -/// Succeds if the next token is alphanumeric -let alpha_num : Parser Char = satisfy char.is_alphanumeric "letter or digit" - -/// Succeds if the next token is a space -let space : Parser Char = token ' ' - -/// Succeds if the next token is a tab -let tab : Parser Char = token '\t' - -/// Parses one or more tokens passing `predicate` and returns the `String` between the start and -/// end of those tokens -let take1 predicate : (Char -> Bool) -> Parser String = - parser (\stream -> - let take_ stream2 = - match uncons stream2 with - | Some record -> - if predicate record.char then take_ record.rest - else if stream.start == stream2.start then - Err { position = stream.start, message = "Unexpected token" } - else Ok { - value = string.slice stream.buffer stream.start stream2.start, - buffer = stream2, - } - | None -> Ok { - value = string.slice stream.buffer stream.start stream.end, - buffer = stream2, - } - take_ stream) - -/// Parses zero or more tokens passing `predicate` and returns the `String` between the start and -/// end of those tokens -let take predicate : (Char -> Bool) -> Parser String = - take1 predicate <|> wrap "" - -/// Parses using `p` and returns the `String` between the start and of what `p` parsed -let recognize p : Parser a -> Parser String = - parser (\stream -> - match parser p stream with - | Ok a -> - Ok { - value = string.slice stream.buffer stream.start a.buffer.start, - buffer = a.buffer, - } - | Err err -> Err err) - -/// Skips over whitespace characters -let spaces = take char.is_whitespace - -/// Creates a parser from a factory function. Useful to prevent mutually recursive parser from looping forever -let lazy_parser f : (() -> Parser a) -> Parser a = - parser (\stream -> f () stream) - -/// Parses `x` between `l` and `r`, returning the result of `x` -let between l r x : Parser a -> Parser b -> Parser c -> Parser c = - l *> x <* r - -rec -/// Parses with `p` zero or more times -let many p : Parser a -> Parser (List a) = - many1 p <|> wrap Nil - -/// Parses with `p` one or more times -let many1 p : Parser a -> Parser (List a) = - do h = p - map (\t -> Cons h t) (many p) -in -rec -/// Parses with `p` zero or more times, ignoring the result of the parser -let skip_many p : Parser a -> Parser () = - skip_many1 p <|> wrap () -/// Parses with `p` one or more times, ignoring the result of the parser -let skip_many1 p : Parser a -> Parser () = - seq p - skip_many p -in -/// Parses one of the characters of `s` -let one_of s : String -> Parser Char = - satisfy (\first -> - let len = string.len s - let one_of_ i = - if i == len then - False +let { Result } = import! std.result +let streamlike @ { Streamlike, ? } = import! std.streamlike +let string @ { String, ? } = import! std.string + +// TODO How handle atom streams generically? Stream-like interface? +// TODO How handle error position generically? Zip stream with enumeration? +type Parser s e a = StateT s (Result e) a +// TODO How have Parser (Result Err) on surface but Streamer type (Option) internally? +// How handle custom error types this way? Do I need to build mini failure lib? + +// use implicit argument that user fills in with error type and end case? +let sr_to_psr end sr : e -> Streamer s a -> Parser s e a = + sr >> \opt -> match opt with + | Some next -> Ok next + | None -> Err end + +// terrible idea? +let any_atom : [Streamlike atm srm] -> Parser srm e atm = + sr_to_psr ? uncons // TODO Error handling + +// TODO mixing stream processors and stream adapters does not work +let take n : [Streamlike atm srm] -> Int -> Parser srm e () = + \xs -> Ok {value = (), state = streamlike.take n xs} + +// TODO What error type should library functions return? +let satisfy_map pred : [Streamlike atm srm] -> (atm -> Option a) -> Parser srm e a = + any_atom >>= \atm -> + match pred atm with + | Some a -> wrap a + | None -> // TODO Error handling + +let satisfy pred : [Streamlike atm srm] -> (atm -> Bool) -> Parser srm e atm = + satisfy_map (\c -> if pred c then Some c else None) + +let atom x : [Streamlike atm srm] -> [Eq atm] -> atm -> Parser srm e atm = + satisfy <| (==) x + +rec let token ts : [Streamlike atm srm] -> [Streamlike atm tknsrm] -> [Eq atm] -> tknsrm -> Parser srm e atm = + any_atom >>= \x -> + match any_atom ts with + | Ok {value = t, state = ts'} -> + if x == t then + map (\_ -> ts) (token ts') else - let c = string.char_at s i - if first == c then True - else one_of_ (i + char.len_utf8 c) - one_of_ 0) - <|> fail ("Expected one of `" <> s <> "`") + Err ? // TODO Error handling + | Err ? -> wrap ts // TODO Error handling: needs to be EndOfStream error + | Err e -> (\_ -> Err e) // unreachable? + +// end - matches end of stream +// take_while1? +// many +// many1 +// skip_many? +// between +// one_of +// sep_by +// sep_by1 +// chain +// chain1 +// parse +type Position = Int +type OffsetString = { start : Position, end : Position, buffer : String } +type StringParser a = Parser OffsetString ? a // TODO Error handling -/// Parses at least one element of `parser` separated by `sep` -let sep_by1 parser sep : Parser a -> Parser b -> Parser (List a) = - do x = parser - do xs = many (sep *> parser) - wrap (Cons x xs) +let eolsym c : Char -> Bool = + elem c ['\r', '\n'] -/// Parses `parser` separated by `sep` -let sep_by parser sep : Parser a -> Parser b -> Parser (List a) = - sep_by1 parser sep <|> wrap Nil +let space : [Streamlike Char srm] -> Parser srm e Char = + atom ' ' -/// Like `sep_by1` but applies the function returned by `op` on the left fold of successive parses -let chainl1 p op : Parser a -> Parser (a -> a -> a) -> Parser a = - do l = p - let rest x = - ( - do f = op - do r = p - rest (f x r)) <|> wrap x - rest l +let eol : [Streamlike Char srm] -> Parser srm e Char = (atom '\r' *> atom '\n') <|> atom '\n' <|> atom '\r' -/// Like `sep_by` but applies the function returned by `op` on the left fold of successive parses -let chainl p op v : Parser a -> Parser (a -> a -> a) -> a -> Parser a = - chainl1 p op <|> wrap v +let whitespace : [Streamlike Char srm] -> Parser srm e Char = + satisfy char.is_whitespace +let letter : [Streamlike Char srm] -> Parser srm e Char = + satisfy char.is_alphabetic -/// Parses `input` using `p` -let parse p input : Parser a -> String -> Result String a = - match p { start = 0, end = string.len input, buffer = input } with - | Ok ok -> Ok ok.value - | Err err -> Err (int.show.show err.position <> ":" <> err.message) +let digit : [Streamlike Char srm] -> Parser srm e Char = + satisfy <| flip char.is_digit 10 -{ - Position, Error, ParseResult, Parser, +let alphanum : [Streamlike Char srm] -> Parser srm e Char = + letter <|> digit - functor, applicative, alternative, monad, +// spaces +// whitespaces? +// rest of line (all but line break)? - parser, +type ByteParser a = // TODO - any, - between, - token, - many, - many1, - satisfy, - satisfy_map, - spaces, - take1, - take, - lazy_parser, - fail, - recognize, - skip_many, - skip_many1, - one_of, - sep_by, - sep_by1, - chainl1, - chainl, - (), - alpha_num, - letter, - digit, - space, - tab, +// practice parser implementation +type PsrErr = + | ParseFailure String + | EndOfStream - parse, -} +type Parser a = Parser [Byte] PsrErr a diff --git a/std/streamlike.glu b/std/streamlike.glu new file mode 100644 index 0000000000..672fa5f590 --- /dev/null +++ b/std/streamlike.glu @@ -0,0 +1,303 @@ +let { id } = import! std.function +let { Lazy, lazy, force } = import! std.lazy + +let statet @ { StateT, StateOut } = import! std.statet +let lazyt @ { LazyT } = import! std.lazyt + +// StateT vs no (vs effect system?) +// strict vs lazy +// state-machine vs dynamic vs closures (vs impl Trait equivalent?) + +// handle adapter types with monomorphization or dynamic dispatch? +// new type, Lazy (Option (a, srm)) as output type of all adapters, hiding special behavior behind closure? +// should streamlike be monadic? (a, srm) looks like State. uncons looks kinda like wrap. + +// Streamlike as a composition of monads? State + Option + Lazy? + +#[implicit] +type Streamlike a srm = { + uncons : srm -> LazyT Option (a, srm) +} + +let option_streamlike : [Streamlike a srm] -> Streamlike a (Option (a, srm)) = + { uncons = force } + +let uncons ?sl : [Streamlike a srm] -> srm -> Option (a, srm) = + sl.uncons + +let empty = lazy (\_ -> None) + +let singleton = lazy (\_ -> Some {value = x, state = empty} + +let next srm : [Streamlike a srm] -> srm -> Option a = + map fst (uncons srm) + +let take n xs : [Streamlike a srm] -> Int -> srm -> ? = + if n > 0 then + match uncons xs with + | Some (x, xs') -> Some {value = x, state = (take (n - 1) xs')} + | None -> empty + else empty + +let functor ?sml : [Streamlike a srm] -> Functor (Lazy (Option (a, srm))) = + rec let map f smout = + match force smout with + | Some (a, srm') -> lazy (\_ -> Some (f a, map f (sml.uncons srm'))) + | None -> lazy (\_ -> None) + + { map } + +let applicative ?sml : [Streamlike a srm] -> Applicative (Lazy (Option (a, srm))) = + let wrap = sml.uncons + let apply mf smout = ? + + { functor, apply, wrap } + +let monad ?sml : [Streamlike a srm] -> Monad (Lazy (Option (a, srm))) = + let flat_map f smout = + functor.map f (force smout) + + { applicative, flat_map } + +let semigroup : [Streamlike a srm] -> Semigroup srm = + let append xs ys = + match uncons xs with + | Some (x, xs') -> lazy (\_ -> Some (x, (append xs' ys))) + | None -> ys + + { append } + +let monoid : [Streamlike a srm] -> Monoid srm = + { semigroup, empty } + +// StateT strict version +#[implicit] +type Streamlike a srm = { + uncons : srm -> Option (StateOut srm a) +} + +type Streamer a srm = StateT srm Option a + +// state-machine adapters +type Unfold acc = { + f : acc -> Option acc, + acc : acc +} + +let unfold_streamlike : Streamlike acc (Unfold acc) = + let uncons unfold = + unfold.f unfold.acc |> map (\acc' -> + {value = acc', state = {f = unfold.f, acc = acc'}}) + { uncons } + +let unfold f acc : (acc -> Option acc) -> acc -> Unfold acc = + {f , acc} + +// replaced with FilterMap +/* // FIXME this seems wrong. Maybe leave mapping to stream processors somehow? */ +/* type MapSrm a b srm = { */ +/* f : a -> b, */ +/* xs : srm */ +/* } */ + +/* let mapsrm_streamlike : [Streamlike a srm] -> Streamlike b (MapSrm a b srm) = */ +/* let uncons mapsrm = */ +/* uncons mapsrm.xs |> map \{value = x, state = xs'} */ +/* {value = mapsrm.f x, state = {f = mapsrm.f, xs = xs'}} */ +/* { uncons } */ + +/* let map_srm f xs : (a -> b) -> srm -> MapSrm a b srm = */ +/* {f, xs} */ + +type FilterMap a b srm = { + pred : a -> Option b, + xs : srm +} + +// FIXME Will not halt if fed an infinite stream of elements that fail the predicate +let filter_map_streamlike : [Streamlike a srm] -> Streamlike b (FilterMap a b srm) = + rec let uncons filtermp = + uncons filtermp.xs |> map (\sout -> + let {value = x, state = xs'} = sout + match filtermp.pred x with + | Some x' -> {value = x', state = {pred = filtermp.pred, xs = xs'}} + | None -> uncons {pred = filtermp.pred, xs = xs'}) + +let filter_map pred xs : [Streamlike a srm] -> (a -> Option b) -> srm -> FilterMap a b srm = + {pred, xs} + +// replaced with FilterMap +/* // TODO Is it a problem for Filter and TakeWhile to have the same type signature/definition? */ +/* type Filter a srm = { */ +/* pred : a -> Bool, */ +/* xs : srm */ +/* } */ + +/* // FIXME Will not halt if fed an infinite stream of elements that fail the predicate */ +/* let filter_streamlike : [Streamlike a srm] -> Streamlike a (Filter a srm) = */ +/* rec let uncons filter = */ +/* uncons filter.xs |> map \{value = Some x, state = xs'} -> */ +/* if filter.pred x then */ +/* {value = x, state = {pred = filter.pred, xs = xs'}} */ +/* else */ +/* uncons {pred = filter.pred, xs = xs'} */ + +/* let filter pred xs : [Streamlike a srm] -> (a -> Bool) -> srm -> Filter a srm = */ +/* {pred, xs} */ + +/* type TakeWhile a srm = { */ +/* pred : a -> Bool, */ +/* xs : srm */ +/* } */ + +/* let take_while_streamlike : [Streamlike a srm] -> Streamlike a (TakeWhile srm) = */ +/* let uncons tw = */ +/* uncons tw.xs >>= \sout -> */ +/* let {value = x, state = xs'} = sout */ +/* if tw.pred x then */ +/* Some {value = x, state = {pred = tw.pred, xs = xs'}} */ +/* else */ +/* None */ + +/* { uncons } */ + +/* let take_while pred xs : [Streamlike a srm] -> (a -> Bool) -> srm -> TakeWhile a srm = */ +/* {pred, xs} */ + +type TakeWhileMap a b srm = { + pred : a -> Option b, + xs : srm +} + +let take_while_map_streamlike : [Streamlike a srm] -> Streamlike b (TakeWhileMap a b srm) = + let uncons tw = + uncons tw.xs >>= \sout -> + let {value = x, state = xs'} = sout + tw.pred x |> map (\x' -> + {value = x', state = {pred = tw.pred, xs = xs'}}) + + { uncons } + +let take_while_map pred xs : [Streamlike a srm] -> (a -> Option b) -> srm -> TakeWhileMap a b srm = + {pred, xs} + +// replaced with composition of Unfold and ZipWith +/* type Take srm = { */ +/* count : Int, */ +/* xs : srm */ +/* } */ + +/* let take_streamlike : [Streamlike a srm] -> Streamlike a (Take srm) = */ +/* let uncons take = */ +/* if take.count > 0 then */ +/* uncons take.xs |> map (\sout -> */ +/* let {value = x, state = xs'} = sout */ +/* {value = x, state = {count = take.count - 1, xs = xs'}}) */ +/* else */ +/* None */ +/* { uncons } */ + +/* let take n xs : [Streamlike a srm] -> Int -> srm -> Take srm = */ +/* {count = n, xs} */ + +type ZipWith a b c srma srmb = { + f : (a -> b -> c), + xs : srma, + ys : srmb +} + +let zip_with_streamlike : [Streamlike a srma] -> [Streamlike b srmb] -> Streamlike c (ZipWith a b c srma srmb) = + let uncons zipw = match (uncons zipw.xs, uncons zipw.ys) with + | (Some {value = x, state = xs'}, Some {value = y, state = ys'}) -> + Some {value = zipw.f x y, state = {f = zipw.f, xs = xs', ys = ys'}}, + | _ -> None + { uncons } + +let zip_with f xs ys : [Streamlike a srma] -> [Streamlike b srmb] -> (a -> b -> c) -> srma -> srmb -> ZipWith a b c srma srmb = + {f, xs, ys} + +// rewrite as composition of Unfold and MapSrm? +type Scan acc a srm = { + f : acc -> a -> Option acc, + acc : acc, + xs : srm +} + +let scan_streamlike : [Streamlike a srm] -> Streamlike (Scan acc a srm) = + let uncons scan = + uncons scan.xs >>= \sout -> + let {value = x, state = xs'} = sout + scan.f scan.acc x |> map (\acc' -> + {value = acc', state = {f = scan.f, acc = acc', xs = xs'}}) + { uncons } + +let scan f acc xs : [Streamlike a srm] -> (acc -> a -> acc) -> acc -> srm -> Scan acc a srm = + {f, acc, xs} + +type Flatten srm srms : { + xs : srm, + xss : srms +} + +// FIXME Will not halt if fed an infinite stream of empties +let flatten_streamlike : [Streamlike a srm] -> [Streamlike srm srms] -> Streamlike a (Flatten srm srms) = + rec let uncons flatten = match uncons flatten.xs with + | Some {value = x, state = xs'} -> + Some {value = x, state = {xs = xs', xss = flatten.xss}} + | None -> + uncons flatten.xss |> map (\sout -> + let {value = xs, state = xss'} = sout + uncons {xs, xss = xss'}) + + { uncons } + +let flatten srms : [Streamlike a srm] -> [Streamlike srm srms] -> srms -> Flatten srm srms = + {xs = empty, xss = srms} + + + +let count_from start : Int -> Unfold Int = + {f = (+) 1, acc = start} + +let count_from_by start step : Int -> Int -> Unfold Int = + {f = (+) step, acc = start} + +let take_while pred = take_while_map <| \x -> if pred x then Some x else None + +let take n = count_from 0 |> take_while ((>) n) |> zip_with (\_ x -> x) + +let repeat x : a -> Unfold a = + {f = Some, acc = x} + +let repeat_n n = take n << repeat + /* {f = \x _ -> Some x, */ + /* acc = x, */ + /* xs = count_from 0 |> take_while ((>) n)} */ + +let map_srm f = filter_map (f >> Some) + +let filter pred = filter_map <| \x -> if pred x then Some x else None + +let cycle : [Streamlike a srm] -> srm -> Flatten srm (Unfold srm) = + flatten << repeat + +let cycle_n n = flatten << repeat_n n + +let zip = zip_with <| \xs ys -> (xs, ys) + +/* let unfold f acc = scan (|>) acc (repeat f) */ + +// TODO test +/* let scan f acc = */ +/* let unf acc = */ +/* uncons acc.state |> map (f acc.value) */ +/* uncons >> unfold unf >> map_srm .value */ + + +// drop +// drop_while +// show? +// singleton? +// intercalate? +// group/chunks_of? +// split_at? From db99e31a3a895dd6e49d3dfb7468d38e48c21025 Mon Sep 17 00:00:00 2001 From: Etherian Date: Fri, 24 May 2019 15:11:48 -0400 Subject: [PATCH 2/7] style(std): cleaned up statet.glu --- std/statet.glu | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/std/statet.glu b/std/statet.glu index 8f8a0f4be8..a862e9dc2d 100644 --- a/std/statet.glu +++ b/std/statet.glu @@ -21,17 +21,16 @@ let functor : [Functor m] -> Functor (StateT s m) = { map = stmap } -// the typechecker can't find map and Functor m without help -let applicative ?mo : [Monad m] -> Applicative (StateT s m) = +let applicative : [Monad m] -> Applicative (StateT s m) = let apply srf sr : StateT s m (a -> b) -> StateT s m a -> StateT s m b = \state -> srf state >>= \fout -> let {value = f, state = state'} = fout - mo.applicative.functor.map (map_sout f) (sr state') + map (map_sout f) (sr state') let stwrap value : a -> StateT s m a = \state -> wrap { value, state } - { functor = functor ?mo.applicative.functor, apply, wrap = stwrap } + { functor, apply, wrap = stwrap } let monad : [Monad m] -> Monad (StateT s m) = let flat_map f sr : (a -> StateT s m b) -> StateT s m a -> StateT s m b = \state -> @@ -45,7 +44,7 @@ let transformer : Transformer (StateT s) = let wrap_monad ma : [Monad m] -> m a -> StateT s m a = \state -> ma >>= \value -> wrap {value, state} - { /* monad, */ wrap_monad } + { wrap_monad } let alternative : [Monad m] -> [Alternative m] -> Alternative (StateT s m) = let stor sra srb = or << sra <*> srb From adac02b952e4294c37874f313487f0fc764d514a Mon Sep 17 00:00:00 2001 From: Etherian Date: Fri, 24 May 2019 15:21:38 -0400 Subject: [PATCH 3/7] feat(std): added Alternative implementation for Result --- std/result.glu | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/std/result.glu b/std/result.glu index 4e75aed0d4..7f79b27651 100644 --- a/std/result.glu +++ b/std/result.glu @@ -1,4 +1,4 @@ -//@NO-IMPLICIT-PRELUDEJ +//@NO-IMPLICIT-PRELUDE //! Error handling type. let { Eq, Ord, Ordering, (==) } = import! std.cmp @@ -73,6 +73,14 @@ let monad : Monad (Result e) = { | Err err -> Err err, } +let alternative : [Alternative e] -> Alternative (Result e) = + let or a b = a |> map_err \ea -> + b |> map_err \eb -> + ea <|> eb + let empty = Err empty + + { or, empty } + let foldable : Foldable (Result e) = { foldr = \f z r -> match r with From 390a59fd0d3d48b0b62012440c84793328b3c974 Mon Sep 17 00:00:00 2001 From: Etherian Date: Fri, 24 May 2019 15:24:11 -0400 Subject: [PATCH 4/7] feat(std): added stuff to parser.glu --- std/parser.glu | 163 ++++++++++++++++++++++++++++++++----------------- 1 file changed, 107 insertions(+), 56 deletions(-) diff --git a/std/parser.glu b/std/parser.glu index c799e22838..71096ac842 100644 --- a/std/parser.glu +++ b/std/parser.glu @@ -4,106 +4,157 @@ let prelude = import! std.prelude let { Functor, Applicative, Alternative, Monad, (<>) } = prelude let { id, flip, (>>), (<<), (|>), (<|) } = import! std.function +let { Option } = import! std.option +let { Result, map_err } = import! std.result +let { StateT, eval_state_t , ? } = import! std.statet let { Bool } = import! std.bool let char @ { Char, ? } = import! std.char let int = import! std.int let list @ { List } = import! std.list -let { Option } = import! std.option -let { Result } = import! std.result -let streamlike @ { Streamlike, ? } = import! std.streamlike let string @ { String, ? } = import! std.string -// TODO How handle atom streams generically? Stream-like interface? +// type Parser s e a = StateT s (Result e) a + +type ParseError = + | EndOfStream + | PredicateFailed + | TokenMismatch String + | MsgErr String + | Label String (List ParseErr) + // TODO How handle error position generically? Zip stream with enumeration? -type Parser s e a = StateT s (Result e) a -// TODO How have Parser (Result Err) on surface but Streamer type (Option) internally? -// How handle custom error types this way? Do I need to build mini failure lib? - -// use implicit argument that user fills in with error type and end case? -let sr_to_psr end sr : e -> Streamer s a -> Parser s e a = - sr >> \opt -> match opt with - | Some next -> Ok next - | None -> Err end - -// terrible idea? -let any_atom : [Streamlike atm srm] -> Parser srm e atm = - sr_to_psr ? uncons // TODO Error handling - -// TODO mixing stream processors and stream adapters does not work -let take n : [Streamlike atm srm] -> Int -> Parser srm e () = - \xs -> Ok {value = (), state = streamlike.take n xs} - -// TODO What error type should library functions return? -let satisfy_map pred : [Streamlike atm srm] -> (atm -> Option a) -> Parser srm e a = +type Parser s a = StateT s (Result (List ParseErr)) a + +#[implicit] +type Parsable a s = { + any_atom : Parser s a +} + +let any_atom ?pb : [Parsable atm srm] -> Parser srm atm = pb.any_atom + +let fail err : ParseErr -> Parser srm _ = \_ -> + wrap_monad <| Err <| Cons err Nil + +let fail_msg msg : String -> Parser srm _ = \_ -> + fail (MsgErr msg) + +let label_parser lbl psr : String -> Parser srm a -> Parser srm a = \s -> + psr s |> map_err (\errs -> Cons (Label lbl errs) Nil) + +#[infix(left, 0)] +let () = flip label_parser + + +// succeeds iff the stream is empty +let eos : Parser s () = \s -> + match any_atom s with + | Err EndOfStream -> wrap () + | Ok _ -> wrap_monad (Err PredicateFailed) + | e -> e + +let parse_foldl f acc psr : (b -> a -> b) -> b -> Parser s a -> Parser s b = + map (\x -> parse_foldl f (f acc x) psr) psr <|> wrap acc + +let parse_foldr f acc psr : (a -> b -> b) -> b -> Parser s a -> Parser s b = + (wrap f <*> psr <*> parse_foldr f acc psr) <|> wrap acc + +let many psr : [Parsable atm srm] -> Parser srm a -> Parser srm (List a) = + parse_foldl (flip Cons) Nil psr + +let many1 psr : [Parsable atm srm] -> Parser srm a -> Parser srm (List a) = + wrap Cons <*> prs <*> many psr + +let chain vpsr oppsr acc : Parser s a -> Parser (b -> a -> b) -> b -> Parser s b = + let rhs = map flip oppsr <*> + parse_foldl (|>) acc rhs + +let chain1 vpsr oppsr = vpsr |> map (chain vpsr oppsr) + +let skip n : [Parsable atm srm] -> Int -> Parser srm () = + any_atom >>= \_ -> if n == 0 then + wrap () + else + skip (n - 1) + +let take_with n psr : [Parsable atm srm] -> Int -> Parser srm a -> Parser srm (List a) = + if n > 0 then + wrap Cons <*> psr <*> take_with (n-1) psr + else + wrap Nil + +let take = flip take_with any_atom + +let satisfy_map pred : [Parsable atm srm] -> (atm -> Option a) -> Parser srm a = any_atom >>= \atm -> match pred atm with | Some a -> wrap a - | None -> // TODO Error handling + | None -> wrap_monad <| Err PredicateFailed -let satisfy pred : [Streamlike atm srm] -> (atm -> Bool) -> Parser srm e atm = +let satisfy pred : [Parsable atm srm] -> (atm -> Bool) -> Parser srm atm = satisfy_map (\c -> if pred c then Some c else None) -let atom x : [Streamlike atm srm] -> [Eq atm] -> atm -> Parser srm e atm = +let atom x : [Parsable atm srm] -> [Eq atm] -> atm -> Parser srm atm = satisfy <| (==) x -rec let token ts : [Streamlike atm srm] -> [Streamlike atm tknsrm] -> [Eq atm] -> tknsrm -> Parser srm e atm = - any_atom >>= \x -> - match any_atom ts with - | Ok {value = t, state = ts'} -> +let one_of atms : [Parsable atm srm] -> [Foldable (m atm)] -> [Eq atm] -> m atm -> Parser srm atm = + satisfy (flip elem atms) + +// FIXME Fails if end of token is at end of stream? +rec let token ts : [Parsable atm srm] -> [Streamlike atm tksrm] -> [Eq atm] -> tksrm -> Parser srm tksrm = + match uncons ts with + | Some {value = t, state = ts'} -> + s |> (any_atom >>= \x -> if x == t then map (\_ -> ts) (token ts') else - Err ? // TODO Error handling - | Err ? -> wrap ts // TODO Error handling: needs to be EndOfStream error - | Err e -> (\_ -> Err e) // unreachable? - -// end - matches end of stream -// take_while1? -// many -// many1 -// skip_many? -// between -// one_of + wrap_monad (Err TokenMismatch)) + | None -> wrap ts + +let between fst x snd : Parser s a -> Parser s b -> Parser s c = + fst *> x <* snd + // sep_by // sep_by1 // chain // chain1 // parse +// lazy_parser? type Position = Int type OffsetString = { start : Position, end : Position, buffer : String } -type StringParser a = Parser OffsetString ? a // TODO Error handling +type StringParser a = Parser OffsetString a let eolsym c : Char -> Bool = elem c ['\r', '\n'] -let space : [Streamlike Char srm] -> Parser srm e Char = +let eol : [Parsable Char srm] -> Parser srm Char = (atom '\r' *> atom '\n') <|> atom '\n' <|> atom '\r' + +let space : [Parsable Char srm] -> Parser srm Char = atom ' ' -let eol : [Streamlike Char srm] -> Parser srm e Char = (atom '\r' *> atom '\n') <|> atom '\n' <|> atom '\r' +let spaces = many space -let whitespace : [Streamlike Char srm] -> Parser srm e Char = +let whitespace : [Parsable Char srm] -> Parser srm Char = satisfy char.is_whitespace -let letter : [Streamlike Char srm] -> Parser srm e Char = +let whitespaces = many whitespace + +let letter : [Parsable Char srm] -> Parser srm Char = satisfy char.is_alphabetic -let digit : [Streamlike Char srm] -> Parser srm e Char = +let digit : [Parsable Char srm] -> Parser srm Char = satisfy <| flip char.is_digit 10 -let alphanum : [Streamlike Char srm] -> Parser srm e Char = +let alphanum : [Parsable Char srm] -> Parser srm Char = letter <|> digit -// spaces -// whitespaces? -// rest of line (all but line break)? +let rest_of_line : Parser s a = + many // TODO not eol + type ByteParser a = // TODO // practice parser implementation -type PsrErr = - | ParseFailure String - | EndOfStream -type Parser a = Parser [Byte] PsrErr a +type Parser a = Parser [Byte] a From 8abc820a3cb0d8ad2dc4f40c51f7b81211ba0a76 Mon Sep 17 00:00:00 2001 From: Etherian Date: Fri, 24 May 2019 16:54:55 -0400 Subject: [PATCH 5/7] remove indexable and streamlike from parser branch --- std/indexable.glu | 11 -- std/streamlike.glu | 303 --------------------------------------------- 2 files changed, 314 deletions(-) delete mode 100644 std/indexable.glu delete mode 100644 std/streamlike.glu diff --git a/std/indexable.glu b/std/indexable.glu deleted file mode 100644 index 74d3eec550..0000000000 --- a/std/indexable.glu +++ /dev/null @@ -1,11 +0,0 @@ -type Indexable ind = { - index : ind a -> Int -> a -} - -let index ?ind : [Indexable ind] -> ind a -> Int -> a = ind.index - -{ - Indexable, - - index, -} \ No newline at end of file diff --git a/std/streamlike.glu b/std/streamlike.glu deleted file mode 100644 index 672fa5f590..0000000000 --- a/std/streamlike.glu +++ /dev/null @@ -1,303 +0,0 @@ -let { id } = import! std.function -let { Lazy, lazy, force } = import! std.lazy - -let statet @ { StateT, StateOut } = import! std.statet -let lazyt @ { LazyT } = import! std.lazyt - -// StateT vs no (vs effect system?) -// strict vs lazy -// state-machine vs dynamic vs closures (vs impl Trait equivalent?) - -// handle adapter types with monomorphization or dynamic dispatch? -// new type, Lazy (Option (a, srm)) as output type of all adapters, hiding special behavior behind closure? -// should streamlike be monadic? (a, srm) looks like State. uncons looks kinda like wrap. - -// Streamlike as a composition of monads? State + Option + Lazy? - -#[implicit] -type Streamlike a srm = { - uncons : srm -> LazyT Option (a, srm) -} - -let option_streamlike : [Streamlike a srm] -> Streamlike a (Option (a, srm)) = - { uncons = force } - -let uncons ?sl : [Streamlike a srm] -> srm -> Option (a, srm) = - sl.uncons - -let empty = lazy (\_ -> None) - -let singleton = lazy (\_ -> Some {value = x, state = empty} - -let next srm : [Streamlike a srm] -> srm -> Option a = - map fst (uncons srm) - -let take n xs : [Streamlike a srm] -> Int -> srm -> ? = - if n > 0 then - match uncons xs with - | Some (x, xs') -> Some {value = x, state = (take (n - 1) xs')} - | None -> empty - else empty - -let functor ?sml : [Streamlike a srm] -> Functor (Lazy (Option (a, srm))) = - rec let map f smout = - match force smout with - | Some (a, srm') -> lazy (\_ -> Some (f a, map f (sml.uncons srm'))) - | None -> lazy (\_ -> None) - - { map } - -let applicative ?sml : [Streamlike a srm] -> Applicative (Lazy (Option (a, srm))) = - let wrap = sml.uncons - let apply mf smout = ? - - { functor, apply, wrap } - -let monad ?sml : [Streamlike a srm] -> Monad (Lazy (Option (a, srm))) = - let flat_map f smout = - functor.map f (force smout) - - { applicative, flat_map } - -let semigroup : [Streamlike a srm] -> Semigroup srm = - let append xs ys = - match uncons xs with - | Some (x, xs') -> lazy (\_ -> Some (x, (append xs' ys))) - | None -> ys - - { append } - -let monoid : [Streamlike a srm] -> Monoid srm = - { semigroup, empty } - -// StateT strict version -#[implicit] -type Streamlike a srm = { - uncons : srm -> Option (StateOut srm a) -} - -type Streamer a srm = StateT srm Option a - -// state-machine adapters -type Unfold acc = { - f : acc -> Option acc, - acc : acc -} - -let unfold_streamlike : Streamlike acc (Unfold acc) = - let uncons unfold = - unfold.f unfold.acc |> map (\acc' -> - {value = acc', state = {f = unfold.f, acc = acc'}}) - { uncons } - -let unfold f acc : (acc -> Option acc) -> acc -> Unfold acc = - {f , acc} - -// replaced with FilterMap -/* // FIXME this seems wrong. Maybe leave mapping to stream processors somehow? */ -/* type MapSrm a b srm = { */ -/* f : a -> b, */ -/* xs : srm */ -/* } */ - -/* let mapsrm_streamlike : [Streamlike a srm] -> Streamlike b (MapSrm a b srm) = */ -/* let uncons mapsrm = */ -/* uncons mapsrm.xs |> map \{value = x, state = xs'} */ -/* {value = mapsrm.f x, state = {f = mapsrm.f, xs = xs'}} */ -/* { uncons } */ - -/* let map_srm f xs : (a -> b) -> srm -> MapSrm a b srm = */ -/* {f, xs} */ - -type FilterMap a b srm = { - pred : a -> Option b, - xs : srm -} - -// FIXME Will not halt if fed an infinite stream of elements that fail the predicate -let filter_map_streamlike : [Streamlike a srm] -> Streamlike b (FilterMap a b srm) = - rec let uncons filtermp = - uncons filtermp.xs |> map (\sout -> - let {value = x, state = xs'} = sout - match filtermp.pred x with - | Some x' -> {value = x', state = {pred = filtermp.pred, xs = xs'}} - | None -> uncons {pred = filtermp.pred, xs = xs'}) - -let filter_map pred xs : [Streamlike a srm] -> (a -> Option b) -> srm -> FilterMap a b srm = - {pred, xs} - -// replaced with FilterMap -/* // TODO Is it a problem for Filter and TakeWhile to have the same type signature/definition? */ -/* type Filter a srm = { */ -/* pred : a -> Bool, */ -/* xs : srm */ -/* } */ - -/* // FIXME Will not halt if fed an infinite stream of elements that fail the predicate */ -/* let filter_streamlike : [Streamlike a srm] -> Streamlike a (Filter a srm) = */ -/* rec let uncons filter = */ -/* uncons filter.xs |> map \{value = Some x, state = xs'} -> */ -/* if filter.pred x then */ -/* {value = x, state = {pred = filter.pred, xs = xs'}} */ -/* else */ -/* uncons {pred = filter.pred, xs = xs'} */ - -/* let filter pred xs : [Streamlike a srm] -> (a -> Bool) -> srm -> Filter a srm = */ -/* {pred, xs} */ - -/* type TakeWhile a srm = { */ -/* pred : a -> Bool, */ -/* xs : srm */ -/* } */ - -/* let take_while_streamlike : [Streamlike a srm] -> Streamlike a (TakeWhile srm) = */ -/* let uncons tw = */ -/* uncons tw.xs >>= \sout -> */ -/* let {value = x, state = xs'} = sout */ -/* if tw.pred x then */ -/* Some {value = x, state = {pred = tw.pred, xs = xs'}} */ -/* else */ -/* None */ - -/* { uncons } */ - -/* let take_while pred xs : [Streamlike a srm] -> (a -> Bool) -> srm -> TakeWhile a srm = */ -/* {pred, xs} */ - -type TakeWhileMap a b srm = { - pred : a -> Option b, - xs : srm -} - -let take_while_map_streamlike : [Streamlike a srm] -> Streamlike b (TakeWhileMap a b srm) = - let uncons tw = - uncons tw.xs >>= \sout -> - let {value = x, state = xs'} = sout - tw.pred x |> map (\x' -> - {value = x', state = {pred = tw.pred, xs = xs'}}) - - { uncons } - -let take_while_map pred xs : [Streamlike a srm] -> (a -> Option b) -> srm -> TakeWhileMap a b srm = - {pred, xs} - -// replaced with composition of Unfold and ZipWith -/* type Take srm = { */ -/* count : Int, */ -/* xs : srm */ -/* } */ - -/* let take_streamlike : [Streamlike a srm] -> Streamlike a (Take srm) = */ -/* let uncons take = */ -/* if take.count > 0 then */ -/* uncons take.xs |> map (\sout -> */ -/* let {value = x, state = xs'} = sout */ -/* {value = x, state = {count = take.count - 1, xs = xs'}}) */ -/* else */ -/* None */ -/* { uncons } */ - -/* let take n xs : [Streamlike a srm] -> Int -> srm -> Take srm = */ -/* {count = n, xs} */ - -type ZipWith a b c srma srmb = { - f : (a -> b -> c), - xs : srma, - ys : srmb -} - -let zip_with_streamlike : [Streamlike a srma] -> [Streamlike b srmb] -> Streamlike c (ZipWith a b c srma srmb) = - let uncons zipw = match (uncons zipw.xs, uncons zipw.ys) with - | (Some {value = x, state = xs'}, Some {value = y, state = ys'}) -> - Some {value = zipw.f x y, state = {f = zipw.f, xs = xs', ys = ys'}}, - | _ -> None - { uncons } - -let zip_with f xs ys : [Streamlike a srma] -> [Streamlike b srmb] -> (a -> b -> c) -> srma -> srmb -> ZipWith a b c srma srmb = - {f, xs, ys} - -// rewrite as composition of Unfold and MapSrm? -type Scan acc a srm = { - f : acc -> a -> Option acc, - acc : acc, - xs : srm -} - -let scan_streamlike : [Streamlike a srm] -> Streamlike (Scan acc a srm) = - let uncons scan = - uncons scan.xs >>= \sout -> - let {value = x, state = xs'} = sout - scan.f scan.acc x |> map (\acc' -> - {value = acc', state = {f = scan.f, acc = acc', xs = xs'}}) - { uncons } - -let scan f acc xs : [Streamlike a srm] -> (acc -> a -> acc) -> acc -> srm -> Scan acc a srm = - {f, acc, xs} - -type Flatten srm srms : { - xs : srm, - xss : srms -} - -// FIXME Will not halt if fed an infinite stream of empties -let flatten_streamlike : [Streamlike a srm] -> [Streamlike srm srms] -> Streamlike a (Flatten srm srms) = - rec let uncons flatten = match uncons flatten.xs with - | Some {value = x, state = xs'} -> - Some {value = x, state = {xs = xs', xss = flatten.xss}} - | None -> - uncons flatten.xss |> map (\sout -> - let {value = xs, state = xss'} = sout - uncons {xs, xss = xss'}) - - { uncons } - -let flatten srms : [Streamlike a srm] -> [Streamlike srm srms] -> srms -> Flatten srm srms = - {xs = empty, xss = srms} - - - -let count_from start : Int -> Unfold Int = - {f = (+) 1, acc = start} - -let count_from_by start step : Int -> Int -> Unfold Int = - {f = (+) step, acc = start} - -let take_while pred = take_while_map <| \x -> if pred x then Some x else None - -let take n = count_from 0 |> take_while ((>) n) |> zip_with (\_ x -> x) - -let repeat x : a -> Unfold a = - {f = Some, acc = x} - -let repeat_n n = take n << repeat - /* {f = \x _ -> Some x, */ - /* acc = x, */ - /* xs = count_from 0 |> take_while ((>) n)} */ - -let map_srm f = filter_map (f >> Some) - -let filter pred = filter_map <| \x -> if pred x then Some x else None - -let cycle : [Streamlike a srm] -> srm -> Flatten srm (Unfold srm) = - flatten << repeat - -let cycle_n n = flatten << repeat_n n - -let zip = zip_with <| \xs ys -> (xs, ys) - -/* let unfold f acc = scan (|>) acc (repeat f) */ - -// TODO test -/* let scan f acc = */ -/* let unf acc = */ -/* uncons acc.state |> map (f acc.value) */ -/* uncons >> unfold unf >> map_srm .value */ - - -// drop -// drop_while -// show? -// singleton? -// intercalate? -// group/chunks_of? -// split_at? From 48d845bf1c5eeea11cccde07d749f62d8d656e4e Mon Sep 17 00:00:00 2001 From: Etherian Date: Sat, 25 May 2019 23:52:18 -0400 Subject: [PATCH 6/7] fix(std): fixed Result's Alternative implementation --- std/result.glu | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/std/result.glu b/std/result.glu index 7f79b27651..6bd45eec9e 100644 --- a/std/result.glu +++ b/std/result.glu @@ -73,13 +73,17 @@ let monad : Monad (Result e) = { | Err err -> Err err, } -let alternative : [Alternative e] -> Alternative (Result e) = - let or a b = a |> map_err \ea -> - b |> map_err \eb -> - ea <|> eb - let empty = Err empty - - { or, empty } +let alternative ?alt : [Alternative m] -> Alternative (Result (m e)) = + let or a b = + match a with + | Ok a -> Ok a + | Err ea -> + match b with + | Ok b -> Ok b + | Err eb -> Err (ea <|> eb) + let empty = Err alt.empty + + { applicative, or, empty } let foldable : Foldable (Result e) = { foldr = \f z r -> @@ -119,6 +123,7 @@ let show ?e ?t : [Show e] -> [Show t] -> Show (Result e t) = functor, applicative, monad, + alternative, foldable, traversable, show, From c738f6c1ab3f0342f88b1c3c11373d44d2fddf2f Mon Sep 17 00:00:00 2001 From: Etherian Date: Sun, 26 May 2019 02:01:33 -0400 Subject: [PATCH 7/7] fix(std): fix Result's Alternative implementation again --- std/result.glu | 1 + 1 file changed, 1 insertion(+) diff --git a/std/result.glu b/std/result.glu index 6bd45eec9e..1b6d7d3b4a 100644 --- a/std/result.glu +++ b/std/result.glu @@ -6,6 +6,7 @@ let { Show } = import! std.show let { Functor } = import! std.functor let { Applicative } = import! std.applicative let { Monad } = import! std.monad +let { Alternative, (<|>) } = import! std.alternative let { Result } = import! std.types let { Foldable } = import! std.foldable let { Traversable } = import! std.traversable