diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,22 @@ +# 3.0.0.0 + + * Rewrite backend to always stream/not blow up memory + * Better error messages when a field is out of bounds + * Better error message on empty `|>` (`fold1`) + * Fix parsing bug in curried binary operators + * Add `--asv` and `--usv` command-line flags + * Add `:set asv;` `:set usv;` to language + * Add `Witherable` instance for `List` + * Add `subs` builtin + +# 2.0.3.0 + + * Handle some parsing/currying cases (still hinky) + * Add `sub1` builtin like AWK's `sub` + * Better presentation of regex engine errors + * Faster float printing + * Rewrite pretty-printer to parenthesize correctly. + # 2.0.2.0 * Add support for custom record separators diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,5 @@ -Jacinda is a functional, expression-oriented data processing language, -complementing [AWK](http://www.awklang.org). +Jacinda is a functional pattern sifting language, +a smaller [AWK](http://www.awklang.org). # Installation @@ -23,13 +23,29 @@ There is a [vim plugin](https://github.com/vmchale/jacinda-vim) and a [VSCode extension](https://marketplace.visualstudio.com/items?itemName=vmchale.jacinda). -# SHOCK & AWE +# Usefulness +Unix uses record separators in many places; we can display one entry in the +`PATH` variable with: + ``` -curl -sL https://raw.githubusercontent.com/nychealth/coronavirus-data/master/latest/now-weekly-breakthrough.csv | \ - ja ',[1.0-x%y] {ix>1}{`5:} {ix>1}{`17:}' -F, +echo $PATH | ja -F: "{|[x+'\n'+y]|>\`$}" ``` +Many Unix tools output much information separated with spaces. We use regular +expressions to match relevant lines and then select the field with the data +itself, viz. + +``` +otool -l $(locate libpng.dylib) | ja '{`1 ~ /^name/}{`2}' +``` + +To get the value of a variable (say, `PATH`) from the output of `printenv`: + +``` +printenv | ja -F= '{%/^PATH/}{`2}' +``` + ## Rosetta Replace @@ -64,8 +80,8 @@ * No nested dfns * No list literal syntax * Postfix `:f` and `:i` are handled poorly - * Polymorphic functions can't be instantiated with separate types (global - monomorphism restriction) + * Streams of functions don't work + * Higher-order functions are subtly broken Intentionally missing features: @@ -76,3 +92,7 @@ * [Rust's regular expressions](https://docs.rs/regex/) - extensively documented with Unicode support * Deduplicate builtin + +# Contributing + +Bug reports are welcome contributions. diff --git a/app/Main.hs b/app/Main.hs deleted file mode 100644 --- a/app/Main.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Main (main) where - -import qualified Data.Text as T -import qualified Data.Text.IO as TIO -import qualified Data.Version as V -import File -import Options.Applicative -import qualified Paths_jacinda as P -import System.IO (stdin) - -data Command = TypeCheck !FilePath ![FilePath] - | Run !FilePath !(Maybe FilePath) ![FilePath] - | Expr !T.Text !(Maybe FilePath) !(Maybe T.Text) !Bool !(Maybe T.Text) ![FilePath] - | Eval !T.Text - -jacFile :: Parser FilePath -jacFile = argument str - (metavar "JACFILE" - <> help "Source code" - <> jacCompletions) - -asv :: Parser Bool -asv = switch - (long "asv" - <> help "Read from ASV") - -jacRs :: Parser (Maybe T.Text) -jacRs = optional $ option str - (short 'R' - <> metavar "REGEXP" - <> help "Record separator") - -jacFs :: Parser (Maybe T.Text) -jacFs = optional $ option str - (short 'F' - <> metavar "REGEXP" - <> help "Field separator") - -jacExpr :: Parser T.Text -jacExpr = argument str - (metavar "EXPR" - <> help "Jacinda expression") - -inpFile :: Parser (Maybe FilePath) -inpFile = optional $ option str - (short 'i' - <> metavar "DATAFILE" - <> help "Data file") - -jacCompletions :: HasCompleter f => Mod f a -jacCompletions = completer . bashCompleter $ "file -X '!*.jac' -o plusdirs" - -commandP :: Parser Command -commandP = hsubparser - (command "tc" (info tcP (progDesc "Type-check file")) - <> command "e" (info eP (progDesc "Evaluate an expression (no file context)")) - <> command "run" (info runP (progDesc "Run from file"))) - <|> exprP - where - tcP = TypeCheck <$> jacFile <*> includes - runP = Run <$> jacFile <*> inpFile <*> includes - exprP = Expr <$> jacExpr <*> inpFile <*> jacFs <*> asv <*> jacRs <*> includes - eP = Eval <$> jacExpr - -includes :: Parser [FilePath] -includes = many $ strOption - (metavar "DIR" - <> long "include" - <> short 'I' - <> dirCompletions) - -dirCompletions :: HasCompleter f => Mod f a -dirCompletions = completer . bashCompleter $ "directory" - - -wrapper :: ParserInfo Command -wrapper = info (helper <*> versionMod <*> commandP) - (fullDesc - <> progDesc "Jacinda language for functional stream processing, filtering, and reports" - <> header "Jacinda - a functional complement to AWK") - -versionMod :: Parser (a -> a) -versionMod = infoOption (V.showVersion P.version) (short 'V' <> long "version" <> help "Show version") - -main :: IO () -main = run =<< execParser wrapper - -ap :: Bool -> Maybe T.Text -> Maybe T.Text -ap True Just{} = errorWithoutStackTrace "--asv specified with field separator." -ap True Nothing = Just "\\x1f" -ap _ fs = fs - -run :: Command -> IO () -run (TypeCheck fp is) = tcIO is =<< TIO.readFile fp -run (Run fp Nothing is) = do { contents <- TIO.readFile fp ; runOnHandle is contents Nothing Nothing stdin } -run (Run fp (Just dat) is) = do { contents <- TIO.readFile fp ; runOnFile is contents Nothing Nothing dat } -run (Expr eb Nothing fs a rs is) = runOnHandle is eb (ap a fs) rs stdin -run (Expr eb (Just fp) fs a rs is) = runOnFile is eb (ap a fs) rs fp -run (Eval e) = print (exprEval e) diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -12,12 +12,18 @@ main :: IO () main = defaultMain [ bgroup "eval" - [ bench "exprEval" $ nf exprEval "[x+' '+y]|'' split '01-23-1987' /-/" - , bench "path" $ nfIO (silence $ runOnFile [] "{|[x+'\\n'+y]|>`$}" (Just ":") Nothing "bench/data/PATH") + [ bench "exprEval" $ nf exprEval "[x+' '+y]|'' split '01-23-1987' /-/" ] + , bgroup "stream" + [ bench "path" $ nfIO (silence $ runOnFile [] "{|[x+'\\n'+y]|>`$}" (Just ":") Nothing "bench/data/PATH") , bench "RS" $ nfIO (silence $ runOnFile [] "$0" Nothing (Just ":") "bench/data/PATH") , bench "runOnFile" $ nfIO (silence $ runOnFile [] "(+)|0 {%/Bloom/}{1}" Nothing Nothing "bench/data/ulysses.txt") , bench "runOnFile" $ nfIO (silence $ do { contents <- TIO.readFile "examples/wc.jac" ; runOnFile [] contents Nothing Nothing "bench/data/ulysses.txt" }) , bench "runOnFile" $ nfIO (silence $ do { contents <- TIO.readFile "examples/span2.jac" ; runOnFile [] contents Nothing Nothing "bench/data/span.txt" }) + , bench "sedstream.jac" $ nfIO (silence $ do { contents <- TIO.readFile "examples/sedstream.jac" ; runOnFile [] contents Nothing Nothing "bench/data/lines.txt" }) + , bench "gnused.jac" $ nfIO (silence $ do { contents <- TIO.readFile "examples/gnused.jac" ; runOnFile [] contents Nothing Nothing "bench/data/lines.txt" }) + , bench "fungnused.jac" $ nfIO (silence $ do { contents <- TIO.readFile "examples/fungnused.jac" ; runOnFile [] contents Nothing Nothing "bench/data/lines.txt" }) + , bench "hsLibversionMac.jac" $ nfIO (silence $ do { contents <- TIO.readFile "examples/hsLibversionMac.jac"; runOnFile [] contents Nothing Nothing "bench/data/pandoc-mac" }) + , bench "sedsmtp.jac" $ nfIO (silence $ do { contents <- TIO.readFile "examples/sedsmtp.jac" ; runOnFile [] contents Nothing Nothing "test/examples/data/2.txt" }) ] ] diff --git a/doc/guide.pdf b/doc/guide.pdf Binary files a/doc/guide.pdf and b/doc/guide.pdf differ diff --git a/examples/bc.jac b/examples/bc.jac deleted file mode 100644 --- a/examples/bc.jac +++ /dev/null @@ -1,2 +0,0 @@ -{. {#t}{#`0} -#"$0 diff --git a/examples/compilerVersion.jac b/examples/compilerVersion.jac new file mode 100644 --- /dev/null +++ b/examples/compilerVersion.jac @@ -0,0 +1,7 @@ +{. readelf -p .comment -p .note.gnu.gold-version $(which ja) | ja run compilerVersion.jac +@include'lib/string.jac' + +:set rs:=/String dump of section '[\.a-z\-]*':\n/; +:set fs:=/\s*\[[ a-f0-9]*\]\s*/; + +unlines¨{% /[^\s]/}{(λstr. str ~* 1 /([^\n]*)\s*/):?([x ~ /GHC|GCC|clang|mold|rustc|gold/] #. `$)} diff --git a/examples/fungnused.jac b/examples/fungnused.jac new file mode 100644 --- /dev/null +++ b/examples/fungnused.jac @@ -0,0 +1,10 @@ +{. https://www.gnu.org/software/sed/manual/sed.html#Joining-lines + +fn go(acc, line) := + let + val next := option [x] [(x+)] (acc->1) + in + option (None . (Some (next line))) [(Some (next x) . None)] (line ~* 1 /([^\\]*)\\/) + end; + +[x->2]:?(go^(None . None) $0) diff --git a/examples/gnused.jac b/examples/gnused.jac new file mode 100644 --- /dev/null +++ b/examples/gnused.jac @@ -0,0 +1,5 @@ +{. https://www.gnu.org/software/sed/manual/sed.html#Joining-lines +fn go(acc, line) := + option (acc+'\n'+line) [x+line] (acc ~* 1 /([^\\]*)\\/); + +go|>$0 diff --git a/examples/hsLibversion.jac b/examples/hsLibversion.jac --- a/examples/hsLibversion.jac +++ b/examples/hsLibversion.jac @@ -1,1 +1,1 @@ -.?{| `0 ~* 1 /(^[A-Za-z][A-Za-z0-9\-]*\-\d+(\.\d+)*)\-[0-9a-f]{64}$/} +~..?{| `0 ~* 1 /(^[A-Za-z][A-Za-z0-9\-]*\-\d+(\.\d+)*)\-([0-9a-f]{64}|[0-9a-f]{4})/} diff --git a/examples/hsLibversion2.jac b/examples/hsLibversion2.jac --- a/examples/hsLibversion2.jac +++ b/examples/hsLibversion2.jac @@ -1,1 +1,1 @@ -[x ~* 1 /(^[A-Za-z][A-Za-z0-9\-]*\-\d+(\.\d+)*)\-[0-9a-f]{64}$/]:? $0 +~.[x ~* 1 /(^[A-Za-z][A-Za-z0-9\-]*\-\d+(\.\d+)*)\-([0-9a-f]{64}$|[0-9a-f]{4})/]:? $0 diff --git a/examples/hsLibversionMac.jac b/examples/hsLibversionMac.jac --- a/examples/hsLibversionMac.jac +++ b/examples/hsLibversionMac.jac @@ -1,1 +1,1 @@ -~..?{| `0 ~* 1 /(^[A-Za-z][A-Za-z0-9\-]*\-\d+(\.\d+)*)\-[0-9a-zA-Z]{8}$/} +~..?{| `0 ~* 1 /(^[A-Za-z][A-Za-z0-9\-]*\-\d+(\.\d+)*)\-([0-9a-f]{8}|[0-9a-f]{4})$/} diff --git a/examples/hsLibversionMac2.jac b/examples/hsLibversionMac2.jac --- a/examples/hsLibversionMac2.jac +++ b/examples/hsLibversionMac2.jac @@ -1,1 +1,1 @@ -~.[x ~* 1 /(^[A-Za-z][A-Za-z0-9\-]*\-\d+(\.\d+)*)\-[0-9a-zA-Z]{22}$/]:? $0 +~.[x ~* 1 /(^[A-Za-z][A-Za-z0-9\-]*\-\d+(\.\d+)*)\-([0-9a-zA-Z]{8}|[0-9a-zA-Z]{4})$/]:? $0 diff --git a/examples/lc.jac b/examples/lc.jac deleted file mode 100644 --- a/examples/lc.jac +++ /dev/null @@ -1,3 +0,0 @@ -{. (+)|0 {/./}{1} (count nonblank lines) -(+)|0 {#t}{1} -{. (+)|0 #"$0 (count bytes in file) diff --git a/examples/liblibversion.jac b/examples/liblibversion.jac --- a/examples/liblibversion.jac +++ b/examples/liblibversion.jac @@ -1,3 +1,5 @@ @include'lib/string.jac' -(+)|'' (intercalate '\n')¨{% /-lHS/}{captures `0 1 /-lHS([A-Aa-z][A-Za-z0-9\-]*\d+(\.\d+)*)/} +{. TODO: handle type-equality-1-b4033320810f291878747510666a8cf89d0b44830502670dc4d3746b158afa8 + +unlines¨{% /-lHS/}{captures `0 1 /-lHS([A-Aa-z][A-Za-z0-9\-]*\d+(\.\d+)*)/} diff --git a/examples/libversion.jac b/examples/libversion.jac --- a/examples/libversion.jac +++ b/examples/libversion.jac @@ -1,1 +1,1 @@ -(+)|> ([x+'\n'+y]|>)¨{%/-lHS/}{captures `0 1 /-lHS([A-Aa-z][A-Za-z0-9\-]*\d+(\.\d+)*)/} +([x+'\n'+y]|>)¨{%/-lHS/}{captures `0 1 /-lHS([A-Aa-z][A-Za-z0-9\-]*\d+(\.\d+)*)/} diff --git a/examples/nl.jac b/examples/nl.jac --- a/examples/nl.jac +++ b/examples/nl.jac @@ -1,14 +1,11 @@ -{. FIXME: figure out @include'lib/string.jac'?? @include'lib/string.jac' fn step(acc, line) := - if empty line - then (acc->1 . '') - else (acc->1 + 1 . line); + ?empty line; + (acc->1 . ''); + (acc->1 + 1 . line); fn process(x) := - if !empty (x->2) - then sprintf ' %i\t%s' x - else ''; + ?!empty (x->2); sprintf ' %i\t%s' x; ''; process"step^(0 . '') $0 diff --git a/examples/nmCtx.jac b/examples/nmCtx.jac --- a/examples/nmCtx.jac +++ b/examples/nmCtx.jac @@ -4,9 +4,7 @@ @include'lib/maybe.jac' fn mMatch(str, re) := - if str ~ re - then Some str - else None; + ?str ~ re; Some str; None; fn step(ctx, line) := let diff --git a/examples/sed.jac b/examples/sed.jac deleted file mode 100644 --- a/examples/sed.jac +++ /dev/null @@ -1,14 +0,0 @@ -{. program equiv to s/^(type|interface)/export \1/ - -@include'prelude/fn.jac' - -fn replaceAtWith(line, ixes) := - let - val pre := take (ixes->1) line - val at := drop (ixes->1) line {. in our case - in pre + 'export ' + at end; - -fn replaceAt(line) := - option line (replaceAtWith line) (match line /^(type|interface)/); - -replaceAt"$0 diff --git a/examples/sedreplace.jac b/examples/sedreplace.jac deleted file mode 100644 --- a/examples/sedreplace.jac +++ /dev/null @@ -1,11 +0,0 @@ -{. s/^var/export const/ in sed - -@include'prelude/fn.jac' - -fn insert(line, str, ixes) := - take (ixes->1) line + str + drop (ixes->2) line; - -fn replace(re, str, line) := - option line (insert line str) (match line re); - -(replace /^var/ 'export const')"$0 diff --git a/examples/sedsmtp.jac b/examples/sedsmtp.jac new file mode 100644 --- /dev/null +++ b/examples/sedsmtp.jac @@ -0,0 +1,7 @@ +{. https://www.gnu.org/software/sed/manual/sed.html#Joining-lines +{. SMTP example + +fn go(acc, line) := + option (acc+'\n'+line) [acc+' '+x] (line ~* 1 /^\s+(\.*)/); + +go|>$0 diff --git a/examples/sedstream.jac b/examples/sedstream.jac new file mode 100644 --- /dev/null +++ b/examples/sedstream.jac @@ -0,0 +1,11 @@ +{. https://www.gnu.org/software/sed/manual/sed.html#Joining-lines +@include'prelude/fn.jac' + +fn go(acc, line) := + let + val accStr := fromMaybe '' (acc->1) + in + option (None . Some (accStr+line)) [(Some (accStr+x) . None)] (line ~* 1 /([^\\]*)\\/) + end; + +[x->2]:?(go^(None.None) $0) diff --git a/examples/slow.jac b/examples/slow.jac new file mode 100644 --- /dev/null +++ b/examples/slow.jac @@ -0,0 +1,1 @@ +(+)|> ([x+'\n'+y]|>)¨{|captures `0 1 /-lHS([A-Aa-z][A-Za-z0-9\-]*\d+(\.\d+)*)/} diff --git a/examples/stripUnprintable.jac b/examples/stripUnprintable.jac deleted file mode 100644 --- a/examples/stripUnprintable.jac +++ /dev/null @@ -1,3 +0,0 @@ -@include'lib/string.jac' - -(replace /[^[:print:]]/ '')"$0 diff --git a/examples/sumLs.jac b/examples/sumLs.jac deleted file mode 100644 --- a/examples/sumLs.jac +++ /dev/null @@ -1,2 +0,0 @@ -{. ls -l | ja ... -{ix>1}{`5:i} diff --git a/examples/tabularize.jac b/examples/tabularize.jac new file mode 100644 --- /dev/null +++ b/examples/tabularize.jac @@ -0,0 +1,5 @@ +:set fs:=/\s+\|\s+/; + +sprintf '%s
' + ([x+'\n'+y]|> + {|sprintf '%s' ((+)|>((if ix=1 then sprintf '%s' else sprintf '%s')¨`$))}) diff --git a/examples/trailingLine.jac b/examples/trailingLine.jac --- a/examples/trailingLine.jac +++ b/examples/trailingLine.jac @@ -1,1 +1,1 @@ -if [y]|>$0 = '' then fp else '' +?[y]|>$0 = ''; fp; '' diff --git a/examples/trimwhitespace.jac b/examples/trimwhitespace.jac deleted file mode 100644 --- a/examples/trimwhitespace.jac +++ /dev/null @@ -1,3 +0,0 @@ -@include'lib/sed.jac' - -(replace1 /\s+$/ '')"$0 diff --git a/examples/uniq.jac b/examples/uniq.jac --- a/examples/uniq.jac +++ b/examples/uniq.jac @@ -1,6 +1,6 @@ fn step(acc, this) := - if this = acc->1 - then (this . None) - else (this . Some this); + ?this = acc->1; + (this . None); + (this . Some this); (->2):?step^(''.None) $0 diff --git a/examples/year.jac b/examples/year.jac deleted file mode 100644 --- a/examples/year.jac +++ /dev/null @@ -1,2 +0,0 @@ -{. extract year from column of dates in YYYY-MM-DD format -.? {|`1 ~* 1 /(\d{4})-\d{2}-\d{2}/} diff --git a/jacinda.cabal b/jacinda.cabal --- a/jacinda.cabal +++ b/jacinda.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: jacinda -version: 2.0.2.0 +version: 3.0.0.0 license: AGPL-3.0-only license-file: COPYING maintainer: vamchale@gmail.com @@ -35,7 +35,14 @@ default: False manual: True +common warnings + ghc-options: + -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wredundant-constraints -Widentities -Wcpp-undef + -Wmissing-export-lists -Wunused-packages + library jacinda-lib + import: warnings exposed-modules: Parser Parser.Rw @@ -57,23 +64,14 @@ Jacinda.Check.Field Jacinda.Backend.Parse Jacinda.Backend.Const - Jacinda.Backend.P + Jacinda.Backend.T Jacinda.Backend.Printf Include Paths_jacinda autogen-modules: Paths_jacinda default-language: Haskell2010 - other-extensions: - OverloadedStrings OverloadedLists DeriveFunctor FlexibleContexts - DeriveAnyClass DeriveGeneric TypeFamilies - - ghc-options: - -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wredundant-constraints -Widentities -Wcpp-undef - -Wmissing-export-lists -Wunused-packages -Wall -O2 - -Wno-missing-signatures -Wno-x-partial - + ghc-options: -Wall -O2 -Wno-missing-signatures -Wno-x-partial build-depends: base >=4.11.0.0 && <5, bytestring >=0.11.0.0, @@ -93,40 +91,44 @@ split, deepseq + other-extensions: + OverloadedStrings + OverloadedLists + DeriveFunctor + FlexibleContexts + DeriveAnyClass + DeriveGeneric + TypeFamilies + if !flag(cross) build-tool-depends: alex:alex >=3.5.0.0, happy:happy executable ja + import: warnings main-is: Main.hs - hs-source-dirs: app + hs-source-dirs: x other-modules: Paths_jacinda autogen-modules: Paths_jacinda default-language: Haskell2010 - ghc-options: - -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wredundant-constraints -Widentities -Wcpp-undef - -Wmissing-export-lists -Wunused-packages -Wall -rtsopts - "-with-rtsopts=-A200k -k32k" -Wincomplete-uni-patterns - -Wincomplete-record-updates -Wredundant-constraints -Widentities - -Wcpp-undef -Wmissing-export-lists -Wunused-packages - + ghc-options: -Wall -rtsopts "-with-rtsopts=-A200k -k32k" build-depends: base, jacinda-lib, optparse-applicative >=0.14.1.0, text + ghc-options: + -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wredundant-constraints -Widentities -Wcpp-undef + -Wmissing-export-lists -Wunused-packages + test-suite jacinda-test + import: warnings type: exitcode-stdio-1.0 main-is: Spec.hs hs-source-dirs: test default-language: Haskell2010 - ghc-options: - -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wredundant-constraints -Widentities -Wcpp-undef - -Wmissing-export-lists -Wunused-packages -Wall -threaded -rtsopts - "-with-rtsopts=-N -K1K" -Wall - + ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N -K1K" -Wall build-depends: base, jacinda-lib, @@ -136,16 +138,12 @@ tasty-hunit benchmark jacinda-bench + import: warnings type: exitcode-stdio-1.0 main-is: Bench.hs hs-source-dirs: bench default-language: Haskell2010 - ghc-options: - -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wredundant-constraints -Widentities -Wcpp-undef - -Wmissing-export-lists -Wunused-packages -Wall -rtsopts - "-with-rtsopts=-A200k -k32k" - + ghc-options: -Wall -rtsopts "-with-rtsopts=-A200k -k32k" build-depends: base, criterion, diff --git a/lib/sed.jac b/lib/sed.jac --- a/lib/sed.jac +++ b/lib/sed.jac @@ -1,8 +1,3 @@ @include'prelude/fn.jac' -{. example: (replace /^var/ 'export const')"$0 -fn replace1(re, str, line) := - let - val insert := \line. \str. \ixes. - take (ixes->1) line + str + drop (ixes->2) line - in option line (insert line str) (match line re) end; +fn replace1(re, str, line) := sub1 re str line; diff --git a/lib/string.jac b/lib/string.jac --- a/lib/string.jac +++ b/lib/string.jac @@ -4,5 +4,12 @@ fn replace(re, t, str) := [x+t+y] |> (split str re); +{. censor, bowlderize, expunge? +fn redact(re, x) := + sub1 re '' x; + fn empty(str) := #str = 0; + +fn unlines(strs) := + intercalate '\n' strs; diff --git a/man/ja.1 b/man/ja.1 --- a/man/ja.1 +++ b/man/ja.1 @@ -1,4 +1,4 @@ -.\" Automatically generated by Pandoc 3.1.12 +.\" Automatically generated by Pandoc 3.1.13 .\" .TH "ja (1)" "" "" "" "" .SH NAME @@ -104,6 +104,12 @@ \f[B]substr\f[R] Extract substring Str \-> Int \-> Int \-> Str .TP +\f[B]sub1\f[R] Substitute first occurrence +Regex \-> Str \-> Str \-> Str +.TP +\f[B]subs\f[R] Substitute all occurrences +Regex \-> Str \-> Str \-> Str +.TP \f[B]split\f[R] Split a string by regex Str \-> Regex \-> List Str .TP @@ -132,7 +138,7 @@ Str \-> Int \-> Regex \-> Option Str .TP \f[B]captures\f[R] Return all aptures (nth capture group) -Str \-> Int \-> Regex \-> List Str +Str \-> Int \-> Regex \-> Str .TP \f[B]:?\f[R] mapMaybe Witherable f :=> (a \-> Option b) \-> f a \-> f b @@ -143,6 +149,8 @@ \f[B]fp\f[R] Filename .PP \f[B]nf\f[R] Number of fields +.PP +\f[B]⍬\f[R] Empty string/empty list .SS SYNTAX \f[B]\[ga]n\f[R] nth field .PP @@ -177,6 +185,12 @@ \f[B]{.\f[R] Line comment .PP \f[B]\[at]include\[aq]/path/file.jac\[cq]\f[R] File include +.PP +\f[B]?; ; \f[R] If\&... +then\&... +else +.PP +\f[B],, \f[R] Bookend a stream .SS DECLARATIONS \f[B]:set fs=/REGEX/;\f[R] Set field separator .PP @@ -228,9 +242,6 @@ .TP [y]|> {|\[ga]0\[ti]/\[ha]$/} Is the last line blank? -.TP -\&.?{|\[ga]1 \[ti]* 1 /([\[ha]\[rs]?]*)/} -Trim URL .SH BUGS Please report any bugs you may come across to https://github.com/vmchale/jacinda/issues diff --git a/src/A.hs b/src/A.hs --- a/src/A.hs +++ b/src/A.hs @@ -19,6 +19,7 @@ import qualified Data.ByteString as BS import qualified Data.IntMap as IM import Data.List (foldl') +import Data.Maybe (isJust) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) import qualified Data.Vector as V @@ -36,7 +37,7 @@ (<##>) :: Doc a -> Doc a -> Doc a (<##>) x y = x <> hardline <> hardline <> y -data TB = TyInteger | TyFloat | TyStr +data TB = TyI | TyFloat | TyStr | TyStream | TyVec | TyOption | TyR | TyBool | TyUnit deriving (Eq, Ord) @@ -66,7 +67,7 @@ deriving (Eq, Ord) instance Pretty TB where - pretty TyInteger = "Integer"; pretty TyStr = "Str"; pretty TyFloat = "Float" + pretty TyI = "Integer"; pretty TyStr = "Str"; pretty TyFloat = "Float" pretty TyStream = "Stream"; pretty TyVec = "List"; pretty TyOption = "Optional" pretty TyBool = "Bool"; pretty TyUnit = "𝟙"; pretty TyR = "Regex" @@ -80,6 +81,8 @@ pretty (TyTup tys) = jacTup tys pretty (Rho n fs) = braces (pretty n <+> pipe <+> prettyFields (IM.toList fs)) +parensp True=parens; parensp False=id + prettyFields :: [(Int, T)] -> Doc ann prettyFields = mconcat . punctuate "," . fmap g where g (i, t) = pretty i <> ":" <+> pretty t @@ -116,9 +119,10 @@ data BTer = ZipW | Fold | Scan - | Substr + | Substr | Sub1 | Subs | Option | Captures | AllCaptures + | Bookend deriving (Eq) instance Pretty BTer where @@ -129,6 +133,9 @@ pretty Option = "option" pretty Captures = "~*" pretty AllCaptures = "captures" + pretty Sub1 = "sub1" + pretty Subs = "subs" + pretty Bookend = "bookend" -- builtin data BBin = Plus | Times | Div @@ -160,10 +167,12 @@ instance Pretty DfnVar where pretty X = "x"; pretty Y = "y" -- 0-ary -data N = Ix | Nf | None | Fp deriving (Eq) +data N = Ix | Nf | None | Fp | MZ deriving (Eq) data L = ILit !Integer | FLit !Double | BLit !Bool | StrLit BS.ByteString deriving (Generic, NFData, Eq) +class PS a where ps :: Int -> a -> Doc ann + -- expression data E a = Column { eLoc :: a, col :: Int } | IParseCol { eLoc :: a, col :: Int } | FParseCol { eLoc :: a, col :: Int } | ParseCol { eLoc :: a, col :: Int } @@ -179,6 +188,7 @@ | Let { eLoc :: a, eBind :: (Nm a, E a), eE :: E a } -- TODO: literals type (make pattern matching easier down the road) | Var { eLoc :: a, eVar :: !(Nm a) } + | F { hole :: !(Nm a) } | Lit { eLoc :: a, lit :: !L } | RegexLit { eLoc :: a, eRr :: BS.ByteString } | Lam { eLoc :: a, eBound :: Nm a, lamE :: E a } @@ -195,6 +205,7 @@ | Cond { eLoc :: a, eIf :: E a, eThen :: E a, eElse :: E a } | In { oop :: E a, ip :: Maybe (E a), mm :: Maybe (E a), istream :: E a } | RwB { eLoc :: a, eBin :: BBin } | RwT { eLoc :: a, eTer :: BTer } + -- TODO: "Report" aka $> print stream + display summary expression deriving (Functor, Generic) instance Recursive (E a) where @@ -208,6 +219,7 @@ | GuardedF a x x | ImplicitF a x | LetF a (Nm a, x) x | VarF a (Nm a) + | FF (Nm a) | LitF a !L | RegexLitF a BS.ByteString | LamF a (Nm a) x @@ -228,7 +240,7 @@ type instance Base (E a) = (EF a) instance Pretty N where - pretty Ix = "⍳"; pretty Nf = "nf"; pretty None = "None"; pretty Fp = "fp" + pretty Ix="⍳"; pretty Nf="nf"; pretty None="None"; pretty Fp="fp"; pretty MZ="⍬" instance Pretty L where pretty (ILit i) = pretty i @@ -237,70 +249,87 @@ pretty (BLit False) = "#f" pretty (StrLit str) = pretty (decodeUtf8 str) -instance Pretty (E a) where - pretty (Column _ i) = "$" <> pretty i - pretty AllColumn{} = "$0" - pretty IParseAllCol{} = "$0:i" - pretty FParseAllCol{} = "$0:f" - pretty ParseAllCol{} = "$0:" - pretty (IParseCol _ i) = "$" <> pretty i <> ":i" - pretty (FParseCol _ i) = "$" <> pretty i <> ":f" - pretty (ParseCol _ i) = "$" <> pretty i <> ":" - pretty AllField{} = "`0" - pretty (Field _ i) = "`" <> pretty i - pretty LastField{} = "`*" - pretty FieldList{} = "`$" - pretty (EApp _ (EApp _ (BB _ Prior) e) e') = pretty e <> "\\." <+> pretty e' - pretty (EApp _ (EApp _ (BB _ Max) e) e') = "max" <+> pretty e <+> pretty e' - pretty (EApp _ (EApp _ (BB _ Min) e) e') = "min" <+> pretty e <+> pretty e' - pretty (EApp _ (EApp _ (BB _ Split) e) e') = "split" <+> pretty e <+> pretty e' - pretty (EApp _ (EApp _ (BB _ Splitc) e) e') = "splitc" <+> pretty e <+> pretty e' - pretty (EApp _ (EApp _ (BB _ Match) e) e') = "match" <+> pretty e <+> pretty e' - pretty (EApp _ (EApp _ (BB _ Sprintf) e) e') = "sprintf" <+> pretty e <+> pretty e' - pretty (EApp _ (EApp _ (BB _ Map) e) e') = pretty e <> "¨" <> pretty e' - pretty (EApp _ (EApp _ (BB _ b) e) e') = pretty e <+> pretty b <+> pretty e' - pretty (EApp _ (BB _ b) e) = parens (pretty e <> pretty b) - pretty (EApp _ (EApp _ (EApp _ (TB _ Fold) e) e') e'') = pretty e <> "|" <> pretty e' <+> pretty e'' - pretty (EApp _ (EApp _ (EApp _ (TB _ Scan) e) e') e'') = pretty e <> "^" <> pretty e' <+> pretty e'' - pretty (EApp _ (EApp _ (EApp _ (TB _ ZipW) op) e') e'') = "," <> pretty op <+> pretty e' <+> pretty e'' - pretty (EApp _ (EApp _ (EApp _ (TB _ Substr) e) e') e'') = "substr" <+> pretty e <+> pretty e' <+> pretty e'' - pretty (EApp _ (EApp _ (EApp _ (TB _ Option) e) e') e'') = "option" <+> pretty e <+> pretty e' <+> pretty e'' - pretty (EApp _ (EApp _ (EApp _ (TB _ AllCaptures) e) e') e'') = "captures" <+> pretty e <+> pretty e' <+> pretty e'' - pretty (EApp _ (EApp _ (EApp _ (TB _ Captures) e) e') e'') = pretty e <+> "~*" <+> pretty e' <+> pretty e'' - pretty (EApp _ (UB _ (At i)) e) = pretty e <> "." <> pretty i - pretty (EApp _ (UB _ (Select i)) e) = pretty e <> "->" <> pretty i - pretty (EApp _ (UB _ IParse) e') = pretty e' <> ":i" - pretty (EApp _ (UB _ FParse) e') = pretty e' <> ":f" - pretty (EApp _ (UB _ Parse) e') = pretty e' <> ":" - pretty (EApp _ e@UB{} e') = pretty e <> pretty e' - pretty (EApp _ e e') = pretty e <+> pretty e' - pretty (Lit _ l) = pretty l - pretty (Var _ n) = pretty n - pretty (RegexLit _ rr) = "/" <> pretty (decodeUtf8 rr) <> "/" - pretty (BB _ b) = parens (pretty b) - pretty (UB _ u) = pretty u - pretty (ResVar _ x) = pretty x - pretty (Tup _ es) = jacTup es - pretty (Lam _ n e) = parens ("λ" <> pretty n <> "." <+> pretty e) - pretty (Dfn _ e) = brackets (pretty e) - pretty (Guarded _ p e) = braces (pretty p) <> braces (pretty e) - pretty (Implicit _ e) = braces ("|" <+> pretty e) - pretty (NB _ n) = pretty n - pretty RC{} = "(compiled regex)" - pretty (Let _ (n, b) e) = "let" <+> "val" <+> pretty n <+> ":=" <+> pretty b <+> "in" <+> pretty e <+> "end" - pretty (Paren _ e) = parens (pretty e) - pretty (Arr _ es) = tupledByFunky "," (V.toList $ pretty <$> es) - pretty (Anchor _ es) = "&" <> tupledBy "." (pretty <$> es) - pretty (OptionVal _ (Just e)) = "Some" <+> pretty e - pretty (OptionVal _ Nothing) = "None" - pretty (Cond _ e0 e1 e2) = "if" <+> pretty e0 <+> "then" <+> pretty e1 <+> "else" <+> pretty e2 - pretty (RwB _ MapMaybe) = "mapMaybe" - pretty (RwB _ DedupOn) = "dedupOn" - pretty (RwB _ Filter) = "filter" - pretty (RwT _ Fold) = "fold" - pretty (RwT _ Scan) = "scan" - pretty (RwB _ Fold1) = "fold1" +mPrec :: BBin -> Maybe Int +mPrec Prior = Just 5 +mPrec DedupOn = Just 5 +mPrec MapMaybe = Just 5 +mPrec Map = Just 5 +mPrec Filter = Just 5 +mPrec Fold1 = Just 5 +mPrec Exp = Just 8 +mPrec Plus = Just 6 +mPrec Minus = Just 6 +mPrec Times = Just 7 +mPrec Div = Just 7 +mPrec Eq = Just 4 +mPrec Neq = Just 4 +mPrec Geq = Just 4 +mPrec Gt = Just 4 +mPrec Lt = Just 4 +mPrec Leq = Just 4 +mPrec Matches = Just 4 +mPrec NotMatches = Just 4 +mPrec And = Just 3 +mPrec Or = Just 2 +mPrec _ = Nothing +instance PS (E a) where + ps _ (Column _ i) = "$" <> pretty i + ps _ AllColumn{} = "$0" + ps _ IParseAllCol{} = "$0:i" + ps _ FParseAllCol{} = "$0:f" + ps _ ParseAllCol{} = "$0:" + ps _ (IParseCol _ i) = "$" <> pretty i <> ":i" + ps _ (FParseCol _ i) = "$" <> pretty i <> ":f" + ps _ (ParseCol _ i) = "$" <> pretty i <> ":" + ps _ AllField{} = "`0" + ps _ (Field _ i) = "`" <> pretty i + ps _ LastField{} = "`*" + ps _ FieldList{} = "`$" + ps d (EApp _ (EApp _ (BB _ op) e0) e1) | Just d' <- mPrec op = parensp (d>d') (ps (d'+1) e0 <+> pretty op <+> ps (d'+1) e1) + ps _ (EApp _ (BB _ op) e) | isJust (mPrec op) = parens (pretty e <+> pretty op) + ps d (EApp _ (UB _ (At i)) e) = parensp (d>0) (ps 1 e) <> "." <> pretty i + ps d (EApp _ (UB _ (Select i)) e) = parensp (d>0) (ps 1 e) <> "->" <> pretty i + ps _ (EApp _ (UB _ IParse) e') = pretty e' <> ":i" + ps _ (EApp _ (UB _ FParse) e') = pretty e' <> ":f" + ps _ (EApp _ (UB _ Parse) e') = pretty e' <> ":" + ps d (EApp _ (EApp _ (EApp _ (TB _ Bookend) e) e') e'') = parensp (d>3) (ps 4 e <> ",," <> ps 4 e' <+> ps 5 e'') + ps d (EApp _ (EApp _ (EApp _ (TB _ Fold) e) e') e'') = parensp (d>5) (ps 6 e <> "|" <> ps 6 e' <+> ps 7 e'') + ps d (EApp _ (EApp _ (EApp _ (TB _ Scan) e) e') e'') = parensp (d>5) (ps 6 e <> "^" <> ps 6 e' <+> ps 7 e'') + ps d (EApp _ (EApp _ (EApp _ (TB _ ZipW) op) e') e'') = parensp (d>5) ("," <> ps 6 op <+> ps 7 e' <+> ps 8 e'') + ps d (EApp _ (EApp _ (EApp _ (TB _ Captures) e) e') e'') = parensp (d>6) (ps 7 e <+> "~*" <+> ps 7 e' <+> ps 8 e'') + ps d (EApp _ e0 e1) = parensp (d>10) (ps 10 e0 <+> ps 11 e1) + ps d (OptionVal _ (Just e)) = parensp (d>10) ("Some" <+> ps 11 e) + ps _ (OptionVal _ Nothing) = "None" + ps _ (BB _ op) = parens (pretty op) + ps _ (Lit _ l) = pretty l + ps _ (Var _ n) = pretty n + ps _ (F n) = pretty n + ps _ (RegexLit _ rr) = "/" <> pretty (decodeUtf8 rr) <> "/" + ps _ (UB _ u) = pretty u + ps _ (ResVar _ x) = pretty x + ps _ (Dfn _ e) = brackets (pretty e) + ps _ (NB _ n) = pretty n + ps _ RC{} = "(compiled regex)" + ps _ (Guarded _ p e) = braces (pretty p) <> braces (pretty e) + ps _ (Implicit _ e) = braces ("|" <+> pretty e) + ps _ (Paren _ e) = parens (pretty e) + ps _ (RwB _ MapMaybe) = "mapMaybe" + ps _ (RwB _ DedupOn) = "dedupOn" + ps _ (RwB _ Filter) = "filter" + ps _ (RwT _ Fold) = "fold" + ps _ (RwT _ Scan) = "scan" + ps _ (RwB _ Fold1) = "fold1" + ps _ (Cond _ e0 e1 e2) = "?" <> pretty e0 <> ";" <+> pretty e1 <> ";" <+> pretty e2 + ps _ (Tup _ es) = jacTup es + ps _ (Arr _ es) = tupledByFunky "," (V.toList $ pretty <$> es) + ps _ (Anchor _ es) = "&" <> tupledBy "." (pretty <$> es) + ps _ (Let _ (n, b) e) = "let" <+> "val" <+> pretty n <+> ":=" <+> pretty b <+> "in" <+> pretty e <+> "end" + ps d (Lam _ n e) = parensp (d>1) ("λ" <> pretty n <> "." <+> ps 2 e) + ps _ (TB _ g) = pretty g + +instance Pretty (E a) where pretty=ps 0 + instance Show (E a) where show=show.pretty -- for tests @@ -338,7 +367,7 @@ data C = IsNum | IsEq | IsOrd | IsParse | IsPrintf - | IsSemigroup + | IsSemigroup | IsMonoid | Functor -- ^ For map (@"@) | Foldable | Witherable deriving (Eq, Ord) @@ -348,6 +377,7 @@ pretty IsParse = "Parseable"; pretty IsSemigroup = "Semigroup" pretty Functor = "Functor"; pretty Foldable = "Foldable" pretty IsPrintf = "Printf"; pretty Witherable = "Witherable" + pretty IsMonoid = "Monoid" instance Show C where show=show.pretty @@ -355,7 +385,7 @@ data D a = SetFS T.Text | SetRS T.Text | FunDecl (Nm a) [Nm a] (E a) | FlushDecl - | SetAsv + | SetAsv | SetUsv | SetOFS T.Text | SetORS T.Text deriving (Functor) instance Pretty (D a) where @@ -364,6 +394,9 @@ pretty (FunDecl n ns e) = "fn" <+> pretty n <> tupled (pretty <$> ns) <+> ":=" <#> indent 2 (pretty e <> ";") pretty FlushDecl = ":flush;" pretty SetAsv = ":set asv;" + pretty SetUsv = ":set usv;" + pretty (SetOFS sep) = ":set ofs :=" <+> "'" <> pretty sep <> "';" + pretty (SetORS sep) = ":set ors :=" <+> "'" <> pretty sep <> "';" data Program a = Program { decls :: [D a], expr :: E a } deriving (Functor) @@ -378,7 +411,8 @@ getS :: Program a -> (Maybe T.Text, Maybe T.Text) getS (Program ds _) = foldl' go (Nothing, Nothing) ds where go (_, rs) (SetFS bs) = (Just bs, rs) - go (_, rs) SetAsv = (Just "\\x1f", rs) + go _ SetAsv = (Just "\\x1f", Just "\\x1e") + go _ SetUsv = (Just "␞",Just "␟") go (fs, _) (SetRS bs) = (fs, Just bs) go next _ = next diff --git a/src/A/I.hs b/src/A/I.hs --- a/src/A/I.hs +++ b/src/A/I.hs @@ -7,7 +7,7 @@ ) where import A -import Control.Monad.State.Strict (State, gets, modify, runState, state) +import Control.Monad.State.Strict (State, evalState, gets, modify, runState, state) import Data.Bifunctor (second) import Data.Foldable (traverse_) import qualified Data.IntMap as IM @@ -28,7 +28,7 @@ bind :: Nm a -> E a -> ISt a -> ISt a bind (Nm _ (U u) _) e (ISt r bs) = ISt r (IM.insert u e bs) -runI i = second (max_.renames) . flip runState (ISt (Renames i mempty) mempty) +runI i = second (max_.renames) . flip runState (ISt (Rs i mempty) mempty) ib :: Int -> Program T -> (E T, Int) ib i = uncurry (flip β).runI i.iP where iP (Program ds e) = traverse_ iD ds *> iE e @@ -41,7 +41,8 @@ iD :: D T -> RM T () iD (FunDecl n [] e) = do {eI <- iE e; modify (bind n eI)} -iD SetFS{} = pure (); iD SetRS{} = pure (); iD SetAsv = pure (); iD FlushDecl{} = pure () +iD SetFS{} = pure (); iD SetRS{} = pure (); iD SetAsv = pure (); iD SetUsv = pure () +iD SetORS{} = pure (); iD SetOFS{} = pure (); iD FlushDecl{} = pure () iD FunDecl{} = desugar desugar = error "Internal error. Should have been de-sugared in an earlier stage!" diff --git a/src/File.hs b/src/File.hs --- a/src/File.hs +++ b/src/File.hs @@ -6,12 +6,13 @@ ) where import A +import A.E import A.I import Control.Applicative ((<|>)) import Control.Exception (Exception, throw, throwIO) import Control.Monad ((<=<)) import Control.Monad.IO.Class (liftIO) -import Control.Monad.State.Strict (StateT, get, put, runStateT) +import Control.Monad.State.Strict (StateT, get, put, runState, runStateT) import Control.Recursion (cata, embed) import Data.Bifunctor (second) import qualified Data.ByteString as BS @@ -25,7 +26,7 @@ import Data.Tuple (swap) import Include import Jacinda.Backend.Const -import Jacinda.Backend.P +import Jacinda.Backend.T import Jacinda.Check.Field import Jacinda.Regex import L @@ -82,7 +83,7 @@ Right (ast, m) -> let (typed, i) = yeet $ runTyM m (tyP ast) (inlined, j) = ib i typed - in eB j pure (compileR (error "nf not defined.") inlined) + in eB j (compileR (error "nf not defined.") inlined) compileFS :: Maybe T.Text -> RurePtr compileFS = maybe defaultRurePtr tcompile @@ -101,7 +102,8 @@ let (eI, j) = ib i typed m'Throw $ cF eI let ~(afs, ars) = getS ast - cont <- yIO $ runJac (compileFS (cliFS <|> afs)) (flushD typed) j (compileR (encodeUtf8 $ T.pack fp) eI) + (e', k) = runState (eta eI) j + cont=run (compileFS (cliFS <|> afs)) (flushD typed) k (compileR (encodeUtf8 $ T.pack fp) e') case cliRS <|> ars of Nothing -> cont $ fmap BSL.toStrict (ASCIIL.lines contents) Just rs -> cont $ lazySplit (tcompile rs) contents diff --git a/src/Jacinda/Backend/P.hs b/src/Jacinda/Backend/P.hs deleted file mode 100644 --- a/src/Jacinda/Backend/P.hs +++ /dev/null @@ -1,463 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Jacinda.Backend.P ( EvalErr (..), runJac, eB ) where - -import A -import A.I -import Control.Exception (Exception, throw) -import Control.Monad (foldM, (<=<)) -import Control.Monad.State.Strict (State, evalState, get, modify, runState) -import Data.Bifunctor (bimap) -import qualified Data.ByteString as BS -import Data.Containers.ListUtils (nubOrdOn) -import Data.Foldable (traverse_) -import qualified Data.IntMap as IM -import Data.List (scanl', transpose, uncons, unzip4) -import Data.Maybe (catMaybes, mapMaybe) -import qualified Data.Vector as V -import Data.Word (Word8) -import Foreign.C.String (CString) -import Jacinda.Backend.Const -import Jacinda.Backend.Parse -import Jacinda.Backend.Printf -import Jacinda.Fuse -import Jacinda.Regex -import Nm -import Prettyprinter (hardline, pretty) -import Prettyprinter.Render.Text (putDoc) -import Regex.Rure (RureMatch (RureMatch), RurePtr) -import System.IO (hFlush, stdout) -import System.IO.Unsafe (unsafeDupablePerformIO) -import Ty.Const -import U - -φ1 :: E T -> Int -φ1 (BB (TyArr _ (TyArr (TyB TyStream:$_) _)) Fold1) = 1 -φ1 (EApp _ e0 e1) = φ1 e0+φ1 e1 -φ1 (Tup _ es) = sum (φ1<$>es) -φ1 (OptionVal _ (Just e)) = φ1 e -φ1 (Cond _ p e0 e1) = φ1 p+φ1 e0+φ1 e1 -φ1 (Lam _ _ e) = φ1 e -φ1 _ = 0 - - -φ :: E T -> Int -φ (TB (TyArr _ (TyArr _ (TyArr (TyB TyStream:$_) _))) Fold) = 1 -φ (EApp _ e0 e1) = φ e0+φ e1 -φ (Tup _ es) = sum (φ<$>es) -φ (OptionVal _ (Just e)) = φ e -φ (Cond _ p e0 e1) = φ p+φ e0+φ e1 -φ (Lam _ _ e) = φ e -φ _ = 0 - -noleak :: E T -> Bool -noleak e = φ e > 1 && φ1 e < 1 - -runJac :: RurePtr -- ^ Record separator - -> Bool -- ^ Flush output? - -> Int - -> E T - -> Either StreamError ([BS.ByteString] -> IO ()) -runJac re f i e = ϝ (bsProcess re f) (if noleak e then fuse i e else (e, i)) where ϝ = uncurry.flip - -data StreamError = NakedField deriving (Show) - -instance Exception StreamError where - -data EvalErr = EmptyFold - | IndexOutOfBounds Int - | InternalCoercionError (E T) TB - | ExpectedTup (E T) - | BadHole (Nm T) - deriving (Show) - -instance Exception EvalErr where - -(!) :: V.Vector a -> Int -> a -v ! ix = case v V.!? ix of {Just x -> x; Nothing -> throw $ IndexOutOfBounds ix} - -parseAsEInt :: BS.ByteString -> E T -parseAsEInt = mkI.readDigits - -parseAsF :: BS.ByteString -> E T -parseAsF = mkF.readFloat - -readFloat :: BS.ByteString -> Double -readFloat = unsafeDupablePerformIO . (`BS.useAsCString` atof) - -foreign import ccall unsafe atof :: CString -> IO Double - -the :: BS.ByteString -> Word8 -the bs = case BS.uncons bs of - Nothing -> error "Empty splitc char!" - Just (c,b) | BS.null b -> c - Just _ -> error "Splitc takes only one char!" - -asTup :: Maybe RureMatch -> E T -asTup Nothing = OptionVal undefined Nothing -asTup (Just (RureMatch s e)) = OptionVal undefined (Just (Tup undefined (mkI . fromIntegral <$> [s, e]))) - -mkFoldVar :: Int -> b -> E b -mkFoldVar i l = Var l (Nm "fold_placeholder" (U i) l) - -takeConcatMap :: (a -> [b]) -> [a] -> [b] -takeConcatMap f = concat . transpose . fmap f - --- this relies on all streams being the same length stream which in turn relies --- on the fuse step (fold-of-filter->fold) -foldAll :: Int -> RurePtr -> [(Int, E T, E T, E T)] -> [BS.ByteString] -> ([(Int, E T)], Int) -foldAll i r xs bs = runState (foldMultiple seeds streams ctxStream ixStream) i - where (ns, ops, seeds, es) = unzip4 xs - mkStream e = eStream i r e bs - streams = mkStream<$>es - ctxStream = [(b, splitBy r b) | b <- bs] - ixStream = [1..] - - foldMultiple seedsϵ esϵ (ctx:ctxes) (ix:ixes) = allHeads esϵ `seq` do {es' <- sequence$zipWith3 (c2Mϵ (pure.eCtx ctx ix)) ops seedsϵ (head<$>esϵ); foldMultiple es' (tail<$>esϵ) ctxes ixes} - -- TODO: sanity check same length all streams - foldMultiple seedsϵ _ [] _ = pure$zip ns seedsϵ - - allHeads = foldr seq () - -gf :: E T -> State (Int, [(Int, E T, E T, E T)]) (E T) -gf (EApp _ (EApp _ (EApp _ (TB _ Fold) op) seed) stream) | t@(TyB TyStream:$_) <- eLoc stream = do - (i,_) <- get - modify (bimap (+1) ((i, op, seed, stream) :)) - pure $ mkFoldVar i t -gf (EApp ty e0 e1) = EApp ty <$> gf e0 <*> gf e1 -gf (Tup ty es) = Tup ty <$> traverse gf es -gf (Arr ty es) = Arr ty <$> traverse gf es -gf (OptionVal ty e) = OptionVal ty <$> traverse gf e -gf (Cond ty p e e') = Cond ty <$> gf p <*> gf e <*> gf e' -gf (Lam t n e) = Lam t n <$> gf e -gf e@BB{} = pure e; gf e@TB{} = pure e; gf e@UB{} = pure e; gf e@NB{} = pure e -gf e@Lit{} = pure e -gf e@RC{} = pure e; gf e@Var{} = pure e - -ug :: IM.IntMap (E T) -> E T -> E T -ug st (Var _ n@(Nm _ (U i) _)) = - IM.findWithDefault (throw (BadHole n)) i st -ug _ e = e - -bsProcess :: RurePtr - -> Bool -- ^ Flush output? - -> Int -- ^ Unique context - -> E T - -> Either StreamError ([BS.ByteString] -> IO ()) -bsProcess _ _ _ AllField{} = Left NakedField -bsProcess _ _ _ Field{} = Left NakedField -bsProcess _ _ _ (NB _ Ix) = Left NakedField -bsProcess r f u e | (TyB TyStream:$_) <- eLoc e = Right (pS f.eStream u r e) -bsProcess r f u (Anchor _ es) = Right (\bs -> pS f $ takeConcatMap (\e -> eStream u r e bs) es) -bsProcess r _ u e = - Right $ \bs -> pDocLn (eF u r e bs) - -pDocLn = putDoc.(<>hardline).pretty - -pS p = traverse_ g where g | p = (*>fflush).pDocLn | otherwise = pDocLn - fflush = hFlush stdout - -scanM :: Monad m => (b -> a -> m b) -> b -> [a] -> m [b] -scanM op seed xs = sequence $ - scanl' go (pure seed) xs where go seedϵ x = do {seedϵ' <- seedϵ; op seedϵ' x} - -eF :: Int -> RurePtr -> E T -> [BS.ByteString] -> E T -eF u r e | noleak e = \bs -> - let (eHoley, (_, folds)) = runState (gf e) (0, []) - (filledHoles, u') = foldAll u r folds bs - in eB u' (pure.ug (IM.fromList filledHoles)) eHoley - | otherwise = \bs -> - eB u (go bs) e - where go bb (EApp _ (EApp _ (EApp _ (TB _ Fold) op) seed) xs) = do - op' <- eBM pure op - seed' <- eBM pure seed - let xsϵ=eStream u r xs bb - foldM (c2M op') seed' xsϵ - go bb (EApp _ (EApp _ (BB _ Fold1) op) xs) = do - op' <- eBM pure op - let (seed',xsϵ)=case uncons $ eStream u r xs bb of {Just s -> s; Nothing -> throw EmptyFold} - foldM (c2M op') seed' xsϵ - go _ eϵ = pure eϵ - - -a1 :: E T -> E T -> UM (E T) -a1 f x | TyArr _ cod <- eLoc f = lβ (EApp cod f x) - -a2 :: E T -> E T -> E T -> UM (E T) -a2 op x0 x1 | TyArr _ t@(TyArr _ t') <- eLoc op = lβ (EApp t' (EApp t op x0) x1) - -c1 :: Int -> E T -> E T -> E T -c1 i f x = evalState (eBM pure =<< a1 f x) i - -c2M op x0 x1 = eBM pure =<< a2 op x0 x1 -c2Mϵ f g e e' = eBM f =<< a2 g e e' - -c2 :: Int -> E T -> E T -> E T -> E T -c2 i op x0 x1 = evalState (c2M op x0 x1) i - -eStream :: Int -> RurePtr -> E T -> [BS.ByteString] -> [E T] -eStream u r (EApp _ (EApp _ (EApp _ (TB _ Scan) op) seed) xs) bs = - let op'=eB u pure op; seed'=eB u pure seed; xsϵ=eStream u r xs bs - in evalState (scanM (c2M op') seed' xsϵ) u -eStream i r (EApp _ (UB _ CatMaybes) e) bs = mapMaybe asM$eStream i r e bs -eStream u r (Implicit _ e) bs = zipWith (\fs i -> eB u (pure.eCtx fs i) e) [(b, splitBy r b) | b <- bs] [1..] -eStream _ _ AllColumn{} bs = mkStr<$>bs -eStream _ _ IParseAllCol{} bs = parseAsEInt<$>bs -eStream _ _ FParseAllCol{} bs = parseAsF<$>bs -eStream _ _ (ParseAllCol (_:$TyB TyInteger)) bs = parseAsEInt<$>bs -eStream _ _ (ParseAllCol (_:$TyB TyFloat)) bs = parseAsF<$>bs -eStream _ r (Column _ i) bs = mkStr.(! (i-1)).splitBy r<$>bs -eStream _ r (IParseCol _ n) bs = [parseAsEInt (splitBy r b ! (n-1)) | b <- bs] -eStream _ r (ParseCol (_:$TyB TyInteger) n) bs = [parseAsEInt (splitBy r b ! (n-1)) | b <- bs] -eStream _ r (FParseCol _ n) bs = [parseAsF (splitBy r b ! (n-1)) | b <- bs] -eStream _ r (ParseCol (_:$TyB TyFloat) n) bs = [parseAsF (splitBy r b ! (n-1)) | b <- bs] -eStream i r (EApp _ (EApp _ (BB _ MapMaybe) f) e) bs = let xs = eStream i r e bs in mapMaybe (asM.c1 i f) xs -eStream i r (EApp _ (EApp _ (BB _ Map) f) e) bs = let xs=eStream i r e bs in fmap (c1 i f) xs -eStream i r (EApp _ (EApp _ (BB _ Prior) op) e) bs = let xs=eStream i r e bs in zipWith (c2 i op) (tail xs) xs -eStream i r (EApp _ (EApp _ (BB _ Filter) p) e) bs = let xs=eStream i r e bs; ps=fmap (asB.c1 i p) xs in [x | (pϵ,x) <- zip ps xs, pϵ] -eStream i r (EApp _ (EApp _ (EApp _ (TB _ ZipW) f) e0) e1) bs = let xs0=eStream i r e0 bs; xs1=eStream i r e1 bs in zipWith (c2 i f) xs0 xs1 -eStream i r (EApp (_:$TyB TyStr) (UB _ Dedup) e) bs = let s = eStream i r e bs in nubOrdOn asS s -eStream i r (EApp (_:$TyB TyInteger) (UB _ Dedup) e) bs = let s = eStream i r e bs in nubOrdOn asI s -eStream i r (EApp (_:$TyB TyFloat) (UB _ Dedup) e) bs = let s = eStream i r e bs in nubOrdOn asF s -eStream i r (EApp _ (EApp _ (BB _ DedupOn) op) e) bs | TyArr _ (TyB TyStr) <- eLoc op = let xs = eStream i r e bs in nubOrdOn (asS.c1 i op) xs -eStream i r (EApp _ (EApp _ (BB _ DedupOn) op) e) bs | TyArr _ (TyB TyInteger) <- eLoc op = let xs = eStream i r e bs in nubOrdOn (asI.c1 i op) xs -eStream i r (EApp _ (EApp _ (BB _ DedupOn) op) e) bs | TyArr _ (TyB TyFloat) <- eLoc op = let xs = eStream i r e bs in nubOrdOn (asF.c1 i op) xs -eStream u r (Guarded _ p e) bs = - let bss=(\b -> (b, splitBy r b))<$>bs - in catMaybes $ zipWith (\fs i -> if asB (eB u (pure.eCtx fs i) p) then Just (eB u (pure.eCtx fs i) e) else Nothing) bss [1..] - -asS :: E T -> BS.ByteString -asS (Lit _ (StrLit s)) = s; asS e = throw (InternalCoercionError e TyStr) - -asI :: E T -> Integer -asI (Lit _ (ILit i)) = i; asI e = throw (InternalCoercionError e TyInteger) - -asF :: E T -> Double -asF (Lit _ (FLit x)) = x; asF e = throw (InternalCoercionError e TyFloat) - -asR :: E T -> RurePtr -asR (RC r) = r; asR e = throw (InternalCoercionError e TyR) - -asM :: E T -> Maybe (E T) -asM (OptionVal _ e) = e; asM e = throw (InternalCoercionError e TyOption) - -asB :: E T -> Bool -asB (Lit _ (BLit b)) = b; asB e = throw (InternalCoercionError e TyBool) - -asV :: E T -> V.Vector (E T) -asV (Arr _ v) = v; asV e = throw (InternalCoercionError e TyVec) - -asT :: E T -> [E T] -asT (Tup _ es) = es; asT e = throw (ExpectedTup e) - -vS :: V.Vector BS.ByteString -> E T -vS = Arr (tyV tyStr).fmap mkStr - -eCtx :: (BS.ByteString, V.Vector BS.ByteString) -- ^ Line, split by field separator - -> Integer -- ^ Line number - -> E T -> E T -eCtx ~(f, _) _ AllField{} = mkStr f -eCtx (_, fs) _ (Field _ i) = mkStr (fs ! (i-1)) -eCtx (_, fs) _ LastField{} = mkStr (V.last fs) -eCtx (_, fs) _ FieldList{} = vS fs -eCtx _ i (NB _ Ix) = mkI i -eCtx (_, fs) _ (NB _ Nf) = mkI (fromIntegral$V.length fs) -eCtx _ _ e = e - -eB :: Int -> (E T -> UM (E T)) -> E T -> E T -eB i f x = evalState (eBM f x) i - -{-# SCC eBM #-} -eBM :: (E T -> UM (E T)) -> E T -> UM (E T) -eBM f (EApp t (EApp _ (EApp _ (TB _ Captures) s) i) r) = do - s' <- eBM f s; i' <- eBM f i; r' <- eBM f r - pure $ OptionVal t (mkStr <$> findCapture (asR r') (asS s') (fromIntegral$asI i')) -eBM f (EApp t (EApp _ (EApp _ (TB _ AllCaptures) s) i) r) = do - s' <- eBM f s; i' <- eBM f i; r' <- eBM f r - pure $ Arr t (V.fromList (mkStr <$> captures' (asR r') (asS s') (fromIntegral$asI i'))) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyInteger) _) Max) x0) x1) = do - x0' <- asI<$>eBM f x0; x1' <- asI<$>eBM f x1 - pure (mkI (max x0' x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyInteger) _) Min) x0) x1) = do - x0' <- asI<$>eBM f x0; x1' <- asI<$>eBM f x1 - pure (mkI (min x0' x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyFloat) _) Min) x0) x1) = do - x0' <- asF<$>eBM f x0; x1' <- asF<$>eBM f x1 - pure (mkF (min x0' x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyFloat) _) Max) x0) x1) = do - x0' <- asF<$>eBM f x0; x1' <- asF<$>eBM f x1 - pure (mkF (max x0' x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyStr) _) Min) x0) x1) = do - x0' <- asS<$>eBM f x0; x1' <- asS<$>eBM f x1 - pure (mkStr (min x0' x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyStr) _) Max) x0) x1) = do - x0' <- asS<$>eBM f x0; x1' <- asS<$>eBM f x1 - pure (mkStr (max x0' x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyInteger) _) Plus) x0) x1) = do - x0' <- asI <$> eBM f x0; x1' <- asI<$>eBM f x1 - pure (mkI (x0'+x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyInteger) _) Minus) x0) x1) = do - x0' <- asI <$> eBM f x0; x1' <- asI<$>eBM f x1 - pure (mkI (x0'-x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyInteger) _) Times) x0) x1) = do - x0' <- asI <$> eBM f x0; x1' <- asI<$>eBM f x1 - pure (mkI (x0'*x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyFloat) _) Plus) x0) x1) = do - x0' <- asF <$> eBM f x0; x1' <- asF<$>eBM f x1 - pure (mkF (x0'+x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyFloat) _) Minus) x0) x1) = do - x0' <- asF <$> eBM f x0; x1' <- asF<$>eBM f x1 - pure (mkF (x0'-x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyFloat) _) Times) x0) x1) = do - x0' <- asF <$> eBM f x0; x1' <- asF<$>eBM f x1 - pure (mkF (x0'*x1')) -eBM f (EApp _ (EApp _ (BB _ Div) x0) x1) = do - x0' <- asF <$> eBM f x0; x1' <- asF<$>eBM f x1 - pure (mkF (x0'/x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyInteger) _) Eq) x0) x1) = do - x0' <- asI<$>eBM f x0; x1' <- asI<$>eBM f x1 - pure (mkB (x0'==x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyInteger) _) Neq) x0) x1) = do - x0' <- asI<$>eBM f x0; x1' <- asI<$>eBM f x1 - pure (mkB (x0'/=x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyInteger) _) Gt) x0) x1) = do - x0' <- asI<$>eBM f x0; x1' <- asI<$>eBM f x1 - pure (mkB (x0'>x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyInteger) _) Lt) x0) x1) = do - x0' <- asI<$>eBM f x0; x1' <- asI<$>eBM f x1 - pure (mkB (x0'eBM f x0; x1' <- asI<$>eBM f x1 - pure (mkB (x0'<=x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyInteger) _) Geq) x0) x1) = do - x0' <- asI<$>eBM f x0; x1' <- asI<$>eBM f x1 - pure (mkB (x0'>=x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyFloat) _) Gt) x0) x1) = do - x0' <- asF<$>eBM f x0; x1' <- asF<$>eBM f x1 - pure (mkB (x0'>x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyFloat) _) Lt) x0) x1) = do - x0' <- asF<$>eBM f x0; x1' <- asF<$>eBM f x1 - pure (mkB (x0'eBM f x0; x1' <- asF<$>eBM f x1 - pure (mkB (x0'==x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyFloat) _) Neq) x0) x1) = do - x0' <- asF<$>eBM f x0; x1' <- asF<$>eBM f x1 - pure (mkB (x0'/=x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyFloat) _) Geq) x0) x1) = do - x0' <- asF<$>eBM f x0; x1' <- asF<$>eBM f x1 - pure (mkB (x0'>=x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyFloat) _) Leq) x0) x1) = do - x0' <- asF<$>eBM f x0; x1' <- asF<$>eBM f x1 - pure (mkB (x0'<=x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyStr) _) Eq) x0) x1) = do - x0' <- asS<$>eBM f x0; x1' <- asS<$>eBM f x1 - pure (mkB (x0'==x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyStr) _) Neq) x0) x1) = do - x0' <- asS<$>eBM f x0; x1' <- asS<$>eBM f x1 - pure (mkB (x0'/=x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyStr) _) Gt) x0) x1) = do - x0' <- asS<$>eBM f x0; x1' <- asS<$>eBM f x1 - pure (mkB (x0'>x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyStr) _) Geq) x0) x1) = do - x0' <- asS<$>eBM f x0; x1' <- asS<$>eBM f x1 - pure (mkB (x0'>=x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyStr) _) Lt) x0) x1) = do - x0' <- asS<$>eBM f x0; x1' <- asS<$>eBM f x1 - pure (mkB (x0'eBM f x0; x1' <- asS<$>eBM f x1 - pure (mkB (x0'<=x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyInteger) _) Exp) x0) x1) = do - x0' <- asI <$> eBM f x0; x1' <- asI<$>eBM f x1 - pure (mkI (x0'^x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyFloat) _) Exp) x0) x1) = do - x0' <- asF <$> eBM f x0; x1' <- asF<$>eBM f x1 - pure (mkF (x0'**x1')) -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyVec:$t) _) Eq) x0) x1) = do - x0' <- asV<$>eBM f x0; x1' <- asV<$>eBM f x1 - mkB <$> if V.length x0'==V.length x1' - then all asB <$> V.zipWithM (c2Mϵ f op) x0' x1' - else pure False - where op = BB (TyArr t (TyArr t tyB)) Eq -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyOption:$t) _) Eq) x0) x1) = do - x0' <- asM<$>eBM f x0; x1' <- asM<$>eBM f x1 - case (x0',x1') of - (Nothing, Nothing) -> pure (mkB True) - (Nothing, Just{}) -> pure (mkB False) - (Just{}, Nothing) -> pure (mkB False) - (Just e0, Just e1) -> c2Mϵ f op e0 e1 - where op = BB (TyArr t (TyArr t tyB)) Eq -eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyStr) _) Plus) x0) x1) = do - x0' <- asS <$> eBM f x0; x1' <- asS<$>eBM f x1 - pure (mkStr (x0'<>x1')) -eBM f (EApp _ (EApp _ (BB _ And) x0) x1) = do - x0' <- asB<$>eBM f x0; x1' <- asB<$>eBM f x1 - pure (mkB (x0'&&x1')) -eBM f (EApp _ (EApp _ (BB _ Or) x0) x1) = do - x0' <- asB<$>eBM f x0; x1' <- asB<$>eBM f x1 - pure (mkB (x0'||x1')) -eBM f (EApp _ (UB _ Not) b) = do {b' <- asB<$>eBM f b; pure $ mkB (not b')} -eBM f (EApp _ (EApp _ (BB _ Matches) s) r) = {-# SCC "eBMMatch" #-} do - s' <- asS<$>eBM f s; r' <- asR<$>eBM f r - pure $ mkB (isMatch' r' s') -eBM f (EApp _ (EApp _ (BB _ NotMatches) s) r) = do - s' <- asS<$>eBM f s; r' <- asR<$>eBM f r - pure $ mkB (not$isMatch' r' s') -eBM f (EApp _ (EApp _ (BB _ Split) s) r) = do - s' <- asS<$>eBM f s; r' <- asR<$>eBM f r - pure (vS (splitBy r' s')) -eBM f (EApp _ (EApp _ (BB _ Splitc) s) c) = do - s' <- asS<$>eBM f s; c' <- the.asS<$>eBM f c - pure (vS (V.fromList (BS.split c' s'))) -eBM f (EApp _ (UB _ FParse) x) = do {x' <- eBM f x; pure (parseAsF (asS x'))} -eBM f (EApp _ (UB _ IParse) x) = do {x' <- eBM f x; pure (parseAsEInt (asS x'))} -eBM f (EApp (TyB TyInteger) (UB _ Parse) x) = do {x' <- eBM f x; pure (parseAsEInt (asS x'))} -eBM f (EApp (TyB TyFloat) (UB _ Parse) x) = do {x' <- eBM f x; pure (parseAsF (asS x'))} -eBM f (EApp _ (UB _ (At i)) v) = do {v' <- eBM f v; pure (asV v'!(i-1))} -eBM f (EApp _ (UB _ (Select i)) x) = do {x' <- eBM f x; pure (asT x' !! (i-1))} -eBM f (EApp _ (UB _ Floor) x) = do {xr <- asF<$>eBM f x; pure $ mkI (floor xr)} -eBM f (EApp _ (UB _ Ceiling) x) = do {xr <- asF<$>eBM f x; pure $ mkI (ceiling xr)} -eBM f (EApp (TyB TyInteger) (UB _ Negate) i) = do {i' <- eBM f i; pure $ mkI (negate (asI i'))} -eBM f (EApp (TyB TyFloat) (UB _ Negate) x) = do {x' <- eBM f x; pure $ mkF (negate (asF x'))} -eBM f (EApp t (UB _ Some) e) = do {e' <- eBM f e; pure (OptionVal t (Just e'))} -eBM _ (NB t None) = pure (OptionVal t Nothing) -eBM f (EApp _ (UB _ Tally) e) = do - s' <- eBM f e - let r =fromIntegral (BS.length$asS s') - pure (mkI r) -eBM f (EApp _ (UB _ TallyList) e) = do - e' <- eBM f e - let r=fromIntegral (V.length$asV e') - pure (mkI r) -eBM f (EApp _ (EApp _ (UB _ Const) e) _) = eBM f e -eBM f (EApp _ (EApp _ (BB _ Sprintf) fs) s) = do - fs' <- eBM f fs; s' <- eBM f s - pure $ mkStr (sprintf (asS fs') s') -eBM f (EApp _ (EApp _ (BB _ Match) s) r) = do - s' <- eBM f s; r' <- eBM f r - pure $ asTup (find' (asR r') (asS s')) -eBM f (EApp _ (EApp _ (EApp _ (TB _ Fold) op) seed) xs) | TyB TyVec:$_ <- eLoc xs = do - op' <- eBM f op; seed' <- eBM f seed; xs' <- eBM f xs - V.foldM (c2Mϵ f op') seed' (asV xs') -eBM f (EApp _ (EApp _ (BB _ Fold1) op) xs) | TyB TyVec:$_ <- eLoc xs = do - op' <- eBM f op; xs' <- eBM f xs - let xsV=asV xs'; Just (seed, xs'') = V.uncons xsV - V.foldM (c2Mϵ f op') seed xs'' -eBM f (EApp yT@(TyB TyOption:$_) (EApp _ (BB _ Map) g) x) = do - g' <- eBM f g; x' <- eBM f x - OptionVal yT <$> traverse (eBM f <=< a1 g') (asM x') -eBM f (EApp yT@(TyB TyVec:$_) (EApp _ (BB _ Map) g) x) = do - g' <- eBM f g; x' <- eBM f x - Arr yT <$> traverse (eBM f <=< a1 g') (asV x') -eBM f (EApp t (EApp _ (EApp _ (TB _ Option) x) g) y) = do - x' <- eBM f x; g' <- eBM f g; y' <- eBM f y - case asM y' of - Nothing -> pure x' - Just yϵ -> eBM f =<< lβ (EApp t g' yϵ) -eBM f (EApp _ (EApp _ (EApp _ (TB _ Substr) s) i0) i1) = do - i0' <- eBM f i0; i1' <- eBM f i1; s' <- eBM f s - pure $ mkStr (substr (asS s') (fromIntegral$asI i0') (fromIntegral$asI i1')) -eBM f (Cond _ p e e') = do {p' <- eBM f p; if asB p' then eBM f e else eBM f e'} -eBM f (Tup t es) = Tup t <$> traverse (eBM f) es -eBM f e = f e diff --git a/src/Jacinda/Backend/Parse.hs b/src/Jacinda/Backend/Parse.hs --- a/src/Jacinda/Backend/Parse.hs +++ b/src/Jacinda/Backend/Parse.hs @@ -1,7 +1,14 @@ -module Jacinda.Backend.Parse ( readDigits ) where +module Jacinda.Backend.Parse ( readDigits, readFloat ) where import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as ASCII +import Foreign.C.String (CString) +import System.IO.Unsafe (unsafeDupablePerformIO) + +readFloat :: BS.ByteString -> Double +readFloat = unsafeDupablePerformIO . (`BS.useAsCString` atof) + +foreign import ccall unsafe atof :: CString -> IO Double readDigits :: BS.ByteString -> Integer readDigits b | Just (45, bs) <- BS.uncons b = negate $ readDigits bs diff --git a/src/Jacinda/Backend/Printf.hs b/src/Jacinda/Backend/Printf.hs --- a/src/Jacinda/Backend/Printf.hs +++ b/src/Jacinda/Backend/Printf.hs @@ -4,23 +4,27 @@ ) where import A -import qualified Data.ByteString as BS -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import qualified Data.ByteString as BS +import Data.ByteString.Builder (toLazyByteString) +import Data.ByteString.Builder.RealFloat (doubleDec) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8, encodeUtf8) sprintf :: BS.ByteString -- ^ Format string -> E a -> BS.ByteString sprintf fmt e = encodeUtf8 (sprintf' (decodeUtf8 fmt) e) --- TODO: https://hackage.haskell.org/package/floatshow --- +pf :: Double -> T.Text +pf = decodeUtf8 . BSL.toStrict . toLazyByteString . doubleDec + -- TODO: interpret precision, like %0.6f %.6 sprintf' :: T.Text -> E a -> T.Text sprintf' fmt (Lit _ (FLit f)) = let (prefix, fmt') = T.breakOn "%f" fmt - in prefix <> T.pack (show f) <> T.drop 2 fmt' + in prefix <> pf f <> T.drop 2 fmt' sprintf' fmt (Lit _ (ILit i)) = let (prefix, fmt') = T.breakOn "%i" fmt in prefix <> T.pack (show i) <> T.drop 2 fmt' diff --git a/src/Jacinda/Backend/T.hs b/src/Jacinda/Backend/T.hs new file mode 100644 --- /dev/null +++ b/src/Jacinda/Backend/T.hs @@ -0,0 +1,605 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Jacinda.Backend.T ( run, eB ) where + +import A +import A.I +import Control.Exception (Exception, throw) +import Control.Monad ((<=<)) +import Control.Monad.State.Strict (State, evalState, runState, state) +import qualified Data.ByteString as BS +import Data.ByteString.Builder (hPutBuilder) +import Data.ByteString.Builder.RealFloat (doubleDec) +import Data.Foldable (fold, traverse_) +import Data.Function ((&)) +import qualified Data.IntMap.Strict as IM +import qualified Data.IntSet as IS +import Data.List (foldl', scanl') +import Data.Maybe (fromMaybe) +import qualified Data.Set as S +import qualified Data.Vector as V +import Data.Word (Word8) +import Jacinda.Backend.Const +import Jacinda.Backend.Parse +import Jacinda.Backend.Printf +import Jacinda.Regex +import Nm +import Prettyprinter (hardline, pretty) +import Prettyprinter.Render.Text (putDoc) +import Regex.Rure (RureMatch (RureMatch), RurePtr) +import System.IO (hFlush, stdout) +import Ty.Const +import U + +data EvalErr = EmptyFold + | IndexOutOfBounds Int + | NoSuchField Int BS.ByteString + | InternalCoercionError (E T) TB + | ExpectedTup (E T) + | InternalTmp Tmp + | InternalNm (Nm T) + | InternalArityOrEta Int (E T) + deriving (Show) + +instance Exception EvalErr where + +data StreamError = NakedField deriving (Show) + +instance Exception StreamError where + +-- TODO: dedup... tracking env! +type Env = IM.IntMap (Maybe (E T)); type I=Int +data Σ = Σ !I Env (IM.IntMap (S.Set BS.ByteString)) (IM.IntMap IS.IntSet) (IM.IntMap (S.Set Double)) +type Tmp = Int +type Β = IM.IntMap (E T) + +mE :: (Env -> Env) -> Σ -> Σ +mE f (Σ i e d di df) = Σ i (f e) d di df +gE (Σ _ e _ _ _) = e + +at :: V.Vector a -> Int -> a +v `at` ix = case v V.!? (ix-1) of {Just x -> x; Nothing -> throw $ IndexOutOfBounds ix} + +fieldOf :: V.Vector BS.ByteString -> BS.ByteString -> Int -> BS.ByteString +fieldOf fs b n = case fs V.!? (n-1) of {Just x -> x; Nothing -> throw $ NoSuchField n b} + +parseAsEInt :: BS.ByteString -> E T +parseAsEInt = mkI.readDigits + +parseAsF :: BS.ByteString -> E T +parseAsF = mkF.readFloat + +(!) :: Env -> Tmp -> Maybe (E T) +(!) m r = IM.findWithDefault (throw$InternalTmp r) r m + +foldSeq x = foldr seq () x `seq` x + +type MM = State Int + +nI :: MM Int +nI = state (\i -> (i, i+1)) + +nN :: T -> MM (Nm T) +nN t = do {u <- nI; pure (Nm "fold_hole" (U u) t)} + +run :: RurePtr -> Bool -> Int -> E T -> [BS.ByteString] -> IO () +run _ _ _ e _ | TyB TyUnit <- eLoc e = undefined +run r flush j e bs | TyB TyStream:$_ <- eLoc e = traverse_ (traverse_ (pS flush)).flip evalState j $ do + t <- nI + (iEnv, μ) <- ctx e t + u <- nI + let ctxs=zipWith (\ ~(x,y) z -> (x,y,z)) [(b, splitBy r b) | b <- bs] [1..] + outs=μ<$>ctxs; es=scanl' (&) (Σ u iEnv IM.empty IM.empty IM.empty) outs + pure ((! t).gE<$>es) +run r _ j e bs = pDocLn $ evalState (summar r e bs) j + +pS p = if p then (*>fflush).pDocLn else pDocLn where fflush = hFlush stdout + +pDocLn :: E T -> IO () +pDocLn (Lit _ (FLit f)) = hPutBuilder stdout (doubleDec f <> "\n") +pDocLn e = putDoc (pretty e <> hardline) + +summar :: RurePtr -> E T -> [BS.ByteString] -> MM (E T) +summar r e bs = do + (iEnv, g, e0) <- collect e + u <- nI + let ctxs=zipWith (\ ~(x,y) z -> (x,y,z)) [(b, splitBy r b) | b <- bs] [1..] + updates=g<$>ctxs + finEnv=foldl' (&) (Σ u iEnv IM.empty IM.empty IM.empty) updates + e0@>(fromMaybe (throw EmptyFold)<$>gE finEnv) + +collect :: E T -> MM (Env, LineCtx -> Σ -> Σ, E T) +collect e@(EApp ty (EApp _ (EApp _ (TB _ Fold) _) _) _) = do + v <- nN ty + (iEnv, g) <- φ e (unU$unique v) + pure (iEnv, g, F v) +collect e@(EApp ty (EApp _ (BB _ Fold1) _) _) = do + v <- nN ty + (iEnv, g) <- φ e (unU$unique v) + pure (iEnv, g, F v) +collect (Tup ty es) = do + (seedEnvs, updates, es') <- unzip3 <$> traverse collect es + pure (fold seedEnvs, ts updates, Tup ty es') +collect (EApp ty0 (EApp ty1 op@BB{} e0) e1) = do + (env0, f0, e0') <- collect e0 + (env1, f1, e1') <- collect e1 + pure (env0<>env1, \l -> f1 l.f0 l, EApp ty0 (EApp ty1 op e0') e1') +collect (EApp ty f@UB{} e) = do + (env, fϵ, eϵ) <- collect e + pure (env, fϵ, EApp ty f eϵ) +collect e@Lit{} = pure (IM.empty, const id, e) + +ts :: [LineCtx -> Σ -> Σ] -> LineCtx -> Σ -> Σ +ts = foldl' (\f g l -> f l.g l) (const id) + +φ :: E T -> Tmp -> MM (Env, LineCtx -> Σ -> Σ) +φ (EApp _ (EApp _ (EApp _ (TB _ Fold) op) seed) xs) tgt = do + t <- nI + seed' <- seed @> mempty + let iEnv=IM.singleton tgt (Just$!seed') + (env, f) <- ctx xs t + let g=wF op t tgt + pure (env<>iEnv, (g.).f) +φ (EApp _ (EApp _ (EApp _ (TB _ Scan) op) seed) xs) tgt = do + t <- nI + seed' <- seed @> mempty + let iEnv=IM.singleton tgt (Just$!seed') + (env, f) <- ctx xs t + let g=wF op t tgt + pure (env<>iEnv, (g.).f) +φ (EApp _ (EApp _ (BB _ Fold1) op) xs) tgt = do + let iEnv=IM.singleton tgt Nothing + t <- nI + (env, f) <- ctx xs t + let g=wF op t tgt + pure (env<>iEnv, (g.).f) + +κ :: E T -> LineCtx -> E T +κ AllField{} ~(b, _, _) = mkStr b +κ (Field _ i) ~(_, bs, _) = mkStr $ bs `at` i +κ LastField{} ~(_, bs, _) = mkStr $ V.last bs +κ FieldList{} ~(_, bs, _) = vS bs +κ (EApp ty e0 e1) line = EApp ty (e0 `κ` line) (e1 `κ` line) +κ (NB _ Ix) ~(_, _, fp) = mkI fp +κ (NB _ Nf) ~(_, bs, _) = mkI$fromIntegral (length bs) +κ e@BB{} _ = e +κ e@UB{} _ = e +κ e@TB{} _ = e +κ e@NB{} _ = e +κ e@Lit{} _ = e +κ e@RC{} _ = e +κ e@Var{} _ = e +κ (Lam t n e) line = Lam t n (κ e line) + +ni t=IM.singleton t Nothing +na=IM.alter go where go Nothing = Just Nothing; go x@Just{} = x + +ctx :: E T -> Tmp -> MM (Env, LineCtx -> Σ -> Σ) +ctx AllColumn{} res = pure (ni res, \ ~(b, _, _) -> mE$IM.insert res (Just$!mkStr b)) +ctx (ParseAllCol (_:$TyB TyI)) res = pure (ni res, \ ~(b, _, _) -> mE$IM.insert res (Just$!parseAsEInt b)) +ctx (ParseAllCol (_:$TyB TyFloat)) res = pure (ni res, \ ~(b, _, _) -> mE$IM.insert res (Just$!parseAsF b)) +ctx FParseAllCol{} res = pure (ni res, \ ~(b, _, _) -> mE$IM.insert res (Just$!parseAsF b)) +ctx IParseAllCol{} res = pure (ni res, \ ~(b, _, _) -> mE$IM.insert res (Just$!parseAsEInt b)) +ctx (Column _ i) res = pure (ni res, \ ~(b, bs, _) -> mE$IM.insert res (Just$mkStr (fieldOf bs b i))) +ctx (FParseCol _ i) res = pure (ni res, \ ~(b, bs, _) -> mE$IM.insert res (Just$!parseAsF (fieldOf bs b i))) +ctx (IParseCol _ i) res = pure (ni res, \ ~(b, bs, _) -> mE$IM.insert res (Just$!parseAsEInt (fieldOf bs b i))) +ctx (ParseCol (_:$TyB TyFloat) i) res = pure (ni res, \ ~(b, bs, _) -> mE$IM.insert res (Just$!parseAsF (fieldOf bs b i))) +ctx (ParseCol (_:$TyB TyI) i) res = pure (ni res, \ ~(b, bs, _) -> mE$IM.insert res (Just$!parseAsEInt (fieldOf bs b i))) +ctx (EApp _ (EApp _ (BB _ Map) f) xs) o = do {t <- nI; (env, sb) <- ctx xs t; pure (na o env, \l->wM f t o.sb l)} +ctx (EApp _ (EApp _ (BB _ MapMaybe) f) xs) o = do {t <- nI; (env, sb) <- ctx xs t; pure (na o env, \l->wMM f t o.sb l)} +ctx (EApp _ (UB _ CatMaybes) xs) o = do {t <- nI; (env, sb) <- ctx xs t; pure (na o env, \l->wCM t o.sb l)} +ctx (EApp _ (EApp _ (BB _ Filter) p) xs) o = do {t <- nI; (env, sb) <- ctx xs t; pure (na o env, \l->wP p t o.sb l)} +ctx (Guarded _ p e) o = pure (ni o, wG (p, e) o) +ctx (Implicit _ e) o = pure (ni o, wI e o) +ctx (EApp _ (EApp _ (EApp _ (TB _ Scan) op) seed) xs) o = do {t <- nI; (env, sb) <- ctx xs t; seed' <- seed@>mempty; pure (IM.insert o (Just$!seed') env, \l->wF op t o.sb l)} +ctx (EApp _ (EApp _ (EApp _ (TB _ ZipW) op) xs) ys) o = do {t0 <- nI; t1 <- nI; (env0, sb0) <- ctx xs t0; (env1, sb1) <- ctx ys t1; pure (na o (env0<>env1), \l->wZ op t0 t1 o.sb0 l.sb1 l)} +ctx (EApp _ (EApp _ (BB _ Prior) op) xs) o = do {t <- nI; (env, sb) <- ctx xs t; pt <- nI; pure (na o (IM.insert pt Nothing env), \l -> wΠ op pt t o.sb l)} +ctx (EApp (_:$TyB ty) (UB _ Dedup) xs) o = do {k <- nI; t <- nI; (env, sb) <- ctx xs t; pure (na o env, \l->wD ty k t o.sb l)} +ctx (EApp _ (EApp _ (BB _ DedupOn) f) xs) o = do {k <- nI; t <- nI; (env, sb) <- ctx xs t; pure (na o env, \l->wDOp f k t o.sb l)} + +type LineCtx = (BS.ByteString, V.Vector BS.ByteString, Integer) -- line number + +asS :: E T -> BS.ByteString +asS (Lit _ (StrLit s)) = s; asS e = throw (InternalCoercionError e TyStr) + +asI :: E T -> Integer +asI (Lit _ (ILit i)) = i; asI e = throw (InternalCoercionError e TyI) + +asF :: E T -> Double +asF (Lit _ (FLit x)) = x; asF e = throw (InternalCoercionError e TyFloat) + +asR :: E T -> RurePtr +asR (RC r) = r; asR e = throw (InternalCoercionError e TyR) + +asM :: E T -> Maybe (E T) +asM (OptionVal _ e) = e; asM e = throw (InternalCoercionError e TyOption) + +asB :: E T -> Bool +asB (Lit _ (BLit b)) = b; asB e = throw (InternalCoercionError e TyBool) + +asV :: E T -> V.Vector (E T) +asV (Arr _ v) = v; asV e = throw (InternalCoercionError e TyVec) + +asT :: E T -> [E T] +asT (Tup _ es) = es; asT e = throw (ExpectedTup e) + +vS :: V.Vector BS.ByteString -> E T +vS = Arr (tyV tyStr).fmap mkStr + +the :: BS.ByteString -> Word8 +the bs = case BS.uncons bs of + Nothing -> error "Empty splitc char!" + Just (c,b) | BS.null b -> c + Just _ -> error "Splitc takes only one char!" + +asTup :: Maybe RureMatch -> E T +asTup Nothing = OptionVal undefined Nothing +asTup (Just (RureMatch s e)) = OptionVal undefined (Just (Tup undefined (mkI . fromIntegral <$> [s, e]))) + +{-# SCC (!>) #-} +(!>) :: Β -> Nm T -> E T +(!>) m n = IM.findWithDefault (throw$InternalNm n) (unU$unique n) m + +a2e :: Β -> E T -> E T -> E T -> UM (E T) +a2e b op e0 e1 = (@>b) =<< a2 op e0 e1 + +a1e :: Β -> E T -> E T -> UM (E T) +a1e b f x = (@>b) =<< a1 f x + +eB :: Int ->E T -> E T +eB j = flip evalState j.((@>mempty) <=< lβ) + +a1 :: E T -> E T -> UM (E T) +a1 f x | TyArr _ cod <- eLoc f = lβ (EApp cod f x) + +a2 :: E T -> E T -> E T -> UM (E T) +a2 op x0 x1 | TyArr _ t@(TyArr _ t') <- eLoc op = lβ (EApp t' (EApp t op x0) x1) + +num :: Num a => BBin -> Maybe (a -> a -> a) +num Plus = Just (+); num Minus = Just (-); num Times = Just (*); num _ = Nothing + +binRel :: Ord a => BBin -> Maybe (a -> a -> Bool) +binRel Lt = Just (<); binRel Gt = Just (>); binRel Eq = Just (==) +binRel Neq = Just (/=); binRel Geq = Just (>=); binRel Leq = Just (<=) +binRel _ = Nothing + +($@) :: E T -> Int -> (E T, Int) +e $@ j = e@!(j,mempty) + +(@!) :: E T -> (Int, Β) -> (E T, Int) +(@!) e (j,ϵ) = runState (e@>ϵ) j + +{-# SCC (@>) #-} +(@>) :: E T -> Β -> UM (E T) +e@Lit{} @> _ = pure e +e@RC{} @> _ = pure e +(F n) @> b = pure $ b!>n +e@(Var _ n) @> b = pure $ case IM.lookup (unU$unique n) b of {Just y -> y; Nothing -> e} +(EApp _ (EApp _ (BB (TyArr (TyB TyI) _) Max) x0) x1) @> b = do + x0' <- asI<$>(x0@>b); x1' <- asI<$>(x1@>b) + pure $ mkI (max x0' x1') +(EApp _ (EApp _ (BB (TyArr (TyB TyI) _) Min) x0) x1) @> b = do + x0' <- asI <$> (x0@>b); x1' <- asI <$> (x1@>b) + pure $ mkI (min x0' x1') +(EApp _ (EApp _ (BB (TyArr (TyB TyFloat) _) Max) x0) x1) @> b = do + x0' <- asF<$>(x0@>b); x1' <- asF<$>(x1@>b) + pure $ mkF (max x0' x1') +(EApp _ (EApp _ (BB (TyArr (TyB TyFloat) _) Min) x0) x1) @> b = do + x0' <- asF<$>(x0@>b); x1' <- asF<$>(x1@>b) + pure $ mkF (min x0' x1') +(EApp _ (EApp _ (BB (TyArr (TyB TyStr) _) Max) x0) x1) @> b = do + x0' <- asS<$>(x0@>b); x1' <- asS<$>(x1@>b) + pure $ mkStr (max x0' x1') +(EApp _ (EApp _ (BB (TyArr (TyB TyStr) _) Min) x0) x1) @> b = do + x0' <- asS<$>(x0@>b); x1'<-asS<$>(x1@>b) + pure $ mkStr (min x0' x1') +(EApp _ (EApp _ (BB (TyArr (TyB TyI) _) op) x0) x1) @> b | Just op' <- num op = do + x0e <- asI<$>(x0@>b); x1e <- asI<$>(x1@>b) + pure $ mkI (op' x0e x1e) +(EApp _ (EApp _ (BB (TyArr (TyB TyFloat) _) op) x0) x1) @> b | Just op' <- num op = do + x0e <- asF<$>(x0@>b); x1e <- asF<$>(x1@>b) + pure $ mkF (op' x0e x1e) +(EApp _ (EApp _ (BB _ Div) x0) x1) @> b = do + x0e <- x0@>b; x1e <- x1@>b + pure (mkF (asF x0e/asF x1e)) +(EApp _ (EApp _ (BB (TyArr (TyB TyI) _) op) x0) x1) @> b | Just rel <- binRel op = do + x0e<-asI<$>(x0@>b); x1e<-asI<$>(x1@>b) + pure (mkB (rel x0e x1e)) +(EApp _ (EApp _ (BB (TyArr (TyB TyFloat) _) op) x0) x1) @> b | Just rel <- binRel op = do + x0e <- asF<$>(x0@>b); x1e <- asF<$>(x1@>b) + pure (mkB (rel x0e x1e)) +(EApp _ (EApp _ (BB (TyArr (TyB TyStr) _) op) x0) x1) @> b | Just rel <- binRel op = do + x0e <- asS<$>(x0@>b); x1e <- asS<$>(x1@>b) + pure (mkB (rel x0e x1e)) +(EApp _ (EApp _ (BB (TyArr (TyB TyStr) _) Plus) x0) x1) @> b = do + x0e <- x0@>b; x1e <- x1@>b + pure (mkStr (asS x0e<>asS x1e)) +(EApp _ (EApp _ (BB _ And) x0) x1) @> b = do + x0e <- x0@>b; x1e <- x1@>b + pure (mkB (asB x0e&&asB x1e)) +(EApp _ (EApp _ (BB _ Or) x0) x1) @> b = do + x0e <- x0@>b; x1e <- x1@>b + pure (mkB (asB x0e||asB x1e)) +(EApp _ (EApp _ (UB _ Const) x) _) @> b = x@>b +(EApp _ (EApp _ (BB _ Match) s) r) @> b = do + s' <- s@>b; r' <- r@>b + pure (asTup (find' (asR r') (asS s'))) +(EApp _ (EApp _ (BB _ Matches) s) r) @> b = do + se <- s@>b; re <- r@>b + pure (mkB (isMatch' (asR re) (asS se))) +(EApp _ (EApp _ (BB _ NotMatches) s) r) @> b = do + se <- s@>b; re <- r@>b + pure (mkB (not$isMatch' (asR re) (asS se))) +(Tup ty es) @> b = Tup ty.foldSeq <$> traverse (@>b) es +(EApp _ (UB _ Tally) e) @> b = do + e' <- e@>b + let r=fromIntegral (BS.length$asS e') + pure (mkI r) +(EApp _ (UB _ TallyList) e) @> b = do + e' <- e@>b + let r=fromIntegral (V.length$asV e') + pure (mkI r) +(EApp _ (EApp _ (BB _ Sprintf) fs) s) @> b = do + fs' <- fs@>b; s' <- s@>b + pure (mkStr (sprintf (asS fs') s')) +(Cond _ p e e') @> b = do {p' <- p@>b; if asB p' then e@>b else e'@>b} +(EApp ty (EApp _ (EApp _ (TB _ Captures) s) i) r) @> b = do + s' <- s@>b; i' <- i@>b; r' <- r@>b + pure $ OptionVal ty (mkStr <$> findCapture (asR r') (asS s') (fromIntegral$asI i')) +(EApp ty (EApp _ (EApp _ (TB _ AllCaptures) s) i) r) @> b = do + s' <- s@>b; i' <- i@>b; r' <- r@>b + pure $ Arr ty (V.fromList (mkStr <$> captures' (asR r') (asS s') (fromIntegral$asI i'))) +(NB (TyB TyStr) MZ) @> _ = pure $ mkStr BS.empty +(NB ty@(TyB TyVec:$_) MZ) @> _ = pure $ Arr ty V.empty +(EApp _ (UB _ Not) e) @> b = do {e' <- e@> b; pure$mkB (not (asB e'))} +(EApp _ (EApp _ (BB _ Split) s) r) @> b = do + s' <- s@>b; r' <- r@>b + pure $ vS (splitBy (asR r') (asS s')) +(EApp _ (EApp _ (BB _ Splitc) s) c) @> b = do + s' <- s@>b; c' <- c@>b + pure $ vS (V.fromList (BS.split (the$asS c') (asS s'))) +(EApp _ (UB _ FParse) x) @> b = do {x' <- x@>b; pure (parseAsF (asS x'))} +(EApp _ (UB _ IParse) x) @> b = do {x' <- x@>b; pure (parseAsEInt (asS x'))} +(EApp (TyB TyI) (UB _ Parse) x) @> b = do {x' <- x@>b; pure (parseAsEInt (asS x'))} +(EApp (TyB TyFloat) (UB _ Parse) x) @> b = do {x' <- x@>b; pure (parseAsF (asS x'))} +(EApp _ (UB _ (At i)) v) @> b = do {v' <- v@>b; pure (asV v' `at` (i-1))} +(EApp _ (UB _ (Select i)) x) @> b = do {x' <- x@>b; pure (asT x' !! (i-1))} +(EApp _ (UB _ Floor) x) @> b = mkI.floor.asF<$>(x@>b) +(EApp _ (UB _ Ceiling) x) @> b = mkI.ceiling.asF<$>(x@>b) +(EApp (TyB TyI) (UB _ Negate) i) @> b = mkI.negate.asI<$>(i@>b) +(EApp (TyB TyFloat) (UB _ Negate) x) @> b = mkF.negate.asF<$>(x@>b) +(EApp ty (UB _ Some) e) @> b = OptionVal ty.Just<$>(e@>b) +(NB ty None) @> _ = pure $ OptionVal ty Nothing +(EApp _ (EApp _ (EApp _ (TB _ Substr) s) i0) i1) @> b = do + i0' <- i0@>b; i1' <- i1@>b; s' <- s@>b + pure $ mkStr (substr (asS s') (fromIntegral$asI i0') (fromIntegral$asI i1')) +(EApp _ (EApp _ (EApp _ (TB _ Sub1) r) s0) s1) @> b = do + r' <- r@>b; s0' <- s0@>b; s1' <- s1@>b + pure $ mkStr (sub1 (asR r') (asS s1') (asS s0')) +(EApp _ (EApp _ (EApp _ (TB _ Subs) r) s0) s1) @> b = do + r' <- r@>b; s0' <- s0@>b; s1' <- s1@>b + pure $ mkStr (subs (asR r') (asS s1') (asS s0')) +(EApp _ (EApp _ (EApp _ (TB _ Fold) op) seed) xs) @> b | TyB TyVec:$_ <- eLoc xs = do + seed' <- seed@>b; xs' <- xs@>b + V.foldM (a2e b op) seed' (asV xs') +(EApp _ (EApp _ (BB _ Fold1) op) xs) @> b | TyB TyVec:$_ <- eLoc xs = do + xs' <- xs@>b + let xsV=asV xs' + (seed, xs'') = case V.uncons xsV of + Just v -> v + Nothing -> throw EmptyFold + V.foldM (a2e b op) seed xs'' +(EApp yT@(TyB TyVec:$_) (EApp _ (BB _ Filter) p) xs) @> b = do + xs' <- xs@>b + Arr yT <$> V.filterM (fmap asB.a1e b p) (asV xs') +(EApp yT@(TyB TyVec:$_) (EApp _ (BB _ Map) f) xs) @> b = do + xs' <- xs@>b + Arr yT <$> traverse (a1e b f) (asV xs') +(EApp yT@(TyB TyOption:$_) (EApp _ (BB _ Map) f) x) @> b = do + x' <- x@>b + OptionVal yT <$> traverse (a1e b f) (asM x') +(EApp yT@(TyB TyVec:$_) (EApp _ (BB _ MapMaybe) g) x) @> b = do + x' <- x@>b + Arr yT <$> V.mapMaybeM (fmap asM.a1e b g) (asV x') +(EApp yT@(TyB TyVec:$_) (UB _ CatMaybes) x) @> b = do + x' <- x@>b + pure $ Arr yT (V.catMaybes (asM<$>asV x')) +(EApp t (EApp _ (EApp _ (TB _ Option) x) g) y) @> b = do + x' <- x@>b; y' <- y@>b + case asM y' of + Nothing -> pure x' + Just yϵ -> (@>b) =<< lβ (EApp t g yϵ) +(Arr t es) @> b = Arr t <$> traverse (@>b) es +e@BB{} @> _ = pure e +e@TB{} @> _ = pure e +e@UB{} @> _ = pure e +(Lam t n e) @> b = Lam t n <$> (e@>b) +-- basically an option can evaluate to a function... so ((option ...) x) +-- needs to be reduced! but nothing will detect that... +-- (when can a builtin etc. return a FUNCTION? if...then...else could!) +-- +-- Question: would (f x) ever need for x to be inspected in order for things +-- to proceed?? I think no... +-- +-- thabove returns g'=(and another +) e=line (should be further reduced!) +-- but g'=(+) and e=... will trip up + +me :: [(Nm T, E T)] -> Β +me xs = IM.fromList [(unU$unique nm, e) | (nm, e) <- xs] + +ms :: Nm T -> E T -> Β +ms (Nm _ (U i) _) = IM.singleton i + +wCM :: Tmp -> Tmp -> Σ -> Σ +wCM src tgt (Σ u env d di df) = + let xϵ=env!src + in Σ u (case xϵ of + Just y -> case asM y of {Nothing -> IM.insert tgt Nothing env; Just yϵ -> IM.insert tgt (Just$!yϵ) env} + Nothing -> IM.insert tgt Nothing env) d di df + +wMM :: E T -> Tmp -> Tmp -> Σ -> Σ +wMM (Lam _ n e) src tgt (Σ j env d di df) = + let xϵ=env!src + in case xϵ of + Just x -> + let be=ms n x; (y,k)=e@!(j,be) + in Σ k (case asM y of + Just yϵ -> IM.insert tgt (Just$!yϵ) env + Nothing -> IM.insert tgt Nothing env) d di df + Nothing -> Σ j (IM.insert tgt Nothing env) d di df +wMM e _ _ _ = throw$InternalArityOrEta 1 e + +wZ :: E T -> Tmp -> Tmp -> Tmp -> Σ -> Σ +wZ (Lam _ n0 (Lam _ n1 e)) src0 src1 tgt (Σ j env d di df) = + let x0ϵ=env!src0; x1ϵ=env!src1 + in (case (x0ϵ, x1ϵ) of + (Just x, Just y) -> + let be=me [(n0, x), (n1, y)]; (z,k)=e@!(j,be) + in Σ k (IM.insert tgt (Just$!z) env) + (Nothing, Nothing) -> Σ j (IM.insert tgt Nothing env)) d di df +wZ e _ _ _ _ = throw$InternalArityOrEta 2 e + +wM :: E T -> Tmp -> Tmp -> Σ -> Σ +wM (Lam _ n e) src tgt (Σ j env d di df) = + let xϵ=env!src + in case xϵ of + Just x -> + let be=ms n x; (y,k)=e@!(j,be) + in Σ k (IM.insert tgt (Just$!y) env) d di df + Nothing -> Σ j (IM.insert tgt Nothing env) d di df +wM e _ _ _ = throw$InternalArityOrEta 1 e + +wI :: E T -> Tmp -> LineCtx -> Σ -> Σ +wI e tgt line (Σ j env d di df) = + let e'=e `κ` line; (e'',k)=e'$@j in Σ k (IM.insert tgt (Just$!e'') env) d di df + +wG :: (E T, E T) -> Tmp -> LineCtx -> Σ -> Σ +wG (p, e) tgt line (Σ j env d di df) = + let p'=p `κ` line; (p'',k)=p'$@j + in if asB p'' + then let e'=e `κ` line; (e'',u) =e'$@k in Σ u (IM.insert tgt (Just$!e'') env) d di df + else Σ k (IM.insert tgt Nothing env) d di df + +wDOp :: E T -> Int -> Tmp -> Tmp -> Σ -> Σ +wDOp (Lam (TyArr _ (TyB TyStr)) n e) key src tgt (Σ i env d di df) = + let x=env!src + in case x of + Nothing -> Σ i (IM.insert tgt Nothing env) d di df + Just xϵ -> + case IM.lookup key d of + Nothing -> Σ k (IM.insert tgt (Just$!y) env) (IM.insert key (S.singleton e') d) di df + Just ss -> (if e' `S.member` ss then Σ k (IM.insert tgt Nothing env) d else Σ k (IM.insert tgt (Just$!y) env) (IM.alter go key d)) di df + where + (y,k)=e@!(i,be); be=ms n xϵ + e'=asS y + + go Nothing = Just$!S.singleton e' + go (Just s) = Just$!S.insert e' s +wDOp (Lam (TyArr _ (TyB TyI)) n e) key src tgt (Σ i env d di df) = + let x=env!src + in case x of + Nothing -> Σ i (IM.insert tgt Nothing env) d di df + Just xϵ -> + case IM.lookup key di of + Nothing -> Σ k (IM.insert tgt (Just$!y) env) d (IM.insert key (IS.singleton e') di) df + Just ds -> (if e' `IS.member` ds then Σ k (IM.insert tgt Nothing env) d di else Σ k (IM.insert tgt (Just$!y) env) d (IM.alter go key di)) df + + where + (y,k)=e@!(i,be); be=ms n xϵ + e'=fromIntegral$asI y + + go Nothing = Just$!IS.singleton e' + go (Just s) = Just$!IS.insert e' s +wDOp (Lam (TyArr _ (TyB TyFloat)) n e) key src tgt (Σ i env d di df) = + let x=env!src + in case x of + Nothing -> Σ i (IM.insert tgt Nothing env) d di df + Just xϵ -> + case IM.lookup key df of + Nothing -> Σ k (IM.insert tgt (Just$!y) env) d di (IM.insert key (S.singleton e') df) + Just ds -> if e' `S.member` ds then Σ k (IM.insert tgt Nothing env) d di df else Σ k (IM.insert tgt (Just$!y) env) d di (IM.alter go key df) + where + (y,k)=e@!(i,be); be=ms n xϵ + e'=asF y + + go Nothing = Just$!S.singleton e' + go (Just s) = Just$!S.insert e' s +wDOp e _ _ _ _ = throw $ InternalArityOrEta 1 e + +wD :: TB -> Int -> Tmp -> Tmp -> Σ -> Σ +wD TyStr key src tgt (Σ i env d di df) = + let x=env!src + in case x of + Nothing -> Σ i (IM.insert tgt Nothing env) d di df + Just e -> + case IM.lookup key d of + Nothing -> Σ i (IM.insert tgt (Just$!e) env) (IM.insert key (S.singleton e') d) di df + Just ds -> (if e' `S.member` ds then Σ i (IM.insert tgt Nothing env) d else Σ i (IM.insert tgt (Just$!e) env) (IM.alter go key d)) di df + where + go Nothing = Just$!S.singleton e' + go (Just s) = Just$!S.insert e' s + + e'=asS e +wD TyI key src tgt (Σ i env d di df) = + let x=env!src + in case x of + Nothing -> Σ i (IM.insert tgt Nothing env) d di df + Just e -> + case IM.lookup key di of + Nothing -> Σ i (IM.insert tgt (Just$!e) env) d (IM.insert key (IS.singleton e') di) df + Just ds -> (if e' `IS.member` ds then Σ i (IM.insert tgt Nothing env) d di else Σ i (IM.insert tgt (Just$!e) env) d (IM.alter go key di)) df + where + e'=fromIntegral$asI e + + go Nothing = Just$!IS.singleton e' + go (Just s) = Just$!IS.insert e' s +wD TyFloat key src tgt (Σ i env d di df) = + let x=env!src + in case x of + Nothing -> Σ i (IM.insert tgt Nothing env) d di df + Just e -> + case IM.lookup key df of + Nothing -> Σ i (IM.insert tgt (Just$!e) env) d di (IM.insert key (S.singleton e') df) + Just ds -> if e' `S.member` ds then Σ i (IM.insert tgt Nothing env) d di df else Σ i (IM.insert tgt (Just$!e) env) d di (IM.alter go key df) + where + e'=asF e + + go Nothing = Just$!S.singleton e' + go (Just s) = Just$!S.insert e' s + + +wP :: E T -> Tmp -> Tmp -> Σ -> Σ +wP (Lam _ n e) src tgt (Σ j env d di df) = + let xϵ=env!src + in case xϵ of + Just x -> + let be=ms n x; (p,k)=e@!(j,be) + in Σ k (IM.insert tgt (if asB p then Just$!x else Nothing) env) d di df + Nothing -> Σ j (IM.insert tgt Nothing env) d di df +wP e _ _ _ = throw $ InternalArityOrEta 1 e + +wΠ :: E T -> Tmp -> Tmp -> Tmp -> Σ -> Σ +wΠ (Lam _ nn (Lam _ nprev e)) pt src tgt (Σ j env d di df) = + let prevϵ=env!pt; xϵ=env!src + in (case (prevϵ, xϵ) of + (Just prev, Just x) -> + let be=me [(nprev, prev), (nn, x)] + (res,u)=e@!(j,be) + in Σ u (IM.insert pt (Just$!x) (IM.insert tgt (Just$!res) env)) + (Nothing, Nothing) -> Σ j (IM.insert tgt Nothing env) + (Nothing, Just x) -> Σ j (IM.insert pt (Just$!x) (IM.insert tgt Nothing env)) + (Just{}, Nothing) -> Σ j (IM.insert tgt Nothing env)) d di df +wΠ e _ _ _ _ = throw $ InternalArityOrEta 2 e + +wF :: E T -> Tmp -> Tmp -> Σ -> Σ +wF (Lam _ nacc (Lam _ nn e)) src tgt (Σ j env d di df) = + let accϵ = env!tgt; xϵ = env!src + in (case (accϵ, xϵ) of + (Just acc, Just x) -> + let be=me [(nacc, acc), (nn, x)] + (res, u)=e@!(j, be) + in Σ u (IM.insert tgt (Just$!res) env) + (Just acc, Nothing) -> Σ j (IM.insert tgt (Just$!acc) env) + (Nothing, Nothing) -> Σ j (IM.insert tgt Nothing env) + (Nothing, Just x) -> Σ j (IM.insert tgt (Just$!x) env)) d di df +wF e _ _ _ = throw $ InternalArityOrEta 2 e diff --git a/src/Jacinda/Fuse.hs b/src/Jacinda/Fuse.hs --- a/src/Jacinda/Fuse.hs +++ b/src/Jacinda/Fuse.hs @@ -10,9 +10,6 @@ fuse :: Int -> E T -> (E T, Int) fuse i = flip runState i.fM --- fold1: needs a special "form" for fold1-of-map (pick seed through map) --- also "filter-of-fold1" b/c we need to pick a seed that isn't filtered. - fM :: E T -> M (E T) fM (EApp t0 (EApp t1 (EApp t2 ho@(TB _ Fold) op) seed) stream) | TyB TyStream :$ _ <- eLoc stream = do stream' <- fM stream diff --git a/src/Jacinda/Regex.hs b/src/Jacinda/Regex.hs --- a/src/Jacinda/Regex.hs +++ b/src/Jacinda/Regex.hs @@ -6,6 +6,7 @@ , defaultRurePtr , isMatch' , find' + , sub1, subs , compileDefault , substr , findCapture @@ -14,6 +15,7 @@ import Control.Exception (Exception, throwIO) import Control.Monad ((<=<)) +import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Lazy as BSL import qualified Data.Vector as V @@ -52,6 +54,19 @@ s' = fromIntegral s in BS.BS (fp `plusForeignPtr` s') (e'-s') +{-# NOINLINE subs #-} +subs :: RurePtr -> BS.ByteString -> BS.ByteString -> BS.ByteString +subs re haystack = let ms = unsafeDupablePerformIO $ matches' re haystack in go Nothing ms + where go _ [] _ = haystack + go (Just (RureMatch _ pe)) ((RureMatch ms _):_) _ | pe > ms = error "Overlapping matches." + go _ (m@(RureMatch ms me):s) substituend = let next=go (Just m) s substituend in BS.take (fromIntegral ms) next <> substituend <> BS.drop (fromIntegral me) next + +sub1 :: RurePtr -> BS.ByteString -> BS.ByteString -> BS.ByteString +sub1 re bs ss = + case find' re bs of + Nothing -> bs + Just (RureMatch s e) -> BS.take (fromIntegral s) bs <> ss <> BS.drop (fromIntegral e) bs + {-# NOINLINE find' #-} find' :: RurePtr -> BS.ByteString -> Maybe RureMatch find' re str = unsafeDupablePerformIO $ find re str 0 @@ -77,8 +92,8 @@ {-# NOINLINE splitBy #-} splitByA :: RurePtr - -> BS.ByteString - -> [BS.ByteString] + -> BS.ByteString + -> [BS.ByteString] splitByA _ "" = mempty splitByA re haystack@(BS.BS fp l) = [BS.BS (fp `plusForeignPtr` s) (e-s) | (s, e) <- slicePairs] @@ -97,7 +112,9 @@ compileDefault :: BS.ByteString -> RurePtr compileDefault = unsafeDupablePerformIO . (yIO <=< compile genFlags) -newtype RureExe = RegexCompile String deriving (Show) +newtype RureExe = RegexCompile String + +instance Show RureExe where show (RegexCompile str) = str instance Exception RureExe where diff --git a/src/L.x b/src/L.x --- a/src/L.x +++ b/src/L.x @@ -86,6 +86,7 @@ \" { mkSym Quot } "^" { mkSym Caret } "|>" { mkSym Fold1Tok } + ⍬ { mkSym Zilde } "=" { mkSym EqTok } "!=" { mkSym NeqTok } @@ -98,12 +99,14 @@ "(" { mkSym LParen } ")" { mkSym RParen } "&(" { mkSym LAnchor } + "$>" { mkSym IceCreamCone } "{%" { mkSym LBracePercent } "{|" { mkSym LBraceBar } "]" { mkSym RSqBracket `andBegin` 0 } "~" { mkSym Tilde } "!~" { mkSym NotMatchTok } "," { mkSym Comma } + ",," { mkSym DoubleComma } "." { mkSym Dot } "#" { mkSym TallyTok } "#*" { mkSym LengthTok } @@ -128,6 +131,7 @@ "-." { mkSym NegTok } "`*" { mkSym LastFieldTok } "`$" { mkSym FieldListTok } + \? { mkSym QuestionMark } in { mkKw KwIn } let { mkKw KwLet } @@ -140,6 +144,8 @@ if { mkKw KwIf } then { mkKw KwThen } else { mkKw KwElse } + asv { mkKw KwAsv } + usv { mkKw KwUsv } fs { mkRes VarFs } rs { mkRes VarRs } @@ -168,6 +174,8 @@ fold { mkBuiltin BuiltinFold } fold1 { mkBuiltin BuiltinFold1 } scan { mkBuiltin BuiltinScan } + "sub1" { mkBuiltin BuiltinSub1 } + subs { mkBuiltin BuiltinSubs } ":i" { mkBuiltin BuiltinIParse } ":f" { mkBuiltin BuiltinFParse } @@ -248,31 +256,26 @@ | PercentTok | ExpTok | FoldTok + | IceCreamCone | Fold1Tok | Quot | TimesTok | DefEq | Colon - | LBrace - | RBrace + | LBrace | RBrace | LParen | LAnchor | RParen - | LSqBracket - | RSqBracket + | LSqBracket | RSqBracket | Semicolon | Underscore - | EqTok - | LeqTok - | LtTok - | NeqTok - | GeqTok - | GtTok - | AndTok - | OrTok - | Tilde - | NotMatchTok + | EqTok | NeqTok + | GtTok | GeqTok + | LtTok | LeqTok + | AndTok | OrTok + | Tilde | NotMatchTok | Comma + | DoubleComma | Dot | TallyTok | LengthTok @@ -281,8 +284,10 @@ | LBraceBar | Exclamation | Caret + | Zilde | Backslash | BackslashDot + | QuestionMark | FilterTok | FloorSym | CeilSym @@ -325,8 +330,10 @@ pretty Tilde = "~" pretty NotMatchTok = "!~" pretty Comma = "," + pretty DoubleComma = ",," pretty Dot = "." pretty TallyTok = "#" + pretty Zilde = "⍬" pretty LengthTok = "#*" pretty Quot = "¨" pretty Caret = "^" @@ -347,6 +354,8 @@ pretty NegTok = "-." pretty LastFieldTok = "`*" pretty FieldListTok = "`$" + pretty IceCreamCone = "$>" + pretty QuestionMark = "?" data Keyword = KwLet | KwIn @@ -356,15 +365,14 @@ | KwFlush | KwFn | KwInclude - | KwIf - | KwThen - | KwElse + | KwIf | KwThen | KwElse + | KwAsv | KwUsv -- | Reserved/special variables data Var = VarX | VarY - | VarFs - | VarRs + | VarFs | VarRs + | VarOfs | VarOrs | VarIx | VarMin | VarMax @@ -375,6 +383,8 @@ pretty VarY = "y" pretty VarFs = "fs" pretty VarRs = "rs" + pretty VarOrs = "ors" + pretty VarOfs = "ofs" pretty VarIx = "⍳" pretty VarNf = "nf" pretty VarMin = "min" @@ -392,27 +402,25 @@ pretty KwIf = "if" pretty KwThen = "then" pretty KwElse = "else" + pretty KwUsv = "usv" + pretty KwAsv = "asv" -data Builtin = BuiltinIParse - | BuiltinFParse +data Builtin = BuiltinIParse | BuiltinFParse | BuiltinSubstr - | BuiltinSplit - | BuiltinSplitc + | BuiltinSplit | BuiltinSplitc | BuiltinOption | BuiltinSprintf - | BuiltinFloor - | BuiltinCeil + | BuiltinFloor | BuiltinCeil | BuiltinMatch | BuiltinCaptures - | BuiltinSome - | BuiltinNone + | BuiltinSome | BuiltinNone | BuiltinFp | BuiltinMapMaybe | BuiltinDedupOn | BuiltinFilt - | BuiltinFold - | BuiltinFold1 + | BuiltinFold | BuiltinFold1 | BuiltinScan + | BuiltinSub1 | BuiltinSubs instance Pretty Builtin where pretty BuiltinIParse = ":i" @@ -435,6 +443,8 @@ pretty BuiltinFold = "fold" pretty BuiltinFold1 = "fold1" pretty BuiltinScan = "scan" + pretty BuiltinSub1 = "sub1" + pretty BuiltinSubs = "subs" data Token a = EOF { loc :: a } | TokSym { loc :: a, _sym :: Sym } @@ -475,13 +485,20 @@ freshName :: T.Text -> Alex (Nm AlexPosn) freshName t = do pos <- get_pos - newIdentAlex pos t + (i, ns, us) <- alexGetUserState + let (j, n) = freshIdent pos t i + alexSetUserState (j, ns, us) $> (n$>pos) newIdentAlex :: AlexPosn -> T.Text -> Alex (Nm AlexPosn) newIdentAlex pos t = do st <- alexGetUserState let (st', n) = newIdent pos t st alexSetUserState st' $> (n $> pos) + +freshIdent :: AlexPosn -> T.Text -> Int -> (Int, Nm AlexPosn) +freshIdent pos t max' = + let i=max'+1; nm=Nm t (U i) pos + in (i, nm) newIdent :: AlexPosn -> T.Text -> AlexUserState -> (AlexUserState, Nm AlexPosn) newIdent pos t pre@(max', names, uniqs) = diff --git a/src/Parser.y b/src/Parser.y --- a/src/Parser.y +++ b/src/Parser.y @@ -47,6 +47,7 @@ rparen { TokSym $$ RParen } semicolon { TokSym $$ Semicolon } backslash { TokSym $$ Backslash } + questionMark { TokSym $$ QuestionMark } tilde { TokSym $$ Tilde } notMatch { TokSym $$ NotMatchTok } dot { TokSym $$ Dot } @@ -72,9 +73,11 @@ exp { TokSym $$ ExpTok } comma { TokSym $$ Comma } + doubleComma { TokSym $$ DoubleComma } fold { TokSym $$ FoldTok } fold1 { TokSym $$ Fold1Tok } caret { TokSym $$ Caret } + z { TokSym $$ Zilde } quot { TokSym $$ Quot } mapMaybe { TokSym $$ MapMaybeTok } catMaybes { TokSym $$ CatMaybesTok } @@ -116,6 +119,8 @@ if { TokKeyword $$ KwIf } then { TokKeyword $$ KwThen } else { TokKeyword $$ KwElse } + usv { TokKeyword $$ KwUsv } + asv { TokKeyword $$ KwAsv } x { TokResVar $$ VarX } y { TokResVar $$ VarY } @@ -126,10 +131,14 @@ nf { TokResVar $$ VarNf } fs { TokResVar $$ VarFs } rs { TokResVar $$ VarRs } + ofs { TokResVar $$ VarOfs } + ors { TokResVar $$ VarOrs } split { TokBuiltin $$ BuiltinSplit } splitc { TokBuiltin $$ BuiltinSplitc } substr { TokBuiltin $$ BuiltinSubstr } + sub1 { TokBuiltin $$ BuiltinSub1 } + subs { TokBuiltin $$ BuiltinSubs } sprintf { TokBuiltin $$ BuiltinSprintf } floor { TokBuiltin $$ BuiltinFloor } ceil { TokBuiltin $$ BuiltinCeil } @@ -209,6 +218,10 @@ D :: { D AlexPosn } : set fs defEq rr semicolon { SetFS (rr $4) } | set rs defEq rr semicolon { SetRS (rr $4) } + | set ofs defEq strLit semicolon { SetOFS (strTok $4) } + | set ors defEq strLit semicolon { SetORS (strTok $4) } + | set asv semicolon { SetAsv } + | set usv semicolon { SetUsv } | flush semicolon { FlushDecl } | fn name Args defEq E semicolon { FunDecl $2 $3 $5 } | fn name defEq E semicolon { FunDecl $2 [] $4 } @@ -224,8 +237,8 @@ Program :: { Program AlexPosn } : many(D) E { Program (reverse $1) $2 } - + E :: { E AlexPosn } : name { Var (Nm.loc $1) $1 } | intLit { Lit (loc $1) (ILit (int $1)) } @@ -280,6 +293,7 @@ | lparen sepBy(E, dot) rparen { Tup $1 (reverse $2) } | lanchor sepBy(E, dot) rparen { Anchor $1 (reverse $2) } | E E { EApp (eLoc $1) $1 $2 } + | E doubleComma E E { EApp (eLoc $1) (EApp (eLoc $1) (EApp $2 (TB $2 Bookend) $1) $3) $4 } | tally { UB $1 Tally } | tallyL { UB $1 TallyList } | const { UB $1 Const } @@ -300,6 +314,8 @@ | match { BB $1 Match } | splitc { BB $1 Splitc } | substr { TB $1 Substr } + | sub1 { TB $1 Sub1 } + | subs { TB $1 Subs } | sprintf { BB $1 Sprintf } | option { TB $1 Option } | captures { TB $1 AllCaptures } @@ -312,6 +328,7 @@ | catMaybes { UB $1 CatMaybes } | neg { UB $1 Negate } | ix { NB $1 Ix } + | z { NB $1 MZ } | nf { NB $1 Nf } | none { NB $1 None } | fp { NB $1 Fp } @@ -322,6 +339,7 @@ | backslash name dot E { Lam $1 $2 $4 } | parens(E) { Paren (eLoc $1) $1 } | if E then E else E { Cond $1 $2 $4 $6 } + | questionMark E semicolon E semicolon E { Cond $1 $2 $4 $6 } { diff --git a/src/Parser/Rw.hs b/src/Parser/Rw.hs --- a/src/Parser/Rw.hs +++ b/src/Parser/Rw.hs @@ -66,15 +66,24 @@ a (EAppF l e0@Var{} (EApp l0 e1 (EApp l1 (EApp l2 op@BB{} e2) e3))) = EApp l1 (EApp l2 op (EApp l (EApp l0 e0 e1) e2)) e3 a (EAppF l e0@Var{} (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2 a (EAppF l e0@(BB _ op) (EApp lϵ e1 e2)) | Nothing <- mFi op = EApp l (EApp lϵ e0 e1) e2 + a (EAppF l e0@(TB _ Sub1) (EApp lϵ (EApp lϵϵ e1 e2) e3)) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3 + a (EAppF l e0@(TB _ Sub1) (EApp lϵ e1 (EApp lϵϵ e2 e3))) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3 + a (EAppF l e0@(TB _ Sub1) (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2 + a (EAppF l e0@(TB _ Subs) (EApp lϵ (EApp lϵϵ e1 e2) e3)) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3 + a (EAppF l e0@(TB _ Subs) (EApp lϵ e1 (EApp lϵϵ e2 e3))) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3 + a (EAppF l e0@(TB _ Subs) (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2 a (EAppF l e0@(TB _ Substr) (EApp lϵ (EApp lϵϵ e1 e2) e3)) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3 a (EAppF l e0@(TB _ Substr) (EApp lϵ e1 (EApp lϵϵ e2 e3))) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3 + a (EAppF l e0@(TB _ Substr) (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2 a (EAppF l e0@(TB _ Option) (EApp lϵ (EApp lϵϵ e1 e2) e3)) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3 a (EAppF l e0@(TB _ Option) (EApp lϵ e1 (EApp lϵϵ e2 e3))) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3 a (EAppF l e0@(TB _ Option) (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2 a (EAppF l e0@(TB _ Captures) (EApp lϵ (EApp lϵϵ e1 e2) e3)) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3 a (EAppF l e0@(TB _ Captures) (EApp lϵ e1 (EApp lϵϵ e2 e3))) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3 + a (EAppF l e0@(TB _ Captures) (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2 a (EAppF l e0@(TB _ AllCaptures) (EApp lϵ (EApp lϵϵ e1 e2) e3)) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3 a (EAppF l e0@(TB _ AllCaptures) (EApp lϵ e1 (EApp lϵϵ e2 e3))) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3 + a (EAppF l e0@(TB _ AllCaptures) (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2 a (EAppF l (RwB l0 b) (EApp lϵ e1 e2)) = EApp l (EApp lϵ (BB l0 b) e1) e2 a (EAppF l (RwT l0 t) (EApp lϵ (EApp lϵϵ e1 e2) e3)) = EApp l (EApp lϵ (EApp lϵϵ (TB l0 t) e1) e2) e3 a (EAppF l (RwT l0 t) (EApp lϵ e1 (EApp lϵϵ e2 e3))) = EApp l (EApp lϵ (EApp lϵϵ (TB l0 t) e1) e2) e3 diff --git a/src/R.hs b/src/R.hs --- a/src/R.hs +++ b/src/R.hs @@ -18,7 +18,7 @@ import Nm import U -data Renames = Renames { max_ :: Int, bound :: IM.IntMap Int } +data Renames = Rs { max_ :: Int, bound :: IM.IntMap Int } class HasRenames a where rename :: Lens' a Renames @@ -38,7 +38,7 @@ rP i = runRM i . renameProgram runRM :: Int -> RenameM x -> (x, Int) -runRM i act = second max_ (runState act (Renames i IM.empty)) +runRM i act = second max_ (runState act (Rs i IM.empty)) replaceUnique :: (MonadState s m, HasRenames s) => U -> m U replaceUnique u@(U i) = do @@ -80,7 +80,7 @@ pure res setMax :: Int -> Renames -> Renames -setMax i (Renames _ b) = Renames i b +setMax i (Rs _ b) = Rs i b -- | Desguar top-level functions as lambdas mkLam :: [Nm a] -> E a -> E a diff --git a/src/Ty.hs b/src/Ty.hs --- a/src/Ty.hs +++ b/src/Ty.hs @@ -193,38 +193,41 @@ cloneTyM tyϵ@TyB{} = pure tyϵ checkType :: Ord a => T -> (C, a) -> TyM a () -checkType TyVar{} _ = pure () -checkType (TyB TyStr) (IsSemigroup, _) = pure () -checkType (TyB TyInteger) (IsSemigroup, _) = pure () -checkType (TyB TyFloat) (IsSemigroup, _) = pure () -checkType (TyB TyInteger) (IsNum, _) = pure () -checkType (TyB TyFloat) (IsNum, _) = pure () -checkType (TyB TyInteger) (IsEq, _) = pure () -checkType (TyB TyFloat) (IsEq, _) = pure () -checkType (TyB TyBool) (IsEq, _) = pure () -checkType (TyB TyStr) (IsEq, _) = pure () -checkType (TyTup tys) (c@IsEq, l) = traverse_ (`checkType` (c, l)) tys -checkType (Rho _ rs) (c@IsEq, l) = traverse_ (`checkType` (c, l)) (IM.elems rs) -checkType (TyB TyVec:$ty) (c@IsEq, l) = checkType ty (c, l) -checkType (TyB TyOption:$ty) (c@IsEq, l) = checkType ty (c, l) -checkType (TyB TyInteger) (IsParse, _) = pure () -checkType (TyB TyFloat) (IsParse, _) = pure () -checkType (TyB TyFloat) (IsOrd, _) = pure () -checkType (TyB TyInteger) (IsOrd, _) = pure () -checkType (TyB TyStr) (IsOrd, _) = pure () -checkType (TyB TyVec) (Functor, _) = pure () -checkType (TyB TyStream) (Functor, _) = pure () -checkType (TyB TyOption) (Functor, _) = pure () -checkType (TyB TyStream) (Witherable, _) = pure () -checkType (TyB TyVec) (Foldable, _) = pure () -checkType (TyB TyStream) (Foldable, _) = pure () -checkType (TyB TyStr) (IsPrintf, _) = pure () -checkType (TyB TyFloat) (IsPrintf, _) = pure () -checkType (TyB TyInteger) (IsPrintf, _) = pure () -checkType (TyB TyBool) (IsPrintf, _) = pure () -checkType (TyTup tys) (c@IsPrintf, l) = traverse_ (`checkType` (c, l)) tys -checkType (Rho _ rs) (c@IsPrintf, l) = traverse_ (`checkType` (c, l)) (IM.elems rs) -checkType ty (c, l) = throwError $ Doesn'tSatisfy l ty c +checkType TyVar{} _ = pure () +checkType (TyB TyStr) (IsSemigroup, _) = pure () +checkType (TyB TyI) (IsSemigroup, _) = pure () +checkType (TyB TyFloat) (IsSemigroup, _) = pure () +checkType (TyB TyI) (IsNum, _) = pure () +checkType (TyB TyFloat) (IsNum, _) = pure () +checkType (TyB TyI) (IsEq, _) = pure () +checkType (TyB TyFloat) (IsEq, _) = pure () +checkType (TyB TyBool) (IsEq, _) = pure () +checkType (TyB TyStr) (IsEq, _) = pure () +checkType (TyTup tys) (c@IsEq, l) = traverse_ (`checkType` (c, l)) tys +checkType (Rho _ rs) (c@IsEq, l) = traverse_ (`checkType` (c, l)) (IM.elems rs) +checkType (TyB TyVec:$ty) (c@IsEq, l) = checkType ty (c, l) +checkType (TyB TyOption:$ty) (c@IsEq, l) = checkType ty (c, l) +checkType (TyB TyI) (IsParse, _) = pure () +checkType (TyB TyFloat) (IsParse, _) = pure () +checkType (TyB TyFloat) (IsOrd, _) = pure () +checkType (TyB TyI) (IsOrd, _) = pure () +checkType (TyB TyStr) (IsOrd, _) = pure () +checkType (TyB TyVec) (Functor, _) = pure () +checkType (TyB TyStream) (Functor, _) = pure () +checkType (TyB TyOption) (Functor, _) = pure () +checkType (TyB TyStream) (Witherable, _) = pure () +checkType (TyB TyVec) (Witherable, _) = pure () +checkType (TyB TyVec) (Foldable, _) = pure () +checkType (TyB TyStream) (Foldable, _) = pure () +checkType (TyB TyStr) (IsMonoid, _) = pure () +checkType (TyB TyVec:$_) (IsMonoid, _) = pure () +checkType (TyB TyStr) (IsPrintf, _) = pure () +checkType (TyB TyFloat) (IsPrintf, _) = pure () +checkType (TyB TyI) (IsPrintf, _) = pure () +checkType (TyB TyBool) (IsPrintf, _) = pure () +checkType (TyTup tys) (c@IsPrintf, l) = traverse_ (`checkType` (c, l)) tys +checkType (Rho _ rs) (c@IsPrintf, l) = traverse_ (`checkType` (c, l)) (IM.elems rs) +checkType ty (c, l) = throwError $ Doesn'tSatisfy l ty c checkClass :: Ord a => IM.IntMap T -- ^ Unification result @@ -247,10 +250,13 @@ tyOf = fmap eLoc . tyE tyDS :: Ord a => Subst -> D a -> TyM a (D T, Subst) -tyDS s (SetFS bs) = pure (SetFS bs, s) -tyDS s (SetRS bs) = pure (SetRS bs, s) -tyDS s SetAsv = pure (SetAsv, s) -tyDS s FlushDecl = pure (FlushDecl, s) +tyDS s (SetFS bs) = pure (SetFS bs, s) +tyDS s (SetRS bs) = pure (SetRS bs, s) +tyDS s (SetOFS bs) = pure (SetOFS bs, s) +tyDS s (SetORS bs) = pure (SetORS bs, s) +tyDS s SetAsv = pure (SetAsv, s) +tyDS s SetUsv = pure (SetUsv, s) +tyDS s FlushDecl = pure (FlushDecl, s) tyDS s (FunDecl n@(Nm _ (U i) _) [] e) = do (e', s') <- tyES s e let t=eLoc e' @@ -356,6 +362,7 @@ tyES s FParseAllCol{} = pure (FParseAllCol (tyStream tyF), s) tyES s IParseAllCol{} = pure (IParseAllCol (tyStream tyI), s) tyES s (ParseAllCol l) = do {a <- freshN "a"; modify (mapCV (addC a (IsParse, l))); pure (ParseAllCol (tyStream (var a)), s)} +tyES s (NB l MZ) = do {m <- freshN "m"; modify (mapCV (addC m (IsMonoid, l))); pure (NB (var m) MZ, s)} tyES s (NB _ Ix) = pure (NB tyI Ix, s) tyES s (NB _ Fp) = pure (NB tyStr Fp, s) tyES s (NB _ Nf) = pure (NB tyI Nf, s) @@ -381,7 +388,9 @@ tyES s (BB _ And) = pure (BB (tyB ~> tyB ~> tyB) And, s) tyES s (BB _ Or) = pure (BB (tyB ~> tyB ~> tyB) Or, s) tyES s (BB _ Match) = pure (BB (tyStr ~> tyR ~> tyOpt (TyTup [tyI, tyI])) Match, s) -tyES s (TB _ Substr) = pure (TB (tyStr ~> tyI ~> (tyI ~> tyStr)) Substr, s) +tyES s (TB _ Substr) = pure (TB (tyStr ~> tyI ~> tyI ~> tyStr) Substr, s) +tyES s (TB _ Sub1) = pure (TB (tyR ~> tyStr ~> tyStr ~> tyStr) Sub1, s) +tyES s (TB _ Subs) = pure (TB (tyR ~> tyStr ~> tyStr ~> tyStr) Subs, s) tyES s (UB _ IParse) = pure (UB (tyStr ~> tyI) IParse, s) tyES s (UB _ FParse) = pure (UB (tyArr tyStr tyF) FParse, s) tyES s (UB _ Floor) = pure (UB (tyArr tyF tyI) Floor, s) @@ -391,14 +400,14 @@ tyES s (UB _ Some) = do {a <- var <$> freshN "a"; pure (UB (tyArr a (tyOpt a)) Some, s)} tyES s (NB _ None) = do {a <- freshN "a"; pure (NB (tyOpt (var a)) None, s)} tyES s (ParseCol l i) = do {a <- freshN "a"; modify (mapCV (addC a (IsParse, l))); pure (ParseCol (tyStream (var a)) i, s)} -tyES s (UB l Parse) = do {a <- freshN "a"; modify (mapCV (addC a (IsParse, l))); pure (UB (tyArr tyStr (var a)) Parse, s)} -tyES s (BB l Sprintf) = do {a <- freshN "a"; modify (mapCV (addC a (IsPrintf, l))); pure (BB (tyStr ~> (var a ~> tyStr)) Sprintf, s)} +tyES s (UB l Parse) = do {a <- freshN "a"; modify (mapCV (addC a (IsParse, l))); pure (UB (tyStr ~> var a) Parse, s)} +tyES s (BB l Sprintf) = do {a <- freshN "a"; modify (mapCV (addC a (IsPrintf, l))); pure (BB (tyStr ~> var a ~> tyStr) Sprintf, s)} tyES s (BB l DedupOn) = do {a <- var <$> freshN "a"; b <- freshN "b"; modify (mapCV (addC b (IsEq, l))); let b'=var b in pure (BB (tyArr (a ~> b') (tyArr (tyStream a) (tyStream b'))) DedupOn, s)} -tyES s (UB _ (At i)) = do {a <- var <$> freshN "a"; pure (UB (tyArr (tyV a) a) (At i), s)} +tyES s (UB _ (At i)) = do {a <- var <$> freshN "a"; pure (UB (tyV a ~> a) (At i), s)} tyES s (UB l Dedup) = do {a <- freshN "a"; modify (mapCV (addC a (IsEq, l))); let sA=tyStream (var a) in pure (UB (sA ~> sA) Dedup, s)} -tyES s (UB _ Const) = do {a <- var <$> freshN "a"; b <- var <$> freshN "b"; pure (UB (a ~> (b ~> a)) Const, s)} +tyES s (UB _ Const) = do {a <- var <$> freshN "a"; b <- var <$> freshN "b"; pure (UB (a ~> b ~> a) Const, s)} tyES s (UB l CatMaybes) = do {a <- freshN "a"; f <- freshN "f"; modify (mapCV (addC f (Witherable, l))); let a'=var a; f'=var f in pure (UB (tyArr (f':$tyOpt a') (f':$a')) CatMaybes, s)} -tyES s (BB l Filter) = do {a <- freshN "a"; f <- freshN "f"; modify (mapCV (addC f (Witherable, l))); let a'=var a; f'=var f; w=f':$a' in pure (BB (tyArr (tyArr a' tyB) (w ~> w)) Filter, s)} +tyES s (BB l Filter) = do {a <- freshN "a"; f <- freshN "f"; modify (mapCV (addC f (Witherable, l))); let a'=var a; f'=var f; w=f':$a' in pure (BB ((a' ~> tyB) ~> w ~> w) Filter, s)} tyES s (UB _ (Select i)) = do ρ <- freshN "ρ"; a <- var <$> freshN "a" pure (UB (Rho ρ (IM.singleton i a) ~> a) (Select i), s) @@ -419,27 +428,28 @@ f <- freshN "f" let f'=var f modify (mapCV (addC f (Foldable, l))) - pure (TB ((b ~> (a ~> b)) ~> (b ~> (f':$a) ~> b)) Fold, s) + pure (TB ((b ~> a ~> b) ~> (b ~> (f':$a) ~> b)) Fold, s) tyES s (BB l Fold1) = do a <- var <$> freshN "a" f <- freshN "f" let f'=var f modify (mapCV (addC f (Foldable, l))) - pure (BB ((a ~> (a ~> a)) ~> ((f':$a) ~> a)) Fold1, s) -tyES s (TB _ Captures) = pure (TB (tyStr ~> (tyI ~> (tyR ~> tyOpt tyStr))) Captures, s) + pure (BB ((a ~> a ~> a) ~> ((f':$a) ~> a)) Fold1, s) +tyES s (TB _ Bookend) = pure (TB (tyR ~> tyR ~> tyStream tyStr ~> tyStream tyStr) Bookend, s) +tyES s (TB _ Captures) = pure (TB (tyStr ~> tyI ~> tyR ~> tyOpt tyStr) Captures, s) tyES s (BB _ Prior) = do a <- var <$> freshN "a"; b <- var <$> freshN "b" - pure (BB (tyArr (a ~> (a ~> b)) (tyStream a ~> tyStream b)) Prior, s) + pure (BB (tyArr (a ~> a ~> b) (tyStream a ~> tyStream b)) Prior, s) tyES s (TB _ ZipW) = do a <- var <$> freshN "a"; b <- var <$> freshN "b"; c <- var <$> freshN "c" - pure (TB (tyArr (a ~> (b ~> c)) (tyStream a ~> (tyStream b ~> tyStream c))) ZipW, s) + pure (TB (tyArr (a ~> b ~> c) (tyStream a ~> tyStream b ~> tyStream c)) ZipW, s) tyES s (TB _ Scan) = do a <- var <$> freshN "a"; b <- var <$> freshN "b" - pure (TB (tyArr (b ~> (a ~> b)) (b ~> tyStream a ~> tyStream b)) Scan, s) + pure (TB (tyArr (b ~> a ~> b) (b ~> tyStream a ~> tyStream b)) Scan, s) tyES s (TB _ Option) = do a <- var <$> freshN "a"; b <- var <$> freshN "b" - pure (TB (b ~> (a ~> b) ~> (tyOpt a ~> b)) Option, s) -tyES s (TB _ AllCaptures) = pure (TB (tyStr ~> (tyI ~> (tyR ~> tyV tyStr))) AllCaptures, s) + pure (TB (b ~> (a ~> b) ~> tyOpt a ~> b) Option, s) +tyES s (TB _ AllCaptures) = pure (TB (tyStr ~> tyI ~> tyR ~> tyV tyStr) AllCaptures, s) tyES s (Implicit _ e) = do {(e',s') <- tyES s e; pure (Implicit (tyStream (eLoc e')) e', s')} tyES s (Guarded l e se) = do (se', s0) <- tyES s se diff --git a/src/Ty/Const.hs b/src/Ty/Const.hs --- a/src/Ty/Const.hs +++ b/src/Ty/Const.hs @@ -9,7 +9,7 @@ tyStream = (TyB TyStream :$) tyB, tyI, tyF, tyStr, tyR :: T -tyB=TyB TyBool; tyI=TyB TyInteger; tyF=TyB TyFloat; tyStr=TyB TyStr; tyR=TyB TyR +tyB=TyB TyBool; tyI=TyB TyI; tyF=TyB TyFloat; tyStr=TyB TyStr; tyR=TyB TyR tyOpt :: T -> T tyOpt = (TyB TyOption :$) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -28,9 +28,12 @@ "drwxr-xr-x 12 vanessa staff 384 Dec 26 19:43 _darcs" ["drwxr-xr-x","12","vanessa","staff","384","Dec","26","19:43","_darcs"] , splitWhitespaceT " 55 ./src/Jacinda/File.hs" ["55", "./src/Jacinda/File.hs"] + , testCase "subs" $ + let actual = subs (compileDefault "zi") "vectorzm0zi13zi1zi0zmc80ea02f780be2984f831df2de071f6e6040c0f670b3dd2428e80f5d111d7f72_DataziVectorziGeneric_partition_closure" "." + in actual @?= "vectorzm0.13.1.0zmc80ea02f780be2984f831df2de071f6e6040c0f670b3dd2428e80f5d111d7f72_Data.Vector.Generic_partition_closure" , splitWhitespaceT "" [] , splitWhitespaceT "5" ["5"] - , testCase "type of" (tyOfT sumBytes (TyB TyInteger)) + , testCase "type of" (tyOfT sumBytes (TyB TyI)) , testCase "type of" (tyOfT krakRegex (TyB TyStream :$ TyB TyStr)) -- stream of str , testCase "type of" (tyOfT krakCol (TyB TyStream :$ TyB TyStr)) -- stream of str , testCase "type of (zip)" (tyOfT ",(-) $3:i $6:i" (tyStream tyI)) diff --git a/test/examples/bookend.jac b/test/examples/bookend.jac new file mode 100644 --- /dev/null +++ b/test/examples/bookend.jac @@ -0,0 +1,1 @@ +/Disassembly of section \.text:/,,/Disassembly of section/$0 diff --git a/test/examples/evenOdd.jac b/test/examples/evenOdd.jac --- a/test/examples/evenOdd.jac +++ b/test/examples/evenOdd.jac @@ -1,5 +1,3 @@ -{. :set rs:=/\n+/; - fn count(x) ≔ (+)|0 [:1"x; @@ -13,7 +11,6 @@ val iStream := $0 val even := count (isEven #. iStream) val odd := count (isOdd #. iStream) - {. val tens := (+)|> {%/0$/}{1} - val tens := count {%/0$/}{`0} + val tens := (+)|> {%/0$/}{1} val total := odd + even in (total . even . odd . tens) end diff --git a/test/examples/foldFilter.jac b/test/examples/foldFilter.jac new file mode 100644 --- /dev/null +++ b/test/examples/foldFilter.jac @@ -0,0 +1,4 @@ +fn count(x) ≔ + (+)|0 [:1"x; + +count ((~/(0|2|4|6|8)$/) #. $0) diff --git a/test/examples/sillyPragmas.jac b/test/examples/sillyPragmas.jac deleted file mode 100644 --- a/test/examples/sillyPragmas.jac +++ /dev/null @@ -1,2 +0,0 @@ -{. run ja run test/examples/sillyPragmas.jac -i src/A.hs -[x+', '+y]|'' .?{|`0 ~* 1 /\{-#\s*LANGUAGE\s*([^\s]*)\s*#-\}/} diff --git a/test/examples/sillyPragmas2.jac b/test/examples/sillyPragmas2.jac deleted file mode 100644 --- a/test/examples/sillyPragmas2.jac +++ /dev/null @@ -1,1 +0,0 @@ -[x+', '+y]|'' [x ~* 1 /\{-#\s*LANGUAGE\s*([^\s]*)\s*#-\}/]:?$0 diff --git a/test/examples/ty.jac b/test/examples/ty.jac deleted file mode 100644 --- a/test/examples/ty.jac +++ /dev/null @@ -1,4 +0,0 @@ -fn count(x) := - (+)|0 [:1"x; - -1 diff --git a/x/Main.hs b/x/Main.hs new file mode 100644 --- /dev/null +++ b/x/Main.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import qualified Data.Version as V +import File +import Options.Applicative +import qualified Paths_jacinda as P +import System.IO (stdin) + +data Command = TypeCheck !FilePath ![FilePath] + | Run !FilePath !(Maybe T.Text) !(Maybe T.Text) !(Maybe FilePath) ![FilePath] + | Expr !T.Text !(Maybe FilePath) !(Maybe T.Text) !Bool !Bool !(Maybe T.Text) ![FilePath] + | Eval !T.Text + +jacFile :: Parser FilePath +jacFile = argument str + (metavar "JACFILE" + <> help "Source code" + <> jacCompletions) + +asv :: Parser Bool +asv = switch + (long "asv" + <> help "Process as ASV") + +usv :: Parser Bool +usv = switch + (long "usv" + <> short 'u' + <> help "Process as USV") + +jacRs :: Parser (Maybe T.Text) +jacRs = optional $ option str + (short 'R' + <> metavar "REGEXP" + <> help "Record separator") + +jacFs :: Parser (Maybe T.Text) +jacFs = optional $ option str + (short 'F' + <> metavar "REGEXP" + <> help "Field separator") + +jacExpr :: Parser T.Text +jacExpr = argument str + (metavar "EXPR" + <> help "Jacinda expression") + +inpFile :: Parser (Maybe FilePath) +inpFile = optional $ option str + (short 'i' + <> metavar "DATAFILE" + <> help "Data file") + +jacCompletions :: HasCompleter f => Mod f a +jacCompletions = completer . bashCompleter $ "file -X '!*.jac' -o plusdirs" + +commandP :: Parser Command +commandP = hsubparser + (command "tc" (info tcP (progDesc "Type-check file")) + <> command "e" (info eP (progDesc "Evaluate an expression (no file context)")) + <> command "run" (info runP (progDesc "Run from file"))) + <|> exprP + where + tcP = TypeCheck <$> jacFile <*> includes + runP = Run <$> jacFile <*> jacFs <*> jacRs <*> inpFile <*> includes + exprP = Expr <$> jacExpr <*> inpFile <*> jacFs <*> asv <*> usv <*> jacRs <*> includes + eP = Eval <$> jacExpr + +includes :: Parser [FilePath] +includes = many $ strOption + (metavar "DIR" + <> long "include" + <> short 'I' + <> dirCompletions) + +dirCompletions :: HasCompleter f => Mod f a +dirCompletions = completer . bashCompleter $ "directory" + + +wrapper :: ParserInfo Command +wrapper = info (helper <*> versionMod <*> commandP) + (fullDesc + <> progDesc "Jacinda language for functional stream processing, filtering, and reports" + <> header "Jacinda - a functional complement to AWK") + +versionMod :: Parser (a -> a) +versionMod = infoOption (V.showVersion P.version) (short 'V' <> long "version" <> help "Show version") + +main :: IO () +main = run =<< execParser wrapper + +ap :: Bool -> Bool -> Maybe T.Text -> Maybe T.Text -> (Maybe T.Text, Maybe T.Text) +ap True True _ _ = errorWithoutStackTrace "--asv and --usv both specified." +ap _ True Just{} _ = errorWithoutStackTrace "--usv and field separator both speficied." +ap _ True _ Just{} = errorWithoutStackTrace "--usv and record separator both speficied." +ap True _ Just{} _ = errorWithoutStackTrace "--asv and field separator both speficied." +ap True _ _ Just{} = errorWithoutStackTrace "--asv and record separator both speficied." +ap True _ Nothing Nothing = (Just "\\x1f", Just "\\x1e") +ap _ True Nothing Nothing = (Just "␟", Just "␞") +ap _ _ fs rs = (fs,rs) + +run :: Command -> IO () +run (TypeCheck fp is) = tcIO is =<< TIO.readFile fp +run (Run fp fs rs Nothing is) = do { contents <- TIO.readFile fp ; runOnHandle is contents fs rs stdin } +run (Run fp fs rs (Just dat) is) = do { contents <- TIO.readFile fp ; runOnFile is contents fs rs dat } +run (Expr eb Nothing fs a u rs is) = let (fs',rs') = ap a u fs rs in runOnHandle is eb fs' rs' stdin +run (Expr eb (Just fp) fs a u rs is) = let (fs',rs') = ap a u fs rs in runOnFile is eb fs' rs' fp +run (Eval e) = print (exprEval e)