jacinda 0.3.0.0 → 0.3.1.0
raw patch · 41 files changed
+574/−159 lines, 41 files
Files
- CHANGELOG.md +18/−0
- README.md +0/−3
- doc/guide.pdf binary
- examples/hsLibversion.jac +1/−0
- examples/hsLibversion2.jac +1/−0
- examples/hsLibversionMac.jac +1/−0
- examples/hsLibversionMac2.jac +1/−0
- examples/hsLibversionPerf.jac +1/−0
- examples/libversion.jac +3/−0
- examples/longline.jac +1/−0
- examples/nl.jac +14/−0
- examples/path.jac +1/−1
- examples/pathx.jac +5/−0
- examples/sed.jac +14/−0
- examples/sedreplace.jac +11/−0
- examples/span2.jac +1/−4
- examples/stripUnprintable.jac +3/−0
- examples/tags.jac +1/−1
- examples/trailingLine.jac +1/−0
- examples/trimwhitespace.jac +3/−0
- examples/uniq.jac +6/−0
- examples/year.jac +2/−0
- jacinda.cabal +8/−9
- lib/sed.jac +8/−0
- lib/string.jac +6/−3
- man/ja.1 +62/−3
- prelude/fn.jac +7/−1
- src/Data/List/Ext.hs +3/−3
- src/Jacinda/AST.hs +72/−58
- src/Jacinda/Backend/Normalize.hs +52/−8
- src/Jacinda/Backend/TreeWalk.hs +70/−20
- src/Jacinda/File.hs +1/−1
- src/Jacinda/Include.hs +3/−2
- src/Jacinda/Lexer.x +32/−13
- src/Jacinda/Parser.y +11/−0
- src/Jacinda/Parser/Rewrite.hs +9/−0
- src/Jacinda/Regex.hs +9/−1
- src/Jacinda/Rename.hs +20/−13
- src/Jacinda/Ty.hs +104/−15
- src/Jacinda/Ty/Const.hs +7/−0
- test/Spec.hs +1/−0
CHANGELOG.md view
@@ -1,3 +1,21 @@+# 0.3.1.0++ * Performance improvements+ * Bug fix, dfns are renamed properly+ * Add `-.` negate function+ * Work with shell shebangs+ * Implement `=` for boolean+ * Add `captures` as a builtin+ * Add `|>`, fold without seed+ * Allow `fn...` declarations with no arguments and no parentheses+ * Add conditionals+ * Fix bug in normalizing `Some` and `None`+ * Fix bug in indexing + filter+ * Fix bug in polymorphic functions used at multiple sites+ * Change parsing/rewrite so `f a b + c` parses as `(f a b) + c` rather than `f a (b + c)`+ * Fix bug in parser rewriting in `@include`d files+ * Include searches current directory+ # 0.3.0.0 * Fix renaming bug that was inveigling folds with lambdas
README.md view
@@ -84,9 +84,6 @@ Intentionally missing features: * No loops- * No conditionals--The latter in particular I may add if necessary/requested # Further Advantages
doc/guide.pdf view
binary file changed (184810 → 196912 bytes)
+ examples/hsLibversion.jac view
@@ -0,0 +1,1 @@+.?{| `0 ~* 1 /(^[A-Za-z][A-Za-z0-9\-]*\-\d+(\.\d+)*)\-[0-9a-f]{64}$/}
+ examples/hsLibversion2.jac view
@@ -0,0 +1,1 @@+[x ~* 1 /(^[A-Za-z][A-Za-z0-9\-]*\-\d+(\.\d+)*)\-[0-9a-f]{64}$/]:? $0
+ examples/hsLibversionMac.jac view
@@ -0,0 +1,1 @@+~..?{| `0 ~* 1 /(^[A-Za-z][A-Za-z0-9\-]*\-\d+(\.\d+)*)\-[0-9a-zA-Z]{22}$/}
+ examples/hsLibversionMac2.jac view
@@ -0,0 +1,1 @@+~.[x ~* 1 /(^[A-Za-z][A-Za-z0-9\-]*\-\d+(\.\d+)*)\-[0-9a-zA-Z]{22}$/]:? $0
+ examples/hsLibversionPerf.jac view
@@ -0,0 +1,1 @@+.?{% /[0-9a-f]{64}$/}{`0 ~* 1 /(^[A-Za-z][A-Za-z0-9\-]*\-\d+(\.\d+)*)\-[0-9a-f]{64}$/}
+ examples/libversion.jac view
@@ -0,0 +1,3 @@+@include'lib/string.jac'++(+)|'' (intercalate '\n')"{% /-lHS/}{captures `0 1 /-lHS([A-Aa-z][A-Za-z0-9\-]*\d+(\.\d+)*)/}
+ examples/longline.jac view
@@ -0,0 +1,1 @@+{#`0>180}{sprintf'%s:%i %s' (fp.ix.`0)}
+ examples/nl.jac view
@@ -0,0 +1,14 @@+{. 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);++fn process(x) :=+ if !empty (x->2)+ then sprintf ' %i\t%s' x+ else '';++process"step^(0 . '') $0
examples/path.jac view
@@ -1,5 +1,5 @@ {. echo $PATH | ja run examples/path.jac fn path(x) :=- ([x+'\n'+y])|'' (splitc x ':');+ ([x+'\n'+y]) |> (splitc x ':'); path"$0
+ examples/pathx.jac view
@@ -0,0 +1,5 @@+#!/usr/bin/env -S ja run+fn path(x) :=+ ([x+'\n'+y]) |> (splitc x ':');++path"$0
+ examples/sed.jac view
@@ -0,0 +1,14 @@+{. 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
+ examples/sedreplace.jac view
@@ -0,0 +1,11 @@+{. 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
examples/span2.jac view
@@ -1,9 +1,6 @@ :set fs:=/\|/; fn printSpan(str) :=- let- val p := match str /\^+/- val str := (sprintf '%i-%i')"p- in str end;+ (sprintf '%i-%i')"(match str /\^+/); printSpan:?{% /\|/}{`2}
+ examples/stripUnprintable.jac view
@@ -0,0 +1,3 @@+@include'lib/string.jac'++(replace /[^[:print:]]/ '')"$0
examples/tags.jac view
@@ -3,7 +3,7 @@ fn processStr(s) := let- val line := split s /[ \(]+/+ val line := split s /[ \(:]+/ val outLine := sprintf '%s\t%s\t%s' (line.2 . fp . mkEx s) in outLine end;
+ examples/trailingLine.jac view
@@ -0,0 +1,1 @@+if [y]|>$0 = '' then fp else ''
+ examples/trimwhitespace.jac view
@@ -0,0 +1,3 @@+@include'lib/sed.jac'++(replace1 /\s+$/ '')"$0
+ examples/uniq.jac view
@@ -0,0 +1,6 @@+fn step(acc, this) :=+ if this = acc->1+ then (this . None)+ else (this . Some this);++(->2):?step^(''.None) $0
+ examples/year.jac view
@@ -0,0 +1,2 @@+{. extract year from column of dates in YYYY-MM-DD format+.? {|`1 ~* 1 /(\d{4})-\d{2}-\d{2}/}
jacinda.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: jacinda-version: 0.3.0.0+version: 0.3.1.0 license: AGPL-3 license-file: COPYING maintainer: vamchale@gmail.com@@ -12,6 +12,10 @@ category: Language, Interpreters, Text, Data build-type: Simple+data-files:+ lib/*.jac+ prelude/*.jac+ extra-source-files: CHANGELOG.md README.md@@ -20,10 +24,6 @@ test/examples/*.jac examples/*.jac -data-files:- lib/*.jac- prelude/*.jac- source-repository head type: git location: https://github.com/vmchale/jacinda@@ -56,8 +56,8 @@ Data.List.Ext Data.Vector.Ext Paths_jacinda- autogen-modules: Paths_jacinda + autogen-modules: Paths_jacinda default-language: Haskell2010 ghc-options: -Wall -O2 build-depends:@@ -101,7 +101,7 @@ other-modules: Paths_jacinda autogen-modules: Paths_jacinda default-language: Haskell2010- ghc-options: -Wall -rtsopts -with-rtsopts=-A200k+ ghc-options: -Wall -rtsopts "-with-rtsopts=-A200k -k32k" build-depends: base, jacinda-lib,@@ -149,13 +149,12 @@ if impl(ghc >=8.10) ghc-options: -Wunused-packages - benchmark jacinda-bench type: exitcode-stdio-1.0 main-is: Bench.hs hs-source-dirs: bench default-language: Haskell2010- ghc-options: -Wall+ ghc-options: -Wall -rtsopts "-with-rtsopts=-A200k -k32k" build-depends: base, criterion,
+ lib/sed.jac view
@@ -0,0 +1,8 @@+@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;
lib/string.jac view
@@ -1,5 +1,8 @@-fn intercalate(b, strs) :=- [x+b+y]|'' strs;+fn intercalate(b) :=+ ([x+b+y] |>); fn replace(re, t, str) :=- [x+t+y]|'' (split str re);+ [x+t+y] |> (split str re);++fn empty(str) :=+ #str = 0;
man/ja.1 view
@@ -1,5 +1,19 @@-.\" Automatically generated by Pandoc 2.17.0.1+.\" Automatically generated by Pandoc 2.17.1.1 .\"+.\" Define V font for inline verbatim, using C font in formats+.\" that render this, and otherwise B font.+.ie "\f[CB]x\f[]"x" \{\+. ftr V B+. ftr VI BI+. ftr VB B+. ftr VBI BI+.\}+.el \{\+. ftr V CR+. ftr VI CI+. ftr VB CB+. ftr VBI CBI+.\} .TH "ja (1)" "" "" "" "" .hy .SH NAME@@ -9,7 +23,7 @@ .PP ja run src.jac -i data.txt .PP-cat FILE1 FILE2 | ja \[aq]#\[lq]$0\[cq]+cat FILE1 FILE2 | ja \[aq]#\[dq]$0\[cq] .PP ja tc script.jac .PP@@ -55,10 +69,13 @@ \f[B]|\f[R] Ternary operator: fold Foldable f :=> (b -> a -> b) -> b -> f a -> b .TP+\f[B]|>\f[R] Fold without seed+Foldable f :=> (a -> a -> a) -> f a -> a+.TP \f[B]\[ha]\f[R] Ternary operator: scan (b -> a -> b) -> b -> Stream a -> Stream b .TP-\f[B]\[lq]\f[R] Binary operator: map+\f[B]\[dq]\f[R] Binary operator: map Functor f :=> a -> b -> f a -> f b .TP \f[B][:\f[R] Unary operator: const@@ -104,6 +121,8 @@ \f[B]|\[ga]\f[R] Ceiling function Float -> Int .PP+\f[B]-.\f[R] Unary negate+.PP \f[B]sprintf\f[R] Convert an expression to a string using the format string .TP@@ -114,6 +133,12 @@ Str -> Regex -> Option (Int . Int) .TP+\f[B]\[ti]*\f[R] Match, returning nth capture group+Str -> Int -> Regex -> Option Str+.TP+\f[B]captures\f[R] Return all captures+Str -> Int -> Regex -> List Str+.TP \f[B]:?\f[R] mapMaybe Witherable f :=> (a -> Option b) -> f a -> f b .TP@@ -149,6 +174,40 @@ \f[B]{.\f[R] Line comment .PP \f[B]\[at]include\[aq]/path/file.jac\[cq]\f[R] File include+.SH INFLUENTIAL ENVIRONMENT VARIABLES+.PP+\f[V]JAC_PATH\f[R] - colon-separated list of directories to search+.SH EXAMPLES+.TP+[#x>72] #. $0+Print lines longer than 72 bytes+.TP+{#\[ga]0>72}{\[ga]0}+Print lines longer than 72 bytes+.TP+{| sprintf \[aq]%i %i\[aq] (\[ga]2 . \[ga]1)}+Print the first two fields in opposite order+.TP+:set fs := /,[ \[rs]t]*|[ \[rs]t]+/; {| sprintf \[aq]%i %i\[aq] (\[ga]2 . \[ga]1)}+Same, with input fields separated by comma and/or blanks and tabs.+.TP+(+)|0 $1:i+Sum first column+.TP+(+)|0 [:1\[dq]$0+Count lines+.TP+[y]|0 {|ix}+Count lines+.TP+(+)|0 [#x+1]\[dq]$0+Count bytes (+1 for newlines)+.TP+(+)|0 {|#\[ga]0+1}+Count bytes+.TP+{|sprintf \[aq]%i: %s\[aq] (ix.\[ga]0)}+Display with line numbers .SH BUGS .PP Please report any bugs you may come across to
prelude/fn.jac view
@@ -11,7 +11,7 @@ {. rounds down on .5 fn round(x) := |. (x+0.5); -fn itostring() :=+fn itostring := sprintf '%i'; fn any(p, xs) :=@@ -24,3 +24,9 @@ fn fromMaybe(a, x) := option a [x] x;++fn last :=+ ([y]|>);++fn head :=+ ([[:x]|>);
src/Data/List/Ext.hs view
@@ -1,5 +1,5 @@ module Data.List.Ext ( imap- , ifilter+ , ifilter' , prior ) where @@ -9,5 +9,5 @@ imap :: (Int -> a -> b) -> [a] -> [b] imap f xs = fmap (uncurry f) (zip [1..] xs) -ifilter :: (Int -> a -> Bool) -> [a] -> [a]-ifilter p xs = snd <$> filter (uncurry p) (zip [1..] xs)+ifilter' :: (Int -> a -> Bool) -> [a] -> [(Int, a)]+ifilter' p xs = filter (uncurry p) (zip [1..] xs)
src/Jacinda/AST.hs view
@@ -48,6 +48,10 @@ | KArr K K deriving (Eq, Ord) +instance Pretty K where+ pretty Star = "★"+ pretty (KArr k0 k1) = parens (pretty k0 <+> "⟶" <+> pretty k1)+ data TB = TyInteger | TyFloat | TyDate@@ -117,6 +121,7 @@ | Some | Dedup | CatMaybes+ | Negate deriving (Eq) instance Pretty BUn where@@ -133,6 +138,7 @@ pretty Some = "Some" pretty Dedup = "~." pretty CatMaybes = ".?"+ pretty Negate = "-." -- ternary data BTer = ZipW@@ -141,15 +147,17 @@ | Substr | Option | Captures+ | AllCaptures deriving (Eq) instance Pretty BTer where- pretty ZipW = ","- pretty Fold = "|"- pretty Scan = "^"- pretty Substr = "substr"- pretty Option = "option"- pretty Captures = "~*"+ pretty ZipW = ","+ pretty Fold = "|"+ pretty Scan = "^"+ pretty Substr = "substr"+ pretty Option = "option"+ pretty Captures = "~*"+ pretty AllCaptures = "captures" -- builtin data BBin = Plus@@ -176,6 +184,7 @@ | Sprintf | Match | MapMaybe+ | Fold1 -- TODO: floor functions, sqrt, sin, cos, exp. (power) deriving (Eq) @@ -204,6 +213,7 @@ pretty Sprintf = "sprintf" pretty Match = "match" pretty MapMaybe = ":?"+ pretty Fold1 = "|>" data DfnVar = X | Y deriving (Eq) @@ -250,6 +260,7 @@ | Anchor { eLoc :: a, eAnchored :: [E a] } | Paren { eLoc :: a, eExpr :: E a } | OptionVal { eLoc :: a, eMaybe :: Maybe (E a) }+ | Cond { eLoc :: a, eIf :: E a, eThen :: E a, eElse :: E a } -- TODO: regex literal deriving (Functor, Generic) -- TODO: side effects: allow since it's strict?@@ -287,6 +298,7 @@ | AnchorF a [x] | ParenF a x | OptionValF a (Maybe x)+ | CondF a x x x deriving (Generic, Functor, Foldable, Traversable) type instance Base (E a) = (EF a)@@ -298,58 +310,60 @@ pretty Fp = "fp" instance Pretty (E a) where- pretty (Column _ i) = "$" <> pretty i- pretty AllColumn{} = "$0"- pretty (IParseCol _ i) = "$" <> pretty i <> ":i"- pretty (FParseCol _ i) = "$" <> pretty i <> ":f"- pretty AllField{} = "`0"- pretty (Field _ i) = "`" <> pretty i- pretty (EApp _ (EApp _ (BBuiltin _ Prior) e) e') = pretty e <> "\\." <+> pretty e'- pretty (EApp _ (EApp _ (BBuiltin _ Max) e) e') = "max" <+> pretty e <+> pretty e'- pretty (EApp _ (EApp _ (BBuiltin _ Min) e) e') = "min" <+> pretty e <+> pretty e'- pretty (EApp _ (EApp _ (BBuiltin _ Split) e) e') = "split" <+> pretty e <+> pretty e'- pretty (EApp _ (EApp _ (BBuiltin _ Splitc) e) e') = "splitc" <+> pretty e <+> pretty e'- pretty (EApp _ (EApp _ (BBuiltin _ Match) e) e') = "match" <+> pretty e <+> pretty e'- pretty (EApp _ (EApp _ (BBuiltin _ Sprintf) e) e') = "sprintf" <+> pretty e <+> pretty e'- pretty (EApp _ (EApp _ (BBuiltin _ Map) e) e') = pretty e <> "\"" <> pretty e'- pretty (EApp _ (EApp _ (BBuiltin _ b) e) e') = pretty e <+> pretty b <+> pretty e'- pretty (EApp _ (BBuiltin _ b) e) = parens (pretty e <> pretty b)- pretty (EApp _ (EApp _ (EApp _ (TBuiltin _ Fold) e) e') e'') = pretty e <> "|" <> pretty e' <+> pretty e''- pretty (EApp _ (EApp _ (EApp _ (TBuiltin _ Scan) e) e') e'') = pretty e <> "^" <> pretty e' <+> pretty e''- pretty (EApp _ (EApp _ (EApp _ (TBuiltin _ ZipW) op) e') e'') = "," <> pretty op <+> pretty e' <+> pretty e''- pretty (EApp _ (EApp _ (EApp _ (TBuiltin _ Substr) e) e') e'') = "substr" <+> pretty e <+> pretty e' <+> pretty e''- pretty (EApp _ (EApp _ (EApp _ (TBuiltin _ Option) e) e') e'') = "option" <+> pretty e <+> pretty e' <+> pretty e''- pretty (EApp _ (EApp _ (EApp _ (TBuiltin _ Captures) e) e') e'') = pretty e <+> "~*" <+> pretty e' <+> pretty e''- pretty (EApp _ (UBuiltin _ (At i)) e) = pretty e <> "." <> pretty i- pretty (EApp _ (UBuiltin _ (Select i)) e) = pretty e <> "->" <> pretty i- pretty (EApp _ (UBuiltin _ IParse) e') = pretty e' <> ":i"- pretty (EApp _ (UBuiltin _ FParse) e') = pretty e' <> ":f"- pretty (EApp _ (UBuiltin _ Parse) e') = pretty e' <> ":"- pretty (EApp _ e@UBuiltin{} e') = pretty e <> pretty e'- pretty (EApp _ e e') = pretty e <+> pretty e'- pretty (Var _ n) = pretty n- pretty (IntLit _ i) = pretty i- pretty (RegexLit _ rr) = "/" <> pretty (decodeUtf8 rr) <> "/"- pretty (FloatLit _ f) = pretty f- pretty (BoolLit _ True) = "#t"- pretty (BoolLit _ False) = "#f"- pretty (BBuiltin _ b) = parens (pretty b)- pretty (UBuiltin _ u) = pretty u- pretty (StrLit _ bstr) = pretty (decodeUtf8 bstr)- 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 (NBuiltin _ n) = pretty n- pretty RegexCompiled{} = error "Nonsense."- 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 (Column _ i) = "$" <> pretty i+ pretty AllColumn{} = "$0"+ pretty (IParseCol _ i) = "$" <> pretty i <> ":i"+ pretty (FParseCol _ i) = "$" <> pretty i <> ":f"+ pretty AllField{} = "`0"+ pretty (Field _ i) = "`" <> pretty i+ pretty (EApp _ (EApp _ (BBuiltin _ Prior) e) e') = pretty e <> "\\." <+> pretty e'+ pretty (EApp _ (EApp _ (BBuiltin _ Max) e) e') = "max" <+> pretty e <+> pretty e'+ pretty (EApp _ (EApp _ (BBuiltin _ Min) e) e') = "min" <+> pretty e <+> pretty e'+ pretty (EApp _ (EApp _ (BBuiltin _ Split) e) e') = "split" <+> pretty e <+> pretty e'+ pretty (EApp _ (EApp _ (BBuiltin _ Splitc) e) e') = "splitc" <+> pretty e <+> pretty e'+ pretty (EApp _ (EApp _ (BBuiltin _ Match) e) e') = "match" <+> pretty e <+> pretty e'+ pretty (EApp _ (EApp _ (BBuiltin _ Sprintf) e) e') = "sprintf" <+> pretty e <+> pretty e'+ pretty (EApp _ (EApp _ (BBuiltin _ Map) e) e') = pretty e <> "\"" <> pretty e'+ pretty (EApp _ (EApp _ (BBuiltin _ b) e) e') = pretty e <+> pretty b <+> pretty e'+ pretty (EApp _ (BBuiltin _ b) e) = parens (pretty e <> pretty b)+ pretty (EApp _ (EApp _ (EApp _ (TBuiltin _ Fold) e) e') e'') = pretty e <> "|" <> pretty e' <+> pretty e''+ pretty (EApp _ (EApp _ (EApp _ (TBuiltin _ Scan) e) e') e'') = pretty e <> "^" <> pretty e' <+> pretty e''+ pretty (EApp _ (EApp _ (EApp _ (TBuiltin _ ZipW) op) e') e'') = "," <> pretty op <+> pretty e' <+> pretty e''+ pretty (EApp _ (EApp _ (EApp _ (TBuiltin _ Substr) e) e') e'') = "substr" <+> pretty e <+> pretty e' <+> pretty e''+ pretty (EApp _ (EApp _ (EApp _ (TBuiltin _ Option) e) e') e'') = "option" <+> pretty e <+> pretty e' <+> pretty e''+ pretty (EApp _ (EApp _ (EApp _ (TBuiltin _ AllCaptures) e) e') e'') = "captures" <+> pretty e <+> pretty e' <+> pretty e''+ pretty (EApp _ (EApp _ (EApp _ (TBuiltin _ Captures) e) e') e'') = pretty e <+> "~*" <+> pretty e' <+> pretty e''+ pretty (EApp _ (UBuiltin _ (At i)) e) = pretty e <> "." <> pretty i+ pretty (EApp _ (UBuiltin _ (Select i)) e) = pretty e <> "->" <> pretty i+ pretty (EApp _ (UBuiltin _ IParse) e') = pretty e' <> ":i"+ pretty (EApp _ (UBuiltin _ FParse) e') = pretty e' <> ":f"+ pretty (EApp _ (UBuiltin _ Parse) e') = pretty e' <> ":"+ pretty (EApp _ e@UBuiltin{} e') = pretty e <> pretty e'+ pretty (EApp _ e e') = pretty e <+> pretty e'+ pretty (Var _ n) = pretty n+ pretty (IntLit _ i) = pretty i+ pretty (RegexLit _ rr) = "/" <> pretty (decodeUtf8 rr) <> "/"+ pretty (FloatLit _ f) = pretty f+ pretty (BoolLit _ True) = "#t"+ pretty (BoolLit _ False) = "#f"+ pretty (BBuiltin _ b) = parens (pretty b)+ pretty (UBuiltin _ u) = pretty u+ pretty (StrLit _ bstr) = pretty (decodeUtf8 bstr)+ 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 (NBuiltin _ n) = pretty n+ pretty RegexCompiled{} = error "Nonsense."+ 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 instance Show (E a) where show = show . pretty
src/Jacinda/Backend/Normalize.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} --- TODO: test this module? module Jacinda.Backend.Normalize ( compileR , compileIn , eClosed@@ -14,11 +13,13 @@ , parseAsF , the , asTup+ , EvalError (..) -- * Monad , runEvalM , eNorm ) where +import Control.Exception (Exception, throw) import Control.Monad.State.Strict (State, evalState, gets, modify, runState) import Control.Recursion (cata, embed) import Data.Bifunctor (second)@@ -38,6 +39,12 @@ import Jacinda.Ty.Const import Regex.Rure (RureMatch (..)) +data EvalError = EmptyFold+ | IndexOutOfBounds Int+ deriving (Show)++instance Exception EvalError where+ mkI :: Integer -> E (T K) mkI = IntLit tyI @@ -82,6 +89,7 @@ compileR = cata a where -- TODO: combine with eNorm pass? a (RegexLitF _ rr) = RegexCompiled (compileDefault rr) a x = embed x+ -- TODO: is cata performant enough? compileIn :: Program a -> Program a compileIn (Program ds e) = Program (compileD <$> ds) (compileR e)@@ -183,6 +191,7 @@ eNorm e@TBuiltin{} = pure e eNorm (Tup tys es) = Tup tys <$> traverse eNorm es eNorm (Anchor ty es) = Anchor ty <$> traverse eNorm es+eNorm (NBuiltin ty None) = pure $ OptionVal ty Nothing eNorm e@NBuiltin{} = pure e eNorm (EApp ty op@BBuiltin{} e) = EApp ty op <$> eNorm e eNorm (EApp ty (EApp ty' op@(BBuiltin _ Matches) e) e') = do@@ -270,7 +279,7 @@ pure $ case (eI, eI') of (IntLit _ i, IntLit _ j) -> i `seq` j `seq` IntLit tyI (i*j) _ -> EApp ty (EApp ty' op eI) eI'-eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyFloat) _) Plus) e) e') = do+eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyFloat) _) Plus) e) e') = do -- TODO: don't match on type, do that below eI <- eNorm e eI' <- eNorm e' pure $ case (eI, eI') of@@ -383,6 +392,18 @@ pure $ case (eI, eI') of (StrLit _ i, StrLit _ j) -> BoolLit tyBool (i /= j) _ -> EApp ty (EApp ty' op eI) eI'+eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyBool) _) Eq) e) e') = do+ eI <- eNorm e+ eI' <- eNorm e'+ pure $ case (eI, eI') of+ (BoolLit _ b, BoolLit _ b') -> BoolLit tyBool (b == b')+ _ -> EApp ty (EApp ty' op eI) eI'+eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyBool) _) Neq) e) e') = do+ eI <- eNorm e+ eI' <- eNorm e'+ pure $ case (eI, eI') of+ (BoolLit _ b, BoolLit _ b') -> BoolLit tyBool (b /= b')+ _ -> EApp ty (EApp ty' op eI) eI' eNorm (EApp ty0 (EApp ty1 op@(BBuiltin _ And) e) e') = do eI <- eNorm e eI' <- eNorm e'@@ -408,6 +429,12 @@ pure $ case eI of (Tup _ es) -> es !! (i-1) _ -> EApp ty op eI+eNorm (EApp ty op@(UBuiltin _ Negate) e) = do+ eI <- eNorm e+ pure $ case eI of+ (FloatLit _ f) -> mkF $ negate f+ (IntLit _ i) -> mkI $ negate i+ _ -> EApp ty op eI eNorm (EApp ty op@(UBuiltin _ Not) e) = do eI <- eNorm e pure $ case eI of@@ -469,6 +496,13 @@ pure $ case (e0', e1', e2') of (StrLit _ str, IntLit _ ix, RegexCompiled re) -> OptionVal (tyOpt tyStr) (mkStr <$> findCapture re str (fromIntegral ix)) _ -> EApp ty0 (EApp ty1 (EApp ty2 op e0') e1') e2'+eNorm (EApp ty0 (EApp ty1 (EApp ty2 op@(TBuiltin _ AllCaptures) e0) e1) e2) = do+ e0' <- eNorm e0+ e1' <- eNorm e1+ e2' <- eNorm e2+ pure $ case (e0', e1', e2') of+ (StrLit _ str, IntLit _ ix, RegexCompiled re) -> Arr (mkVec tyStr) (mkStr <$> V.fromList (captures' re str (fromIntegral ix)))+ _ -> EApp ty0 (EApp ty1 (EApp ty2 op e0') e1') e2' eNorm (EApp ty0 (EApp ty1 (EApp ty2 op@(TBuiltin _ Option) e0) e1) e2) = do e0' <- eNorm e0 e1' <- eNorm e1@@ -501,6 +535,12 @@ case y' of OptionVal _ e -> OptionVal undefined <$> traverse (applyUn x') e -- TODO: undefined? _ -> pure $ EApp ty0 (EApp ty1 op x') y'+eNorm (EApp ty0 (EApp ty1 op@(BBuiltin (TyArr _ _ (TyArr _ (TyApp _ (TyB _ TyVec) _) _)) Fold1) f) x) = do+ f' <- eNorm f+ x' <- eNorm x+ case x' of+ Arr _ es -> case V.uncons es of { Just (y, ys) -> foldE f' y ys ; Nothing -> throw EmptyFold }+ _ -> pure $ EApp ty0 (EApp ty1 op f') x' eNorm (EApp ty0 (EApp ty1 (EApp ty2 op@(TBuiltin (TyArr _ _ (TyArr _ _ (TyArr _ (TyApp _ (TyB _ TyVec) _) _))) Fold) f) x) y) = do f' <- eNorm f x' <- eNorm x@@ -522,13 +562,17 @@ -- (Arr _ es, Arr _ es') -> Arr undefined <$> V.zipWithM (applyOp f') es es' -- _ -> pure $ EApp ty0 (EApp ty1 (EApp ty2 op f') x') y' eNorm (EApp ty0 (EApp ty1 (EApp ty2 op@TBuiltin{} f) x) y) = EApp ty0 <$> (EApp ty1 <$> (EApp ty2 op <$> eNorm f) <*> eNorm x) <*> eNorm y-eNorm (EApp ty0 (EApp ty1 op@(BBuiltin _ Map) x) y) = EApp ty0 <$> (EApp ty1 op <$> eNorm x) <*> eNorm y-eNorm (EApp ty0 (EApp ty1 op@(BBuiltin _ MapMaybe) x) y) = EApp ty0 <$> (EApp ty1 op <$> eNorm x) <*> eNorm y-eNorm (EApp ty0 (EApp ty1 op@(BBuiltin _ Prior) x) y) = EApp ty0 <$> (EApp ty1 op <$> eNorm x) <*> eNorm y-eNorm (EApp ty0 (EApp ty1 op@(BBuiltin _ Filter) x) y) = EApp ty0 <$> (EApp ty1 op <$> eNorm x) <*> eNorm y--- FIXME: this will almost surely run into trouble; if the above pattern matches--- are not complete it will bottom!+-- we include this in case (+) has type (a->a->a) (for instance) if it is+-- normalizing a decl (which can be ambiguous/general)+eNorm (EApp ty0 (EApp ty1 op@BBuiltin{} e) e') = EApp ty0 <$> (EApp ty1 op <$> eNorm e) <*> eNorm e'+-- FIXME: specialize types after inlining hm eNorm (EApp ty e@EApp{} e') = eNorm =<< (EApp ty <$> eNorm e <*> pure e') eNorm (Arr ty es) = Arr ty <$> traverse eNorm es eNorm (OptionVal ty e) = OptionVal ty <$> traverse eNorm e+eNorm (Cond ty p e0 e1) = do+ p' <- eNorm p+ case p' of+ BoolLit _ True -> eNorm e0+ BoolLit _ False -> eNorm e1+ _ -> pure $ Cond ty p' e0 e1 -- don't eval further, might bottom?
src/Jacinda/Backend/TreeWalk.hs view
@@ -14,6 +14,7 @@ import Data.Maybe (mapMaybe) import Data.Semigroup ((<>)) import qualified Data.Vector as V+import Debug.Trace (traceShow, traceShowId) import Jacinda.AST import Jacinda.Backend.Normalize import Jacinda.Backend.Printf@@ -25,7 +26,6 @@ | UnevalFun | TupOfStreams -- ^ Reject a tuple of streams | BadCtx- | IndexOutOfBounds Int deriving (Show) type FileBS = BS.ByteString@@ -37,44 +37,39 @@ Just x -> x Nothing -> throw $ IndexOutOfBounds ix -noRes :: a-noRes = error "Internal error: did not normalize to appropriate type."+noRes :: E b -> String -> a+noRes e ty = error ("Internal error: " ++ show e ++ " did not normalize to appropriate type, expected " ++ ty) badSugar :: a badSugar = error "Internal error: dfn syntactic sugar at a stage where it should not be." asInt :: E a -> Integer asInt (IntLit _ i) = i-asInt _ = noRes+asInt e = noRes e "Int" asBool :: E a -> Bool asBool (BoolLit _ b) = b-asBool _ = noRes+asBool e = noRes e "Bool" asStr :: E a -> BS.ByteString asStr (StrLit _ str) = str-asStr _ = noRes+asStr e = noRes e "Str" asFloat :: E a -> Double asFloat (FloatLit _ f) = f-asFloat _ = noRes+asFloat e = noRes e "Float" asRegex :: E a -> RurePtr asRegex (RegexCompiled re) = re-asRegex _ = noRes+asRegex e = noRes e "Regex" asArr :: E a -> V.Vector (E a) asArr (Arr _ es) = es-asArr _ = noRes+asArr e = noRes e "List" asOpt :: E a -> Maybe (E a) asOpt (OptionVal _ e) = e-asOpt _ = noRes---- just shove some big number into the renamer and hope it doesn't clash (bad,--- hack, this is why we got kicked out of the garden of Eden)-reprehensible :: Int-reprehensible = (maxBound :: Int) `div` 2+asOpt e = noRes e "Option" -- TODO: do I want to interleave state w/ eNorm or w/e @@ -101,11 +96,21 @@ go (EApp ty op@BBuiltin{} e) = EApp ty op (go e) go (NBuiltin _ Ix) = mkI (fromIntegral ix) go (NBuiltin _ Fp) = mkStr fp+ go (NBuiltin _ None) = OptionVal undefined Nothing+ go (EApp ty (UBuiltin _ Some) e) =+ let eI = go e+ in OptionVal ty (Just eI) go AllField{} = StrLit tyStr line go (Field _ i) = StrLit tyStr (ctx ! (i-1)) -- cause vector indexing starts at 0 go (EApp _ (UBuiltin _ IParse) e) = let eI = asStr (go e) in parseAsEInt eI+ go (EApp _ (UBuiltin (TyArr _ (TyB _ TyInteger) _) Negate) e) =+ let eI = asInt (go e)+ in mkI (negate eI)+ go (EApp _ (UBuiltin (TyArr _ (TyB _ TyFloat) _) Negate) e) =+ let eI = asFloat (go e)+ in mkF (negate eI) go (EApp _ (UBuiltin _ FParse) e) = let eI = asStr (go e) in parseAsF eI@@ -121,14 +126,14 @@ in case (eI, eI') of (RegexCompiled reϵ, StrLit _ strϵ) -> BoolLit tyBool (isMatch' reϵ strϵ) (StrLit _ strϵ, RegexCompiled reϵ) -> BoolLit tyBool (isMatch' reϵ strϵ)- _ -> noRes+ _ -> noRes eI "Regex or Str" go (EApp _ (EApp _ (BBuiltin _ NotMatches) e) e') = let eI = go e eI' = go e' in case (eI, eI') of (RegexCompiled reϵ, StrLit _ strϵ) -> BoolLit tyBool (not $ isMatch' reϵ strϵ) (StrLit _ strϵ, RegexCompiled reϵ) -> BoolLit tyBool (not $ isMatch' reϵ strϵ)- _ -> noRes+ _ -> noRes eI "Regex or Str" go (EApp _ (EApp _ (BBuiltin _ Match) e) e') = let eI = asRegex (go e) eI' = asStr (go e')@@ -138,6 +143,11 @@ e1' = asInt (go e1) e2' = asRegex (go e2) in OptionVal (tyOpt tyStr) (mkStr <$> findCapture e2' e0' (fromIntegral e1'))+ go (EApp _ (EApp _ (EApp _ (TBuiltin _ AllCaptures) e0) e1) e2) =+ let e0' = asStr (go e0)+ e1' = asInt (go e1)+ e2' = asRegex (go e2)+ in Arr (mkVec tyStr) (mkStr <$> V.fromList (captures' e2' e0' (fromIntegral e1'))) go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyInteger) _) Plus) e) e') = let eI = asInt (go e) eI' = asInt (go e')@@ -207,6 +217,14 @@ let eI = asFloat (go e) eI' = asFloat (go e') in FloatLit tyF (eI * eI')+ go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyBool) _) Eq) e) e') =+ let eI = asBool (go e)+ eI' = asBool (go e')+ in BoolLit tyBool (eI == eI')+ go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyBool) _) Neq) e) e') =+ let eI = asBool (go e)+ eI' = asBool (go e')+ in BoolLit tyBool (eI /= eI') go (EApp _ (EApp _ (BBuiltin _ Div) e) e') = let eI = asFloat (go e) eI' = asFloat (go e')@@ -267,12 +285,12 @@ let eI = go e in case eI of (Arr _ es) -> go (es V.! (i-1))- _ -> noRes+ _ -> noRes eI "List" go (EApp _ (UBuiltin _ (Select i)) e) = let eI = go e in case eI of (Tup _ es) -> go (es !! (i-1))- _ -> noRes+ _ -> noRes eI "Tuple" go (EApp _ (EApp _ (BBuiltin _ Sprintf) e) e') = let eI = asStr (go e) eI' = go e'@@ -298,8 +316,26 @@ in foldE f' seed' xs' where foldE op = V.foldl' (applyOp' op) applyOp' op e e' = go (EApp undefined (EApp undefined op e) e')+ go (EApp _ (EApp _ (BBuiltin (TyArr _ _ (TyArr _ (TyApp _ (TyB _ TyVec) _) _)) Fold1) f) xs) =+ let f' = go f+ xs' = asArr (go xs)+ in+ case V.uncons xs' of+ Just (y, ys) -> foldE f' y ys+ Nothing -> throw EmptyFold+ where foldE op = V.foldl' (applyOp' op)+ applyOp' op e e' = go (EApp undefined (EApp undefined op e) e') go (Arr ty es) = Arr ty (go <$> es)+ go (Cond _ p e0 e1) =+ let p' = asBool (go p)+ in if p' then go e0 else go e1 ++-- just shove some big number into the renamer and hope it doesn't clash (bad,+-- hack, this is why we got kicked out of the garden of Eden)+reprehensible :: Int+reprehensible = (maxBound :: Int) `div` 2+ applyOp :: E (T K) -- ^ Operator -> E (T K) -> E (T K)@@ -341,7 +377,7 @@ e' = compileR e -- FIXME: compile e too? -- TODO: normalize before stream- in imap (\ix line -> eEval (mkCtx fp re ix line) e') . ifilter (\ix line -> asBool (eEval (mkCtx fp re ix line) pe'))+ in fmap (uncurry (\ix line -> eEval (mkCtx fp re ix line) e')) . ifilter' (\ix line -> asBool (eEval (mkCtx fp re ix line) pe')) ir fp re (EApp _ (EApp _ (BBuiltin _ Map) op) stream) = let op' = compileR (withFp fp op) in fmap (applyUn op') . ir fp re stream ir fp re (EApp _ (EApp _ (BBuiltin _ Filter) op) stream) = let op' = compileR (withFp fp op)@@ -381,6 +417,17 @@ -> E (T K) foldWithCtx fp re op seed streamExpr = foldl' (applyOp op) seed . ir fp re streamExpr +fold1 :: FileBS+ -> RurePtr+ -> E (T K)+ -> E (T K)+ -> [BS.ByteString]+ -> E (T K)+fold1 fp re op streamExpr bs =+ case ir fp re streamExpr bs of+ e:es -> foldl' (applyOp op) e es+ _ -> throw EmptyFold+ runJac :: FileBS -> RurePtr -- ^ Record separator -> Int@@ -391,6 +438,7 @@ -- evaluate something that has a fold nested in it eWith :: FileBS -> RurePtr -> E (T K) -> [BS.ByteString] -> E (T K) eWith fp re (EApp _ (EApp _ (EApp _ (TBuiltin (TyArr _ _ (TyArr _ _ (TyArr _ (TyApp _ (TyB _ TyStream) _) _))) Fold) op) seed) stream) = foldWithCtx fp re op seed stream+eWith fp re (EApp _ (EApp _ (BBuiltin (TyArr _ _ (TyArr _ (TyApp _ (TyB _ TyStream) _) _)) Fold1) op) stream) = fold1 fp re op stream eWith fp re (EApp ty e0 e1) = \bs -> eClosed undefined (EApp ty (eWith fp re e0 bs) (eWith fp re e1 bs)) eWith _ _ e@BBuiltin{} = const e eWith _ _ e@UBuiltin{} = const e@@ -401,6 +449,8 @@ eWith _ _ e@BoolLit{} = const e eWith fp re (Tup ty es) = \bs -> Tup ty ((\e -> eWith fp re e bs) <$> es) eWith fp re (OptionVal ty e) = \bs -> OptionVal ty ((\eϵ -> eWith fp re eϵ bs) <$> e)+eWith fp re (Cond ty p e e') = \bs -> eClosed undefined (Cond ty (eWith fp re p bs) (eWith fp re e bs) (eWith fp re e' bs))+eWith fp _ (NBuiltin _ Fp) = const (mkStr fp) -- TODO: rewrite tuple-of-folds as fold-of-tuples ... "compile" to E (T K) -> E (T K) -- OR "compile" to [(Int, E (T K)] -> ...
src/Jacinda/File.hs view
@@ -37,7 +37,7 @@ case parseLibWithCtx contents st of Left err -> liftIO (throwIO err) Right (st', ([], ds)) -> put st' $> (rewriteD <$> ds)- Right (st', (is, ds)) -> do { put st' ; dss <- traverse (parseLib incls) is ; pure (concat dss ++ ds) }+ Right (st', (is, ds)) -> do { put st' ; dss <- traverse (parseLib incls) is ; pure (concat dss ++ fmap rewriteD ds) } parseE :: [FilePath] -> BSL.ByteString -> StateT AlexUserState IO (Program AlexPosn) parseE incls bs = do
src/Jacinda/Include.hs view
@@ -7,7 +7,7 @@ import Data.List.Split (splitWhen) import Data.Maybe (listToMaybe) import Paths_jacinda (getDataDir)-import System.Directory (doesFileExist)+import System.Directory (doesFileExist, getCurrentDirectory) import System.Environment (lookupEnv) import System.FilePath ((</>)) @@ -19,7 +19,8 @@ defaultIncludes = do path <- jacPath d <- getDataDir- pure $ (d:) . (++path)+ dot <- getCurrentDirectory+ pure $ (dot:) . (d:) . (++path) -- | Parsed @JAC_PATH@ jacPath :: IO [FilePath]
src/Jacinda/Lexer.x view
@@ -67,6 +67,7 @@ $white+ ; "{.".* ;+ "#!".* ; -- shebang ":=" { mkSym DefEq } "≔" { mkSym DefEq }@@ -84,6 +85,7 @@ "|" { mkSym FoldTok } \" { mkSym Quot } "^" { mkSym Caret }+ "|>" { mkSym Fold1Tok } "=" { mkSym EqTok } "!=" { mkSym NeqTok }@@ -116,6 +118,7 @@ ".?" { mkSym CatMaybesTok } ":?" { mkSym MapMaybeTok } "~*" { mkSym CapTok }+ "-." { mkSym NegTok } in { mkKw KwIn } let { mkKw KwLet }@@ -124,6 +127,9 @@ :set { mkKw KwSet } fn { mkKw KwFn } "@include" { mkKw KwInclude }+ if { mkKw KwIf }+ then { mkKw KwThen }+ else { mkKw KwElse } fs { mkRes VarFs } ix { mkRes VarIx }@@ -142,6 +148,7 @@ floor { mkBuiltin BuiltinFloor } ceil { mkBuiltin BuiltinCeil } match { mkBuiltin BuiltinMatch }+ captures { mkBuiltin BuiltinCaptures } Some { mkBuiltin BuiltinSome } None { mkBuiltin BuiltinNone } fp { mkBuiltin BuiltinFp }@@ -236,6 +243,7 @@ | MinusTok | PercentTok | FoldTok+ | Fold1Tok | Quot | TimesTok | DefEq@@ -276,12 +284,14 @@ | CatMaybesTok | MapMaybeTok | CapTok+ | NegTok instance Pretty Sym where pretty PlusTok = "+" pretty MinusTok = "-" pretty PercentTok = "%" pretty FoldTok = "|"+ pretty Fold1Tok = "|>" pretty TimesTok = "*" pretty DefEq = ":=" pretty Colon = ":"@@ -322,6 +332,7 @@ pretty CatMaybesTok = ".?" pretty MapMaybeTok = ":?" pretty CapTok = "~*"+ pretty NegTok = "-." data Keyword = KwLet | KwIn@@ -330,6 +341,9 @@ | KwSet | KwFn | KwInclude+ | KwIf+ | KwThen+ | KwElse -- | Reserved/special variables data Var = VarX@@ -358,6 +372,9 @@ pretty KwSet = ":set" pretty KwFn = "fn" pretty KwInclude = "@include"+ pretty KwIf = "if"+ pretty KwThen = "then"+ pretty KwElse = "else" data Builtin = BuiltinIParse | BuiltinFParse@@ -369,24 +386,26 @@ | BuiltinFloor | BuiltinCeil | BuiltinMatch+ | BuiltinCaptures | BuiltinSome | BuiltinNone | BuiltinFp instance Pretty Builtin where- pretty BuiltinIParse = ":i"- pretty BuiltinFParse = ":f"- pretty BuiltinSubstr = "substr"- pretty BuiltinSplit = "split"- pretty BuiltinOption = "option"- pretty BuiltinSplitc = "splitc"- pretty BuiltinSprintf = "sprintf"- pretty BuiltinFloor = "floor"- pretty BuiltinCeil = "ceil"- pretty BuiltinMatch = "match"- pretty BuiltinSome = "Some"- pretty BuiltinNone = "None"- pretty BuiltinFp = "fp"+ pretty BuiltinIParse = ":i"+ pretty BuiltinFParse = ":f"+ pretty BuiltinSubstr = "substr"+ pretty BuiltinSplit = "split"+ pretty BuiltinOption = "option"+ pretty BuiltinSplitc = "splitc"+ pretty BuiltinSprintf = "sprintf"+ pretty BuiltinFloor = "floor"+ pretty BuiltinCeil = "ceil"+ pretty BuiltinMatch = "match"+ pretty BuiltinSome = "Some"+ pretty BuiltinNone = "None"+ pretty BuiltinFp = "fp"+ pretty BuiltinCaptures = "captures" data Token a = EOF { loc :: a } | TokSym { loc :: a, _sym :: Sym }
src/Jacinda/Parser.y view
@@ -70,11 +70,13 @@ comma { TokSym $$ Comma } fold { TokSym $$ FoldTok }+ fold1 { TokSym $$ Fold1Tok } caret { TokSym $$ Caret } quot { TokSym $$ Quot } mapMaybe { TokSym $$ MapMaybeTok } catMaybes { TokSym $$ CatMaybesTok } capture { TokSym $$ CapTok }+ neg { TokSym $$ NegTok } eq { TokSym $$ EqTok } neq { TokSym $$ NeqTok }@@ -105,6 +107,9 @@ set { TokKeyword $$ KwSet } fn { TokKeyword $$ KwFn } include { TokKeyword $$ KwInclude }+ if { TokKeyword $$ KwIf }+ then { TokKeyword $$ KwThen }+ else { TokKeyword $$ KwElse } x { TokResVar $$ VarX } y { TokResVar $$ VarY }@@ -126,6 +131,7 @@ some { TokBuiltin $$ BuiltinSome } none { TokBuiltin $$ BuiltinNone } fp { TokBuiltin $$ BuiltinFp }+ captures { TokBuiltin $$ BuiltinCaptures } iParse { TokBuiltin $$ BuiltinIParse } fParse { TokBuiltin $$ BuiltinFParse }@@ -175,6 +181,7 @@ | or { Or } | backslashdot { Prior } | filter { Filter }+ | fold1 { Fold1 } Bind :: { (Name AlexPosn, E AlexPosn) } : val name defEq E { ($2, $4) }@@ -187,6 +194,7 @@ D :: { D AlexPosn } : set fs defEq rr semicolon { SetFS (BSL.toStrict $ rr $4) } | fn name Args defEq E semicolon { FunDecl $2 $3 $5 }+ | fn name defEq E semicolon { FunDecl $2 [] $4 } Include :: { FilePath } : include strLit { ASCII.unpack (strTok $2) }@@ -257,6 +265,7 @@ | substr { TBuiltin $1 Substr } | sprintf { BBuiltin $1 Sprintf } | option { TBuiltin $1 Option }+ | captures { TBuiltin $1 AllCaptures } | floor { UBuiltin $1 Floor } | ceil { UBuiltin $1 Ceiling } | floorSym { UBuiltin $1 Floor }@@ -264,6 +273,7 @@ | dedup { UBuiltin $1 Dedup } | some { UBuiltin $1 Some } | catMaybes { UBuiltin $1 CatMaybes }+ | neg { UBuiltin $1 Negate } | ix { NBuiltin $1 Ix } | nf { NBuiltin $1 Nf } | none { NBuiltin $1 None }@@ -274,6 +284,7 @@ | E select { EApp (eLoc $1) (UBuiltin (loc $2) (Select $ field $2)) $1 } | 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 } {
src/Jacinda/Parser/Rewrite.hs view
@@ -34,8 +34,15 @@ a (EAppF l e0@(EApp _ (BBuiltin _ Matches) _) (EApp l1 (EApp l2 e1@(BBuiltin _ Or) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3 a (EAppF l e0@(EApp _ (BBuiltin _ NotMatches) _) (EApp l1 (EApp l2 e1@(BBuiltin _ And) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3 a (EAppF l e0@(EApp _ (BBuiltin _ NotMatches) _) (EApp l1 (EApp l2 e1@(BBuiltin _ Or) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@(EApp _ (BBuiltin _ Fold1) _) (EApp l1 (EApp l2 e1@(BBuiltin _ Eq) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@(EApp _ (BBuiltin _ Fold1) _) (EApp l1 (EApp l2 e1@(BBuiltin _ Neq) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@(EApp _ (BBuiltin _ Fold1) _) (EApp l1 (EApp l2 e1@(BBuiltin _ Gt) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@(EApp _ (BBuiltin _ Fold1) _) (EApp l1 (EApp l2 e1@(BBuiltin _ Geq) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@(EApp _ (BBuiltin _ Fold1) _) (EApp l1 (EApp l2 e1@(BBuiltin _ Leq) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@(EApp _ (BBuiltin _ Fold1) _) (EApp l1 (EApp l2 e1@(BBuiltin _ Lt) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3 a (EAppF l e0@Var{} (EApp lϵ (EApp lϵϵ e1 e2) e3)) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3 -- TODO rewrite dfn+ a (EAppF l e0@Var{} (EApp l0 e1 (EApp l1 (EApp l2 op@BBuiltin{} 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@(BBuiltin _ Max) (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2 a (EAppF l e0@(BBuiltin _ Min) (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2@@ -47,4 +54,6 @@ a (EAppF l e0@(TBuiltin _ Substr) (EApp lϵ e1 (EApp lϵϵ e2 e3))) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3 a (EAppF l e0@(TBuiltin _ Option) (EApp lϵ (EApp lϵϵ e1 e2) e3)) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3 a (EAppF l e0@(TBuiltin _ Option) (EApp lϵ e1 (EApp lϵϵ e2 e3))) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3+ a (EAppF l e0@(TBuiltin _ AllCaptures) (EApp lϵ (EApp lϵϵ e1 e2) e3)) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3+ a (EAppF l e0@(TBuiltin _ AllCaptures) (EApp lϵ e1 (EApp lϵϵ e2 e3))) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3 a x = embed x
src/Jacinda/Regex.hs view
@@ -9,6 +9,7 @@ , compileDefault , substr , findCapture+ , captures' ) where import Control.Exception (Exception, throwIO)@@ -37,9 +38,16 @@ substr (BS.BS fp l) begin endϵ | endϵ >= begin = BS.BS (fp `plusForeignPtr` begin) (min l endϵ - begin) | otherwise = "error: invalid substring indices." +captures' :: RurePtr -> BS.ByteString -> CSize -> [BS.ByteString]+captures' re haystack@(BS.BS fp _) ix = unsafeDupablePerformIO $ fmap go <$> captures re haystack ix+ where go (RureMatch s e) =+ let e' = fromIntegral e+ s' = fromIntegral s+ in BS.BS (fp `plusForeignPtr` s') (e'-s')+ {-# NOINLINE findCapture #-} findCapture :: RurePtr -> BS.ByteString -> CSize -> Maybe BS.ByteString-findCapture re haystack@(BS.BS fp l) ix = unsafeDupablePerformIO $ fmap go <$> findCaptures re haystack ix 0+findCapture re haystack@(BS.BS fp _) ix = unsafeDupablePerformIO $ fmap go <$> findCaptures re haystack ix 0 where go (RureMatch s e) = let e' = fromIntegral e s' = fromIntegral s
src/Jacinda/Rename.hs view
@@ -91,19 +91,25 @@ mkLam :: [Name a] -> E a -> E a mkLam ns e = foldr (\n -> Lam (loc n) n) e ns +-- TODO: investigate performance w/out cata+ -- | A dfn could be unary or binary - here we guess if it is binary hasY :: E a -> Bool hasY = cata a where- a (ResVarF _ Y) = True- a (TupF _ es) = or es- a (EAppF _ e e') = e || e'- a (LamF _ _ e) = e- a DfnF{} = error "Not supported yet."- a (LetF _ b e) = e || snd b- a (GuardedF _ p b) = b || p- a (ImplicitF _ e) = e- a (ParenF _ e) = e- a _ = False+ a (ResVarF _ Y) = True+ a (TupF _ es) = or es+ a (EAppF _ e e') = e || e'+ a (LamF _ _ e) = e+ a DfnF{} = error "Not supported yet."+ a (LetF _ b e) = e || snd b+ a (GuardedF _ p b) = b || p+ a (ImplicitF _ e) = e+ a (ParenF _ e) = e+ a (ArrF _ es) = or es+ a (AnchorF _ es) = or es+ a (OptionValF _ (Just e)) = e+ a (CondF _ p e e') = p || e || e'+ a _ = False replaceXY :: (a -> Name a) -- ^ @x@ -> (a -> Name a) -- ^ @y@@@ -133,14 +139,14 @@ renameE (Lam l n e) = do (n', modR) <- withName n Lam l n' <$> withRenames modR (renameE e)-renameE (Dfn l e) | hasY e = do+renameE (Dfn l e) | {-# SCC "hasY" #-} hasY e = do x@(Name nX uX _) <- dummyName l "x" y@(Name nY uY _) <- dummyName l "y"- Lam l x . Lam l y <$> renameE (replaceXY (Name nX uX) (Name nY uY) e)+ Lam l x . Lam l y <$> renameE ({-# SCC "replaceXY" #-} replaceXY (Name nX uX) (Name nY uY) e) | otherwise = do x@(Name n u _) <- dummyName l "x" -- no need for withName... withRenames because this is fresh/globally unique- Lam l x <$> renameE (replaceX (Name n u) e)+ Lam l x <$> renameE ({-# SCC "replaceX" #-} replaceX (Name n u) e) renameE (Guarded l p e) = Guarded l <$> renameE p <*> renameE e renameE (Implicit l e) = Implicit l <$> renameE e renameE ResVar{} = error "Bare reserved variable."@@ -152,4 +158,5 @@ renameE (Arr l es) = Arr l <$> traverse renameE es renameE (Anchor l es) = Anchor l <$> traverse renameE es renameE (OptionVal l e) = OptionVal l <$> traverse renameE e+renameE (Cond l p e e') = Cond l <$> renameE p <*> renameE e <*> renameE e' renameE e = pure e -- literals &c.
src/Jacinda/Ty.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Jacinda.Ty ( TypeM@@ -11,7 +12,7 @@ import Control.Exception (Exception) import Control.Monad (forM) import Control.Monad.Except (throwError)-import Control.Monad.State.Strict (StateT, gets, modify, runStateT)+import Control.Monad.State.Strict (StateT, gets, modify, runState, runStateT) import Data.Bifunctor (first, second) import Data.Foldable (traverse_) import Data.Functor (void, ($>))@@ -33,12 +34,16 @@ | Doesn'tSatisfy a (T ()) C | IllScoped a (Name a) | Ambiguous (E ())+ | Expected K K+ | IllScopedTyVar (TyName ()) instance Pretty a => Pretty (Error a) where pretty (UnificationFailed l ty ty') = pretty l <+> "could not unify type" <+> squotes (pretty ty) <+> "with" <+> squotes (pretty ty') pretty (Doesn'tSatisfy l ty c) = pretty l <+> squotes (pretty ty) <+> "is not a member of class" <+> pretty c pretty (IllScoped l n) = pretty l <+> squotes (pretty n) <+> "is not in scope." pretty (Ambiguous e) = "type of" <+> squotes (pretty e) <+> "is ambiguous"+ pretty (Expected k0 k1) = "Found kind" <+> pretty k0 <> ", expected kind" <+> pretty k1+ pretty (IllScopedTyVar n) = "Type variable" <+> squotes (pretty n) <+> "is not in scope." instance Pretty a => Show (Error a) where show = show . pretty@@ -47,7 +52,7 @@ -- solve, unify etc. THEN check that all constraints are satisfied? -- (after accumulating classVar membership...)-data TyState a = TyState { maxU :: Int+data TyState a = TyState { maxU :: !Int , kindEnv :: IM.IntMap K , classVars :: IM.IntMap (S.Set (C, a)) , varEnv :: IM.IntMap (T K)@@ -64,6 +69,10 @@ mapMaxU :: (Int -> Int) -> TyState a -> TyState a mapMaxU f (TyState u k c v cs) = TyState (f u) k c v cs +setMaxU :: Int -> TyState a -> TyState a+-- setMaxU i = mapMaxU (const i)+setMaxU i (TyState _ k c v cs) = TyState i k c v cs+ mapClassVars :: (IM.IntMap (S.Set (C, a)) -> IM.IntMap (S.Set (C, a))) -> TyState a -> TyState a mapClassVars f (TyState u k cvs v cs) = TyState u k (f cvs) v cs @@ -129,7 +138,7 @@ unify = unifyPrep IM.empty unifyM :: S.Set (l, T a, T a) -> TypeM l (IM.IntMap (T a))-unifyM s = unify (S.toList s)+unifyM s = {-# SCC "unifyM" #-} unify (S.toList s) substInt :: IM.IntMap (T a) -> Int -> Maybe (T a) substInt tys k =@@ -159,10 +168,12 @@ higherOrder :: T.Text -> TypeM a (Name K) higherOrder t = freshName t (KArr Star Star)+-- TODO: this should modify kind environment -- of kind 'Star' dummyName :: T.Text -> TypeM a (Name K) dummyName n = freshName n Star+-- TODO: this should modify kind environment addC :: Ord a => Name b -> (C, a) -> IM.IntMap (S.Set (C, a)) -> IM.IntMap (S.Set (C, a)) addC (Name _ (Unique i) _) c = IM.alter (Just . go) i where@@ -181,6 +192,68 @@ pushConstraint l ty ty' = modify (addConstraint (l, ty, ty')) +isStar :: K -> TypeM a ()+isStar Star = pure ()+isStar k = throwError $ Expected k Star++liftCloneTy :: T a -> TypeM b (T a)+liftCloneTy ty = do+ i <- gets maxU+ let (ty', j) = cloneTy i ty+ ty <$ modify (setMaxU i)++cloneTy :: Int -> T a -> (T a, Int)+cloneTy i ty = second fst $ flip runState (i, IM.empty) $ cloneTyM ty+ where cloneTyM (TyVar l (Name n (Unique j) l')) = do+ st <- gets snd+ case IM.lookup j st of+ Just k -> pure k+ Nothing -> do+ k <- gets fst+ let ty' = TyVar l (Name n (Unique $ k+1) l')+ ty' <$ modify (\(u, s) -> (u+1, IM.insert j ty' s))+ cloneTyM (TyArr l tyϵ ty') = TyArr l <$> cloneTyM tyϵ <*> cloneTyM ty'+ cloneTyM (TyApp l tyϵ ty') = TyApp l <$> cloneTyM tyϵ <*> cloneTyM ty'+ cloneTyM (TyTup l tys) = TyTup l <$> traverse cloneTyM tys+ cloneTyM ty@TyNamed{} = pure ty+ cloneTyM ty@TyB{} = pure ty++kind :: T K -> TypeM a ()+kind (TyB Star TyStr) = pure ()+kind (TyB Star TyInteger) = pure ()+kind (TyB Star TyFloat) = pure ()+kind (TyB (KArr Star Star) TyStream) = pure ()+kind (TyB (KArr Star Star) TyOption) = pure ()+kind (TyB Star TyBool) = pure ()+kind (TyB (KArr Star Star) TyVec) = pure ()+kind (TyB Star TyUnit) = pure ()+kind (TyB k TyStr) = throwError $ Expected Star k+kind (TyB k TyInteger) = throwError $ Expected Star k+kind (TyB k TyFloat) = throwError $ Expected Star k+kind (TyB k TyUnit) = throwError $ Expected Star k+kind (TyB k TyBool) = throwError $ Expected Star k+kind (TyB k TyOption) = throwError $ Expected (KArr Star Star) k+kind (TyB k TyStream) = throwError $ Expected (KArr Star Star) k+kind (TyB k TyVec) = throwError $ Expected (KArr Star Star) k+kind (TyVar _ n@(Name _ (Unique i) _)) = do+ preK <- gets (IM.lookup i . kindEnv)+ case preK of+ Just{} -> pure ()+ Nothing -> throwError $ IllScopedTyVar (void n)+kind (TyTup Star tys) =+ traverse_ isStar (fmap tLoc tys)+kind (TyTup k _) = throwError $ Expected Star k+kind (TyArr Star ty0 ty1) =+ isStar (tLoc ty0) *>+ isStar (tLoc ty1)+kind (TyArr k _ _) = throwError $ Expected Star k+kind (TyApp k1 ty0 ty1) = do+ case tLoc ty0 of+ (KArr k0 k1') | k0 == tLoc ty1 && k1' == k1 -> pure ()+ | k0 == tLoc ty1 -> throwError $ Expected k1' k1+ | otherwise -> throwError $ Expected (tLoc ty1) k0+ k0 -> throwError $ Expected (KArr Star Star) k0+ -- TODO: this will need some class context if we permit custom types (Optional) checkType :: Ord a => T K -> (C, a) -> TypeM a () checkType TyVar{} _ = pure () -- TODO: I think this is right@@ -235,16 +308,16 @@ -> Int -> S.Set (C, a) -> TypeM a ()-checkClass tys i cs =+checkClass tys i cs = {-# SCC "checkClass" #-} case substInt tys i of Just ty -> traverse_ (checkType ty) (first (substC tys) <$> S.toList cs)- Nothing -> pure () -- FIXME: do we need to check var is well-kinded for constraint?+ Nothing -> pure () -- FIXME: we need to check that the var is well-kinded for constraint lookupVar :: Name a -> TypeM a (T K) lookupVar n@(Name _ (Unique i) l) = do st <- gets varEnv case IM.lookup i st of- Just ty -> pure ty+ Just ty -> liftCloneTy ty Nothing -> throwError $ IllScoped l n tyOf :: Ord a => E a -> TypeM a (T K)@@ -290,10 +363,9 @@ traverse_ (uncurry (checkClass backNames)) toCheck backNames' <- unifyM =<< gets constraints -- FIXME: not sure if termination/whatever is guaranteed, need 2 think..- let res = fmap (substConstraints backNames') (Program ds' e')+ let res = {-# SCC "substConstraints" #-} fmap (substConstraints backNames') (Program ds' e') checkAmb (expr res) $> res --- FIXME kind check tyE :: Ord a => E a -> TypeM a (E (T K)) tyE e = do e' <- tyE0 e@@ -341,12 +413,6 @@ desugar :: a desugar = error "Should have been de-sugared in an earlier stage!" -tyVec :: T K-tyVec = TyB (KArr Star Star) TyVec--mkVec :: T K -> T K-mkVec = hkt tyVec- tyE0 :: Ord a => E a -> TypeM a (E (T K)) tyE0 (BoolLit _ b) = pure $ BoolLit tyBool b tyE0 (IntLit _ i) = pure $ IntLit tyI i@@ -388,6 +454,11 @@ tyE0 (UBuiltin _ FParse) = pure $ UBuiltin (tyArr tyStr tyF) FParse tyE0 (UBuiltin _ Floor) = pure $ UBuiltin (tyArr tyF tyI) Floor tyE0 (UBuiltin _ Ceiling) = pure $ UBuiltin (tyArr tyF tyI) Ceiling+tyE0 (UBuiltin l Negate) = do+ a <- dummyName "a"+ modify (mapClassVars (addC a (IsNum, l)))+ let a' = var a+ pure $ UBuiltin (tyArr a' a') Negate tyE0 (UBuiltin _ Some) = do a <- dummyName "a" let a' = var a@@ -408,7 +479,7 @@ tyE0 (UBuiltin _ (At i)) = do a <- dummyName "a" let a' = var a- tyV = hkt tyVec a'+ tyV = mkVec a' pure $ UBuiltin (tyArr tyV a') (At i) tyE0 (UBuiltin l (Select i)) = do a <- dummyName "a"@@ -477,6 +548,14 @@ fTy = tyArr (tyArr b' (tyArr a' b')) (tyArr b' (tyArr (hkt f' a') b')) modify (mapClassVars (addC f (Foldable, l))) pure $ TBuiltin fTy Fold+tyE0 (BBuiltin l Fold1) = do+ a <- dummyName "a"+ f <- higherOrder "f"+ let a' = var a+ f' = var f+ fTy = tyArr (tyArr a' (tyArr a' a')) (tyArr (hkt f' a') a')+ modify (mapClassVars (addC f (Foldable, l)))+ pure $ BBuiltin fTy Fold1 tyE0 (TBuiltin _ Captures) = pure $ TBuiltin (tyArr tyStr (tyArr tyI (tyArr tyStr (tyOpt tyStr)))) Captures -- (a -> a -> a) -> Stream a -> Stream a@@ -510,6 +589,8 @@ a' = var a fTy = tyArr b' (tyArr (tyArr a' b') (tyArr (tyOpt a') b')) pure $ TBuiltin fTy Option+tyE0 (TBuiltin _ AllCaptures) =+ pure $ TBuiltin (tyArr tyStr (tyArr tyI (tyArr tyStr (mkVec tyStr)))) AllCaptures tyE0 (Implicit _ e) = do e' <- tyE0 e pure $ Implicit (tyStream (eLoc e')) e'@@ -576,3 +657,11 @@ let a' = var a pushConstraint l (tyStream a') (eLoc e') $> e' pure $ Anchor (TyB Star TyUnit) es'+tyE0 (Cond l p e0 e1) = do+ p' <- tyE0 p+ e0' <- tyE0 e0+ e1' <- tyE0 e1+ let ty0 = eLoc e0'+ pushConstraint l tyBool (eLoc p')+ pushConstraint (eLoc e0) ty0 (eLoc e1')+ pure $ Cond ty0 p' e0' e1'
src/Jacinda/Ty/Const.hs view
@@ -5,6 +5,7 @@ , tyBool , hkt , tyOpt+ , mkVec ) where import Jacinda.AST@@ -30,3 +31,9 @@ tyOpt :: T K -> T K tyOpt = hkt (TyB (KArr Star Star) TyOption)++tyVec :: T K+tyVec = TyB (KArr Star Star) TyVec++mkVec :: T K -> T K+mkVec = hkt tyVec
test/Spec.hs view
@@ -42,6 +42,7 @@ , testCase "typechecks/parses correctly" (tyFile "test/examples/line.jac") , testCase "split eval" (evalTo "[x+' '+y]|'' split '01-23-1987' /-/" " 01 23 1987") , testCase "captureE" (evalTo "'01-23-1987' ~* 3 /(\\d{2})-(\\d{2})-(\\d{4})/" "Some 1987")+ , testCase "if...then...else" (evalTo "if #t then 0 else 1" "0") ] evalTo :: BSL.ByteString -> String -> Assertion