jacinda 3.1.1.1 → 3.2.0.0
raw patch · 30 files changed
+918/−606 lines, 30 files
Files
- CHANGELOG.md +9/−0
- README.md +7/−25
- bench/Bench.hs +11/−11
- doc/guide.pdf binary
- jacinda.cabal +10/−11
- lib/color.jac +20/−0
- man/ja.1 +40/−21
- src/A.hs +23/−9
- src/A/E.hs +2/−0
- src/A/I.hs +13/−7
- src/C.hs +6/−0
- src/Data/Vector/Ext.hs +9/−0
- src/File.hs +27/−14
- src/Jacinda/Backend/Parse.hs +0/−19
- src/Jacinda/Backend/Printf.hs +1/−0
- src/Jacinda/Backend/T.hs +89/−15
- src/Jacinda/Check/Field.hs +5/−3
- src/Jacinda/Regex.hs +5/−0
- src/L.x +232/−214
- src/Nm.hs +2/−6
- src/Nm/Map.hs +49/−0
- src/NumParse.hs +19/−0
- src/Parser.y +88/−53
- src/Parser/Rw.hs +6/−3
- src/R.hs +19/−19
- src/Ty.hs +90/−44
- src/Ty/Const.hs +3/−9
- src/U.hs +1/−1
- x/Main.hs +0/−122
- x/Opt.hs +132/−0
CHANGELOG.md view
@@ -1,8 +1,17 @@+# 3.2.0.0++ * Add records and accessors (with row types)+ * Fix bug: backslashes in string literals+ * Admit `\ESC` as escaped character (see `lib/color.jac`)+ * Allow values to be passed on the command-line+ * Fix heinous bug that caused conditional expressions to crash+ # 3.1.1.1 * Pretty-print `:set csv` * `:set csv` inline case * Fix bug in `mapMaybe` &c. synonym parsing+ * More informative error messages from happy via `explist`. # 3.1.1.0
README.md view
@@ -1,5 +1,5 @@-Jacinda is a functional pattern sifting language,-a smaller [AWK](http://www.awklang.org).+Jacinda is a functional pattern filtering language,+inspired by [AWK](http://www.awklang.org). # Installation @@ -32,7 +32,7 @@ echo $PATH | ja -F: "{|[x+'\n'+y]|>\`$}" ``` -Many Unix tools output much information separated with spaces. We use regular+Many Unix tools output information separated with spaces. We use regular expressions to match relevant lines and then select the field with the data itself, viz. @@ -46,32 +46,14 @@ printenv | ja -F= '{%/^PATH/}{`2}' ``` -## 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+See the [guide](https://vmchale.github.io/jacinda/) (archived on [Hackage](https://hackage.haskell.org/package/jacinda/src/doc/guide.pdf), which contains a tutorial on some of the features as well as examples. -The manpages document the builtins and provide a syntax reference.+The [manpages](https://hackage.haskell.org/package/jacinda/src/man/ja.1) document the builtins and provide a syntax reference.++See the [rosetta](./ROSETTA.md) showing AWK alongside, or the [examples][./EXAMPLES.md] for its own capabilities. # Status
bench/Bench.hs view
@@ -16,20 +16,20 @@ , bench "exprEval" $ nf exprEval "reintercalate ' ' (split '01-23-1987' /-/)" ] , bgroup "csv"- [ bench "dedup" $ nfIO (silence $ runOnFile [] "~.{ix>1}{`8}" CSV "bench/data/food-prices.csv")- , bench "succdiff" $ nfIO (silence $ runOnFile [] "(%)\\. {%/Apple/}{`3:}" CSV "bench/data/food-prices.csv")+ [ bench "dedup" $ nfIO (silence $ runOnFile [] "~.{ix>1}{`8}" [] CSV "bench/data/food-prices.csv")+ , bench "succdiff" $ nfIO (silence $ runOnFile [] "(%)\\. {%/Apple/}{`3:}" [] CSV "bench/data/food-prices.csv") ] , bgroup "stream"- [ bench "path" $ nfIO (silence $ runOnFile [] "{|[x+'\\n'+y]|>`$}" (AWK (Just ":") Nothing) "bench/data/PATH")- , bench "RS" $ nfIO (silence $ runOnFile [] "$0" (AWK Nothing (Just ":")) "bench/data/PATH")- , bench "runOnFile" $ nfIO (silence $ runOnFile [] "(+)|0 {%/Bloom/}{1}" (AWK Nothing Nothing) "bench/data/ulysses.txt")- , bench "runOnFile/wc.jac" $ nfIO (silence $ do { contents <- TIO.readFile "examples/wc.jac" ; runOnFile [] contents (AWK Nothing Nothing) "bench/data/ulysses.txt" })- , bench "runOnFile/span2.jac" $ nfIO (silence $ do { contents <- TIO.readFile "examples/span2.jac" ; runOnFile [] contents (AWK Nothing Nothing) "bench/data/span.txt" })- , bench "sedstream.jac" $ nfIO (silence $ do { contents <- TIO.readFile "examples/sedstream.jac" ; runOnFile [] contents (AWK Nothing Nothing) "bench/data/lines.txt" })- , bench "gnused.jac" $ nfIO (silence $ do { contents <- TIO.readFile "examples/gnused.jac" ; runOnFile [] contents (AWK Nothing Nothing) "bench/data/lines.txt" })+ [ bench "path" $ nfIO (silence $ runOnFile [] "{|[x+'\\n'+y]|>`$}" [] (AWK (Just ":") Nothing) "bench/data/PATH")+ , bench "RS" $ nfIO (silence $ runOnFile [] "$0" [] (AWK Nothing (Just ":")) "bench/data/PATH")+ , bench "runOnFile" $ nfIO (silence $ runOnFile [] "(+)|0 {%/Bloom/}{1}" [] (AWK Nothing Nothing) "bench/data/ulysses.txt")+ , bench "runOnFile/wc.jac" $ nfIO (silence $ do { contents <- TIO.readFile "examples/wc.jac" ; runOnFile [] contents [] (AWK Nothing Nothing) "bench/data/ulysses.txt" })+ , bench "runOnFile/span2.jac" $ nfIO (silence $ do { contents <- TIO.readFile "examples/span2.jac" ; runOnFile [] contents [] (AWK Nothing Nothing) "bench/data/span.txt" })+ , bench "sedstream.jac" $ nfIO (silence $ do { contents <- TIO.readFile "examples/sedstream.jac" ; runOnFile [] contents [] (AWK Nothing Nothing) "bench/data/lines.txt" })+ , bench "gnused.jac" $ nfIO (silence $ do { contents <- TIO.readFile "examples/gnused.jac" ; runOnFile [] contents [] (AWK Nothing Nothing) "bench/data/lines.txt" }) -- , bench "fungnused.jac" $ nfIO (silence $ do { contents <- TIO.readFile "examples/fungnused.jac" ; runOnFile [] contents (AWK Nothing Nothing) "bench/data/lines.txt" })- , bench "hsLibversionMac.jac" $ nfIO (silence $ do { contents <- TIO.readFile "examples/hsLibversionMac.jac"; runOnFile [] contents (AWK Nothing Nothing) "bench/data/pandoc-mac" })- , bench "sedsmtp.jac" $ nfIO (silence $ do { contents <- TIO.readFile "examples/sedsmtp.jac" ; runOnFile [] contents (AWK Nothing Nothing) "test/examples/data/2.txt" })+ , bench "hsLibversionMac.jac" $ nfIO (silence $ do { contents <- TIO.readFile "examples/hsLibversionMac.jac"; runOnFile [] contents [] (AWK Nothing Nothing) "bench/data/pandoc-mac" })+ , bench "sedsmtp.jac" $ nfIO (silence $ do { contents <- TIO.readFile "examples/sedsmtp.jac" ; runOnFile [] contents [] (AWK Nothing Nothing) "test/examples/data/2.txt" }) ] ]
doc/guide.pdf view
binary file changed (75165 → 79844 bytes)
jacinda.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: jacinda-version: 3.1.1.1+version: 3.2.0.0 license: AGPL-3.0-only license-file: COPYING maintainer: vamchale@gmail.com@@ -42,7 +42,8 @@ -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints -Widentities -Wcpp-undef- -Wmissing-export-lists -Wunused-packages+ -Wmissing-export-lists -Wunused-packages -Wno-x-partial+ -Wno-missing-signatures library jacinda-lib import: warnings@@ -64,16 +65,19 @@ U R Jacinda.Check.Field- Jacinda.Backend.Parse Jacinda.Backend.Const Jacinda.Backend.T Jacinda.Backend.Printf Include+ Nm.Map+ NumParse+ Data.Vector.Ext+ C Paths_jacinda autogen-modules: Paths_jacinda default-language: Haskell2010- ghc-options: -O2 -Wno-missing-signatures -Wno-x-partial+ ghc-options: -O2 build-depends: base >=4.11.0.0 && <5, bytestring >=0.11.2.0,@@ -103,11 +107,11 @@ TypeFamilies if !flag(cross)- build-tool-depends: alex:alex >=3.5.0.0, happy:happy+ build-tool-depends: alex:alex >=3.5.0.0, happy:happy >=1.17.1 executable ja import: warnings- main-is: Main.hs+ main-is: Opt.hs hs-source-dirs: x other-modules: Paths_jacinda autogen-modules: Paths_jacinda@@ -118,11 +122,6 @@ jacinda-lib, optparse-applicative >=0.14.1.0, text-- ghc-options:- -Wincomplete-uni-patterns -Wincomplete-record-updates- -Wredundant-constraints -Widentities -Wcpp-undef- -Wmissing-export-lists -Wunused-packages test-suite jacinda-test import: warnings
+ lib/color.jac view
@@ -0,0 +1,20 @@+{. https://stackoverflow.com/a/33206814/11296354+{. https://stackoverflow.com/a/75985833/11296354+fn code(begin, str) :=+ '\ESC[' + begin + 'm' + str + '\ESC[0m';++fn underline := + code '4';+fn bold := + code '1';++fn black := code '30';+fn red := code '31';+fn green := code '32';+fn yellow := code '33';+fn blue := code '34';+fn magenta := code '35';+fn cyan := code '36';+fn white := code '37'++fn boldred := code '31;1';
man/ja.1 view
@@ -1,16 +1,16 @@-.\" Automatically generated by Pandoc 3.2+.\" Automatically generated by Pandoc 3.5 .\"-.TH "ja (1)" "" "" "" ""+.TH "ja (1)" "" "" "" .SH NAME ja \- Jacinda: data filtering, processing, reporting .SH SYNOPSIS ja run src.jac \-i data.txt .PP-cat FILE1 FILE2 | ja \[aq]#\[dq]$0\[cq]+cat FILE1 FILE2 | ja \[aq]#\[dq]$0\[aq] .PP ja tc script.jac .PP-ja e \[aq]11.67*1.2\[cq]+ja e \[aq]11.67*1.2\[aq] .SH DESCRIPTION \f[B]Jacinda\f[R] is a data stream processing language à la AWK. .SH SUBCOMMANDS@@ -38,6 +38,9 @@ .TP \f[B]\-\-csv\f[R] Process as CSV+.TP+\f[B]\-Dfile=main.c\f[R]+Define variable .SH LANGUAGE .SS REGEX Regular expressions follow Rust\[cq]s regex library:@@ -66,6 +69,9 @@ \f[B]\[ha]\f[R] Ternary operator: scan (b \-> a \-> b) \-> b \-> Stream a \-> Stream b .TP+\f[B]\[ha]*\f[R] Scan (list)+(b \-> a \-> b) \-> b \-> List a \-> List b+.TP \f[B]\[dq]\f[R], \f[B]¨\f[R] Binary operator: map Functor f :=> a \-> b \-> f a \-> f b .TP@@ -157,6 +163,15 @@ \f[B]nf\f[R] Number of fields .PP \f[B]⍬\f[R] Empty string/empty list+.TP+\f[B]head#, last#\f[R]+List a \-> a+.TP+\f[B]tail#, init#\f[R]+List a \-> List a+.TP+\f[B]drop#, take#\f[R]+Int \-> List a \-> List a .SS SYNTAX \f[B]\[ga]n\f[R] nth field .PP@@ -198,16 +213,20 @@ .PP \f[B]<pattern>,,<pattern> <expr>\f[R] Bookend a stream .PP-\f[B] $> \f[R] Print stream and summary result-.TP-\f[B]head#, last#\f[R]-List a \-> a-.TP-\f[B]tail#, init#\f[R]-List a \-> List a-.TP-\f[B]drop#, take#\f[R]-Int \-> List a \-> List a+\f[B]<expr> $> <expr>\f[R] Print stream and summary result+.PP+\f[B]fn f(x, y) := x + y;\f[R] Function definition+.PP+\f[B]let val x := y + 1 in x end\f[R] Let binding+.PP+\f[B](<expr> .+<expr> .+\&...+\&.+<expr>)\f[R] Tuple+.PP+\f[B]#{ <fieldname> .= <expr>; \&...+<fieldname> .= <expr> }\f[R] Record literal .SS DECLARATIONS \f[B]:set fs=/REGEX/;\f[R] Set field separator .PP@@ -229,13 +248,7 @@ {ix=3}{\[ga]0} Select only the third line .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-:set csv; {ix=1}{[x+`\[rs]n'+y]|>\[ga]$}+:set csv; {ix=1}{[x+\[aq]\[rs]n\[aq]+y]|>\[ga]$} Present column names of a .csv file, one per line .TP (+)|0 $1:i@@ -261,6 +274,12 @@ .TP [y]|> {|\[ga]0\[ti]/\[ha]$/} Is the last line blank?+.TP+{|option ⍬ [x] (\[ga]0 \[ti]* 1 /\[ha]((\[rs]s+\[rs]S|\[rs]S)*)$/)}+Trim trailing whitespace+.TP+ja \-R\[aq]\[rs]n\[rs]s*\[aq] \[dq][x+\[aq] \[aq]+y]|>\[rs]$0\[dq]+Concatenate into one line, discarding extra leading whitespace between .SH BUGS Please report any bugs you may come across to https://github.com/vmchale/jacinda/issues
src/A.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-} module A ( E (..), T (..), (~>), TB (..), C (..) , L (..), N (..), BBin (..), BTer (..)@@ -23,6 +22,8 @@ import qualified Data.Vector as V import GHC.Generics (Generic) import Nm+import Nm.Map (NmMap)+import qualified Nm.Map as Nm import Prettyprinter (Doc, Pretty (..), braces, brackets, concatWith, encloseSep, flatAlt, group, hardline, indent, parens, pipe, punctuate, tupled, (<+>)) import Regex.Rure (RurePtr) @@ -47,6 +48,8 @@ j'Tup :: Pretty a => [a] -> Doc ann j'Tup = tupledBy " . " . fmap pretty +jrec = encloseSep (flatAlt "#{ " "#{") (flatAlt (hardline <+> "}") "}") (flatAlt " ; " "; ")+ infixr 0 ~> (~>) :: T -> T -> T@@ -59,8 +62,10 @@ | TyArr { tyArr0, tyArr1 :: T } | TyVar { tyVar :: Nm () } | TyTup { tyTups :: [T] }+ | TyRec { tyres :: NmMap T } | Rho { tyRho :: Nm (), tyArms :: IM.IntMap T }- deriving (Eq, Ord)+ | Ρ { tyΡ :: Nm (), tyρs :: NmMap T }+ deriving Eq instance Pretty TB where pretty TyI = "Integer"; pretty TyStr = "Str"; pretty TyFloat = "Float"@@ -75,11 +80,13 @@ pretty (TyVar n) = pretty n pretty (TyArr ty ty') = pretty ty <+> "⟶" <+> pretty ty' pretty (TyTup tys) = j'Tup tys+ pretty (TyRec rs) = jrec ((\(n,t) -> pretty n <> ":" <+> pretty t)<$>Nm.toList rs) pretty (Rho n fs) = braces (pretty n <+> pipe <+> prettyFields (IM.toList fs))+ pretty (Ρ n fs) = braces (pretty n <+> pipe <+> prettyFields (Nm.toList fs)) parensp True=parens; parensp False=id -prettyFields :: [(Int, T)] -> Doc ann+prettyFields :: Pretty a => [(a, T)] -> Doc ann prettyFields = mconcat . punctuate "," . fmap g where g (i, t) = pretty i <> ":" <+> pretty t instance Show T where show=show.pretty@@ -87,7 +94,7 @@ data BUn = Tally -- length of string field | Const | Not -- ^ Boolean- | At !Int | Select !Int+ | At !Int | Select !Int | SelR !(Nm ()) | IParse | FParse | Parse | Floor | Ceiling | Some@@ -103,6 +110,7 @@ pretty Not = "!" pretty (At i) = "." <> pretty i pretty (Select i) = "->" <> pretty i+ pretty (SelR r) = "->" <> pretty r pretty IParse = ":i" pretty FParse = ":f" pretty Floor = "floor"@@ -119,10 +127,10 @@ pretty Last = "last#" data BTer = ZipW- | Fold | Scan+ | Fold | Scan | ScanList | Substr | Sub1 | Subs | Option- | Captures | AllCaptures+ | Captures | AllCaptures | Ixes | Bookend deriving (Eq) @@ -130,6 +138,7 @@ pretty ZipW = "," pretty Fold = "|" pretty Scan = "^"+ pretty ScanList = "^*" pretty Substr = "substr" pretty Option = "option" pretty Captures = "~*"@@ -137,6 +146,7 @@ pretty Sub1 = "sub1" pretty Subs = "subs" pretty Bookend = ",,"+ pretty Ixes = "ices" -- builtin data BBin = Plus | Times | Div@@ -170,7 +180,7 @@ data DfnVar = X | Y deriving (Eq) -instance Pretty DfnVar where pretty X = "x"; pretty Y = "y"+instance Pretty DfnVar where pretty X="x"; pretty Y="y" -- 0-ary data N = Ix | Nf | None | Fp | MZ deriving (Eq)@@ -202,6 +212,7 @@ | BB { eLoc :: a, eBin :: BBin } | TB { eLoc :: a, eTer :: BTer } | UB { eLoc :: a, eUn :: BUn } | NB { eLoc :: a, eNil :: N } | Tup { eLoc :: a, esTup :: [E a] }+ | Rec { eLoc :: a, esR :: [(Nm a, E a)] } | ResVar { eLoc :: a, dfnVar :: DfnVar } | RC RurePtr -- compiled regex after normalization | Arr { eLoc :: a, elems :: !(V.Vector (E a)) }@@ -209,9 +220,8 @@ | Paren { eLoc :: a, eExpr :: E a } | OptionVal { eLoc :: a, eMaybe :: Maybe (E a) } | Cond { eLoc :: a, eIf, eThen, eElse :: E a }- | In { oop :: E a, ip :: Maybe (E a), mm :: Maybe (E a), istream :: E a } | RwB { eLoc :: a, eBin :: BBin } | RwT { eLoc :: a, eTer :: BTer }- deriving (Functor, Generic)+ deriving (Functor) instance Pretty N where pretty Ix="⍳"; pretty Nf="nf"; pretty None="None"; pretty Fp="fp"; pretty MZ="⍬"@@ -266,12 +276,14 @@ ps _ (EApp _ (BB _ op) e) | isJust (mPrec op) = parens (pretty e <+> pretty op) ps d (EApp _ (UB _ (At i)) e) = parensp (d>0) (ps 1 e) <> "." <> pretty i ps d (EApp _ (UB _ (Select i)) e) = parensp (d>0) (ps 1 e) <> "->" <> pretty i+ ps d (EApp _ (UB _ (SelR n)) e) = parensp (d>0) (ps 1 e) <> "->" <> pretty n ps _ (EApp _ (UB _ IParse) e') = pretty e' <> ":i" ps _ (EApp _ (UB _ FParse) e') = pretty e' <> ":f" ps _ (EApp _ (UB _ Parse) e') = pretty e' <> ":" ps d (EApp _ (EApp _ (EApp _ (TB _ Bookend) e) e') e'') = parensp (d>3) (ps 4 e <> ",," <> ps 4 e' <+> ps 5 e'') ps d (EApp _ (EApp _ (EApp _ (TB _ Fold) e) e') e'') = parensp (d>5) (ps 6 e <> "|" <> ps 6 e' <+> ps 7 e'') ps d (EApp _ (EApp _ (EApp _ (TB _ Scan) e) e') e'') = parensp (d>5) (ps 6 e <> "^" <> ps 6 e' <+> ps 7 e'')+ ps d (EApp _ (EApp _ (EApp _ (TB _ ScanList) e) e') e'') = parensp (d>5) (ps 6 e <> "^" <> ps 6 e' <+> ps 7 e'') ps d (EApp _ (EApp _ (EApp _ (TB _ ZipW) op) e') e'') = parensp (d>5) ("," <> ps 6 op <+> ps 7 e' <+> ps 8 e'') ps d (EApp _ (EApp _ (EApp _ (TB _ Captures) e) e') e'') = parensp (d>6) (ps 7 e <+> "~*" <+> ps 7 e' <+> ps 8 e'') ps d (EApp _ e0 e1) = parensp (d>10) (ps 10 e0 <+> ps 11 e1)@@ -298,6 +310,7 @@ ps _ (RwB _ Fold1) = "fold1" ps _ (Cond _ e0 e1 e2) = "?" <> pretty e0 <> ";" <+> pretty e1 <> ";" <+> pretty e2 ps _ (Tup _ es) = j'Tup es+ ps _ (Rec _ es) = jrec ((\(n,e) -> pretty n <+> ".=" <+> pretty e)<$>es) ps _ (Arr _ es) = tupledByFunky "," (V.toList $ pretty <$> es) ps _ (Anchor _ es) = "&" <> tupledBy "." (pretty <$> es) ps _ (Let _ (n, b) e) = "let" <+> "val" <+> pretty n <+> ":=" <+> pretty b <+> "in" <+> pretty e <+> "end"@@ -331,6 +344,7 @@ (==) (UB _ unOp) (UB _ unOp') = unOp == unOp' (==) (NB _ x) (NB _ y) = x == y (==) (Tup _ es) (Tup _ es') = es == es'+ (==) (Rec _ es) (Rec _ es') = es == es' (==) (ResVar _ x) (ResVar _ y) = x == y (==) (Dfn _ f) (Dfn _ g) = f == g -- we're testing for lexical equivalence (==) RC{} _ = error "Cannot compare compiled regex!"
src/A/E.hs view
@@ -3,6 +3,7 @@ module A.E ( M, nN, eta ) where import A+import C import Control.Monad ((<=<)) import Control.Monad.State.Strict (State, state) import qualified Data.Text as T@@ -53,6 +54,7 @@ eM (Lam t n e) = Lam t n <$> eM e eM (Guarded t p e) = Guarded t <$> eM p <*> eM e eM (Tup t es) = Tup t <$> traverse eM es+eM (Rec t es) = Rec t <$> traverse (secondM eM) es eM (Anchor t es) = Anchor t <$> traverse eM es eM (Arr t es) = Arr t <$> traverse eM es eM (Let t (n, e') e) = do {e'𝜂 <- eM e'; e𝜂 <- eM e; pure (Let t (n, e'𝜂) e𝜂)}
src/A/I.hs view
@@ -7,6 +7,7 @@ ) where import A+import C import Control.Monad.State.Strict (State, gets, modify, runState, state) import Data.Bifunctor (second) import Data.Foldable (traverse_)@@ -26,6 +27,9 @@ bind :: Nm a -> E a -> ISt a -> ISt a bind (Nm _ (U u) _) e (ISt r bs) = ISt r (IM.insert u e bs) +bindM :: Nm a -> E a -> RM a ()+bindM n e = modify (bind n e)+ runI i = second (max_.renames) . flip runState (ISt (Rs i mempty) mempty) ib :: Int -> Program T -> (E T, Int)@@ -38,7 +42,7 @@ lβ e = state (`β` e) iD :: D T -> RM T ()-iD (FunDecl n [] e) = do {eI <- iE e; modify (bind n eI)}+iD (FunDecl n [] e) = do {eI <- iE e; bindM n eI} iD SetFS{} = pure (); iD SetRS{} = pure (); iD SetAsv = pure (); iD SetUsv = pure (); iD SetCsv = pure () iD SetORS{} = pure (); iD SetOFS{} = pure (); iD FlushDecl{} = pure () iD FunDecl{} = desugar@@ -47,14 +51,12 @@ bM :: E a -> RM a (E a) bM (EApp _ (EApp _ (Lam _ n (Lam _ n' e')) e'') e) = do- eI <- bM e- modify (bind n' eI)- eI'' <- bM e''- modify (bind n eI'')+ eI <- bM e; bindM n' eI+ eI'' <- bM e''; bindM n eI'' bM e' bM (EApp _ (Lam _ n e') e) = do eI <- bM e- modify (bind n eI) *> bM e'+ bindM n eI *> bM e' bM (EApp l e0 e1) = do e0' <- bM e0 e1' <- bM e1@@ -71,6 +73,7 @@ eB <- bM e pure $ Let l (n, e'B) eB bM (Tup l es) = Tup l <$> traverse bM es; bM (Arr l es) = Arr l <$> traverse bM es+bM (Rec l es) = Rec l <$> traverse (secondM bM) es bM (Anchor l es) = Anchor l <$> traverse bM es; bM (OptionVal l es) = OptionVal l <$> traverse bM es bM (Lam l n e) = Lam l n <$> bM e bM (Implicit l e) = Implicit l <$> bM e@@ -82,6 +85,7 @@ bM e@RC{} = pure e; bM e@Lit{} = pure e; bM e@RegexLit{} = pure e bM e@BB{} = pure e; bM e@NB{} = pure e; bM e@UB{} = pure e; bM e@TB{} = pure e bM ResVar{} = desugar; bM Dfn{} = desugar; bM Paren{} = desugar+bM RwT{} = desugar; bM RwB{} = desugar; bM F{} = error "impossible." iE :: E T -> RM T (E T) iE e@NB{} = pure e; iE e@UB{} = pure e; iE e@BB{} = pure e; iE e@TB{} = pure e@@ -95,16 +99,18 @@ iE (Implicit t e) = Implicit t <$> iE e iE (Lam t n e) = Lam t n <$> iE e iE (Tup t es) = Tup t <$> traverse iE es+iE (Rec t es) = Rec t <$> traverse (secondM iE) es iE (Arr t es) = Arr t <$> traverse iE es iE (Anchor t es) = Anchor t <$> traverse iE es iE (OptionVal t es) = OptionVal t <$> traverse iE es iE (Cond t p e e') = Cond t <$> iE p <*> iE e <*> iE e' iE (Let _ (n, e') e) = do eI <- iE e'- modify (bind n eI) *> iE e+ bindM n eI *> iE e iE e@(Var t (Nm _ (U i) _)) = do st <- gets binds case IM.lookup i st of Just e' -> do {er <- rE e'; pure $ fmap (aT (match (eLoc er) t)) er} Nothing -> pure e iE Dfn{} = desugar; iE Paren{} = desugar; iE ResVar{} = desugar+iE RwB{} = desugar; iE RwT{} = desugar; iE F{} = error "impossible."
+ src/C.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TupleSections #-}++module C ( secondM ) where++secondM :: Functor m => (b -> m b') -> (a, b) -> m (a, b')+secondM f (x,y) = (x,)<$>f y
+ src/Data/Vector/Ext.hs view
@@ -0,0 +1,9 @@+module Data.Vector.Ext (scanlM') where++import Data.Vector.Fusion.Bundle.Monadic (fromVector)+import qualified Data.Vector.Fusion.Bundle.Monadic as Bundle+import Data.Vector.Generic (Vector, unstreamM)++scanlM' :: (Monad m, Vector v a, Vector v b) => (a -> b -> m a) -> a -> v b -> m (v a)+scanlM' op seed = unstreamM . Bundle.scanlM' op seed . fromVector+-- scanlM'
src/File.hs view
@@ -59,23 +59,23 @@ Right (st', ([], ds)) -> put st' $> (rwD <$> ds) Right (st', (is, ds)) -> do {put st'; dss <- traverse (parseLib incls) is; pure (concat dss ++ fmap rwD ds)} -parseE :: [FilePath] -> T.Text -> StateT AlexUserState IO (Program AlexPosn)-parseE incls bs = do+parseP :: [FilePath] -> T.Text -> [(T.Text, Value)] -> StateT AlexUserState IO (Program AlexPosn)+parseP incls src var = do st <- get- case parseWithCtx bs st of+ case parseWithCtx src var 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 rwD ds) (rwE e) --- | Parse + rename (decls)-parseEWithMax :: [FilePath] -> T.Text -> IO (Program AlexPosn, Int)-parseEWithMax incls bsl = uncurry rP . swap . second fst3 <$> runStateT (parseE incls bsl) alexInitUserState- where fst3 (x, _, _) = x+-- | Parse + rename+parsePWithMax :: [FilePath] -> T.Text -> [(T.Text, T.Text)] -> IO (Program AlexPosn, Int)+parsePWithMax incls src vars = uncurry rP.swap.second fst3 <$> runStateT (parseP incls src vars) alexInitUserState+ where fst3 (x,_,_) = x parseWithMax' :: T.Text -> Either (ParseError AlexPosn) (Program AlexPosn, Int)-parseWithMax' = fmap (uncurry rP . second (rwP . snd)) . parseWithMax+parseWithMax' = fmap (uncurry rP . second (rwP.snd)) . parseWithMax type FileBS = BS.ByteString @@ -113,9 +113,16 @@ r (Let l (n, eb) e) = Let l (n, r eb) (r e) r (Lam l n e) = Lam l n (r e) r (Tup l es) = Tup l (r<$>es)+ r (Rec l es) = Rec l (second r<$>es) r (Arr l es) = Arr l (r<$>es) r (Anchor l es) = Anchor l (r<$>es)- r (In l e0 e1 e) = In l (r<$>e0) (r<$>e1) (r e)+ r F{} = error "impossible"+ r Dfn{} = desugar+ r Paren{} = desugar+ r ResVar{} = desugar+ r RwB{} = desugar+ r RwT{} = desugar+ r RC{} = error "???" exprEval :: T.Text -> E T exprEval src =@@ -132,12 +139,13 @@ runOnBytes :: [FilePath] -> FilePath -- ^ Data file name, for @nf@ -> T.Text -- ^ Program+ -> [(T.Text, Value)] -> Mode -> BSL.ByteString -> IO ()-runOnBytes incls fp src mode contents = do+runOnBytes incls fp src vars mode contents = do incls' <- defaultIncludes <*> pure incls- (ast, m) <- parseEWithMax incls' src+ (ast, m) <- parsePWithMax incls' src vars (typed, i) <- yIO $ runTyM m (tyP ast) let (eI, j) = ib i typed m'Throw $ cF eI@@ -156,21 +164,23 @@ runStdin :: [FilePath] -> T.Text -- ^ Program+ -> [(T.Text, Value)] -> Mode -> IO ()-runStdin is src m = runOnBytes is "(stdin)" src m =<< BSL.hGetContents stdin+runStdin is src vars m = runOnBytes is "(stdin)" src vars m =<< BSL.hGetContents stdin runOnFile :: [FilePath] -> T.Text+ -> [(T.Text, Value)] -> Mode -> FilePath -> IO ()-runOnFile is e m fp = runOnBytes is fp e m =<< BSL.readFile fp+runOnFile is e vs m fp = runOnBytes is fp e vs m =<< BSL.readFile fp tcIO :: [FilePath] -> T.Text -> IO () tcIO incls src = do incls' <- defaultIncludes <*> pure incls- (ast, m) <- parseEWithMax incls' src+ (ast, m) <- parsePWithMax incls' src [] (pT, i) <- yIO $ runTyM m (tyP ast) let (eI, _) = ib i pT m'Throw $ cF eI@@ -189,3 +199,6 @@ yeet :: Exception e => Either e a -> a yeet = either throw id++desugar :: a+desugar = error "Interal error: should have been desugared."
− src/Jacinda/Backend/Parse.hs
@@ -1,19 +0,0 @@-module Jacinda.Backend.Parse ( readDigits, readFloat ) where--import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as ASCII-import Foreign.C.String (CString)-import System.IO.Unsafe (unsafeDupablePerformIO)--readFloat :: BS.ByteString -> Double-readFloat = unsafeDupablePerformIO . (`BS.useAsCString` atof)--foreign import ccall unsafe atof :: CString -> IO Double--readDigits :: BS.ByteString -> Integer-readDigits b | Just (45, bs) <- BS.uncons b = negate $ readDigits bs-readDigits b = ASCII.foldl' (\seed x -> 10 * seed + f x) 0 b- where f '0' = 0; f '1' = 1; f '2' = 2; f '3' = 3;- f '4' = 4; f '5' = 5; f '6' = 6; f '7' = 7;- f '8' = 8; f '9' = 9- f c = error (c:" is not a valid digit!")
src/Jacinda/Backend/Printf.hs view
@@ -21,6 +21,7 @@ -- TODO: interpret precision, like %0.6f %.6 +-- FIXME: if next is, say %i and encounter an int in the tuple, that should be an error sprintf' :: T.Text -> E a -> T.Text sprintf' fmt (Lit _ (FLit f)) = let (prefix, fmt') = T.breakOn "%f" fmt
src/Jacinda/Backend/T.hs view
@@ -4,9 +4,11 @@ import A import A.I+import C import Control.Exception (Exception, throw) import Control.Monad (zipWithM, (<=<)) import Control.Monad.State.Strict (State, evalState, runState, state)+import Data.Bifunctor (first, second) import qualified Data.ByteString as BS import Data.ByteString.Builder (hPutBuilder) import Data.ByteString.Builder.RealFloat (doubleDec)@@ -15,15 +17,18 @@ import qualified Data.IntMap.Strict as IM import qualified Data.IntSet as IS import Data.List (foldl', scanl')+import qualified Data.Map as M import Data.Maybe (fromMaybe) import qualified Data.Set as S+import qualified Data.Text as T import qualified Data.Vector as V+import Data.Vector.Ext (scanlM') import Data.Word (Word8) import Jacinda.Backend.Const-import Jacinda.Backend.Parse import Jacinda.Backend.Printf import Jacinda.Regex import Nm+import NumParse import Prettyprinter (hardline, pretty) import Prettyprinter.Render.Text (putDoc) import Regex.Rure (RureMatch (RureMatch), RurePtr)@@ -31,14 +36,17 @@ import Ty.Const import U +infixl 4 <$!>+ data EvalErr = EmptyFold | IndexOutOfBounds Int | NoSuchField Int BS.ByteString | InternalCoercionError (E T) TB- | ExpectedTup (E T)+ | ExpectedTup (E T) | ExpectedRec (E T) | InternalTmp Tmp | InternalNm (Nm T) | InternalArityOrEta Int (E T)+ | InternalUnexpectedStream (E T) deriving (Show) instance Exception EvalErr where@@ -119,7 +127,8 @@ t <- nI (iEnv, μ) <- ctx es t (rEnv, g) <- φ e r- pure (Just r, [t], iEnv<>rEnv, \l -> μ l.g l)+ pure (Just r, [t], iEnv<>rEnv, μ@.g)+unit e = error ("Internal error. '" ++ show e ++ "' assigned unit type?") pS p = if p then (*>fflush).pDocLn else pDocLn where fflush = hFlush stdout @@ -139,10 +148,15 @@ collect (Tup ty es) = do (seedEnvs, updates, es') <- unzip3 <$> traverse collect es pure (fold seedEnvs, ts updates, Tup ty es')+collect (Rec ty rs) = do+ (seedEnvs, updates, es') <- unzip3 <$> traverse collect es+ pure (fold seedEnvs, ts updates, Rec ty (zip ns es'))+ where+ (ns,es)=unzip rs collect (EApp ty0 (EApp ty1 op@BB{} e0) e1) = do (env1, f1, e1') <- collect e1 (env0, f0, e0') <- collect e0- pure (env0<>env1, \l -> f1 l.f0 l, EApp ty0 (EApp ty1 op e0') e1')+ pure (env0<>env1, f1@.f0, EApp ty0 (EApp ty1 op e0') e1') collect (EApp ty0 (EApp ty1 (EApp ty2 op@TB{} e0) e1) e2) = do (env2, f2, e2') <- collect e2 (env1, f1, e1') <- collect e1@@ -152,12 +166,37 @@ (env, fϵ, eϵ) <- collect e pure (env, fϵ, EApp ty f eϵ) collect e@Lit{} = pure (IM.empty, const id, e)--- TODO: cond+collect (Cond t p e0 e1) = do+ (envp, pg, p') <- collect p+ (env0, f0, e0') <- collect e0+ (env1, f1, e1') <- collect e1+ pure (envp<>env0<>env1, pg@.f0@.f1, Cond t p' e0' e1')+collect (Lam t n e) = do+ (env,f,e') <- collect e+ pure (env,f,Lam t n e')+collect (OptionVal t (Just e)) = do+ (env, f, e') <- collect e+ pure (env, f, OptionVal t (Just e'))+collect (OptionVal t Nothing) = pure (mempty, const id, OptionVal t Nothing)+collect e@Column{} = throw $ InternalUnexpectedStream e+collect e@IParseCol{} = throw $ InternalUnexpectedStream e+collect e@FParseCol{} = throw $ InternalUnexpectedStream e+collect e@ParseCol{} = throw $ InternalUnexpectedStream e+collect e@AllColumn{} = throw $ InternalUnexpectedStream e+collect e@ParseAllCol{} = throw $ InternalUnexpectedStream e+collect e@IParseAllCol{} = throw $ InternalUnexpectedStream e+collect e@FParseAllCol{} = throw $ InternalUnexpectedStream e+collect e@Guarded{} = throw $ InternalUnexpectedStream e+collect e@Implicit{} = throw $ InternalUnexpectedStream e+collect Field{} = throw NakedField+collect LastField{} = throw NakedField+collect AllField{} = throw NakedField+collect FieldList{} = throw NakedField f @. g = \l -> f l.g l ts :: [LineCtx -> Σ -> Σ] -> LineCtx -> Σ -> Σ-ts = foldl' (\f g l -> f l.g l) (const id)+ts = foldl' (@.) (\_ -> id) φ :: E T -> Tmp -> MM (Env, LineCtx -> Σ -> Σ) φ (EApp _ (EApp _ (EApp _ (TB _ Fold) op) seed) xs) tgt = do@@ -167,13 +206,6 @@ (env, f) <- ctx xs t let g=wF op t tgt pure (env<>iEnv, (g.).f)-φ (EApp _ (EApp _ (EApp _ (TB _ Scan) op) seed) xs) tgt = do- t <- nI- seed' <- seed @> mempty- let iEnv=IM.singleton tgt (Just$!seed')- (env, f) <- ctx xs t- let g=wF op t tgt- pure (env<>iEnv, (g.).f) φ (EApp _ (EApp _ (BB _ Fold1) op) xs) tgt = do let iEnv=IM.singleton tgt Nothing t <- nI@@ -197,8 +229,29 @@ κ e@Lit{} _ = e κ e@RC{} _ = e κ e@Var{} _ = e+κ e@F{} _ = e κ (Lam t n e) line = Lam t n (κ e line) κ (Tup ty es) line = Tup ty ((`κ` line)<$>es)+κ (Arr ty es) line = Arr ty ((`κ` line)<$>es)+κ (Rec ty es) line = Rec ty (second (`κ` line)<$>es)+κ (OptionVal t e) line = OptionVal t ((`κ` line)<$!>e)+κ (Cond ty p e0 e1) line = Cond ty (p `κ` line) (e0 `κ` line) (e1 `κ` line)+κ e@ParseCol{} _ = badctx e+κ e@IParseCol{} _ = badctx e+κ e@FParseCol{} _ = badctx e+κ e@Column{} _ = badctx e+κ e@AllColumn{} _ = badctx e+κ e@Guarded{} _ = badctx e+κ e@Implicit{} _ = badctx e+κ e@IParseAllCol{} _ = badctx e+κ e@FParseAllCol{} _ = badctx e+κ e@Anchor{} _ = badctx e+κ e@ParseAllCol{} _ = badctx e+κ Dfn{} _ = desugar+κ ResVar{} _ = desugar+κ Paren{} _ = desugar+κ RwB{} _ = desugar+κ RwT{} _ = desugar ni t=IM.singleton t Nothing na=IM.alter go where go Nothing = Just Nothing; go x@Just{} = x@@ -226,6 +279,8 @@ ctx (EApp (_:$TyB ty) (UB _ Dedup) xs) o = do {k <- nI; t <- nI; (env, sb) <- ctx xs t; pure (na o env, \l->wD ty k t o.sb l)} ctx (EApp _ (EApp _ (BB _ DedupOn) f) xs) o = do {k <- nI; t <- nI; (env, sb) <- ctx xs t; pure (na o env, \l->wDOp f k t o.sb l)} ctx (EApp _ (EApp _ (EApp _ (TB _ Bookend) e0) e1) xs) o = do {k <- nI; t <- nI; (env, sb) <- ctx xs t; r0 <- e0@>mempty; r1<- e1@>mempty; pure (na o env, \l->wB (r0,r1) k t o.sb l)}+ctx e _ | TyB TyStream:$_ <- eLoc e = error ("?? uh-oh. " ++ show e)+ | otherwise = error "Internal error. ctx expects a stream." type LineCtx = (BS.ByteString, V.Vector BS.ByteString, Integer) -- line number @@ -253,6 +308,9 @@ asT :: E T -> [E T] asT (Tup _ es) = es; asT e = throw (ExpectedTup e) +asRec :: E T -> M.Map T.Text (E T)+asRec (Rec _ rs) = M.fromList (first name<$>rs); asRec e = throw (ExpectedRec e)+ vS :: V.Vector BS.ByteString -> E T vS = Arr (tyV tyStr).fmap mkStr @@ -262,9 +320,12 @@ Just (c,b) | BS.null b -> c Just _ -> error "Splitc takes only one char!" +rureMatchTup :: RureMatch -> E T+rureMatchTup (RureMatch s e) = Tup (TyTup [tyI,tyI]) (mkI.fromIntegral<$>[s,e])+ asTup :: Maybe RureMatch -> E T-asTup Nothing = OptionVal undefined Nothing-asTup (Just (RureMatch s e)) = OptionVal undefined (Just (Tup undefined (mkI . fromIntegral <$> [s, e])))+asTup Nothing = OptionVal undefined Nothing+asTup (Just m) = OptionVal undefined (Just (rureMatchTup m)) {-# SCC (!>) #-} (!>) :: Β -> Nm T -> E T@@ -370,6 +431,7 @@ n' <- asI<$>(n@>b); x' <- asV<$>(x@>b) pure $ Arr ty (V.drop (fromIntegral n') x') (Tup ty es) @> b = Tup ty.foldSeq <$> traverse (@>b) es+(Rec ty es) @> b = Rec ty.foldSeq <$> traverse (secondM (@>b)) es (EApp _ (UB _ Head) x) @> b = do x' <- x@>b pure $ V.head (asV x')@@ -398,6 +460,9 @@ (EApp ty (EApp _ (EApp _ (TB _ AllCaptures) s) i) r) @> b = do s' <- s@>b; i' <- i@>b; r' <- r@>b pure $ Arr ty (V.fromList (mkStr <$> captures' (asR r') (asS s') (fromIntegral$asI i')))+(EApp _ (EApp _ (EApp _ (TB _ Ixes) s) i) r) @> b = do+ s' <- s@>b; i' <- i@>b; r' <- r@>b+ pure (Arr (tyV (TyTup [tyI,tyI])) (V.fromList (rureMatchTup<$>capturesIx (asR r') (asS s') (fromIntegral (asI i'))))) (NB (TyB TyStr) MZ) @> _ = pure $ mkStr BS.empty (NB ty@(TyB TyVec:$_) MZ) @> _ = pure $ Arr ty V.empty (EApp _ (UB _ Not) e) @> b = do {e' <- e@> b; pure$mkB (not (asB e'))}@@ -413,6 +478,7 @@ (EApp (TyB TyFloat) (UB _ Parse) x) @> b = do {x' <- x@>b; pure (parseAsF (asS x'))} (EApp _ (UB _ (At i)) v) @> b = do {v' <- v@>b; pure (asV v' `at` i)} (EApp _ (UB _ (Select i)) x) @> b = do {x' <- x@>b; pure (asT x' !! (i-1))}+(EApp _ (UB _ (SelR n)) x) @> b = do {x' <- x@>b; pure (asRec x' M.! name n)} (EApp _ (UB _ Floor) x) @> b = mkI.floor.asF<$>(x@>b) (EApp _ (UB _ Ceiling) x) @> b = mkI.ceiling.asF<$>(x@>b) (EApp (TyB TyI) (UB _ Negate) i) @> b = mkI.negate.asI<$>(i@>b)@@ -434,6 +500,9 @@ (EApp _ (EApp _ (BB _ Rein) s) ss) @> b | TyB TyVec:$_ <- eLoc ss = do s' <- fmap asS (s@>b); ss' <- ss@>b pure $ mkStr (V.foldl' (\x y -> x <> s' <> y) mempty (asS<$>asV ss'))+(EApp yT@(TyB TyVec:$_) (EApp _ (EApp _ (TB _ ScanList) op) seed) xs) @> b | TyB TyVec:$_ <- eLoc xs = do+ xs' <- xs@>b; seed' <- seed@>b+ Arr yT <$> scanlM' (a2e b op) seed' (asV xs') (EApp _ (EApp _ (BB _ Fold1) op) xs) @> b | TyB TyVec:$_ <- eLoc xs = do xs' <- xs@>b let xsV=asV xs'@@ -669,3 +738,8 @@ (Nothing, Nothing) -> Σ j (IM.insert tgt Nothing env) (Nothing, Just x) -> Σ j (IM.insert tgt (Just$!x) env)) d di df b wF e _ _ _ = throw $ InternalArityOrEta 2 e++badctx e = error ("Internal error: κ called on" ++ show e)+desugar = error "Internal error. Should have been desugared by now."++(<$!>) f x = fmap (f$!) x
src/Jacinda/Check/Field.hs view
@@ -8,18 +8,19 @@ import Data.Foldable (asum) import Prettyprinter (Pretty (..), squotes, (<+>)) -data LErr = NF (E T) | TS (E T)+data LErr = NF (E T) | TS (E T) | RS (E T) instance Pretty LErr where pretty (NF e) = "Naked field in expression" <+> squotes (pretty e) pretty (TS e) = squotes (pretty e) <+> "Tuples cannot have streams."+ pretty (RS e) = squotes (pretty e) <+> "Records cannot have streams." instance Show LErr where show=show.pretty instance Exception LErr where cF :: E T -> Maybe LErr-cF e@(Tup (TyTup ts) _) | any isS ts = Just (TS e)+cF e@(Tup (TyTup ts) _) | any isS ts = Just (TS e); cF e@(Rec (TyRec rs) _) | any isS rs = Just (RS e) cF e@Field{} = Just (NF e); cF e@AllField{} = Just (NF e); cF e@LastField{} = Just (NF e); cF e@FieldList{} = Just (NF e) cF e@(NB _ Ix) = Just (NF e); cF e@(NB _ Nf) = Just (NF e) cF IParseCol{} = Nothing; cF FParseCol{} = Nothing; cF ParseCol{} = Nothing; cF Column{} = Nothing@@ -28,11 +29,12 @@ cF Lit{} = Nothing; cF RegexLit{} = Nothing; cF NB{} = Nothing; cF UB{} = Nothing; cF BB{} = Nothing; cF TB{} = Nothing cF Var{} = Nothing; cF (Tup _ es) = foldMapAlternative cF es; cF (Anchor _ es) = foldMapAlternative cF es-cF (Arr _ es) = foldMapAlternative cF es; cF (EApp _ e e') = cF e <|> cF e'+cF (Arr _ es) = foldMapAlternative cF es; cF (Rec _ es) = foldMapAlternative (cF.snd) es; cF (EApp _ e e') = cF e <|> cF e' cF (Cond _ p e e') = cF p <|> cF e <|> cF e'; cF (OptionVal _ e) = foldMapAlternative cF e cF (Lam _ _ e) = cF e; cF Let{} = error "Inlining unexpectedly failed?" cF RC{} = error "Sanity check failed. Regex should not be compiled at this time." cF Dfn{} = desugar; cF Paren{} = desugar; cF ResVar{} = desugar+cF RwB{} = desugar; cF RwT{} = desugar isS :: T -> Bool isS (TyB TyStream:$_) = True; isS _ = False
src/Jacinda/Regex.hs view
@@ -11,6 +11,7 @@ , substr , findCapture , captures'+ , capturesIx ) where import Control.Exception (Exception, throwIO)@@ -45,6 +46,10 @@ let e' = fromIntegral e s' = fromIntegral s in BS.BS (fp `plusForeignPtr` s') (e'-s')++{-# NOINLINE capturesIx #-}+capturesIx :: RurePtr -> BS.ByteString -> CSize -> [RureMatch]+capturesIx re str n = unsafeDupablePerformIO $ captures re str n {-# NOINLINE findCapture #-} findCapture :: RurePtr -> BS.ByteString -> CSize -> Maybe BS.ByteString
src/L.x view
@@ -2,10 +2,10 @@ {-# LANGUAGE OverloadedStrings #-} module L ( alexMonadScan , alexInitUserState- , runAlex , runAlexSt , withAlexSt , freshName+ , newVarAlex , AlexPosn (..) , Alex (..) , Token (..)@@ -39,7 +39,7 @@ $str_special = [\\\'] -@escape_str = \\ [$str_special nt]+@escape_str = \\ ([$str_special nt] | "ESC") @string = \' ([^ $str_special] | @escape_str)* \' @@ -55,11 +55,11 @@ tokens :- <dfn> {- x { mkRes VarX }- y { mkRes VarY }+ x { res VarX }+ y { res VarY } } - <0> "[" { mkSym LSqBracket `andBegin` dfn } -- FIXME: this doesn't allow nested+ <0> "[" { sym LSqBracket `andBegin` dfn } -- FIXME: this doesn't allow nested <0,dfn> { @@ -68,72 +68,75 @@ "{.".* ; "#!".* ; -- shebang - ":=" { mkSym DefEq }- "≔" { mkSym DefEq }- "{" { mkSym LBrace }- "}" { mkSym RBrace }+ ":=" { sym DefEq }+ "≔" { sym DefEq }+ "{" { sym LBrace }+ "}" { sym RBrace } - "#." { mkSym FilterTok }+ "#." { sym FilterTok } -- symbols/operators- "%" { mkSym PercentTok }- "*" { mkSym TimesTok }- "**" { mkSym ExpTok }- "+" { mkSym PlusTok }- "-" { mkSym MinusTok }+ "%" { sym PercentTok }+ "*" { sym TimesTok }+ "**" { sym ExpTok }+ "+" { sym PlusTok }+ "-" { sym MinusTok } - "|" { mkSym FoldTok }- \" { mkSym Quot }- "^" { mkSym Caret }- "|>" { mkSym Fold1Tok }- ⍬ { mkSym Zilde }+ "|" { sym FoldTok }+ \" { sym Quot }+ "^" { sym Caret }+ "^*" { sym CaretStar }+ "|>" { sym Fold1Tok }+ ⍬ { sym Zilde } - "=" { mkSym EqTok }- "!=" { mkSym NeqTok }- "<=" { mkSym LeqTok }- "<" { mkSym LtTok }- ">=" { mkSym GeqTok }- ">" { mkSym GtTok }- "&" { mkSym AndTok }- "||" { mkSym OrTok }- "(" { mkSym LParen }- ")" { mkSym RParen }- "&(" { mkSym LAnchor }- "$>" { mkSym IceCreamCone }- "{%" { mkSym LBracePercent }- "{|" { mkSym LBraceBar }- "]" { mkSym RSqBracket `andBegin` 0 }- "~" { mkSym Tilde }- "!~" { mkSym NotMatchTok }- "~?" { mkSym MMatch }- "," { mkSym Comma }- ",," { mkSym DoubleComma }- "." { mkSym Dot }- "#" { mkSym TallyTok }- "#*" { mkSym LengthTok }- "[:" { mkSym ConstTok }- "!" { mkSym Exclamation }- ":" { mkSym Colon }- ";" { mkSym Semicolon }- "\." { mkSym BackslashDot }- \\ { mkSym Backslash }- λ { mkSym Backslash }- "|`" { mkSym CeilSym }- ⌈ { mkSym CeilSym }- "|." { mkSym FloorSym }- ⌊ { mkSym FloorSym }- "~." { mkSym DedupTok }- dedup { mkSym DedupTok }- "~.*" { mkSym DedupOnTok }- ".?" { mkSym CatMaybesTok }- catMaybes { mkSym CatMaybesTok }- ":?" { mkSym MapMaybeTok }- "~*" { mkSym CapTok }- "-." { mkSym NegTok }- "`*" { mkSym LastFieldTok }- "`$" { mkSym FieldListTok }- \? { mkSym QuestionMark }- "@@" { mkSym AmpAmp }+ "=" { sym EqTok }+ "!=" { sym NeqTok }+ "<=" { sym LeqTok }+ "<" { sym LtTok }+ ">=" { sym GeqTok }+ ">" { sym GtTok }+ "&" { sym AndTok }+ "||" { sym OrTok }+ "(" { sym LParen }+ ")" { sym RParen }+ "&(" { sym LAnchor }+ "$>" { sym IceCreamCone }+ "{%" { sym LBracePercent }+ "#{" { sym LBraceOctothorpe }+ "{|" { sym LBraceBar }+ "]" { sym RSqBracket `andBegin` 0 }+ ".=" { sym DotEq }+ "~" { sym Tilde }+ "!~" { sym NotMatchTok }+ "~?" { sym MMatch }+ "," { sym Comma }+ ",," { sym DoubleComma }+ "." { sym Dot }+ "#" { sym TallyTok }+ "#*" { sym LengthTok }+ "[:" { sym ConstTok }+ "!" { sym Exclamation }+ ":" { sym Colon }+ ";" { sym Semicolon }+ "\." { sym BackslashDot }+ \\ { sym Backslash }+ λ { sym Backslash }+ "|`" { sym CeilSym }+ ⌈ { sym CeilSym }+ "|." { sym FloorSym }+ ⌊ { sym FloorSym }+ "~." { sym DedupTok }+ dedup { sym DedupTok }+ "~.*" { sym DedupOnTok }+ ".?" { sym CatMaybesTok }+ catMaybes { sym CatMaybesTok }+ ":?" { sym MapMaybeTok }+ "~*" { sym CapTok }+ "-." { sym NegTok }+ "`*" { sym LastFieldTok }+ "`$" { sym FieldListTok }+ \? { sym QuestionMark }+ "@@" { sym AmpAmp } in { mkKw KwIn } let { mkKw KwLet }@@ -150,45 +153,46 @@ usv { mkKw KwUsv } csv { mkKw KwCsv } - fs { mkRes VarFs }- rs { mkRes VarRs }- ix { mkRes VarIx }- ⍳ { mkRes VarIx }- nf { mkRes VarNf }- ¨ { mkSym Quot }- min { mkRes VarMin }- max { mkRes VarMax }+ fs { res VarFs }+ rs { res VarRs }+ ix { res VarIx }+ ⍳ { res VarIx }+ nf { res VarNf }+ ¨ { sym Quot }+ min { res VarMin }+ max { res VarMax } - substr { mkBuiltin BuiltinSubstr }- split { mkBuiltin BuiltinSplit }- splitc { mkBuiltin BuiltinSplitc }- sprintf { mkBuiltin BuiltinSprintf }- option { mkBuiltin BuiltinOption }- floor { mkBuiltin BuiltinFloor }- ceil { mkBuiltin BuiltinCeil }- match { mkBuiltin BuiltinMatch }- captures { mkBuiltin BuiltinCaptures }- Some { mkBuiltin BuiltinSome }- None { mkBuiltin BuiltinNone }- fp { mkBuiltin BuiltinFp }- mapMaybe { mkBuiltin BuiltinMapMaybe }- dedupOn { mkBuiltin BuiltinDedupOn }- filter { mkBuiltin BuiltinFilt }- fold { mkBuiltin BuiltinFold }- fold1 { mkBuiltin BuiltinFold1 }- scan { mkBuiltin BuiltinScan }- "sub1" { mkBuiltin BuiltinSub1 }- subs { mkBuiltin BuiltinSubs }- "head#" { mkBuiltin BuiltinHead }- "tail#" { mkBuiltin BuiltinTail }- "last#" { mkBuiltin BuiltinLast }- "init#" { mkBuiltin BuiltinInit }- "take#" { mkBuiltin BuiltinTake }- "drop#" { mkBuiltin BuiltinDrop }- reintercalate { mkBuiltin BuiltinRein }+ substr { mkBuiltin BSubstr }+ split { mkBuiltin BSplit }+ splitc { mkBuiltin BSplitc }+ sprintf { mkBuiltin BSprintf }+ option { mkBuiltin BOption }+ floor { mkBuiltin BFloor }+ ceil { mkBuiltin BCeil }+ match { mkBuiltin BMatch }+ ices { mkBuiltin BIxes }+ captures { mkBuiltin BCaptures }+ Some { mkBuiltin BSome }+ None { mkBuiltin BNone }+ fp { mkBuiltin BFp }+ mapMaybe { mkBuiltin BMapMaybe }+ dedupOn { mkBuiltin BDedupOn }+ filter { mkBuiltin BFilt }+ fold { mkBuiltin BFold }+ fold1 { mkBuiltin BFold1 }+ scan { mkBuiltin BScan }+ "sub1" { mkBuiltin BSub1 }+ subs { mkBuiltin BSubs }+ "head#" { mkBuiltin BHead }+ "tail#" { mkBuiltin BTail }+ "last#" { mkBuiltin BLast }+ "init#" { mkBuiltin BInit }+ "take#" { mkBuiltin BTake }+ "drop#" { mkBuiltin BDrop }+ reintercalate { mkBuiltin BRein } - ":i" { mkBuiltin BuiltinIParse }- ":f" { mkBuiltin BuiltinFParse }+ ":i" { mkBuiltin BIParse }+ ":f" { mkBuiltin BFParse } "#t" { tok (\p _ -> alex $ TokBool p True) } "#f" { tok (\p _ -> alex $ TokBool p False) }@@ -198,6 +202,7 @@ "."$digit+ { tok (\p s -> alex $ TokAccess p (read $ T.unpack $ T.tail s)) } "->"$digit+ { tok (\p s -> alex $ TokSelect p (read $ T.unpack $ T.drop 2 s)) }+ "->"$latin+ { tok (\p s -> TokR p <$> newIdentAlex p (T.drop 2 s)) } $digit+ { tok (\p s -> alex $ TokInt p (read $ T.unpack s)) } _$digit+ { tok (\p s -> alex $ TokInt p (negate $ read $ T.unpack $ T.tail s)) } @@ -226,11 +231,11 @@ constructor c t = tok (\p _ -> alex $ c p t) -mkRes = constructor TokResVar+res = constructor TokResVar mkKw = constructor TokKeyword -mkSym = constructor TokSym+sym = constructor TokSym mkBuiltin = constructor TokBuiltin @@ -238,6 +243,8 @@ escReplace :: T.Text -> T.Text escReplace = T.replace "\\\"" "\""+ . T.replace "\\\\" "\\"+ . T.replace "\\ESC" "\ESC" . T.replace "\\n" "\n" . T.replace "\\t" "\t" @@ -273,6 +280,7 @@ | LBrace | RBrace | LParen | LAnchor+ | DotEq | RParen | LSqBracket | RSqBracket | Semicolon@@ -287,9 +295,10 @@ | TallyTok | LengthTok | ConstTok | LBracePercent+ | LBraceOctothorpe | LBraceBar | Exclamation- | Caret+ | Caret | CaretStar | Zilde | Backslash | BackslashDot@@ -304,63 +313,66 @@ | AmpAmp instance Pretty Sym where- pretty PlusTok = "+"- pretty MinusTok = "-"- pretty PercentTok = "%"- pretty ExpTok = "**"- pretty FoldTok = "|"- pretty Fold1Tok = "|>"- pretty TimesTok = "*"- pretty DefEq = ":="- pretty Colon = ":"- pretty LBrace = "{"- pretty RBrace = "}"- pretty Semicolon = ";"- pretty Underscore = "_"- pretty EqTok = "="- pretty LeqTok = "<="- pretty LtTok = "<"- pretty NeqTok = "!="- pretty GeqTok = ">="- pretty GtTok = ">"- pretty AndTok = "&"- pretty OrTok = "||"- pretty LParen = "("- pretty RParen = ")"- pretty LAnchor = "&("- pretty LSqBracket = "["- pretty RSqBracket = "]"- pretty Tilde = "~"- pretty NotMatchTok = "!~"- pretty MMatch = "~?"- pretty Comma = ","- pretty DoubleComma = ",,"- pretty Dot = "."- pretty TallyTok = "#"- pretty Zilde = "⍬"- pretty LengthTok = "#*"- pretty Quot = "¨"- pretty Caret = "^"- pretty ConstTok = "[:"- pretty LBracePercent = "{%"- pretty LBraceBar = "{|"- pretty Exclamation = "!"- pretty Backslash = "\\"- pretty BackslashDot = "\\."- pretty FilterTok = "#."- pretty FloorSym = "⌊"- pretty CeilSym = "⌈"- pretty DedupTok = "~."- pretty DedupOnTok = "~.*"- pretty CatMaybesTok = ".?"- pretty MapMaybeTok = ":?"- pretty CapTok = "~*"- pretty NegTok = "-."- pretty LastFieldTok = "`*"- pretty FieldListTok = "`$"- pretty IceCreamCone = "$>"- pretty QuestionMark = "?"- pretty AmpAmp = "@@"+ pretty PlusTok = "+"+ pretty MinusTok = "-"+ pretty PercentTok = "%"+ pretty ExpTok = "**"+ pretty FoldTok = "|"+ pretty Fold1Tok = "|>"+ pretty TimesTok = "*"+ pretty DefEq = ":="+ pretty DotEq = ".="+ pretty Colon = ":"+ pretty LBrace = "{"+ pretty RBrace = "}"+ pretty Semicolon = ";"+ pretty Underscore = "_"+ pretty EqTok = "="+ pretty LeqTok = "<="+ pretty LtTok = "<"+ pretty NeqTok = "!="+ pretty GeqTok = ">="+ pretty GtTok = ">"+ pretty AndTok = "&"+ pretty OrTok = "||"+ pretty LParen = "("+ pretty RParen = ")"+ pretty LAnchor = "&("+ pretty LSqBracket = "["+ pretty RSqBracket = "]"+ pretty Tilde = "~"+ pretty NotMatchTok = "!~"+ pretty MMatch = "~?"+ pretty Comma = ","+ pretty DoubleComma = ",,"+ pretty Dot = "."+ pretty TallyTok = "#"+ pretty Zilde = "⍬"+ pretty LengthTok = "#*"+ pretty Quot = "¨"+ pretty Caret = "^"+ pretty CaretStar = "^*"+ pretty ConstTok = "[:"+ pretty LBracePercent = "{%"+ pretty LBraceOctothorpe = "#{"+ pretty LBraceBar = "{|"+ pretty Exclamation = "!"+ pretty Backslash = "\\"+ pretty BackslashDot = "\\."+ pretty FilterTok = "#."+ pretty FloorSym = "⌊"+ pretty CeilSym = "⌈"+ pretty DedupTok = "~."+ pretty DedupOnTok = "~.*"+ pretty CatMaybesTok = ".?"+ pretty MapMaybeTok = ":?"+ pretty CapTok = "~*"+ pretty NegTok = "-."+ pretty LastFieldTok = "`*"+ pretty FieldListTok = "`$"+ pretty IceCreamCone = "$>"+ pretty QuestionMark = "?"+ pretty AmpAmp = "@@" data Keyword = KwLet | KwIn@@ -403,57 +415,58 @@ pretty KwAsv = "asv" pretty KwCsv = "csv" -data Builtin = BuiltinIParse | BuiltinFParse- | BuiltinSubstr- | BuiltinSplit | BuiltinSplitc- | BuiltinOption- | BuiltinSprintf- | BuiltinFloor | BuiltinCeil- | BuiltinMatch- | BuiltinCaptures- | BuiltinSome | BuiltinNone- | BuiltinFp- | BuiltinMapMaybe- | BuiltinDedupOn- | BuiltinFilt- | BuiltinFold | BuiltinFold1- | BuiltinScan- | BuiltinSub1 | BuiltinSubs- | BuiltinHead | BuiltinTail- | BuiltinInit | BuiltinLast- | BuiltinDrop | BuiltinTake- | BuiltinRein+data Builtin = BIParse | BFParse+ | BSubstr+ | BSplit | BSplitc+ | BOption+ | BSprintf+ | BFloor | BCeil+ | BMatch | BIxes+ | BCaptures+ | BSome | BNone+ | BFp+ | BMapMaybe+ | BDedupOn+ | BFilt+ | BFold | BFold1+ | BScan+ | BSub1 | BSubs+ | BHead | BTail+ | BInit | BLast+ | BDrop | BTake+ | BRein 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 BuiltinCaptures = "captures"- pretty BuiltinMapMaybe = "mapMaybe"- pretty BuiltinDedupOn = "dedupOn"- pretty BuiltinFilt = "filter"- pretty BuiltinFold = "fold"- pretty BuiltinFold1 = "fold1"- pretty BuiltinScan = "scan"- pretty BuiltinSub1 = "sub1"- pretty BuiltinSubs = "subs"- pretty BuiltinHead = "head#"- pretty BuiltinTail = "tail#"- pretty BuiltinInit = "init#"- pretty BuiltinLast = "last#"- pretty BuiltinTake = "take#"- pretty BuiltinDrop = "drop#"- pretty BuiltinRein = "reintercalate"+ pretty BIParse = ":i"+ pretty BFParse = ":f"+ pretty BSubstr = "substr"+ pretty BSplit = "split"+ pretty BOption = "option"+ pretty BSplitc = "splitc"+ pretty BSprintf = "sprintf"+ pretty BFloor = "floor"+ pretty BCeil = "ceil"+ pretty BMatch = "match"+ pretty BIxes = "ices"+ pretty BSome = "Some"+ pretty BNone = "None"+ pretty BFp = "fp"+ pretty BCaptures = "captures"+ pretty BMapMaybe = "mapMaybe"+ pretty BDedupOn = "dedupOn"+ pretty BFilt = "filter"+ pretty BFold = "fold"+ pretty BFold1 = "fold1"+ pretty BScan = "scan"+ pretty BSub1 = "sub1"+ pretty BSubs = "subs"+ pretty BHead = "head#"+ pretty BTail = "tail#"+ pretty BInit = "init#"+ pretty BLast = "last#"+ pretty BTake = "take#"+ pretty BDrop = "drop#"+ pretty BRein = "reintercalate" data Token a = EOF { loc :: a } | TokSym { loc :: a, _sym :: Sym }@@ -471,6 +484,7 @@ | TokRR { loc :: a, rr :: T.Text } | TokAccess { loc :: a, ix :: Int } | TokSelect { loc :: a, field :: Int }+ | TokR { loc :: a, nfield :: Nm a } instance Pretty (Token a) where pretty EOF{} = "(eof)"@@ -490,19 +504,23 @@ pretty (TokAccess _ i) = "." <> pretty i pretty (TokFloat _ f) = pretty f pretty (TokSelect _ i) = "->" <> pretty i+ pretty (TokR _ r) = "->" <> pretty r freshName :: T.Text -> Alex (Nm AlexPosn) freshName t = do pos <- get_pos (i, ns, us) <- alexGetUserState let (j, n) = freshIdent pos t i- alexSetUserState (j, ns, us) $> (n$>pos)+ alexSetUserState (j, ns, us) $> n +newVarAlex :: T.Text -> Alex (Nm AlexPosn)+newVarAlex t = do {pos <- get_pos; newIdentAlex pos t}+ newIdentAlex :: AlexPosn -> T.Text -> Alex (Nm AlexPosn) newIdentAlex pos t = do st <- alexGetUserState let (st', n) = newIdent pos t st- alexSetUserState st' $> (n $> pos)+ alexSetUserState st' $> n freshIdent :: AlexPosn -> T.Text -> Int -> (Int, Nm AlexPosn) freshIdent pos t max' =
src/Nm.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE DeriveFunctor #-} -module Nm ( Nm (..)- , TyName+module Nm ( Nm (..), TyName , eqName ) where @@ -14,7 +13,7 @@ , loc :: a } deriving (Functor) --- for testing+-- test eqName :: Nm a -> Nm a -> Bool eqName (Nm n _ _) (Nm n' _ _) = n == n' @@ -25,8 +24,5 @@ pretty (Nm t _ _) = pretty t instance Show (Nm a) where show=show.pretty--instance Ord (Nm a) where- compare (Nm _ u _) (Nm _ u' _) = compare u u' type TyName = Nm
+ src/Nm/Map.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}++module Nm.Map ( NmMap (..)+ , intersectionWith+ , isSubmapOf+ , (!)+ , elems+ , singleton+ , toList+ , fromList+ ) where++import Control.Arrow ((&&&))+import Data.Bifunctor (first)+import qualified Data.IntMap as IM+import qualified Data.Text as T+import Nm+import U++infixl 9 !++data NmMap a = NmMap { xx :: !(IM.IntMap a), context :: IM.IntMap T.Text }+ deriving (Eq, Functor, Foldable, Traversable)++instance Semigroup (NmMap a) where+ (<>) (NmMap x y) (NmMap x' y') = NmMap (x<>x') (y<>y')++singleton :: Nm a -> b -> NmMap b+singleton (Nm n (U i) _) x = NmMap (IM.singleton i x) (IM.singleton i n)++(!) :: NmMap a -> Nm b -> a+(!) (NmMap x _) (Nm _ (U i) _) = x IM.! i++intersectionWith :: (a -> b -> c) -> NmMap a -> NmMap b -> NmMap c+intersectionWith f (NmMap x0 c0) (NmMap x1 c1) = NmMap (IM.intersectionWith f x0 x1) (IM.intersection c0 c1)++isSubmapOf :: NmMap a -> NmMap b -> Bool+isSubmapOf (NmMap x _) (NmMap y _) = IM.isSubmapOfBy (\_ _ -> True) x y++elems :: NmMap a -> [a]+elems (NmMap x _) = IM.elems x++toList :: NmMap a -> [(Nm (), a)]+toList (NmMap x ns) = map (first (\i -> Nm (ns IM.! i) (U i) ())) (IM.toList x)++fromList :: [(Nm a, b)] -> NmMap b+fromList xs = NmMap { xx = IM.fromList [ (i,x) | (Nm _ (U i) _, x) <- xs ], context = IM.fromList (map ((unU.unique) &&& name) (fst<$>xs)) }
+ src/NumParse.hs view
@@ -0,0 +1,19 @@+module NumParse ( readDigits, readFloat ) where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as ASCII+import Foreign.C.String (CString)+import System.IO.Unsafe (unsafeDupablePerformIO)++readFloat :: BS.ByteString -> Double+readFloat = unsafeDupablePerformIO . (`BS.useAsCString` atof)++foreign import ccall unsafe atof :: CString -> IO Double++readDigits :: BS.ByteString -> Integer+readDigits b | Just (45, bs) <- BS.uncons b = negate $ readDigits bs+readDigits b = ASCII.foldl' (\seed x -> 10 * seed + f x) 0 b+ where f '0' = 0; f '1' = 1; f '2' = 2; f '3' = 3;+ f '4' = 4; f '5' = 5; f '6' = 6; f '7' = 7;+ f '8' = 8; f '9' = 9+ f c = error (c:" is not a valid digit!")
src/Parser.y view
@@ -2,20 +2,20 @@ {-# LANGUAGE OverloadedStrings #-} module Parser ( parse , parseWithMax- , parseWithInitCtx , parseWithCtx , parseLibWithCtx , ParseError (..) -- * Type synonyms , File , Library+ , Value ) where -import Control.Exception (Exception)+import Control.Exception (Exception, throw) import Control.Monad.Except (ExceptT, runExceptT, throwError) import Control.Monad.Trans.Class (lift)-import Data.Bifunctor (first)-import qualified Data.ByteString.Lazy as BSL+import Data.Bifunctor (first, second)+import Data.Functor (void) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Data.Typeable (Typeable)@@ -23,13 +23,15 @@ import L import Nm hiding (loc) import qualified Nm-import Prettyprinter (Pretty (pretty), (<+>))+import Prettyprinter (Pretty (pretty), (<+>), concatWith, squotes) } %name parseF File %name parseLib Library+%name pValue Value %tokentype { Token AlexPosn }+%errorhandlertype explist %error { parseError } %monad { Parse } { (>>=) } { pure } %lexer { lift alexMonadScan >>= } { EOF _ }@@ -43,8 +45,9 @@ lsqbracket { TokSym $$ LSqBracket } rsqbracket { TokSym $$ RSqBracket } lparen { TokSym $$ LParen }- lanchor { TokSym $$ LAnchor } rparen { TokSym $$ RParen }+ loctothorpe { TokSym $$ LBraceOctothorpe }+ lanchor { TokSym $$ LAnchor } semicolon { TokSym $$ Semicolon } backslash { TokSym $$ Backslash } questionMark { TokSym $$ QuestionMark }@@ -61,6 +64,7 @@ backslashdot { TokSym $$ BackslashDot } at { $$@(TokAccess _ _) } select { $$@(TokSelect _ _) }+ get { $$@(TokR _ _) } floorSym { TokSym $$ FloorSym } ceilSym { TokSym $$ CeilSym } dedup { TokSym $$ DedupTok }@@ -75,9 +79,11 @@ comma { TokSym $$ Comma } doubleComma { TokSym $$ DoubleComma }+ dotEq { TokSym $$ DotEq } fold { TokSym $$ FoldTok } fold1 { TokSym $$ Fold1Tok } caret { TokSym $$ Caret }+ cs { TokSym $$ CaretStar } amp { TokSym $$ AmpAmp } z { TokSym $$ Zilde } quot { TokSym $$ Quot }@@ -138,37 +144,38 @@ ofs { TokResVar $$ VarOfs } ors { TokResVar $$ VarOrs } - split { TokBuiltin $$ BuiltinSplit }- splitc { TokBuiltin $$ BuiltinSplitc }- substr { TokBuiltin $$ BuiltinSubstr }- sub1 { TokBuiltin $$ BuiltinSub1 }- subs { TokBuiltin $$ BuiltinSubs }- sprintf { TokBuiltin $$ BuiltinSprintf }- floor { TokBuiltin $$ BuiltinFloor }- ceil { TokBuiltin $$ BuiltinCeil }- option { TokBuiltin $$ BuiltinOption }- match { TokBuiltin $$ BuiltinMatch }- some { TokBuiltin $$ BuiltinSome }- none { TokBuiltin $$ BuiltinNone }- fp { TokBuiltin $$ BuiltinFp }- captures { TokBuiltin $$ BuiltinCaptures }- mapMaybeL { TokBuiltin $$ BuiltinMapMaybe }- dedupOnL { TokBuiltin $$ BuiltinDedupOn }- filterL { TokBuiltin $$ BuiltinFilt }- foldL { TokBuiltin $$ BuiltinFold }- fold1L { TokBuiltin $$ BuiltinFold1 }- scanL { TokBuiltin $$ BuiltinScan }+ split { TokBuiltin $$ BSplit }+ splitc { TokBuiltin $$ BSplitc }+ substr { TokBuiltin $$ BSubstr }+ sub1 { TokBuiltin $$ BSub1 }+ subs { TokBuiltin $$ BSubs }+ sprintf { TokBuiltin $$ BSprintf }+ floor { TokBuiltin $$ BFloor }+ ceil { TokBuiltin $$ BCeil }+ option { TokBuiltin $$ BOption }+ match { TokBuiltin $$ BMatch }+ ices { TokBuiltin $$ BIxes }+ some { TokBuiltin $$ BSome }+ none { TokBuiltin $$ BNone }+ fp { TokBuiltin $$ BFp }+ captures { TokBuiltin $$ BCaptures }+ mapMaybeL { TokBuiltin $$ BMapMaybe }+ dedupOnL { TokBuiltin $$ BDedupOn }+ filterL { TokBuiltin $$ BFilt }+ foldL { TokBuiltin $$ BFold }+ fold1L { TokBuiltin $$ BFold1 }+ scanL { TokBuiltin $$ BScan } - head { TokBuiltin $$ BuiltinHead }- tail { TokBuiltin $$ BuiltinTail }- init { TokBuiltin $$ BuiltinInit }- last { TokBuiltin $$ BuiltinLast }- take { TokBuiltin $$ BuiltinTake }- drop { TokBuiltin $$ BuiltinDrop }- rein { TokBuiltin $$ BuiltinRein }+ head { TokBuiltin $$ BHead }+ tail { TokBuiltin $$ BTail }+ init { TokBuiltin $$ BInit }+ last { TokBuiltin $$ BLast }+ take { TokBuiltin $$ BTake }+ drop { TokBuiltin $$ BDrop }+ rein { TokBuiltin $$ BRein } - iParse { TokBuiltin $$ BuiltinIParse }- fParse { TokBuiltin $$ BuiltinFParse }+ iParse { TokBuiltin $$ BIParse }+ fParse { TokBuiltin $$ BFParse } rr { $$@(TokRR _ _) } @@ -218,9 +225,18 @@ | report { Report } | amp { Nier } +Value :: { E AlexPosn }+ : intLit { Lit (loc $1) (ILit (int $1)) }+ | floatLit { Lit (loc $1) (FLit (float $1)) }+ | boolLit { Lit (loc $1) (BLit (boolTok $1)) }+ | rr { RegexLit (loc $1) (encodeUtf8 $ rr $1) }+ Bind :: { (Nm AlexPosn, E AlexPosn) } : val name defEq E { ($2, $4) } +Rec :: { (Nm AlexPosn, E AlexPosn) }+ : name dotEq E { ($1, $3) }+ Args :: { [(Nm AlexPosn)] } : lparen rparen { [] } | parens(name) { [$1] }@@ -250,19 +266,21 @@ Program :: { Program AlexPosn } : many(D) E { Program (reverse $1) $2 } +L :: { (AlexPosn, L) }+ : intLit { (loc $1, ILit (int $1)) }+ | floatLit { (loc $1, FLit (float $1)) }+ | boolLit { (loc $1, BLit (boolTok $1)) }+ | strLit { (loc $1, StrLit (encodeUtf8 $ strTok $1)) } E :: { E AlexPosn } : name { Var (Nm.loc $1) $1 }- | intLit { Lit (loc $1) (ILit (int $1)) }- | floatLit { Lit (loc $1) (FLit (float $1)) }- | boolLit { Lit (loc $1) (BLit (boolTok $1)) }- | strLit { Lit (loc $1) (StrLit (encodeUtf8 $ strTok $1)) } | column { Column (loc $1) (ix $1) } | field { Field (loc $1) (ix $1) } | allColumn { AllColumn $1 } | allField { AllField $1 } | lastField { LastField $1 } | listField { FieldList $1 }+ | L { Lit (fst $1) (snd $1) } | field iParse { EApp (loc $1) (UB $2 IParse) (Field (loc $1) (ix $1)) } | field fParse { EApp (loc $1) (UB $2 FParse) (Field (loc $1) (ix $1)) } | name iParse { EApp (Nm.loc $1) (UB $2 IParse) (Var (Nm.loc $1) $1) }@@ -297,13 +315,15 @@ | E fold E E { EApp (eLoc $1) (EApp (eLoc $1) (EApp $2 (TB $2 Fold) $1) $3) $4 } | E capture E E { EApp (eLoc $1) (EApp (eLoc $1) (EApp $2 (TB $2 Captures) $1) $3) $4 } | E caret E E { EApp (eLoc $1) (EApp (eLoc $1) (EApp $2 (TB $2 Scan) $1) $3) $4 }+ | E cs E E { EApp (eLoc $1) (EApp (eLoc $1) (EApp $2 (TB $2 ScanList) $1) $3) $4 } | comma E E E { EApp $1 (EApp $1 (EApp $1 (TB $1 ZipW) $2) $3) $4 } | lbrace E rbrace braces(E) { Guarded $1 $2 $4 } | lbracePercent E rbrace braces(E) { let tl = eLoc $2 in Guarded $1 (EApp tl (EApp tl (BB tl Matches) (AllField tl)) $2) $4 } | 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) }+ | lparen sepBy(E,dot) rparen { Tup $1 (reverse $2) } | lanchor sepBy(E, dot) rparen { Anchor $1 (reverse $2) }+ | loctothorpe sepBy(Rec,semicolon) rbrace { Rec $1 (reverse $2) } | E E { EApp (eLoc $1) $1 $2 } | E doubleComma E E { EApp (eLoc $1) (EApp (eLoc $1) (EApp $2 (TB $2 Bookend) $1) $3) $4 } | tally { UB $1 Tally }@@ -332,6 +352,7 @@ | sprintf { BB $1 Sprintf } | option { TB $1 Option } | captures { TB $1 AllCaptures }+ | ices { TB $1 Ixes } | floor { UB $1 Floor } | ceil { UB $1 Ceiling } | floorSym { UB $1 Floor } | ceilSym { UB $1 Ceiling }@@ -348,8 +369,10 @@ | fp { NB $1 Fp } | parens(at) { UB (loc $1) (At $ ix $1) } | parens(select) { UB (loc $1) (Select $ field $1) }+ | parens(get) { UB (loc $1) (SelR (void $ nfield $1)) } | E at { EApp (eLoc $1) (UB (loc $2) (At $ ix $2)) $1 } | E select { EApp (eLoc $1) (UB (loc $2) (Select $ field $2)) $1 }+ | E get { EApp (eLoc $1) (UB (loc $2) (SelR (void $ nfield $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 }@@ -358,22 +381,23 @@ { type File = ([FilePath], Program AlexPosn)- type Library = ([FilePath], [D AlexPosn]) -parseError :: Token AlexPosn -> Parse a-parseError = throwError . Unexpected+type Value = T.Text +parseError :: (Token AlexPosn, [String]) -> Parse a+parseError = throwError . uncurry Unexpected+ mkLet :: a -> [(Nm a, E a)] -> E a -> E a mkLet _ [] e = e mkLet l (b:bs) e = Let l b (mkLet l bs e) -data ParseError a = Unexpected (Token a)+data ParseError a = Unexpected !(Token a) [String] | LexErr String instance Pretty a => Pretty (ParseError a) where- pretty (Unexpected tok) = pretty (loc tok) <+> "Unexpected" <+> pretty tok- pretty (LexErr str) = pretty (T.pack str)+ pretty (Unexpected tok valid) = pretty (loc tok) <+> "Unexpected" <+> pretty tok <> "." <+> "Expected one of" <+> concatWith (\x y -> x <> "," <+> y) (squotes.pretty<$>valid)+ pretty (LexErr str) = pretty (T.pack str) instance Pretty a => Show (ParseError a) where show = show . pretty@@ -382,6 +406,17 @@ type Parse = ExceptT (ParseError AlexPosn) Alex +parseThrow :: Parse a -> T.Text -> a+parseThrow p = snd.either throw id.runParse p++guess :: AlexPosn -> T.Text -> E AlexPosn+guess l v = case snd<$>runParse pValue v of+ Right e -> e+ Left {} -> Lit l (StrLit$encodeUtf8 v)++df :: T.Text -> Value -> Alex (E AlexPosn -> E AlexPosn)+df t x = do {nm <- newVarAlex t; let l=Nm.loc nm in pure (Let l (nm, guess l x))}+ parse :: T.Text -> Either (ParseError AlexPosn) File parse = fmap snd . runParse parseF @@ -389,12 +424,15 @@ parseWithMax = fmap (first fst3) . runParse parseF where fst3 (x, _, _) = x -parseWithInitCtx :: T.Text -> Either (ParseError AlexPosn) (AlexUserState, File)-parseWithInitCtx bsl = parseWithCtx bsl alexInitUserState+binds :: [(T.Text, Value)] -> Alex (E AlexPosn -> E AlexPosn)+binds = fmap thread.traverse (uncurry df) where thread = foldr (.) id -parseWithCtx :: T.Text -> AlexUserState -> Either (ParseError AlexPosn) (AlexUserState, File)-parseWithCtx = parseWithInitSt parseF+parseCli :: [(T.Text, Value)] -> Parse File+parseCli vs = lift (fmap (second.mapExpr) (binds vs)) <*> parseF +parseWithCtx :: T.Text -> [(T.Text, Value)] -> AlexUserState -> Either (ParseError AlexPosn) (AlexUserState, File)+parseWithCtx src vars = parseWithInitSt (parseCli vars) src+ parseLibWithCtx :: T.Text -> AlexUserState -> Either (ParseError AlexPosn) (AlexUserState, Library) parseLibWithCtx = parseWithInitSt parseLib @@ -403,9 +441,6 @@ parseWithInitSt :: Parse a -> T.Text -> AlexUserState -> Either (ParseError AlexPosn) (AlexUserState, a) parseWithInitSt parser str st = liftErr $ withAlexSt str st (runExceptT parser)- where liftErr (Left err) = Left (LexErr err)- liftErr (Right (_, Left err)) = Left err- liftErr (Right (i, Right x)) = Right (i, x) liftErr :: Either String (b, Either (ParseError a) c) -> Either (ParseError a) (b, c) liftErr (Left err) = Left (LexErr err)
src/Parser/Rw.hs view
@@ -2,6 +2,7 @@ import A+import Data.Bifunctor (second) rwP :: Program a -> Program a rwP (Program ds e) = Program (rwD <$> ds) (rwE e)@@ -63,12 +64,12 @@ rwE (EApp l (RwB l0 b) e') = case rwE e' of (EApp lϵ e1 e2) -> EApp l (EApp lϵ (BB l0 b) e1) e2- eϵ -> EApp l (BB l0 b) eϵ+ eϵ -> EApp l (BB l0 b) eϵ rwE (EApp l (RwT l0 t) e') = case rwE e' of (EApp lϵ (EApp lϵϵ e1 e2) e3) -> EApp l (EApp lϵ (EApp lϵϵ (TB l0 t) e1) e2) e3- (EApp lϵ e1 e2) -> EApp l (EApp lϵ (TB l0 t) e1) e2- eϵ -> EApp l (TB l0 t) eϵ+ (EApp lϵ e1 e2) -> EApp l (EApp lϵ (TB l0 t) e1) e2+ eϵ -> EApp l (TB l0 t) eϵ rwE (EApp l e0 e') = case (e0, rwE e') of (_, EApp lϵ (EApp lϵϵ e3@(BB _ op) e4) e2) | Just{} <- mFi op -> EApp l (EApp lϵϵ e3 (rwE $ EApp lϵ e0 e4)) e2@@ -88,6 +89,7 @@ rwE e@IParseAllCol{} = e rwE e@FParseAllCol{} = e rwE e@ParseAllCol{} = e+rwE F{} = error "impossible."; rwE RC{} = error "impossible." rwE (Guarded l p e) = Guarded l (rwE p) (rwE e) rwE (Implicit l e) = Implicit l (rwE e) rwE (Let l (n, e') e) = Let l (n, rwE e') (rwE e)@@ -101,6 +103,7 @@ rwE e@UB{} = e rwE e@NB{} = e rwE (Tup l es) = Tup l (rwE<$>es)+rwE (Rec l es) = Rec l (second rwE<$>es) rwE e@ResVar{} = e rwE (Paren l e) = Paren l (rwE e) rwE (Cond l p e e') = Cond l (rwE p) (rwE e) (rwE e')
src/R.hs view
@@ -8,6 +8,7 @@ ) where import A+import C import Control.Monad.State.Strict (MonadState, State, runState) import Data.Bifunctor (second) import qualified Data.IntMap as IM@@ -87,24 +88,21 @@ hasY :: E a -> Bool hasY = g where- g (ResVar _ Y) = True- g (Tup _ es) = any g es- g (OptionVal _ (Just e)) = g e- g (EApp _ e0 e1) = g e0 || g e1- g Dfn{} = error "nested dfns not yet implemented"- g (Let _ (_, be) e) = g e || g be- g (Lam _ _ e) = g e- g (Paren _ e) = g e- g (Guarded _ p e) = g p || g e- g (Implicit _ e) = g e- g (Arr _ es) = any g es- g (Anchor _ es) = any g es- g (Cond _ p e0 e1) = g e0 || g e1 || g p- g (In _ (Just e0) (Just e1) e) = g e || g e0 || g e1- g (In _ _ (Just e1) e) = g e || g e1- g (In _ (Just e0) _ e) = g e || g e0- g (In _ _ _ e) = g e- g _ = False+ g (ResVar _ Y) = True+ g (Tup _ es) = any g es+ g (Rec _ es) = any (g.snd) es+ g (OptionVal _ (Just e)) = g e+ g (EApp _ e0 e1) = g e0 || g e1+ g Dfn{} = error "nested dfns not yet implemented"+ g (Let _ (_, be) e) = g e || g be+ g (Lam _ _ e) = g e+ g (Paren _ e) = g e+ g (Guarded _ p e) = g p || g e+ g (Implicit _ e) = g e+ g (Arr _ es) = any g es+ g (Anchor _ es) = any g es+ g (Cond _ p e0 e1) = g e0 || g e1 || g p+ g _ = False replaceXY :: (a -> Nm a) -- ^ @x@ -> (a -> Nm a) -- ^ @y@@@ -129,9 +127,9 @@ r (Let l (n, be) e) = Let l (n, r be) (r e) r (Lam l n e) = Lam l n (r e) r (Cond l p e0 e1) = Cond l (r p) (r e0) (r e1)- r (In l e0 e1 e) = In l (r<$>e0) (r<$>e1) (r e) r (OptionVal l e) = OptionVal l (r<$>e) r (Tup l es) = Tup l (r<$>es)+ r (Rec l es) = Rec l (second r<$>es) r (Arr l es) = Arr l (r<$>es) r (Anchor l es) = Anchor l (r<$>es) r e@Column{} = e@@ -148,6 +146,7 @@ r e@ParseCol{} = e r (Paren l e) = Paren l (r e) r Dfn{} = error "nested dfns not yet implemented"+ r F{} = error "Internal error." replaceX :: (a -> Nm a) -> E a -> E a replaceX n = replaceXY n (error "Internal error: 'y' not expected.")@@ -163,6 +162,7 @@ rE :: (HasRenames s, MonadState s m) => E a -> m (E a) rE (EApp l e e') = EApp l <$> rE e <*> rE e' rE (Tup l es) = Tup l <$> traverse rE es+rE (Rec l es) = Rec l <$> traverse (secondM rE) es rE (Var l n) = Var l <$> replaceVar n rE (Lam l n e) = doLocal $ do n' <- freshen n
src/Ty.hs view
@@ -2,10 +2,8 @@ {-# LANGUAGE OverloadedStrings #-} module Ty ( Subst- , runTyM- , tyP- , match- , aT+ , runTyM, tyP+ , match, aT , tyOf ) where @@ -13,17 +11,20 @@ import Control.Exception (Exception, throw) import Control.Monad (zipWithM) import Control.Monad.Except (liftEither, throwError)-import Control.Monad.State.Strict (StateT, gets, modify, runState, runStateT)+import Control.Monad.State.Strict (StateT, gets, modify, runState, runStateT, state) import Data.Bifunctor (first, second) import Data.Foldable (traverse_)+import Data.Function (on) import Data.Functor (void, ($>)) import qualified Data.IntMap as IM import qualified Data.IntSet as IS+import Data.List (find) import qualified Data.Set as S import qualified Data.Text as T import Data.Typeable (Typeable) import qualified Data.Vector as V import Nm+import qualified Nm.Map as Nm import Prettyprinter (Pretty (..), squotes, (<+>)) import Ty.Const import U@@ -54,18 +55,21 @@ , varEnv :: IM.IntMap T } -mapMaxU :: (Int -> Int) -> TyState a -> TyState a-mapMaxU f (TyState u c v) = TyState (f u) c v- setMaxU :: Int -> TyState a -> TyState a setMaxU i (TyState _ c v) = TyState i c v +addCM :: Ord a => Nm b -> (C, a) -> TyM a ()+addCM tv c = modify (mapCV (addC tv c))+ mapCV :: (IM.IntMap (S.Set (C, a)) -> IM.IntMap (S.Set (C, a))) -> TyState a -> TyState a mapCV f (TyState u cvs v) = TyState u (f cvs) v addVarEnv :: Int -> T -> TyState a -> TyState a addVarEnv i ty (TyState u cvs v) = TyState u cvs (IM.insert i ty v) +addVarM :: Int -> T -> TyM a ()+addVarM i ty = modify (addVarEnv i ty)+ type TyM a = StateT (TyState a) (Either (Err a)) runTyM :: Int -> TyM a b -> Either (Err a) (b, Int)@@ -78,22 +82,31 @@ case IM.lookup i um of Just ty@TyVar{} -> aT (IM.delete i um) ty -- prevent cyclic lookups Just ty@Rho{} -> aT (IM.delete i um) ty+ Just ty@Ρ{} -> aT (IM.delete i um) ty Just ty -> aT um ty Nothing -> ty' aT um (Rho n@(Nm _ (U i) _) rs) = case IM.lookup i um of Just ty@Rho{} -> aT (IM.delete i um) ty+ Just ty@Ρ{} -> aT (IM.delete i um) ty Just ty@TyVar{} -> aT (IM.delete i um) ty Just ty -> aT um ty Nothing -> Rho n (fmap (aT um) rs)+aT um (Ρ n@(Nm _ (U i) _) rs) =+ case IM.lookup i um of+ Just ty@Ρ{} -> aT (IM.delete i um) ty+ Just ty@TyVar{} -> aT (IM.delete i um) ty+ Just ty@Rho{} -> aT (IM.delete i um) ty+ Just ty -> aT um ty+ Nothing -> Ρ n (fmap (aT um) rs) aT _ ty'@TyB{} = ty' aT um (ty:$ty') = aT um ty :$ aT um ty' aT um (TyArr ty ty') = TyArr (aT um ty) (aT um ty') aT um (TyTup tys) = TyTup (aT um <$> tys)+aT um (TyRec tys) = TyRec (aT um <$> tys) mguPrep :: l -> Subst -> T -> T -> Either (Err l) Subst-mguPrep l s t0 t1 =- let t0' = aT s t0; t1' = aT s t1 in mgu l s t0' t1'+mguPrep l s = mgu l s `on` aT s match :: T -> T -> Subst match t t' = either (throw :: Err () -> Subst) id (maM t t')@@ -115,9 +128,11 @@ occ (TyVar (Nm _ (U i) _)) = IS.singleton i occ TyB{} = IS.empty occ (TyTup ts) = foldMap occ ts+occ (TyRec ts) = foldMap occ ts occ (t:$t') = occ t <> occ t' occ (TyArr t t') = occ t <> occ t' occ (Rho (Nm _ (U i) _) rs) = IS.insert i (foldMap occ (IM.elems rs))+occ (Ρ (Nm _ (U i) _) rs) = IS.insert i (foldMap occ (Nm.elems rs)) mgu :: l -> Subst -> T -> T -> Either (Err l) Subst mgu _ s (TyB b) (TyB b') | b == b' = Right s@@ -131,10 +146,18 @@ mgu l s (TyTup ts) (TyTup ts') | length ts == length ts' = zS (mguPrep l) s ts ts' mgu l s (Rho n rs) t'@(TyTup ts) | length ts >= fst (IM.findMax rs) && fst (IM.findMin rs) > 0 = tS_ (\sϵ (i, tϵ) -> IM.insert (unU$unique n) t' <$> mguPrep l sϵ (ts!!(i-1)) tϵ) s (IM.toList rs)+mgu l s (Ρ n rs) t'@(TyRec ts) | rs `Nm.isSubmapOf` rs+ = tS_ (\sϵ (nr, tϵ) -> IM.insert (unU$unique n) t' <$> mguPrep l sϵ (ts Nm.! nr) tϵ) s (Nm.toList rs) mgu l s t@TyTup{} t'@Rho{} = mgu l s t' t+mgu l s t@TyRec{} t'@Ρ{} = mgu l s t' t+mgu l s (TyRec ts) (TyRec ts') | ts `Nm.isSubmapOf` ts' && ts' `Nm.isSubmapOf` ts+ = tS_ (\sϵ (t0,t1) -> mguPrep l sϵ t0 t1) s $ Nm.elems $ Nm.intersectionWith (,) ts ts' mgu l s (Rho n rs) (Rho n' rs') = do rss <- tS_ (\sϵ (t0,t1) -> mguPrep l sϵ t0 t1) s $ IM.elems $ IM.intersectionWith (,) rs rs' pure (IM.insert (unU$unique n) (Rho n' (rs <> rs')) rss)+mgu l s (Ρ n rs) (Ρ n' rs') = do+ rss <- tS_ (\sϵ (t0,t1) -> mguPrep l sϵ t0 t1) s $ Nm.elems $ Nm.intersectionWith (,) rs rs'+ pure (IM.insert (unU$unique n) (Ρ n' (rs <> rs')) rss) mgu l _ t t' = Left $ UF l t t' tS_ :: Monad m => (Subst -> b -> m Subst) -> Subst -> [b] -> m Subst@@ -151,15 +174,15 @@ Just ty'@TyVar{} -> Just $ aT (IM.delete k tys) ty' Just (ty0:$ty1) -> Just $ let tys'=IM.delete k tys in aT tys' ty0 :$ aT tys' ty1 Just (TyArr ty0 ty1) -> Just $ let tys'=IM.delete k tys in TyArr (aT tys' ty0) (aT tys' ty1)- Just (TyTup tysϵ) -> Just $ let tys'=IM.delete k tys in TyTup (aT tys' <$> tysϵ)+ Just (TyTup tysϵ) -> Just $ let tys'=IM.delete k tys in TyTup (aT tys'<$>tysϵ)+ Just (TyRec tysϵ) -> Just $ let tys'=IM.delete k tys in TyRec (aT tys'<$>tysϵ)+ Just ty'@Rho{} -> Just $ aT (IM.delete k tys) ty'+ Just ty'@Ρ{} -> Just $ aT (IM.delete k tys) ty' Just ty' -> Just ty' Nothing -> Nothing freshN :: T.Text -> TyM a (Nm ())-freshN n = do- st <- gets maxU- Nm n (U $ st+1) ()- <$ modify (mapMaxU (+1))+freshN n = state (\st -> let j=maxU st+1 in (Nm n (U j) (), st { maxU = j })) freshTV :: T.Text -> TyM a T freshTV=fmap var.freshN@@ -188,13 +211,15 @@ st <- gets snd case IM.lookup j st of Just k -> pure (TyVar (Nm n k l'))- Nothing -> do- k <- gets fst- let j' = U$k+1- TyVar (Nm n j' l') <$ modify (\(u, s) -> (u+1, IM.insert j j' s))+ Nothing -> state $ \(k, b) ->+ let j'=k+1; u=U j'+ in (TyVar (Nm n u l'), (j', IM.insert j u b)) cloneTyM (TyArr tyϵ ty') = TyArr <$> cloneTyM tyϵ <*> cloneTyM ty' cloneTyM (tyϵ:$ty') = (:$) <$> cloneTyM tyϵ <*> cloneTyM ty' cloneTyM (TyTup tys) = TyTup <$> traverse cloneTyM tys+ cloneTyM (TyRec tys) = TyRec <$> traverse cloneTyM tys+ cloneTyM (Rho n tys) = Rho n <$> traverse cloneTyM tys+ cloneTyM (Ρ n tys) = Ρ n <$> traverse cloneTyM tys cloneTyM tyϵ@TyB{} = pure tyϵ checkType :: Ord a => T -> (C, a) -> TyM a ()@@ -209,7 +234,9 @@ checkType (TyB TyBool) (IsEq, _) = pure () checkType (TyB TyStr) (IsEq, _) = pure () checkType (TyTup tys) (c@IsEq, l) = traverse_ (`checkType` (c, l)) tys+checkType (TyRec tys) (c@IsEq, l) = traverse_ (`checkType` (c, l)) tys checkType (Rho _ rs) (c@IsEq, l) = traverse_ (`checkType` (c, l)) (IM.elems rs)+checkType (Ρ _ rs) (c@IsEq, l) = traverse_ (`checkType` (c, l)) (Nm.elems rs) checkType (TyB TyVec:$ty) (c@IsEq, l) = checkType ty (c, l) checkType (TyB TyOption:$ty) (c@IsEq, l) = checkType ty (c, l) checkType (TyB TyI) (IsParse, _) = pure ()@@ -231,10 +258,12 @@ checkType (TyB TyI) (IsPrintf, _) = pure () checkType (TyB TyBool) (IsPrintf, _) = pure () checkType (TyTup tys) (c@IsPrintf, l) | not$any nest tys = traverse_ (`checkType` (c, l)) tys+checkType (TyRec tys) (c@IsPrintf, l) | tys' <- Nm.elems tys, not$any nest tys' = traverse_ (`checkType` (c, l)) tys' checkType (Rho _ rs) (c@IsPrintf, l) | tys <- IM.elems rs, not$any nest tys = traverse_ (`checkType` (c, l)) tys+checkType (Ρ _ rs) (c@IsPrintf, l) | tys <- Nm.elems rs, not$any nest tys = traverse_ (`checkType` (c, l)) tys checkType ty (c, l) = throwError $ Doesn'tSatisfy l ty c -nest TyTup{}=True; nest Rho{}=True; nest _=False+nest TyTup{}=True; nest TyRec{}=True; nest Rho{}=True; nest Ρ{}=True; nest _=False checkClass :: Ord a => IM.IntMap T -- ^ Unification result@@ -268,7 +297,7 @@ tyDS s (FunDecl n@(Nm _ (U i) _) [] e) = do (e', s') <- tyES s e let t=eLoc e'- modify (addVarEnv i t) $> (FunDecl (n$>t) [] e', s')+ addVarM i t $> (FunDecl (n$>t) [] e', s') tyDS _ FunDecl{} = error "Internal error. Should have been desugared by now." isAmbiguous :: T -> Bool@@ -276,8 +305,10 @@ isAmbiguous (TyArr ty ty') = isAmbiguous ty || isAmbiguous ty' isAmbiguous (ty:$ty') = isAmbiguous ty || isAmbiguous ty' isAmbiguous (TyTup tys) = any isAmbiguous tys+isAmbiguous (TyRec tys) = any isAmbiguous tys isAmbiguous TyB{} = False isAmbiguous Rho{} = True+isAmbiguous Ρ{} = True checkAmb :: E T -> TyM a () checkAmb e@(BB ty _) | isAmbiguous ty = throwError $ Ambiguous ty (void e)@@ -287,6 +318,7 @@ checkAmb (Guarded _ p e') = checkAmb p *> checkAmb e' checkAmb (EApp _ e' e'') = checkAmb e' *> checkAmb e'' -- more precise errors checkAmb (Tup _ es) = traverse_ checkAmb es+checkAmb (Rec _ es) = traverse_ (checkAmb.snd) es checkAmb e@(Arr ty _) | isAmbiguous ty = throwError $ Ambiguous ty (void e) checkAmb e@(Var ty _) | isAmbiguous ty = throwError $ Ambiguous ty (void e) checkAmb (Let _ bs e) = traverse_ checkAmb [e, snd bs]@@ -310,28 +342,28 @@ tyNumOp :: Ord a => a -> TyM a T tyNumOp l = do m <- freshN "m"- modify (mapCV (addC m (IsNum, l)))+ addCM m (IsNum, l) let m' = var m pure $ m' ~> m' ~> m' tySemiOp :: Ord a => a -> TyM a T tySemiOp l = do m <- freshN "m"- modify (mapCV (addC m (IsSemigroup, l)))+ addCM m (IsSemigroup, l) let m' = var m pure $ m' ~> m' ~> m' tyOrd :: Ord a => a -> TyM a T tyOrd l = do a <- freshN "a"- modify (mapCV (addC a (IsOrd, l)))+ addCM a (IsOrd, l) let a' = var a pure $ a' ~> a' ~> tyB tyEq :: Ord a => a -> TyM a T tyEq l = do a <- freshN "a"- modify (mapCV (addC a (IsEq, l)))+ addCM a (IsEq, l) let a' = var a pure $ a' ~> a' ~> tyB @@ -339,7 +371,7 @@ tyM :: Ord a => a -> TyM a T tyM l = do a <- freshN "a"- modify (mapCV (addC a (IsOrd, l)))+ addCM a (IsOrd, l) let a' = var a pure $ a' ~> a' ~> a' @@ -354,6 +386,7 @@ pure (fmap (aT s) e') tyES :: Ord a => Subst -> E a -> TyM a (E T, Subst)+tyES _ F{} = error "impossible." tyES s (Lit _ (BLit b)) = pure (Lit tyB (BLit b), s) tyES s (Lit _ (ILit i)) = pure (Lit tyI (ILit i), s) tyES s (Lit _ (FLit f)) = pure (Lit tyF (FLit f), s)@@ -369,8 +402,8 @@ tyES s AllColumn{} = pure (AllColumn (tyStream tyStr), s) tyES s FParseAllCol{} = pure (FParseAllCol (tyStream tyF), s) tyES s IParseAllCol{} = pure (IParseAllCol (tyStream tyI), s)-tyES s (ParseAllCol l) = do {a <- freshN "a"; modify (mapCV (addC a (IsParse, l))); pure (ParseAllCol (tyStream (var a)), s)}-tyES s (NB l MZ) = do {m <- freshN "m"; modify (mapCV (addC m (IsMonoid, l))); pure (NB (var m) MZ, s)}+tyES s (ParseAllCol l) = do {a <- freshN "a"; addCM a (IsParse, l); pure (ParseAllCol (tyStream (var a)), s)}+tyES s (NB l MZ) = do {m <- freshN "m"; addCM m (IsMonoid, l); pure (NB (var m) MZ, s)} tyES s (NB _ Ix) = pure (NB tyI Ix, s) tyES s (NB _ Fp) = pure (NB tyStr Fp, s) tyES s (NB _ Nf) = pure (NB tyI Nf, s)@@ -412,46 +445,49 @@ tyES s (UB _ Init) = do {a <- freshTV "a"; pure (UB (tyV a ~> tyV a) Init, s)} tyES s (BB _ Report) = do {a <- freshTV "a"; b <- freshTV "b"; pure (BB (tyStream a ~> b ~> TyB TyUnit) Report, s)} tyES s (UB _ TallyList) = do {a <- freshTV "a"; pure (UB (a ~> tyI) TallyList, s)}-tyES s (UB l Negate) = do {a <- freshN "a"; modify (mapCV (addC a (IsNum, l))); let a'=var a in pure (UB (tyArr a' a') Negate, s)}+tyES s (UB l Negate) = do {a <- freshN "a"; addCM a (IsNum, l); let a'=var a in pure (UB (tyArr a' a') Negate, s)} tyES s (UB _ Some) = do {a <- freshTV "a"; pure (UB (tyArr a (tyOpt a)) Some, s)} tyES s (NB _ None) = do {a <- freshTV "a"; pure (NB (tyOpt a) None, s)}-tyES s (ParseCol l i) = do {a <- freshN "a"; modify (mapCV (addC a (IsParse, l))); pure (ParseCol (tyStream (var a)) i, s)}-tyES s (UB l Parse) = do {a <- freshN "a"; modify (mapCV (addC a (IsParse, l))); pure (UB (tyStr ~> var a) Parse, s)}-tyES s (BB l Sprintf) = do {a <- freshN "a"; modify (mapCV (addC a (IsPrintf, l))); pure (BB (tyStr ~> var a ~> tyStr) Sprintf, s)}-tyES s (BB l Rein) = do {f <- freshN "f"; modify (mapCV (addC f (Foldable, l))); pure (BB (tyStr ~> (var f:$tyStr) ~> tyStr) Rein, s)}-tyES s (BB l Nier) = do {f <- freshN "f"; modify (mapCV (addC f (Foldable, l))); pure (BB ((var f:$tyStr) ~> tyStr ~> tyStr) Nier, s)}-tyES s (BB l DedupOn) = do {a <- freshTV "a"; b <- freshN "b"; modify (mapCV (addC b (IsEq, l))); let b'=var b in pure (BB (tyArr (a ~> b') (tyArr (tyStream a) (tyStream b'))) DedupOn, s)}+tyES s (ParseCol l i) = do {a <- freshN "a"; addCM a (IsParse, l); pure (ParseCol (tyStream (var a)) i, s)}+tyES s (UB l Parse) = do {a <- freshN "a"; addCM a (IsParse, l); pure (UB (tyStr ~> var a) Parse, s)}+tyES s (BB l Sprintf) = do {a <- freshN "a"; addCM a (IsPrintf, l); pure (BB (tyStr ~> var a ~> tyStr) Sprintf, s)}+tyES s (BB l Rein) = do {f <- freshN "f"; addCM f (Foldable, l); pure (BB (tyStr ~> (var f:$tyStr) ~> tyStr) Rein, s)}+tyES s (BB l Nier) = do {f <- freshN "f"; addCM f (Foldable, l); pure (BB ((var f:$tyStr) ~> tyStr ~> tyStr) Nier, s)}+tyES s (BB l DedupOn) = do {a <- freshTV "a"; b <- freshN "b"; addCM b (IsEq, l); let b'=var b in pure (BB (tyArr (a ~> b') (tyArr (tyStream a) (tyStream b'))) DedupOn, s)} tyES s (UB _ (At i)) = do {a <- freshTV "a"; pure (UB (tyV a ~> a) (At i), s)}-tyES s (UB l Dedup) = do {a <- freshN "a"; modify (mapCV (addC a (IsEq, l))); let sA=tyStream (var a) in pure (UB (sA ~> sA) Dedup, s)}+tyES s (UB l Dedup) = do {a <- freshN "a"; addCM a (IsEq, l); let sA=tyStream (var a) in pure (UB (sA ~> sA) Dedup, s)} tyES s (UB _ Const) = do {a <- freshTV "a"; b <- freshTV "b"; pure (UB (a ~> b ~> a) Const, s)}-tyES s (UB l CatMaybes) = do {a <- freshN "a"; f <- freshN "f"; modify (mapCV (addC f (Witherable, l))); let a'=var a; f'=var f in pure (UB (tyArr (f':$tyOpt a') (f':$a')) CatMaybes, s)}-tyES s (BB l Filter) = do {a <- freshN "a"; f <- freshN "f"; modify (mapCV (addC f (Witherable, l))); let a'=var a; f'=var f; w=f':$a' in pure (BB ((a' ~> tyB) ~> w ~> w) Filter, s)}+tyES s (UB l CatMaybes) = do {a <- freshN "a"; f <- freshN "f"; addCM f (Witherable, l); let a'=var a; f'=var f in pure (UB (tyArr (f':$tyOpt a') (f':$a')) CatMaybes, s)}+tyES s (BB l Filter) = do {a <- freshN "a"; f <- freshN "f"; addCM f (Witherable, l); let a'=var a; f'=var f; w=f':$a' in pure (BB ((a' ~> tyB) ~> w ~> w) Filter, s)} tyES s (UB _ (Select i)) = do ρ <- freshN "ρ"; a <- freshTV "a" pure (UB (Rho ρ (IM.singleton i a) ~> a) (Select i), s)+tyES s (UB _ (SelR n)) = do+ ρ <- freshN "ρ"; a <- freshTV "a"+ pure (UB (Ρ ρ (Nm.singleton n a) ~> a) (SelR n), s) tyES s (BB l MapMaybe) = do a <- freshTV "a"; b <- freshTV "b" f <- freshN "f"- modify (mapCV (addC f (Witherable, l)))+ addCM f (Witherable, l) let f'=var f pure (BB (tyArr (a ~> tyOpt b) ((f':$a) ~> (f':$b))) MapMaybe, s) tyES s (BB l Map) = do a <- freshTV "a"; b <- freshTV "b" f <- freshN "f" let f'=var f- modify (mapCV (addC f (Functor, l)))+ addCM f (Functor, l) pure (BB (tyArr (a ~> b) ((f':$a) ~> (f':$b))) Map, s) tyES s (TB l Fold) = do a <- freshTV "a"; b <- freshTV "b" f <- freshN "f" let f'=var f- modify (mapCV (addC f (Foldable, l)))+ addCM f (Foldable, l) pure (TB ((b ~> a ~> b) ~> (b ~> (f':$a) ~> b)) Fold, s) tyES s (BB l Fold1) = do a <- freshTV "a" f <- freshN "f" let f'=var f- modify (mapCV (addC f (Foldable, l)))+ addCM f (Foldable, l) pure (BB ((a ~> a ~> a) ~> ((f':$a) ~> a)) Fold1, s) tyES s (TB _ Bookend) = pure (TB (tyR ~> tyR ~> tyStream tyStr ~> tyStream tyStr) Bookend, s) tyES s (TB _ Captures) = pure (TB (tyStr ~> tyI ~> tyR ~> tyOpt tyStr) Captures, s)@@ -464,9 +500,13 @@ tyES s (TB _ Scan) = do a <- freshTV "a"; b <- freshTV "b" pure (TB (tyArr (b ~> a ~> b) (b ~> tyStream a ~> tyStream b)) Scan, s)+tyES s (TB _ ScanList) = do+ a <- freshTV "a"; b <- freshTV "b"+ pure (TB (tyArr (b ~> a ~> b) (b ~> tyV a ~> tyV b)) ScanList, s) tyES s (TB _ Option) = do a <- freshTV "a"; b <- freshTV "b" pure (TB (b ~> (a ~> b) ~> tyOpt a ~> b) Option, s)+tyES s (TB _ Ixes) = pure (TB (tyStr ~> tyI ~> tyR ~> tyV (TyTup [tyI, tyI])) Ixes, s) tyES s (TB _ AllCaptures) = pure (TB (tyStr ~> tyI ~> tyR ~> tyV tyStr) AllCaptures, s) tyES s (Implicit _ e) = do {(e',s') <- tyES s e; pure (Implicit (tyStream (eLoc e')) e', s')} tyES s (Guarded l e se) = do@@ -484,16 +524,22 @@ pure (EApp b' e0' e1', s3) tyES s (Lam _ n@(Nm _ (U i) _) e) = do a <- freshTV "a"- modify (addVarEnv i a)+ addVarM i a (e', s') <- tyES s e pure (Lam (a ~> eLoc e') (n$>a) e', s') tyES s (Let _ (n@(Nm _ (U i) _), eϵ) e) = do (eϵ', s0) <- tyES s eϵ let bTy=eLoc eϵ'- modify (addVarEnv i bTy)+ addVarM i bTy (e', s1) <- tyES s0 e pure (Let (eLoc e') (n$>bTy, eϵ') e', s1) tyES s (Tup _ es) = do {(es', s') <- tS tyES s es; pure (Tup (TyTup (fmap eLoc es')) es', s')}+tyES s (Rec _ es) = do+ (es', s') <- tS tyES s esϵ+ let ts=eLoc<$>es'; ns'=zipWith ($>) ns ts+ pure (Rec (TyRec (Nm.fromList (zip (void<$>ns) ts))) (zip ns' es'), s')+ where+ (ns,esϵ) = unzip es tyES s (Var _ n) = do {t <- lookupVar n; pure (Var t (n$>t), s)} tyES s (OptionVal _ (Just e)) = do {(e', s') <- tyES s e; pure (OptionVal (tyOpt (eLoc e')) (Just e'), s')} tyES s (OptionVal _ Nothing) = do {a <- freshTV "a"; pure (OptionVal (tyOpt a) Nothing, s)}
src/Ty/Const.hs view
@@ -4,15 +4,9 @@ import A --- | argument assumed to have kind 'Star'-tyStream :: T -> T-tyStream = (TyB TyStream:$)- tyB, tyI, tyF, tyStr, tyR :: T tyB=TyB TyBool; tyI=TyB TyI; tyF=TyB TyFloat; tyStr=TyB TyStr; tyR=TyB TyR -tyOpt :: T -> T-tyOpt = (TyB TyOption:$)--tyV :: T -> T-tyV = (TyB TyVec:$)+-- | argument assumed to have kind 'Star'+tyOpt, tyV, tyStream :: T -> T+tyOpt = (TyB TyOption:$); tyStream = (TyB TyStream:$); tyV = (TyB TyVec:$)
src/U.hs view
@@ -1,3 +1,3 @@ module U ( U (..) ) where -newtype U = U { unU :: Int } deriving (Eq, Ord)+newtype U = U { unU :: Int } deriving (Eq)
− x/Main.hs
@@ -1,122 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Main (main) where--import A (Mode (..))-import qualified Data.Text as T-import qualified Data.Text.IO as TIO-import qualified Data.Version as V-import File-import Options.Applicative-import qualified Paths_jacinda as P--data Command = TypeCheck !FilePath ![FilePath]- | Run !FilePath !(Maybe T.Text) !(Maybe T.Text) !(Maybe FilePath) ![FilePath]- | Expr !T.Text !(Maybe FilePath) !(Maybe T.Text) !Bool !Bool !Bool !(Maybe T.Text) ![FilePath]- | Eval !T.Text--jacFile :: Parser FilePath-jacFile = argument str- (metavar "JACFILE"- <> help "Source code"- <> jacCompletions)--csv :: Parser Bool-csv = switch- (long "csv"- <> help "Process as CSV")--asv :: Parser Bool-asv = switch- (long "asv"- <> help "Process as ASV")--usv :: Parser Bool-usv = switch- (long "usv"- <> short 'u'- <> help "Process as USV")--jacRs :: Parser (Maybe T.Text)-jacRs = optional $ option str- (short 'R'- <> metavar "REGEXP"- <> help "Record separator")--jacFs :: Parser (Maybe T.Text)-jacFs = optional $ option str- (short 'F'- <> metavar "REGEXP"- <> help "Field separator")--jacExpr :: Parser T.Text-jacExpr = argument str- (metavar "EXPR"- <> help "Jacinda expression")--inpFile :: Parser (Maybe FilePath)-inpFile = optional $ option str- (short 'i'- <> metavar "DATAFILE"- <> help "Data file")--jacCompletions :: HasCompleter f => Mod f a-jacCompletions = completer . bashCompleter $ "file -X '!*.jac' -o plusdirs"--commandP :: Parser Command-commandP = hsubparser- (command "tc" (info tcP (progDesc "Type-check file"))- <> command "e" (info eP (progDesc "Evaluate an expression (no file context)"))- <> command "run" (info runP (progDesc "Run from file")))- <|> exprP- where- tcP = TypeCheck <$> jacFile <*> includes- runP = Run <$> jacFile <*> jacFs <*> jacRs <*> inpFile <*> includes- exprP = Expr <$> jacExpr <*> inpFile <*> jacFs <*> asv <*> usv <*> csv <*> jacRs <*> includes- eP = Eval <$> jacExpr--includes :: Parser [FilePath]-includes = many $ strOption- (metavar "DIR"- <> long "include"- <> short 'I'- <> dirCompletions)--dirCompletions :: HasCompleter f => Mod f a-dirCompletions = completer . bashCompleter $ "directory"---wrapper :: ParserInfo Command-wrapper = info (helper <*> versionMod <*> commandP)- (fullDesc- <> progDesc "Jacinda language for functional stream processing, filtering, and reports"- <> header "Jacinda - a functional complement to AWK")--versionMod :: Parser (a -> a)-versionMod = infoOption (V.showVersion P.version) (short 'V' <> long "version" <> help "Show version")--main :: IO ()-main = run =<< execParser wrapper--ap :: Bool -> Bool -> Bool -> Maybe T.Text -> Maybe T.Text -> Mode-ap True True _ _ _ = errorWithoutStackTrace "--asv and --usv both specified."-ap True _ True _ _ = errorWithoutStackTrace "--asv and --csv both specified."-ap _ True True _ _ = errorWithoutStackTrace "--usv and --csv both specified."-ap _ True _ Just{} _ = errorWithoutStackTrace "--usv and field separator both speficied."-ap _ True _ _ Just{} = errorWithoutStackTrace "--usv and record separator both speficied."-ap True _ _ Just{} _ = errorWithoutStackTrace "--asv and field separator both speficied."-ap True _ _ _ Just{} = errorWithoutStackTrace "--asv and record separator both speficied."-ap _ _ True Just{} _ = errorWithoutStackTrace "--csv and field separator both speficied."-ap _ _ True _ Just{} = errorWithoutStackTrace "--csv and record separator both speficied."-ap _ _ True Nothing Nothing = CSV-ap True _ _ Nothing Nothing = AWK (Just "\\x1f") (Just "\\x1e")-ap _ True _ Nothing Nothing = AWK (Just "␟") (Just "␞")-ap _ _ _ fs rs = AWK fs rs--run :: Command -> IO ()-run (TypeCheck fp is) = tcIO is =<< TIO.readFile fp-run (Run fp fs rs Nothing is) = do { contents <- TIO.readFile fp ; runStdin is contents (AWK fs rs) }-run (Run fp fs rs (Just dat) is) = do { contents <- TIO.readFile fp ; runOnFile is contents (AWK fs rs) dat }-run (Expr eb Nothing fs a u c rs is) = let m = ap a u c fs rs in runStdin is eb m-run (Expr eb (Just fp) fs a u c rs is) = let m = ap a u c fs rs in runOnFile is eb m fp-run (Eval e) = print (exprEval e)
+ x/Opt.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import A (Mode (..))+import Control.Applicative ((<|>))+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import qualified Data.Version as V+import File+import Options.Applicative (HasCompleter, Mod, Parser, argument, bashCompleter, command, completer, execParser, fullDesc, header, help, helper, hsubparser, info,+ infoOption, long, many, metavar, option, optional, progDesc, short, str, strOption, switch)+import Parser (Value)+import qualified Paths_jacinda as P++data Cmd = TC !FilePath ![FilePath]+ | Run !FilePath !(Maybe T.Text) !(Maybe T.Text) !(Maybe FilePath) ![FilePath] ![(T.Text, Value)]+ | Expr !T.Text !(Maybe FilePath) !(Maybe T.Text) !Bool !Bool !Bool !(Maybe T.Text) ![FilePath]+ | Eval !T.Text+ | Install++kv :: T.Text -> (T.Text, Value)+kv inp = case T.splitOn "=" inp of+ [k,v] -> (k, v)+ _ -> error "Values specified on the command-line must be of the form -Dvar=value"++defVar :: Parser [(T.Text, Value)]+defVar = many $ fmap kv (option str+ (short 'D'+ <> metavar "VALUE"+ <> help "Pass a value on the command-line"))++jacFile :: Parser FilePath+jacFile = argument str+ (metavar "JACFILE"+ <> help "Source code"+ <> jacCompletions)++csv, asv, usv :: Parser Bool+csv = switch+ (long "csv"+ <> help "Process as CSV")++asv = switch+ (long "asv"+ <> help "Process as ASV")++usv = switch+ (long "usv"+ <> short 'u'+ <> help "Process as USV")++jacRs, jacFs :: Parser (Maybe T.Text)+jacRs = optional $ option str+ (short 'R'+ <> metavar "REGEXP"+ <> help "Record separator")++jacFs = optional $ option str+ (short 'F'+ <> metavar "REGEXP"+ <> help "Field separator")++jacExpr :: Parser T.Text+jacExpr = argument str+ (metavar "EXPR"+ <> help "Jacinda expression")++inpFile :: Parser (Maybe FilePath)+inpFile = optional $ option str+ (short 'i'+ <> metavar "DATAFILE"+ <> help "Data file")++jacCompletions, dirCompletions :: HasCompleter f => Mod f a+jacCompletions = completer . bashCompleter $ "file -X '!*.jac' -o plusdirs"+dirCompletions = completer . bashCompleter $ "directory"++commandP :: Parser Cmd+commandP = hsubparser+ (command "tc" (info tcP (progDesc "Type-check file"))+ <> command "e" (info eP (progDesc "Evaluate an expression (no file context)"))+ <> command "run" (info runP (progDesc "Run from file"))+ <> command "install-dir" (info (pure Install) (progDesc "Show directory for bundled libraries")))+ <|> exprP+ where+ tcP = TC <$> jacFile <*> includes+ runP = Run <$> jacFile <*> jacFs <*> jacRs <*> inpFile <*> includes <*> defVar+ exprP = Expr <$> jacExpr <*> inpFile <*> jacFs <*> asv <*> usv <*> csv <*> jacRs <*> includes+ eP = Eval <$> jacExpr++includes :: Parser [FilePath]+includes = many $ strOption+ (metavar "DIR"+ <> long "include"+ <> short 'I'+ <> dirCompletions)++wrapper = info (helper <*> versionMod <*> commandP)+ (fullDesc+ <> progDesc "Jacinda language for functional stream processing, filtering, and reports"+ <> header "Jacinda - a functional complement to AWK")++versionMod :: Parser (a -> a)+versionMod = infoOption (V.showVersion P.version) (short 'V' <> long "version" <> help "Show version")++main :: IO ()+main = run =<< execParser wrapper++ap :: Bool -> Bool -> Bool -> Maybe T.Text -> Maybe T.Text -> Mode+ap True True _ _ _ = errorWithoutStackTrace "--asv and --usv both specified."+ap True _ True _ _ = errorWithoutStackTrace "--asv and --csv both specified."+ap _ True True _ _ = errorWithoutStackTrace "--usv and --csv both specified."+ap _ True _ Just{} _ = errorWithoutStackTrace "--usv and field separator both speficied."+ap _ True _ _ Just{} = errorWithoutStackTrace "--usv and record separator both speficied."+ap True _ _ Just{} _ = errorWithoutStackTrace "--asv and field separator both speficied."+ap True _ _ _ Just{} = errorWithoutStackTrace "--asv and record separator both speficied."+ap _ _ True Just{} _ = errorWithoutStackTrace "--csv and field separator both speficied."+ap _ _ True _ Just{} = errorWithoutStackTrace "--csv and record separator both speficied."+ap _ _ True Nothing Nothing = CSV+ap True _ _ Nothing Nothing = AWK (Just "\\x1f") (Just "\\x1e")+ap _ True _ Nothing Nothing = AWK (Just "␟") (Just "␞")+ap _ _ _ fs rs = AWK fs rs++run :: Cmd -> IO ()+run (TC fp is) = tcIO is =<< TIO.readFile fp+run (Run fp fs rs Nothing is vs) = do { contents <- TIO.readFile fp ; runStdin is contents vs (AWK fs rs) }+run (Run fp fs rs (Just dat) is vs) = do { contents <- TIO.readFile fp ; runOnFile is contents vs (AWK fs rs) dat }+run (Expr eb Nothing fs a u c rs is) = let m = ap a u c fs rs in runStdin is eb [] m+run (Expr eb (Just fp) fs a u c rs is) = let m = ap a u c fs rs in runOnFile is eb [] m fp+run (Eval e) = print (exprEval e)+run Install = putStrLn =<< P.getDataDir