diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,505 @@ +# jl [![Build Status](https://travis-ci.org/chrisdone/jl.svg)](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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/jl.cabal b/jl.cabal new file mode 100644 --- /dev/null +++ b/jl.cabal @@ -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 diff --git a/src/JL.hs b/src/JL.hs new file mode 100644 --- /dev/null +++ b/src/JL.hs @@ -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) diff --git a/src/JL/Functions.hs b/src/JL/Functions.hs new file mode 100644 --- /dev/null +++ b/src/JL/Functions.hs @@ -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 .-> diff --git a/src/JL/Inferer.hs b/src/JL/Inferer.hs new file mode 100644 --- /dev/null +++ b/src/JL/Inferer.hs @@ -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 <> "’" diff --git a/src/JL/Interpreter.hs b/src/JL/Interpreter.hs new file mode 100644 --- /dev/null +++ b/src/JL/Interpreter.hs @@ -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 diff --git a/src/JL/Parser.hs b/src/JL/Parser.hs new file mode 100644 --- /dev/null +++ b/src/JL/Parser.hs @@ -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) diff --git a/src/JL/Printer.hs b/src/JL/Printer.hs new file mode 100644 --- /dev/null +++ b/src/JL/Printer.hs @@ -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 _ -> "" + 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 diff --git a/src/JL/Serializer.hs b/src/JL/Serializer.hs new file mode 100644 --- /dev/null +++ b/src/JL/Serializer.hs @@ -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) diff --git a/src/JL/Tokenizer.hs b/src/JL/Tokenizer.hs new file mode 100644 --- /dev/null +++ b/src/JL/Tokenizer.hs @@ -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 <> "’" diff --git a/src/JL/Types.hs b/src/JL/Types.hs new file mode 100644 --- /dev/null +++ b/src/JL/Types.hs @@ -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 + }