jacinda 3.1.0.1 → 3.1.1.0
raw patch · 18 files changed
+242/−207 lines, 18 filesdep −recursion
Dependencies removed: recursion
Files
- CHANGELOG.md +6/−1
- bench/Bench.hs +3/−1
- examples/hsExtensions.jac +1/−3
- examples/path2.jac +1/−3
- examples/slow.jac +1/−0
- examples/tagsex.jac +0/−12
- jacinda.cabal +1/−2
- man/ja.1 +3/−0
- src/A.hs +15/−49
- src/File.hs +36/−12
- src/Jacinda/Backend/T.hs +11/−7
- src/L.x +13/−13
- src/Parser.y +4/−0
- src/Parser/Rw.hs +52/−49
- src/R.hs +59/−24
- src/Ty.hs +32/−28
- src/Ty/Const.hs +3/−3
- test/examples/bookend.jac +1/−0
CHANGELOG.md view
@@ -1,3 +1,8 @@+# 3.1.1.0++ * Add `reintercalate` builtin+ * Save a few hundred μs by not using recursion schemes+ # 3.1.0.1 * Fix package description (.cabal)@@ -6,7 +11,7 @@ * Add support for CSV via the `--csv` flag and `:set csv` * Add `~?` (maybe match)- + # 3.0.2.0 * Fix list indexing
bench/Bench.hs view
@@ -12,7 +12,9 @@ main :: IO () main = defaultMain [ bgroup "eval"- [ bench "exprEval" $ nf exprEval "[x+' '+y]|'' split '01-23-1987' /-/" ]+ [ bench "exprEval" $ nf exprEval "[x+' '+y]|'' split '01-23-1987' /-/"+ , bench "exprEval" $ nf exprEval "reintercalate ' ' (split '01-23-1987' /-/)"+ ] , bgroup "csv" [ bench "succdiff" $ nfIO (silence $ runOnFile [] "~.{ix>1}{`8}" CSV "bench/data/food-prices.csv") ] , bgroup "stream"
examples/hsExtensions.jac view
@@ -1,9 +1,7 @@-@include'lib/string.jac'- fn findExtensions(line) := let val extStr ≔ line ~* 1 /\{-#\s*LANGUAGE\s*(.*)#-\}/ val extList ≔ (\s.split s /,\s*/)"extStr in extList end; -~.(λx.(intercalate'\n')¨(findExtensions x)):?$0+~.(λx.(reintercalate'\n')¨(findExtensions x)):?$0
examples/path2.jac view
@@ -1,8 +1,6 @@ {. echo $PATH | ja run examples/path.jac -@include'lib/string.jac'- fn path(x) :=- intercalate '\n' (splitc x ':');+ reintercalate '\n' (splitc x ':'); path¨$0
+ examples/slow.jac view
@@ -0,0 +1,1 @@+(+)|> ([x+'\n'+y]|>)¨{|captures `0 1 /-lHS([A-Aa-z][A-Za-z0-9\-]*\d+(\.\d+)*)/}
− examples/tagsex.jac
@@ -1,12 +0,0 @@-fn mkEx(s) :=- '/^' + s + '$/;';--{. TODO: insert \zs at precise identifier! https://stackoverflow.com/a/31089753/11296354--fn processStr(s) :=- let- val line := split s /[ \(:]+/- val outLine := sprintf '%s\t%s\t%s' (line.3 . fp . mkEx s)- in outLine end;--processStr¨{%/fn +[[:lower:]][[:latin:]]*.*:=/}{`0}
jacinda.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: jacinda-version: 3.1.0.1+version: 3.1.1.0 license: AGPL-3.0-only license-file: COPYING maintainer: vamchale@gmail.com@@ -89,7 +89,6 @@ filepath, microlens-mtl >=0.1.8.0, vector >=0.12.2.0,- recursion >=1.0.0.0, split, deepseq, lazy-csv
man/ja.1 view
@@ -140,6 +140,9 @@ \f[B]\[ti]?\f[R] Maybe match: return string if it is a match, otherwise None Str \-> Regex \-> Option Str .TP+\f[B]\[at]\f[R] Intercalate+List Str \-> Str \-> Str+.TP \f[B]\[ti]*\f[R] Match, returning nth capture group Str \-> Int \-> Regex \-> Option Str .TP
src/A.hs view
@@ -11,12 +11,9 @@ , Mode (..) , mapExpr , getS, flushD- -- * Base functors- , EF (..) ) where import Control.DeepSeq (NFData)-import Control.Recursion (Base, Corecursive, Recursive) import qualified Data.ByteString as BS import qualified Data.IntMap as IM import Data.List (foldl')@@ -32,10 +29,8 @@ infixr 6 <#> infixr 6 <##> -(<#>) :: Doc a -> Doc a -> Doc a+(<#>), (<##>) :: Doc a -> Doc a -> Doc a (<#>) x y = x <> hardline <> y--(<##>) :: Doc a -> Doc a -> Doc a (<##>) x y = x <> hardline <> hardline <> y data TB = TyI | TyFloat | TyStr@@ -49,8 +44,8 @@ tupledBy :: Doc ann -> [Doc ann] -> Doc ann tupledBy sep = group . encloseSep (flatAlt "( " "(") (flatAlt " )" ")") sep -jacTup :: Pretty a => [a] -> Doc ann-jacTup = tupledBy " . " . fmap pretty+j'Tup :: Pretty a => [a] -> Doc ann+j'Tup = tupledBy " . " . fmap pretty infixr 0 ~> @@ -60,8 +55,8 @@ infixr 0 :$ data T = TyB { tyBuiltin :: TB }- | (:$) { tyApp0 :: T, tyApp1 :: T }- | TyArr { tyArr0 :: T, tyArr1 :: T }+ | (:$) { tyApp0, tyApp1 :: T }+ | TyArr { tyArr0, tyArr1 :: T } | TyVar { tyVar :: Nm () } | TyTup { tyTups :: [T] } | Rho { tyRho :: Nm (), tyArms :: IM.IntMap T }@@ -79,7 +74,7 @@ pretty (ty:$ty') = pretty ty <+> pretty ty' pretty (TyVar n) = pretty n pretty (TyArr ty ty') = pretty ty <+> "⟶" <+> pretty ty'- pretty (TyTup tys) = jacTup tys+ pretty (TyTup tys) = j'Tup tys pretty (Rho n fs) = braces (pretty n <+> pipe <+> prettyFields (IM.toList fs)) parensp True=parens; parensp False=id@@ -92,7 +87,7 @@ data BUn = Tally -- length of string field | Const | Not -- ^ Boolean- | At Int | Select Int+ | At !Int | Select !Int | IParse | FParse | Parse | Floor | Ceiling | Some@@ -158,6 +153,7 @@ | Match | Sprintf | Report | Take | Drop+ | Rein | Nier deriving (Eq) instance Pretty BBin where@@ -169,7 +165,8 @@ pretty Split = "split"; pretty Splitc = "splitc"; pretty Sprintf = "sprintf" pretty Match = "match"; pretty MapMaybe = ":?"; pretty Fold1 = "|>" pretty Exp = "**"; pretty DedupOn = "~.*"; pretty Report = "$>"- pretty Take = "take#"; pretty Drop = "drop#"+ pretty Take = "take#"; pretty Drop = "drop#"; pretty Rein = "reintercalate"+ pretty Nier = "@@" data DfnVar = X | Y deriving (Eq) @@ -191,8 +188,8 @@ | IParseAllCol { eLoc :: a } -- ^ @$0@, parsed as an integer | FParseAllCol { eLoc :: a } -- ^ @$0@, parsed as a float | ParseAllCol { eLoc :: a }- | EApp { eLoc :: a, eApp0 :: E a, eApp1 :: E a }- | Guarded { eLoc :: a, eP :: E a, eGuarded :: E a }+ | EApp { eLoc :: a, eApp0, eApp1 :: E a }+ | Guarded { eLoc :: a, eP, eGuarded :: E a } | Implicit { eLoc :: a, eImplicit :: E a } | Let { eLoc :: a, eBind :: (Nm a, E a), eE :: E a } -- TODO: literals type (make pattern matching easier down the road)@@ -207,46 +204,15 @@ | Tup { eLoc :: a, esTup :: [E a] } | ResVar { eLoc :: a, dfnVar :: DfnVar } | RC RurePtr -- compiled regex after normalization- | Arr { eLoc :: a, elems :: V.Vector (E a) }+ | Arr { eLoc :: a, elems :: !(V.Vector (E a)) } | Anchor { eLoc :: a, eAnchored :: [E a] } | Paren { eLoc :: a, eExpr :: E a } | OptionVal { eLoc :: a, eMaybe :: Maybe (E a) }- | Cond { eLoc :: a, eIf :: E a, eThen :: E a, eElse :: 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) -instance Recursive (E a) where-instance Corecursive (E a) where--data EF a x = ColumnF a Int- | IParseColF a Int | FParseColF a Int | ParseColF a Int- | FieldF a Int | LastFieldF a | FieldListF a | AllFieldF a- | AllColumnF a | IParseAllColF a | FParseAllColF a | ParseAllColF a- | EAppF a x x- | GuardedF a x x | ImplicitF a x- | LetF a (Nm a, x) x- | VarF a (Nm a)- | FF (Nm a)- | LitF a !L- | RegexLitF a BS.ByteString- | LamF a (Nm a) x- | DfnF a x- | BBF a BBin | TBF a BTer | UBF a BUn | NBF a N- | TupF a [x]- | ResVarF a DfnVar- | RCF RurePtr- | ArrF a (V.Vector x)- | AnchorF a [x]- | ParenF a x- | OptionValF a (Maybe x)- | CondF a x x x- | InF x (Maybe x) (Maybe x) x- | RwBF a BBin | RwTF a BTer- deriving (Generic, Functor)--type instance Base (E a) = (EF a)- instance Pretty N where pretty Ix="⍳"; pretty Nf="nf"; pretty None="None"; pretty Fp="fp"; pretty MZ="⍬" @@ -331,7 +297,7 @@ ps _ (RwT _ Scan) = "scan" ps _ (RwB _ Fold1) = "fold1" ps _ (Cond _ e0 e1 e2) = "?" <> pretty e0 <> ";" <+> pretty e1 <> ";" <+> pretty e2- ps _ (Tup _ es) = jacTup es+ ps _ (Tup _ es) = j'Tup 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"
src/File.hs view
@@ -12,7 +12,6 @@ import Control.Exception (Exception, throw, throwIO) import Control.Monad.IO.Class (liftIO) import Control.Monad.State.Strict (StateT, get, put, runState, runStateT)-import Control.Recursion (cata, embed) import Data.Bifunctor (second) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL@@ -40,8 +39,8 @@ csvCtx :: BSL.ByteString -> [LineCtx] csvCtx = go Nothing . parseCSV where- go _ [] = []- go _ (Left err:_) = error (show err)+ go _ [] = []+ go _ (Left err:_) = error (show err) -- TODO: re-csv it? go (Just n) (Right r:rs) = let fs=mB<$>r in (fold fs, V.fromListN n fs, fromIntegral (line r)):go (Just n) rs go Nothing (Right r:rs) = let fs=mB<$>r; n=length fs in (fold fs, V.fromListN n fs, fromIntegral (line r)):go (Just n) rs@@ -85,10 +84,35 @@ compileR :: FileBS -> E T -> E T-compileR fp = cata a where- a (RegexLitF _ rrϵ) = RC (compileDefault rrϵ)- a (NBF _ Fp) = mkStr fp- a x = embed x+compileR fp = r where+ r (RegexLit _ rrϵ) = RC (compileDefault rrϵ)+ r (NB _ Fp) = mkStr fp+ r e@Var{} = e+ r e@UB{} = e+ r e@NB{} = e+ r e@Lit{} = e+ r e@TB{} = e+ r e@BB{} = e+ r (Cond l p e0 e1) = Cond l (r p) (r e0) (r e1)+ r (OptionVal l e) = OptionVal l (r<$>e)+ r (EApp l e0 e1) = EApp l (r e0) (r e1)+ r e@Column{} = e+ r e@IParseCol{} = e+ r e@FParseCol{} = e+ r e@ParseCol{} = e+ r e@LastField{} = e+ r e@Field{} = e+ r e@FieldList{} = e+ r e@AllField{} = e+ r e@AllColumn{} = e+ r (Guarded l p e) = Guarded l (r p) (r e)+ r (Implicit l e) = Implicit l (r e)+ 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 (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) exprEval :: T.Text -> E T exprEval src =@@ -114,18 +138,18 @@ (typed, i) <- yIO $ runTyM m (tyP ast) let (eI, j) = ib i typed m'Throw $ cF eI- let ~(AWK afs ars) = getS ast- (e', k) = runState (eta eI) j+ let (e', k) = runState (eta eI) j cont=run (flushD typed) k (compileR (encodeUtf8 $ T.pack fp) e')- case mode of- AWK cliFS cliRS ->+ case (mode, getS ast) of+ (AWK cliFS cliRS, AWK afs ars) -> let r=compileFS (cliFS <|> afs) bs=case cliRS <|> ars of Nothing -> fmap BSL.toStrict (ASCIIL.lines contents) Just rs -> lazySplit (tcompile rs) contents ctxs=zipWith (\ ~(x,y) z -> (x,y,z)) [(b, splitBy r b) | b <- bs] [1..] in cont ctxs- CSV -> let ctxs = csvCtx contents in cont ctxs+ (CSV, _) -> let ctxs = csvCtx contents in cont ctxs+ (_, CSV) -> let ctxs = csvCtx contents in cont ctxs runStdin :: [FilePath] -> T.Text -- ^ Program
src/Jacinda/Backend/T.hs view
@@ -47,9 +47,8 @@ instance Exception StreamError where --- TODO: dedup... tracking env! type Env = IM.IntMap (Maybe (E T)); type I=Int-data Σ = Σ !I Env (IM.IntMap (S.Set BS.ByteString)) (IM.IntMap IS.IntSet) (IM.IntMap (S.Set Double)) IS.IntSet+data Σ = Σ !I !Env (IM.IntMap (S.Set BS.ByteString)) (IM.IntMap IS.IntSet) (IM.IntMap (S.Set Double)) IS.IntSet type Tmp = Int type Β = IM.IntMap (E T) @@ -101,7 +100,7 @@ t <- nI (iEnv, μ) <- ctx e t u <- nI- let outs=μ<$>ctxs; es=scanl' (&) (Σ u iEnv IM.empty IM.empty IM.empty IS.empty) outs+ let outs=μ<$>ctxs; es={-# SCC "scanMain" #-} scanl' (&) (Σ u iEnv IM.empty IM.empty IM.empty IS.empty) outs pure ((! t).gE<$>es) run _ j e ctxs = pDocLn $ flip evalState j $ do (iEnv, g, e0) <- collect e@@ -182,6 +181,7 @@ let g=wF op t tgt pure (env<>iEnv, (g.).f) +{-# SCC κ #-} κ :: E T -> LineCtx -> E T κ AllField{} ~(b, _, _) = mkStr b κ (Field _ i) ~(_, bs, _) = mkStr $ bs `at` i@@ -384,12 +384,10 @@ pure $ Arr ty (V.init (asV x')) (EApp _ (UB _ Tally) e) @> b = do e' <- e@>b- let r=fromIntegral (BS.length$asS e')- pure (mkI r)+ pure $ let r=fromIntegral (BS.length$asS e') in mkI r (EApp _ (UB _ TallyList) e) @> b = do e' <- e@>b- let r=fromIntegral (V.length$asV e')- pure (mkI r)+ pure $ let r=fromIntegral (V.length$asV e') in mkI r (EApp _ (EApp _ (BB _ Sprintf) fs) s) @> b = do fs' <- fs@>b; s' <- s@>b pure (mkStr (sprintf (asS fs') s'))@@ -433,6 +431,9 @@ (EApp _ (EApp _ (EApp _ (TB _ Fold) op) seed) xs) @> b | TyB TyVec:$_ <- eLoc xs = do seed' <- seed@>b; xs' <- xs@>b V.foldM (a2e b op) seed' (asV xs')+(EApp _ (EApp _ (BB _ 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 _ (EApp _ (BB _ Fold1) op) xs) @> b | TyB TyVec:$_ <- eLoc xs = do xs' <- xs@>b let xsV=asV xs'@@ -488,6 +489,7 @@ Just y -> case asM y of {Nothing -> IM.insert tgt Nothing env; Just yϵ -> IM.insert tgt (Just$!yϵ) env} Nothing -> IM.insert tgt Nothing env) d di df b +{-# SCC wMM #-} wMM :: E T -> Tmp -> Tmp -> Σ -> Σ wMM (Lam _ n e) src tgt (Σ j env d di df b) = let xϵ=env!src@@ -588,6 +590,7 @@ where r0=asR e0; r1=asR e1 +{-# SCC wD #-} wD :: TB -> Int -> Tmp -> Tmp -> Σ -> Σ wD TyStr key src tgt (Σ i env d di df b) = let x=env!src@@ -653,6 +656,7 @@ (Just{}, Nothing) -> Σ j (IM.insert tgt Nothing env)) d di df b wΠ e _ _ _ _ = throw $ InternalArityOrEta 2 e +{-# SCC wF #-} wF :: E T -> Tmp -> Tmp -> Σ -> Σ wF (Lam _ nacc (Lam _ nn e)) src tgt (Σ j env d di df b) = let accϵ = env!tgt; xϵ = env!src
src/L.x view
@@ -133,6 +133,7 @@ "`*" { mkSym LastFieldTok } "`$" { mkSym FieldListTok } \? { mkSym QuestionMark }+ "@@" { mkSym AmpAmp } in { mkKw KwIn } let { mkKw KwLet }@@ -184,6 +185,7 @@ "init#" { mkBuiltin BuiltinInit } "take#" { mkBuiltin BuiltinTake } "drop#" { mkBuiltin BuiltinDrop }+ reintercalate { mkBuiltin BuiltinRein } ":i" { mkBuiltin BuiltinIParse } ":f" { mkBuiltin BuiltinFParse }@@ -298,8 +300,8 @@ | CatMaybesTok | MapMaybeTok | CapTok | NegTok- | LastFieldTok- | FieldListTok+ | LastFieldTok | FieldListTok+ | AmpAmp instance Pretty Sym where pretty PlusTok = "+"@@ -358,6 +360,7 @@ pretty FieldListTok = "`$" pretty IceCreamCone = "$>" pretty QuestionMark = "?"+ pretty AmpAmp = "@@" data Keyword = KwLet | KwIn@@ -378,25 +381,20 @@ | VarMin | VarMax instance Pretty Var where- pretty VarX = "x"- pretty VarY = "y"- pretty VarFs = "fs"- pretty VarRs = "rs"- pretty VarOrs = "ors"- pretty VarOfs = "ofs"- pretty VarIx = "⍳"- pretty VarNf = "nf"- pretty VarMin = "min"- pretty VarMax = "max"+ pretty VarX = "x"; pretty VarY = "y"+ pretty VarFs = "fs"; pretty VarRs = "rs"+ pretty VarOrs = "ors"; pretty VarOfs = "ofs"+ pretty VarMin = "min"; pretty VarMax = "max"+ pretty VarIx = "⍳"; pretty VarNf = "nf" instance Pretty Keyword where pretty KwLet = "let" pretty KwIn = "in" pretty KwVal = "val" pretty KwEnd = "end"+ pretty KwFn = "fn" pretty KwSet = ":set" pretty KwFlush = ":flush"- pretty KwFn = "fn" pretty KwInclude = "@include" pretty KwIf = "if" pretty KwThen = "then"@@ -424,6 +422,7 @@ | BuiltinHead | BuiltinTail | BuiltinInit | BuiltinLast | BuiltinDrop | BuiltinTake+ | BuiltinRein instance Pretty Builtin where pretty BuiltinIParse = ":i"@@ -454,6 +453,7 @@ pretty BuiltinLast = "last#" pretty BuiltinTake = "take#" pretty BuiltinDrop = "drop#"+ pretty BuiltinRein = "reintercalate" data Token a = EOF { loc :: a } | TokSym { loc :: a, _sym :: Sym }
src/Parser.y view
@@ -78,6 +78,7 @@ fold { TokSym $$ FoldTok } fold1 { TokSym $$ Fold1Tok } caret { TokSym $$ Caret }+ amp { TokSym $$ AmpAmp } z { TokSym $$ Zilde } quot { TokSym $$ Quot } mapMaybe { TokSym $$ MapMaybeTok }@@ -164,6 +165,7 @@ last { TokBuiltin $$ BuiltinLast } take { TokBuiltin $$ BuiltinTake } drop { TokBuiltin $$ BuiltinDrop }+ rein { TokBuiltin $$ BuiltinRein } iParse { TokBuiltin $$ BuiltinIParse } fParse { TokBuiltin $$ BuiltinFParse }@@ -214,6 +216,7 @@ | exp { Exp } | dedupon { DedupOn } | report { Report }+ | amp { Nier } Bind :: { (Nm AlexPosn, E AlexPosn) } : val name defEq E { ($2, $4) }@@ -313,6 +316,7 @@ | rr { RegexLit (loc $1) (encodeUtf8 $ rr $1) } | min { BB $1 Min } | max { BB $1 Max } | drop { BB $1 Drop } | take { BB $1 Take }+ | rein { BB $1 Rein } | mapMaybeL { RwB $1 MapMaybe } | dedupOnL { RwB $1 DedupOn } | filterL { RwB $1 Filter }
src/Parser/Rw.hs view
@@ -1,11 +1,7 @@-module Parser.Rw ( rwP- , rwD- , rwE- ) where+module Parser.Rw ( rwP, rwD, rwE ) where import A-import Control.Recursion (cata, embed) rwP :: Program a -> Program a rwP (Program ds e) = Program (rwD <$> ds) (rwE e)@@ -42,53 +38,60 @@ mFi Match = Nothing mFi Drop = Nothing mFi Take = Nothing+mFi Rein = Nothing mFi Prior = Just 5 mFi DedupOn = Just 5 mFi Report = Just 4 -isPre :: BUn -> Bool-isPre At{} = False-isPre Select{} = False-isPre IParse = False-isPre FParse = False-isPre Parse = False-isPre _ = True+pPre :: BUn -> Bool+pPre Dedup = True+pPre Not = True+pPre TallyList = True+pPre Tally = True+pPre _ = False +-- FIXME: prefix-not should extend over vars...+ rwE :: E a -> E a-rwE = cata a where- a (EAppF l e0@(UB _ op) (EApp lϵ (EApp lϵϵ e1@(BB _ bop) e2) e3))- | Just{} <- mFi bop- , isPre op && op /= Dedup- = EApp l (EApp lϵ e1 (EApp lϵϵ e0 e2)) e3- a (EAppF l e0@(EApp _ (BB _ op0) _) (EApp l1 (EApp l2 e1@(BB _ op1) e2) e3))- | Just f0 <- mFi op0- , Just f1 <- mFi op1- , f0 > f1- = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3- a (EAppF l e0@Var{} (EApp lϵ (EApp lϵϵ e1 e2) e3)) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3- -- TODO rewrite dfn- a (EAppF l e0@Var{} (EApp l0 e1 (EApp l1 (EApp l2 op@BB{} e2) e3))) = EApp l1 (EApp l2 op (EApp l (EApp l0 e0 e1) e2)) e3- a (EAppF l e0@Var{} (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2- a (EAppF l e0@(BB _ op) (EApp lϵ e1 e2)) | Nothing <- mFi op = EApp l (EApp lϵ e0 e1) e2- a (EAppF l e0@(TB _ Sub1) (EApp lϵ (EApp lϵϵ e1 e2) e3)) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3- a (EAppF l e0@(TB _ Sub1) (EApp lϵ e1 (EApp lϵϵ e2 e3))) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3- a (EAppF l e0@(TB _ Sub1) (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2- a (EAppF l e0@(TB _ Subs) (EApp lϵ (EApp lϵϵ e1 e2) e3)) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3- a (EAppF l e0@(TB _ Subs) (EApp lϵ e1 (EApp lϵϵ e2 e3))) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3- a (EAppF l e0@(TB _ Subs) (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2- a (EAppF l e0@(TB _ Substr) (EApp lϵ (EApp lϵϵ e1 e2) e3)) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3- a (EAppF l e0@(TB _ Substr) (EApp lϵ e1 (EApp lϵϵ e2 e3))) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3- a (EAppF l e0@(TB _ Substr) (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2- a (EAppF l e0@(TB _ Option) (EApp lϵ (EApp lϵϵ e1 e2) e3)) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3- a (EAppF l e0@(TB _ Option) (EApp lϵ e1 (EApp lϵϵ e2 e3))) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3- a (EAppF l e0@(TB _ Option) (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2- a (EAppF l e0@(TB _ Captures) (EApp lϵ (EApp lϵϵ e1 e2) e3)) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3- a (EAppF l e0@(TB _ Captures) (EApp lϵ e1 (EApp lϵϵ e2 e3))) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3- a (EAppF l e0@(TB _ Captures) (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2- a (EAppF l e0@(TB _ AllCaptures) (EApp lϵ (EApp lϵϵ e1 e2) e3)) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3- a (EAppF l e0@(TB _ AllCaptures) (EApp lϵ e1 (EApp lϵϵ e2 e3))) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3- a (EAppF l e0@(TB _ AllCaptures) (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2- a (EAppF l (RwB l0 b) (EApp lϵ e1 e2)) = EApp l (EApp lϵ (BB l0 b) e1) e2- a (EAppF l (RwT l0 t) (EApp lϵ (EApp lϵϵ e1 e2) e3)) = EApp l (EApp lϵ (EApp lϵϵ (TB l0 t) e1) e2) e3- a (EAppF l (RwT l0 t) (EApp lϵ e1 (EApp lϵϵ e2 e3))) = EApp l (EApp lϵ (EApp lϵϵ (TB l0 t) e1) e2) e3- a x = embed x+rwE (EApp l0 (EApp l1 (EApp l2 ho@TB{} e3) e2) e1) =+ (EApp l0 (EApp l1 (EApp l2 ho (rwE e3)) (rwE e2)) (rwE e1))+rwE (EApp l0 (EApp l1 e0@(BB _ op0) e1) e2) | Just fi <- mFi op0 =+ case rwE e2 of+ (EApp l2 (EApp l3 e3@(BB _ op1) e4) e5) | Just fi' <- mFi op1, fi > fi' -> EApp l0 (EApp l1 e3 (rwE (EApp l2 (EApp l3 e0 e1) e4))) e5+ e2' -> EApp l0 (EApp l1 e0 (rwE e1)) e2'+rwE (EApp l op@(UB _ Dedup) e) = EApp l op (rwE 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+ (UB _ f, e2) | pPre f -> EApp l e0 e2+ (_, EApp lϵ e1@EApp{} e2) -> EApp l (rwE $ EApp lϵ e0 e1) e2+ (_, EApp lϵ e1 e2) -> EApp l (EApp lϵ (rwE e0) e1) e2+ (_, eRw) -> EApp l (rwE e0) eRw+rwE e@Column{} = e+rwE e@IParseCol{} = e+rwE e@FParseCol{} = e+rwE e@ParseCol{} = e+rwE e@Field{} = e+rwE e@LastField{} = e+rwE e@FieldList{} = e+rwE e@AllField{} = e+rwE e@AllColumn{} = e+rwE e@IParseAllCol{} = e+rwE e@FParseAllCol{} = e+rwE e@ParseAllCol{} = e+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)+rwE e@Var{} = e+rwE e@Lit{} = e+rwE e@RegexLit{} = e+rwE (Lam l n e) = Lam l n (rwE e)+rwE (Dfn l e) = Dfn l (rwE e)+rwE e@BB{} = e+rwE e@TB{} = e+rwE e@UB{} = e+rwE e@NB{} = e+rwE (Tup l es) = Tup l (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
@@ -9,7 +9,6 @@ import A import Control.Monad.State.Strict (MonadState, State, runState)-import Control.Recursion (cata, embed) import Data.Bifunctor (second) import qualified Data.IntMap as IM import qualified Data.Text as T@@ -35,7 +34,7 @@ type RenameM = State Renames rP :: Int -> Program a -> (Program a, Int)-rP i = runRM i . renameProgram+rP i = runRM i.renameProgram runRM :: Int -> RenameM x -> (x, Int) runRM i act = second max_ (runState act (Rs i IM.empty))@@ -87,35 +86,71 @@ mkLam ns e = foldr (\n -> Lam (loc n) n) e ns hasY :: E a -> Bool-hasY = cata a where- a (ResVarF _ Y) = True- a (TupF _ es) = or es- a (EAppF _ e e') = e || e'- a (LamF _ _ e) = e- a DfnF{} = error "Not supported yet."- a (LetF _ b e) = e || snd b- a (GuardedF _ p b) = b || p- a (ImplicitF _ e) = e- a (ParenF _ e) = e- a (ArrF _ es) = or es- a (AnchorF _ es) = or es- a (OptionValF _ (Just e)) = e- a (CondF _ p e e') = p || e || e'- a _ = False+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 replaceXY :: (a -> Nm a) -- ^ @x@ -> (a -> Nm a) -- ^ @y@ -> E a -> E a-replaceXY nX nY = cata a where- a (ResVarF l X) = Var l (nX l)- a (ResVarF l Y) = Var l (nY l)- a x = embed x+replaceXY nX nY = r where+ r (ResVar l Y) = Var l (nY l)+ r (ResVar l X) = Var l (nX l)+ r e@Lit{} = e+ r e@RegexLit{} = e+ r e@RC{} = e+ r e@Var{} = e+ r e@NB{} = e+ r e@UB{} = e+ r e@BB{} = e+ r e@RwB{} = e+ r e@RwT{} = e+ r e@TB{} = e+ r (EApp l e0 e1) = EApp l (r e0) (r e1)+ r (Implicit l e) = Implicit l (r e)+ r (Guarded l p e) = Guarded l (r p) (r e)+ 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 (Arr l es) = Arr l (r<$>es)+ r (Anchor l es) = Anchor l (r<$>es)+ r e@Column{} = e+ r e@AllColumn{} = e+ r e@Field{} = e+ r e@AllField{} = e+ r e@LastField{} = e+ r e@FieldList{} = e+ r e@FParseAllCol{} = e+ r e@IParseAllCol{} = e+ r e@ParseAllCol{} = e+ r e@FParseCol{} = e+ r e@IParseCol{} = e+ r e@ParseCol{} = e+ r (Paren l e) = Paren l (r e)+ r Dfn{} = error "nested dfns not yet implemented" replaceX :: (a -> Nm a) -> E a -> E a-replaceX n = cata a where- a (ResVarF l X) = Var l (n l)- a x = embed x+replaceX n = replaceXY n (error "Internal error: 'y' not expected.") renameD :: D a -> RenameM (D a) renameD (FunDecl n ns e) = FunDecl n [] <$> rE (mkLam ns e)
src/Ty.hs view
@@ -6,7 +6,6 @@ , tyP , match , aT- -- * For debugging , tyOf ) where @@ -159,6 +158,9 @@ Nm n (U $ st+1) () <$ modify (mapMaxU (+1)) +freshTV :: T.Text -> TyM a T+freshTV=fmap var.freshN+ addC :: Ord a => Nm b -> (C, a) -> IM.IntMap (S.Set (C, a)) -> IM.IntMap (S.Set (C, a)) addC (Nm _ (U i) _) c = IM.alter (Just . go) i where go Nothing = S.singleton c@@ -249,7 +251,7 @@ Nothing -> throwError $ IllScoped l n tyOf :: Ord a => E a -> TyM a T-tyOf = fmap eLoc . tyE+tyOf = fmap eLoc.tyE tyDS :: Ord a => Subst -> D a -> TyM a (D T, Subst) tyDS s (SetFS bs) = pure (SetFS bs, s)@@ -386,8 +388,8 @@ tyES s (BB _ NotMatches) = pure (BB (tyStr ~> tyR ~> tyB) NotMatches, s) tyES s (BB _ MMatch) = pure (BB (tyStr ~> tyR ~> tyOpt tyStr) MMatch, s) tyES s (UB _ Tally) = pure (UB (tyStr ~> tyI) Tally, s)-tyES s (BB _ Take) = do {a <- var<$>freshN "a"; pure (BB (tyI ~> tyV a ~> tyV a) Take, s)}-tyES s (BB _ Drop) = do {a <- var<$>freshN "a"; pure (BB (tyI ~> tyV a ~> tyV a) Drop, s)}+tyES s (BB _ Take) = do {a <- freshTV "a"; pure (BB (tyI ~> tyV a ~> tyV a) Take, s)}+tyES s (BB _ Drop) = do {a <- freshTV "a"; pure (BB (tyI ~> tyV a ~> tyV a) Drop, s)} tyES s (BB _ Div) = pure (BB (tyF ~> tyF ~> tyF) Div, s) tyES s (UB _ Not) = pure (UB (tyB ~> tyB) Not, s) tyES s (BB _ And) = pure (BB (tyB ~> tyB ~> tyB) And, s)@@ -400,47 +402,49 @@ tyES s (UB _ FParse) = pure (UB (tyArr tyStr tyF) FParse, s) tyES s (UB _ Floor) = pure (UB (tyArr tyF tyI) Floor, s) tyES s (UB _ Ceiling) = pure (UB (tyF ~> tyI) Ceiling, s)-tyES s (UB _ Head) = do {a <- var<$>freshN "a"; pure (UB (tyV a ~> a) Head, s)}-tyES s (UB _ Tail) = do {a <- var<$>freshN "a"; pure (UB (tyV a ~> tyV a) Tail, s)}-tyES s (UB _ Last) = do {a <- var<$>freshN "a"; pure (UB (tyV a ~> a) Last, s)}-tyES s (UB _ Init) = do {a <- var<$>freshN "a"; pure (UB (tyV a ~> tyV a) Init, s)}-tyES s (BB _ Report) = do {a <- var <$> freshN "a"; b <- var <$> freshN "b"; pure (BB (tyStream a ~> b ~> TyB TyUnit) Report, s)}-tyES s (UB _ TallyList) = do {a <- var <$> freshN "a"; pure (UB (a ~> tyI) TallyList, s)}+tyES s (UB _ Head) = do {a <- freshTV "a"; pure (UB (tyV a ~> a) Head, s)}+tyES s (UB _ Tail) = do {a <- freshTV "a"; pure (UB (tyV a ~> tyV a) Tail, s)}+tyES s (UB _ Last) = do {a <- freshTV "a"; pure (UB (tyV a ~> a) Last, s)}+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 _ Some) = do {a <- var <$> freshN "a"; pure (UB (tyArr a (tyOpt a)) Some, s)}-tyES s (NB _ None) = do {a <- freshN "a"; pure (NB (tyOpt (var a)) None, s)}+tyES s (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 DedupOn) = do {a <- var <$> freshN "a"; b <- freshN "b"; modify (mapCV (addC b (IsEq, l))); let b'=var b in pure (BB (tyArr (a ~> b') (tyArr (tyStream a) (tyStream b'))) DedupOn, s)}-tyES s (UB _ (At i)) = do {a <- var <$> freshN "a"; pure (UB (tyV a ~> a) (At i), 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 (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 _ Const) = do {a <- var <$> freshN "a"; b <- var <$> freshN "b"; pure (UB (a ~> b ~> a) Const, 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 _ (Select i)) = do- ρ <- freshN "ρ"; a <- var <$> freshN "a"+ ρ <- freshN "ρ"; a <- freshTV "a" pure (UB (Rho ρ (IM.singleton i a) ~> a) (Select i), s) tyES s (BB l MapMaybe) = do- a <- var <$> freshN "a"; b <- var <$> freshN "b"+ a <- freshTV "a"; b <- freshTV "b" f <- freshN "f" modify (mapCV (addC 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 <- var <$> freshN "a"; b <- var <$> freshN "b"+ a <- freshTV "a"; b <- freshTV "b" f <- freshN "f" let f'=var f modify (mapCV (addC f (Functor, l))) pure (BB (tyArr (a ~> b) ((f':$a) ~> (f':$b))) Map, s) tyES s (TB l Fold) = do- a <- var <$> freshN "a"; b <- var <$> freshN "b"+ a <- freshTV "a"; b <- freshTV "b" f <- freshN "f" let f'=var f modify (mapCV (addC f (Foldable, l))) pure (TB ((b ~> a ~> b) ~> (b ~> (f':$a) ~> b)) Fold, s) tyES s (BB l Fold1) = do- a <- var <$> freshN "a"+ a <- freshTV "a" f <- freshN "f" let f'=var f modify (mapCV (addC f (Foldable, l)))@@ -448,16 +452,16 @@ tyES s (TB _ Bookend) = pure (TB (tyR ~> tyR ~> tyStream tyStr ~> tyStream tyStr) Bookend, s) tyES s (TB _ Captures) = pure (TB (tyStr ~> tyI ~> tyR ~> tyOpt tyStr) Captures, s) tyES s (BB _ Prior) = do- a <- var <$> freshN "a"; b <- var <$> freshN "b"+ a <- freshTV "a"; b <- freshTV "b" pure (BB (tyArr (a ~> a ~> b) (tyStream a ~> tyStream b)) Prior, s) tyES s (TB _ ZipW) = do- a <- var <$> freshN "a"; b <- var <$> freshN "b"; c <- var <$> freshN "c"+ a <- freshTV "a"; b <- freshTV "b"; c <- freshTV "c" pure (TB (tyArr (a ~> b ~> c) (tyStream a ~> tyStream b ~> tyStream c)) ZipW, s) tyES s (TB _ Scan) = do- a <- var <$> freshN "a"; b <- var <$> freshN "b"+ a <- freshTV "a"; b <- freshTV "b" pure (TB (tyArr (b ~> a ~> b) (b ~> tyStream a ~> tyStream b)) Scan, s) tyES s (TB _ Option) = do- a <- var <$> freshN "a"; b <- var <$> freshN "b"+ a <- freshTV "a"; b <- freshTV "b" pure (TB (b ~> (a ~> b) ~> tyOpt a ~> b) Option, s) tyES s (TB _ AllCaptures) = pure (TB (tyStr ~> tyI ~> tyR ~> tyV tyStr) AllCaptures, s) tyES s (Implicit _ e) = do {(e',s') <- tyES s e; pure (Implicit (tyStream (eLoc e')) e', s')}@@ -475,7 +479,7 @@ s3 <- liftEither $ mguPrep l s2 (eLoc e1') a' pure (EApp b' e0' e1', s3) tyES s (Lam _ n@(Nm _ (U i) _) e) = do- a <- var <$> freshN "a"+ a <- freshTV "a" modify (addVarEnv i a) (e', s') <- tyES s e pure (Lam (a ~> eLoc e') (n$>a) e', s')@@ -488,9 +492,9 @@ tyES s (Tup _ es) = do {(es', s') <- tS tyES s es; pure (Tup (TyTup (fmap eLoc es')) es', s')} 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 <- var <$> freshN "a"; pure (OptionVal (tyOpt a) Nothing, s)}+tyES s (OptionVal _ Nothing) = do {a <- freshTV "a"; pure (OptionVal (tyOpt a) Nothing, s)} tyES s (Arr l v) | V.null v = do- a <- var <$> freshN "a"+ a <- freshTV "a" pure (Arr (tyV a) V.empty, s) | otherwise = do (v',s0) <- tS tyES s (V.toList v)@@ -506,7 +510,7 @@ s4 <- liftEither $ mguPrep l s3 t (eLoc e1') pure (Cond t p' e0' e1', s4) tyES s (Anchor l es) = do- (es', s') <- tS (\sϵ e -> do {(e',s0) <- tyES sϵ e; a <- var <$> freshN "a"; s1 <- liftEither $ mguPrep l s0 (tyStream a) (eLoc e'); pure (e', s1)}) s es+ (es', s') <- tS (\sϵ e -> do {(e',s0) <- tyES sϵ e; a <- freshTV "a"; s1 <- liftEither $ mguPrep l s0 (tyStream a) (eLoc e'); pure (e', s1)}) s es pure (Anchor (TyB TyUnit) es', s') tyES _ RC{} = error "Regex should not be compiled at this stage." tyES _ Dfn{} = desugar; tyES _ ResVar{} = desugar; tyES _ Paren{} = desugar
src/Ty/Const.hs view
@@ -6,13 +6,13 @@ -- | argument assumed to have kind 'Star' tyStream :: T -> T-tyStream = (TyB TyStream :$)+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 :$)+tyOpt = (TyB TyOption:$) tyV :: T -> T-tyV = (TyB TyVec :$)+tyV = (TyB TyVec:$)
+ test/examples/bookend.jac view
@@ -0,0 +1,1 @@+/Disassembly of section \.text:/,,/Disassembly of section/$0