jacinda 1.2.0.0 → 2.0.0.0
raw patch · 63 files changed
+3155/−3712 lines, 63 filesdep ~arraydep ~bytestringdep ~containers
Dependency ranges changed: array, bytestring, containers, criterion, deepseq, directory, filepath, microlens, microlens-mtl, mtl, optparse-applicative, prettyprinter, recursion, regex-rure, silently, split, tasty, tasty-hunit, text, transformers, vector
Files
- CHANGELOG.md +7/−0
- README.md +2/−12
- app/Main.hs +14/−15
- bench/Bench.hs +10/−13
- doc/guide.pdf binary
- examples/chess.jac +0/−6
- examples/diffctx.jac +1/−1
- examples/extensions.jac +10/−0
- examples/fdupes.jac +10/−0
- examples/hsExtensions.jac +1/−1
- examples/laconicPragmas.jac +3/−0
- examples/liblibversion.jac +3/−0
- examples/libversion.jac +1/−3
- examples/nmCtx.jac +1/−1
- examples/path.jac +1/−1
- examples/path2.jac +1/−1
- examples/pathx.jac +1/−1
- examples/silly.jac +0/−7
- examples/tags.jac +1/−1
- jacinda.cabal +26/−22
- lib/gitCtx.jac +22/−0
- man/ja.1 +30/−17
- prelude/fn.jac +0/−3
- src/A.hs +424/−0
- src/A/E.hs +74/−0
- src/A/I.hs +109/−0
- src/Data/List/Ext.hs +0/−13
- src/Data/Vector/Ext.hs +0/−7
- src/File.hs +139/−0
- src/Include.hs +36/−0
- src/Intern/Name.hs +0/−30
- src/Intern/Unique.hs +0/−5
- src/Jacinda/AST.hs +0/−460
- src/Jacinda/Backend/Const.hs +17/−0
- src/Jacinda/Backend/Normalize.hs +0/−483
- src/Jacinda/Backend/P.hs +453/−0
- src/Jacinda/Backend/Parse.hs +12/−0
- src/Jacinda/Backend/Printf.hs +4/−13
- src/Jacinda/Backend/TreeWalk.hs +0/−591
- src/Jacinda/Check/Field.hs +42/−0
- src/Jacinda/File.hs +0/−136
- src/Jacinda/Fuse.hs +62/−0
- src/Jacinda/Include.hs +0/−37
- src/Jacinda/Lexer.x +0/−487
- src/Jacinda/Parser.y +0/−354
- src/Jacinda/Parser/Rewrite.hs +0/−60
- src/Jacinda/Regex.hs +7/−7
- src/Jacinda/Rename.hs +0/−161
- src/Jacinda/Ty.hs +0/−684
- src/Jacinda/Ty/Const.hs +0/−42
- src/L.x +482/−0
- src/Nm.hs +32/−0
- src/Parser.y +360/−0
- src/Parser/Rw.hs +59/−0
- src/R.hs +152/−0
- src/Ty.hs +485/−0
- src/Ty/Const.hs +18/−0
- src/U.hs +3/−0
- test/Spec.hs +32/−31
- test/examples/evenOdd.jac +3/−6
- test/examples/polymorphic.jac +2/−0
- test/examples/sillyPragmas.jac +2/−0
- test/examples/sillyPragmas2.jac +1/−0
CHANGELOG.md view
@@ -1,3 +1,10 @@+# 2.0.0.0++ * Scrap `HasField` typeclass; add row types+ * Expressions with multiple folds no longer blow up memory (🤞)+ * Fix many bugs+ * Unicode syntax works from command-line+ # 1.2.0.0 * `~`, `!~` builtins require that the regex be the second argument.
README.md view
@@ -19,9 +19,9 @@ cabal install jacinda ``` -## Vim Plugin+## Editor Support -There is a [vim plugin](https://github.com/vmchale/jacinda-vim).+There is a [vim plugin](https://github.com/vmchale/jacinda-vim) and a [VSCode extension](https://marketplace.visualstudio.com/items?itemName=vmchale.jacinda). # SHOCK & AWE @@ -59,23 +59,13 @@ # Status -The project is in beta, it doesn't necessarily work and there are many-missing features, but the language will remain stable.--It is worse than awk but it has its place and it avoids some of the painful-imperative/scoping defects.- ## Missing Features & Bugs * No nested dfns- * Obscure renamer edge cases during evaluation- * `printf` formatting for floats * No list literal syntax- * Typeclasses are not documented * Postfix `:f` and `:i` are handled poorly * Polymorphic functions can't be instantiated with separate types (global monomorphism restriction)- * Expressions with multiple folds blow up in memory sometimes Intentionally missing features:
app/Main.hs view
@@ -1,18 +1,18 @@ module Main (main) where -import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BSL-import Data.Semigroup ((<>))-import qualified Data.Version as V-import Jacinda.File+import Data.Semigroup ((<>))+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import qualified Data.Version as V+import File import Options.Applicative-import qualified Paths_jacinda as P-import System.IO (stdin)+import qualified Paths_jacinda as P+import System.IO (stdin) data Command = TypeCheck !FilePath ![FilePath] | Run !FilePath !(Maybe FilePath) ![FilePath]- | Expr !BSL.ByteString !(Maybe FilePath) !(Maybe BS.ByteString) ![FilePath]- | Eval !BSL.ByteString+ | Expr !T.Text !(Maybe FilePath) !(Maybe T.Text) ![FilePath]+ | Eval !T.Text jacFile :: Parser FilePath jacFile = argument str@@ -20,14 +20,13 @@ <> help "Source code" <> jacCompletions) -jacFs :: Parser (Maybe BS.ByteString)+jacFs :: Parser (Maybe T.Text) jacFs = optional $ option str (short 'F' <> metavar "REGEXP" <> help "Field separator") --- FIXME: this seems to mishandle iota on the command-line..-jacExpr :: Parser BSL.ByteString+jacExpr :: Parser T.Text jacExpr = argument str (metavar "EXPR" <> help "Jacinda expression")@@ -77,9 +76,9 @@ main = run =<< execParser wrapper run :: Command -> IO ()-run (TypeCheck fp is) = tcIO is =<< BSL.readFile fp-run (Run fp Nothing is) = do { contents <- BSL.readFile fp ; runOnHandle is contents Nothing stdin }-run (Run fp (Just dat) is) = do { contents <- BSL.readFile fp ; runOnFile is contents Nothing dat }+run (TypeCheck fp is) = tcIO is =<< TIO.readFile fp+run (Run fp Nothing is) = do { contents <- TIO.readFile fp ; runOnHandle is contents Nothing stdin }+run (Run fp (Just dat) is) = do { contents <- TIO.readFile fp ; runOnFile is contents Nothing dat } run (Expr eb Nothing fs is) = runOnHandle is eb fs stdin run (Expr eb (Just fp) fs is) = runOnFile is eb fs fp run (Eval e) = print (exprEval e)
bench/Bench.hs view
@@ -2,28 +2,25 @@ module Main (main) where -import Control.DeepSeq (NFData (..))+import A+import Control.DeepSeq (NFData (..)) import Criterion.Main-import qualified Data.ByteString.Lazy as BSL-import Jacinda.AST-import Jacinda.File-import System.IO.Silently (silence)+import qualified Data.Text.IO as TIO+import File+import System.IO.Silently (silence) main :: IO () main = defaultMain [ bgroup "eval" [ bench "exprEval" $ nf exprEval "[x+' '+y]|'' split '01-23-1987' /-/" , bench "runOnFile" $ nfIO (silence $ runOnFile [] "(+)|0 {%/Bloom/}{1}" Nothing "bench/data/ulysses.txt")- , bench "runOnFile" $ nfIO (silence $ do { contents <- BSL.readFile "examples/wc.jac" ; runOnFile [] contents Nothing "bench/data/ulysses.txt" })- , bench "runOnFile" $ nfIO (silence $ do { contents <- BSL.readFile "examples/span2.jac" ; runOnFile [] contents Nothing "bench/data/span.txt" })+ , bench "runOnFile" $ nfIO (silence $ do { contents <- TIO.readFile "examples/wc.jac" ; runOnFile [] contents Nothing "bench/data/ulysses.txt" })+ , bench "runOnFile" $ nfIO (silence $ do { contents <- TIO.readFile "examples/span2.jac" ; runOnFile [] contents Nothing "bench/data/span.txt" }) ] ] instance NFData (E a) where- rnf (StrLit _ str) = rnf str- rnf (IntLit _ i) = rnf i- rnf (BoolLit _ b) = rnf b- rnf (FloatLit _ f) = rnf f- rnf (Arr _ es) = rnf es- rnf (Tup _ es) = rnf es+ rnf (StrLit _ str) = rnf str; rnf (ILit _ i) = rnf i;+ rnf (BLit _ b) = rnf b; rnf (FLit _ f) = rnf f+ rnf (Arr _ es) = rnf es; rnf (Tup _ es) = rnf es rnf (OptionVal _ e) = rnf e
doc/guide.pdf view
binary file changed (198278 → 205361 bytes)
examples/chess.jac view
@@ -1,9 +1,3 @@-{. fn sum(x) :=- {. (+)|0 x;--{. fn count(x) :=- {. sum [:1"x;- fn count(x) ≔ (+)|0 [:1"x;
examples/diffctx.jac view
@@ -17,7 +17,7 @@ fn process(x) := let val fpCtx ≔ fromMaybe 'WARN' (x->1)- val line ≔ (λl. sprintf'%s: %s' (fpCtx.l))"(x->2)+ val line ≔ (λl. sprintf'%s: %s' (fpCtx.l))¨(x->2) in line end; process:?(step/(\+|-).*TODO/)^(None.None)$0
+ examples/extensions.jac view
@@ -0,0 +1,10 @@+{. shows extensions used + total line count+{. invoke like so:+{. fd '\.hs$' -x ja run extensions.jac -i | sort -k2 -n+fn count(x):=+ (+)|0 [:1"x;++let+ val ext := count {%/^\s*\{-#\s*LANGUAGE\s*(.*)#-\}/}{`0}+ val tot := count $0+in sprintf '%s\t%i\t%i' (fp.ext.tot) end
+ examples/fdupes.jac view
@@ -0,0 +1,10 @@+{. invoke like so:+{. fd . -t f -x md5sum | sort | ja run fdupes.jac+{. inspired by Yann Le Du: https://twitter.com/Yann_Le_Du/status/1610299070819729410++fn step(acc, this) :=+ if (substr this 0 32) = (substr (acc->1) 0 32)+ then (this . Some (this + '\n' + acc->1))+ else (this . None);++(->2):?step^(''.None) $0
examples/hsExtensions.jac view
@@ -6,4 +6,4 @@ val extList ≔ (\s.split s /,\s*/)"extStr in extList end; -~.(λx.(intercalate'\n')"(findExtensions x)):?$0+~.(λx.(intercalate'\n')¨(findExtensions x)):?$0
+ examples/laconicPragmas.jac view
@@ -0,0 +1,3 @@+let+ val list := [x+', '+y]|>[x ~* 1 /\{-#\s*LANGUAGE\s*([^\s]*)\s*#-\}/]:?$0+in sprintf '{-# LANGUAGE %s -#}' list end
+ examples/liblibversion.jac view
@@ -0,0 +1,3 @@+@include'lib/string.jac'++(+)|'' (intercalate '\n')¨{% /-lHS/}{captures `0 1 /-lHS([A-Aa-z][A-Za-z0-9\-]*\d+(\.\d+)*)/}
examples/libversion.jac view
@@ -1,3 +1,1 @@-@include'lib/string.jac'--(+)|'' (intercalate '\n')"{% /-lHS/}{captures `0 1 /-lHS([A-Aa-z][A-Za-z0-9\-]*\d+(\.\d+)*)/}+(+)|> ([x+'\n'+y]|>)¨{%/-lHS/}{captures `0 1 /-lHS([A-Aa-z][A-Za-z0-9\-]*\d+(\.\d+)*)/}
examples/nmCtx.jac view
@@ -17,7 +17,7 @@ fn process(x) := let val fpCtx := fromMaybe 'WARN' (x->1)- val line := (λl. sprintf'%s: %s' (fpCtx.l))"(x->2)+ val line := (λl. sprintf'%s: %s' (fpCtx.l))¨(x->2) in line end; process:?step^(None.None)$0
examples/path.jac view
@@ -2,4 +2,4 @@ fn path(x) := ([x+'\n'+y]) |> (splitc x ':'); -path"$0+path¨$0
examples/path2.jac view
@@ -5,4 +5,4 @@ fn path(x) := intercalate '\n' (splitc x ':'); -path"$0+path¨$0
examples/pathx.jac view
@@ -2,4 +2,4 @@ fn path(x) := ([x+'\n'+y]) |> (splitc x ':'); -path"$0+path¨$0
− examples/silly.jac
@@ -1,7 +0,0 @@-fn count(x):=- (+)|0 [:1"x;--let- val ext := count {%/\{-#\s*LANGUAGE\s*(.*)#-\}/}{`0}- val tot := count $0-in (ext.tot) end
examples/tags.jac view
@@ -7,4 +7,4 @@ val outLine := sprintf '%s\t%s\t%s' (line.2 . fp . mkEx s) in outLine end; -processStr"{%/fn +[[:lower:]][[:latin:]]*.*:=/}{`0}+processStr¨{%/fn +[[:lower:]][[:latin:]]*.*:=/}{`0}
jacinda.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: jacinda-version: 1.2.0.0+version: 2.0.0.0 license: AGPL-3 license-file: COPYING maintainer: vamchale@gmail.com@@ -35,31 +35,34 @@ library jacinda-lib exposed-modules:- Jacinda.Parser- Jacinda.Parser.Rewrite- Jacinda.AST- Jacinda.Ty- Jacinda.Ty.Const+ Parser+ Parser.Rw+ A+ Ty+ Ty.Const Jacinda.Regex- Jacinda.File+ File hs-source-dirs: src other-modules:- Jacinda.Lexer- Intern.Name- Intern.Unique- Jacinda.Rename- Jacinda.Backend.Normalize- Jacinda.Backend.TreeWalk+ A.I+ A.E+ L+ Jacinda.Fuse+ Nm+ U+ R+ Jacinda.Check.Field+ Jacinda.Backend.Parse+ Jacinda.Backend.Const+ Jacinda.Backend.P Jacinda.Backend.Printf- Jacinda.Include- Data.List.Ext- Data.Vector.Ext+ Include Paths_jacinda autogen-modules: Paths_jacinda default-language: Haskell2010- ghc-options: -Wall -O2+ ghc-options: -Wall -O2 -Wno-missing-signatures build-depends: base >=4.10.0.0 && <5, bytestring >=0.11.0.0,@@ -79,7 +82,7 @@ split if !flag(cross)- build-tool-depends: alex:alex, happy:happy+ build-tool-depends: alex:alex >=3.4.0.0, happy:happy if impl(ghc >=8.0) ghc-options:@@ -106,7 +109,7 @@ base, jacinda-lib, optparse-applicative >=0.13.0.0,- bytestring+ text if impl(ghc >=8.0) ghc-options:@@ -132,8 +135,9 @@ base, jacinda-lib, tasty,- tasty-hunit,- bytestring+ bytestring,+ text,+ tasty-hunit if impl(ghc >=8.0) ghc-options:@@ -160,7 +164,7 @@ criterion, jacinda-lib, deepseq,- bytestring,+ text, silently if impl(ghc >=8.0)
+ lib/gitCtx.jac view
@@ -0,0 +1,22 @@+@include'prelude/fn.jac'+@include'lib/maybe.jac'++fn mMatch(p, str) :=+ if p str+ then Some str+ else None;++fn step(p, ctx, line) :=+ let+ val fpCtx ≔ line ~* 1 /diff --git\s+([^\s]+)/+ val mLine ≔ mMatch p line+ in (alternative (ctx->1) fpCtx.mLine) end;++fn process(x) :=+ let+ val fpCtx ≔ fromMaybe 'WARN' (x->1)+ val line ≔ (λl. sprintf'%s: %s' (fpCtx.l))"(x->2)+ in line end;++fn main(p) :=+ process:?(step p)^(None.None)$0;
man/ja.1 view
@@ -1,4 +1,4 @@-.\" Automatically generated by Pandoc 2.19.2+.\" Automatically generated by Pandoc 3.1.6.1 .\" .\" Define V font for inline verbatim, using C font in formats .\" that render this, and otherwise B font.@@ -30,7 +30,7 @@ ja e \[aq]11.67*1.2\[cq] .SH DESCRIPTION .PP-\f[B]Jacinda\f[R] is a data stream processing language \[`a] la AWK.+\f[B]Jacinda\f[R] is a data stream processing language à la AWK. .SH SUBCOMMANDS .PP \f[B]run\f[R] - Run a program from file@@ -78,7 +78,7 @@ \f[B]\[ha]\f[R] Ternary operator: scan (b -> a -> b) -> b -> Stream a -> Stream b .TP-\f[B]\[dq]\f[R] Binary operator: map+\f[B]\[dq]\f[R], \f[B]¨\f[R] Binary operator: map Functor f :=> a -> b -> f a -> f b .TP \f[B][:\f[R] Unary operator: const@@ -91,11 +91,16 @@ (a -> a -> b) -> Stream a -> Stream b .TP \f[B]\[ti].\f[R] Unary deduplication (stream)-Eq a :=> Stream a -> Stream a-.PP+Ord a :=> Stream a -> Stream a+.TP+\f[B]\[ti].*\f[R] Deduplicate on (stream)+Ord b :=> (a -> b) -> Stream a -> Stream a+.TP \f[B]max\f[R] Maximum of two values-.PP+Ord a :=> a -> a -> a+.TP \f[B]min\f[R] Minimum of two values+Ord a :=> a -> a -> a .PP \f[B]&\f[R] Boolean and .PP@@ -109,7 +114,7 @@ \f[B]!\[ti]\f[R] Does not match Str -> Regex -> Bool .PP-\f[B]ix\f[R] Line number+\f[B]ix\f[R], \f[B]⍳\f[R] Line number .TP \f[B]substr\f[R] Extract substring Str -> Int -> Int -> Str@@ -120,17 +125,17 @@ \f[B]splitc\f[R] Split a string on a single character Str -> Str -> List Str .TP-\f[B]|.\f[R] Floor function+\f[B]⌊\f[R], \f[B]|.\f[R] Floor function Float -> Int .TP-\f[B]|\[ga]\f[R] Ceiling function+\f[B]⌈\f[R], \f[B]|\[ga]\f[R] Ceiling function Float -> Int .PP \f[B]-.\f[R] Unary negate-.PP-\f[B]sprintf\f[R] Convert an expression to a string using the format-string .TP+\f[B]sprintf\f[R] Convert an expression to a string using the format string+\f[B]%f\f[R] float \f[B]%i\f[R] integer \f[B]%s\f[R] string+.TP \f[B]option\f[R] Option eliminator b -> (a -> b) -> Option a -> b .TP@@ -141,7 +146,7 @@ \f[B]\[ti]*\f[R] Match, returning nth capture group Str -> Int -> Regex -> Option Str .TP-\f[B]captures\f[R] Return all captures+\f[B]captures\f[R] Return all captures (nth capture group) Str -> Int -> Regex -> List Str .TP \f[B]:?\f[R] mapMaybe@@ -181,6 +186,11 @@ \f[B]{.\f[R] Line comment .PP \f[B]\[at]include\[aq]/path/file.jac\[cq]\f[R] File include+.SS DECLARATIONS+.PP+\f[B]:set fs=/REGEX/;\f[R] Set field separator+.PP+\f[B]:flush;\f[R] Flush stdout for every line .SH INFLUENTIAL ENVIRONMENT VARIABLES .PP \f[V]JAC_PATH\f[R] - colon-separated list of directories to search@@ -192,13 +202,13 @@ {#\[ga]0>72}{\[ga]0} Print lines longer than 72 bytes .TP-{| sprintf \[aq]%i %i\[aq] (\[ga]2 . \[ga]1)}-Print the first two fields in opposite order-.TP {ix=3}{\[ga]0} Select only the third line .TP-:set fs := /,[ \[rs]t]*|[ \[rs]t]+/; {| sprintf \[aq]%i %i\[aq] (\[ga]2 . \[ga]1)}+{|sprintf \[aq]%i %i\[aq] (\[ga]2 . \[ga]1)}+Print the first two fields in opposite order+.TP+:set fs := /,[ \[rs]t]*|[ \[rs]t]+/; {|sprintf \[aq]%i %i\[aq] (\[ga]2 . \[ga]1)} Same, with input fields separated by comma and/or blanks and tabs. .TP (+)|0 $1:i@@ -224,6 +234,9 @@ .TP [y]|> {|\[ga]0\[ti]/\[ha]$/} Is the last line blank?+.TP+\&.?{|\[ga]1 \[ti]* 1 /([\[ha]\[rs]?]*)/}+Trim URL .SH BUGS .PP Please report any bugs you may come across to
prelude/fn.jac view
@@ -30,12 +30,9 @@ fn head := ([[:x]|>);-<<<<<<< Updated upstream-======= {. fold two on the same stream fn foldTwo(op0, op1, seed0, seed1, stream) := let val go := \acc. \line. (op0 (acc->1) line . op1 (acc->2) line) in go|(seed0.seed1) stream end;->>>>>>> Stashed changes
+ src/A.hs view
@@ -0,0 +1,424 @@+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module A ( E (..)+ , T (..)+ , TB (..)+ , BBin (..)+ , BTer (..)+ , BUn (..)+ , DfnVar (..)+ , D (..)+ , Program (..)+ , C (..)+ , N (..)+ , mapExpr+ , getFS, flushD+ -- * Base functors+ , EF (..)+ ) where++import Control.Recursion (Base, Corecursive, Recursive)+import qualified Data.ByteString as BS+import qualified Data.IntMap as IM+import Data.Maybe (listToMaybe)+import Data.Semigroup ((<>))+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8)+import qualified Data.Vector as V+import GHC.Generics (Generic)+import Nm+import Prettyprinter (Doc, Pretty (..), braces, brackets, concatWith, encloseSep, flatAlt, group, hardline, indent, parens, pipe, punctuate, tupled, (<+>))+import Regex.Rure (RurePtr)++infixr 6 <#>+infixr 6 <##>++(<#>) :: Doc a -> Doc a -> Doc a+(<#>) x y = x <> hardline <> y++(<##>) :: Doc a -> Doc a -> Doc a+(<##>) x y = x <> hardline <> hardline <> y++data TB = TyInteger+ | TyFloat+ | TyStr | TyR+ | TyStream+ | TyVec+ | TyBool+ | TyOption+ | TyUnit+ deriving (Eq, Ord)++tupledByFunky :: Doc ann -> [Doc ann] -> Doc ann+tupledByFunky sep = group . encloseSep (flatAlt "⟨ " "⟨") (flatAlt " ⟩" "⟩") sep++tupledBy :: Doc ann -> [Doc ann] -> Doc ann+tupledBy sep = group . encloseSep (flatAlt "( " "(") (flatAlt " )" ")") sep++jacTup :: Pretty a => [a] -> Doc ann+jacTup = tupledBy " . " . fmap pretty++data T = TyB { tyBuiltin :: TB }+ | TyApp { tyApp0 :: T, tyApp1 :: T }+ | TyArr { tyArr0 :: T, tyArr1 :: T }+ | TyVar { tyVar :: Nm () }+ | TyTup { tyTups :: [T] }+ | Rho { tyRho :: Nm (), tyArms :: IM.IntMap T }+ deriving (Eq, Ord)++instance Pretty TB where+ pretty TyInteger = "Integer"+ pretty TyStream = "Stream"+ pretty TyBool = "Bool"+ pretty TyStr = "Str"+ pretty TyFloat = "Float"+ pretty TyVec = "List"+ pretty TyOption = "Optional"+ pretty TyUnit = "𝟙"+ pretty TyR = "Regex"++instance Show TB where show=show.pretty++instance Pretty T where+ pretty (TyB b) = pretty b+ pretty (TyApp 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 (Rho n fs) = braces (pretty n <+> pipe <+> prettyFields (IM.toList fs))++prettyFields :: [(Int, T)] -> Doc ann+prettyFields = mconcat . punctuate "," . fmap g where g (i, t) = pretty i <> ":" <+> pretty t++instance Show T where show=show.pretty++data BUn = Tally -- length of string field+ | Const+ | Not -- ^ Boolean+ | At Int+ | Select Int+ | IParse+ | FParse+ | Parse+ | Floor+ | Ceiling+ | Some+ | Dedup+ | CatMaybes+ | Negate+ | TallyList -- length of vector+ deriving (Eq)++instance Pretty BUn where+ pretty Tally = "#"+ pretty Const = "[:"+ pretty Not = "!"+ pretty (At i) = "." <> pretty i+ pretty (Select i) = "->" <> pretty i+ pretty IParse = ":i"+ pretty FParse = ":f"+ pretty Floor = "floor"+ pretty Ceiling = "ceil"+ pretty Parse = ":"+ pretty Some = "Some"+ pretty Dedup = "~."+ pretty CatMaybes = ".?"+ pretty Negate = "-."+ pretty TallyList = "#*"++data BTer = ZipW+ | Fold | Scan+ | Substr+ | Option+ | Captures | AllCaptures+ deriving (Eq)++instance Pretty BTer where+ pretty ZipW = ","+ pretty Fold = "|"+ pretty Scan = "^"+ pretty Substr = "substr"+ pretty Option = "option"+ pretty Captures = "~*"+ pretty AllCaptures = "captures"++-- builtin+data BBin = Plus | Times | Div+ | Minus | Exp+ | Eq | Neq | Geq | Gt | Lt | Leq+ | Map+ | Matches -- ^ @'string' ~ /pat/@+ | NotMatches+ | And | Or+ | Min | Max+ | Split | Splitc+ | Prior+ | Filter+ | Sprintf+ | Match+ | MapMaybe+ | Fold1+ | DedupOn+ deriving (Eq)++instance Pretty BBin where+ pretty Plus = "+"+ pretty Times = "*"+ pretty Div = "%"+ pretty Minus = "-"+ pretty Eq = "="+ pretty Gt = ">"+ pretty Lt = "<"+ pretty Geq = ">="+ pretty Leq = "<="+ pretty Neq = "!="+ pretty Map = "¨"+ pretty Matches = "~"+ pretty NotMatches = "!~"+ pretty And = "&"+ pretty Or = "||"+ pretty Max = "max"+ pretty Min = "min"+ pretty Prior = "\\."+ pretty Filter = "#."+ pretty Split = "split"+ pretty Splitc = "splitc"+ pretty Sprintf = "sprintf"+ pretty Match = "match"+ pretty MapMaybe = ":?"+ pretty Fold1 = "|>"+ pretty Exp = "**"+ pretty DedupOn = "~.*"++data DfnVar = X | Y deriving (Eq)++instance Pretty DfnVar where pretty X = "x"; pretty Y = "y"++-- 0-ary+data N = Ix | Nf | None | Fp deriving (Eq)++-- expression+data E a = Column { eLoc :: a, col :: Int }+ | IParseCol { eLoc :: a, col :: Int } -- always a column+ | FParseCol { eLoc :: a, col :: Int }+ | ParseCol { eLoc :: a, col :: Int }+ | Field { eLoc :: a, eField :: Int }+ | LastField { eLoc :: a }+ | AllField { eLoc :: a } -- ^ Think @$0@ in awk.+ | AllColumn { eLoc :: a } -- ^ Think @$0@ in awk.+ | EApp { eLoc :: a, eApp0 :: E a, eApp1 :: E a }+ | Guarded { eLoc :: a, eP :: E a, 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)+ | Var { eLoc :: a, eVar :: !(Nm a) }+ | ILit { eLoc :: a, eInt :: !Integer }+ | BLit { eLoc :: a, eBool :: !Bool }+ | StrLit { eLoc :: a, eStr :: BS.ByteString }+ | RegexLit { eLoc :: a, eRr :: BS.ByteString }+ | FLit { eLoc :: a, eFloat :: !Double }+ | Lam { eLoc :: a, eBound :: Nm a, lamE :: E a }+ | Dfn { eLoc :: a, eDfn :: E a }+ | 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] }+ | ResVar { eLoc :: a, dfnVar :: DfnVar }+ | RC RurePtr -- compiled regex after normalization+ | Arr { eLoc :: a, elems :: V.Vector (E a) }+ | Anchor { eLoc :: a, eAnchored :: [E a] }+ | Paren { eLoc :: a, eExpr :: E a }+ | OptionVal { eLoc :: a, eMaybe :: Maybe (E a) }+ | Cond { eLoc :: a, eIf :: E a, eThen :: E a, eElse :: E a }+ | In { oop :: E a, ip :: Maybe (E a), mm :: Maybe (E a), istream :: E a }+ 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+ | AllFieldF a+ | AllColumnF a+ | EAppF a x x+ | GuardedF a x x+ | ImplicitF a x+ | LetF a (Nm a, x) x+ | VarF a (Nm a)+ | ILitF a Integer+ | BLitF a Bool+ | StrLitF a BS.ByteString+ | RegexLitF a BS.ByteString+ | FLitF a Double+ | 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+ deriving (Generic, Functor, Foldable, Traversable)++type instance Base (E a) = (EF a)++instance Pretty N where+ pretty Ix = "⍳"; pretty Nf = "nf"; pretty None = "None"; pretty Fp = "fp"++instance Pretty (E a) where+ pretty (Column _ i) = "$" <> pretty i+ pretty AllColumn{} = "$0"+ pretty (IParseCol _ i) = "$" <> pretty i <> ":i"+ pretty (FParseCol _ i) = "$" <> pretty i <> ":f"+ pretty (ParseCol _ i) = "$" <> pretty i <> ":"+ pretty AllField{} = "`0"+ pretty (Field _ i) = "`" <> pretty i+ pretty LastField{} = "`*"+ pretty (EApp _ (EApp _ (BB _ Prior) e) e') = pretty e <> "\\." <+> pretty e'+ pretty (EApp _ (EApp _ (BB _ Max) e) e') = "max" <+> pretty e <+> pretty e'+ pretty (EApp _ (EApp _ (BB _ Min) e) e') = "min" <+> pretty e <+> pretty e'+ pretty (EApp _ (EApp _ (BB _ Split) e) e') = "split" <+> pretty e <+> pretty e'+ pretty (EApp _ (EApp _ (BB _ Splitc) e) e') = "splitc" <+> pretty e <+> pretty e'+ pretty (EApp _ (EApp _ (BB _ Match) e) e') = "match" <+> pretty e <+> pretty e'+ pretty (EApp _ (EApp _ (BB _ Sprintf) e) e') = "sprintf" <+> pretty e <+> pretty e'+ pretty (EApp _ (EApp _ (BB _ Map) e) e') = pretty e <> "¨" <> pretty e'+ pretty (EApp _ (EApp _ (BB _ b) e) e') = pretty e <+> pretty b <+> pretty e'+ pretty (EApp _ (BB _ b) e) = parens (pretty e <> pretty b)+ pretty (EApp _ (EApp _ (EApp _ (TB _ Fold) e) e') e'') = pretty e <> "|" <> pretty e' <+> pretty e''+ pretty (EApp _ (EApp _ (EApp _ (TB _ Scan) e) e') e'') = pretty e <> "^" <> pretty e' <+> pretty e''+ pretty (EApp _ (EApp _ (EApp _ (TB _ ZipW) op) e') e'') = "," <> pretty op <+> pretty e' <+> pretty e''+ pretty (EApp _ (EApp _ (EApp _ (TB _ Substr) e) e') e'') = "substr" <+> pretty e <+> pretty e' <+> pretty e''+ pretty (EApp _ (EApp _ (EApp _ (TB _ Option) e) e') e'') = "option" <+> pretty e <+> pretty e' <+> pretty e''+ pretty (EApp _ (EApp _ (EApp _ (TB _ AllCaptures) e) e') e'') = "captures" <+> pretty e <+> pretty e' <+> pretty e''+ pretty (EApp _ (EApp _ (EApp _ (TB _ Captures) e) e') e'') = pretty e <+> "~*" <+> pretty e' <+> pretty e''+ pretty (EApp _ (UB _ (At i)) e) = pretty e <> "." <> pretty i+ pretty (EApp _ (UB _ (Select i)) e) = pretty e <> "->" <> pretty i+ pretty (EApp _ (UB _ IParse) e') = pretty e' <> ":i"+ pretty (EApp _ (UB _ FParse) e') = pretty e' <> ":f"+ pretty (EApp _ (UB _ Parse) e') = pretty e' <> ":"+ pretty (EApp _ e@UB{} e') = pretty e <> pretty e'+ pretty (EApp _ e e') = pretty e <+> pretty e'+ pretty (Var _ n) = pretty n+ pretty (ILit _ i) = pretty i+ pretty (RegexLit _ rr) = "/" <> pretty (decodeUtf8 rr) <> "/"+ pretty (FLit _ f) = pretty f+ pretty (BLit _ True) = "#t"+ pretty (BLit _ False) = "#f"+ pretty (BB _ b) = parens (pretty b)+ pretty (UB _ u) = pretty u+ pretty (StrLit _ str) = pretty (decodeUtf8 str)+ pretty (ResVar _ x) = pretty x+ pretty (Tup _ es) = jacTup es+ pretty (Lam _ n e) = parens ("λ" <> pretty n <> "." <+> pretty e)+ pretty (Dfn _ e) = brackets (pretty e)+ pretty (Guarded _ p e) = braces (pretty p) <> braces (pretty e)+ pretty (Implicit _ e) = braces ("|" <+> pretty e)+ pretty (NB _ n) = pretty n+ pretty RC{} = "(compiled regex)"+ pretty (Let _ (n, b) e) = "let" <+> "val" <+> pretty n <+> ":=" <+> pretty b <+> "in" <+> pretty e <+> "end"+ pretty (Paren _ e) = parens (pretty e)+ pretty (Arr _ es) = tupledByFunky "," (V.toList $ pretty <$> es)+ pretty (Anchor _ es) = "&" <> tupledBy "." (pretty <$> es)+ pretty (OptionVal _ (Just e)) = "Some" <+> pretty e+ pretty (OptionVal _ Nothing) = "None"+ pretty (Cond _ e0 e1 e2) = "if" <+> pretty e0 <+> "then" <+> pretty e1 <+> "else" <+> pretty e2++instance Show (E a) where show=show.pretty++-- for tests+instance Eq (E a) where+ (==) (Column _ i) (Column _ j) = i == j+ (==) (IParseCol _ i) (IParseCol _ j) = i == j+ (==) (FParseCol _ i) (FParseCol _ j) = i == j+ (==) (Field _ i) (Field _ j) = i == j+ (==) LastField{} LastField{} = True+ (==) AllColumn{} AllColumn{} = True+ (==) AllField{} AllField{} = True+ (==) (EApp _ e0 e1) (EApp _ e0' e1') = e0 == e0' && e1 == e1'+ (==) (Guarded _ p e) (Guarded _ p' e') = p == p' && e == e'+ (==) (Implicit _ e) (Implicit _ e') = e == e'+ (==) (Let _ (n, eϵ) e) (Let _ (n', eϵ') e') = eqName n n' && e == e' && eϵ == eϵ'+ (==) (Var _ n) (Var _ n') = eqName n n'+ (==) (Lam _ n e) (Lam _ n' e') = eqName n n' && e == e'+ (==) (ILit _ i) (ILit _ j) = i == j+ (==) (FLit _ u) (FLit _ v) = u == v+ (==) (StrLit _ str) (StrLit _ str') = str == str'+ (==) (RegexLit _ rr) (RegexLit _ rr') = rr == rr'+ (==) (BLit _ b) (BLit _ b') = b == b'+ (==) (BB _ b) (BB _ b') = b == b'+ (==) (TB _ b) (TB _ b') = b == b'+ (==) (UB _ unOp) (UB _ unOp') = unOp == unOp'+ (==) (NB _ x) (NB _ y) = x == y+ (==) (Tup _ es) (Tup _ 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!"+ (==) _ RC{} = error "Cannot compare compiled regex!"+ (==) (Paren _ e) e' = e == e'+ (==) e (Paren _ e') = e == e'+ (==) _ _ = False++data C = IsNum | IsEq | IsOrd+ | IsParse | IsPrintf+ | IsSemigroup+ | Functor -- ^ For map (@"@)+ | Foldable | Witherable+ deriving (Eq, Ord)++instance Pretty C where+ pretty IsNum = "Num"+ pretty IsEq = "Eq"+ pretty IsOrd = "Ord"+ pretty IsParse = "Parseable"+ pretty IsSemigroup = "Semigroup"+ pretty Functor = "Functor"+ pretty Foldable = "Foldable"+ pretty IsPrintf = "Printf"+ pretty Witherable = "Witherable"++instance Show C where show=show.pretty++-- decl+data D a = SetFS T.Text+ | FunDecl (Nm a) [Nm a] (E a)+ | FlushDecl+ deriving (Functor)++instance Pretty (D a) where+ pretty (SetFS bs) = ":set" <+> "/" <> pretty bs <> "/;"+ pretty (FunDecl n ns e) = "fn" <+> pretty n <> tupled (pretty <$> ns) <+> ":=" <#> indent 2 (pretty e <> ";")+ pretty FlushDecl = ":flush;"++data Program a = Program { decls :: [D a], expr :: E a } deriving (Functor)++instance Pretty (Program a) where+ pretty (Program ds e) = concatWith (<##>) (pretty <$> ds) <##> pretty e++instance Show (Program a) where show=show.pretty++flushD :: Program a -> Bool+flushD (Program ds _) = any p ds where p FlushDecl = True; p _ = False++getFS :: Program a -> Maybe T.Text+getFS (Program ds _) = listToMaybe (concatMap go ds) where go (SetFS bs) = [bs]; go _ = []++mapExpr :: (E a -> E a) -> Program a -> Program a+mapExpr f (Program ds e) = Program ds (f e)
+ src/A/E.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE OverloadedStrings #-}++module A.E ( M, nN, eta ) where++import A+import Control.Monad ((<=<))+import Control.Monad.State.Strict (State, get, modify)+import Data.Functor (($>))+import qualified Data.Text as T+import Nm+import U++type M = State Int++nN :: T.Text -> a -> M (Nm a)+nN n l = do {i <- get; modify (+1) $> Nm n (U$i+1) l}++doms :: T -> [T]+doms (TyArr t t') = t:doms t'; doms _ = []++cLam :: E a -> Int+cLam (Lam _ _ e) = 1+cLam e; cLam _ = 0++tuck :: E a -> (E a -> E a, E a)+tuck (Lam l n e) = let (f, e') = tuck e in (Lam l n.f, e'); tuck e = (id, e)++unseam :: [T] -> M (E T -> E T, E T -> E T)+unseam ts = do+ lApps <- traverse (\t -> do {n <- nN "x" t; pure (\e' -> let t' = eLoc e' in Lam (TyArr t t') n e', \e' -> let TyArr _ cod = eLoc e' in EApp cod e' (Var t n))}) ts+ let (ls, eApps) = unzip lApps+ pure (thread ls, thread (reverse eApps))+ where thread = foldr (.) id++mkLam :: [T] -> E T -> M (E T)+mkLam ts e = do+ (lam, app) <- unseam ts+ pure $ lam (app e)++eta = eM <=< eO++eM :: E T -> M (E T)+eM (EApp t ho@(BB _ Map) op) = EApp t ho <$> eta op+eM (EApp t ho@(BB _ Filter) op) = EApp t ho <$> eta op+eM (EApp t ho@(BB _ Prior) op) = EApp t ho <$> eta op+eM (EApp t ho@(BB _ DedupOn) op) = EApp t ho <$> eta op+eM (EApp t ho@(BB _ Fold1) op) = EApp t ho <$> eta op+eM (EApp t ho@(TB _ Fold) op) = EApp t ho <$> eta op+eM (EApp t ho@(TB _ Scan) op) = EApp t ho <$> eta op+eM (EApp t ho@(TB _ ZipW) op) = EApp t ho <$> eta op+eM (EApp t e0 e1) = EApp t <$> eM e0 <*> eM e1+eM (Cond t p e0 e1) = Cond t <$> eM p <*> eM e0 <*> eM e1+eM (OptionVal t e) = OptionVal t <$> traverse eM e+eM (Implicit t e) = Implicit t <$> eM e+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 (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𝜂)}+eM e = pure e++-- outermost+eO :: E T -> M (E T)+eO e@(Var t@TyArr{} _) = mkLam (doms t) e+eO e@(UB t _) = mkLam (doms t) e+eO e@(BB t _) = mkLam (doms t) e+eO e@(TB t _) = mkLam (doms t) e+eO e@(EApp t@TyArr{} _ _) = mkLam (doms t) e+eO e@(Lam t@TyArr{} _ _) = do+ let l = length (doms t)+ (preL, e') = tuck e+ (lam, app) <- unseam (take (l-cLam e) $ doms t)+ pure (lam (preL (app e')))+eO e = pure e
+ src/A/I.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE FlexibleContexts #-}++module A.I ( RM, UM, ISt (..)+ , ib+ , β, lβ+ , runI+ ) where++import A+import Control.Monad.State.Strict (State, gets, modify, runState, state)+import Data.Bifunctor (second)+import Data.Foldable (traverse_)+import qualified Data.IntMap as IM+import Nm+import R+import Ty+import U++data ISt a = ISt { renames :: !Renames+ , binds :: IM.IntMap (E a)+ }++instance HasRenames (ISt a) where+ rename f s = fmap (\x -> s { renames = x }) (f (renames s))++type RM a = State (ISt a); type UM = State Int++bind :: Nm a -> E a -> ISt a -> ISt a+bind (Nm _ (U u) _) e (ISt r bs) = ISt r (IM.insert u e bs)++runI i = second (max_.renames) . flip runState (ISt (Renames i mempty) mempty)++ib :: Int -> Program T -> (E T, Int)+ib i = uncurry (flip β).runI i.iP where iP (Program ds e) = traverse_ iD ds *> iE e++β :: Int -> E a -> (E a, Int)+β i = runI i.bM.(i `seq`)++lβ :: E a -> UM (E a)+lβ e = state (`β` e)++iD :: D T -> RM T ()+iD (FunDecl n [] e) = do {eI <- iE e; modify (bind n eI)}+iD SetFS{} = pure (); iD FlushDecl{} = pure ()+iD FunDecl{} = desugar++desugar = error "Internal error. Should have been de-sugared in an earlier stage!"++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'')+ bM e'+bM (EApp _ (Lam _ n e') e) = do+ eI <- bM e+ modify (bind n eI) *> bM e'+bM (EApp l e0 e1) = do+ e0' <- bM e0+ e1' <- bM e1+ case e0' of+ Lam{} -> bM (EApp l e0' e1')+ _ -> pure (EApp l e0' e1')+bM e@(Var _ (Nm _ (U i) _)) = do+ st <- gets binds+ case IM.lookup i st of+ Just e' -> rE e'+ Nothing -> pure e+bM (Let l (n, e') e) = do+ e'B <- bM e'+ 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 (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+bM (Guarded l e0 e1) = Guarded l <$> bM e0 <*> bM e1+bM (Cond l p e0 e1) = Cond l <$> bM p <*> bM e0 <*> bM e1+bM e@Column{} = pure e; bM e@IParseCol{} = pure e; bM e@FParseCol{} = pure e; bM e@AllField{} = pure e+bM e@LastField{} = pure e; bM e@Field{} = pure e; bM e@ParseCol{} = pure e; bM e@AllColumn{} = pure e; bM e@RC{} = pure e+bM e@ILit{} = pure e; bM e@FLit{} = pure e; bM e@StrLit{} = pure e; bM e@RegexLit{} = pure e; bM e@BLit{} = 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++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+iE e@Column{} = pure e; iE e@ParseCol{} = pure e; iE e@IParseCol{} = pure e; iE e@FParseCol{} = pure e+iE e@Field{} = pure e; iE e@LastField{} = pure e; iE e@AllField{} = pure e; iE e@AllColumn{} = pure e+iE e@ILit{} = pure e; iE e@FLit{} = pure e; iE e@BLit{} = pure e; iE e@StrLit{} = pure e+iE e@RegexLit{} = pure e; iE e@RC{} = pure e+iE (EApp t e e') = EApp t <$> iE e <*> iE e'+iE (Guarded t p e) = Guarded t <$> iE p <*> iE e+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 (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+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
− src/Data/List/Ext.hs
@@ -1,13 +0,0 @@-module Data.List.Ext ( imap- , ifilter'- , prior- ) where--prior :: (a -> a -> b) -> [a] -> [b]-prior op xs = zipWith op (tail xs) xs--imap :: (Int -> a -> b) -> [a] -> [b]-imap f xs = fmap (uncurry f) (zip [1..] xs)--ifilter' :: (Int -> a -> Bool) -> [a] -> [(Int, a)]-ifilter' p xs = filter (uncurry p) (zip [1..] xs)
− src/Data/Vector/Ext.hs
@@ -1,7 +0,0 @@-module Data.Vector.Ext ( priorM_- ) where--import qualified Data.Vector as V--priorM_ :: Monad m => (a -> a -> m b) -> V.Vector a -> m ()-priorM_ op xs = V.zipWithM_ op (V.tail xs) xs
+ src/File.hs view
@@ -0,0 +1,139 @@+module File ( tcIO+ , tySrc+ , runOnHandle+ , runOnFile+ , exprEval+ ) where++import A+import A.I+import Control.Applicative ((<|>))+import Control.Exception (Exception, throw, throwIO)+import Control.Monad ((<=<))+import Control.Monad.IO.Class (liftIO)+import Control.Monad.State.Strict (StateT, get, put, runStateT)+import Control.Recursion (cata, embed)+import Data.Bifunctor (second)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Char8 as ASCIIL+import Data.Foldable (traverse_)+import Data.Functor (($>))+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import qualified Data.Text.IO as TIO+import Data.Tuple (swap)+import Include+import Jacinda.Backend.Const+import Jacinda.Backend.P+import Jacinda.Check.Field+import Jacinda.Regex+import L+import Parser+import Parser.Rw+import R+import Regex.Rure (RurePtr)+import System.IO (Handle)+import Ty++parseLib :: [FilePath] -> FilePath -> StateT AlexUserState IO [D AlexPosn]+parseLib incls fp = do+ contents <- liftIO $ TIO.readFile =<< resolveImport incls fp+ st <- get+ case parseLibWithCtx contents st of+ Left err -> liftIO (throwIO err)+ 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+ st <- get+ case parseWithCtx bs st of+ Left err -> liftIO $ throwIO err+ Right (st', (is, Program ds e)) -> do+ put st'+ dss <- traverse (parseLib incls) is+ pure $ Program (concat dss ++ fmap 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++parseWithMax' :: T.Text -> Either (ParseError AlexPosn) (Program AlexPosn, Int)+parseWithMax' = fmap (uncurry rP . second (rwP . snd)) . parseWithMax++type FileBS = BS.ByteString++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++exprEval :: T.Text -> E T+exprEval src =+ case parseWithMax' src of+ Left err -> throw err+ Right (ast, m) ->+ let (typed, i) = yeet $ runTyM m (tyP ast)+ (inlined, j) = ib i typed+ in eB j pure (compileR (error "nf not defined.") inlined)++compileFS :: Maybe T.Text -> RurePtr+compileFS (Just bs) = compileDefault (encodeUtf8 bs)+compileFS Nothing = defaultRurePtr++runOnBytes :: [FilePath]+ -> FilePath -- ^ Data file name, for @nf@+ -> T.Text -- ^ Program+ -> Maybe T.Text -- ^ Field separator+ -> BSL.ByteString+ -> IO ()+runOnBytes incls fp src cliFS contents = do+ incls' <- defaultIncludes <*> pure incls+ (ast, m) <- parseEWithMax incls' src+ (typed, i) <- yIO $ runTyM m (tyP ast)+ let (eI, j) = ib i typed+ m'Throw $ cF eI+ cont <- yIO $ runJac (compileFS (cliFS <|> getFS ast)) (flushD typed) j (compileR (encodeUtf8 $ T.pack fp) eI)+ cont $ fmap BSL.toStrict (ASCIIL.lines contents)++runOnHandle :: [FilePath]+ -> T.Text -- ^ Program+ -> Maybe T.Text -- ^ Field separator+ -> Handle+ -> IO ()+runOnHandle is src cliFS = runOnBytes is "(runOnBytes)" src cliFS <=< BSL.hGetContents++runOnFile :: [FilePath]+ -> T.Text+ -> Maybe T.Text+ -> FilePath+ -> IO ()+runOnFile is e fs fp = runOnBytes is fp e fs =<< BSL.readFile fp++tcIO :: [FilePath] -> T.Text -> IO ()+tcIO incls src = do+ incls' <- defaultIncludes <*> pure incls+ (ast, m) <- parseEWithMax incls' src+ (pT, i) <- yIO $ runTyM m (tyP ast)+ let (eI, _) = ib i pT+ m'Throw $ cF eI++tySrc :: T.Text -> T+tySrc src =+ case parseWithMax' src of+ Right (ast, m) -> yeet $ fst <$> runTyM m (tyOf (expr ast))+ Left err -> throw err++m'Throw :: Exception e => Maybe e -> IO ()+m'Throw = traverse_ throwIO++yIO :: Exception e => Either e a -> IO a+yIO = either throwIO pure++yeet :: Exception e => Either e a -> a+yeet = either throw id
+ src/Include.hs view
@@ -0,0 +1,36 @@+module Include ( defaultIncludes+ , resolveImport+ ) where++import Control.Exception (Exception, throwIO)+import Control.Monad (filterM)+import Data.List.Split (splitWhen)+import Data.Maybe (listToMaybe)+import Paths_jacinda (getDataDir)+import System.Directory (doesFileExist, getCurrentDirectory)+import System.Environment (lookupEnv)+import System.FilePath ((</>))++data ImportError = FileNotFound !FilePath ![FilePath] deriving (Show)++instance Exception ImportError where++defaultIncludes :: IO ([FilePath] -> [FilePath])+defaultIncludes = do+ path <- jacPath+ d <- getDataDir+ dot <- getCurrentDirectory+ pure $ (dot:).(d:).(++path)++jacPath :: IO [FilePath]+jacPath = maybe [] splitEnv <$> lookupEnv "JAC_PATH"++splitEnv :: String -> [FilePath]+splitEnv = splitWhen (== ':')++resolveImport :: [FilePath] -- ^ Places to look+ -> FilePath+ -> IO FilePath+resolveImport incl fp =+ maybe (throwIO $ FileNotFound fp incl) pure . listToMaybe+ =<< (filterM doesFileExist . fmap (</> fp) $ incl)
− src/Intern/Name.hs
@@ -1,30 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}--module Intern.Name ( Name (..)- , TyName- , eqName- ) where--import qualified Data.Text as T-import Intern.Unique-import Prettyprinter (Pretty (pretty))--data Name a = Name { name :: T.Text- , unique :: !Unique- , loc :: a- } deriving (Functor)---- for testing-eqName :: Name a -> Name a -> Bool-eqName (Name n _ _) (Name n' _ _) = n == n'--instance Eq (Name a) where- (==) (Name _ u _) (Name _ u' _) = u == u'--instance Pretty (Name a) where- pretty (Name t _ _) = pretty t--instance Ord (Name a) where- compare (Name _ u _) (Name _ u' _) = compare u u'--type TyName = Name
− src/Intern/Unique.hs
@@ -1,5 +0,0 @@-module Intern.Unique ( Unique (..)- ) where--newtype Unique = Unique { unUnique :: Int }- deriving (Eq, Ord)
− src/Jacinda/AST.hs
@@ -1,460 +0,0 @@-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}--module Jacinda.AST ( E (..)- , T (..)- , TB (..)- , BBin (..)- , BTer (..)- , BUn (..)- , K (..)- , DfnVar (..)- , D (..)- , Program (..)- , C (..)- , N (..)- , mapExpr- , getFS- -- * Base functors- , EF (..)- ) where--import Control.Recursion (Base, Corecursive, Recursive)-import qualified Data.ByteString as BS-import Data.Maybe (listToMaybe)-import Data.Semigroup ((<>))-import Data.Text.Encoding (decodeUtf8)-import qualified Data.Vector as V-import GHC.Generics (Generic)-import Intern.Name-import Prettyprinter (Doc, Pretty (..), braces, brackets, concatWith, encloseSep, flatAlt, group, hardline, indent, parens, tupled, (<+>))-import Regex.Rure (RurePtr)--infixr 6 <#>-infixr 6 <##>--(<#>) :: Doc a -> Doc a -> Doc a-(<#>) x y = x <> hardline <> y--(<##>) :: Doc a -> Doc a -> Doc a-(<##>) x y = x <> hardline <> hardline <> y---- kind-data K = Star- | KArr K K- deriving (Eq, Ord)--instance Pretty K where- pretty Star = "★"- pretty (KArr k0 k1) = parens (pretty k0 <+> "⟶" <+> pretty k1)--data TB = TyInteger- | TyFloat- | TyDate- | TyStr | TyR- | TyStream- | TyVec- | TyBool- | TyOption- | TyUnit- -- TODO: convert float to int- deriving (Eq, Ord)---- unicode mathematical angle bracket-tupledByFunky :: Doc ann -> [Doc ann] -> Doc ann-tupledByFunky sep = group . encloseSep (flatAlt "⟨ " "⟨") (flatAlt " ⟩" "⟩") sep--tupledBy :: Doc ann -> [Doc ann] -> Doc ann-tupledBy sep = group . encloseSep (flatAlt "( " "(") (flatAlt " )" ")") sep--jacTup :: Pretty a => [a] -> Doc ann-jacTup = tupledBy " . " . fmap pretty---- type-data T a = TyNamed { tLoc :: a, tyName :: TyName a }- | TyB { tLoc :: a, tyBuiltin :: TB }- | TyApp { tLoc :: a, tyApp0 :: T a, tyApp1 :: T a }- | TyArr { tLoc :: a, tyArr0 :: T a, tyArr1 :: T a }- | TyVar { tLoc :: a, tyVar :: Name a }- | TyTup { tLoc :: a, tyTups :: [T a] } -- in practice, parse only >1- deriving (Eq, Ord, Functor) -- this is so we can store consntraints in a set, not alpha-equiv. or anything- -- TODO: type vars, products...--instance Pretty TB where- pretty TyInteger = "Integer"- pretty TyStream = "Stream"- pretty TyBool = "Bool"- pretty TyStr = "Str"- pretty TyFloat = "Float"- pretty TyDate = "Date"- pretty TyVec = "List"- pretty TyOption = "Optional"- pretty TyUnit = "𝟙"- pretty TyR = "Regex"--instance Pretty (T a) where- pretty (TyB _ b) = pretty b- pretty (TyApp _ 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 (TyNamed _ tn) = pretty tn--instance Show (T a) where- show = show . pretty---- unary-data BUn = Tally -- length of string field- | Const- | Not -- ^ Boolean- | At Int- | Select Int- | IParse- | FParse- | Parse- | Floor- | Ceiling- | Some- | Dedup- | CatMaybes- | Negate- | TallyList -- length of vector- deriving (Eq)--instance Pretty BUn where- pretty Tally = "#"- pretty Const = "[:"- pretty Not = "!"- pretty (At i) = "." <> pretty i- pretty (Select i) = "->" <> pretty i- pretty IParse = ":i"- pretty FParse = ":f"- pretty Floor = "floor"- pretty Ceiling = "ceil"- pretty Parse = ":"- pretty Some = "Some"- pretty Dedup = "~."- pretty CatMaybes = ".?"- pretty Negate = "-."- pretty TallyList = "#*"---- ternary-data BTer = ZipW- | Fold- | Scan- | Substr- | Option- | Captures- | AllCaptures- deriving (Eq)--instance Pretty BTer where- pretty ZipW = ","- pretty Fold = "|"- pretty Scan = "^"- pretty Substr = "substr"- pretty Option = "option"- pretty Captures = "~*"- pretty AllCaptures = "captures"---- builtin-data BBin = Plus- | Times- | Div- | Minus- | Eq- | Neq- | Geq- | Gt- | Lt- | Leq- | Map- | Matches -- ^ @/pat/ ~ 'string'@- | NotMatches- | And- | Or- | Min- | Max- | Split- | Splitc- | Prior- | Filter- | Sprintf- | Match- | MapMaybe- | Fold1- -- TODO: floor functions, sqrt, sin, cos, exp. (power)- deriving (Eq)--instance Pretty BBin where- pretty Plus = "+"- pretty Times = "*"- pretty Div = "%"- pretty Minus = "-"- pretty Eq = "="- pretty Gt = ">"- pretty Lt = "<"- pretty Geq = ">="- pretty Leq = "<="- pretty Neq = "!="- pretty Map = "\""- pretty Matches = "~"- pretty NotMatches = "!~"- pretty And = "&"- pretty Or = "||"- pretty Max = "max"- pretty Min = "min"- pretty Prior = "\\."- pretty Filter = "#."- pretty Split = "split"- pretty Splitc = "splitc"- pretty Sprintf = "sprintf"- pretty Match = "match"- pretty MapMaybe = ":?"- pretty Fold1 = "|>"--data DfnVar = X | Y deriving (Eq)--instance Pretty DfnVar where- pretty X = "x"- pretty Y = "y"---- 0-ary-data N = Ix- | Nf- | None- | Fp- deriving (Eq)---- expression-data E a = Column { eLoc :: a, col :: Int }- | IParseCol { eLoc :: a, col :: Int } -- always a column- | FParseCol { eLoc :: a, col :: Int }- | ParseCol { eLoc :: a, col :: Int }- | Field { eLoc :: a, eField :: Int }- | LastField { eLoc :: a }- | AllField { eLoc :: a } -- ^ Think @$0@ in awk.- | AllColumn { eLoc :: a } -- ^ Think @$0@ in awk.- | EApp { eLoc :: a, eApp0 :: E a, eApp1 :: E a }- | Guarded { eLoc :: a, eP :: E a, eGuarded :: E a }- | Implicit { eLoc :: a, eImplicit :: E a }- | Let { eLoc :: a, eBind :: (Name a, E a), eE :: E a }- -- TODO: literals type (make pattern matching easier down the road)- | Var { eLoc :: a, eVar :: Name a }- | IntLit { eLoc :: a, eInt :: !Integer }- | BoolLit { eLoc :: a, eBool :: !Bool }- | StrLit { eLoc :: a, eStr :: BS.ByteString }- | RegexLit { eLoc :: a, eRr :: BS.ByteString }- | FloatLit { eLoc :: a, eFloat :: !Double }- | Lam { eLoc :: a, eBound :: Name a, lamE :: E a }- | Dfn { eLoc :: a, eDfn :: E a }- | BBuiltin { eLoc :: a, eBin :: BBin }- | TBuiltin { eLoc :: a, eTer :: BTer }- | UBuiltin { eLoc :: a, eUn :: BUn }- | NBuiltin { eLoc :: a, eNil :: N }- | Tup { eLoc :: a, esTup :: [E a] }- | ResVar { eLoc :: a, dfnVar :: DfnVar }- | RegexCompiled RurePtr -- holds compiled regex after normalization- | Arr { eLoc :: a, elems :: V.Vector (E a) }- | Anchor { eLoc :: a, eAnchored :: [E a] }- | Paren { eLoc :: a, eExpr :: E a }- | OptionVal { eLoc :: a, eMaybe :: Maybe (E a) }- | Cond { eLoc :: a, eIf :: E a, eThen :: E a, eElse :: E a }- 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- | AllFieldF a- | AllColumnF a- | EAppF a x x- | GuardedF a x x- | ImplicitF a x- | LetF a (Name a, x) x- | VarF a (Name a)- | IntLitF a Integer- | BoolLitF a Bool- | StrLitF a BS.ByteString- | RegexLitF a BS.ByteString- | FloatLitF a Double- | LamF a (Name a) x- | DfnF a x- | BBuiltinF a BBin- | TBuiltinF a BTer- | UBuiltinF a BUn- | NBuiltinF a N- | TupF a [x]- | ResVarF a DfnVar- | RegexCompiledF RurePtr- | ArrF a (V.Vector x)- | AnchorF a [x]- | ParenF a x- | OptionValF a (Maybe x)- | CondF a x x x- deriving (Generic, Functor, Foldable, Traversable)--type instance Base (E a) = (EF a)--instance Pretty N where- pretty Ix = "ix"- pretty Nf = "nf"- pretty None = "None"- pretty Fp = "fp"--instance Pretty (E a) where- pretty (Column _ i) = "$" <> pretty i- pretty AllColumn{} = "$0"- pretty (IParseCol _ i) = "$" <> pretty i <> ":i"- pretty (FParseCol _ i) = "$" <> pretty i <> ":f"- pretty (ParseCol _ i) = "$" <> pretty i <> ":"- pretty AllField{} = "`0"- pretty (Field _ i) = "`" <> pretty i- pretty LastField{} = "`*"- pretty (EApp _ (EApp _ (BBuiltin _ Prior) e) e') = pretty e <> "\\." <+> pretty e'- pretty (EApp _ (EApp _ (BBuiltin _ Max) e) e') = "max" <+> pretty e <+> pretty e'- pretty (EApp _ (EApp _ (BBuiltin _ Min) e) e') = "min" <+> pretty e <+> pretty e'- pretty (EApp _ (EApp _ (BBuiltin _ Split) e) e') = "split" <+> pretty e <+> pretty e'- pretty (EApp _ (EApp _ (BBuiltin _ Splitc) e) e') = "splitc" <+> pretty e <+> pretty e'- pretty (EApp _ (EApp _ (BBuiltin _ Match) e) e') = "match" <+> pretty e <+> pretty e'- pretty (EApp _ (EApp _ (BBuiltin _ Sprintf) e) e') = "sprintf" <+> pretty e <+> pretty e'- pretty (EApp _ (EApp _ (BBuiltin _ Map) e) e') = pretty e <> "\"" <> pretty e'- pretty (EApp _ (EApp _ (BBuiltin _ b) e) e') = pretty e <+> pretty b <+> pretty e'- pretty (EApp _ (BBuiltin _ b) e) = parens (pretty e <> pretty b)- pretty (EApp _ (EApp _ (EApp _ (TBuiltin _ Fold) e) e') e'') = pretty e <> "|" <> pretty e' <+> pretty e''- pretty (EApp _ (EApp _ (EApp _ (TBuiltin _ Scan) e) e') e'') = pretty e <> "^" <> pretty e' <+> pretty e''- pretty (EApp _ (EApp _ (EApp _ (TBuiltin _ ZipW) op) e') e'') = "," <> pretty op <+> pretty e' <+> pretty e''- pretty (EApp _ (EApp _ (EApp _ (TBuiltin _ Substr) e) e') e'') = "substr" <+> pretty e <+> pretty e' <+> pretty e''- pretty (EApp _ (EApp _ (EApp _ (TBuiltin _ Option) e) e') e'') = "option" <+> pretty e <+> pretty e' <+> pretty e''- pretty (EApp _ (EApp _ (EApp _ (TBuiltin _ AllCaptures) e) e') e'') = "captures" <+> pretty e <+> pretty e' <+> pretty e''- pretty (EApp _ (EApp _ (EApp _ (TBuiltin _ Captures) e) e') e'') = pretty e <+> "~*" <+> pretty e' <+> pretty e''- pretty (EApp _ (UBuiltin _ (At i)) e) = pretty e <> "." <> pretty i- pretty (EApp _ (UBuiltin _ (Select i)) e) = pretty e <> "->" <> pretty i- pretty (EApp _ (UBuiltin _ IParse) e') = pretty e' <> ":i"- pretty (EApp _ (UBuiltin _ FParse) e') = pretty e' <> ":f"- pretty (EApp _ (UBuiltin _ Parse) e') = pretty e' <> ":"- pretty (EApp _ e@UBuiltin{} e') = pretty e <> pretty e'- pretty (EApp _ e e') = pretty e <+> pretty e'- pretty (Var _ n) = pretty n- pretty (IntLit _ i) = pretty i- pretty (RegexLit _ rr) = "/" <> pretty (decodeUtf8 rr) <> "/"- pretty (FloatLit _ f) = pretty f- pretty (BoolLit _ True) = "#t"- pretty (BoolLit _ False) = "#f"- pretty (BBuiltin _ b) = parens (pretty b)- pretty (UBuiltin _ u) = pretty u- pretty (StrLit _ bstr) = pretty (decodeUtf8 bstr)- pretty (ResVar _ x) = pretty x- pretty (Tup _ es) = jacTup es- pretty (Lam _ n e) = parens ("λ" <> pretty n <> "." <+> pretty e)- pretty (Dfn _ e) = brackets (pretty e)- pretty (Guarded _ p e) = braces (pretty p) <> braces (pretty e)- pretty (Implicit _ e) = braces ("|" <+> pretty e)- pretty (NBuiltin _ n) = pretty n- pretty RegexCompiled{} = "(compiled regex)"- pretty (Let _ (n, b) e) = "let" <+> "val" <+> pretty n <+> ":=" <+> pretty b <+> "in" <+> pretty e <+> "end"- pretty (Paren _ e) = parens (pretty e)- pretty (Arr _ es) = tupledByFunky "," (V.toList $ pretty <$> es)- pretty (Anchor _ es) = "&" <> tupledBy "." (pretty <$> es)- pretty (OptionVal _ (Just e)) = "Some" <+> pretty e- pretty (OptionVal _ Nothing) = "None"- pretty (Cond _ e0 e1 e2) = "if" <+> pretty e0 <+> "then" <+> pretty e1 <+> "else" <+> pretty e2--instance Show (E a) where- show = show . pretty---- for tests-instance Eq (E a) where- (==) (Column _ i) (Column _ j) = i == j- (==) (IParseCol _ i) (IParseCol _ j) = i == j- (==) (FParseCol _ i) (FParseCol _ j) = i == j- (==) (Field _ i) (Field _ j) = i == j- (==) LastField{} LastField{} = True- (==) AllColumn{} AllColumn{} = True- (==) AllField{} AllField{} = True- (==) (EApp _ e0 e1) (EApp _ e0' e1') = e0 == e0' && e1 == e1'- (==) (Guarded _ p e) (Guarded _ p' e') = p == p' && e == e'- (==) (Implicit _ e) (Implicit _ e') = e == e'- (==) (Let _ (n, eϵ) e) (Let _ (n', eϵ') e') = eqName n n' && e == e' && eϵ == eϵ'- (==) (Var _ n) (Var _ n') = eqName n n'- (==) (Lam _ n e) (Lam _ n' e') = eqName n n' && e == e'- (==) (IntLit _ i) (IntLit _ j) = i == j- (==) (FloatLit _ u) (FloatLit _ v) = u == v- (==) (StrLit _ str) (StrLit _ str') = str == str'- (==) (RegexLit _ rr) (RegexLit _ rr') = rr == rr'- (==) (BoolLit _ b) (BoolLit _ b') = b == b'- (==) (BBuiltin _ b) (BBuiltin _ b') = b == b'- (==) (TBuiltin _ b) (TBuiltin _ b') = b == b'- (==) (UBuiltin _ unOp) (UBuiltin _ unOp') = unOp == unOp'- (==) (NBuiltin _ x) (NBuiltin _ y) = x == y- (==) (Tup _ es) (Tup _ es') = es == es'- (==) (ResVar _ x) (ResVar _ y) = x == y- (==) (Dfn _ f) (Dfn _ g) = f == g -- we're testing for lexical equivalence- (==) RegexCompiled{} _ = error "Cannot compare compiled regex!"- (==) _ RegexCompiled{} = error "Cannot compare compiled regex!"- (==) (Paren _ e) e' = e == e'- (==) e (Paren _ e') = e == e'- (==) _ _ = False--data C = IsNum- | IsEq- | IsOrd- | IsParseable- | IsSemigroup- | Functor -- ^ For map (@"@)- | Foldable- | IsPrintf- | HasField Int (T K)- | Witherable- deriving (Eq, Ord)--instance Pretty C where- pretty IsNum = "Num"- pretty IsEq = "Eq"- pretty IsOrd = "Ord"- pretty IsParseable = "Parseable"- pretty IsSemigroup = "Semigroup"- pretty Functor = "Functor"- pretty Foldable = "Foldable"- pretty IsPrintf = "Printf"- pretty (HasField i ty) = "HasField" <+> pretty i <+> "~" <+> pretty ty- pretty Witherable = "Witherable"--instance Show C where- show = show . pretty---- decl-data D a = SetFS BS.ByteString- | FunDecl (Name a) [Name a] (E a)- deriving (Functor)--instance Pretty (D a) where- pretty (SetFS bs) = ":set" <+> "/" <> pretty (decodeUtf8 bs) <> "/"- pretty (FunDecl n ns e) = "fn" <+> pretty n <> tupled (pretty <$> ns) <+> ":=" <#> indent 2 (pretty e <> ";")---- TODO: fun decls (type decls)-data Program a = Program { decls :: [D a], expr :: E a } deriving (Functor)--instance Pretty (Program a) where- pretty (Program ds e) = concatWith (<##>) (pretty <$> ds) <##> pretty e--instance Show (Program a) where- show = show . pretty--getFS :: Program a -> Maybe BS.ByteString-getFS (Program ds _) = listToMaybe (concatMap go ds) where- go (SetFS bs) = [bs]- go _ = []--mapExpr :: (E a -> E a) -> Program a -> Program a-mapExpr f (Program ds e) = Program ds (f e)
+ src/Jacinda/Backend/Const.hs view
@@ -0,0 +1,17 @@+module Jacinda.Backend.Const ( mkI, mkF, mkStr, mkB ) where++import A+import qualified Data.ByteString as BS+import Ty.Const++mkI :: Integer -> E T+mkI = ILit tyI++mkF :: Double -> E T+mkF = FLit tyF++mkB :: Bool -> E T+mkB = BLit tyB++mkStr :: BS.ByteString -> E T+mkStr = StrLit tyStr
− src/Jacinda/Backend/Normalize.hs
@@ -1,483 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Jacinda.Backend.Normalize ( eClosed- , closedProgram- , readDigits- , readFloat- , mkI- , mkF- , mkStr- , parseAsEInt- , parseAsF- , the- , asTup- , EvalError (..)- -- * Monad- , runEvalM- , eNorm- ) where--import Control.Exception (Exception, throw)-import Control.Monad.State.Strict (State, evalState, gets, modify)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as ASCII-import Data.Foldable (traverse_)-import qualified Data.IntMap as IM-import Data.Semigroup ((<>))-import qualified Data.Vector as V-import Data.Word (Word8)-import Intern.Name-import Intern.Unique-import Jacinda.AST-import Jacinda.Backend.Printf-import Jacinda.Regex-import Jacinda.Rename-import Jacinda.Ty.Const-import Regex.Rure (RureMatch (..))--data EvalError = EmptyFold- | IndexOutOfBounds Int- deriving (Show)--instance Exception EvalError where--mkI :: Integer -> E (T K)-mkI = IntLit tyI--mkF :: Double -> E (T K)-mkF = FloatLit tyF--mkStr :: BS.ByteString -> E (T K)-mkStr = StrLit tyStr--parseAsEInt :: BS.ByteString -> E (T K)-parseAsEInt = mkI . readDigits--parseAsF :: BS.ByteString -> E (T K)-parseAsF = FloatLit tyF . readFloat--readDigits :: BS.ByteString -> Integer-readDigits = ASCII.foldl' (\seed x -> 10 * seed + f x) 0- 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!")--the :: BS.ByteString -> Word8-the bs = case BS.uncons bs of- Nothing -> error "Empty splitc char!"- Just (c,"") -> c- Just _ -> error "Splitc takes only one char!"--readFloat :: BS.ByteString -> Double-readFloat = read . ASCII.unpack--desugar :: a-desugar = error "Should have been desugared by this stage."--data LetCtx = LetCtx { binds :: IM.IntMap (E (T K))- , renames_ :: Renames- }--instance HasRenames LetCtx where- rename f s = fmap (\x -> s { renames_ = x }) (f (renames_ s))--mapBinds :: (IM.IntMap (E (T K)) -> IM.IntMap (E (T K))) -> LetCtx -> LetCtx-mapBinds f (LetCtx b r) = LetCtx (f b) r--type EvalM = State LetCtx--mkLetCtx :: Int -> LetCtx-mkLetCtx i = LetCtx IM.empty (Renames i IM.empty)--runEvalM :: Int- -> EvalM a- -> a-runEvalM i = flip evalState (mkLetCtx i)--eClosed :: Int- -> E (T K)- -> E (T K)-eClosed i = runEvalM i . eNorm--closedProgram :: Int- -> Program (T K)- -> E (T K)-closedProgram i (Program ds e) = runEvalM i $- traverse_ processDecl ds *> eNorm e--processDecl :: D (T K)- -> EvalM ()-processDecl SetFS{} = pure ()-processDecl (FunDecl (Name _ (Unique i) _) [] e) = do- e' <- eNorm e- modify (mapBinds (IM.insert i e'))--asTup :: Maybe RureMatch -> E (T K)-asTup Nothing = OptionVal undefined Nothing-asTup (Just (RureMatch s e)) = OptionVal undefined (Just $ Tup undefined (mkI . fromIntegral <$> [s, e]))---- don't need to rename op because it's being used in a map, can't affect etc.-applyUn :: E (T K)- -> E (T K)- -> EvalM (E (T K))-applyUn unOp e =- case eLoc unOp of- TyArr _ _ res -> eNorm (EApp res unOp e)- _ -> error "Internal error?"--applyOp :: E (T K)- -> E (T K)- -> E (T K)- -> EvalM (E (T K))-applyOp op@BBuiltin{} e e' = eNorm (EApp undefined (EApp undefined op e) e') -- short-circuit if not a lambda, don't need rename-applyOp op e e' = do { op' <- renameE op ; eNorm (EApp undefined (EApp undefined op' e) e') }--foldE :: E (T K)- -> E (T K)- -> V.Vector (E (T K))- -> EvalM (E (T K))-foldE op = V.foldM' (applyOp op)---- TODO: equality on tuples, lists-eNorm :: E (T K)- -> EvalM (E (T K))-eNorm e@Field{} = pure e-eNorm e@IntLit{} = pure e-eNorm e@FloatLit{} = pure e-eNorm e@BoolLit{} = pure e-eNorm e@StrLit{} = pure e-eNorm e@RegexLit{} = pure e-eNorm e@RegexCompiled{} = pure e-eNorm e@UBuiltin{} = pure e-eNorm e@Column{} = pure e-eNorm e@AllColumn{} = pure e-eNorm e@IParseCol{} = pure e-eNorm e@FParseCol{} = pure e-eNorm e@ParseCol{} = pure e-eNorm e@AllField{} = pure e-eNorm e@LastField{} = pure e-eNorm (Guarded ty pe e) = Guarded ty <$> eNorm pe <*> eNorm e-eNorm (Implicit ty e) = Implicit ty <$> eNorm e-eNorm (Lam ty n e) = Lam ty n <$> eNorm e-eNorm e@BBuiltin{} = pure e-eNorm e@TBuiltin{} = pure e-eNorm (Tup tys es) = Tup tys <$> traverse eNorm es-eNorm (Anchor ty es) = Anchor ty <$> traverse eNorm es-eNorm (NBuiltin ty None) = pure $ OptionVal ty Nothing-eNorm e@NBuiltin{} = pure e-eNorm (EApp ty op@BBuiltin{} e) = EApp ty op <$> eNorm e-eNorm (EApp ty (EApp ty' op@(BBuiltin _ Matches) e) e') = do- eI <- eNorm e- eI' <- eNorm e'- pure $ case (eI, eI') of- (StrLit _ str, RegexCompiled re) -> BoolLit tyBool (isMatch' re str)- _ -> EApp ty (EApp ty' op eI) eI'-eNorm (EApp ty (EApp ty' op@(BBuiltin _ NotMatches) e) e') = do- eI <- eNorm e- eI' <- eNorm e'- pure $ case (eI, eI') of- (StrLit _ str, RegexCompiled re) -> BoolLit tyBool (not $ isMatch' re str)- _ -> EApp ty (EApp ty' op eI) eI'-eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyInteger) _) Max) e) e') = do- eI <- eNorm e- eI' <- eNorm e'- pure $ case (eI, eI') of- (IntLit _ i, IntLit _ j) -> i `seq` j `seq` IntLit tyI (max i j)- _ -> EApp ty (EApp ty' op eI) eI'-eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyInteger) _) Min) e) e') = do- eI <- eNorm e- eI' <- eNorm e'- pure $ case (eI, eI') of- (IntLit _ i, IntLit _ j) -> i `seq` j `seq` IntLit tyI (min i j)- _ -> EApp ty (EApp ty' op eI) eI'-eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyFloat) _) Max) e) e') = do- eI <- eNorm e- eI' <- eNorm e'- pure $ case (eI, eI') of- (FloatLit _ x, FloatLit _ y) -> x `seq` y `seq` FloatLit tyF (max x y)- _ -> EApp ty (EApp ty' op eI) eI'-eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyFloat) _) Min) e) e') = do- eI <- eNorm e- eI' <- eNorm e'- pure $ case (eI, eI') of- (FloatLit _ x, FloatLit _ y) -> x `seq` y `seq` FloatLit tyF (min x y)- _ -> EApp ty (EApp ty' op eI) eI'-eNorm (EApp ty (EApp ty' op@(BBuiltin _ Split) e) e') = do- eI <- eNorm e- eI' <- eNorm e'- pure $ case (eI, eI') of- (StrLit l str, RegexCompiled re) -> let bss = splitBy re str in Arr undefined (StrLit l <$> bss)- _ -> EApp ty (EApp ty' op eI) eI'-eNorm (EApp ty (EApp ty' op@(BBuiltin _ Splitc) e) e') = do- eI <- eNorm e- eI' <- eNorm e'- pure $ case (eI, eI') of- (StrLit l str, StrLit _ c) -> let bss = BS.split (the c) str in Arr undefined (StrLit l <$> V.fromList bss)- _ -> EApp ty (EApp ty' op eI) eI'-eNorm (EApp ty op@(UBuiltin _ Floor) e) = do- eI <- eNorm e- pure $ case eI of- (FloatLit _ f) -> mkI (floor f)- _ -> EApp ty op eI-eNorm (EApp ty op@(UBuiltin _ Ceiling) e) = do- eI <- eNorm e- pure $ case eI of- (FloatLit _ f) -> mkI (ceiling f)- _ -> EApp ty op eI-eNorm (EApp ty0 (EApp ty1 op@(BBuiltin _ Minus) e) e') = do- eI <- eNorm e- eI' <- eNorm e'- pure $ case (eI, eI') of- (IntLit _ i, IntLit _ j) -> i `seq` j `seq` IntLit tyI (i-j)- (FloatLit _ i, FloatLit _ j) -> i `seq` j `seq` FloatLit tyF (i-j)- _ -> EApp ty0 (EApp ty1 op eI) eI'-eNorm (EApp ty (EApp ty' op@(BBuiltin _ Times) e) e') = do- eI <- eNorm e- eI' <- eNorm e'- pure $ case (eI, eI') of- (IntLit _ i, IntLit _ j) -> i `seq` j `seq` IntLit tyI (i*j)- (FloatLit _ i, FloatLit _ j) -> i `seq` j `seq` FloatLit tyF (i*j)- _ -> EApp ty (EApp ty' op eI) eI'-eNorm (EApp ty (EApp ty' op@(BBuiltin _ Plus) e) e') = do- eI <- eNorm e- eI' <- eNorm e'- pure $ case (eI, eI') of- (IntLit _ i, IntLit _ j) -> i `seq` j `seq` IntLit tyI (i+j)- (StrLit _ s, StrLit _ s') -> StrLit tyStr (s <> s') -- TODO: copy?- (RegexLit _ rr, RegexLit _ rr') -> RegexLit tyStr (rr <> rr')- (FloatLit _ i, FloatLit _ j) -> i `seq` j `seq` FloatLit tyF (i+j)- _ -> EApp ty (EApp ty' op eI) eI'-eNorm (EApp ty (EApp ty' op@(BBuiltin _ Div) e) e') = do- eI <- eNorm e- eI' <- eNorm e'- pure $ case (eI, eI') of- (FloatLit _ i, FloatLit _ j) -> i `seq` j `seq` FloatLit tyF (i/j)- _ -> EApp ty (EApp ty' op eI) eI'-eNorm (EApp ty (UBuiltin ty' Tally) e) = do- eI <- eNorm e- pure $ case eI of- StrLit _ str -> IntLit tyI (fromIntegral $ BS.length str)- _ -> EApp ty (UBuiltin ty' Tally) eI-eNorm (EApp ty op@(UBuiltin _ TallyList) e) = do- eI <- eNorm e- pure $ case eI of- (Arr _ xs) -> mkI $ fromIntegral $ V.length xs- _ -> EApp ty op eI-eNorm (EApp ty (EApp ty' op@(BBuiltin _ Lt) e) e') = do- eI <- eNorm e- eI' <- eNorm e'- pure $ case (eI, eI') of- (IntLit _ i, IntLit _ j) -> BoolLit tyBool (i < j)- (FloatLit _ i, FloatLit _ j) -> BoolLit tyBool (i < j)- _ -> EApp ty (EApp ty' op eI) eI'-eNorm (EApp ty (EApp ty' op@(BBuiltin _ Gt) e) e') = do- eI <- eNorm e- eI' <- eNorm e'- pure $ case (eI, eI') of- (IntLit _ i, IntLit _ j) -> BoolLit tyBool (i > j)- (FloatLit _ i, FloatLit _ j) -> BoolLit tyBool (i > j)- _ -> EApp ty (EApp ty' op eI) eI'-eNorm (EApp ty (EApp ty' op@(BBuiltin _ Eq) e) e') = do- eI <- eNorm e- eI' <- eNorm e'- pure $ case (eI, eI') of- (IntLit _ i, IntLit _ j) -> BoolLit tyBool (i == j)- (FloatLit _ i, FloatLit _ j) -> BoolLit tyBool (i == j)- (BoolLit _ b, BoolLit _ b') -> BoolLit tyBool (b == b')- (StrLit _ i, StrLit _ j) -> BoolLit tyBool (i == j)- _ -> EApp ty (EApp ty' op eI) eI'-eNorm (EApp ty (EApp ty' op@(BBuiltin _ Neq) e) e') = do- eI <- eNorm e- eI' <- eNorm e'- pure $ case (eI, eI') of- (IntLit _ i, IntLit _ j) -> BoolLit tyBool (i /= j)- (FloatLit _ i, FloatLit _ j) -> BoolLit tyBool (i /= j)- (StrLit _ i, StrLit _ j) -> BoolLit tyBool (i /= j)- (BoolLit _ b, BoolLit _ b') -> BoolLit tyBool (b /= b')- _ -> EApp ty (EApp ty' op eI) eI'-eNorm (EApp ty (EApp ty' op@(BBuiltin _ Leq) e) e') = do- eI <- eNorm e- eI' <- eNorm e'- pure $ case (eI, eI') of- (IntLit _ i, IntLit _ j) -> BoolLit tyBool (i <= j)- (FloatLit _ i, FloatLit _ j) -> BoolLit tyBool (i <= j)- _ -> EApp ty (EApp ty' op eI) eI'-eNorm (EApp ty (EApp ty' op@(BBuiltin _ Geq) e) e') = do- eI <- eNorm e- eI' <- eNorm e'- pure $ case (eI, eI') of- (IntLit _ i, IntLit _ j) -> BoolLit tyBool (i >= j)- (FloatLit _ i, FloatLit _ j) -> BoolLit tyBool (i >= j)- _ -> EApp ty (EApp ty' op eI) eI'-eNorm (EApp ty0 (EApp ty1 op@(BBuiltin _ And) e) e') = do- eI <- eNorm e- eI' <- eNorm e'- pure $ case (eI, eI') of- (BoolLit _ b, BoolLit _ b') -> b `seq` b' `seq` BoolLit tyBool (b && b')- _ -> EApp ty0 (EApp ty1 op eI) eI'-eNorm (EApp ty0 (EApp ty1 op@(BBuiltin _ Or) e) e') = do- eI <- eNorm e- eI' <- eNorm e'- pure $ case (eI, eI') of- (BoolLit _ b, BoolLit _ b') -> b `seq` b' `seq` BoolLit tyBool (b || b')- _ -> EApp ty0 (EApp ty1 op eI) eI'-eNorm (EApp _ (EApp _ (UBuiltin _ Const) e) _) = eNorm e-eNorm (EApp ty op@(UBuiltin _ Const) e) = EApp ty op <$> eNorm e-eNorm (EApp ty op@(UBuiltin _ Dedup) e) = EApp ty op <$> eNorm e-eNorm (EApp ty op@(UBuiltin _ (At i)) e) = do- eI <- eNorm e- pure $ case eI of- (Arr _ es) -> es V.! (i-1)- _ -> EApp ty op eI-eNorm (EApp ty op@(UBuiltin _ (Select i)) e) = do- eI <- eNorm e- pure $ case eI of- (Tup _ es) -> es !! (i-1)- _ -> EApp ty op eI-eNorm (EApp ty op@(UBuiltin _ Negate) e) = do- eI <- eNorm e- pure $ case eI of- (FloatLit _ f) -> mkF $ negate f- (IntLit _ i) -> mkI $ negate i- _ -> EApp ty op eI-eNorm (EApp ty op@(UBuiltin _ Not) e) = do- eI <- eNorm e- pure $ case eI of- (BoolLit _ b) -> BoolLit tyBool (not b)- _ -> EApp ty op eI-eNorm (EApp ty op@(UBuiltin _ IParse) e) = do- eI <- eNorm e- pure $ case eI of- (StrLit _ str) -> parseAsEInt str- _ -> EApp ty op eI-eNorm (EApp ty op@(UBuiltin _ FParse) e) = do- eI <- eNorm e- pure $ case eI of- (StrLit _ str) -> parseAsF str- _ -> EApp ty op eI-eNorm (EApp ty op@(UBuiltin (TyArr _ _ (TyB _ TyFloat)) Parse) e) = do- eI <- eNorm e- pure $ case eI of- (StrLit _ str) -> parseAsF str- _ -> EApp ty op eI-eNorm (EApp ty op@(UBuiltin (TyArr _ _ (TyB _ TyInteger)) Parse) e) = do- eI <- eNorm e- pure $ case eI of- (StrLit _ str) -> parseAsEInt str- _ -> EApp ty op eI-eNorm (EApp ty (UBuiltin _ Some) e) = do- eI <- eNorm e- pure $ OptionVal ty (Just eI)--- catMaybes only works for streams atm-eNorm (EApp ty op@(UBuiltin _ CatMaybes) e) = EApp ty op <$> eNorm e-eNorm Dfn{} = desugar-eNorm ResVar{} = desugar-eNorm (Let _ (Name _ (Unique i) _, b) e) = do- b' <- eNorm b- modify (mapBinds (IM.insert i b'))- eNorm e-eNorm e@(Var _ (Name _ (Unique i) _)) = do- st <- gets binds- case IM.lookup i st of- Just e'@Var{} -> eNorm e' -- no cyclic binds- Just e' -> renameE e' -- FIXME: set outermost type to be type of var...- Nothing -> pure e -- default to e in case var was bound in a lambda-eNorm (EApp ty e@Var{} e') = eNorm =<< (EApp ty <$> eNorm e <*> pure e')-eNorm (EApp _ (Lam _ (Name _ (Unique i) _) e) e') = do- e'' <- eNorm e'- modify (mapBinds (IM.insert i e''))- eNorm e-eNorm (EApp ty0 (EApp ty1 (EApp ty2 (TBuiltin ty3 Substr) e0) e1) e2) = do- e0' <- eNorm e0- e1' <- eNorm e1- e2' <- eNorm e2- pure $ case (e0', e1', e2') of- (StrLit _ str, IntLit _ i, IntLit _ j) -> mkStr (substr str (fromIntegral i) (fromIntegral j))- _ -> EApp ty0 (EApp ty1 (EApp ty2 (TBuiltin ty3 Substr) e0') e1') e2'-eNorm (EApp ty0 (EApp ty1 (EApp ty2 op@(TBuiltin _ Captures) e0) e1) e2) = do- e0' <- eNorm e0- e1' <- eNorm e1- e2' <- eNorm e2- pure $ case (e0', e1', e2') of- (StrLit _ str, IntLit _ ix, RegexCompiled re) -> OptionVal (tyOpt tyStr) (mkStr <$> findCapture re str (fromIntegral ix))- _ -> EApp ty0 (EApp ty1 (EApp ty2 op e0') e1') e2'-eNorm (EApp ty0 (EApp ty1 (EApp ty2 op@(TBuiltin _ AllCaptures) e0) e1) e2) = do- e0' <- eNorm e0- e1' <- eNorm e1- e2' <- eNorm e2- pure $ case (e0', e1', e2') of- (StrLit _ str, IntLit _ ix, RegexCompiled re) -> Arr (mkVec tyStr) (mkStr <$> V.fromList (captures' re str (fromIntegral ix)))- _ -> EApp ty0 (EApp ty1 (EApp ty2 op e0') e1') e2'-eNorm (EApp ty0 (EApp ty1 (EApp ty2 op@(TBuiltin _ Option) e0) e1) e2) = do- e0' <- eNorm e0- e1' <- eNorm e1- e2' <- eNorm e2- case e2' of- (OptionVal _ Nothing) -> pure e0'- (OptionVal _ (Just e)) -> eNorm (EApp undefined e1' e)- _ -> pure $ EApp ty0 (EApp ty1 (EApp ty2 op e0') e1') e2'-eNorm (EApp ty1 (EApp ty2 op@(TBuiltin _ Option) e0) e1) = do- e0' <- eNorm e0- e1' <- eNorm e1- pure $ EApp ty1 (EApp ty2 op e0') e1'-eNorm (EApp ty0 (EApp ty1 op@(BBuiltin _ Match) e) e') = do- eI <- eNorm e- eI' <- eNorm e'- pure $ case (eI, eI') of- (StrLit _ str, RegexCompiled re) -> asTup (find' re str)- _ -> EApp ty0 (EApp ty1 op eI) eI'-eNorm (EApp ty0 (EApp ty1 op@(BBuiltin _ Sprintf) e) e') = do- eI <- eNorm e- eI' <- eNorm e'- pure $ case (eI, eI') of- (StrLit _ fmt, _) | isReady eI' -> mkStr $ sprintf fmt eI'- _ -> EApp ty0 (EApp ty1 op eI) eI'-eNorm (EApp ty0 (EApp ty1 op@(BBuiltin (TyArr _ _ (TyArr _ _ (TyApp _ (TyB _ TyVec) _))) Map) x) y) = do- x' <- eNorm x- y' <- eNorm y- case y' of- Arr _ es -> Arr undefined <$> traverse (applyUn x') es -- TODO: undefined?- _ -> pure $ EApp ty0 (EApp ty1 op x') y'-eNorm (EApp ty0 (EApp ty1 op@(BBuiltin (TyArr _ _ (TyArr _ _ (TyApp _ (TyB _ TyOption) _))) Map) x) y) = do- x' <- eNorm x- y' <- eNorm y- case y' of- OptionVal _ e -> OptionVal undefined <$> traverse (applyUn x') e -- TODO: undefined?- _ -> pure $ EApp ty0 (EApp ty1 op x') y'-eNorm (EApp ty0 (EApp ty1 op@(BBuiltin (TyArr _ _ (TyArr _ (TyApp _ (TyB _ TyVec) _) _)) Fold1) f) x) = do- f' <- eNorm f- x' <- eNorm x- case x' of- Arr _ es -> case V.uncons es of { Just (y, ys) -> foldE f' y ys ; Nothing -> throw EmptyFold }- _ -> pure $ EApp ty0 (EApp ty1 op f') x'-eNorm (EApp ty0 (EApp ty1 (EApp ty2 op@(TBuiltin (TyArr _ _ (TyArr _ _ (TyArr _ (TyApp _ (TyB _ TyVec) _) _))) Fold) f) x) y) = do- f' <- eNorm f- x' <- eNorm x- y' <- eNorm y- case y' of- Arr _ es -> foldE f' x' es- _ -> pure $ EApp ty0 (EApp ty1 (EApp ty2 op f') x') y'-eNorm (EApp ty0 (EApp ty1 (EApp ty2 op@TBuiltin{} f) x) y) = EApp ty0 <$> (EApp ty1 <$> (EApp ty2 op <$> eNorm f) <*> eNorm x) <*> eNorm y--- we include this in case (+) has type (a->a->a) (for instance) if it is--- normalizing a decl (which can be ambiguous/general)-eNorm (EApp ty0 (EApp ty1 op@BBuiltin{} e) e') = EApp ty0 <$> (EApp ty1 op <$> eNorm e) <*> eNorm e'--- FIXME: monomorphize types after inlining-eNorm (EApp ty e@EApp{} e') =- eNorm =<< (EApp ty <$> eNorm e <*> pure e')-eNorm (Arr ty es) = Arr ty <$> traverse eNorm es-eNorm (OptionVal ty e) = OptionVal ty <$> traverse eNorm e-eNorm (Cond ty p e0 e1) = do- p' <- eNorm p- case p' of- BoolLit _ True -> eNorm e0- BoolLit _ False -> eNorm e1- _ -> Cond ty p' <$> eNorm e0 <*> eNorm e1 -- needed to perform substitutions-eNorm e = error ("Internal error: " ++ show e)
+ src/Jacinda/Backend/P.hs view
@@ -0,0 +1,453 @@+{-# LANGUAGE OverloadedStrings #-}++module Jacinda.Backend.P ( EvalErr (..), runJac, eB ) where++import A+import A.I+import Control.Exception (Exception, throw)+import Control.Monad (foldM, (<=<))+import Control.Monad.State.Strict (State, evalState, get, modify, runState)+import Data.Bifunctor (bimap)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as ASCII+import Data.Containers.ListUtils (nubOrdOn)+import Data.Foldable (traverse_)+import qualified Data.IntMap as IM+import Data.List (scanl', transpose, uncons, unzip4)+import Data.Maybe (catMaybes, mapMaybe)+import Data.Semigroup ((<>))+import qualified Data.Vector as V+import Data.Word (Word8)+import Jacinda.Backend.Const+import Jacinda.Backend.Parse+import Jacinda.Backend.Printf+import Jacinda.Fuse+import Jacinda.Regex+import Nm+import Prettyprinter (hardline, pretty)+import Prettyprinter.Render.Text (putDoc)+import Regex.Rure (RureMatch (RureMatch), RurePtr)+import System.IO (hFlush, stdout)+import Ty.Const+import U++φ1 :: E T -> Int+φ1 (BB (TyArr _ (TyArr (TyApp (TyB TyStream) _) _)) Fold1) = 1+φ1 (EApp _ e0 e1) = φ1 e0+φ1 e1+φ1 (Tup _ es) = sum (φ1<$>es)+φ1 (OptionVal _ (Just e)) = φ1 e+φ1 (Cond _ p e0 e1) = φ1 p+φ1 e0+φ1 e1+φ1 (Lam _ _ e) = φ1 e+φ1 _ = 0+++φ :: E T -> Int+φ (TB (TyArr _ (TyArr _ (TyArr (TyApp (TyB TyStream) _) _))) Fold) = 1+φ (EApp _ e0 e1) = φ e0+φ e1+φ (Tup _ es) = sum (φ<$>es)+φ (OptionVal _ (Just e)) = φ e+φ (Cond _ p e0 e1) = φ p+φ e0+φ e1+φ (Lam _ _ e) = φ e+φ _ = 0++noleak :: E T -> Bool+noleak e = φ e > 1 && φ1 e < 1++runJac :: RurePtr -- ^ Record separator+ -> Bool -- ^ Flush output?+ -> Int+ -> E T+ -> Either StreamError ([BS.ByteString] -> IO ())+runJac re f i e = ϝ (bsProcess re f) (if noleak e then fuse i e else (e, i)) where ϝ = uncurry.flip++data StreamError = NakedField deriving (Show)++instance Exception StreamError where++data EvalErr = EmptyFold+ | IndexOutOfBounds Int+ | InternalCoercionError (E T) TB+ | ExpectedTup (E T)+ | BadHole (Nm T)+ deriving (Show)++instance Exception EvalErr where++(!) :: V.Vector a -> Int -> a+v ! ix = case v V.!? ix of {Just x -> x; Nothing -> throw $ IndexOutOfBounds ix}++parseAsEInt :: BS.ByteString -> E T+parseAsEInt = mkI . readDigits++parseAsF :: BS.ByteString -> E T+parseAsF = FLit tyF . readFloat++readFloat :: BS.ByteString -> Double+readFloat = read . ASCII.unpack++the :: BS.ByteString -> Word8+the bs = case BS.uncons bs of+ Nothing -> error "Empty splitc char!"+ Just (c,b) | BS.null b -> c+ Just _ -> error "Splitc takes only one char!"++asTup :: Maybe RureMatch -> E T+asTup Nothing = OptionVal undefined Nothing+asTup (Just (RureMatch s e)) = OptionVal undefined (Just (Tup undefined (mkI . fromIntegral <$> [s, e])))++mkFoldVar :: Int -> b -> E b+mkFoldVar i l = Var l (Nm "fold_placeholder" (U i) l)++takeConcatMap :: (a -> [b]) -> [a] -> [b]+takeConcatMap f = concat . transpose . fmap f++-- this relies on all streams being the same length stream which in turn relies+-- on the fuse step (fold-of-filter->fold)+foldAll :: Int -> RurePtr -> [(Int, E T, E T, E T)] -> [BS.ByteString] -> ([(Int, E T)], Int)+foldAll i r xs bs = runState (foldMultiple seeds streams ctxStream ixStream) i+ where (ns, ops, seeds, es) = unzip4 xs+ mkStream e = eStream i r e bs+ streams = mkStream<$>es+ ctxStream = [(b, splitBy r b) | b <- bs]+ ixStream = [1..]++ foldMultiple seedsϵ esϵ (ctx:ctxes) (ix:ixes) = allHeads esϵ `seq` do {es' <- sequence$zipWith3 (c2Mϵ (pure.eCtx ctx ix)) ops seedsϵ (head<$>esϵ); foldMultiple es' (tail<$>esϵ) ctxes ixes}+ -- TODO: sanity check same length all streams+ foldMultiple seedsϵ _ [] _ = pure$zip ns seedsϵ++ allHeads = foldr seq ()++gf :: E T -> State (Int, [(Int, E T, E T, E T)]) (E T)+gf (EApp _ (EApp _ (EApp _ (TB _ Fold) op) seed) stream) | t@(TyApp (TyB TyStream) _) <- eLoc stream = do+ (i,_) <- get+ modify (bimap (+1) ((i, op, seed, stream) :))+ pure $ mkFoldVar i t+gf (EApp ty e0 e1) = EApp ty <$> gf e0 <*> gf e1+gf (Tup ty es) = Tup ty <$> traverse gf es+gf (Arr ty es) = Arr ty <$> traverse gf es+gf (OptionVal ty e) = OptionVal ty <$> traverse gf e+gf (Cond ty p e e') = Cond ty <$> gf p <*> gf e <*> gf e'+gf (Lam t n e) = Lam t n <$> gf e+gf e@BB{} = pure e; gf e@TB{} = pure e; gf e@UB{} = pure e; gf e@NB{} = pure e+gf e@StrLit{} = pure e; gf e@FLit{} = pure e; gf e@ILit{} = pure e; gf e@BLit{} = pure e+gf e@RC{} = pure e; gf e@Var{} = pure e++ug :: IM.IntMap (E T) -> E T -> E T+ug st (Var _ n@(Nm _ (U i) _)) =+ IM.findWithDefault (throw (BadHole n)) i st+ug _ e = e++bsProcess :: RurePtr+ -> Bool -- ^ Flush output?+ -> Int -- ^ Unique context+ -> E T+ -> Either StreamError ([BS.ByteString] -> IO ())+bsProcess _ _ _ AllField{} = Left NakedField+bsProcess _ _ _ Field{} = Left NakedField+bsProcess _ _ _ (NB _ Ix) = Left NakedField+bsProcess r f u e | (TyApp (TyB TyStream) _) <- eLoc e = Right (pS f.eStream u r e)+bsProcess r f u (Anchor _ es) = Right (\bs -> pS f $ takeConcatMap (\e -> eStream u r e bs) es)+bsProcess r _ u e =+ Right $ \bs -> pDocLn (eF u r e bs)++pDocLn = putDoc.(<>hardline).pretty++pS p = traverse_ g where g | p = (*>fflush).pDocLn | otherwise = pDocLn+ fflush = hFlush stdout++scanM :: Monad m => (b -> a -> m b) -> b -> [a] -> m [b]+scanM op seed xs = sequence $+ scanl' go (pure seed) xs where go seedϵ x = do {seedϵ' <- seedϵ; op seedϵ' x}++eF :: Int -> RurePtr -> E T -> [BS.ByteString] -> E T+eF u r e | noleak e = \bs ->+ let (eHoley, (_, folds)) = runState (gf e) (0, [])+ (filledHoles, u') = foldAll u r folds bs+ in eB u' (pure.ug (IM.fromList filledHoles)) eHoley+ | otherwise = \bs ->+ eB u (go bs) e+ where go bb (EApp _ (EApp _ (EApp _ (TB _ Fold) op) seed) xs) = do+ op' <- eBM pure op+ seed' <- eBM pure seed+ let xsϵ=eStream u r xs bb+ foldM (c2M op') seed' xsϵ+ go bb (EApp _ (EApp _ (BB _ Fold1) op) xs) = do+ op' <- eBM pure op+ let (seed',xsϵ)=case uncons $ eStream u r xs bb of {Just s -> s; Nothing -> throw EmptyFold}+ foldM (c2M op') seed' xsϵ+ go _ eϵ = pure eϵ+++a1 :: E T -> E T -> UM (E T)+a1 f x | TyArr _ cod <- eLoc f = lβ (EApp cod f x)++a2 :: E T -> E T -> E T -> UM (E T)+a2 op x0 x1 | TyArr _ t@(TyArr _ t') <- eLoc op = lβ (EApp t' (EApp t op x0) x1)++c1 :: Int -> E T -> E T -> E T+c1 i f x = evalState (eBM pure =<< a1 f x) i++c2M op x0 x1 = eBM pure =<< a2 op x0 x1+c2Mϵ f g e e' = eBM f =<< a2 g e e'++c2 :: Int -> E T -> E T -> E T -> E T+c2 i op x0 x1 = evalState (c2M op x0 x1) i++eStream :: Int -> RurePtr -> E T -> [BS.ByteString] -> [E T]+eStream u r (EApp _ (EApp _ (EApp _ (TB _ Scan) op) seed) xs) bs =+ let op'=eB u pure op; seed'=eB u pure seed; xsϵ=eStream u r xs bs+ in evalState (scanM (c2M op') seed' xsϵ) u+eStream i r (EApp _ (UB _ CatMaybes) e) bs = mapMaybe asM$eStream i r e bs+eStream u r (Implicit _ e) bs = zipWith (\fs i -> eB u (pure.eCtx fs i) e) [(b, splitBy r b) | b <- bs] [1..]+eStream _ _ AllColumn{} bs = mkStr<$>bs+eStream _ r (Column _ i) bs = mkStr.(! (i-1)).splitBy r<$>bs+eStream _ r (IParseCol _ n) bs = [parseAsEInt (splitBy r b ! (n-1)) | b <- bs]+eStream _ r (ParseCol (TyApp _ (TyB TyInteger)) n) bs = [parseAsEInt (splitBy r b ! (n-1)) | b <- bs]+eStream _ r (FParseCol _ n) bs = [parseAsF (splitBy r b ! (n-1)) | b <- bs]+eStream _ r (ParseCol (TyApp _ (TyB TyFloat)) n) bs = [parseAsF (splitBy r b ! (n-1)) | b <- bs]+eStream i r (EApp _ (EApp _ (BB _ MapMaybe) f) e) bs = let xs = eStream i r e bs in mapMaybe (asM.c1 i f) xs+eStream i r (EApp _ (EApp _ (BB _ Map) f) e) bs = let xs=eStream i r e bs in fmap (c1 i f) xs+eStream i r (EApp _ (EApp _ (BB _ Prior) op) e) bs = let xs=eStream i r e bs in zipWith (c2 i op) (tail xs) xs+eStream i r (EApp _ (EApp _ (BB _ Filter) p) e) bs = let xs=eStream i r e bs; ps=fmap (asB.c1 i p) xs in [x | (pϵ,x) <- zip ps xs, pϵ]+eStream i r (EApp _ (EApp _ (EApp _ (TB _ ZipW) f) e0) e1) bs = let xs0=eStream i r e0 bs; xs1=eStream i r e1 bs in zipWith (c2 i f) xs0 xs1+eStream i r (EApp (TyApp _ (TyB TyStr)) (UB _ Dedup) e) bs = let s = eStream i r e bs in nubOrdOn asS s+eStream i r (EApp (TyApp _ (TyB TyInteger)) (UB _ Dedup) e) bs = let s = eStream i r e bs in nubOrdOn asI s+eStream i r (EApp (TyApp _ (TyB TyFloat)) (UB _ Dedup) e) bs = let s = eStream i r e bs in nubOrdOn asF s+eStream i r (EApp _ (EApp _ (BB _ DedupOn) op) e) bs | TyArr _ (TyB TyStr) <- eLoc op = let xs = eStream i r e bs in nubOrdOn (asS.c1 i op) xs+eStream i r (EApp _ (EApp _ (BB _ DedupOn) op) e) bs | TyArr _ (TyB TyInteger) <- eLoc op = let xs = eStream i r e bs in nubOrdOn (asI.c1 i op) xs+eStream i r (EApp _ (EApp _ (BB _ DedupOn) op) e) bs | TyArr _ (TyB TyFloat) <- eLoc op = let xs = eStream i r e bs in nubOrdOn (asF.c1 i op) xs+eStream u r (Guarded _ p e) bs =+ let bss=(\b -> (b, splitBy r b))<$>bs+ in catMaybes $ zipWith (\fs i -> if asB (eB u (pure.eCtx fs i) p) then Just (eB u (pure.eCtx fs i) e) else Nothing) bss [1..]++asS :: E T -> BS.ByteString+asS (StrLit _ s) = s; asS e = throw (InternalCoercionError e TyStr)++asI :: E T -> Integer+asI (ILit _ i) = i; asI e = throw (InternalCoercionError e TyInteger)++asF :: E T -> Double+asF (FLit _ x) = x; asF e = throw (InternalCoercionError e TyFloat)++asR :: E T -> RurePtr+asR (RC r) = r; asR e = throw (InternalCoercionError e TyR)++asM :: E T -> Maybe (E T)+asM (OptionVal _ e) = e; asM e = throw (InternalCoercionError e TyOption)++asB :: E T -> Bool+asB (BLit _ b) = b; asB e = throw (InternalCoercionError e TyBool)++asV :: E T -> V.Vector (E T)+asV (Arr _ v) = v; asV e = throw (InternalCoercionError e TyVec)++asT :: E T -> [E T]+asT (Tup _ es) = es; asT e = throw (ExpectedTup e)++eCtx :: (BS.ByteString, V.Vector BS.ByteString) -- ^ Line, split by field separator+ -> Integer -- ^ Line number+ -> E T -> E T+eCtx ~(f, _) _ AllField{} = mkStr f+eCtx (_, fs) _ (Field _ i) = mkStr (fs ! (i-1))+eCtx (_, fs) _ LastField{} = mkStr (V.last fs)+eCtx _ i (NB _ Ix) = mkI i+eCtx (_, fs) _ (NB _ Nf) = mkI (fromIntegral$V.length fs)+eCtx _ _ e = e++eB :: Int -> (E T -> UM (E T)) -> E T -> E T+eB i f x = evalState (eBM f x) i++{-# SCC eBM #-}+eBM :: (E T -> UM (E T)) -> E T -> UM (E T)+eBM f (EApp t (EApp _ (EApp _ (TB _ Captures) s) i) r) = do+ s' <- eBM f s; i' <- eBM f i; r' <- eBM f r+ pure $ OptionVal t (mkStr <$> findCapture (asR r') (asS s') (fromIntegral$asI i'))+eBM f (EApp t (EApp _ (EApp _ (TB _ AllCaptures) s) i) r) = do+ s' <- eBM f s; i' <- eBM f i; r' <- eBM f r+ pure $ Arr t (V.fromList (mkStr <$> captures' (asR r') (asS s') (fromIntegral$asI i')))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyInteger) _) Max) x0) x1) = do+ x0' <- asI<$>eBM f x0; x1' <- asI<$>eBM f x1+ pure (mkI (max x0' x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyInteger) _) Min) x0) x1) = do+ x0' <- asI<$>eBM f x0; x1' <- asI<$>eBM f x1+ pure (mkI (min x0' x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyFloat) _) Min) x0) x1) = do+ x0' <- asF<$>eBM f x0; x1' <- asF<$>eBM f x1+ pure (mkF (min x0' x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyFloat) _) Max) x0) x1) = do+ x0' <- asF<$>eBM f x0; x1' <- asF<$>eBM f x1+ pure (mkF (max x0' x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyStr) _) Min) x0) x1) = do+ x0' <- asS<$>eBM f x0; x1' <- asS<$>eBM f x1+ pure (mkStr (min x0' x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyStr) _) Max) x0) x1) = do+ x0' <- asS<$>eBM f x0; x1' <- asS<$>eBM f x1+ pure (mkStr (max x0' x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyInteger) _) Plus) x0) x1) = do+ x0' <- asI <$> eBM f x0; x1' <- asI<$>eBM f x1+ pure (mkI (x0'+x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyInteger) _) Minus) x0) x1) = do+ x0' <- asI <$> eBM f x0; x1' <- asI<$>eBM f x1+ pure (mkI (x0'-x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyInteger) _) Times) x0) x1) = do+ x0' <- asI <$> eBM f x0; x1' <- asI<$>eBM f x1+ pure (mkI (x0'*x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyFloat) _) Plus) x0) x1) = do+ x0' <- asF <$> eBM f x0; x1' <- asF<$>eBM f x1+ pure (mkF (x0'+x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyFloat) _) Minus) x0) x1) = do+ x0' <- asF <$> eBM f x0; x1' <- asF<$>eBM f x1+ pure (mkF (x0'-x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyFloat) _) Times) x0) x1) = do+ x0' <- asF <$> eBM f x0; x1' <- asF<$>eBM f x1+ pure (mkF (x0'*x1'))+eBM f (EApp _ (EApp _ (BB _ Div) x0) x1) = do+ x0' <- asF <$> eBM f x0; x1' <- asF<$>eBM f x1+ pure (mkF (x0'/x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyInteger) _) Eq) x0) x1) = do+ x0' <- asI<$>eBM f x0; x1' <- asI<$>eBM f x1+ pure (mkB (x0'==x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyInteger) _) Neq) x0) x1) = do+ x0' <- asI<$>eBM f x0; x1' <- asI<$>eBM f x1+ pure (mkB (x0'/=x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyInteger) _) Gt) x0) x1) = do+ x0' <- asI<$>eBM f x0; x1' <- asI<$>eBM f x1+ pure (mkB (x0'>x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyInteger) _) Lt) x0) x1) = do+ x0' <- asI<$>eBM f x0; x1' <- asI<$>eBM f x1+ pure (mkB (x0'<x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyInteger) _) Leq) x0) x1) = do+ x0' <- asI<$>eBM f x0; x1' <- asI<$>eBM f x1+ pure (mkB (x0'<=x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyInteger) _) Geq) x0) x1) = do+ x0' <- asI<$>eBM f x0; x1' <- asI<$>eBM f x1+ pure (mkB (x0'>=x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyFloat) _) Gt) x0) x1) = do+ x0' <- asF<$>eBM f x0; x1' <- asF<$>eBM f x1+ pure (mkB (x0'>x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyFloat) _) Lt) x0) x1) = do+ x0' <- asF<$>eBM f x0; x1' <- asF<$>eBM f x1+ pure (mkB (x0'<x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyFloat) _) Eq) x0) x1) = do+ x0' <- asF<$>eBM f x0; x1' <- asF<$>eBM f x1+ pure (mkB (x0'==x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyFloat) _) Neq) x0) x1) = do+ x0' <- asF<$>eBM f x0; x1' <- asF<$>eBM f x1+ pure (mkB (x0'/=x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyFloat) _) Geq) x0) x1) = do+ x0' <- asF<$>eBM f x0; x1' <- asF<$>eBM f x1+ pure (mkB (x0'>=x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyFloat) _) Leq) x0) x1) = do+ x0' <- asF<$>eBM f x0; x1' <- asF<$>eBM f x1+ pure (mkB (x0'<=x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyStr) _) Eq) x0) x1) = do+ x0' <- asS<$>eBM f x0; x1' <- asS<$>eBM f x1+ pure (mkB (x0'==x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyStr) _) Neq) x0) x1) = do+ x0' <- asS<$>eBM f x0; x1' <- asS<$>eBM f x1+ pure (mkB (x0'/=x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyStr) _) Gt) x0) x1) = do+ x0' <- asS<$>eBM f x0; x1' <- asS<$>eBM f x1+ pure (mkB (x0'>x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyStr) _) Geq) x0) x1) = do+ x0' <- asS<$>eBM f x0; x1' <- asS<$>eBM f x1+ pure (mkB (x0'>=x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyStr) _) Lt) x0) x1) = do+ x0' <- asS<$>eBM f x0; x1' <- asS<$>eBM f x1+ pure (mkB (x0'<x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyStr) _) Leq) x0) x1) = do+ x0' <- asS<$>eBM f x0; x1' <- asS<$>eBM f x1+ pure (mkB (x0'<=x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyInteger) _) Exp) x0) x1) = do+ x0' <- asI <$> eBM f x0; x1' <- asI<$>eBM f x1+ pure (mkI (x0'^x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyFloat) _) Exp) x0) x1) = do+ x0' <- asF <$> eBM f x0; x1' <- asF<$>eBM f x1+ pure (mkF (x0'**x1'))+eBM f (EApp _ (EApp _ (BB (TyArr (TyApp (TyB TyVec) t) _) Eq) x0) x1) = do+ x0' <- asV<$>eBM f x0; x1' <- asV<$>eBM f x1+ mkB <$> if V.length x0'==V.length x1'+ then all asB <$> V.zipWithM (c2Mϵ f op) x0' x1'+ else pure False+ where op = BB (TyArr t (TyArr t tyB)) Eq+eBM f (EApp _ (EApp _ (BB (TyArr (TyApp (TyB TyOption) t) _) Eq) x0) x1) = do+ x0' <- asM<$>eBM f x0; x1' <- asM<$>eBM f x1+ case (x0',x1') of+ (Nothing, Nothing) -> pure (mkB True)+ (Nothing, Just{}) -> pure (mkB False)+ (Just{}, Nothing) -> pure (mkB False)+ (Just e0, Just e1) -> c2Mϵ f op e0 e1+ where op = BB (TyArr t (TyArr t tyB)) Eq+eBM f (EApp _ (EApp _ (BB (TyArr (TyB TyStr) _) Plus) x0) x1) = do+ x0' <- asS <$> eBM f x0; x1' <- asS<$>eBM f x1+ pure (mkStr (x0'<>x1'))+eBM f (EApp _ (EApp _ (BB _ And) x0) x1) = do+ x0' <- asB<$>eBM f x0; x1' <- asB<$>eBM f x1+ pure (mkB (x0'&&x1'))+eBM f (EApp _ (EApp _ (BB _ Or) x0) x1) = do+ x0' <- asB<$>eBM f x0; x1' <- asB<$>eBM f x1+ pure (mkB (x0'||x1'))+eBM f (EApp _ (UB _ Not) b) = do {b' <- asB<$>eBM f b; pure $ mkB (not b')}+eBM f (EApp _ (EApp _ (BB _ Matches) s) r) = {-# SCC "eBMMatch" #-} do+ s' <- asS<$>eBM f s; r' <- asR<$>eBM f r+ pure $ mkB (isMatch' r' s')+eBM f (EApp _ (EApp _ (BB _ NotMatches) s) r) = do+ s' <- asS<$>eBM f s; r' <- asR<$>eBM f r+ pure $ mkB (not$isMatch' r' s')+eBM f (EApp _ (EApp _ (BB _ Split) s) r) = do+ s' <- asS<$>eBM f s; r' <- asR<$>eBM f r+ pure (Arr (tyV tyStr) (mkStr<$>splitBy r' s'))+eBM f (EApp _ (EApp _ (BB _ Splitc) s) c) = do+ s' <- asS<$>eBM f s; c' <- the.asS<$>eBM f c+ pure (Arr (tyV tyStr) (mkStr <$> V.fromList (BS.split c' s')))+eBM f (EApp _ (UB _ FParse) x) = do {x' <- eBM f x; pure (parseAsF (asS x'))}+eBM f (EApp _ (UB _ IParse) x) = do {x' <- eBM f x; pure (parseAsEInt (asS x'))}+eBM f (EApp (TyB TyInteger) (UB _ Parse) x) = do {x' <- eBM f x; pure (parseAsEInt (asS x'))}+eBM f (EApp (TyB TyFloat) (UB _ Parse) x) = do {x' <- eBM f x; pure (parseAsF (asS x'))}+eBM f (EApp _ (UB _ (At i)) v) = do {v' <- eBM f v; pure (asV v'!(i-1))}+eBM f (EApp _ (UB _ (Select i)) x) = do {x' <- eBM f x; pure (asT x' !! (i-1))}+eBM f (EApp _ (UB _ Floor) x) = do {xr <- asF<$>eBM f x; pure $ mkI (floor xr)}+eBM f (EApp _ (UB _ Ceiling) x) = do {xr <- asF<$>eBM f x; pure $ mkI (ceiling xr)}+eBM f (EApp (TyB TyInteger) (UB _ Negate) i) = do {i' <- eBM f i; pure $ mkI (negate (asI i'))}+eBM f (EApp (TyB TyFloat) (UB _ Negate) x) = do {x' <- eBM f x; pure $ mkF (negate (asF x'))}+eBM f (EApp t (UB _ Some) e) = do {e' <- eBM f e; pure (OptionVal t (Just e'))}+eBM _ (NB t None) = pure (OptionVal t Nothing)+eBM f (EApp _ (UB _ Tally) e) = do+ s' <- eBM f e+ let r =fromIntegral (BS.length$asS s')+ pure (mkI r)+eBM f (EApp _ (UB _ TallyList) e) = do+ e' <- eBM f e+ let r=fromIntegral (V.length$asV e')+ pure (mkI r)+eBM f (EApp _ (EApp _ (UB _ Const) e) _) = eBM f e+eBM f (EApp _ (EApp _ (BB _ Sprintf) fs) s) = do+ fs' <- eBM f fs; s' <- eBM f s+ pure $ mkStr (sprintf (asS fs') s')+eBM f (EApp _ (EApp _ (BB _ Match) s) r) = do+ s' <- eBM f s; r' <- eBM f r+ pure $ asTup (find' (asR r') (asS s'))+eBM f (EApp _ (EApp _ (EApp _ (TB _ Fold) op) seed) xs) | TyApp (TyB TyVec) _ <- eLoc xs = do+ op' <- eBM f op; seed' <- eBM f seed; xs' <- eBM f xs+ V.foldM (c2Mϵ f op') seed' (asV xs')+eBM f (EApp _ (EApp _ (BB _ Fold1) op) xs) | TyApp (TyB TyVec) _ <- eLoc xs = do+ op' <- eBM f op; xs' <- eBM f xs+ let xsV=asV xs'; Just (seed, xs'') = V.uncons xsV+ V.foldM (c2Mϵ f op') seed xs''+eBM f (EApp yT@(TyApp (TyB TyOption) _) (EApp _ (BB _ Map) g) x) = do+ g' <- eBM f g; x' <- eBM f x+ OptionVal yT <$> traverse (eBM f <=< a1 g') (asM x')+eBM f (EApp yT@(TyApp (TyB TyVec) _) (EApp _ (BB _ Map) g) x) = do+ g' <- eBM f g; x' <- eBM f x+ Arr yT <$> traverse (eBM f <=< a1 g') (asV x')+eBM f (EApp t (EApp _ (EApp _ (TB _ Option) x) g) y) = do+ x' <- eBM f x; g' <- eBM f g; y' <- eBM f y+ case asM y' of+ Nothing -> pure x'+ Just yϵ -> eBM f =<< lβ (EApp t g' yϵ)+eBM f (EApp _ (EApp _ (EApp _ (TB _ Substr) s) i0) i1) = do+ i0' <- eBM f i0; i1' <- eBM f i1; s' <- eBM f s+ pure $ mkStr (substr (asS s') (fromIntegral$asI i0') (fromIntegral$asI i1'))+eBM f (Cond _ p e e') = do {p' <- eBM f p; if asB p' then eBM f e else eBM f e'}+eBM f (Tup t es) = Tup t <$> traverse (eBM f) es+eBM f e = f e
+ src/Jacinda/Backend/Parse.hs view
@@ -0,0 +1,12 @@+module Jacinda.Backend.Parse ( readDigits ) where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as ASCII++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
@@ -1,23 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} module Jacinda.Backend.Printf ( sprintf- , isReady ) where +import A import qualified Data.ByteString as BS import Data.Semigroup ((<>)) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8)-import Jacinda.AST -isReady :: E a -> Bool-isReady FloatLit{} = True-isReady StrLit{} = True-isReady IntLit{} = True-isReady BoolLit{} = True-isReady (Tup _ es) = all isReady es-isReady _ = False- sprintf :: BS.ByteString -- ^ Format string -> E a -> BS.ByteString@@ -28,10 +19,10 @@ -- TODO: interpret precision, like %0.6f %.6 sprintf' :: T.Text -> E a -> T.Text-sprintf' fmt (FloatLit _ f) =+sprintf' fmt (FLit _ f) = let (prefix, fmt') = T.breakOn "%f" fmt in prefix <> T.pack (show f) <> T.drop 2 fmt'-sprintf' fmt (IntLit _ i) =+sprintf' fmt (ILit _ i) = let (prefix, fmt') = T.breakOn "%i" fmt in prefix <> T.pack (show i) <> T.drop 2 fmt' sprintf' fmt (StrLit _ bs) =@@ -41,7 +32,7 @@ sprintf' fmt (Tup l (e:es)) = let nextFmt = sprintf' fmt e in sprintf' nextFmt (Tup l es)-sprintf' fmt (BoolLit _ b) =+sprintf' fmt (BLit _ b) = let (prefix, fmt') = T.breakOn "%b" fmt in prefix <> showBool b <> T.drop 2 fmt' where showBool True = "true"
− src/Jacinda/Backend/TreeWalk.hs
@@ -1,591 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- | Tree-walking interpreter-module Jacinda.Backend.TreeWalk ( runJac- ) where---- TODO: normalize before mapping?--import Control.Exception (Exception, throw)-import Control.Monad.State.Strict (State, get, modify, runState)-import Data.Bifunctor (bimap)-import qualified Data.ByteString as BS-import Data.Containers.ListUtils (nubIntOn, nubOrdOn)-import Data.Foldable (foldl', traverse_)-import qualified Data.IntMap as IM-import Data.List (scanl', transpose, unzip4)-import Data.List.Ext-import Data.Maybe (mapMaybe)-import Data.Semigroup ((<>))-import qualified Data.Vector as V-import Intern.Name (Name (Name))-import Intern.Unique (Unique (Unique))-import Jacinda.AST-import Jacinda.Backend.Normalize-import Jacinda.Backend.Printf-import Jacinda.Regex (captures', find', findCapture, isMatch', splitBy, substr)-import Jacinda.Ty.Const-import Regex.Rure (RurePtr)--data StreamError = NakedField- | UnevalFun- | TupOfStreams -- ^ Reject a tuple of streams- | BadCtx- | InternalError- deriving (Show)--instance Exception StreamError where--(!) :: V.Vector a -> Int -> a-v ! ix = case v V.!? ix of- Just x -> x- Nothing -> throw $ IndexOutOfBounds ix--noRes :: E b -> String -> a-noRes e ty = error ("Internal error: " ++ show e ++ " did not normalize to appropriate type, expected " ++ ty)--badSugar :: a-badSugar = error "Internal error: dfn syntactic sugar at a stage where it should not be."--asInt :: E a -> Integer-asInt (IntLit _ i) = i-asInt e = noRes e "Int"--asBool :: E a -> Bool-asBool (BoolLit _ b) = b-asBool e = noRes e "Bool"--asStr :: E a -> BS.ByteString-asStr (StrLit _ str) = str-asStr e = noRes e "Str"--asFloat :: E a -> Double-asFloat (FloatLit _ f) = f-asFloat e = noRes e "Float"--asRegex :: E a -> RurePtr-asRegex (RegexCompiled re) = re-asRegex e = noRes e "Regex"--asArr :: E a -> V.Vector (E a)-asArr (Arr _ es) = es-asArr e = noRes e "List"--asOpt :: E a -> Maybe (E a)-asOpt (OptionVal _ e) = e-asOpt e = noRes e "Option"---- eval-eEval :: (Int, BS.ByteString, V.Vector BS.ByteString) -- ^ Field context (for that line)- -> E (T K)- -> E (T K)-eEval (ix, line, ctx) = go where- go b@BoolLit{} = b- go i@IntLit{} = i- go f@FloatLit{} = f- go str@StrLit{} = str- go rr@RegexLit{} = rr- go reϵ@RegexCompiled{} = reϵ- go op@BBuiltin{} = op- go op@UBuiltin{} = op- go op@TBuiltin{} = op- go (NBuiltin _ Nf) = mkI (fromIntegral $ V.length ctx)- go (EApp ty op@BBuiltin{} e) = EApp ty op (go e)- go (NBuiltin _ Ix) = mkI (fromIntegral ix)- go (NBuiltin _ None) = OptionVal undefined Nothing- go (EApp ty (UBuiltin _ Some) e) =- let eI = go e- in OptionVal ty (Just eI)- go AllField{} = StrLit tyStr line- go (Field _ i) = StrLit tyStr (ctx ! (i-1)) -- cause vector indexing starts at 0- go LastField{} = StrLit tyStr (V.last ctx)- go (EApp _ (UBuiltin _ IParse) e) =- let eI = asStr (go e)- in parseAsEInt eI- go (EApp _ (UBuiltin (TyArr _ (TyB _ TyInteger) _) Negate) e) =- let eI = asInt (go e)- in mkI (negate eI)- go (EApp _ (UBuiltin (TyArr _ (TyB _ TyFloat) _) Negate) e) =- let eI = asFloat (go e)- in mkF (negate eI)- go (EApp _ (UBuiltin _ FParse) e) =- let eI = asStr (go e)- in parseAsF eI- go (EApp _ (UBuiltin (TyArr _ _ (TyB _ TyInteger)) Parse) e) =- let eI = asStr (go e)- in parseAsEInt eI- go (EApp _ (UBuiltin (TyArr _ _ (TyB _ TyFloat)) Parse) e) =- let eI = asStr (go e)- in parseAsF eI- go (EApp _ (EApp _ (BBuiltin _ Matches) e) e') =- let eI = go e- eI' = go e'- in case (eI, eI') of- (StrLit _ strϵ, RegexCompiled reϵ) -> BoolLit tyBool (isMatch' reϵ strϵ)- (StrLit{}, _) -> noRes eI' "Regex"- _ -> noRes eI "Str"- go (EApp _ (EApp _ (BBuiltin _ NotMatches) e) e') =- let eI = go e- eI' = go e'- in case (eI, eI') of- (StrLit _ strϵ, RegexCompiled reϵ) -> BoolLit tyBool (not $ isMatch' reϵ strϵ)- (StrLit{}, _) -> noRes eI' "Regex"- _ -> noRes eI "Str"- go (EApp _ (EApp _ (BBuiltin _ Match) e) e') =- let eI = asRegex (go e)- eI' = asStr (go e')- in asTup (find' eI eI')- go (EApp _ (EApp _ (EApp _ (TBuiltin _ Captures) e0) e1) e2) =- let e0' = asStr (go e0)- e1' = asInt (go e1)- e2' = asRegex (go e2)- in OptionVal (tyOpt tyStr) (mkStr <$> findCapture e2' e0' (fromIntegral e1'))- go (EApp _ (EApp _ (EApp _ (TBuiltin _ AllCaptures) e0) e1) e2) =- let e0' = asStr (go e0)- e1' = asInt (go e1)- e2' = asRegex (go e2)- in Arr (mkVec tyStr) (mkStr <$> V.fromList (captures' e2' e0' (fromIntegral e1')))- go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyInteger) _) Plus) e) e') =- let eI = asInt (go e)- eI' = asInt (go e')- in mkI (eI + eI')- go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyInteger) _) Minus) e) e') =- let eI = asInt (go e)- eI' = asInt (go e')- in mkI (eI - eI')- go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyInteger) _) Times) e) e') =- let eI = asInt (go e)- eI' = asInt (go e')- in mkI (eI * eI')- go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyStr) _) Plus) e) e') =- let eI = asStr (go e)- eI' = asStr (go e')- -- TODO: copy??- in mkStr (eI <> eI')- go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyStr) _) Eq) e) e') =- let eI = asStr (go e)- eI' = asStr (go e')- in BoolLit tyBool (eI == eI')- go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyInteger) _) Gt) e) e') =- let eI = asInt (go e)- eI' = asInt (go e')- in BoolLit tyBool (eI > eI')- go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyInteger) _) Lt) e) e') =- let eI = asInt (go e)- eI' = asInt (go e')- in BoolLit tyBool (eI < eI')- go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyInteger) _) Eq) e) e') =- let eI = asInt (go e)- eI' = asInt (go e')- in BoolLit tyBool (eI == eI')- go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyInteger) _) Neq) e) e') =- let eI = asInt (go e)- eI' = asInt (go e')- in BoolLit tyBool (eI == eI')- go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyStr) _) Neq) e) e') =- let eI = asStr (go e)- eI' = asStr (go e')- in BoolLit tyBool (eI /= eI')- go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyInteger) _) Leq) e) e') =- let eI = asInt (go e)- eI' = asInt (go e')- in BoolLit tyBool (eI <= eI')- go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyInteger) _) Geq) e) e') =- let eI = asInt (go e)- eI' = asInt (go e')- in BoolLit tyBool (eI <= eI')- go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyFloat) _) Eq) e) e') =- let eI = asFloat (go e)- eI' = asFloat (go e')- in BoolLit tyBool (eI == eI')- go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyFloat) _) Neq) e) e') =- let eI = asFloat (go e)- eI' = asFloat (go e')- in BoolLit tyBool (eI /= eI')- go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyFloat) _) Lt) e) e') =- let eI = asFloat (go e)- eI' = asFloat (go e')- in BoolLit tyBool (eI < eI')- go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyFloat) _) Gt) e) e') =- let eI = asFloat (go e)- eI' = asFloat (go e')- in BoolLit tyBool (eI > eI')- go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyFloat) _) Geq) e) e') =- let eI = asFloat (go e)- eI' = asFloat (go e')- in BoolLit tyBool (eI >= eI')- go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyFloat) _) Leq) e) e') =- let eI = asFloat (go e)- eI' = asFloat (go e')- in BoolLit tyBool (eI <= eI')- go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyFloat) _) Plus) e) e') =- let eI = asFloat (go e)- eI' = asFloat (go e')- in mkF (eI + eI')- go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyFloat) _) Minus) e) e') =- let eI = asFloat (go e)- eI' = asFloat (go e')- in mkF (eI - eI')- go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyFloat) _) Times) e) e') =- let eI = asFloat (go e)- eI' = asFloat (go e')- in FloatLit tyF (eI * eI')- go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyBool) _) Eq) e) e') =- let eI = asBool (go e)- eI' = asBool (go e')- in BoolLit tyBool (eI == eI')- go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyBool) _) Neq) e) e') =- let eI = asBool (go e)- eI' = asBool (go e')- in BoolLit tyBool (eI /= eI')- go (EApp _ (EApp _ (BBuiltin _ Div) e) e') =- let eI = asFloat (go e)- eI' = asFloat (go e')- in FloatLit tyF (eI / eI')- go (EApp _ (EApp _ (BBuiltin _ And) e) e') =- let b = asBool (go e)- b' = asBool (go e')- in BoolLit tyBool (b && b')- go (EApp _ (EApp _ (BBuiltin _ Or) e) e') =- let b = asBool e- b' = asBool e'- in BoolLit tyBool (b || b')- go (EApp _ (UBuiltin _ Tally) e) =- mkI (fromIntegral $ BS.length str)- where str = asStr (go e)- go (EApp _ (UBuiltin _ Floor) e) =- let f = asFloat e- in mkI (floor f)- go (EApp _ (UBuiltin _ Ceiling) e) =- let f = asFloat e- in mkI (ceiling f)- go (Tup ty es) = Tup ty (go <$> es)- go (EApp _ (EApp _ (BBuiltin _ Split) e) e') =- let str = asStr (go e)- re = asRegex (go e')- bss = splitBy re str- in Arr undefined (mkStr <$> bss)- go (EApp _ (EApp _ (BBuiltin _ Splitc) e) e') =- let str = asStr (go e)- c = the (asStr (go e'))- bss = BS.split c str- in Arr undefined (mkStr <$> V.fromList bss)- go (EApp _ (EApp _ (EApp _ (TBuiltin _ Substr) e0) e1) e2) =- let eI0 = asStr (go e0)- eI1 = asInt (go e1)- eI2 = asInt (go e2)- in mkStr (substr eI0 (fromIntegral eI1) (fromIntegral eI2))- go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyFloat) _) Max) e) e') =- let eI = asFloat (go e)- eI' = asFloat (go e')- in mkF (max eI eI')- go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyFloat) _) Min) e) e') =- let eI = asFloat (go e)- eI' = asFloat (go e')- in mkF (min eI eI')- go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyInteger) _) Max) e) e') =- let eI = asInt (go e)- eI' = asInt (go e')- in mkI (max eI eI')- go (EApp _ (EApp _ (BBuiltin (TyArr _ (TyB _ TyInteger) _) Min) e) e') =- let eI = asInt (go e)- eI' = asInt (go e')- in mkI (min eI eI')- go (EApp _ (UBuiltin _ Not) e) =- let eI = asBool (go e)- in BoolLit tyBool (not eI)- go (EApp _ (UBuiltin _ (At i)) e) =- let eI = go e- in case eI of- (Arr _ es) -> go (es V.! (i-1))- _ -> noRes eI "List"- go (EApp _ (UBuiltin _ (Select i)) e) =- let eI = go e- in case eI of- (Tup _ es) -> go (es !! (i-1))- _ -> noRes eI "Tuple"- go (EApp _ (EApp _ (BBuiltin _ Sprintf) e) e') =- let eI = asStr (go e)- eI' = go e'- in mkStr (sprintf eI eI')- go (OptionVal ty e) =- OptionVal ty (go <$> e)- go (EApp _ (EApp _ (EApp _ (TBuiltin _ Option) e0) e1) e2) =- let e0' = go e0- e1' = go e1- e2' = go e2- in case asOpt e2' of- Nothing -> e0'- Just e -> go (EApp undefined e1' e)- go (EApp _ (EApp _ (BBuiltin (TyArr _ _ (TyArr _ _ (TyApp _ (TyB _ TyVec) _))) Map) x) y) =- let x' = go x- y' = asArr (go y)- in Arr undefined (applyUn' x' <$> y')- where applyUn' :: E (T K) -> E (T K) -> E (T K)- applyUn' e e' = go (EApp undefined e e')- go (EApp _ (EApp _ (BBuiltin (TyArr _ _ (TyArr _ _ (TyApp _ (TyB _ TyOption) _))) Map) x) y) =- let x' = go x- y' = asOpt (go y)- in OptionVal undefined (applyUn' x' <$> y')- where applyUn' :: E (T K) -> E (T K) -> E (T K)- applyUn' e e' = go (EApp undefined e e')- go (EApp _ (EApp _ (EApp _ (TBuiltin (TyArr _ _ (TyArr _ _ (TyArr _ (TyApp _ (TyB _ TyVec) _) _))) Fold) f) seed) xs) =- let f' = go f- seed' = go seed- xs' = asArr (go xs)- in foldE f' seed' xs'- where foldE op = V.foldl' (applyOp' op)- applyOp' op e e' = go (EApp undefined (EApp undefined op e) e')- go (EApp _ (EApp _ (BBuiltin (TyArr _ _ (TyArr _ (TyApp _ (TyB _ TyVec) _) _)) Fold1) f) xs) =- let f' = go f- xs' = asArr (go xs)- in- case V.uncons xs' of- Just (y, ys) -> foldE f' y ys- Nothing -> throw EmptyFold- where foldE op = V.foldl' (applyOp' op)- applyOp' op e e' = go (EApp undefined (EApp undefined op e) e')- go (Arr ty es) = Arr ty (go <$> es)- go (Cond _ p e0 e1) =- let p' = asBool (go p)- in if p' then go e0 else go e1- go (EApp _ (UBuiltin _ TallyList) e) =- let xs = asArr (go e)- in mkI $ fromIntegral $ V.length xs- go e = error ("Internal error: " ++ show e)---- just shove some big number into the renamer and hope it doesn't clash (bad,--- hack, this is why we got kicked out of the garden of Eden)-reprehensible :: Int-reprehensible = (maxBound :: Int) `div` 2--applyOp :: E (T K) -- ^ Operator- -> E (T K)- -> E (T K)- -> E (T K)-applyOp op e e' = eClosed reprehensible (EApp undefined (EApp undefined op e) e') -- FIXME: undefined is ??--atField :: RurePtr- -> Int- -> BS.ByteString -- ^ Line- -> BS.ByteString-atField re i = (! (i-1)) . splitBy re--mkCtx :: RurePtr -> Int -> BS.ByteString -> (Int, BS.ByteString, V.Vector BS.ByteString)-mkCtx re ix line = (ix, line, splitBy re line)--applyUn :: E (T K)- -> E (T K)- -> E (T K)-applyUn unOp e =- case eLoc unOp of- TyArr _ _ res -> eClosed reprehensible (EApp res unOp e)- _ -> error "Internal error?"---- | Turn an expression representing a stream into a stream of expressions (using line as context)-ir :: RurePtr- -> E (T K)- -> [BS.ByteString]- -> [E (T K)] -- TODO: include chunks/context too?-ir _ AllColumn{} = fmap mkStr-ir re (Column _ i) = fmap (mkStr . atField re i)-ir re (IParseCol _ i) = fmap (parseAsEInt . atField re i)-ir re (FParseCol _ i) = fmap (parseAsF . atField re i)-ir re (ParseCol ty@(TyApp _ _ (TyB _ TyFloat)) i) = ir re (FParseCol ty i)-ir re (ParseCol ty@(TyApp _ _ (TyB _ TyInteger)) i) = ir re (IParseCol ty i)-ir re (Implicit _ e) =- imap (\ix line -> eEval (mkCtx re ix line) e)-ir re (Guarded _ pe e) =- -- TODO: normalize before stream- fmap (\(ix, line) -> eEval (mkCtx re ix line) e) . ifilter' (\ix line -> asBool (eEval (mkCtx re ix line) pe))-ir re (EApp _ (EApp _ (BBuiltin _ Map) op) stream) = fmap (applyUn op) . ir re stream-ir re (EApp _ (EApp _ (BBuiltin _ Filter) op) stream) =- filter (asBool . applyUn op) . ir re stream-ir re (EApp _ (EApp _ (BBuiltin _ MapMaybe) op) stream) =- mapMaybe (asOpt . applyUn op) . ir re stream-ir re (EApp _ (UBuiltin _ CatMaybes) stream) =- mapMaybe asOpt . ir re stream-ir re (EApp _ (EApp _ (BBuiltin _ Prior) op) stream) = prior (applyOp op) . ir re stream-ir re (EApp _ (EApp _ (EApp _ (TBuiltin _ ZipW) op) streaml) streamr) = \lineStream ->- let- irl = ir re streaml lineStream- irr = ir re streamr lineStream- in zipWith (applyOp op) irl irr-ir re (EApp _ (EApp _ (EApp _ (TBuiltin _ Scan) op) seed) xs) =- scanl' (applyOp op) seed . ir re xs-ir re (EApp _ (UBuiltin (TyArr _ (TyApp _ _ (TyB _ TyStr)) _) Dedup) e) =- nubOrdOn asStr . ir re e-ir re (EApp _ (UBuiltin (TyArr _ (TyApp _ _ (TyB _ TyInteger)) _) Dedup) e) =- nubIntOn (fromIntegral . asInt) . ir re e-ir re (EApp _ (UBuiltin (TyArr _ (TyApp _ _ (TyB _ TyFloat)) _) Dedup) e) =- nubIntOn (fromEnum . asFloat) . ir re e-ir re (EApp _ (UBuiltin (TyArr _ (TyApp _ _ (TyB _ TyBool)) _) Dedup) e) =- nubIntOn (fromEnum . asBool) . ir re e---- | Output stream that prints each entry (expression)-printStream :: [E (T K)] -> IO ()-printStream = traverse_ print--foldWithCtx :: RurePtr- -> E (T K)- -> E (T K)- -> E (T K)- -> [BS.ByteString]- -> E (T K)-foldWithCtx re op seed streamExpr = foldl' (applyOp op) seed . ir re streamExpr--fold1 :: RurePtr- -> E (T K)- -> E (T K)- -> [BS.ByteString]- -> E (T K)-fold1 re op streamExpr bs =- case ir re streamExpr bs of- e:es -> foldl' (applyOp op) e es- _ -> throw EmptyFold--runJac :: RurePtr -- ^ Record separator- -> Int- -> Program (T K)- -> Either StreamError ([BS.ByteString] -> IO ())-runJac re i e = fileProcessor re (closedProgram i e)--foldAll :: RurePtr- -> [(Int, E (T K), E (T K), E (T K))]- -> [BS.ByteString]- -> [(Int, E (T K))]-foldAll re foldExprs bs = evalAll seeds (mkStreams streamExprs) where- (is, ops, seeds, streamExprs) = unzip4 foldExprs- mkStreams = fmap (\streamExpr -> ir re streamExpr bs)-- evalAll seedsϵ ess | not (any null ess) = let es' = zipWith3 applyOp' ops seedsϵ (headMaybe <$> ess) in es' `seqAll` evalAll es' (tail' <$> ess)- -- if I try to use the (all null ess) criterion it space- -- leaks like crazy so... inspect only when we need?- --- -- (still leaks space... but less)- | not (all null ess) = let es' = zipWith3 applyOp' ops seedsϵ (headMaybe <$> ess) in es' `seqAll` evalAll es' (tail' <$> ess)- | otherwise = zip is seedsϵ-- seqAll (e:es) z = foldr seq e es `seq` z- seqAll [] z = z-- applyOp' op seed (Just e) = applyOp op seed e- applyOp' _ seed Nothing = seed-- headMaybe [] = Nothing- headMaybe (x:_) = Just x-- tail' [] = []- tail' (_:xs) = xs--ungather :: IM.IntMap (E (T K)) -> E (T K) -> E (T K)-ungather st (Var _ (Name _ (Unique i) _)) =- case IM.lookup i st of- Just res -> res- Nothing -> throw InternalError-ungather st (EApp ty e0 e1) = EApp ty (ungather st e0) (ungather st e1)-ungather st (Tup ty es) = Tup ty (ungather st <$> es)-ungather st (Arr ty es) = Arr ty (ungather st <$> es)-ungather st (OptionVal ty e) = OptionVal ty (ungather st <$> e)-ungather _ e@BBuiltin{} = e-ungather _ e@UBuiltin{} = e-ungather _ (NBuiltin _ None) = OptionVal undefined Nothing-ungather _ e@NBuiltin{} = e-ungather _ e@TBuiltin{} = e-ungather _ e@StrLit{} = e-ungather _ e@BoolLit{} = e-ungather _ e@FloatLit{} = e-ungather _ e@IntLit{} = e--mkFoldVar :: Int -> b -> E b-mkFoldVar i l = Var l (Name "fold_placeholder" (Unique i) l)--gatherFoldsM :: E (T K) -> State (Int, [(Int, E (T K), E (T K), E (T K))]) (E (T K))-gatherFoldsM (EApp _ (EApp _ (EApp _ (TBuiltin (TyArr _ _ (TyArr _ _ (TyArr _ (TyApp _ (TyB _ TyStream) _) _))) Fold) op) seed) stream) = do- (i,_) <- get- modify (bimap (+1) ((i, op, seed, stream) :))- pure $ mkFoldVar i undefined-gatherFoldsM (EApp ty e0 e1) = EApp ty <$> gatherFoldsM e0 <*> gatherFoldsM e1-gatherFoldsM (Tup ty es) = Tup ty <$> traverse gatherFoldsM es-gatherFoldsM (Arr ty es) = Arr ty <$> traverse gatherFoldsM es-gatherFoldsM (OptionVal ty e) = OptionVal ty <$> traverse gatherFoldsM e-gatherFoldsM (Cond ty p e e') = Cond ty <$> gatherFoldsM p <*> gatherFoldsM e <*> gatherFoldsM e'-gatherFoldsM (NBuiltin _ None) = pure $ OptionVal undefined Nothing-gatherFoldsM e@BBuiltin{} = pure e-gatherFoldsM e@TBuiltin{} = pure e-gatherFoldsM e@UBuiltin{} = pure e-gatherFoldsM e@NBuiltin{} = pure e-gatherFoldsM e@StrLit{} = pure e-gatherFoldsM e@FloatLit{} = pure e-gatherFoldsM e@IntLit{} = pure e-gatherFoldsM e@BoolLit{} = pure e--eWith :: RurePtr -> E (T K) -> [BS.ByteString] -> E (T K)-eWith re (EApp _ (EApp _ (EApp _ (TBuiltin (TyArr _ _ (TyArr _ _ (TyArr _ (TyApp _ (TyB _ TyStream) _) _))) Fold) op) seed) stream) = foldWithCtx re op seed stream-eWith re (EApp _ (EApp _ (BBuiltin (TyArr _ _ (TyArr _ (TyApp _ (TyB _ TyStream) _) _)) Fold1) op) stream) = fold1 re op stream-eWith _ e@BBuiltin{} = const e-eWith _ e@UBuiltin{} = const e-eWith _ e@TBuiltin{} = const e-eWith _ e@StrLit{} = const e-eWith _ e@FloatLit{} = const e-eWith _ e@IntLit{} = const e-eWith _ e@BoolLit{} = const e-eWith re e = \bs ->- let (eHoles, (_, folds)) = runState (gatherFoldsM e) (0, []) -- 0 state, should contain no vars by now- in eClosed undefined $ ungather (IM.fromList $ foldAll re folds bs) eHoles--takeConcatMap :: (a -> [b]) -> [a] -> [b]-takeConcatMap f = concat . transpose . fmap f---- | Given an expression, turn it into a function which will process the file.-fileProcessor :: RurePtr- -> E (T K)- -> Either StreamError ([BS.ByteString] -> IO ())-fileProcessor _ AllField{} = Left NakedField-fileProcessor _ Field{} = Left NakedField-fileProcessor _ (NBuiltin _ Ix) = Left NakedField-fileProcessor re e@AllColumn{} = Right $ \inp ->- printStream $ ir re e inp-fileProcessor re e@Column{} = Right $ \inp ->- printStream $ ir re e inp-fileProcessor re e@IParseCol{} = Right $ \inp ->- printStream $ ir re e inp-fileProcessor re e@FParseCol{} = Right $ \inp ->- printStream $ ir re e inp-fileProcessor re e@ParseCol{} = Right $ \inp -> printStream $ ir re e inp-fileProcessor re e@Guarded{} = Right $ \inp ->- printStream $ ir re e inp-fileProcessor re e@Implicit{} = Right $ \inp ->- printStream $ ir re e inp-fileProcessor re e@(EApp _ (EApp _ (BBuiltin _ Filter) _) _) = Right $ \inp ->- printStream $ ir re e inp--- at the moment, catMaybes only works on streams-fileProcessor re e@(EApp _ (UBuiltin _ CatMaybes) _) = Right $ \inp ->- printStream $ ir re e inp-fileProcessor re e@(EApp _ (EApp _ (BBuiltin (TyArr _ _ (TyArr _ _ (TyApp _ (TyB _ TyStream) _))) Map) _) _) = Right $ \inp ->- printStream $ ir re e inp-fileProcessor re e@(EApp _ (EApp _ (BBuiltin (TyArr _ _ (TyArr _ _ (TyApp _ (TyB _ TyStream) _))) MapMaybe) _) _) = Right $ \inp ->- printStream $ ir re e inp-fileProcessor re e@(EApp _ (EApp _ (BBuiltin _ Prior) _) _) = Right $ \inp ->- printStream $ ir re e inp-fileProcessor re e@(EApp _ (EApp _ (EApp _ (TBuiltin _ Scan) _) _) _) = Right $ \inp ->- printStream $ ir re e inp-fileProcessor re e@(EApp _ (EApp _ (EApp _ (TBuiltin _ ZipW) _) _) _) = Right $ \inp ->- printStream $ ir re e inp-fileProcessor re e@(EApp _ (UBuiltin _ Dedup) _) = Right $ \inp ->- printStream $ ir re e inp-fileProcessor re (Anchor _ es) = Right $ \inp ->- printStream $ takeConcatMap (\e -> ir re e inp) es-fileProcessor _ Var{} = error "Internal error?"-fileProcessor _ e@IntLit{} = Right $ const (print e)-fileProcessor _ e@BoolLit{} = Right $ const (print e)-fileProcessor _ e@StrLit{} = Right $ const (print e)-fileProcessor _ e@FloatLit{} = Right $ const (print e)-fileProcessor _ e@RegexLit{} = Right $ const (print e)-fileProcessor _ Lam{} = Left UnevalFun-fileProcessor _ Dfn{} = badSugar-fileProcessor _ ResVar{} = badSugar-fileProcessor _ BBuiltin{} = Left UnevalFun-fileProcessor _ UBuiltin{} = Left UnevalFun-fileProcessor _ TBuiltin{} = Left UnevalFun-fileProcessor re e = Right $ print . eWith re e
+ src/Jacinda/Check/Field.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}++module Jacinda.Check.Field ( cF, LErr (..) ) where++import A+import Control.Applicative (Alternative (..))+import Control.Exception (Exception)+import Data.Foldable (asum)+import Prettyprinter (Pretty (..), squotes, (<+>))++data LErr = NF (E T) | TS (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."++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@Field{} = Just (NF e); cF e@AllField{} = Just (NF e); cF e@LastField{} = 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+cF AllColumn{} = Nothing; cF Guarded{} = Nothing; cF Implicit{} = Nothing; cF ILit{} = Nothing+cF BLit{} = Nothing; cF RegexLit{} = Nothing; cF FLit{} = Nothing; cF StrLit{} = 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 (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++isS :: T -> Bool+isS (TyApp (TyB TyStream) _) = True; isS _ = False++foldMapAlternative :: (Traversable t, Alternative f) => (a -> f b) -> t a -> f b+foldMapAlternative f xs = asum (f <$> xs)++desugar = error "Internal error. Should have been desugared by now."
− src/Jacinda/File.hs
@@ -1,136 +0,0 @@-module Jacinda.File ( tcIO- , tySrc- , runOnHandle- , runOnFile- , exprEval- ) where--import Control.Applicative ((<|>))-import Control.Exception (Exception, throw, throwIO)-import Control.Monad ((<=<))-import Control.Monad.IO.Class (liftIO)-import Control.Monad.State.Strict (StateT, get, put, runStateT)-import Control.Recursion (cata, embed)-import Data.Bifunctor (second)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as ASCII-import qualified Data.ByteString.Lazy as BSL-import qualified Data.ByteString.Lazy.Char8 as ASCIIL-import Data.Functor (void, ($>))-import Data.Tuple (swap)-import Jacinda.AST-import Jacinda.Backend.Normalize-import Jacinda.Backend.TreeWalk-import Jacinda.Include-import Jacinda.Lexer-import Jacinda.Parser-import Jacinda.Parser.Rewrite-import Jacinda.Regex-import Jacinda.Rename-import Jacinda.Ty-import Regex.Rure (RurePtr)-import System.IO (Handle)--parseLib :: [FilePath] -> FilePath -> StateT AlexUserState IO [D AlexPosn]-parseLib incls fp = do- contents <- liftIO $ BSL.readFile =<< resolveImport incls fp- st <- get- case parseLibWithCtx contents st of- Left err -> liftIO (throwIO err)- Right (st', ([], ds)) -> put st' $> (rewriteD <$> ds)- Right (st', (is, ds)) -> do { put st' ; dss <- traverse (parseLib incls) is ; pure (concat dss ++ fmap rewriteD ds) }--parseE :: [FilePath] -> BSL.ByteString -> StateT AlexUserState IO (Program AlexPosn)-parseE incls bs = do- st <- get- case parseWithCtx bs st of- Left err -> liftIO $ throwIO err- Right (st', (is, Program ds e)) -> do- put st'- dss <- traverse (parseLib incls) is- pure $ Program (concat dss ++ fmap rewriteD ds) (rewriteE e)---- | Parse + rename (decls)-parseEWithMax :: [FilePath] -> BSL.ByteString -> IO (Program AlexPosn, Int)-parseEWithMax incls bsl = uncurry renamePGlobal . swap . second fst3 <$> runStateT (parseE incls bsl) alexInitUserState- where fst3 (x, _, _) = x---- | Parse + rename (globally)-parseWithMax' :: BSL.ByteString -> Either (ParseError AlexPosn) (Program AlexPosn, Int)-parseWithMax' = fmap (uncurry renamePGlobal . second (rewriteProgram . snd)) . parseWithMax--type FileBS = BS.ByteString---- fill in regex with compiled.-compileR :: FileBS- -> E (T K)- -> E (T K)-compileR fp = cata a where- a (RegexLitF _ rrϵ) = RegexCompiled (compileDefault rrϵ)- a (NBuiltinF _ Fp) = mkStr fp- a x = embed x--compileIn :: FileBS -> Program (T K) -> Program (T K)-compileIn fp (Program ds e) = Program (compileD fp <$> ds) (compileR fp e)--compileD :: FileBS -> D (T K) -> D (T K)-compileD _ d@SetFS{} = d-compileD fp (FunDecl n l e) = FunDecl n l (compileR fp e)--exprEval :: BSL.ByteString -> E (T K)-exprEval src =- case parseWithMax' src of- Left err -> throw err- Right (ast, m) ->- let (typed, i) = yeet $ runTypeM m (tyProgram ast)- in closedProgram i (compileIn undefined typed)--compileFS :: Maybe BS.ByteString -> RurePtr-compileFS (Just bs) = compileDefault bs-compileFS Nothing = defaultRurePtr--runOnBytes :: [FilePath]- -> FilePath -- ^ Data file name, for @nf@- -> BSL.ByteString -- ^ Program- -> Maybe BS.ByteString -- ^ Field separator- -> BSL.ByteString- -> IO ()-runOnBytes incls fp src cliFS contents = do- incls' <- defaultIncludes <*> pure incls- (ast, m) <- parseEWithMax incls' src- (typed, i) <- yeetIO $ runTypeM m (tyProgram ast)- cont <- yeetIO $ runJac (compileFS (cliFS <|> getFS ast)) i (compileIn (ASCII.pack fp) typed)- cont $ fmap BSL.toStrict (ASCIIL.lines contents)- -- TODO: BSL.split, BSL.splitWith for arbitrary record separators--runOnHandle :: [FilePath]- -> BSL.ByteString -- ^ Program- -> Maybe BS.ByteString -- ^ Field separator- -> Handle- -> IO ()-runOnHandle is src cliFS = runOnBytes is "(runOnBytes)" src cliFS <=< BSL.hGetContents--runOnFile :: [FilePath]- -> BSL.ByteString- -> Maybe BS.ByteString- -> FilePath- -> IO ()-runOnFile is e fs fp = runOnBytes is fp e fs =<< BSL.readFile fp--tcIO :: [FilePath] -> BSL.ByteString -> IO ()-tcIO incls src = do- incls' <- defaultIncludes <*> pure incls- (ast, m) <- parseEWithMax incls' src- yeetIO $ void $ runTypeM m (tyProgram ast)--tySrc :: BSL.ByteString -> T K-tySrc src =- case parseWithMax' src of- Right (ast, m) -> yeet $ fst <$> runTypeM m (tyOf (expr ast))- Left err -> throw err--yeetIO :: Exception e => Either e a -> IO a-yeetIO = either throwIO pure--yeet :: Exception e => Either e a -> a-yeet = either throw id
+ src/Jacinda/Fuse.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE OverloadedStrings #-}++module Jacinda.Fuse ( fuse ) where++import A+import A.E+import Control.Monad.State.Strict (runState)+import Ty.Const++fuse :: Int -> E T -> (E T, Int)+fuse i = flip runState i.fM++-- fold1: needs a special "form" for fold1-of-map (pick seed through map)+-- also "filter-of-fold1" b/c we need to pick a seed that isn't filtered.++fM :: E T -> M (E T)+fM (EApp t0 (EApp t1 (EApp t2 ho@(TB _ Fold) op) seed) stream) | TyApp (TyB TyStream) _ <- eLoc stream = do+ stream' <- fM stream+ case stream' of+ (EApp _ (EApp _ (BB _ Filter) p) xs) -> do+ let opTy@(TyArr sTy popTy@(TyArr xTy _)) = eLoc op+ s <- nN "seed" sTy; x <- nN "x" xTy+ let sE=Var sTy s; xE=Var xTy x+ let fop=Lam opTy s (Lam popTy x (Cond sTy (EApp tyB p xE) (EApp sTy (EApp popTy op sE) xE) sE)) in pure (EApp t0 (EApp t1 (EApp t2 ho fop) seed) xs)+ (Guarded t p e) -> do+ let opTy@(TyArr sTy popTy@(TyArr xTy _)) = eLoc op+ s <- nN "seed" sTy; x <- nN "x" xTy+ let sE=Var sTy s; xE=Var xTy x+ let fop=Lam opTy s (Lam popTy x (Cond sTy p (EApp sTy (EApp popTy op sE) xE) sE)) in pure (EApp t0 (EApp t1 (EApp t2 ho fop) seed) (Implicit t e))+ -- FIXME: does this evaluate e? (could be exception)+ (EApp _ (EApp _ (BB _ Map) f) xs) -> do+ let (TyArr xTy yTy) = eLoc f+ (TyArr sTy _) = eLoc op+ s <- nN "seed" sTy; x <- nN "x" xTy+ let sE=Var sTy s; xE=Var xTy x+ popT=TyArr xTy sTy; fopT=TyArr sTy popT+ fop=Lam fopT s (Lam popT x (EApp undefined (EApp undefined op sE) (EApp yTy f xE)))+ fM (EApp sTy (EApp undefined (EApp undefined (TB (TyArr fopT (TyArr sTy (TyArr (TyApp (TyB TyStream) xTy) sTy))) Fold) fop) seed) xs)+ (EApp _ (EApp _ (BB _ MapMaybe) f) xs) -> do+ -- op | seed (f:?xs) -> [option x (x `op`) (f y)] | seed xs+ let TyArr xT yT=eLoc f+ sT=eLoc seed+ s <- nN "seed" sT; x <- nN "x" xT+ let sE=Var sT s; xE=Var xT x+ popT=TyArr xT sT; fopT=TyArr sT popT+ fop=Lam fopT s (Lam popT x (EApp sT (EApp undefined (EApp undefined (TB (TyArr sT (TyArr undefined (TyArr yT sT))) Option) sE) (EApp undefined op sE)) (EApp yT f xE)))+ fM (EApp sT (EApp undefined (EApp undefined (TB (TyArr fopT (TyArr sT (TyArr (TyApp (TyB TyStream) xT) sT))) Fold) fop) seed) xs)+ (EApp _ (UB _ CatMaybes) xs) -> do+ -- op | seed (.? xs) -> [option x (x `op`) y] | seed xs+ let TyArr _ (TyArr xTy _)=eLoc op+ xMT=tyOpt xTy+ sTy=eLoc seed+ s <- nN "seed" sTy; x <- nN "x" xMT+ let sE=Var sTy s; xE=Var xMT x+ popT=TyArr xMT sTy; fopT=TyArr sTy popT+ fop=Lam fopT s (Lam popT x (EApp sTy (EApp undefined (EApp undefined (TB (TyArr sTy (TyArr undefined (TyArr xMT sTy))) Option) sE) (EApp undefined op sE)) xE))+ fM (EApp sTy (EApp undefined (EApp undefined (TB (TyArr fopT (TyArr sTy (TyArr (TyApp (TyB TyStream) xMT) sTy))) Fold) fop) seed) xs)+ _ -> pure (EApp t0 (EApp t1 (EApp t2 ho op) seed) stream')+fM (Tup t es) = Tup t <$> traverse fM es+fM (EApp t e0 e1) = EApp t <$> fM e0 <*> fM e1+fM (Lam t n e) = Lam t n <$> fM e+fM e = pure e
− src/Jacinda/Include.hs
@@ -1,37 +0,0 @@-module Jacinda.Include ( defaultIncludes- , resolveImport- ) where--import Control.Exception (Exception, throwIO)-import Control.Monad (filterM)-import Data.List.Split (splitWhen)-import Data.Maybe (listToMaybe)-import Paths_jacinda (getDataDir)-import System.Directory (doesFileExist, getCurrentDirectory)-import System.Environment (lookupEnv)-import System.FilePath ((</>))--data ImportError = FileNotFound !FilePath ![FilePath] deriving (Show)--instance Exception ImportError where--defaultIncludes :: IO ([FilePath] -> [FilePath])-defaultIncludes = do- path <- jacPath- d <- getDataDir- dot <- getCurrentDirectory- pure $ (dot:) . (d:) . (++path)---- | Parsed @JAC_PATH@-jacPath :: IO [FilePath]-jacPath = maybe [] splitEnv <$> lookupEnv "JAC_PATH"--splitEnv :: String -> [FilePath]-splitEnv = splitWhen (== ':')--resolveImport :: [FilePath] -- ^ Places to look- -> FilePath- -> IO FilePath-resolveImport incl fp =- maybe (throwIO $ FileNotFound fp incl) pure . listToMaybe- =<< (filterM doesFileExist . fmap (</> fp) $ incl)
− src/Jacinda/Lexer.x
@@ -1,487 +0,0 @@-{- {-# LANGUAGE OverloadedStrings #-}- {-# LANGUAGE StandaloneDeriving #-}- module Jacinda.Lexer ( alexMonadScan- , alexInitUserState- , runAlex- , runAlexSt- , withAlexSt- , freshName- , AlexPosn (..)- , Alex (..)- , Token (..)- , Keyword (..)- , Sym (..)- , Builtin (..)- , Var (..)- , AlexUserState- ) where--import Control.Arrow ((&&&))-import Data.Bifunctor (first)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BSL-import qualified Data.ByteString.Lazy.Char8 as ASCII-import Data.Functor (($>))-import qualified Data.IntMap as IM-import qualified Data.Map as M-import Data.Semigroup ((<>))-import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8, encodeUtf8)-import Intern.Name-import Intern.Unique-import Prettyprinter (Pretty (pretty), (<+>), colon, squotes)--}--%wrapper "monadUserState-bytestring"--$digit = [0-9]--$latin = [a-zA-Z]--@follow_char = [$latin $digit \_]--$str_special = [\\\']--@escape_str = \\ [$str_special nt]--@string = \' ([^ $str_special] | @escape_str)* \'--@name = [a-z] @follow_char*-@tyname = [A-Z] @follow_char*--@float = $digit+\.$digit+--tokens :--- <dfn> {- x { mkRes VarX }- y { mkRes VarY }- }-- <0> "[" { mkSym LSqBracket `andBegin` dfn } -- FIXME: this doesn't allow nested-- <0,dfn> {-- $white+ ;-- "{.".* ;- "#!".* ; -- shebang-- ":=" { mkSym DefEq }- "≔" { mkSym DefEq }- "{" { mkSym LBrace }- "}" { mkSym RBrace }-- "#." { mkSym FilterTok }-- -- symbols/operators- "%" { mkSym PercentTok }- "*" { mkSym TimesTok }- "+" { mkSym PlusTok }- "-" { mkSym MinusTok }-- "|" { mkSym FoldTok }- \" { mkSym Quot }- ¨ { mkSym Quot }- "^" { mkSym Caret }- "|>" { mkSym Fold1Tok }-- "=" { mkSym EqTok }- "!=" { mkSym NeqTok }- "<=" { mkSym LeqTok }- "<" { mkSym LtTok }- ">=" { mkSym GeqTok }- ">" { mkSym GtTok }- "&" { mkSym AndTok }- "||" { mkSym OrTok }- "(" { mkSym LParen }- ")" { mkSym RParen }- "&(" { mkSym LAnchor }- "{%" { mkSym LBracePercent }- "{|" { mkSym LBraceBar }- "]" { mkSym RSqBracket `andBegin` 0 }- "~" { mkSym Tilde }- "!~" { mkSym NotMatchTok }- "," { mkSym Comma }- "." { mkSym Dot }- "#" { mkSym TallyTok }- "#*" { mkSym LengthTok }- "[:" { mkSym ConstTok }- "!" { mkSym Exclamation }- ":" { mkSym Colon }- ";" { mkSym Semicolon }- "\." { mkSym BackslashDot }- \\ { mkSym Backslash }- λ { mkSym Backslash }- "|`" { mkSym CeilSym }- "|." { mkSym FloorSym }- "~." { mkSym DedupTok }- ".?" { mkSym CatMaybesTok }- ":?" { mkSym MapMaybeTok }- "~*" { mkSym CapTok }- "-." { mkSym NegTok }- "`*" { mkSym LastFieldTok }-- in { mkKw KwIn }- let { mkKw KwLet }- val { mkKw KwVal }- end { mkKw KwEnd }- :set { mkKw KwSet }- fn { mkKw KwFn }- "@include" { mkKw KwInclude }- if { mkKw KwIf }- then { mkKw KwThen }- else { mkKw KwElse }-- fs { mkRes VarFs }- ix { mkRes VarIx }- ⍳ { mkRes VarIx }- nf { mkRes VarNf }- -- TODO: does this uncover an alex bug?- -- ⍳ { mkRes VarIx }- -- ¨ { mkSym Quot }- min { mkRes VarMin }- max { mkRes 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 }-- ":i" { mkBuiltin BuiltinIParse }- ":f" { mkBuiltin BuiltinFParse }-- "#t" { tok (\p _ -> alex $ TokBool p True) }- "#f" { tok (\p _ -> alex $ TokBool p False) }-- \$$digit+ { tok (\p s -> alex $ TokStreamLit p (read $ ASCII.unpack $ BSL.tail s)) }- `$digit+ { tok (\p s -> alex $ TokFieldLit p (read $ ASCII.unpack $ BSL.tail s)) }-- "."$digit+ { tok (\p s -> alex $ TokAccess p (read $ ASCII.unpack $ ASCII.tail s)) }- "->"$digit+ { tok (\p s -> alex $ TokSelect p (read $ ASCII.unpack $ ASCII.drop 2 s)) }- $digit+ { tok (\p s -> alex $ TokInt p (read $ ASCII.unpack s)) }- _$digit+ { tok (\p s -> alex $ TokInt p (negate $ read $ ASCII.unpack $ BSL.tail s)) }-- $digit+\.$digit+ { tok (\p s -> alex $ TokFloat p (read $ ASCII.unpack s)) }- _$digit+\.$digit+ { tok (\p s -> alex $ TokFloat p (negate $ read $ ASCII.unpack $ BSL.tail s)) }-- @string { tok (\p s -> alex $ TokStr p (escReplace' $ BSL.init $ BSL.tail s)) }-- -- TODO: allow chars to be escaped- "/"[^\/]*"/" { tok (\p s -> alex $ TokRR p (BSL.init $ BSL.tail s)) }-- @name { tok (\p s -> TokName p <$> newIdentAlex p (mkText s)) }- @tyname { tok (\p s -> TokTyName p <$> newIdentAlex p (mkText s)) }-- }--{--dropQuotes :: BSL.ByteString -> BSL.ByteString-dropQuotes = BSL.init . BSL.tail--alex :: a -> Alex a-alex = pure--tok f (p,_,s,_) len = f p (BSL.take len s)--constructor c t = tok (\p _ -> alex $ c p t)--mkRes = constructor TokResVar--mkKw = constructor TokKeyword--mkSym = constructor TokSym--mkBuiltin = constructor TokBuiltin--escReplace' :: BSL.ByteString -> BS.ByteString-escReplace' = encodeUtf8 . escReplace . decodeUtf8 . BSL.toStrict---- this is inefficient but w/e-escReplace :: T.Text -> T.Text-escReplace =- T.replace "\\\"" "\""- . T.replace "\\n" "\n"- . T.replace "\\t" "\t"--mkText :: BSL.ByteString -> T.Text-mkText = decodeUtf8 . BSL.toStrict--instance Pretty AlexPosn where- pretty (AlexPn _ line col) = pretty line <> colon <> pretty col--deriving instance Ord AlexPosn---- functional bimap?-type AlexUserState = (Int, M.Map T.Text Int, IM.IntMap (Name AlexPosn))--alexInitUserState :: AlexUserState-alexInitUserState = (0, mempty, mempty)--gets_alex :: (AlexState -> a) -> Alex a-gets_alex f = Alex (Right . (id &&& f))--get_ust :: Alex AlexUserState-get_ust = gets_alex alex_ust--get_pos :: Alex AlexPosn-get_pos = gets_alex alex_pos--set_ust :: AlexUserState -> Alex ()-set_ust st = Alex (Right . (go &&& (const ())))- where go s = s { alex_ust = st }--alexEOF = EOF <$> get_pos--data Sym = PlusTok- | MinusTok- | PercentTok- | FoldTok- | Fold1Tok- | Quot- | TimesTok- | DefEq- | Colon- | LBrace- | RBrace- | LParen- | LAnchor- | RParen- | LSqBracket- | RSqBracket- | Semicolon- | Underscore- | EqTok- | LeqTok- | LtTok- | NeqTok- | GeqTok- | GtTok- | AndTok- | OrTok- | Tilde- | NotMatchTok- | Comma- | Dot- | TallyTok- | LengthTok- | ConstTok- | LBracePercent- | LBraceBar- | Exclamation- | Caret- | Backslash- | BackslashDot- | FilterTok- | FloorSym- | CeilSym- | DedupTok- | CatMaybesTok- | MapMaybeTok- | CapTok- | NegTok- | LastFieldTok--instance Pretty Sym where- pretty PlusTok = "+"- pretty MinusTok = "-"- pretty PercentTok = "%"- 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 Comma = ","- pretty Dot = "."- pretty TallyTok = "#"- 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 CatMaybesTok = ".?"- pretty MapMaybeTok = ":?"- pretty CapTok = "~*"- pretty NegTok = "-."- pretty LastFieldTok = "`*"--data Keyword = KwLet- | KwIn- | KwVal- | KwEnd- | KwSet- | KwFn- | KwInclude- | KwIf- | KwThen- | KwElse---- | Reserved/special variables-data Var = VarX- | VarY- | VarFs- | VarIx- | VarMin- | VarMax- | VarNf--instance Pretty Var where- pretty VarX = "x"- pretty VarY = "y"- pretty VarFs = "fs"- pretty VarIx = "ix"- pretty VarNf = "nf"- pretty VarMin = "min"- pretty VarMax = "max"- -- TODO: exp, log, sqrt, floor ...--instance Pretty Keyword where- pretty KwLet = "let"- pretty KwIn = "in"- pretty KwVal = "val"- pretty KwEnd = "end"- pretty KwSet = ":set"- pretty KwFn = "fn"- pretty KwInclude = "@include"- pretty KwIf = "if"- pretty KwThen = "then"- pretty KwElse = "else"--data Builtin = BuiltinIParse- | BuiltinFParse- | BuiltinSubstr- | BuiltinSplit- | BuiltinSplitc- | BuiltinOption- | BuiltinSprintf- | BuiltinFloor- | BuiltinCeil- | BuiltinMatch- | BuiltinCaptures- | BuiltinSome- | BuiltinNone- | BuiltinFp--instance Pretty Builtin where- pretty BuiltinIParse = ":i"- pretty BuiltinFParse = ":f"- pretty BuiltinSubstr = "substr"- pretty BuiltinSplit = "split"- pretty BuiltinOption = "option"- pretty BuiltinSplitc = "splitc"- pretty BuiltinSprintf = "sprintf"- pretty BuiltinFloor = "floor"- pretty BuiltinCeil = "ceil"- pretty BuiltinMatch = "match"- pretty BuiltinSome = "Some"- pretty BuiltinNone = "None"- pretty BuiltinFp = "fp"- pretty BuiltinCaptures = "captures"--data Token a = EOF { loc :: a }- | TokSym { loc :: a, _sym :: Sym }- | TokName { loc :: a, _name :: Name a }- | TokTyName { loc :: a, _tyName :: TyName a }- | TokBuiltin { loc :: a, _builtin :: Builtin }- | TokKeyword { loc :: a, _kw :: Keyword }- | TokResVar { loc :: a, _var :: Var }- | TokInt { loc :: a, int :: Integer }- | TokFloat { loc :: a, float :: Double }- | TokBool { loc :: a, boolTok :: Bool }- | TokStr { loc :: a, strTok :: BS.ByteString }- | TokStreamLit { loc :: a, ix :: Int }- | TokFieldLit { loc :: a, ix :: Int }- | TokRR { loc :: a, rr :: BSL.ByteString }- | TokAccess { loc :: a, ix :: Int }- | TokSelect { loc :: a, field :: Int }--instance Pretty (Token a) where- pretty EOF{} = "(eof)"- pretty (TokSym _ s) = "symbol" <+> squotes (pretty s)- pretty (TokName _ n) = "identifier" <+> squotes (pretty n)- pretty (TokTyName _ tn) = "identifier" <+> squotes (pretty tn)- pretty (TokBuiltin _ b) = "builtin" <+> squotes (pretty b)- pretty (TokKeyword _ kw) = "keyword" <+> squotes (pretty kw)- pretty (TokInt _ i) = pretty i- pretty (TokStr _ str) = squotes (pretty $ decodeUtf8 str)- pretty (TokStreamLit _ i) = "$" <> pretty i- pretty (TokFieldLit _ i) = "`" <> pretty i- pretty (TokRR _ rr') = "/" <> pretty (mkText rr') <> "/"- pretty (TokResVar _ v) = "reserved variable" <+> squotes (pretty v)- pretty (TokBool _ True) = "#t"- pretty (TokBool _ False) = "#f"- pretty (TokAccess _ i) = "." <> pretty i- pretty (TokFloat _ f) = pretty f- pretty (TokSelect _ i) = "->" <> pretty i--freshName :: T.Text -> Alex (Name AlexPosn)-freshName t = do- pos <- get_pos- newIdentAlex pos t--newIdentAlex :: AlexPosn -> T.Text -> Alex (Name AlexPosn)-newIdentAlex pos t = do- st <- get_ust- let (st', n) = newIdent pos t st- set_ust st' $> (n $> pos)--newIdent :: AlexPosn -> T.Text -> AlexUserState -> (AlexUserState, Name AlexPosn)-newIdent pos t pre@(max', names, uniqs) =- case M.lookup t names of- Just i -> (pre, Name t (Unique i) pos)- Nothing -> let i = max' + 1- in let newName = Name t (Unique i) pos- in ((i, M.insert t i names, IM.insert i newName uniqs), newName)--runAlexSt :: BSL.ByteString -> Alex a -> Either String (AlexUserState, a)-runAlexSt inp = withAlexSt inp alexInitUserState--withAlexSt :: BSL.ByteString -> AlexUserState -> Alex a -> Either String (AlexUserState, a)-withAlexSt inp ust (Alex f) = first alex_ust <$> f- (AlexState { alex_bpos = 0- , alex_pos = alexStartPos- , alex_inp = inp- , alex_chr = '\n'- , alex_ust = ust- , alex_scd = 0- })--}
− src/Jacinda/Parser.y
@@ -1,354 +0,0 @@-{- {-# LANGUAGE OverloadedStrings #-}- module Jacinda.Parser ( parse- , parseWithMax- , parseWithInitCtx- , parseWithCtx- , parseLibWithCtx- , ParseError (..)- -- * Type synonyms- , File- , Library- ) where--import Control.Exception (Exception)-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 qualified Data.ByteString.Char8 as ASCII-import qualified Data.Text as T-import Data.Typeable (Typeable)-import qualified Intern.Name as Name-import Intern.Name hiding (loc)-import Jacinda.AST-import Jacinda.Lexer-import Prettyprinter (Pretty (pretty), (<+>))--}--%name parseF File-%name parseLib Library-%tokentype { Token AlexPosn }-%error { parseError }-%monad { Parse } { (>>=) } { pure }-%lexer { lift alexMonadScan >>= } { EOF _ }--%token-- defEq { TokSym $$ DefEq }- colon { TokSym $$ Colon }- lbrace { TokSym $$ LBrace }- rbrace { TokSym $$ RBrace }- lsqbracket { TokSym $$ LSqBracket }- rsqbracket { TokSym $$ RSqBracket }- lparen { TokSym $$ LParen }- lanchor { TokSym $$ LAnchor }- rparen { TokSym $$ RParen }- semicolon { TokSym $$ Semicolon }- backslash { TokSym $$ Backslash }- tilde { TokSym $$ Tilde }- notMatch { TokSym $$ NotMatchTok }- dot { TokSym $$ Dot }- lbracePercent { TokSym $$ LBracePercent }- lbraceBar { TokSym $$ LBraceBar }- tally { TokSym $$ TallyTok }- tallyL { TokSym $$ LengthTok }- const { TokSym $$ ConstTok }- filter { TokSym $$ FilterTok }- exclamation { TokSym $$ Exclamation }- backslashdot { TokSym $$ BackslashDot }- at { $$@(TokAccess _ _) }- select { $$@(TokSelect _ _) }- floorSym { TokSym $$ FloorSym }- ceilSym { TokSym $$ CeilSym }- dedup { TokSym $$ DedupTok }-- plus { TokSym $$ PlusTok }- minus { TokSym $$ MinusTok }- times { TokSym $$ TimesTok }- percent { TokSym $$ PercentTok }-- comma { TokSym $$ Comma }- fold { TokSym $$ FoldTok }- fold1 { TokSym $$ Fold1Tok }- caret { TokSym $$ Caret }- quot { TokSym $$ Quot }- mapMaybe { TokSym $$ MapMaybeTok }- catMaybes { TokSym $$ CatMaybesTok }- capture { TokSym $$ CapTok }- neg { TokSym $$ NegTok }-- eq { TokSym $$ EqTok }- neq { TokSym $$ NeqTok }- leq { TokSym $$ LeqTok }- lt { TokSym $$ LtTok }- geq { TokSym $$ GeqTok }- gt { TokSym $$ GtTok }-- and { TokSym $$ AndTok }- or { TokSym $$ OrTok }-- name { TokName _ $$ }- tyName { TokTyName _ $$ }-- intLit { $$@(TokInt _ _) }- floatLit { $$@(TokFloat _ _) }- boolLit { $$@(TokBool _ _) }- strLit { $$@(TokStr _ _) }- allColumn { TokStreamLit $$ 0 }- allField { TokFieldLit $$ 0 }- column { $$@(TokStreamLit _ _) }- field { $$@(TokFieldLit _ _) }- lastField { TokSym $$ LastFieldTok } -- TokSym is maybe insensible but whatever-- let { TokKeyword $$ KwLet }- in { TokKeyword $$ KwIn }- val { TokKeyword $$ KwVal }- end { TokKeyword $$ KwEnd }- set { TokKeyword $$ KwSet }- fn { TokKeyword $$ KwFn }- include { TokKeyword $$ KwInclude }- if { TokKeyword $$ KwIf }- then { TokKeyword $$ KwThen }- else { TokKeyword $$ KwElse }-- x { TokResVar $$ VarX }- y { TokResVar $$ VarY }-- min { TokResVar $$ VarMin }- max { TokResVar $$ VarMax }- ix { TokResVar $$ VarIx }- nf { TokResVar $$ VarNf }- fs { TokResVar $$ VarFs }-- split { TokBuiltin $$ BuiltinSplit }- splitc { TokBuiltin $$ BuiltinSplitc }- substr { TokBuiltin $$ BuiltinSubstr }- 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 }-- iParse { TokBuiltin $$ BuiltinIParse }- fParse { TokBuiltin $$ BuiltinFParse }-- rr { $$@(TokRR _ _) }--%right const-%left paren iParse fParse-%nonassoc leq geq gt lt neq eq--%%--many(p)- : many(p) p { $2 : $1 }- | { [] }--sepBy(p,q)- : sepBy(p,q) q p { $3 : $1 }- | p q p { $3 : [$1] }--braces(p)- : lbrace p rbrace { $2 }--brackets(p)- : lsqbracket p rsqbracket { $2 }--parens(p)- : lparen p rparen { $2 }---- binary operator-BBin :: { BBin }- : plus { Plus }- | times { Times }- | minus { Minus }- | percent { Div }- | gt { Gt }- | lt { Lt }- | geq { Geq }- | leq { Leq }- | eq { Eq }- | neq { Neq }- | quot { Map }- | mapMaybe { MapMaybe }- | tilde { Matches }- | notMatch { NotMatches }- | and { And }- | or { Or }- | backslashdot { Prior }- | filter { Filter }- | fold1 { Fold1 }--Bind :: { (Name AlexPosn, E AlexPosn) }- : val name defEq E { ($2, $4) }--Args :: { [(Name AlexPosn)] }- : lparen rparen { [] }- | parens(name) { [$1] }- | parens(sepBy(name, comma)) { reverse $1 }--D :: { D AlexPosn }- : set fs defEq rr semicolon { SetFS (BSL.toStrict $ rr $4) }- | fn name Args defEq E semicolon { FunDecl $2 $3 $5 }- | fn name defEq E semicolon { FunDecl $2 [] $4 }--Include :: { FilePath }- : include strLit { ASCII.unpack (strTok $2) }--File :: { ([FilePath], Program AlexPosn) }- : many(Include) Program { (reverse $1, $2) }--Library :: { Library }- : many(Include) many(D) { (reverse $1, reverse $2) }--Program :: { Program AlexPosn }- : many(D) E { Program (reverse $1) $2 }--E :: { E AlexPosn }- : name { Var (Name.loc $1) $1 }- | intLit { IntLit (loc $1) (int $1) }- | floatLit { FloatLit (loc $1) (float $1) }- | boolLit { BoolLit (loc $1) (boolTok $1) }- | strLit { StrLit (loc $1) (strTok $1) }- | column { Column (loc $1) (ix $1) }- | field { Field (loc $1) (ix $1) }- | allColumn { AllColumn $1 }- | allField { AllField $1 }- | lastField { LastField $1 }- | field iParse { EApp (loc $1) (UBuiltin $2 IParse) (Field (loc $1) (ix $1)) }- | field fParse { EApp (loc $1) (UBuiltin $2 FParse) (Field (loc $1) (ix $1)) }- | name iParse { EApp (Name.loc $1) (UBuiltin $2 IParse) (Var (Name.loc $1) $1) }- | name fParse { EApp (Name.loc $1) (UBuiltin $2 FParse) (Var (Name.loc $1) $1) }- | field colon { EApp (loc $1) (UBuiltin $2 Parse) (Field (loc $1) (ix $1)) }- | name colon { EApp (Name.loc $1) (UBuiltin $2 Parse) (Var (Name.loc $1) $1) }- | lastField iParse { EApp $1 (UBuiltin $2 IParse) (LastField $1) }- | lastField fParse { EApp $1 (UBuiltin $2 FParse) (LastField $1) }- | lastField colon { EApp $1 (UBuiltin $2 Parse) (LastField $1) }- | x colon { EApp $1 (UBuiltin $2 Parse) (ResVar $1 X) }- | y colon { EApp $1 (UBuiltin $2 Parse) (ResVar $1 Y) }- | x iParse { EApp $1 (UBuiltin $2 IParse) (ResVar $1 X) }- | x fParse { EApp $1 (UBuiltin $2 FParse) (ResVar $1 X) }- | y iParse { EApp $1 (UBuiltin $2 IParse) (ResVar $1 Y) }- | y fParse { EApp $1 (UBuiltin $2 FParse) (ResVar $1 Y) }- | column iParse { IParseCol (loc $1) (ix $1) }- | column fParse { FParseCol (loc $1) (ix $1) }- | column colon { ParseCol (loc $1) (ix $1) }- | parens(iParse) { UBuiltin $1 IParse }- | parens(fParse) { UBuiltin $1 FParse }- | parens(colon) { UBuiltin $1 Parse }- | lparen BBin rparen { BBuiltin $1 $2 }- | lparen E BBin rparen { EApp $1 (BBuiltin $1 $3) $2 }- | lparen BBin E rparen {% do { n <- lift $ freshName "x" ; pure (Lam $1 n (EApp $1 (EApp $1 (BBuiltin $1 $2) (Var (Name.loc n) n)) $3)) } }- | E BBin E { EApp (eLoc $1) (EApp (eLoc $3) (BBuiltin (eLoc $1) $2) $1) $3 }- | E fold E E { EApp (eLoc $1) (EApp (eLoc $1) (EApp $2 (TBuiltin $2 Fold) $1) $3) $4 }- | E capture E E { EApp (eLoc $1) (EApp (eLoc $1) (EApp $2 (TBuiltin $2 Captures) $1) $3) $4 }- | E caret E E { EApp (eLoc $1) (EApp (eLoc $1) (EApp $2 (TBuiltin $2 Scan) $1) $3) $4 }- | comma E E E { EApp $1 (EApp $1 (EApp $1 (TBuiltin $1 ZipW) $2) $3) $4 }- | lbrace E rbrace braces(E) { Guarded $1 $2 $4 }- | lbracePercent E rbrace braces(E) { let tl = eLoc $2 in Guarded $1 (EApp tl (EApp tl (BBuiltin 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) }- | lanchor sepBy(E, dot) rparen { Anchor $1 (reverse $2) }- | E E { EApp (eLoc $1) $1 $2 }- | tally { UBuiltin $1 Tally }- | tallyL { UBuiltin $1 TallyList }- | const { UBuiltin $1 Const }- | exclamation { UBuiltin $1 Not }- | lsqbracket E rsqbracket { Dfn $1 $2 }- | x { ResVar $1 X }- | y { ResVar $1 Y }- | rr { RegexLit (loc $1) (BSL.toStrict $ rr $1) }- | min { BBuiltin $1 Min }- | max { BBuiltin $1 Max }- | split { BBuiltin $1 Split }- | match { BBuiltin $1 Match }- | splitc { BBuiltin $1 Splitc }- | substr { TBuiltin $1 Substr }- | sprintf { BBuiltin $1 Sprintf }- | option { TBuiltin $1 Option }- | captures { TBuiltin $1 AllCaptures }- | floor { UBuiltin $1 Floor }- | ceil { UBuiltin $1 Ceiling }- | floorSym { UBuiltin $1 Floor }- | ceilSym { UBuiltin $1 Ceiling }- | dedup { UBuiltin $1 Dedup }- | some { UBuiltin $1 Some }- | catMaybes { UBuiltin $1 CatMaybes }- | neg { UBuiltin $1 Negate }- | ix { NBuiltin $1 Ix }- | nf { NBuiltin $1 Nf }- | none { NBuiltin $1 None }- | fp { NBuiltin $1 Fp }- | parens(at) { UBuiltin (loc $1) (At $ ix $1) }- | parens(select) { UBuiltin (loc $1) (Select $ field $1) }- | E at { EApp (eLoc $1) (UBuiltin (loc $2) (At $ ix $2)) $1 }- | E select { EApp (eLoc $1) (UBuiltin (loc $2) (Select $ field $2)) $1 }- | backslash name dot E { Lam $1 $2 $4 }- | parens(E) { Paren (eLoc $1) $1 }- | if E then E else E { Cond $1 $2 $4 $6 }--{--type File = ([FilePath], Program AlexPosn)--type Library = ([FilePath], [D AlexPosn])--parseError :: Token AlexPosn -> Parse a-parseError = throwError . Unexpected--mkLet :: a -> [(Name 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)- | 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)--instance Pretty a => Show (ParseError a) where- show = show . pretty--instance (Pretty a, Typeable a) => Exception (ParseError a)--type Parse = ExceptT (ParseError AlexPosn) Alex--parse :: BSL.ByteString -> Either (ParseError AlexPosn) File-parse = fmap snd . runParse parseF--parseWithMax :: BSL.ByteString -> Either (ParseError AlexPosn) (Int, File)-parseWithMax = fmap (first fst3) . runParse parseF- where fst3 (x, _, _) = x--parseWithInitCtx :: BSL.ByteString -> Either (ParseError AlexPosn) (AlexUserState, File)-parseWithInitCtx bsl = parseWithCtx bsl alexInitUserState--parseWithCtx :: BSL.ByteString -> AlexUserState -> Either (ParseError AlexPosn) (AlexUserState, File)-parseWithCtx = parseWithInitSt parseF--parseLibWithCtx :: BSL.ByteString -> AlexUserState -> Either (ParseError AlexPosn) (AlexUserState, Library)-parseLibWithCtx = parseWithInitSt parseLib--runParse :: Parse a -> BSL.ByteString -> Either (ParseError AlexPosn) (AlexUserState, a)-runParse parser str = liftErr $ runAlexSt str (runExceptT parser)--parseWithInitSt :: Parse a -> BSL.ByteString -> 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)-liftErr (Right (_, Left err)) = Left err-liftErr (Right (i, Right x)) = Right (i, x)--}
− src/Jacinda/Parser/Rewrite.hs
@@ -1,60 +0,0 @@-module Jacinda.Parser.Rewrite ( rewriteProgram- , rewriteD- , rewriteE- ) where---import Control.Recursion (cata, embed)-import Jacinda.AST--rewriteProgram :: Program a -> Program a-rewriteProgram (Program ds e) = Program (rewriteD <$> ds) (rewriteE e)--rewriteD :: D a -> D a-rewriteD d@SetFS{} = d-rewriteD (FunDecl n bs e) = FunDecl n bs (rewriteE e)--rewriteE :: E a -> E a-rewriteE = cata a where- a (EAppF l e0@(UBuiltin _ Tally) (EApp lϵ (EApp lϵϵ e1@BBuiltin{} e2) e3)) = EApp l (EApp lϵ e1 (EApp lϵϵ e0 e2)) e3- a (EAppF l e0@(UBuiltin _ Const) (EApp lϵ (EApp lϵϵ e1@(BBuiltin _ Map) e2) e3)) = EApp l (EApp lϵ e1 (EApp lϵϵ e0 e2)) e3- a (EAppF l e0@(EApp _ (BBuiltin _ Eq) _) (EApp l1 (EApp l2 e1@(BBuiltin _ And) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3- a (EAppF l e0@(EApp _ (BBuiltin _ Eq) _) (EApp l1 (EApp l2 e1@(BBuiltin _ Or) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3- a (EAppF l e0@(EApp _ (BBuiltin _ Neq) _) (EApp l1 (EApp l2 e1@(BBuiltin _ And) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3- a (EAppF l e0@(EApp _ (BBuiltin _ Neq) _) (EApp l1 (EApp l2 e1@(BBuiltin _ Or) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3- a (EAppF l e0@(EApp _ (BBuiltin _ Gt) _) (EApp l1 (EApp l2 e1@(BBuiltin _ And) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3- a (EAppF l e0@(EApp _ (BBuiltin _ Gt) _) (EApp l1 (EApp l2 e1@(BBuiltin _ Or) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3- a (EAppF l e0@(EApp _ (BBuiltin _ Lt) _) (EApp l1 (EApp l2 e1@(BBuiltin _ And) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3- a (EAppF l e0@(EApp _ (BBuiltin _ Lt) _) (EApp l1 (EApp l2 e1@(BBuiltin _ Or) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3- a (EAppF l e0@(EApp _ (BBuiltin _ Leq) _) (EApp l1 (EApp l2 e1@(BBuiltin _ And) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3- a (EAppF l e0@(EApp _ (BBuiltin _ Leq) _) (EApp l1 (EApp l2 e1@(BBuiltin _ Or) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3- a (EAppF l e0@(EApp _ (BBuiltin _ Geq) _) (EApp l1 (EApp l2 e1@(BBuiltin _ And) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3- a (EAppF l e0@(EApp _ (BBuiltin _ Geq) _) (EApp l1 (EApp l2 e1@(BBuiltin _ Or) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3- a (EAppF l e0@(EApp _ (BBuiltin _ Matches) _) (EApp l1 (EApp l2 e1@(BBuiltin _ And) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3- a (EAppF l e0@(EApp _ (BBuiltin _ Matches) _) (EApp l1 (EApp l2 e1@(BBuiltin _ Or) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3- a (EAppF l e0@(EApp _ (BBuiltin _ NotMatches) _) (EApp l1 (EApp l2 e1@(BBuiltin _ And) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3- a (EAppF l e0@(EApp _ (BBuiltin _ NotMatches) _) (EApp l1 (EApp l2 e1@(BBuiltin _ Or) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3- a (EAppF l e0@(EApp _ (BBuiltin _ Fold1) _) (EApp l1 (EApp l2 e1@(BBuiltin _ Eq) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3- a (EAppF l e0@(EApp _ (BBuiltin _ Fold1) _) (EApp l1 (EApp l2 e1@(BBuiltin _ Neq) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3- a (EAppF l e0@(EApp _ (BBuiltin _ Fold1) _) (EApp l1 (EApp l2 e1@(BBuiltin _ Gt) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3- a (EAppF l e0@(EApp _ (BBuiltin _ Fold1) _) (EApp l1 (EApp l2 e1@(BBuiltin _ Geq) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3- a (EAppF l e0@(EApp _ (BBuiltin _ Fold1) _) (EApp l1 (EApp l2 e1@(BBuiltin _ Leq) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3- a (EAppF l e0@(EApp _ (BBuiltin _ Fold1) _) (EApp l1 (EApp l2 e1@(BBuiltin _ Lt) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3- a (EAppF l e0@Var{} (EApp lϵ (EApp lϵϵ e1 e2) e3)) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3- -- TODO rewrite dfn- a (EAppF l e0@Var{} (EApp l0 e1 (EApp l1 (EApp l2 op@BBuiltin{} e2) e3))) = EApp l1 (EApp l2 op (EApp l (EApp l0 e0 e1) e2)) e3- a (EAppF l e0@Var{} (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2- a (EAppF l e0@(BBuiltin _ Max) (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2- a (EAppF l e0@(BBuiltin _ Min) (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2- a (EAppF l e0@(BBuiltin _ Split) (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2- a (EAppF l e0@(BBuiltin _ Match) (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2- a (EAppF l e0@(BBuiltin _ Splitc) (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2- a (EAppF l e0@(BBuiltin _ Sprintf) (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2- a (EAppF l e0@(TBuiltin _ Substr) (EApp lϵ (EApp lϵϵ e1 e2) e3)) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3- a (EAppF l e0@(TBuiltin _ Substr) (EApp lϵ e1 (EApp lϵϵ e2 e3))) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3- a (EAppF l e0@(TBuiltin _ Option) (EApp lϵ (EApp lϵϵ e1 e2) e3)) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3- a (EAppF l e0@(TBuiltin _ Option) (EApp lϵ e1 (EApp lϵϵ e2 e3))) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3- a (EAppF l e0@(TBuiltin _ Option) (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2- a (EAppF l e0@(TBuiltin _ AllCaptures) (EApp lϵ (EApp lϵϵ e1 e2) e3)) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3- a (EAppF l e0@(TBuiltin _ AllCaptures) (EApp lϵ e1 (EApp lϵϵ e2 e3))) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3- a x = embed x
src/Jacinda/Regex.hs view
@@ -21,17 +21,17 @@ import Regex.Rure (RureMatch (..), RurePtr, captures, compile, find, findCaptures, isMatch, matches', rureDefaultFlags, rureFlagDotNL) import System.IO.Unsafe (unsafeDupablePerformIO, unsafePerformIO) --- see: https://docs.rs/regex/latest/regex/#perl-character-classes-unicode-friendly+-- https://docs.rs/regex/latest/regex/#perl-character-classes-unicode-friendly defaultFs :: BS.ByteString defaultFs = "\\s+" {-# NOINLINE defaultRurePtr #-} defaultRurePtr :: RurePtr-defaultRurePtr = unsafePerformIO $ yeetRureIO =<< compile genFlags defaultFs- where genFlags = rureDefaultFlags <> rureFlagDotNL -- in case they want to use a weird custom record separator+defaultRurePtr = unsafePerformIO $ yIO =<< compile genFlags defaultFs+ where genFlags = rureDefaultFlags <> rureFlagDotNL -- in case they want to use a custom record separator substr :: BS.ByteString -> Int -> Int -> BS.ByteString-substr (BS.BS fp l) begin endϵ | endϵ >= begin = BS.BS (fp `plusForeignPtr` begin) (min l endϵ - begin)+substr (BS.BS fp l) begin endϵ | endϵ >= begin = BS.BS (fp `plusForeignPtr` begin) (min l endϵ-begin) | otherwise = "error: invalid substring indices." captures' :: RurePtr -> BS.ByteString -> CSize -> [BS.ByteString]@@ -74,11 +74,11 @@ isMatch' re haystack = unsafeDupablePerformIO $ isMatch re haystack 0 compileDefault :: BS.ByteString -> RurePtr-compileDefault = unsafeDupablePerformIO . (yeetRureIO <=< compile rureDefaultFlags) -- TODO: rureFlagDotNL? in case they have weird records+compileDefault = unsafeDupablePerformIO . (yIO <=< compile rureDefaultFlags) -- TODO: rureFlagDotNL newtype RureExe = RegexCompile String deriving (Show) instance Exception RureExe where -yeetRureIO :: Either String a -> IO a-yeetRureIO = either (throwIO . RegexCompile) pure+yIO :: Either String a -> IO a+yIO = either (throwIO . RegexCompile) pure
− src/Jacinda/Rename.hs
@@ -1,161 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Jacinda.Rename ( renameE- , renameProgram- , runRenameM- , renamePGlobal- , RenameM- , Renames (..)- , HasRenames (..)- ) where--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-import Intern.Name-import Intern.Unique-import Jacinda.AST-import Lens.Micro (Lens')-import Lens.Micro.Mtl (modifying, use, (%=), (.=))--data Renames = Renames { max_ :: Int, bound :: IM.IntMap Int }---- TODO: instance Pretty Renames for debug?--class HasRenames a where- rename :: Lens' a Renames--instance HasRenames Renames where- rename = id--boundLens :: Lens' Renames (IM.IntMap Int)-boundLens f s = fmap (\x -> s { bound = x }) (f (bound s))--maxLens :: Lens' Renames Int-maxLens f s = fmap (\x -> s { max_ = x }) (f (max_ s))--type RenameM = State Renames--renamePGlobal :: Int -> Program a -> (Program a, Int)-renamePGlobal i = runRenameM i . renameProgram--runRenameM :: Int -> RenameM x -> (x, Int)-runRenameM i act = second max_ (runState act (Renames i IM.empty))---- Make sure you don't have cycles in the renames map!-replaceUnique :: (MonadState s m, HasRenames s) => Unique -> m Unique-replaceUnique u@(Unique i) = do- rSt <- use (rename.boundLens)- case IM.lookup i rSt of- Nothing -> pure u- Just j -> replaceUnique (Unique j)--replaceVar :: (MonadState s m, HasRenames s) => Name a -> m (Name a)-replaceVar (Name n u l) = do- u' <- replaceUnique u- pure $ Name n u' l--dummyName :: (MonadState s m, HasRenames s) => a -> T.Text -> m (Name a)-dummyName l n = do- st <- use (rename.maxLens)- Name n (Unique $ st+1) l- <$ modifying (rename.maxLens) (+1)---- allows us to work with a temporary change to the renamer state, tracking the--- max sensibly-withRenames :: (HasRenames s, MonadState s m) => (Renames -> Renames) -> m a -> m a-withRenames modSt act = do- preSt <- use rename- rename %= modSt- res <- act- postMax <- use (rename.maxLens)- rename .= setMax postMax preSt- pure res--withName :: (HasRenames s, MonadState s m) => Name a -> m (Name a, Renames -> Renames)-withName (Name t (Unique i) l) = do- m <- use (rename.maxLens)- let newUniq = m+1- rename.maxLens .= newUniq- pure (Name t (Unique newUniq) l, mapBound (IM.insert i (m+1)))--mapBound :: (IM.IntMap Int -> IM.IntMap Int) -> Renames -> Renames-mapBound f (Renames m b) = Renames m (f b)--setMax :: Int -> Renames -> Renames-setMax i (Renames _ b) = Renames i b---- | Desguar top-level functions as lambdas-mkLam :: [Name a] -> E a -> E a-mkLam ns e = foldr (\n -> Lam (loc n) n) e ns---- | A dfn could be unary or binary - here we guess if it is binary-hasY :: E a -> Bool-hasY = cata a where- a (ResVarF _ Y) = True- a (TupF _ es) = or es- a (EAppF _ e e') = e || e'- a (LamF _ _ e) = e- a DfnF{} = error "Not supported yet."- a (LetF _ b e) = e || snd b- a (GuardedF _ p b) = b || p- a (ImplicitF _ e) = e- a (ParenF _ e) = e- a (ArrF _ es) = or es- a (AnchorF _ es) = or es- a (OptionValF _ (Just e)) = e- a (CondF _ p e e') = p || e || e'- a _ = False--replaceXY :: (a -> Name a) -- ^ @x@- -> (a -> Name a) -- ^ @y@- -> 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--replaceX :: (a -> Name a) -> E a -> E a-replaceX n = cata a where- a (ResVarF l X) = Var l (n l)- a x = embed x--renameD :: D a -> RenameM (D a)-renameD d@SetFS{} = pure d-renameD (FunDecl n ns e) = FunDecl n [] <$> renameE (mkLam ns e)--renameProgram :: Program a -> RenameM (Program a)-renameProgram (Program ds e) = Program <$> traverse renameD ds <*> renameE e--{-# INLINABLE renameE #-}-renameE :: (HasRenames s, MonadState s m) => E a -> m (E a)-renameE (EApp l e e') = EApp l <$> renameE e <*> renameE e'-renameE (Tup l es) = Tup l <$> traverse renameE es-renameE (Var l n) = Var l <$> replaceVar n-renameE (Lam l n e) = do- (n', modR) <- withName n- Lam l n' <$> withRenames modR (renameE e)-renameE (Dfn l e) | {-# SCC "hasY" #-} hasY e = do- x@(Name nX uX _) <- dummyName l "x"- y@(Name nY uY _) <- dummyName l "y"- Lam l x . Lam l y <$> renameE ({-# SCC "replaceXY" #-} replaceXY (Name nX uX) (Name nY uY) e)- | otherwise = do- x@(Name n u _) <- dummyName l "x"- -- no need for withName... withRenames because this is fresh/globally unique- Lam l x <$> renameE ({-# SCC "replaceX" #-} replaceX (Name n u) e)-renameE (Guarded l p e) = Guarded l <$> renameE p <*> renameE e-renameE (Implicit l e) = Implicit l <$> renameE e-renameE ResVar{} = error "Bare reserved variable."-renameE (Let l (n, eϵ) e') = do- eϵ' <- renameE eϵ- (n', modR) <- withName n- Let l (n', eϵ') <$> withRenames modR (renameE e')-renameE (Paren _ e) = renameE e-renameE (Arr l es) = Arr l <$> traverse renameE es-renameE (Anchor l es) = Anchor l <$> traverse renameE es-renameE (OptionVal l e) = OptionVal l <$> traverse renameE e-renameE (Cond l p e e') = Cond l <$> renameE p <*> renameE e <*> renameE e'-renameE e = pure e -- literals &c.
− src/Jacinda/Ty.hs
@@ -1,684 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}--module Jacinda.Ty ( TypeM- , Error (..)- , runTypeM- , tyProgram- -- * For debugging- , tyOf- ) where--import Control.Exception (Exception)-import Control.Monad (forM)-import Control.Monad.Except (throwError)-import Control.Monad.State.Strict (StateT, gets, modify, runState, runStateT)-import Data.Bifunctor (first, second)-import Data.Foldable (traverse_)-import Data.Functor (void, ($>))-import qualified Data.IntMap as IM-import Data.Maybe (fromMaybe)-import Data.Semigroup ((<>))-import qualified Data.Set as S-import qualified Data.Text as T-import Data.Typeable (Typeable)-import qualified Data.Vector as V-import qualified Data.Vector.Ext as V-import Intern.Name-import Intern.Unique-import Jacinda.AST-import Jacinda.Ty.Const-import Prettyprinter (Doc, Pretty (..), squotes, vsep, (<+>))--data Error a = UnificationFailed a (T ()) (T ())- | Doesn'tSatisfy a (T ()) C- | IllScoped a (Name a)- | Ambiguous (T K) (E ())- | Expected K K- | IllScopedTyVar (TyName ())--instance Pretty a => Pretty (Error a) where- pretty (UnificationFailed l ty ty') = pretty l <+> "could not unify type" <+> squotes (pretty ty) <+> "with" <+> squotes (pretty ty')- pretty (Doesn'tSatisfy l ty c) = pretty l <+> squotes (pretty ty) <+> "is not a member of class" <+> pretty c- pretty (IllScoped l n) = pretty l <+> squotes (pretty n) <+> "is not in scope."- pretty (Ambiguous ty e) = "type" <+> squotes (pretty ty) <+> "of" <+> squotes (pretty e) <+> "is ambiguous"- pretty (Expected k0 k1) = "Found kind" <+> pretty k0 <> ", expected kind" <+> pretty k1- pretty (IllScopedTyVar n) = "Type variable" <+> squotes (pretty n) <+> "is not in scope."--instance Pretty a => Show (Error a) where- show = show . pretty--instance (Typeable a, Pretty a) => Exception (Error a) where---- solve, unify etc. THEN check that all constraints are satisfied?--- (after accumulating classVar membership...)-data TyState a = TyState { maxU :: !Int- , kindEnv :: IM.IntMap K- , classVars :: IM.IntMap (S.Set (C, a))- , varEnv :: IM.IntMap (T K)- , constraints :: S.Set (a, T K, T K)- }--prettyConstraints :: S.Set (b, T a, T a) -> Doc ann-prettyConstraints cs = vsep (prettyEq . go <$> S.toList cs) where- go (_, x, y) = (x, y)--prettyEq :: (T a, T a) -> Doc ann-prettyEq (ty, ty') = pretty ty <+> "≡" <+> pretty ty'--mapMaxU :: (Int -> Int) -> TyState a -> TyState a-mapMaxU f (TyState u k c v cs) = TyState (f u) k c v cs--setMaxU :: Int -> TyState a -> TyState a--- setMaxU i = mapMaxU (const i)-setMaxU i (TyState _ k c v cs) = TyState i k c v cs--mapClassVars :: (IM.IntMap (S.Set (C, a)) -> IM.IntMap (S.Set (C, a))) -> TyState a -> TyState a-mapClassVars f (TyState u k cvs v cs) = TyState u k (f cvs) v cs--addVarEnv :: Int -> T K -> TyState a -> TyState a-addVarEnv i ty (TyState u k cvs v cs) = TyState u k cvs (IM.insert i ty v) cs--addKindEnv :: Int -> K -> TyState a -> TyState a-addKindEnv i k (TyState u ks cvs v cs) = TyState u (IM.insert i k ks) cvs v cs--addConstraint :: Ord a => (a, T K, T K) -> TyState a -> TyState a-addConstraint c (TyState u k cvs v cs) = TyState u k cvs v (S.insert c cs)--type TypeM a = StateT (TyState a) (Either (Error a))--runTypeM :: Int -> TypeM a b -> Either (Error a) (b, Int)-runTypeM i = fmap (second maxU) . flip runStateT (TyState i IM.empty IM.empty IM.empty S.empty)--type UnifyMap a = IM.IntMap (T a)--inContext :: UnifyMap a -> T a -> T a-inContext um ty'@(TyVar _ (Name _ (Unique i) _)) =- case IM.lookup i um of- Just ty@TyVar{} -> inContext (IM.delete i um) ty -- prevent cyclic lookups- -- TODO: does this need a case for TyApp -> inContext?- Just ty -> ty- Nothing -> ty'-inContext _ ty'@TyB{} = ty'-inContext _ ty'@TyNamed{} = ty'-inContext um (TyApp l ty ty') = TyApp l (inContext um ty) (inContext um ty')-inContext um (TyArr l ty ty') = TyArr l (inContext um ty) (inContext um ty')-inContext um (TyTup l tys) = TyTup l (inContext um <$> tys)---- | Perform substitutions before handing off to 'unifyMatch'-unifyPrep :: UnifyMap a- -> [(l, T a, T a)]- -> TypeM l (IM.IntMap (T a))-unifyPrep _ [] = pure mempty-unifyPrep um ((l, ty, ty'):tys) =- let ty'' = inContext um ty- ty''' = inContext um ty'- in unifyMatch um $ (l, ty'', ty'''):tys--unifyMatch :: UnifyMap a -> [(l, T a, T a)] -> TypeM l (IM.IntMap (T a))-unifyMatch _ [] = pure mempty-unifyMatch um ((_, TyB _ b, TyB _ b'):tys) | b == b' = unifyPrep um tys-unifyMatch um ((_, TyNamed _ n0, TyNamed _ n1):tys) | n0 == n1 = unifyPrep um tys-unifyMatch um ((_, ty@TyB{}, TyVar _ (Name _ (Unique k) _)):tys) = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys-unifyMatch um ((_, TyVar _ (Name _ (Unique k) _), ty@(TyB{})):tys) = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys-unifyMatch um ((_, ty@TyArr{}, TyVar _ (Name _ (Unique k) _)):tys) = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys-unifyMatch um ((_, TyVar _ (Name _ (Unique k) _), ty@(TyArr{})):tys) = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys-unifyMatch um ((_, ty@TyApp{}, TyVar _ (Name _ (Unique k) _)):tys) = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys-unifyMatch um ((_, TyVar _ (Name _ (Unique k) _), ty@(TyTup{})):tys) = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys-unifyMatch um ((_, ty@TyTup{}, TyVar _ (Name _ (Unique k) _)):tys) = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys-unifyMatch um ((_, TyVar _ (Name _ (Unique k) _), ty@(TyApp{})):tys) = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys-unifyMatch um ((l, TyApp _ ty ty', TyApp _ ty'' ty'''):tys) = unifyPrep um ((l, ty, ty'') : (l, ty', ty''') : tys)-unifyMatch um ((l, TyArr _ ty ty', TyArr _ ty'' ty'''):tys) = unifyPrep um ((l, ty, ty'') : (l, ty', ty''') : tys)-unifyMatch um ((l, ty@(TyTup _ tys), ty'@(TyTup _ tys')):tyss)- | length tys == length tys' = unifyPrep um (zip3 (repeat l) tys tys' ++ tyss)- | otherwise = throwError (UnificationFailed l (void ty) (void ty'))-unifyMatch um ((_, TyVar _ n@(Name _ (Unique k) _), ty@(TyVar _ n')):tys)- | n == n' = unifyPrep um tys- | otherwise = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys-unifyMatch _ ((l, ty, ty'):_) = throwError (UnificationFailed l (void ty) (void ty'))--unify :: [(l, T a, T a)] -> TypeM l (IM.IntMap (T a))-unify = unifyPrep IM.empty--unifyM :: S.Set (l, T a, T a) -> TypeM l (IM.IntMap (T a))-unifyM s = {-# SCC "unifyM" #-} unify (S.toList s)--substInt :: IM.IntMap (T a) -> Int -> Maybe (T a)-substInt tys k =- case IM.lookup k tys of- Just ty'@TyVar{} -> Just $ substConstraints (IM.delete k tys) ty' -- TODO: this is to prevent cyclic lookups: is it right?- Just (TyApp l ty0 ty1) -> Just $ let tys' = IM.delete k tys in TyApp l (substConstraints tys' ty0) (substConstraints tys' ty1)- Just (TyArr l ty0 ty1) -> Just $ let tys' = IM.delete k tys in TyArr l (substConstraints tys' ty0) (substConstraints tys' ty1)- Just (TyTup l tysϵ) -> Just $ let tys' = IM.delete k tys in TyTup l (substConstraints tys' <$> tysϵ)- Just ty' -> Just ty'- Nothing -> Nothing--substConstraints :: IM.IntMap (T a) -> T a -> T a-substConstraints _ ty@TyB{} = ty-substConstraints _ ty@TyNamed{} = ty-substConstraints tys ty@(TyVar _ (Name _ (Unique k) _)) = fromMaybe ty (substInt tys k)-substConstraints tys (TyTup l tysϵ) = TyTup l (substConstraints tys <$> tysϵ)-substConstraints tys (TyApp l ty ty') =- TyApp l (substConstraints tys ty) (substConstraints tys ty')-substConstraints tys (TyArr l ty ty') =- TyArr l (substConstraints tys ty) (substConstraints tys ty')--freshName :: T.Text -> K -> TypeM a (Name K)-freshName n k = do- st <- gets maxU- Name n (Unique $ st+1) k- <$ modify (mapMaxU (+1))--namek :: Name K -> TypeM a (Name K)-namek n =- modify (addKindEnv (unUnique$unique n) (loc n)) $> n--higherOrder :: T.Text -> TypeM a (Name K)-higherOrder t = freshName t (KArr Star Star) >>= namek---- of kind 'Star'-dummyName :: T.Text -> TypeM a (Name K)-dummyName n = freshName n Star >>= namek--addC :: Ord a => Name b -> (C, a) -> IM.IntMap (S.Set (C, a)) -> IM.IntMap (S.Set (C, a))-addC (Name _ (Unique i) _) c = IM.alter (Just . go) i where- go Nothing = S.singleton c- go (Just cs) = S.insert c cs---- | arguments assumed to have kind 'Star'-tyArr :: T K -> T K -> T K-tyArr = TyArr Star--var :: Name K -> T K-var = TyVar Star---- assumes they have been renamed...-pushConstraint :: Ord a => a -> T K -> T K -> TypeM a ()-pushConstraint l ty ty' =- modify (addConstraint (l, ty, ty'))--isStar :: K -> TypeM a ()-isStar Star = pure ()-isStar k = throwError $ Expected k Star--liftCloneTy :: T a -> TypeM b (T a)-liftCloneTy ty = do- i <- gets maxU- let (ty', (j, iMaps)) = cloneTy i ty- -- FIXME: clone/propagate constraints- ty' <$ modify (setMaxU j)--cloneTy :: Int -> T a -> (T a, (Int, IM.IntMap Unique))-cloneTy i ty = flip runState (i, IM.empty) $ cloneTyM ty- where cloneTyM (TyVar l (Name n (Unique j) l')) = do- st <- gets snd- case IM.lookup j st of- Just k -> pure (TyVar l (Name n k l'))- Nothing -> do- k <- gets fst- let j' = Unique $ k+1- TyVar l (Name n j' l') <$ modify (\(u, s) -> (u+1, IM.insert j j' s))- cloneTyM (TyArr l tyϵ ty') = TyArr l <$> cloneTyM tyϵ <*> cloneTyM ty'- cloneTyM (TyApp l tyϵ ty') = TyApp l <$> cloneTyM tyϵ <*> cloneTyM ty'- cloneTyM (TyTup l tys) = TyTup l <$> traverse cloneTyM tys- cloneTyM tyϵ@TyNamed{} = pure tyϵ- cloneTyM tyϵ@TyB{} = pure tyϵ--kind :: T K -> TypeM a ()-kind (TyB Star TyStr) = pure ()-kind (TyB Star TyInteger) = pure ()-kind (TyB Star TyFloat) = pure ()-kind (TyB (KArr Star Star) TyStream) = pure ()-kind (TyB (KArr Star Star) TyOption) = pure ()-kind (TyB Star TyBool) = pure ()-kind (TyB (KArr Star Star) TyVec) = pure ()-kind (TyB Star TyUnit) = pure ()-kind (TyB k TyStr) = throwError $ Expected Star k-kind (TyB k TyInteger) = throwError $ Expected Star k-kind (TyB k TyFloat) = throwError $ Expected Star k-kind (TyB k TyUnit) = throwError $ Expected Star k-kind (TyB k TyBool) = throwError $ Expected Star k-kind (TyB k TyOption) = throwError $ Expected (KArr Star Star) k-kind (TyB k TyStream) = throwError $ Expected (KArr Star Star) k-kind (TyB k TyVec) = throwError $ Expected (KArr Star Star) k-kind (TyVar _ n@(Name _ (Unique i) _)) = do- preK <- gets (IM.lookup i . kindEnv)- case preK of- Just{} -> pure ()- Nothing -> throwError $ IllScopedTyVar (void n)-kind (TyTup Star tys) =- traverse_ isStar (fmap tLoc tys)-kind (TyTup k _) = throwError $ Expected Star k-kind (TyArr Star ty0 ty1) =- isStar (tLoc ty0) *>- isStar (tLoc ty1)-kind (TyArr k _ _) = throwError $ Expected Star k-kind (TyApp k1 ty0 ty1) = do- case tLoc ty0 of- (KArr k0 k1') | k0 == tLoc ty1 && k1' == k1 -> pure ()- | k0 == tLoc ty1 -> throwError $ Expected k1' k1- | otherwise -> throwError $ Expected (tLoc ty1) k0- k0 -> throwError $ Expected (KArr Star Star) k0--checkType :: Ord a => T K -> (C, a) -> TypeM a ()-checkType TyVar{} _ = pure () -- TODO: I think this is right-checkType (TyB _ TyR) (IsSemigroup, _) = pure ()-checkType (TyB _ TyStr) (IsSemigroup, _) = pure ()-checkType (TyB _ TyInteger) (IsSemigroup, _) = pure ()-checkType (TyB _ TyInteger) (IsNum, _) = pure ()-checkType (TyB _ TyInteger) (IsOrd, _) = pure ()-checkType (TyB _ TyInteger) (IsEq, _) = pure ()-checkType (TyB _ TyInteger) (IsParseable, _) = pure ()-checkType (TyB _ TyFloat) (IsParseable, _) = pure ()-checkType ty (IsParseable, l) = throwError $ Doesn'tSatisfy l (void ty) IsParseable-checkType (TyB _ TyFloat) (IsSemigroup, _) = pure ()-checkType (TyB _ TyFloat) (IsNum, _) = pure ()-checkType (TyB _ TyFloat) (IsOrd, _) = pure ()-checkType (TyB _ TyFloat) (IsEq, _) = pure ()-checkType (TyB _ TyBool) (IsEq, _) = pure ()-checkType (TyB _ TyStr) (IsEq, _) = pure ()-checkType ty@(TyB _ TyStr) (c@IsOrd, l) = throwError $ Doesn'tSatisfy l (void ty) c-checkType (TyTup _ tys) (IsEq, l) = traverse_ (`checkType` (IsEq, l)) tys-checkType (TyTup _ tys) (IsOrd, l) = traverse_ (`checkType` (IsOrd, l)) tys-checkType (TyApp _ (TyB _ TyVec) ty) (IsEq, l) = checkType ty (IsEq, l)-checkType ty@TyTup{} (c@IsNum, l) = throwError $ Doesn'tSatisfy l (void ty) c-checkType ty@(TyB _ TyStr) (c@IsNum, l) = throwError $ Doesn'tSatisfy l (void ty) c-checkType ty@(TyB _ TyBool) (c@IsNum, l) = throwError $ Doesn'tSatisfy l (void ty) c-checkType ty@TyArr{} (c, l) = throwError $ Doesn'tSatisfy l (void ty) c-checkType (TyB _ TyVec) (Functor, _) = pure ()-checkType (TyB _ TyStream) (Functor, _) = pure ()-checkType (TyB _ TyOption) (Functor, _) = pure ()-checkType (TyB _ TyStream) (Witherable, _) = pure ()-checkType ty (c@Witherable, l) = throwError $ Doesn'tSatisfy l (void ty) c-checkType ty (c@Functor, l) = throwError $ Doesn'tSatisfy l (void ty) c-checkType (TyB _ TyVec) (Foldable, _) = pure ()-checkType (TyB _ TyStream) (Foldable, _) = pure ()-checkType ty (c@Foldable, l) = throwError $ Doesn'tSatisfy l (void ty) c-checkType (TyB _ TyStr) (IsPrintf, _) = pure ()-checkType (TyB _ TyFloat) (IsPrintf, _) = pure ()-checkType (TyB _ TyInteger) (IsPrintf, _) = pure ()-checkType (TyB _ TyBool) (IsPrintf, _) = pure ()-checkType (TyTup _ tys) (IsPrintf, l) = traverse_ (`checkType` (IsPrintf, l)) tys-checkType ty (c@IsPrintf, l) = throwError $ Doesn'tSatisfy l (void ty) c-checkType ty@(TyTup _ tys) (c@(HasField i ty'), l) | length tys >= i = pushConstraint l ty' (tys !! (i-1))- | otherwise = throwError $ Doesn'tSatisfy l (void ty) c-checkType ty (c@HasField{}, l) = throwError $ Doesn'tSatisfy l (void ty) c--substC :: IM.IntMap (T K) -- ^ Unification result- -> C- -> C-substC um (HasField i ty) = HasField i (substConstraints um ty)-substC _ c = c--checkClass :: Ord a- => IM.IntMap (T K) -- ^ Unification result- -> Int- -> S.Set (C, a)- -> TypeM a ()-checkClass tys i cs = {-# SCC "checkClass" #-}- case substInt tys i of- Just ty -> traverse_ (checkType ty) (first (substC tys) <$> S.toList cs)- Nothing -> pure () -- FIXME: we need to check that the var is well-kinded for constraint--lookupVar :: Name a -> TypeM a (T K)-lookupVar n@(Name _ (Unique i) l) = do- st <- gets varEnv- case IM.lookup i st of- Just ty -> pure ty -- liftCloneTy ty- Nothing -> throwError $ IllScoped l n--tyOf :: Ord a => E a -> TypeM a (T K)-tyOf = fmap eLoc . tyE--tyD0 :: Ord a => D a -> TypeM a (D (T K))-tyD0 (SetFS bs) = pure $ SetFS bs-tyD0 (FunDecl n@(Name _ (Unique i) _) [] e) = do- e' <- tyE0 e- let ty = eLoc e'- modify (addVarEnv i ty)- pure $ FunDecl (n $> ty) [] e'-tyD0 FunDecl{} = error "Internal error. Should have been desugared by now."--isAmbiguous :: T K -> Bool-isAmbiguous TyVar{} = True-isAmbiguous (TyArr _ ty ty') = isAmbiguous ty || isAmbiguous ty'-isAmbiguous (TyApp _ ty ty') = isAmbiguous ty || isAmbiguous ty'-isAmbiguous (TyTup _ tys) = any isAmbiguous tys-isAmbiguous TyNamed{} = False-isAmbiguous TyB{} = False--checkAmb :: E (T K) -> TypeM a ()-checkAmb e@(BBuiltin ty _) | isAmbiguous ty = throwError $ Ambiguous ty (void e)-checkAmb TBuiltin{} = pure () -- don't fail on ternary builtins, we don't need it anyway... better error messages-checkAmb e@(UBuiltin ty _) | isAmbiguous ty = throwError $ Ambiguous ty (void e)-checkAmb (Implicit _ e') = checkAmb e'-checkAmb (Guarded _ p e') = checkAmb p *> checkAmb e'-checkAmb (EApp _ e' e'') = checkAmb e' *> checkAmb e'' -- more precise errors, don't fail yet!-checkAmb (Tup _ es) = traverse_ checkAmb 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]-checkAmb (Lam _ _ e) = checkAmb e -- I think-checkAmb _ = pure ()--tyProgram :: Ord a => Program a -> TypeM a (Program (T K))-tyProgram (Program ds e) = do- ds' <- traverse tyD0 ds- e' <- tyE0 e- backNames <- unifyM =<< gets constraints- toCheck <- gets (IM.toList . classVars)- traverse_ (uncurry (checkClass backNames)) toCheck- backNames' <- unifyM =<< gets constraints- -- FIXME: not sure if termination/whatever is guaranteed, need 2 think..- let res = {-# SCC "substConstraints" #-} fmap (substConstraints backNames') (Program ds' e')- checkAmb (expr res) $> res--tyE :: Ord a => E a -> TypeM a (E (T K))-tyE e = do- e' <- tyE0 e- backNames <- unifyM =<< gets constraints- toCheck <- gets (IM.toList . classVars)- traverse_ (uncurry (checkClass backNames)) toCheck- pure (fmap (substConstraints backNames) e')--tyNumOp :: Ord a => a -> TypeM a (T K)-tyNumOp l = do- m <- dummyName "m"- modify (mapClassVars (addC m (IsNum, l)))- let m' = var m- pure $ tyArr m' (tyArr m' m')--tySemiOp :: Ord a => a -> TypeM a (T K)-tySemiOp l = do- m <- dummyName "m"- modify (mapClassVars (addC m (IsSemigroup, l)))- let m' = var m- pure $ tyArr m' (tyArr m' m')--tyOrd :: Ord a => a -> TypeM a (T K)-tyOrd l = do- a <- dummyName "a"- modify (mapClassVars (addC a (IsOrd, l)))- let a' = var a- pure $ tyArr a' (tyArr a' tyBool)--tyEq :: Ord a => a -> TypeM a (T K)-tyEq l = do- a <- dummyName "a"- modify (mapClassVars (addC a (IsEq, l)))- let a' = var a- pure $ tyArr a' (tyArr a' tyBool)---- min/max-tyM :: Ord a => a -> TypeM a (T K)-tyM l = do- a <- dummyName "a"- modify (mapClassVars (addC a (IsOrd, l)))- let a' = var a- pure $ tyArr a' (tyArr a' a')--desugar :: a-desugar = error "Should have been de-sugared in an earlier stage!"--tyE0 :: Ord a => E a -> TypeM a (E (T K))-tyE0 (BoolLit _ b) = pure $ BoolLit tyBool b-tyE0 (IntLit _ i) = pure $ IntLit tyI i-tyE0 (FloatLit _ f) = pure $ FloatLit tyF f-tyE0 (StrLit _ str) = pure $ StrLit tyStr str-tyE0 (RegexLit _ rr) = pure $ RegexLit tyR rr-tyE0 (Column _ i) = pure $ Column (tyStream tyStr) i-tyE0 (IParseCol _ i) = pure $ IParseCol (tyStream tyI) i-tyE0 (FParseCol _ i) = pure $ FParseCol (tyStream tyF) i-tyE0 (Field _ i) = pure $ Field tyStr i-tyE0 (LastField _) = pure $ LastField tyStr-tyE0 AllField{} = pure $ AllField tyStr-tyE0 AllColumn{} = pure $ AllColumn (tyStream tyStr)-tyE0 (NBuiltin _ Ix) = pure $ NBuiltin tyI Ix-tyE0 (NBuiltin _ Fp) = pure $ NBuiltin tyStr Fp-tyE0 (NBuiltin _ Nf) = pure $ NBuiltin tyI Nf-tyE0 (BBuiltin l Plus) = BBuiltin <$> tySemiOp l <*> pure Plus-tyE0 (BBuiltin l Minus) = BBuiltin <$> tyNumOp l <*> pure Minus-tyE0 (BBuiltin l Times) = BBuiltin <$> tyNumOp l <*> pure Times-tyE0 (BBuiltin l Gt) = BBuiltin <$> tyOrd l <*> pure Gt-tyE0 (BBuiltin l Lt) = BBuiltin <$> tyOrd l <*> pure Lt-tyE0 (BBuiltin l Geq) = BBuiltin <$> tyOrd l <*> pure Geq-tyE0 (BBuiltin l Leq) = BBuiltin <$> tyOrd l <*> pure Leq-tyE0 (BBuiltin l Eq) = BBuiltin <$> tyEq l <*> pure Eq-tyE0 (BBuiltin l Neq) = BBuiltin <$> tyEq l <*> pure Neq-tyE0 (BBuiltin l Min) = BBuiltin <$> tyM l <*> pure Min-tyE0 (BBuiltin l Max) = BBuiltin <$> tyM l <*> pure Max-tyE0 (BBuiltin _ Split) = pure $ BBuiltin (tyArr tyStr (tyArr tyR (mkVec tyStr))) Split-tyE0 (BBuiltin _ Splitc) = pure $ BBuiltin (tyArr tyStr (tyArr tyStr (mkVec tyStr))) Splitc-tyE0 (BBuiltin _ Matches) = pure $ BBuiltin (tyArr tyStr (tyArr tyR tyBool)) Matches-tyE0 (BBuiltin _ NotMatches) = pure $ BBuiltin (tyArr tyStr (tyArr tyR tyBool)) NotMatches-tyE0 (UBuiltin _ Tally) = pure $ UBuiltin (tyArr tyStr tyI) Tally-tyE0 (BBuiltin _ Div) = pure $ BBuiltin (tyArr tyF (tyArr tyF tyF)) Div-tyE0 (UBuiltin _ Not) = pure $ UBuiltin (tyArr tyBool tyBool) Not-tyE0 (BBuiltin _ And) = pure $ BBuiltin (tyArr tyBool (tyArr tyBool tyBool)) And-tyE0 (BBuiltin _ Or) = pure $ BBuiltin (tyArr tyBool (tyArr tyBool tyBool)) Or-tyE0 (BBuiltin _ Match) = pure $ BBuiltin (tyArr tyStr (tyArr tyR (tyOpt $ TyTup Star [tyI, tyI]))) Match-tyE0 (TBuiltin _ Substr) = pure $ TBuiltin (tyArr tyStr (tyArr tyI (tyArr tyI tyStr))) Substr-tyE0 (UBuiltin _ IParse) = pure $ UBuiltin (tyArr tyStr tyI) IParse-tyE0 (UBuiltin _ FParse) = pure $ UBuiltin (tyArr tyStr tyF) FParse-tyE0 (UBuiltin _ Floor) = pure $ UBuiltin (tyArr tyF tyI) Floor-tyE0 (UBuiltin _ Ceiling) = pure $ UBuiltin (tyArr tyF tyI) Ceiling-tyE0 (UBuiltin _ TallyList) = do- a <- dummyName "a"- let a' = var a- pure $ UBuiltin (tyArr a' tyI) TallyList-tyE0 (UBuiltin l Negate) = do- a <- dummyName "a"- modify (mapClassVars (addC a (IsNum, l)))- let a' = var a- pure $ UBuiltin (tyArr a' a') Negate-tyE0 (UBuiltin _ Some) = do- a <- dummyName "a"- let a' = var a- pure $ UBuiltin (tyArr a' (tyOpt a')) Some-tyE0 (NBuiltin _ None) = do- a <- dummyName "a"- pure $ NBuiltin (tyOpt $ var a) None-tyE0 (ParseCol l i) = do- a <- dummyName "a"- let a' = var a- modify (mapClassVars (addC a (IsParseable, l)))- pure $ ParseCol (tyStream a') i-tyE0 (UBuiltin l Parse) = do- a <- dummyName "a"- let a' = var a- modify (mapClassVars (addC a (IsParseable, l)))- pure $ UBuiltin (tyArr tyStr a') Parse-tyE0 (BBuiltin l Sprintf) = do- a <- dummyName "a"- let a' = var a- modify (mapClassVars (addC a (IsPrintf, l)))- pure $ BBuiltin (tyArr tyStr (tyArr a' tyStr)) Sprintf-tyE0 (UBuiltin _ (At i)) = do- a <- dummyName "a"- let a' = var a- tyV = mkVec a'- pure $ UBuiltin (tyArr tyV a') (At i)-tyE0 (UBuiltin l (Select i)) = do- a <- dummyName "a"- b <- dummyName "b"- let a' = var a- b' = var b- modify (mapClassVars (addC a (HasField i b', l)))- pure $ UBuiltin (tyArr a' b') (Select i)-tyE0 (UBuiltin l Dedup) = do- a <- dummyName "a"- let a' = var a- fTy = tyArr (tyStream a') (tyStream a')- modify (mapClassVars (addC a (IsEq, l)))- pure $ UBuiltin fTy Dedup-tyE0 (UBuiltin _ Const) = do- a <- dummyName "a"- b <- dummyName "b"- let a' = var a- b' = var b- fTy = tyArr a' (tyArr b' a')- pure $ UBuiltin fTy Const-tyE0 (UBuiltin l CatMaybes) = do- a <- dummyName "a"- f <- higherOrder "f"- let a' = var a- f' = var f- fTy = tyArr (hkt f' $ tyOpt a') (hkt f' a')- modify (mapClassVars (addC f (Witherable, l)))- pure $ UBuiltin fTy CatMaybes-tyE0 (BBuiltin l Filter) = do- a <- dummyName "a"- f <- higherOrder "f"- let a' = var a- f' = var f- fTy = tyArr (tyArr a' tyBool) (tyArr (hkt f' a') (hkt f' a'))- modify (mapClassVars (addC f (Witherable , l)))- pure $ BBuiltin fTy Filter-tyE0 (BBuiltin l MapMaybe) = do- a <- dummyName "a"- b <- dummyName "b"- f <- higherOrder "f"- let a' = var a- b' = var b- f' = var f- fTy = tyArr (tyArr a' (tyOpt b')) (tyArr (hkt f' a') (hkt f' b'))- modify (mapClassVars (addC f (Witherable, l)))- pure $ BBuiltin fTy MapMaybe-tyE0 (BBuiltin l Map) = do- a <- dummyName "a"- b <- dummyName "b"- f <- higherOrder "f"- let a' = var a- b' = var b- f' = var f- fTy = tyArr (tyArr a' b') (tyArr (hkt f' a') (hkt f' b'))- modify (mapClassVars (addC f (Functor, l)))- pure $ BBuiltin fTy Map-tyE0 (TBuiltin l Fold) = do- b <- dummyName "b"- a <- dummyName "a"- f <- higherOrder "f"- let b' = var b- a' = var a- f' = var f- fTy = tyArr (tyArr b' (tyArr a' b')) (tyArr b' (tyArr (hkt f' a') b'))- modify (mapClassVars (addC f (Foldable, l)))- pure $ TBuiltin fTy Fold-tyE0 (BBuiltin l Fold1) = do- a <- dummyName "a"- f <- higherOrder "f"- let a' = var a- f' = var f- fTy = tyArr (tyArr a' (tyArr a' a')) (tyArr (hkt f' a') a')- modify (mapClassVars (addC f (Foldable, l)))- pure $ BBuiltin fTy Fold1-tyE0 (TBuiltin _ Captures) =- pure $ TBuiltin (tyArr tyStr (tyArr tyI (tyArr tyR (tyOpt tyStr)))) Captures--- (a -> a -> a) -> Stream a -> Stream a-tyE0 (BBuiltin _ Prior) = do- a <- dummyName "a"- b <- dummyName "b"- let a' = var a- b' = var b- fTy = tyArr (tyArr a' (tyArr a' b')) (tyArr (tyStream a') (tyStream b'))- pure $ BBuiltin fTy Prior--- (a -> b -> c) -> Stream a -> Stream b -> Stream c-tyE0 (TBuiltin _ ZipW) = do- a <- dummyName "a"- b <- dummyName "b"- c <- dummyName "c"- let a' = var a- b' = var b- c' = var c- fTy = tyArr (tyArr a' (tyArr b' c')) (tyArr (tyStream a') (tyArr (tyStream b') (tyStream c')))- pure $ TBuiltin fTy ZipW--- (b -> a -> b) -> b -> Stream a -> Stream b-tyE0 (TBuiltin _ Scan) = do- b <- dummyName "b"- a <- dummyName "a"- let b' = var b- a' = var a- fTy = tyArr (tyArr b' (tyArr a' b')) (tyArr b' (tyArr (tyStream a') (tyStream b')))- pure $ TBuiltin fTy Scan-tyE0 (TBuiltin _ Option) = do- b <- dummyName "b"- a <- dummyName "a"- let b' = var b- a' = var a- fTy = tyArr b' (tyArr (tyArr a' b') (tyArr (tyOpt a') b'))- pure $ TBuiltin fTy Option-tyE0 (TBuiltin _ AllCaptures) =- pure $ TBuiltin (tyArr tyStr (tyArr tyI (tyArr tyR (mkVec tyStr)))) AllCaptures-tyE0 (Implicit _ e) = do- e' <- tyE0 e- pure $ Implicit (tyStream (eLoc e')) e'-tyE0 (Guarded l e streamE) = do- streamE' <- tyE0 streamE- e' <- tyE0 e- pushConstraint l tyBool (eLoc e')- pure $ Guarded (tyStream (eLoc streamE')) e' streamE'-tyE0 (EApp _ e0 e1) = do- e0' <- tyE0 e0- e1' <- tyE0 e1- a <- dummyName "a"- b <- dummyName "b"- let a' = var a- b' = var b- fTy = tyArr a' b'- pushConstraint (eLoc e0) fTy (eLoc e0')- pushConstraint (eLoc e1) a' (eLoc e1')- pure $ EApp b' e0' e1'-tyE0 (Lam _ n@(Name _ (Unique i) _) e) = do- a <- dummyName "a"- let a' = var a- modify (addVarEnv i a')- e' <- tyE0 e- pure $ Lam (tyArr a' (eLoc e')) (n $> a') e'-tyE0 (Let _ (n@(Name _ (Unique i) _), eϵ) e) = do- eϵ' <- tyE0 eϵ- let bTy = eLoc eϵ'- modify (addVarEnv i bTy)- e' <- tyE0 e- pure $ Let (eLoc e') (n $> bTy, eϵ') e'-tyE0 (Tup _ es) = do- es' <- traverse tyE0 es- pure $ Tup (TyTup Star (eLoc <$> es')) es'-tyE0 (Var _ n) = do- ty <- lookupVar n- pure (Var ty (n $> ty))-tyE0 Dfn{} = desugar-tyE0 (ResVar _ X) = desugar-tyE0 (ResVar _ Y) = desugar-tyE0 RegexCompiled{} = error "Regex should not be compiled at this stage."-tyE0 Paren{} = desugar-tyE0 (OptionVal _ (Just e)) = do- e' <- tyE0 e- pure $ OptionVal (tyOpt $ eLoc e') (Just e')-tyE0 (OptionVal _ Nothing) = do- a <- dummyName "a"- let a' = var a- pure $ OptionVal (tyOpt a') Nothing-tyE0 (Arr l v) | V.null v = do- a <- dummyName "a"- let a' = var a- pure $ Arr (mkVec a') V.empty- | otherwise = do- v' <- traverse tyE0 v- let x = V.head v'- V.priorM_ (\y y' -> pushConstraint l (eLoc y) (eLoc y')) v'- pure $ Arr (eLoc x) v'-tyE0 (Anchor l es) = do- es' <- forM es $ \e -> do- e' <- tyE0 e- a <- dummyName "a"- let a' = var a- pushConstraint l (tyStream a') (eLoc e') $> e'- pure $ Anchor (TyB Star TyUnit) es'-tyE0 (Cond l p e0 e1) = do- p' <- tyE0 p- e0' <- tyE0 e0- e1' <- tyE0 e1- let ty0 = eLoc e0'- pushConstraint l tyBool (eLoc p')- pushConstraint (eLoc e0) ty0 (eLoc e1')- pure $ Cond ty0 p' e0' e1'
− src/Jacinda/Ty/Const.hs
@@ -1,42 +0,0 @@-module Jacinda.Ty.Const ( tyStream- , tyStr, tyR- , tyI- , tyF- , tyBool- , hkt- , tyOpt- , mkVec- ) where--import Jacinda.AST---- | argument assumed to have kind 'Star'-tyStream :: T K -> T K-tyStream = TyApp Star (TyB (KArr Star Star) TyStream)--tyBool :: T K-tyBool = TyB Star TyBool--tyI :: T K-tyI = TyB Star TyInteger--tyF :: T K-tyF = TyB Star TyFloat--tyStr :: T K-tyStr = TyB Star TyStr--tyR :: T K-tyR = TyB Star TyR--hkt :: T K -> T K -> T K-hkt = TyApp Star--tyOpt :: T K -> T K-tyOpt = hkt (TyB (KArr Star Star) TyOption)--tyVec :: T K-tyVec = TyB (KArr Star Star) TyVec--mkVec :: T K -> T K-mkVec = hkt tyVec
+ src/L.x view
@@ -0,0 +1,482 @@+{+ {-# LANGUAGE OverloadedStrings #-}+ module L ( alexMonadScan+ , alexInitUserState+ , runAlex+ , runAlexSt+ , withAlexSt+ , freshName+ , AlexPosn (..)+ , Alex (..)+ , Token (..)+ , Keyword (..)+ , Sym (..)+ , Builtin (..)+ , Var (..)+ , AlexUserState+ ) where++import Control.Arrow ((&&&))+import Data.Bifunctor (first)+import qualified Data.ByteString.Lazy as BSL+import Data.Functor (($>))+import qualified Data.IntMap as IM+import qualified Data.Map as M+import Data.Semigroup ((<>))+import qualified Data.Text as T+import Nm+import Prettyprinter (Pretty (pretty), (<+>), colon, squotes)+import U++}++%wrapper "monadUserState-strict-text"++$digit = [0-9]++$latin = [a-zA-Z]++@follow_char = [$latin $digit \_]++$str_special = [\\\']++@escape_str = \\ [$str_special nt]++@string = \' ([^ $str_special] | @escape_str)* \'++@name = [a-z] @follow_char*+@tyname = [A-Z] @follow_char*++@float = $digit+\.$digit+++tokens :-++ <dfn> {+ x { mkRes VarX }+ y { mkRes VarY }+ }++ <0> "[" { mkSym LSqBracket `andBegin` dfn } -- FIXME: this doesn't allow nested++ <0,dfn> {++ $white+ ;++ "{.".* ;+ "#!".* ; -- shebang++ ":=" { mkSym DefEq }+ "≔" { mkSym DefEq }+ "{" { mkSym LBrace }+ "}" { mkSym RBrace }++ "#." { mkSym FilterTok }++ -- symbols/operators+ "%" { mkSym PercentTok }+ "*" { mkSym TimesTok }+ "**" { mkSym ExpTok }+ "+" { mkSym PlusTok }+ "-" { mkSym MinusTok }++ "|" { mkSym FoldTok }+ \" { mkSym Quot }+ "^" { mkSym Caret }+ "|>" { mkSym Fold1Tok }++ "=" { mkSym EqTok }+ "!=" { mkSym NeqTok }+ "<=" { mkSym LeqTok }+ "<" { mkSym LtTok }+ ">=" { mkSym GeqTok }+ ">" { mkSym GtTok }+ "&" { mkSym AndTok }+ "||" { mkSym OrTok }+ "(" { mkSym LParen }+ ")" { mkSym RParen }+ "&(" { mkSym LAnchor }+ "{%" { mkSym LBracePercent }+ "{|" { mkSym LBraceBar }+ "]" { mkSym RSqBracket `andBegin` 0 }+ "~" { mkSym Tilde }+ "!~" { mkSym NotMatchTok }+ "," { mkSym Comma }+ "." { 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 }+ "~.*" { mkSym DedupOnTok }+ ".?" { mkSym CatMaybesTok }+ ":?" { mkSym MapMaybeTok }+ "~*" { mkSym CapTok }+ "-." { mkSym NegTok }+ "`*" { mkSym LastFieldTok }++ in { mkKw KwIn }+ let { mkKw KwLet }+ val { mkKw KwVal }+ end { mkKw KwEnd }+ :set { mkKw KwSet }+ :flush { mkKw KwFlush }+ fn { mkKw KwFn }+ "@include" { mkKw KwInclude }+ if { mkKw KwIf }+ then { mkKw KwThen }+ else { mkKw KwElse }++ fs { mkRes VarFs }+ ix { mkRes VarIx }+ ⍳ { mkRes VarIx }+ nf { mkRes VarNf }+ ¨ { mkSym Quot }+ min { mkRes VarMin }+ max { mkRes 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 }++ ":i" { mkBuiltin BuiltinIParse }+ ":f" { mkBuiltin BuiltinFParse }++ "#t" { tok (\p _ -> alex $ TokBool p True) }+ "#f" { tok (\p _ -> alex $ TokBool p False) }++ \$$digit+ { tok (\p s -> alex $ TokStreamLit p (read $ T.unpack $ T.tail s)) }+ `$digit+ { tok (\p s -> alex $ TokFieldLit p (read $ T.unpack $ T.tail s)) }++ "."$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)) }+ $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)) }++ $digit+\.$digit+ { tok (\p s -> alex $ TokFloat p (read $ T.unpack s)) }+ _$digit+\.$digit+ { tok (\p s -> alex $ TokFloat p (negate $ read $ T.unpack $ T.tail s)) }++ @string { tok (\p s -> alex $ TokStr p (escReplace $ T.init $ T.tail s)) }++ -- TODO: allow chars to be escaped+ "/"[^\/]*"/" { tok (\p s -> alex $ TokRR p (T.init $ T.tail s)) }++ @name { tok (\p s -> TokName p <$> newIdentAlex p s) }+ @tyname { tok (\p s -> TokTyName p <$> newIdentAlex p s) }++ }++{++dropQuotes :: BSL.ByteString -> BSL.ByteString+dropQuotes = BSL.init . BSL.tail++alex :: a -> Alex a+alex = pure++tok f (p,_,_,s) len = f p (T.take len s)++constructor c t = tok (\p _ -> alex $ c p t)++mkRes = constructor TokResVar++mkKw = constructor TokKeyword++mkSym = constructor TokSym++mkBuiltin = constructor TokBuiltin++-- this is inefficient but w/e+escReplace :: T.Text -> T.Text+escReplace =+ T.replace "\\\"" "\""+ . T.replace "\\n" "\n"+ . T.replace "\\t" "\t"++instance Pretty AlexPosn where+ pretty (AlexPn _ line col) = pretty line <> colon <> pretty col++-- functional bimap?+type AlexUserState = (Int, M.Map T.Text Int, IM.IntMap (Nm AlexPosn))++alexInitUserState :: AlexUserState+alexInitUserState = (0, mempty, mempty)++gets_alex :: (AlexState -> a) -> Alex a+gets_alex f = Alex (Right . (id &&& f))++get_ust :: Alex AlexUserState+get_ust = gets_alex alex_ust++get_pos :: Alex AlexPosn+get_pos = gets_alex alex_pos++set_ust :: AlexUserState -> Alex ()+set_ust st = Alex (Right . (go &&& (const ())))+ where go s = s { alex_ust = st }++alexEOF = EOF <$> get_pos++data Sym = PlusTok+ | MinusTok+ | PercentTok+ | ExpTok+ | FoldTok+ | Fold1Tok+ | Quot+ | TimesTok+ | DefEq+ | Colon+ | LBrace+ | RBrace+ | LParen+ | LAnchor+ | RParen+ | LSqBracket+ | RSqBracket+ | Semicolon+ | Underscore+ | EqTok+ | LeqTok+ | LtTok+ | NeqTok+ | GeqTok+ | GtTok+ | AndTok+ | OrTok+ | Tilde+ | NotMatchTok+ | Comma+ | Dot+ | TallyTok+ | LengthTok+ | ConstTok+ | LBracePercent+ | LBraceBar+ | Exclamation+ | Caret+ | Backslash+ | BackslashDot+ | FilterTok+ | FloorSym+ | CeilSym+ | DedupTok+ | DedupOnTok+ | CatMaybesTok+ | MapMaybeTok+ | CapTok+ | NegTok+ | LastFieldTok++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 Comma = ","+ pretty Dot = "."+ pretty TallyTok = "#"+ 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 = "`*"++data Keyword = KwLet+ | KwIn+ | KwVal+ | KwEnd+ | KwSet+ | KwFlush+ | KwFn+ | KwInclude+ | KwIf+ | KwThen+ | KwElse++-- | Reserved/special variables+data Var = VarX+ | VarY+ | VarFs+ | VarIx+ | VarMin+ | VarMax+ | VarNf++instance Pretty Var where+ pretty VarX = "x"+ pretty VarY = "y"+ pretty VarFs = "fs"+ pretty VarIx = "⍳"+ pretty VarNf = "nf"+ pretty VarMin = "min"+ pretty VarMax = "max"++instance Pretty Keyword where+ pretty KwLet = "let"+ pretty KwIn = "in"+ pretty KwVal = "val"+ pretty KwEnd = "end"+ pretty KwSet = ":set"+ pretty KwFlush = ":flush"+ pretty KwFn = "fn"+ pretty KwInclude = "@include"+ pretty KwIf = "if"+ pretty KwThen = "then"+ pretty KwElse = "else"++data Builtin = BuiltinIParse+ | BuiltinFParse+ | BuiltinSubstr+ | BuiltinSplit+ | BuiltinSplitc+ | BuiltinOption+ | BuiltinSprintf+ | BuiltinFloor+ | BuiltinCeil+ | BuiltinMatch+ | BuiltinCaptures+ | BuiltinSome+ | BuiltinNone+ | BuiltinFp++instance Pretty Builtin where+ pretty BuiltinIParse = ":i"+ pretty BuiltinFParse = ":f"+ pretty BuiltinSubstr = "substr"+ pretty BuiltinSplit = "split"+ pretty BuiltinOption = "option"+ pretty BuiltinSplitc = "splitc"+ pretty BuiltinSprintf = "sprintf"+ pretty BuiltinFloor = "floor"+ pretty BuiltinCeil = "ceil"+ pretty BuiltinMatch = "match"+ pretty BuiltinSome = "Some"+ pretty BuiltinNone = "None"+ pretty BuiltinFp = "fp"+ pretty BuiltinCaptures = "captures"++data Token a = EOF { loc :: a }+ | TokSym { loc :: a, _sym :: Sym }+ | TokName { loc :: a, _name :: Nm a }+ | TokTyName { loc :: a, _tyName :: TyName a }+ | TokBuiltin { loc :: a, _builtin :: Builtin }+ | TokKeyword { loc :: a, _kw :: Keyword }+ | TokResVar { loc :: a, _var :: Var }+ | TokInt { loc :: a, int :: Integer }+ | TokFloat { loc :: a, float :: Double }+ | TokBool { loc :: a, boolTok :: Bool }+ | TokStr { loc :: a, strTok :: T.Text }+ | TokStreamLit { loc :: a, ix :: Int }+ | TokFieldLit { loc :: a, ix :: Int }+ | TokRR { loc :: a, rr :: T.Text }+ | TokAccess { loc :: a, ix :: Int }+ | TokSelect { loc :: a, field :: Int }++instance Pretty (Token a) where+ pretty EOF{} = "(eof)"+ pretty (TokSym _ s) = "symbol" <+> squotes (pretty s)+ pretty (TokName _ n) = "identifier" <+> squotes (pretty n)+ pretty (TokTyName _ tn) = "identifier" <+> squotes (pretty tn)+ pretty (TokBuiltin _ b) = "builtin" <+> squotes (pretty b)+ pretty (TokKeyword _ kw) = "keyword" <+> squotes (pretty kw)+ pretty (TokInt _ i) = pretty i+ pretty (TokStr _ str) = squotes (pretty str)+ pretty (TokStreamLit _ i) = "$" <> pretty i+ pretty (TokFieldLit _ i) = "`" <> pretty i+ pretty (TokRR _ rr') = "/" <> pretty rr' <> "/"+ pretty (TokResVar _ v) = "reserved variable" <+> squotes (pretty v)+ pretty (TokBool _ True) = "#t"+ pretty (TokBool _ False) = "#f"+ pretty (TokAccess _ i) = "." <> pretty i+ pretty (TokFloat _ f) = pretty f+ pretty (TokSelect _ i) = "->" <> pretty i++freshName :: T.Text -> Alex (Nm AlexPosn)+freshName t = do+ pos <- get_pos+ newIdentAlex pos t++newIdentAlex :: AlexPosn -> T.Text -> Alex (Nm AlexPosn)+newIdentAlex pos t = do+ st <- get_ust+ let (st', n) = newIdent pos t st+ set_ust st' $> (n $> pos)++newIdent :: AlexPosn -> T.Text -> AlexUserState -> (AlexUserState, Nm AlexPosn)+newIdent pos t pre@(max', names, uniqs) =+ case M.lookup t names of+ Just i -> (pre, Nm t (U i) pos)+ Nothing -> let i = max' + 1+ in let newName = Nm t (U i) pos+ in ((i, M.insert t i names, IM.insert i newName uniqs), newName)++runAlexSt :: T.Text -> Alex a -> Either String (AlexUserState, a)+runAlexSt inp = withAlexSt inp alexInitUserState++withAlexSt :: T.Text -> AlexUserState -> Alex a -> Either String (AlexUserState, a)+withAlexSt inp ust (Alex f) = first alex_ust <$> f+ (AlexState { alex_bytes = []+ , alex_pos = alexStartPos+ , alex_inp = inp+ , alex_chr = '\n'+ , alex_ust = ust+ , alex_scd = 0+ })++}
+ src/Nm.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE DeriveFunctor #-}++module Nm ( Nm (..)+ , TyName+ , eqName+ ) where++import qualified Data.Text as T+import Prettyprinter (Pretty (pretty))+import U++data Nm a = Nm { name :: T.Text+ , unique :: !U+ , loc :: a+ } deriving (Functor)++-- for testing+eqName :: Nm a -> Nm a -> Bool+eqName (Nm n _ _) (Nm n' _ _) = n == n'++instance Eq (Nm a) where+ (==) (Nm _ u _) (Nm _ u' _) = u == u'++instance Pretty (Nm a) where+ 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/Parser.y view
@@ -0,0 +1,360 @@+{+ {-# LANGUAGE OverloadedStrings #-}+ module Parser ( parse+ , parseWithMax+ , parseWithInitCtx+ , parseWithCtx+ , parseLibWithCtx+ , ParseError (..)+ -- * Type synonyms+ , File+ , Library+ ) where++import Control.Exception (Exception)+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 qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import Data.Typeable (Typeable)+import A+import L+import Nm hiding (loc)+import qualified Nm+import Prettyprinter (Pretty (pretty), (<+>))++}++%name parseF File+%name parseLib Library+%tokentype { Token AlexPosn }+%error { parseError }+%monad { Parse } { (>>=) } { pure }+%lexer { lift alexMonadScan >>= } { EOF _ }++%token++ defEq { TokSym $$ DefEq }+ colon { TokSym $$ Colon }+ lbrace { TokSym $$ LBrace }+ rbrace { TokSym $$ RBrace }+ lsqbracket { TokSym $$ LSqBracket }+ rsqbracket { TokSym $$ RSqBracket }+ lparen { TokSym $$ LParen }+ lanchor { TokSym $$ LAnchor }+ rparen { TokSym $$ RParen }+ semicolon { TokSym $$ Semicolon }+ backslash { TokSym $$ Backslash }+ tilde { TokSym $$ Tilde }+ notMatch { TokSym $$ NotMatchTok }+ dot { TokSym $$ Dot }+ lbracePercent { TokSym $$ LBracePercent }+ lbraceBar { TokSym $$ LBraceBar }+ tally { TokSym $$ TallyTok }+ tallyL { TokSym $$ LengthTok }+ const { TokSym $$ ConstTok }+ filter { TokSym $$ FilterTok }+ exclamation { TokSym $$ Exclamation }+ backslashdot { TokSym $$ BackslashDot }+ at { $$@(TokAccess _ _) }+ select { $$@(TokSelect _ _) }+ floorSym { TokSym $$ FloorSym }+ ceilSym { TokSym $$ CeilSym }+ dedup { TokSym $$ DedupTok }+ dedupon { TokSym $$ DedupOnTok }++ plus { TokSym $$ PlusTok }+ minus { TokSym $$ MinusTok }+ times { TokSym $$ TimesTok }+ percent { TokSym $$ PercentTok }+ exp { TokSym $$ ExpTok }++ comma { TokSym $$ Comma }+ fold { TokSym $$ FoldTok }+ fold1 { TokSym $$ Fold1Tok }+ caret { TokSym $$ Caret }+ quot { TokSym $$ Quot }+ mapMaybe { TokSym $$ MapMaybeTok }+ catMaybes { TokSym $$ CatMaybesTok }+ capture { TokSym $$ CapTok }+ neg { TokSym $$ NegTok }++ eq { TokSym $$ EqTok }+ neq { TokSym $$ NeqTok }+ leq { TokSym $$ LeqTok }+ lt { TokSym $$ LtTok }+ geq { TokSym $$ GeqTok }+ gt { TokSym $$ GtTok }++ and { TokSym $$ AndTok }+ or { TokSym $$ OrTok }++ name { TokName _ $$ }+ tyName { TokTyName _ $$ }++ intLit { $$@(TokInt _ _) }+ floatLit { $$@(TokFloat _ _) }+ boolLit { $$@(TokBool _ _) }+ strLit { $$@(TokStr _ _) }+ allColumn { TokStreamLit $$ 0 }+ allField { TokFieldLit $$ 0 }+ column { $$@(TokStreamLit _ _) }+ field { $$@(TokFieldLit _ _) }+ lastField { TokSym $$ LastFieldTok } -- TokSym is maybe insensible but whatever++ let { TokKeyword $$ KwLet }+ in { TokKeyword $$ KwIn }+ val { TokKeyword $$ KwVal }+ end { TokKeyword $$ KwEnd }+ set { TokKeyword $$ KwSet }+ flush { TokKeyword $$ KwFlush }+ fn { TokKeyword $$ KwFn }+ include { TokKeyword $$ KwInclude }+ if { TokKeyword $$ KwIf }+ then { TokKeyword $$ KwThen }+ else { TokKeyword $$ KwElse }++ x { TokResVar $$ VarX }+ y { TokResVar $$ VarY }++ min { TokResVar $$ VarMin }+ max { TokResVar $$ VarMax }+ ix { TokResVar $$ VarIx }+ nf { TokResVar $$ VarNf }+ fs { TokResVar $$ VarFs }++ split { TokBuiltin $$ BuiltinSplit }+ splitc { TokBuiltin $$ BuiltinSplitc }+ substr { TokBuiltin $$ BuiltinSubstr }+ 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 }++ iParse { TokBuiltin $$ BuiltinIParse }+ fParse { TokBuiltin $$ BuiltinFParse }++ rr { $$@(TokRR _ _) }++%right const+%left paren iParse fParse+%nonassoc leq geq gt lt neq eq++%%++many(p)+ : many(p) p { $2 : $1 }+ | { [] }++sepBy(p,q)+ : sepBy(p,q) q p { $3 : $1 }+ | p q p { $3 : [$1] }++braces(p)+ : lbrace p rbrace { $2 }++brackets(p)+ : lsqbracket p rsqbracket { $2 }++parens(p)+ : lparen p rparen { $2 }++-- binary operator+BBin :: { BBin }+ : plus { Plus }+ | times { Times }+ | minus { Minus }+ | percent { Div }+ | gt { Gt }+ | lt { Lt }+ | geq { Geq }+ | leq { Leq }+ | eq { Eq }+ | neq { Neq }+ | quot { Map }+ | mapMaybe { MapMaybe }+ | tilde { Matches }+ | notMatch { NotMatches }+ | and { And }+ | or { Or }+ | backslashdot { Prior }+ | filter { Filter }+ | fold1 { Fold1 }+ | exp { Exp }+ | dedupon { DedupOn }++Bind :: { (Nm AlexPosn, E AlexPosn) }+ : val name defEq E { ($2, $4) }++Args :: { [(Nm AlexPosn)] }+ : lparen rparen { [] }+ | parens(name) { [$1] }+ | parens(sepBy(name, comma)) { reverse $1 }++D :: { D AlexPosn }+ : set fs defEq rr semicolon { SetFS (rr $4) }+ | flush semicolon { FlushDecl }+ | fn name Args defEq E semicolon { FunDecl $2 $3 $5 }+ | fn name defEq E semicolon { FunDecl $2 [] $4 }++Include :: { FilePath }+ : include strLit { T.unpack (strTok $2) }++File :: { ([FilePath], Program AlexPosn) }+ : many(Include) Program { (reverse $1, $2) }++Library :: { Library }+ : many(Include) many(D) { (reverse $1, reverse $2) }++Program :: { Program AlexPosn }+ : many(D) E { Program (reverse $1) $2 }++E :: { E AlexPosn }+ : name { Var (Nm.loc $1) $1 }+ | intLit { ILit (loc $1) (int $1) }+ | floatLit { FLit (loc $1) (float $1) }+ | boolLit { BLit (loc $1) (boolTok $1) }+ | strLit { StrLit (loc $1) (encodeUtf8 $ strTok $1) }+ | column { Column (loc $1) (ix $1) }+ | field { Field (loc $1) (ix $1) }+ | allColumn { AllColumn $1 }+ | allField { AllField $1 }+ | lastField { LastField $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) }+ | name fParse { EApp (Nm.loc $1) (UB $2 FParse) (Var (Nm.loc $1) $1) }+ | field colon { EApp (loc $1) (UB $2 Parse) (Field (loc $1) (ix $1)) }+ | name colon { EApp (Nm.loc $1) (UB $2 Parse) (Var (Nm.loc $1) $1) }+ | lastField iParse { EApp $1 (UB $2 IParse) (LastField $1) }+ | lastField fParse { EApp $1 (UB $2 FParse) (LastField $1) }+ | lastField colon { EApp $1 (UB $2 Parse) (LastField $1) }+ | x colon { EApp $1 (UB $2 Parse) (ResVar $1 X) }+ | y colon { EApp $1 (UB $2 Parse) (ResVar $1 Y) }+ | x iParse { EApp $1 (UB $2 IParse) (ResVar $1 X) }+ | x fParse { EApp $1 (UB $2 FParse) (ResVar $1 X) }+ | y iParse { EApp $1 (UB $2 IParse) (ResVar $1 Y) }+ | y fParse { EApp $1 (UB $2 FParse) (ResVar $1 Y) }+ | column iParse { IParseCol (loc $1) (ix $1) }+ | column fParse { FParseCol (loc $1) (ix $1) }+ | column colon { ParseCol (loc $1) (ix $1) }+ | parens(iParse) { UB $1 IParse }+ | parens(fParse) { UB $1 FParse }+ | parens(colon) { UB $1 Parse }+ | lparen BBin rparen { BB $1 $2 }+ | lparen E BBin rparen { EApp $1 (BB $1 $3) $2 }+ | lparen BBin E rparen {% do { n <- lift $ freshName "x" ; pure (Lam $1 n (EApp $1 (EApp $1 (BB $1 $2) (Var (Nm.loc n) n)) $3)) } }+ | E BBin E { EApp (eLoc $1) (EApp (eLoc $3) (BB (eLoc $1) $2) $1) $3 }+ | 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 }+ | 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) }+ | lanchor sepBy(E, dot) rparen { Anchor $1 (reverse $2) }+ | E E { EApp (eLoc $1) $1 $2 }+ | tally { UB $1 Tally }+ | tallyL { UB $1 TallyList }+ | const { UB $1 Const }+ | exclamation { UB $1 Not }+ | lsqbracket E rsqbracket { Dfn $1 $2 }+ | x { ResVar $1 X }+ | y { ResVar $1 Y }+ | rr { RegexLit (loc $1) (encodeUtf8 $ rr $1) }+ | min { BB $1 Min }+ | max { BB $1 Max }+ | split { BB $1 Split }+ | match { BB $1 Match }+ | splitc { BB $1 Splitc }+ | substr { TB $1 Substr }+ | sprintf { BB $1 Sprintf }+ | option { TB $1 Option }+ | captures { TB $1 AllCaptures }+ | floor { UB $1 Floor }+ | ceil { UB $1 Ceiling }+ | floorSym { UB $1 Floor }+ | ceilSym { UB $1 Ceiling }+ | dedup { UB $1 Dedup }+ | some { UB $1 Some }+ | catMaybes { UB $1 CatMaybes }+ | neg { UB $1 Negate }+ | ix { NB $1 Ix }+ | nf { NB $1 Nf }+ | none { NB $1 None }+ | fp { NB $1 Fp }+ | parens(at) { UB (loc $1) (At $ ix $1) }+ | parens(select) { UB (loc $1) (Select $ field $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 }+ | 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 }++{++type File = ([FilePath], Program AlexPosn)++type Library = ([FilePath], [D AlexPosn])++parseError :: Token AlexPosn -> Parse a+parseError = throwError . 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)+ | 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)++instance Pretty a => Show (ParseError a) where+ show = show . pretty++instance (Pretty a, Typeable a) => Exception (ParseError a)++type Parse = ExceptT (ParseError AlexPosn) Alex++parse :: T.Text -> Either (ParseError AlexPosn) File+parse = fmap snd . runParse parseF++parseWithMax :: T.Text -> Either (ParseError AlexPosn) (Int, File)+parseWithMax = fmap (first fst3) . runParse parseF+ where fst3 (x, _, _) = x++parseWithInitCtx :: T.Text -> Either (ParseError AlexPosn) (AlexUserState, File)+parseWithInitCtx bsl = parseWithCtx bsl alexInitUserState++parseWithCtx :: T.Text -> AlexUserState -> Either (ParseError AlexPosn) (AlexUserState, File)+parseWithCtx = parseWithInitSt parseF++parseLibWithCtx :: T.Text -> AlexUserState -> Either (ParseError AlexPosn) (AlexUserState, Library)+parseLibWithCtx = parseWithInitSt parseLib++runParse :: Parse a -> T.Text -> Either (ParseError AlexPosn) (AlexUserState, a)+runParse parser str = liftErr $ runAlexSt str (runExceptT parser)++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)+liftErr (Right (_, Left err)) = Left err+liftErr (Right (i, Right x)) = Right (i, x)++}
+ src/Parser/Rw.hs view
@@ -0,0 +1,59 @@+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)++rwD :: D a -> D a+rwD (FunDecl n bs e) = FunDecl n bs (rwE e); rwD d = d++rwE :: E a -> E a+rwE = cata a where+ a (EAppF l e0@(UB _ Tally) (EApp lϵ (EApp lϵϵ e1@BB{} e2) e3)) = EApp l (EApp lϵ e1 (EApp lϵϵ e0 e2)) e3+ a (EAppF l e0@(UB _ Const) (EApp lϵ (EApp lϵϵ e1@(BB _ Map) e2) e3)) = EApp l (EApp lϵ e1 (EApp lϵϵ e0 e2)) e3+ a (EAppF l e0@(EApp _ (BB _ Eq) _) (EApp l1 (EApp l2 e1@(BB _ And) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@(EApp _ (BB _ Eq) _) (EApp l1 (EApp l2 e1@(BB _ Or) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@(EApp _ (BB _ Neq) _) (EApp l1 (EApp l2 e1@(BB _ And) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@(EApp _ (BB _ Neq) _) (EApp l1 (EApp l2 e1@(BB _ Or) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@(EApp _ (BB _ Gt) _) (EApp l1 (EApp l2 e1@(BB _ And) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@(EApp _ (BB _ Gt) _) (EApp l1 (EApp l2 e1@(BB _ Or) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@(EApp _ (BB _ Lt) _) (EApp l1 (EApp l2 e1@(BB _ And) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@(EApp _ (BB _ Lt) _) (EApp l1 (EApp l2 e1@(BB _ Or) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@(EApp _ (BB _ Leq) _) (EApp l1 (EApp l2 e1@(BB _ And) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@(EApp _ (BB _ Leq) _) (EApp l1 (EApp l2 e1@(BB _ Or) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@(EApp _ (BB _ Geq) _) (EApp l1 (EApp l2 e1@(BB _ And) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@(EApp _ (BB _ Geq) _) (EApp l1 (EApp l2 e1@(BB _ Or) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@(EApp _ (BB _ Matches) _) (EApp l1 (EApp l2 e1@(BB _ And) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@(EApp _ (BB _ Matches) _) (EApp l1 (EApp l2 e1@(BB _ Or) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@(EApp _ (BB _ NotMatches) _) (EApp l1 (EApp l2 e1@(BB _ And) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@(EApp _ (BB _ NotMatches) _) (EApp l1 (EApp l2 e1@(BB _ Or) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@(EApp _ (BB _ Fold1) _) (EApp l1 (EApp l2 e1@(BB _ Eq) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@(EApp _ (BB _ Fold1) _) (EApp l1 (EApp l2 e1@(BB _ Neq) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@(EApp _ (BB _ Fold1) _) (EApp l1 (EApp l2 e1@(BB _ Gt) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@(EApp _ (BB _ Fold1) _) (EApp l1 (EApp l2 e1@(BB _ Geq) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@(EApp _ (BB _ Fold1) _) (EApp l1 (EApp l2 e1@(BB _ Leq) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@(EApp _ (BB _ Fold1) _) (EApp l1 (EApp l2 e1@(BB _ Lt) e2) e3)) = EApp l1 (EApp l2 e1 (EApp l e0 e2)) e3+ a (EAppF l e0@Var{} (EApp lϵ (EApp lϵϵ e1 e2) e3)) = EApp l (EApp lϵ (EApp lϵϵ e0 e1) e2) e3+ -- TODO rewrite dfn+ a (EAppF l e0@Var{} (EApp l0 e1 (EApp l1 (EApp l2 op@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 _ Max) (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2+ a (EAppF l e0@(BB _ Min) (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2+ a (EAppF l e0@(BB _ Split) (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2+ a (EAppF l e0@(BB _ Match) (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2+ a (EAppF l e0@(BB _ Splitc) (EApp lϵ e1 e2)) = EApp l (EApp lϵ e0 e1) e2+ a (EAppF l e0@(BB _ Sprintf) (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 _ 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 _ 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 x = embed x
+ src/R.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE OverloadedStrings #-}++module R ( rE+ , rP+ , RenameM+ , Renames (..)+ , HasRenames (..)+ ) where++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+import Lens.Micro (Lens', over)+import Lens.Micro.Mtl (modifying, use, (%=), (.=))+import Nm+import U++data Renames = Renames { max_ :: Int, bound :: IM.IntMap Int }++class HasRenames a where+ rename :: Lens' a Renames++instance HasRenames Renames where+ rename = id++boundLens :: Lens' Renames (IM.IntMap Int)+boundLens f s = fmap (\x -> s { bound = x }) (f (bound s))++maxLens :: Lens' Renames Int+maxLens f s = fmap (\x -> s { max_ = x }) (f (max_ s))++type RenameM = State Renames++rP :: Int -> Program a -> (Program a, Int)+rP i = runRM i . renameProgram++runRM :: Int -> RenameM x -> (x, Int)+runRM i act = second max_ (runState act (Renames i IM.empty))++replaceUnique :: (MonadState s m, HasRenames s) => U -> m U+replaceUnique u@(U i) = do+ rSt <- use (rename.boundLens)+ case IM.lookup i rSt of+ Nothing -> pure u+ Just j -> withRenames (over boundLens (IM.delete i)) $ replaceUnique (U j)++replaceVar :: (MonadState s m, HasRenames s) => Nm a -> m (Nm a)+replaceVar (Nm n u l) = do+ u' <- replaceUnique u+ pure $ Nm n u' l++dummyName :: (MonadState s m, HasRenames s) => a -> T.Text -> m (Nm a)+dummyName l n = do+ st <- use (rename.maxLens)+ Nm n (U$st+1) l+ <$ modifying (rename.maxLens) (+1)++withRenames :: (HasRenames s, MonadState s m) => (Renames -> Renames) -> m a -> m a+withRenames modSt act = do+ preSt <- use rename+ rename %= modSt+ res <- act+ postMax <- use (rename.maxLens)+ rename .= setMax postMax preSt+ pure res++withName :: (HasRenames s, MonadState s m) => Nm a -> m (Nm a, Renames -> Renames)+withName (Nm t (U i) l) = do+ m <- use (rename.maxLens)+ let newUniq = m+1+ rename.maxLens .= newUniq+ pure (Nm t (U newUniq) l, mapBound (IM.insert i (m+1)))++mapBound :: (IM.IntMap Int -> IM.IntMap Int) -> Renames -> Renames+mapBound f (Renames m b) = Renames m (f b)++setMax :: Int -> Renames -> Renames+setMax i (Renames _ b) = Renames i b++-- | Desguar top-level functions as lambdas+mkLam :: [Nm a] -> E a -> E a+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++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++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++renameD :: D a -> RenameM (D a)+renameD (FunDecl n ns e) = FunDecl n [] <$> rE (mkLam ns e)+renameD d = pure d++renameProgram :: Program a -> RenameM (Program a)+renameProgram (Program ds e) = Program <$> traverse renameD ds <*> rE e++{-# INLINABLE rE #-}+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 (Var l n) = Var l <$> replaceVar n+rE (Lam l n e) = do+ (n', modR) <- withName n+ Lam l n' <$> withRenames modR (rE e)+rE (Dfn l e) | {-# SCC "hasY" #-} hasY e = do+ x@(Nm nX uX _) <- dummyName l "x"+ y@(Nm nY uY _) <- dummyName l "y"+ Lam l x . Lam l y <$> rE ({-# SCC "replaceXY" #-} replaceXY (Nm nX uX) (Nm nY uY) e)+ | otherwise = do+ x@(Nm n u _) <- dummyName l "x"+ Lam l x <$> rE ({-# SCC "replaceX" #-} replaceX (Nm n u) e)+rE (Guarded l p e) = Guarded l <$> rE p <*> rE e+rE (Implicit l e) = Implicit l <$> rE e+rE ResVar{} = error "Bare reserved variable."+rE (Let l (n, eϵ) e') = do+ eϵ' <- rE eϵ+ (n', modR) <- withName n+ Let l (n', eϵ') <$> withRenames modR (rE e')+rE (Paren _ e) = rE e+rE (Arr l es) = Arr l <$> traverse rE es+rE (Anchor l es) = Anchor l <$> traverse rE es+rE (OptionVal l e) = OptionVal l <$> traverse rE e+rE (Cond l p e e') = Cond l <$> rE p <*> rE e <*> rE e'+rE e = pure e
+ src/Ty.hs view
@@ -0,0 +1,485 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module Ty ( Subst+ , runTyM+ , tyP+ , match+ , aT+ -- * For debugging+ , tyOf+ ) where++import A+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 Data.Bifunctor (first, second)+import Data.Foldable (traverse_)+import Data.Functor (void, ($>))+import qualified Data.IntMap as IM+import qualified Data.IntSet as IS+import Data.Semigroup ((<>))+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 Prettyprinter (Pretty (..), squotes, (<+>))+import Ty.Const+import U++data Err a = UF a T T+ | Doesn'tSatisfy a T C+ | IllScoped a (Nm a)+ | Ambiguous T (E ())+ | IllScopedTyVar (TyName ())+ | MF T T+ | Occ a T T++instance Pretty a => Pretty (Err a) where+ pretty (UF l ty ty') = pretty l <+> "could not unify type" <+> squotes (pretty ty) <+> "with" <+> squotes (pretty ty')+ pretty (Doesn'tSatisfy l ty c) = pretty l <+> squotes (pretty ty) <+> "is not a member of class" <+> pretty c+ pretty (IllScoped l n) = pretty l <+> squotes (pretty n) <+> "is not in scope."+ pretty (Ambiguous ty e) = "type" <+> squotes (pretty ty) <+> "of" <+> squotes (pretty e) <+> "is ambiguous"+ pretty (IllScopedTyVar n) = "Type variable" <+> squotes (pretty n) <+> "is not in scope."+ pretty (MF t t') = "Failed to match" <+> squotes (pretty t) <+> "against type" <+> squotes (pretty t')+ pretty (Occ l t t') = pretty l <+> "occurs check failed when unifying type" <+> squotes (pretty t) <+> "with type" <+> squotes (pretty t')++instance Pretty a => Show (Err a) where show=show.pretty++instance (Typeable a, Pretty a) => Exception (Err a) where++data TyState a = TyState { maxU :: !Int+ , classVars :: IM.IntMap (S.Set (C, a))+ , 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++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)++type TyM a = StateT (TyState a) (Either (Err a))++runTyM :: Int -> TyM a b -> Either (Err a) (b, Int)+runTyM i = fmap (second maxU) . flip runStateT (TyState i IM.empty IM.empty)++type Subst = IM.IntMap T++aT :: Subst -> T -> T+aT um ty'@(TyVar (Nm _ (U i) _)) =+ 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 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@TyVar{} -> aT (IM.delete i um) ty+ Just ty -> aT um ty+ Nothing -> Rho n (fmap (aT um) rs)+aT _ ty'@TyB{} = ty'+aT um (TyApp ty ty') = TyApp (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)++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'++match :: T -> T -> Subst+match t t' = either (throw :: Err () -> Subst) id (maM t t')++maM :: T -> T -> Either (Err l) Subst+maM (TyB b) (TyB b') | b == b' = Right mempty+maM (TyVar n) (TyVar n') | n == n' = Right mempty+maM (TyVar (Nm _ (U i) _)) t = Right (IM.singleton i t)+maM (TyArr t0 t1) (TyArr t0' t1') = (<>) <$> maM t0 t0' <*> maM t1' t1 -- TODO: I think <> is right+maM (TyTup ts) (TyTup ts') = fmap mconcat (zipWithM maM ts ts')+maM (Rho n _) (Rho n' _) | n == n' = Right mempty+maM (Rho n rs) t@(Rho _ rs') | IM.keysSet rs' `IS.isSubsetOf` IM.keysSet rs = IM.insert (unU$unique n) t . mconcat <$> traverse (uncurry maM) (IM.elems (IM.intersectionWith (,) rs rs'))+maM (Rho n rs) t@(TyTup ts) | length ts >= fst (IM.findMax rs) = IM.insert (unU$unique n) t . mconcat <$> traverse (uncurry maM) [ (ts!!(i-1),tϵ) | (i,tϵ) <- IM.toList rs ]+maM t t' = Left $ MF t t'++occ :: T -> IS.IntSet+occ (TyVar (Nm _ (U i) _)) = IS.singleton i+occ TyB{} = IS.empty+occ (TyTup ts) = foldMap occ ts+occ (TyApp 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))++mgu :: l -> Subst -> T -> T -> Either (Err l) Subst+mgu _ s (TyB b) (TyB b') | b == b' = Right s+mgu _ s (TyVar n) (TyVar n') | n == n' = Right s+mgu l s t t'@(TyVar (Nm _ (U k) _)) | k `IS.notMember` occ t = Right $ IM.insert k t s+ | otherwise = Left $ Occ l t' t+mgu l s t@(TyVar (Nm _ (U k) _)) t' | k `IS.notMember` occ t' = Right $ IM.insert k t' s+ | otherwise = Left $ Occ l t t'+mgu l s (TyArr t0 t1) (TyArr t0' t1') = do {s0 <- mguPrep l s t0 t0'; mguPrep l s0 t1 t1'}+mgu l s (TyApp t0 t1) (TyApp t0' t1') = do {s0 <- mguPrep l s t0 t0'; mguPrep l s0 t1 t1'}+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) = tS_ (\sϵ (i, tϵ) -> IM.insert (unU$unique n) t' <$> mguPrep l sϵ (ts!!(i-1)) tϵ) s (IM.toList rs)+mgu l s t@TyTup{} t'@Rho{} = mgu l s t' t+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 _ t t' = Left $ UF l t t'++tS_ :: Monad m => (Subst -> b -> m Subst) -> Subst -> [b] -> m Subst+tS_ _ s [] = pure s+tS_ f s (t:ts) = do {next <- f s t; tS_ f next ts}++zS _ s [] _ = pure s+zS _ s _ [] = pure s+zS op s (x:xs) (y:ys) = do {next <- op s x y; zS op next xs ys}++substInt :: IM.IntMap T -> Int -> Maybe T+substInt tys k =+ case IM.lookup k tys of+ Just ty'@TyVar{} -> Just $ aT (IM.delete k tys) ty'+ Just (TyApp ty0 ty1) -> Just $ let tys'=IM.delete k tys in TyApp (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 ty' -> Just ty'+ Nothing -> Nothing++freshName :: T.Text -> TyM a (Nm ())+freshName n = do+ st <- gets maxU+ Nm n (U $ st+1) ()+ <$ modify (mapMaxU (+1))++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+ go (Just cs) = S.insert c cs++tyArr :: T -> T -> T+tyArr = TyArr++var :: Nm () -> T+var = TyVar++liftCloneTy :: T -> TyM b T+liftCloneTy ty = do+ i <- gets maxU+ let (ty', (j, iMaps)) = cloneTy i ty+ -- FIXME: clone/propagate constraints+ ty' <$ modify (setMaxU j)++cloneTy :: Int -> T -> (T, (Int, IM.IntMap U))+cloneTy i ty = flip runState (i, IM.empty) $ cloneTyM ty+ where cloneTyM (TyVar (Nm n (U j) l')) = do+ 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))+ cloneTyM (TyArr tyϵ ty') = TyArr <$> cloneTyM tyϵ <*> cloneTyM ty'+ cloneTyM (TyApp tyϵ ty') = TyApp <$> cloneTyM tyϵ <*> cloneTyM ty'+ cloneTyM (TyTup tys) = TyTup <$> traverse cloneTyM tys+ cloneTyM tyϵ@TyB{} = pure tyϵ++checkType :: Ord a => T -> (C, a) -> TyM a ()+checkType TyVar{} _ = pure ()+checkType (TyB TyStr) (IsSemigroup, _) = pure ()+checkType (TyB TyInteger) (IsSemigroup, _) = pure ()+checkType (TyB TyFloat) (IsSemigroup, _) = pure ()+checkType (TyB TyInteger) (IsNum, _) = pure ()+checkType (TyB TyFloat) (IsNum, _) = pure ()+checkType (TyB TyInteger) (IsEq, _) = pure ()+checkType (TyB TyFloat) (IsEq, _) = pure ()+checkType (TyB TyBool) (IsEq, _) = pure ()+checkType (TyB TyStr) (IsEq, _) = pure ()+checkType (TyTup tys) (c@IsEq, l) = traverse_ (`checkType` (c, l)) tys+checkType (Rho _ rs) (c@IsEq, l) = traverse_ (`checkType` (c, l)) (IM.elems rs)+checkType (TyApp (TyB TyVec) ty) (c@IsEq, l) = checkType ty (c, l)+checkType (TyApp (TyB TyOption) ty) (c@IsEq, l) = checkType ty (c, l)+checkType (TyB TyInteger) (IsParse, _) = pure ()+checkType (TyB TyFloat) (IsParse, _) = pure ()+checkType (TyB TyFloat) (IsOrd, _) = pure ()+checkType (TyB TyInteger) (IsOrd, _) = pure ()+checkType (TyB TyStr) (IsOrd, _) = pure ()+checkType (TyB TyVec) (Functor, _) = pure ()+checkType (TyB TyStream) (Functor, _) = pure ()+checkType (TyB TyOption) (Functor, _) = pure ()+checkType (TyB TyStream) (Witherable, _) = pure ()+checkType (TyB TyVec) (Foldable, _) = pure ()+checkType (TyB TyStream) (Foldable, _) = pure ()+checkType (TyB TyStr) (IsPrintf, _) = pure ()+checkType (TyB TyFloat) (IsPrintf, _) = pure ()+checkType (TyB TyInteger) (IsPrintf, _) = pure ()+checkType (TyB TyBool) (IsPrintf, _) = pure ()+checkType (TyTup tys) (c@IsPrintf, l) = traverse_ (`checkType` (c, l)) tys+checkType (Rho _ rs) (c@IsPrintf, l) = traverse_ (`checkType` (c, l)) (IM.elems rs)+checkType ty (c, l) = throwError $ Doesn'tSatisfy l ty c++checkClass :: Ord a+ => IM.IntMap T -- ^ Unification result+ -> Int+ -> S.Set (C, a)+ -> TyM a ()+checkClass tys i cs = {-# SCC "checkClass" #-}+ case substInt tys i of+ Just ty -> traverse_ (checkType ty) (S.toList cs)+ Nothing -> pure ()++lookupVar :: Nm a -> TyM a T+lookupVar n@(Nm _ (U i) l) = do+ st <- gets varEnv+ case IM.lookup i st of+ Just ty -> pure ty -- liftCloneTy ty+ Nothing -> throwError $ IllScoped l n++tyOf :: Ord a => E a -> TyM a T+tyOf = fmap eLoc . tyE++tyDS :: Ord a => Subst -> D a -> TyM a (D T, Subst)+tyDS s (SetFS bs) = pure (SetFS bs, s)+tyDS s FlushDecl = pure (FlushDecl, s)+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')+tyDS _ FunDecl{} = error "Internal error. Should have been desugared by now."++isAmbiguous :: T -> Bool+isAmbiguous TyVar{} = True+isAmbiguous (TyArr ty ty') = isAmbiguous ty || isAmbiguous ty'+isAmbiguous (TyApp ty ty') = isAmbiguous ty || isAmbiguous ty'+isAmbiguous (TyTup tys) = any isAmbiguous tys+isAmbiguous TyB{} = False+isAmbiguous Rho{} = True++checkAmb :: E T -> TyM a ()+checkAmb e@(BB ty _) | isAmbiguous ty = throwError $ Ambiguous ty (void e)+checkAmb TB{} = pure () -- don't fail on ternary builtins, we don't need it anyway... better error messages+checkAmb e@(UB ty _) | isAmbiguous ty = throwError $ Ambiguous ty (void e)+checkAmb (Implicit _ e') = checkAmb e'+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 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]+checkAmb (Lam _ _ e) = checkAmb e -- I think+checkAmb _ = pure ()++tS _ s [] = pure ([], s)+tS f s (t:ts) = do {(x, next) <- f s t; first (x:) <$> tS f next ts}++tyP :: Ord a => Program a -> TyM a (Program T)+tyP (Program ds e) = do+ (ds', s0) <- tS tyDS mempty ds+ (e', s1) <- tyES s0 e+ toCheck <- gets (IM.toList . classVars)+ traverse_ (uncurry (checkClass s1)) toCheck+ let res = {-# SCC "aT" #-} fmap (aT s1) (Program ds' e')+ checkAmb (expr res) $> res++tyNumOp :: Ord a => a -> TyM a T+tyNumOp l = do+ m <- freshName "m"+ modify (mapCV (addC m (IsNum, l)))+ let m' = var m+ pure $ tyArr m' (tyArr m' m')++tySemiOp :: Ord a => a -> TyM a T+tySemiOp l = do+ m <- freshName "m"+ modify (mapCV (addC m (IsSemigroup, l)))+ let m' = var m+ pure $ tyArr m' (tyArr m' m')++tyOrd :: Ord a => a -> TyM a T+tyOrd l = do+ a <- freshName "a"+ modify (mapCV (addC a (IsOrd, l)))+ let a' = var a+ pure $ tyArr a' (tyArr a' tyB)++tyEq :: Ord a => a -> TyM a T+tyEq l = do+ a <- freshName "a"+ modify (mapCV (addC a (IsEq, l)))+ let a' = var a+ pure $ tyArr a' (tyArr a' tyB)++-- min/max+tyM :: Ord a => a -> TyM a T+tyM l = do+ a <- freshName "a"+ modify (mapCV (addC a (IsOrd, l)))+ let a' = var a+ pure $ tyArr a' (tyArr a' a')++desugar :: a+desugar = error "Should have been de-sugared in an earlier stage!"++tyE :: Ord a => E a -> TyM a (E T)+tyE e = do+ (e', s) <- tyES mempty e+ cvs <- gets (IM.toList . classVars)+ traverse_ (uncurry (checkClass s)) cvs+ pure (fmap (aT s) e')++tyES :: Ord a => Subst -> E a -> TyM a (E T, Subst)+tyES s (BLit _ b) = pure (BLit tyB b, s)+tyES s (ILit _ i) = pure (ILit tyI i, s)+tyES s (FLit _ f) = pure (FLit tyF f, s)+tyES s (StrLit _ str) = pure (StrLit tyStr str, s)+tyES s (RegexLit _ rr) = pure (RegexLit tyR rr, s)+tyES s (Column _ i) = pure (Column (tyStream tyStr) i, s)+tyES s (IParseCol _ i) = pure (IParseCol (tyStream tyI) i, s)+tyES s (FParseCol _ i) = pure (FParseCol (tyStream tyF) i, s)+tyES s (Field _ i) = pure (Field tyStr i, s)+tyES s LastField{} = pure (LastField tyStr, s)+tyES s AllField{} = pure (AllField tyStr, s)+tyES s AllColumn{} = pure (AllColumn (tyStream tyStr), 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)+tyES s (BB l Plus) = do {t <- tySemiOp l; pure (BB t Plus, s)}+tyES s (BB l Minus) = do {t <- tyNumOp l; pure (BB t Minus, s)}+tyES s (BB l Times) = do {t <- tyNumOp l; pure (BB t Times, s)}+tyES s (BB l Exp) = do {t <- tyNumOp l; pure (BB t Exp, s)}+tyES s (BB l Gt) = do {t <- tyOrd l; pure (BB t Gt, s)}+tyES s (BB l Lt) = do {t <- tyOrd l; pure (BB t Lt, s)}+tyES s (BB l Geq) = do {t <- tyOrd l; pure (BB t Geq, s)}+tyES s (BB l Leq) = do {t <- tyOrd l; pure (BB t Leq, s)}+tyES s (BB l Eq) = do {t <- tyEq l; pure (BB t Eq, s)}+tyES s (BB l Neq) = do {t <- tyEq l; pure (BB t Neq, s)}+tyES s (BB l Min) = do {t <- tyM l; pure (BB t Min, s)}+tyES s (BB l Max) = do {t <- tyM l; pure (BB t Max, s)}+tyES s (BB _ Split) = pure (BB (tyArr tyStr (tyArr tyR (tyV tyStr))) Split, s)+tyES s (BB _ Splitc) = pure (BB (tyArr tyStr (tyArr tyStr (tyV tyStr))) Splitc, s)+tyES s (BB _ Matches) = pure (BB (tyArr tyStr (tyArr tyR tyB)) Matches, s)+tyES s (BB _ NotMatches) = pure (BB (tyArr tyStr (tyArr tyR tyB)) NotMatches, s)+tyES s (UB _ Tally) = pure (UB (tyArr tyStr tyI) Tally, s)+tyES s (BB _ Div) = pure (BB (tyArr tyF (tyArr tyF tyF)) Div, s)+tyES s (UB _ Not) = pure (UB (tyArr tyB tyB) Not, s)+tyES s (BB _ And) = pure (BB (tyArr tyB (tyArr tyB tyB)) And, s)+tyES s (BB _ Or) = pure (BB (tyArr tyB (tyArr tyB tyB)) Or, s)+tyES s (BB _ Match) = pure (BB (tyArr tyStr (tyArr tyR (tyOpt $ TyTup [tyI, tyI]))) Match, s)+tyES s (TB _ Substr) = pure (TB (tyArr tyStr (tyArr tyI (tyArr tyI tyStr))) Substr, s)+tyES s (UB _ IParse) = pure (UB (tyArr tyStr tyI) IParse, s)+tyES s (UB _ FParse) = pure (UB (tyArr tyStr tyF) FParse, s)+tyES s (UB _ Floor) = pure (UB (tyArr tyF tyI) Floor, s)+tyES s (UB _ Ceiling) = pure (UB (tyArr tyF tyI) Ceiling, s)+tyES s (UB _ TallyList) = do {a <- var <$> freshName "a"; pure (UB (tyArr a tyI) TallyList, s)}+tyES s (UB l Negate) = do {a <- freshName "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 <$> freshName "a"; pure (UB (tyArr a (tyOpt a)) Some, s)}+tyES s (NB _ None) = do {a <- freshName "a"; pure (NB (tyOpt (var a)) None, s)}+tyES s (ParseCol l i) = do {a <- freshName "a"; modify (mapCV (addC a (IsParse, l))); pure (ParseCol (tyStream (var a)) i, s)}+tyES s (UB l Parse) = do {a <- freshName "a"; modify (mapCV (addC a (IsParse, l))); pure (UB (tyArr tyStr (var a)) Parse, s)}+tyES s (BB l Sprintf) = do {a <- freshName "a"; modify (mapCV (addC a (IsPrintf, l))); pure (BB (tyArr tyStr (tyArr (var a) tyStr)) Sprintf, s)}+tyES s (BB l DedupOn) = do {a <- var <$> freshName "a"; b <- freshName "b"; modify (mapCV (addC b (IsEq, l))); let b'=var b in pure (BB (tyArr (tyArr a b') (tyArr (tyStream a) (tyStream b'))) DedupOn, s)}+tyES s (UB _ (At i)) = do {a <- var <$> freshName "a"; pure (UB (tyArr (tyV a) a) (At i), s)}+tyES s (UB l Dedup) = do {a <- freshName "a"; modify (mapCV (addC a (IsEq, l))); let sA=tyStream (var a) in pure (UB (tyArr sA sA) Dedup, s)}+tyES s (UB _ Const) = do {a <- var <$> freshName "a"; b <- var <$> freshName "b"; pure (UB (tyArr a (tyArr b a)) Const, s)}+tyES s (UB l CatMaybes) = do {a <- freshName "a"; f <- freshName "f"; modify (mapCV (addC f (Witherable, l))); let a'=var a; f'=var f in pure (UB (tyArr (TyApp f' (tyOpt a')) (TyApp f' a')) CatMaybes, s)}+tyES s (BB l Filter) = do {a <- freshName "a"; f <- freshName "f"; modify (mapCV (addC f (Witherable, l))); let a'=var a; f'=var f; w=TyApp f' a' in pure (BB (tyArr (tyArr a' tyB) (tyArr w w)) Filter, s)}+tyES s (UB _ (Select i)) = do+ ρ <- freshName "ρ"; a <- var <$> freshName "a"+ pure (UB (tyArr (Rho ρ (IM.singleton i a)) a) (Select i), s)+tyES s (BB l MapMaybe) = do+ a <- var <$> freshName "a"; b <- var <$> freshName "b"+ f <- freshName "f"+ modify (mapCV (addC f (Witherable, l)))+ let f'=var f+ pure (BB (tyArr (tyArr a (tyOpt b)) (tyArr (TyApp f' a) (TyApp f' b))) MapMaybe, s)+tyES s (BB l Map) = do+ a <- var <$> freshName "a"; b <- var <$> freshName "b"+ f <- freshName "f"+ let f'=var f+ modify (mapCV (addC f (Functor, l)))+ pure (BB (tyArr (tyArr a b) (tyArr (TyApp f' a) (TyApp f' b))) Map, s)+tyES s (TB l Fold) = do+ a <- var <$> freshName "a"; b <- var <$> freshName "b"+ f <- freshName "f"+ let f'=var f+ modify (mapCV (addC f (Foldable, l)))+ pure (TB (tyArr (tyArr b (tyArr a b)) (tyArr b (tyArr (TyApp f' a) b))) Fold, s)+tyES s (BB l Fold1) = do+ a <- var <$> freshName "a"+ f <- freshName "f"+ let f'=var f+ modify (mapCV (addC f (Foldable, l)))+ pure (BB (tyArr (tyArr a (tyArr a a)) (tyArr (TyApp f' a) a)) Fold1, s)+tyES s (TB _ Captures) = pure (TB (tyArr tyStr (tyArr tyI (tyArr tyR (tyOpt tyStr)))) Captures, s)+tyES s (BB _ Prior) = do+ a <- var <$> freshName "a"; b <- var <$> freshName "b"+ pure (BB (tyArr (tyArr a (tyArr a b)) (tyArr (tyStream a) (tyStream b))) Prior, s)+tyES s (TB _ ZipW) = do+ a <- var <$> freshName "a"; b <- var <$> freshName "b"; c <- var <$> freshName "c"+ pure (TB (tyArr (tyArr a (tyArr b c)) (tyArr (tyStream a) (tyArr (tyStream b) (tyStream c)))) ZipW, s)+tyES s (TB _ Scan) = do+ a <- var <$> freshName "a"; b <- var <$> freshName "b"+ pure (TB (tyArr (tyArr b (tyArr a b)) (tyArr b (tyArr (tyStream a) (tyStream b)))) Scan, s)+tyES s (TB _ Option) = do+ a <- var <$> freshName "a"; b <- var <$> freshName "b"+ pure (TB (tyArr b (tyArr (tyArr a b) (tyArr (tyOpt a) b))) Option, s)+tyES s (TB _ AllCaptures) = pure (TB (tyArr tyStr (tyArr tyI (tyArr tyR (tyV tyStr)))) AllCaptures, s)+tyES s (Implicit _ e) = do {(e',s') <- tyES s e; pure (Implicit (tyStream (eLoc e')) e', s')}+tyES s (Guarded l e se) = do+ (se', s0) <- tyES s se+ (e', s1) <- tyES s0 e+ s2 <- liftEither $ mguPrep l s1 tyB (eLoc e')+ pure (Guarded (tyStream (eLoc se')) e' se', s2)+tyES s (EApp l e0 e1) = do+ a <- freshName "a"; b <- freshName "b"+ let a'=var a; b'=var b; e0Ty=tyArr a' b'+ (e0', s0) <- tyES s e0+ (e1', s1) <- tyES s0 e1+ s2 <- liftEither $ mguPrep l s1 (eLoc e0') e0Ty+ 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 <$> freshName "a"+ modify (addVarEnv i a)+ (e', s') <- tyES s e+ pure (Lam (tyArr 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)+ (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 (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 <$> freshName "a"; pure (OptionVal (tyOpt a) Nothing, s)}+tyES s (Arr l v) | V.null v = do+ a <- var <$> freshName "a"+ pure (Arr (tyV a) V.empty, s)+ | otherwise = do+ (v',s0) <- tS tyES s (V.toList v)+ let vt=fmap eLoc v'+ s1 <- liftEither $ zS (mguPrep l) s0 vt (tail vt)+ pure (Arr (head vt) (V.fromList v'), s1)+tyES s (Cond l p e0 e1) = do+ (p', s0) <- tyES s p+ (e0', s1) <- tyES s0 e0+ (e1', s2) <- tyES s1 e1+ let t=eLoc e0'+ s3 <- liftEither $ mguPrep l s2 tyB (eLoc p')+ 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 <$> freshName "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
@@ -0,0 +1,18 @@+module Ty.Const ( tyStream, tyOpt, tyV+ , tyStr, tyR, tyI, tyF, tyB+ ) where++import A++-- | argument assumed to have kind 'Star'+tyStream :: T -> T+tyStream = TyApp (TyB TyStream)++tyB, tyI, tyF, tyStr, tyR :: T+tyB=TyB TyBool; tyI=TyB TyInteger; tyF=TyB TyFloat; tyStr=TyB TyStr; tyR=TyB TyR++tyOpt :: T -> T+tyOpt = TyApp (TyB TyOption)++tyV :: T -> T+tyV = TyApp (TyB TyVec)
+ src/U.hs view
@@ -0,0 +1,3 @@+module U ( U (..) ) where++newtype U = U { unU :: Int } deriving (Eq, Ord)
test/Spec.hs view
@@ -2,19 +2,20 @@ module Main (main) where -import Control.Monad ((<=<))-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BSL-import Data.Foldable (toList)-import Data.Functor (void)-import Jacinda.AST-import Jacinda.File-import Jacinda.Parser-import Jacinda.Parser.Rewrite+import A+import Control.Monad ((<=<))+import qualified Data.ByteString as BS+import Data.Foldable (toList)+import Data.Functor (void)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import File import Jacinda.Regex-import Jacinda.Ty.Const+import Parser+import Parser.Rw import Test.Tasty import Test.Tasty.HUnit+import Ty.Const main :: IO () main = defaultMain $@@ -30,14 +31,14 @@ , splitWhitespaceT " 55 ./src/Jacinda/File.hs" ["55", "./src/Jacinda/File.hs"] , splitWhitespaceT "" [] , splitWhitespaceT "5" ["5"]- , testCase "type of" (tyOfT sumBytes (TyB Star TyInteger))- , testCase "type of" (tyOfT krakRegex (TyApp Star (TyB (KArr Star Star) TyStream) (TyB Star TyStr))) -- stream of str- , testCase "type of" (tyOfT krakCol (TyApp Star (TyB (KArr Star Star) TyStream) (TyB Star TyStr))) -- stream of str+ , testCase "type of" (tyOfT sumBytes (TyB TyInteger))+ , testCase "type of" (tyOfT krakRegex (TyApp (TyB TyStream) (TyB TyStr))) -- stream of str+ , testCase "type of" (tyOfT krakCol (TyApp (TyB TyStream) (TyB TyStr))) -- stream of str , testCase "type of (zip)" (tyOfT ",(-) $3:i $6:i" (tyStream tyI)) , testCase "type of (filter)" (tyOfT "(>110) #. #\"$0" (tyStream tyI)) , testCase "typechecks dfn" (tyOfT "[(+)|0 x] $1:i" tyI)- , testCase "count bytes" (tyOfT "(+)|0 #\"$0" tyI)- , testCase "running count (lines)" (tyOfT "(+)^0 [:1\"$0" (tyStream tyI))+ , testCase "count bytes" (tyOfT "(+)|0 #¨$0" tyI)+ , testCase "running count (lines)" (tyOfT "(+)^0 [:1¨$0" (tyStream tyI)) , testCase "type of (tally)" (tyOfT "#'hello world'" tyI) , testCase "typechecks dfn" (tyFile "test/examples/ab.jac") , testCase "parses parens" (tyFile "examples/lib.jac")@@ -48,7 +49,7 @@ , testCase "if...then...else" (evalTo "if #t then 0 else 1" "0") ] -evalTo :: BSL.ByteString -> String -> Assertion+evalTo :: T.Text -> String -> Assertion evalTo bsl expected = let actual = show (exprEval bsl) in actual @?= expected@@ -57,11 +58,11 @@ pAst = EApp () (EApp ()- (BBuiltin () Gt)+ (BB () Gt) (EApp ()- (UBuiltin () Tally)+ (UB () Tally) (AllField ())))- (IntLit () 72)+ (ILit () 72) splitWhitespaceT :: BS.ByteString -> [BS.ByteString] -> TestTree splitWhitespaceT haystack expected =@@ -69,13 +70,13 @@ toList (splitBy defaultRurePtr haystack) @?= expected -- example: ls -l | ja '(+)|0 $5:i'-sumBytes :: BSL.ByteString+sumBytes :: T.Text sumBytes = "(+)|0 $5:i" -krakRegex :: BSL.ByteString+krakRegex :: T.Text krakRegex = "{% /Krakatoa/}{`0}" -krakCol :: BSL.ByteString+krakCol :: T.Text krakCol = "{`3:i > 4}{`0}" sumBytesAST :: E ()@@ -83,28 +84,28 @@ EApp () (EApp () (EApp ()- (TBuiltin () Fold)- (BBuiltin () Plus))- (IntLit () 0))+ (TB () Fold)+ (BB () Plus))+ (ILit () 0)) (IParseCol () 5) tyFile :: FilePath -> Assertion-tyFile = tcIO [] <=< BSL.readFile+tyFile = tcIO [] <=< TIO.readFile -tyOfT :: BSL.ByteString -> T K -> Assertion+tyOfT :: T.Text -> T -> Assertion tyOfT src expected = tySrc src @?= expected -parseTo :: BSL.ByteString -> E () -> Assertion+parseTo :: T.Text -> E () -> Assertion parseTo src e =- case rewriteProgram . snd <$> parse src of+ case rwP . snd <$> parse src of Left err -> assertFailure (show err) Right actual -> void (expr actual) @?= e parseFile :: FilePath -> TestTree-parseFile fp = testCase ("Parses " ++ fp) $ parseNoErr =<< BSL.readFile fp+parseFile fp = testCase ("Parses " ++ fp) $ parseNoErr =<< TIO.readFile fp -parseNoErr :: BSL.ByteString -> Assertion+parseNoErr :: T.Text -> Assertion parseNoErr src = case parse src of Left err -> assertFailure (show err)
test/examples/evenOdd.jac view
@@ -7,14 +7,11 @@ fn isOdd() := (~ /(1|3|5|7|9)$/); -fn divTen() :=- (~/0$/);- let val iStream := $0 val even := count (isEven #. iStream) val odd := count (isOdd #. iStream)- val tens := count (divTen #. iStream)- {. FIXME: if different lengths, all fucked (and... wrong :(+ val tens := (+)|> {%/0$/}{1}+ {. val tens := count {%/0$/}{`0} val total := odd + even-in (total . odd . even) end+in (total . even . odd . tens) end
+ test/examples/polymorphic.jac view
@@ -0,0 +1,2 @@+let val sum := [(+)|0 x]+ in sum {|sum (let val l := splitc `0 ' ' in l:i end)} end
+ test/examples/sillyPragmas.jac view
@@ -0,0 +1,2 @@+{. run ja run test/examples/sillyPragmas.jac -i src/A.hs+[x+', '+y]|'' .?{|`0 ~* 1 /\{-#\s*LANGUAGE\s*([^\s]*)\s*#-\}/}
+ test/examples/sillyPragmas2.jac view
@@ -0,0 +1,1 @@+[x+', '+y]|'' [x ~* 1 /\{-#\s*LANGUAGE\s*([^\s]*)\s*#-\}/]:?$0