jacinda (empty) → 0.1.0.0
raw patch · 22 files changed
+3239/−0 lines, 22 filesdep +arraydep +basedep +bytestring
Dependencies added: array, base, bytestring, containers, jacinda, microlens, microlens-mtl, mtl, optparse-applicative, prettyprinter, recursion, regex-rure, tasty, tasty-hunit, text, transformers, vector
Files
- CHANGELOG.md +3/−0
- LICENSE +14/−0
- README.md +73/−0
- app/Main.hs +72/−0
- jacinda.cabal +129/−0
- man/ja.1 +122/−0
- src/Data/List/Ext.hs +13/−0
- src/Intern/Name.hs +30/−0
- src/Intern/Unique.hs +5/−0
- src/Jacinda/AST.hs +365/−0
- src/Jacinda/Backend/Normalize.hs +394/−0
- src/Jacinda/Backend/Printf.hs +47/−0
- src/Jacinda/Backend/TreeWalk.hs +364/−0
- src/Jacinda/File.hs +89/−0
- src/Jacinda/Lexer.x +404/−0
- src/Jacinda/Parser.y +276/−0
- src/Jacinda/Parser/Rewrite.hs +41/−0
- src/Jacinda/Regex.hs +65/−0
- src/Jacinda/Rename.hs +150/−0
- src/Jacinda/Ty.hs +459/−0
- src/Jacinda/Ty/Const.hs +24/−0
- test/Spec.hs +100/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# 0.1.0.0++* Initial release
+ LICENSE view
@@ -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 <http://www.gnu.org/licenses/>.
+ README.md view
@@ -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)+```
+ app/Main.hs view
@@ -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)
+ jacinda.cabal view
@@ -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
+ man/ja.1 view
@@ -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]{%<pattern>}{<expr>}\f[R] Filtered stream on lines matching+<pattern>, defined by <expr>+.PP+\f[B]{<expr>}{<expr>}\f[R] Filtered stream defined by <expr>, on lines+satisfying a boolean expression.+.PP+\f[B]{|<expr>}\f[R] Stream defined by <expr>+.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<vamchale@gmail.com>.
+ src/Data/List/Ext.hs view
@@ -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)
+ src/Intern/Name.hs view
@@ -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
+ src/Intern/Unique.hs view
@@ -0,0 +1,5 @@+module Intern.Unique ( Unique (..)+ ) where++newtype Unique = Unique { unUnique :: Int }+ deriving (Eq, Ord)
+ src/Jacinda/AST.hs view
@@ -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)
+ src/Jacinda/Backend/Normalize.hs view
@@ -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
+ src/Jacinda/Backend/Printf.hs view
@@ -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"
+ src/Jacinda/Backend/TreeWalk.hs view
@@ -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
+ src/Jacinda/File.hs view
@@ -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
+ src/Jacinda/Lexer.x view
@@ -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 :-++ <dfn> {+ 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+ })++}
+ src/Jacinda/Parser.y view
@@ -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)++}
+ src/Jacinda/Parser/Rewrite.hs view
@@ -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
+ src/Jacinda/Regex.hs view
@@ -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
+ src/Jacinda/Rename.hs view
@@ -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.
+ src/Jacinda/Ty.hs view
@@ -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
+ src/Jacinda/Ty/Const.hs view
@@ -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
+ test/Spec.hs view
@@ -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