diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,3 @@
+# 0.1.0.0
+
+* Initial release
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,14 @@
+Copyright (C) 2021-2022 Vanessa McHale
+
+This program is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program. If not, see .
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,73 @@
+Jacinda is a functional, expression-oriented data processing language,
+complementing [AWK](http://www.awklang.org).
+
+# Installation
+
+## From Source
+
+First, install [Rust's regex library](https://github.com/rust-lang/regex/tree/master/regex-capi#c-api-for-rusts-regex-engine).
+
+If you have [cabal](https://www.haskell.org/cabal/) and [GHC](https://www.haskell.org/ghc/) installed (perhaps via [ghcup](https://www.haskell.org/ghcup/)):
+
+```
+cabal install jacinda
+```
+
+# Documentation
+
+The manpages document the builtins and provide a syntax reference.
+
+# SHOCK & AWE
+
+```
+ls -l | ja '(+)|0 {ix>1}{`5:i}'
+```
+
+```
+curl -sL https://raw.githubusercontent.com/nychealth/coronavirus-data/master/latest/now-weekly-breakthrough.csv | \
+ ja ',[1.0-x%y] {ix>1}{`5:f} {ix>1}{`11:f}' -F,
+```
+
+# Further Advantages
+
+ * [Rust's regular expressions](https://docs.rs/regex/)
+ - extensively documented with Unicode support
+
+# PERFORMANCE
+
+## Linux + x64
+
+```
+benchmarking bench/ja '(+)|0 {%/Bloom/}{1}' -i /tmp/ulysses.txt
+time 8.110 ms (7.926 ms .. 8.304 ms)
+ 0.996 R² (0.993 R² .. 0.998 R²)
+mean 8.470 ms (8.278 ms .. 8.771 ms)
+std dev 693.0 μs (437.4 μs .. 1.008 ms)
+variance introduced by outliers: 47% (moderately inflated)
+
+benchmarking bench/original-awk '/Bloom/ { total += 1; } END { print total }' /tmp/ulysses.txt
+time 13.24 ms (13.04 ms .. 13.39 ms)
+ 0.999 R² (0.998 R² .. 1.000 R²)
+mean 13.39 ms (13.29 ms .. 13.49 ms)
+std dev 256.0 μs (197.8 μs .. 380.7 μs)
+
+benchmarking bench/gawk '/Bloom/ { total += 1; } END { print total }' /tmp/ulysses.txt
+time 7.804 ms (7.706 ms .. 7.931 ms)
+ 0.996 R² (0.991 R² .. 0.999 R²)
+mean 7.668 ms (7.572 ms .. 7.783 ms)
+std dev 303.4 μs (229.7 μs .. 442.5 μs)
+variance introduced by outliers: 17% (moderately inflated)
+
+benchmarking bench/mawk '/Bloom/ { total += 1; } END { print total }' /tmp/ulysses.txt
+time 3.179 ms (3.099 ms .. 3.240 ms)
+ 0.997 R² (0.995 R² .. 0.998 R²)
+mean 3.213 ms (3.178 ms .. 3.270 ms)
+std dev 148.9 μs (97.11 μs .. 267.6 μs)
+variance introduced by outliers: 29% (moderately inflated)
+
+benchmarking bench/busybox awk '/Bloom/ { total += 1; } END { print total }' /tmp/ulysses.txt
+time 12.61 ms (12.43 ms .. 12.77 ms)
+ 0.999 R² (0.998 R² .. 1.000 R²)
+mean 12.98 ms (12.86 ms .. 13.09 ms)
+std dev 303.1 μs (234.5 μs .. 396.2 μs)
+```
diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
--- /dev/null
+++ b/app/Main.hs
@@ -0,0 +1,72 @@
+module Main (main) where
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BSL
+import qualified Data.Version as V
+import Jacinda.File
+import Options.Applicative
+import qualified Paths_jacinda as P
+import System.IO (stdin)
+
+data Command = TypeCheck !FilePath
+ | Run !FilePath !(Maybe FilePath)
+ | Expr !BSL.ByteString !(Maybe FilePath) !(Maybe BS.ByteString)
+ | Eval !BSL.ByteString
+
+jacFile :: Parser FilePath
+jacFile = argument str
+ (metavar "JACFILE"
+ <> help "Source code"
+ <> jacCompletions)
+
+jacFs :: Parser (Maybe BS.ByteString)
+jacFs = optional $ option str
+ (short 'F'
+ <> metavar "REGEXP"
+ <> help "Field separator")
+
+jacExpr :: Parser BSL.ByteString
+jacExpr = argument str
+ (metavar "EXPR"
+ <> help "Jacinda expression")
+
+inpFile :: Parser (Maybe FilePath)
+inpFile = optional $ option str
+ (short 'i'
+ <> metavar "DATAFILE"
+ <> help "Data file")
+
+jacCompletions :: HasCompleter f => Mod f a
+jacCompletions = completer . bashCompleter $ "file -X '!*.jac' -o plusdirs"
+
+commandP :: Parser Command
+commandP = hsubparser
+ (command "tc" (info tcP (progDesc "Type-check file"))
+ <> command "e" (info eP (progDesc "Evaluate an expression (no file context)"))
+ <> command "run" (info runP (progDesc "Run from file")))
+ <|> exprP
+ where
+ tcP = TypeCheck <$> jacFile
+ runP = Run <$> jacFile <*> inpFile
+ exprP = Expr <$> jacExpr <*> inpFile <*> jacFs
+ eP = Eval <$> jacExpr
+
+wrapper :: ParserInfo Command
+wrapper = info (helper <*> versionMod <*> commandP)
+ (fullDesc
+ <> progDesc "Jacinda language for functional stream processing, filtering, and reports"
+ <> header "Jacinda - a functional complement to AWK")
+
+versionMod :: Parser (a -> a)
+versionMod = infoOption (V.showVersion P.version) (short 'V' <> long "version" <> help "Show version")
+
+main :: IO ()
+main = run =<< execParser wrapper
+
+run :: Command -> IO ()
+run (TypeCheck fp) = tcIO =<< BSL.readFile fp
+run (Run fp Nothing) = do { contents <- BSL.readFile fp ; runOnHandle contents Nothing stdin }
+run (Run fp (Just dat)) = do { contents <- BSL.readFile fp ; runOnFile contents Nothing dat }
+run (Expr eb Nothing fs) = runOnHandle eb fs stdin
+run (Expr eb (Just fp) fs) = runOnFile eb fs fp
+run (Eval e) = print (exprEval e)
diff --git a/jacinda.cabal b/jacinda.cabal
new file mode 100644
--- /dev/null
+++ b/jacinda.cabal
@@ -0,0 +1,129 @@
+cabal-version: 2.0
+name: jacinda
+version: 0.1.0.0
+license: GPL-3
+license-file: LICENSE
+maintainer: vamchale@gmail.com
+author: Vanessa McHale
+bug-reports: https://github.com/vmchale/jacinda/issues
+synopsis: Functional, expression-oriented data processing language
+description:
+ APL meets AWK. A command-line tool for summarizing and reporting, powered by Rust's [regex](https://docs.rs/regex/regex/) library.
+
+category: Language, Interpreters, Text, Data
+build-type: Simple
+extra-source-files:
+ CHANGELOG.md
+ README.md
+ man/ja.1
+
+source-repository head
+ type: git
+ location: https://github.com/vmchale/jacinda
+
+library jacinda-lib
+ exposed-modules:
+ Jacinda.Parser
+ Jacinda.Parser.Rewrite
+ Jacinda.AST
+ Jacinda.Ty
+ Jacinda.Ty.Const
+ Jacinda.Regex
+ Jacinda.File
+ Jacinda.Rename
+ Jacinda.Backend.TreeWalk
+
+ build-tool-depends: alex:alex, happy:happy
+ hs-source-dirs: src
+ other-modules:
+ Jacinda.Lexer
+ Intern.Name
+ Intern.Unique
+ Jacinda.Backend.Normalize
+ Jacinda.Backend.Printf
+ Data.List.Ext
+
+ default-language: Haskell2010
+ ghc-options: -Wall
+ build-depends:
+ base >=4.10.0.0 && <5,
+ bytestring >=0.11.0.0,
+ text,
+ prettyprinter >=1.7.0,
+ containers,
+ array,
+ mtl,
+ transformers,
+ regex-rure,
+ microlens,
+ microlens-mtl,
+ vector,
+ recursion >=1.0.0.0
+
+ if impl(ghc >=8.0)
+ ghc-options:
+ -Wincomplete-uni-patterns -Wincomplete-record-updates
+ -Wredundant-constraints -Widentities
+
+ if impl(ghc >=8.4)
+ ghc-options: -Wmissing-export-lists
+
+ if impl(ghc >=8.2)
+ ghc-options: -Wcpp-undef
+
+ if impl(ghc >=8.10)
+ ghc-options: -Wunused-packages
+
+executable ja
+ main-is: Main.hs
+ hs-source-dirs: app
+ other-modules: Paths_jacinda
+ autogen-modules: Paths_jacinda
+ default-language: Haskell2010
+ ghc-options: -Wall -rtsopts -with-rtsopts=-A100k
+ build-depends:
+ base,
+ jacinda-lib,
+ optparse-applicative,
+ bytestring
+
+ if impl(ghc >=8.0)
+ ghc-options:
+ -Wincomplete-uni-patterns -Wincomplete-record-updates
+ -Wredundant-constraints -Widentities
+
+ if impl(ghc >=8.4)
+ ghc-options: -Wmissing-export-lists
+
+ if impl(ghc >=8.2)
+ ghc-options: -Wcpp-undef
+
+ if impl(ghc >=8.10)
+ ghc-options: -Wunused-packages
+
+test-suite jacinda-test
+ type: exitcode-stdio-1.0
+ main-is: Spec.hs
+ hs-source-dirs: test
+ default-language: Haskell2010
+ ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N -K1K" -Wall
+ build-depends:
+ base,
+ jacinda-lib,
+ tasty,
+ tasty-hunit,
+ bytestring
+
+ if impl(ghc >=8.0)
+ ghc-options:
+ -Wincomplete-uni-patterns -Wincomplete-record-updates
+ -Wredundant-constraints -Widentities
+
+ if impl(ghc >=8.4)
+ ghc-options: -Wmissing-export-lists
+
+ if impl(ghc >=8.2)
+ ghc-options: -Wcpp-undef
+
+ if impl(ghc >=8.10)
+ ghc-options: -Wunused-packages
diff --git a/man/ja.1 b/man/ja.1
new file mode 100644
--- /dev/null
+++ b/man/ja.1
@@ -0,0 +1,122 @@
+.\" Automatically generated by Pandoc 2.16.2
+.\"
+.TH "ja (1)" "" "" "" ""
+.hy
+.SH NAME
+.PP
+ja - Jacinda: data filtering, processing, reporting
+.SH SYNOPSIS
+.PP
+ja run src.jac -i data.txt
+.PP
+cat FILE1 FILE2 | ja `#\[lq]$0'
+.PP
+ja tc script.jac
+.PP
+ja e `11.67*1.2'
+.SH DESCRIPTION
+.PP
+\f[B]Jacinda\f[R] is a data stream processing language \[`a] la AWK.
+.SH SUBCOMMANDS
+.PP
+\f[B]run\f[R] - Run a program from file
+.PP
+\f[B]tc\f[R] - Typecheck a program
+.PP
+\f[B]e\f[R] - Evaluate an expression (without reference to a file)
+.SH OPTIONS
+.TP
+\f[B]-h\f[R] \f[B]--help\f[R]
+Display help
+.TP
+\f[B]-V\f[R] \f[B]--version\f[R]
+Display version information
+.SH LANGUAGE
+.SS REGEX
+.PP
+Regular expressions follow Rust\[cq]s regex library:
+https://docs.rs/regex/
+.SS BUILTINS
+.PP
+\f[B]:i\f[R] Postfix operator: parse integer
+.PP
+\f[B]:f\f[R] Postfix operator: parse float
+.PP
+\f[B]#\f[R] Prefix operator: tally (count bytes in string)
+.TP
+\f[B],\f[R] Ternary operator: zip with
+(a -> b -> c) -> Stream a -> Stream b -> Stream c
+.TP
+\f[B]|\f[R] Ternary operator: fold
+(b -> a -> b) -> b -> Stream a -> b
+.TP
+\f[B]\[ha]\f[R] Ternary operator: scan
+(b -> a -> b) -> b -> Stream a -> Stream b
+.TP
+\f[B]\[lq]\f[R] Binary operator: map
+a -> b -> Stream a -> Stream b
+.TP
+\f[B][:\f[R] Unary operator: const
+a -> b -> a
+.TP
+\f[B]#.\f[R] Binary operator: filter
+(a -> Bool) -> Stream a -> Stream a
+.PP
+\f[B]max\f[R] Maximum of two values
+.PP
+\f[B]min\f[R] Minimum of two values
+.PP
+\f[B]&\f[R] Boolean and
+.PP
+\f[B]||\f[R] Boolean or
+.PP
+\f[B]!\f[R] Prefix boolean not
+.PP
+\f[B]\[ti]\f[R] Matches regex
+.PP
+\f[B]!\[ti]\f[R] Does not match
+.PP
+\f[B]ix\f[R] Line number
+.TP
+\f[B]substr\f[R] Extract substring
+Str -> Int -> Int -> Str
+.TP
+\f[B]split\f[R] Split a string by regex
+Str -> Regex -> List Str
+.TP
+\f[B]floor\f[R] Floor function
+Float -> Int
+.TP
+\f[B]ceil\f[R] Ceiling function
+Float -> Int
+.PP
+\f[B]sprintf\f[R] Convert an expression to a string using the format
+string
+.SS SYNTAX
+.PP
+\f[B]\[ga]n\f[R] nth field
+.PP
+\f[B]$n\f[R] nth column
+.PP
+\f[B]{%}{}\f[R] Filtered stream on lines matching
+, defined by
+.PP
+\f[B]{}{}\f[R] Filtered stream defined by , on lines
+satisfying a boolean expression.
+.PP
+\f[B]{|}\f[R] Stream defined by
+.PP
+\f[B]#t\f[R] Boolean literal
+.PP
+\f[B]_n\f[R] Negative number
+.SH BUGS
+.PP
+Please report any bugs you may come across to
+https://github.com/vmchale/jacinda/issues
+.SH COPYRIGHT
+.PP
+Copyright 2021-2022.
+Vanessa McHale.
+All Rights Reserved.
+.SH AUTHORS
+Vanessa McHale.
diff --git a/src/Data/List/Ext.hs b/src/Data/List/Ext.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/List/Ext.hs
@@ -0,0 +1,13 @@
+module Data.List.Ext ( imap
+ , ifilter
+ , prior
+ ) where
+
+prior :: (a -> a -> a) -> [a] -> [a]
+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] -> [a]
+ifilter p xs = snd <$> filter (uncurry p) (zip [1..] xs)
diff --git a/src/Intern/Name.hs b/src/Intern/Name.hs
new file mode 100644
--- /dev/null
+++ b/src/Intern/Name.hs
@@ -0,0 +1,30 @@
+{-# 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
diff --git a/src/Intern/Unique.hs b/src/Intern/Unique.hs
new file mode 100644
--- /dev/null
+++ b/src/Intern/Unique.hs
@@ -0,0 +1,5 @@
+module Intern.Unique ( Unique (..)
+ ) where
+
+newtype Unique = Unique { unUnique :: Int }
+ deriving (Eq, Ord)
diff --git a/src/Jacinda/AST.hs b/src/Jacinda/AST.hs
new file mode 100644
--- /dev/null
+++ b/src/Jacinda/AST.hs
@@ -0,0 +1,365 @@
+{-# 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 (..)
+ , 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, encloseSep, flatAlt, group, parens, (<+>))
+import Regex.Rure (RurePtr)
+
+-- kind
+data K = Star
+ | KArr K K
+ deriving (Eq, Ord)
+
+data TB = TyInteger
+ | TyFloat
+ | TyDate
+ | TyStr
+ | TyStream
+ | TyVec
+ | TyBool
+ | TyOptional
+ -- TODO: tyRegex
+ -- 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 TyOptional = "Optional"
+
+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
+
+instance Show (T a) where
+ show = show . pretty
+
+-- unary
+data BUn = Tally -- length of string field
+ | Const
+ | Not -- ^ Boolean
+ | At Int
+ | IParse
+ | FParse
+ | Floor
+ | Ceiling
+ deriving (Eq)
+
+instance Pretty BUn where
+ pretty Tally = "#"
+ pretty Const = "[:"
+ pretty Not = "!"
+ pretty (At i) = "." <> pretty i
+ pretty IParse = ":i"
+ pretty FParse = ":f"
+ pretty Floor = "floor"
+ pretty Ceiling = "ceil"
+
+-- ternary
+data BTer = ZipW
+ | Fold
+ | Scan
+ | Substr
+ deriving (Eq)
+
+instance Pretty BTer where
+ pretty ZipW = ","
+ pretty Fold = "|"
+ pretty Scan = "^"
+ pretty Substr = "substr"
+
+-- builtin
+data BBin = Plus
+ | Times
+ | Div
+ | Minus
+ | Eq
+ | Neq
+ | Geq
+ | Gt
+ | Lt
+ | Leq
+ | Map
+ | Matches -- ^ @/pat/ ~ 'string'@
+ | NotMatches
+ | And
+ | Or
+ | Min
+ | Max
+ | Split
+ | Prior
+ | Filter
+ | Sprintf
+ -- 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 Sprintf = "sprintf"
+
+data DfnVar = X | Y deriving (Eq)
+
+instance Pretty DfnVar where
+ pretty X = "x"
+ pretty Y = "y"
+
+-- expression
+data E a = Column { eLoc :: a, col :: Int }
+ | IParseCol { eLoc :: a, col :: Int } -- always a column
+ | FParseCol { eLoc :: a, col :: Int }
+ | Field { eLoc :: a, field :: Int }
+ | 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 } -- to be rewritten as a lambda...
+ -- TODO: builtin sum type ? (makes pattern matching easier down the road)
+ | BBuiltin { eLoc :: a, eBin :: BBin }
+ | TBuiltin { eLoc :: a, eTer :: BTer }
+ | UBuiltin { eLoc :: a, eUn :: BUn }
+ | Ix { eLoc :: a } -- only 0-ary builtin atm
+ | 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) }
+ | Paren { eLoc :: a, eExpr :: E a }
+ -- TODO: regex literal
+ deriving (Functor, Generic)
+ -- TODO: side effects: allow since it's strict?
+
+instance Recursive (E a) where
+
+instance Corecursive (E a) where
+
+data EF a x = ColumnF a Int
+ | IParseColF a Int
+ | FParseColF a Int
+ | FieldF a Int
+ | 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
+ | IxF a
+ | TupF a [x]
+ | ResVarF a DfnVar
+ | RegexCompiledF RurePtr
+ | ArrF a (V.Vector x)
+ | ParenF a x
+ deriving (Generic, Functor, Foldable, Traversable)
+
+type instance Base (E a) = (EF a)
+
+instance Pretty (E a) where
+ pretty (Column _ i) = "$" <> pretty i
+ pretty AllColumn{} = "$0"
+ pretty (IParseCol _ i) = "$" <> pretty i <> ":i"
+ pretty (FParseCol _ i) = "$" <> pretty i <> ":f"
+ pretty AllField{} = "`0"
+ pretty (Field _ i) = "`" <> pretty i
+ pretty (EApp _ (EApp _ (BBuiltin _ Prior) e) e') = pretty e <> "\\." <+> pretty e'
+ pretty (EApp _ (EApp _ (BBuiltin _ Max) e) e') = "max" <+> pretty e <+> pretty e'
+ pretty (EApp _ (EApp _ (BBuiltin _ Min) e) e') = "min" <+> pretty e <+> pretty e'
+ pretty (EApp _ (EApp _ (BBuiltin _ Split) e) e') = "split" <+> pretty e <+> pretty e'
+ pretty (EApp _ (EApp _ (BBuiltin _ 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 _ (UBuiltin _ (At i)) e') = pretty e' <> "." <> pretty i
+ pretty (EApp _ (UBuiltin _ IParse) e') = pretty e' <> ":i"
+ pretty (EApp _ (UBuiltin _ FParse) e') = pretty e' <> ":f"
+ 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 Ix{} = "ix"
+ pretty RegexCompiled{} = error "Nonsense."
+ pretty (Let _ (n, b) e) = "let" <+> "val" <+> pretty n <+> ":=" <+> pretty b <+> "in" <+> pretty e <+> "end"
+ pretty (Paren _ e) = parens (pretty e)
+ pretty (Arr _ es) = tupledByFunky "," (V.toList $ pretty <$> es)
+
+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
+ (==) 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'
+ (==) (Tup _ es) (Tup _ es') = es == es'
+ (==) (ResVar _ x) (ResVar _ y) = x == y
+ (==) (Dfn _ f) (Dfn _ g) = f == g -- we're testing for lexical equivalence
+ (==) Ix{} Ix{} = True
+ (==) 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
+ -- TODO: 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"
+
+-- decl
+data D a = SetFS BS.ByteString
+ | FunDecl (Name a) [Name a] (E a)
+ deriving (Functor)
+
+-- TODO: fun decls (type decls)
+data Program a = Program { decls :: [D a], expr :: E a } deriving (Functor)
+
+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)
diff --git a/src/Jacinda/Backend/Normalize.hs b/src/Jacinda/Backend/Normalize.hs
new file mode 100644
--- /dev/null
+++ b/src/Jacinda/Backend/Normalize.hs
@@ -0,0 +1,394 @@
+-- TODO: test this module?
+module Jacinda.Backend.Normalize ( compileR
+ , eClosed
+ , closedProgram
+ , readDigits
+ , readFloat
+ , mkI
+ , mkF
+ , mkStr
+ , parseAsEInt
+ , parseAsF
+ ) where
+
+import Control.Monad.State.Strict (State, evalState, gets, modify)
+import Control.Recursion (cata, embed)
+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 Intern.Name
+import Intern.Unique
+import Jacinda.AST
+import Jacinda.Backend.Printf
+import Jacinda.Regex
+import Jacinda.Rename
+import Jacinda.Ty.Const
+
+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!")
+
+readFloat :: BS.ByteString -> Double
+readFloat = read . ASCII.unpack
+
+-- fill in regex with compiled.
+compileR :: E (T K)
+ -> E (T K)
+compileR = cata a where -- TODO: combine with eNorm pass?
+ a (RegexLitF _ rr) = RegexCompiled (compileDefault rr)
+ a x = embed x
+
+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)
+
+eClosed :: Int
+ -> E (T K)
+ -> E (T K)
+eClosed i = flip evalState (mkLetCtx i) . eNorm
+
+closedProgram :: Int
+ -> Program (T K)
+ -> E (T K)
+closedProgram i (Program ds e) = flip evalState (mkLetCtx 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'))
+
+-- 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@AllField{} = 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 e@Ix{} = 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
+ (RegexCompiled re, StrLit _ str) -> BoolLit tyBool (isMatch' re str)
+ (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
+ (RegexCompiled re, StrLit _ str) -> BoolLit tyBool (not $ isMatch' re str)
+ (StrLit _ str, RegexCompiled re) -> BoolLit tyBool (not $ isMatch' re str)
+ _ -> EApp ty (EApp ty' op eI) eI'
+eNorm (EApp ty0 (EApp ty1 op@(BBuiltin (TyArr _ (TyB _ TyInteger) _) Plus) e) e') = do
+ eI <- eNorm e
+ eI' <- eNorm e'
+ pure $ case (eI, eI') of
+ (IntLit _ i, IntLit _ j) -> IntLit tyI (i+j)
+ _ -> EApp ty0 (EApp ty1 op eI) eI'
+eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyStr) _) Plus) e) e') = do
+ eI <- eNorm e
+ eI' <- eNorm e'
+ pure $ case (eI, eI') of
+ (StrLit _ s, StrLit _ s') -> StrLit tyStr (s <> s')
+ (RegexLit _ rr, RegexLit _ rr') -> RegexLit tyStr (rr <> rr')
+ _ -> EApp ty (EApp ty' op eI) eI'
+eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyInteger) _) Max) e) e') = do
+ eI <- eNorm e
+ eI' <- eNorm e'
+ pure $ case (eI, eI') of
+ (IntLit _ i, IntLit _ j) -> 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) -> 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) -> 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) -> 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 l (StrLit l <$> bss) -- FIXME type of Arr (l) is wrong
+ _ -> 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 (TyArr _ (TyB _ TyInteger) _) Minus) e) e') = do
+ eI <- eNorm e
+ eI' <- eNorm e'
+ pure $ case (eI, eI') of
+ (IntLit _ i, IntLit _ j) -> IntLit tyI (i-j)
+ _ -> EApp ty0 (EApp ty1 op eI) eI'
+eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyInteger) _) Times) e) e') = do
+ eI <- eNorm e
+ eI' <- eNorm e'
+ pure $ case (eI, eI') of
+ (IntLit _ i, IntLit _ j) -> IntLit tyI (i*j)
+ _ -> EApp ty (EApp ty' op eI) eI'
+eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyFloat) _) Plus) e) e') = do
+ eI <- eNorm e
+ eI' <- eNorm e'
+ pure $ case (eI, eI') of
+ (FloatLit _ i, FloatLit _ j) -> FloatLit tyF (i+j)
+ _ -> EApp ty (EApp ty' op eI) eI'
+eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyFloat) _) Minus) e) e') = do
+ eI <- eNorm e
+ eI' <- eNorm e'
+ pure $ case (eI, eI') of
+ (FloatLit _ i, FloatLit _ j) -> FloatLit tyF (i-j)
+ _ -> EApp ty (EApp ty' op eI) eI'
+eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyFloat) _) Times) e) e') = do
+ eI <- eNorm e
+ eI' <- eNorm e'
+ pure $ case (eI, eI') of
+ (FloatLit _ i, FloatLit _ j) -> FloatLit tyF (i*j)
+ _ -> EApp ty (EApp ty' op eI) eI'
+eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyFloat) _) Div) e) e') = do
+ eI <- eNorm e
+ eI' <- eNorm e'
+ pure $ case (eI, eI') of
+ (FloatLit _ i, FloatLit _ j) -> 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 (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyStr) _) Eq) e) e') = do
+ eI <- eNorm e
+ eI' <- eNorm e'
+ pure $ case (eI, eI') of
+ (StrLit _ i, StrLit _ j) -> BoolLit tyBool (i == j)
+ _ -> EApp ty (EApp ty' op eI) eI'
+eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyInteger) _) Lt) e) e') = do
+ eI <- eNorm e
+ eI' <- eNorm e'
+ pure $ case (eI, eI') of
+ (IntLit _ i, IntLit _ j) -> BoolLit tyBool (i < j)
+ _ -> EApp ty (EApp ty' op eI) eI'
+eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyInteger) _) Gt) e) e') = do
+ eI <- eNorm e
+ eI' <- eNorm e'
+ pure $ case (eI, eI') of
+ (IntLit _ i, IntLit _ j) -> BoolLit tyBool (i > j)
+ _ -> EApp ty (EApp ty' op eI) eI'
+eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyInteger) _) Eq) e) e') = do
+ eI <- eNorm e
+ eI' <- eNorm e'
+ pure $ case (eI, eI') of
+ (IntLit _ i, IntLit _ j) -> BoolLit tyBool (i == j)
+ _ -> EApp ty (EApp ty' op eI) eI'
+eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyInteger) _) Neq) e) e') = do
+ eI <- eNorm e
+ eI' <- eNorm e'
+ pure $ case (eI, eI') of
+ (IntLit _ i, IntLit _ j) -> BoolLit tyBool (i /= j)
+ _ -> EApp ty (EApp ty' op eI) eI'
+eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyInteger) _) Leq) e) e') = do
+ eI <- eNorm e
+ eI' <- eNorm e'
+ pure $ case (eI, eI') of
+ (IntLit _ i, IntLit _ j) -> BoolLit tyBool (i <= j)
+ _ -> EApp ty (EApp ty' op eI) eI'
+eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyInteger) _) Geq) e) e') = do
+ eI <- eNorm e
+ eI' <- eNorm e'
+ pure $ case (eI, eI') of
+ (IntLit _ i, IntLit _ j) -> BoolLit tyBool (i >= j)
+ _ -> EApp ty (EApp ty' op eI) eI'
+eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyFloat) _) Eq) e) e') = do
+ eI <- eNorm e
+ eI' <- eNorm e'
+ pure $ case (eI, eI') of
+ (FloatLit _ i, FloatLit _ j) -> BoolLit tyBool (i == j)
+ _ -> EApp ty (EApp ty' op eI) eI'
+eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyFloat) _) Neq) e) e') = do
+ eI <- eNorm e
+ eI' <- eNorm e'
+ pure $ case (eI, eI') of
+ (FloatLit _ i, FloatLit _ j) -> BoolLit tyBool (i /= j)
+ _ -> EApp ty (EApp ty' op eI) eI'
+eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyFloat) _) Leq) e) e') = do
+ eI <- eNorm e
+ eI' <- eNorm e'
+ pure $ case (eI, eI') of
+ (FloatLit _ i, FloatLit _ j) -> BoolLit tyBool (i <= j)
+ _ -> EApp ty (EApp ty' op eI) eI'
+eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyFloat) _) Geq) e) e') = do
+ eI <- eNorm e
+ eI' <- eNorm e'
+ pure $ case (eI, eI') of
+ (FloatLit _ i, FloatLit _ j) -> BoolLit tyBool (i >= j)
+ _ -> EApp ty (EApp ty' op eI) eI'
+eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyFloat) _) Gt) e) e') = do
+ eI <- eNorm e
+ eI' <- eNorm e'
+ pure $ case (eI, eI') of
+ (FloatLit _ i, FloatLit _ j) -> BoolLit tyBool (i > j)
+ _ -> EApp ty (EApp ty' op eI) eI'
+eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyFloat) _) Lt) e) e') = do
+ eI <- eNorm e
+ eI' <- eNorm e'
+ pure $ case (eI, eI') of
+ (FloatLit _ i, FloatLit _ j) -> BoolLit tyBool (i < j)
+ _ -> EApp ty (EApp ty' op eI) eI'
+eNorm (EApp ty (EApp ty' op@(BBuiltin (TyArr _ (TyB _ TyStr) _) Neq) e) e') = do
+ eI <- eNorm e
+ eI' <- eNorm e'
+ pure $ case (eI, eI') of
+ (StrLit _ i, StrLit _ 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') -> 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') -> 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 _ (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 _ 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 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'
+ 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 op@(BBuiltin _ Sprintf) e) e') = do
+ eI <- eNorm e
+ eI' <- eNorm e'
+ case (eI, eI') of
+ (StrLit _ fmt, _) | isReady eI' -> pure $ mkStr $ sprintf fmt eI'
+ _ -> EApp ty0 (EApp ty1 op eI) <$> eNorm e'
+eNorm (EApp ty0 (EApp ty1 (EApp ty2 op@TBuiltin{} f) x) y) = EApp ty0 <$> (EApp ty1 <$> (EApp ty2 op <$> eNorm f) <*> eNorm x) <*> eNorm y
+eNorm (EApp ty0 (EApp ty1 op@(BBuiltin _ Prior) x) y) = EApp ty0 <$> (EApp ty1 op <$> eNorm x) <*> eNorm y
+eNorm (EApp ty0 (EApp ty1 op@(BBuiltin _ Map) x) y) = EApp ty0 <$> (EApp ty1 op <$> eNorm x) <*> eNorm y
+eNorm (EApp ty0 (EApp ty1 op@(BBuiltin _ Filter) x) y) = EApp ty0 <$> (EApp ty1 op <$> eNorm x) <*> eNorm y
+-- FIXME: this will almost surely run into trouble; if the above pattern matches
+-- are not complete it will bottom!
+eNorm (EApp ty e@EApp{} e') =
+ eNorm =<< (EApp ty <$> eNorm e <*> pure e')
+eNorm (Arr ty es) = Arr ty <$> traverse eNorm es
diff --git a/src/Jacinda/Backend/Printf.hs b/src/Jacinda/Backend/Printf.hs
new file mode 100644
--- /dev/null
+++ b/src/Jacinda/Backend/Printf.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Jacinda.Backend.Printf ( sprintf
+ , isReady
+ ) where
+
+import qualified Data.ByteString as BS
+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
+sprintf fmt e = encodeUtf8 (sprintf' (decodeUtf8 fmt) e)
+
+-- TODO: https://hackage.haskell.org/package/floatshow
+--
+-- TODO: interpret precision, like %0.6f %.6
+
+sprintf' :: T.Text -> E a -> T.Text
+sprintf' fmt (FloatLit _ f) =
+ let (prefix, fmt') = T.breakOn "%f" fmt
+ in prefix <> T.pack (show f) <> T.drop 2 fmt'
+sprintf' fmt (IntLit _ i) =
+ let (prefix, fmt') = T.breakOn "%i" fmt
+ in prefix <> T.pack (show i) <> T.drop 2 fmt'
+sprintf' fmt (StrLit _ bs) =
+ let (prefix, fmt') = T.breakOn "%s" fmt
+ in prefix <> decodeUtf8 bs <> T.drop 2 fmt'
+sprintf' fmt (Tup _ [e]) = sprintf' fmt e
+sprintf' fmt (Tup l (e:es)) =
+ let nextFmt = sprintf' fmt e
+ in sprintf' nextFmt (Tup l es)
+sprintf' fmt (BoolLit _ b) =
+ let (prefix, fmt') = T.breakOn "%b" fmt
+ in prefix <> showBool b <> T.drop 2 fmt'
+ where showBool True = "true"
+ showBool False = "false"
diff --git a/src/Jacinda/Backend/TreeWalk.hs b/src/Jacinda/Backend/TreeWalk.hs
new file mode 100644
--- /dev/null
+++ b/src/Jacinda/Backend/TreeWalk.hs
@@ -0,0 +1,364 @@
+-- | Tree-walking interpreter
+module Jacinda.Backend.TreeWalk ( runJac
+ ) where
+
+-- TODO: normalize before mapping?
+
+import Control.Exception (Exception, throw)
+import qualified Data.ByteString as BS
+import Data.Foldable (foldl', traverse_)
+import Data.List (scanl')
+import Data.List.Ext
+import Data.Semigroup ((<>))
+import qualified Data.Vector as V
+import Jacinda.AST
+import Jacinda.Backend.Normalize
+import Jacinda.Backend.Printf
+import Jacinda.Regex
+import Jacinda.Ty.Const
+import Regex.Rure (RurePtr)
+
+data StreamError = NakedField
+ | UnevalFun
+ | TupOfStreams -- ^ Reject a tuple of streams
+ | BadCtx
+ | IndexOutOfBounds Int
+ 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 :: a
+noRes = error "Internal error: did not normalize to appropriate type."
+
+badSugar :: a
+badSugar = error "Internal error: dfn syntactic sugar at a stage where it should not be."
+
+asInt :: E a -> Integer
+asInt (IntLit _ i) = i
+asInt _ = noRes
+
+asBool :: E a -> Bool
+asBool (BoolLit _ b) = b
+asBool _ = noRes
+
+asStr :: E a -> BS.ByteString
+asStr (StrLit _ str) = str
+asStr _ = noRes
+
+asFloat :: E a -> Double
+asFloat (FloatLit _ f) = f
+asFloat _ = noRes
+
+asRegex :: E a -> RurePtr
+asRegex (RegexCompiled re) = re
+asRegex _ = noRes
+
+-- TODO: do I want to interleave state w/ eNorm or w/e
+
+-- 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 (EApp ty op@BBuiltin{} e) = EApp ty op (go e)
+ go Ix{} = mkI (fromIntegral ix)
+ go AllField{} = StrLit tyStr line
+ go (Field _ i) = StrLit tyStr (ctx ! (i-1)) -- cause vector indexing starts at 0
+ go (EApp _ (UBuiltin _ IParse) e) =
+ let eI = asStr (go e)
+ in parseAsEInt eI
+ go (EApp _ (UBuiltin _ FParse) 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
+ (RegexCompiled reϵ, StrLit _ strϵ) -> BoolLit tyBool (isMatch' reϵ strϵ)
+ (StrLit _ strϵ, RegexCompiled reϵ) -> BoolLit tyBool (isMatch' reϵ strϵ)
+ _ -> noRes
+ go (EApp _ (EApp _ (BBuiltin _ NotMatches) e) e') =
+ let eI = go e
+ eI' = go e'
+ in case (eI, eI') of
+ (RegexCompiled reϵ, StrLit _ strϵ) -> BoolLit tyBool (not $ isMatch' reϵ strϵ)
+ (StrLit _ strϵ, RegexCompiled reϵ) -> BoolLit tyBool (not $ isMatch' reϵ strϵ)
+ _ -> noRes
+ 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')
+ 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) _) 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 _ 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 (StrLit undefined <$> 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
+ go (EApp _ (EApp _ (BBuiltin _ Sprintf) e) e') =
+ let eI = asStr (go e)
+ eI' = go e'
+ in mkStr (sprintf eI eI')
+
+applyOp :: Int
+ -> E (T K) -- ^ Operator
+ -> E (T K)
+ -> E (T K)
+ -> E (T K)
+applyOp i op e e' = eClosed i (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 :: Int
+ -> E (T K)
+ -> E (T K)
+ -> E (T K)
+applyUn i unOp e =
+ case eLoc unOp of
+ TyArr _ _ res -> eClosed i (EApp res unOp e)
+ _ -> error "Internal error?"
+
+-- | Turn an expression representing a stream into a stream of expressions (using line as context)
+ir :: RurePtr
+ -> Int
+ -> 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 _ (Implicit _ e) =
+ let e' = compileR e
+ in imap (\ix line -> eEval (mkCtx re ix line) e')
+ir re _ (Guarded _ pe e) =
+ let pe' = compileR pe
+ e' = compileR e
+ -- FIXME: compile e too?
+ -- TODO: normalize before stream
+ in imap (\ix line -> eEval (mkCtx re ix line) e') . ifilter (\ix line -> asBool (eEval (mkCtx re ix line) pe'))
+ir re i (EApp _ (EApp _ (BBuiltin _ Map) op) stream) = let op' = compileR op in fmap (applyUn i op') . ir re i stream
+ir re i (EApp _ (EApp _ (BBuiltin _ Filter) op) stream) =
+ let op' = compileR op
+ in filter (\e -> asBool (eClosed i $ applyUn i op' e)) . ir re i stream
+ir re i (EApp _ (EApp _ (BBuiltin _ Prior) op) stream) = prior (applyOp i op) . ir re i stream
+ir re i (EApp _ (EApp _ (EApp _ (TBuiltin _ ZipW) op) streaml) streamr) = \lineStream ->
+ let
+ irl = ir re i streaml lineStream
+ irr = ir re i streamr lineStream
+ in zipWith (applyOp i op) irl irr
+ir re i (EApp _ (EApp _ (EApp _ (TBuiltin _ Scan) op) seed) xs) =
+ scanl' (applyOp i op) seed . ir re i xs
+
+-- | Output stream that prints each entry (expression)
+printStream :: [E (T K)] -> IO ()
+printStream = traverse_ print
+
+foldWithCtx :: RurePtr -> Int
+ -> E (T K)
+ -> E (T K)
+ -> E (T K)
+ -> [BS.ByteString]
+ -> E (T K)
+foldWithCtx re i op seed streamExpr = foldl' (applyOp i op) seed . ir re i streamExpr
+
+runJac :: RurePtr -- ^ Record separator
+ -> Int
+ -> Program (T K)
+ -> Either StreamError ([BS.ByteString] -> IO ())
+runJac re i e = fileProcessor re i (closedProgram i e)
+
+-- evaluate something that has a fold nested in it
+eWith :: RurePtr -> Int -> E (T K) -> [BS.ByteString] -> E (T K)
+eWith re i (EApp _ (EApp _ (EApp _ (TBuiltin _ Fold) op) seed) stream) = foldWithCtx re i op seed stream -- FIXME: only fold on streams!!
+eWith re i (EApp ty e0 e1) = \bs -> eClosed i (EApp ty (eWith re i e0 bs) (eWith re i e1 bs))
+eWith _ _ e@BBuiltin{} = const e
+eWith _ _ e@UBuiltin{} = const e
+eWith _ _ e@TBuiltin{} = const e
+eWith _ _ e@StrLit{} = const e
+eWith _ _ e@FloatLit{} = const e
+eWith _ _ e@IntLit{} = const e
+eWith _ _ e@BoolLit{} = const e
+eWith re i (Tup ty es) = \bs -> Tup ty ((\e -> eWith re i e bs) <$> es)
+
+-- TODO: passing in 'i' separately to each eClosed is sketch but... hopefully
+-- won't blow up in our faces
+--
+-- | Given an expression, turn it into a function which will process the file.
+fileProcessor :: RurePtr
+ -> Int
+ -> E (T K)
+ -> Either StreamError ([BS.ByteString] -> IO ())
+fileProcessor _ _ AllField{} = Left NakedField
+fileProcessor _ _ Field{} = Left NakedField
+fileProcessor _ _ Ix{} = Left NakedField
+fileProcessor _ _ AllColumn{} = Right $ \inp ->
+ printStream $ fmap mkStr inp
+fileProcessor re _ (Column _ i) = Right $ \inp -> do
+ printStream $ fmap (mkStr . atField re i) inp
+fileProcessor re _ (IParseCol _ i) = Right $ \inp -> do
+ printStream $ fmap (parseAsEInt . atField re i) inp
+fileProcessor re _ (FParseCol _ i) = Right $ \inp -> do
+ printStream $ fmap (parseAsF . atField re i) inp
+-- TODO: this should extract any regex and compile them, use io/low-level API...
+fileProcessor re i e@Guarded{} = Right $ \inp -> do
+ printStream $ ir re i e inp
+fileProcessor re i e@Implicit{} = Right $ \inp -> do
+ printStream $ ir re i e inp
+fileProcessor re i e@(EApp _ (EApp _ (BBuiltin _ Filter) _) _) = Right $ \inp -> do
+ printStream $ ir re i e inp
+fileProcessor re i e@(EApp _ (EApp _ (BBuiltin _ Map) _) _) = Right $ \inp -> do
+ printStream $ ir re i e inp
+fileProcessor re i e@(EApp _ (EApp _ (BBuiltin _ Prior) _) _) = Right $ \inp -> do
+ printStream $ ir re i e inp
+fileProcessor re i e@(EApp _ (EApp _ (EApp _ (TBuiltin _ Scan) _) _) _) = Right $ \inp -> do
+ printStream $ ir re i e inp
+fileProcessor re i e@(EApp _ (EApp _ (EApp _ (TBuiltin _ ZipW) _) _) _) = Right $ \inp -> do
+ printStream $ ir re i e inp
+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 i e = Right $ print . eWith re i e
diff --git a/src/Jacinda/File.hs b/src/Jacinda/File.hs
new file mode 100644
--- /dev/null
+++ b/src/Jacinda/File.hs
@@ -0,0 +1,89 @@
+module Jacinda.File ( tyCheck
+ , tcIO
+ , tySrc
+ , runOnHandle
+ , runOnFile
+ , exprEval
+ ) where
+
+import Control.Applicative ((<|>))
+import Control.Exception (Exception, throw, throwIO)
+import Control.Monad ((<=<))
+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.Functor (void)
+import Jacinda.AST
+import Jacinda.Backend.Normalize
+import Jacinda.Backend.TreeWalk
+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)
+
+-- | Parse + rename (globally)
+parseWithMax' :: BSL.ByteString -> Either (ParseError AlexPosn) (Program AlexPosn, Int)
+parseWithMax' = fmap (uncurry renamePGlobal . second rewriteProgram) . parseWithMax
+
+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 typed
+
+compileFS :: Maybe BS.ByteString -> RurePtr
+compileFS (Just bs) = compileDefault bs
+compileFS Nothing = defaultRurePtr
+
+runOnBytes :: BSL.ByteString -- ^ Program
+ -> Maybe BS.ByteString -- ^ Field separator
+ -> BSL.ByteString
+ -> IO ()
+runOnBytes src cliFS contents =
+ case parseWithMax' src of
+ Left err -> throwIO err
+ Right (ast, m) -> do
+ (typed, i) <- yeetIO $ runTypeM m (tyProgram ast)
+ cont <- yeetIO $ runJac (compileFS (cliFS <|> getFS ast)) i typed
+ cont $ concatMap BSL.toChunks (ASCIIL.lines contents) -- FIXME: "lines" discards empty... perhaps ok?
+
+runOnHandle :: BSL.ByteString -- ^ Program
+ -> Maybe BS.ByteString -- ^ Field separator
+ -> Handle
+ -> IO ()
+runOnHandle src cliFS = runOnBytes src cliFS <=< BSL.hGetContents
+
+runOnFile :: BSL.ByteString
+ -> Maybe BS.ByteString
+ -> FilePath
+ -> IO ()
+runOnFile e fs = runOnBytes e fs <=< BSL.readFile
+
+tcIO :: BSL.ByteString -> IO ()
+tcIO = yeetIO . tyCheck
+
+-- | Typecheck an expression
+tyCheck :: BSL.ByteString -> Either (Error AlexPosn) ()
+tyCheck src =
+ case parseWithMax' src of
+ Right (ast, m) -> void $ runTypeM m (tyProgram ast)
+ Left err -> throw err
+
+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
diff --git a/src/Jacinda/Lexer.x b/src/Jacinda/Lexer.x
new file mode 100644
--- /dev/null
+++ b/src/Jacinda/Lexer.x
@@ -0,0 +1,404 @@
+{
+ {-# LANGUAGE OverloadedStrings #-}
+ {-# LANGUAGE StandaloneDeriving #-}
+ module Jacinda.Lexer ( alexMonadScan
+ , alexInitUserState
+ , runAlex
+ , runAlexSt
+ , withAlexSt
+ , lexJac
+ , 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 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)
+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 \_]
+
+@name = [a-z] @follow_char*
+@tyname = [A-Z] @follow_char*
+
+@float = $digit+\.$digit+
+
+tokens :-
+
+ {
+ x { mkRes VarX }
+ y { mkRes VarY }
+ }
+
+ <0,dfn> {
+
+ $white+ ;
+
+ "{.".* ;
+
+ ":=" { 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 EqTok }
+ "!=" { mkSym NeqTok }
+ "<=" { mkSym LeqTok }
+ "<" { mkSym LtTok }
+ ">=" { mkSym GeqTok }
+ ">" { mkSym GtTok }
+ "&" { mkSym AndTok }
+ "||" { mkSym OrTok }
+ "(" { mkSym LParen }
+ ")" { mkSym RParen }
+ "{%" { mkSym LBracePercent }
+ "{|" { mkSym LBraceBar }
+ "[" { mkSym LSqBracket `andBegin` dfn }
+ "]" { mkSym RSqBracket `andBegin` 0 } -- FIXME: this doesn't allow nested
+ "~" { mkSym Tilde }
+ "!~" { mkSym NotMatchTok }
+ "," { mkSym Comma }
+ "." { mkSym Dot }
+ "#" { mkSym TallyTok }
+ "[:" { mkSym ConstTok }
+ "!" { mkSym Exclamation }
+ ":" { mkSym Colon }
+ ";" { mkSym Semicolon }
+ "\." { mkSym BackslashDot }
+ \\ { mkSym Backslash }
+
+ in { mkKw KwIn }
+ let { mkKw KwLet }
+ val { mkKw KwVal }
+ end { mkKw KwEnd }
+ :set { mkKw KwSet }
+ fn { mkKw KwFn }
+
+ fs { mkRes VarFs }
+ ix { mkRes VarIx }
+ ⍳ { mkRes VarIx }
+ min { mkRes VarMin }
+ max { mkRes VarMax }
+
+ substr { mkBuiltin BuiltinSubstr }
+ split { mkBuiltin BuiltinSplit }
+ sprintf { mkBuiltin BuiltinSprintf }
+ floor { mkBuiltin BuiltinFloor }
+ ceil { mkBuiltin BuiltinCeil }
+
+ ":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 $ 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)) }
+
+ -- TODO: allow chars to be escaped
+ -- TODO: consider dropping this syntax for strings?
+ '[^']*' { tok (\p s -> alex $ TokStr p (BSL.init $ BSL.tail s)) }
+
+ "/"[^\/]*"/" { tok (\p s -> alex $ TokRR p (BSL.init $ BSL.tail s)) } -- TODO: allow slashes that are escaped
+
+ @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
+
+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
+ | Quot
+ | TimesTok
+ | DefEq
+ | Colon
+ | LBrace
+ | RBrace
+ | LParen
+ | RParen
+ | LSqBracket
+ | RSqBracket
+ | Semicolon
+ | Underscore
+ | EqTok
+ | LeqTok
+ | LtTok
+ | NeqTok
+ | GeqTok
+ | GtTok
+ | AndTok
+ | OrTok
+ | Tilde
+ | NotMatchTok
+ | Comma
+ | Dot
+ | TallyTok
+ | ConstTok
+ | LBracePercent
+ | LBraceBar
+ | Exclamation
+ | Caret
+ | Backslash
+ | BackslashDot
+ | FilterTok
+
+instance Pretty Sym where
+ pretty PlusTok = "+"
+ pretty MinusTok = "-"
+ pretty PercentTok = "%"
+ pretty FoldTok = "|"
+ 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 LSqBracket = "["
+ pretty RSqBracket = "]"
+ pretty Tilde = "~"
+ pretty NotMatchTok = "!~"
+ pretty Comma = ","
+ pretty Dot = "."
+ pretty TallyTok = "#"
+ pretty Quot = "\""
+ pretty Caret = "^"
+ pretty ConstTok = "[:"
+ pretty LBracePercent = "{%"
+ pretty LBraceBar = "{|"
+ pretty Exclamation = "!"
+ pretty Backslash = "\\"
+ pretty BackslashDot = "\\."
+ pretty FilterTok = "#."
+
+data Keyword = KwLet
+ | KwIn
+ | KwVal
+ | KwEnd
+ | KwSet
+ | KwFn
+
+-- | Reserved/special variables
+data Var = VarX
+ | VarY
+ | VarFs
+ | VarIx
+ | VarMin
+ | VarMax
+
+instance Pretty Var where
+ pretty VarX = "x"
+ pretty VarY = "y"
+ pretty VarFs = "fs"
+ pretty VarIx = "ix"
+ 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"
+
+data Builtin = BuiltinIParse
+ | BuiltinFParse
+ | BuiltinSubstr
+ | BuiltinSplit
+ | BuiltinSprintf
+ | BuiltinFloor
+ | BuiltinCeil
+
+instance Pretty Builtin where
+ pretty BuiltinIParse = ":i"
+ pretty BuiltinFParse = ":f"
+ pretty BuiltinSubstr = "substr"
+ pretty BuiltinSplit = "split"
+ pretty BuiltinSprintf = "sprintf"
+ pretty BuiltinFloor = "floor"
+ pretty BuiltinCeil = "ceil"
+
+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 :: BSL.ByteString }
+ | TokStreamLit { loc :: a, ix :: Int }
+ | TokFieldLit { loc :: a, ix :: Int }
+ | TokRR { loc :: a, rr :: BSL.ByteString }
+ | TokAccess { loc :: a, ix :: 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 $ mkText 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
+
+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)
+
+loop :: Alex [Token AlexPosn]
+loop = do
+ tok' <- alexMonadScan
+ case tok' of
+ EOF{} -> pure []
+ _ -> (tok' :) <$> loop
+
+lexJac :: BSL.ByteString -> Either String [Token AlexPosn]
+lexJac = flip runAlex loop
+
+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
+ })
+
+}
diff --git a/src/Jacinda/Parser.y b/src/Jacinda/Parser.y
new file mode 100644
--- /dev/null
+++ b/src/Jacinda/Parser.y
@@ -0,0 +1,276 @@
+{
+ {-# LANGUAGE OverloadedStrings #-}
+ module Jacinda.Parser ( parse
+ , parseWithMax
+ , parseWithCtx
+ , parseWithInitCtx
+ , ParseError (..)
+ ) 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.Typeable (Typeable)
+import qualified Intern.Name as Name
+import Intern.Name hiding (loc)
+import Jacinda.AST
+import Jacinda.Lexer
+import Prettyprinter (Pretty (pretty), (<+>))
+
+}
+
+%name parseP Program
+%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 }
+ 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 }
+ const { TokSym $$ ConstTok }
+ filter { TokSym $$ FilterTok }
+ exclamation { TokSym $$ Exclamation }
+ backslashdot { TokSym $$ BackslashDot }
+ at { $$@(TokAccess _ _) }
+
+ plus { TokSym $$ PlusTok }
+ minus { TokSym $$ MinusTok }
+ times { TokSym $$ TimesTok }
+ percent { TokSym $$ PercentTok }
+
+ comma { TokSym $$ Comma }
+ fold { TokSym $$ FoldTok }
+ caret { TokSym $$ Caret }
+ quot { TokSym $$ Quot }
+
+ 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 _ _) }
+
+ let { TokKeyword $$ KwLet }
+ in { TokKeyword $$ KwIn }
+ val { TokKeyword $$ KwVal }
+ end { TokKeyword $$ KwEnd }
+ set { TokKeyword $$ KwSet }
+ fn { TokKeyword $$ KwFn }
+
+ x { TokResVar $$ VarX }
+ y { TokResVar $$ VarY }
+
+ min { TokResVar $$ VarMin }
+ max { TokResVar $$ VarMax }
+ ix { TokResVar $$ VarIx }
+ fs { TokResVar $$ VarFs }
+
+ split { TokBuiltin $$ BuiltinSplit }
+ substr { TokBuiltin $$ BuiltinSubstr }
+ sprintf { TokBuiltin $$ BuiltinSprintf }
+ floor { TokBuiltin $$ BuiltinFloor }
+ ceil { TokBuiltin $$ BuiltinCeil }
+
+ 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 }
+ | tilde { Matches }
+ | notMatch { NotMatches }
+ | and { And }
+ | or { Or }
+ | backslashdot { Prior }
+ | filter { Filter }
+
+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 }
+
+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) (BSL.toStrict $ strTok $1) }
+ | column { Column (loc $1) (ix $1) }
+ | field { Field (loc $1) (ix $1) }
+ | allColumn { AllColumn $1 }
+ | allField { AllField $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) }
+ | 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) }
+ | 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 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) }
+ | E E { EApp (eLoc $1) $1 $2 }
+ | tally { UBuiltin $1 Tally }
+ | 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 }
+ | substr { TBuiltin $1 Substr }
+ | sprintf { BBuiltin $1 Sprintf }
+ | floor { UBuiltin $1 Floor }
+ | ceil { UBuiltin $1 Ceiling }
+ | ix { Ix $1 }
+ | parens(at) { UBuiltin (loc $1) (At $ ix $1) }
+ | E at { EApp (eLoc $1) (UBuiltin (loc $2) (At $ ix $2)) $1 }
+ | backslash name dot E { Lam $1 $2 $4 }
+ | parens(E) { Paren (eLoc $1) $1 }
+
+{
+
+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
+ | NoImpl (Name a)
+
+instance Pretty a => Pretty (ParseError a) where
+ pretty (Unexpected tok) = pretty (loc tok) <+> "Unexpected" <+> pretty tok
+ pretty (LexErr str) = pretty (T.pack str)
+ pretty (NoImpl n) = pretty (Name.loc n) <+> "Signature for" <+> pretty n <+> "is not accompanied by an implementation"
+
+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) (Program AlexPosn)
+parse = fmap snd . runParse parseP
+
+parseWithMax :: BSL.ByteString -> Either (ParseError AlexPosn) (Int, Program AlexPosn)
+parseWithMax = fmap (first fst3) . parseWithInitCtx
+ where fst3 (x, _, _) = x
+
+parseWithInitCtx :: BSL.ByteString -> Either (ParseError AlexPosn) (AlexUserState, Program AlexPosn)
+parseWithInitCtx bsl = parseWithCtx bsl alexInitUserState
+
+parseWithCtx :: BSL.ByteString -> AlexUserState -> Either (ParseError AlexPosn) (AlexUserState, Program AlexPosn)
+parseWithCtx = parseWithInitSt parseP
+
+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)
+
+}
diff --git a/src/Jacinda/Parser/Rewrite.hs b/src/Jacinda/Parser/Rewrite.hs
new file mode 100644
--- /dev/null
+++ b/src/Jacinda/Parser/Rewrite.hs
@@ -0,0 +1,41 @@
+module Jacinda.Parser.Rewrite ( rewriteProgram
+ ) 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@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 _ 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 x = embed x
diff --git a/src/Jacinda/Regex.hs b/src/Jacinda/Regex.hs
new file mode 100644
--- /dev/null
+++ b/src/Jacinda/Regex.hs
@@ -0,0 +1,65 @@
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Jacinda.Regex ( splitBy
+ , splitWhitespace
+ , defaultRurePtr
+ , isMatch'
+ , compileDefault
+ , substr
+ ) where
+
+import Control.Exception (Exception, throwIO)
+import Control.Monad ((<=<))
+import qualified Data.ByteString.Internal as BS
+import Data.Semigroup ((<>))
+import qualified Data.Vector as V
+import Foreign.ForeignPtr (plusForeignPtr)
+import Regex.Rure (RureMatch (..), RurePtr, compile, isMatch, matches, mkIter, rureDefaultFlags, rureFlagDotNL)
+import System.IO.Unsafe (unsafeDupablePerformIO, unsafePerformIO)
+
+-- see: https://docs.rs/regex/latest/regex/#perl-character-classes-unicode-friendly
+defaultFs :: BS.ByteString
+defaultFs = "\\s+"
+
+-- also ls -l | ja '{ix>1}{`5:i}'
+
+{-# NOINLINE defaultRurePtr #-}
+defaultRurePtr :: RurePtr
+defaultRurePtr = unsafePerformIO $ yeetRureIO =<< compile genFlags defaultFs
+ where genFlags = rureDefaultFlags <> rureFlagDotNL -- in case they want to use a weird custom record separator
+
+splitWhitespace :: BS.ByteString -> V.Vector BS.ByteString
+splitWhitespace = splitBy defaultRurePtr
+
+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)
+ | otherwise = "error: invalid substring indices."
+
+{-# NOINLINE splitBy #-}
+splitBy :: RurePtr
+ -> BS.ByteString
+ -> V.Vector BS.ByteString
+splitBy re haystack@(BS.BS fp l) =
+ (\sp -> V.fromList [BS.BS (fp `plusForeignPtr` s) (e-s) | (s, e) <- sp]) slicePairs
+ where ixes = unsafeDupablePerformIO $ do { reIptr <- mkIter re; matches reIptr haystack }
+ slicePairs = case ixes of
+ (RureMatch 0 i:rms) -> mkMiddle (fromIntegral i) rms
+ rms -> mkMiddle 0 rms
+ mkMiddle begin' [] = [(begin', l)]
+ mkMiddle begin' (rm0:rms) = (begin', fromIntegral (start rm0)) : mkMiddle (fromIntegral $ end rm0) rms
+
+isMatch' :: RurePtr
+ -> BS.ByteString
+ -> Bool
+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
+
+newtype RureExe = RegexCompile String deriving (Show)
+
+instance Exception RureExe where
+
+yeetRureIO :: Either String a -> IO a
+yeetRureIO = either (throwIO . RegexCompile) pure
diff --git a/src/Jacinda/Rename.hs b/src/Jacinda/Rename.hs
new file mode 100644
--- /dev/null
+++ b/src/Jacinda/Rename.hs
@@ -0,0 +1,150 @@
+{-# 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 _ = 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
+
+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) | hasY e = do
+ x@(Name nX uX _) <- dummyName l "x"
+ y@(Name nY uY _) <- dummyName l "y"
+ Lam l x . Lam l y <$> renameE (replaceXY (Name nX uX) (Name nY uY) e)
+ | otherwise = do
+ x@(Name n u _) <- dummyName l "x"
+ -- no need for withName... withRenames because this is fresh/globally unique
+ Lam l x <$> renameE (replaceX (Name n u) e)
+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 e = pure e -- literals &c.
diff --git a/src/Jacinda/Ty.hs b/src/Jacinda/Ty.hs
new file mode 100644
--- /dev/null
+++ b/src/Jacinda/Ty.hs
@@ -0,0 +1,459 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Jacinda.Ty ( TypeM
+ , Error (..)
+ , runTypeM
+ , tyProgram
+ -- * For debugging
+ , tyOf
+ ) where
+
+import Control.Exception (Exception)
+import Control.Monad.Except (throwError)
+import Control.Monad.State.Strict (StateT, gets, runStateT)
+import Data.Bifunctor (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 Intern.Name
+import Intern.Unique
+import Jacinda.AST
+import Jacinda.Ty.Const
+import Lens.Micro (Lens')
+import Lens.Micro.Mtl (modifying)
+import Prettyprinter (Doc, Pretty (..), hardline, squotes, vsep, (<+>))
+
+infixr 6 <#>
+
+(<#>) :: Doc a -> Doc a -> Doc a
+(<#>) x y = x <> hardline <> y
+
+data Error a = UnificationFailed a (T ()) (T ())
+ | Doesn'tSatisfy (T ()) C
+ | IllScoped a (Name a)
+
+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 ty c) = squotes (pretty ty) <+> "is not a member of class" <+> pretty c
+ pretty (IllScoped l n) = pretty l <+> 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)
+ , varEnv :: IM.IntMap (T K)
+ , constraints :: S.Set (a, T K, T K)
+ }
+
+instance Pretty (TyState a) where
+ pretty (TyState _ _ _ _ cs) =
+ "constraints:" <#> prettyConstraints cs
+
+prettyConstraints :: S.Set (b, T a, T a) -> Doc ann
+prettyConstraints cs = vsep (prettyEq . go <$> S.toList cs) where
+ go (_, x, y) = (x, y)
+
+prettyEq :: (T a, T a) -> Doc ann
+prettyEq (ty, ty') = pretty ty <+> "≡" <+> pretty ty'
+
+maxULens :: Lens' (TyState a) Int
+maxULens f s = fmap (\x -> s { maxU = x }) (f (maxU s))
+
+classVarsLens :: Lens' (TyState a) (IM.IntMap (S.Set C))
+classVarsLens f s = fmap (\x -> s { classVars = x }) (f (classVars s))
+
+varEnvLens :: Lens' (TyState a) (IM.IntMap (T K))
+varEnvLens f s = fmap (\x -> s { varEnv = x }) (f (varEnv s))
+
+constraintsLens :: Lens' (TyState a) (S.Set (a, T K, T K))
+constraintsLens f s = fmap (\x -> s { constraints = x }) (f (constraints s))
+
+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 ((_, TyVar _ n@(Name _ (Unique k) _), ty@(TyVar _ n')):tys)
+ | n == n' = unifyPrep um tys -- a type variable is always equal to itself, don't bother inserting this!
+ | 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 = 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 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
+ <$ modifying maxULens (+1)
+
+higherOrder :: T.Text -> TypeM a (Name K)
+higherOrder t = freshName t (KArr Star Star)
+
+-- of kind 'Star'
+dummyName :: T.Text -> TypeM a (Name K)
+dummyName n = freshName n Star
+
+addC :: Name a -> C -> IM.IntMap (S.Set C) -> IM.IntMap (S.Set C)
+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' =
+ modifying constraintsLens (S.insert (l, ty, ty'))
+
+-- TODO: this will need some class context if we permit custom types (Optional)
+checkType :: T b -> C -> TypeM a ()
+checkType TyVar{} _ = pure () -- TODO: I think this is right
+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 (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 (TyTup _ tys) IsEq = traverse_ (`checkType` IsEq) tys
+checkType (TyTup _ tys) IsOrd = traverse_ (`checkType` IsOrd) tys
+checkType (TyApp _ (TyB _ TyVec) ty) IsEq = checkType ty IsEq
+checkType ty@TyTup{} c@IsNum = throwError $ Doesn'tSatisfy (void ty) c
+checkType ty@(TyB _ TyStr) c@IsNum = throwError $ Doesn'tSatisfy (void ty) c
+checkType ty@(TyB _ TyBool) c@IsNum = throwError $ Doesn'tSatisfy (void ty) c
+checkType ty@TyArr{} c = throwError $ Doesn'tSatisfy (void ty) c
+checkType (TyB _ TyVec) Functor = pure ()
+checkType (TyB _ TyStream) Functor = pure ()
+checkType ty c@Functor = throwError $ Doesn'tSatisfy (void ty) c
+checkType (TyB _ TyVec) Foldable = pure ()
+checkType (TyB _ TyStream) Foldable = pure ()
+checkType ty c@Foldable = throwError $ Doesn'tSatisfy (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 = traverse_ (`checkType` IsPrintf) tys
+checkType ty c@IsPrintf = throwError $ Doesn'tSatisfy (void ty) c
+
+checkClass :: IM.IntMap (T K) -- ^ Unification result
+ -> Int
+ -> S.Set C
+ -> TypeM a ()
+checkClass tys i cs =
+ case substInt tys i of
+ Just ty -> traverse_ (checkType ty) (S.toList cs)
+ Nothing -> pure () -- FIXME: do we need to check 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
+ 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'
+ modifying varEnvLens (IM.insert i ty)
+ pure $ FunDecl (n $> ty) [] e'
+tyD0 FunDecl{} = error "Internal error. Should have been desugared by now."
+
+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
+ pure (fmap (substConstraints backNames) (Program ds' e'))
+
+-- FIXME kind check
+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 :: TypeM a (T K)
+tyNumOp = do
+ m <- dummyName "m"
+ modifying classVarsLens (addC m IsNum)
+ let m' = var m
+ pure $ tyArr m' (tyArr m' m')
+
+tySemiOp :: TypeM a (T K)
+tySemiOp = do
+ m <- dummyName "m"
+ modifying classVarsLens (addC m IsSemigroup)
+ let m' = var m
+ pure $ tyArr m' (tyArr m' m')
+
+tyOrd :: TypeM a (T K)
+tyOrd = do
+ a <- dummyName "a"
+ modifying classVarsLens (addC a IsOrd)
+ let a' = var a
+ pure $ tyArr a' (tyArr a' tyBool)
+
+tyEq :: TypeM a (T K)
+tyEq = do
+ a <- dummyName "a"
+ modifying classVarsLens (addC a IsEq)
+ let a' = var a
+ pure $ tyArr a' (tyArr a' tyBool)
+
+-- min/max
+tyM :: TypeM a (T K)
+tyM = do
+ a <- dummyName "a"
+ modifying classVarsLens (addC a IsOrd)
+ let a' = var a
+ pure $ tyArr a' (tyArr a' a')
+
+desugar :: a
+desugar = error "Should have been de-sugared in an earlier stage!"
+
+hkt :: T K -> T K -> T K
+hkt = TyApp Star
+
+tyVec :: T K
+tyVec = TyB (KArr Star Star) TyVec
+
+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 tyStr 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 AllField{} = pure $ AllField tyStr
+tyE0 AllColumn{} = pure $ AllColumn (tyStream tyStr)
+tyE0 Ix{} = pure $ Ix tyI
+tyE0 (BBuiltin _ Plus) = BBuiltin <$> tySemiOp <*> pure Plus
+tyE0 (BBuiltin _ Minus) = BBuiltin <$> tyNumOp <*> pure Minus
+tyE0 (BBuiltin _ Times) = BBuiltin <$> tyNumOp <*> pure Times
+tyE0 (BBuiltin _ Gt) = BBuiltin <$> tyOrd <*> pure Gt
+tyE0 (BBuiltin _ Lt) = BBuiltin <$> tyOrd <*> pure Lt
+tyE0 (BBuiltin _ Geq) = BBuiltin <$> tyOrd <*> pure Geq
+tyE0 (BBuiltin _ Leq) = BBuiltin <$> tyOrd <*> pure Leq
+tyE0 (BBuiltin _ Eq) = BBuiltin <$> tyEq <*> pure Eq
+tyE0 (BBuiltin _ Neq) = BBuiltin <$> tyEq <*> pure Neq
+tyE0 (BBuiltin _ Min) = BBuiltin <$> tyM <*> pure Min
+tyE0 (BBuiltin _ Max) = BBuiltin <$> tyM <*> pure Max
+tyE0 (BBuiltin _ Split) = pure $ BBuiltin (tyArr tyStr (tyArr tyStr (hkt tyVec tyStr))) Split
+tyE0 (BBuiltin _ Matches) = pure $ BBuiltin (tyArr tyStr (tyArr tyStr tyBool)) Matches
+tyE0 (BBuiltin _ NotMatches) = pure $ BBuiltin (tyArr tyStr (tyArr tyStr 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 (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 (BBuiltin _ Sprintf) = do
+ a <- dummyName "a"
+ let a' = var a
+ modifying classVarsLens (addC a IsPrintf)
+ pure $ BBuiltin (tyArr tyStr (tyArr a' tyStr)) Sprintf
+tyE0 (UBuiltin _ (At i)) = do
+ a <- dummyName "a"
+ let a' = var a
+ tyV = hkt tyVec a'
+ pure $ UBuiltin (tyArr tyV a') (At i)
+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 (BBuiltin _ Filter) = do
+ a <- dummyName "a"
+ let a' = var a
+ fTy = tyArr (tyArr a' tyBool) (tyArr (tyStream a') (tyStream a'))
+ pure $ BBuiltin fTy Filter
+tyE0 (BBuiltin _ 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'))
+ modifying classVarsLens (addC f Functor)
+ pure $ BBuiltin fTy Map
+-- (b -> a -> b) -> b -> Stream a -> b
+tyE0 (TBuiltin _ 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'))
+ modifying classVarsLens (addC f Foldable)
+ pure $ TBuiltin fTy Fold
+-- (a -> a -> a) -> Stream a -> Stream a
+tyE0 (BBuiltin _ Prior) = do
+ a <- dummyName "a"
+ let a' = var a
+ fTy = tyArr (tyArr a' (tyArr a' a')) (tyArr (tyStream a') (tyStream a'))
+ 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 (Implicit _ e) = do
+ e' <- tyE0 e
+ pure $ Implicit (tyStream (eLoc e')) e'
+-- (a -> b -> c) -> Stream a -> Stream b -> Stream c
+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
+ modifying varEnvLens (IM.insert i a')
+ e' <- tyE0 e
+ pure $ Lam (tyArr a' (eLoc e')) (n $> a') e'
+tyE0 (Let _ (n@(Name _ (Unique i) _), eϵ) e) = do
+ eϵ' <- tyE0 eϵ
+ let bTy = eLoc eϵ'
+ modifying varEnvLens (IM.insert i bTy)
+ 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
diff --git a/src/Jacinda/Ty/Const.hs b/src/Jacinda/Ty/Const.hs
new file mode 100644
--- /dev/null
+++ b/src/Jacinda/Ty/Const.hs
@@ -0,0 +1,24 @@
+module Jacinda.Ty.Const ( tyStream
+ , tyStr
+ , tyI
+ , tyF
+ , tyBool
+ ) 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
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,100 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+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 Jacinda.Regex
+import Jacinda.Ty.Const
+import Test.Tasty
+import Test.Tasty.HUnit
+
+main :: IO ()
+main = defaultMain $
+ testGroup "Jacinda interpreter"
+ [ testCase "parses no error" (parseNoErr sumBytes)
+ , testCase "parse as" (parseTo sumBytes sumBytesAST)
+ , testCase "parse as" (parseTo "#`0>72" pAst)
+ , parseFile "test/examples/ab.jac"
+ , splitWhitespaceT "1 1.3\tj" ["1", "1.3", "j"]
+ , splitWhitespaceT
+ "drwxr-xr-x 12 vanessa staff 384 Dec 26 19:43 _darcs"
+ ["drwxr-xr-x","12","vanessa","staff","384","Dec","26","19:43","_darcs"]
+ , splitWhitespaceT " 55 ./src/Jacinda/File.hs" ["55", "./src/Jacinda/File.hs"]
+ , 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 (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 "type of (tally)" (tyOfT "#'hello world'" tyI)
+ , testCase "typechecks dfn" (tyFile "test/examples/ab.jac")
+ , testCase "parses parens" (tyFile "lib/example.jac")
+ , testCase "typechecks/parses correctly" (tyFile "test/examples/line.jac")
+ ]
+
+pAst :: E ()
+pAst =
+ EApp ()
+ (EApp ()
+ (BBuiltin () Gt)
+ (EApp ()
+ (UBuiltin () Tally)
+ (AllField ())))
+ (IntLit () 72)
+
+splitWhitespaceT :: BS.ByteString -> [BS.ByteString] -> TestTree
+splitWhitespaceT haystack expected =
+ testCase "split col" $
+ toList (splitWhitespace haystack) @?= expected
+
+-- example: ls -l | ja '(+)|0 $5:i'
+sumBytes :: BSL.ByteString
+sumBytes = "(+)|0 $5:i"
+
+krakRegex :: BSL.ByteString
+krakRegex = "{% /Krakatoa/}{`0}"
+
+krakCol :: BSL.ByteString
+krakCol = "{`3:i > 4}{`0}"
+
+sumBytesAST :: E ()
+sumBytesAST =
+ EApp ()
+ (EApp ()
+ (EApp ()
+ (TBuiltin () Fold)
+ (BBuiltin () Plus))
+ (IntLit () 0))
+ (IParseCol () 5)
+
+tyFile :: FilePath -> Assertion
+tyFile = tcIO <=< BSL.readFile
+
+tyOfT :: BSL.ByteString -> T K -> Assertion
+tyOfT src expected =
+ tySrc src @?= expected
+
+parseTo :: BSL.ByteString -> E () -> Assertion
+parseTo src e =
+ case rewriteProgram <$> 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
+
+parseNoErr :: BSL.ByteString -> Assertion
+parseNoErr src =
+ case parse src of
+ Left err -> assertFailure (show err)
+ Right{} -> assertBool "success" True