jl (empty) → 0.1.0
raw patch · 14 files changed
+2894/−0 lines, 14 filesdep +aesondep +aeson-prettydep +attoparsecsetup-changed
Dependencies added: aeson, aeson-pretty, attoparsec, base, bytestring, conduit, conduit-extra, containers, exceptions, jl, mtl, optparse-simple, parsec, scientific, text, unordered-containers, vector
Files
- LICENSE +30/−0
- README.md +505/−0
- Setup.hs +2/−0
- app/Main.hs +150/−0
- jl.cabal +38/−0
- src/JL.hs +35/−0
- src/JL/Functions.hs +952/−0
- src/JL/Inferer.hs +182/−0
- src/JL/Interpreter.hs +80/−0
- src/JL/Parser.hs +263/−0
- src/JL/Printer.hs +117/−0
- src/JL/Serializer.hs +69/−0
- src/JL/Tokenizer.hs +334/−0
- src/JL/Types.hs +137/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Chris Done (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Chris Done nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,505 @@+# jl [](https://travis-ci.org/chrisdone/jl)+jl ("JSON lambda") is a tiny functional language for querying and+manipulating JSON.++Example:++``` haskell+$ jl 'map $ \o -> { sha: o.sha, ps: map _.sha o.parents }' x.json+[{"sha":"7b81a836c31500e685d043729259affa8b670a87","ps":["c538237f4e4c381d35f1c15497c...+```++## Installing++Binary releases for Linux and OS X are available [here](https://github.com/chrisdone/jl/releases).++Builds on Windows (see [AppVeyor status](https://ci.appveyor.com/project/chrisdone/jl)), haven't added Windows+binaries to the releases yet.++Installing from source:++1. Get [stack](https://haskell-lang.org/get-started)+2. Run `stack install` in the repository directory.+3. Add `~/.local/bin/` to your `PATH`.++## Core syntax++Literals:++ 123, 4.5, -6, "hi", null, true, false++Lambdas:++ \x -> y++Function application++ get "f" o++Arithmetic:++ x * (4 + 3)++Objects:++ {foo: 123, bar: 34.3, "a:b": "hi"}++Arrays:++ [1, 4 * 5, id 5]++Conditionals:++ if x then y else z++Short-hand for fields:++ o.f is sugar for get "f" o+ _.f is sugar for (\o -> get "f" o)++For arrays:++ _[0] is sugar for (\o -> get 0 o)++Or objects:++ _[k] is sugar for (\o -> get k o)+ _["foo"] is sugar for (\o -> get "foo" o)++Function composition:++ a | b | c is sugar for `\x -> c (b (a x))`++## Mini tutorial++You do everything with usual functional programming functions.++Returning the same thing, aka identity. That's normal in functional+programming:++``` haskell+jl 'id'+```++A sequence of JSON strings will be read in and processed individually:++E.g.++``` haskell+$ cat x.json | jl id+{"a":1}+{"a":2}+{"a":3}+{"a":4}+```++If you want to read the input in as an array, use `--array`:++``` haskell+$ cat x.json | jl --array 'map _.a'+[1,2,3,4]+```++After processing, sometimes you want to print each element of the+array out line by line, for that use `--lines`:++``` haskell+$ cat x.json | jl --array --lines 'map _.a'+1+2+3+4+```++Taking the first element of something, using syntax that looks like+regular array access. The `_` is a short-hand so that you don't need a+lambda:++``` haskell+jl '_[0]'+```++If you want to get what keys are available, you can run:++``` haskell+jl 'map keys | _[0]'+["sha","committer","url","comments_url","parents","author","html_url","commit"]+```++Taking the first element and then creating a record of some parts of it:++``` haskell+jl '_[0] | \o -> {msg: o.commit.message, n: o.commit.committer.name}'+```++Note the use of `|` to compose functions. Just like in the shell.++Applying a function to all elements in an array:++``` haskell+jl 'map _.commit.committer.name'+```++Note how you can nest property access easily.++Applying something more detailed, by constructing a record of our own++``` haskell+jl 'map $ \o -> {msg: o.commit.message, n: o.commit.committer.name}'+```++You can use `$` to avoid using parentheses on the right. That's a+trick from Haskell.++Applying functions to nested data structures:++``` haskell+jl '_[0] | \o -> {msg: o.commit.message, n: o.commit.committer.name, ps: map _.html_url o.parents }'+```++Notice the `ps` property comes by taking the `html_url` of all the parents.++Filtering is easy, simply write a function that returns true:++``` haskell+jl 'map (\o -> { sha: o.sha, ps: map _.sha o.parents }) | filter (\o -> length o.ps > 1)'+```++If you want to make an object with arbitrary keys that come at runtime, use `set`:++``` haskell+$ echo '"hello"' | jl '\x -> set x 123 {}'+{"hello":123}+```++This sets the key `x` in the empty object `{}` to `"hello"` with the value `123`.+You can use `set` repeatedly to construct more keys.++If you want to construct an object from a list of key/values, you can use `fold`:++```haskell+$ echo '[{"k":"foo","v":123},{"k":"bar","v":456}]' | jl 'fold (\acc o -> set o.k o.v acc) {}'+{"foo":123,"bar":456}+```++# Available functions++## Record access++```haskell+get :: JSON → JSON → JSON+```++Get the value at k from the object++```haskell+set :: JSON → JSON → JSON → JSON+```++Set the value k to v in object++```haskell+modify :: JSON → (JSON → JSON) → JSON → JSON+```++Modify the object at k with function f++```haskell+keys :: JSON → JSON+```++Get all keys of the object++```haskell+elems :: JSON → JSON+```++Get all elements of the object+++## Sequences++```haskell+map :: (JSON → JSON) → JSON → JSON+```++Apply a function to every element in the sequence++```haskell+filter :: (JSON → JSON) → JSON → JSON+```++Keep only items from the sequence for which p returns true++```haskell+takeWhile :: (JSON → JSON) → JSON → JSON+```++Take elements from a sequence while given predicate is true++```haskell+empty :: JSON → JSON+```++Is a sequence empty?++```haskell+length :: JSON → JSON+```++Get the length of a sequence++```haskell+reverse :: JSON → JSON+```++Reverse a sequence++```haskell+drop :: JSON → JSON → JSON+```++Drop n items from the sequence++```haskell+elem :: JSON → JSON → JSON+```++Is x an element of y?++```haskell+concat :: JSON → JSON+```++Concatenate a list of sequences into one sequence++```haskell+zipWith :: (JSON → JSON → JSON) → JSON → JSON → JSON+```++Zip two lists calling with each element to f x y++```haskell+take :: JSON → JSON → JSON+```++Take n items from sequence++```haskell+fold :: (JSON → JSON → JSON) → JSON → JSON → JSON+```++Fold over a structure with a state.++```haskell+dropWhile :: (JSON → JSON) → JSON → JSON+```++Drop elements from a sequence while a predicate is true++```haskell+any :: (JSON → JSON) → JSON → JSON+```++Does p return true for any of the elements?++```haskell+all :: (JSON → JSON) → JSON → JSON+```++Does p return true for all of the elements?++```haskell+nub :: JSON → JSON+```++Return the sequence with no duplicates; the nub of it++```haskell+sort :: JSON → JSON+```++Return the sequence sorted++```haskell+append :: JSON → JSON → JSON+```++Append the members of the second sequence to the first sequence++```haskell+sum :: JSON → JSON+```++Get the sum of a sequence++```haskell+product :: JSON → JSON+```++Get the product of a sequence++```haskell+minimum :: JSON → JSON+```++Get the minimum of a sequence++```haskell+maximum :: JSON → JSON+```++Get the maximum of a sequence+++## Strings++```haskell+words :: JSON → JSON+```++Split the string into a list of words++```haskell+unwords :: JSON → JSON+```++Join the list of strings into a string separated by spaces++```haskell+lines :: JSON → JSON+```++Split the string into a list of lines++```haskell+unlines :: JSON → JSON+```++Join the list of strings into a string separated by lines and terminated by a new line+++## Predicate operators++```haskell+/= :: JSON → JSON → JSON+```++a /= b++```haskell+= :: JSON → JSON → JSON+```++a = b+++## Boolean operators++```haskell+&& :: JSON → JSON → JSON+```++a && b++```haskell+|| :: JSON → JSON → JSON+```++a || b++```haskell+not :: JSON → JSON+```++not b+++## Numeric operators++```haskell+> :: JSON → JSON → JSON+```++a > b++```haskell+< :: JSON → JSON → JSON+```++a < b++```haskell+>= :: JSON → JSON → JSON+```++a >= b++```haskell+<= :: JSON → JSON → JSON+```++a <= b++```haskell+* :: JSON → JSON → JSON+```++a * b++```haskell++ :: JSON → JSON → JSON+```++a + b++```haskell+- :: JSON → JSON → JSON+```++a - b++```haskell+/ :: JSON → JSON → JSON+```++a / b++```haskell+min :: JSON → JSON → JSON+```++a min b++```haskell+max :: JSON → JSON → JSON+```++a max b++```haskell+abs :: JSON → JSON+```++abs b+++## Function combinators++```haskell+id :: JSON → JSON+```++Identity function, returns its input unchanged++```haskell+compose :: (JSON → JSON) → (JSON → JSON) → JSON → JSON+```++Compose two functions++```haskell+flip :: (JSON → JSON → JSON) → JSON → JSON → JSON+```++Flips the argument order of a function of two or more arguments
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++module Main where++import Control.Monad.Writer+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Encode.Pretty as Aeson+import qualified Data.Aeson.Parser as Aeson+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Char8 as L8+import Data.Conduit ( (.|), runConduit)+import Data.Conduit.Attoparsec+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.List as CL+import qualified Data.Map.Strict as M+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.Vector as V+import JL.Functions+import JL.Inferer+import JL.Interpreter+import JL.Parser+import JL.Printer+import JL.Serializer+import JL.Types+import Options.Applicative.Simple+import System.IO++main :: IO ()+main = do+ do hSetBuffering stdout LineBuffering+ hSetBuffering stdin LineBuffering+ ((inp, file, inarray, aslines, browse, markdown, pretty), ()) <-+ simpleOptions+ "0.0.0"+ "jl - JSON Lambda calculus"+ "Command-line language for querying and outputting JSON."+ ((,,,,,,) <$>+ strArgument+ (metavar "CODE" <>+ help "JL code; supports completion of function names" <>+ completeWith (map (\(Variable v) -> T.unpack v) (M.keys context))) <*>+ optional (strArgument (metavar "FILE")) <*>+ flag+ False+ True+ (short 'a' <> long "array" <>+ help "Read each line of input as a single array") <*>+ flag+ False+ True+ (short 'l' <> long "lines" <>+ help+ "Output each element of arrays on a newline suitable for UNIX piping") <*>+ flag+ False+ True+ (long "browse" <> help "Prints out all available functions") <*>+ flag+ False+ True+ (long "browse-markdown" <>+ help "Prints out all available functions, in markdown format") <*>+ flag+ False+ True+ (short 'p' <> long "pretty" <>+ help "Outputs JSON in a human-friendly format"))+ empty+ let block xs =+ if markdown+ then "```haskell\n" <> xs <> "\n```"+ else xs+ if browse || markdown+ then mapM_+ (\(groupname, defs) ->+ T.putStrLn+ (((if markdown+ then "## "+ else "") <>+ groupname) <>+ "\n\n" <>+ T.unlines+ (map+ (\def ->+ (let Variable v = definitionName def+ in block+ (v <> " :: " <>+ prettyType (definitionType def)) <>+ "\n\n" <>+ (if not markdown+ then " "+ else "") <>+ definitionDoc def <>+ "\n"))+ defs)))+ functions+ else case parseText "" (T.pack inp) of+ Left err -> error (show err)+ Right expr0 -> do+ case file of+ Just fp -> do+ bytes <- L.readFile fp+ case Aeson.decode bytes of+ Nothing -> hPutStr stderr "invalid input JSON"+ Just j -> handleJson pretty expr0 aslines j+ Nothing -> process pretty expr0 inarray aslines+ where+ process pretty expr0 inarray aslines = runConduit $+ CB.sourceHandle stdin .| CB.lines .| conduitParserEither Aeson.value .|+ (if inarray+ then do+ es <-+ CL.mapM (either (error . errorMessage) (return . snd)) .|+ CL.consume+ liftIO+ (handleJson pretty expr0 aslines (Aeson.Array (V.fromList es)))+ else CL.mapM_+ (either+ (hPutStrLn stderr . errorMessage)+ (handleJson pretty expr0 aslines . snd))) .|+ CL.sinkNull++-- | Handle a JSON input, printing out one to many JSON values.+handleJson :: Bool -> Expression -> Bool -> Aeson.Value -> IO ()+handleJson pretty expr0 aslines j =+ let expr = ApplicationExpression expr0 (valueToExpression j)+ in case infer context expr (map TypeVariable [1 ..]) of+ !_ ->+ case eval+ (foldl+ (\e (v, f) -> subst v f e)+ (desugar expr)+ (M.toList scope)) of+ v ->+ if aslines+ then mapM_+ L8.putStrLn+ (map Aeson.encode (V.toList (asArray (coreToValue v))))+ else L8.putStrLn (encode' (coreToValue v))+ where asArray =+ \case+ Aeson.Array xs -> xs+ x -> V.singleton x+ encode' =+ if pretty+ then Aeson.encodePretty+ else Aeson.encode
+ jl.cabal view
@@ -0,0 +1,38 @@+name: jl+version: 0.1.0+synopsis: Functional sed for JSON+description: jl ("JSON lambda") is a tiny functional language for querying and manipulating JSON.+homepage: https://github.com/chrisdone/jl#readme+license: BSD3+license-file: LICENSE+author: Chris Done+maintainer: chrisdone@gmail.com+copyright: 2017 Chris Done+category: Development+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ ghc-options: -Wall -O2+ exposed-modules:+ JL+ JL.Parser+ JL.Tokenizer+ JL.Types+ JL.Inferer+ JL.Interpreter+ JL.Printer+ JL.Functions+ JL.Serializer+ build-depends: base >= 4.7 && < 5, attoparsec, mtl, text, containers, aeson >=2, bytestring, vector, parsec, exceptions, text, containers, text, unordered-containers, scientific+ default-language: Haskell2010++executable jl+ hs-source-dirs: app+ main-is: Main.hs+ ghc-options: -Wall -O2 -static+ build-depends: base+ , jl, text, aeson >=2, aeson-pretty, containers, bytestring, mtl, optparse-simple, vector, conduit, conduit-extra+ default-language: Haskell2010
+ src/JL.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++-- | Main library entry point.++module JL where++import Data.Aeson+import Data.ByteString.Lazy (ByteString)+import qualified Data.Map.Strict as M+import Data.Text (Text)+import qualified Data.Text.IO as T+import JL.Functions+import JL.Inferer+import JL.Interpreter+import JL.Parser+import JL.Printer+import JL.Serializer+import JL.Types++repl :: Text -> ByteString -> IO ()+repl inp js =+ case decode js of+ Nothing -> error "Invalid JSON"+ Just j ->+ case parseText "" inp of+ Left err -> error (show err)+ Right expr0 -> do+ T.putStrLn+ (prettyExp expr <> " : " <>+ prettyType (infer context expr (map TypeVariable [1 ..])))+ T.putStrLn+ (prettyCore+ (eval (foldl (\e (v, f) -> subst v f e) (desugar expr) (M.toList scope))))+ where expr = ApplicationExpression expr0 (valueToExpression j)
+ src/JL/Functions.hs view
@@ -0,0 +1,952 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++-- |++module JL.Functions (context, scope, functions) where++import Control.Arrow+import Data.Aeson (Value)+import Data.Function+import qualified Data.HashMap.Strict as HM+import Data.List+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Maybe+import Data.Ord+import Data.Scientific+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Vector as V+import JL.Interpreter+import JL.Serializer+import JL.Types++--------------------------------------------------------------------------------+-- Lists++-- | The typing context.+context :: Map Variable Type+context = M.fromList (map (definitionName &&& definitionType) (concatMap snd functions))++-- | Bindings available in scope.+scope :: Map Variable Core+scope = M.fromList (map (definitionName &&&definitionCore) (concatMap snd functions))++-- | All functions.+functions :: [(Text, [Definition])]+functions =+ [ ("Record access", [getf, setf, modifyf, keysf, elemsf])+ , ( "Sequences"+ , [ mapf+ , filterf+ , takeWhilef+ , empty+ , len+ , rev+ , dropf+ , elemf+ , concatf+ , zipw+ , takef+ , foldf+ , dropWhilef+ , anyf+ , allf+ , nubf+ , sortf+ , appendf+ , sumf+ , productf+ , minimumf+ , maximumf+ ])+ , ("Strings", [wordsf, unwordsf, linesf, unlinesf])+ , ( "Predicate operators"+ , [predicateOperator "/=" (/=), predicateOperator "=" (==)])+ , ( "Boolean operators"+ , [boolOperator "&&" (&&), boolOperator "||" (||), boolFun "not" not])+ , ( "Numeric operators"+ , [ numericPredicateOperator ">" (>)+ , numericPredicateOperator "<" (<)+ , numericPredicateOperator ">=" (>=)+ , numericPredicateOperator "<=" (<=)+ , arithmeticOperator "*" (*)+ , arithmeticOperator "+" (+)+ , arithmeticOperator "-" (-)+ , arithmeticOperator "/" (/)+ , arithmeticOperator "min" min+ , arithmeticOperator "max" max+ , arithmeticFun "abs" abs+ ])+ , ("Function combinators", [idf, compose, flipf])+ ]++--------------------------------------------------------------------------------+-- Functions++keysf :: Definition+keysf =+ Definition+ { definitionDoc = "Get all keys of the object"+ , definitionName = Variable "keys"+ , definitionCore =+ (EvalCore+ (\obj ->+ case obj of+ RecordCore o ->+ ArrayCore+ (V.fromList (map (ConstantCore . StringConstant) (HM.keys o)))+ _ -> error "keys function expected an object"))+ , definitionType = FunctionType JSONType JSONType+ }++elemsf :: Definition+elemsf =+ Definition+ { definitionDoc = "Get all elements of the object"+ , definitionName = Variable "elems"+ , definitionCore =+ (EvalCore+ (\obj ->+ case obj of+ RecordCore o ->+ ArrayCore+ (V.fromList (HM.elems o))+ _ -> error "elems function expected an object"))+ , definitionType = FunctionType JSONType JSONType+ }++modifyf :: Definition+modifyf =+ Definition+ { definitionDoc = "Modify the object at k with function f"+ , definitionName = Variable "modify"+ , definitionCore =+ (EvalCore+ (\key ->+ EvalCore+ (\f ->+ EvalCore+ (\obj ->+ case (key, obj) of+ (ConstantCore (StringConstant k), (RecordCore o)) ->+ (RecordCore+ (HM.adjust (\v -> eval (ApplicationCore f v)) k o))+ _ -> error "type error for args to modify"))))+ , definitionType =+ FunctionType+ JSONType+ (FunctionType+ (FunctionType JSONType JSONType)+ (FunctionType JSONType JSONType))+ }++getf :: Definition+getf =+ Definition+ { definitionDoc = "Get the value at k from the object"+ , definitionName = Variable "get"+ , definitionCore =+ (EvalCore+ (\key ->+ EvalCore+ (\obj ->+ case (key, obj) of+ (ConstantCore (StringConstant k), RecordCore o) ->+ (case HM.lookup k o of+ Nothing -> error ("missing key " <> show k)+ Just v -> v)+ (ConstantCore (NumberConstant i), (ArrayCore v)) ->+ (case v V.!? (round i) of+ Nothing -> error ("missing array index " <> show i)+ Just v' -> v')+ _ -> error "type error for get arguments")))+ , definitionType = FunctionType JSONType (FunctionType JSONType JSONType)+ }++setf :: Definition+setf =+ Definition+ { definitionDoc = "Set the value k to v in object"+ , definitionName = Variable "set"+ , definitionCore =+ (EvalCore+ (\key ->+ EvalCore+ (\val ->+ EvalCore+ (\obj ->+ case (key, val, obj) of+ (ConstantCore (StringConstant k), v, RecordCore o) ->+ (RecordCore (HM.insert k v o))+ _ -> error "type error in arguments to: set"))))+ , definitionType =+ FunctionType+ JSONType+ (FunctionType JSONType (FunctionType JSONType JSONType))+ }++idf :: Definition+idf =+ Definition+ { definitionDoc = "Identity function, returns its input unchanged"+ , definitionName = Variable "id"+ , definitionCore = (EvalCore (\x -> x))+ , definitionType = FunctionType JSONType JSONType+ }++flipf :: Definition+flipf =+ Definition+ { definitionDoc = "Flips the argument order of a function of two or more arguments"+ , definitionName = Variable "flip"+ , definitionCore =+ (EvalCore+ (\f ->+ EvalCore+ (\x ->+ EvalCore (\y -> eval (ApplicationCore (ApplicationCore f y) x)))))+ , definitionType =+ FunctionType+ (FunctionType JSONType (FunctionType JSONType JSONType))+ (FunctionType JSONType (FunctionType JSONType JSONType))+ }++compose :: Definition+compose =+ Definition+ { definitionDoc = "Compose two functions"+ , definitionName = Variable "compose"+ , definitionCore =+ EvalCore+ (\f ->+ EvalCore+ (\g ->+ EvalCore (\x -> eval (ApplicationCore g (ApplicationCore f x)))))+ , definitionType =+ FunctionType+ (FunctionType JSONType JSONType)+ (FunctionType+ (FunctionType JSONType JSONType)+ (FunctionType JSONType JSONType))+ }++foldf :: Definition+foldf =+ Definition+ { definitionDoc = "Fold over a structure with a state."+ , definitionName = Variable "fold"+ , definitionCore =+ EvalCore+ (\cons ->+ EvalCore+ (\nil ->+ EvalCore+ (\xs ->+ case xs of+ ArrayCore xs' ->+ (V.foldl+ (\acc x ->+ eval+ (ApplicationCore (ApplicationCore cons acc) x))+ nil+ xs')+ ConstantCore (StringConstant xs') ->+ (T.foldl+ (\acc x ->+ eval+ (ApplicationCore+ (ApplicationCore cons acc)+ (ConstantCore+ (StringConstant (T.singleton x)))))+ nil+ xs')+ _ -> error "can only fold sequences")))+ , definitionType =+ (FunctionType+ ((FunctionType JSONType (FunctionType JSONType JSONType)))+ (FunctionType JSONType (FunctionType JSONType JSONType)))+ }++zipw :: Definition+zipw =+ Definition+ { definitionDoc = "Zip two lists calling with each element to f x y"+ , definitionName = Variable "zipWith"+ , definitionCore =+ EvalCore+ (\f ->+ EvalCore+ (\xs ->+ EvalCore+ (\ys ->+ case (xs, ys) of+ (ArrayCore xs', ArrayCore ys') ->+ (ArrayCore+ (V.zipWith+ (\x y ->+ eval (ApplicationCore (ApplicationCore f x) y))+ xs'+ ys'))+ _ -> error "can only zip two arrays")))+ , definitionType =+ FunctionType+ (FunctionType JSONType (FunctionType JSONType JSONType))+ (FunctionType JSONType (FunctionType JSONType JSONType))+ }++elemf :: Definition+elemf =+ Definition+ { definitionDoc = "Is x an element of y?"+ , definitionName = Variable "elem"+ , definitionCore =+ EvalCore+ (\n ->+ EvalCore+ (\xs ->+ case xs of+ (ArrayCore xs') ->+ (ConstantCore+ (BoolConstant+ (V.elem (coreToValue n) (fmap coreToValue xs'))))+ (ConstantCore (StringConstant xs')) ->+ (ConstantCore+ (BoolConstant+ (isJust+ (T.findIndex+ (\cc ->+ case n of+ ConstantCore (StringConstant c) ->+ c == T.singleton cc+ _ -> False)+ xs'))))+ _ ->+ error+ "can only check elements from sequences"))+ , definitionType = FunctionType JSONType (FunctionType JSONType JSONType)+ }++takef :: Definition+takef =+ Definition+ { definitionDoc = "Take n items from sequence"+ , definitionName = Variable "take"+ , definitionCore =+ EvalCore+ (\n ->+ EvalCore+ (\xs ->+ case (n, xs) of+ (ConstantCore (NumberConstant n'), ArrayCore xs') ->+ (ArrayCore (V.take (round n') xs'))+ (ConstantCore (NumberConstant n'), ConstantCore (StringConstant xs')) ->+ (ConstantCore (StringConstant (T.take (round n') xs')))+ _ -> error "can only take from sequences"))+ , definitionType = FunctionType JSONType (FunctionType JSONType JSONType)+ }++dropf :: Definition+dropf =+ Definition+ { definitionDoc = "Drop n items from the sequence"+ , definitionName = Variable "drop"+ , definitionCore =+ EvalCore+ (\n ->+ EvalCore+ (\xs ->+ case (n, xs) of+ (ConstantCore (NumberConstant n'), ConstantCore (StringConstant xs')) ->+ (ConstantCore (StringConstant (T.drop (round n') xs')))+ (ConstantCore (NumberConstant n'), ArrayCore xs') ->+ (ArrayCore (V.drop (round n') xs'))+ _ -> error "can only drop from sequences"))+ , definitionType = FunctionType JSONType (FunctionType JSONType JSONType)+ }++concatf :: Definition+concatf =+ Definition+ { definitionDoc = "Concatenate a list of sequences into one sequence"+ , definitionName = Variable "concat"+ , definitionCore =+ (EvalCore+ (\xs ->+ case xs of+ (ArrayCore xs') ->+ (ArrayCore (V.concat (map coreToArray (V.toList xs'))))+ _ -> error "can only concat arrays"))+ , definitionType = FunctionType JSONType JSONType+ }++rev :: Definition+rev =+ Definition+ { definitionDoc = "Reverse a sequence"+ , definitionName = Variable "reverse"+ , definitionCore =+ (EvalCore+ (\xs ->+ case xs of+ (ArrayCore xs') -> (ArrayCore (V.reverse xs'))+ (ConstantCore (StringConstant xs')) ->+ (ConstantCore (StringConstant (T.reverse xs')))+ _ -> error "can only reverse a sequence"))+ , definitionType = FunctionType JSONType JSONType+ }++appendf :: Definition+appendf =+ Definition+ { definitionDoc = "Append the members of the second sequence to the first sequence"+ , definitionName = Variable "append"+ , definitionCore =+ (EvalCore+ (\xs ->+ (EvalCore+ (\ys ->+ case (xs, ys) of+ (ArrayCore xs', ArrayCore ys') -> (ArrayCore (xs' <> ys'))+ (ConstantCore (StringConstant xs'), ConstantCore (StringConstant ys')) ->+ (ConstantCore (StringConstant (xs' <> ys')))+ _ -> error "can only append two sequences of the same type"))))+ , definitionType = FunctionType JSONType (FunctionType JSONType JSONType)+ }++nubf :: Definition+nubf =+ Definition+ { definitionDoc = "Return the sequence with no duplicates; the nub of it"+ , definitionName = Variable "nub"+ , definitionCore =+ (EvalCore+ (\xs ->+ case xs of+ (ArrayCore xs') ->+ (ArrayCore+ (V.fromList (nubBy (on (==) coreToValue) (V.toList xs'))))+ (ConstantCore (StringConstant xs')) ->+ (ConstantCore+ (StringConstant+ (T.pack (nub (T.unpack xs')))))+ _ -> error "can only nub a sequence"))+ , definitionType = FunctionType JSONType JSONType+ }++linesf :: Definition+linesf =+ Definition+ { definitionDoc = "Split the string into a list of lines"+ , definitionName = Variable "lines"+ , definitionCore =+ (EvalCore+ (\xs ->+ case xs of+ (ConstantCore (StringConstant xs')) ->+ (ArrayCore+ (V.map+ (ConstantCore . StringConstant)+ ((V.fromList (T.lines xs')))))+ _ -> error "can only lines a string"))+ , definitionType = FunctionType JSONType JSONType+ }++wordsf :: Definition+wordsf =+ Definition+ { definitionDoc = "Split the string into a list of words"+ , definitionName = Variable "words"+ , definitionCore =+ (EvalCore+ (\xs ->+ case xs of+ (ConstantCore (StringConstant xs')) ->+ (ArrayCore+ (V.map+ (ConstantCore . StringConstant)+ ((V.fromList (T.words xs')))))+ _ -> error "can only words a string"))+ , definitionType = FunctionType JSONType JSONType+ }++unwordsf :: Definition+unwordsf =+ Definition+ { definitionDoc = "Join the list of strings into a string separated by spaces"+ , definitionName = Variable "unwords"+ , definitionCore =+ (EvalCore+ (\xs ->+ case xs of+ (ArrayCore xs') ->+ (ConstantCore (StringConstant (T.unwords (V.toList (fmap coreToString xs')))))+ _ -> error "can only unwords a string"))+ , definitionType = FunctionType JSONType JSONType+ }++unlinesf :: Definition+unlinesf =+ Definition+ { definitionDoc = "Join the list of strings into a string separated by lines and terminated by a new line"+ , definitionName = Variable "unlines"+ , definitionCore =+ (EvalCore+ (\xs ->+ case xs of+ (ArrayCore xs') ->+ (ConstantCore (StringConstant (T.unlines (V.toList (fmap coreToString xs')))))+ _ -> error "can only unlines a string"))+ , definitionType = FunctionType JSONType JSONType+ }++sortf :: Definition+sortf =+ Definition+ { definitionDoc = "Return the sequence sorted"+ , definitionName = Variable "sort"+ , definitionCore =+ (EvalCore+ (\xs ->+ case xs of+ (ArrayCore xs') ->+ (ArrayCore+ (V.fromList (sortBy (comparing coreToCompare) (V.toList xs'))))+ (ConstantCore (StringConstant xs')) ->+ (ConstantCore+ (StringConstant+ (T.pack (sort (T.unpack xs')))))+ _ -> error "can only sort a sequence"))+ , definitionType = FunctionType JSONType JSONType+ }++len :: Definition+len =+ Definition+ { definitionDoc = "Get the length of a sequence"+ , definitionName = Variable "length"+ , definitionCore =+ (EvalCore+ (\xs ->+ case xs of+ (ArrayCore xs') ->+ (ConstantCore (NumberConstant (fromIntegral (V.length xs'))))+ (ConstantCore (StringConstant xs')) ->+ (ConstantCore (NumberConstant (fromIntegral (T.length xs'))))+ _ -> error "can only take length of sequences"))+ , definitionType = FunctionType JSONType JSONType+ }++sumf :: Definition+sumf =+ Definition+ { definitionDoc = "Get the sum of a sequence"+ , definitionName = Variable "sum"+ , definitionCore =+ (EvalCore+ (\xs ->+ case xs of+ (ArrayCore xs') ->+ (ConstantCore (NumberConstant (V.sum (fmap coreToNumber xs'))))+ _ -> error "can only take sum of arrays"))+ , definitionType = FunctionType JSONType JSONType+ }++productf :: Definition+productf =+ Definition+ { definitionDoc = "Get the product of a sequence"+ , definitionName = Variable "product"+ , definitionCore =+ (EvalCore+ (\xs ->+ case xs of+ (ArrayCore xs') ->+ (ConstantCore (NumberConstant (V.product (fmap coreToNumber xs'))))+ _ -> error "can only take product of arrays"))+ , definitionType = FunctionType JSONType JSONType+ }++maximumf :: Definition+maximumf =+ Definition+ { definitionDoc = "Get the maximum of a sequence"+ , definitionName = Variable "maximum"+ , definitionCore =+ (EvalCore+ (\xs ->+ case xs of+ (ArrayCore xs') ->+ (ConstantCore (NumberConstant (V.maximum (fmap coreToNumber xs'))))+ _ -> error "can only take maximum of arrays"))+ , definitionType = FunctionType JSONType JSONType+ }++minimumf :: Definition+minimumf =+ Definition+ { definitionDoc = "Get the minimum of a sequence"+ , definitionName = Variable "minimum"+ , definitionCore =+ (EvalCore+ (\xs ->+ case xs of+ (ArrayCore xs') ->+ (ConstantCore (NumberConstant (V.minimum (fmap coreToNumber xs'))))+ _ -> error "can only take minimum of arrays"))+ , definitionType = FunctionType JSONType JSONType+ }++empty :: Definition+empty =+ Definition+ { definitionDoc = "Is a sequence empty?"+ , definitionName = Variable "empty"+ , definitionCore =+ (EvalCore+ (\xs ->+ case xs of+ (ArrayCore xs') -> (ConstantCore (BoolConstant (V.null xs')))+ (ConstantCore (StringConstant xs')) ->+ (ConstantCore (BoolConstant (T.null xs')))+ _ -> error "can only check if sequences are empty"))+ , definitionType = FunctionType JSONType JSONType+ }++anyf :: Definition+anyf =+ Definition+ { definitionDoc = "Does p return true for any of the elements?"+ , definitionName = Variable "any"+ , definitionCore =+ EvalCore+ (\f ->+ EvalCore+ (\xs ->+ case xs of+ (ArrayCore xs') ->+ (ConstantCore+ (BoolConstant+ (V.any+ (\x ->+ case eval (ApplicationCore f x) of+ ConstantCore (BoolConstant b) -> b+ _ -> True)+ xs')))+ (ConstantCore (StringConstant xs')) ->+ (ConstantCore+ (BoolConstant+ (T.any+ (\x ->+ case eval+ (ApplicationCore+ f+ (ConstantCore+ (StringConstant (T.singleton x)))) of+ ConstantCore (BoolConstant b) -> b+ _ -> True)+ xs')))+ _ -> error "can only any over sequences"))+ , definitionType =+ FunctionType+ (FunctionType JSONType JSONType)+ (FunctionType JSONType JSONType)+ }++allf :: Definition+allf =+ Definition+ { definitionDoc = "Does p return true for all of the elements?"+ , definitionName = Variable "all"+ , definitionCore =+ EvalCore+ (\f ->+ EvalCore+ (\xs ->+ case xs of+ (ArrayCore xs') ->+ (ConstantCore+ (BoolConstant+ (V.all+ (\x ->+ case eval (ApplicationCore f x) of+ ConstantCore (BoolConstant b) -> b+ _ -> True)+ xs')))+ (ConstantCore (StringConstant xs')) ->+ (ConstantCore+ (BoolConstant+ (T.all+ (\x ->+ case eval+ (ApplicationCore+ f+ (ConstantCore+ (StringConstant (T.singleton x)))) of+ ConstantCore (BoolConstant b) -> b+ _ -> True)+ xs')))+ _ -> error "can only all over sequences"))+ , definitionType =+ FunctionType+ (FunctionType JSONType JSONType)+ (FunctionType JSONType JSONType)+ }++dropWhilef :: Definition+dropWhilef =+ Definition+ { definitionDoc = "Drop elements from a sequence while a predicate is true"+ , definitionName = Variable "dropWhile"+ , definitionCore =+ EvalCore+ (\f ->+ EvalCore+ (\xs ->+ case xs of+ (ArrayCore xs') ->+ (ArrayCore+ (V.dropWhile+ (\x ->+ case eval (ApplicationCore f x) of+ ConstantCore (BoolConstant b) -> b+ _ -> True)+ xs'))+ (ConstantCore (StringConstant xs')) ->+ (ConstantCore+ (StringConstant+ (T.dropWhile+ (\x ->+ case eval+ (ApplicationCore+ f+ (ConstantCore+ (StringConstant (T.singleton x)))) of+ ConstantCore (BoolConstant b) -> b+ _ -> True)+ xs')))+ _ -> error "can only dropWhile over sequences"))+ , definitionType =+ FunctionType+ (FunctionType JSONType JSONType)+ (FunctionType JSONType JSONType)+ }++takeWhilef :: Definition+takeWhilef =+ Definition+ { definitionDoc =+ "Take elements from a sequence while given predicate is true"+ , definitionName = Variable "takeWhile"+ , definitionCore =+ (EvalCore+ (\f ->+ EvalCore+ (\xs ->+ case xs of+ (ConstantCore (StringConstant xs')) ->+ (ConstantCore+ (StringConstant+ (T.takeWhile+ (\x ->+ case eval+ (ApplicationCore+ f+ (ConstantCore+ (StringConstant (T.singleton x)))) of+ ConstantCore (BoolConstant b) -> b+ _ -> True)+ xs')))+ (ArrayCore xs') ->+ (ArrayCore+ (V.takeWhile+ (\x ->+ case eval (ApplicationCore f x) of+ ConstantCore (BoolConstant b) -> b+ _ -> True)+ xs'))+ _ -> error "can only takeWhile over sequences")))+ , definitionType =+ FunctionType+ (FunctionType JSONType JSONType)+ (FunctionType JSONType JSONType)+ }++filterf :: Definition+filterf =+ Definition+ { definitionDoc = "Keep only items from the sequence for which p returns true"+ , definitionName = Variable "filter"+ , definitionCore =+ EvalCore+ (\f ->+ EvalCore+ (\xs ->+ case xs of+ (ConstantCore (StringConstant xs')) ->+ (ConstantCore+ (StringConstant+ (T.filter+ (\x ->+ case eval+ (ApplicationCore+ f+ (ConstantCore+ (StringConstant (T.singleton x)))) of+ ConstantCore (BoolConstant b) -> b+ _ -> True)+ xs')))+ (ArrayCore xs') ->+ (ArrayCore+ (V.filter+ (\x ->+ case eval (ApplicationCore f x) of+ ConstantCore (BoolConstant b) -> b+ _ -> True)+ xs'))+ _ -> error "can only filter over sequences"))+ , definitionType =+ FunctionType+ (FunctionType JSONType JSONType)+ (FunctionType JSONType JSONType)+ }++mapf :: Definition+mapf =+ Definition+ { definitionDoc = "Apply a function to every element in the sequence"+ , definitionName = Variable "map"+ , definitionCore =+ EvalCore+ (\f ->+ EvalCore+ (\xs ->+ case xs of+ (ConstantCore (StringConstant xs')) ->+ (ConstantCore+ (StringConstant+ (T.concatMap+ (\x ->+ case eval+ (ApplicationCore+ f+ (ConstantCore+ (StringConstant (T.singleton x)))) of+ ConstantCore (StringConstant b) -> b+ _ -> error "map over a string must return strings")+ xs')))+ (ArrayCore xs') ->+ (ArrayCore (fmap (\x -> (eval (ApplicationCore f (x)))) xs'))+ _ -> error "can only map over sequences"))+ , definitionType =+ FunctionType+ (FunctionType JSONType JSONType)+ (FunctionType JSONType JSONType)+ }++--------------------------------------------------------------------------------+-- Function builders++arithmeticOperator :: Text -> (Scientific -> Scientific -> Scientific) -> Definition+arithmeticOperator name f =+ Definition+ { definitionName = Variable name+ , definitionCore =+ EvalCore+ (\x ->+ EvalCore+ (\y ->+ case (x, y) of+ (ConstantCore (NumberConstant a), ConstantCore (NumberConstant b)) ->+ ConstantCore (NumberConstant (f a b))+ _ -> error ("type error for arguments to " <> show name)))+ , definitionType = JSONType .-> JSONType .-> JSONType+ , definitionDoc = "a " <> name <> " b"+ }++boolOperator :: Text -> (Bool -> Bool -> Bool) -> Definition+boolOperator name f =+ Definition+ { definitionName = Variable name+ , definitionCore =+ EvalCore+ (\x ->+ EvalCore+ (\y ->+ case (x, y) of+ (ConstantCore (BoolConstant a), ConstantCore (BoolConstant b)) ->+ ConstantCore (BoolConstant (f a b))+ _ -> error ("type error for arguments to " <> show name)))+ , definitionType = JSONType .-> JSONType .-> JSONType+ , definitionDoc = "a " <> name <> " b"+ }++arithmeticFun :: Text -> (Scientific -> Scientific) -> Definition+arithmeticFun name f =+ Definition+ { definitionName = Variable name+ , definitionCore =+ EvalCore+ (\x ->+ case (x) of+ (ConstantCore (NumberConstant a)) ->+ ConstantCore (NumberConstant (f a))+ _ -> error ("type error for arguments to " <> show name))+ , definitionType = JSONType .-> JSONType+ , definitionDoc = name <> " b"+ }++boolFun :: Text -> (Bool -> Bool) -> Definition+boolFun name f =+ Definition+ { definitionName = Variable name+ , definitionCore =+ EvalCore+ (\x ->+ case (x) of+ (ConstantCore (BoolConstant a)) ->+ ConstantCore (BoolConstant (f a))+ _ -> error ("type error for arguments to " <> show name))+ , definitionType = JSONType .-> JSONType+ , definitionDoc = name <> " b"+ }++predicateOperator :: Text -> (Value -> Value -> Bool) -> Definition+predicateOperator name f =+ Definition+ { definitionName = Variable name+ , definitionCore =+ EvalCore+ (\x ->+ EvalCore+ (\y ->+ ConstantCore (BoolConstant (f (coreToValue x) (coreToValue y)))))+ , definitionType = JSONType .-> JSONType .-> JSONType+ , definitionDoc = "a " <> name <> " b"+ }++numericPredicateOperator :: Text -> (Scientific -> Scientific -> Bool) -> Definition+numericPredicateOperator name f =+ Definition+ { definitionName = Variable name+ , definitionCore =+ EvalCore+ (\x ->+ EvalCore+ (\y ->+ case (x, y) of+ (ConstantCore (NumberConstant a), ConstantCore (NumberConstant b)) ->+ ConstantCore (BoolConstant (f a b))+ _ -> error ("type error for arguments to " <> show name)))+ , definitionType = JSONType .-> JSONType .-> JSONType+ , definitionDoc = "a " <> name <> " b"+ }++--------------------------------------------------------------------------------+-- Handy combinators++-- | Type a -> b.+(.->) :: Type -> Type -> Type+a .-> b = FunctionType a b+infixr 9 .->
+ src/JL/Inferer.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}++-- |++module JL.Inferer where+++import Control.Monad.State.Strict+import qualified Data.HashMap.Strict as HM+import Data.Map (Map)+import qualified Data.Map as M+import Data.Set (Set)+import qualified Data.Set as S+import Data.Text (Text)+import qualified Data.Text as T+import JL.Printer+import JL.Types++-- | Get the type of the expression.+infer :: Map Variable Type -> Expression -> [TypeVariable] -> Type+infer ctx t stream =+ case evalState (check ctx t) stream of+ (ty, cs) ->+ let s = evalState (unify (S.toList cs)) ()+ in replace s ty++-- | Check the exp with the given context.+check+ :: MonadState ([TypeVariable]) m+ => Map Variable Type -> Expression -> m (Type, Set (Type, Type))+check ctx expr =+ case expr of+ VariableExpression name@(Variable text) ->+ case M.lookup name ctx of+ Nothing -> error ("Not in scope: `" <> T.unpack text <> "'")+ Just typ -> return (typ, mempty)+ LambdaExpression x body -> do+ sym <- generateTypeVariable+ let xty = VariableType sym+ (rty, cs) <- check (M.insert x xty ctx) body+ return (FunctionType xty rty, cs)+ ConstantExpression {} -> return (JSONType, mempty)+ ApplicationExpression f x -> do+ (fty, cs1) <- check ctx f+ (xty, cs2) <- check ctx x+ sym <- generateTypeVariable+ let rty = VariableType sym+ cs = S.insert (fty, FunctionType xty rty) (cs1 <> cs2)+ return (rty, cs)+ InfixExpression l f r -> do+ (fty, cs1) <- check ctx (VariableExpression f)+ (ty1, cs2) <- check ctx l+ (ty2, cs3) <- check ctx r+ sym <- generateTypeVariable+ let rty = VariableType sym+ cs =+ S.insert+ (fty, FunctionType ty1 (FunctionType ty2 rty))+ (cs1 <> cs2 <> cs3)+ return (rty, cs)+ IfExpression cond a b -> do+ (condty, cs1) <- check ctx cond+ (aty, cs2) <- check ctx a+ (bty, cs3) <- check ctx b+ sym <- generateTypeVariable+ let rty = VariableType sym+ cs =+ S.insert+ (condty, JSONType)+ (S.insert (aty, bty) (cs1 <> cs2 <> cs3))+ pure (rty, cs)+ RecordExpression pairs -> do+ cs <-+ foldM+ (\cs (_, e) -> do+ (pty, cs') <- check ctx e+ pure (S.insert (pty, JSONType) (cs <> cs')))+ mempty+ (HM.toList pairs)+ pure (JSONType, cs)+ SubscriptExpression e ks -> do+ (t1, c1) <-+ (case e of+ ExpressionSubscripted es -> check ctx es+ WildcardSubscripted -> pure (FunctionType JSONType JSONType, mempty))+ cs <-+ foldM+ (\cs s ->+ case s of+ PropertySubscript {} -> pure cs+ ExpressionSubscript es -> do+ (pty, cs') <- check ctx es+ pure (S.insert (pty, JSONType) (cs <> cs')))+ c1+ ks+ let rty = case e of+ WildcardSubscripted -> FunctionType JSONType JSONType+ _ -> JSONType+ pure+ ( rty+ , S.insert (t1, rty) cs)+ ArrayExpression as -> do+ cs <-+ foldM+ (\cs e -> do+ (pty, cs') <- check ctx e+ pure (S.insert (pty, JSONType) (cs <> cs')))+ mempty+ as+ pure (JSONType, cs)++-- | Generate a fresh type variable.+generateTypeVariable+ :: MonadState ([TypeVariable]) m+ => m TypeVariable+generateTypeVariable =+ get >>= \case+ v:vs -> do+ put vs+ pure v+ _ ->+ error "Ran out of type variables"++-- | Unify the list of constraints.+unify+ :: Monad m+ => [(Type, Type)] -> m (Map TypeVariable Type)+unify [] = return mempty+unify ((a, b):cs)+ | a == b = unify cs+ | VariableType v <- a = unifyVariable v cs a b+ | VariableType v <- b = unifyVariable v cs b a+ | FunctionType a1 b1 <- a+ , FunctionType a2 b2 <- b = unify ([(a1, a2), (b1, b2)] <> cs)+ | otherwise =+ error+ (T.unpack+ ("Type " <> quote (prettyType a) <> " doesn't match " <>+ quote (prettyType b)))++-- | Unify a type variable for two types.+unifyVariable+ :: Monad m+ => TypeVariable -> [(Type, Type)] -> Type -> Type -> m (Map TypeVariable Type)+unifyVariable v cs a b =+ if occurs v b+ then error+ (T.unpack ("Occurs check: " <> prettyType a <> " ~ " <> prettyType b))+ else let subbed = M.singleton v b+ in do rest <- unify (substitute subbed cs)+ return (rest <> subbed)++-- | Occurs check.+occurs :: TypeVariable -> Type -> Bool+occurs x (VariableType y)+ | x == y = True+ | otherwise = False+occurs x (FunctionType a b) = occurs x a || occurs x b+occurs _ JSONType = False++-- | Substitute the unified type into the constraints.+substitute :: Map TypeVariable Type -> [(Type, Type)] -> [(Type, Type)]+substitute subs = map go+ where+ go (a, b) = (replace subs a, replace subs b)++-- | Apply a substitution to a type.+replace :: Map TypeVariable Type -> Type -> Type+replace s' t' = M.foldrWithKey go t' s'+ where+ go s1 t (VariableType s2)+ | s1 == s2 = t+ | otherwise = VariableType s2+ go s t (FunctionType t2 t3) = FunctionType (go s t t2) (go s t t3)+ go _ _ JSONType = JSONType++-- | Quote something for showing to the programmer.+quote :: Text -> Text+quote t = "‘" <> t <> "’"
+ src/JL/Interpreter.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}++-- |++module JL.Interpreter where++import qualified Data.Text as T+import JL.Printer+import JL.Types++-- | Eval core.+eval :: Core -> Core+eval (ApplicationCore op arg) =+ case eval op of+ LambdaCore param expr ->+ case eval arg of+ a@VariableCore {} ->+ error (T.unpack (prettyCore a <> " is not in scope!"))+ a -> eval (subst param a expr)+ EvalCore f -> f (eval arg)+ _ -> error (T.unpack (prettyCore op <> " is not a function!"))+eval (IfCore c a b) =+ case eval c of+ ConstantCore (BoolConstant True) -> eval a+ ConstantCore (BoolConstant False) -> eval b+ _ -> error ("type error for if condition, should be bool")+eval (RecordCore hms) =+ RecordCore (fmap eval hms)+eval (ArrayCore hms) =+ ArrayCore (fmap eval hms)+eval e = e++-- | Substitute name in function body.+subst :: Variable -> Core -> Core -> Core+subst name val e@(VariableCore name')+ | name == name' = val+ | otherwise = e+subst name val (LambdaCore name' e)+ | name /= name' = LambdaCore name' (subst name val e)+subst name val (ApplicationCore f a) =+ ApplicationCore (subst name val f) (subst name val a)+subst name val (IfCore f a b) =+ IfCore (subst name val f) (subst name val a) (subst name val b)+subst name val (RecordCore hm) = RecordCore (fmap (subst name val) hm)+subst name val (ArrayCore hm) = ArrayCore (fmap (subst name val) hm)+subst _ _ e = e++-- | Remove syntactic sugar and convert into executable form.+desugar :: Expression -> Core+desugar =+ \case+ (InfixExpression a f b) ->+ ApplicationCore (ApplicationCore (VariableCore f) (desugar a)) (desugar b)+ VariableExpression v -> VariableCore v+ LambdaExpression v e -> LambdaCore v (desugar e)+ ApplicationExpression f a -> ApplicationCore (desugar f) (desugar a)+ IfExpression a b c -> IfCore (desugar a) (desugar b) (desugar c)+ RecordExpression pars -> RecordCore (fmap desugar pars)+ ArrayExpression as -> ArrayCore (fmap desugar as)+ ConstantExpression c -> ConstantCore c+ SubscriptExpression subscripted subscripts ->+ let index =+ \c k ->+ ApplicationCore+ (ApplicationCore+ (VariableCore (Variable "get"))+ (case k of+ ExpressionSubscript e -> desugar e+ PropertySubscript t -> ConstantCore (StringConstant t)))+ c+ in case subscripted of+ WildcardSubscripted ->+ LambdaCore+ (Variable "a'")+ (foldl index (VariableCore (Variable "a'")) subscripts)+ ExpressionSubscripted e -> foldl index (desugar e) subscripts
+ src/JL/Parser.hs view
@@ -0,0 +1,263 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- |++module JL.Parser where++import Control.Monad.Catch+import Data.Functor+import qualified Data.HashMap.Strict as HM+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Vector as V+import JL.Tokenizer+import JL.Types+import Text.Parsec hiding (satisfy, anyToken)++parseText :: MonadThrow m => SourceName -> Text -> m Expression+parseText fp inp =+ case parse tokensTokenizer fp (inp) of+ Left e -> throwM (TokenizerError e)+ Right tokens' ->+ case runParser (expressionParser <* endOfTokens) 0 fp tokens' of+ Left e -> throwM (ParserError e)+ Right ast -> pure ast++expressionParser :: TokenParser Expression+expressionParser = pipes+ where+ pipes = do+ ps <- sepBy1 dollars (equalToken Bar)+ case ps of+ [p] -> pure p+ [] -> unexpected "empty expression"+ (p:ps') ->+ pure+ (foldl+ (\x y ->+ ApplicationExpression+ (ApplicationExpression+ (VariableExpression (Variable "compose"))+ x)+ y)+ p+ ps')+ dollars = do+ ps <- sepBy1 dollarable (equalToken Dollar)+ case ps of+ [p] -> pure p+ (p:ps') -> pure (foldl ApplicationExpression p ps')+ [] -> unexpected "empty expression"+ where+ dollarable =+ array <|> record <|> lambda <|> ifParser <|> infix' <|> app <|> atomic+ array = do+ void (equalToken OpenBracket) <?> ("open bracket " <> curlyQuotes "[")+ es <- sepBy expressionParser (void (equalToken Comma))+ void (equalToken CloseBracket) <?> ("closing bracket " <> curlyQuotes "]")+ pure (ArrayExpression (V.fromList es))+ record = do+ _ <- equalToken OpenBrace+ pairs' <- sepBy pair (equalToken Comma <?> curlyQuotes ",")+ _ <- equalToken CloseBrace <?> ("closing brace " <> curlyQuotes "}")+ pure (RecordExpression (HM.fromList pairs'))+ where+ pair = do+ var <-+ fmap+ fst+ (consumeToken+ (\case+ VariableToken i -> Just i+ _ -> Nothing)) <|>+ fmap+ fst+ (consumeToken+ (\case+ StringToken c -> Just c+ _ -> Nothing))+ _ <- equalToken Colon+ e <- expressionParser+ pure (var, e)+ app = do+ left <- funcOp <?> "function expression"+ right <- many unambiguous <?> "function arguments"+ case right of+ [] -> pure left+ _ -> pure (foldl (ApplicationExpression) left right)+ infix' =+ (do left <- (app <|> unambiguous) <?> "left-hand side of operator"+ tok <- fmap Just (operator <?> "infix operator") <|> pure Nothing+ case tok of+ Just (Operator t, _) -> do+ right <-+ (app <|> unambiguous) <?>+ ("right-hand side of " +++ curlyQuotes (T.unpack t) ++ " operator")+ badop <- fmap Just (lookAhead operator) <|> pure Nothing+ let infixexp = InfixExpression left (Variable t) right+ maybe+ (return ())+ (\op ->+ unexpected+ (concat+ [ tokenString op +++ ". When more than one operator is used\n"+ , "in the same expression, use parentheses."+ ]))+ badop+ pure infixexp+ _ -> pure left) <?>+ "infix expression (e.g. x * y)"+ where+ operator =+ satisfyToken+ (\case+ Operator {} -> True+ _ -> False)+ funcOp = do+ let collectsubscripts ks a = do+ bracket' <-+ fmap (const True) (equalToken OpenBracket) <|> pure False+ if bracket'+ then do+ k <- expressionParser+ _ <- equalToken CloseBracket+ collectsubscripts (ks . (ExpressionSubscript k :)) a+ else do+ dot <- fmap (const True) (equalToken Period) <|> pure False+ if dot+ then do+ k <-+ fmap+ fst+ (consumeToken+ (\case+ VariableToken i -> Just i+ Integer i -> Just (T.pack (show i))+ _ -> Nothing))+ collectsubscripts (ks . (PropertySubscript k :)) a+ else pure (ks [], a)+ a <- varParser <|> parensExpr+ (subscripts, b) <- collectsubscripts id a+ if null subscripts+ then case b of+ VariableExpression (Variable "_") -> unexpected "wildcard without subscript"+ _ -> pure a+ else pure (SubscriptExpression+ (case b of+ VariableExpression (Variable "_") -> WildcardSubscripted+ _ -> ExpressionSubscripted b)+ subscripts)+ unambiguous = funcOp <|> record <|> atomic+ parensExpr = parens expressionParser++parens :: TokenParser a -> TokenParser a+parens p = go <?> "parens e.g. (x)"+ where+ go = do+ _ <- equalToken OpenParen+ e <- p <?> "expression inside parentheses e.g. (foo)"+ _ <- equalToken CloseParen <?> "closing parenthesis ‘)’"+ pure e++varParser :: TokenParser Expression+varParser = go <?> "variable (e.g. ‘foo’, ‘id’, etc.)"+ where+ go = do+ (v, _) <-+ consumeToken+ (\case+ VariableToken i -> Just i+ _ -> Nothing)+ pure+ (VariableExpression (Variable v))++ifParser :: TokenParser Expression+ifParser = go <?> "if expression (e.g. ‘if p then x else y’)"+ where+ go = do+ _ <- equalToken If+ p <- expressionParser <?> "condition expresion of if-expression"+ _ <- equalToken Then <?> "‘then’ keyword for if-expression"+ e1 <- expressionParser <?> "‘then’ clause of if-expression"+ _ <- equalToken Else <?> "‘else’ keyword for if-expression"+ e2 <- expressionParser <?> "‘else’ clause of if-expression"+ pure (IfExpression p e1 e2)++atomic :: TokenParser Expression+atomic =+ nullParser <|> boolParser <|> varParser <|> stringParser <|> integerParser <|>+ decimalParser+ where++ integerParser = go <?> "integer (e.g. 42, 123)"+ where+ go = do+ (c, _) <-+ consumeToken+ (\case+ Integer c -> Just c+ _ -> Nothing)+ pure (ConstantExpression (NumberConstant (fromIntegral c)))+ decimalParser = go <?> "decimal (e.g. 42, 123)"+ where+ go = do+ (c, _) <-+ consumeToken+ (\case+ Decimal c -> Just c+ _ -> Nothing)+ pure (ConstantExpression (NumberConstant (realToFrac c)))+ boolParser = go <?> "boolean (e.g. true, false)"+ where+ go = do+ (c, _) <-+ consumeToken+ (\case+ TrueToken -> pure True+ FalseToken -> pure False+ _ -> Nothing)+ pure (ConstantExpression (BoolConstant c))+ nullParser = go <?> "null"+ where+ go = do+ ((), _) <-+ consumeToken+ (\case+ NullToken -> pure ()+ _ -> Nothing)+ pure (ConstantExpression NullConstant)++stringParser :: TokenParser Expression+stringParser = go <?> "string (e.g. \"a\")"+ where+ go = do+ (c, _) <-+ consumeToken+ (\case+ StringToken c -> Just c+ _ -> Nothing)+ pure (ConstantExpression (StringConstant c))++lambda :: TokenParser (Expression)+lambda = do+ _ <- equalToken Backslash <?> "lambda expression (e.g. \\x -> x)"+ args <- many1 funcParam <?> "lambda parameters"+ _ <- equalToken RightArrow+ e <- expressionParser+ pure (foldl (\e' arg -> LambdaExpression arg e') e (reverse args))++funcParam :: TokenParser Variable+funcParam = go <?> "function parameter (e.g. ‘x’, ‘limit’, etc.)"+ where+ go = do+ (v, _) <-+ consumeToken+ (\case+ VariableToken i -> Just i+ _ -> Nothing)+ pure (Variable v)
+ src/JL/Printer.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}++-- |++module JL.Printer where++import qualified Data.HashMap.Strict as HM+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Vector as V+import JL.Types++-- | Pretty printing for type.+prettyType :: Type -> Text+prettyType = render+ where+ render = go+ where+ go t =+ case t of+ JSONType -> "JSON"+ VariableType (TypeVariable n) -> nameStream !! n+ FunctionType a b ->+ (case a of+ FunctionType {} -> "(" <> go a <> ")"+ _ -> go a) <>+ " → " <>+ go b+ nameStream = go 'a' (0 :: Integer)+ where+ go c n =+ (T.pack+ (c :+ if n == 0+ then ""+ else show n)) :+ (go+ (toEnum (fromEnum 'a' + (mod (fromEnum c - fromEnum 'a' + 1) 26)))+ (if c == 'z'+ then n + 1+ else n))++-- | Pretty printing for expression.+prettyExp :: Expression -> Text+prettyExp = go+ where+ go t =+ case t of+ VariableExpression (Variable name) -> name+ LambdaExpression (Variable n) e ->+ "(\\" <> n <> " -> " <> go e <> ")"+ ApplicationExpression f x -> "(" <> go f <> " (" <> go x <> "))"+ InfixExpression l o r ->+ prettyExp l <> " " <> prettyVariable o <> " " <> prettyExp r+ IfExpression a b c ->+ "if " <> prettyExp a <> " then " <> prettyExp b <> " else " <>+ prettyExp c+ RecordExpression hm ->+ "{" <>+ T.intercalate+ ", "+ (map (\(k, v) -> k <> ": " <> prettyExp v) (HM.toList hm)) <>+ "}"+ SubscriptExpression o ks ->+ (case o of+ WildcardSubscripted -> "_"+ ExpressionSubscripted e -> go e) <>+ mconcat (map prettySubcript ks)+ ArrayExpression as ->+ "[" <> T.intercalate ", " (map prettyExp (V.toList as)) <> "]"+ ConstantExpression c -> prettyConstant c++-- | Pretty printing for core.+prettyCore :: Core -> Text+prettyCore = go+ where+ go t =+ case t of+ VariableCore (Variable name) -> name+ LambdaCore (Variable n) e -> "(\\" <> n <> " -> " <> go e <> ")"+ ApplicationCore f x -> "(" <> go f <> " (" <> go x <> "))"+ IfCore a b c ->+ "if " <> prettyCore a <> " then " <> prettyCore b <> " else " <>+ prettyCore c+ RecordCore hm ->+ "{" <>+ T.intercalate+ ", "+ (map (\(k, v) -> k <> ": " <> prettyCore v) (HM.toList hm)) <>+ "}"+ EvalCore _ -> "<internal>"+ ArrayCore as ->+ "[" <> T.intercalate ", " (map prettyCore (V.toList as)) <> "]"+ ConstantCore c -> prettyConstant c++prettyConstant :: Constant -> Text+prettyConstant =+ \case+ NumberConstant s -> T.pack (show s)+ StringConstant t -> T.pack (show t)+ BoolConstant b ->+ if b+ then "true"+ else "false"+ NullConstant -> "null"++prettySubcript :: Subscript -> Text+prettySubcript =+ \case+ ExpressionSubscript e -> "[" <> prettyExp e <> "]"+ PropertySubscript p -> "." <> p++prettyVariable :: Variable -> Text+prettyVariable (Variable t) = t
+ src/JL/Serializer.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++-- |++module JL.Serializer where++import Data.Aeson+import Data.Aeson.KeyMap+import Data.Scientific+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Vector as V+import JL.Printer+import JL.Types++coreToNumber :: Core -> Scientific+coreToNumber =+ \case+ ConstantCore (NumberConstant xs) -> xs+ x -> error ("expected number but found: " <> T.unpack (prettyCore x))++coreToString :: Core -> Text+coreToString =+ \case+ ConstantCore (StringConstant xs) -> xs+ x -> error ("expected string but found: " <> T.unpack (prettyCore x))++coreToArray :: Core -> V.Vector Core+coreToArray =+ \case+ ArrayCore xs -> xs+ x -> error ("expected array but found single value: " <> T.unpack (prettyCore x))++coreToValue :: Core -> Value+coreToValue =+ \case+ ConstantCore v -> constantToValue v+ RecordCore hm -> Object (fromHashMapText (fmap coreToValue hm))+ ArrayCore a -> Array (fmap coreToValue a)+ e -> error ("code generated invalid JSON: " <> T.unpack (prettyCore e))++constantToValue :: Constant -> Value+constantToValue =+ \case+ NullConstant -> Null+ BoolConstant b -> Bool b+ StringConstant s -> String s+ NumberConstant n -> Number n++valueToCore :: Value -> Core+valueToCore =+ \case+ Object os -> RecordCore (fmap valueToCore (toHashMapText os))+ Array xs -> ArrayCore (fmap valueToCore xs)+ Number n -> ConstantCore (NumberConstant n)+ Bool n -> ConstantCore (BoolConstant n)+ Null -> ConstantCore NullConstant+ String t -> ConstantCore (StringConstant t)++valueToExpression :: Value -> Expression+valueToExpression =+ \case+ Object os -> RecordExpression (fmap valueToExpression (toHashMapText os))+ Array xs -> ArrayExpression (fmap valueToExpression xs)+ Number n -> ConstantExpression (NumberConstant n)+ Bool n -> ConstantExpression (BoolConstant n)+ Null -> ConstantExpression NullConstant+ String t -> ConstantExpression (StringConstant t)
+ src/JL/Tokenizer.hs view
@@ -0,0 +1,334 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Duet syntax tokenizer.++module JL.Tokenizer where++import Control.Monad+import Data.Char+import Data.List+import Data.Text (Text)+import qualified Data.Text as T+import JL.Types+import Text.Parsec hiding (anyToken)+import Text.Parsec.Text+import Text.Printf++tokenize :: FilePath -> Text -> Either ParseError [(Token, Location)]+tokenize fp t = parse tokensTokenizer fp t++tokensTokenizer :: Parser [(Token, Location)]+tokensTokenizer =+ manyTill (many space >>= tokenTokenizer) (try (spaces >> eof))++tokenTokenizer :: [Char] -> Parser (Token, Location)+tokenTokenizer prespaces =+ choice+ [ if isSuffixOf "\n" prespaces+ then do+ pos <- getPosition+ pure+ ( NonIndentedNewline+ , Location+ (sourceLine pos)+ (sourceColumn pos)+ (sourceLine pos)+ (sourceColumn pos))+ else unexpected "indented newline"+ , atomThenSpace If "if"+ , atomThenSpace Then "then"+ , atomThenSpace Else "else"+ , atomThenSpace Case "case"+ , atomThenSpace Of "of"+ , atom RightArrow "->"+ , atom Period "."+ , atom Colon ":"+ , atom Backslash "\\"+ , atom OpenParen "("+ , atom CloseParen ")"+ , atom OpenBrace "{"+ , atom CloseBrace "}"+ , atom OpenBracket "["+ , atom CloseBracket "]"++ , atom Dollar "$"+ , atom Comma ","++ , do tok <-+ parsing+ Operator+ (fmap+ T.pack+ (choice+ [ string "*"+ , string "+"+ , try (string ">=")+ , try (string "<=")+ , try (string "/=")+ , string ">"+ , string "<"+ , string "/"+ , string "="+ , string "&&"+ , try (string "||")+ ]))+ "operator (e.g. *, <, +, =, etc.)"+ when+ (null prespaces)+ (unexpected+ (tokenString tok +++ ", there should be spaces before and after operators."))+ lookAhead spaces1 <?> ("space after " ++ tokenString tok)+ pure tok+ , atom Bar "|"+ , parsing+ StringToken+ (do _ <- string "\""+ chars <- many (satisfy (\c -> c /= '"'))+ when+ (any (== '\\') chars)+ (unexpected "\\ character, not allowed inside a string.")+ when+ (any (== '\n') chars)+ (unexpected "newline character, not allowed inside a string.")+ _ <- string "\"" <?> "double quotes (\") to close the string"+ pure (T.pack chars))+ "string (e.g. \"hello\", \"123\", etc.)"+ , do (var, loc) <-+ parsing+ VariableToken+ (do variable <-+ do start <- many1 (satisfy (\c -> c=='_' || isLetter c))+ end <-+ many+ (satisfy+ (\c -> c=='_' || isLetter c || isDigit c))+ pure (start ++ end)+ pure (T.pack variable))+ "variable (e.g. “elephant”, “age”, “t2”, etc.)"+ pure+ ( case var of+ VariableToken "null" -> NullToken+ VariableToken "true" -> TrueToken+ VariableToken "false" -> FalseToken+ _ -> var+ , loc)+ , parseNumbers prespaces+ ]+ where++spaces1 :: Parser ()+spaces1 = space >> spaces++ellipsis :: Int -> [Char] -> [Char]+ellipsis n text =+ if length text > 2+ then take n text ++ "…"+ else text++specialParsing :: (t1 -> t) -> Parser t1 -> String -> Parser (t, Location)+specialParsing constructor parser description = do+ start <- getPosition+ thing <- parser <?> description+ end <- getPosition+ pure+ ( constructor thing+ , Location+ (sourceLine start)+ (sourceColumn start)+ (sourceLine end)+ (sourceColumn end))++atom :: t -> String -> Parser (t, Location)+atom constructor text = do+ start <- getPosition+ _ <- try (string text) <?> smartQuotes text+ end <- getPosition+ pure+ ( constructor+ , Location+ (sourceLine start)+ (sourceColumn start)+ (sourceLine end)+ (sourceColumn end))++atomThenSpace :: t -> String -> Parser (t, Location)+atomThenSpace constructor text = do+ start <- getPosition+ _ <-+ try ((string text <?> smartQuotes text) <*+ (lookAhead spaces1 <?> ("space or newline after " ++ smartQuotes text)))+ end <- getPosition+ pure+ ( constructor+ , Location+ (sourceLine start)+ (sourceColumn start)+ (sourceLine end)+ (sourceColumn end))++parsing :: (Text -> t) -> Parser Text -> String -> Parser (t, Location)+parsing constructor parser description = do+ start <- getPosition+ text <- parser <?> description+ end <- getPosition+ pure+ ( constructor text+ , Location+ (sourceLine start)+ (sourceColumn start)+ (sourceLine end)+ (sourceColumn end))++parseNumbers :: [a] -> Parser (Token, Location)+parseNumbers prespaces = parser <?> "number (e.g. 42, 3.141, etc.)"+ where+ parser = do+ start <- getPosition+ neg <- fmap Just (char '-') <|> pure Nothing+ let operator = do+ end <- getPosition+ pure+ ( Operator "-"+ , Location+ (sourceLine start)+ (sourceColumn start)+ (sourceLine end)+ (sourceColumn end))+ number+ :: (forall a. (Num a) =>+ a -> a)+ -> Parser (Token, Location)+ number f = do+ x <- many1 digit+ (do _ <- char '.'+ y <- many1 digit <?> ("decimal component, e.g. " ++ x ++ ".0")+ end <- getPosition+ pure+ ( Decimal (f (read (x ++ "." ++ y)))+ , Location+ (sourceLine start)+ (sourceColumn start)+ (sourceLine end)+ (sourceColumn end))) <|>+ (do end <- getPosition+ pure+ ( Integer (f (read x))+ , Location+ (sourceLine start)+ (sourceColumn start)+ (sourceLine end)+ (sourceColumn end)))+ case neg of+ Nothing -> number id+ Just {} -> do+ when+ (null prespaces)+ (unexpected+ (curlyQuotes "-" ++ ", there should be a space before it."))+ (number (* (-1)) <?> "number (e.g. 123)") <|>+ operator <* (space <?> ("space after operator " ++ curlyQuotes "-"))++smartQuotes :: [Char] -> [Char]+smartQuotes t = "“" <> t <> "”"++equalToken :: Token -> TokenParser Location+equalToken p = fmap snd (satisfyToken (==p) <?> tokenStr p)++-- | Consume the given predicate from the token stream.+satisfyToken :: (Token -> Bool) -> TokenParser (Token, Location)+satisfyToken p =+ consumeToken (\tok -> if p tok+ then Just tok+ else Nothing)++-- | The parser @anyToken@ accepts any kind of token. It is for example+-- used to implement 'eof'. Returns the accepted token.+anyToken :: TokenParser (Token, Location)+anyToken = consumeToken Just++-- | Consume the given predicate from the token stream.+consumeToken :: (Token -> Maybe a) -> TokenParser (a, Location)+consumeToken f = do+ u <- getState+ tokenPrim+ tokenString+ tokenPosition+ (\(tok, loc) ->+ if locationStartColumn loc > u+ then fmap (, loc) (f tok)+ else Nothing)++-- | Make a string out of the token, for error message purposes.+tokenString :: (Token, Location) -> [Char]+tokenString = tokenStr . fst++tokenStr :: Token -> [Char]+tokenStr tok =+ case tok of+ If -> curlyQuotes "if"+ Then -> curlyQuotes "then"+ RightArrow -> curlyQuotes "->"+ Else -> curlyQuotes "else"+ Case -> curlyQuotes "case"+ Of -> curlyQuotes "of"+ NonIndentedNewline -> "non-indented newline"+ Backslash -> curlyQuotes ("backslash " ++ curlyQuotes "\\")+ OpenParen -> "opening parenthesis " ++ curlyQuotes "("+ CloseParen -> "closing parenthesis " ++ curlyQuotes ")"+ VariableToken t -> "variable " ++ curlyQuotes (T.unpack t)+ StringToken !t -> "string " ++ show t+ Operator !t -> "operator " ++ curlyQuotes (T.unpack t)+ Comma -> curlyQuotes ","+ Integer !i -> "integer " ++ show i+ Decimal !d -> "decimal " ++ printf "%f" d+ Bar -> curlyQuotes "|"+ Dollar -> curlyQuotes "$"+ Period -> curlyQuotes "."+ TrueToken -> curlyQuotes "true"+ FalseToken -> curlyQuotes "false"+ NullToken -> curlyQuotes "null"+ CloseBrace -> curlyQuotes "}"+ OpenBrace -> curlyQuotes "{"+ CloseBracket -> curlyQuotes "]"+ OpenBracket -> curlyQuotes "["+ Colon -> curlyQuotes ":"++-- | Update the position by the token.+tokenPosition :: SourcePos -> (Token, Location) -> t -> SourcePos+tokenPosition pos (_, l) _ =+ setSourceColumn (setSourceLine pos line) col+ where (line,col) = (locationStartLine l, locationStartColumn l)++type TokenParser e = forall s m. Stream s m (Token, Location) => ParsecT s Int m e++-- | @notFollowedBy p@ only succeeds when parser @p@ fails. This parser+-- does not consume any input. This parser can be used to implement the+-- \'longest match\' rule. For example, when recognizing keywords (for+-- example @let@), we want to make sure that a keyword is not followed+-- by a legal identifier character, in which case the keyword is+-- actually an identifier (for example @lets@). We can program this+-- behaviour as follows:+--+-- > keywordLet = try (do{ string "let"+-- > ; notFollowedBy alphaNum+-- > })+notFollowedBy' :: TokenParser (Token, Location) -> TokenParser ()+notFollowedBy' p =+ try ((do c <- try p+ unexpected (tokenString c)) <|>+ return ())++-- | This parser only succeeds at the end of the input. This is not a+-- primitive parser but it is defined using 'notFollowedBy'.+--+-- > eof = notFollowedBy anyToken <?> "end of input"+endOfTokens :: TokenParser ()+endOfTokens = notFollowedBy' anyToken <?> "end of input"++curlyQuotes :: [Char] -> [Char]+curlyQuotes t = "‘" <> t <> "’"
+ src/JL/Types.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE LambdaCase #-}+-- |++module JL.Types where++import Control.Exception+import Data.Data+import qualified Data.HashMap.Strict as HM+import Data.HashMap.Strict (HashMap)+import Data.Scientific+import Data.Text (Text)+import Data.Vector (Vector)+import Text.Parsec.Error++data ParseException+ = TokenizerError !ParseError+ | ParserError !ParseError+ deriving (Typeable, Show)+instance Exception ParseException++-- | A type.+data Type+ = VariableType !TypeVariable+ | FunctionType !Type !Type+ | JSONType+ deriving (Ord, Eq, Show)++-- | A parsed expression.+data Expression+ = VariableExpression Variable+ | LambdaExpression Variable Expression+ | ApplicationExpression Expression Expression+ | InfixExpression Expression Variable Expression+ | IfExpression Expression Expression Expression+ | SubscriptExpression Subscripted [Subscript]+ | RecordExpression (HashMap Text Expression)+ | ArrayExpression (Vector Expression)+ | ConstantExpression Constant+ deriving (Show, Eq)++data Subscripted+ = WildcardSubscripted+ | ExpressionSubscripted Expression+ deriving (Show, Eq)++data Subscript+ = PropertySubscript Text+ | ExpressionSubscript Expression+ deriving (Show, Eq)++-- | Desugared core AST.+data Core+ = VariableCore Variable+ | LambdaCore Variable Core+ | ApplicationCore Core Core+ | IfCore Core Core Core+ | EvalCore (Core -> Core)+ | RecordCore (HashMap Text Core)+ | ArrayCore (Vector Core)+ | ConstantCore Constant++data Compare+ = ConstantCompare Constant+ | VectorCompare (Vector Compare)+ | RecordCompare [(Text, Compare)]+ deriving (Eq, Ord)++coreToCompare :: Core -> Compare+coreToCompare =+ \case+ ConstantCore c -> ConstantCompare c+ ArrayCore cs -> VectorCompare (fmap coreToCompare cs)+ RecordCore cs -> RecordCompare (HM.toList (fmap coreToCompare cs))+ _ -> error "Cannot compare that value for sorting"++-- | A self-evaluating constant.+data Constant+ = StringConstant Text+ | NumberConstant Scientific+ | BoolConstant Bool+ | NullConstant+ deriving (Show, Eq, Ord)++-- | A type variable, generated by the type system.+newtype TypeVariable =+ TypeVariable Int+ deriving (Show, Eq, Ord)++-- | A value variable, inputted by the programmer.+newtype Variable =+ Variable Text+ deriving (Show, Eq, Ord)++data Token+ = If+ | Then+ | Else+ | Case+ | Of+ | Backslash+ | RightArrow+ | Dollar+ | OpenParen+ | CloseParen+ | OpenBracket+ | CloseBracket+ | VariableToken !Text+ | StringToken !Text+ | Operator !Text+ | Period+ | Comma+ | Integer !Integer+ | Decimal !Double+ | OpenBrace+ | CloseBrace+ | Colon+ | NonIndentedNewline+ | Bar+ | TrueToken+ | FalseToken+ | NullToken+ deriving (Eq, Ord, Show)++data Location = Location+ { locationStartLine :: !Int+ , locationStartColumn :: !Int+ , locationEndLine :: !Int+ , locationEndColumn :: !Int+ } deriving (Show, Eq)++data Definition = Definition+ { definitionName :: Variable+ , definitionDoc :: Text+ , definitionType :: Type+ , definitionCore :: Core+ }