jacinda 0.2.1.0 → 0.3.0.0
raw patch · 38 files changed
+733/−208 lines, 38 filesdep +criteriondep +deepseqdep +directorydep ~basedep ~containersdep ~regex-rure
Dependencies added: criterion, deepseq, directory, filepath, split
Dependency ranges changed: base, containers, regex-rure
Files
- CHANGELOG.md +11/−0
- README.md +23/−3
- app/Main.hs +23/−12
- bench/Bench.hs +24/−0
- doc/guide.pdf binary
- examples/bc.jac +2/−0
- examples/chess.jac +23/−0
- examples/excess.jac +2/−0
- examples/lc.jac +3/−0
- examples/lib.jac +10/−0
- examples/line.jac +1/−0
- examples/mve.jac +8/−0
- examples/path.jac +5/−0
- examples/path2.jac +8/−0
- examples/span.jac +9/−0
- examples/span2.jac +9/−0
- examples/sumLs.jac +2/−0
- examples/tags.jac +10/−0
- jacinda.cabal +41/−4
- lib/example.jac +0/−10
- lib/maybe.jac +5/−0
- lib/string.jac +5/−0
- lib/tag.jac +2/−0
- man/ja.1 +20/−7
- prelude/fn.jac +26/−0
- src/Jacinda/AST.hs +93/−56
- src/Jacinda/Backend/Normalize.hs +39/−8
- src/Jacinda/Backend/TreeWalk.hs +66/−17
- src/Jacinda/File.hs +51/−26
- src/Jacinda/Include.hs +36/−0
- src/Jacinda/Lexer.x +27/−6
- src/Jacinda/Parser.y +46/−8
- src/Jacinda/Parser/Rewrite.hs +4/−0
- src/Jacinda/Regex.hs +12/−4
- src/Jacinda/Rename.hs +1/−0
- src/Jacinda/Ty.hs +68/−44
- src/Jacinda/Ty/Const.hs +8/−0
- test/Spec.hs +10/−3
CHANGELOG.md view
@@ -1,3 +1,14 @@+# 0.3.0.0++ * Fix renaming bug that was inveigling folds with lambdas+ * Add `nf` builtin+ * Add deduplication builtin (`~.`)+ * Add anchor ability to print multiple streams+ * Make `Option` a functor+ * Add `Witherable` class, `:?` (mapMaybe)+ * Allow file `@include`s (crude library capability)+ * Fix typos in manpage+ # 0.2.1.0 * Add `fp` builtin
README.md view
@@ -24,7 +24,7 @@ # SHOCK & AWE ```-ls -l | ja '(+)|0 {ix>1}{`5:i}'+ls -l | ja '(+)|0 {ix>1}{`5:}' ``` ```@@ -32,6 +32,26 @@ ja ',[1.0-x%y] {ix>1}{`5:} {ix>1}{`11:}' -F, ``` +## Rosetta++Replace++```awk+NF == 1 && $1 != "}" {+ haveversion[$1] = 1+}+END {+ for (i in haveversion)+ printf "have-%s = yes\n", i+}+```++with++```+(sprintf 'have-%s = yes')" ~.{nf=1 & `1 != '}'}{`1}+```+ # Documentation See the [guide](https://vmchale.github.io/jacinda/), which contains a tutorial@@ -59,7 +79,6 @@ * Typeclasses are not documented * Type system is questionable * Postfix `:f` and `:i` are handled poorly- * File imports/includes * Various bugs in evaluation with regular expressions Intentionally missing features:@@ -67,12 +86,13 @@ * No loops * No conditionals -The latter in particular I may add if necessary+The latter in particular I may add if necessary/requested # Further Advantages * [Rust's regular expressions](https://docs.rs/regex/) - extensively documented with Unicode support+ * Deduplicate builtin # PERFORMANCE
app/Main.hs view
@@ -9,9 +9,9 @@ import qualified Paths_jacinda as P import System.IO (stdin) -data Command = TypeCheck !FilePath- | Run !FilePath !(Maybe FilePath)- | Expr !BSL.ByteString !(Maybe FilePath) !(Maybe BS.ByteString)+data Command = TypeCheck !FilePath ![FilePath]+ | Run !FilePath !(Maybe FilePath) ![FilePath]+ | Expr !BSL.ByteString !(Maybe FilePath) !(Maybe BS.ByteString) ![FilePath] | Eval !BSL.ByteString jacFile :: Parser FilePath@@ -47,11 +47,22 @@ <> command "run" (info runP (progDesc "Run from file"))) <|> exprP where- tcP = TypeCheck <$> jacFile- runP = Run <$> jacFile <*> inpFile- exprP = Expr <$> jacExpr <*> inpFile <*> jacFs+ tcP = TypeCheck <$> jacFile <*> includes+ runP = Run <$> jacFile <*> inpFile <*> includes+ exprP = Expr <$> jacExpr <*> inpFile <*> jacFs <*> 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@@ -65,9 +76,9 @@ main = run =<< execParser wrapper run :: Command -> IO ()-run (TypeCheck fp) = tcIO =<< BSL.readFile fp-run (Run fp Nothing) = do { contents <- BSL.readFile fp ; runOnHandle contents Nothing stdin }-run (Run fp (Just dat)) = do { contents <- BSL.readFile fp ; runOnFile contents Nothing dat }-run (Expr eb Nothing fs) = runOnHandle eb fs stdin-run (Expr eb (Just fp) fs) = runOnFile eb fs fp-run (Eval e) = print (exprEval e)+run (TypeCheck fp is) = tcIO is =<< BSL.readFile fp+run (Run fp Nothing is) = do { contents <- BSL.readFile fp ; runOnHandle is contents Nothing stdin }+run (Run fp (Just dat) is) = do { contents <- BSL.readFile fp ; runOnFile is contents Nothing dat }+run (Expr eb Nothing fs is) = runOnHandle is eb fs stdin+run (Expr eb (Just fp) fs is) = runOnFile is eb fs fp+run (Eval e) = print (exprEval e)
+ bench/Bench.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Control.DeepSeq (NFData (..))+import Criterion.Main+import Jacinda.AST+import Jacinda.File++main :: IO ()+main =+ defaultMain [ bgroup "eval"+ [ bench "exprEval" $ nf exprEval "[x+' '+y]|'' split '01-23-1987' /-/"+ ]+ ]++instance NFData (E a) where+ rnf (StrLit _ str) = rnf str+ rnf (IntLit _ i) = rnf i+ rnf (BoolLit _ b) = rnf b+ rnf (FloatLit _ f) = rnf f+ rnf (Arr _ es) = rnf es+ rnf (Tup _ es) = rnf es+ rnf (OptionVal _ e) = rnf e
doc/guide.pdf view
binary file changed (181573 → 184810 bytes)
+ examples/bc.jac view
@@ -0,0 +1,2 @@+{. {#t}{#`0}+#"$0
+ examples/chess.jac view
@@ -0,0 +1,23 @@+{. fn sum(x) :=+ {. (+)|0 x;++{. fn count(x) :=+ {. sum [:1"x;++fn count(x) ≔+ (+)|0 [:1"x;++fn processLine(b) ≔+ let+ val pre := (split b /-/).1+ val l := #pre+ val res := substr pre (l-1) l+ in res end;++let+ val iStream := processLine"$0+ val white := count ((='1') #. iStream)+ val black := count ((='0') #. iStream)+ val draw := count ((='2') #. iStream)+ val total := white + black + draw+in (total . white . black . draw) end
+ examples/excess.jac view
@@ -0,0 +1,2 @@+:set fs := /,/;+{ix>1 & `11 = 'Unweighted' & `12 = 'All causes'}{(`1.`2.`3:i-`6:i)}
+ examples/lc.jac view
@@ -0,0 +1,3 @@+{. (+)|0 {/./}{1} (count nonblank lines)+(+)|0 {#t}{1}+{. (+)|0 #"$0 (count bytes in file)
+ examples/lib.jac view
@@ -0,0 +1,10 @@+fn sum(x) :=+ (+)|0 x;++fn map(f, x) :=+ f"x;++fn count (x) :=+ sum (map ([:1) x);++sum $1:i
+ examples/line.jac view
@@ -0,0 +1,1 @@+{|sprintf '%i: %s' (ix.`0)}
+ examples/mve.jac view
@@ -0,0 +1,8 @@+fn colmap(str) :=+ let val p := split str /.*\^/ in p end;++{. option 0 (->2) (match '---------^' /.*\^/)++let+ val col := {%/^[\t-]*\^/}{`0}+in col end
+ examples/path.jac view
@@ -0,0 +1,5 @@+{. echo $PATH | ja run examples/path.jac+fn path(x) :=+ ([x+'\n'+y])|'' (splitc x ':');++path"$0
+ examples/path2.jac view
@@ -0,0 +1,8 @@+{. echo $PATH | ja run examples/path.jac++@include'lib/string.jac'++fn path(x) :=+ intercalate '\n' (splitc x ':');++path"$0
+ examples/span.jac view
@@ -0,0 +1,9 @@+:set fs:=/\|/;++fn printSpan(str) :=+ let+ val p := match str /\^+/+ val str := option '(none)' (sprintf '%i-%i') p+ in str end;++printSpan"{% / *\^+/}{`2}
+ examples/span2.jac view
@@ -0,0 +1,9 @@+:set fs:=/\|/;++fn printSpan(str) :=+ let+ val p := match str /\^+/+ val str := (sprintf '%i-%i')"p+ in str end;++printSpan:?{% /\|/}{`2}
+ examples/sumLs.jac view
@@ -0,0 +1,2 @@+{. ls -l | ja ...+{ix>1}{`5:i}
+ examples/tags.jac view
@@ -0,0 +1,10 @@+fn mkEx(s) :=+ '/^' + s + '$/;';++fn processStr(s) :=+ let+ val line := split s /[ \(]+/+ val outLine := sprintf '%s\t%s\t%s' (line.2 . fp . mkEx s)+ in outLine end;++processStr"{%/fn +[[:lower:]][[:latin:]]*.*:=/}{`0}
jacinda.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: jacinda-version: 0.2.1.0+version: 0.3.0.0 license: AGPL-3 license-file: COPYING maintainer: vamchale@gmail.com@@ -18,7 +18,11 @@ man/ja.1 doc/guide.pdf test/examples/*.jac+ examples/*.jac++data-files: lib/*.jac+ prelude/*.jac source-repository head type: git@@ -48,8 +52,11 @@ Jacinda.Backend.Normalize Jacinda.Backend.TreeWalk Jacinda.Backend.Printf+ Jacinda.Include Data.List.Ext Data.Vector.Ext+ Paths_jacinda+ autogen-modules: Paths_jacinda default-language: Haskell2010 ghc-options: -Wall -O2@@ -58,15 +65,18 @@ bytestring >=0.11.0.0, text, prettyprinter >=1.7.0,- containers,+ containers >=0.6.0.1, array, mtl, transformers,- regex-rure,+ regex-rure >=0.1.2.0, microlens,+ directory,+ filepath, microlens-mtl, vector,- recursion >=1.0.0.0+ recursion >=1.0.0.0,+ split if !flag(cross) build-tool-depends: alex:alex, happy:happy@@ -124,6 +134,33 @@ tasty, tasty-hunit, bytestring++ if impl(ghc >=8.0)+ ghc-options:+ -Wincomplete-uni-patterns -Wincomplete-record-updates+ -Wredundant-constraints -Widentities++ if impl(ghc >=8.4)+ ghc-options: -Wmissing-export-lists++ if impl(ghc >=8.2)+ ghc-options: -Wcpp-undef++ 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+ build-depends:+ base,+ criterion,+ jacinda-lib,+ deepseq if impl(ghc >=8.0) ghc-options:
− lib/example.jac
@@ -1,10 +0,0 @@-fn sum(x) :=- (+)|0 x;--fn map(f, x) :=- f"x;--fn count (x) :=- sum (map ([:1) x);--sum $1:i
+ lib/maybe.jac view
@@ -0,0 +1,5 @@+fn isJust(x) :=+ option #f ([:#t) x;++fn isNothing(x) :=+ option #t ([:#f) x;
+ lib/string.jac view
@@ -0,0 +1,5 @@+fn intercalate(b, strs) :=+ [x+b+y]|'' strs;++fn replace(re, t, str) :=+ [x+t+y]|'' (split str re);
+ lib/tag.jac view
@@ -0,0 +1,2 @@+fn mkEx(s) :=+ '/^' + s + '$/;';
man/ja.1 view
@@ -1,4 +1,4 @@-.\" Automatically generated by Pandoc 2.17+.\" Automatically generated by Pandoc 2.17.0.1 .\" .TH "ja (1)" "" "" "" "" .hy@@ -9,11 +9,11 @@ .PP ja run src.jac -i data.txt .PP-cat FILE1 FILE2 | ja `#\[lq]$0'+cat FILE1 FILE2 | ja \[aq]#\[lq]$0\[cq] .PP ja tc script.jac .PP-ja e `11.67*1.2'+ja e \[aq]11.67*1.2\[cq] .SH DESCRIPTION .PP \f[B]Jacinda\f[R] is a data stream processing language \[`a] la AWK.@@ -31,6 +31,9 @@ .TP \f[B]-V\f[R] \f[B]--version\f[R] Display version information+.TP+\f[B]-I\f[R] \f[B]--include\f[R]+Include directory for imports .SH LANGUAGE .SS REGEX .PP@@ -62,10 +65,13 @@ a -> b -> a .TP \f[B]#.\f[R] Binary operator: filter-(a -> Bool) -> Stream a -> Stream a+Witherable f :=> (a -> Bool) -> f a -> f a .TP \f[B]\[rs].\f[R] Binary operator: prior (a -> a -> a) -> Stream a -> Stream a+.TP+\f[B]\[ti].\f[R] Unary deduplication (stream)+Eq a :=> Stream a -> Stream a .PP \f[B]max\f[R] Maximum of two values .PP@@ -107,8 +113,16 @@ \f[B]match\f[R] Str -> Regex -> Option (Int . Int)+.TP+\f[B]:?\f[R] mapMaybe+Witherable f :=> (a -> Option b) -> f a -> f b+.TP+\f[B].?\f[R] catMaybes+Witherable f :=> f (Option a) -> f a .PP \f[B]fp\f[R] Filename+.PP+\f[B]nf\f[R] Number of fields .SS SYNTAX .PP \f[B]\[ga]n\f[R] nth field@@ -133,13 +147,12 @@ \f[B]->n\f[R] Get the nth element of a tuple .PP \f[B]{.\f[R] Line comment+.PP+\f[B]\[at]include\[aq]/path/file.jac\[cq]\f[R] File include .SH BUGS .PP Please report any bugs you may come across to https://github.com/vmchale/jacinda/issues-.SS Limitations-.PP-Note that \f[C]Option\f[R] is not implemented as a functor. .SH COPYRIGHT .PP Copyright 2021-2022.
+ prelude/fn.jac view
@@ -0,0 +1,26 @@+fn sum(x) :=+ (+)|0 x;++fn drop(n, str) :=+ let val l := #str+ in substr str n l end;++fn take(n, str) :=+ substr str 0 n;++{. rounds down on .5+fn round(x) := |. (x+0.5);++fn itostring() :=+ sprintf '%i';++fn any(p, xs) :=+ (||)|#f p"xs;++fn all(p, xs) :=+ (&)|#t p"xs;++fn id(x) := x;++fn fromMaybe(a, x) :=+ option a [x] x;
src/Jacinda/AST.hs view
@@ -31,9 +31,18 @@ import qualified Data.Vector as V import GHC.Generics (Generic) import Intern.Name-import Prettyprinter (Doc, Pretty (..), braces, brackets, encloseSep, flatAlt, group, parens, (<+>))+import Prettyprinter (Doc, Pretty (..), braces, brackets, concatWith, encloseSep, flatAlt, group, hardline, indent, parens, tupled, (<+>)) import Regex.Rure (RurePtr) +infixr 6 <#>+infixr 6 <##>++(<#>) :: Doc a -> Doc a -> Doc a+(<#>) x y = x <> hardline <> y++(<##>) :: Doc a -> Doc a -> Doc a+(<##>) x y = x <> hardline <> hardline <> y+ -- kind data K = Star | KArr K K@@ -47,6 +56,7 @@ | TyVec | TyBool | TyOption+ | TyUnit -- TODO: tyRegex -- TODO: convert float to int deriving (Eq, Ord)@@ -80,6 +90,7 @@ pretty TyDate = "Date" pretty TyVec = "List" pretty TyOption = "Optional"+ pretty TyUnit = "𝟙" instance Pretty (T a) where pretty (TyB _ b) = pretty b@@ -104,6 +115,8 @@ | Floor | Ceiling | Some+ | Dedup+ | CatMaybes deriving (Eq) instance Pretty BUn where@@ -118,6 +131,8 @@ pretty Ceiling = "ceil" pretty Parse = ":" pretty Some = "Some"+ pretty Dedup = "~."+ pretty CatMaybes = ".?" -- ternary data BTer = ZipW@@ -125,14 +140,16 @@ | Scan | Substr | Option+ | Captures deriving (Eq) instance Pretty BTer where- pretty ZipW = ","- pretty Fold = "|"- pretty Scan = "^"- pretty Substr = "substr"- pretty Option = "option"+ pretty ZipW = ","+ pretty Fold = "|"+ pretty Scan = "^"+ pretty Substr = "substr"+ pretty Option = "option"+ pretty Captures = "~*" -- builtin data BBin = Plus@@ -158,6 +175,7 @@ | Filter | Sprintf | Match+ | MapMaybe -- TODO: floor functions, sqrt, sin, cos, exp. (power) deriving (Eq) @@ -185,6 +203,7 @@ pretty Splitc = "splitc" pretty Sprintf = "sprintf" pretty Match = "match"+ pretty MapMaybe = ":?" data DfnVar = X | Y deriving (Eq) @@ -194,6 +213,7 @@ -- 0-ary data N = Ix+ | Nf | None | Fp deriving (Eq)@@ -227,6 +247,7 @@ | ResVar { eLoc :: a, dfnVar :: DfnVar } | RegexCompiled RurePtr -- holds compiled regex (after normalization) | Arr { eLoc :: a, elems :: V.Vector (E a) }+ | Anchor { eLoc :: a, eAnchored :: [E a] } | Paren { eLoc :: a, eExpr :: E a } | OptionVal { eLoc :: a, eMaybe :: Maybe (E a) } -- TODO: regex literal@@ -263,6 +284,7 @@ | ResVarF a DfnVar | RegexCompiledF RurePtr | ArrF a (V.Vector x)+ | AnchorF a [x] | ParenF a x | OptionValF a (Maybe x) deriving (Generic, Functor, Foldable, Traversable)@@ -271,60 +293,63 @@ instance Pretty N where pretty Ix = "ix"+ pretty Nf = "nf" pretty None = "None" 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 _ (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 (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 _ 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" instance Show (E a) where show = show . pretty@@ -370,6 +395,7 @@ | Foldable | IsPrintf | HasField Int (T K)+ | Witherable -- TODO: witherable deriving (Eq, Ord) @@ -383,6 +409,7 @@ pretty Foldable = "Foldable" pretty IsPrintf = "Printf" pretty (HasField i ty) = "HasField" <+> pretty i <+> "~" <+> pretty ty+ pretty Witherable = "Witherable" instance Show C where show = show . pretty@@ -392,8 +419,18 @@ | FunDecl (Name a) [Name a] (E a) deriving (Functor) +instance Pretty (D a) where+ pretty (SetFS bs) = ":set" <+> "/" <> pretty (decodeUtf8 bs) <> "/"+ pretty (FunDecl n ns e) = "fn" <+> pretty n <> tupled (pretty <$> ns) <+> ":=" <#> indent 2 (pretty e <> ";")+ -- TODO: fun decls (type decls) data Program a = Program { decls :: [D a], expr :: E a } deriving (Functor)++instance Pretty (Program a) where+ pretty (Program ds e) = concatWith (<##>) (pretty <$> ds) <##> pretty e++instance Show (Program a) where+ show = show . pretty getFS :: Program a -> Maybe BS.ByteString getFS (Program ds _) = listToMaybe (concatMap go ds) where
src/Jacinda/Backend/Normalize.hs view
@@ -14,10 +14,14 @@ , parseAsF , the , asTup+ -- * Monad+ , runEvalM+ , eNorm ) where -import Control.Monad.State.Strict (State, evalState, gets, modify)+import Control.Monad.State.Strict (State, evalState, gets, modify, runState) import Control.Recursion (cata, embed)+import Data.Bifunctor (second) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as ASCII import Data.Foldable (traverse_)@@ -104,17 +108,24 @@ mkLetCtx :: Int -> LetCtx mkLetCtx i = LetCtx IM.empty (Renames i IM.empty) +hoistEvalM :: Int -> EvalM a -> (a, Int)+hoistEvalM i = second (max_ . renames_) . flip runState (mkLetCtx i)++runEvalM :: Int+ -> EvalM a+ -> a+runEvalM i = flip evalState (mkLetCtx i)+ eClosed :: Int -> E (T K) -> E (T K)-eClosed i = flip evalState (mkLetCtx i) . eNorm+eClosed i = runEvalM i . eNorm closedProgram :: Int -> Program (T K) -> E (T K)-closedProgram i (Program ds e) = flip evalState (mkLetCtx i) $- traverse_ processDecl ds *>- eNorm e+closedProgram i (Program ds e) = runEvalM i $+ traverse_ processDecl ds *> eNorm e processDecl :: D (T K) -> EvalM ()@@ -127,6 +138,7 @@ asTup Nothing = OptionVal undefined Nothing asTup (Just (RureMatch s e)) = OptionVal undefined (Just $ Tup undefined (mkI . fromIntegral <$> [s, e])) +-- don't need to rename op because it's being used in a map, can't affect etc. applyUn :: E (T K) -> E (T K) -> EvalM (E (T K))@@ -139,7 +151,8 @@ -> E (T K) -> E (T K) -> EvalM (E (T K))-applyOp op e e' = eNorm (EApp undefined (EApp undefined op e) e') -- TODO: undefined??+applyOp op@BBuiltin{} e e' = eNorm (EApp undefined (EApp undefined op e) e') -- short-circuit if not a lambda, don't need rename+applyOp op e e' = do { op' <- renameE op ; eNorm (EApp undefined (EApp undefined op' e) e') } foldE :: E (T K) -> E (T K)@@ -169,6 +182,7 @@ eNorm e@BBuiltin{} = pure e eNorm e@TBuiltin{} = pure e eNorm (Tup tys es) = Tup tys <$> traverse eNorm es+eNorm (Anchor ty es) = Anchor ty <$> traverse eNorm es 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@@ -195,7 +209,7 @@ eI <- eNorm e eI' <- eNorm e' pure $ case (eI, eI') of- (StrLit _ s, StrLit _ s') -> StrLit tyStr (s <> s')+ (StrLit _ s, StrLit _ s') -> StrLit tyStr (s <> s') -- TODO: copy? (RegexLit _ rr, RegexLit _ rr') -> RegexLit tyStr (rr <> rr') _ -> EApp ty (EApp ty' op eI) eI' eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyInteger) _) Max) e) e') = do@@ -383,6 +397,7 @@ _ -> EApp ty0 (EApp ty1 op eI) eI' eNorm (EApp _ (EApp _ (UBuiltin _ Const) e) _) = eNorm e eNorm (EApp ty op@(UBuiltin _ Const) e) = EApp ty op <$> eNorm e+eNorm (EApp ty op@(UBuiltin _ Dedup) e) = EApp ty op <$> eNorm e eNorm (EApp ty op@(UBuiltin _ (At i)) e) = do eI <- eNorm e pure $ case eI of@@ -418,9 +433,11 @@ pure $ case eI of (StrLit _ str) -> parseAsEInt str _ -> EApp ty op eI-eNorm (EApp ty op@(UBuiltin _ Some) e) = do+eNorm (EApp ty (UBuiltin _ Some) e) = do eI <- eNorm e pure $ OptionVal ty (Just eI)+-- catMaybes only works for streams atm+eNorm (EApp ty op@(UBuiltin _ CatMaybes) e) = EApp ty op <$> eNorm e eNorm Dfn{} = desugar eNorm ResVar{} = desugar eNorm (Let _ (Name _ (Unique i) _, b) e) = do@@ -445,6 +462,13 @@ pure $ case (e0', e1', e2') of (StrLit _ str, IntLit _ i, IntLit _ j) -> mkStr (substr str (fromIntegral i) (fromIntegral j)) _ -> EApp ty0 (EApp ty1 (EApp ty2 (TBuiltin ty3 Substr) e0') e1') e2'+eNorm (EApp ty0 (EApp ty1 (EApp ty2 op@(TBuiltin _ Captures) 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) -> 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 _ Option) e0) e1) e2) = do e0' <- eNorm e0 e1' <- eNorm e1@@ -471,6 +495,12 @@ case y' of Arr _ es -> Arr undefined <$> traverse (applyUn x') es -- TODO: undefined? _ -> pure $ EApp ty0 (EApp ty1 op x') y'+eNorm (EApp ty0 (EApp ty1 op@(BBuiltin (TyArr _ _ (TyArr _ _ (TyApp _ (TyB _ TyOption) _))) Map) x) y) = do+ x' <- eNorm x+ y' <- eNorm y+ 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 (EApp ty2 op@(TBuiltin (TyArr _ _ (TyArr _ _ (TyArr _ (TyApp _ (TyB _ TyVec) _) _))) Fold) f) x) y) = do f' <- eNorm f x' <- eNorm x@@ -493,6 +523,7 @@ -- _ -> 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
src/Jacinda/Backend/TreeWalk.hs view
@@ -7,9 +7,11 @@ import Control.Exception (Exception, throw) import Control.Recursion (cata, embed) import qualified Data.ByteString as BS+import Data.Containers.ListUtils (nubIntOn, nubOrdOn) import Data.Foldable (foldl', traverse_)-import Data.List (scanl')+import Data.List (scanl', transpose) import Data.List.Ext+import Data.Maybe (mapMaybe) import Data.Semigroup ((<>)) import qualified Data.Vector as V import Jacinda.AST@@ -65,6 +67,15 @@ asArr (Arr _ es) = es asArr _ = noRes +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+ -- TODO: do I want to interleave state w/ eNorm or w/e withFp :: FileBS -> E (T K) -> E (T K)@@ -86,6 +97,7 @@ go op@BBuiltin{} = op go op@UBuiltin{} = op go op@TBuiltin{} = op+ go (NBuiltin _ Nf) = mkI (fromIntegral $ V.length ctx) go (EApp ty op@BBuiltin{} e) = EApp ty op (go e) go (NBuiltin _ Ix) = mkI (fromIntegral ix) go (NBuiltin _ Fp) = mkStr fp@@ -121,6 +133,11 @@ let eI = asRegex (go e) eI' = asStr (go e') in asTup (find' eI eI')+ go (EApp _ (EApp _ (EApp _ (TBuiltin _ Captures) e0) e1) e2) =+ let e0' = asStr (go e0)+ e1' = asInt (go e1)+ e2' = asRegex (go e2)+ in OptionVal (tyOpt tyStr) (mkStr <$> findCapture e2' e0' (fromIntegral e1')) go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyInteger) _) Plus) e) e') = let eI = asInt (go e) eI' = asInt (go e')@@ -136,6 +153,7 @@ go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyStr) _) Plus) e) e') = let eI = asStr (go e) eI' = asStr (go e')+ -- TODO: copy?? in mkStr (eI <> eI') go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyStr) _) Eq) e) e') = let eI = asStr (go e)@@ -267,6 +285,12 @@ in Arr undefined (applyUn' x' <$> y') where applyUn' :: E (T K) -> E (T K) -> E (T K) applyUn' e e' = go (EApp undefined e e')+ go (EApp _ (EApp _ (BBuiltin (TyArr _ _ (TyArr _ _ (TyApp _ (TyB _ TyOption) _))) Map) x) y) =+ let x' = go x+ y' = asOpt (go y)+ in OptionVal undefined (applyUn' x' <$> y')+ where applyUn' :: E (T K) -> E (T K) -> E (T K)+ applyUn' e e' = go (EApp undefined e e') go (EApp _ (EApp _ (EApp _ (TBuiltin (TyArr _ _ (TyArr _ _ (TyArr _ (TyApp _ (TyB _ TyVec) _) _))) Fold) f) seed) xs) = let f' = go f seed' = go seed@@ -280,7 +304,7 @@ -> E (T K) -> E (T K) -> E (T K)-applyOp op e e' = eClosed undefined (EApp undefined (EApp undefined op e) e') -- FIXME: undefined is ??+applyOp op e e' = eClosed reprehensible (EApp undefined (EApp undefined op e) e') -- FIXME: undefined is ?? atField :: RurePtr -> Int@@ -296,7 +320,7 @@ -> E (T K) applyUn unOp e = case eLoc unOp of- TyArr _ _ res -> eClosed undefined (EApp res unOp e)+ TyArr _ _ res -> eClosed reprehensible (EApp res unOp e) _ -> error "Internal error?" -- | Turn an expression representing a stream into a stream of expressions (using line as context)@@ -322,6 +346,11 @@ ir fp re (EApp _ (EApp _ (BBuiltin _ Filter) op) stream) = let op' = compileR (withFp fp op) in filter (asBool . applyUn op') . ir fp re stream+ir fp re (EApp _ (EApp _ (BBuiltin _ MapMaybe) op) stream) =+ let op' = compileR (withFp fp op)+ in mapMaybe (asOpt . applyUn op') . ir fp re stream+ir fp re (EApp _ (UBuiltin _ CatMaybes) stream) =+ mapMaybe asOpt . ir fp re stream ir fp re (EApp _ (EApp _ (BBuiltin _ Prior) op) stream) = prior (applyOp (withFp fp op)) . ir fp re stream ir fp re (EApp _ (EApp _ (EApp _ (TBuiltin _ ZipW) op) streaml) streamr) = \lineStream -> let@@ -330,6 +359,14 @@ in zipWith (applyOp (withFp fp op)) irl irr ir fp re (EApp _ (EApp _ (EApp _ (TBuiltin _ Scan) op) seed) xs) = scanl' (applyOp (withFp fp op)) seed . ir fp re xs+ir fp re (EApp _ (UBuiltin (TyArr _ (TyApp _ _ (TyB _ TyStr)) _) Dedup) e) =+ nubOrdOn asStr . ir fp re e+ir fp re (EApp _ (UBuiltin (TyArr _ (TyApp _ _ (TyB _ TyInteger)) _) Dedup) e) =+ nubIntOn (fromIntegral . asInt) . ir fp re e+ir fp re (EApp _ (UBuiltin (TyArr _ (TyApp _ _ (TyB _ TyFloat)) _) Dedup) e) =+ nubIntOn (fromEnum . asFloat) . ir fp re e+ir fp re (EApp _ (UBuiltin (TyArr _ (TyApp _ _ (TyB _ TyBool)) _) Dedup) e) =+ nubIntOn (fromEnum . asBool) . ir fp re e -- | Output stream that prints each entry (expression) printStream :: [E (T K)] -> IO ()@@ -355,18 +392,21 @@ 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 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-eWith _ _ e@TBuiltin{} = const e-eWith _ _ e@StrLit{} = const e-eWith _ _ e@FloatLit{} = const e-eWith _ _ e@IntLit{} = const e-eWith _ _ e@BoolLit{} = const e+eWith _ _ e@BBuiltin{} = const e+eWith _ _ e@UBuiltin{} = const e+eWith _ _ e@TBuiltin{} = const e+eWith _ _ e@StrLit{} = const e+eWith _ _ e@FloatLit{} = const e+eWith _ _ e@IntLit{} = const e+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) -- TODO: rewrite tuple-of-folds as fold-of-tuples ... "compile" to E (T K) -> E (T K) -- OR "compile" to [(Int, E (T K)] -> ... +takeConcatMap :: (a -> [b]) -> [a] -> [b]+takeConcatMap f = concat . transpose . fmap f+ -- | Given an expression, turn it into a function which will process the file. fileProcessor :: FileBS -> RurePtr@@ -383,20 +423,29 @@ printStream $ fmap (parseAsEInt . atField re i) inp fileProcessor _ re (FParseCol _ i) = Right $ \inp -> do printStream $ fmap (parseAsF . atField re i) inp-fileProcessor fp re e@Guarded{} = Right $ \inp -> do+fileProcessor fp re e@Guarded{} = Right $ \inp -> printStream $ ir fp re e inp-fileProcessor fp re e@Implicit{} = Right $ \inp -> do+fileProcessor fp re e@Implicit{} = Right $ \inp -> printStream $ ir fp re e inp-fileProcessor fp re e@(EApp _ (EApp _ (BBuiltin _ Filter) _) _) = Right $ \inp -> do+fileProcessor fp re e@(EApp _ (EApp _ (BBuiltin _ Filter) _) _) = Right $ \inp -> printStream $ ir fp re e inp-fileProcessor fp re e@(EApp _ (EApp _ (BBuiltin (TyArr _ _ (TyArr _ _ (TyApp _ (TyB _ TyStream) _))) Map) _) _) = Right $ \inp -> do+-- at the moment, catMaybes only works on streams+fileProcessor fp re e@(EApp _ (UBuiltin _ CatMaybes) _) = Right $ \inp -> printStream $ ir fp re e inp-fileProcessor fp re e@(EApp _ (EApp _ (BBuiltin _ Prior) _) _) = Right $ \inp -> do+fileProcessor fp re e@(EApp _ (EApp _ (BBuiltin (TyArr _ _ (TyArr _ _ (TyApp _ (TyB _ TyStream) _))) Map) _) _) = Right $ \inp -> printStream $ ir fp re e inp-fileProcessor fp re e@(EApp _ (EApp _ (EApp _ (TBuiltin _ Scan) _) _) _) = Right $ \inp -> do+fileProcessor fp re e@(EApp _ (EApp _ (BBuiltin (TyArr _ _ (TyArr _ _ (TyApp _ (TyB _ TyStream) _))) MapMaybe) _) _) = Right $ \inp -> printStream $ ir fp re e inp-fileProcessor fp re e@(EApp _ (EApp _ (EApp _ (TBuiltin _ ZipW) _) _) _) = Right $ \inp -> do+fileProcessor fp re e@(EApp _ (EApp _ (BBuiltin _ Prior) _) _) = Right $ \inp -> printStream $ ir fp re e inp+fileProcessor fp re e@(EApp _ (EApp _ (EApp _ (TBuiltin _ Scan) _) _) _) = Right $ \inp ->+ printStream $ ir fp re e inp+fileProcessor fp re e@(EApp _ (EApp _ (EApp _ (TBuiltin _ ZipW) _) _) _) = Right $ \inp ->+ printStream $ ir fp re e inp+fileProcessor fp re e@(EApp _ (UBuiltin _ Dedup) _) = Right $ \inp ->+ printStream $ ir fp re e inp+fileProcessor fp re (Anchor _ es) = Right $ \inp ->+ printStream $ takeConcatMap (\e -> ir fp re e inp) es fileProcessor _ _ Var{} = error "Internal error?" fileProcessor _ _ e@IntLit{} = Right $ const (print e) fileProcessor _ _ e@BoolLit{} = Right $ const (print e)
src/Jacinda/File.hs view
@@ -1,5 +1,4 @@-module Jacinda.File ( tyCheck- , tcIO+module Jacinda.File ( tcIO , tySrc , runOnHandle , runOnFile@@ -9,15 +8,19 @@ 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 Data.Bifunctor (second) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as ASCII import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as ASCIIL-import Data.Functor (void)+import Data.Functor (void, ($>))+import Data.Tuple (swap) import Jacinda.AST import Jacinda.Backend.Normalize import Jacinda.Backend.TreeWalk+import Jacinda.Include import Jacinda.Lexer import Jacinda.Parser import Jacinda.Parser.Rewrite@@ -27,9 +30,33 @@ import Regex.Rure (RurePtr) import System.IO (Handle) +parseLib :: [FilePath] -> FilePath -> StateT AlexUserState IO [D AlexPosn]+parseLib incls fp = do+ contents <- liftIO $ BSL.readFile =<< resolveImport incls fp+ st <- get+ 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) }++parseE :: [FilePath] -> BSL.ByteString -> StateT AlexUserState IO (Program AlexPosn)+parseE incls bs = do+ st <- get+ case parseWithCtx bs st of+ Left err -> liftIO $ throwIO err+ Right (st', (is, Program ds e)) -> do+ put st'+ dss <- traverse (parseLib incls) is+ pure $ Program (concat dss ++ fmap rewriteD ds) (rewriteE e)++-- | Parse + rename (decls)+parseEWithMax :: [FilePath] -> BSL.ByteString -> IO (Program AlexPosn, Int)+parseEWithMax incls bsl = uncurry renamePGlobal . swap . second fst3 <$> runStateT (parseE incls bsl) alexInitUserState+ where fst3 (x, _, _) = x+ -- | Parse + rename (globally) parseWithMax' :: BSL.ByteString -> Either (ParseError AlexPosn) (Program AlexPosn, Int)-parseWithMax' = fmap (uncurry renamePGlobal . second rewriteProgram) . parseWithMax+parseWithMax' = fmap (uncurry renamePGlobal . second (rewriteProgram . snd)) . parseWithMax exprEval :: BSL.ByteString -> E (T K) exprEval src =@@ -43,41 +70,39 @@ compileFS (Just bs) = compileDefault bs compileFS Nothing = defaultRurePtr -runOnBytes :: FilePath+runOnBytes :: [FilePath]+ -> FilePath -- ^ Data file name, for @nf@ -> BSL.ByteString -- ^ Program -> Maybe BS.ByteString -- ^ Field separator -> BSL.ByteString -> IO ()-runOnBytes fp src cliFS contents =- case parseWithMax' src of- Left err -> throwIO err- Right (ast, m) -> do- (typed, i) <- yeetIO $ runTypeM m (tyProgram ast)- cont <- yeetIO $ runJac (ASCII.pack fp) (compileFS (cliFS <|> getFS ast)) i typed- cont $ fmap BSL.toStrict (ASCIIL.lines contents)- -- see: BSL.split, BSL.splitWith+runOnBytes incls fp src cliFS contents = do+ incls' <- defaultIncludes <*> pure incls+ (ast, m) <- parseEWithMax incls' src+ (typed, i) <- yeetIO $ runTypeM m (tyProgram ast)+ cont <- yeetIO $ runJac (ASCII.pack fp) (compileFS (cliFS <|> getFS ast)) i typed+ cont $ fmap BSL.toStrict (ASCIIL.lines contents)+ -- see: BSL.split, BSL.splitWith -runOnHandle :: BSL.ByteString -- ^ Program+runOnHandle :: [FilePath]+ -> BSL.ByteString -- ^ Program -> Maybe BS.ByteString -- ^ Field separator -> Handle -> IO ()-runOnHandle src cliFS = runOnBytes "(runOnBytes)" src cliFS <=< BSL.hGetContents+runOnHandle is src cliFS = runOnBytes is "(runOnBytes)" src cliFS <=< BSL.hGetContents -runOnFile :: BSL.ByteString+runOnFile :: [FilePath]+ -> BSL.ByteString -> Maybe BS.ByteString -> FilePath -> IO ()-runOnFile e fs fp = runOnBytes fp e fs =<< BSL.readFile fp--tcIO :: BSL.ByteString -> IO ()-tcIO = yeetIO . tyCheck+runOnFile is e fs fp = runOnBytes is fp e fs =<< BSL.readFile fp --- | Typecheck an expression-tyCheck :: BSL.ByteString -> Either (Error AlexPosn) ()-tyCheck src =- case parseWithMax' src of- Right (ast, m) -> void $ runTypeM m (tyProgram ast)- Left err -> throw err+tcIO :: [FilePath] -> BSL.ByteString -> IO ()+tcIO incls src = do+ incls' <- defaultIncludes <*> pure incls+ (ast, m) <- parseEWithMax incls' src+ yeetIO $ void $ runTypeM m (tyProgram ast) tySrc :: BSL.ByteString -> T K tySrc src =
+ src/Jacinda/Include.hs view
@@ -0,0 +1,36 @@+module Jacinda.Include ( defaultIncludes+ , resolveImport+ ) where++import Control.Exception (Exception, throwIO)+import Control.Monad (filterM)+import Data.List.Split (splitWhen)+import Data.Maybe (listToMaybe)+import Paths_jacinda (getDataDir)+import System.Directory (doesFileExist)+import System.Environment (lookupEnv)+import System.FilePath ((</>))++data ImportError = FileNotFound !FilePath ![FilePath] deriving (Show)++instance Exception ImportError where++defaultIncludes :: IO ([FilePath] -> [FilePath])+defaultIncludes = do+ path <- jacPath+ d <- getDataDir+ pure $ (d:) . (++path)++-- | Parsed @JAC_PATH@+jacPath :: IO [FilePath]+jacPath = maybe [] splitEnv <$> lookupEnv "JAC_PATH"++splitEnv :: String -> [FilePath]+splitEnv = splitWhen (== ':')++resolveImport :: [FilePath] -- ^ Places to look+ -> FilePath+ -> IO FilePath+resolveImport incl fp =+ maybe (throwIO $ FileNotFound fp incl) pure . listToMaybe+ =<< (filterM doesFileExist . fmap (</> fp) $ incl)
src/Jacinda/Lexer.x view
@@ -95,6 +95,7 @@ "||" { mkSym OrTok } "(" { mkSym LParen } ")" { mkSym RParen }+ "&(" { mkSym LAnchor } "{%" { mkSym LBracePercent } "{|" { mkSym LBraceBar } "]" { mkSym RSqBracket `andBegin` 0 }@@ -111,6 +112,10 @@ \\ { mkSym Backslash } "|`" { mkSym CeilSym } "|." { mkSym FloorSym }+ "~." { mkSym DedupTok }+ ".?" { mkSym CatMaybesTok }+ ":?" { mkSym MapMaybeTok }+ "~*" { mkSym CapTok } in { mkKw KwIn } let { mkKw KwLet }@@ -118,9 +123,11 @@ end { mkKw KwEnd } :set { mkKw KwSet } fn { mkKw KwFn }+ "@include" { mkKw KwInclude } fs { mkRes VarFs } ix { mkRes VarIx }+ nf { mkRes VarNf } -- TODO: does this uncover an alex bug? -- ⍳ { mkRes VarIx } -- ¨ { mkSym Quot }@@ -236,6 +243,7 @@ | LBrace | RBrace | LParen+ | LAnchor | RParen | LSqBracket | RSqBracket@@ -264,6 +272,10 @@ | FilterTok | FloorSym | CeilSym+ | DedupTok+ | CatMaybesTok+ | MapMaybeTok+ | CapTok instance Pretty Sym where pretty PlusTok = "+"@@ -287,6 +299,7 @@ pretty OrTok = "||" pretty LParen = "(" pretty RParen = ")"+ pretty LAnchor = "&(" pretty LSqBracket = "[" pretty RSqBracket = "]" pretty Tilde = "~"@@ -305,6 +318,10 @@ pretty FilterTok = "#." pretty FloorSym = "|." pretty CeilSym = "|`"+ pretty DedupTok = "~."+ pretty CatMaybesTok = ".?"+ pretty MapMaybeTok = ":?"+ pretty CapTok = "~*" data Keyword = KwLet | KwIn@@ -312,6 +329,7 @@ | KwEnd | KwSet | KwFn+ | KwInclude -- | Reserved/special variables data Var = VarX@@ -320,23 +338,26 @@ | VarIx | VarMin | VarMax+ | VarNf instance Pretty Var where pretty VarX = "x" pretty VarY = "y" pretty VarFs = "fs" pretty VarIx = "ix"+ pretty VarNf = "nf" pretty VarMin = "min" pretty VarMax = "max" -- TODO: exp, log, sqrt, floor ... instance Pretty Keyword where- pretty KwLet = "let"- pretty KwIn = "in"- pretty KwVal = "val"- pretty KwEnd = "end"- pretty KwSet = ":set"- pretty KwFn = "fn"+ pretty KwLet = "let"+ pretty KwIn = "in"+ pretty KwVal = "val"+ pretty KwEnd = "end"+ pretty KwSet = ":set"+ pretty KwFn = "fn"+ pretty KwInclude = "@include" data Builtin = BuiltinIParse | BuiltinFParse
src/Jacinda/Parser.y view
@@ -2,9 +2,13 @@ {-# LANGUAGE OverloadedStrings #-} module Jacinda.Parser ( parse , parseWithMax- , parseWithCtx , parseWithInitCtx+ , parseWithCtx+ , parseLibWithCtx , ParseError (..)+ -- * Type synonyms+ , File+ , Library ) where import Control.Exception (Exception)@@ -12,6 +16,7 @@ import Control.Monad.Trans.Class (lift) import Data.Bifunctor (first) import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Char8 as ASCII import qualified Data.Text as T import Data.Typeable (Typeable) import qualified Intern.Name as Name@@ -22,7 +27,8 @@ } -%name parseP Program+%name parseF File+%name parseLib Library %tokentype { Token AlexPosn } %error { parseError } %monad { Parse } { (>>=) } { pure }@@ -37,6 +43,7 @@ lsqbracket { TokSym $$ LSqBracket } rsqbracket { TokSym $$ RSqBracket } lparen { TokSym $$ LParen }+ lanchor { TokSym $$ LAnchor } rparen { TokSym $$ RParen } semicolon { TokSym $$ Semicolon } backslash { TokSym $$ Backslash }@@ -54,6 +61,7 @@ select { $$@(TokSelect _ _) } floorSym { TokSym $$ FloorSym } ceilSym { TokSym $$ CeilSym }+ dedup { TokSym $$ DedupTok } plus { TokSym $$ PlusTok } minus { TokSym $$ MinusTok }@@ -64,6 +72,9 @@ fold { TokSym $$ FoldTok } caret { TokSym $$ Caret } quot { TokSym $$ Quot }+ mapMaybe { TokSym $$ MapMaybeTok }+ catMaybes { TokSym $$ CatMaybesTok }+ capture { TokSym $$ CapTok } eq { TokSym $$ EqTok } neq { TokSym $$ NeqTok }@@ -93,6 +104,7 @@ end { TokKeyword $$ KwEnd } set { TokKeyword $$ KwSet } fn { TokKeyword $$ KwFn }+ include { TokKeyword $$ KwInclude } x { TokResVar $$ VarX } y { TokResVar $$ VarY }@@ -100,6 +112,7 @@ min { TokResVar $$ VarMin } max { TokResVar $$ VarMax } ix { TokResVar $$ VarIx }+ nf { TokResVar $$ VarNf } fs { TokResVar $$ VarFs } split { TokBuiltin $$ BuiltinSplit }@@ -155,6 +168,7 @@ | eq { Eq } | neq { Neq } | quot { Map }+ | mapMaybe { MapMaybe } | tilde { Matches } | notMatch { NotMatches } | and { And }@@ -174,6 +188,15 @@ : set fs defEq rr semicolon { SetFS (BSL.toStrict $ rr $4) } | fn name Args defEq E semicolon { FunDecl $2 $3 $5 } +Include :: { FilePath }+ : include strLit { ASCII.unpack (strTok $2) }++File :: { ([FilePath], Program AlexPosn) }+ : many(Include) Program { (reverse $1, $2) }++Library :: { Library }+ : many(Include) many(D) { (reverse $1, reverse $2) }+ Program :: { Program AlexPosn } : many(D) E { Program (reverse $1) $2 } @@ -201,11 +224,15 @@ | y fParse { EApp $1 (UBuiltin $2 FParse) (ResVar $1 Y) } | column iParse { IParseCol (loc $1) (ix $1) } | column fParse { FParseCol (loc $1) (ix $1) }+ | parens(iParse) { UBuiltin $1 IParse }+ | parens(fParse) { UBuiltin $1 FParse }+ | parens(colon) { UBuiltin $1 Parse } | lparen BBin rparen { BBuiltin $1 $2 } | lparen E BBin rparen { EApp $1 (BBuiltin $1 $3) $2 } | lparen BBin E rparen {% do { n <- lift $ freshName "x" ; pure (Lam $1 n (EApp $1 (EApp $1 (BBuiltin $1 $2) (Var (Name.loc n) n)) $3)) } } | E BBin E { EApp (eLoc $1) (EApp (eLoc $3) (BBuiltin (eLoc $1) $2) $1) $3 } | E fold E E { EApp (eLoc $1) (EApp (eLoc $1) (EApp $2 (TBuiltin $2 Fold) $1) $3) $4 }+ | E capture E E { EApp (eLoc $1) (EApp (eLoc $1) (EApp $2 (TBuiltin $2 Captures) $1) $3) $4 } | E caret E E { EApp (eLoc $1) (EApp (eLoc $1) (EApp $2 (TBuiltin $2 Scan) $1) $3) $4 } | comma E E E { EApp $1 (EApp $1 (EApp $1 (TBuiltin $1 ZipW) $2) $3) $4 } | lbrace E rbrace braces(E) { Guarded $1 $2 $4 }@@ -213,6 +240,7 @@ | lbraceBar E rbrace { Implicit $1 $2 } | let many(Bind) in E end { mkLet $1 (reverse $2) $4 } | 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 } | tally { UBuiltin $1 Tally } | const { UBuiltin $1 Const }@@ -233,8 +261,11 @@ | ceil { UBuiltin $1 Ceiling } | floorSym { UBuiltin $1 Floor } | ceilSym { UBuiltin $1 Ceiling }+ | dedup { UBuiltin $1 Dedup } | some { UBuiltin $1 Some }+ | catMaybes { UBuiltin $1 CatMaybes } | ix { NBuiltin $1 Ix }+ | nf { NBuiltin $1 Nf } | none { NBuiltin $1 None } | fp { NBuiltin $1 Fp } | parens(at) { UBuiltin (loc $1) (At $ ix $1) }@@ -246,6 +277,10 @@ { +type File = ([FilePath], Program AlexPosn)++type Library = ([FilePath], [D AlexPosn])+ parseError :: Token AlexPosn -> Parse a parseError = throwError . Unexpected @@ -269,18 +304,21 @@ type Parse = ExceptT (ParseError AlexPosn) Alex -parse :: BSL.ByteString -> Either (ParseError AlexPosn) (Program AlexPosn)-parse = fmap snd . runParse parseP+parse :: BSL.ByteString -> Either (ParseError AlexPosn) File+parse = fmap snd . runParse parseF -parseWithMax :: BSL.ByteString -> Either (ParseError AlexPosn) (Int, Program AlexPosn)+parseWithMax :: BSL.ByteString -> Either (ParseError AlexPosn) (Int, File) parseWithMax = fmap (first fst3) . parseWithInitCtx where fst3 (x, _, _) = x -parseWithInitCtx :: BSL.ByteString -> Either (ParseError AlexPosn) (AlexUserState, Program AlexPosn)+parseWithInitCtx :: BSL.ByteString -> Either (ParseError AlexPosn) (AlexUserState, File) parseWithInitCtx bsl = parseWithCtx bsl alexInitUserState -parseWithCtx :: BSL.ByteString -> AlexUserState -> Either (ParseError AlexPosn) (AlexUserState, Program AlexPosn)-parseWithCtx = parseWithInitSt parseP+parseWithCtx :: BSL.ByteString -> AlexUserState -> Either (ParseError AlexPosn) (AlexUserState, File)+parseWithCtx = parseWithInitSt parseF++parseLibWithCtx :: BSL.ByteString -> AlexUserState -> Either (ParseError AlexPosn) (AlexUserState, Library)+parseLibWithCtx = parseWithInitSt parseLib runParse :: Parse a -> BSL.ByteString -> Either (ParseError AlexPosn) (AlexUserState, a) runParse parser str = liftErr $ runAlexSt str (runExceptT parser)
src/Jacinda/Parser/Rewrite.hs view
@@ -1,6 +1,9 @@ module Jacinda.Parser.Rewrite ( rewriteProgram+ , rewriteD+ , rewriteE ) where + import Control.Recursion (cata, embed) import Jacinda.AST @@ -31,6 +34,7 @@ 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@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 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
src/Jacinda/Regex.hs view
@@ -8,6 +8,7 @@ , find' , compileDefault , substr+ , findCapture ) where import Control.Exception (Exception, throwIO)@@ -15,16 +16,15 @@ import qualified Data.ByteString.Internal as BS import Data.Semigroup ((<>)) import qualified Data.Vector as V+import Foreign.C.Types (CSize) import Foreign.ForeignPtr (plusForeignPtr)-import Regex.Rure (RureMatch (..), RurePtr, compile, find, isMatch, matches, mkIter, rureDefaultFlags, rureFlagDotNL)+import Regex.Rure (RureMatch (..), RurePtr, captures, compile, find, findCaptures, isMatch, matches', rureDefaultFlags, rureFlagDotNL) import System.IO.Unsafe (unsafeDupablePerformIO, unsafePerformIO) -- see: https://docs.rs/regex/latest/regex/#perl-character-classes-unicode-friendly defaultFs :: BS.ByteString defaultFs = "\\s+" --- also ls -l | ja '{ix>1}{`5:i}'- {-# NOINLINE defaultRurePtr #-} defaultRurePtr :: RurePtr defaultRurePtr = unsafePerformIO $ yeetRureIO =<< compile genFlags defaultFs@@ -37,6 +37,14 @@ substr (BS.BS fp l) begin endϵ | endϵ >= begin = BS.BS (fp `plusForeignPtr` begin) (min l endϵ - begin) | otherwise = "error: invalid substring indices." +{-# 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+ where go (RureMatch s e) =+ let e' = fromIntegral e+ s' = fromIntegral s+ in BS.BS (fp `plusForeignPtr` s') (e'-s')+ {-# NOINLINE find' #-} find' :: RurePtr -> BS.ByteString -> Maybe RureMatch find' re str = unsafeDupablePerformIO $ find re str 0@@ -47,7 +55,7 @@ -> V.Vector BS.ByteString splitBy re haystack@(BS.BS fp l) = (\sp -> V.fromList [BS.BS (fp `plusForeignPtr` s) (e-s) | (s, e) <- sp]) slicePairs- where ixes = unsafeDupablePerformIO $ do { reIptr <- mkIter re; matches reIptr haystack }+ where ixes = unsafeDupablePerformIO $ matches' re haystack slicePairs = case ixes of (RureMatch 0 i:rms) -> mkMiddle (fromIntegral i) rms rms -> mkMiddle 0 rms
src/Jacinda/Rename.hs view
@@ -150,5 +150,6 @@ Let l (n', eϵ') <$> withRenames modR (renameE e') renameE (Paren _ e) = renameE e 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 e = pure e -- literals &c.
src/Jacinda/Ty.hs view
@@ -9,8 +9,9 @@ ) where import Control.Exception (Exception)+import Control.Monad (forM) import Control.Monad.Except (throwError)-import Control.Monad.State.Strict (StateT, gets, runStateT)+import Control.Monad.State.Strict (StateT, gets, modify, runStateT) import Data.Bifunctor (first, second) import Data.Foldable (traverse_) import Data.Functor (void, ($>))@@ -26,14 +27,7 @@ import Intern.Unique import Jacinda.AST import Jacinda.Ty.Const-import Lens.Micro (Lens')-import Lens.Micro.Mtl (modifying)-import Prettyprinter (Doc, Pretty (..), hardline, squotes, vsep, (<+>))--infixr 6 <#>--(<#>) :: Doc a -> Doc a -> Doc a-(<#>) x y = x <> hardline <> y+import Prettyprinter (Doc, Pretty (..), squotes, vsep, (<+>)) data Error a = UnificationFailed a (T ()) (T ()) | Doesn'tSatisfy a (T ()) C@@ -60,10 +54,6 @@ , constraints :: S.Set (a, T K, T K) } -instance Pretty (TyState a) where- pretty (TyState _ _ _ _ cs) =- "constraints:" <#> prettyConstraints cs- prettyConstraints :: S.Set (b, T a, T a) -> Doc ann prettyConstraints cs = vsep (prettyEq . go <$> S.toList cs) where go (_, x, y) = (x, y)@@ -71,17 +61,17 @@ prettyEq :: (T a, T a) -> Doc ann prettyEq (ty, ty') = pretty ty <+> "≡" <+> pretty ty' -maxULens :: Lens' (TyState a) Int-maxULens f s = fmap (\x -> s { maxU = x }) (f (maxU s))+mapMaxU :: (Int -> Int) -> TyState a -> TyState a+mapMaxU f (TyState u k c v cs) = TyState (f u) k c v cs -classVarsLens :: Lens' (TyState a) (IM.IntMap (S.Set (C, a)))-classVarsLens f s = fmap (\x -> s { classVars = x }) (f (classVars s))+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 -varEnvLens :: Lens' (TyState a) (IM.IntMap (T K))-varEnvLens f s = fmap (\x -> s { varEnv = x }) (f (varEnv s))+addVarEnv :: Int -> T K -> TyState a -> TyState a+addVarEnv i ty (TyState u k cvs v cs) = TyState u k cvs (IM.insert i ty v) cs -constraintsLens :: Lens' (TyState a) (S.Set (a, T K, T K))-constraintsLens f s = fmap (\x -> s { constraints = x }) (f (constraints s))+addConstraint :: Ord a => (a, T K, T K) -> TyState a -> TyState a+addConstraint c (TyState u k cvs v cs) = TyState u k cvs v (S.insert c cs) type TypeM a = StateT (TyState a) (Either (Error a)) @@ -165,7 +155,7 @@ freshName n k = do st <- gets maxU Name n (Unique $ st+1) k- <$ modifying maxULens (+1)+ <$ modify (mapMaxU (+1)) higherOrder :: T.Text -> TypeM a (Name K) higherOrder t = freshName t (KArr Star Star)@@ -189,7 +179,7 @@ -- assumes they have been renamed... pushConstraint :: Ord a => a -> T K -> T K -> TypeM a () pushConstraint l ty ty' =- modifying constraintsLens (S.insert (l, ty, ty'))+ modify (addConstraint (l, ty, ty')) -- TODO: this will need some class context if we permit custom types (Optional) checkType :: Ord a => T K -> (C, a) -> TypeM a ()@@ -217,6 +207,9 @@ checkType ty@TyArr{} (c, l) = throwError $ Doesn'tSatisfy l (void ty) c checkType (TyB _ TyVec) (Functor, _) = pure () checkType (TyB _ TyStream) (Functor, _) = pure ()+checkType (TyB _ TyOption) (Functor, _) = pure ()+checkType (TyB _ TyStream) (Witherable, _) = pure ()+checkType ty (c@Witherable, l) = throwError $ Doesn'tSatisfy l (void ty) c checkType ty (c@Functor, l) = throwError $ Doesn'tSatisfy l (void ty) c checkType (TyB _ TyVec) (Foldable, _) = pure () checkType (TyB _ TyStream) (Foldable, _) = pure ()@@ -262,7 +255,7 @@ tyD0 (FunDecl n@(Name _ (Unique i) _) [] e) = do e' <- tyE0 e let ty = eLoc e'- modifying varEnvLens (IM.insert i ty)+ modify (addVarEnv i ty) pure $ FunDecl (n $> ty) [] e' tyD0 FunDecl{} = error "Internal error. Should have been desugared by now." @@ -312,28 +305,28 @@ tyNumOp :: Ord a => a -> TypeM a (T K) tyNumOp l = do m <- dummyName "m"- modifying classVarsLens (addC m (IsNum, l))+ modify (mapClassVars (addC m (IsNum, l))) let m' = var m pure $ tyArr m' (tyArr m' m') tySemiOp :: Ord a => a -> TypeM a (T K) tySemiOp l = do m <- dummyName "m"- modifying classVarsLens (addC m (IsSemigroup, l))+ modify (mapClassVars (addC m (IsSemigroup, l))) let m' = var m pure $ tyArr m' (tyArr m' m') tyOrd :: Ord a => a -> TypeM a (T K) tyOrd l = do a <- dummyName "a"- modifying classVarsLens (addC a (IsOrd, l))+ modify (mapClassVars (addC a (IsOrd, l))) let a' = var a pure $ tyArr a' (tyArr a' tyBool) tyEq :: Ord a => a -> TypeM a (T K) tyEq l = do a <- dummyName "a"- modifying classVarsLens (addC a (IsEq, l))+ modify (mapClassVars (addC a (IsEq, l))) let a' = var a pure $ tyArr a' (tyArr a' tyBool) @@ -341,25 +334,19 @@ tyM :: Ord a => a -> TypeM a (T K) tyM l = do a <- dummyName "a"- modifying classVarsLens (addC a (IsOrd, l))+ modify (mapClassVars (addC a (IsOrd, l))) let a' = var a pure $ tyArr a' (tyArr a' a') desugar :: a desugar = error "Should have been de-sugared in an earlier stage!" -hkt :: T K -> T K -> T K-hkt = TyApp Star- tyVec :: T K tyVec = TyB (KArr Star Star) TyVec mkVec :: T K -> T K mkVec = hkt tyVec -tyOpt :: T K -> T K-tyOpt = hkt (TyB (KArr Star Star) TyOption)- tyE0 :: Ord a => E a -> TypeM a (E (T K)) tyE0 (BoolLit _ b) = pure $ BoolLit tyBool b tyE0 (IntLit _ i) = pure $ IntLit tyI i@@ -374,6 +361,7 @@ tyE0 AllColumn{} = pure $ AllColumn (tyStream tyStr) tyE0 (NBuiltin _ Ix) = pure $ NBuiltin tyI Ix tyE0 (NBuiltin _ Fp) = pure $ NBuiltin tyStr Fp+tyE0 (NBuiltin _ Nf) = pure $ NBuiltin tyI Nf tyE0 (BBuiltin l Plus) = BBuiltin <$> tySemiOp l <*> pure Plus tyE0 (BBuiltin l Minus) = BBuiltin <$> tyNumOp l <*> pure Minus tyE0 (BBuiltin l Times) = BBuiltin <$> tyNumOp l <*> pure Times@@ -410,12 +398,12 @@ tyE0 (UBuiltin l Parse) = do a <- dummyName "a" let a' = var a- modifying classVarsLens (addC a (IsParseable, l))+ modify (mapClassVars (addC a (IsParseable, l))) pure $ UBuiltin (tyArr tyStr a') Parse tyE0 (BBuiltin l Sprintf) = do a <- dummyName "a" let a' = var a- modifying classVarsLens (addC a (IsPrintf, l))+ modify (mapClassVars (addC a (IsPrintf, l))) pure $ BBuiltin (tyArr tyStr (tyArr a' tyStr)) Sprintf tyE0 (UBuiltin _ (At i)) = do a <- dummyName "a"@@ -427,8 +415,14 @@ b <- dummyName "b" let a' = var a b' = var b- modifying classVarsLens (addC a (HasField i b', l))+ modify (mapClassVars (addC a (HasField i b', l))) pure $ UBuiltin (tyArr a' b') (Select i)+tyE0 (UBuiltin l Dedup) = do+ a <- dummyName "a"+ let a' = var a+ fTy = tyArr (tyStream a') (tyStream a')+ modify (mapClassVars (addC a (IsEq, l)))+ pure $ UBuiltin fTy Dedup tyE0 (UBuiltin _ Const) = do a <- dummyName "a" b <- dummyName "b"@@ -436,11 +430,32 @@ b' = var b fTy = tyArr a' (tyArr b' a') pure $ UBuiltin fTy Const-tyE0 (BBuiltin _ Filter) = do+tyE0 (UBuiltin l CatMaybes) = do a <- dummyName "a"+ f <- higherOrder "f" let a' = var a- fTy = tyArr (tyArr a' tyBool) (tyArr (tyStream a') (tyStream a'))+ f' = var f+ fTy = tyArr (hkt f' $ tyOpt a') (hkt f' a')+ modify (mapClassVars (addC f (Witherable, l)))+ pure $ UBuiltin fTy CatMaybes+tyE0 (BBuiltin l Filter) = do+ a <- dummyName "a"+ f <- higherOrder "f"+ let a' = var a+ f' = var f+ fTy = tyArr (tyArr a' tyBool) (tyArr (hkt f' a') (hkt f' a'))+ modify (mapClassVars (addC f (Witherable , l))) pure $ BBuiltin fTy Filter+tyE0 (BBuiltin l MapMaybe) = do+ a <- dummyName "a"+ b <- dummyName "b"+ f <- higherOrder "f"+ let a' = var a+ b' = var b+ f' = var f+ fTy = tyArr (tyArr a' (tyOpt b')) (tyArr (hkt f' a') (hkt f' b'))+ modify (mapClassVars (addC f (Witherable, l)))+ pure $ BBuiltin fTy MapMaybe tyE0 (BBuiltin l Map) = do a <- dummyName "a" b <- dummyName "b"@@ -449,7 +464,7 @@ b' = var b f' = var f fTy = tyArr (tyArr a' b') (tyArr (hkt f' a') (hkt f' b'))- modifying classVarsLens (addC f (Functor, l))+ modify (mapClassVars (addC f (Functor, l))) pure $ BBuiltin fTy Map -- (b -> a -> b) -> b -> Stream a -> b tyE0 (TBuiltin l Fold) = do@@ -460,8 +475,10 @@ a' = var a f' = var f fTy = tyArr (tyArr b' (tyArr a' b')) (tyArr b' (tyArr (hkt f' a') b'))- modifying classVarsLens (addC f (Foldable, l))+ modify (mapClassVars (addC f (Foldable, l))) pure $ TBuiltin fTy Fold+tyE0 (TBuiltin _ Captures) =+ pure $ TBuiltin (tyArr tyStr (tyArr tyI (tyArr tyStr (tyOpt tyStr)))) Captures -- (a -> a -> a) -> Stream a -> Stream a tyE0 (BBuiltin _ Prior) = do a <- dummyName "a"@@ -516,13 +533,13 @@ tyE0 (Lam _ n@(Name _ (Unique i) _) e) = do a <- dummyName "a" let a' = var a- modifying varEnvLens (IM.insert i a')+ modify (addVarEnv i a') e' <- tyE0 e pure $ Lam (tyArr a' (eLoc e')) (n $> a') e' tyE0 (Let _ (n@(Name _ (Unique i) _), eϵ) e) = do eϵ' <- tyE0 eϵ let bTy = eLoc eϵ'- modifying varEnvLens (IM.insert i bTy)+ modify (addVarEnv i bTy) e' <- tyE0 e pure $ Let (eLoc e') (n $> bTy, eϵ') e' tyE0 (Tup _ es) = do@@ -552,3 +569,10 @@ let x = V.head v' V.priorM_ (\y y' -> pushConstraint l (eLoc y) (eLoc y')) v' pure $ Arr (eLoc x) v'+tyE0 (Anchor l es) = do+ es' <- forM es $ \e -> do+ e' <- tyE0 e+ a <- dummyName "a"+ let a' = var a+ pushConstraint l (tyStream a') (eLoc e') $> e'+ pure $ Anchor (TyB Star TyUnit) es'
src/Jacinda/Ty/Const.hs view
@@ -3,6 +3,8 @@ , tyI , tyF , tyBool+ , hkt+ , tyOpt ) where import Jacinda.AST@@ -22,3 +24,9 @@ tyStr :: T K tyStr = TyB Star TyStr++hkt :: T K -> T K -> T K+hkt = TyApp Star++tyOpt :: T K -> T K+tyOpt = hkt (TyB (KArr Star Star) TyOption)
test/Spec.hs view
@@ -38,10 +38,17 @@ , testCase "running count (lines)" (tyOfT "(+)^0 [:1\"$0" (tyStream tyI)) , testCase "type of (tally)" (tyOfT "#'hello world'" tyI) , testCase "typechecks dfn" (tyFile "test/examples/ab.jac")- , testCase "parses parens" (tyFile "lib/example.jac")+ , testCase "parses parens" (tyFile "examples/lib.jac") , 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") ] +evalTo :: BSL.ByteString -> String -> Assertion+evalTo bsl expected =+ let actual = show (exprEval bsl)+ in actual @?= expected+ pAst :: E () pAst = EApp ()@@ -78,7 +85,7 @@ (IParseCol () 5) tyFile :: FilePath -> Assertion-tyFile = tcIO <=< BSL.readFile+tyFile = tcIO [] <=< BSL.readFile tyOfT :: BSL.ByteString -> T K -> Assertion tyOfT src expected =@@ -86,7 +93,7 @@ parseTo :: BSL.ByteString -> E () -> Assertion parseTo src e =- case rewriteProgram <$> parse src of+ case rewriteProgram . snd <$> parse src of Left err -> assertFailure (show err) Right actual -> void (expr actual) @?= e