diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,16 @@ +* 0.1.6 (16 December 2023) + + - A bunch more documentation + - Allow `!=` as a synonym for `/=` + - Allow `=<` and `=>` as aliases for `<=` and `>=`, respectively + - Better reporting of test results + - Load standard library modules immediately on startup + - `:doc` now works for case expressions, wildcard patterns, `unit` + and `Unit` + - Allow optional commas on either side of an ellipsis (#361) + - Propositions can be combined with binary operators (thanks to + @cally-cmd) + * 0.1.5 (12 March 2022) - Syntax errors in function definitions now result in much more diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,13 +5,96 @@ programming principles in the context of a discrete mathematics course. +Using Disco on replit.com +--------------------------- + +If you just want to *use* disco (*i.e.* if you are a student, or just +checking out the language), the recommended way is to use it via +`replit.com`. Simply [visit this +REPL](https://replit.com/@BrentYorgey/Disco#README.md) and follow the +instructions there to fork your own copy, where you will be able to +evaluate Disco expressions, and edit and run your own `.disco` files, +all via your web browser, without installing anything on your computer. + +Design principles +----------------- + +* Includes those features, and *only* those features, useful in the + context of a discrete math course. This is *not* intended to be a + general-purpose language. +* Syntax is as close to standard *mathematical* practice as possible, + to make it easier for mathematicians to pick up, and to reduce as + much as possible the incongruity between the language and the + mathematics being explored and modeled. +* Tooling, error messages, etc. are very important---the language + needs to be accessible to undergrads with no prior programming + experience. (However, this principle is, as of yet, only + that---there is no tooling or nice error messages to speak of.) + +Feel free to look around, ask questions, etc. You can also +[contribute](CONTRIBUTING.md)---collaborators are most welcome. + +Community +--------- + +Check out the disco IRC channel, `#disco-lang` on Libera.Chat. If +you're not familiar with IRC, you can connect via [this web client](https://kiwiirc.com/nextclient/irc.libera.chat/?nick=Guest?#disco-lang). + +Documentation +------------- + +Documentation is [hosted on +readthedocs.io](http://disco-lang.readthedocs.io/en/latest/). + +Contributing +------------ + +If you'd like to contribute to disco development, check out +[CONTRIBUTING.md](CONTRIBUTING.md). + +Building with stack +------------------- + +First, make sure you have +[the `stack` tool](https://docs.haskellstack.org/en/stable/README/) +(the easiest way to install it is via [ghcup](https://www.haskell.org/ghcup/)). +Then open a command prompt, navigate to the root directory of this +repository, and execute + +``` +stack build +``` + +After this completes, you should be able to + +``` +stack exec disco +``` + +to run the Disco command-line REPL. + +While developing, you may want to use a command like + +``` +stack test --fast --file-watch --ghc-options='-Wall' +``` + +which will turn on warnings, turn off optimizations for a faster +edit-compile-test cycle, and automatically recompile and run the test +suite every time a source file changes. + Installation ------------ -If you just want to *use* disco (*i.e.* if you are a student), follow -these instructions. If you want to *contribute* to disco development, -you should skip to the instructions below about building with stack. +If for some reasons you want to actually install `disco` on your +computer, follow the below instructions. (If you want to *contribute* +to disco development, you should skip to the instructions about +building with stack.) +**Note**, if you are a student, you should **not** need to do this! +The above instructions about using `disco` on `replit.com` should be +all you need. The below instructions are kept here for completeness. + - Follow the instructions to [install ghcup](https://www.haskell.org/ghcup/) by opening a terminal or command prompt and copy-pasting the given installation command. You @@ -110,70 +193,3 @@ workarounds I learn. So even if you encounter a difficulty but figure out the solution youself, let me know --- that way I can include the problem and solution here so others can benefit! - -Design principles ------------------ - -* Includes those features, and *only* those features, useful in the - context of a discrete math course. This is *not* intended to be a - general-purpose language. -* Syntax is as close to standard *mathematical* practice as possible, - to make it easier for mathematicians to pick up, and to reduce as - much as possible the incongruity between the language and the - mathematics being explored and modeled. -* Tooling, error messages, etc. are very important---the language - needs to be accessible to undergrads with no prior programming - experience. (However, this principle is, as of yet, only - that---there is no tooling or nice error messages to speak of.) - -Feel free to look around, ask questions, etc. You can also -[contribute](CONTRIBUTING.md)---collaborators are most welcome. - -Community ---------- - -Check out the disco IRC channel, `#disco-lang` on Libera.Chat. If -you're not familiar with IRC, you can connect via [this web client](https://kiwiirc.com/nextclient/irc.libera.chat/?nick=Guest?#disco-lang). - -Documentation -------------- - -Documentation is [hosted on -readthedocs.io](http://disco-lang.readthedocs.io/en/latest/). - -Contributing ------------- - -If you'd like to contribute to disco development, check out -[CONTRIBUTING.md](CONTRIBUTING.md). - -Building with stack -------------------- - -First, make sure you have -[the `stack` tool](https://docs.haskellstack.org/en/stable/README/) -(the easiest way to install it is via [ghcup](https://www.haskell.org/ghcup/)). -Then open a command prompt, navigate to the root directory of this -repository, and execute - -``` -stack build -``` - -After this completes, you should be able to - -``` -stack exec disco -``` - -to run the Disco command-line REPL. - -While developing, you may want to use a command like - -``` -stack test --fast --file-watch --ghc-options='-Wall' -``` - -which will turn on warnings, turn off optimizations for a faster -edit-compile-test cycle, and automatically recompile and run the test -suite every time a source file changes. diff --git a/disco.cabal b/disco.cabal --- a/disco.cabal +++ b/disco.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: disco -version: 0.1.5 +version: 0.1.6 synopsis: Functional programming language for teaching discrete math. description: Disco is a simple functional programming language for use in teaching discrete math. Its syntax is designed to be close @@ -12,14 +12,14 @@ copyright: Disco team 2016-2022 (see LICENSE) category: Language -tested-with: GHC == 8.10.4 +tested-with: GHC ==8.10.7 || ==9.2.5 || ==9.4.3 data-dir: lib data-files: *.disco -extra-source-files: README.md, CHANGELOG.md, stack.yaml, example/*.disco, repl/*.hs - docs/tutorial/example/*.disco +extra-doc-files: README.md, CHANGELOG.md, example/*.disco, docs/tutorial/example/*.disco +extra-source-files: stack.yaml, repl/*.hs --- TEST FILES BEGIN (updated automatically by add-test-files.hs) --- test/README.md test/Tests.hs @@ -91,6 +91,8 @@ test/error-emptycase/input test/error-names/expected test/error-names/input + test/error-nonlinear/expected + test/error-nonlinear/input test/error-notcon/expected test/error-notcon/input test/error-notype/expected @@ -132,8 +134,6 @@ test/interp-strictmatch/bomb.disco test/interp-strictmatch/expected test/interp-strictmatch/input - test/lib-oeis/expected - test/lib-oeis/input test/list-comp/expected test/list-comp/input test/list-poly/expected @@ -170,6 +170,8 @@ test/parse-case-expr/input test/parse-nested-list/expected test/parse-nested-list/input + test/parse-patguard/expected + test/parse-patguard/input test/parse-quantifiers/expected test/parse-quantifiers/input test/parse-top-term/expected @@ -189,8 +191,6 @@ test/pretty-defn/input test/pretty-functions/expected test/pretty-functions/input - test/pretty-issue258/expected - test/pretty-issue258/input test/pretty-lit/expected test/pretty-lit/input test/pretty-ops/expected @@ -212,6 +212,8 @@ test/prop-basic/expected test/prop-basic/input test/prop-basic/prop-basic.disco + test/prop-binary/expected + test/prop-binary/input test/prop-cmp/expected test/prop-cmp/input test/prop-fail/bad-tests.disco @@ -280,6 +282,8 @@ test/syntax-doc/expected test/syntax-doc/input test/syntax-doc/syntax-doc.disco + test/syntax-ellipsis/expected + test/syntax-ellipsis/input test/syntax-exts/expected test/syntax-exts/input test/syntax-exts/syntax-exts.disco @@ -315,6 +319,8 @@ test/types-192/input test/types-306/expected test/types-306/input + test/types-357/expected + test/types-357/input test/types-bind/expected test/types-bind/input test/types-char-string/expected @@ -448,34 +454,37 @@ other-modules: Paths_disco autogen-modules: Paths_disco - build-depends: base >=4.8 && <4.17, + build-depends: base >=4.8 && <4.18, filepath, directory, - mtl >=2.2 && <2.3, - megaparsec >= 6.1.1 && < 9.3, + mtl >=2.2 && <2.4, + megaparsec >= 6.1.1 && < 9.6, parser-combinators >= 1.0.0 && < 1.4, - pretty >=1.1 && <1.2, + prettyprinter >=1.7 && < 1.8, split >= 0.2 && < 0.3, transformers >= 0.4 && < 0.7, containers >=0.5 && <0.7, - unbound-generics >= 0.3 && < 0.5, - polysemy >= 1.6.0.0 && < 1.8, + unbound-generics >= 0.3 && < 0.4.3, + -- unbound-generics 0.4.3 added substBvs to + -- Subst class which adds a new Generic + -- constraint, hence a breaking change + polysemy >= 1.6.0.0 && < 1.10, polysemy-plugin >= 0.4 && < 0.5, polysemy-zoo >= 0.7 && < 0.9, - lens >= 4.14 && < 5.2, + lens >= 4.14 && < 5.3, exact-combinatorics >= 0.2 && < 0.3, - arithmoi >= 0.10 && < 0.13, + arithmoi >= 0.10 && < 0.14, integer-logarithms >= 1.0 && < 1.1, simple-enumeration >= 0.2 && < 0.3, haskeline >=0.8 && <0.9, exceptions >= 0.10 && < 0.11, QuickCheck >= 2.9 && < 2.15, splitmix >= 0.1 && < 0.2, - fgl >= 5.5 && < 5.8, - optparse-applicative >= 0.12 && < 0.18, - oeis >= 0.3.10, - algebraic-graphs >= 0.5, - pretty-show >= 1.10 + fgl >= 5.5 && < 5.9, + optparse-applicative >= 0.12 && < 0.19, + -- oeis2 < 1.1, + algebraic-graphs >= 0.5 && < 0.8, + pretty-show >= 1.10 && < 1.11 hs-source-dirs: src default-language: Haskell2010 @@ -484,19 +493,20 @@ import: common hs-source-dirs: repl main-is: REPL.hs + ghc-options: +RTS --io-manager=native -RTS build-depends: base, disco, directory, filepath, haskeline >=0.8 && <0.9, - mtl >=2.2 && <2.3, + mtl >=2.2 && <2.4, transformers >= 0.4 && < 0.7, - megaparsec >= 6.1.1 && < 9.3, + megaparsec >= 6.1.1 && < 9.6, containers >= 0.5 && < 0.7, - unbound-generics >= 0.3 && < 0.5, - lens >= 4.14 && < 5.2, - optparse-applicative >= 0.12 && < 0.18, - oeis >= 0.3.10 + unbound-generics >= 0.3 && < 0.4.3, + lens >= 4.14 && < 5.3, + optparse-applicative >= 0.12 && < 0.19 + -- oeis2 < 1.1 default-language: Haskell2010 @@ -506,13 +516,13 @@ main-is: Tests.hs hs-source-dirs: test ghc-options: -threaded - build-depends: base >= 4.7 && < 4.17, - tasty >= 0.10 && < 1.5, + build-depends: base >= 4.7 && < 4.18, + tasty >= 0.10 && < 1.6, tasty-golden >= 2.3 && < 2.4, directory >= 1.2 && < 1.4, filepath >= 1.4 && < 1.5, process >= 1.4 && < 1.7, - bytestring >= 0.9 && < 0.12, + bytestring >= 0.9 && < 0.13, disco default-language: Haskell2010 @@ -522,7 +532,7 @@ main-is: TestExamples.hs hs-source-dirs: example ghc-options: -threaded - build-depends: base >= 4.7 && < 4.17, + build-depends: base >= 4.7 && < 4.18, directory >= 1.2 && < 1.4, filepath >= 1.4 && < 1.5, process >= 1.4 && < 1.7 diff --git a/example/catalan.disco b/example/catalan.disco deleted file mode 100644 --- a/example/catalan.disco +++ /dev/null @@ -1,19 +0,0 @@ -import list -import oeis - --- The type of binary tree shapes: empty tree, or a pair of subtrees. -type BT = Unit + BT*BT - --- Generate the list of all binary tree shapes of a given size. -treesOfSize : N -> List(BT) -treesOfSize(0) = [left(■)] -treesOfSize(k+1) = - [ right (l,r) | x <- [0 .. k], l <- treesOfSize(x), r <- treesOfSize(k .- x) ] - --- Compute first few Catalan numbers by brute force. -catalan1 : List(N) -catalan1 = each(\k. length(treesOfSize(k)), [0..4]) - --- Extend the sequence via the OEIS. -catalan : List(N) -catalan = extendSequence(catalan1) diff --git a/example/gcd.disco b/example/gcd.disco --- a/example/gcd.disco +++ b/example/gcd.disco @@ -16,6 +16,8 @@ !!! gcd(7,6) == 1 !!! gcd(12,18) == 6 !!! gcd(0,0) == 0 +!!! forall a:N, b:N. gcd(a,b) divides a /\ gcd(a,b) divides b +!!! forall a:N, b:N, g:N. (g divides a /\ g divides b) ==> g divides gcd(a,b) gcd : N * N -> N gcd(a,0) = a diff --git a/example/grid.disco b/example/grid.disco --- a/example/grid.disco +++ b/example/grid.disco @@ -59,12 +59,7 @@ -- in infinite recursion! One way that would work is to write the -- test as follows: -!!! forall n:Nat. powerIsoPos (powerIsoPos' (n+1)) == (n+1) - --- Alternatively, since 'implies' is lazy (i.e. "short-circuiting"), --- we can write - -!!! ∀ n : Nat. (n > 0) ==> powerIsoPos (powerIsoPos' n) == n +-- !!! forall n:Nat. powerIsoPos (powerIsoPos' (n+1)) == (n+1) powerIsoPos : ℕ×ℕ → ℕ powerIsoPos (x,y) = 2^x * (2y + 1) diff --git a/example/prime.disco b/example/prime.disco --- a/example/prime.disco +++ b/example/prime.disco @@ -47,7 +47,4 @@ !!! isPrime 113 isPrime : N -> Bool -isPrime n = - {? false if n <= 1, - ld n == n otherwise - ?} +isPrime n = (n >= 2) and (ld n == n) diff --git a/example/tree.disco b/example/tree.disco --- a/example/tree.disco +++ b/example/tree.disco @@ -4,7 +4,7 @@ leaf = left(■) node : N * Tree * Tree -> Tree -node(x, l, r) = right(x, l, r) +node = right tree1 : Tree tree1 = node(3, node(5, node(1, leaf, leaf), leaf), node(6, node(2, leaf, leaf), node(8, leaf, leaf))) diff --git a/lib/oeis.disco b/lib/oeis.disco deleted file mode 100644 --- a/lib/oeis.disco +++ /dev/null @@ -1,13 +0,0 @@ -using Primitives - -||| Look up a sequence of integers using https://oeis.org -!!! lookupSequence [] == left(unit) -!!! lookupSequence [1,1,2,3] == right "https://oeis.org/A000045" -lookupSequence : List(N) -> Unit + List(Char) -lookupSequence = $lookupSequence - -||| Extend a known sequence of integers with data from https://oeis.org -!!! extendSequence [] == [] -!!! extendSequence [1,1,2,3,5] == [1, 1, 2, 3, 5, 8, 13, 21, 34, 55, 89, 144, 233, 377, 610, 987, 1597, 2584, 4181, 6765, 10946, 17711, 28657, 46368, 75025, 121393, 196418, 317811, 514229, 832040, 1346269, 2178309, 3524578, 5702887, 9227465, 14930352, 24157817, 39088169, 63245986, 102334155] -extendSequence : List(N) -> List(N) -extendSequence = $extendSequence diff --git a/repl/REPL.hs b/repl/REPL.hs --- a/repl/REPL.hs +++ b/repl/REPL.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- | +-- \| -- Module : REPL -- Copyright : disco team and contributors -- Maintainer : byorgey@gmail.com @@ -7,10 +7,9 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- A text-based REPL for disco. --- ----------------------------------------------------------------------------- -import Disco.Interactive.CmdLine +import Disco.Interactive.CmdLine main :: IO () main = discoMain diff --git a/src/Disco/AST/Core.hs b/src/Disco/AST/Core.hs --- a/src/Disco/AST/Core.hs +++ b/src/Disco/AST/Core.hs @@ -1,10 +1,9 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} ------------------------------------------------------------------------------ -- | -- Module : Disco.AST.Core -- Copyright : disco team and contributors @@ -14,34 +13,35 @@ -- -- Abstract syntax trees representing the desugared, untyped core -- language for Disco. ------------------------------------------------------------------------------ - -module Disco.AST.Core - ( -- * Core AST - RationalDisplay(..) - , Core(..) - , Op(..), opArity, substQC, substsQC - ) - where +module Disco.AST.Core ( + -- * Core AST + RationalDisplay (..), + Core (..), + Op (..), + opArity, + substQC, + substsQC, +) +where -import Control.Lens.Plated -import Data.Data (Data) -import Data.Data.Lens (uniplate) -import qualified Data.Set as S -import GHC.Generics -import Prelude hiding ((<>)) -import qualified Prelude as P -import Unbound.Generics.LocallyNameless hiding (LFresh, lunbind) +import Control.Lens.Plated +import Data.Data (Data) +import Data.Data.Lens (uniplate) +import qualified Data.Set as S +import GHC.Generics +import Unbound.Generics.LocallyNameless hiding (LFresh, lunbind) +import Prelude hiding ((<>)) +import qualified Prelude as P -import Disco.Effects.LFresh -import Polysemy (Members, Sem) -import Polysemy.Reader +import Disco.Effects.LFresh +import Polysemy (Members, Sem) +import Polysemy.Reader -import Data.Ratio -import Disco.AST.Generic (Side, selectSide) -import Disco.Names (QName) -import Disco.Pretty -import Disco.Types +import Data.Ratio +import Disco.AST.Generic (Side, selectSide) +import Disco.Names (QName) +import Disco.Pretty +import Disco.Types -- | A type of flags specifying whether to display a rational number -- as a fraction or a decimal. @@ -51,7 +51,7 @@ instance Semigroup RationalDisplay where Decimal <> _ = Decimal _ <> Decimal = Decimal - _ <> _ = Fraction + _ <> _ = Fraction -- | The 'Monoid' instance for 'RationalDisplay' corresponds to the -- idea that the result should be displayed as a decimal if any @@ -231,8 +231,8 @@ | -- | Equality assertion, @=!=@ OShouldEq Type | -- Other primitives - - -- | Error for non-exhaustive pattern match + OShouldLt Type + | -- | Error for non-exhaustive pattern match OMatchErr | -- | Crash with a user-supplied message OCrash @@ -242,6 +242,15 @@ OLookupSeq | -- | Extend a List via OEIS OExtendSeq + | -- | Not the Boolean `And`, but instead a propositional BOp + -- | Should only be seen and used with Props. + OAnd + | -- | Not the Boolean `Or`, but instead a propositional BOp + -- | Should only be seen and used with Props. + OOr + | -- | Not the Boolean `Impl`, but instead a propositional BOp + -- | Should only be seen and used with Props. + OImpl deriving (Show, Generic, Data, Alpha, Eq, Ord) -- | Get the arity (desired number of arguments) of a function @@ -249,8 +258,8 @@ -- uncurried and hence has arity 1. opArity :: Op -> Int opArity OEmptyGraph = 0 -opArity OMatchErr = 0 -opArity _ = 1 +opArity OMatchErr = 0 +opArity _ = 1 substQC :: QName Core -> Core -> Core -> Core substQC x s = transform $ \case @@ -263,63 +272,66 @@ substsQC xs = transform $ \case CVar y -> case P.lookup y xs of Just c -> c - _ -> CVar y + _ -> CVar y t -> t instance Pretty Core where pretty = \case - CVar qn -> pretty qn + CVar qn -> pretty qn CNum _ r | denominator r == 1 -> text (show (numerator r)) - | otherwise -> text (show (numerator r)) <> "/" <> text (show (denominator r)) + | otherwise -> text (show (numerator r)) <> "/" <> text (show (denominator r)) CApp (CConst op) (CPair c1 c2) | isInfix op -> parens (pretty c1 <+> text (opToStr op) <+> pretty c2) CApp (CConst op) c | isPrefix op -> text (opToStr op) <> pretty c | isPostfix op -> pretty c <> text (opToStr op) - CConst op -> pretty op - CInj s c -> withPA funPA $ selectSide s "left" "right" <+> rt (pretty c) - CCase c l r -> do + CConst op -> pretty op + CInj s c -> withPA funPA $ selectSide s "left" "right" <+> rt (pretty c) + CCase c l r -> do lunbind l $ \(x, lc) -> do - lunbind r $ \(y, rc) -> do - "case" <+> pretty c <+> "of {" - $+$ nest 2 ( - vcat - [ withPA funPA $ "left" <+> rt (pretty x) <+> "->" <+> pretty lc - , withPA funPA $ "right" <+> rt (pretty y) <+> "->" <+> pretty rc - ]) - $+$ "}" - CUnit -> "unit" - CPair c1 c2 -> setPA initPA $ parens (pretty c1 <> ", " <> pretty c2) - CProj s c -> withPA funPA $ selectSide s "fst" "snd" <+> rt (pretty c) - CAbs lam -> withPA initPA $ do + lunbind r $ \(y, rc) -> do + nest 2 $ + "case" + <+> pretty c + <+> "of {" + $+$ vcat + [ withPA funPA $ "left" <+> rt (pretty x) <+> "->" <+> pretty lc + , withPA funPA $ "right" <+> rt (pretty y) <+> "->" <+> pretty rc + ] + $+$ "}" + CUnit -> "unit" + CPair c1 c2 -> setPA initPA $ parens (pretty c1 <> ", " <> pretty c2) + CProj s c -> withPA funPA $ selectSide s "fst" "snd" <+> rt (pretty c) + CAbs lam -> withPA initPA $ do lunbind lam $ \(xs, body) -> "λ" <> intercalate "," (map pretty xs) <> "." <+> lt (pretty body) - CApp c1 c2 -> withPA funPA $ lt (pretty c1) <+> rt (pretty c2) - CTest xs c -> "test" <+> prettyTestVars xs <+> pretty c - CType ty -> pretty ty - CDelay d -> withPA initPA $ do + CApp c1 c2 -> withPA funPA $ lt (pretty c1) <+> rt (pretty c2) + CTest xs c -> "test" <+> prettyTestVars xs <+> pretty c + CType ty -> pretty ty + CDelay d -> withPA initPA $ do lunbind d $ \(xs, bodies) -> "delay" <+> intercalate "," (map pretty xs) <> "." <+> pretty (toTuple bodies) - CForce c -> withPA funPA $ "force" <+> rt (pretty c) + CForce c -> withPA funPA $ "force" <+> rt (pretty c) toTuple :: [Core] -> Core toTuple = foldr CPair CUnit -prettyTestVars :: Members '[Reader PA, LFresh] r => [(String, Type, Name Core)] -> Sem r Doc +prettyTestVars :: Members '[Reader PA, LFresh] r => [(String, Type, Name Core)] -> Sem r (Doc ann) prettyTestVars = brackets . intercalate "," . map prettyTestVar - where - prettyTestVar (s, ty, n) = parens (intercalate "," [text s, pretty ty, pretty n]) + where + prettyTestVar (s, ty, n) = parens (intercalate "," [text s, pretty ty, pretty n]) isInfix, isPrefix, isPostfix :: Op -> Bool -isInfix OShouldEq{} = True -isInfix op = op `S.member` S.fromList - [ OAdd, OMul, ODiv, OExp, OMod, ODivides, OMultinom, OEq, OLt] - +isInfix OShouldEq {} = True +isInfix OShouldLt {} = True +isInfix op = + op + `S.member` S.fromList + [OAdd, OMul, ODiv, OExp, OMod, ODivides, OMultinom, OEq, OLt, OAnd, OOr, OImpl] isPrefix ONeg = True -isPrefix _ = False - +isPrefix _ = False isPostfix OFact = True -isPostfix _ = False +isPostfix _ = False instance Pretty Op where pretty (OForall tys) = "∀" <> intercalate "," (map pretty tys) <> "." @@ -328,63 +340,67 @@ | isInfix op = "~" <> text (opToStr op) <> "~" | isPrefix op = text (opToStr op) <> "~" | isPostfix op = "~" <> text (opToStr op) - | otherwise = text (opToStr op) + | otherwise = text (opToStr op) opToStr :: Op -> String opToStr = \case - OAdd -> "+" - ONeg -> "-" - OSqrt -> "sqrt" - OFloor -> "floor" - OCeil -> "ceil" - OAbs -> "abs" - OMul -> "*" - ODiv -> "/" - OExp -> "^" - OMod -> "mod" - ODivides -> "divides" - OMultinom -> "choose" - OFact -> "!" - OEq -> "==" - OLt -> "<" - OEnum -> "enumerate" - OCount -> "count" - OPower -> "power" - OBagElem -> "elem_bag" - OListElem -> "elem_list" - OEachBag -> "each_bag" - OEachSet -> "each_set" - OFilterBag -> "filter_bag" - OMerge -> "merge" - OBagUnions -> "unions_bag" - OSummary -> "summary" - OEmptyGraph -> "emptyGraph" - OVertex -> "vertex" - OOverlay -> "overlay" - OConnect -> "connect" - OInsert -> "insert" - OLookup -> "lookup" - OUntil -> "until" - OSetToList -> "set2list" - OBagToSet -> "bag2set" - OBagToList -> "bag2list" - OListToSet -> "list2set" - OListToBag -> "list2bag" - OBagToCounts -> "bag2counts" - OCountsToBag -> "counts2bag" + OAdd -> "+" + ONeg -> "-" + OSqrt -> "sqrt" + OFloor -> "floor" + OCeil -> "ceil" + OAbs -> "abs" + OMul -> "*" + ODiv -> "/" + OExp -> "^" + OMod -> "mod" + ODivides -> "divides" + OMultinom -> "choose" + OFact -> "!" + OEq -> "==" + OLt -> "<" + OEnum -> "enumerate" + OCount -> "count" + OPower -> "power" + OBagElem -> "elem_bag" + OListElem -> "elem_list" + OEachBag -> "each_bag" + OEachSet -> "each_set" + OFilterBag -> "filter_bag" + OMerge -> "merge" + OBagUnions -> "unions_bag" + OSummary -> "summary" + OEmptyGraph -> "emptyGraph" + OVertex -> "vertex" + OOverlay -> "overlay" + OConnect -> "connect" + OInsert -> "insert" + OLookup -> "lookup" + OUntil -> "until" + OSetToList -> "set2list" + OBagToSet -> "bag2set" + OBagToList -> "bag2list" + OListToSet -> "list2set" + OListToBag -> "list2bag" + OBagToCounts -> "bag2counts" + OCountsToBag -> "counts2bag" OUnsafeCountsToBag -> "ucounts2bag" - OMapToSet -> "map2set" - OSetToMap -> "set2map" - OIsPrime -> "isPrime" - OFactor -> "factor" - OFrac -> "frac" - OHolds -> "holds" - ONotProp -> "not" - OShouldEq _ -> "=!=" - OMatchErr -> "matchErr" - OCrash -> "crash" - OId -> "id" - OLookupSeq -> "lookupSeq" - OExtendSeq -> "extendSeq" - OForall{} -> "∀" - OExists{} -> "∃" + OMapToSet -> "map2set" + OSetToMap -> "set2map" + OIsPrime -> "isPrime" + OFactor -> "factor" + OFrac -> "frac" + OHolds -> "holds" + ONotProp -> "not" + OShouldEq _ -> "=!=" + OShouldLt _ -> "!<" + OMatchErr -> "matchErr" + OCrash -> "crash" + OId -> "id" + OLookupSeq -> "lookupSeq" + OExtendSeq -> "extendSeq" + OForall {} -> "∀" + OExists {} -> "∃" + OAnd -> "and" + OOr -> "or" + OImpl -> "implies" diff --git a/src/Disco/AST/Desugared.hs b/src/Disco/AST/Desugared.hs --- a/src/Disco/AST/Desugared.hs +++ b/src/Disco/AST/Desugared.hs @@ -1,6 +1,5 @@ {-# LANGUAGE PatternSynonyms #-} ------------------------------------------------------------------------------ -- | -- Module : Disco.AST.Desugared -- Copyright : disco team and contributors @@ -10,57 +9,51 @@ -- -- Typed abstract syntax trees representing the typechecked, desugared -- Disco language. --- ------------------------------------------------------------------------------ - -module Disco.AST.Desugared - ( -- * Desugared, type-annotated terms - DTerm - , pattern DTVar - , pattern DTPrim - , pattern DTUnit - , pattern DTBool - , pattern DTChar - , pattern DTNat - , pattern DTRat - , pattern DTAbs - , pattern DTApp - , pattern DTPair - , pattern DTCase - , pattern DTTyOp - , pattern DTNil - , pattern DTTest - - , Container(..) - , DBinding - , pattern DBinding - -- * Branches and guards - , DBranch - - , DGuard - , pattern DGPat - - , DPattern - , pattern DPVar - , pattern DPWild - , pattern DPUnit - , pattern DPPair - , pattern DPInj +module Disco.AST.Desugared ( + -- * Desugared, type-annotated terms + DTerm, + pattern DTVar, + pattern DTPrim, + pattern DTUnit, + pattern DTBool, + pattern DTChar, + pattern DTNat, + pattern DTRat, + pattern DTAbs, + pattern DTApp, + pattern DTPair, + pattern DTCase, + pattern DTTyOp, + pattern DTNil, + pattern DTTest, + Container (..), + DBinding, + pattern DBinding, - , DProperty - ) - where + -- * Branches and guards + DBranch, + DGuard, + pattern DGPat, + DPattern, + pattern DPVar, + pattern DPWild, + pattern DPUnit, + pattern DPPair, + pattern DPInj, + DProperty, +) +where -import GHC.Generics +import GHC.Generics -import Data.Void -import Unbound.Generics.LocallyNameless +import Data.Void +import Unbound.Generics.LocallyNameless -import Disco.AST.Generic -import Disco.Names (QName (..)) -import Disco.Syntax.Operators -import Disco.Syntax.Prims -import Disco.Types +import Disco.AST.Generic +import Disco.Names (QName (..)) +import Disco.Syntax.Operators +import Disco.Syntax.Prims +import Disco.Types data DS @@ -69,36 +62,37 @@ -- | A @DTerm@ is a term which has been typechecked and desugared, so -- it has fewer constructors and complex features than 'ATerm', but -- still retains typing information. - type DTerm = Term_ DS -type instance X_Binder DS = Name DTerm +type instance X_Binder DS = Name DTerm -type instance X_TVar DS = Void -- names are qualified -type instance X_TPrim DS = Type -type instance X_TLet DS = Void -- Let gets translated to lambda -type instance X_TUnit DS = () -type instance X_TBool DS = Type -type instance X_TChar DS = () -type instance X_TString DS = Void -type instance X_TNat DS = Type -type instance X_TRat DS = () -type instance X_TAbs DS = Type -- For lambas this is the function type but - -- for forall/exists it's the argument type -type instance X_TApp DS = Type -type instance X_TCase DS = Type -type instance X_TChain DS = Void -- Chains are translated into conjunctions of - -- binary comparisons -type instance X_TTyOp DS = Type -type instance X_TContainer DS = Void -- Literal containers are desugared into - -- conversion functions applied to list literals +type instance X_TVar DS = Void -- names are qualified +type instance X_TPrim DS = Type +type instance X_TLet DS = Void -- Let gets translated to lambda +type instance X_TUnit DS = () +type instance X_TBool DS = Type +type instance X_TChar DS = () +type instance X_TString DS = Void +type instance X_TNat DS = Type +type instance X_TRat DS = () +type instance X_TAbs DS = Type -- For lambas this is the function type but +-- for forall/exists it's the argument type +type instance X_TApp DS = Type +type instance X_TCase DS = Type +type instance X_TChain DS = Void -- Chains are translated into conjunctions of +-- binary comparisons + +type instance X_TTyOp DS = Type +type instance X_TContainer DS = Void -- Literal containers are desugared into +-- conversion functions applied to list literals + type instance X_TContainerComp DS = Void -- Container comprehensions are translated - -- into monadic chains +-- into monadic chains -type instance X_TAscr DS = Void -- No type ascriptions -type instance X_TTup DS = Void -- No tuples, only pairs -type instance X_TParens DS = Void -- No explicit parens +type instance X_TAscr DS = Void -- No type ascriptions +type instance X_TTup DS = Void -- No tuples, only pairs +type instance X_TParens DS = Void -- No explicit parens -- Extra constructors type instance X_Term DS = X_DTerm @@ -125,7 +119,7 @@ pattern DTBool :: Type -> Bool -> DTerm pattern DTBool ty bool = TBool_ ty bool -pattern DTNat :: Type -> Integer -> DTerm +pattern DTNat :: Type -> Integer -> DTerm pattern DTNat ty int = TNat_ ty int pattern DTRat :: Rational -> DTerm @@ -137,7 +131,7 @@ pattern DTAbs :: Quantifier -> Type -> Bind (Name DTerm) DTerm -> DTerm pattern DTAbs q ty lam = TAbs_ q ty lam -pattern DTApp :: Type -> DTerm -> DTerm -> DTerm +pattern DTApp :: Type -> DTerm -> DTerm -> DTerm pattern DTApp ty term1 term2 = TApp_ ty term1 term2 pattern DTPair :: Type -> DTerm -> DTerm -> DTerm @@ -158,9 +152,22 @@ pattern DTTest :: [(String, Type, Name DTerm)] -> DTerm -> DTerm pattern DTTest ns t = XTerm_ (DTTest_ ns t) -{-# COMPLETE DTVar, DTPrim, DTUnit, DTBool, DTChar, DTNat, DTRat, - DTAbs, DTApp, DTPair, DTCase, DTTyOp, - DTNil, DTTest #-} +{-# COMPLETE + DTVar + , DTPrim + , DTUnit + , DTBool + , DTChar + , DTNat + , DTRat + , DTAbs + , DTApp + , DTPair + , DTCase + , DTTyOp + , DTNil + , DTTest + #-} type instance X_TLink DS = Void @@ -175,9 +182,9 @@ type DGuard = Guard_ DS -type instance X_GBool DS = Void -- Boolean guards get desugared to pattern-matching -type instance X_GPat DS = () -type instance X_GLet DS = Void -- Let gets desugared to 'when' with a variable +type instance X_GBool DS = Void -- Boolean guards get desugared to pattern-matching +type instance X_GPat DS = () +type instance X_GLet DS = Void -- Let gets desugared to 'when' with a variable pattern DGPat :: Embed DTerm -> DPattern -> DGuard pattern DGPat embedt pat = GPat_ () embedt pat @@ -186,23 +193,23 @@ type DPattern = Pattern_ DS -type instance X_PVar DS = Embed Type -type instance X_PWild DS = Embed Type -type instance X_PAscr DS = Void -type instance X_PUnit DS = () -type instance X_PBool DS = Void -type instance X_PChar DS = Void -type instance X_PString DS = Void -type instance X_PTup DS = Void -type instance X_PInj DS = Void -type instance X_PNat DS = Void -type instance X_PCons DS = Void -type instance X_PList DS = Void -type instance X_PAdd DS = Void -type instance X_PMul DS = Void -type instance X_PSub DS = Void -type instance X_PNeg DS = Void -type instance X_PFrac DS = Void +type instance X_PVar DS = Embed Type +type instance X_PWild DS = Embed Type +type instance X_PAscr DS = Void +type instance X_PUnit DS = () +type instance X_PBool DS = Void +type instance X_PChar DS = Void +type instance X_PString DS = Void +type instance X_PTup DS = Void +type instance X_PInj DS = Void +type instance X_PNat DS = Void +type instance X_PCons DS = Void +type instance X_PList DS = Void +type instance X_PAdd DS = Void +type instance X_PMul DS = Void +type instance X_PSub DS = Void +type instance X_PNeg DS = Void +type instance X_PFrac DS = Void -- In the desugared language, constructor patterns (DPPair, DPInj) can -- only contain variables, not nested patterns. This means that the @@ -210,10 +217,11 @@ -- exploding nested patterns into sequential guards, which makes the -- interpreter simpler. -type instance X_Pattern DS = - Either - (Embed Type, Name DTerm, Name DTerm) -- DPPair - (Embed Type, Side, Name DTerm) -- DPInj +type instance + X_Pattern DS = + Either + (Embed Type, Name DTerm, Name DTerm) -- DPPair + (Embed Type, Side, Name DTerm) -- DPInj pattern DPVar :: Type -> Name DTerm -> DPattern pattern DPVar ty name <- PVar_ (unembed -> ty) name @@ -228,19 +236,19 @@ pattern DPUnit :: DPattern pattern DPUnit = PUnit_ () -pattern DPPair :: Type -> Name DTerm -> Name DTerm -> DPattern +pattern DPPair :: Type -> Name DTerm -> Name DTerm -> DPattern pattern DPPair ty x1 x2 <- XPattern_ (Left (unembed -> ty, x1, x2)) where DPPair ty x1 x2 = XPattern_ (Left (embed ty, x1, x2)) -pattern DPInj :: Type -> Side -> Name DTerm -> DPattern +pattern DPInj :: Type -> Side -> Name DTerm -> DPattern pattern DPInj ty s x <- XPattern_ (Right (unembed -> ty, s, x)) where DPInj ty s x = XPattern_ (Right (embed ty, s, x)) {-# COMPLETE DPVar, DPWild, DPUnit, DPPair, DPInj #-} -type instance X_QBind DS = Void +type instance X_QBind DS = Void type instance X_QGuard DS = Void ------------------------------------------------------------ @@ -248,25 +256,25 @@ ------------------------------------------------------------ instance HasType DTerm where - getType (DTVar ty _) = ty - getType (DTPrim ty _) = ty - getType DTUnit = TyUnit - getType (DTBool ty _) = ty - getType (DTChar _) = TyC - getType (DTNat ty _) = ty - getType (DTRat _) = TyF + getType (DTVar ty _) = ty + getType (DTPrim ty _) = ty + getType DTUnit = TyUnit + getType (DTBool ty _) = ty + getType (DTChar _) = TyC + getType (DTNat ty _) = ty + getType (DTRat _) = TyF getType (DTAbs Lam ty _) = ty - getType DTAbs{} = TyProp - getType (DTApp ty _ _) = ty - getType (DTPair ty _ _) = ty - getType (DTCase ty _) = ty - getType (DTTyOp ty _ _) = ty - getType (DTNil ty) = ty - getType (DTTest _ _) = TyProp + getType DTAbs {} = TyProp + getType (DTApp ty _ _) = ty + getType (DTPair ty _ _) = ty + getType (DTCase ty _) = ty + getType (DTTyOp ty _ _) = ty + getType (DTNil ty) = ty + getType (DTTest _ _) = TyProp instance HasType DPattern where - getType (DPVar ty _) = ty - getType (DPWild ty) = ty - getType DPUnit = TyUnit + getType (DPVar ty _) = ty + getType (DPWild ty) = ty + getType DPUnit = TyUnit getType (DPPair ty _ _) = ty - getType (DPInj ty _ _) = ty + getType (DPInj ty _ _) = ty diff --git a/src/Disco/AST/Generic.hs b/src/Disco/AST/Generic.hs --- a/src/Disco/AST/Generic.hs +++ b/src/Disco/AST/Generic.hs @@ -1,15 +1,19 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} - -- Orphan Alpha Void instance {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + +-- SPDX-License-Identifier: BSD-3-Clause + -- | -- Module : Disco.AST.Generic -- Copyright : disco team and contributors @@ -36,128 +40,117 @@ -- underlying type. Particular instantiations of the generic -- framework here can be found in "Disco.AST.Surface", -- "Disco.AST.Typed", and "Disco.AST.Desugared". ------------------------------------------------------------------------------ - --- SPDX-License-Identifier: BSD-3-Clause - -module Disco.AST.Generic - ( -- * Telescopes - - Telescope (..), telCons - , foldTelescope, mapTelescope - , traverseTelescope - , toTelescope, fromTelescope - - -- * Utility types - - , Side (..), selectSide, fromSide - , Container (..) - , Ellipsis (..) - - -- * Term - - , Term_ (..) - - , X_TVar - , X_TPrim - , X_TLet - , X_TParens - , X_TUnit - , X_TBool - , X_TNat - , X_TRat - , X_TChar - , X_TString - , X_TAbs - , X_TApp - , X_TTup - , X_TCase - , X_TChain - , X_TTyOp - , X_TContainer - , X_TContainerComp - , X_TAscr - , X_Term - - , ForallTerm - - -- * Link - - , Link_ (..) - , X_TLink - , ForallLink - - -- * Qual - - , Qual_ (..) - , X_QBind - , X_QGuard - , ForallQual - - -- * Binding +module Disco.AST.Generic ( + -- * Telescopes + Telescope (..), + telCons, + foldTelescope, + mapTelescope, + traverseTelescope, + toTelescope, + fromTelescope, - , Binding_ (..) + -- * Utility types + Side (..), + selectSide, + fromSide, + Container (..), + Ellipsis (..), - -- * Branch - , Branch_ + -- * Term + Term_ (..), + X_TVar, + X_TPrim, + X_TLet, + X_TParens, + X_TUnit, + X_TBool, + X_TNat, + X_TRat, + X_TChar, + X_TString, + X_TAbs, + X_TApp, + X_TTup, + X_TCase, + X_TChain, + X_TTyOp, + X_TContainer, + X_TContainerComp, + X_TAscr, + X_Term, + ForallTerm, - -- * Guard + -- * Link + Link_ (..), + X_TLink, + ForallLink, - , Guard_ (..) - , X_GBool - , X_GPat - , X_GLet - , ForallGuard + -- * Qual + Qual_ (..), + X_QBind, + X_QGuard, + ForallQual, - -- * Pattern + -- * Binding + Binding_ (..), - , Pattern_ (..) - , X_PVar - , X_PWild - , X_PAscr - , X_PUnit - , X_PBool - , X_PTup - , X_PInj - , X_PNat - , X_PChar - , X_PString - , X_PCons - , X_PList - , X_PAdd - , X_PMul - , X_PSub - , X_PNeg - , X_PFrac - , X_Pattern - , ForallPattern + -- * Branch + Branch_, - -- * Quantifiers + -- * Guard + Guard_ (..), + X_GBool, + X_GPat, + X_GLet, + ForallGuard, - , Quantifier(..) - , Binder_ - , X_Binder + -- * Pattern + Pattern_ (..), + X_PVar, + X_PWild, + X_PAscr, + X_PUnit, + X_PBool, + X_PTup, + X_PInj, + X_PNat, + X_PChar, + X_PString, + X_PCons, + X_PList, + X_PAdd, + X_PMul, + X_PSub, + X_PNeg, + X_PFrac, + X_Pattern, + ForallPattern, - -- * Property + -- * Quantifiers + Quantifier (..), + Binder_, + X_Binder, - , Property_ - ) - where + -- * Property + Property_, +) +where -import Control.Lens.Plated -import Data.Data (Data) -import Data.Data.Lens (uniplate) -import Data.Typeable -import GHC.Exts (Constraint) -import GHC.Generics (Generic) +import Control.Lens.Plated +import Data.Data (Data) +import Data.Data.Lens (uniplate) +import Data.Typeable +import GHC.Exts (Constraint) +import GHC.Generics (Generic) -import Data.Void -import Unbound.Generics.LocallyNameless +import Data.Void +import Unbound.Generics.LocallyNameless -import Disco.Pretty -import Disco.Syntax.Operators -import Disco.Syntax.Prims -import Disco.Types +import Disco.Pretty +import Disco.Syntax.Operators +import Disco.Syntax.Prims +import Disco.Types ------------------------------------------------------------ -- Telescopes @@ -166,13 +159,11 @@ -- | A telescope is essentially a list, except that each item can bind -- names in the rest of the list. data Telescope b where - -- | The empty telescope. TelEmpty :: Telescope b - -- | A binder of type @b@ followed by zero or more @b@'s. This @b@ -- can bind variables in the subsequent @b@'s. - TelCons :: Rebind b (Telescope b) -> Telescope b + TelCons :: Rebind b (Telescope b) -> Telescope b deriving (Show, Generic, Alpha, Subst t, Data) -- | Add a new item to the beginning of a 'Telescope'. @@ -182,17 +173,19 @@ -- | Fold a telescope given a combining function and a value to use -- for the empty telescope. Analogous to 'foldr' for lists. foldTelescope :: Alpha b => (b -> r -> r) -> r -> Telescope b -> r -foldTelescope _ z TelEmpty = z -foldTelescope f z (TelCons (unrebind -> (b,bs))) = f b (foldTelescope f z bs) +foldTelescope _ z TelEmpty = z +foldTelescope f z (TelCons (unrebind -> (b, bs))) = f b (foldTelescope f z bs) -- | Apply a function to every item in a telescope. mapTelescope :: (Alpha a, Alpha b) => (a -> b) -> Telescope a -> Telescope b mapTelescope f = toTelescope . map f . fromTelescope -- | Traverse over a telescope. -traverseTelescope - :: (Applicative f, Alpha a, Alpha b) - => (a -> f b) -> Telescope a -> f (Telescope b) +traverseTelescope :: + (Applicative f, Alpha a, Alpha b) => + (a -> f b) -> + Telescope a -> + f (Telescope b) traverseTelescope f = foldTelescope (\a ftb -> telCons <$> f a <*> ftb) (pure TelEmpty) -- | Convert a list to a telescope. @@ -230,8 +223,8 @@ -- lists, bags, and sets. data Container where ListContainer :: Container - BagContainer :: Container - SetContainer :: Container + BagContainer :: Container + SetContainer :: Container deriving (Show, Eq, Enum, Generic, Data, Alpha, Subst t) -- | An ellipsis is an "omitted" part of a literal container (such as @@ -240,7 +233,7 @@ -- containers must be finite. data Ellipsis t where -- | 'Until' represents an ellipsis with a given endpoint, as in @[3 .. 20]@. - Until :: t -> Ellipsis t -- @.. t@ + Until :: t -> Ellipsis t -- @.. t@ deriving (Show, Generic, Functor, Foldable, Traversable, Alpha, Subst a, Data) ------------------------------------------------------------ @@ -276,43 +269,32 @@ -- example, in the typed phase many constructors store an extra -- type, giving the type of the term. data Term_ e where - -- | A term variable. - TVar_ :: X_TVar e -> Name (Term_ e) -> Term_ e - + TVar_ :: X_TVar e -> Name (Term_ e) -> Term_ e -- | A primitive, /i.e./ a constant which is interpreted specially -- at runtime. See "Disco.Syntax.Prims". - TPrim_ :: X_TPrim e -> Prim -> Term_ e - + TPrim_ :: X_TPrim e -> Prim -> Term_ e -- | A (non-recursive) let expression, @let x1 = t1, x2 = t2, ... in t@. - TLet_ :: X_TLet e -> Bind (Telescope (Binding_ e)) (Term_ e) -> Term_ e - + TLet_ :: X_TLet e -> Bind (Telescope (Binding_ e)) (Term_ e) -> Term_ e -- | Explicit parentheses. We need to keep track of these in the -- surface syntax in order to syntactically distinguish -- multiplication and function application. However, note that -- these disappear after the surface syntax phase. TParens_ :: X_TParens e -> Term_ e -> Term_ e - -- | The unit value, (), of type Unit. - TUnit_ :: X_TUnit e -> Term_ e - + TUnit_ :: X_TUnit e -> Term_ e -- | A boolean value. - TBool_ :: X_TBool e -> Bool -> Term_ e - + TBool_ :: X_TBool e -> Bool -> Term_ e -- | A natural number. - TNat_ :: X_TNat e -> Integer -> Term_ e - + TNat_ :: X_TNat e -> Integer -> Term_ e -- | A nonnegative rational number, parsed as a decimal. (Note -- syntax like @3/5@ does not parse as a rational, but rather as -- the application of a division operator to two natural numbers.) - TRat_ :: X_TRat e -> Rational -> Term_ e - + TRat_ :: X_TRat e -> Rational -> Term_ e -- | A literal unicode character, /e.g./ @'d'@. - TChar_ :: X_TChar e -> Char -> Term_ e - + TChar_ :: X_TChar e -> Char -> Term_ e -- | A string literal, /e.g./ @"disco"@. TString_ :: X_TString e -> [Char] -> Term_ e - -- | A binding abstraction, of the form @Q vars. expr@ where @Q@ is -- a quantifier and @vars@ is a list of bound variables and -- optional type annotations. In particular, this could be a @@ -320,77 +302,68 @@ -- (y:N). 2x + y@), a universal quantifier (@forall x, (y:N). x^2 + -- y > 0@), or an existential quantifier (@exists x, (y:N). x^2 + y -- == 0@). - TAbs_ :: Quantifier -> X_TAbs e -> Binder_ e (Term_ e) -> Term_ e - + TAbs_ :: Quantifier -> X_TAbs e -> Binder_ e (Term_ e) -> Term_ e -- | Function application, @t1 t2@. - TApp_ :: X_TApp e -> Term_ e -> Term_ e -> Term_ e - + TApp_ :: X_TApp e -> Term_ e -> Term_ e -> Term_ e -- | An n-tuple, @(t1, ..., tn)@. - TTup_ :: X_TTup e -> [Term_ e] -> Term_ e - + TTup_ :: X_TTup e -> [Term_ e] -> Term_ e -- | A case expression. - TCase_ :: X_TCase e -> [Branch_ e] -> Term_ e - + TCase_ :: X_TCase e -> [Branch_ e] -> Term_ e -- | A chained comparison, consisting of a term followed by one or -- more "links", where each link is a comparison operator and -- another term. TChain_ :: X_TChain e -> Term_ e -> [Link_ e] -> Term_ e - -- | An application of a type operator. - TTyOp_ :: X_TTyOp e -> TyOp -> Type -> Term_ e - + TTyOp_ :: X_TTyOp e -> TyOp -> Type -> Term_ e -- | A containter literal (set, bag, or list). TContainer_ :: X_TContainer e -> Container -> [(Term_ e, Maybe (Term_ e))] -> Maybe (Ellipsis (Term_ e)) -> Term_ e - -- | A container comprehension. TContainerComp_ :: X_TContainerComp e -> Container -> Bind (Telescope (Qual_ e)) (Term_ e) -> Term_ e - -- | Type ascription, @(Term_ e : type)@. - TAscr_ :: X_TAscr e -> Term_ e -> PolyType -> Term_ e - + TAscr_ :: X_TAscr e -> Term_ e -> PolyType -> Term_ e -- | A data constructor with an extension descriptor that a "concrete" -- implementation of a generic AST may use to carry extra information. - XTerm_ :: X_Term e -> Term_ e + XTerm_ :: X_Term e -> Term_ e deriving (Generic) -- A type that abstracts over constraints for generic data constructors. -- This makes it easier to derive typeclass instances for generic types. -type ForallTerm (a :: * -> Constraint) e - = ( a (X_TVar e) - , a (X_TPrim e) - , a (X_TLet e) - , a (X_TParens e) - , a (X_TUnit e) - , a (X_TBool e) - , a (X_TNat e) - , a (X_TRat e) - , a (X_TChar e) - , a (X_TString e) - , a (X_TAbs e) - , a (X_TApp e) - , a (X_TCase e) - , a (X_TTup e) - , a (X_TChain e) - , a (X_TTyOp e) - , a (X_TContainer e) - , a (X_TContainerComp e) - , a (X_TAscr e) - , a (X_Term e) - , a (Qual_ e) - , a (Guard_ e) - , a (Link_ e) - , a (Binding_ e) - , a (Pattern_ e) - , a (Binder_ e (Term_ e)) - ) +type ForallTerm (a :: * -> Constraint) e = + ( a (X_TVar e) + , a (X_TPrim e) + , a (X_TLet e) + , a (X_TParens e) + , a (X_TUnit e) + , a (X_TBool e) + , a (X_TNat e) + , a (X_TRat e) + , a (X_TChar e) + , a (X_TString e) + , a (X_TAbs e) + , a (X_TApp e) + , a (X_TCase e) + , a (X_TTup e) + , a (X_TChain e) + , a (X_TTyOp e) + , a (X_TContainer e) + , a (X_TContainerComp e) + , a (X_TAscr e) + , a (X_Term e) + , a (Qual_ e) + , a (Guard_ e) + , a (Link_ e) + , a (Binding_ e) + , a (Pattern_ e) + , a (Binder_ e (Term_ e)) + ) deriving instance ForallTerm Show e => Show (Term_ e) instance ( Typeable e , ForallTerm (Subst Type) e , ForallTerm Alpha e - ) - => Subst Type (Term_ e) + ) => + Subst Type (Term_ e) instance (Typeable e, ForallTerm Alpha e) => Alpha (Term_ e) deriving instance (Data e, Typeable e, ForallTerm Data e) => Data (Term_ e) @@ -407,19 +380,18 @@ -- followed by a sequence of links makes up a comparison chain, such -- as @2 < x < y < 10@. data Link_ e where - -- | Note that although the type of 'TLink_' says it can hold any -- 'BOp', it should really only hold comparison operators. TLink_ :: X_TLink e -> BOp -> Term_ e -> Link_ e - deriving Generic + deriving (Generic) -type ForallLink (a :: * -> Constraint) e - = ( a (X_TLink e) - , a (Term_ e) - ) +type ForallLink (a :: * -> Constraint) e = + ( a (X_TLink e) + , a (Term_ e) + ) -deriving instance ForallLink Show e => Show (Link_ e) -instance ForallLink (Subst Type) e => Subst Type (Link_ e) +deriving instance ForallLink Show e => Show (Link_ e) +instance ForallLink (Subst Type) e => Subst Type (Link_ e) instance (Typeable e, Show (Link_ e), ForallLink Alpha e) => Alpha (Link_ e) deriving instance (Typeable e, Data e, ForallLink Data e) => Data (Link_ e) @@ -434,23 +406,20 @@ -- of qualifiers. Each qualifier either binds a variable to some -- collection or consists of a boolean guard. data Qual_ e where - -- | A binding qualifier (i.e. @x in t@). - QBind_ :: X_QBind e -> Name (Term_ e) -> Embed (Term_ e) -> Qual_ e - + QBind_ :: X_QBind e -> Name (Term_ e) -> Embed (Term_ e) -> Qual_ e -- | A boolean guard qualfier (i.e. @x + y > 4@). - QGuard_ :: X_QGuard e -> Embed (Term_ e) -> Qual_ e - - deriving Generic + QGuard_ :: X_QGuard e -> Embed (Term_ e) -> Qual_ e + deriving (Generic) -type ForallQual (a :: * -> Constraint) e - = ( a (X_QBind e) - , a (X_QGuard e) - , a (Term_ e) - ) +type ForallQual (a :: * -> Constraint) e = + ( a (X_QBind e) + , a (X_QGuard e) + , a (Term_ e) + ) -deriving instance ForallQual Show e => Show (Qual_ e) -instance ForallQual (Subst Type) e => Subst Type (Qual_ e) +deriving instance ForallQual Show e => Show (Qual_ e) +instance ForallQual (Subst Type) e => Subst Type (Qual_ e) instance (Typeable e, ForallQual Alpha e) => Alpha (Qual_ e) deriving instance (Typeable e, Data e, ForallQual Data e) => Data (Qual_ e) @@ -463,7 +432,7 @@ data Binding_ e = Binding_ (Maybe (Embed PolyType)) (Name (Term_ e)) (Embed (Term_ e)) deriving (Generic) -deriving instance ForallTerm Show e => Show (Binding_ e) +deriving instance ForallTerm Show e => Show (Binding_ e) instance Subst Type (Term_ e) => Subst Type (Binding_ e) instance (Typeable e, Show (Binding_ e), Alpha (Term_ e)) => Alpha (Binding_ e) deriving instance (Typeable e, Data e, ForallTerm Data e) => Data (Binding_ e) @@ -475,7 +444,6 @@ -- | A branch of a case is a list of guards with an accompanying term. -- The guards scope over the term. Additionally, each guard scopes -- over subsequent guards. - type Branch_ e = Bind (Telescope (Guard_ e)) (Term_ e) ------------------------------------------------------------ @@ -488,29 +456,25 @@ -- | Guards in case expressions. data Guard_ e where - -- | Boolean guard (@if @) GBool_ :: X_GBool e -> Embed (Term_ e) -> Guard_ e - -- | Pattern guard (@when term = pat@) - GPat_ :: X_GPat e -> Embed (Term_ e) -> Pattern_ e -> Guard_ e - + GPat_ :: X_GPat e -> Embed (Term_ e) -> Pattern_ e -> Guard_ e -- | Let (@let x = term@) - GLet_ :: X_GLet e -> Binding_ e -> Guard_ e - - deriving Generic + GLet_ :: X_GLet e -> Binding_ e -> Guard_ e + deriving (Generic) -type ForallGuard (a :: * -> Constraint) e - = ( a (X_GBool e) - , a (X_GPat e) - , a (X_GLet e) - , a (Term_ e) - , a (Pattern_ e) - , a (Binding_ e) - ) +type ForallGuard (a :: * -> Constraint) e = + ( a (X_GBool e) + , a (X_GPat e) + , a (X_GLet e) + , a (Term_ e) + , a (Pattern_ e) + , a (Binding_ e) + ) -deriving instance ForallGuard Show e => Show (Guard_ e) -instance ForallGuard (Subst Type) e => Subst Type (Guard_ e) +deriving instance ForallGuard Show e => Show (Guard_ e) +instance ForallGuard (Subst Type) e => Subst Type (Guard_ e) instance (Typeable e, Show (Guard_ e), ForallGuard Alpha e) => Alpha (Guard_ e) deriving instance (Typeable e, Data e, ForallGuard Data e) => Data (Guard_ e) @@ -539,87 +503,72 @@ -- | Patterns. data Pattern_ e where - -- | Variable pattern: matches anything and binds the variable. - PVar_ :: X_PVar e -> Name (Term_ e) -> Pattern_ e - + PVar_ :: X_PVar e -> Name (Term_ e) -> Pattern_ e -- | Wildcard pattern @_@: matches anything. PWild_ :: X_PWild e -> Pattern_ e - -- | Type ascription pattern @pat : ty@. PAscr_ :: X_PAscr e -> Pattern_ e -> Type -> Pattern_ e - -- | Unit pattern @()@: matches @()@. PUnit_ :: X_PUnit e -> Pattern_ e - -- | Literal boolean pattern. PBool_ :: X_PBool e -> Bool -> Pattern_ e - -- | Tuple pattern @(pat1, .. , patn)@. - PTup_ :: X_PTup e -> [Pattern_ e] -> Pattern_ e - + PTup_ :: X_PTup e -> [Pattern_ e] -> Pattern_ e -- | Injection pattern (@inl pat@ or @inr pat@). - PInj_ :: X_PInj e -> Side -> Pattern_ e -> Pattern_ e - + PInj_ :: X_PInj e -> Side -> Pattern_ e -> Pattern_ e -- | Literal natural number pattern. - PNat_ :: X_PNat e -> Integer -> Pattern_ e - + PNat_ :: X_PNat e -> Integer -> Pattern_ e -- | Unicode character pattern PChar_ :: X_PChar e -> Char -> Pattern_ e - -- | String pattern. PString_ :: X_PString e -> String -> Pattern_ e - -- | Cons pattern @p1 :: p2@. PCons_ :: X_PCons e -> Pattern_ e -> Pattern_ e -> Pattern_ e - -- | List pattern @[p1, .., pn]@. PList_ :: X_PList e -> [Pattern_ e] -> Pattern_ e - -- | Addition pattern, @p + t@ or @t + p@ - PAdd_ :: X_PAdd e -> Side -> Pattern_ e -> Term_ e -> Pattern_ e - + PAdd_ :: X_PAdd e -> Side -> Pattern_ e -> Term_ e -> Pattern_ e -- | Multiplication pattern, @p * t@ or @t * p@ - PMul_ :: X_PMul e -> Side -> Pattern_ e -> Term_ e -> Pattern_ e - + PMul_ :: X_PMul e -> Side -> Pattern_ e -> Term_ e -> Pattern_ e -- | Subtraction pattern, @p - t@ - PSub_ :: X_PSub e -> Pattern_ e -> Term_ e -> Pattern_ e - + PSub_ :: X_PSub e -> Pattern_ e -> Term_ e -> Pattern_ e -- | Negation pattern, @-p@ - PNeg_ :: X_PNeg e -> Pattern_ e -> Pattern_ e - + PNeg_ :: X_PNeg e -> Pattern_ e -> Pattern_ e -- | Fraction pattern, @p1/p2@ PFrac_ :: X_PFrac e -> Pattern_ e -> Pattern_ e -> Pattern_ e - + -- | A special placeholder node for a nonlinear occurrence of a + -- variable; we can only detect this at parse time but need to + -- generate an error later. + PNonlinear_ :: Embed (Pattern_ e) -> Name (Term_ e) -> Pattern_ e -- | Expansion slot. XPattern_ :: X_Pattern e -> Pattern_ e - deriving (Generic) -type ForallPattern (a :: * -> Constraint) e - = ( a (X_PVar e) - , a (X_PWild e) - , a (X_PAscr e) - , a (X_PUnit e) - , a (X_PBool e) - , a (X_PNat e) - , a (X_PChar e) - , a (X_PString e) - , a (X_PTup e) - , a (X_PInj e) - , a (X_PCons e) - , a (X_PList e) - , a (X_PAdd e) - , a (X_PMul e) - , a (X_PSub e) - , a (X_PNeg e) - , a (X_PFrac e) - , a (X_Pattern e) - , a (Term_ e) - ) +type ForallPattern (a :: * -> Constraint) e = + ( a (X_PVar e) + , a (X_PWild e) + , a (X_PAscr e) + , a (X_PUnit e) + , a (X_PBool e) + , a (X_PNat e) + , a (X_PChar e) + , a (X_PString e) + , a (X_PTup e) + , a (X_PInj e) + , a (X_PCons e) + , a (X_PList e) + , a (X_PAdd e) + , a (X_PMul e) + , a (X_PSub e) + , a (X_PNeg e) + , a (X_PFrac e) + , a (X_Pattern e) + , a (Term_ e) + ) -deriving instance ForallPattern Show e => Show (Pattern_ e) -instance ForallPattern (Subst Type) e => Subst Type (Pattern_ e) +deriving instance ForallPattern Show e => Show (Pattern_ e) +instance ForallPattern (Subst Type) e => Subst Type (Pattern_ e) instance (Typeable e, Show (Pattern_ e), ForallPattern Alpha e) => Alpha (Pattern_ e) deriving instance (Typeable e, Data e, ForallPattern Data e) => Data (Pattern_ e) diff --git a/src/Disco/AST/Surface.hs b/src/Disco/AST/Surface.hs --- a/src/Disco/AST/Surface.hs +++ b/src/Disco/AST/Surface.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} ------------------------------------------------------------------------------ -- | -- Module : Disco.AST.Surface -- Copyright : disco team and contributors @@ -12,147 +11,173 @@ -- -- Abstract syntax trees representing the surface syntax of the Disco -- language. --- ------------------------------------------------------------------------------ - -module Disco.AST.Surface - ( -- * Modules - Module(..), TopLevel(..) - -- ** Documentation - , Docs, DocThing(..), Property - -- ** Declarations - , TypeDecl(..), TermDefn(..), TypeDefn(..) - , Decl(..), partitionDecls, prettyTyDecl - - -- * Terms - , UD - , Term - , pattern TVar - , pattern TPrim - , pattern TUn - , pattern TBin - , pattern TLet - , pattern TParens - , pattern TUnit - , pattern TBool - , pattern TChar - , pattern TString - , pattern TNat - , pattern TRat - , pattern TAbs - , pattern TApp - , pattern TTup - , pattern TCase - , pattern TChain - , pattern TTyOp - , pattern TContainerComp - , pattern TContainer - , pattern TAscr - , pattern TWild - , pattern TList - , pattern TListComp - - , Quantifier(..) - - -- ** Telescopes - , Telescope(..), foldTelescope, mapTelescope, toTelescope, fromTelescope - -- ** Expressions - , Side(..) - - , Link - , pattern TLink - - , Binding +module Disco.AST.Surface ( + -- * Modules + Module (..), + emptyModule, + TopLevel (..), - -- ** Lists - , Qual - , pattern QBind - , pattern QGuard + -- ** Documentation + Docs, + DocThing (..), + Property, - , Container(..) + -- ** Declarations + TypeDecl (..), + TermDefn (..), + TypeDefn (..), + Decl (..), + partitionDecls, + prettyTyDecl, - , Ellipsis(..) + -- * Terms + UD, + Term, + pattern TVar, + pattern TPrim, + pattern TUn, + pattern TBin, + pattern TLet, + pattern TParens, + pattern TUnit, + pattern TBool, + pattern TChar, + pattern TString, + pattern TNat, + pattern TRat, + pattern TAbs, + pattern TApp, + pattern TTup, + pattern TCase, + pattern TChain, + pattern TTyOp, + pattern TContainerComp, + pattern TContainer, + pattern TAscr, + pattern TWild, + pattern TList, + pattern TListComp, + Quantifier (..), - -- ** Case expressions and patterns - , Branch + -- ** Telescopes + Telescope (..), + foldTelescope, + mapTelescope, + toTelescope, + fromTelescope, - , Guard - , pattern GBool - , pattern GPat - , pattern GLet + -- ** Expressions + Side (..), + Link, + pattern TLink, + Binding, - , Pattern - , pattern PVar - , pattern PWild - , pattern PAscr - , pattern PUnit - , pattern PBool - , pattern PChar - , pattern PString - , pattern PTup - , pattern PInj - , pattern PNat - , pattern PCons - , pattern PList - , pattern PAdd - , pattern PMul - , pattern PSub - , pattern PNeg - , pattern PFrac + -- ** Lists + Qual, + pattern QBind, + pattern QGuard, + Container (..), + Ellipsis (..), - , pattern Binding - ) - where + -- ** Case expressions and patterns + Branch, + Guard, + pattern GBool, + pattern GPat, + pattern GLet, + Pattern, + pattern PVar, + pattern PWild, + pattern PAscr, + pattern PUnit, + pattern PBool, + pattern PChar, + pattern PString, + pattern PTup, + pattern PInj, + pattern PNat, + pattern PCons, + pattern PList, + pattern PAdd, + pattern PMul, + pattern PSub, + pattern PNeg, + pattern PFrac, + pattern PNonlinear, + pattern Binding, +) +where -import Prelude hiding ((<>)) +import Prelude hiding ((<>)) -import Control.Lens (_1, _2, _3, (%~)) -import Data.Char (toLower) -import qualified Data.Map as M -import Data.Set (Set) -import Data.Void +import Control.Lens ((%~), _1, _2, _3) +import Data.Char (toLower) +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S +import Data.Void -import Disco.Effects.LFresh -import Polysemy hiding (Embed) -import Polysemy.Reader +import Disco.Effects.LFresh +import Polysemy hiding (Embed, embed) +import Polysemy.Reader -import Disco.AST.Generic -import Disco.Extensions -import Disco.Pretty -import Disco.Syntax.Operators -import Disco.Syntax.Prims -import Disco.Types -import Unbound.Generics.LocallyNameless hiding (LFresh (..), lunbind) +import Disco.AST.Generic +import Disco.Extensions +import Disco.Pretty +import Disco.Syntax.Operators +import Disco.Syntax.Prims +import Disco.Types +import Unbound.Generics.LocallyNameless hiding (LFresh (..), lunbind) -- | The extension descriptor for Surface specific AST types. data UD -- | A module contains all the information from one disco source file. data Module = Module - { modExts :: Set Ext -- ^ Enabled extensions - , modImports :: [String] -- ^ Module imports - , modDecls :: [Decl] -- ^ Declarations - , modDocs :: [(Name Term, Docs)] -- ^ Documentation - , modTerms :: [Term] -- ^ Top-level (bare) terms + { modExts :: Set Ext + -- ^ Enabled extensions + , modImports :: [String] + -- ^ Module imports + , modDecls :: [Decl] + -- ^ Declarations + , modDocs :: [(Name Term, Docs)] + -- ^ Documentation + , modTerms :: [Term] + -- ^ Top-level (bare) terms } -deriving instance ForallTerm Show UD => Show Module +deriving instance ForallTerm Show UD => Show Module + +emptyModule :: Module +emptyModule = + Module + { modExts = S.empty + , modImports = [] + , modDecls = [] + , modDocs = [] + , modTerms = [] + } + -- | A @TopLevel@ is either documentation (a 'DocThing') or a -- declaration ('Decl'). data TopLevel = TLDoc DocThing | TLDecl Decl | TLExpr Term -deriving instance ForallTerm Show UD => Show TopLevel +deriving instance ForallTerm Show UD => Show TopLevel + -- | Convenient synonym for a list of 'DocThing's. type Docs = [DocThing] -- | An item of documentation. data DocThing - = DocString [String] -- ^ A documentation string, i.e. a block - -- of @||| text@ items - | DocProperty Property -- ^ An example/doctest/property of the - -- form @!!! forall (x1:ty1) ... . property@ -deriving instance ForallTerm Show UD => Show DocThing + = -- | A documentation string, i.e. a block + -- of @||| text@ items + DocString [String] + | -- | An example/doctest/property of the + -- form @!!! forall (x1:ty1) ... . property@ + DocProperty Property +deriving instance ForallTerm Show UD => Show DocThing + -- | A property is a universally quantified term of the form -- @forall v1 : T1, v2 : T2. term@. type Property = Property_ UD @@ -169,24 +194,24 @@ -- -- @type T arg1 arg2 ... = body data TypeDefn = TypeDefn String [String] Type - deriving Show + deriving (Show) -- | A declaration is either a type declaration, a term definition, or -- a type definition. data Decl where - DType :: TypeDecl -> Decl - DDefn :: TermDefn -> Decl + DType :: TypeDecl -> Decl + DDefn :: TermDefn -> Decl DTyDef :: TypeDefn -> Decl -deriving instance ForallTerm Show UD => Show TypeDecl -deriving instance ForallTerm Show UD => Show TermDefn -deriving instance ForallTerm Show UD => Show Decl +deriving instance ForallTerm Show UD => Show TypeDecl +deriving instance ForallTerm Show UD => Show TermDefn +deriving instance ForallTerm Show UD => Show Decl partitionDecls :: [Decl] -> ([TypeDecl], [TermDefn], [TypeDefn]) -partitionDecls (DType tyDecl : ds) = (_1 %~ (tyDecl:)) (partitionDecls ds) -partitionDecls (DDefn def : ds) = (_2 %~ (def:)) (partitionDecls ds) -partitionDecls (DTyDef def : ds) = (_3 %~ (def:)) (partitionDecls ds) -partitionDecls [] = ([], [], []) +partitionDecls (DType tyDecl : ds) = (_1 %~ (tyDecl :)) (partitionDecls ds) +partitionDecls (DDefn def : ds) = (_2 %~ (def :)) (partitionDecls ds) +partitionDecls (DTyDef def : ds) = (_3 %~ (def :)) (partitionDecls ds) +partitionDecls [] = ([], [], []) ------------------------------------------------------------ -- Pretty-printing top-level declarations @@ -196,10 +221,10 @@ instance Pretty Decl where pretty = \case - DType (TypeDecl x ty) -> pretty x <+> text ":" <+> pretty ty + DType (TypeDecl x ty) -> pretty x <+> text ":" <+> pretty ty DTyDef (TypeDefn x args body) -> text "type" <+> text x <+> hsep (map text args) <+> text "=" <+> pretty body - DDefn (TermDefn x bs) -> vcat $ map (pretty . (x,)) bs + DDefn (TermDefn x bs) -> vcat $ map (pretty . (x,)) bs -- | Pretty-print a single clause in a definition. instance Pretty (Name a, Bind [Pattern] Term) where @@ -207,7 +232,7 @@ pretty x <> hcat (map prettyPatternP ps) <+> text "=" <+> setPA initPA (pretty t) -- | Pretty-print a type declaration. -prettyTyDecl :: Members '[Reader PA, LFresh] r => Name t -> Type -> Sem r Doc +prettyTyDecl :: Members '[Reader PA, LFresh] r => Name t -> Type -> Sem r (Doc ann) prettyTyDecl x ty = hsep [pretty x, text ":", pretty ty] ------------------------------------------------------------ @@ -219,28 +244,28 @@ -- (nonempty) list of patterns. Each pattern might contain any -- number of variables, and might have type annotations on some -- of its components. -type instance X_Binder UD = [Pattern] +type instance X_Binder UD = [Pattern] -type instance X_TVar UD = () -type instance X_TPrim UD = () -type instance X_TLet UD = () -type instance X_TParens UD = () -type instance X_TUnit UD = () -type instance X_TBool UD = () -type instance X_TNat UD = () -type instance X_TRat UD = () -type instance X_TChar UD = () -type instance X_TString UD = () -type instance X_TAbs UD = () -type instance X_TApp UD = () -type instance X_TTup UD = () -type instance X_TCase UD = () -type instance X_TChain UD = () -type instance X_TTyOp UD = () -type instance X_TContainer UD = () -type instance X_TContainerComp UD = () -type instance X_TAscr UD = () -type instance X_Term UD = () -- TWild +type instance X_TVar UD = () +type instance X_TPrim UD = () +type instance X_TLet UD = () +type instance X_TParens UD = () +type instance X_TUnit UD = () +type instance X_TBool UD = () +type instance X_TNat UD = () +type instance X_TRat UD = () +type instance X_TChar UD = () +type instance X_TString UD = () +type instance X_TAbs UD = () +type instance X_TApp UD = () +type instance X_TTup UD = () +type instance X_TCase UD = () +type instance X_TChain UD = () +type instance X_TTyOp UD = () +type instance X_TContainer UD = () +type instance X_TContainerComp UD = () +type instance X_TAscr UD = () +type instance X_Term UD = () -- TWild pattern TVar :: Name Term -> Term pattern TVar name = TVar_ () name @@ -258,7 +283,7 @@ pattern TLet bind = TLet_ () bind pattern TParens :: Term -> Term -pattern TParens term = TParens_ () term +pattern TParens term = TParens_ () term pattern TUnit :: Term pattern TUnit = TUnit_ () @@ -266,7 +291,7 @@ pattern TBool :: Bool -> Term pattern TBool bool = TBool_ () bool -pattern TNat :: Integer -> Term +pattern TNat :: Integer -> Term pattern TNat int = TNat_ () int pattern TRat :: Rational -> Term @@ -281,7 +306,7 @@ pattern TAbs :: Quantifier -> Bind [Pattern] Term -> Term pattern TAbs q bind = TAbs_ q () bind -pattern TApp :: Term -> Term -> Term +pattern TApp :: Term -> Term -> Term pattern TApp term1 term2 = TApp_ () term1 term2 pattern TTup :: [Term] -> Term @@ -311,9 +336,28 @@ pattern TWild :: Term pattern TWild = XTerm_ () -{-# COMPLETE TVar, TPrim, TLet, TParens, TUnit, TBool, TNat, TRat, TChar, - TString, TAbs, TApp, TTup, TCase, TChain, TTyOp, - TContainer, TContainerComp, TAscr, TWild #-} +{-# COMPLETE + TVar + , TPrim + , TLet + , TParens + , TUnit + , TBool + , TNat + , TRat + , TChar + , TString + , TAbs + , TApp + , TTup + , TCase + , TChain + , TTyOp + , TContainer + , TContainerComp + , TAscr + , TWild + #-} pattern TList :: [Term] -> Maybe (Ellipsis Term) -> Term pattern TList ts e <- TContainer_ () ListContainer (map fst -> ts) e @@ -357,8 +401,8 @@ type Guard = Guard_ UD type instance X_GBool UD = () -type instance X_GPat UD = () -type instance X_GLet UD = () +type instance X_GPat UD = () +type instance X_GLet UD = () pattern GBool :: Embed Term -> Guard pattern GBool embedt = GBool_ () embedt @@ -373,23 +417,23 @@ type Pattern = Pattern_ UD -type instance X_PVar UD = () -type instance X_PWild UD = () -type instance X_PAscr UD = () -type instance X_PUnit UD = () -type instance X_PBool UD = () -type instance X_PTup UD = () -type instance X_PInj UD = () -type instance X_PNat UD = () -type instance X_PChar UD = () +type instance X_PVar UD = () +type instance X_PWild UD = () +type instance X_PAscr UD = () +type instance X_PUnit UD = () +type instance X_PBool UD = () +type instance X_PTup UD = () +type instance X_PInj UD = () +type instance X_PNat UD = () +type instance X_PChar UD = () type instance X_PString UD = () -type instance X_PCons UD = () -type instance X_PList UD = () -type instance X_PAdd UD = () -type instance X_PMul UD = () -type instance X_PSub UD = () -type instance X_PNeg UD = () -type instance X_PFrac UD = () +type instance X_PCons UD = () +type instance X_PList UD = () +type instance X_PAdd UD = () +type instance X_PMul UD = () +type instance X_PSub UD = () +type instance X_PNeg UD = () +type instance X_PFrac UD = () type instance X_Pattern UD = Void pattern PVar :: Name Term -> Pattern @@ -398,8 +442,8 @@ pattern PWild :: Pattern pattern PWild = PWild_ () - -- (?) TAscr uses a PolyType, but without higher rank types - -- I think we can't possibly need that here. +-- (?) TAscr uses a PolyType, but without higher rank types +-- I think we can't possibly need that here. pattern PAscr :: Pattern -> Type -> Pattern pattern PAscr p ty = PAscr_ () p ty @@ -407,7 +451,7 @@ pattern PUnit = PUnit_ () pattern PBool :: Bool -> Pattern -pattern PBool b = PBool_ () b +pattern PBool b = PBool_ () b pattern PChar :: Char -> Pattern pattern PChar c = PChar_ () c @@ -415,17 +459,17 @@ pattern PString :: String -> Pattern pattern PString s = PString_ () s -pattern PTup :: [Pattern] -> Pattern +pattern PTup :: [Pattern] -> Pattern pattern PTup lp = PTup_ () lp -pattern PInj :: Side -> Pattern -> Pattern +pattern PInj :: Side -> Pattern -> Pattern pattern PInj s p = PInj_ () s p -pattern PNat :: Integer -> Pattern +pattern PNat :: Integer -> Pattern pattern PNat n = PNat_ () n pattern PCons :: Pattern -> Pattern -> Pattern -pattern PCons p1 p2 = PCons_ () p1 p2 +pattern PCons p1 p2 = PCons_ () p1 p2 pattern PList :: [Pattern] -> Pattern pattern PList lp = PList_ () lp @@ -445,9 +489,31 @@ pattern PFrac :: Pattern -> Pattern -> Pattern pattern PFrac p1 p2 = PFrac_ () p1 p2 -{-# COMPLETE PVar, PWild, PAscr, PUnit, PBool, PTup, PInj, PNat, - PChar, PString, PCons, PList, PAdd, PMul, PSub, PNeg, PFrac #-} +pattern PNonlinear :: Pattern -> Name Term -> Pattern +pattern PNonlinear p x <- PNonlinear_ (unembed -> p) x + where + PNonlinear p x = PNonlinear_ (embed p) x +{-# COMPLETE + PVar + , PWild + , PAscr + , PUnit + , PBool + , PTup + , PInj + , PNat + , PChar + , PString + , PCons + , PList + , PAdd + , PMul + , PSub + , PNeg + , PFrac + #-} + ------------------------------------------------------------ -- Pretty-printing for surface-syntax terms -- @@ -456,86 +522,88 @@ -- term (e.g. via the :doc REPL command). -- | Pretty-print a term with guaranteed parentheses. -prettyTermP :: Members '[LFresh, Reader PA] r => Term -> Sem r Doc -prettyTermP t@TTup{} = setPA initPA $ pretty t +prettyTermP :: Members '[LFresh, Reader PA] r => Term -> Sem r (Doc ann) +prettyTermP t@TTup {} = setPA initPA $ pretty t -- prettyTermP t@TContainer{} = setPA initPA $ "" <+> prettyTerm t -prettyTermP t = withPA initPA $ pretty t +prettyTermP t = withPA initPA $ pretty t instance Pretty Term where pretty = \case - TVar x -> pretty x + TVar x -> pretty x TPrim (PrimUOp uop) -> case M.lookup uop uopMap of - Just (OpInfo (UOpF Pre _) (syn:_) _) -> text syn <> text "~" - Just (OpInfo (UOpF Post _) (syn:_) _) -> text "~" <> text syn + Just (OpInfo (UOpF Pre _) (syn : _) _) -> text syn <> text "~" + Just (OpInfo (UOpF Post _) (syn : _) _) -> text "~" <> text syn _ -> error $ "pretty @Term: " ++ show uop ++ " is not in the uopMap!" TPrim (PrimBOp bop) -> text "~" <> pretty bop <> text "~" TPrim p -> case M.lookup p primMap of - Just (PrimInfo _ nm True) -> text nm + Just (PrimInfo _ nm True) -> text nm Just (PrimInfo _ nm False) -> text "$" <> text nm Nothing -> error $ "pretty @Term: Prim " ++ show p ++ " is not in the primMap!" - TParens t -> pretty t - TUnit -> text "■" - (TBool b) -> text (map toLower $ show b) - TChar c -> text (show c) - TString cs -> doubleQuotes $ text cs - TAbs q bnd -> withPA initPA $ + TParens t -> pretty t + TUnit -> text "■" + (TBool b) -> text (map toLower $ show b) + TChar c -> text (show c) + TString cs -> doubleQuotes $ text cs + TAbs q bnd -> withPA initPA $ lunbind bnd $ \(args, body) -> - prettyQ q - <> (hsep =<< punctuate (text ",") (map pretty args)) - <> text "." - <+> lt (pretty body) - where - prettyQ Lam = text "λ" - prettyQ All = text "∀" - prettyQ Ex = text "∃" + prettyQ q + <> (hsep =<< punctuate (text ",") (map pretty args)) + <> text "." + <+> lt (pretty body) + where + prettyQ Lam = text "λ" + prettyQ All = text "∀" + prettyQ Ex = text "∃" -- special case for fully applied unary operators TApp (TPrim (PrimUOp uop)) t -> case M.lookup uop uopMap of - Just (OpInfo (UOpF Post _) _ _) -> withPA (ugetPA uop) $ - lt (pretty t) <> pretty uop - Just (OpInfo (UOpF Pre _) _ _) -> withPA (ugetPA uop) $ - pretty uop <> rt (pretty t) + Just (OpInfo (UOpF Post _) _ _) -> + withPA (ugetPA uop) $ + lt (pretty t) <> pretty uop + Just (OpInfo (UOpF Pre _) _ _) -> + withPA (ugetPA uop) $ + pretty uop <> rt (pretty t) _ -> error $ "pretty @Term: uopMap doesn't contain " ++ show uop - -- special case for fully applied binary operators - TApp (TPrim (PrimBOp bop)) (TTup [t1, t2]) -> withPA (getPA bop) $ - hsep - [ lt (pretty t1) - , pretty bop - , rt (pretty t2) - ] - + TApp (TPrim (PrimBOp bop)) (TTup [t1, t2]) -> + withPA (getPA bop) $ + hsep + [ lt (pretty t1) + , pretty bop + , rt (pretty t2) + ] -- Always pretty-print function applications with parentheses - TApp t1 t2 -> withPA funPA $ - lt (pretty t1) <> prettyTermP t2 - - TTup ts -> setPA initPA $ do + TApp t1 t2 -> + withPA funPA $ + lt (pretty t1) <> prettyTermP t2 + TTup ts -> setPA initPA $ do ds <- punctuate (text ",") (map pretty ts) parens (hsep ds) - TContainer c ts e -> setPA initPA $ do + TContainer c ts e -> setPA initPA $ do ds <- punctuate (text ",") (map prettyCount ts) let pe = case e of - Nothing -> [] - Just (Until t) -> [text "..", pretty t] + Nothing -> [] + Just (Until t) -> [text "..", pretty t] containerDelims c (hsep (ds ++ pe)) - where - prettyCount (t, Nothing) = pretty t - prettyCount (t, Just n) = lt (pretty t) <+> text "#" <+> rt (pretty n) + where + prettyCount (t, Nothing) = pretty t + prettyCount (t, Just n) = lt (pretty t) <+> text "#" <+> rt (pretty n) TContainerComp c bqst -> - lunbind bqst $ \(qs,t) -> - setPA initPA $ containerDelims c (hsep [pretty t, text "|", pretty qs]) - TNat n -> integer n - TChain t lks -> withPA (getPA Eq) . hsep $ + lunbind bqst $ \(qs, t) -> + setPA initPA $ containerDelims c (hsep [pretty t, text "|", pretty qs]) + TNat n -> integer n + TChain t lks -> + withPA (getPA Eq) . hsep $ lt (pretty t) - : concatMap prettyLink lks - where - prettyLink (TLink op t2) = - [ pretty op - , setPA (getPA op) . rt $ pretty t2 - ] + : concatMap prettyLink lks + where + prettyLink (TLink op t2) = + [ pretty op + , setPA (getPA op) . rt $ pretty t2 + ] TLet bnd -> withPA initPA $ lunbind bnd $ \(bs, t2) -> do ds <- punctuate (text ",") (map pretty (fromTelescope bs)) @@ -545,46 +613,47 @@ , text "in" , pretty t2 ] - - TCase b -> withPA initPA $ - (text "{?" <+> prettyBranches b) $+$ text "?}" - TAscr t ty -> withPA ascrPA $ - lt (pretty t) <+> text ":" <+> rt (pretty ty) - TRat r -> text (prettyDecimal r) - TTyOp op ty -> withPA funPA $ - pretty op <+> pretty ty + TCase b -> + withPA initPA $ + (text "{?" <+> prettyBranches b) $+$ text "?}" + TAscr t ty -> + withPA ascrPA $ + lt (pretty t) <+> text ":" <+> rt (pretty ty) + TRat r -> text (prettyDecimal r) + TTyOp op ty -> + withPA funPA $ + pretty op <+> pretty ty TWild -> text "_" -- | Print appropriate delimiters for a container literal. -containerDelims :: Member (Reader PA) r => Container -> (Sem r Doc -> Sem r Doc) +containerDelims :: Member (Reader PA) r => Container -> (Sem r (Doc ann) -> Sem r (Doc ann)) containerDelims ListContainer = brackets -containerDelims BagContainer = bag -containerDelims SetContainer = braces +containerDelims BagContainer = bag +containerDelims SetContainer = braces -prettyBranches :: Members '[Reader PA, LFresh] r => [Branch] -> Sem r Doc +prettyBranches :: Members '[Reader PA, LFresh] r => [Branch] -> Sem r (Doc ann) prettyBranches = \case [] -> error "Empty branches are disallowed." - b:bs -> + b : bs -> pretty b - $+$ - foldr (($+$) . (text "," <+>) . pretty) empty bs + $+$ foldr (($+$) . (text "," <+>) . pretty) empty bs -- | Pretty-print a single branch in a case expression. instance Pretty Branch where - pretty br = lunbind br $ \(gs,t) -> + pretty br = lunbind br $ \(gs, t) -> pretty t <+> pretty gs -- | Pretty-print the guards in a single branch of a case expression. instance Pretty (Telescope Guard) where pretty = \case TelEmpty -> text "otherwise" - gs -> foldr (\g r -> pretty g <+> r) (text "") (fromTelescope gs) + gs -> foldr (\g r -> pretty g <+> r) (text "") (fromTelescope gs) instance Pretty Guard where pretty = \case - GBool et -> text "if" <+> pretty (unembed et) + GBool et -> text "if" <+> pretty (unembed et) GPat et p -> text "when" <+> pretty (unembed et) <+> text "is" <+> pretty p - GLet b -> text "let" <+> pretty b + GLet b -> text "let" <+> pretty b -- | Pretty-print a binding, i.e. a pairing of a name (with optional -- type annotation) and term. @@ -605,12 +674,12 @@ instance Pretty Qual where pretty = \case QBind x (unembed -> t) -> hsep [pretty x, text "in", pretty t] - QGuard (unembed -> t) -> pretty t + QGuard (unembed -> t) -> pretty t -- | Pretty-print a pattern with guaranteed parentheses. -prettyPatternP :: Members '[LFresh, Reader PA] r => Pattern -> Sem r Doc -prettyPatternP p@PTup{} = setPA initPA $ pretty p -prettyPatternP p = withPA initPA $ pretty p +prettyPatternP :: Members '[LFresh, Reader PA] r => Pattern -> Sem r (Doc ann) +prettyPatternP p@PTup {} = setPA initPA $ pretty p +prettyPatternP p = withPA initPA $ pretty p -- We could probably alternatively write a function to turn a pattern -- back into a term, and pretty-print that instead of the below. @@ -618,37 +687,46 @@ instance Pretty Pattern where pretty = \case - PVar x -> pretty x - PWild -> text "_" - PAscr p ty -> withPA ascrPA $ - lt (pretty p) <+> text ":" <+> rt (pretty ty) - PUnit -> text "■" - PBool b -> text $ map toLower $ show b - PChar c -> text (show c) - PString s -> text (show s) - PTup ts -> setPA initPA $ do + PVar x -> pretty x + PWild -> text "_" + PAscr p ty -> + withPA ascrPA $ + lt (pretty p) <+> text ":" <+> rt (pretty ty) + PUnit -> text "■" + PBool b -> text $ map toLower $ show b + PChar c -> text (show c) + PString s -> text (show s) + PTup ts -> setPA initPA $ do ds <- punctuate (text ",") (map pretty ts) parens (hsep ds) - PInj s p -> withPA funPA $ - pretty s <> prettyPatternP p - PNat n -> integer n - PCons p1 p2 -> withPA (getPA Cons) $ - lt (pretty p1) <+> text "::" <+> rt (pretty p2) - PList ps -> setPA initPA $ do + PInj s p -> + withPA funPA $ + pretty s <> prettyPatternP p + PNat n -> integer n + PCons p1 p2 -> + withPA (getPA Cons) $ + lt (pretty p1) <+> text "::" <+> rt (pretty p2) + PList ps -> setPA initPA $ do ds <- punctuate (text ",") (map pretty ps) brackets (hsep ds) - PAdd L p t -> withPA (getPA Add) $ - lt (pretty p) <+> text "+" <+> rt (pretty t) - PAdd R p t -> withPA (getPA Add) $ - lt (pretty t) <+> text "+" <+> rt (pretty p) - PMul L p t -> withPA (getPA Mul) $ - lt (pretty p) <+> text "*" <+> rt (pretty t) - PMul R p t -> withPA (getPA Mul) $ - lt (pretty t) <+> text "*" <+> rt (pretty p) - PSub p t -> withPA (getPA Sub) $ - lt (pretty p) <+> text "-" <+> rt (pretty t) - PNeg p -> withPA (ugetPA Neg) $ - text "-" <> rt (pretty p) - PFrac p1 p2 -> withPA (getPA Div) $ - lt (pretty p1) <+> text "/" <+> rt (pretty p2) - + PAdd L p t -> + withPA (getPA Add) $ + lt (pretty p) <+> text "+" <+> rt (pretty t) + PAdd R p t -> + withPA (getPA Add) $ + lt (pretty t) <+> text "+" <+> rt (pretty p) + PMul L p t -> + withPA (getPA Mul) $ + lt (pretty p) <+> text "*" <+> rt (pretty t) + PMul R p t -> + withPA (getPA Mul) $ + lt (pretty t) <+> text "*" <+> rt (pretty p) + PSub p t -> + withPA (getPA Sub) $ + lt (pretty p) <+> text "-" <+> rt (pretty t) + PNeg p -> + withPA (ugetPA Neg) $ + text "-" <> rt (pretty p) + PFrac p1 p2 -> + withPA (getPA Div) $ + lt (pretty p1) <+> text "/" <+> rt (pretty p2) diff --git a/src/Disco/AST/Typed.hs b/src/Disco/AST/Typed.hs --- a/src/Disco/AST/Typed.hs +++ b/src/Disco/AST/Typed.hs @@ -1,7 +1,10 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PatternSynonyms #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Disco.AST.Typed -- Copyright : disco team and contributors @@ -12,100 +15,91 @@ -- Typed abstract syntax trees representing the typechecked surface -- syntax of the Disco language. Each tree node is annotated with the -- type of its subtree. --- ------------------------------------------------------------------------------ - -module Disco.AST.Typed - ( -- * Type-annotated terms - ATerm - , pattern ATVar - , pattern ATPrim - , pattern ATLet - , pattern ATUnit - , pattern ATBool - , pattern ATNat - , pattern ATRat - , pattern ATChar - , pattern ATString - , pattern ATAbs - , pattern ATApp - , pattern ATTup - , pattern ATCase - , pattern ATChain - , pattern ATTyOp - , pattern ATContainer - , pattern ATContainerComp - , pattern ATList - , pattern ATListComp - , pattern ATTest - - , ALink - , pattern ATLink - - , Container(..) - , ABinding - -- * Branches and guards - , ABranch - - , AGuard - , pattern AGBool - , pattern AGPat - , pattern AGLet - - , AQual - , pattern AQBind - , pattern AQGuard - - , APattern - , pattern APVar - , pattern APWild - , pattern APUnit - , pattern APBool - , pattern APTup - , pattern APInj - , pattern APNat - , pattern APChar - , pattern APString - , pattern APCons - , pattern APList - , pattern APAdd - , pattern APMul - , pattern APSub - , pattern APNeg - , pattern APFrac +module Disco.AST.Typed ( + -- * Type-annotated terms + ATerm, + pattern ATVar, + pattern ATPrim, + pattern ATLet, + pattern ATUnit, + pattern ATBool, + pattern ATNat, + pattern ATRat, + pattern ATChar, + pattern ATString, + pattern ATAbs, + pattern ATApp, + pattern ATTup, + pattern ATCase, + pattern ATChain, + pattern ATTyOp, + pattern ATContainer, + pattern ATContainerComp, + pattern ATList, + pattern ATListComp, + pattern ATTest, + ALink, + pattern ATLink, + Container (..), + ABinding, - , pattern ABinding - -- * Utilities - , varsBound - , getType - , setType - , substQT + -- * Branches and guards + ABranch, + AGuard, + pattern AGBool, + pattern AGPat, + pattern AGLet, + AQual, + pattern AQBind, + pattern AQGuard, + APattern, + pattern APVar, + pattern APWild, + pattern APUnit, + pattern APBool, + pattern APTup, + pattern APInj, + pattern APNat, + pattern APChar, + pattern APString, + pattern APCons, + pattern APList, + pattern APAdd, + pattern APMul, + pattern APSub, + pattern APNeg, + pattern APFrac, + pattern ABinding, - , AProperty - ) - where + -- * Utilities + varsBound, + getType, + setType, + substQT, + AProperty, +) +where -import Unbound.Generics.LocallyNameless -import Unbound.Generics.LocallyNameless.Unsafe +import Unbound.Generics.LocallyNameless +import Unbound.Generics.LocallyNameless.Unsafe -import Control.Arrow ((***)) -import Data.Coerce (coerce) -import Data.Data (Data) -import Data.Void +import Control.Arrow ((***)) +import Data.Coerce (coerce) +import Data.Data (Data) +import Data.Void -import Control.Lens.Plated (transform) -import Disco.AST.Generic -import Disco.AST.Surface -import Disco.Names -import Disco.Pretty -import Disco.Syntax.Operators -import Disco.Syntax.Prims -import Disco.Types +import Control.Lens.Plated (transform) +import Disco.AST.Generic +import Disco.AST.Surface +import Disco.Names +import Disco.Pretty +import Disco.Syntax.Operators +import Disco.Syntax.Prims +import Disco.Types -- | The extension descriptor for Typed specific AST types. - data TY - deriving Data + deriving (Data) type AProperty = Property_ TY @@ -116,34 +110,33 @@ -- | An @ATerm@ is a typechecked term where every node in the tree has -- been annotated with the type of the subterm rooted at that node. - type ATerm = Term_ TY -type instance X_Binder TY = [APattern] +type instance X_Binder TY = [APattern] -type instance X_TVar TY = Void -- Names are now qualified -type instance X_TPrim TY = Type -type instance X_TLet TY = Type -type instance X_TUnit TY = () -type instance X_TBool TY = Type -type instance X_TNat TY = Type -type instance X_TRat TY = () -type instance X_TChar TY = () -type instance X_TString TY = () -type instance X_TAbs TY = Type -type instance X_TApp TY = Type -type instance X_TCase TY = Type -type instance X_TChain TY = Type -type instance X_TTyOp TY = Type -type instance X_TContainer TY = Type -type instance X_TContainerComp TY = Type -type instance X_TAscr TY = Void -- No more type ascriptions in typechecked terms -type instance X_TTup TY = Type -type instance X_TParens TY = Void -- No more explicit parens +type instance X_TVar TY = Void -- Names are now qualified +type instance X_TPrim TY = Type +type instance X_TLet TY = Type +type instance X_TUnit TY = () +type instance X_TBool TY = Type +type instance X_TNat TY = Type +type instance X_TRat TY = () +type instance X_TChar TY = () +type instance X_TString TY = () +type instance X_TAbs TY = Type +type instance X_TApp TY = Type +type instance X_TCase TY = Type +type instance X_TChain TY = Type +type instance X_TTyOp TY = Type +type instance X_TContainer TY = Type +type instance X_TContainerComp TY = Type +type instance X_TAscr TY = Void -- No more type ascriptions in typechecked terms +type instance X_TTup TY = Type +type instance X_TParens TY = Void -- No more explicit parens - -- A test frame for reporting counterexamples in a test. These don't appear - -- in source programs, but because the deugarer manipulates partly-desugared - -- terms it helps to be able to represent these in 'ATerm'. +-- A test frame for reporting counterexamples in a test. These don't appear +-- in source programs, but because the deugarer manipulates partly-desugared +-- terms it helps to be able to represent these in 'ATerm'. type instance X_Term TY = Either ([(String, Type, Name ATerm)], ATerm) (Type, QName ATerm) pattern ATVar :: Type -> QName ATerm -> ATerm @@ -161,7 +154,7 @@ pattern ATBool :: Type -> Bool -> ATerm pattern ATBool ty bool = TBool_ ty bool -pattern ATNat :: Type -> Integer -> ATerm +pattern ATNat :: Type -> Integer -> ATerm pattern ATNat ty int = TNat_ ty int pattern ATRat :: Rational -> ATerm @@ -176,7 +169,7 @@ pattern ATAbs :: Quantifier -> Type -> Bind [APattern] ATerm -> ATerm pattern ATAbs q ty bind = TAbs_ q ty bind -pattern ATApp :: Type -> ATerm -> ATerm -> ATerm +pattern ATApp :: Type -> ATerm -> ATerm -> ATerm pattern ATApp ty term1 term2 = TApp_ ty term1 term2 pattern ATTup :: Type -> [ATerm] -> ATerm @@ -200,9 +193,26 @@ pattern ATTest :: [(String, Type, Name ATerm)] -> ATerm -> ATerm pattern ATTest ns t = XTerm_ (Left (ns, t)) -{-# COMPLETE ATVar, ATPrim, ATLet, ATUnit, ATBool, ATNat, ATRat, ATChar, - ATString, ATAbs, ATApp, ATTup, ATCase, ATChain, ATTyOp, - ATContainer, ATContainerComp, ATTest #-} +{-# COMPLETE + ATVar + , ATPrim + , ATLet + , ATUnit + , ATBool + , ATNat + , ATRat + , ATChar + , ATString + , ATAbs + , ATApp + , ATTup + , ATCase + , ATChain + , ATTyOp + , ATContainer + , ATContainerComp + , ATTest + #-} pattern ATList :: Type -> [ATerm] -> Maybe (Ellipsis ATerm) -> ATerm pattern ATList t xs e <- ATContainer t ListContainer (map fst -> xs) e @@ -221,13 +231,11 @@ {-# COMPLETE ATLink #-} - type AQual = Qual_ TY type instance X_QBind TY = () type instance X_QGuard TY = () - pattern AQBind :: Name ATerm -> Embed ATerm -> AQual pattern AQBind namet embedt = QBind_ () namet embedt @@ -248,8 +256,8 @@ type AGuard = Guard_ TY type instance X_GBool TY = () -type instance X_GPat TY = () -type instance X_GLet TY = () -- ??? Type? +type instance X_GPat TY = () +type instance X_GLet TY = () -- ??? Type? pattern AGBool :: Embed ATerm -> AGuard pattern AGBool embedt = GBool_ () embedt @@ -267,25 +275,25 @@ -- We have to use Embed Type because we don't want any type variables -- inside the types being treated as binders! -type instance X_PVar TY = Embed Type -type instance X_PWild TY = Embed Type -type instance X_PAscr TY = Void -- No more ascriptions in typechecked patterns. -type instance X_PUnit TY = () -type instance X_PBool TY = () -type instance X_PChar TY = () -type instance X_PString TY = () -type instance X_PTup TY = Embed Type -type instance X_PInj TY = Embed Type -type instance X_PNat TY = Embed Type -type instance X_PCons TY = Embed Type -type instance X_PList TY = Embed Type -type instance X_PAdd TY = Embed Type -type instance X_PMul TY = Embed Type -type instance X_PSub TY = Embed Type -type instance X_PNeg TY = Embed Type -type instance X_PFrac TY = Embed Type +type instance X_PVar TY = Embed Type +type instance X_PWild TY = Embed Type +type instance X_PAscr TY = Void -- No more ascriptions in typechecked patterns. +type instance X_PUnit TY = () +type instance X_PBool TY = () +type instance X_PChar TY = () +type instance X_PString TY = () +type instance X_PTup TY = Embed Type +type instance X_PInj TY = Embed Type +type instance X_PNat TY = Embed Type +type instance X_PCons TY = Embed Type +type instance X_PList TY = Embed Type +type instance X_PAdd TY = Embed Type +type instance X_PMul TY = Embed Type +type instance X_PSub TY = Embed Type +type instance X_PNeg TY = Embed Type +type instance X_PFrac TY = Embed Type -type instance X_Pattern TY = () +type instance X_Pattern TY = () pattern APVar :: Type -> Name ATerm -> APattern pattern APVar ty name <- PVar_ (unembed -> ty) name @@ -301,25 +309,25 @@ pattern APUnit = PUnit_ () pattern APBool :: Bool -> APattern -pattern APBool b = PBool_ () b +pattern APBool b = PBool_ () b pattern APChar :: Char -> APattern -pattern APChar c = PChar_ () c +pattern APChar c = PChar_ () c pattern APString :: String -> APattern pattern APString s = PString_ () s -pattern APTup :: Type -> [APattern] -> APattern +pattern APTup :: Type -> [APattern] -> APattern pattern APTup ty lp <- PTup_ (unembed -> ty) lp where APTup ty lp = PTup_ (embed ty) lp -pattern APInj :: Type -> Side -> APattern -> APattern +pattern APInj :: Type -> Side -> APattern -> APattern pattern APInj ty s p <- PInj_ (unembed -> ty) s p where APInj ty s p = PInj_ (embed ty) s p -pattern APNat :: Type -> Integer -> APattern +pattern APNat :: Type -> Integer -> APattern pattern APNat ty n <- PNat_ (unembed -> ty) n where APNat ty n = PNat_ (embed ty) n @@ -359,87 +367,103 @@ where APFrac ty p1 p2 = PFrac_ (embed ty) p1 p2 -{-# COMPLETE APVar, APWild, APUnit, APBool, APChar, APString, - APTup, APInj, APNat, APCons, APList, APAdd, APMul, APSub, APNeg, APFrac #-} +{-# COMPLETE + APVar + , APWild + , APUnit + , APBool + , APChar + , APString + , APTup + , APInj + , APNat + , APCons + , APList + , APAdd + , APMul + , APSub + , APNeg + , APFrac + #-} varsBound :: APattern -> [(Name ATerm, Type)] -varsBound (APVar ty n) = [(n, ty)] -varsBound (APWild _) = [] -varsBound APUnit = [] -varsBound (APBool _) = [] -varsBound (APChar _) = [] -varsBound (APString _) = [] -varsBound (APTup _ ps) = varsBound =<< ps -varsBound (APInj _ _ p) = varsBound p -varsBound (APNat _ _) = [] -varsBound (APCons _ p q) = varsBound p ++ varsBound q -varsBound (APList _ ps) = varsBound =<< ps +varsBound (APVar ty n) = [(n, ty)] +varsBound (APWild _) = [] +varsBound APUnit = [] +varsBound (APBool _) = [] +varsBound (APChar _) = [] +varsBound (APString _) = [] +varsBound (APTup _ ps) = varsBound =<< ps +varsBound (APInj _ _ p) = varsBound p +varsBound (APNat _ _) = [] +varsBound (APCons _ p q) = varsBound p ++ varsBound q +varsBound (APList _ ps) = varsBound =<< ps varsBound (APAdd _ _ p _) = varsBound p varsBound (APMul _ _ p _) = varsBound p -varsBound (APSub _ p _) = varsBound p -varsBound (APNeg _ p) = varsBound p -varsBound (APFrac _ p q) = varsBound p ++ varsBound q +varsBound (APSub _ p _) = varsBound p +varsBound (APNeg _ p) = varsBound p +varsBound (APFrac _ p q) = varsBound p ++ varsBound q ------------------------------------------------------------ -- getType ------------------------------------------------------------ instance HasType ATerm where - getType (ATVar ty _) = ty - getType (ATPrim ty _) = ty - getType ATUnit = TyUnit - getType (ATBool ty _) = ty - getType (ATNat ty _) = ty - getType (ATRat _) = TyF - getType (ATChar _) = TyC - getType (ATString _) = TyList TyC - getType (ATAbs _ ty _) = ty - getType (ATApp ty _ _) = ty - getType (ATTup ty _) = ty - getType (ATTyOp ty _ _) = ty - getType (ATChain ty _ _) = ty - getType (ATContainer ty _ _ _) = ty + getType (ATVar ty _) = ty + getType (ATPrim ty _) = ty + getType ATUnit = TyUnit + getType (ATBool ty _) = ty + getType (ATNat ty _) = ty + getType (ATRat _) = TyF + getType (ATChar _) = TyC + getType (ATString _) = TyList TyC + getType (ATAbs _ ty _) = ty + getType (ATApp ty _ _) = ty + getType (ATTup ty _) = ty + getType (ATTyOp ty _ _) = ty + getType (ATChain ty _ _) = ty + getType (ATContainer ty _ _ _) = ty getType (ATContainerComp ty _ _) = ty - getType (ATLet ty _) = ty - getType (ATCase ty _) = ty - getType (ATTest _ _ ) = TyProp + getType (ATLet ty _) = ty + getType (ATCase ty _) = ty + getType (ATTest _ _) = TyProp - setType ty (ATVar _ x ) = ATVar ty x - setType ty (ATPrim _ x ) = ATPrim ty x - setType _ ATUnit = ATUnit - setType ty (ATBool _ b) = ATBool ty b - setType ty (ATNat _ x ) = ATNat ty x - setType _ (ATRat r) = ATRat r - setType _ (ATChar c) = ATChar c - setType _ (ATString cs) = ATString cs - setType ty (ATAbs q _ x ) = ATAbs q ty x - setType ty (ATApp _ x y ) = ATApp ty x y - setType ty (ATTup _ x ) = ATTup ty x - setType ty (ATTyOp _ x y ) = ATTyOp ty x y - setType ty (ATChain _ x y ) = ATChain ty x y - setType ty (ATContainer _ x y z) = ATContainer ty x y z + setType ty (ATVar _ x) = ATVar ty x + setType ty (ATPrim _ x) = ATPrim ty x + setType _ ATUnit = ATUnit + setType ty (ATBool _ b) = ATBool ty b + setType ty (ATNat _ x) = ATNat ty x + setType _ (ATRat r) = ATRat r + setType _ (ATChar c) = ATChar c + setType _ (ATString cs) = ATString cs + setType ty (ATAbs q _ x) = ATAbs q ty x + setType ty (ATApp _ x y) = ATApp ty x y + setType ty (ATTup _ x) = ATTup ty x + setType ty (ATTyOp _ x y) = ATTyOp ty x y + setType ty (ATChain _ x y) = ATChain ty x y + setType ty (ATContainer _ x y z) = ATContainer ty x y z setType ty (ATContainerComp _ x y) = ATContainerComp ty x y - setType ty (ATLet _ x ) = ATLet ty x - setType ty (ATCase _ x ) = ATCase ty x - setType _ (ATTest vs x) = ATTest vs x + setType ty (ATLet _ x) = ATLet ty x + setType ty (ATCase _ x) = ATCase ty x + setType _ (ATTest vs x) = ATTest vs x instance HasType APattern where - getType (APVar ty _) = ty - getType (APWild ty) = ty - getType APUnit = TyUnit - getType (APBool _) = TyBool - getType (APChar _) = TyC - getType (APString _) = TyList TyC - getType (APTup ty _) = ty - getType (APInj ty _ _) = ty - getType (APNat ty _) = ty - getType (APCons ty _ _) = ty - getType (APList ty _) = ty + getType (APVar ty _) = ty + getType (APWild ty) = ty + getType APUnit = TyUnit + getType (APBool _) = TyBool + getType (APChar _) = TyC + getType (APString _) = TyList TyC + getType (APTup ty _) = ty + getType (APInj ty _ _) = ty + getType (APNat ty _) = ty + getType (APCons ty _ _) = ty + getType (APList ty _) = ty getType (APAdd ty _ _ _) = ty getType (APMul ty _ _ _) = ty - getType (APSub ty _ _) = ty - getType (APNeg ty _) = ty - getType (APFrac ty _ _) = ty + getType (APSub ty _ _) = ty + getType (APNeg ty _) = ty + getType (APFrac ty _ _) = ty instance HasType ABranch where getType = getType . snd . unsafeUnbind @@ -451,7 +475,7 @@ substQT :: QName ATerm -> ATerm -> ATerm -> ATerm substQT x s = transform $ \case t@(ATVar _ y) - | x == y -> s + | x == y -> s | otherwise -> t t -> t @@ -464,32 +488,34 @@ explode :: ATerm -> Term explode = \case - ATVar ty x -> TAscr (TVar (coerce (qname x))) (toPolyType ty) - ATPrim ty x -> TAscr (TPrim x) (toPolyType ty) - ATLet ty tel -> TAscr (TLet (explodeTelescope explodeBinding tel)) (toPolyType ty) - ATUnit -> TUnit - ATBool _ty b -> TBool b - ATNat ty x -> TAscr (TNat x) (toPolyType ty) - ATRat r -> TRat r - ATChar c -> TChar c - ATString cs -> TString cs - ATAbs q ty a -> TAscr (TAbs q (explodeAbs a)) (toPolyType ty) - ATApp ty x y -> TAscr (TApp (explode x) (explode y)) (toPolyType ty) - ATTup ty xs -> TAscr (TTup (map explode xs)) (toPolyType ty) - ATCase ty bs -> TAscr (TCase (map explodeBranch bs)) (toPolyType ty) - ATChain ty t ls -> TAscr (TChain (explode t) (map explodeLink ls)) (toPolyType ty) - ATTyOp ty x y -> TAscr (TTyOp x y) (toPolyType ty) + ATVar ty x -> TAscr (TVar (coerce (qname x))) (toPolyType ty) + ATPrim ty x -> TAscr (TPrim x) (toPolyType ty) + ATLet ty tel -> TAscr (TLet (explodeTelescope explodeBinding tel)) (toPolyType ty) + ATUnit -> TUnit + ATBool _ty b -> TBool b + ATNat ty x -> TAscr (TNat x) (toPolyType ty) + ATRat r -> TRat r + ATChar c -> TChar c + ATString cs -> TString cs + ATAbs q ty a -> TAscr (TAbs q (explodeAbs a)) (toPolyType ty) + ATApp ty x y -> TAscr (TApp (explode x) (explode y)) (toPolyType ty) + ATTup ty xs -> TAscr (TTup (map explode xs)) (toPolyType ty) + ATCase ty bs -> TAscr (TCase (map explodeBranch bs)) (toPolyType ty) + ATChain ty t ls -> TAscr (TChain (explode t) (map explodeLink ls)) (toPolyType ty) + ATTyOp ty x y -> TAscr (TTyOp x y) (toPolyType ty) ATContainer ty c ts el -> TAscr (TContainer c (map (explode *** fmap explode) ts) (fmap (fmap explode) el)) (toPolyType ty) ATContainerComp ty c b -> TAscr (TContainerComp c (explodeTelescope explodeQual b)) (toPolyType ty) - ATTest _vs x -> TAscr (explode x) (toPolyType TyProp) + ATTest _vs x -> TAscr (explode x) (toPolyType TyProp) -explodeTelescope - :: (Alpha a, Alpha b) - => (a -> b) -> Bind (Telescope a) ATerm -> Bind (Telescope b) Term -explodeTelescope explodeBinder (unsafeUnbind -> (xs,at)) = bind (mapTelescope explodeBinder xs) (explode at) +explodeTelescope :: + (Alpha a, Alpha b) => + (a -> b) -> + Bind (Telescope a) ATerm -> + Bind (Telescope b) Term +explodeTelescope explodeBinder (unsafeUnbind -> (xs, at)) = bind (mapTelescope explodeBinder xs) (explode at) explodeBinding :: ABinding -> Binding explodeBinding (ABinding m b (unembed -> n)) = Binding m (coerce b) (embed (explode n)) @@ -499,34 +525,34 @@ explodePattern :: APattern -> Pattern explodePattern = \case - APVar ty x -> PAscr (PVar (coerce x)) ty - APWild ty -> PAscr PWild ty - APUnit -> PUnit - APBool b -> PBool b - APChar c -> PChar c - APString s -> PString s - APTup ty ps -> PAscr (PTup (map explodePattern ps)) ty - APInj ty s p -> PAscr (PInj s (explodePattern p)) ty - APNat ty n -> PAscr (PNat n) ty + APVar ty x -> PAscr (PVar (coerce x)) ty + APWild ty -> PAscr PWild ty + APUnit -> PUnit + APBool b -> PBool b + APChar c -> PChar c + APString s -> PString s + APTup ty ps -> PAscr (PTup (map explodePattern ps)) ty + APInj ty s p -> PAscr (PInj s (explodePattern p)) ty + APNat ty n -> PAscr (PNat n) ty APCons ty p1 p2 -> PAscr (PCons (explodePattern p1) (explodePattern p2)) ty - APList ty ps -> PAscr (PList (map explodePattern ps)) ty - APAdd ty s p t -> PAscr (PAdd s (explodePattern p) (explode t)) ty - APMul ty s p t -> PAscr (PMul s (explodePattern p) (explode t)) ty - APSub ty p t -> PAscr (PSub (explodePattern p) (explode t)) ty - APNeg ty p -> PAscr (PNeg (explodePattern p)) ty - APFrac ty p q -> PAscr (PFrac (explodePattern p) (explodePattern q)) ty + APList ty ps -> PAscr (PList (map explodePattern ps)) ty + APAdd ty s p t -> PAscr (PAdd s (explodePattern p) (explode t)) ty + APMul ty s p t -> PAscr (PMul s (explodePattern p) (explode t)) ty + APSub ty p t -> PAscr (PSub (explodePattern p) (explode t)) ty + APNeg ty p -> PAscr (PNeg (explodePattern p)) ty + APFrac ty p q -> PAscr (PFrac (explodePattern p) (explodePattern q)) ty explodeBranch :: ABranch -> Branch explodeBranch = explodeTelescope explodeGuard explodeGuard :: AGuard -> Guard -explodeGuard (AGBool (unembed -> at)) = GBool (embed (explode at)) +explodeGuard (AGBool (unembed -> at)) = GBool (embed (explode at)) explodeGuard (AGPat (unembed -> at) ap) = GPat (embed (explode at)) (explodePattern ap) -explodeGuard (AGLet ab) = GLet (explodeBinding ab) +explodeGuard (AGLet ab) = GLet (explodeBinding ab) explodeLink :: ALink -> Link explodeLink (ATLink bop at) = TLink bop (explode at) explodeQual :: AQual -> Qual explodeQual (AQBind x (unembed -> at)) = QBind (coerce x) (embed (explode at)) -explodeQual (AQGuard (unembed -> at)) = QGuard (embed (explode at)) +explodeQual (AQGuard (unembed -> at)) = QGuard (embed (explode at)) diff --git a/src/Disco/Compile.hs b/src/Disco/Compile.hs --- a/src/Disco/Compile.hs +++ b/src/Disco/Compile.hs @@ -1,4 +1,7 @@ ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Disco.Compile -- Copyright : disco team and contributors @@ -8,37 +11,39 @@ -- -- Compiling the typechecked, desugared AST to the untyped core -- language. ------------------------------------------------------------------------------ - module Disco.Compile where -import Control.Monad ((<=<)) -import Data.Bool (bool) -import Data.Coerce -import qualified Data.Map as M -import Data.Ratio -import Data.Set (Set) -import qualified Data.Set as S -import Data.Set.Lens (setOf) +import Control.Monad ((<=<)) +import Data.Bool (bool) +import Data.Coerce +import qualified Data.Map as M +import Data.Ratio +import Data.Set (Set) +import qualified Data.Set as S +import Data.Set.Lens (setOf) -import Disco.Effects.Fresh -import Polysemy (Member, Sem, run) -import Unbound.Generics.LocallyNameless (Name, bind, string2Name, - unembed) +import Disco.Effects.Fresh +import Polysemy (Member, Sem, run) +import Unbound.Generics.LocallyNameless ( + Name, + bind, + string2Name, + unembed, + ) -import Disco.AST.Core -import Disco.AST.Desugared -import Disco.AST.Generic -import Disco.AST.Typed -import Disco.Context as Ctx -import Disco.Desugar -import Disco.Module -import Disco.Names -import Disco.Syntax.Operators -import Disco.Syntax.Prims -import qualified Disco.Typecheck.Graph as G -import Disco.Types -import Disco.Util +import Disco.AST.Core +import Disco.AST.Desugared +import Disco.AST.Generic +import Disco.AST.Typed +import Disco.Context as Ctx +import Disco.Desugar +import Disco.Module +import Disco.Names +import Disco.Syntax.Operators +import Disco.Syntax.Prims +import qualified Disco.Typecheck.Graph as G +import Disco.Types +import Disco.Util ------------------------------------------------------------ -- Convenience operations @@ -106,19 +111,18 @@ -- have -- -- fT = force (delay fL. [force fL / fT] body) - | f `S.member` setOf fvQ defn = return . (:[]) $ - (fT, CForce (CProj L (CDelay (bind [qname fL] [substQC fT (CForce (CVar fL)) cdefn])))) - + | f `S.member` setOf fvQ defn = + return . (: []) $ + (fT, CForce (CProj L (CDelay (bind [qname fL] [substQC fT (CForce (CVar fL)) cdefn])))) -- A non-recursive definition just compiles simply. | otherwise = - return [(fT, cdefn)] - - where - fT, fL :: QName Core - fT = coerce f - fL = localName (coerce (qname f)) + return [(fT, cdefn)] + where + fT, fL :: QName Core + fT = coerce f + fL = localName (coerce (qname f)) - cdefn = compileThing desugarDefn defn + cdefn = compileThing desugarDefn defn -- A group of mutually recursive definitions {f = fbody, g = gbody, ...} -- compiles to @@ -140,12 +144,12 @@ bodies' :: [Core] bodies' = map (substsQC forceVars . compileThing desugarDefn) bodies return $ - (grp, CDelay (bind (map qname varsL) bodies')) : - zip varsT (for [0 ..] $ CForce . flip proj (CVar grp)) - where - proj :: Int -> Core -> Core - proj 0 = CProj L - proj n = proj (n -1) . CProj R + (grp, CDelay (bind (map qname varsL) bodies')) + : zip varsT (for [0 ..] $ CForce . flip proj (CVar grp)) + where + proj :: Int -> Core -> Core + proj 0 = CProj L + proj n = proj (n - 1) . CProj R ------------------------------------------------------------ -- Compiling terms @@ -166,22 +170,22 @@ cbody <- compileDTerm body case q of Lam -> return $ abstract xs cbody - Ex -> return $ quantify (OExists tys) (abstract xs cbody) + Ex -> return $ quantify (OExists tys) (abstract xs cbody) All -> return $ quantify (OForall tys) (abstract xs cbody) - where - -- Gather nested abstractions with the same quantifier. - unbindDeep :: Member Fresh r => DTerm -> Sem r ([Name DTerm], [Type], DTerm) - unbindDeep (DTAbs q' ty l) | q == q' = do - (name, inner) <- unbind l - (ns, tys, body) <- unbindDeep inner - return (name : ns, ty : tys, body) - unbindDeep t = return ([], [], t) + where + -- Gather nested abstractions with the same quantifier. + unbindDeep :: Member Fresh r => DTerm -> Sem r ([Name DTerm], [Type], DTerm) + unbindDeep (DTAbs q' ty l) | q == q' = do + (name, inner) <- unbind l + (ns, tys, body) <- unbindDeep inner + return (name : ns, ty : tys, body) + unbindDeep t = return ([], [], t) - abstract :: [Name DTerm] -> Core -> Core - abstract xs body = CAbs (bind (map coerce xs) body) + abstract :: [Name DTerm] -> Core -> Core + abstract xs body = CAbs (bind (map coerce xs) body) - quantify :: Op -> Core -> Core - quantify op = CApp (CConst op) + quantify :: Op -> Core -> Core + quantify op = CApp (CConst op) -- Special case for Cons, which compiles to a constructor application -- rather than a function application. @@ -197,12 +201,12 @@ CPair <$> compileDTerm t1 <*> compileDTerm t2 compileDTerm (DTCase _ bs) = CApp <$> compileCase bs <*> pure CUnit compileDTerm (DTTyOp _ op ty) = return $ CApp (CConst (tyOps ! op)) (CType ty) - where - tyOps = - M.fromList - [ Enumerate ==> OEnum, - Count ==> OCount - ] + where + tyOps = + M.fromList + [ Enumerate ==> OEnum + , Count ==> OCount + ] compileDTerm (DTNil _) = return $ CInj L CUnit compileDTerm (DTTest info t) = CTest (coerce info) <$> compileDTerm t @@ -231,27 +235,27 @@ hd <- fresh (string2Name "hd") tl <- fresh (string2Name "tl") return $ CAbs $ bind [hd, tl] $ CInj R (CPair (CVar (localName hd)) (CVar (localName tl))) - compilePrim _ PrimLeft = do a <- fresh (string2Name "a") return $ CAbs $ bind [a] $ CInj L (CVar (localName a)) - compilePrim _ PrimRight = do a <- fresh (string2Name "a") return $ CAbs $ bind [a] $ CInj R (CVar (localName a)) - compilePrim (ty1 :*: ty2 :->: resTy) (PrimBOp bop) = return $ compileBOp ty1 ty2 resTy bop compilePrim ty p@(PrimBOp _) = compilePrimErr p ty compilePrim _ PrimSqrt = return $ CConst OSqrt compilePrim _ PrimFloor = return $ CConst OFloor compilePrim _ PrimCeil = return $ CConst OCeil -compilePrim (TySet _ :->: _) PrimAbs = return $ - CVar (Named Stdlib "container" .- string2Name "setSize") -compilePrim (TyBag _ :->: _) PrimAbs = return $ - CVar (Named Stdlib "container" .- string2Name "bagSize") -compilePrim (TyList _ :->: _) PrimAbs = return $ - CVar (Named Stdlib "list" .- string2Name "length") -compilePrim _ PrimAbs = return $ CConst OAbs +compilePrim (TySet _ :->: _) PrimAbs = + return $ + CVar (Named Stdlib "container" .- string2Name "setSize") +compilePrim (TyBag _ :->: _) PrimAbs = + return $ + CVar (Named Stdlib "container" .- string2Name "bagSize") +compilePrim (TyList _ :->: _) PrimAbs = + return $ + CVar (Named Stdlib "list" .- string2Name "length") +compilePrim _ PrimAbs = return $ CConst OAbs compilePrim (TySet _ :->: _) PrimPower = return $ CConst OPower compilePrim (TyBag _ :->: _) PrimPower = return $ CConst OPower compilePrim ty PrimPower = compilePrimErr PrimPower ty @@ -284,34 +288,38 @@ compilePrim ty PrimConnect = compilePrimErr PrimConnect ty compilePrim _ PrimInsert = return $ CConst OInsert compilePrim _ PrimLookup = return $ CConst OLookup -compilePrim (_ :*: TyList _ :->: _) PrimEach = return $ - CVar (Named Stdlib "list" .- string2Name "eachlist") +compilePrim (_ :*: TyList _ :->: _) PrimEach = + return $ + CVar (Named Stdlib "list" .- string2Name "eachlist") compilePrim (_ :*: TyBag _ :->: TyBag _) PrimEach = return $ CConst OEachBag compilePrim (_ :*: TySet _ :->: TySet _) PrimEach = return $ CConst OEachSet compilePrim ty PrimEach = compilePrimErr PrimEach ty compilePrim (_ :*: _ :*: TyList _ :->: _) PrimReduce = return $ CVar (Named Stdlib "list" .- string2Name "foldr") -compilePrim (_ :*: _ :*: TyBag _ :->: _) PrimReduce = return $ - CVar (Named Stdlib "container" .- string2Name "reducebag") -compilePrim (_ :*: _ :*: TySet _ :->: _) PrimReduce = return $ - CVar (Named Stdlib "container" .- string2Name "reduceset") +compilePrim (_ :*: _ :*: TyBag _ :->: _) PrimReduce = + return $ + CVar (Named Stdlib "container" .- string2Name "reducebag") +compilePrim (_ :*: _ :*: TySet _ :->: _) PrimReduce = + return $ + CVar (Named Stdlib "container" .- string2Name "reduceset") compilePrim ty PrimReduce = compilePrimErr PrimReduce ty -compilePrim (_ :*: TyList _ :->: _) PrimFilter = return $ - CVar (Named Stdlib "list" .- string2Name "filterlist") +compilePrim (_ :*: TyList _ :->: _) PrimFilter = + return $ + CVar (Named Stdlib "list" .- string2Name "filterlist") compilePrim (_ :*: TyBag _ :->: _) PrimFilter = return $ CConst OFilterBag compilePrim (_ :*: TySet _ :->: _) PrimFilter = return $ CConst OFilterBag compilePrim ty PrimFilter = compilePrimErr PrimFilter ty -compilePrim (_ :->: TyList _) PrimJoin = return $ - CVar (Named Stdlib "list" .- string2Name "concat") +compilePrim (_ :->: TyList _) PrimJoin = + return $ + CVar (Named Stdlib "list" .- string2Name "concat") compilePrim (_ :->: TyBag _) PrimJoin = return $ CConst OBagUnions -compilePrim (_ :->: TySet _) PrimJoin = return $ - CVar (Named Stdlib "container" .- string2Name "unions") +compilePrim (_ :->: TySet _) PrimJoin = + return $ + CVar (Named Stdlib "container" .- string2Name "unions") compilePrim ty PrimJoin = compilePrimErr PrimJoin ty - compilePrim (_ :*: TyBag _ :*: _ :->: _) PrimMerge = return $ CConst OMerge compilePrim (_ :*: TySet _ :*: _ :->: _) PrimMerge = return $ CConst OMerge -compilePrim ty PrimMerge = compilePrimErr PrimMerge ty - +compilePrim ty PrimMerge = compilePrimErr PrimMerge ty compilePrim _ PrimIsPrime = return $ CConst OIsPrime compilePrim _ PrimFactor = return $ CConst OFactor compilePrim _ PrimFrac = return $ CConst OFrac @@ -418,13 +426,14 @@ UOp -> Core compileUOp _ op = CConst (coreUOps ! op) - where - -- Just look up the corresponding core operator. - coreUOps = - M.fromList - [ Neg ==> ONeg, - Fact ==> OFact - ] + where + -- Just look up the corresponding core operator. + coreUOps = + M.fromList + [ Neg ==> ONeg + , Fact ==> OFact + , Not ==> ONotProp + ] -- | Compile a binary operator. This function needs to know the types -- of the arguments and result since some operators are overloaded @@ -462,13 +471,13 @@ -- addition and multiplication. compileBOp (TyGraph _) (TyGraph _) (TyGraph _) op | op `elem` [Add, Mul] = - CConst (regularOps ! op) - where - regularOps = - M.fromList - [ Add ==> OOverlay, - Mul ==> OConnect - ] + CConst (regularOps ! op) + where + regularOps = + M.fromList + [ Add ==> OOverlay + , Mul ==> OConnect + ] -- The Cartesian product operator just compiles to library function calls. compileBOp (TySet _) _ _ CartProd = @@ -477,28 +486,31 @@ CVar (Named Stdlib "container" .- string2Name "bagCP") compileBOp (TyList _) _ _ CartProd = CVar (Named Stdlib "list" .- string2Name "listCP") - -- Some regular arithmetic operations that just translate straightforwardly. compileBOp _ _ _ op | op `M.member` regularOps = CConst (regularOps ! op) - where - regularOps = - M.fromList - [ Add ==> OAdd, - Mul ==> OMul, - Div ==> ODiv, - Exp ==> OExp, - Mod ==> OMod, - Divides ==> ODivides, - Choose ==> OMultinom, - Eq ==> OEq, - Lt ==> OLt - ] + where + regularOps = + M.fromList + [ Add ==> OAdd + , Mul ==> OMul + , Div ==> ODiv + , Exp ==> OExp + , Mod ==> OMod + , Divides ==> ODivides + , Choose ==> OMultinom + , Eq ==> OEq + , Lt ==> OLt + , And ==> OAnd + , Or ==> OOr + , Impl ==> OImpl + ] -- ShouldEq needs to know the type at which the comparison is -- occurring, so values can be correctly pretty-printed if the test -- fails. compileBOp ty _ _ ShouldEq = CConst (OShouldEq ty) +compileBOp ty _ _ ShouldLt = CConst (OShouldLt ty) compileBOp _ty (TyList _) _ Elem = CConst OListElem compileBOp _ty _ _ Elem = CConst OBagElem compileBOp ty1 ty2 resTy op = diff --git a/src/Disco/Context.hs b/src/Disco/Context.hs --- a/src/Disco/Context.hs +++ b/src/Disco/Context.hs @@ -1,6 +1,11 @@ {-# LANGUAGE DeriveTraversable #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + +-- SPDX-License-Identifier: BSD-3-Clause + -- | -- Module : Disco.Context -- Copyright : disco team and contributors @@ -9,81 +14,80 @@ -- A *context* is a mapping from names to other things (such as types -- or values). This module defines a generic type of contexts which -- is used in many different places throughout the disco codebase. --- ------------------------------------------------------------------------------ - --- SPDX-License-Identifier: BSD-3-Clause - -module Disco.Context - ( -- * Context type - Ctx - - -- * Construction - , emptyCtx - , singleCtx - , fromList - , ctxForModule - , localCtx +module Disco.Context ( + -- * Context type + Ctx, - -- * Insertion - , insert - , extend - , extends + -- * Construction + emptyCtx, + singleCtx, + fromList, + ctxForModule, + localCtx, - -- * Query - , null - , lookup, lookup' - , lookupNonLocal, lookupNonLocal' - , lookupAll, lookupAll' + -- * Insertion + insert, + extend, + extends, - -- * Conversion - , names - , elems - , assocs - , keysSet + -- * Query + null, + lookup, + lookup', + lookupNonLocal, + lookupNonLocal', + lookupAll, + lookupAll', - -- * Traversal - , coerceKeys - , restrictKeys + -- * Conversion + names, + elems, + assocs, + keysSet, - -- * Combination - , joinCtx - , joinCtxs + -- * Traversal + coerceKeys, + restrictKeys, - -- * Filter - , filter + -- * Combination + joinCtx, + joinCtxs, - ) where + -- * Filter + filter, +) where -import Control.Monad ((<=<)) -import Data.Bifunctor (first, second) -import Data.Coerce -import Data.Map (Map) -import qualified Data.Map as M -import Data.Map.Merge.Lazy as MM -import Data.Set (Set) -import qualified Data.Set as S -import Prelude hiding (filter, lookup, null) +import Control.Monad ((<=<)) +import Data.Bifunctor (first, second) +import Data.Coerce +import Data.Map (Map) +import qualified Data.Map as M +import Data.Map.Merge.Lazy as MM +import Data.Set (Set) +import qualified Data.Set as S +import Prelude hiding (filter, lookup, null) -import Unbound.Generics.LocallyNameless (Name) +import Unbound.Generics.LocallyNameless (Name) -import Polysemy -import Polysemy.Reader +import Polysemy +import Polysemy.Reader -import Disco.Names (ModuleName, - NameProvenance (..), - QName (..)) +import Disco.Names ( + ModuleName, + NameProvenance (..), + QName (..), + ) -- | A context maps qualified names to things. In particular a @Ctx a -- b@ maps qualified names for @a@s to values of type @b@. -newtype Ctx a b = Ctx { getCtx :: M.Map NameProvenance (M.Map (Name a) b) } +newtype Ctx a b = Ctx {getCtx :: M.Map NameProvenance (M.Map (Name a) b)} deriving (Eq, Show, Functor, Foldable, Traversable) - -- Note that we implement a context as a nested map from - -- NameProvenance to Name to b, rather than as a Map QName b. They - -- are isomorphic, but this way it is easier to do name resolution, - -- because given an (unqualified) Name, we can look it up in each - -- inner map corresponding to modules that are in scope. +-- Note that we implement a context as a nested map from +-- NameProvenance to Name to b, rather than as a Map QName b. They +-- are isomorphic, but this way it is easier to do name resolution, +-- because given an (unqualified) Name, we can look it up in each +-- inner map corresponding to modules that are in scope. instance Semigroup (Ctx a b) where (<>) = joinCtx @@ -159,8 +163,8 @@ -- | Look up all the non-local bindings of a name in a context. lookupNonLocal' :: Name a -> Ctx a b -> [(ModuleName, b)] lookupNonLocal' n = nonLocal . lookupAll' n - where - nonLocal bs = [(m,b) | (QName (QualifiedName m) _, b) <- bs] + where + nonLocal bs = [(m, b) | (QName (QualifiedName m) _, b) <- bs] -- | Look up all the bindings of an (unqualified) name in an ambient context. lookupAll :: Member (Reader (Ctx a b)) r => Name a -> Sem r [(QName a, b)] @@ -186,9 +190,9 @@ -- context. assocs :: Ctx a b -> [(QName a, b)] assocs = concatMap (uncurry modAssocs) . M.assocs . getCtx - where - modAssocs :: NameProvenance -> Map (Name a) b -> [(QName a, b)] - modAssocs p = map (first (QName p)) . M.assocs + where + modAssocs :: NameProvenance -> Map (Name a) b -> [(QName a, b)] + modAssocs p = map (first (QName p)) . M.assocs -- | Return a set of all qualified names in the context. keysSet :: Ctx a b -> Set (QName a) @@ -205,9 +209,9 @@ -- | Restrict a context to only the keys in the given set. restrictKeys :: Ctx a b -> Set (QName a) -> Ctx a b restrictKeys ctx xs = Ctx . restrict m . getCtx $ ctx - where - restrict = MM.merge MM.dropMissing MM.dropMissing (MM.zipWithMatched (\_ ns m' -> M.restrictKeys m' ns)) - m = M.fromListWith S.union . map (\(QName p n) -> (p, S.singleton n)) . S.toList $ xs + where + restrict = MM.merge MM.dropMissing MM.dropMissing (MM.zipWithMatched (\_ ns m' -> M.restrictKeys m' ns)) + m = M.fromListWith S.union . map (\(QName p n) -> (p, S.singleton n)) . S.toList $ xs ------------------------------------------------------------ -- Combination @@ -217,7 +221,7 @@ -- exists in both contexts, the result will use the value from the -- first context, and throw away the value from the second.). joinCtx :: Ctx a b -> Ctx a b -> Ctx a b -joinCtx a b = joinCtxs [a,b] +joinCtx a b = joinCtxs [a, b] -- | Join a list of contexts (left-biased). joinCtxs :: [Ctx a b] -> Ctx a b diff --git a/src/Disco/Data.hs b/src/Disco/Data.hs --- a/src/Disco/Data.hs +++ b/src/Disco/Data.hs @@ -1,25 +1,25 @@ -{-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wno-orphans #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Disco.Data -- Copyright : disco team and contributors -- Maintainer : byorgey@gmail.com -- -- Some orphan 'Data' instances. --- ------------------------------------------------------------------------------ - module Disco.Data where -import Unbound.Generics.LocallyNameless.Bind -import Unbound.Generics.LocallyNameless.Embed -import Unbound.Generics.LocallyNameless.Name +import Unbound.Generics.LocallyNameless.Bind +import Unbound.Generics.LocallyNameless.Embed +import Unbound.Generics.LocallyNameless.Name -import Data.Data (Data) -import Unbound.Generics.LocallyNameless.Rebind +import Data.Data (Data) +import Unbound.Generics.LocallyNameless.Rebind ------------------------------------------------------------ -- Some orphan instances @@ -29,4 +29,3 @@ deriving instance Data t => Data (Embed t) deriving instance (Data a, Data b) => Data (Rebind a b) deriving instance Data a => Data (Name a) - diff --git a/src/Disco/Desugar.hs b/src/Disco/Desugar.hs --- a/src/Disco/Desugar.hs +++ b/src/Disco/Desugar.hs @@ -1,4 +1,7 @@ ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Disco.Desugar -- Copyright : disco team and contributors @@ -8,43 +11,49 @@ -- -- Desugaring the typechecked surface language to a (still typed) -- simpler language. --- ------------------------------------------------------------------------------ - -module Disco.Desugar - ( -- * Running desugaring computations - runDesugar +module Disco.Desugar ( + -- * Running desugaring computations + runDesugar, - -- * Programs, terms, and properties - , desugarDefn, desugarTerm, desugarProperty + -- * Programs, terms, and properties + desugarDefn, + desugarTerm, + desugarProperty, - -- * Case expressions and patterns - , desugarBranch, desugarGuards - ) - where + -- * Case expressions and patterns + desugarBranch, + desugarGuards, +) +where -import Control.Monad.Cont -import Data.Bool (bool) -import Data.Coerce -import Data.Maybe (fromMaybe, isJust) +import Control.Monad.Cont +import Data.Bool (bool) +import Data.Coerce +import Data.Maybe (fromMaybe, isJust) -import Disco.AST.Desugared -import Disco.AST.Surface -import Disco.AST.Typed -import Disco.Module -import Disco.Names -import Disco.Syntax.Operators -import Disco.Syntax.Prims -import Disco.Typecheck (containerTy) -import Disco.Types +import Disco.AST.Desugared +import Disco.AST.Surface +import Disco.AST.Typed +import Disco.Module +import Disco.Names +import Disco.Syntax.Operators +import Disco.Syntax.Prims +import Disco.Typecheck (containerTy) +import Disco.Types -import Disco.Effects.Fresh -import Polysemy (Member, Sem, run) -import Unbound.Generics.LocallyNameless (Bind, Name, bind, - embed, name2String, - string2Name, unembed, - unrebind) -import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) +import Disco.Effects.Fresh +import Polysemy (Member, Sem, run) +import Unbound.Generics.LocallyNameless ( + Bind, + Name, + bind, + embed, + name2String, + string2Name, + unembed, + unrebind, + ) +import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) ------------------------------------------------------------ -- Running desugaring computations @@ -53,11 +62,12 @@ -- | Run a desugaring computation. runDesugar :: Sem '[Fresh] a -> a runDesugar = run . runFresh1 - -- Using runFresh1 is a bit of a hack; that way we won't - -- ever pick a name with #0 (which is what is generated by default - -- by string2Name), hence won't conflict with any existing free - -- variables which came from the parser. +-- Using runFresh1 is a bit of a hack; that way we won't +-- ever pick a name with #0 (which is what is generated by default +-- by string2Name), hence won't conflict with any existing free +-- variables which came from the parser. + ------------------------------------------------------------ -- ATerm DSL ------------------------------------------------------------ @@ -71,20 +81,20 @@ tapp :: ATerm -> ATerm -> ATerm tapp t1 t2 = ATApp resTy t1 t2 - where - resTy = case getType t1 of - (_ :->: r) -> r - ty -> error $ "Impossible! Got non-function type " ++ show ty ++ " in tapp" + where + resTy = case getType t1 of + (_ :->: r) -> r + ty -> error $ "Impossible! Got non-function type " ++ show ty ++ " in tapp" mkBin :: Type -> BOp -> ATerm -> ATerm -> ATerm -mkBin resTy bop t1 t2 - = tapp (ATPrim (getType t1 :*: getType t2 :->: resTy) (PrimBOp bop)) (mkPair t1 t2) +mkBin resTy bop t1 t2 = + tapp (ATPrim (getType t1 :*: getType t2 :->: resTy) (PrimBOp bop)) (mkPair t1 t2) mkUn :: Type -> UOp -> ATerm -> ATerm mkUn resTy uop t = tapp (ATPrim (getType t :->: resTy) (PrimUOp uop)) t mkPair :: ATerm -> ATerm -> ATerm -mkPair t1 t2 = mkTup [t1,t2] +mkPair t1 t2 = mkTup [t1, t2] mkTup :: [ATerm] -> ATerm mkTup ts = ATTup (foldr1 (:*:) (map getType ts)) ts @@ -151,14 +161,14 @@ dtapp :: DTerm -> DTerm -> DTerm dtapp t1 t2 = DTApp resTy t1 t2 - where - resTy = case getType t1 of - (_ :->: r) -> r - ty -> error $ "Impossible! Got non-function type " ++ show ty ++ " in dtapp" + where + resTy = case getType t1 of + (_ :->: r) -> r + ty -> error $ "Impossible! Got non-function type " ++ show ty ++ " in dtapp" dtbin :: Type -> Prim -> DTerm -> DTerm -> DTerm -dtbin resTy p dt1 dt2 - = dtapp (DTPrim (getType dt1 :*: getType dt2 :->: resTy) p) (mkDTPair dt1 dt2) +dtbin resTy p dt1 dt2 = + dtapp (DTPrim (getType dt1 :*: getType dt2 :->: resTy) p) (mkDTPair dt1 dt2) mkDTPair :: DTerm -> DTerm -> DTerm mkDTPair dt1 dt2 = DTPair (getType dt1 :*: getType dt2) dt1 dt2 @@ -181,15 +191,14 @@ -- with their corresponding patterns. Definitions are abstractions -- (which happen to be named), and source-level lambdas are also -- abstractions (which happen to have only one clause). - desugarAbs :: Member Fresh r => Quantifier -> Type -> [Clause] -> Sem r DTerm -- Special case for compiling a single lambda with no pattern matching directly to a lambda desugarAbs Lam ty [cl@(unsafeUnbind -> ([APVar _ _], _))] = do (ps, at) <- unbind cl d <- desugarTerm at return $ DTAbs Lam ty (bind (getVar (head ps)) d) - where - getVar (APVar _ x) = coerce x + where + getVar (APVar _ x) = coerce x -- General case desugarAbs quant overallTy body = do clausePairs <- unbindClauses body @@ -205,36 +214,37 @@ let branches = zipWith (mkBranch (zip args patTys)) bodies pats dcase <- desugarTerm $ ATCase bodyTy branches return $ mkAbs quant overallTy patTys (coerce args) dcase - - where - mkBranch :: [(Name ATerm, Type)] -> ATerm -> [APattern] -> ABranch - mkBranch xs b ps = bind (mkGuards xs ps) b + where + mkBranch :: [(Name ATerm, Type)] -> ATerm -> [APattern] -> ABranch + mkBranch xs b ps = bind (mkGuards xs ps) b - mkGuards :: [(Name ATerm, Type)] -> [APattern] -> Telescope AGuard - mkGuards xs ps = toTelescope $ zipWith AGPat (map (\(x,ty) -> embed (atVar ty x)) xs) ps + mkGuards :: [(Name ATerm, Type)] -> [APattern] -> Telescope AGuard + mkGuards xs ps = toTelescope $ zipWith AGPat (map (\(x, ty) -> embed (atVar ty x)) xs) ps - -- To make searches fairer, we lift up directly nested abstractions - -- with the same quantifier when there's only a single clause. That - -- way, we generate a chain of abstractions followed by a case, instead - -- of a bunch of alternating abstractions and cases. - unbindClauses :: Member Fresh r => [Clause] -> Sem r [([APattern], ATerm)] - unbindClauses [c] | quant `elem` [All, Ex] = do - (ps, t) <- liftClause c - return [(ps, addDbgInfo ps t)] - unbindClauses cs = mapM unbind cs + -- To make searches fairer, we lift up directly nested abstractions + -- with the same quantifier when there's only a single clause. That + -- way, we generate a chain of abstractions followed by a case, instead + -- of a bunch of alternating abstractions and cases. + unbindClauses :: Member Fresh r => [Clause] -> Sem r [([APattern], ATerm)] + unbindClauses [c] | quant `elem` [All, Ex] = do + (ps, t) <- liftClause c + return [(ps, addDbgInfo ps t)] + unbindClauses cs = mapM unbind cs - liftClause :: Member Fresh r => Bind [APattern] ATerm -> Sem r ([APattern], ATerm) - liftClause c = unbind c >>= \case + liftClause :: Member Fresh r => Bind [APattern] ATerm -> Sem r ([APattern], ATerm) + liftClause c = + unbind c >>= \case (ps, ATAbs q _ c') | q == quant -> do (ps', b) <- liftClause c' return (ps ++ ps', b) (ps, b) -> return (ps, b) - -- Wrap a term in a test frame to report the values of all variables - -- bound in the patterns. - addDbgInfo :: [APattern] -> ATerm -> ATerm - addDbgInfo ps t = ATTest (map withName $ concatMap varsBound ps) t - where withName (n, ty) = (name2String n, ty, n) + -- Wrap a term in a test frame to report the values of all variables + -- bound in the patterns. + addDbgInfo :: [APattern] -> ATerm -> ATerm + addDbgInfo ps t = ATTest (map withName $ concatMap varsBound ps) t + where + withName (n, ty) = (name2String n, ty, n) ------------------------------------------------------------ -- Term desugaring @@ -245,11 +255,14 @@ desugarCList2B :: Member Fresh r => Prim -> Type -> Type -> Type -> Sem r DTerm desugarCList2B p ty cts b = do c <- fresh (string2Name "c") - body <- desugarTerm $ - tapp (ATPrim (TyBag cts :->: TyBag b) p) - (tapp (ATPrim (TyList cts :->: TyBag cts) PrimBag) - (atVar (TyList cts) c) - ) + body <- + desugarTerm $ + tapp + (ATPrim (TyBag cts :->: TyBag b) p) + ( tapp + (ATPrim (TyList cts :->: TyBag cts) PrimBag) + (atVar (TyList cts) c) + ) return $ mkLambda ty [c] body -- | Desugar a typechecked term. @@ -261,43 +274,33 @@ | bopDesugars ty1 ty2 resTy bop = desugarPrimBOp ty1 ty2 resTy bop desugarTerm (ATPrim ty@(TyList cts :->: TyBag b) PrimC2B) = desugarCList2B PrimC2B ty cts b desugarTerm (ATPrim ty@(TyList cts :->: TyBag b) PrimUC2B) = desugarCList2B PrimUC2B ty cts b - -desugarTerm (ATPrim ty x) = return $ DTPrim ty x -desugarTerm ATUnit = return DTUnit -desugarTerm (ATBool ty b) = return $ DTBool ty b -desugarTerm (ATChar c) = return $ DTChar c -desugarTerm (ATString cs) = +desugarTerm (ATPrim ty x) = return $ DTPrim ty x +desugarTerm ATUnit = return DTUnit +desugarTerm (ATBool ty b) = return $ DTBool ty b +desugarTerm (ATChar c) = return $ DTChar c +desugarTerm (ATString cs) = desugarContainer (TyList TyC) ListContainer (map (\c -> (ATChar c, Nothing)) cs) Nothing -desugarTerm (ATAbs q ty lam) = desugarAbs q ty [lam] - +desugarTerm (ATAbs q ty lam) = desugarAbs q ty [lam] -- Special cases for fully applied operators desugarTerm (ATApp resTy (ATPrim _ (PrimUOp uop)) t) | uopDesugars (getType t) resTy uop = desugarUnApp resTy uop t -desugarTerm (ATApp resTy (ATPrim _ (PrimBOp bop)) (ATTup _ [t1,t2])) +desugarTerm (ATApp resTy (ATPrim _ (PrimBOp bop)) (ATTup _ [t1, t2])) | bopDesugars (getType t1) (getType t2) resTy bop = desugarBinApp resTy bop t1 t2 - -desugarTerm (ATApp ty t1 t2) = +desugarTerm (ATApp ty t1 t2) = DTApp ty <$> desugarTerm t1 <*> desugarTerm t2 -desugarTerm (ATTup ty ts) = desugarTuples ty ts -desugarTerm (ATNat ty n) = return $ DTNat ty n -desugarTerm (ATRat r) = return $ DTRat r - -desugarTerm (ATTyOp ty op t) = return $ DTTyOp ty op t - -desugarTerm (ATChain _ t1 links) = desugarTerm $ expandChain t1 links - +desugarTerm (ATTup ty ts) = desugarTuples ty ts +desugarTerm (ATNat ty n) = return $ DTNat ty n +desugarTerm (ATRat r) = return $ DTRat r +desugarTerm (ATTyOp ty op t) = return $ DTTyOp ty op t +desugarTerm (ATChain _ t1 links) = desugarTerm $ expandChain t1 links desugarTerm (ATContainer ty c es mell) = desugarContainer ty c es mell - desugarTerm (ATContainerComp _ ctr bqt) = do (qs, t) <- unbind bqt desugarComp ctr t qs - desugarTerm (ATLet _ t) = do (bs, t2) <- unbind t desugarLet (fromTelescope bs) t2 - desugarTerm (ATCase ty bs) = DTCase ty <$> mapM desugarBranch bs - desugarTerm (ATTest info t) = DTTest (coerce info) <$> desugarTerm t -- | Desugar a property by wrapping its corresponding term in a test @@ -313,7 +316,8 @@ -- desugared, given the type of the argument and result. uopDesugars :: Type -> Type -> UOp -> Bool -- uopDesugars _ (TyFin _) Neg = True -uopDesugars _ _ uop = uop == Not +uopDesugars TyProp TyProp Not = False +uopDesugars _ _ uop = uop == Not desugarPrimUOp :: Member Fresh r => Type -> Type -> UOp -> Sem r DTerm desugarPrimUOp argTy resTy op = do @@ -324,16 +328,34 @@ -- | Test whether a given binary operator is one that needs to be -- desugared, given the two types of the arguments and the type of the result. bopDesugars :: Type -> Type -> Type -> BOp -> Bool -bopDesugars _ TyN _ Choose = True +bopDesugars _ TyN _ Choose = True -- bopDesugars _ _ (TyFin _) bop | bop `elem` [Add, Mul] = True -bopDesugars _ _ _ bop = bop `elem` - [ And, Or, Impl, Iff - , Neq, Gt, Leq, Geq, Min, Max - , IDiv - , Sub, SSub - , Inter, Diff, Union, Subset - ] +-- And, Or, Impl for Props don't desugar because they are primitive +-- Prop constructors. On the other hand, logical operations on Bool +-- can desugar in terms of more primitive conditional expressions. +bopDesugars _ _ TyProp bop | bop `elem` [And, Or, Impl] = False +bopDesugars _ _ _ bop = + bop + `elem` [ And + , Or + , Impl + , Iff + , Neq + , Gt + , Leq + , Geq + , Min + , Max + , IDiv + , Sub + , SSub + , Inter + , Diff + , Union + , Subset + ] + -- | Desugar a primitive binary operator at the given type. desugarPrimBOp :: Member Fresh r => Type -> Type -> Type -> BOp -> Sem r DTerm desugarPrimBOp ty1 ty2 resTy op = do @@ -342,17 +364,18 @@ y <- fresh (string2Name "arg2") let argsTy = ty1 :*: ty2 body <- desugarBinApp resTy op (atVar ty1 x) (atVar ty2 y) - return $ mkLambda (argsTy :->: resTy) [p] $ - DTCase resTy - [ bind - (toTelescope [DGPat (embed (dtVar argsTy (coerce p))) (DPPair argsTy (coerce x) (coerce y))]) - body - ] + return $ + mkLambda (argsTy :->: resTy) [p] $ + DTCase + resTy + [ bind + (toTelescope [DGPat (embed (dtVar argsTy (coerce p))) (DPPair argsTy (coerce x) (coerce y))]) + body + ] -- | Desugar a saturated application of a unary operator. -- The first argument is the type of the result. desugarUnApp :: Member Fresh r => Type -> UOp -> ATerm -> Sem r DTerm - -- Desugar negation on TyFin to a negation on TyZ followed by a mod. -- See the comments below re: Add and Mul on TyFin. -- desugarUnApp (TyFin n) Neg t = @@ -360,83 +383,84 @@ -- XXX This should be turned into a standard library definition. -- not t ==> {? false if t, true otherwise ?} -desugarUnApp _ Not t = desugarTerm $ - ATCase TyBool - [ fls <==. [AGBool (embed t)] - , tru <==. [] - ] - +desugarUnApp _ Not t = + desugarTerm $ + ATCase + TyBool + [ fls <==. [AGBool (embed t)] + , tru <==. [] + ] desugarUnApp ty uop t = error $ "Impossible! desugarUnApp " ++ show ty ++ " " ++ show uop ++ " " ++ show t -- | Desugar a saturated application of a binary operator. -- The first argument is the type of the result. desugarBinApp :: Member Fresh r => Type -> BOp -> ATerm -> ATerm -> Sem r DTerm - -- Implies, and, or should all be turned into a standard library -- definition. This will require first (1) adding support for -- modules/a standard library, including (2) the ability to define -- infix operators. -- t1 and t2 ==> {? t2 if t1, false otherwise ?} -desugarBinApp _ And t1 t2 = desugarTerm $ - ATCase TyBool - [ t2 <==. [tif t1] - , fls <==. [] - ] - +desugarBinApp _ And t1 t2 = + desugarTerm $ + ATCase + TyBool + [ t2 <==. [tif t1] + , fls <==. [] + ] -- (t1 implies t2) ==> (not t1 or t2) desugarBinApp _ Impl t1 t2 = desugarTerm $ tnot t1 ||. t2 - -- (t1 iff t2) ==> (t1 == t2) desugarBinApp _ Iff t1 t2 = desugarTerm $ t1 ==. t2 - -- t1 or t2 ==> {? true if t1, t2 otherwise ?}) -desugarBinApp _ Or t1 t2 = desugarTerm $ - ATCase TyBool - [ tru <==. [tif t1] - , t2 <==. [] - ] - +desugarBinApp _ Or t1 t2 = + desugarTerm $ + ATCase + TyBool + [ tru <==. [tif t1] + , t2 <==. [] + ] desugarBinApp _ Neq t1 t2 = desugarTerm $ tnot (t1 ==. t2) -desugarBinApp _ Gt t1 t2 = desugarTerm $ t2 <. t1 +desugarBinApp _ Gt t1 t2 = desugarTerm $ t2 <. t1 desugarBinApp _ Leq t1 t2 = desugarTerm $ tnot (t2 <. t1) desugarBinApp _ Geq t1 t2 = desugarTerm $ tnot (t1 <. t2) - -- XXX sharing! -desugarBinApp ty Min t1 t2 = desugarTerm $ - ATCase ty - [ t1 <==. [tif (t1 <. t2)] - , t2 <==. [] - ] - -desugarBinApp ty Max t1 t2 = desugarTerm $ - ATCase ty - [ t1 <==. [tif (t2 <. t1)] - , t2 <==. [] - ] - +desugarBinApp ty Min t1 t2 = + desugarTerm $ + ATCase + ty + [ t1 <==. [tif (t1 <. t2)] + , t2 <==. [] + ] +desugarBinApp ty Max t1 t2 = + desugarTerm $ + ATCase + ty + [ t1 <==. [tif (t2 <. t1)] + , t2 <==. [] + ] -- t1 // t2 ==> floor (t1 / t2) -desugarBinApp resTy IDiv t1 t2 = desugarTerm $ - ATApp resTy (ATPrim (getType t1 :->: resTy) PrimFloor) (mkBin (getType t1) Div t1 t2) - +desugarBinApp resTy IDiv t1 t2 = + desugarTerm $ + ATApp resTy (ATPrim (getType t1 :->: resTy) PrimFloor) (mkBin (getType t1) Div t1 t2) -- Desugar normal binomial coefficient (n choose k) to a multinomial -- coefficient with a singleton list, (n choose [k]). -- Note this will only be called when (getType t2 == TyN); see bopDesugars. -desugarBinApp _ Choose t1 t2 - = desugarTerm $ mkBin TyN Choose t1 (ctrSingleton ListContainer t2) - -desugarBinApp ty Sub t1 t2 = desugarTerm $ mkBin ty Add t1 (mkUn ty Neg t2) -desugarBinApp ty SSub t1 t2 = desugarTerm $ - -- t1 -. t2 ==> {? 0 if t1 < t2, t1 - t2 otherwise ?} - ATCase ty - [ ATNat ty 0 <==. [tif (t1 <. t2)] - , mkBin ty Sub t1 t2 <==. [] +desugarBinApp _ Choose t1 t2 = + desugarTerm $ mkBin TyN Choose t1 (ctrSingleton ListContainer t2) +desugarBinApp ty Sub t1 t2 = desugarTerm $ mkBin ty Add t1 (mkUn ty Neg t2) +desugarBinApp ty SSub t1 t2 = + desugarTerm $ + -- t1 -. t2 ==> {? 0 if t1 < t2, t1 - t2 otherwise ?} + ATCase + ty + [ ATNat ty 0 <==. [tif (t1 <. t2)] + , mkBin ty Sub t1 t2 <==. [] -- NOTE, the above is slightly bogus since the whole point of SSub is -- because we can't subtract naturals. However, this will -- immediately desugar to a DTerm. When we write a linting -- typechecker for DTerms we should allow subtraction on TyN! - ] - + ] -- Addition and multiplication on TyFin just desugar to the operation -- followed by a call to mod. -- desugarBinApp (TyFin n) op t1 t2 @@ -444,57 +468,60 @@ -- mkBin (TyFin n) Mod -- (mkBin TyN op t1 t2) -- (ATNat TyN n) - -- Note the typing of this is a bit funny: t1 and t2 presumably - -- have type (TyFin n), and now we are saying that applying 'op' - -- to them results in TyN, then applying 'mod' results in a TyFin - -- n again. Using TyN as the intermediate result is necessary so - -- we don't fall into an infinite desugaring loop, and intuitively - -- makes sense because the idea is that we first do the operation - -- as a normal operation in "natural land" and then do a mod. - -- - -- We will have to think carefully about how the linting - -- typechecker for DTerms should treat TyN and TyFin. Probably - -- something like this will work: TyFin is a subtype of TyN, and - -- TyN can be turned into TyFin with mod. (We don't want such - -- typing rules in the surface disco language itself because - -- implicit coercions from TyFin -> N don't commute with - -- operations like addition and multiplication, e.g. 3+3 yields 1 - -- if we add them in Z5 and then coerce to Nat, but 6 if we first - -- coerce both and then add. +-- Note the typing of this is a bit funny: t1 and t2 presumably +-- have type (TyFin n), and now we are saying that applying 'op' +-- to them results in TyN, then applying 'mod' results in a TyFin +-- n again. Using TyN as the intermediate result is necessary so +-- we don't fall into an infinite desugaring loop, and intuitively +-- makes sense because the idea is that we first do the operation +-- as a normal operation in "natural land" and then do a mod. +-- +-- We will have to think carefully about how the linting +-- typechecker for DTerms should treat TyN and TyFin. Probably +-- something like this will work: TyFin is a subtype of TyN, and +-- TyN can be turned into TyFin with mod. (We don't want such +-- typing rules in the surface disco language itself because +-- implicit coercions from TyFin -> N don't commute with +-- operations like addition and multiplication, e.g. 3+3 yields 1 +-- if we add them in Z5 and then coerce to Nat, but 6 if we first +-- coerce both and then add. -- Intersection, difference, and union all desugar to an application -- of 'merge' with an appropriate combining operation. desugarBinApp ty op t1 t2 | op `elem` [Inter, Diff, Union] = - desugarTerm $ - tapps (ATPrim ((TyN :*: TyN :->: TyN) :*: ty :*: ty :->: ty) PrimMerge) - [ ATPrim (TyN :*: TyN :->: TyN) (mergeOp ty op) - , t1 - , t2 - ] - where - mergeOp _ Inter = PrimBOp Min - mergeOp _ Diff = PrimBOp SSub - mergeOp (TySet _) Union = PrimBOp Max - mergeOp (TyBag _) Union = PrimBOp Add - mergeOp _ _ = error $ "Impossible! mergeOp " ++ show ty ++ " " ++ show op + desugarTerm $ + tapps + (ATPrim ((TyN :*: TyN :->: TyN) :*: ty :*: ty :->: ty) PrimMerge) + [ ATPrim (TyN :*: TyN :->: TyN) (mergeOp ty op) + , t1 + , t2 + ] + where + mergeOp _ Inter = PrimBOp Min + mergeOp _ Diff = PrimBOp SSub + mergeOp (TySet _) Union = PrimBOp Max + mergeOp (TyBag _) Union = PrimBOp Add + mergeOp _ _ = error $ "Impossible! mergeOp " ++ show ty ++ " " ++ show op -- A ⊆ B <==> (A ⊔ B = B) -- where ⊔ denotes 'merge max'. -- Note it is NOT union, since this doesn't work for bags. -- e.g. bag [1] union bag [1,2] = bag [1,1,2] /= bag [1,2]. -desugarBinApp _ Subset t1 t2 = desugarTerm $ - tapps (ATPrim (ty :*: ty :->: TyBool) (PrimBOp Eq)) - [ tapps (ATPrim ((TyN :*: TyN :->: TyN) :*: ty :*: ty :->: ty) PrimMerge) - [ ATPrim (TyN :*: TyN :->: TyN) (PrimBOp Max) - , t1 - , t2 - ] - , t2 -- XXX sharing - ] - where - ty = getType t1 - +desugarBinApp _ Subset t1 t2 = + desugarTerm $ + tapps + (ATPrim (ty :*: ty :->: TyBool) (PrimBOp Eq)) + [ tapps + (ATPrim ((TyN :*: TyN :->: TyN) :*: ty :*: ty :->: ty) PrimMerge) + [ ATPrim (TyN :*: TyN :->: TyN) (PrimBOp Max) + , t1 + , t2 + ] + , t2 -- XXX sharing + ] + where + ty = getType t1 desugarBinApp ty bop t1 t2 = error $ "Impossible! desugarBinApp " ++ show ty ++ " " ++ show bop ++ " " ++ show t1 ++ " " ++ show t2 ------------------------------------------------------------ @@ -508,36 +535,37 @@ -- | Expand a container comprehension into an equivalent ATerm. expandComp :: Member Fresh r => Container -> ATerm -> Telescope AQual -> Sem r ATerm - -- [ t | ] = [ t ] expandComp ctr t TelEmpty = return $ ctrSingleton ctr t - -- [ t | q, qs ] = ... -expandComp ctr t (TelCons (unrebind -> (q,qs))) - = case q of - -- [ t | x in l, qs ] = join (map (\x -> [t | qs]) l) - AQBind x (unembed -> lst) -> do - tqs <- expandComp ctr t qs - let c = containerTy ctr - tTy = getType t - xTy = case getType lst of - TyContainer _ e -> e - _ -> error "Impossible! Not a container in expandComp" - joinTy = c (c tTy) :->: c tTy - mapTy = (xTy :->: c tTy) :*: c xTy :->: c (c tTy) - return $ tapp (ATPrim joinTy PrimJoin) $ +expandComp ctr t (TelCons (unrebind -> (q, qs))) = + case q of + -- [ t | x in l, qs ] = join (map (\x -> [t | qs]) l) + AQBind x (unembed -> lst) -> do + tqs <- expandComp ctr t qs + let c = containerTy ctr + tTy = getType t + xTy = case getType lst of + TyContainer _ e -> e + _ -> error "Impossible! Not a container in expandComp" + joinTy = c (c tTy) :->: c tTy + mapTy = (xTy :->: c tTy) :*: c xTy :->: c (c tTy) + return $ + tapp (ATPrim joinTy PrimJoin) $ tapp (ATPrim mapTy PrimEach) - (mkPair - (ATAbs Lam (xTy :->: c tTy) (bind [APVar xTy x] tqs)) - lst + ( mkPair + (ATAbs Lam (xTy :->: c tTy) (bind [APVar xTy x] tqs)) + lst ) - -- [ t | g, qs ] = if g then [ t | qs ] else [] - AQGuard (unembed -> g) -> do - tqs <- expandComp ctr t qs - return $ ATCase (containerTy ctr (getType t)) - [ tqs <==. [tif g] + -- [ t | g, qs ] = if g then [ t | qs ] else [] + AQGuard (unembed -> g) -> do + tqs <- expandComp ctr t qs + return $ + ATCase + (containerTy ctr (getType t)) + [ tqs <==. [tif g] , ctrNil ctr (getType t) <==. [] ] @@ -553,8 +581,8 @@ desugarLet [] t = desugarTerm t desugarLet ((ABinding _ x (unembed -> t1)) : ls) t = dtapp - <$> (DTAbs Lam (getType t1 :->: getType t) - <$> (bind (coerce x) <$> desugarLet ls t) + <$> ( DTAbs Lam (getType t1 :->: getType t) + <$> (bind (coerce x) <$> desugarLet ls t) ) <*> desugarTerm t1 @@ -569,26 +597,26 @@ -- @\x. \y. \z. q@ mkLambda :: Type -> [Name ATerm] -> DTerm -> DTerm mkLambda funty args c = go funty args - where - go _ [] = c - go ty@(_ :->: ty2) (x:xs) = DTAbs Lam ty (bind (coerce x) (go ty2 xs)) - go ty as = error $ "Impossible! mkLambda.go " ++ show ty ++ " " ++ show as + where + go _ [] = c + go ty@(_ :->: ty2) (x : xs) = DTAbs Lam ty (bind (coerce x) (go ty2 xs)) + go ty as = error $ "Impossible! mkLambda.go " ++ show ty ++ " " ++ show as mkQuant :: Quantifier -> [Type] -> [Name ATerm] -> DTerm -> DTerm mkQuant q argtys args c = foldr quantify c (zip args argtys) where - quantify (x, ty) body = DTAbs q ty (bind (coerce x) body) + quantify (x, ty) body = DTAbs q ty (bind (coerce x) body) mkAbs :: Quantifier -> Type -> [Type] -> [Name ATerm] -> DTerm -> DTerm mkAbs Lam funty _ args c = mkLambda funty args c -mkAbs q _ argtys args c = mkQuant q argtys args c +mkAbs q _ argtys args c = mkQuant q argtys args c -- | Desugar a tuple to nested pairs, /e.g./ @(a,b,c,d) ==> (a,(b,(c,d)))@.a desugarTuples :: Member Fresh r => Type -> [ATerm] -> Sem r DTerm -desugarTuples _ [t] = desugarTerm t -desugarTuples ty@(_ :*: ty2) (t:ts) = DTPair ty <$> desugarTerm t <*> desugarTuples ty2 ts -desugarTuples ty ats - = error $ "Impossible! desugarTuples " ++ show ty ++ " " ++ show ats +desugarTuples _ [t] = desugarTerm t +desugarTuples ty@(_ :*: ty2) (t : ts) = DTPair ty <$> desugarTerm t <*> desugarTuples ty2 ts +desugarTuples ty ats = + error $ "Impossible! desugarTuples " ++ show ty ++ " " ++ show ats -- | Expand a chain of comparisons into a sequence of binary -- comparisons combined with @and@. Note we only expand it into @@ -600,7 +628,9 @@ expandChain _ [] = error "Can't happen! expandChain _ []" expandChain t1 [ATLink op t2] = mkBin TyBool op t1 t2 expandChain t1 (ATLink op t2 : links) = - mkBin TyBool And + mkBin + TyBool + And (mkBin TyBool op t1 t2) (expandChain t2 links) @@ -609,7 +639,7 @@ desugarBranch b = do (ags, at) <- unbind b dgs <- desugarGuards ags - d <- desugarTerm at + d <- desugarTerm at return $ bind dgs d -- | Desugar the list of guards in one branch of a case expression. @@ -617,215 +647,208 @@ -- turned into pattern guards which match against @true@. desugarGuards :: Member Fresh r => Telescope AGuard -> Sem r (Telescope DGuard) desugarGuards = fmap (toTelescope . concat) . mapM desugarGuard . fromTelescope - where - desugarGuard :: Member Fresh r => AGuard -> Sem r [DGuard] - - -- A Boolean guard is desugared to a pattern-match on @true = right(unit)@. - desugarGuard (AGBool (unembed -> at)) = do - dt <- desugarTerm at - desugarMatch dt (APInj TyBool R APUnit) - - -- 'let x = t' is desugared to 'when t is x'. - desugarGuard (AGLet (ABinding _ x (unembed -> at))) = do - dt <- desugarTerm at - varMatch dt (coerce x) - - -- Desugaring 'when t is p' is the most complex case; we have to - -- break down the pattern and match it incrementally. - desugarGuard (AGPat (unembed -> at) p) = do - dt <- desugarTerm at - desugarMatch dt p + where + desugarGuard :: Member Fresh r => AGuard -> Sem r [DGuard] - -- Desugar a guard of the form 'when dt is p'. An entire match is - -- the right unit to desugar --- as opposed to, say, writing a - -- function to desugar a pattern --- since a match may desugar to - -- multiple matches, and on recursive calls we need to know what - -- term/variable should be bound to the pattern. - -- - -- A match may desugar to multiple matches for two reasons: - -- - -- 1. Nested patterns 'explode' into a 'telescope' matching one - -- constructor at a time, for example, 'when t is (x,y,3)' - -- becomes 'when t is (x,x0) when x0 is (y,x1) when x1 is 3'. - -- This makes the order of matching explicit and enables lazy - -- matching without requiring special support from the - -- interpreter other than WHNF reduction. - -- - -- 2. Matches against arithmetic patterns desugar to a - -- combination of matching, computation, and boolean checks. - -- For example, 'when t is (y+1)' becomes 'when t is x0 if x0 >= - -- 1 let y = x0-1'. - desugarMatch :: Member Fresh r => DTerm -> APattern -> Sem r [DGuard] - desugarMatch dt (APVar ty x) = mkMatch dt (DPVar ty (coerce x)) - desugarMatch _ (APWild _) = return [] - desugarMatch dt APUnit = mkMatch dt DPUnit - desugarMatch dt (APBool b) = desugarMatch dt (APInj TyBool (bool L R b) APUnit) - desugarMatch dt (APNat ty n) = desugarMatch (dtbin TyBool (PrimBOp Eq) dt (DTNat ty n)) (APBool True) - desugarMatch dt (APChar c) = desugarMatch (dtbin TyBool (PrimBOp Eq) dt (DTChar c)) (APBool True) - desugarMatch dt (APString s) = desugarMatch dt (APList (TyList TyC) (map APChar s)) - desugarMatch dt (APTup tupTy pat) = desugarTuplePats tupTy dt pat - where - desugarTuplePats :: Member Fresh r => Type -> DTerm -> [APattern] -> Sem r [DGuard] - desugarTuplePats _ _ [] = error "Impossible! desugarTuplePats []" - desugarTuplePats _ t [p] = desugarMatch t p - desugarTuplePats ty@(_ :*: ty2) t (p:ps) = do - (x1,gs1) <- varForPat p - (x2,gs2) <- case ps of - [APVar _ px2] -> return (coerce px2, []) - _ -> do - x <- fresh (string2Name "x") - (x,) <$> desugarTuplePats ty2 (dtVar ty2 x) ps - fmap concat . sequence $ - [ mkMatch t $ DPPair ty x1 x2 - , return gs1 - , return gs2 - ] - desugarTuplePats ty _ _ - = error $ "Impossible! desugarTuplePats with non-pair type " ++ show ty + -- A Boolean guard is desugared to a pattern-match on @true = right(unit)@. + desugarGuard (AGBool (unembed -> at)) = do + dt <- desugarTerm at + desugarMatch dt (APInj TyBool R APUnit) - desugarMatch dt (APInj ty s p) = do - (x,gs) <- varForPat p - fmap concat . sequence $ - [ mkMatch dt $ DPInj ty s x - , return gs - ] + -- 'let x = t' is desugared to 'when t is x'. + desugarGuard (AGLet (ABinding _ x (unembed -> at))) = do + dt <- desugarTerm at + varMatch dt (coerce x) - desugarMatch dt (APCons ty p1 p2) = do - y <- fresh (string2Name "y") - (x1, gs1) <- varForPat p1 - (x2, gs2) <- varForPat p2 + -- Desugaring 'when t is p' is the most complex case; we have to + -- break down the pattern and match it incrementally. + desugarGuard (AGPat (unembed -> at) p) = do + dt <- desugarTerm at + desugarMatch dt p - let eltTy = getType p1 - unrolledTy = eltTy :*: ty + -- Desugar a guard of the form 'when dt is p'. An entire match is + -- the right unit to desugar --- as opposed to, say, writing a + -- function to desugar a pattern --- since a match may desugar to + -- multiple matches, and on recursive calls we need to know what + -- term/variable should be bound to the pattern. + -- + -- A match may desugar to multiple matches for two reasons: + -- + -- 1. Nested patterns 'explode' into a 'telescope' matching one + -- constructor at a time, for example, 'when t is (x,y,3)' + -- becomes 'when t is (x,x0) when x0 is (y,x1) when x1 is 3'. + -- This makes the order of matching explicit and enables lazy + -- matching without requiring special support from the + -- interpreter other than WHNF reduction. + -- + -- 2. Matches against arithmetic patterns desugar to a + -- combination of matching, computation, and boolean checks. + -- For example, 'when t is (y+1)' becomes 'when t is x0 if x0 >= + -- 1 let y = x0-1'. + desugarMatch :: Member Fresh r => DTerm -> APattern -> Sem r [DGuard] + desugarMatch dt (APVar ty x) = mkMatch dt (DPVar ty (coerce x)) + desugarMatch _ (APWild _) = return [] + desugarMatch dt APUnit = mkMatch dt DPUnit + desugarMatch dt (APBool b) = desugarMatch dt (APInj TyBool (bool L R b) APUnit) + desugarMatch dt (APNat ty n) = desugarMatch (dtbin TyBool (PrimBOp Eq) dt (DTNat ty n)) (APBool True) + desugarMatch dt (APChar c) = desugarMatch (dtbin TyBool (PrimBOp Eq) dt (DTChar c)) (APBool True) + desugarMatch dt (APString s) = desugarMatch dt (APList (TyList TyC) (map APChar s)) + desugarMatch dt (APTup tupTy pat) = desugarTuplePats tupTy dt pat + where + desugarTuplePats :: Member Fresh r => Type -> DTerm -> [APattern] -> Sem r [DGuard] + desugarTuplePats _ _ [] = error "Impossible! desugarTuplePats []" + desugarTuplePats _ t [p] = desugarMatch t p + desugarTuplePats ty@(_ :*: ty2) t (p : ps) = do + (x1, gs1) <- varForPat p + (x2, gs2) <- case ps of + [APVar _ px2] -> return (coerce px2, []) + _ -> do + x <- fresh (string2Name "x") + (x,) <$> desugarTuplePats ty2 (dtVar ty2 x) ps fmap concat . sequence $ - [ mkMatch dt (DPInj ty R y) - , mkMatch (dtVar unrolledTy y) (DPPair unrolledTy x1 x2) + [ mkMatch t $ DPPair ty x1 x2 , return gs1 , return gs2 ] - - desugarMatch dt (APList ty []) = desugarMatch dt (APInj ty L APUnit) - desugarMatch dt (APList ty ps) = - desugarMatch dt $ foldr (APCons ty) (APList ty []) ps - - -- when dt is (p + t) ==> when dt is x0; let v = t; [if x0 >= v]; when x0-v is p - desugarMatch dt (APAdd ty _ p t) = arithBinMatch posRestrict (-.) dt ty p t - where - posRestrict plusty - | plusty `elem` [TyN, TyF] = Just (>=.) - | otherwise = Nothing - - -- when dt is (p * t) ==> when dt is x0; let v = t; [if v divides x0]; when x0 / v is p - desugarMatch dt (APMul ty _ p t) = arithBinMatch intRestrict (/.) dt ty p t - where - intRestrict plusty - | plusty `elem` [TyN, TyZ] = Just (flip (|.)) - | otherwise = Nothing - - -- when dt is (p - t) ==> when dt is x0; let v = t; when x0 + v is p - desugarMatch dt (APSub ty p t) = arithBinMatch (const Nothing) (+.) dt ty p t - - -- when dt is (p/q) ==> when $frac(dt) is (p, q) - desugarMatch dt (APFrac _ p q) - = desugarMatch - (dtapp (DTPrim (TyQ :->: TyZ :*: TyN) PrimFrac) dt) - (APTup (TyZ :*: TyN) [p, q]) + desugarTuplePats ty _ _ = + error $ "Impossible! desugarTuplePats with non-pair type " ++ show ty + desugarMatch dt (APInj ty s p) = do + (x, gs) <- varForPat p + fmap concat . sequence $ + [ mkMatch dt $ DPInj ty s x + , return gs + ] + desugarMatch dt (APCons ty p1 p2) = do + y <- fresh (string2Name "y") + (x1, gs1) <- varForPat p1 + (x2, gs2) <- varForPat p2 - -- when dt is (-p) ==> when dt is x0; if x0 < 0; when -x0 is p - desugarMatch dt (APNeg ty p) = do + let eltTy = getType p1 + unrolledTy = eltTy :*: ty + fmap concat . sequence $ + [ mkMatch dt (DPInj ty R y) + , mkMatch (dtVar unrolledTy y) (DPPair unrolledTy x1 x2) + , return gs1 + , return gs2 + ] + desugarMatch dt (APList ty []) = desugarMatch dt (APInj ty L APUnit) + desugarMatch dt (APList ty ps) = + desugarMatch dt $ foldr (APCons ty) (APList ty []) ps + -- when dt is (p + t) ==> when dt is x0; let v = t; [if x0 >= v]; when x0-v is p + desugarMatch dt (APAdd ty _ p t) = arithBinMatch posRestrict (-.) dt ty p t + where + posRestrict plusty + | plusty `elem` [TyN, TyF] = Just (>=.) + | otherwise = Nothing - -- when dt is x0 - (x0, g1) <- varFor dt + -- when dt is (p * t) ==> when dt is x0; let v = t; [if v divides x0]; when x0 / v is p + desugarMatch dt (APMul ty _ p t) = arithBinMatch intRestrict (/.) dt ty p t + where + intRestrict plusty + | plusty `elem` [TyN, TyZ] = Just (flip (|.)) + | otherwise = Nothing - -- if x0 < 0 - g2 <- desugarGuard $ AGBool (embed (atVar ty (coerce x0) <. ATNat ty 0)) + -- when dt is (p - t) ==> when dt is x0; let v = t; when x0 + v is p + desugarMatch dt (APSub ty p t) = arithBinMatch (const Nothing) (+.) dt ty p t + -- when dt is (p/q) ==> when $frac(dt) is (p, q) + desugarMatch dt (APFrac _ p q) = + desugarMatch + (dtapp (DTPrim (TyQ :->: TyZ :*: TyN) PrimFrac) dt) + (APTup (TyZ :*: TyN) [p, q]) + -- when dt is (-p) ==> when dt is x0; if x0 < 0; when -x0 is p + desugarMatch dt (APNeg ty p) = do + -- when dt is x0 + (x0, g1) <- varFor dt - -- when -x0 is p - neg <- desugarTerm $ mkUn ty Neg (atVar ty (coerce x0)) - g3 <- desugarMatch neg p + -- if x0 < 0 + g2 <- desugarGuard $ AGBool (embed (atVar ty (coerce x0) <. ATNat ty 0)) - return (g1 ++ g2 ++ g3) + -- when -x0 is p + neg <- desugarTerm $ mkUn ty Neg (atVar ty (coerce x0)) + g3 <- desugarMatch neg p - mkMatch :: Member Fresh r => DTerm -> DPattern -> Sem r [DGuard] - mkMatch dt dp = return [DGPat (embed dt) dp] + return (g1 ++ g2 ++ g3) - varMatch :: Member Fresh r => DTerm -> Name DTerm -> Sem r [DGuard] - varMatch dt x = mkMatch dt (DPVar (getType dt) x) + mkMatch :: Member Fresh r => DTerm -> DPattern -> Sem r [DGuard] + mkMatch dt dp = return [DGPat (embed dt) dp] - varFor :: Member Fresh r => DTerm -> Sem r (Name DTerm, [DGuard]) - varFor (DTVar _ (QName _ x)) = return (x, []) -- XXX return a name + provenance?? - varFor dt = do - x <- fresh (string2Name "x") - g <- varMatch dt x - return (x, g) + varMatch :: Member Fresh r => DTerm -> Name DTerm -> Sem r [DGuard] + varMatch dt x = mkMatch dt (DPVar (getType dt) x) - varForPat :: Member Fresh r => APattern -> Sem r (Name DTerm, [DGuard]) - varForPat (APVar _ x) = return (coerce x, []) - varForPat p = do - x <- fresh (string2Name "px") -- changing this from x fixed a bug and I don't know why =( - (x,) <$> desugarMatch (dtVar (getType p) x) p + varFor :: Member Fresh r => DTerm -> Sem r (Name DTerm, [DGuard]) + varFor (DTVar _ (QName _ x)) = return (x, []) -- XXX return a name + provenance?? + varFor dt = do + x <- fresh (string2Name "x") + g <- varMatch dt x + return (x, g) - arithBinMatch - :: Member Fresh r - => (Type -> Maybe (ATerm -> ATerm -> ATerm)) - -> (ATerm -> ATerm -> ATerm) - -> DTerm -> Type -> APattern -> ATerm -> Sem r [DGuard] - arithBinMatch restrict inverse dt ty p t = do - (x0, g1) <- varFor dt + varForPat :: Member Fresh r => APattern -> Sem r (Name DTerm, [DGuard]) + varForPat (APVar _ x) = return (coerce x, []) + varForPat p = do + x <- fresh (string2Name "px") -- changing this from x fixed a bug and I don't know why =( + (x,) <$> desugarMatch (dtVar (getType p) x) p - -- let v = t - t' <- desugarTerm t - (v, g2) <- varFor t' + arithBinMatch :: + Member Fresh r => + (Type -> Maybe (ATerm -> ATerm -> ATerm)) -> + (ATerm -> ATerm -> ATerm) -> + DTerm -> + Type -> + APattern -> + ATerm -> + Sem r [DGuard] + arithBinMatch restrict inverse dt ty p t = do + (x0, g1) <- varFor dt - g3 <- case restrict ty of - Nothing -> return [] + -- let v = t + t' <- desugarTerm t + (v, g2) <- varFor t' - -- if x0 `cmp` v - Just cmp -> - desugarGuard $ - AGBool (embed (atVar ty (coerce x0) `cmp` atVar (getType t) (coerce v))) + g3 <- case restrict ty of + Nothing -> return [] + -- if x0 `cmp` v + Just cmp -> + desugarGuard $ + AGBool (embed (atVar ty (coerce x0) `cmp` atVar (getType t) (coerce v))) - -- when x0 `inverse` v is p - inv <- desugarTerm (atVar ty (coerce x0) `inverse` atVar (getType t) (coerce v)) - g4 <- desugarMatch inv p + -- when x0 `inverse` v is p + inv <- desugarTerm (atVar ty (coerce x0) `inverse` atVar (getType t) (coerce v)) + g4 <- desugarMatch inv p - return (g1 ++ g2 ++ g3 ++ g4) + return (g1 ++ g2 ++ g3 ++ g4) -- | Desugar a container literal such as @[1,2,3]@ or @{1,2,3}@. desugarContainer :: Member Fresh r => Type -> Container -> [(ATerm, Maybe ATerm)] -> Maybe (Ellipsis ATerm) -> Sem r DTerm - -- Literal list containers desugar to nested applications of cons. desugarContainer ty ListContainer es Nothing = foldr (dtbin ty (PrimBOp Cons)) (DTNil ty) <$> mapM (desugarTerm . fst) es - -- A list container with an ellipsis @[x, y, z .. e]@ desugars to an -- application of the primitive 'until' function. desugarContainer ty@(TyList _) ListContainer es (Just (Until t)) = dtbin ty PrimUntil <$> desugarTerm t <*> desugarContainer ty ListContainer es Nothing - -- If desugaring a bag and there are any counts specified, desugar to -- an application of bagFromCounts to a bag of pairs (with a literal -- value of 1 filled in for missing counts as needed). desugarContainer (TyBag eltTy) BagContainer es mell | any (isJust . snd) es = - dtapp (DTPrim (TySet (eltTy :*: TyN) :->: TyBag eltTy) PrimC2B) - <$> desugarContainer (TyBag (eltTy :*: TyN)) BagContainer counts mell - - where - -- turn e.g. x # 3, y into (x, 3), (y, 1) - counts = [ (ATTup (eltTy :*: TyN) [t, fromMaybe (ATNat TyN 1) n], Nothing) - | (t, n) <- es - ] + dtapp (DTPrim (TySet (eltTy :*: TyN) :->: TyBag eltTy) PrimC2B) + <$> desugarContainer (TyBag (eltTy :*: TyN)) BagContainer counts mell + where + -- turn e.g. x # 3, y into (x, 3), (y, 1) + counts = + [ (ATTup (eltTy :*: TyN) [t, fromMaybe (ATNat TyN 1) n], Nothing) + | (t, n) <- es + ] -- Other containers desugar to an application of the appropriate -- container conversion function to the corresponding desugared list. desugarContainer ty _ es mell = dtapp (DTPrim (TyList eltTy :->: ty) conv) <$> desugarContainer (TyList eltTy) ListContainer es mell - where - (conv, eltTy) = case ty of - TyBag e -> (PrimBag, e) - TySet e -> (PrimSet, e) - _ -> error $ "Impossible! Non-container type " ++ show ty ++ " in desugarContainer" + where + (conv, eltTy) = case ty of + TyBag e -> (PrimBag, e) + TySet e -> (PrimSet, e) + _ -> error $ "Impossible! Non-container type " ++ show ty ++ " in desugarContainer" diff --git a/src/Disco/Doc.hs b/src/Disco/Doc.hs --- a/src/Disco/Doc.hs +++ b/src/Disco/Doc.hs @@ -1,141 +1,157 @@ ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + +-- SPDX-License-Identifier: BSD-3-Clause + -- | -- Module : Disco.Doc -- Copyright : disco team and contributors -- Maintainer : byorgey@gmail.com -- -- Built-in documentation. --- ------------------------------------------------------------------------------ - --- SPDX-License-Identifier: BSD-3-Clause - -module Disco.Doc - ( primDoc, primReference, otherDoc, otherReference - ) where +module Disco.Doc ( + primDoc, + primReference, + otherDoc, + otherReference, +) where -import Data.Map (Map) -import qualified Data.Map as M +import Data.Map (Map) +import qualified Data.Map as M -import Disco.Syntax.Operators -import Disco.Syntax.Prims -import Disco.Util ((==>)) +import Disco.Syntax.Operators +import Disco.Syntax.Prims +import Disco.Util ((==>)) -- | A map from some primitives to a short descriptive string, -- to be shown by the :doc command. primDoc :: Map Prim String -primDoc = M.fromList - [ PrimUOp Neg ==> "Arithmetic negation." - , PrimBOp Add ==> "The sum of two numbers, types, or graphs." - , PrimBOp Sub ==> "The difference of two numbers." - , PrimBOp SSub ==> "The difference of two numbers, with a lower bound of 0." - , PrimBOp Mul ==> "The product of two numbers, types, or graphs." - , PrimBOp Div ==> "Divide two numbers." - , PrimBOp IDiv ==> "The integer quotient of two numbers, rounded down." - , PrimBOp Mod ==> "a mod b is the remainder when a is divided by b." - , PrimBOp Exp ==> "Exponentiation. a ^ b is a raised to the b power." - , PrimUOp Fact ==> "n! computes the factorial of n, that is, 1 * 2 * ... * n." - , PrimFloor ==> "floor(x) is the largest integer which is <= x." - , PrimCeil ==> "ceiling(x) is the smallest integer which is >= x." - , PrimAbs ==> "abs(x) is the absolute value of x. Also written |x|." - , PrimUOp Not ==> "Logical negation: not(true) = false and not(false) = true." - , PrimBOp And ==> "Logical conjunction (and): true /\\ true = true; otherwise x /\\ y = false." - , PrimBOp Or ==> "Logical disjunction (or): false \\/ false = false; otherwise x \\/ y = true." - , PrimBOp Impl ==> "Logical implication (implies): true -> false = false; otherwise x -> y = true." - , PrimBOp Iff ==> "Biconditional (if and only if)." - , PrimBOp Eq ==> "Equality test. x == y is true if x and y are equal." - , PrimBOp Neq ==> "Inequality test. x /= y is true if x and y are unequal." - , PrimBOp Lt ==> "Less-than test. x < y is true if x is less than (but not equal to) y." - , PrimBOp Gt ==> "Greater-than test. x > y is true if x is greater than (but not equal to) y." - , PrimBOp Leq ==> "Less-than-or-equal test. x <= y is true if x is less than or equal to y." - , PrimBOp Geq ==> "Greater-than-or-equal test. x >= y is true if x is greater than or equal to y." - - , PrimBOp CartProd ==> "Cartesian product, i.e. the collection of all pairs. Also works on bags and sets." - , PrimPower ==> "Power set, i.e. the set of all subsets. Also works on bags." - , PrimBOp Union ==> "Union of two sets (or bags)." - , PrimBOp Inter ==> "Intersection of two sets (or bags)." - , PrimBOp Diff ==> "Difference of two sets (or bags)." - ] +primDoc = + M.fromList + [ PrimUOp Neg ==> "Arithmetic negation." + , PrimBOp Add ==> "The sum of two numbers, types, or graphs." + , PrimBOp Sub ==> "The difference of two numbers." + , PrimBOp SSub ==> "The difference of two numbers, with a lower bound of 0." + , PrimBOp Mul ==> "The product of two numbers, types, or graphs." + , PrimBOp Div ==> "Divide two numbers." + , PrimBOp IDiv ==> "The integer quotient of two numbers, rounded down." + , PrimBOp Mod ==> "a mod b is the remainder when a is divided by b." + , PrimBOp Exp ==> "Exponentiation. a ^ b is a raised to the b power." + , PrimUOp Fact ==> "n! computes the factorial of n, that is, 1 * 2 * ... * n." + , PrimFloor ==> "floor(x) is the largest integer which is <= x." + , PrimCeil ==> "ceiling(x) is the smallest integer which is >= x." + , PrimAbs ==> "abs(x) is the absolute value of x. Also written |x|." + , PrimUOp Not ==> "Logical negation: not(true) = false and not(false) = true." + , PrimBOp And ==> "Logical conjunction (and): true /\\ true = true; otherwise x /\\ y = false." + , PrimBOp Or ==> "Logical disjunction (or): false \\/ false = false; otherwise x \\/ y = true." + , PrimBOp Impl ==> "Logical implication (implies): true -> false = false; otherwise x -> y = true." + , PrimBOp Iff ==> "Biconditional (if and only if)." + , PrimBOp Eq ==> "Equality test. x == y is true if x and y are equal." + , PrimBOp Neq ==> "Inequality test. x /= y is true if x and y are unequal." + , PrimBOp Lt ==> "Less-than test. x < y is true if x is less than (but not equal to) y." + , PrimBOp Gt ==> "Greater-than test. x > y is true if x is greater than (but not equal to) y." + , PrimBOp Leq ==> "Less-than-or-equal test. x <= y is true if x is less than or equal to y." + , PrimBOp Geq ==> "Greater-than-or-equal test. x >= y is true if x is greater than or equal to y." + , PrimBOp CartProd ==> "Cartesian product, i.e. the collection of all pairs. Also works on bags and sets." + , PrimPower ==> "Power set, i.e. the set of all subsets. Also works on bags." + , PrimBOp Union ==> "Union of two sets (or bags)." + , PrimBOp Inter ==> "Intersection of two sets (or bags)." + , PrimBOp Diff ==> "Difference of two sets (or bags)." + ] -- | A map from some primitives to their corresponding page in the -- Disco language reference -- (https://disco-lang.readthedocs.io/en/latest/reference/index.html). primReference :: Map Prim String -primReference = M.fromList - [ PrimBOp Add ==> "addition" - , PrimBOp Sub ==> "subtraction" - , PrimBOp SSub ==> "subtraction" - , PrimBOp Mul ==> "multiplication" - , PrimBOp Div ==> "division" - , PrimBOp IDiv ==> "integerdiv" - , PrimBOp Mod ==> "mod" - , PrimBOp Exp ==> "exponentiation" - , PrimUOp Fact ==> "factorial" - , PrimFloor ==> "round" - , PrimCeil ==> "round" - , PrimAbs ==> "abs" - , PrimUOp Not ==> "logic-ops" - , PrimBOp And ==> "logic-ops" - , PrimBOp Or ==> "logic-ops" - , PrimBOp Impl ==> "logic-ops" - , PrimBOp Iff ==> "logic-ops" - , PrimBOp CartProd ==> "cp" - , PrimPower ==> "power" - , PrimBOp Union ==> "set-ops" - , PrimBOp Inter ==> "set-ops" - , PrimBOp Diff ==> "set-ops" - ] +primReference = + M.fromList + [ PrimBOp Add ==> "addition" + , PrimBOp Sub ==> "subtraction" + , PrimBOp SSub ==> "subtraction" + , PrimBOp Mul ==> "multiplication" + , PrimBOp Div ==> "division" + , PrimBOp IDiv ==> "integerdiv" + , PrimBOp Mod ==> "mod" + , PrimBOp Exp ==> "exponentiation" + , PrimUOp Fact ==> "factorial" + , PrimFloor ==> "round" + , PrimCeil ==> "round" + , PrimAbs ==> "abs" + , PrimUOp Not ==> "logic-ops" + , PrimBOp And ==> "logic-ops" + , PrimBOp Or ==> "logic-ops" + , PrimBOp Impl ==> "logic-ops" + , PrimBOp Iff ==> "logic-ops" + , PrimBOp CartProd ==> "cp" + , PrimPower ==> "power" + , PrimBOp Union ==> "set-ops" + , PrimBOp Inter ==> "set-ops" + , PrimBOp Diff ==> "set-ops" + , PrimBOp Eq ==> "compare" + , PrimBOp Neq ==> "compare" + , PrimBOp Lt ==> "compare" + , PrimBOp Gt ==> "compare" + , PrimBOp Leq ==> "compare" + , PrimBOp Geq ==> "compare" + ] otherDoc :: Map String String -otherDoc = M.fromList - [ "N" ==> docN - , "ℕ" ==> docN - , "Nat" ==> docN - , "Natural" ==> docN - , "Z" ==> docZ - , "ℤ" ==> docZ - , "Int" ==> docZ - , "Integer" ==> docZ - , "F" ==> docF - , "𝔽" ==> docF - , "Frac" ==> docF - , "Fractional" ==> docF - , "Q" ==> docQ - , "ℚ" ==> docQ - , "Rational" ==> docQ - , "Bool" ==> docB - , "Boolean" ==> docB - , "Prop" ==> "The type of propositions." - , "Set" ==> "The type of finite sets." - , "|~|" ==> "Absolute value, or the size of a collection." - ] - where - docN = "The type of natural numbers: 0, 1, 2, ..." - docZ = "The type of integers: ..., -2, -1, 0, 1, 2, ..." - docF = "The type of fractional numbers p/q >= 0." - docQ = "The type of rational numbers p/q." - docB = "The type of Booleans (true or false)." +otherDoc = + M.fromList + [ "N" ==> docN + , "ℕ" ==> docN + , "Nat" ==> docN + , "Natural" ==> docN + , "Z" ==> docZ + , "ℤ" ==> docZ + , "Int" ==> docZ + , "Integer" ==> docZ + , "F" ==> docF + , "𝔽" ==> docF + , "Frac" ==> docF + , "Fractional" ==> docF + , "Q" ==> docQ + , "ℚ" ==> docQ + , "Rational" ==> docQ + , "Bool" ==> docB + , "Boolean" ==> docB + , "Unit" ==> "The unit type, i.e. a type with only a single value." + , "Prop" ==> "The type of propositions." + , "Set" ==> "The type of finite sets." + , "|~|" ==> "Absolute value, or the size of a collection." + , "{?" ==> "{? ... ?} is a case expression, for choosing a result based on conditions." + ] + where + docN = "The type of natural numbers: 0, 1, 2, ..." + docZ = "The type of integers: ..., -2, -1, 0, 1, 2, ..." + docF = "The type of fractional numbers p/q >= 0." + docQ = "The type of rational numbers p/q." + docB = "The type of Booleans (true or false)." otherReference :: Map String String -otherReference = M.fromList - [ "N" ==> "natural" - , "ℕ" ==> "natural" - , "Nat" ==> "natural" - , "Natural" ==> "natural" - , "Z" ==> "integer" - , "ℤ" ==> "integer" - , "Int" ==> "integer" - , "Integer" ==> "integer" - , "F" ==> "fraction" - , "𝔽" ==> "fraction" - , "Frac" ==> "fraction" - , "Fractional" ==> "fraction" - , "Q" ==> "rational" - , "ℚ" ==> "rational" - , "Rational" ==> "rational" - , "Bool" ==> "bool" - , "Boolean" ==> "bool" - , "Prop" ==> "prop" - , "Set" ==> "set" - , "|~|" ==> "size" - ] +otherReference = + M.fromList + [ "N" ==> "natural" + , "ℕ" ==> "natural" + , "Nat" ==> "natural" + , "Natural" ==> "natural" + , "Z" ==> "integer" + , "ℤ" ==> "integer" + , "Int" ==> "integer" + , "Integer" ==> "integer" + , "F" ==> "fraction" + , "𝔽" ==> "fraction" + , "Frac" ==> "fraction" + , "Fractional" ==> "fraction" + , "Q" ==> "rational" + , "ℚ" ==> "rational" + , "Rational" ==> "rational" + , "Bool" ==> "bool" + , "Boolean" ==> "bool" + , "Unit" ==> "unit" + , "Prop" ==> "prop" + , "Set" ==> "set" + , "|~|" ==> "size" + , "{?" ==> "case" + ] diff --git a/src/Disco/Effects/Counter.hs b/src/Disco/Effects/Counter.hs --- a/src/Disco/Effects/Counter.hs +++ b/src/Disco/Effects/Counter.hs @@ -1,7 +1,10 @@ -{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Disco.Effects.Counter -- Copyright : disco team and contributors @@ -10,30 +13,26 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- Polysemy effect for integer counter. --- ------------------------------------------------------------------------------ - module Disco.Effects.Counter where -import Polysemy -import Polysemy.State +import Polysemy +import Polysemy.State data Counter m a where - -- | Return the next integer in sequence. - Next :: Counter m Integer + Next :: Counter m Integer makeSem ''Counter -- | Dispatch a counter effect, starting the counter from the given -- Integer. runCounter' :: Integer -> Sem (Counter ': r) a -> Sem r a -runCounter' i - = evalState i - . reinterpret \case +runCounter' i = + evalState i + . reinterpret \case Next -> do n <- get - put (n+1) + put (n + 1) return n -- | Dispatch a counter effect, starting the counter from zero. diff --git a/src/Disco/Effects/Fresh.hs b/src/Disco/Effects/Fresh.hs --- a/src/Disco/Effects/Fresh.hs +++ b/src/Disco/Effects/Fresh.hs @@ -1,8 +1,11 @@ -{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Disco.Effects.Fresh -- Copyright : disco team and contributors @@ -12,50 +15,47 @@ -- -- Polysemy effect for fresh name generation, compatible with the -- unbound-generics library. --- ------------------------------------------------------------------------------ - module Disco.Effects.Fresh where -import Disco.Effects.Counter -import Disco.Names (QName, localName) -import Polysemy -import Polysemy.ConstraintAbsorber -import qualified Unbound.Generics.LocallyNameless as U -import Unbound.Generics.LocallyNameless.Name +import Disco.Effects.Counter +import Disco.Names (QName, localName) +import Polysemy +import Polysemy.ConstraintAbsorber +import qualified Unbound.Generics.LocallyNameless as U +import Unbound.Generics.LocallyNameless.Name -- | Fresh name generation effect, supporting raw generation of fresh -- names, and opening binders with automatic freshening. Simply -- increments a global counter every time 'fresh' is called and -- makes a variable with that numeric suffix. data Fresh m a where - Fresh :: Name x -> Fresh m (Name x) + Fresh :: Name x -> Fresh m (Name x) makeSem ''Fresh -- | Dispatch the fresh name generation effect, starting at a given -- integer. runFresh' :: Integer -> Sem (Fresh ': r) a -> Sem r a -runFresh' i - = runCounter' i - . reinterpret \case +runFresh' i = + runCounter' i + . reinterpret \case Fresh x -> case x of - Fn s _ -> Fn s <$> next - nm@Bn{} -> return nm + Fn s _ -> Fn s <$> next + nm@Bn {} -> return nm - -- Above code copied from - -- https://hackage.haskell.org/package/unbound-generics-0.4.1/docs/src/Unbound.Generics.LocallyNameless.Fresh.html ; - -- see instance Monad m => Fresh (FreshMT m) . +-- Above code copied from +-- https://hackage.haskell.org/package/unbound-generics-0.4.1/docs/src/Unbound.Generics.LocallyNameless.Fresh.html ; +-- see instance Monad m => Fresh (FreshMT m) . - -- It turns out to make things much simpler to reimplement the - -- Fresh effect ourselves in terms of a state effect, since then - -- we can immediately dispatch it. The alternative would be to - -- implement it in terms of (Embed U.FreshM), but then we are - -- stuck with that constraint. Given the constraint-absorbing - -- machinery below, just impementing the 'fresh' effect itself - -- means we can then reuse other things from unbound-generics that - -- depend on a Fresh constraint, such as the 'unbind' function - -- below. +-- It turns out to make things much simpler to reimplement the +-- Fresh effect ourselves in terms of a state effect, since then +-- we can immediately dispatch it. The alternative would be to +-- implement it in terms of (Embed U.FreshM), but then we are +-- stuck with that constraint. Given the constraint-absorbing +-- machinery below, just impementing the 'fresh' effect itself +-- means we can then reuse other things from unbound-generics that +-- depend on a Fresh constraint, such as the 'unbind' function +-- below. -- | Run a computation requiring fresh name generation, beginning with -- 0 for the initial freshly generated name. @@ -92,7 +92,7 @@ absorbFresh = absorbWithSem @U.Fresh @Action (FreshDict fresh) (Sub Dict) {-# INLINEABLE absorbFresh #-} -newtype FreshDict m = FreshDict { fresh_ :: forall x. Name x -> m (Name x) } +newtype FreshDict m = FreshDict {fresh_ :: forall x. Name x -> m (Name x)} -- | Wrapper for a monadic action with phantom type parameter for reflection. -- Locally defined so that the instance we are going to build with reflection @@ -100,8 +100,11 @@ newtype Action m s' a = Action (m a) deriving (Functor, Applicative, Monad) -instance ( Monad m - , Reifies s' (FreshDict m) - ) => U.Fresh (Action m s') where +instance + ( Monad m + , Reifies s' (FreshDict m) + ) => + U.Fresh (Action m s') + where fresh x = Action $ fresh_ (reflect $ Proxy @s') x {-# INLINEABLE fresh #-} diff --git a/src/Disco/Effects/Input.hs b/src/Disco/Effects/Input.hs --- a/src/Disco/Effects/Input.hs +++ b/src/Disco/Effects/Input.hs @@ -1,4 +1,7 @@ ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Disco.Effects.Input -- Copyright : disco team and contributors @@ -7,20 +10,16 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- Utility functions for input effect. --- ------------------------------------------------------------------------------ - -module Disco.Effects.Input - ( module Polysemy.Input - , inputToState - ) - where +module Disco.Effects.Input ( + module Polysemy.Input, + inputToState, +) +where -import Polysemy -import Polysemy.Input -import Polysemy.State +import Polysemy +import Polysemy.Input +import Polysemy.State -- | Run an input effect in terms of an ambient state effect. inputToState :: forall s r a. Member (State s) r => Sem (Input s ': r) a -> Sem r a -inputToState = interpret (\case { Input -> get @s }) - +inputToState = interpret (\case Input -> get @s) diff --git a/src/Disco/Effects/LFresh.hs b/src/Disco/Effects/LFresh.hs --- a/src/Disco/Effects/LFresh.hs +++ b/src/Disco/Effects/LFresh.hs @@ -1,8 +1,11 @@ -{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Disco.Effects.LFresh -- Copyright : disco team and contributors @@ -12,24 +15,21 @@ -- -- Polysemy effect for local fresh name generation, compatible with -- the unbound-generics library. --- ------------------------------------------------------------------------------ - module Disco.Effects.LFresh where -import Data.Set (Set) -import qualified Data.Set as S -import Data.Typeable (Typeable) -import Polysemy -import Polysemy.ConstraintAbsorber -import Polysemy.Reader -import qualified Unbound.Generics.LocallyNameless as U -import Unbound.Generics.LocallyNameless.Name +import Data.Set (Set) +import qualified Data.Set as S +import Data.Typeable (Typeable) +import Polysemy +import Polysemy.ConstraintAbsorber +import Polysemy.Reader +import qualified Unbound.Generics.LocallyNameless as U +import Unbound.Generics.LocallyNameless.Name -- | Local fresh name generation effect. data LFresh m a where - Lfresh :: Typeable a => Name a -> LFresh m (Name a) - Avoid :: [AnyName] -> m a -> LFresh m a + Lfresh :: Typeable a => Name a -> LFresh m (Name a) + Avoid :: [AnyName] -> m a -> LFresh m a GetAvoids :: LFresh m (Set AnyName) makeSem ''LFresh @@ -40,44 +40,48 @@ runLFresh = runReader S.empty . runLFresh' runLFresh' :: Sem (LFresh ': r) a -> Sem (Reader (Set AnyName) ': r) a -runLFresh' - = reinterpretH @_ @(Reader (Set AnyName)) \case - Lfresh nm -> do - let s = name2String nm - used <- ask - pureT $ head (filter (\x -> not (S.member (AnyName x) used)) - (map (makeName s) [0..])) - Avoid names m -> do - m' <- runT m - raise (subsume (runLFresh' (local (S.union (S.fromList names)) m'))) - GetAvoids -> ask >>= pureT +runLFresh' = + reinterpretH @_ @(Reader (Set AnyName)) \case + Lfresh nm -> do + let s = name2String nm + used <- ask + pureT $ + head + ( filter + (\x -> not (S.member (AnyName x) used)) + (map (makeName s) [0 ..]) + ) + Avoid names m -> do + m' <- runT m + raise (subsume (runLFresh' (local (S.union (S.fromList names)) m'))) + GetAvoids -> ask >>= pureT - -- Much of the above code copied from - -- https://hackage.haskell.org/package/unbound-generics-0.4.1/docs/src/Unbound.Generics.LocallyNameless.LFresh.html - -- (see instance Monad m => LFresh (LFreshMT m)) +-- Much of the above code copied from +-- https://hackage.haskell.org/package/unbound-generics-0.4.1/docs/src/Unbound.Generics.LocallyNameless.LFresh.html +-- (see instance Monad m => LFresh (LFreshMT m)) - -- It turns out to make things much simpler to reimplement the - -- LFresh effect ourselves in terms of a reader effect, since then - -- we can immediately dispatch it as above. The alternative would - -- be to implement it in terms of (Final U.LFreshM) (see the - -- commented code at the bottom of this file), but then we are stuck - -- with that constraint. Given the constraint-absorbing machinery - -- below, just impementing the 'LFresh' effect itself means we can - -- then reuse other things from unbound-generics that depend on a - -- Fresh constraint, such as the 'lunbind' function below. +-- It turns out to make things much simpler to reimplement the +-- LFresh effect ourselves in terms of a reader effect, since then +-- we can immediately dispatch it as above. The alternative would +-- be to implement it in terms of (Final U.LFreshM) (see the +-- commented code at the bottom of this file), but then we are stuck +-- with that constraint. Given the constraint-absorbing machinery +-- below, just impementing the 'LFresh' effect itself means we can +-- then reuse other things from unbound-generics that depend on a +-- Fresh constraint, such as the 'lunbind' function below. - -- NOTE: originally, there was a single function runLFresh which - -- called reinterpretH and then immediately dispatched the Reader - -- (Set AnyName) effect. However, since runLFresh is recursive, - -- this means that the recursive calls were running with a - -- completely *separate* Reader effect that started over from the - -- empty set! This meant that LFresh basically never changed any - -- names, leading to all sorts of name clashes and crashes. - -- - -- Instead, we need to organize things as above: runLFresh' is - -- recursive, and keeps the Reader effect (using 'subsume' to squash - -- the duplicated Reader effects together). Then a top-level - -- runLFresh function finally runs the Reader effect. +-- NOTE: originally, there was a single function runLFresh which +-- called reinterpretH and then immediately dispatched the Reader +-- (Set AnyName) effect. However, since runLFresh is recursive, +-- this means that the recursive calls were running with a +-- completely *separate* Reader effect that started over from the +-- empty set! This meant that LFresh basically never changed any +-- names, leading to all sorts of name clashes and crashes. +-- +-- Instead, we need to organize things as above: runLFresh' is +-- recursive, and keeps the Reader effect (using 'subsume' to squash +-- the duplicated Reader effects together). Then a top-level +-- runLFresh function finally runs the Reader effect. -------------------------------------------------- -- Other functions @@ -86,9 +90,11 @@ -- variables, and providing the opened pattern and term to the -- provided continuation. The bound variables are also added to the -- set of in-scope variables within in the continuation. -lunbind - :: (Member LFresh r, U.Alpha p, U.Alpha t) - => U.Bind p t -> ((p,t) -> Sem r c) -> Sem r c +lunbind :: + (Member LFresh r, U.Alpha p, U.Alpha t) => + U.Bind p t -> + ((p, t) -> Sem r c) -> + Sem r c lunbind b k = absorbLFresh (U.lunbind b k) ------------------------------------------------------------ @@ -101,8 +107,8 @@ {-# INLINEABLE absorbLFresh #-} data LFreshDict m = LFreshDict - { lfresh_ :: forall a. Typeable a => Name a -> m (Name a) - , avoid_ :: forall a. [AnyName] -> m a -> m a + { lfresh_ :: forall a. Typeable a => Name a -> m (Name a) + , avoid_ :: forall a. [AnyName] -> m a -> m a , getAvoids_ :: m (Set AnyName) } @@ -112,9 +118,12 @@ newtype Action m s' a = Action (m a) deriving (Functor, Applicative, Monad) -instance ( Monad m - , Reifies s' (LFreshDict m) - ) => U.LFresh (Action m s') where +instance + ( Monad m + , Reifies s' (LFreshDict m) + ) => + U.LFresh (Action m s') + where lfresh x = Action $ lfresh_ (reflect $ Proxy @s') x {-# INLINEABLE lfresh #-} avoid xs (Action m) = Action $ avoid_ (reflect $ Proxy @s') xs m diff --git a/src/Disco/Effects/Random.hs b/src/Disco/Effects/Random.hs --- a/src/Disco/Effects/Random.hs +++ b/src/Disco/Effects/Random.hs @@ -1,4 +1,7 @@ ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Disco.Effects.Random -- Copyright : disco team and contributors @@ -7,22 +10,19 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- Utility functions for random effect. --- ------------------------------------------------------------------------------ - -module Disco.Effects.Random - ( module Polysemy.Random - , runGen - ) - where +module Disco.Effects.Random ( + module Polysemy.Random, + runGen, +) +where -import Polysemy -import Polysemy.Random +import Polysemy +import Polysemy.Random import qualified System.Random.SplitMix as SM -import qualified Test.QuickCheck.Gen as QC +import qualified Test.QuickCheck.Gen as QC import qualified Test.QuickCheck.Random as QCR -import Data.Word (Word64) +import Data.Word (Word64) -- | Run a QuickCheck generator using a 'Random' effect. runGen :: Member Random r => QC.Gen a -> Sem r a diff --git a/src/Disco/Effects/State.hs b/src/Disco/Effects/State.hs --- a/src/Disco/Effects/State.hs +++ b/src/Disco/Effects/State.hs @@ -1,6 +1,9 @@ {-# LANGUAGE BlockArguments #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Disco.Effects.State -- Copyright : disco team and contributors @@ -9,25 +12,24 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- Utility functions for state effect. --- ------------------------------------------------------------------------------ - -module Disco.Effects.State - ( module Polysemy.State - , zoom - , use - ,(%=),(.=)) - where +module Disco.Effects.State ( + module Polysemy.State, + zoom, + use, + (%=), + (.=), +) +where -import Control.Lens (Getter, Lens', view, (%~), (.~)) +import Control.Lens (Getter, Lens', view, (%~), (.~)) -import Polysemy -import Polysemy.State +import Polysemy +import Polysemy.State -- | Use a lens to zoom into a component of a state. zoom :: forall s a r c. Member (State s) r => Lens' s a -> Sem (State a ': r) c -> Sem r c zoom l = interpret \case - Get -> view l <$> get + Get -> view l <$> get Put a -> modify (l .~ a) use :: Member (State s) r => Getter s a -> Sem r a diff --git a/src/Disco/Effects/Store.hs b/src/Disco/Effects/Store.hs --- a/src/Disco/Effects/Store.hs +++ b/src/Disco/Effects/Store.hs @@ -1,7 +1,10 @@ -{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Disco.Effects.Store -- Copyright : disco team and contributors @@ -10,44 +13,40 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- Polysemy effect for a memory store with integer keys. --- ------------------------------------------------------------------------------ - module Disco.Effects.Store where -import qualified Data.IntMap.Lazy as IntMap -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet +import qualified Data.IntMap.Lazy as IntMap +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet -import Disco.Effects.Counter -import Polysemy -import Polysemy.State +import Disco.Effects.Counter +import Polysemy +import Polysemy.State data Store v m a where - - ClearStore :: Store v m () - New :: v -> Store v m Int + ClearStore :: Store v m () + New :: v -> Store v m Int LookupStore :: Int -> Store v m (Maybe v) InsertStore :: Int -> v -> Store v m () - MapStore :: (v -> v) -> Store v m () + MapStore :: (v -> v) -> Store v m () AssocsStore :: Store v m [(Int, v)] - KeepKeys :: IntSet -> Store v m () + KeepKeys :: IntSet -> Store v m () makeSem ''Store -- | Dispatch a store effect. runStore :: forall v r a. Sem (Store v ': r) a -> Sem r a -runStore - = runCounter - . evalState @(IntMap.IntMap v) IntMap.empty - . reinterpret2 \case - ClearStore -> put IntMap.empty - New v -> do +runStore = + runCounter + . evalState @(IntMap.IntMap v) IntMap.empty + . reinterpret2 \case + ClearStore -> put IntMap.empty + New v -> do loc <- fromIntegral <$> next modify $ IntMap.insert loc v return loc - LookupStore k -> gets (IntMap.lookup k) + LookupStore k -> gets (IntMap.lookup k) InsertStore k v -> modify (IntMap.insert k v) - MapStore f -> modify (IntMap.map f) - AssocsStore -> gets IntMap.assocs - KeepKeys ks -> modify (\m -> IntMap.withoutKeys m (IntMap.keysSet m `IntSet.difference` ks)) + MapStore f -> modify (IntMap.map f) + AssocsStore -> gets IntMap.assocs + KeepKeys ks -> modify (\m -> IntMap.withoutKeys m (IntMap.keysSet m `IntSet.difference` ks)) diff --git a/src/Disco/Enumerate.hs b/src/Disco/Enumerate.hs --- a/src/Disco/Enumerate.hs +++ b/src/Disco/Enumerate.hs @@ -1,6 +1,9 @@ {-# LANGUAGE NondecreasingIndentation #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Disco.Enumerate -- Copyright : disco team and contributors @@ -9,41 +12,38 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- Enumerate values inhabiting Disco types. --- ------------------------------------------------------------------------------ +module Disco.Enumerate ( + ValueEnumeration, -module Disco.Enumerate - ( - ValueEnumeration - -- * Base types - , enumVoid - , enumUnit - , enumBool - , enumN - , enumZ - , enumF - , enumQ - , enumC + -- * Base types + enumVoid, + enumUnit, + enumBool, + enumN, + enumZ, + enumF, + enumQ, + enumC, - -- * Containers - , enumSet - -- , enumBag - , enumList + -- * Containers + enumSet, + -- , enumBag + enumList, - -- * Any type - , enumType - , enumTypes + -- * Any type + enumType, + enumTypes, - -- * Lifted functions that return lists - , enumerateType - , enumerateTypes - ) - where + -- * Lifted functions that return lists + enumerateType, + enumerateTypes, +) +where import qualified Data.Enumeration.Invertible as E -import Disco.AST.Generic (Side (..)) -import Disco.Types -import Disco.Value +import Disco.AST.Generic (Side (..)) +import Disco.Types +import Disco.Value type ValueEnumeration = E.IEnumeration Value @@ -58,16 +58,16 @@ -- | Enumerate the values of type @Bool@ as @[false, true]@. enumBool :: ValueEnumeration enumBool = E.mapE toV fromV $ E.finiteList [L, R] - where - toV i = VInj i VUnit - fromV (VInj i VUnit) = i - fromV _ = error "enumBool.fromV: value isn't a bool" + where + toV i = VInj i VUnit + fromV (VInj i VUnit) = i + fromV _ = error "enumBool.fromV: value isn't a bool" -- | Unsafely extract the numeric value of a @Value@ -- (assumed to be a VNum). valToRat :: Value -> Rational valToRat (VNum _ r) = r -valToRat _ = error "valToRat: value isn't a number" +valToRat _ = error "valToRat: value isn't a number" ratToVal :: Rational -> Value ratToVal = VNum mempty @@ -93,9 +93,9 @@ -- | Enumerate all Unicode characters. enumC :: ValueEnumeration enumC = E.mapE toV fromV (E.boundedEnum @Char) - where - toV = ratToVal . fromIntegral . fromEnum - fromV = toEnum . floor . valToRat + where + toV = ratToVal . fromIntegral . fromEnum + fromV = toEnum . floor . valToRat -- | Enumerate all *finite* sets over a certain element type, given an -- enumeration of the elements. If we think of each finite set as a @@ -103,21 +103,21 @@ -- members, the sets are enumerated in order of the binary strings. enumSet :: ValueEnumeration -> ValueEnumeration enumSet e = E.mapE toV fromV (E.finiteSubsetOf e) - where - toV = VBag . map (,1) - fromV (VBag vs) = map fst vs - fromV _ = error "enumSet.fromV: value isn't a set" + where + toV = VBag . map (,1) + fromV (VBag vs) = map fst vs + fromV _ = error "enumSet.fromV: value isn't a set" -- | Enumerate all *finite* lists over a certain element type, given -- an enumeration of the elements. It is very difficult to describe -- the order in which the lists are generated. enumList :: ValueEnumeration -> ValueEnumeration enumList e = E.mapE toV fromV (E.listOf e) - where - toV = foldr VCons VNil - fromV (VCons h t) = h : fromV t - fromV VNil = [] - fromV _ = error "enumList.fromV: value isn't a list" + where + toV = foldr VCons VNil + fromV (VCons h t) = h : fromV t + fromV VNil = [] + fromV _ = error "enumList.fromV: value isn't a list" -- | Enumerate all functions from a finite domain, given enumerations -- for the domain and codomain. @@ -127,60 +127,60 @@ (E.Finite 0, _) -> E.singleton (VFun $ \_ -> error "enumFunction: void function called") (_, E.Finite 0) -> E.void (_, E.Finite 1) -> E.singleton (VFun $ \_ -> E.select ys 0) - _ -> E.mapE toV fromV (E.functionOf xs ys) + _ -> E.mapE toV fromV (E.functionOf xs ys) + where + -- XXX TODO: better error message on functions with an infinite domain - -- XXX TODO: better error message on functions with an infinite domain - where - toV = VFun - fromV (VFun f) = f - fromV _ = error "enumFunction.fromV: value isn't a VFun" + toV = VFun + fromV (VFun f) = f + fromV _ = error "enumFunction.fromV: value isn't a VFun" -- | Enumerate all values of a product type, given enumerations of the -- two component types. Uses a fair interleaving for infinite -- component types. enumProd :: ValueEnumeration -> ValueEnumeration -> ValueEnumeration enumProd xs ys = E.mapE toV fromV $ (E.><) xs ys - where - toV (x, y) = VPair x y - fromV (VPair x y) = (x, y) - fromV _ = error "enumProd.fromV: value isn't a pair" + where + toV (x, y) = VPair x y + fromV (VPair x y) = (x, y) + fromV _ = error "enumProd.fromV: value isn't a pair" -- | Enumerate all values of a sum type, given enumerations of the two -- component types. enumSum :: ValueEnumeration -> ValueEnumeration -> ValueEnumeration enumSum xs ys = E.mapE toV fromV $ (E.<+>) xs ys - where - toV (Left x) = VInj L x - toV (Right y) = VInj R y - fromV (VInj L x) = Left x - fromV (VInj R y) = Right y - fromV _ = error "enumSum.fromV: value isn't a sum" + where + toV (Left x) = VInj L x + toV (Right y) = VInj R y + fromV (VInj L x) = Left x + fromV (VInj R y) = Right y + fromV _ = error "enumSum.fromV: value isn't a sum" -- | Enumerate the values of a given type. enumType :: Type -> ValueEnumeration -enumType TyVoid = enumVoid -enumType TyUnit = enumUnit -enumType TyBool = enumBool -enumType TyN = enumN -enumType TyZ = enumZ -enumType TyF = enumF -enumType TyQ = enumQ -enumType TyC = enumC -enumType (TySet t) = enumSet (enumType t) +enumType TyVoid = enumVoid +enumType TyUnit = enumUnit +enumType TyBool = enumBool +enumType TyN = enumN +enumType TyZ = enumZ +enumType TyF = enumF +enumType TyQ = enumQ +enumType TyC = enumC +enumType (TySet t) = enumSet (enumType t) enumType (TyList t) = enumList (enumType t) -enumType (a :*: b) = enumProd (enumType a) (enumType b) -enumType (a :+: b) = enumSum (enumType a) (enumType b) +enumType (a :*: b) = enumProd (enumType a) (enumType b) +enumType (a :+: b) = enumSum (enumType a) (enumType b) enumType (a :->: b) = enumFunction (enumType a) (enumType b) -enumType ty = error $ "enumType: can't enumerate " ++ show ty +enumType ty = error $ "enumType: can't enumerate " ++ show ty -- | Enumerate a finite product of types. enumTypes :: [Type] -> E.IEnumeration [Value] -enumTypes [] = E.singleton [] -enumTypes (t:ts) = E.mapE toL fromL $ (E.><) (enumType t) (enumTypes ts) - where - toL (x, xs) = x:xs - fromL (x:xs) = (x, xs) - fromL [] = error "enumTypes.fromL: empty list not in enumeration range" +enumTypes [] = E.singleton [] +enumTypes (t : ts) = E.mapE toL fromL $ (E.><) (enumType t) (enumTypes ts) + where + toL (x, xs) = x : xs + fromL (x : xs) = (x, xs) + fromL [] = error "enumTypes.fromL: empty list not in enumeration range" -- | Produce an actual list of the values of a type. enumerateType :: Type -> [Value] diff --git a/src/Disco/Error.hs b/src/Disco/Error.hs --- a/src/Disco/Error.hs +++ b/src/Disco/Error.hs @@ -1,7 +1,10 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Disco.Error -- Copyright : disco team and contributors @@ -11,323 +14,315 @@ -- -- Type for collecting all potential Disco errors at the top level, -- and a type for runtime errors. --- ------------------------------------------------------------------------------ - -module Disco.Error (DiscoError(..), EvalError(..), panic, outputDiscoErrors) where +module Disco.Error (DiscoError (..), EvalError (..), panic, outputDiscoErrors) where -import Prelude hiding ((<>)) +import Prelude hiding ((<>)) -import Text.Megaparsec (ParseErrorBundle, - errorBundlePretty) -import Unbound.Generics.LocallyNameless (Name) +import Text.Megaparsec ( + ParseErrorBundle, + errorBundlePretty, + ) +import Unbound.Generics.LocallyNameless (Name) -import Disco.Effects.LFresh -import Polysemy -import Polysemy.Error -import Polysemy.Output -import Polysemy.Reader +import Disco.Effects.LFresh +import Polysemy +import Polysemy.Error +import Polysemy.Output +import Polysemy.Reader -import Disco.Messages -import Disco.Names (ModuleName, QName) -import Disco.Parser (DiscoParseError) -import Disco.Pretty -import Disco.Typecheck.Solve -import Disco.Typecheck.Util (LocTCError (..), - TCError (..)) -import Disco.Types -import Disco.Types.Qualifiers +import Disco.Messages +import Disco.Names (ModuleName, QName) +import Disco.Parser (DiscoParseError) +import Disco.Pretty +import Disco.Typecheck.Solve +import Disco.Typecheck.Util ( + LocTCError (..), + TCError (..), + ) +import Disco.Types +import Disco.Types.Qualifiers -- | Top-level error type for Disco. data DiscoError where - -- | Module not found. ModuleNotFound :: String -> DiscoError - -- | Cyclic import encountered. CyclicImport :: [ModuleName] -> DiscoError - -- | Error encountered during typechecking. TypeCheckErr :: LocTCError -> DiscoError - -- | Error encountered during parsing. ParseErr :: ParseErrorBundle String DiscoParseError -> DiscoError - -- | Error encountered at runtime. EvalErr :: EvalError -> DiscoError - -- | Something that shouldn't happen; indicates the presence of a -- bug. - Panic :: String -> DiscoError - - deriving Show + Panic :: String -> DiscoError + deriving (Show) -- | Errors that can be generated at runtime. data EvalError where - -- | An unbound name was encountered. - UnboundError :: QName core -> EvalError - + UnboundError :: QName core -> EvalError -- | An unbound name that really shouldn't happen, coming from some -- kind of internal name generation scheme. - UnboundPanic :: Name core -> EvalError - + UnboundPanic :: Name core -> EvalError -- | Division by zero. - DivByZero :: EvalError - + DivByZero :: EvalError -- | Overflow, e.g. (2^66)! - Overflow :: EvalError - + Overflow :: EvalError -- | Non-exhaustive case analysis. - NonExhaustive :: EvalError - + NonExhaustive :: EvalError -- | Infinite loop detected via black hole. - InfiniteLoop :: EvalError - + InfiniteLoop :: EvalError -- | User-generated crash. - Crash :: String -> EvalError + Crash :: String -> EvalError deriving instance Show EvalError panic :: Member (Error DiscoError) r => String -> Sem r a panic = throw . Panic -outputDiscoErrors :: Member (Output Message) r => Sem (Error DiscoError ': r) () -> Sem r () +outputDiscoErrors :: Member (Output (Message ann)) r => Sem (Error DiscoError ': r) () -> Sem r () outputDiscoErrors m = do e <- runError m either (err . pretty') return e instance Pretty DiscoError where pretty = \case - ModuleNotFound m -> "Error: couldn't find a module named '" <> text m <> "'." - CyclicImport ms -> cyclicImportError ms + ModuleNotFound m -> "Error: couldn't find a module named '" <> text m <> "'." + CyclicImport ms -> cyclicImportError ms TypeCheckErr (LocTCError Nothing te) -> prettyTCError te TypeCheckErr (LocTCError (Just n) te) -> - vcat + nest 2 $ vcat [ "While checking " <> pretty' n <> ":" - , nest 2 $ prettyTCError te + , prettyTCError te ] - ParseErr pe -> text (errorBundlePretty pe) - EvalErr ee -> prettyEvalError ee - Panic s -> + ParseErr pe -> text (errorBundlePretty pe) + EvalErr ee -> prettyEvalError ee + Panic s -> vcat [ "Bug! " <> text s , "Please report this as a bug at https://github.com/disco-lang/disco/issues/ ." ] -rtd :: String -> Sem r Doc +rtd :: String -> Sem r (Doc ann) rtd page = "https://disco-lang.readthedocs.io/en/latest/reference/" <> text page <> ".html" -issue :: Int -> Sem r Doc +issue :: Int -> Sem r (Doc ann) issue n = "See https://github.com/disco-lang/disco/issues/" <> text (show n) -cyclicImportError - :: Members '[Reader PA, LFresh] r - => [ModuleName] -> Sem r Doc +cyclicImportError :: + Members '[Reader PA, LFresh] r => + [ModuleName] -> + Sem r (Doc ann) cyclicImportError ms = - vcat + nest 2 $ vcat [ "Error: module imports form a cycle:" - , nest 2 $ intercalate " ->" (map pretty ms) + , intercalate " ->" (map pretty ms) ] -prettyEvalError :: Members '[Reader PA, LFresh] r => EvalError -> Sem r Doc +prettyEvalError :: Members '[Reader PA, LFresh] r => EvalError -> Sem r (Doc ann) prettyEvalError = \case - UnboundPanic x -> - ("Bug! No variable found named" <+> pretty' x <> ".") - $+$ - "Please report this as a bug at https://github.com/disco-lang/disco/issues/ ." - UnboundError x -> "Error: encountered undefined name" <+> pretty' x <> ". Maybe you haven't defined it yet?" - DivByZero -> "Error: division by zero." - Overflow -> "Error: that number would not even fit in the universe!" - NonExhaustive -> "Error: value did not match any of the branches in a case expression." - InfiniteLoop -> "Error: infinite loop detected!" - Crash s -> "User crash:" <+> text s + UnboundPanic x -> + ("Bug! No variable found named" <+> pretty' x <> ".") + $+$ "Please report this as a bug at https://github.com/disco-lang/disco/issues/ ." + UnboundError x -> "Error: encountered undefined name" <+> pretty' x <> ". Maybe you haven't defined it yet?" + DivByZero -> "Error: division by zero." + Overflow -> "Error: that number would not even fit in the universe!" + NonExhaustive -> "Error: value did not match any of the branches in a case expression." + InfiniteLoop -> "Error: infinite loop detected!" + Crash s -> "User crash:" <+> text s -- [X] Step 1: nice error messages, make sure all are tested -- [ ] Step 2: link to wiki/website with more info on errors! -- [ ] Step 3: improve error messages according to notes below -- [ ] Step 4: get it to return multiple error messages -- [ ] Step 5: save parse locations, display with errors -prettyTCError :: Members '[Reader PA, LFresh] r => TCError -> Sem r Doc +prettyTCError :: Members '[Reader PA, LFresh] r => TCError -> Sem r (Doc ann) prettyTCError = \case - -- XXX include some potential misspellings along with Unbound -- see https://github.com/disco-lang/disco/issues/180 - Unbound x -> vcat - [ "Error: there is nothing named" <+> pretty' x <> "." - , rtd "unbound" - ] - - Ambiguous x ms -> vcat - [ "Error: the name" <+> pretty' x <+> "is ambiguous. It could refer to:" - , nest 2 (vcat . map (\m -> pretty' m <> "." <> pretty' x) $ ms) - , rtd "ambiguous" - ] - - NoType x -> vcat - [ "Error: the definition of" <+> pretty' x <+> "must have an accompanying type signature." - , "Try writing something like '" <> pretty' x <+> ": Int' (or whatever the type of" - <+> pretty' x <+> "should be) first." - , rtd "missingtype" - ] - - NotCon c t ty -> vcat - [ "Error: the expression" - , nest 2 $ pretty' t - , "must have both a" <+> conWord c <+> "type and also the incompatible type" - , nest 2 $ pretty' ty <> "." - , rtd "notcon" - ] - - EmptyCase -> vcat - [ "Error: empty case expressions {? ?} are not allowed." - , rtd "empty-case" - ] - - PatternType c pat ty -> vcat - [ "Error: the pattern" - , nest 2 $ pretty' pat - , "is supposed to have type" - , nest 2 $ pretty' ty <> "," - , "but instead it has a" <+> conWord c <+> "type." - , rtd "pattern-type" - ] - - DuplicateDecls x -> vcat - [ "Error: duplicate type signature for" <+> pretty' x <> "." - , rtd "dup-sig" - ] - - DuplicateDefns x -> vcat - [ "Error: duplicate definition for" <+> pretty' x <> "." - , rtd "dup-def" - ] - - DuplicateTyDefns s -> vcat - [ "Error: duplicate definition for type" <+> text s <> "." - , rtd "dup-tydef" - ] - + Unbound x -> + vcat + [ "Error: there is nothing named" <+> pretty' x <> "." + , rtd "unbound" + ] + Ambiguous x ms -> + vcat + [ "Error: the name" <+> pretty' x <+> "is ambiguous. It could refer to:" + , indent 2 . vcat . map (\m -> pretty' m <> "." <> pretty' x) $ ms + , rtd "ambiguous" + ] + NoType x -> + vcat + [ "Error: the definition of" <+> pretty' x <+> "must have an accompanying type signature." + , "Try writing something like '" + <> pretty' x + <+> ": Int' (or whatever the type of" + <+> pretty' x + <+> "should be) first." + , rtd "missingtype" + ] + NotCon c t ty -> + vcat + [ "Error: the expression" + , indent 2 $ pretty' t + , "must have both a" <+> conWord c <+> "type and also the incompatible type" + , indent 2 $ pretty' ty <> "." + , rtd "notcon" + ] + EmptyCase -> + vcat + [ "Error: empty case expressions {? ?} are not allowed." + , rtd "empty-case" + ] + PatternType c pat ty -> + vcat + [ "Error: the pattern" + , indent 2 $ pretty' pat + , "is supposed to have type" + , indent 2 $ pretty' ty <> "," + , "but instead it has a" <+> conWord c <+> "type." + , rtd "pattern-type" + ] + DuplicateDecls x -> + vcat + [ "Error: duplicate type signature for" <+> pretty' x <> "." + , rtd "dup-sig" + ] + DuplicateDefns x -> + vcat + [ "Error: duplicate definition for" <+> pretty' x <> "." + , rtd "dup-def" + ] + DuplicateTyDefns s -> + vcat + [ "Error: duplicate definition for type" <+> text s <> "." + , rtd "dup-tydef" + ] -- XXX include all types involved in the cycle. - CyclicTyDef s -> vcat - [ "Error: cyclic type definition for" <+> text s <> "." - , rtd "cyc-ty" - ] - + CyclicTyDef s -> + vcat + [ "Error: cyclic type definition for" <+> text s <> "." + , rtd "cyc-ty" + ] -- XXX lots more info! & Split into several different errors. - NumPatterns -> vcat - [ "Error: number of arguments does not match." - , rtd "num-args" - ] - + NumPatterns -> + vcat + [ "Error: number of arguments does not match." + , rtd "num-args" + ] + NonlinearPattern p x -> + vcat + [ "Error: pattern" <+> pretty' p <+> "contains duplicate variable" <+> pretty' x <> "." + , rtd "nonlinear" + ] NoSearch ty -> vcat - [ "Error: the type" - , nest 2 $ pretty' ty - , "is not searchable (i.e. it cannot be used in a forall)." - , rtd "no-search" - ] - + [ "Error: the type" + , indent 2 $ pretty' ty + , "is not searchable (i.e. it cannot be used in a forall)." + , rtd "no-search" + ] Unsolvable solveErr -> prettySolveError solveErr - -- XXX maybe include close edit-distance alternatives? - NotTyDef s -> vcat - [ "Error: there is no built-in or user-defined type named '" <> text s <> "'." - , rtd "no-tydef" - ] - - NoTWild -> vcat - [ "Error: wildcards (_) are not allowed in expressions." - , rtd "wildcard-expr" - ] - + NotTyDef s -> + vcat + [ "Error: there is no built-in or user-defined type named '" <> text s <> "'." + , rtd "no-tydef" + ] + NoTWild -> + vcat + [ "Error: wildcards (_) are not allowed in expressions." + , rtd "wildcard-expr" + ] -- XXX say how many are expected, how many there were, what the actual arguments were? -- XXX distinguish between built-in and user-supplied type constructors in the error -- message? - NotEnoughArgs con -> vcat - [ "Error: not enough arguments for the type '" <> pretty' con <> "'." - , rtd "num-args-type" - ] - - TooManyArgs con -> vcat - [ "Error: too many arguments for the type '" <> pretty' con <> "'." - , rtd "num-args-type" - ] - + NotEnoughArgs con -> + vcat + [ "Error: not enough arguments for the type '" <> pretty' con <> "'." + , rtd "num-args-type" + ] + TooManyArgs con -> + vcat + [ "Error: too many arguments for the type '" <> pretty' con <> "'." + , rtd "num-args-type" + ] -- XXX Mention the definition in which it was found, suggest adding the variable -- as a parameter - UnboundTyVar v -> vcat - [ "Error: Unknown type variable '" <> pretty' v <> "'." - , rtd "unbound-tyvar" - ] - - NoPolyRec s ss tys -> vcat - [ "Error: in the definition of " <> text s <> parens (intercalate "," (map text ss)) <> ": recursive occurrences of" <+> text s <+> "may only have type variables as arguments." - , nest 2 ( - text s <> parens (intercalate "," (map pretty' tys)) <+> "does not follow this rule." - ) - , rtd "no-poly-rec" - ] - + UnboundTyVar v -> + vcat + [ "Error: Unknown type variable '" <> pretty' v <> "'." + , rtd "unbound-tyvar" + ] + NoPolyRec s ss tys -> + vcat + [ "Error: in the definition of " <> text s <> parens (intercalate "," (map text ss)) <> ": recursive occurrences of" <+> text s <+> "may only have type variables as arguments." + , indent + 2 + ( text s <> parens (intercalate "," (map pretty' tys)) <+> "does not follow this rule." + ) + , rtd "no-poly-rec" + ] NoError -> empty -conWord :: Con -> Sem r Doc +conWord :: Con -> Sem r (Doc ann) conWord = \case - CArr -> "function" - CProd -> "product" - CSum -> "sum" - CSet -> "set" - CBag -> "bag" - CList -> "list" + CArr -> "function" + CProd -> "pair" + CSum -> "sum" + CSet -> "set" + CBag -> "bag" + CList -> "list" CContainer _ -> "container" - CMap -> "map" - CGraph -> "graph" - CUser s -> text s + CMap -> "map" + CGraph -> "graph" + CUser s -> text s -prettySolveError :: Members '[Reader PA, LFresh] r => SolveError -> Sem r Doc +prettySolveError :: Members '[Reader PA, LFresh] r => SolveError -> Sem r (Doc ann) prettySolveError = \case - -- XXX say which types! - NoWeakUnifier -> vcat - [ "Error: the shape of two types does not match." - , rtd "shape-mismatch" - ] - + NoWeakUnifier -> + vcat + [ "Error: the shape of two types does not match." + , rtd "shape-mismatch" + ] -- XXX say more! XXX HIGHEST PRIORITY! - NoUnify -> vcat - [ "Error: typechecking failed." - , rtd "typecheck-fail" - ] - - UnqualBase q b -> vcat - [ "Error: values of type" <+> pretty' b <+> qualPhrase False q <> "." - , rtd "not-qual" - ] - - Unqual q ty -> vcat - [ "Error: values of type" <+> pretty' ty <+> qualPhrase False q <> "." - , rtd "not-qual" - ] - - QualSkolem q a -> vcat - [ "Error: type variable" <+> pretty' a <+> "represents any type, so we cannot assume values of that type" - , nest 2 (qualPhrase True q) <> "." - , rtd "qual-skolem" - ] + NoUnify -> + vcat + [ "Error: typechecking failed." + , rtd "typecheck-fail" + ] + UnqualBase q b -> + vcat + [ "Error: values of type" <+> pretty' b <+> qualPhrase False q <> "." + , rtd "not-qual" + ] + Unqual q ty -> + vcat + [ "Error: values of type" <+> pretty' ty <+> qualPhrase False q <> "." + , rtd "not-qual" + ] + QualSkolem q a -> + vcat + [ "Error: type variable" <+> pretty' a <+> "represents any type, so we cannot assume values of that type" + , indent 2 (qualPhrase True q) <> "." + , rtd "qual-skolem" + ] -qualPhrase :: Bool -> Qualifier -> Sem r Doc +qualPhrase :: Bool -> Qualifier -> Sem r (Doc ann) qualPhrase b q | q `elem` [QBool, QBasic, QSimple] = "are" <+> (if b then empty else "not") <+> qualAction q | otherwise = "can" <> (if b then empty else "not") <+> "be" <+> qualAction q -qualAction :: Qualifier -> Sem r Doc +qualAction :: Qualifier -> Sem r (Doc ann) qualAction = \case - QNum -> "added and multiplied" - QSub -> "subtracted" - QDiv -> "divided" - QCmp -> "compared" - QEnum -> "enumerated" - QBool -> "boolean" - QBasic -> "basic" + QNum -> "added and multiplied" + QSub -> "subtracted" + QDiv -> "divided" + QCmp -> "compared" + QEnum -> "enumerated" + QBool -> "boolean" + QBasic -> "basic" QSimple -> "simple" - diff --git a/src/Disco/Eval.hs b/src/Disco/Eval.hs --- a/src/Disco/Eval.hs +++ b/src/Disco/Eval.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} ------------------------------------------------------------------------------ -- | -- Module : Disco.Eval -- Copyright : disco team and contributors @@ -11,86 +10,91 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- Top-level evaluation utilities. ------------------------------------------------------------------------------ - -module Disco.Eval - ( - -- * Effects - - EvalEffects - , DiscoEffects - - -- * Top-level info record and associated lenses - - , DiscoConfig, initDiscoConfig, debugMode - , TopInfo - , replModInfo, topEnv, topModMap, lastFile, discoConfig - - -- * Running things - - , runDisco - , runTCM - , inputTopEnv - , parseDiscoModule - , typecheckTop +module Disco.Eval ( + -- * Effects + EvalEffects, + DiscoEffects, - -- * Loading modules + -- * Top-level info record and associated lenses + DiscoConfig, + initDiscoConfig, + debugMode, + TopInfo, + replModInfo, + topEnv, + topModMap, + lastFile, + discoConfig, - , loadDiscoModule - , loadParsedDiscoModule - , loadFile - , addToREPLModule - , setREPLModule - , loadDefsFrom - , loadDef + -- * Running things + runDisco, + runTCM, + inputTopEnv, + parseDiscoModule, + typecheckTop, - ) - where + -- * Loading modules + loadDiscoModule, + loadParsedDiscoModule, + loadFile, + addToREPLModule, + setREPLModule, + loadDefsFrom, + loadDef, +) +where -import Control.Arrow ((&&&)) -import Control.Exception (SomeException, handle) -import Control.Lens (makeLenses, toListOf, view, (%~), - (.~), (<>~), (^.)) -import Control.Monad (unless, void, when) -import Control.Monad.IO.Class (liftIO) -import Data.Bifunctor -import Data.Map (Map) -import qualified Data.Map as M -import qualified Data.Set as S -import Prelude -import System.FilePath ((-<.>)) +import Control.Arrow ((&&&)) +import Control.Exception (SomeException, handle) +import Control.Lens ( + makeLenses, + toListOf, + view, + (%~), + (.~), + (<>~), + (^.), + ) +import Control.Monad (unless, void, when) +import Control.Monad.IO.Class (liftIO) +import Data.Bifunctor +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Set as S +import System.FilePath ((-<.>)) +import Prelude import qualified System.Console.Haskeline as H -import Disco.Effects.Fresh -import Disco.Effects.Input -import Disco.Effects.LFresh -import Disco.Effects.State -import Polysemy -import Polysemy.Embed -import Polysemy.Error -import Polysemy.Fail -import Polysemy.Output -import Polysemy.Random -import Polysemy.Reader +import Disco.Effects.Fresh +import Disco.Effects.Input +import Disco.Effects.LFresh +import Disco.Effects.State +import Polysemy +import Polysemy.Embed +import Polysemy.Error +import Polysemy.Fail +import Polysemy.Output +import Polysemy.Random +import Polysemy.Reader -import Disco.AST.Core -import Disco.AST.Surface -import Disco.Compile (compileDefns) -import Disco.Context as Ctx -import Disco.Error -import Disco.Extensions -import Disco.Interpret.CESK -import Disco.Messages -import Disco.Module -import Disco.Names -import Disco.Parser -import Disco.Pretty hiding ((<>)) -import qualified Disco.Pretty as Pretty -import Disco.Typecheck (checkModule) -import Disco.Typecheck.Util -import Disco.Types -import Disco.Value +import Disco.AST.Core +import Disco.AST.Surface +import Disco.Compile (compileDefns) +import Disco.Context as Ctx +import Disco.Error +import Disco.Extensions +import Disco.Interpret.CESK +import Disco.Messages +import Disco.Module +import Disco.Names +import Disco.Parser +import Disco.Pretty hiding ((<>)) +import qualified Disco.Pretty as Pretty +import Disco.Typecheck (checkModule) +import Disco.Typecheck.Util +import Disco.Types +import Disco.Value ------------------------------------------------------------ -- Configuation options @@ -103,9 +107,10 @@ makeLenses ''DiscoConfig initDiscoConfig :: DiscoConfig -initDiscoConfig = DiscoConfig - { _debugMode = False - } +initDiscoConfig = + DiscoConfig + { _debugMode = False + } ------------------------------------------------------------ -- Top level info record @@ -114,32 +119,29 @@ -- | A record of information about the current top-level environment. data TopInfo = TopInfo { _replModInfo :: ModuleInfo - -- ^ Info about the top-level module collecting stuff entered at - -- the REPL. - - , _topEnv :: Env - -- ^ Top-level environment mapping names to values. Set by - -- 'loadDefs'. - - , _topModMap :: Map ModuleName ModuleInfo - -- ^ Mapping from loaded module names to their 'ModuleInfo' - -- records. - - , _lastFile :: Maybe FilePath - -- ^ The most recent file which was :loaded by the user. - + -- ^ Info about the top-level module collecting stuff entered at + -- the REPL. + , _topEnv :: Env + -- ^ Top-level environment mapping names to values. Set by + -- 'loadDefs'. + , _topModMap :: Map ModuleName ModuleInfo + -- ^ Mapping from loaded module names to their 'ModuleInfo' + -- records. + , _lastFile :: Maybe FilePath + -- ^ The most recent file which was :loaded by the user. , _discoConfig :: DiscoConfig } -- | The initial (empty) record of top-level info. initTopInfo :: DiscoConfig -> TopInfo -initTopInfo cfg = TopInfo - { _replModInfo = emptyModuleInfo - , _topEnv = emptyCtx - , _topModMap = M.empty - , _lastFile = Nothing - , _discoConfig = cfg - } +initTopInfo cfg = + TopInfo + { _replModInfo = emptyModuleInfo + , _topEnv = emptyCtx + , _topModMap = M.empty + , _lastFile = Nothing + , _discoConfig = cfg + } makeLenses ''TopInfo @@ -158,13 +160,14 @@ -- However, just manually implementing it here seems easier. -- | Effects needed at the top level. -type TopEffects = '[Error DiscoError, State TopInfo, Output Message, Embed IO, Final (H.InputT IO)] +type TopEffects = '[Error DiscoError, State TopInfo, Output (Message ()), Embed IO, Final (H.InputT IO)] -- | Effects needed for evaluation. -type EvalEffects = [Error EvalError, Random, LFresh, Output Message, State Mem] - -- XXX write about order. - -- memory, counter etc. should not be reset by errors. +type EvalEffects = [Error EvalError, Random, LFresh, Output (Message ()), State Mem] +-- XXX write about order. +-- memory, counter etc. should not be reset by errors. + -- | All effects needed for the top level + evaluation. type DiscoEffects = AppendEffects EvalEffects TopEffects @@ -188,21 +191,21 @@ . runFinal @(H.InputT IO) . embedToFinal . runEmbedded @_ @(H.InputT IO) liftIO - . runOutputSem (handleMsg msgFilter) -- Handle Output Message via printing to console - . stateToIO (initTopInfo cfg) -- Run State TopInfo via an IORef - . inputToState -- Dispatch Input TopInfo effect via State effect - . runState emptyMem -- Start with empty memory - . outputDiscoErrors -- Output any top-level errors - . runLFresh -- Generate locally fresh names - . runRandomIO -- Generate randomness via IO - . mapError EvalErr -- Embed runtime errors into top-level error type - . failToError Panic -- Turn pattern-match failures into a Panic error - . runReader emptyCtx -- Keep track of current Env + . runOutputSem (handleMsg msgFilter) -- Handle Output Message via printing to console + . stateToIO (initTopInfo cfg) -- Run State TopInfo via an IORef + . inputToState -- Dispatch Input TopInfo effect via State effect + . runState emptyMem -- Start with empty memory + . outputDiscoErrors -- Output any top-level errors + . runLFresh -- Generate locally fresh names + . runRandomIO -- Generate randomness via IO + . mapError EvalErr -- Embed runtime errors into top-level error type + . failToError Panic -- Turn pattern-match failures into a Panic error + . runReader emptyCtx -- Keep track of current Env $ m - where - msgFilter - | cfg ^. debugMode = const True - | otherwise = (/= Debug) . view messageType + where + msgFilter + | cfg ^. debugMode = const True + | otherwise = (/= Debug) . view messageType ------------------------------------------------------------ -- Environment utilities @@ -252,7 +255,7 @@ -- | A variant of 'runTCM' that requires only a 'TCError' instead -- of a 'LocTCError'. -runTCM' :: +runTCM' :: Member (Error DiscoError) r => TyCtx -> TyDefCtx -> @@ -266,12 +269,12 @@ -- | Run a typechecking computation in the context of the top-level -- REPL module, re-throwing a wrapped error if it fails. -typecheckTop - :: Members '[Input TopInfo, Error DiscoError] r - => Sem (Reader TyCtx ': Reader TyDefCtx ': Fresh ': Error TCError ': r) a - -> Sem r a +typecheckTop :: + Members '[Input TopInfo, Error DiscoError] r => + Sem (Reader TyCtx ': Reader TyDefCtx ': Fresh ': Error TCError ': r) a -> + Sem r a typecheckTop tcm = do - tyctx <- inputs (view (replModInfo . miTys)) + tyctx <- inputs (view (replModInfo . miTys)) imptyctx <- inputs (toListOf (replModInfo . miImports . traverse . miTys)) tydefs <- inputs (view (replModInfo . miTydefs)) imptydefs <- inputs (toListOf (replModInfo . miImports . traverse . miTydefs)) @@ -288,9 +291,12 @@ -- -- The 'Resolver' argument specifies where to look for imported -- modules. -loadDiscoModule - :: Members '[State TopInfo, Output Message, Random, State Mem, Error DiscoError, Embed IO] r - => Bool -> Resolver -> FilePath -> Sem r ModuleInfo +loadDiscoModule :: + Members '[State TopInfo, Output (Message ann), Random, State Mem, Error DiscoError, Embed IO] r => + Bool -> + Resolver -> + FilePath -> + Sem r ModuleInfo loadDiscoModule quiet resolver = loadDiscoModule' quiet resolver [] @@ -299,9 +305,13 @@ -- a context that includes the current top-level context (unlike a -- module loaded from disk). Used for e.g. blocks/modules entered -- at the REPL prompt. -loadParsedDiscoModule - :: Members '[State TopInfo, Output Message, Random, State Mem, Error DiscoError, Embed IO] r - => Bool -> Resolver -> ModuleName -> Module -> Sem r ModuleInfo +loadParsedDiscoModule :: + Members '[State TopInfo, Output (Message ann), Random, State Mem, Error DiscoError, Embed IO] r => + Bool -> + Resolver -> + ModuleName -> + Module -> + Sem r ModuleInfo loadParsedDiscoModule quiet resolver = loadParsedDiscoModule' quiet REPL resolver [] @@ -309,15 +319,19 @@ -- Map from module names to 'ModuleInfo' records, to avoid loading -- any imported module more than once. Resolve the module, load and -- parse it, then call 'loadParsedDiscoModule''. -loadDiscoModule' - :: Members '[State TopInfo, Output Message, Random, State Mem, Error DiscoError, Embed IO] r - => Bool -> Resolver -> [ModuleName] -> FilePath - -> Sem r ModuleInfo -loadDiscoModule' quiet resolver inProcess modPath = do - (resolvedPath, prov) <- resolveModule resolver modPath - >>= maybe (throw $ ModuleNotFound modPath) return +loadDiscoModule' :: + Members '[State TopInfo, Output (Message ann), Random, State Mem, Error DiscoError, Embed IO] r => + Bool -> + Resolver -> + [ModuleName] -> + FilePath -> + Sem r ModuleInfo +loadDiscoModule' quiet resolver inProcess modPath = do + (resolvedPath, prov) <- + resolveModule resolver modPath + >>= maybe (throw $ ModuleNotFound modPath) return let name = Named prov modPath - when (name `elem` inProcess) (throw $ CyclicImport (name:inProcess)) + when (name `elem` inProcess) (throw $ CyclicImport (name : inProcess)) modMap <- use @TopInfo topModMap case M.lookup name modMap of Just mi -> return mi @@ -337,34 +351,39 @@ -- it in the context of the top-level type context iff the -- 'LoadingMode' parameter is 'REPL'. Recursively load all its -- imports, then typecheck it. -loadParsedDiscoModule' - :: Members '[State TopInfo, Output Message, Random, State Mem, Error DiscoError, Embed IO] r - => Bool -> LoadingMode -> Resolver -> [ModuleName] -> ModuleName -> Module -> Sem r ModuleInfo +loadParsedDiscoModule' :: + Members '[State TopInfo, Output (Message ann), Random, State Mem, Error DiscoError, Embed IO] r => + Bool -> + LoadingMode -> + Resolver -> + [ModuleName] -> + ModuleName -> + Module -> + Sem r ModuleInfo loadParsedDiscoModule' quiet mode resolver inProcess name cm@(Module _ mns _ _ _) = do - -- Recursively load any modules imported by this one, plus standard -- library modules (unless NoStdLib is enabled), and build a map with the results. mis <- mapM (loadDiscoModule' quiet (withStdlib resolver) inProcess) mns stdmis <- case NoStdLib `S.member` modExts cm of - True -> return [] + True -> return [] False -> mapM (loadDiscoModule' True FromStdlib inProcess) stdLib let modImps = M.fromList (map (view miName &&& id) (mis ++ stdmis)) -- Get context and type definitions from the REPL, in case we are in REPL mode. topImports <- use (replModInfo . miImports) - topTyCtx <- use (replModInfo . miTys) + topTyCtx <- use (replModInfo . miTys) topTyDefns <- use (replModInfo . miTydefs) -- Choose the contexts to use based on mode: if we are loading a -- standalone module, we should start it in an empty context. If we -- are loading something entered at the REPL, we need to include any -- existing top-level REPL context. - let importMap = case mode of { Standalone -> modImps; REPL -> topImports <> modImps } - tyctx = case mode of { Standalone -> emptyCtx ; REPL -> topTyCtx } - tydefns = case mode of { Standalone -> M.empty ; REPL -> topTyDefns } + let importMap = case mode of Standalone -> modImps; REPL -> topImports <> modImps + tyctx = case mode of Standalone -> emptyCtx; REPL -> topTyCtx + tydefns = case mode of Standalone -> M.empty; REPL -> topTyDefns -- Typecheck (and resolve names in) the module. - m <- runTCM tyctx tydefns $ checkModule name importMap cm + m <- runTCM tyctx tydefns $ checkModule name importMap cm -- Evaluate all the module definitions and add them to the topEnv. mapError EvalErr $ loadDefsFrom m @@ -375,27 +394,29 @@ -- | Try loading the contents of a file from the filesystem, emitting -- an error if it's not found. -loadFile :: Members '[Output Message, Embed IO] r => FilePath -> Sem r (Maybe String) +loadFile :: Members '[Output (Message ann), Embed IO] r => FilePath -> Sem r (Maybe String) loadFile file = do res <- liftIO $ handle @SomeException (return . Left) (Right <$> readFile file) case res of - Left _ -> info ("File not found:" <+> text file) >> return Nothing + Left _ -> info ("File not found:" <+> text file) >> return Nothing Right s -> return (Just s) -- | Add things from the given module to the set of currently loaded -- things. -addToREPLModule - :: Members '[Error DiscoError, State TopInfo, Random, State Mem, Output Message] r - => ModuleInfo -> Sem r () +addToREPLModule :: + Members '[Error DiscoError, State TopInfo, Random, State Mem, Output (Message ann)] r => + ModuleInfo -> + Sem r () addToREPLModule mi = modify @TopInfo (replModInfo <>~ mi) -- | Set the given 'ModuleInfo' record as the currently loaded -- module. This also includes updating the top-level state with new -- term definitions, documentation, types, and type definitions. -- Replaces any previously loaded module. -setREPLModule - :: Members '[State TopInfo, Random, Error EvalError, State Mem, Output Message] r - => ModuleInfo -> Sem r () +setREPLModule :: + Members '[State TopInfo, Random, Error EvalError, State Mem, Output (Message ann)] r => + ModuleInfo -> + Sem r () setREPLModule mi = do modify @TopInfo $ replModInfo .~ mi @@ -408,7 +429,6 @@ ModuleInfo -> Sem r () loadDefsFrom mi = do - -- Note that the compiled definitions we get back from compileDefns -- are topologically sorted by mutually recursive group. Each -- definition needs to be evaluated in an environment containing the @@ -418,7 +438,9 @@ loadDef :: Members '[State TopInfo, Random, Error EvalError, State Mem] r => - QName Core -> Core -> Sem r () + QName Core -> + Core -> + Sem r () loadDef x body = do v <- inputToState @TopInfo . inputTopEnv $ eval body modify @TopInfo $ topEnv %~ Ctx.insert x v diff --git a/src/Disco/Extensions.hs b/src/Disco/Extensions.hs --- a/src/Disco/Extensions.hs +++ b/src/Disco/Extensions.hs @@ -6,17 +6,17 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- Optional extensions to the disco language. -module Disco.Extensions - ( Ext (..), - ExtSet, - defaultExts, - allExts, - allExtsList, - addExtension, - ) +module Disco.Extensions ( + Ext (..), + ExtSet, + defaultExts, + allExts, + allExtsList, + addExtension, +) where -import Data.Set (Set) +import Data.Set (Set) import qualified Data.Set as S type ExtSet = Set Ext diff --git a/src/Disco/Interactive/CmdLine.hs b/src/Disco/Interactive/CmdLine.hs --- a/src/Disco/Interactive/CmdLine.hs +++ b/src/Disco/Interactive/CmdLine.hs @@ -1,4 +1,7 @@ ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Disco.Interactive.CmdLine -- Copyright : disco team and contributors @@ -7,50 +10,52 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- Definition of the command-line REPL interface for Disco. --- ------------------------------------------------------------------------------ - -module Disco.Interactive.CmdLine - ( -- * Command-line options record - - DiscoOpts(..) - - -- * optparse-applicative command line parsers - , discoOpts, discoInfo - - -- * main +module Disco.Interactive.CmdLine ( + -- * Command-line options record + DiscoOpts (..), - , discoMain + -- * optparse-applicative command line parsers + discoOpts, + discoInfo, - ) where + -- * main + discoMain, +) where -import Data.Version (showVersion) -import Paths_disco (version) +import Data.Version (showVersion) +import Paths_disco (version) -import Control.Lens hiding (use) -import Control.Monad (unless, when) -import qualified Control.Monad.Catch as CMC -import Control.Monad.IO.Class (MonadIO (..)) -import Data.Foldable (forM_) -import Data.List (isPrefixOf) -import Data.Maybe (isJust) -import System.Exit (exitFailure, - exitSuccess) +import Control.Lens hiding (use) +import Control.Monad (unless, when) +import qualified Control.Monad.Catch as CMC +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Foldable (forM_) +import Data.List (isPrefixOf) +import Data.Maybe (isJust) +import System.Exit ( + exitFailure, + exitSuccess, + ) -import qualified Options.Applicative as O -import System.Console.Haskeline as H +import qualified Options.Applicative as O +import System.Console.Haskeline as H -import Disco.Error -import Disco.Eval -import Disco.Interactive.Commands -import Disco.Messages -import Disco.Module (miExts) -import Disco.Pretty +import Disco.AST.Surface (emptyModule) +import Disco.Error +import Disco.Eval +import Disco.Interactive.Commands +import Disco.Messages +import Disco.Module ( + Resolver (FromStdlib), + miExts, + ) +import Disco.Names (ModuleName (REPLModule)) +import Disco.Pretty -import Disco.Effects.State -import Polysemy -import Polysemy.ConstraintAbsorber.MonadCatch -import Polysemy.Error +import Disco.Effects.State +import Polysemy +import Polysemy.ConstraintAbsorber.MonadCatch +import Polysemy.Error ------------------------------------------------------------ -- Command-line options parser @@ -58,63 +63,75 @@ -- | Command-line options for disco. data DiscoOpts = DiscoOpts - { onlyVersion :: Bool -- ^ Should we just print the version? - , evaluate :: Maybe String -- ^ A single expression to evaluate - , cmdFile :: Maybe String -- ^ Execute the commands in a given file - , checkFile :: Maybe String -- ^ Check a file and then exit - , debugFlag :: Bool + { onlyVersion :: Bool + -- ^ Should we just print the version? + , evaluate :: Maybe String + -- ^ A single expression to evaluate + , cmdFile :: Maybe String + -- ^ Execute the commands in a given file + , checkFile :: Maybe String + -- ^ Check a file and then exit + , debugFlag :: Bool } discoOpts :: O.Parser DiscoOpts -discoOpts = DiscoOpts - <$> O.switch ( - mconcat - [ O.long "version" - , O.short 'v' - , O.help "show current version" - ] - ) - - <*> O.optional ( - O.strOption (mconcat - [ O.long "evaluate" - , O.short 'e' - , O.help "evaluate an expression" - , O.metavar "TERM" - ]) +discoOpts = + DiscoOpts + <$> O.switch + ( mconcat + [ O.long "version" + , O.short 'v' + , O.help "show current version" + ] ) - <*> O.optional ( - O.strOption (mconcat - [ O.long "file" - , O.short 'f' - , O.help "execute the commands in a file" - , O.metavar "FILE" - ]) + <*> O.optional + ( O.strOption + ( mconcat + [ O.long "evaluate" + , O.short 'e' + , O.help "evaluate an expression" + , O.metavar "TERM" + ] + ) ) - <*> O.optional ( - O.strOption (mconcat - [ O.long "check" - , O.help "check a file without starting the interactive REPL" - , O.metavar "FILE" - ]) + <*> O.optional + ( O.strOption + ( mconcat + [ O.long "file" + , O.short 'f' + , O.help "execute the commands in a file" + , O.metavar "FILE" + ] + ) ) - <*> O.switch ( - mconcat - [ O.long "debug" - , O.help "print debugging information" - , O.short 'd' - ] - ) + <*> O.optional + ( O.strOption + ( mconcat + [ O.long "check" + , O.help "check a file without starting the interactive REPL" + , O.metavar "FILE" + ] + ) + ) + <*> O.switch + ( mconcat + [ O.long "debug" + , O.help "print debugging information" + , O.short 'd' + ] + ) discoVersion :: String discoVersion = showVersion version discoInfo :: O.ParserInfo DiscoOpts -discoInfo = O.info (O.helper <*> discoOpts) $ mconcat - [ O.fullDesc - , O.progDesc "Command-line interface for Disco, a programming language for discrete mathematics." - , O.header $ "disco " ++ discoVersion - ] +discoInfo = + O.info (O.helper <*> discoOpts) $ + mconcat + [ O.fullDesc + , O.progDesc "Command-line interface for Disco, a programming language for discrete mathematics." + , O.header $ "disco " ++ discoVersion + ] optsToCfg :: DiscoOpts -> DiscoConfig optsToCfg opts = initDiscoConfig & debugMode .~ debugFlag opts @@ -137,68 +154,70 @@ let batch = any isJust [evaluate opts, cmdFile opts, checkFile opts] unless batch $ putStr banner runDisco (optsToCfg opts) $ do + -- Load an empty module just to force standard libraries to be loaded first + _ <- loadParsedDiscoModule True FromStdlib REPLModule emptyModule + case checkFile opts of Just file -> do res <- handleLoad file liftIO $ if res then exitSuccess else exitFailure - Nothing -> return () + Nothing -> return () case cmdFile opts of Just file -> do mcmds <- loadFile file case mcmds of - Nothing -> return () + Nothing -> return () Just cmds -> mapM_ handleCMD (lines cmds) - Nothing -> return () + Nothing -> return () forM_ (evaluate opts) handleCMD - unless batch loop - - where - - -- These types used to involve InputT Disco, but we now use Final - -- (InputT IO) in the list of effects. see - -- https://github.com/polysemy-research/polysemy/issues/395 for - -- inspiration. + unless batch $ do + loop + where + -- These types used to involve InputT Disco, but we now use Final + -- (InputT IO) in the list of effects. see + -- https://github.com/polysemy-research/polysemy/issues/395 for + -- inspiration. - ctrlC :: MonadIO m => m a -> SomeException -> m a - ctrlC act e = do - liftIO $ print e - act + ctrlC :: MonadIO m => m a -> SomeException -> m a + ctrlC act e = do + liftIO $ print e + act - withCtrlC :: (MonadIO m, CMC.MonadCatch m) => m a -> m a -> m a - withCtrlC resume act = CMC.catch act (ctrlC resume) + withCtrlC :: (MonadIO m, CMC.MonadCatch m) => m a -> m a -> m a + withCtrlC resume act = CMC.catch act (ctrlC resume) - loop :: Members DiscoEffects r => Sem r () - loop = do - minput <- embedFinal $ withCtrlC (return $ Just "") (getInputLine "Disco> ") - case minput of - Nothing -> return () - Just input - | ":q" `isPrefixOf` input && input `isPrefixOf` ":quit" -> do - liftIO $ putStrLn "Goodbye!" - return () - | ":{" `isPrefixOf` input -> do - multiLineLoop [] - loop - | otherwise -> do - mapError @_ @DiscoError (Panic . show) $ - absorbMonadCatch $ + loop :: Members DiscoEffects r => Sem r () + loop = do + minput <- embedFinal $ withCtrlC (return $ Just "") (getInputLine "Disco> ") + case minput of + Nothing -> return () + Just input + | ":q" `isPrefixOf` input && input `isPrefixOf` ":quit" -> do + liftIO $ putStrLn "Goodbye!" + return () + | ":{" `isPrefixOf` input -> do + multiLineLoop [] + loop + | otherwise -> do + mapError @_ @DiscoError (Panic . show) $ + absorbMonadCatch $ withCtrlC (return ()) $ - handleCMD input - loop + handleCMD input + loop - multiLineLoop :: Members DiscoEffects r => [String] -> Sem r () - multiLineLoop ls = do - minput <- embedFinal $ withCtrlC (return Nothing) (getInputLine "Disco| ") - case minput of - Nothing -> return () - Just input - | ":}" `isPrefixOf` input -> do - mapError @_ @DiscoError (Panic . show) $ - absorbMonadCatch $ + multiLineLoop :: Members DiscoEffects r => [String] -> Sem r () + multiLineLoop ls = do + minput <- embedFinal $ withCtrlC (return Nothing) (getInputLine "Disco| ") + case minput of + Nothing -> return () + Just input + | ":}" `isPrefixOf` input -> do + mapError @_ @DiscoError (Panic . show) $ + absorbMonadCatch $ withCtrlC (return ()) $ - handleCMD (unlines (reverse ls)) - | otherwise -> do - multiLineLoop (input:ls) + handleCMD (unlines (reverse ls)) + | otherwise -> do + multiLineLoop (input : ls) -- | Parse and run the command corresponding to some REPL input. handleCMD :: Members DiscoEffects r => String -> Sem r () @@ -206,7 +225,8 @@ handleCMD s = do exts <- use @TopInfo (replModInfo . miExts) case parseLine discoCommands exts s of - Left m -> info (text m) + Left m -> info (text m) Right l -> catch @DiscoError (dispatch discoCommands l) (info . pretty') - -- The above has to be catch, not outputErrors, because - -- the latter won't resume afterwards. + +-- The above has to be catch, not outputErrors, because +-- the latter won't resume afterwards. diff --git a/src/Disco/Interactive/Commands.hs b/src/Disco/Interactive/Commands.hs --- a/src/Disco/Interactive/Commands.hs +++ b/src/Disco/Interactive/Commands.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE StandaloneDeriving #-} ------------------------------------------------------------------------------ -- | -- Module : Disco.Interactive.Commands -- Copyright : disco team and contributors @@ -12,68 +11,86 @@ -- -- Defining and dispatching all commands/functionality available at -- the REPL prompt. ------------------------------------------------------------------------------ - -module Disco.Interactive.Commands - ( dispatch, - discoCommands, - handleLoad, - loadFile, - parseLine - ) where +module Disco.Interactive.Commands ( + dispatch, + discoCommands, + handleLoad, + loadFile, + parseLine, +) where -import Control.Arrow ((&&&)) -import Control.Lens (to, view, (%~), (.~), (?~), - (^.)) -import Control.Monad.Except -import Data.Char (isSpace) -import Data.Coerce -import Data.List (find, isPrefixOf, sortBy) -import Data.Map ((!)) -import qualified Data.Map as M -import Data.Typeable -import Prelude as P -import System.FilePath (splitFileName) +import Control.Arrow ((&&&)) +import Control.Lens ( + to, + view, + (%~), + (.~), + (?~), + (^.), + ) +import Control.Monad.Except +import Data.Char (isSpace) +import Data.Coerce +import Data.List (find, isPrefixOf, sortBy) +import Data.Map ((!)) +import qualified Data.Map as M +import Data.Typeable +import System.FilePath (splitFileName) +import Prelude as P -import Text.Megaparsec hiding (State, runParser) -import qualified Text.Megaparsec.Char as C -import Unbound.Generics.LocallyNameless (Name, name2String, - string2Name) +import Text.Megaparsec hiding (State, runParser) +import qualified Text.Megaparsec.Char as C +import Unbound.Generics.LocallyNameless ( + Name, + name2String, + string2Name, + ) -import Disco.Effects.Input -import Disco.Effects.LFresh -import Disco.Effects.State -import Polysemy -import Polysemy.Error hiding (try) -import Polysemy.Output -import Polysemy.Reader +import Disco.Effects.Input +import Disco.Effects.LFresh +import Disco.Effects.State +import Polysemy +import Polysemy.Error hiding (try) +import Polysemy.Output +import Polysemy.Reader -import Data.Maybe (mapMaybe, maybeToList) -import Disco.AST.Surface -import Disco.AST.Typed -import Disco.Compile -import Disco.Context as Ctx -import Disco.Desugar -import Disco.Doc -import Disco.Error -import Disco.Eval -import Disco.Extensions -import Disco.Interpret.CESK -import Disco.Messages -import Disco.Module -import Disco.Names -import Disco.Parser (Parser, ident, reservedOp, - runParser, sc, symbol, term, - wholeModule, withExts) -import Disco.Pretty hiding (empty, (<>)) -import qualified Disco.Pretty as Pretty -import Disco.Syntax.Operators -import Disco.Syntax.Prims (Prim (PrimBOp, PrimUOp), - toPrim) -import Disco.Typecheck -import Disco.Typecheck.Erase -import Disco.Types (pattern TyString, toPolyType) -import Disco.Value +import Data.Maybe (mapMaybe, maybeToList) +import Disco.AST.Surface +import Disco.AST.Typed +import Disco.Compile +import Disco.Context as Ctx +import Disco.Desugar +import Disco.Doc +import Disco.Error +import Disco.Eval +import Disco.Extensions +import Disco.Interpret.CESK +import Disco.Messages +import Disco.Module +import Disco.Names +import Disco.Parser ( + Parser, + ident, + reservedOp, + runParser, + sc, + symbol, + term, + wholeModule, + withExts, + ) +import Disco.Pretty hiding (empty, (<>)) +import qualified Disco.Pretty as PP +import Disco.Property (prettyTestResult) +import Disco.Syntax.Operators +import Disco.Syntax.Prims ( + Prim (PrimBOp, PrimUOp), + toPrim, + ) +import Disco.Typecheck +import Disco.Typecheck.Erase +import Disco.Types (toPolyType, pattern TyString) +import Disco.Value ------------------------------------------------------------ -- REPL expression type @@ -82,24 +99,24 @@ -- | Data type to represent things typed at the Disco REPL. Each -- constructor has a singleton type to facilitate dispatch. data REPLExpr :: CmdTag -> * where - TypeCheck :: Term -> REPLExpr 'CTypeCheck -- Typecheck a term - Eval :: Module -> REPLExpr 'CEval -- Evaluate a block - TestProp :: Term -> REPLExpr 'CTestProp -- Run a property test - ShowDefn :: Name Term -> REPLExpr 'CShowDefn -- Show a variable's definition - Parse :: Term -> REPLExpr 'CParse -- Show the parsed AST - Pretty :: Term -> REPLExpr 'CPretty -- Pretty-print a term - Print :: Term -> REPLExpr 'CPrint -- Print a string - Ann :: Term -> REPLExpr 'CAnn -- Show type-annotated term - Desugar :: Term -> REPLExpr 'CDesugar -- Show a desugared term - Compile :: Term -> REPLExpr 'CCompile -- Show a compiled term - Load :: FilePath -> REPLExpr 'CLoad -- Load a file. - Reload :: REPLExpr 'CReload -- Reloads the most recently - -- loaded file. - Doc :: DocInput -> REPLExpr 'CDoc -- Show documentation. - Nop :: REPLExpr 'CNop -- No-op, e.g. if the user - -- just enters a comment - Help :: REPLExpr 'CHelp -- Show help - Names :: REPLExpr 'CNames -- Show bound names + TypeCheck :: Term -> REPLExpr 'CTypeCheck -- Typecheck a term + Eval :: Module -> REPLExpr 'CEval -- Evaluate a block + TestProp :: Term -> REPLExpr 'CTestProp -- Run a property test + ShowDefn :: Name Term -> REPLExpr 'CShowDefn -- Show a variable's definition + Parse :: Term -> REPLExpr 'CParse -- Show the parsed AST + Pretty :: Term -> REPLExpr 'CPretty -- Pretty-print a term + Print :: Term -> REPLExpr 'CPrint -- Print a string + Ann :: Term -> REPLExpr 'CAnn -- Show type-annotated term + Desugar :: Term -> REPLExpr 'CDesugar -- Show a desugared term + Compile :: Term -> REPLExpr 'CCompile -- Show a compiled term + Load :: FilePath -> REPLExpr 'CLoad -- Load a file. + Reload :: REPLExpr 'CReload -- Reloads the most recently + -- loaded file. + Doc :: DocInput -> REPLExpr 'CDoc -- Show documentation. + Nop :: REPLExpr 'CNop -- No-op, e.g. if the user + -- just enters a comment + Help :: REPLExpr 'CHelp -- Show help + Names :: REPLExpr 'CNames -- Show bound names deriving instance Show (REPLExpr c) @@ -152,23 +169,23 @@ -- | Data type to represent all the information about a single REPL -- command. data REPLCommand (c :: CmdTag) = REPLCommand - { -- | Name of the command - name :: String, - -- | Help text showing how to use the command, e.g. ":ann " - helpcmd :: String, - -- | Short free-form text explaining the command. - -- We could also consider adding long help text as well. - shortHelp :: String, - -- | Is the command for users or devs? - category :: REPLCommandCategory, - -- | Is it a built-in command or colon command? - cmdtype :: REPLCommandType, - -- | The action to execute, - -- given the input to the - -- command. - action :: REPLExpr c -> (forall r. Members DiscoEffects r => Sem r ()), - -- | Parser for the command argument(s). - parser :: Parser (REPLExpr c) + { name :: String + -- ^ Name of the command + , helpcmd :: String + -- ^ Help text showing how to use the command, e.g. ":ann " + , shortHelp :: String + -- ^ Short free-form text explaining the command. + -- We could also consider adding long help text as well. + , category :: REPLCommandCategory + -- ^ Is the command for users or devs? + , cmdtype :: REPLCommandType + -- ^ Is it a built-in command or colon command? + , action :: REPLExpr c -> (forall r. Members DiscoEffects r => Sem r ()) + -- ^ The action to execute, + -- given the input to the + -- command. + , parser :: Parser (REPLExpr c) + -- ^ Parser for the command argument(s). } -- | An existential wrapper around any REPL command info record. @@ -200,22 +217,22 @@ -- to the first matching command. discoCommands :: REPLCommands discoCommands = - [ SomeCmd annCmd, - SomeCmd compileCmd, - SomeCmd desugarCmd, - SomeCmd docCmd, - SomeCmd evalCmd, - SomeCmd helpCmd, - SomeCmd loadCmd, - SomeCmd namesCmd, - SomeCmd nopCmd, - SomeCmd parseCmd, - SomeCmd prettyCmd, - SomeCmd printCmd, - SomeCmd reloadCmd, - SomeCmd showDefnCmd, - SomeCmd typeCheckCmd, - SomeCmd testPropCmd + [ SomeCmd annCmd + , SomeCmd compileCmd + , SomeCmd desugarCmd + , SomeCmd docCmd + , SomeCmd evalCmd + , SomeCmd helpCmd + , SomeCmd loadCmd + , SomeCmd namesCmd + , SomeCmd nopCmd + , SomeCmd parseCmd + , SomeCmd prettyCmd + , SomeCmd printCmd + , SomeCmd reloadCmd + , SomeCmd showDefnCmd + , SomeCmd typeCheckCmd + , SomeCmd testPropCmd ] ------------------------------------------------------------ @@ -236,12 +253,12 @@ -- colon, return a parser for its arguments. parseCommandArgs :: REPLCommands -> String -> Parser SomeREPLExpr parseCommandArgs allCommands cmd = maybe badCmd snd $ find ((cmd `isPrefixOf`) . fst) parsers - where - badCmd = fail $ "Command \":" ++ cmd ++ "\" is unrecognized." + where + badCmd = fail $ "Command \":" ++ cmd ++ "\" is unrecognized." - parsers = - map (\(SomeCmd rc) -> (name rc, SomeREPL <$> parser rc)) $ - byCmdType ColonCmd allCommands + parsers = + map (\(SomeCmd rc) -> (name rc, SomeREPL <$> parser rc)) $ + byCmdType ColonCmd allCommands -- | Parse a file name. fileParser :: Parser FilePath @@ -259,7 +276,7 @@ parseLine :: REPLCommands -> ExtSet -> String -> Either String SomeREPLExpr parseLine allCommands exts s = case runParser (withExts exts (lineParser allCommands)) "" s of - Left e -> Left $ errorBundlePretty e + Left e -> Left $ errorBundlePretty e Right l -> Right l -------------------------------------------------------------------------------- @@ -272,17 +289,17 @@ annCmd :: REPLCommand 'CAnn annCmd = REPLCommand - { name = "ann", - helpcmd = ":ann", - shortHelp = "Show type-annotated typechecked term", - category = Dev, - cmdtype = ColonCmd, - action = \x -> inputToState @TopInfo . handleAnn $ x, - parser = Ann <$> term + { name = "ann" + , helpcmd = ":ann" + , shortHelp = "Show type-annotated typechecked term" + , category = Dev + , cmdtype = ColonCmd + , action = inputToState @TopInfo . handleAnn + , parser = Ann <$> term } handleAnn :: - Members '[Error DiscoError, Input TopInfo, Output Message] r => + Members '[Error DiscoError, Input TopInfo, Output (Message ())] r => REPLExpr 'CAnn -> Sem r () handleAnn (Ann t) = do @@ -295,17 +312,17 @@ compileCmd :: REPLCommand 'CCompile compileCmd = REPLCommand - { name = "compile", - helpcmd = ":compile", - shortHelp = "Show a compiled term", - category = Dev, - cmdtype = ColonCmd, - action = \x -> inputToState @TopInfo . handleCompile $ x, - parser = Compile <$> term + { name = "compile" + , helpcmd = ":compile" + , shortHelp = "Show a compiled term" + , category = Dev + , cmdtype = ColonCmd + , action = inputToState @TopInfo . handleCompile + , parser = Compile <$> term } handleCompile :: - Members '[Error DiscoError, Input TopInfo, Output Message] r => + Members '[Error DiscoError, Input TopInfo, Output (Message ())] r => REPLExpr 'CCompile -> Sem r () handleCompile (Compile t) = do @@ -318,17 +335,17 @@ desugarCmd :: REPLCommand 'CDesugar desugarCmd = REPLCommand - { name = "desugar", - helpcmd = ":desugar", - shortHelp = "Show a desugared term", - category = Dev, - cmdtype = ColonCmd, - action = \x -> inputToState @TopInfo . handleDesugar $ x, - parser = Desugar <$> term + { name = "desugar" + , helpcmd = ":desugar" + , shortHelp = "Show a desugared term" + , category = Dev + , cmdtype = ColonCmd + , action = inputToState @TopInfo . handleDesugar + , parser = Desugar <$> term } handleDesugar :: - Members '[Error DiscoError, Input TopInfo, LFresh, Output Message] r => + Members '[Error DiscoError, Input TopInfo, LFresh, Output (Message ())] r => REPLExpr 'CDesugar -> Sem r () handleDesugar (Desugar t) = do @@ -341,50 +358,64 @@ docCmd :: REPLCommand 'CDoc docCmd = REPLCommand - { name = "doc", - helpcmd = ":doc ", - shortHelp = "Show documentation", - category = User, - cmdtype = ColonCmd, - action = \x -> inputToState @TopInfo . handleDoc $ x, - parser = Doc <$> parseDoc + { name = "doc" + , helpcmd = ":doc " + , shortHelp = "Show documentation" + , category = User + , cmdtype = ColonCmd + , action = inputToState @TopInfo . handleDoc + , parser = Doc <$> parseDoc } --- XXX +-- An input to the :doc command can be either a term, a primitive +-- operator, or something else. data DocInput = DocTerm Term | DocPrim Prim | DocOther String deriving (Show) parseDoc :: Parser DocInput parseDoc = - (DocTerm <$> try term) - <|> (DocPrim <$> try (parseNakedOpPrim "operator")) - <|> (DocOther <$> (sc *> many (anySingleBut ' '))) + (DocTerm <$> try term) + <|> (DocPrim <$> try (parseNakedOpPrim "operator")) + <|> (DocOther <$> (sc *> many (anySingleBut ' '))) handleDoc :: - Members '[Error DiscoError, Input TopInfo, LFresh, Output Message] r => + Members '[Error DiscoError, Input TopInfo, LFresh, Output (Message ())] r => REPLExpr 'CDoc -> Sem r () handleDoc (Doc (DocTerm (TBool _))) = handleDocBool +handleDoc (Doc (DocTerm TUnit)) = handleDocUnit +handleDoc (Doc (DocTerm TWild)) = handleDocWild handleDoc (Doc (DocTerm (TPrim p))) = handleDocPrim p -handleDoc (Doc (DocTerm (TVar x))) = handleDocVar x -handleDoc (Doc (DocTerm _)) = +handleDoc (Doc (DocTerm (TVar x))) = handleDocVar x +handleDoc (Doc (DocTerm _)) = err "Can't display documentation for an expression. Try asking about a function, operator, or type name." -handleDoc (Doc (DocPrim p)) = handleDocPrim p -handleDoc (Doc (DocOther s)) = handleDocOther s +handleDoc (Doc (DocPrim p)) = handleDocPrim p +handleDoc (Doc (DocOther s)) = handleDocOther s -handleDocBool :: Members '[Output Message] r => Sem r () +handleDocBool :: Members '[Output (Message ())] r => Sem r () handleDocBool = info $ "true and false (also written True and False) are the two possible values of type Boolean." - $+$ - mkReference "bool" + $+$ mkReference "bool" +handleDocUnit :: Members '[Output (Message ())] r => Sem r () +handleDocUnit = + info $ + "The unit value, i.e. the single value of type Unit." + $+$ mkReference "unit" + +handleDocWild :: Members '[Output (Message ())] r => Sem r () +handleDocWild = + info $ + "A wildcard pattern." + $+$ mkReference "wild-pattern" + handleDocVar :: - Members '[Error DiscoError, Input TopInfo, LFresh, Output Message] r => + Members '[Error DiscoError, Input TopInfo, LFresh, Output (Message ())] r => Name Term -> Sem r () handleDocVar x = do - replCtx <- inputs @TopInfo (view (replModInfo . miTys)) + replCtx <- inputs @TopInfo (view (replModInfo . miTys)) replTydefs <- inputs @TopInfo (view (replModInfo . miTydefs)) replDocs <- inputs @TopInfo (view (replModInfo . miDocs)) @@ -402,103 +433,119 @@ ([], Nothing) -> -- Maybe the variable name entered by the user is actually a prim. case toPrim (name2String x) of - (prim:_) -> handleDocPrim prim - _ -> err $ "No documentation found for '" <> pretty' x <> "'." + (prim : _) -> handleDocPrim prim + _ -> err $ "No documentation found for '" <> pretty' x <> "'." (binds, def) -> mapM_ (showDoc docs) (map Left binds ++ map Right (maybeToList def)) - - where - showDoc docMap (Left (qn, ty)) = info $ + where + showDoc docMap (Left (qn, ty)) = + info $ hsep [pretty' x, ":", pretty' ty] - $+$ - case Ctx.lookup' qn docMap of - Just (DocString ss : _) -> vcat (text "" : map text ss ++ [text ""]) - _ -> Pretty.empty - showDoc docMap (Right tdBody) = info $ + $+$ case Ctx.lookup' qn docMap of + Just (DocString ss : _) -> vcat (text "" : map text ss ++ [text ""]) + _ -> PP.empty + showDoc docMap (Right tdBody) = + info $ pretty' (name2String x, tdBody) - $+$ - case Ctx.lookupAll' x docMap of - ((_, DocString ss : _) : _) -> vcat (text "" : map text ss ++ [text ""]) - _ -> Pretty.empty + $+$ case Ctx.lookupAll' x docMap of + ((_, DocString ss : _) : _) -> vcat (text "" : map text ss ++ [text ""]) + _ -> PP.empty handleDocPrim :: - Members '[Error DiscoError, Input TopInfo, LFresh, Output Message] r => + Members '[Error DiscoError, Input TopInfo, LFresh, Output (Message ())] r => Prim -> Sem r () handleDocPrim prim = do handleTypeCheck (TypeCheck (TPrim prim)) - info $ vcat - [ case prim of - PrimUOp u -> describeAlts (f == Post) (f == Pre) syns - where + info + . vcat + $ ( case prim of + PrimUOp u -> describeAlts (f == Post) (f == Pre) syns + where OpInfo (UOpF f _) syns _ = uopMap ! u - PrimBOp b -> describeAlts True True (opSyns $ bopMap ! b) - _ -> Pretty.empty - , case prim of - PrimUOp u -> describePrec (uPrec u) - PrimBOp b -> describePrec (bPrec b) <> describeFixity (assoc b) - _ -> Pretty.empty - ] + PrimBOp b -> describeAlts True True (opSyns $ bopMap ! b) + _ -> [] + ) + ++ ( case prim of + PrimUOp u -> [describePrec (uPrec u)] + PrimBOp b -> [describePrec (bPrec b) <> describeFixity (assoc b)] + _ -> [] + ) case (M.lookup prim primDoc, M.lookup prim primReference) of (Nothing, Nothing) -> return () - (Nothing, Just p) -> info $ mkReference p - (Just d, mp) -> - info $ "" $+$ text d $+$ "" $+$ maybe Pretty.empty (\p -> mkReference p $+$ "") mp - where - describePrec p = "precedence level" <+> text (show p) - describeFixity In = Pretty.empty - describeFixity InL = ", left associative" - describeFixity InR = ", right associative" - describeAlts _ _ [] = Pretty.empty - describeAlts _ _ [_] = Pretty.empty - describeAlts pre post (_:alts) = "Alternative syntax:" <+> intercalate "," (map showOp alts) - where - showOp op = hcat - [ if pre then "~" else Pretty.empty - , text op - , if post then "~" else Pretty.empty] - + (Nothing, Just p) -> info $ mkReference p + (Just d, mp) -> + info $ + vcat + [ PP.empty + , text d + , PP.empty + , maybe PP.empty (\p -> vcat [mkReference p, PP.empty]) mp + ] + where + describePrec p = "precedence level" <+> text (show p) + describeFixity In = PP.empty + describeFixity InL = ", left associative" + describeFixity InR = ", right associative" + describeAlts _ _ [] = [] + describeAlts _ _ [_] = [] + describeAlts pre post (_ : alts) = ["Alternative syntax:" <+> intercalate "," (map showOp alts)] + where + showOp op = + hcat + [ if pre then "~" else PP.empty + , text op + , if post then "~" else PP.empty + ] -mkReference :: String -> Sem r Doc +mkReference :: String -> Sem r (Doc ann) mkReference p = "https://disco-lang.readthedocs.io/en/latest/reference/" <> text p <> ".html" handleDocOther :: - Members '[Error DiscoError, Input TopInfo, LFresh, Output Message] r => + Members '[Error DiscoError, Input TopInfo, LFresh, Output (Message ())] r => String -> Sem r () handleDocOther s = case (M.lookup s otherDoc, M.lookup s otherReference) of (Nothing, Nothing) -> info $ "No documentation found for '" <> text s <> "'." - (Nothing, Just p) -> info $ mkReference p - (Just d, mp) -> - info $ text d $+$ "" $+$ maybe Pretty.empty (\p -> mkReference p $+$ "") mp + (Nothing, Just p) -> info $ mkReference p + (Just d, mp) -> + info $ + vcat + [ text d + , PP.empty + , maybe PP.empty (\p -> vcat [mkReference p, PP.empty]) mp + ] ------------------------------------------------------------ -- eval evalCmd :: REPLCommand 'CEval -evalCmd = REPLCommand - { name = "eval" - , helpcmd = "" - , shortHelp = "Evaluate a block of code" - , category = User - , cmdtype = BuiltIn - , action = \x -> handleEval x - , parser = Eval <$> wholeModule REPL - } +evalCmd = + REPLCommand + { name = "eval" + , helpcmd = "" + , shortHelp = "Evaluate a block of code" + , category = User + , cmdtype = BuiltIn + , action = handleEval + , parser = Eval <$> wholeModule REPL + } -handleEval - :: Members (Error DiscoError ': State TopInfo ': Output Message ': Embed IO ': EvalEffects) r - => REPLExpr 'CEval -> Sem r () +handleEval :: + Members (Error DiscoError ': State TopInfo ': Output (Message ()) ': Embed IO ': EvalEffects) r => + REPLExpr 'CEval -> + Sem r () handleEval (Eval m) = do mi <- inputToState @TopInfo $ loadParsedDiscoModule False FromCwdOrStdlib REPLModule m addToREPLModule mi forM_ (mi ^. miTerms) (mapError EvalErr . evalTerm True . fst) - -- garbageCollect? +-- garbageCollect? + -- First argument = should the value be printed? -evalTerm :: Members (Error EvalError ': State TopInfo ': Output Message ': EvalEffects) r => Bool -> ATerm -> Sem r Value +evalTerm :: Members (Error EvalError ': State TopInfo ': Output (Message ()) ': EvalEffects) r => Bool -> ATerm -> Sem r Value evalTerm pr at = do env <- use @TopInfo topEnv v <- runInputConst env $ eval (compileTerm at) @@ -507,11 +554,11 @@ when pr $ info $ runInputConst tydefs $ prettyValue' ty v modify @TopInfo $ - (replModInfo . miTys %~ Ctx.insert (QName (QualifiedName REPLModule) (string2Name "it")) (toPolyType ty)) . - (topEnv %~ Ctx.insert (QName (QualifiedName REPLModule) (string2Name "it")) v) + (replModInfo . miTys %~ Ctx.insert (QName (QualifiedName REPLModule) (string2Name "it")) (toPolyType ty)) + . (topEnv %~ Ctx.insert (QName (QualifiedName REPLModule) (string2Name "it")) v) return v - where - ty = getType at + where + ty = getType at ------------------------------------------------------------ -- :help @@ -519,33 +566,33 @@ helpCmd :: REPLCommand 'CHelp helpCmd = REPLCommand - { name = "help", - helpcmd = ":help", - shortHelp = "Show help", - category = User, - cmdtype = ColonCmd, - action = \x -> handleHelp x, - parser = return Help + { name = "help" + , helpcmd = ":help" + , shortHelp = "Show help" + , category = User + , cmdtype = ColonCmd + , action = handleHelp + , parser = return Help } -handleHelp :: Member (Output Message) r => REPLExpr 'CHelp -> Sem r () +handleHelp :: Member (Output (Message ())) r => REPLExpr 'CHelp -> Sem r () handleHelp Help = info $ vcat - [ "Commands available from the prompt:" - , text "" - , vcat (map (\(SomeCmd c) -> showCmd c) $ sortedList discoCommands) - , text "" - ] - where - maxlen = longestCmd discoCommands - sortedList cmds = - sortBy (\(SomeCmd x) (SomeCmd y) -> compare (name x) (name y)) $ filteredCommands cmds - -- don't show dev-only commands by default - filteredCommands cmds = P.filter (\(SomeCmd c) -> category c == User) cmds - showCmd c = text (padRight (helpcmd c) maxlen ++ " " ++ shortHelp c) - longestCmd cmds = maximum $ map (\(SomeCmd c) -> length $ helpcmd c) cmds - padRight s maxsize = take maxsize (s ++ repeat ' ') + [ "Commands available from the prompt:" + , text "" + , vcat (map (\(SomeCmd c) -> showCmd c) $ sortedList discoCommands) + , text "" + ] + where + maxlen = longestCmd discoCommands + sortedList cmds = + sortBy (\(SomeCmd x) (SomeCmd y) -> compare (name x) (name y)) $ filteredCommands cmds + showCmd c = text (padRight (helpcmd c) maxlen ++ " " ++ shortHelp c) + longestCmd cmds = maximum $ map (\(SomeCmd c) -> length $ helpcmd c) cmds + padRight s maxsize = take maxsize (s ++ repeat ' ') + -- don't show dev-only commands by default + filteredCommands = P.filter (\(SomeCmd c) -> category c == User) ------------------------------------------------------------ -- :load @@ -553,13 +600,13 @@ loadCmd :: REPLCommand 'CLoad loadCmd = REPLCommand - { name = "load", - helpcmd = ":load ", - shortHelp = "Load a file", - category = User, - cmdtype = ColonCmd, - action = \x -> handleLoadWrapper x, - parser = Load <$> fileParser + { name = "load" + , helpcmd = ":load " + , shortHelp = "Load a file" + , category = User + , cmdtype = ColonCmd + , action = handleLoadWrapper + , parser = Load <$> fileParser } -- | Parses, typechecks, and loads a module by first recursively loading any imported @@ -567,13 +614,13 @@ -- in the parent module are executed. -- Disco.Interactive.CmdLine uses a version of this function that returns a Bool. handleLoadWrapper :: - Members (Error DiscoError ': State TopInfo ': Output Message ': Embed IO ': EvalEffects) r => + Members (Error DiscoError ': State TopInfo ': Output (Message ()) ': Embed IO ': EvalEffects) r => REPLExpr 'CLoad -> Sem r () handleLoadWrapper (Load fp) = void (handleLoad fp) handleLoad :: - Members (Error DiscoError ': State TopInfo ': Output Message ': Embed IO ': EvalEffects) r => + Members (Error DiscoError ': State TopInfo ': Output (Message ()) ': Embed IO ': EvalEffects) r => FilePath -> Sem r Bool handleLoad fp = do @@ -599,36 +646,36 @@ info "Loaded." return t --- XXX Return a structured summary of the results, not a Bool; --- separate out results generation and pretty-printing, & move this --- somewhere else. -runAllTests :: Members (Output Message ': Input TopInfo ': EvalEffects) r => [QName Term] -> Ctx ATerm [AProperty] -> Sem r Bool -- (Ctx ATerm [TestResult]) +-- XXX Return a structured summary of the results, not a Bool; & move +-- this somewhere else? +runAllTests :: Members (Output (Message ()) ': Input TopInfo ': EvalEffects) r => [QName Term] -> Ctx ATerm [AProperty] -> Sem r Bool -- (Ctx ATerm [TestResult]) runAllTests declNames aprops | Ctx.null aprops = return True - | otherwise = do + | otherwise = do info "Running tests..." -- Use the order the names were defined in the module and <$> mapM (uncurry runTests) (mapMaybe (\n -> (n,) <$> Ctx.lookup' (coerce n) aprops) declNames) - - where - numSamples :: Int - numSamples = 50 -- XXX make this configurable somehow - - runTests :: Members (Output Message ': Input TopInfo ': EvalEffects) r => QName Term -> [AProperty] -> Sem r Bool - runTests (QName _ n) props = do - results <- inputTopEnv $ traverse (sequenceA . (id &&& runTest numSamples)) props - let failures = P.filter (not . testIsOk . snd) results - hdr = pretty' n <> ":" + where + numSamples :: Int + numSamples = 50 -- XXX make this configurable somehow + runTests :: Members (Output (Message ()) ': Input TopInfo ': EvalEffects) r => QName Term -> [AProperty] -> Sem r Bool + runTests (QName _ n) props = do + results <- inputTopEnv $ traverse (sequenceA . (id &&& runTest numSamples)) props + let failures = P.filter (not . testIsOk . snd) results + hdr = pretty' n <> ":" - case P.null failures of - True -> info $ nest 2 $ hdr <+> "OK" - False -> do - tydefs <- inputs @TopInfo (view (replModInfo . to allTydefs)) - let prettyFailures = - runInputConst tydefs . runReader initPA . runLFresh $ - bulletList "-" $ map (uncurry prettyTestFailure) failures - info $ nest 2 $ hdr $+$ prettyFailures - return (P.null failures) + case P.null failures of + True -> info $ indent 2 $ hdr <+> "OK" + False -> do + tydefs <- inputs @TopInfo (view (replModInfo . to allTydefs)) + let prettyFailures = + runInputConst tydefs + . runReader initPA + . runLFresh + $ bulletList "-" + $ map (uncurry prettyTestResult) failures + info $ indent 2 $ hdr $+$ prettyFailures + return (P.null failures) ------------------------------------------------------------ -- :names @@ -636,18 +683,18 @@ namesCmd :: REPLCommand 'CNames namesCmd = REPLCommand - { name = "names", - helpcmd = ":names", - shortHelp = "Show all names in current scope", - category = User, - cmdtype = ColonCmd, - action = \x -> inputToState . handleNames $ x, - parser = return Names + { name = "names" + , helpcmd = ":names" + , shortHelp = "Show all names in current scope" + , category = User + , cmdtype = ColonCmd + , action = inputToState . handleNames + , parser = return Names } -- | Show names and types for each item in the top-level context. handleNames :: - Members '[Input TopInfo, LFresh, Output Message] r => + Members '[Input TopInfo, LFresh, Output (Message ())] r => REPLExpr 'CNames -> Sem r () handleNames Names = do @@ -655,10 +702,9 @@ ctx <- inputs @TopInfo (view (replModInfo . miTys)) info $ vcat (map pretty' (M.assocs tyDef)) - $+$ - vcat (map showFn (Ctx.assocs ctx)) - where - showFn (QName _ x, ty) = hsep [pretty' x, text ":", pretty' ty] + $+$ vcat (map showFn (Ctx.assocs ctx)) + where + showFn (QName _ x, ty) = hsep [pretty' x, text ":", pretty' ty] ------------------------------------------------------------ -- nop @@ -666,13 +712,13 @@ nopCmd :: REPLCommand 'CNop nopCmd = REPLCommand - { name = "nop", - helpcmd = "", - shortHelp = "No-op, e.g. if the user just enters a comment", - category = Dev, - cmdtype = BuiltIn, - action = \x -> handleNop x, - parser = Nop <$ (sc <* eof) + { name = "nop" + , helpcmd = "" + , shortHelp = "No-op, e.g. if the user just enters a comment" + , category = Dev + , cmdtype = BuiltIn + , action = handleNop + , parser = Nop <$ (sc <* eof) } handleNop :: REPLExpr 'CNop -> Sem r () @@ -684,16 +730,16 @@ parseCmd :: REPLCommand 'CParse parseCmd = REPLCommand - { name = "parse", - helpcmd = ":parse ", - shortHelp = "Show the parsed AST", - category = Dev, - cmdtype = ColonCmd, - action = \x -> handleParse x, - parser = Parse <$> term + { name = "parse" + , helpcmd = ":parse " + , shortHelp = "Show the parsed AST" + , category = Dev + , cmdtype = ColonCmd + , action = handleParse + , parser = Parse <$> term } -handleParse :: Member (Output Message) r => REPLExpr 'CParse -> Sem r () +handleParse :: Member (Output (Message ())) r => REPLExpr 'CParse -> Sem r () handleParse (Parse t) = info (text (show t)) ------------------------------------------------------------ @@ -702,16 +748,16 @@ prettyCmd :: REPLCommand 'CPretty prettyCmd = REPLCommand - { name = "pretty", - helpcmd = ":pretty ", - shortHelp = "Pretty-print a term", - category = Dev, - cmdtype = ColonCmd, - action = \x -> handlePretty x, - parser = Pretty <$> term + { name = "pretty" + , helpcmd = ":pretty " + , shortHelp = "Pretty-print a term" + , category = Dev + , cmdtype = ColonCmd + , action = handlePretty + , parser = Pretty <$> term } -handlePretty :: Members '[LFresh, Output Message] r => REPLExpr 'CPretty -> Sem r () +handlePretty :: Members '[LFresh, Output (Message ())] r => REPLExpr 'CPretty -> Sem r () handlePretty (Pretty t) = info $ pretty' t ------------------------------------------------------------ @@ -720,16 +766,16 @@ printCmd :: REPLCommand 'CPrint printCmd = REPLCommand - { name = "print", - helpcmd = ":print ", - shortHelp = "Print a string without the double quotes, interpreting special characters", - category = User, - cmdtype = ColonCmd, - action = \x -> handlePrint x, - parser = Print <$> term + { name = "print" + , helpcmd = ":print " + , shortHelp = "Print a string without the double quotes, interpreting special characters" + , category = User + , cmdtype = ColonCmd + , action = handlePrint + , parser = Print <$> term } -handlePrint :: Members (Error DiscoError ': State TopInfo ': Output Message ': EvalEffects) r => REPLExpr 'CPrint -> Sem r () +handlePrint :: Members (Error DiscoError ': State TopInfo ': Output (Message ()) ': EvalEffects) r => REPLExpr 'CPrint -> Sem r () handlePrint (Print t) = do at <- inputToState . typecheckTop $ checkTop t (toPolyType TyString) v <- mapError EvalErr . evalTerm False $ at @@ -741,24 +787,24 @@ reloadCmd :: REPLCommand 'CReload reloadCmd = REPLCommand - { name = "reload", - helpcmd = ":reload", - shortHelp = "Reloads the most recently loaded file", - category = User, - cmdtype = ColonCmd, - action = \x -> handleReload x, - parser = return Reload + { name = "reload" + , helpcmd = ":reload" + , shortHelp = "Reloads the most recently loaded file" + , category = User + , cmdtype = ColonCmd + , action = handleReload + , parser = return Reload } handleReload :: - Members (Error DiscoError ': State TopInfo ': Output Message ': Embed IO ': EvalEffects) r => + Members (Error DiscoError ': State TopInfo ': Output (Message ()) ': Embed IO ': EvalEffects) r => REPLExpr 'CReload -> Sem r () handleReload Reload = do file <- use lastFile case file of Nothing -> info "No file to reload." - Just f -> void (handleLoad f) + Just f -> void (handleLoad f) ------------------------------------------------------------ -- :defn @@ -766,22 +812,22 @@ showDefnCmd :: REPLCommand 'CShowDefn showDefnCmd = REPLCommand - { name = "defn", - helpcmd = ":defn ", - shortHelp = "Show a variable's definition", - category = User, - cmdtype = ColonCmd, - action = \x -> inputToState @TopInfo . handleShowDefn $ x, - parser = ShowDefn <$> (sc *> ident) + { name = "defn" + , helpcmd = ":defn " + , shortHelp = "Show a variable's definition" + , category = User + , cmdtype = ColonCmd + , action = inputToState @TopInfo . handleShowDefn + , parser = ShowDefn <$> (sc *> ident) } handleShowDefn :: - Members '[Input TopInfo, LFresh, Output Message] r => + Members '[Input TopInfo, LFresh, Output (Message ())] r => REPLExpr 'CShowDefn -> Sem r () handleShowDefn (ShowDefn x) = do let name2s = name2String x - defns <- inputs @TopInfo (view (replModInfo . miTermdefs)) + defns <- inputs @TopInfo (view (replModInfo . miTermdefs)) tyDefns <- inputs @TopInfo (view (replModInfo . miTydefs)) let xdefs = Ctx.lookupAll' (coerce x) defns @@ -791,7 +837,7 @@ let ds = map (pretty' . snd) xdefs ++ maybe [] (pure . pretty' . (name2s,)) mtydef case ds of [] -> text "No definition for" <+> pretty' x - _ -> vcat ds + _ -> vcat ds ------------------------------------------------------------ -- :test @@ -799,17 +845,17 @@ testPropCmd :: REPLCommand 'CTestProp testPropCmd = REPLCommand - { name = "test", - helpcmd = ":test ", - shortHelp = "Test a property using random examples", - category = User, - cmdtype = ColonCmd, - action = \x -> handleTest x, - parser = TestProp <$> term + { name = "test" + , helpcmd = ":test " + , shortHelp = "Test a property using random examples" + , category = User + , cmdtype = ColonCmd + , action = handleTest + , parser = TestProp <$> term } handleTest :: - Members (Error DiscoError ': State TopInfo ': Output Message ': EvalEffects) r => + Members (Error DiscoError ': State TopInfo ': Output (Message ()) ': EvalEffects) r => REPLExpr 'CTestProp -> Sem r () handleTest (TestProp t) = do @@ -817,7 +863,7 @@ tydefs <- use @TopInfo (replModInfo . to allTydefs) inputToState . inputTopEnv $ do r <- runTest 100 at -- XXX make configurable - info $ runInputConst tydefs . runReader initPA $ nest 2 $ "-" <+> prettyTestResult at r + info $ runInputConst tydefs . runReader initPA $ indent 2 . nest 2 $ "-" <+> prettyTestResult at r ------------------------------------------------------------ -- :type @@ -825,17 +871,17 @@ typeCheckCmd :: REPLCommand 'CTypeCheck typeCheckCmd = REPLCommand - { name = "type", - helpcmd = ":type ", - shortHelp = "Typecheck a term", - category = Dev, - cmdtype = ColonCmd, - action = \x -> inputToState @TopInfo . handleTypeCheck $ x, - parser = parseTypeCheck + { name = "type" + , helpcmd = ":type " + , shortHelp = "Typecheck a term" + , category = Dev + , cmdtype = ColonCmd + , action = inputToState @TopInfo . handleTypeCheck + , parser = parseTypeCheck } handleTypeCheck :: - Members '[Error DiscoError, Input TopInfo, LFresh, Output Message] r => + Members '[Error DiscoError, Input TopInfo, LFresh, Output (Message ())] r => REPLExpr 'CTypeCheck -> Sem r () handleTypeCheck (TypeCheck t) = do @@ -858,7 +904,7 @@ parseNakedOpPrim :: Parser Prim parseNakedOpPrim = sc *> choice (map mkOpParser (concat opTable)) - where - mkOpParser :: OpInfo -> Parser Prim - mkOpParser (OpInfo (UOpF _ op) syns _) = choice (map ((PrimUOp op <$) . reservedOp) syns) - mkOpParser (OpInfo (BOpF _ op) syns _) = choice (map ((PrimBOp op <$) . reservedOp) syns) + where + mkOpParser :: OpInfo -> Parser Prim + mkOpParser (OpInfo (UOpF _ op) syns _) = choice (map ((PrimUOp op <$) . reservedOp) syns) + mkOpParser (OpInfo (BOpF _ op) syns _) = choice (map ((PrimBOp op <$) . reservedOp) syns) diff --git a/src/Disco/Interpret/CESK.hs b/src/Disco/Interpret/CESK.hs --- a/src/Disco/Interpret/CESK.hs +++ b/src/Disco/Interpret/CESK.hs @@ -2,6 +2,9 @@ {-# OPTIONS_GHC -fmax-pmcheck-models=200 #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Disco.Interpret.CESK -- Copyright : disco team and contributors @@ -10,55 +13,59 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- CESK machine interpreter for Disco. ------------------------------------------------------------------------------ - -module Disco.Interpret.CESK - ( CESK, - runCESK, - step, - eval, - runTest, - ) +module Disco.Interpret.CESK ( + CESK, + runCESK, + step, + eval, + runTest, +) where -import Unbound.Generics.LocallyNameless (Bind, Name) +import Unbound.Generics.LocallyNameless (Bind, Name) -import Algebra.Graph -import qualified Algebra.Graph.AdjacencyMap as AdjMap -import Control.Arrow ((***), (>>>)) -import Control.Monad ((>=>)) -import Data.Bifunctor (first, second) -import Data.List (find) -import qualified Data.Map as M -import Data.Maybe (isJust) -import Data.Ratio -import Disco.AST.Core -import Disco.AST.Generic (Ellipsis (..), Side (..), - selectSide) -import Disco.AST.Typed (AProperty) -import Disco.Compile -import Disco.Context as Ctx -import Disco.Enumerate -import Disco.Error -import Disco.Names -import Disco.Property -import Disco.Types hiding (V) -import Disco.Value -import Math.Combinatorics.Exact.Binomial (choose) -import Math.Combinatorics.Exact.Factorial (factorial) -import Math.NumberTheory.Primes (factorise, unPrime) -import Math.NumberTheory.Primes.Testing (isPrime) -import Math.OEIS (catalogNums, - extendSequence, - lookupSequence) +import Algebra.Graph +import qualified Algebra.Graph.AdjacencyMap as AdjMap +import Control.Arrow ((***), (>>>)) +import Control.Monad ((>=>)) +import Data.Bifunctor (first, second) +import Data.List (find) +import qualified Data.Map as M +import Data.Maybe (isJust) +import Data.Ratio +import Disco.AST.Core +import Disco.AST.Generic ( + Ellipsis (..), + Side (..), + selectSide, + ) +import Disco.AST.Typed (AProperty) +import Disco.Compile +import Disco.Context as Ctx +import Disco.Enumerate +import Disco.Error +import Disco.Names +import Disco.Property +import Disco.Types hiding (V) +import Disco.Value +import Math.Combinatorics.Exact.Binomial (choose) +import Math.Combinatorics.Exact.Factorial (factorial) +import Math.NumberTheory.Primes (factorise, unPrime) +import Math.NumberTheory.Primes.Testing (isPrime) -import Disco.Effects.Fresh -import Disco.Effects.Input -import Disco.Effects.Random -import Polysemy -import Polysemy.Error -import Polysemy.State +-- import Math.OEIS ( +-- catalogNums, +-- extendSequence, +-- lookupSequence, +-- ) +import Disco.Effects.Fresh +import Disco.Effects.Input +import Disco.Effects.Random +import Polysemy +import Polysemy.Error +import Polysemy.State + ------------------------------------------------------------ -- Utilities ------------------------------------------------------------ @@ -141,22 +148,22 @@ -- | Is the CESK machine in a final state? isFinal :: CESK -> Maybe (Either EvalError Value) -isFinal (Up e []) = Just (Left e) +isFinal (Up e []) = Just (Left e) isFinal (Out v []) = Just (Right v) -isFinal _ = Nothing +isFinal _ = Nothing -- | Run a CESK machine to completion. runCESK :: Members '[Fresh, Random, State Mem] r => CESK -> Sem r (Either EvalError Value) runCESK cesk = case isFinal cesk of Just res -> return res - Nothing -> step cesk >>= runCESK + Nothing -> step cesk >>= runCESK -- | Advance the CESK machine by one step. step :: Members '[Fresh, Random, State Mem] r => CESK -> Sem r CESK step cesk = case cesk of (In (CVar x) e k) -> case Ctx.lookup' x e of Nothing -> return $ Up (UnboundError x) k - Just v -> return $ Out v k + Just v -> return $ Out v k (In (CNum d r) _ k) -> return $ Out (VNum d r) k (In (CConst OMatchErr) _ k) -> return $ Up NonExhaustive k (In (CConst OEmptyGraph) _ k) -> return $ Out (VGraph empty) k @@ -177,7 +184,6 @@ return $ Out (foldr (VPair . VRef) VUnit locs) k (In (CForce c) e k) -> return $ In c e (FForce : k) (In (CTest vars c) e k) -> return $ In c e (FTest (TestVars vars) e : k) - (Out v (FInj s : k)) -> return $ Out (VInj s v) k (Out (VInj L v) (FCase e b1 _ : k)) -> do (x, c1) <- unbind b1 @@ -200,7 +206,6 @@ (Out (VClo e (x : xs) b) (FArgV v : k)) -> return $ Out (VClo (Ctx.insert (localName x) v e) xs b) k (Out (VConst op) (FArgV v : k)) -> appConst k op v (Out (VFun f) (FArgV v : k)) -> return $ Out (f v) k - (Out (VRef n) (FForce : k)) -> do cell <- lkup n case cell of @@ -213,18 +218,15 @@ (Out v (FUpdate n : k)) -> do set n (V v) return $ Out v k - - (Up err (f@FTest{} : k)) -> + (Up err (f@FTest {} : k)) -> return $ Out (VProp (VPDone (TestResult False (TestRuntimeError err) emptyTestEnv))) (f : k) (Up err (_ : ks)) -> return $ Up err ks - (Out v (FTest vs e : k)) -> do let result = ensureProp v - res = getTestEnv vs e + res = getTestEnv vs e case res of Left err -> return $ Up err k Right e' -> return $ Out (VProp $ extendPropEnv e' result) k - _ -> error "Impossible! Bad CESK machine state" ------------------------------------------------------------ @@ -233,15 +235,18 @@ arity2 :: (Value -> Value -> a) -> Value -> a arity2 f (VPair x y) = f x y -arity2 _f _v = error "arity2 on a non-pair!" +arity2 _f _v = error "arity2 on a non-pair!" arity3 :: (Value -> Value -> Value -> a) -> Value -> a arity3 f (VPair x (VPair y z)) = f x y z -arity3 _f _v = error "arity3 on a non-triple!" +arity3 _f _v = error "arity3 on a non-triple!" -appConst - :: Members '[Random, State Mem] r - => Cont -> Op -> Value -> Sem r CESK +appConst :: + Members '[Random, State Mem] r => + Cont -> + Op -> + Value -> + Sem r CESK appConst k = \case -------------------------------------------------- -- Basics @@ -259,80 +264,80 @@ OAbs -> numOp1 abs >=> out OMul -> numOp2 (*) >=> out ODiv -> numOp2' divOp >>> outWithErr - where - divOp :: Member (Error EvalError) r => Rational -> Rational -> Sem r Value - divOp _ 0 = throw DivByZero - divOp m n = return $ ratv (m / n) + where + divOp :: Member (Error EvalError) r => Rational -> Rational -> Sem r Value + divOp _ 0 = throw DivByZero + divOp m n = return $ ratv (m / n) OExp -> numOp2 (\m n -> m ^^ numerator n) >=> out OMod -> numOp2' modOp >>> outWithErr - where - modOp :: Member (Error EvalError) r => Rational -> Rational -> Sem r Value - modOp m n - | n == 0 = throw DivByZero - | otherwise = return $ intv (numerator m `mod` numerator n) + where + modOp :: Member (Error EvalError) r => Rational -> Rational -> Sem r Value + modOp m n + | n == 0 = throw DivByZero + | otherwise = return $ intv (numerator m `mod` numerator n) ODivides -> numOp2' (\m n -> return (enumv $ divides m n)) >=> out - where - divides 0 0 = True - divides 0 _ = False - divides x y = denominator (y / x) == 1 + where + divides 0 0 = True + divides 0 _ = False + divides x y = denominator (y / x) == 1 -------------------------------------------------- -- Number theory OIsPrime -> intOp1 (enumv . isPrime) >=> out OFactor -> intOp1' primFactor >>> outWithErr - where - -- Semantics of the @$factor@ prim: turn a natural number into its - -- bag of prime factors. Crash if called on 0, which does not have - -- a prime factorization. - primFactor :: Member (Error EvalError) r => Integer -> Sem r Value - primFactor 0 = throw (Crash "0 has no prime factorization!") - primFactor n = return . VBag $ map ((intv . unPrime) *** fromIntegral) (factorise n) + where + -- Semantics of the @$factor@ prim: turn a natural number into its + -- bag of prime factors. Crash if called on 0, which does not have + -- a prime factorization. + primFactor :: Member (Error EvalError) r => Integer -> Sem r Value + primFactor 0 = throw (Crash "0 has no prime factorization!") + primFactor n = return . VBag $ map ((intv . unPrime) *** fromIntegral) (factorise n) OFrac -> numOp1' (return . primFrac) >=> out - where - -- Semantics of the @$frac@ prim: turn a rational number into a pair - -- of its numerator and denominator. - primFrac :: Rational -> Value - primFrac r = VPair (intv (numerator r)) (intv (denominator r)) + where + -- Semantics of the @$frac@ prim: turn a rational number into a pair + -- of its numerator and denominator. + primFrac :: Rational -> Value + primFrac r = VPair (intv (numerator r)) (intv (denominator r)) -------------------------------------------------- -- Combinatorics OMultinom -> arity2 multinomOp >=> out - where - multinomOp :: Value -> Value -> Sem r Value - multinomOp (vint -> n0) (vlist vint -> ks0) = return . intv $ multinomial n0 ks0 - where - multinomial :: Integer -> [Integer] -> Integer - multinomial _ [] = 1 - multinomial n (k' : ks) - | k' > n = 0 - | otherwise = choose n k' * multinomial (n - k') ks + where + multinomOp :: Value -> Value -> Sem r Value + multinomOp (vint -> n0) (vlist vint -> ks0) = return . intv $ multinomial n0 ks0 + where + multinomial :: Integer -> [Integer] -> Integer + multinomial _ [] = 1 + multinomial n (k' : ks) + | k' > n = 0 + | otherwise = choose n k' * multinomial (n - k') ks OFact -> numOp1' factOp >>> outWithErr - where - factOp :: Member (Error EvalError) r => Rational -> Sem r Value - factOp (numerator -> n) - | n > fromIntegral (maxBound :: Int) = throw Overflow - | otherwise = return . intv $ factorial (fromIntegral n) + where + factOp :: Member (Error EvalError) r => Rational -> Sem r Value + factOp (numerator -> n) + | n > fromIntegral (maxBound :: Int) = throw Overflow + | otherwise = return . intv $ factorial (fromIntegral n) OEnum -> out . enumOp - where - enumOp :: Value -> Value - enumOp (VType ty) = listv id (enumerateType ty) - enumOp v = error $ "Impossible! enumOp on non-type " ++ show v + where + enumOp :: Value -> Value + enumOp (VType ty) = listv id (enumerateType ty) + enumOp v = error $ "Impossible! enumOp on non-type " ++ show v OCount -> out . countOp - where - countOp :: Value -> Value - countOp (VType ty) = case countType ty of - Just num -> VInj R (intv num) - Nothing -> VNil - countOp v = error $ "Impossible! countOp on non-type " ++ show v + where + countOp :: Value -> Value + countOp (VType ty) = case countType ty of + Just num -> VInj R (intv num) + Nothing -> VNil + countOp v = error $ "Impossible! countOp on non-type " ++ show v -------------------------------------------------- -- Sequences OUntil -> arity2 $ \v1 -> out . ellipsis (Until v1) - OLookupSeq -> out . oeisLookup - OExtendSeq -> out . oeisExtend + -- OLookupSeq -> out . oeisLookup + -- OExtendSeq -> out . oeisExtend -------------------------------------------------- -- Comparison @@ -342,40 +347,37 @@ -- Container operations OPower -> withBag OPower $ out . VBag . sortNCount . map (first VBag) . choices - where - choices :: [(Value, Integer)] -> [([(Value, Integer)], Integer)] - choices [] = [([], 1)] - choices ((x, n) : xs) = xs' ++ concatMap (\k' -> map (cons n (x, k')) xs') [1 .. n] - where - xs' = choices xs - cons n (x, k') (zs, m) = ((x, k') : zs, choose n k' * m) - OBagElem -> arity2 $ \x -> withBag OBagElem $ - out . enumv . isJust . find (valEq x) . map fst + where + choices :: [(Value, Integer)] -> [([(Value, Integer)], Integer)] + choices [] = [([], 1)] + choices ((x, n) : xs) = xs' ++ concatMap (\k' -> map (cons n (x, k')) xs') [1 .. n] + where + xs' = choices xs + cons n (x, k') (zs, m) = ((x, k') : zs, choose n k' * m) + OBagElem -> arity2 $ \x -> + withBag OBagElem $ + out . enumv . isJust . find (valEq x) . map fst OListElem -> arity2 $ \x -> out . enumv . isJust . find (valEq x) . vlist id - - OEachSet -> arity2 $ \f -> withBag OEachSet $ - outWithErr . fmap (VBag . countValues) . mapM (evalApp f . (:[]) . fst) - - OEachBag -> arity2 $ \f -> withBag OEachBag $ - outWithErr . fmap (VBag . sortNCount) . mapM (\(x,n) -> (,n) <$> evalApp f [x]) - + OEachSet -> arity2 $ \f -> + withBag OEachSet $ + outWithErr . fmap (VBag . countValues) . mapM (evalApp f . (: []) . fst) + OEachBag -> arity2 $ \f -> + withBag OEachBag $ + outWithErr . fmap (VBag . sortNCount) . mapM (\(x, n) -> (,n) <$> evalApp f [x]) OFilterBag -> arity2 $ \f -> withBag OFilterBag $ \xs -> outWithErr $ do - bs <- mapM (evalApp f . (:[]) . fst) xs + bs <- mapM (evalApp f . (: []) . fst) xs return . VBag . map snd . Prelude.filter (isTrue . fst) $ zip bs xs - where - isTrue (VInj R VUnit) = True - isTrue _ = False - + where + isTrue (VInj R VUnit) = True + isTrue _ = False OMerge -> arity3 $ \f bxs bys -> case (bxs, bys) of (VBag xs, VBag ys) -> outWithErr (VBag <$> mergeM f xs ys) (VBag _, _) -> error $ "Impossible! OMerge on non-VBag " ++ show bys - _ -> error $ "Impossible! OMerge on non-VBag " ++ show bxs - + _ -> error $ "Impossible! OMerge on non-VBag " ++ show bxs OBagUnions -> withBag OBagUnions $ \cts -> - out . VBag $ sortNCount [(x, m*n) | (VBag xs, n) <- cts, (x,m) <- xs] - + out . VBag $ sortNCount [(x, m * n) | (VBag xs, n) <- cts, (x, m) <- xs] -------------------------------------------------- -- Container conversions @@ -392,83 +394,91 @@ -- Disco> :desugar let x = 3 in ⟅ 'a' # (2 + x), 'b', 'b' ⟆ -- (λx. bagFromCounts(bag(('a', 2 + x) :: ('b', 1) :: ('b', 1) :: [])))(3) - OCountsToBag -> withBag OCountsToBag $ - out . VBag . sortNCount . map (second (uncurry (*)) . assoc . first (vpair id vint)) - where - assoc ((a, b), c) = (a, (b, c)) - - OUnsafeCountsToBag -> withBag OUnsafeCountsToBag $ - out . VBag . map (second (uncurry (*)) . assoc . first (vpair id vint)) - where - assoc ((a, b), c) = (a, (b, c)) + OCountsToBag -> + withBag OCountsToBag $ + out . VBag . sortNCount . map (second (uncurry (*)) . assoc . first (vpair id vint)) + where + assoc ((a, b), c) = (a, (b, c)) + OUnsafeCountsToBag -> + withBag OUnsafeCountsToBag $ + out . VBag . map (second (uncurry (*)) . assoc . first (vpair id vint)) + where + assoc ((a, b), c) = (a, (b, c)) -------------------------------------------------- -- Maps - OMapToSet -> withMap OMapToSet $ - out . VBag . map (\(k',v) -> (VPair (fromSimpleValue k') v, 1)) . M.assocs - - OSetToMap -> withBag OSetToMap $ - out . VMap . M.fromList . map (convertAssoc . fst) - where - convertAssoc (VPair k' v) = (toSimpleValue k', v) - convertAssoc v = error $ "Impossible! convertAssoc on non-VPair " ++ show v - - OInsert -> arity3 $ \k' v -> withMap OInsert $ - out . VMap . M.insert (toSimpleValue k') v - - OLookup -> arity2 $ \k' -> withMap OLookup $ - out . toMaybe . M.lookup (toSimpleValue k') - where - toMaybe = maybe (VInj L VUnit) (VInj R) + OMapToSet -> + withMap OMapToSet $ + out . VBag . map (\(k', v) -> (VPair (fromSimpleValue k') v, 1)) . M.assocs + OSetToMap -> + withBag OSetToMap $ + out . VMap . M.fromList . map (convertAssoc . fst) + where + convertAssoc (VPair k' v) = (toSimpleValue k', v) + convertAssoc v = error $ "Impossible! convertAssoc on non-VPair " ++ show v + OInsert -> arity3 $ \k' v -> + withMap OInsert $ + out . VMap . M.insert (toSimpleValue k') v + OLookup -> arity2 $ \k' -> + withMap OLookup $ + out . toMaybe . M.lookup (toSimpleValue k') + where + toMaybe = maybe (VInj L VUnit) (VInj R) -------------------------------------------------- -- Graph operations - OVertex -> out . VGraph . Vertex . toSimpleValue + OVertex -> out . VGraph . Vertex . toSimpleValue OOverlay -> arity2 $ withGraph2 OOverlay $ \g1 g2 -> out $ VGraph (Overlay g1 g2) OConnect -> arity2 $ withGraph2 OConnect $ \g1 g2 -> out $ VGraph (Connect g1 g2) OSummary -> withGraph OSummary $ out . graphSummary - -------------------------------------------------- -- Propositions - OForall tys -> out . (\v -> VProp (VPSearch SMForall tys v emptyTestEnv )) - OExists tys -> out . (\v -> VProp (VPSearch SMExists tys v emptyTestEnv )) + OForall tys -> out . (\v -> VProp (VPSearch SMForall tys v emptyTestEnv)) + OExists tys -> out . (\v -> VProp (VPSearch SMExists tys v emptyTestEnv)) OHolds -> testProperty Exhaustive >=> resultToBool >>> outWithErr ONotProp -> out . VProp . notProp . ensureProp OShouldEq ty -> arity2 $ \v1 v2 -> out $ VProp (VPDone (TestResult (valEq v1 v2) (TestEqual ty v1 v2) emptyTestEnv)) - + OShouldLt ty -> arity2 $ \v1 v2 -> + out $ VProp (VPDone (TestResult (valLt v1 v2) (TestLt ty v1 v2) emptyTestEnv)) + OAnd -> arity2 $ \p1 p2 -> + out $ VProp (VPBin LAnd (ensureProp p1) (ensureProp p2)) + OOr -> arity2 $ \p1 p2 -> + out $ VProp (VPBin LOr (ensureProp p1) (ensureProp p2)) + OImpl -> arity2 $ \p1 p2 -> + out $ VProp (VPBin LImpl (ensureProp p1) (ensureProp p2)) c -> error $ "Unimplemented: appConst " ++ show c - where - outWithErr :: Sem (Error EvalError ': r) Value -> Sem r CESK - outWithErr m = either (`Up` k) (`Out` k) <$> runError m - out v = return $ Out v k - up e = return $ Up e k + where + outWithErr :: Sem (Error EvalError ': r) Value -> Sem r CESK + outWithErr m = either (`Up` k) (`Out` k) <$> runError m + out v = return $ Out v k + up e = return $ Up e k - withBag :: Op -> ([(Value,Integer)] -> Sem r a) -> Value -> Sem r a - withBag op f = \case - VBag xs -> f xs - v -> error $ "Impossible! " ++ show op ++ " on non-VBag " ++ show v + withBag :: Op -> ([(Value, Integer)] -> Sem r a) -> Value -> Sem r a + withBag op f = \case + VBag xs -> f xs + v -> error $ "Impossible! " ++ show op ++ " on non-VBag " ++ show v - withMap :: Op -> (M.Map SimpleValue Value -> Sem r a) -> Value -> Sem r a - withMap op f = \case - VMap m -> f m - v -> error $ "Impossible! " ++ show op ++ " on non-VMap " ++ show v + withMap :: Op -> (M.Map SimpleValue Value -> Sem r a) -> Value -> Sem r a + withMap op f = \case + VMap m -> f m + v -> error $ "Impossible! " ++ show op ++ " on non-VMap " ++ show v - withGraph :: Op -> (Graph SimpleValue -> Sem r a) -> Value -> Sem r a - withGraph op f = \case - VGraph g -> f g - v -> error $ "Impossible! " ++ show op ++ " on non-VGraph " ++ show v + withGraph :: Op -> (Graph SimpleValue -> Sem r a) -> Value -> Sem r a + withGraph op f = \case + VGraph g -> f g + v -> error $ "Impossible! " ++ show op ++ " on non-VGraph " ++ show v - withGraph2 :: Op -> (Graph SimpleValue -> Graph SimpleValue -> Sem r a) -> Value -> Value -> Sem r a - withGraph2 op f v1 v2 = case (v1, v2) of - (VGraph g1, VGraph g2) -> f g1 g2 - (_, VGraph _) -> error $ "Impossible! " ++ show op ++ " on non-VGraph " ++ show v1 - _ -> error $ "Impossible! " ++ show op ++ " on non-VGraph " ++ show v2 + withGraph2 :: Op -> (Graph SimpleValue -> Graph SimpleValue -> Sem r a) -> Value -> Value -> Sem r a + withGraph2 op f v1 v2 = case (v1, v2) of + (VGraph g1, VGraph g2) -> f g1 g2 + (_, VGraph _) -> error $ "Impossible! " ++ show op ++ " on non-VGraph " ++ show v1 + _ -> error $ "Impossible! " ++ show op ++ " on non-VGraph " ++ show v2 -------------------------------------------------- -- Arithmetic @@ -484,7 +494,7 @@ numOp1' :: (Rational -> Sem r Value) -> Value -> Sem r Value numOp1' f (VNum _ m) = f m -numOp1' _ v = error $ "Impossible! numOp1' on non-VNum " ++ show v +numOp1' _ v = error $ "Impossible! numOp1' on non-VNum " ++ show v numOp2 :: (Rational -> Rational -> Rational) -> Value -> Sem r Value numOp2 (#) = numOp2' $ \m n -> return (ratv (m # n)) @@ -496,9 +506,9 @@ res <- n1 # n2 case res of VNum _ r -> return $ VNum (d1 <> d2) r - _ -> return res - (VNum{}, _) -> error $ "Impossible! numOp2' on non-VNum " ++ show v2 - _ -> error $ "Impossible! numOp2' on non-VNum " ++ show v1 + _ -> return res + (VNum {}, _) -> error $ "Impossible! numOp2' on non-VNum " ++ show v2 + _ -> error $ "Impossible! numOp2' on non-VNum " ++ show v1 -- | Perform a square root operation. If the program typechecks, -- then the argument and output will really be Natural. @@ -551,15 +561,15 @@ compareBags [] [] = EQ compareBags [] _ = LT compareBags _ [] = GT -compareBags ((x, xn) : xs) ((y, yn) : ys) - = valCmp x y <> compare xn yn <> compareBags xs ys +compareBags ((x, xn) : xs) ((y, yn) : ys) = + valCmp x y <> compare xn yn <> compareBags xs ys compareMaps :: [(SimpleValue, Value)] -> [(SimpleValue, Value)] -> Ordering compareMaps [] [] = EQ compareMaps [] _ = LT compareMaps _ [] = GT -compareMaps ((k1, v1) : as1) ((k2, v2) : as2) - = valCmp (fromSimpleValue k1) (fromSimpleValue k2) <> valCmp v1 v2 <> compareMaps as1 as2 +compareMaps ((k1, v1) : as1) ((k2, v2) : as2) = + valCmp (fromSimpleValue k1) (fromSimpleValue k2) <> valCmp v1 v2 <> compareMaps as1 as2 ------------------------------------------------------------ -- Polynomial sequences [a,b,c,d .. e] @@ -577,16 +587,16 @@ | d > 0 = takeWhile (<= y) nums | d < 0 = takeWhile (>= y) nums | otherwise = nums - where - d = constdiff xs - nums = babbage xs + where + d = constdiff xs + nums = babbage xs -- | Extend a sequence infinitely by interpolating it as a polynomial -- sequence, via forward differences. Essentially the same -- algorithm used by Babbage's famous Difference Engine. babbage :: Num a => [a] -> [a] -babbage [] = [] -babbage [x] = repeat x +babbage [] = [] +babbage [x] = repeat x babbage (x : xs) = scanl (+) x (babbage (diff (x : xs))) -- | Compute the forward difference of the given sequence, that is, @@ -607,23 +617,23 @@ -- OEIS ------------------------------------------------------------ --- | Looks up a sequence of integers in OEIS. --- Returns 'left()' if the sequence is unknown in OEIS, --- otherwise 'right "https://oeis.org/"' -oeisLookup :: Value -> Value -oeisLookup (vlist vint -> ns) = maybe VNil parseResult (lookupSequence ns) - where - parseResult r = VInj R (listv charv ("https://oeis.org/" ++ seqNum r)) - seqNum = getCatalogNum . catalogNums +-- -- | Looks up a sequence of integers in OEIS. +-- -- Returns 'left()' if the sequence is unknown in OEIS, +-- -- otherwise 'right "https://oeis.org/"' +-- oeisLookup :: Value -> Value +-- oeisLookup (vlist vint -> ns) = maybe VNil parseResult (lookupSequence ns) +-- where +-- parseResult r = VInj R (listv charv ("https://oeis.org/" ++ seqNum r)) +-- seqNum = getCatalogNum . catalogNums - getCatalogNum [] = error "No catalog info" - getCatalogNum (n : _) = n +-- getCatalogNum [] = error "No catalog info" +-- getCatalogNum (n : _) = n --- | Extends a Disco integer list with data from a known OEIS --- sequence. Returns a list of integers upon success, otherwise the --- original list (unmodified). -oeisExtend :: Value -> Value -oeisExtend = listv intv . extendSequence . vlist vint +-- -- | Extends a Disco integer list with data from a known OEIS +-- -- sequence. Returns a list of integers upon success, otherwise the +-- -- original list (unmodified). +-- oeisExtend :: Value -> Value +-- oeisExtend = listv intv . extendSequence . vlist vint ------------------------------------------------------------ -- Normalizing bags/sets @@ -645,8 +655,8 @@ sortNCount [] = [] sortNCount [x] = [x] sortNCount xs = merge (+) (sortNCount firstHalf) (sortNCount secondHalf) - where - (firstHalf, secondHalf) = splitAt (length xs `div` 2) xs + where + (firstHalf, secondHalf) = splitAt (length xs `div` 2) xs -- | Generic function for merging two sorted, count-annotated lists of -- type @[(a,Integer)]@ a la merge sort, using the given comparison @@ -660,18 +670,18 @@ [(Value, Integer)] -> [(Value, Integer)] merge g = go - where - go [] [] = [] - go [] ((y, n) : ys) = mergeCons y 0 n (go [] ys) - go ((x, n) : xs) [] = mergeCons x n 0 (go xs []) - go ((x, n1) : xs) ((y, n2) : ys) = case valCmp x y of - LT -> mergeCons x n1 0 (go xs ((y, n2) : ys)) - EQ -> mergeCons x n1 n2 (go xs ys) - GT -> mergeCons y 0 n2 (go ((x, n1) : xs) ys) + where + go [] [] = [] + go [] ((y, n) : ys) = mergeCons y 0 n (go [] ys) + go ((x, n) : xs) [] = mergeCons x n 0 (go xs []) + go ((x, n1) : xs) ((y, n2) : ys) = case valCmp x y of + LT -> mergeCons x n1 0 (go xs ((y, n2) : ys)) + EQ -> mergeCons x n1 n2 (go xs ys) + GT -> mergeCons y 0 n2 (go ((x, n1) : xs) ys) - mergeCons a m1 m2 zs = case g m1 m2 of - 0 -> zs - n -> (a, n) : zs + mergeCons a m1 m2 zs = case g m1 m2 of + 0 -> zs + n -> (a, n) : zs mergeM :: Members '[Random, Error EvalError, State Mem] r => @@ -680,21 +690,21 @@ [(Value, Integer)] -> Sem r [(Value, Integer)] mergeM g = go - where - go [] [] = return [] - go [] ((y, n) : ys) = mergeCons y 0 n =<< go [] ys - go ((x, n) : xs) [] = mergeCons x n 0 =<< go xs [] - go ((x, n1) : xs) ((y, n2) : ys) = case valCmp x y of - LT -> mergeCons x n1 0 =<< go xs ((y, n2) : ys) - EQ -> mergeCons x n1 n2 =<< go xs ys - GT -> mergeCons y 0 n2 =<< go ((x, n1) : xs) ys + where + go [] [] = return [] + go [] ((y, n) : ys) = mergeCons y 0 n =<< go [] ys + go ((x, n) : xs) [] = mergeCons x n 0 =<< go xs [] + go ((x, n1) : xs) ((y, n2) : ys) = case valCmp x y of + LT -> mergeCons x n1 0 =<< go xs ((y, n2) : ys) + EQ -> mergeCons x n1 n2 =<< go xs ys + GT -> mergeCons y 0 n2 =<< go ((x, n1) : xs) ys - mergeCons a m1 m2 zs = do - nm <- evalApp g [VPair (intv m1) (intv m2)] - return $ case nm of - VNum _ 0 -> zs - VNum _ n -> (a, numerator n) : zs - v -> error $ "Impossible! merge function in mergeM returned non-VNum " ++ show v + mergeCons a m1 m2 zs = do + nm <- evalApp g [VPair (intv m1) (intv m2)] + return $ case nm of + VNum _ 0 -> zs + VNum _ n -> (a, numerator n) : zs + v -> error $ "Impossible! merge function in mergeM returned non-VNum " ++ show v ------------------------------------------------------------ -- Graphs @@ -702,14 +712,14 @@ graphSummary :: Graph SimpleValue -> Value graphSummary = toDiscoAdjMap . reifyGraph - where - reifyGraph :: Graph SimpleValue -> [(SimpleValue, [SimpleValue])] - reifyGraph = - AdjMap.adjacencyList . foldg AdjMap.empty AdjMap.vertex AdjMap.overlay AdjMap.connect + where + reifyGraph :: Graph SimpleValue -> [(SimpleValue, [SimpleValue])] + reifyGraph = + AdjMap.adjacencyList . foldg AdjMap.empty AdjMap.vertex AdjMap.overlay AdjMap.connect - toDiscoAdjMap :: [(SimpleValue, [SimpleValue])] -> Value - toDiscoAdjMap = - VMap . M.fromList . map (second (VBag . countValues . map fromSimpleValue)) + toDiscoAdjMap :: [(SimpleValue, [SimpleValue])] -> Value + toDiscoAdjMap = + VMap . M.fromList . map (second (VBag . countValues . map fromSimpleValue)) ------------------------------------------------------------ -- Propositions / tests @@ -717,66 +727,87 @@ resultToBool :: Member (Error EvalError) r => TestResult -> Sem r Value resultToBool (TestResult _ (TestRuntimeError e) _) = throw e -resultToBool (TestResult b _ _) = return $ enumv b +resultToBool (TestResult b _ _) = return $ enumv b notProp :: ValProp -> ValProp -notProp (VPDone r) = VPDone (invertPropResult r) +notProp (VPDone r) = VPDone (invertPropResult r) notProp (VPSearch sm tys p e) = VPSearch (invertMotive sm) tys p e +notProp (VPBin LAnd vp1 vp2) = VPBin LOr (notProp vp1) (notProp vp2) +notProp (VPBin LOr vp1 vp2) = VPBin LAnd (notProp vp1) (notProp vp2) +notProp (VPBin LImpl vp1 vp2) = VPBin LAnd vp1 (notProp vp2) -- | Convert a @Value@ to a @ValProp@, embedding booleans if necessary. ensureProp :: Value -> ValProp -ensureProp (VProp p) = p +ensureProp (VProp p) = p ensureProp (VInj L _) = VPDone (TestResult False TestBool emptyTestEnv) ensureProp (VInj R _) = VPDone (TestResult True TestBool emptyTestEnv) -ensureProp _ = error "ensureProp: non-prop value" +ensureProp _ = error "ensureProp: non-prop value" -testProperty - :: Members '[Random, State Mem] r - => SearchType -> Value -> Sem r TestResult +combineTestResultBool :: LOp -> TestResult -> TestResult -> Bool +combineTestResultBool op (TestResult b1 _ _) (TestResult b2 _ _) = interpLOp op b1 b2 + +testProperty :: + Members '[Random, State Mem] r => + SearchType -> + Value -> + Sem r TestResult testProperty initialSt = checkProp . ensureProp - where - checkProp - :: Members '[Random, State Mem] r - => ValProp -> Sem r TestResult - checkProp (VPDone r) = return r - checkProp (VPSearch sm tys f e) = - extendResultEnv e <$> (generateSamples initialSt vals >>= go) - where - vals = enumTypes tys - (SearchMotive (whenFound, wantsSuccess)) = sm + where + checkProp :: + Members '[Random, State Mem] r => + ValProp -> + Sem r TestResult + checkProp (VPDone r) = return r + checkProp (VPBin op vp1 vp2) = do + tr1 <- checkProp vp1 + tr2 <- checkProp vp2 + return $ TestResult (combineTestResultBool op tr1 tr2) (TestBin op tr1 tr2) emptyTestEnv + checkProp (VPSearch sm tys f e) = + extendResultEnv e <$> (generateSamples initialSt vals >>= go) + where + vals = enumTypes tys + (SearchMotive (whenFound, wantsSuccess)) = sm - go - :: Members '[Random, State Mem] r - => ([[Value]], SearchType) -> Sem r TestResult - go ([], st) = return $ TestResult (not whenFound) (TestNotFound st) emptyTestEnv - go (x:xs, st) = do - mprop <- runError (ensureProp <$> evalApp f x) - case mprop of - Left err -> return $ TestResult False (TestRuntimeError err) emptyTestEnv - Right (VPDone r) -> continue st xs r - Right prop -> checkProp prop >>= continue st xs + go :: + Members '[Random, State Mem] r => + ([[Value]], SearchType) -> + Sem r TestResult + go ([], st) = return $ TestResult (not whenFound) (TestNotFound st) emptyTestEnv + go (x : xs, st) = do + mprop <- runError (ensureProp <$> evalApp f x) + case mprop of + Left err -> return $ TestResult False (TestRuntimeError err) emptyTestEnv + Right (VPDone r) -> continue st xs r + Right prop -> checkProp prop >>= continue st xs - continue - :: Members '[Random, State Mem] r - => SearchType -> [[Value]] -> TestResult -> Sem r TestResult - continue st xs r@(TestResult _ _ e') - | testIsError r = return r - | testIsOk r == wantsSuccess = - return $ TestResult whenFound (TestFound r) e' - | otherwise = go (xs, st) + continue :: + Members '[Random, State Mem] r => + SearchType -> + [[Value]] -> + TestResult -> + Sem r TestResult + continue st xs r@(TestResult _ _ e') + | testIsError r = return r + | testIsOk r == wantsSuccess = + return $ TestResult whenFound (TestFound r) e' + | otherwise = go (xs, st) -evalApp - :: Members '[Random, Error EvalError, State Mem] r - => Value -> [Value] -> Sem r Value +evalApp :: + Members '[Random, Error EvalError, State Mem] r => + Value -> + [Value] -> + Sem r Value evalApp f xs = runFresh (runCESK (Out f (map FArgV xs))) >>= either throw return -runTest - :: Members '[Random, Error EvalError, Input Env, State Mem] r - => Int -> AProperty -> Sem r TestResult +runTest :: + Members '[Random, Error EvalError, Input Env, State Mem] r => + Int -> + AProperty -> + Sem r TestResult runTest n p = testProperty (Randomized n' n') =<< eval (compileProperty p) - where - n' = fromIntegral (n `div` 2) + where + n' = fromIntegral (n `div` 2) ------------------------------------------------------------ -- Top-level evaluation diff --git a/src/Disco/Messages.hs b/src/Disco/Messages.hs --- a/src/Disco/Messages.hs +++ b/src/Disco/Messages.hs @@ -1,7 +1,10 @@ -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Disco.Messages -- Copyright : disco team and contributors @@ -11,53 +14,50 @@ -- -- Message logging framework (e.g. for errors, warnings, etc.) for -- disco. --- ------------------------------------------------------------------------------ - module Disco.Messages where -import Control.Lens -import Control.Monad (when) -import Polysemy -import Polysemy.Output +import Control.Lens +import Control.Monad (when) +import Polysemy +import Polysemy.Output -import Disco.Pretty (Doc, Pretty, pretty', renderDoc') +import Disco.Pretty (Doc, Pretty, pretty', renderDoc') data MessageType - = Info - | Warning - | ErrMsg - | Debug - deriving (Show, Read, Eq, Ord, Enum, Bounded) + = Info + | Warning + | ErrMsg + | Debug + deriving (Show, Read, Eq, Ord, Enum, Bounded) -data Message = Message {_messageType :: MessageType, _message :: Doc} - deriving (Show) +data Message ann = Message {_messageType :: MessageType, _message :: (Doc ann)} + deriving (Show) makeLenses ''Message -handleMsg :: Member (Embed IO) r => (Message -> Bool) -> Message -> Sem r () +handleMsg :: Member (Embed IO) r => (Message ann -> Bool) -> Message ann -> Sem r () handleMsg p m = when (p m) $ printMsg m -printMsg :: Member (Embed IO) r => Message -> Sem r () +printMsg :: Member (Embed IO) r => Message ann -> Sem r () printMsg (Message _ m) = embed $ putStrLn (renderDoc' m) -msg :: Member (Output Message) r => MessageType -> Sem r Doc -> Sem r () +msg :: Member (Output (Message ann)) r => MessageType -> Sem r (Doc ann) -> Sem r () msg typ m = m >>= output . Message typ -info :: Member (Output Message) r => Sem r Doc -> Sem r () +info :: Member (Output (Message ann)) r => Sem r (Doc ann) -> Sem r () info = msg Info -infoPretty :: (Member (Output Message) r, Pretty t) => t -> Sem r () +infoPretty :: (Member (Output (Message ann)) r, Pretty t) => t -> Sem r () infoPretty = info . pretty' -warn :: Member (Output Message) r => Sem r Doc -> Sem r () +warn :: Member (Output (Message ann)) r => Sem r (Doc ann) -> Sem r () warn = msg Warning -debug :: Member (Output Message) r => Sem r Doc -> Sem r () +debug :: Member (Output (Message ann)) r => Sem r (Doc ann) -> Sem r () debug = msg Debug -debugPretty :: (Member (Output Message) r, Pretty t) => t -> Sem r () +debugPretty :: (Member (Output (Message ann)) r, Pretty t) => t -> Sem r () debugPretty = debug . pretty' -err :: Member (Output Message) r => Sem r Doc -> Sem r () +err :: Member (Output (Message ann)) r => Sem r (Doc ann) -> Sem r () err = msg ErrMsg diff --git a/src/Disco/Module.hs b/src/Disco/Module.hs --- a/src/Disco/Module.hs +++ b/src/Disco/Module.hs @@ -1,10 +1,13 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Disco.Module -- Copyright : (c) 2019 disco team (see LICENSE) @@ -14,43 +17,52 @@ -- -- The 'ModuleInfo' record representing a disco module, and functions -- to resolve the location of a module on disk. ------------------------------------------------------------------------------ - module Disco.Module where -import Data.Data (Data) -import GHC.Generics (Generic) +import Data.Data (Data) +import GHC.Generics (Generic) -import Control.Lens (Getting, foldOf, - makeLenses, view) -import Control.Monad (filterM) -import Control.Monad.IO.Class (MonadIO (..)) -import Data.Bifunctor (first) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (listToMaybe) -import qualified Data.Set as S -import System.Directory (doesFileExist) -import System.FilePath (replaceExtension, - ()) +import Control.Lens ( + Getting, + foldOf, + makeLenses, + view, + ) +import Control.Monad (filterM) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Bifunctor (first) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (listToMaybe) +import qualified Data.Set as S +import System.Directory (doesFileExist) +import System.FilePath ( + replaceExtension, + (), + ) -import Unbound.Generics.LocallyNameless (Alpha, Bind, Name, - Subst, bind) -import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) +import Unbound.Generics.LocallyNameless ( + Alpha, + Bind, + Name, + Subst, + bind, + ) +import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) -import Polysemy +import Polysemy -import Disco.AST.Surface -import Disco.AST.Typed -import Disco.Context -import Disco.Extensions -import Disco.Names -import Disco.Pretty hiding ((<>)) -import Disco.Typecheck.Erase (erase, erasePattern) -import Disco.Typecheck.Util (TyCtx) -import Disco.Types +import Disco.AST.Surface +import Disco.AST.Typed +import Disco.Context +import Disco.Extensions +import Disco.Names +import Disco.Pretty hiding ((<>)) +import Disco.Typecheck.Erase (erase, erasePattern) +import Disco.Typecheck.Util (TyCtx) +import Disco.Types -import Paths_disco +import Paths_disco ------------------------------------------------------------ -- ModuleInfo and related types @@ -76,10 +88,10 @@ deriving (Show, Generic, Alpha, Data, Subst Type) instance Pretty Defn where - pretty (Defn x patTys ty clauses) = vcat $ - prettyTyDecl x (foldr (:->:) ty patTys) - : - map (pretty . (x,) . eraseClause) clauses + pretty (Defn x patTys ty clauses) = + vcat $ + prettyTyDecl x (foldr (:->:) ty patTys) + : map (pretty . (x,) . eraseClause) clauses -- | A clause in a definition consists of a list of patterns (the LHS -- of the =) and a term (the RHS). For example, given the concrete @@ -89,31 +101,31 @@ eraseClause :: Clause -> Bind [Pattern] Term eraseClause b = bind (map erasePattern ps) (erase t) - where (ps, t) = unsafeUnbind b + where + (ps, t) = unsafeUnbind b -- | Type checking a module yields a value of type ModuleInfo which contains -- mapping from terms to their relavent documenation, a mapping from terms to -- properties, and a mapping from terms to their types. data ModuleInfo = ModuleInfo - { _miName :: ModuleName - , _miImports :: Map ModuleName ModuleInfo - - -- List of names declared by the module, in the order they occur - , _miNames :: [QName Term] - , _miDocs :: Ctx Term Docs - , _miProps :: Ctx ATerm [AProperty] - , _miTys :: TyCtx - , _miTydefs :: TyDefCtx + { _miName :: ModuleName + , _miImports :: Map ModuleName ModuleInfo + , -- List of names declared by the module, in the order they occur + _miNames :: [QName Term] + , _miDocs :: Ctx Term Docs + , _miProps :: Ctx ATerm [AProperty] + , _miTys :: TyCtx + , _miTydefs :: TyDefCtx , _miTermdefs :: Ctx ATerm Defn - , _miTerms :: [(ATerm, PolyType)] - , _miExts :: ExtSet + , _miTerms :: [(ATerm, PolyType)] + , _miExts :: ExtSet } deriving (Show) makeLenses ''ModuleInfo instance Semigroup ModuleInfo where - -- | Two ModuleInfos + -- \| Two ModuleInfos -- are merged by joining their doc, type, type definition, and term -- contexts. The property context of the new module is the one -- obtained from the second module. The name of the new module is @@ -121,8 +133,8 @@ -- earlier ones. Note that this function should really only be used -- for the special top-level REPL module. ModuleInfo n1 is1 ns1 d1 _ ty1 tyd1 tm1 tms1 es1 - <> ModuleInfo _ is2 ns2 d2 p2 ty2 tyd2 tm2 tms2 es2 - = ModuleInfo + <> ModuleInfo _ is2 ns2 d2 p2 ty2 tyd2 tm2 tms2 es2 = + ModuleInfo n1 (is1 <> is2) (ns1 <> ns2) @@ -178,7 +190,7 @@ -- `:load`ed module). withStdlib :: Resolver -> Resolver withStdlib (FromDir fp) = FromDirOrStdlib fp -withStdlib r = r +withStdlib r = r -- | Given a module resolution mode and a raw module name, relavent -- directories are searched for the file containing the provided @@ -189,9 +201,9 @@ datadir <- liftIO getDataDir let searchPath = case resolver of - FromStdlib -> [(datadir, Stdlib)] - FromDir dir -> [(dir, Dir dir)] - FromCwdOrStdlib -> [(datadir, Stdlib), (".", Dir ".")] + FromStdlib -> [(datadir, Stdlib)] + FromDir dir -> [(dir, Dir dir)] + FromCwdOrStdlib -> [(datadir, Stdlib), (".", Dir ".")] FromDirOrStdlib dir -> [(datadir, Stdlib), (dir, Dir dir)] let fps = map (first ( replaceExtension modname "disco")) searchPath fexists <- liftIO $ filterM (doesFileExist . fst) fps diff --git a/src/Disco/Names.hs b/src/Disco/Names.hs --- a/src/Disco/Names.hs +++ b/src/Disco/Names.hs @@ -1,39 +1,48 @@ -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + +-- SPDX-License-Identifier: BSD-3-Clause + -- | -- Module : Disco.Names -- Copyright : disco team and contributors -- Maintainer : byorgey@gmail.com -- -- Names for modules and identifiers. --- ------------------------------------------------------------------------------ +module Disco.Names ( + -- * Modules and their provenance + ModuleProvenance (..), + ModuleName (..), --- SPDX-License-Identifier: BSD-3-Clause + -- * Names and their provenance + NameProvenance (..), + QName (..), + isFree, + localName, + (.-), -module Disco.Names - ( -- * Modules and their provenance - ModuleProvenance(..), ModuleName(..) - -- * Names and their provenance - , NameProvenance(..), QName(..), isFree, localName, (.-) - -- * Name-related utilities - , fvQ, substQ, substsQ - ) where + -- * Name-related utilities + fvQ, + substQ, + substsQ, +) where -import Control.Lens (Traversal', filtered) -import Data.Data (Data) -import Data.Data.Lens (template) -import Data.Typeable (Typeable) -import GHC.Generics (Generic) -import Prelude hiding ((<>)) -import System.FilePath (dropExtension) -import Unbound.Generics.LocallyNameless +import Control.Lens (Traversal', filtered) +import Data.Data (Data) +import Data.Data.Lens (template) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import System.FilePath (dropExtension) +import Unbound.Generics.LocallyNameless +import Prelude hiding ((<>)) -import Disco.Pretty -import Disco.Types +import Disco.Pretty +import Disco.Types ------------------------------------------------------------ -- Modules @@ -41,16 +50,19 @@ -- | Where did a module come from? data ModuleProvenance - = Dir FilePath -- ^ From a particular directory (relative to cwd) - | Stdlib -- ^ From the standard library + = -- | From a particular directory (relative to cwd) + Dir FilePath + | -- | From the standard library + Stdlib deriving (Eq, Ord, Show, Generic, Data, Alpha, Subst Type) -- | The name of a module. data ModuleName - = REPLModule -- ^ The special top-level "module" consisting of - -- what has been entered at the REPL. - | Named ModuleProvenance String - -- ^ A named module, with its name and provenance. + = -- | The special top-level "module" consisting of + -- what has been entered at the REPL. + REPLModule + | -- | A named module, with its name and provenance. + Named ModuleProvenance String deriving (Eq, Ord, Show, Generic, Data, Alpha, Subst Type) ------------------------------------------------------------ @@ -59,19 +71,21 @@ -- | Where did a name come from? data NameProvenance - = LocalName -- ^ The name is locally bound - | QualifiedName ModuleName -- ^ The name is exported by the given module + = -- | The name is locally bound + LocalName + | -- | The name is exported by the given module + QualifiedName ModuleName deriving (Eq, Ord, Show, Generic, Data, Alpha, Subst Type) -- | A @QName@, or qualified name, is a 'Name' paired with its -- 'NameProvenance'. -data QName a = QName { qnameProvenance :: NameProvenance, qname :: Name a } +data QName a = QName {qnameProvenance :: NameProvenance, qname :: Name a} deriving (Eq, Ord, Show, Generic, Data, Alpha, Subst Type) -- | Does this name correspond to a free variable? isFree :: QName a -> Bool isFree (QName (QualifiedName _) _) = True -isFree (QName LocalName n) = isFreeName n +isFree (QName LocalName n) = isFreeName n -- | Create a locally bound qualified name. localName :: Name a -> QName a @@ -88,7 +102,7 @@ -- | The @unbound-generics@ library gives us free variables for free. -- But when dealing with typed and desugared ASTs, we want all the -- free 'QName's instead of just 'Name's. -fvQ :: (Data t, Typeable e) => Traversal' t (QName e) +fvQ :: (Data t, Typeable e) => Traversal' t (QName e) fvQ = template . filtered isFree substQ :: Subst b a => QName b -> b -> a -> a @@ -102,10 +116,10 @@ ------------------------------------------------------------ instance Pretty ModuleName where - pretty REPLModule = "REPL" + pretty REPLModule = "REPL" pretty (Named (Dir _) s) = text (dropExtension s) - pretty (Named Stdlib s) = text (dropExtension s) + pretty (Named Stdlib s) = text (dropExtension s) instance Pretty (QName a) where - pretty (QName LocalName x) = pretty x + pretty (QName LocalName x) = pretty x pretty (QName (QualifiedName mn) x) = pretty mn <> "." <> pretty x diff --git a/src/Disco/Parser.hs b/src/Disco/Parser.hs --- a/src/Disco/Parser.hs +++ b/src/Disco/Parser.hs @@ -1,1093 +1,1263 @@ {-# LANGUAGE TemplateHaskell #-} ------------------------------------------------------------------------------ --- | --- Module : Disco.Parser --- Copyright : disco team and contributors --- Maintainer : byorgey@gmail.com --- --- SPDX-License-Identifier: BSD-3-Clause --- --- Parser to convert concrete Disco syntax into an (untyped, surface --- language) AST. --- ------------------------------------------------------------------------------ - -module Disco.Parser - ( -- * Parser type and utilities - DiscoParseError(..), Parser, runParser, withExts, indented, thenIndented - - -- * Lexer - - -- ** Basic lexemes - , sc, lexeme, symbol, reservedOp - , natural, reserved, reservedWords, ident - - -- ** Punctuation - , parens, braces, angles, brackets - , semi, comma, colon, dot, pipe - , lambda - - -- * Disco parser - - -- ** Modules - , wholeModule, parseModule, parseExtName, parseTopLevel, parseDecl - , parseImport, parseModuleName - - -- ** Terms - , term, parseTerm, parseTerm', parseExpr, parseAtom - , parseContainer, parseEllipsis, parseContainerComp, parseQual - , parseLet, parseTypeOp - - -- ** Case and patterns - , parseCase, parseBranch, parseGuards, parseGuard - , parsePattern, parseAtomicPattern - - -- ** Types - , parseType, parseAtomicType - , parsePolyTy - ) - where - -import Unbound.Generics.LocallyNameless (Name, bind, embed, - fvAny, string2Name) -import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) - -import Control.Monad.Combinators.Expr -import Text.Megaparsec hiding (runParser) -import qualified Text.Megaparsec as MP -import Text.Megaparsec.Char -import qualified Text.Megaparsec.Char.Lexer as L - -import Control.Lens (makeLenses, toListOf, - use, (%=), (%~), (&), - (.=)) -import Control.Monad.State -import Data.Char (isAlpha, isDigit) -import Data.Foldable (asum) -import Data.List (find, intercalate) -import qualified Data.Map as M -import Data.Maybe (fromMaybe) -import Data.Ratio -import Data.Set (Set) -import qualified Data.Set as S - -import Disco.AST.Surface -import Disco.Extensions -import Disco.Module -import Disco.Pretty (prettyStr) -import Disco.Syntax.Operators -import Disco.Syntax.Prims -import Disco.Types -import Polysemy (run) - ------------------------------------------------------------- --- Lexer - --- Some of the basic setup code for the parser taken from --- https://markkarpov.com/megaparsec/parsing-simple-imperative-language.html - --- | Currently required indent level. -data IndentMode where - NoIndent :: IndentMode -- ^ Don't require indent. - ThenIndent :: IndentMode -- ^ Parse one token without - -- indent, then switch to @Indent@. - Indent :: IndentMode -- ^ Require everything to be indented at - -- least one space. - --- | Extra custom state for the parser. -data ParserState = ParserState - { _indentMode :: IndentMode -- ^ Currently required level of indentation. - , _enabledExts :: Set Ext -- ^ Set of enabled language extensions - -- (some of which may affect parsing). - } - -makeLenses ''ParserState - -initParserState :: ParserState -initParserState = ParserState NoIndent S.empty - --- OpaqueTerm is a wrapper around Term just to make ShowErrorComponent --- happy, which requires Eq and Ord instances; but we can't make Term --- an instance of either. -newtype OpaqueTerm = OT Term -instance Show OpaqueTerm where - show (OT t) = show t -instance Eq OpaqueTerm where - _ == _ = True -instance Ord OpaqueTerm where - compare _ _ = EQ - -data DiscoParseError - = ReservedVarName String - | InvalidPattern OpaqueTerm - deriving (Show, Eq, Ord) - -instance ShowErrorComponent DiscoParseError where - showErrorComponent (ReservedVarName x) = "keyword \"" ++ x ++ "\" cannot be used as a variable name" - showErrorComponent (InvalidPattern (OT t)) = "Invalid pattern: " ++ run (prettyStr t) - errorComponentLen (ReservedVarName x) = length x - errorComponentLen (InvalidPattern _) = 1 - --- | A parser is a megaparsec parser of strings, with an extra layer --- of state to keep track of the current indentation level and --- language extensions, and some custom error messages. -type Parser = StateT ParserState (MP.Parsec DiscoParseError String) - --- | Run a parser from the initial state. -runParser :: Parser a -> FilePath -> String -> Either (ParseErrorBundle String DiscoParseError) a -runParser = MP.runParser . flip evalStateT initParserState - --- | Run a parser under a specified 'IndentMode'. -withIndentMode :: IndentMode -> Parser a -> Parser a -withIndentMode m p = do - indentMode .= m - res <- p - indentMode .= NoIndent - return res - --- | @indented p@ is just like @p@, except that every token must not --- start in the first column. -indented :: Parser a -> Parser a -indented = withIndentMode Indent - --- | @indented p@ is just like @p@, except that every token after the --- first must not start in the first column. -thenIndented :: Parser a -> Parser a -thenIndented = withIndentMode ThenIndent - --- | @requireIndent p@ possibly requires @p@ to be indented, depending --- on the current '_indentMode'. Used in the definition of --- 'lexeme' and 'symbol'. -requireIndent :: Parser a -> Parser a -requireIndent p = do - l <- use indentMode - case l of - ThenIndent -> do - a <- p - indentMode .= Indent - return a - Indent -> L.indentGuard sc GT pos1 >> p - NoIndent -> p - --- | Locally set the enabled extensions within a subparser. -withExts :: Set Ext -> Parser a -> Parser a -withExts exts p = do - oldExts <- use enabledExts - enabledExts .= exts - a <- p - enabledExts .= oldExts - return a - --- | Locally enable some additional extensions within a subparser. -withAdditionalExts :: Set Ext -> Parser a -> Parser a -withAdditionalExts exts p = do - oldExts <- use enabledExts - enabledExts %= S.union exts - a <- p - enabledExts .= oldExts - return a - --- | Ensure that a specific extension is enabled, fail if not. -ensureEnabled :: Ext -> Parser () -ensureEnabled e = do - exts <- use enabledExts - guard $ e `S.member` exts - --- | Generically consume whitespace, including comments. -sc :: Parser () -sc = L.space space1 lineComment empty {- no block comments in disco -} - where - lineComment = L.skipLineComment "--" - --- | Parse a lexeme, that is, a parser followed by consuming --- whitespace. -lexeme :: Parser a -> Parser a -lexeme p = requireIndent $ L.lexeme sc p - --- | Parse a given string as a lexeme. -symbol :: String -> Parser String -symbol s = requireIndent $ L.symbol sc s - --- | Parse a reserved operator. -reservedOp :: String -> Parser () -reservedOp s = (lexeme . try) (string s *> notFollowedBy (oneOf opChar)) - --- | Characters that can occur in an operator symbol. -opChar :: [Char] -opChar = "~!@#$%^&*-+=|<>?/\\." - -parens, braces, angles, brackets, bagdelims, fbrack, cbrack :: Parser a -> Parser a -parens = between (symbol "(") (symbol ")") -braces = between (symbol "{") (symbol "}") -angles = between (symbol "<") (symbol ">") -brackets = between (symbol "[") (symbol "]") -bagdelims = between (symbol "⟅") (symbol "⟆") -fbrack = between (symbol "⌊") (symbol "⌋") -cbrack = between (symbol "⌈") (symbol "⌉") - -semi, comma, colon, dot, pipe, hash :: Parser String -semi = symbol ";" -comma = symbol "," -colon = symbol ":" -dot = symbol "." -pipe = symbol "|" -hash = symbol "#" - --- | A literal ellipsis of two or more dots, @..@ -ellipsis :: Parser String -ellipsis = label "ellipsis (..)" $ concat <$> ((:) <$> dot <*> some dot) - --- | The symbol that starts an anonymous function (either a backslash --- or a Greek λ). -lambda :: Parser String -lambda = symbol "\\" <|> symbol "λ" - -forall :: Parser () -forall = () <$ symbol "∀" <|> reserved "forall" - -exists :: Parser () -exists = () <$ symbol "∃" <|> reserved "exists" - --- | Parse a natural number. -natural :: Parser Integer -natural = lexeme L.decimal "natural number" - --- | Parse a nonnegative decimal of the form @xxx.yyyy[zzz]@, where --- the @y@s and bracketed @z@s are both optional as long as the --- other is present. (In other words, there must be something after --- the period.) For example, this parser accepts all of the --- following: --- --- > 2.0 --- > 2.333 --- > 2.33[45] --- > 2.[45] --- --- The idea is that brackets surround an infinitely repeating --- sequence of digits. --- --- We used to accept @2.@ with no trailing digits, but no longer do. --- See https://github.com/disco-lang/disco/issues/245 and Note --- [Trailing period]. -decimal :: Parser Rational -decimal = lexeme (readDecimal <$> some digit <* char '.' - <*> fractionalPart - ) - where - digit = satisfy isDigit - fractionalPart = - -- either some digits optionally followed by bracketed digits... - (,) <$> some digit <*> optional (brackets (some digit)) - -- ...or just bracketed digits. - <|> ([],) <$> (Just <$> brackets (some digit)) - - readDecimal a (b, mrep) - = read a % 1 -- integer part - - -- next part is just b/10^n - + (if null b then 0 else read b) % (10^length b) - - -- repeating part - + readRep (length b) mrep - - readRep _ Nothing = 0 - readRep offset (Just rep) = read rep % (10^offset * (10^length rep - 1)) - -- If s = 0.[rep] then 10^(length rep) * s = rep.[rep], so - -- 10^(length rep) * s - s = rep, so - -- - -- s = rep/(10^(length rep) - 1). - -- - -- We also have to divide by 10^(length b) to shift it over - -- past any non-repeating prefix. - --- ~~~~ Note [Trailing period] --- --- We used to accept numbers with nothing after the trailing period, --- such as @2.@. However, this caused some problems with parsing: --- --- - First, https://github.com/disco-lang/disco/issues/99 which we --- solved by making sure there was not another period after the --- trailing period. --- - Next, https://github.com/disco-lang/disco/issues/245. --- --- I first tried solving #245 by disallowing *any* operator character --- after the trailing period, but then some tests in the test suite --- started failing, where we had written things like @1./(10^5)@. The --- problem is that when a period is followed by another operator --- symbol, sometimes we might want them to be parsed as an operator --- (as in @2.-4@, #245), and sometimes we might not (as in --- @1./(10^5)@). So in the end it seems simpler and cleaner to --- require at least a 0 digit after the period --- just like pretty --- much every other programming language and just like standard --- mathematical practice. - --- | Parse a reserved word. -reserved :: String -> Parser () -reserved w = (lexeme . try) $ string w *> notFollowedBy alphaNumChar - --- | The list of all reserved words. -reservedWords :: [String] -reservedWords = - [ "unit", "true", "false", "True", "False", "let", "in", "is" - , "if", "when" - , "otherwise", "and", "or", "mod", "choose", "implies", "iff" - , "min", "max" - , "union", "∪", "intersect", "∩", "subset", "⊆", "elem", "∈" - , "enumerate", "count", "divides" - , "Void", "Unit", "Bool", "Boolean", "Proposition", "Prop", "Char" - , "Nat", "Natural", "Int", "Integer", "Frac", "Fractional", "Rational", "Fin" - , "List", "Bag", "Set", "Graph", "Map" - , "N", "Z", "F", "Q", "ℕ", "ℤ", "𝔽", "ℚ" - , "∀", "forall", "∃", "exists", "type" - , "import", "using" - ] - --- | Parse an identifier, i.e. any non-reserved string beginning with --- a given type of character and continuing with alphanumerics, --- underscores, and apostrophes. -identifier :: Parser Char -> Parser String -identifier begin = (lexeme . try) (p >>= check) "variable name" - where - p = (:) <$> begin <*> many identChar - identChar = alphaNumChar <|> oneOf "_'" - check x - | x `elem` reservedWords = do - -- back up to beginning of bad token to report correct position - updateParserState (\s -> s { stateOffset = stateOffset s - length x }) - customFailure $ ReservedVarName x - | otherwise = return x - --- | Parse an 'identifier' and turn it into a 'Name'. -ident :: Parser (Name Term) -ident = string2Name <$> identifier letterChar - ------------------------------------------------------------- --- Parser - --- | Results from parsing a block of top-level things. -data TLResults = TLResults - { _tlDecls :: [Decl] - , _tlDocs :: [(Name Term, [DocThing])] - , _tlTerms :: [Term] - } - -emptyTLResults :: TLResults -emptyTLResults = TLResults [] [] [] - -makeLenses ''TLResults - --- | Parse the entire input as a module (with leading whitespace and --- no leftovers). -wholeModule :: LoadingMode -> Parser Module -wholeModule = between sc eof . parseModule - --- | Parse an entire module (a list of declarations ended by --- semicolons). The 'LoadingMode' parameter tells us whether to --- include or replace any language extensions enabled at the top --- level. We include them when parsing a module entered at the --- REPL, and replace them when parsing a standalone module. -parseModule :: LoadingMode -> Parser Module -parseModule mode = do - exts <- S.fromList <$> many parseExtension - let extFun = case mode of - Standalone -> withExts - REPL -> withAdditionalExts - - extFun exts $ do - imports <- many parseImport - topLevel <- many parseTopLevel - let theMod = mkModule exts imports topLevel - return theMod - where - groupTLs :: [DocThing] -> [TopLevel] -> TLResults - groupTLs _ [] = emptyTLResults - groupTLs revDocs (TLDoc doc : rest) - = groupTLs (doc : revDocs) rest - groupTLs revDocs (TLDecl decl@(DType (TypeDecl x _)) : rest) - = groupTLs [] rest - & tlDecls %~ (decl :) - & tlDocs %~ ((x, reverse revDocs) :) - groupTLs revDocs (TLDecl decl@(DTyDef (TypeDefn x _ _)) : rest) - = groupTLs [] rest - & tlDecls %~ (decl :) - & tlDocs %~ ((string2Name x, reverse revDocs) :) - groupTLs _ (TLDecl defn : rest) - = groupTLs [] rest - & tlDecls %~ (defn :) - groupTLs _ (TLExpr t : rest) - = groupTLs [] rest & tlTerms %~ (t:) - - defnGroups :: [Decl] -> [Decl] - defnGroups [] = [] - defnGroups (d@DType{} : ds) = d : defnGroups ds - defnGroups (d@DTyDef{} : ds) = d : defnGroups ds - defnGroups (DDefn (TermDefn x bs) : ds) = DDefn (TermDefn x (bs ++ concatMap (\(TermDefn _ cs) -> cs) grp)) : defnGroups rest - where - (grp, rest) = matchDefn ds - matchDefn :: [Decl] -> ([TermDefn], [Decl]) - matchDefn (DDefn t@(TermDefn x' _) : ds2) | x == x' = (t:ts, ds2') - where - (ts, ds2') = matchDefn ds2 - matchDefn ds2 = ([], ds2) - - mkModule exts imps tls = Module exts imps (defnGroups decls) docs terms - where - TLResults decls docs terms = groupTLs [] tls - --- | Parse an extension. -parseExtension :: Parser Ext -parseExtension = L.nonIndented sc $ - reserved "using" *> parseExtName - --- | Parse the name of a language extension (case-insensitive). -parseExtName :: Parser Ext -parseExtName = choice (map parseOneExt allExtsList) "language extension name" - where - parseOneExt ext = ext <$ lexeme (string' (show ext) :: Parser String) - --- | Parse an import, of the form @import @. -parseImport :: Parser String -parseImport = L.nonIndented sc $ - reserved "import" *> parseModuleName - --- | Parse the name of a module. -parseModuleName :: Parser String -parseModuleName = lexeme $ - intercalate "/" <$> (some (alphaNumChar <|> oneOf "_-") `sepBy` char '/') <* optional (string ".disco") - --- | Parse a top level item (either documentation or a declaration), --- which must start at the left margin. -parseTopLevel :: Parser TopLevel -parseTopLevel = L.nonIndented sc $ - TLDoc <$> parseDocThing - <|> TLDecl <$> parseDecl -- See Note [Parsing definitions and top-level expressions] - <|> TLExpr <$> thenIndented parseTerm - - -- ~~~~ Note [Parsing definitions and top-level expressions] - -- - -- The beginning of a definition might look the same as an - -- expression. e.g. is f(x,y) the start of a definition of f, or an - -- expression with a function call? We used to therefore wrap - -- 'parseDecl' in 'try'. The problem is that if a definition has a - -- syntax error on the RHS, it would fail, backtrack, then try - -- parsing a top-level expression and fail when it got to the = - -- sign, giving an uninformative parse error message. - -- See https://github.com/disco-lang/disco/issues/346. - -- - -- The solution is that we now do more careful backtracking within - -- parseDecl itself: when parsing a definition, we only backtrack if - -- we don't get a complete LHS + '=' sign; once we start parsing the - -- RHS of a definition we no longer backtrack, since it can't - -- possibly be a valid top-level expression. - --- | Parse a documentation item: either a group of lines beginning --- with @|||@ (text documentation), or a group beginning with @!!!@ --- (checked examples/properties). -parseDocThing :: Parser DocThing -parseDocThing - = DocString <$> some parseDocString - <|> DocProperty <$> parseProperty - --- | Parse one line of documentation beginning with @|||@. -parseDocString :: Parser String -parseDocString = label "documentation" $ L.nonIndented sc $ - string "|||" - *> takeWhileP Nothing (`elem` " \t") - *> takeWhileP Nothing (`notElem` "\r\n") <* sc - - -- Note we use string "|||" rather than symbol "|||" because we - -- don't want it to consume whitespace afterwards (in particular a - -- line with ||| by itself would cause symbol "|||" to consume the - -- newline). - --- | Parse a top-level property/unit test, of the form --- --- @!!! forall x1 : ty1, ..., xn : tyn. term@. --- --- The forall is optional. -parseProperty :: Parser Term -parseProperty = label "property" $ L.nonIndented sc $ do - _ <- symbol "!!!" - indented parseTerm - --- | Parse a single top-level declaration (either a type declaration --- or single definition clause). -parseDecl :: Parser Decl -parseDecl = try (DType <$> parseTyDecl) <|> DDefn <$> parseDefn <|> DTyDef <$> parseTyDefn - --- | Parse a top-level type declaration of the form @x : ty@. -parseTyDecl :: Parser TypeDecl -parseTyDecl = label "type declaration" $ - TypeDecl <$> ident <*> indented (colon *> parsePolyTy) - --- | Parse a definition of the form @x pat1 .. patn = t@. -parseDefn :: Parser TermDefn -parseDefn = label "definition" $ - (\(x, ps) body -> TermDefn x [bind ps body]) - - -- Only backtrack if we don't get a complete 'LHS ='. Once we see - -- an = sign, commit to parsing a definition, because it can't be a - -- valid standalone expression anymore. If the RHS fails, we don't - -- want to backtrack, we just want to display the parse error. - <$> try ((,) <$> ident <*> indented (many parseAtomicPattern) <* reservedOp "=") - <*> indented parseTerm - --- | Parse the definition of a user-defined algebraic data type. -parseTyDefn :: Parser TypeDefn -parseTyDefn = label "type defintion" $ do - reserved "type" - indented $ do - name <- parseTyDef - args <- fromMaybe [] <$> optional (parens $ parseTyVarName `sepBy1` comma) - _ <- reservedOp "=" - TypeDefn name args <$> parseType - --- | Parse the entire input as a term (with leading whitespace and --- no leftovers). -term :: Parser Term -term = between sc eof parseTerm - --- | Parse a term, consisting of a @parseTerm'@ optionally --- followed by an ascription. -parseTerm :: Parser Term -parseTerm = -- trace "parseTerm" $ - ascribe <$> parseTerm' <*> optional (label "type annotation" $ colon *> parsePolyTy) - where - ascribe t Nothing = t - ascribe t (Just ty) = TAscr t ty - --- | Parse a non-atomic, non-ascribed term. -parseTerm' :: Parser Term -parseTerm' = label "expression" $ - parseQuantified - <|> parseLet - <|> parseExpr - <|> parseAtom - --- | Parse an atomic term. -parseAtom :: Parser Term -parseAtom = label "expression" $ - parseUnit - <|> TBool True <$ (reserved "true" <|> reserved "True") - <|> TBool False <$ (reserved "false" <|> reserved "False") - <|> TChar <$> lexeme (between (char '\'') (char '\'') L.charLiteral) - <|> TString <$> lexeme (char '"' >> manyTill L.charLiteral (char '"')) - <|> TWild <$ try parseWild - <|> TPrim <$> try parseStandaloneOp - - -- Note primitives are NOT reserved words, so they are just parsed - -- as identifiers. This means that it is possible to shadow a - -- primitive in a local context, as it should be. Vars are turned - -- into prims at scope-checking time: if a var is not in scope but - -- there is a prim of that name then it becomes a TPrim. See the - -- 'typecheck Infer (TVar x)' case in Disco.Typecheck. - <|> TVar <$> ident - <|> TPrim <$> (ensureEnabled Primitives *> parsePrim) - <|> TRat <$> try decimal - <|> TNat <$> natural - <|> parseTypeOp - <|> TApp (TPrim PrimFloor) . TParens <$> fbrack parseTerm - <|> TApp (TPrim PrimCeil) . TParens <$> cbrack parseTerm - <|> parseCase - <|> try parseAbs - <|> bagdelims (parseContainer BagContainer) - <|> braces (parseContainer SetContainer) - <|> brackets (parseContainer ListContainer) - <|> tuple <$> parens (parseTerm `sepBy1` comma) - -parseAbs :: Parser Term -parseAbs = TApp (TPrim PrimAbs) <$> (pipe *> parseTerm <* pipe) - -parseUnit :: Parser Term -parseUnit = TUnit <$ (reserved "unit" <|> void (symbol "■")) - --- | Parse a wildcard, which is an underscore that isn't the start of --- an identifier. -parseWild :: Parser () -parseWild = (lexeme . try . void) $ - string "_" <* notFollowedBy (alphaNumChar <|> oneOf "_'") - --- | Parse a standalone operator name with tildes indicating argument --- slots, e.g. ~+~ for the addition operator. -parseStandaloneOp :: Parser Prim -parseStandaloneOp = asum $ concatMap mkStandaloneOpParsers (concat opTable) - where - mkStandaloneOpParsers :: OpInfo -> [Parser Prim] - mkStandaloneOpParsers (OpInfo (UOpF Pre uop) syns _) - = map (\syn -> PrimUOp uop <$ try (lexeme (string syn >> char '~'))) syns - mkStandaloneOpParsers (OpInfo (UOpF Post uop) syns _) - = map (\syn -> PrimUOp uop <$ try (lexeme (char '~' >> string syn))) syns - mkStandaloneOpParsers (OpInfo (BOpF _ bop) syns _) - = map (\syn -> PrimBOp bop <$ try (lexeme (char '~' >> string syn >> char '~'))) syns - - -- XXX TODO: improve the above so it first tries to parse a ~, - -- then parses any postfix or infix thing; or else it looks for - -- a prefix thing followed by a ~. This will get rid of the - -- need for 'try' and also potentially improve error messages. - -- The below may come in useful. - - -- flatOpTable = concat opTable - - -- prefixOps = [ (uop, syns) | (OpInfo (UOpF Pre uop) syns _) <- flatOpTable ] - -- postfixOps = [ (uop, syns) | (OpInfo (UOpF Post uop) syns _) <- flatOpTable ] - -- infixOps = [ (bop, syns) | (OpInfo (BOpF _ bop) syns _) <- flatOpTable ] - --- | Parse a primitive name starting with a $. -parsePrim :: Parser Prim -parsePrim = do - void (char '$') - x <- identifier letterChar - case find ((==x) . primSyntax) primTable of - Just (PrimInfo p _ _) -> return p - Nothing -> fail ("Unrecognized primitive $" ++ x) - --- | Parse a container, like a literal list, set, bag, or a --- comprehension (not including the square or curly brackets). --- --- @ --- --- ::= '[' ']' --- | '{' '}' --- --- --- ::= empty | --- --- --- ::= [ ] --- | --- --- --- ::= '|' --- | ',' [ (',' )* ] [ ] --- --- ::= [ ',' ]* --- --- --- ::= 'in' --- | --- --- ::= '..' [ ] --- @ - -parseContainer :: Container -> Parser Term -parseContainer c = nonEmptyContainer <|> return (TContainer c [] Nothing) - -- Careful to do this without backtracking, since backtracking can - -- lead to bad performance in certain pathological cases (for - -- example, a very deeply nested list). - - where - -- Any non-empty container starts with a term, followed by some - -- remainder (which could either be the rest of a literal - -- container, or a container comprehension). If there is no - -- remainder just return a singleton container, optionally with an - -- ellipsis. - nonEmptyContainer = do - t <- parseRepTerm - - containerRemainder t <|> singletonContainer t - - parseRepTerm = do - t <- parseTerm - n <- optional $ do - guard (c == BagContainer) - void hash - parseTerm - return (t, n) - - singletonContainer t = TContainer c [t] <$> optional parseEllipsis - - -- The remainder of a container after the first term starts with - -- either a pipe (for a comprehension) or a comma (for a literal - -- container). - containerRemainder :: (Term, Maybe Term) -> Parser Term - containerRemainder (t,n) = do - s <- pipe <|> comma - case (s, n) of - ("|", Nothing) -> parseContainerComp c t - ("|", Just _) -> fail "no comprehension with bag repetition syntax" - (",", _) -> do - -- Parse the rest of the terms in a literal container after - -- the first, then an optional ellipsis, and return - -- everything together. - ts <- parseRepTerm `sepBy` comma - e <- optional parseEllipsis - - return $ TContainer c ((t,n):ts) e - _ -> error "Impossible, got a symbol other than '|' or ',' in containerRemainder" - --- | Parse an ellipsis at the end of a literal list, of the form --- @.. t@. Any number > 1 of dots may be used, just for fun. -parseEllipsis :: Parser (Ellipsis Term) -parseEllipsis = do - _ <- ellipsis - Until <$> parseTerm - --- | Parse the part of a list comprehension after the | (without --- square brackets), i.e. a list of qualifiers. --- --- @q [,q]*@ -parseContainerComp :: Container -> Term -> Parser Term -parseContainerComp c t = do - qs <- toTelescope <$> (parseQual `sepBy` comma) - return (TContainerComp c $ bind qs t) - --- | Parse a qualifier in a comprehension: either a binder @x in t@ or --- a guard @t@. -parseQual :: Parser Qual -parseQual = try parseSelection <|> parseQualGuard - where - parseSelection = label "membership expression (x in ...)" $ - QBind <$> ident <*> (selector *> (embed <$> parseTerm)) - selector = reservedOp "<-" <|> reserved "in" - - parseQualGuard = label "boolean expression" $ - QGuard . embed <$> parseTerm - --- | Turn a parenthesized list of zero or more terms into the --- appropriate syntax node: one term @(t)@ is just the term itself --- (but we record the fact that it was parenthesized, in order to --- correctly turn juxtaposition into multiplication); two or more --- terms @(t1,t2,...)@ are a tuple. -tuple :: [Term] -> Term -tuple [x] = TParens x -tuple t = TTup t - --- | Parse a quantified abstraction (λ, ∀, ∃). -parseQuantified :: Parser Term -parseQuantified = - TAbs <$> parseQuantifier - <*> (bind <$> parsePattern `sepBy` comma <*> (dot *> parseTerm)) - --- | Parse a quantifier symbol (lambda, forall, or exists). -parseQuantifier :: Parser Quantifier -parseQuantifier = - Lam <$ lambda - <|> All <$ forall - <|> Ex <$ exists - --- | Parse a let expression (@let x1 = t1, x2 = t2, ... in t@). -parseLet :: Parser Term -parseLet = - TLet <$> - (reserved "let" *> - (bind - <$> (toTelescope <$> (parseBinding `sepBy` comma)) - <*> (reserved "in" *> parseTerm))) - --- | Parse a single binding (@x [ : ty ] = t@). -parseBinding :: Parser Binding -parseBinding = do - x <- ident - mty <- optional (colon *> parsePolyTy) - t <- symbol "=" *> (embed <$> parseTerm) - return $ Binding (embed <$> mty) x t - --- | Parse a case expression. -parseCase :: Parser Term -parseCase = between (symbol "{?") (symbol "?}") $ - TCase <$> parseBranch `sepBy` comma - --- | Parse one branch of a case expression. -parseBranch :: Parser Branch -parseBranch = flip bind <$> parseTerm <*> parseGuards - --- | Parse the list of guards in a branch. @otherwise@ can be used --- interchangeably with an empty list of guards. -parseGuards :: Parser (Telescope Guard) -parseGuards = (TelEmpty <$ reserved "otherwise") <|> (toTelescope <$> many parseGuard) - --- | Parse a single guard (@if@, @if ... is@, or @let@) -parseGuard :: Parser Guard -parseGuard = try parseGPat <|> parseGBool <|> parseGLet - where - guardWord = reserved "if" <|> reserved "when" - parseGBool = GBool <$> (embed <$> (guardWord *> parseTerm)) - parseGPat = GPat <$> (embed <$> (guardWord *> parseTerm)) - <*> (reserved "is" *> parsePattern) - parseGLet = GLet <$> (reserved "let" *> parseBinding) - --- | Parse an atomic pattern, by parsing a term and then attempting to --- convert it to a pattern. -parseAtomicPattern :: Parser Pattern -parseAtomicPattern = label "pattern" $ do - t <- parseAtom - case termToPattern t of - Nothing -> customFailure $ InvalidPattern (OT t) - Just p -> return p - --- | Parse a pattern, by parsing a term and then attempting to convert --- it to a pattern. -parsePattern :: Parser Pattern -parsePattern = label "pattern" $ do - t <- parseTerm - case termToPattern t of - Nothing -> customFailure $ InvalidPattern (OT t) - Just p -> return p - --- | Attempt converting a term to a pattern. -termToPattern :: Term -> Maybe Pattern -termToPattern TWild = Just PWild -termToPattern (TVar x) = Just $ PVar x -termToPattern (TParens t) = termToPattern t -termToPattern TUnit = Just PUnit -termToPattern (TBool b) = Just $ PBool b -termToPattern (TNat n) = Just $ PNat n -termToPattern (TChar c) = Just $ PChar c -termToPattern (TString s) = Just $ PString s -termToPattern (TTup ts) = PTup <$> mapM termToPattern ts -termToPattern (TApp (TVar i) t) - | i == string2Name "left" = PInj L <$> termToPattern t - | i == string2Name "right" = PInj R <$> termToPattern t --- termToPattern (TInj s t) = PInj s <$> termToPattern t - -termToPattern (TAscr t s) = case s of - Forall (unsafeUnbind -> ([], s')) -> PAscr <$> termToPattern t <*> pure s' - _ -> Nothing - -termToPattern (TBin Cons t1 t2) - = PCons <$> termToPattern t1 <*> termToPattern t2 - -termToPattern (TBin Add t1 t2) - = case (termToPattern t1, termToPattern t2) of - (Just p, _) - | length (toListOf fvAny p) == 1 - && null (toListOf fvAny t2) - -> Just $ PAdd L p t2 - (_, Just p) - | length (toListOf fvAny p) == 1 - && null (toListOf fvAny t1) - -> Just $ PAdd R p t1 - _ -> Nothing - -- If t1 is a pattern binding one variable, and t2 has no fvs, - -- this can be a PAdd L. Also vice versa for PAdd R. - -termToPattern (TBin Mul t1 t2) - = case (termToPattern t1, termToPattern t2) of - (Just p, _) - | length (toListOf fvAny p) == 1 - && null (toListOf fvAny t2) - -> Just $ PMul L p t2 - (_, Just p) - | length (toListOf fvAny p) == 1 - && null (toListOf fvAny t1) - -> Just $ PMul R p t1 - _ -> Nothing - -- If t1 is a pattern binding one variable, and t2 has no fvs, - -- this can be a PMul L. Also vice versa for PMul R. - -termToPattern (TBin Sub t1 t2) - = case termToPattern t1 of - Just p - | length (toListOf fvAny p) == 1 - && null (toListOf fvAny t2) - -> Just $ PSub p t2 - _ -> Nothing - -- If t1 is a pattern binding one variable, and t2 has no fvs, - -- this can be a PSub. - - -- For now we don't handle the case of t - p, since it seems - -- less useful (and desugaring it would require extra code since - -- subtraction is not commutative). - -termToPattern (TBin Div t1 t2) - = PFrac <$> termToPattern t1 <*> termToPattern t2 - -termToPattern (TUn Neg t) = PNeg <$> termToPattern t - -termToPattern (TContainer ListContainer ts Nothing) - = PList <$> mapM (termToPattern . fst) ts - -termToPattern _ = Nothing - --- | Parse an expression built out of unary and binary operators. -parseExpr :: Parser Term -parseExpr = fixJuxtMul . fixChains <$> (makeExprParser parseAtom table "expression") - where - table - -- Special case for function application, with highest - -- precedence. Note that we parse all juxtaposition as - -- function application first; we later go through and turn - -- some into multiplication (fixing up the precedence - -- appropriately) based on a syntactic analysis. - = [ InfixL (TApp <$ string "") ] - - -- get all other operators from the opTable - : (map . concatMap) mkOpParser opTable - - mkOpParser :: OpInfo -> [Operator Parser Term] - mkOpParser (OpInfo op syns _) = concatMap (withOpFixity op) syns - - -- Only parse unary operators consisting of operator symbols. - -- Alphabetic unary operators (i.e. 'not') will be parsed as - -- applications of variable names, since if they are parsed here - -- they will incorrectly parse even when they are a prefix of a - -- variable name. - withOpFixity (UOpF fx op) syn - | any isAlpha syn = [] - | otherwise = [ufxParser fx ((reservedOp syn "operator") >> return (TUn op))] - - withOpFixity (BOpF fx op) syn - = [bfxParser fx ((reservedOp syn "operator") >> return (TBin op))] - - ufxParser Pre = Prefix - ufxParser Post = Postfix - - bfxParser InL = InfixL - bfxParser InR = InfixR - bfxParser In = InfixN - - isChainable op = op `elem` [Eq, Neq, Lt, Gt, Leq, Geq, Divides] - - -- Comparison chains like 3 < x < 5 first get parsed as 3 < (x < - -- 5), which does not make sense. This function looks for such - -- nested comparison operators and turns them into a TChain. - fixChains (TUn op t) = TUn op (fixChains t) - fixChains (TBin op t1 (TBin op' t21 t22)) - | isChainable op && isChainable op' = TChain t1 (TLink op t21 : getLinks op' t22) - fixChains (TBin op t1 t2) = TBin op (fixChains t1) (fixChains t2) - fixChains (TApp t1 t2) = TApp (fixChains t1) (fixChains t2) - - -- Only recurse as long as we see TUn, TBin, or TApp which could - -- have been generated by the expression parser. If we see - -- anything else we can stop. - fixChains e = e - - getLinks op (TBin op' t1 t2) - | isChainable op' = TLink op t1 : getLinks op' t2 - getLinks op e = [TLink op (fixChains e)] - - -- Find juxtapositions (parsed as function application) which - -- syntactically have either a literal Nat or a parenthesized - -- expression containing an operator as the LHS, and turn them - -- into multiplications. Then fix up the parse tree by rotating - -- newly created multiplications up until their precedence is - -- higher than the thing above them. - - fixJuxtMul :: Term -> Term - - -- Just recurse through TUn or TBin and fix precedence on the way back up. - fixJuxtMul (TUn op t) = fixPrec $ TUn op (fixJuxtMul t) - fixJuxtMul (TBin op t1 t2) = fixPrec $ TBin op (fixJuxtMul t1) (fixJuxtMul t2) - - -- Possibly turn a TApp into a multiplication, if the LHS looks - -- like a multiplicative term. However, we must be sure to - -- *first* recursively fix the subterms (particularly the - -- left-hand one) *before* doing this analysis. See - -- . - fixJuxtMul (TApp t1 t2) - | isMultiplicativeTerm t1' = fixPrec $ TBin Mul t1' t2' - | otherwise = fixPrec $ TApp t1' t2' - where - t1' = fixJuxtMul t1 - t2' = fixJuxtMul t2 - - -- Otherwise we can stop recursing, since anything other than TUn, - -- TBin, or TApp could not have been produced by the expression - -- parser. - fixJuxtMul t = t - - -- A multiplicative term is one that looks like either a natural - -- number literal, or a unary or binary operation (optionally - -- parenthesized). For example, 3, (-2), and (x + 5) are all - -- multiplicative terms, so 3x, (-2)x, and (x + 5)x all get parsed - -- as multiplication. On the other hand, (x y) is always parsed - -- as function application, even if x and y both turn out to have - -- numeric types; a variable like x does not count as a - -- multiplicative term. Likewise, (x y) z is parsed as function - -- application, since (x y) is not a multiplicative term: it is - -- parenthezised, but contains a TApp rather than a TBin or TUn. - isMultiplicativeTerm :: Term -> Bool - isMultiplicativeTerm (TNat _) = True - isMultiplicativeTerm TUn{} = True - isMultiplicativeTerm TBin{} = True - isMultiplicativeTerm (TParens t) = isMultiplicativeTerm t - isMultiplicativeTerm _ = False - - -- Fix precedence by bubbling up any new TBin terms whose - -- precedence is less than that of the operator above them. We - -- don't worry at all about fixing associativity, just precedence. - - fixPrec :: Term -> Term - - -- e.g. 2y! --> (2@y)! --> fixup --> 2 * (y!) - fixPrec (TUn uop (TBin bop t1 t2)) - | bPrec bop < uPrec uop = case uopMap M.! uop of - OpInfo (UOpF Pre _) _ _ -> TBin bop (TUn uop t1) t2 - OpInfo (UOpF Post _) _ _ -> TBin bop t1 (TUn uop t2) - _ -> error "Impossible! In fixPrec, uopMap contained OpInfo (BOpF ...)" - - fixPrec (TBin bop1 (TBin bop2 t1 t2) t3) - | bPrec bop2 < bPrec bop1 = TBin bop2 t1 (fixPrec $ TBin bop1 t2 t3) - - -- e.g. x^2y --> x^(2@y) --> x^(2*y) --> (x^2) * y - fixPrec (TBin bop1 t1 (TBin bop2 t2 t3)) - | bPrec bop2 < bPrec bop1 = TBin bop2 (fixPrec $ TBin bop1 t1 t2) t3 - - fixPrec t = t - --- | Parse an atomic type. -parseAtomicType :: Parser Type -parseAtomicType = label "type" $ - TyVoid <$ reserved "Void" - <|> TyUnit <$ reserved "Unit" - <|> TyBool <$ (reserved "Boolean" <|> reserved "Bool") - <|> TyProp <$ (reserved "Proposition" <|> reserved "Prop") - <|> TyC <$ reserved "Char" - -- <|> try parseTyFin - <|> TyN <$ (reserved "Natural" <|> reserved "Nat" <|> reserved "N" <|> reserved "ℕ") - <|> TyZ <$ (reserved "Integer" <|> reserved "Int" <|> reserved "Z" <|> reserved "ℤ") - <|> TyF <$ (reserved "Fractional" <|> reserved "Frac" <|> reserved "F" <|> reserved "𝔽") - <|> TyQ <$ (reserved "Rational" <|> reserved "Q" <|> reserved "ℚ") - <|> TyCon <$> parseCon <*> (fromMaybe [] <$> optional (parens (parseType `sepBy1` comma))) - <|> TyVar <$> parseTyVar - <|> parens parseType - --- parseTyFin :: Parser Type --- parseTyFin = TyFin <$> (reserved "Fin" *> natural) --- <|> TyFin <$> (lexeme (string "Z" <|> string "ℤ") *> natural) - -parseCon :: Parser Con -parseCon = - CList <$ reserved "List" - <|> CBag <$ reserved "Bag" - <|> CSet <$ reserved "Set" - <|> CGraph <$ reserved "Graph" - <|> CMap <$ reserved "Map" - <|> CUser <$> parseTyDef - -parseTyDef :: Parser String -parseTyDef = identifier upperChar - -parseTyVarName :: Parser String -parseTyVarName = identifier lowerChar - -parseTyVar :: Parser (Name Type) -parseTyVar = string2Name <$> parseTyVarName - -parsePolyTy :: Parser PolyType -parsePolyTy = closeType <$> parseType - --- | Parse a type expression built out of binary operators. -parseType :: Parser Type -parseType = makeExprParser parseAtomicType table - where - table = [ [ infixR "*" (:*:) - , infixR "×" (:*:) ] - , [ infixR "+" (:+:) - , infixR "⊎" (:+:) - ] - , [ infixR "->" (:->:) - , infixR "→" (:->:) - ] - ] - - infixR name fun = InfixR (reservedOp name >> return fun) - -parseTyOp :: Parser TyOp -parseTyOp = - Enumerate <$ reserved "enumerate" - <|> Count <$ reserved "count" +-- | +-- Module : Disco.Parser +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Parser to convert concrete Disco syntax into an (untyped, surface +-- language) AST. +module Disco.Parser ( + -- * Parser type and utilities + DiscoParseError (..), + Parser, + runParser, + withExts, + indented, + thenIndented, + + -- * Lexer + + -- ** Basic lexemes + sc, + lexeme, + symbol, + reservedOp, + natural, + reserved, + reservedWords, + ident, + + -- ** Punctuation + parens, + braces, + angles, + brackets, + semi, + comma, + colon, + dot, + pipe, + lambda, + + -- * Disco parser + + -- ** Modules + wholeModule, + parseModule, + parseExtName, + parseTopLevel, + parseDecl, + parseImport, + parseModuleName, + + -- ** Terms + term, + parseTerm, + parseTerm', + parseExpr, + parseAtom, + parseContainer, + parseEllipsis, + parseContainerComp, + parseQual, + parseLet, + parseTypeOp, + + -- ** Case and patterns + parseCase, + parseBranch, + parseGuards, + parseGuard, + parsePattern, + parseAtomicPattern, + + -- ** Types + parseType, + parseAtomicType, + parsePolyTy, +) +where + +import Unbound.Generics.LocallyNameless ( + Name, + bind, + embed, + fvAny, + name2String, + string2Name, + ) +import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) + +import Control.Monad.Combinators.Expr +import Text.Megaparsec hiding ( + State, + runParser, + ) +import qualified Text.Megaparsec as MP +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L + +import Control.Lens ( + makeLenses, + toListOf, + use, + (%=), + (%~), + (&), + (.=), + ) +import Control.Monad.State +import Data.Char (isAlpha, isDigit) +import Data.Foldable (asum) +import Data.List (find, intercalate) +import qualified Data.Map as M +import Data.Maybe (fromMaybe, isNothing) +import Data.Ratio +import Data.Set (Set) +import qualified Data.Set as S + +import Disco.AST.Surface +import Disco.Extensions +import Disco.Module +import Disco.Pretty (prettyStr) +import Disco.Syntax.Operators +import Disco.Syntax.Prims +import Disco.Types +import Polysemy (run) + +------------------------------------------------------------ +-- Lexer + +-- Some of the basic setup code for the parser taken from +-- https://markkarpov.com/megaparsec/parsing-simple-imperative-language.html + +-- | Currently required indent level. +data IndentMode where + NoIndent :: + -- | Don't require indent. + IndentMode + ThenIndent :: + -- | Parse one token without + -- indent, then switch to @Indent@. + IndentMode + Indent :: + -- | Require everything to be indented at + -- least one space. + IndentMode + +-- | Extra custom state for the parser. +data ParserState = ParserState + { _indentMode :: IndentMode + -- ^ Currently required level of indentation. + , _enabledExts :: Set Ext + -- ^ Set of enabled language extensions + -- (some of which may affect parsing). + } + +makeLenses ''ParserState + +initParserState :: ParserState +initParserState = ParserState NoIndent S.empty + +-- OpaqueTerm is a wrapper around Term just to make ShowErrorComponent +-- happy, which requires Eq and Ord instances; but we can't make Term +-- an instance of either. +newtype OpaqueTerm = OT Term +instance Show OpaqueTerm where + show (OT t) = show t +instance Eq OpaqueTerm where + _ == _ = True +instance Ord OpaqueTerm where + compare _ _ = EQ + +data DiscoParseError + = ReservedVarName String + | InvalidPattern OpaqueTerm + | MissingAscr + | MultiArgLambda + deriving (Show, Eq, Ord) + +instance ShowErrorComponent DiscoParseError where + showErrorComponent (ReservedVarName x) = "keyword \"" ++ x ++ "\" cannot be used as a variable name" + showErrorComponent (InvalidPattern (OT t)) = "Invalid pattern: " ++ run (prettyStr t) + showErrorComponent MissingAscr = "Variables introduced by ∀ or ∃ must have a type" + showErrorComponent MultiArgLambda = "Anonymous functions (lambdas) can only have a single argument.\nInstead of \\x, y. ... you can write \\x. \\y. ...\nhttps://disco-lang.readthedocs.io/en/latest/reference/anonymous-func.html" + errorComponentLen (ReservedVarName x) = length x + errorComponentLen (InvalidPattern _) = 1 + errorComponentLen MissingAscr = 1 + errorComponentLen MultiArgLambda = 1 + +-- | A parser is a megaparsec parser of strings, with an extra layer +-- of state to keep track of the current indentation level and +-- language extensions, and some custom error messages. +type Parser = StateT ParserState (MP.Parsec DiscoParseError String) + +-- | Run a parser from the initial state. +runParser :: Parser a -> FilePath -> String -> Either (ParseErrorBundle String DiscoParseError) a +runParser = MP.runParser . flip evalStateT initParserState + +-- | Run a parser under a specified 'IndentMode'. +withIndentMode :: IndentMode -> Parser a -> Parser a +withIndentMode m p = do + indentMode .= m + res <- p + indentMode .= NoIndent + return res + +-- | @indented p@ is just like @p@, except that every token must not +-- start in the first column. +indented :: Parser a -> Parser a +indented = withIndentMode Indent + +-- | @indented p@ is just like @p@, except that every token after the +-- first must not start in the first column. +thenIndented :: Parser a -> Parser a +thenIndented = withIndentMode ThenIndent + +-- | @requireIndent p@ possibly requires @p@ to be indented, depending +-- on the current '_indentMode'. Used in the definition of +-- 'lexeme' and 'symbol'. +requireIndent :: Parser a -> Parser a +requireIndent p = do + l <- use indentMode + case l of + ThenIndent -> do + a <- p + indentMode .= Indent + return a + Indent -> L.indentGuard sc GT pos1 >> p + NoIndent -> p + +-- | Locally set the enabled extensions within a subparser. +withExts :: Set Ext -> Parser a -> Parser a +withExts exts p = do + oldExts <- use enabledExts + enabledExts .= exts + a <- p + enabledExts .= oldExts + return a + +-- | Locally enable some additional extensions within a subparser. +withAdditionalExts :: Set Ext -> Parser a -> Parser a +withAdditionalExts exts p = do + oldExts <- use enabledExts + enabledExts %= S.union exts + a <- p + enabledExts .= oldExts + return a + +-- | Ensure that a specific extension is enabled, fail if not. +ensureEnabled :: Ext -> Parser () +ensureEnabled e = do + exts <- use enabledExts + guard $ e `S.member` exts + +-- | Generically consume whitespace, including comments. +sc :: Parser () +sc = L.space space1 lineComment empty {- no block comments in disco -} + where + lineComment = L.skipLineComment "--" + +-- | Parse a lexeme, that is, a parser followed by consuming +-- whitespace. +lexeme :: Parser a -> Parser a +lexeme p = requireIndent $ L.lexeme sc p + +-- | Parse a given string as a lexeme. +symbol :: String -> Parser String +symbol s = requireIndent $ L.symbol sc s + +-- | Parse a reserved operator. +reservedOp :: String -> Parser () +reservedOp s = (lexeme . try) (string s *> notFollowedBy (oneOf opChar)) + +-- | Characters that can occur in an operator symbol. +opChar :: [Char] +opChar = "~!@#$%^&*-+=|<>?/\\." + +parens, braces, angles, brackets, bagdelims, fbrack, cbrack :: Parser a -> Parser a +parens = between (symbol "(") (symbol ")") +braces = between (symbol "{") (symbol "}") +angles = between (symbol "<") (symbol ">") +brackets = between (symbol "[") (symbol "]") +bagdelims = between (symbol "⟅") (symbol "⟆") +fbrack = between (symbol "⌊") (symbol "⌋") +cbrack = between (symbol "⌈") (symbol "⌉") + +semi, comma, colon, dot, pipe, hash :: Parser String +semi = symbol ";" +comma = symbol "," +colon = symbol ":" +dot = symbol "." +pipe = symbol "|" +hash = symbol "#" + +-- | A literal ellipsis of two or more dots, @..@ +ellipsis :: Parser String +ellipsis = label "ellipsis (..)" $ concat <$> ((:) <$> dot <*> some dot) + +-- | The symbol that starts an anonymous function (either a backslash +-- or a Greek λ). +lambda :: Parser String +lambda = symbol "\\" <|> symbol "λ" + +forall :: Parser () +forall = void (symbol "∀") <|> reserved "forall" + +exists :: Parser () +exists = void (symbol "∃") <|> reserved "exists" + +-- | Parse a natural number. +natural :: Parser Integer +natural = lexeme L.decimal "natural number" + +-- | Parse a nonnegative decimal of the form @xxx.yyyy[zzz]@, where +-- the @y@s and bracketed @z@s are both optional as long as the +-- other is present. (In other words, there must be something after +-- the period.) For example, this parser accepts all of the +-- following: +-- +-- > 2.0 +-- > 2.333 +-- > 2.33[45] +-- > 2.[45] +-- +-- The idea is that brackets surround an infinitely repeating +-- sequence of digits. +-- +-- We used to accept @2.@ with no trailing digits, but no longer do. +-- See https://github.com/disco-lang/disco/issues/245 and Note +-- [Trailing period]. +decimal :: Parser Rational +decimal = + lexeme + ( readDecimal + <$> some digit + <* char '.' + <*> fractionalPart + ) + where + digit = satisfy isDigit + fractionalPart = + -- either some digits optionally followed by bracketed digits... + (,) <$> some digit <*> optional (brackets (some digit)) + -- ...or just bracketed digits. + <|> ([],) <$> (Just <$> brackets (some digit)) + + readDecimal a (b, mrep) = + read a % 1 -- integer part + + -- next part is just b/10^n + + (if null b then 0 else read b) % (10 ^ length b) + -- repeating part + + readRep (length b) mrep + + readRep _ Nothing = 0 + readRep offset (Just rep) = read rep % (10 ^ offset * (10 ^ length rep - 1)) + +-- If s = 0.[rep] then 10^(length rep) * s = rep.[rep], so +-- 10^(length rep) * s - s = rep, so +-- +-- s = rep/(10^(length rep) - 1). +-- +-- We also have to divide by 10^(length b) to shift it over +-- past any non-repeating prefix. + +-- ~~~~ Note [Trailing period] +-- +-- We used to accept numbers with nothing after the trailing period, +-- such as @2.@. However, this caused some problems with parsing: +-- +-- - First, https://github.com/disco-lang/disco/issues/99 which we +-- solved by making sure there was not another period after the +-- trailing period. +-- - Next, https://github.com/disco-lang/disco/issues/245. +-- +-- I first tried solving #245 by disallowing *any* operator character +-- after the trailing period, but then some tests in the test suite +-- started failing, where we had written things like @1./(10^5)@. The +-- problem is that when a period is followed by another operator +-- symbol, sometimes we might want them to be parsed as an operator +-- (as in @2.-4@, #245), and sometimes we might not (as in +-- @1./(10^5)@). So in the end it seems simpler and cleaner to +-- require at least a 0 digit after the period --- just like pretty +-- much every other programming language and just like standard +-- mathematical practice. + +-- | Parse a reserved word. +reserved :: String -> Parser () +reserved w = (lexeme . try) $ string w *> notFollowedBy alphaNumChar + +-- | The list of all reserved words. +reservedWords :: [String] +reservedWords = + [ "unit" + , "true" + , "false" + , "True" + , "False" + , "let" + , "in" + , "is" + , "if" + , "when" + , "otherwise" + , "and" + , "or" + , "mod" + , "choose" + , "implies" + , "iff" + , "min" + , "max" + , "union" + , "∪" + , "intersect" + , "∩" + , "subset" + , "⊆" + , "elem" + , "∈" + , "enumerate" + , "count" + , "divides" + , "Void" + , "Unit" + , "Bool" + , "Boolean" + , "Proposition" + , "Prop" + , "Char" + , "Nat" + , "Natural" + , "Int" + , "Integer" + , "Frac" + , "Fractional" + , "Rational" + , "Fin" + , "List" + , "Bag" + , "Set" + , "Graph" + , "Map" + , "N" + , "Z" + , "F" + , "Q" + , "ℕ" + , "ℤ" + , "𝔽" + , "ℚ" + , "∀" + , "forall" + , "∃" + , "exists" + , "type" + , "import" + , "using" + ] + +-- | Parse an identifier, i.e. any non-reserved string beginning with +-- a given type of character and continuing with alphanumerics, +-- underscores, and apostrophes. +identifier :: Parser Char -> Parser String +identifier begin = (lexeme . try) (p >>= check) "variable name" + where + p = (:) <$> begin <*> many identChar + identChar = alphaNumChar <|> oneOf "_'" + check x + | x `elem` reservedWords = do + -- back up to beginning of bad token to report correct position + updateParserState (\s -> s {stateOffset = stateOffset s - length x}) + customFailure $ ReservedVarName x + | otherwise = return x + +-- | Parse an 'identifier' and turn it into a 'Name'. +ident :: Parser (Name Term) +ident = string2Name <$> identifier letterChar + +------------------------------------------------------------ +-- Parser + +-- | Results from parsing a block of top-level things. +data TLResults = TLResults + { _tlDecls :: [Decl] + , _tlDocs :: [(Name Term, [DocThing])] + , _tlTerms :: [Term] + } + +emptyTLResults :: TLResults +emptyTLResults = TLResults [] [] [] + +makeLenses ''TLResults + +-- | Parse the entire input as a module (with leading whitespace and +-- no leftovers). +wholeModule :: LoadingMode -> Parser Module +wholeModule = between sc eof . parseModule + +-- | Parse an entire module (a list of declarations ended by +-- semicolons). The 'LoadingMode' parameter tells us whether to +-- include or replace any language extensions enabled at the top +-- level. We include them when parsing a module entered at the +-- REPL, and replace them when parsing a standalone module. +parseModule :: LoadingMode -> Parser Module +parseModule mode = do + exts <- S.fromList <$> many parseExtension + let extFun = case mode of + Standalone -> withExts + REPL -> withAdditionalExts + + extFun exts $ do + imports <- many parseImport + topLevel <- many parseTopLevel + let theMod = mkModule exts imports topLevel + return theMod + where + groupTLs :: [DocThing] -> [TopLevel] -> TLResults + groupTLs _ [] = emptyTLResults + groupTLs revDocs (TLDoc doc : rest) = + groupTLs (doc : revDocs) rest + groupTLs revDocs (TLDecl decl@(DType (TypeDecl x _)) : rest) = + groupTLs [] rest + & tlDecls %~ (decl :) + & tlDocs %~ ((x, reverse revDocs) :) + groupTLs revDocs (TLDecl decl@(DTyDef (TypeDefn x _ _)) : rest) = + groupTLs [] rest + & tlDecls %~ (decl :) + & tlDocs %~ ((string2Name x, reverse revDocs) :) + groupTLs _ (TLDecl defn : rest) = + groupTLs [] rest + & tlDecls %~ (defn :) + groupTLs _ (TLExpr t : rest) = + groupTLs [] rest & tlTerms %~ (t :) + + defnGroups :: [Decl] -> [Decl] + defnGroups [] = [] + defnGroups (d@DType {} : ds) = d : defnGroups ds + defnGroups (d@DTyDef {} : ds) = d : defnGroups ds + defnGroups (DDefn (TermDefn x bs) : ds) = DDefn (TermDefn x (bs ++ concatMap (\(TermDefn _ cs) -> cs) grp)) : defnGroups rest + where + (grp, rest) = matchDefn ds + matchDefn :: [Decl] -> ([TermDefn], [Decl]) + matchDefn (DDefn t@(TermDefn x' _) : ds2) | x == x' = (t : ts, ds2') + where + (ts, ds2') = matchDefn ds2 + matchDefn ds2 = ([], ds2) + + mkModule exts imps tls = Module exts imps (defnGroups decls) docs terms + where + TLResults decls docs terms = groupTLs [] tls + +-- | Parse an extension. +parseExtension :: Parser Ext +parseExtension = + L.nonIndented sc $ + reserved "using" *> parseExtName + +-- | Parse the name of a language extension (case-insensitive). +parseExtName :: Parser Ext +parseExtName = choice (map parseOneExt allExtsList) "language extension name" + where + parseOneExt ext = ext <$ lexeme (string' (show ext) :: Parser String) + +-- | Parse an import, of the form @import @. +parseImport :: Parser String +parseImport = + L.nonIndented sc $ + reserved "import" *> parseModuleName + +-- | Parse the name of a module. +parseModuleName :: Parser String +parseModuleName = + lexeme $ + intercalate "/" <$> (some (alphaNumChar <|> oneOf "_-") `sepBy` char '/') <* optional (string ".disco") + +-- | Parse a top level item (either documentation or a declaration), +-- which must start at the left margin. +parseTopLevel :: Parser TopLevel +parseTopLevel = + L.nonIndented sc $ + TLDoc <$> parseDocThing + <|> TLDecl <$> parseDecl -- See Note [Parsing definitions and top-level expressions] + <|> TLExpr <$> thenIndented parseTerm + +-- ~~~~ Note [Parsing definitions and top-level expressions] +-- +-- The beginning of a definition might look the same as an +-- expression. e.g. is f(x,y) the start of a definition of f, or an +-- expression with a function call? We used to therefore wrap +-- 'parseDecl' in 'try'. The problem is that if a definition has a +-- syntax error on the RHS, it would fail, backtrack, then try +-- parsing a top-level expression and fail when it got to the = +-- sign, giving an uninformative parse error message. +-- See https://github.com/disco-lang/disco/issues/346. +-- +-- The solution is that we now do more careful backtracking within +-- parseDecl itself: when parsing a definition, we only backtrack if +-- we don't get a complete LHS + '=' sign; once we start parsing the +-- RHS of a definition we no longer backtrack, since it can't +-- possibly be a valid top-level expression. + +-- | Parse a documentation item: either a group of lines beginning +-- with @|||@ (text documentation), or a group beginning with @!!!@ +-- (checked examples/properties). +parseDocThing :: Parser DocThing +parseDocThing = + DocString <$> some parseDocString + <|> DocProperty <$> parseProperty + +-- | Parse one line of documentation beginning with @|||@. +parseDocString :: Parser String +parseDocString = + label "documentation" $ + L.nonIndented sc $ + string "|||" + *> takeWhileP Nothing (`elem` " \t") + *> takeWhileP Nothing (`notElem` "\r\n") + <* sc + +-- Note we use string "|||" rather than symbol "|||" because we +-- don't want it to consume whitespace afterwards (in particular a +-- line with ||| by itself would cause symbol "|||" to consume the +-- newline). + +-- | Parse a top-level property/unit test, which is just @!!!@ +-- followed by an arbitrary term. +parseProperty :: Parser Term +parseProperty = label "property" $ L.nonIndented sc $ do + _ <- symbol "!!!" + indented parseTerm + +-- | Parse a single top-level declaration (either a type declaration +-- or single definition clause). +parseDecl :: Parser Decl +parseDecl = try (DType <$> parseTyDecl) <|> DDefn <$> parseDefn <|> DTyDef <$> parseTyDefn + +-- | Parse a top-level type declaration of the form @x : ty@. +parseTyDecl :: Parser TypeDecl +parseTyDecl = + label "type declaration" $ + TypeDecl <$> ident <*> indented (colon *> parsePolyTy) + +-- | Parse a definition of the form @x pat1 .. patn = t@. +parseDefn :: Parser TermDefn +parseDefn = + label "definition" $ + (\(x, ps) body -> TermDefn x [bind ps body]) + -- Only backtrack if we don't get a complete 'LHS ='. Once we see + -- an = sign, commit to parsing a definition, because it can't be a + -- valid standalone expression anymore. If the RHS fails, we don't + -- want to backtrack, we just want to display the parse error. + <$> try ((,) <$> ident <*> indented (many parseAtomicPattern) <* reservedOp "=") + <*> indented parseTerm + +-- | Parse the definition of a user-defined algebraic data type. +parseTyDefn :: Parser TypeDefn +parseTyDefn = label "type defintion" $ do + reserved "type" + indented $ do + name <- parseTyDef + args <- fromMaybe [] <$> optional (parens $ parseTyVarName `sepBy1` comma) + _ <- reservedOp "=" + TypeDefn name args <$> parseType + +-- | Parse the entire input as a term (with leading whitespace and +-- no leftovers). +term :: Parser Term +term = between sc eof parseTerm + +-- | Parse a term, consisting of a @parseTerm'@ optionally +-- followed by an ascription. +parseTerm :: Parser Term +parseTerm = + -- trace "parseTerm" $ + ascribe <$> parseTerm' <*> optional (label "type annotation" $ colon *> parsePolyTy) + where + ascribe t Nothing = t + ascribe t (Just ty) = TAscr t ty + +-- | Parse a non-atomic, non-ascribed term. +parseTerm' :: Parser Term +parseTerm' = + label "expression" $ + parseQuantified + <|> parseLet + <|> parseExpr + <|> parseAtom + +-- | Parse an atomic term. +parseAtom :: Parser Term +parseAtom = + label "expression" $ + parseUnit + <|> TBool True <$ (reserved "true" <|> reserved "True") + <|> TBool False <$ (reserved "false" <|> reserved "False") + <|> TChar <$> lexeme (between (char '\'') (char '\'') L.charLiteral) + <|> TString <$> lexeme (char '"' >> manyTill L.charLiteral (char '"')) + <|> TWild <$ try parseWild + <|> TPrim <$> try parseStandaloneOp + -- Note primitives are NOT reserved words, so they are just parsed + -- as identifiers. This means that it is possible to shadow a + -- primitive in a local context, as it should be. Vars are turned + -- into prims at scope-checking time: if a var is not in scope but + -- there is a prim of that name then it becomes a TPrim. See the + -- 'typecheck Infer (TVar x)' case in Disco.Typecheck. + <|> TVar <$> ident + <|> TPrim <$> (ensureEnabled Primitives *> parsePrim) + <|> TRat <$> try decimal + <|> TNat <$> natural + <|> parseTypeOp + <|> TApp (TPrim PrimFloor) . TParens <$> fbrack parseTerm + <|> TApp (TPrim PrimCeil) . TParens <$> cbrack parseTerm + <|> parseCase + <|> try parseAbs + <|> bagdelims (parseContainer BagContainer) + <|> braces (parseContainer SetContainer) + <|> brackets (parseContainer ListContainer) + <|> tuple <$> parens (parseTerm `sepBy1` comma) + +parseAbs :: Parser Term +parseAbs = TApp (TPrim PrimAbs) <$> (pipe *> parseTerm <* pipe) + +parseUnit :: Parser Term +parseUnit = TUnit <$ (reserved "unit" <|> void (symbol "■")) + +-- | Parse a wildcard, which is an underscore that isn't the start of +-- an identifier. +parseWild :: Parser () +parseWild = + (lexeme . try . void) $ + string "_" <* notFollowedBy (alphaNumChar <|> oneOf "_'") + +-- | Parse a standalone operator name with tildes indicating argument +-- slots, e.g. ~+~ for the addition operator. +parseStandaloneOp :: Parser Prim +parseStandaloneOp = asum $ concatMap mkStandaloneOpParsers (concat opTable) + where + mkStandaloneOpParsers :: OpInfo -> [Parser Prim] + mkStandaloneOpParsers (OpInfo (UOpF Pre uop) syns _) = + map (\syn -> PrimUOp uop <$ try (lexeme (string syn >> char '~'))) syns + mkStandaloneOpParsers (OpInfo (UOpF Post uop) syns _) = + map (\syn -> PrimUOp uop <$ try (lexeme (char '~' >> string syn))) syns + mkStandaloneOpParsers (OpInfo (BOpF _ bop) syns _) = + map (\syn -> PrimBOp bop <$ try (lexeme (char '~' >> string syn >> char '~'))) syns + +-- XXX TODO: improve the above so it first tries to parse a ~, +-- then parses any postfix or infix thing; or else it looks for +-- a prefix thing followed by a ~. This will get rid of the +-- need for 'try' and also potentially improve error messages. +-- The below may come in useful. + +-- flatOpTable = concat opTable + +-- prefixOps = [ (uop, syns) | (OpInfo (UOpF Pre uop) syns _) <- flatOpTable ] +-- postfixOps = [ (uop, syns) | (OpInfo (UOpF Post uop) syns _) <- flatOpTable ] +-- infixOps = [ (bop, syns) | (OpInfo (BOpF _ bop) syns _) <- flatOpTable ] + +-- | Parse a primitive name starting with a $. +parsePrim :: Parser Prim +parsePrim = do + void (char '$') + x <- identifier letterChar + case find ((== x) . primSyntax) primTable of + Just (PrimInfo p _ _) -> return p + Nothing -> fail ("Unrecognized primitive $" ++ x) + +-- | Parse a container, like a literal list, set, bag, or a +-- comprehension (not including the square or curly brackets). +-- +-- @ +-- +-- ::= | empty +-- +-- ::= +-- +-- +-- ::= '|' +-- | (',' )* [ ] +-- +-- ::= [ ',' ]* +-- +-- +-- ::= 'in' +-- | +-- +-- ::= [ ',' ] '..' [ ',' ] +-- @ +parseContainer :: Container -> Parser Term +parseContainer c = nonEmptyContainer <|> return (TContainer c [] Nothing) + where + -- Careful to do this without backtracking, since backtracking can + -- lead to bad performance in certain pathological cases (for + -- example, a very deeply nested list). + + -- Any non-empty container starts with a term, followed by some + -- remainder (which could either be the rest of a literal + -- container, or a container comprehension). If there is no + -- remainder just return a "singleton" container (which could + -- include a trailing ellipsis + final term). + nonEmptyContainer = parseRepTerm >>= containerRemainder + + parseRepTerm = do + t <- parseTerm + n <- optional $ do + guard (c == BagContainer) + void hash + parseTerm + return (t, n) + + -- The remainder of a container after the first term starts with + -- either a pipe (for a comprehension) or a comma (for a literal + -- container). + containerRemainder :: (Term, Maybe Term) -> Parser Term + containerRemainder (t, n) = + (guard (isNothing n) *> parseContainerComp c t) <|> parseLitContainerRemainder t n + + parseLitContainerRemainder :: Term -> Maybe Term -> Parser Term + parseLitContainerRemainder t n = do + -- Wrapping the (',' term) production in 'try' is important: if + -- it consumes a comma but then fails when parsing a term, we + -- want to be able to backtrack so we can potentially parse an + -- ellipsis beginning with a comma. + ts <- many (try (comma *> parseRepTerm)) + e <- optional parseEllipsis + return $ TContainer c ((t, n) : ts) e + +-- | Parse an ellipsis at the end of a literal list, of the form +-- @.. t@. Any number > 1 of dots may be used, just for fun. +parseEllipsis :: Parser (Ellipsis Term) +parseEllipsis = optional comma *> ellipsis *> optional comma *> (Until <$> parseTerm) + +-- | Parse the part of a list comprehension after the | (without +-- square brackets), i.e. a list of qualifiers. +-- +-- @q [,q]*@ +parseContainerComp :: Container -> Term -> Parser Term +parseContainerComp c t = do + _ <- pipe + qs <- toTelescope <$> (parseQual `sepBy` comma) + return (TContainerComp c $ bind qs t) + +-- | Parse a qualifier in a comprehension: either a binder @x in t@ or +-- a guard @t@. +parseQual :: Parser Qual +parseQual = parseSelection <|> parseQualGuard + where + parseSelection = + label "membership expression (x in ...)" $ + QBind <$> try (ident <* selector) <*> (embed <$> parseTerm) + selector = reservedOp "<-" <|> reserved "in" + + parseQualGuard = + label "boolean expression" $ + QGuard . embed <$> parseTerm + +-- | Turn a parenthesized list of zero or more terms into the +-- appropriate syntax node: one term @(t)@ is just the term itself +-- (but we record the fact that it was parenthesized, in order to +-- correctly turn juxtaposition into multiplication); two or more +-- terms @(t1,t2,...)@ are a tuple. +tuple :: [Term] -> Term +tuple [x] = TParens x +tuple t = TTup t + +-- | Parse a quantified abstraction (λ, ∀, ∃). +parseQuantified :: Parser Term +parseQuantified = do + q <- parseQuantifier + TAbs q <$> (bind <$> parseArgs (q /= Lam) <*> (dot *> parseTerm)) + where + parseArgs notLam = (parsePattern notLam `sepBy1` comma) >>= checkMulti + where + -- ∀ and ∃ can have multiple bindings separated by commas, + -- like ∀ x:N, y:N. ... but we don't allow this for λ. + + checkMulti :: [Pattern] -> Parser [Pattern] + checkMulti ps + | notLam = return ps + | otherwise = case ps of + [p] -> return [p] + _ -> customFailure MultiArgLambda + +-- | Parse a quantifier symbol (lambda, forall, or exists). +parseQuantifier :: Parser Quantifier +parseQuantifier = + Lam <$ lambda + <|> All <$ forall + <|> Ex <$ exists + +-- | Parse a let expression (@let x1 = t1, x2 = t2, ... in t@). +parseLet :: Parser Term +parseLet = + TLet + <$> ( reserved "let" + *> ( bind + <$> (toTelescope <$> (parseBinding `sepBy` comma)) + <*> (reserved "in" *> parseTerm) + ) + ) + +-- | Parse a single binding (@x [ : ty ] = t@). +parseBinding :: Parser Binding +parseBinding = do + x <- ident + mty <- optional (colon *> parsePolyTy) + t <- symbol "=" *> (embed <$> parseTerm) + return $ Binding (embed <$> mty) x t + +-- | Parse a case expression. +parseCase :: Parser Term +parseCase = + between (symbol "{?") (symbol "?}") $ + TCase <$> parseBranch `sepBy` comma + +-- | Parse one branch of a case expression. +parseBranch :: Parser Branch +parseBranch = flip bind <$> parseTerm <*> parseGuards + +-- | Parse the list of guards in a branch. @otherwise@ can be used +-- interchangeably with an empty list of guards. +parseGuards :: Parser (Telescope Guard) +parseGuards = (TelEmpty <$ reserved "otherwise") <|> (toTelescope <$> many parseGuard) + +-- | Parse a single guard (@if@, @if ... is ...@, or @let@) +parseGuard :: Parser Guard +parseGuard = parseGCond <|> parseGLet + where + guardWord = reserved "if" <|> reserved "when" + parseGCond = do + guardWord + t <- parseTerm + parseGPat t <|> parseGBool t + parseGPat t = GPat (embed t) <$> (reserved "is" *> parsePattern False) + parseGBool t = pure $ GBool (embed t) + parseGLet = GLet <$> (reserved "let" *> parseBinding) + +-- | Parse an atomic pattern, by parsing a term and then attempting to +-- convert it to a pattern. +parseAtomicPattern :: Parser Pattern +parseAtomicPattern = label "pattern" $ do + t <- parseAtom + case termToPattern t of + Nothing -> customFailure $ InvalidPattern (OT t) + Just p -> return $ maybe p (PNonlinear p) (findDuplicatePVar p) + +-- | Parse a pattern, by parsing a term and then attempting to convert +-- it to a pattern. The Bool parameter says whether to require +-- a type ascription. +parsePattern :: Bool -> Parser Pattern +parsePattern requireAscr = label "pattern" $ do + t <- parseTerm + case termToPattern t of + Nothing -> customFailure $ InvalidPattern (OT t) + Just p + | requireAscr && not (hasAscr p) -> customFailure MissingAscr + | otherwise -> return $ maybe p (PNonlinear p) (findDuplicatePVar p) + +-- | Does a pattern either have a top-level ascription, or consist of +-- a tuple with each component recursively having ascriptions? +-- This is required for patterns bound by ∀ and ∃ quantifiers. +hasAscr :: Pattern -> Bool +hasAscr PAscr {} = True +hasAscr (PTup ps) = all hasAscr ps +hasAscr _ = False + +-- | Lazy monadic variant of find. +findM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b) +findM _ [] = return Nothing +findM p (a : as) = do + b <- p a + case b of + Just x -> return $ Just x + _ -> findM p as + +-- | Does a pattern have the same variable repeated more than once? +findDuplicatePVar :: Pattern -> Maybe (Name Term) +findDuplicatePVar = flip evalState S.empty . go + where + go :: Pattern -> State (Set String) (Maybe (Name Term)) + go (PVar x) = do + let xName = name2String x + seen <- gets (S.member xName) + if seen + then return (Just x) + else do + modify (S.insert xName) + return Nothing + go (PAscr p _) = go p + go (PTup ps) = findM go ps + go (PInj _ p) = go p + go (PCons p1 p2) = findM go [p1, p2] + go (PList ps) = findM go ps + go (PAdd _ p _) = go p + go (PMul _ p _) = go p + go (PSub p _) = go p + go (PNeg p) = go p + go (PFrac p1 p2) = findM go [p1, p2] + go _ = return Nothing + +-- | Attempt converting a term to a pattern. +termToPattern :: Term -> Maybe Pattern +termToPattern TWild = Just PWild +termToPattern (TVar x) = Just $ PVar x +termToPattern (TParens t) = termToPattern t +termToPattern TUnit = Just PUnit +termToPattern (TBool b) = Just $ PBool b +termToPattern (TNat n) = Just $ PNat n +termToPattern (TChar c) = Just $ PChar c +termToPattern (TString s) = Just $ PString s +termToPattern (TTup ts) = PTup <$> mapM termToPattern ts +termToPattern (TApp (TVar i) t) + | i == string2Name "left" = PInj L <$> termToPattern t + | i == string2Name "right" = PInj R <$> termToPattern t +-- termToPattern (TInj s t) = PInj s <$> termToPattern t + +termToPattern (TAscr t s) = case s of + Forall (unsafeUnbind -> ([], s')) -> PAscr <$> termToPattern t <*> pure s' + _ -> Nothing +termToPattern (TBin Cons t1 t2) = + PCons <$> termToPattern t1 <*> termToPattern t2 +termToPattern (TBin Add t1 t2) = + case (termToPattern t1, termToPattern t2) of + (Just p, _) + | length (toListOf fvAny p) == 1 + && null (toListOf fvAny t2) -> + Just $ PAdd L p t2 + (_, Just p) + | length (toListOf fvAny p) == 1 + && null (toListOf fvAny t1) -> + Just $ PAdd R p t1 + _ -> Nothing +-- If t1 is a pattern binding one variable, and t2 has no fvs, +-- this can be a PAdd L. Also vice versa for PAdd R. + +termToPattern (TBin Mul t1 t2) = + case (termToPattern t1, termToPattern t2) of + (Just p, _) + | length (toListOf fvAny p) == 1 + && null (toListOf fvAny t2) -> + Just $ PMul L p t2 + (_, Just p) + | length (toListOf fvAny p) == 1 + && null (toListOf fvAny t1) -> + Just $ PMul R p t1 + _ -> Nothing +-- If t1 is a pattern binding one variable, and t2 has no fvs, +-- this can be a PMul L. Also vice versa for PMul R. + +termToPattern (TBin Sub t1 t2) = + case termToPattern t1 of + Just p + | length (toListOf fvAny p) == 1 + && null (toListOf fvAny t2) -> + Just $ PSub p t2 + _ -> Nothing +-- If t1 is a pattern binding one variable, and t2 has no fvs, +-- this can be a PSub. + +-- For now we don't handle the case of t - p, since it seems +-- less useful (and desugaring it would require extra code since +-- subtraction is not commutative). + +termToPattern (TBin Div t1 t2) = + PFrac <$> termToPattern t1 <*> termToPattern t2 +termToPattern (TUn Neg t) = PNeg <$> termToPattern t +termToPattern (TContainer ListContainer ts Nothing) = + PList <$> mapM (termToPattern . fst) ts +termToPattern _ = Nothing + +-- | Parse an expression built out of unary and binary operators. +parseExpr :: Parser Term +parseExpr = fixJuxtMul . fixChains <$> (makeExprParser parseAtom table "expression") + where + table = + -- Special case for function application, with highest + -- precedence. Note that we parse all juxtaposition as + -- function application first; we later go through and turn + -- some into multiplication (fixing up the precedence + -- appropriately) based on a syntactic analysis. + [InfixL (TApp <$ string "")] + -- get all other operators from the opTable + : (map . concatMap) mkOpParser opTable + + mkOpParser :: OpInfo -> [Operator Parser Term] + mkOpParser (OpInfo op syns _) = concatMap (withOpFixity op) syns + + -- Only parse unary operators consisting of operator symbols. + -- Alphabetic unary operators (i.e. 'not') will be parsed as + -- applications of variable names, since if they are parsed here + -- they will incorrectly parse even when they are a prefix of a + -- variable name. + withOpFixity (UOpF fx op) syn + | any isAlpha syn = [] + | otherwise = [ufxParser fx ((reservedOp syn "operator") >> return (TUn op))] + withOpFixity (BOpF fx op) syn = + [bfxParser fx ((reservedOp syn "operator") >> return (TBin op))] + + ufxParser Pre = Prefix + ufxParser Post = Postfix + + bfxParser InL = InfixL + bfxParser InR = InfixR + bfxParser In = InfixN + + isChainable op = op `elem` [Eq, Neq, Lt, Gt, Leq, Geq, Divides] + + -- Comparison chains like 3 < x < 5 first get parsed as 3 < (x < + -- 5), which does not make sense. This function looks for such + -- nested comparison operators and turns them into a TChain. + fixChains (TUn op t) = TUn op (fixChains t) + fixChains (TBin op t1 (TBin op' t21 t22)) + | isChainable op && isChainable op' = TChain t1 (TLink op t21 : getLinks op' t22) + fixChains (TBin op t1 t2) = TBin op (fixChains t1) (fixChains t2) + fixChains (TApp t1 t2) = TApp (fixChains t1) (fixChains t2) + -- Only recurse as long as we see TUn, TBin, or TApp which could + -- have been generated by the expression parser. If we see + -- anything else we can stop. + fixChains e = e + + getLinks op (TBin op' t1 t2) + | isChainable op' = TLink op t1 : getLinks op' t2 + getLinks op e = [TLink op (fixChains e)] + + -- Find juxtapositions (parsed as function application) which + -- syntactically have either a literal Nat or a parenthesized + -- expression containing an operator as the LHS, and turn them + -- into multiplications. Then fix up the parse tree by rotating + -- newly created multiplications up until their precedence is + -- higher than the thing above them. + + fixJuxtMul :: Term -> Term + + -- Just recurse through TUn or TBin and fix precedence on the way back up. + fixJuxtMul (TUn op t) = fixPrec $ TUn op (fixJuxtMul t) + fixJuxtMul (TBin op t1 t2) = fixPrec $ TBin op (fixJuxtMul t1) (fixJuxtMul t2) + -- Possibly turn a TApp into a multiplication, if the LHS looks + -- like a multiplicative term. However, we must be sure to + -- \*first* recursively fix the subterms (particularly the + -- left-hand one) *before* doing this analysis. See + -- . + fixJuxtMul (TApp t1 t2) + | isMultiplicativeTerm t1' = fixPrec $ TBin Mul t1' t2' + | otherwise = fixPrec $ TApp t1' t2' + where + t1' = fixJuxtMul t1 + t2' = fixJuxtMul t2 + + -- Otherwise we can stop recursing, since anything other than TUn, + -- TBin, or TApp could not have been produced by the expression + -- parser. + fixJuxtMul t = t + + -- A multiplicative term is one that looks like either a natural + -- number literal, or a unary or binary operation (optionally + -- parenthesized). For example, 3, (-2), and (x + 5) are all + -- multiplicative terms, so 3x, (-2)x, and (x + 5)x all get parsed + -- as multiplication. On the other hand, (x y) is always parsed + -- as function application, even if x and y both turn out to have + -- numeric types; a variable like x does not count as a + -- multiplicative term. Likewise, (x y) z is parsed as function + -- application, since (x y) is not a multiplicative term: it is + -- parenthezised, but contains a TApp rather than a TBin or TUn. + isMultiplicativeTerm :: Term -> Bool + isMultiplicativeTerm (TNat _) = True + isMultiplicativeTerm TUn {} = True + isMultiplicativeTerm TBin {} = True + isMultiplicativeTerm (TParens t) = isMultiplicativeTerm t + isMultiplicativeTerm _ = False + + -- Fix precedence by bubbling up any new TBin terms whose + -- precedence is less than that of the operator above them. We + -- don't worry at all about fixing associativity, just precedence. + + fixPrec :: Term -> Term + + -- e.g. 2y! --> (2@y)! --> fixup --> 2 * (y!) + fixPrec (TUn uop (TBin bop t1 t2)) + | bPrec bop < uPrec uop = case uopMap M.! uop of + OpInfo (UOpF Pre _) _ _ -> TBin bop (TUn uop t1) t2 + OpInfo (UOpF Post _) _ _ -> TBin bop t1 (TUn uop t2) + _ -> error "Impossible! In fixPrec, uopMap contained OpInfo (BOpF ...)" + fixPrec (TBin bop1 (TBin bop2 t1 t2) t3) + | bPrec bop2 < bPrec bop1 = TBin bop2 t1 (fixPrec $ TBin bop1 t2 t3) + -- e.g. x^2y --> x^(2@y) --> x^(2*y) --> (x^2) * y + fixPrec (TBin bop1 t1 (TBin bop2 t2 t3)) + | bPrec bop2 < bPrec bop1 = TBin bop2 (fixPrec $ TBin bop1 t1 t2) t3 + fixPrec t = t + +-- | Parse an atomic type. +parseAtomicType :: Parser Type +parseAtomicType = + label "type" $ + TyVoid <$ reserved "Void" + <|> TyUnit <$ reserved "Unit" + <|> TyBool <$ (reserved "Boolean" <|> reserved "Bool") + <|> TyProp <$ (reserved "Proposition" <|> reserved "Prop") + <|> TyC <$ reserved "Char" + -- <|> try parseTyFin + <|> TyN <$ (reserved "Natural" <|> reserved "Nat" <|> reserved "N" <|> reserved "ℕ") + <|> TyZ <$ (reserved "Integer" <|> reserved "Int" <|> reserved "Z" <|> reserved "ℤ") + <|> TyF <$ (reserved "Fractional" <|> reserved "Frac" <|> reserved "F" <|> reserved "𝔽") + <|> TyQ <$ (reserved "Rational" <|> reserved "Q" <|> reserved "ℚ") + <|> TyCon <$> parseCon <*> (fromMaybe [] <$> optional (parens (parseType `sepBy1` comma))) + <|> TyVar <$> parseTyVar + <|> parens parseType + +-- parseTyFin :: Parser Type +-- parseTyFin = TyFin <$> (reserved "Fin" *> natural) +-- <|> TyFin <$> (lexeme (string "Z" <|> string "ℤ") *> natural) + +parseCon :: Parser Con +parseCon = + CList <$ reserved "List" + <|> CBag <$ reserved "Bag" + <|> CSet <$ reserved "Set" + <|> CGraph <$ reserved "Graph" + <|> CMap <$ reserved "Map" + <|> CUser <$> parseTyDef + +parseTyDef :: Parser String +parseTyDef = identifier upperChar + +parseTyVarName :: Parser String +parseTyVarName = identifier lowerChar + +parseTyVar :: Parser (Name Type) +parseTyVar = string2Name <$> parseTyVarName + +parsePolyTy :: Parser PolyType +parsePolyTy = closeType <$> parseType + +-- | Parse a type expression built out of binary operators. +parseType :: Parser Type +parseType = makeExprParser parseAtomicType table + where + table = + [ + [ infixR "*" (:*:) + , infixR "×" (:*:) + ] + , + [ infixR "+" (:+:) + , infixR "⊎" (:+:) + ] + , + [ infixR "->" (:->:) + , infixR "→" (:->:) + ] + ] + + infixR name fun = InfixR (reservedOp name >> return fun) + +parseTyOp :: Parser TyOp +parseTyOp = + Enumerate <$ reserved "enumerate" + <|> Count <$ reserved "count" parseTypeOp :: Parser Term parseTypeOp = TTyOp <$> parseTyOp <*> parseAtomicType diff --git a/src/Disco/Pretty.hs b/src/Disco/Pretty.hs --- a/src/Disco/Pretty.hs +++ b/src/Disco/Pretty.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ +-- TODO: the calls to 'error' should be replaced with logging/error capabilities. + -- | -- Module : Disco.Pretty -- Copyright : disco team and contributors @@ -11,40 +12,31 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- Various pretty-printing facilities for disco. --- ------------------------------------------------------------------------------ - --- TODO: the calls to 'error' should be replaced with logging/error capabilities. - -module Disco.Pretty - ( module Disco.Pretty.DSL - , module Disco.Pretty - , module Disco.Pretty.Prec - , Doc - ) - where - -import Prelude hiding ((<>)) - -import Data.Bifunctor -import Data.Char (isAlpha) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Ratio -import Data.Set (Set) -import qualified Data.Set as S - -import Disco.Effects.LFresh -import Polysemy - -import Polysemy.Reader +module Disco.Pretty ( + module Disco.Pretty.DSL, + module Disco.Pretty, + module Disco.Pretty.Prec, + Doc, +) +where -import Text.PrettyPrint (Doc) -import Unbound.Generics.LocallyNameless (Name) +import Prelude hiding ((<>)) -import Disco.Pretty.DSL -import Disco.Pretty.Prec -import Disco.Syntax.Operators +import Data.Bifunctor +import Data.Char (isAlpha) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Ratio +import Data.Set (Set) +import qualified Data.Set as S +import Disco.Effects.LFresh +import Disco.Pretty.DSL +import Disco.Pretty.Prec +import Disco.Syntax.Operators +import Polysemy +import Polysemy.Reader +import Prettyprinter (Doc) +import Unbound.Generics.LocallyNameless (Name) ------------------------------------------------------------ -- Utilities for handling precedence and associativity @@ -54,7 +46,7 @@ -- associativity of a term is, and optionally surround it with -- parentheses depending on the precedence and associativity of its -- parent. -withPA :: Member (Reader PA) r => PA -> Sem r Doc -> Sem r Doc +withPA :: Member (Reader PA) r => PA -> Sem r (Doc ann) -> Sem r (Doc ann) withPA pa = mparens pa . setPA pa -- | Locally set the precedence and associativity within a @@ -65,20 +57,20 @@ -- | Mark a subcomputation as pretty-printing a term on the left of an -- operator (so parentheses can be inserted appropriately, depending -- on the associativity). -lt :: Member (Reader PA) r => Sem r Doc -> Sem r Doc +lt :: Member (Reader PA) r => Sem r (Doc ann) -> Sem r (Doc ann) lt = local (\(PA p _) -> PA p InL) -- | Mark a subcomputation as pretty-printing a term on the right of -- an operator (so parentheses can be inserted appropriately, -- depending on the associativity). -rt :: Member (Reader PA) r => Sem r Doc -> Sem r Doc +rt :: Member (Reader PA) r => Sem r (Doc ann) -> Sem r (Doc ann) rt = local (\(PA p _) -> PA p InR) -- | Optionally surround a pretty-printed term with parentheses, -- depending on its precedence and associativity (given as the 'PA' -- argument) and that of its context (given by the ambient 'Reader -- PA' effect). -mparens :: Member (Reader PA) r => PA -> Sem r Doc -> Sem r Doc +mparens :: Member (Reader PA) r => PA -> Sem r (Doc ann) -> Sem r (Doc ann) mparens pa doc = do parentPA <- ask (if pa < parentPA then parens else id) doc @@ -87,12 +79,12 @@ -- Pretty type class class Pretty t where - pretty :: Members '[Reader PA, LFresh] r => t -> Sem r Doc + pretty :: Members '[Reader PA, LFresh] r => t -> Sem r (Doc ann) prettyStr :: Pretty t => t -> Sem r String prettyStr = renderDoc . runLFresh . pretty -pretty' :: Pretty t => t -> Sem r Doc +pretty' :: Pretty t => t -> Sem r (Doc ann) pretty' = runReader initPA . runLFresh . pretty ------------------------------------------------------------ @@ -103,7 +95,7 @@ instance (Pretty k, Pretty v) => Pretty (Map k v) where pretty m = do - let es = map (\(k,v) -> pretty k <+> "->" <+> pretty v) (M.assocs m) + let es = map (\(k, v) -> pretty k <+> "->" <+> pretty v) (M.assocs m) ds <- setPA initPA $ punctuate "," es braces (hsep ds) @@ -119,13 +111,13 @@ instance Pretty TyOp where pretty = \case Enumerate -> text "enumerate" - Count -> text "count" + Count -> text "count" -- | Pretty-print a unary operator, by looking up its concrete syntax -- in the 'uopMap'. instance Pretty UOp where pretty op = case M.lookup op uopMap of - Just (OpInfo _ (syn:_) _) -> + Just (OpInfo _ (syn : _) _) -> text $ syn ++ (if all isAlpha syn then " " else "") _ -> error $ "UOp " ++ show op ++ " not in uopMap!" @@ -133,8 +125,8 @@ -- in the 'bopMap'. instance Pretty BOp where pretty op = case M.lookup op bopMap of - Just (OpInfo _ (syn:_) _) -> text syn - _ -> error $ "BOp " ++ show op ++ " not in bopMap!" + Just (OpInfo _ (syn : _) _) -> text syn + _ -> error $ "BOp " ++ show op ++ " not in bopMap!" -------------------------------------------------- -- Pretty-printing decimals @@ -144,19 +136,19 @@ -- in square brackets. prettyDecimal :: Rational -> String prettyDecimal r = printedDecimal + where + (n, d) = properFraction r :: (Integer, Rational) + (expan, len) = digitalExpansion 10 (numerator d) (denominator d) + printedDecimal + | length first102 > 101 || length first102 == 101 && last first102 /= 0 = + show n ++ "." ++ concatMap show (take 100 expan) ++ "..." + | rep == [0] = + show n ++ "." ++ (if null pre then "0" else concatMap show pre) + | otherwise = + show n ++ "." ++ concatMap show pre ++ "[" ++ concatMap show rep ++ "]" where - (n,d) = properFraction r :: (Integer, Rational) - (expan, len) = digitalExpansion 10 (numerator d) (denominator d) - printedDecimal - | length first102 > 101 || length first102 == 101 && last first102 /= 0 - = show n ++ "." ++ concatMap show (take 100 expan) ++ "..." - | rep == [0] - = show n ++ "." ++ (if null pre then "0" else concatMap show pre) - | otherwise - = show n ++ "." ++ concatMap show pre ++ "[" ++ concatMap show rep ++ "]" - where - (pre, rep) = splitAt len expan - first102 = take 102 expan + (pre, rep) = splitAt len expan + first102 = take 102 expan -- Given a list, find the indices of the list giving the first and -- second occurrence of the first element to repeat, or Nothing if @@ -166,9 +158,9 @@ findRep' :: Ord a => M.Map a Int -> Int -> [a] -> ([a], Int) findRep' _ _ [] = error "Impossible. Empty list in findRep'" -findRep' prevs ix (x:xs) +findRep' prevs ix (x : xs) | x `M.member` prevs = ([], prevs M.! x) - | otherwise = first (x:) $ findRep' (M.insert x ix prevs) (ix+1) xs + | otherwise = first (x :) $ findRep' (M.insert x ix prevs) (ix + 1) xs -- | @digitalExpansion b n d@ takes the numerator and denominator of a -- fraction n/d between 0 and 1, and returns a pair of (1) a list of @@ -185,7 +177,7 @@ -- looking for the first time that the remainder repeats. digitalExpansion :: Integer -> Integer -> Integer -> ([Integer], Int) digitalExpansion b n d = digits - where - longDivStep (_, r) = (b*r) `divMod` d - res = tail $ iterate longDivStep (0,n) - digits = first (map fst) (findRep res) + where + longDivStep (_, r) = (b * r) `divMod` d + res = tail $ iterate longDivStep (0, n) + digits = first (map fst) (findRep res) diff --git a/src/Disco/Pretty/DSL.hs b/src/Disco/Pretty/DSL.hs --- a/src/Disco/Pretty/DSL.hs +++ b/src/Disco/Pretty/DSL.hs @@ -1,4 +1,5 @@ ------------------------------------------------------------------------------ +{-# OPTIONS_GHC -fno-warn-orphans #-} + -- | -- Module : Disco.Pretty.DSL -- Copyright : disco team and contributors @@ -7,26 +8,20 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- Adapter DSL on top of Text.PrettyPrint for Applicative pretty-printing. --- ------------------------------------------------------------------------------ - -{-# OPTIONS_GHC -fno-warn-orphans #-} - module Disco.Pretty.DSL where -import Control.Applicative hiding (empty) -import Data.String (IsString (..)) -import Prelude hiding ((<>)) - -import Polysemy -import Polysemy.Reader - -import Text.PrettyPrint (Doc) -import qualified Text.PrettyPrint as PP - -import Disco.Pretty.Prec +import Control.Applicative hiding (empty) +import Data.String (IsString (..)) +import Disco.Pretty.Prec +import Polysemy +import Polysemy.Reader +import Prettyprinter (Doc) +import qualified Prettyprinter as PP +import Prettyprinter.Internal (Doc (Empty)) -- XXX comment me +import Prettyprinter.Render.String (renderString) +import Prelude hiding ((<>)) -instance IsString (Sem r Doc) where +instance IsString (Sem r (Doc ann)) where fromString = text ------------------------------------------------------------ @@ -35,73 +30,79 @@ -- Each combinator here mirrors one from Text.PrettyPrint, but -- operates over a generic functor/monad. -vcat :: Applicative f => [f Doc] -> f Doc -vcat ds = PP.vcat <$> sequenceA ds +vcat :: Applicative f => [f (Doc ann)] -> f (Doc ann) +vcat ds = PP.vcat <$> sequenceA ds -hcat :: Applicative f => [f Doc] -> f Doc -hcat ds = PP.hcat <$> sequenceA ds +hcat :: Applicative f => [f (Doc ann)] -> f (Doc ann) +hcat ds = PP.hcat <$> sequenceA ds -hsep :: Applicative f => [f Doc] -> f Doc -hsep ds = PP.hsep <$> sequenceA ds +hsep :: Applicative f => [f (Doc ann)] -> f (Doc ann) +hsep ds = PP.hsep <$> sequenceA ds -parens :: Functor f => f Doc -> f Doc -parens = fmap PP.parens +parens :: Functor f => f (Doc ann) -> f (Doc ann) +parens = fmap PP.parens -brackets :: Functor f => f Doc -> f Doc +brackets :: Functor f => f (Doc ann) -> f (Doc ann) brackets = fmap PP.brackets -braces :: Functor f => f Doc -> f Doc +braces :: Functor f => f (Doc ann) -> f (Doc ann) braces = fmap PP.braces -bag :: Applicative f => f Doc -> f Doc +bag :: Applicative f => f (Doc ann) -> f (Doc ann) bag p = text "⟅" <> p <> text "⟆" -quotes :: Functor f => f Doc -> f Doc -quotes = fmap PP.quotes +quotes :: Functor f => f (Doc ann) -> f (Doc ann) +quotes = fmap PP.squotes -doubleQuotes :: Functor f => f Doc -> f Doc -doubleQuotes = fmap PP.doubleQuotes +doubleQuotes :: Functor f => f (Doc ann) -> f (Doc ann) +doubleQuotes = fmap PP.dquotes -text :: Applicative m => String -> m Doc -text = pure . PP.text +text :: Applicative m => String -> m (Doc ann) +text = pure . fromString -integer :: Applicative m => Integer -> m Doc -integer = pure . PP.integer +integer :: Applicative m => Integer -> m (Doc ann) +integer = pure . PP.pretty -nest :: Functor f => Int -> f Doc -> f Doc +nest :: Functor f => Int -> f (Doc ann) -> f (Doc ann) nest n d = PP.nest n <$> d -hang :: Applicative f => f Doc -> Int -> f Doc -> f Doc -hang d1 n d2 = PP.hang <$> d1 <*> pure n <*> d2 +indent :: Functor f => Int -> f (Doc ann) -> f (Doc ann) +indent n d = PP.indent n <$> d -empty :: Applicative m => m Doc -empty = pure PP.empty +hang :: Applicative f => f (Doc ann) -> Int -> f (Doc ann) -> f (Doc ann) +hang d1 n d2 = d1 <+> nest n d2 -(<+>) :: Applicative f => f Doc -> f Doc -> f Doc +empty :: Applicative m => m (Doc ann) +empty = pure PP.emptyDoc + +(<+>) :: Applicative f => f (Doc ann) -> f (Doc ann) -> f (Doc ann) (<+>) = liftA2 (PP.<+>) -(<>) :: Applicative f => f Doc -> f Doc -> f Doc -(<>) = liftA2 (PP.<>) +(<>) :: Applicative f => f (Doc ann) -> f (Doc ann) -> f (Doc ann) +(<>) = liftA2 (PP.<>) -($+$) :: Applicative f => f Doc -> f Doc -> f Doc -($+$) = liftA2 (PP.$+$) +($+$) :: Applicative f => f (Doc ann) -> f (Doc ann) -> f (Doc ann) +d1 $+$ d2 = f <$> d1 <*> d2 + where + f x1 Empty = x1 + f x1 x2 = PP.vcat [x1, x2] -punctuate :: Applicative f => f Doc -> [f Doc] -> f [f Doc] +punctuate :: Applicative f => f (Doc ann) -> [f (Doc ann)] -> f [f (Doc ann)] punctuate p ds = map pure <$> (PP.punctuate <$> p <*> sequenceA ds) -intercalate :: Monad f => f Doc -> [f Doc] -> f Doc +intercalate :: Monad f => f (Doc ann) -> [f (Doc ann)] -> f (Doc ann) intercalate p ds = do ds' <- punctuate p ds hsep ds' -bulletList :: Applicative f => f Doc -> [f Doc] -> f Doc +bulletList :: Applicative f => f (Doc ann) -> [f (Doc ann)] -> f (Doc ann) bulletList bullet = vcat . map (hang bullet 2) ------------------------------------------------------------ -- Running a pretty-printer -renderDoc :: Sem (Reader PA ': r) Doc -> Sem r String -renderDoc = fmap PP.render . runReader initPA +renderDoc :: Sem (Reader PA ': r) (Doc ann) -> Sem r String +renderDoc = fmap renderDoc' . runReader initPA -renderDoc' :: Doc -> String -renderDoc' = PP.render +renderDoc' :: Doc ann -> String +renderDoc' = renderString . PP.layoutPretty PP.defaultLayoutOptions diff --git a/src/Disco/Pretty/Prec.hs b/src/Disco/Pretty/Prec.hs --- a/src/Disco/Pretty/Prec.hs +++ b/src/Disco/Pretty/Prec.hs @@ -1,4 +1,7 @@ ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Disco.Pretty.Prec -- Copyright : disco team and contributors @@ -7,12 +10,9 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- Precedence and associativity for pretty-printing. --- ------------------------------------------------------------------------------ - module Disco.Pretty.Prec where -import Disco.Syntax.Operators +import Disco.Syntax.Operators -- Types for storing precedence + associativity together diff --git a/src/Disco/Property.hs b/src/Disco/Property.hs --- a/src/Disco/Property.hs +++ b/src/Disco/Property.hs @@ -1,5 +1,7 @@ - ----------------------------------------------------------------------------- +----------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} + -- | -- Module : Disco.Property -- Copyright : disco team and contributors @@ -8,19 +10,37 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- Properties of disco functions. --- ------------------------------------------------------------------------------ +module Disco.Property ( + -- * Generation + generateSamples, -module Disco.Property - where + -- * Utility + invertMotive, + invertPropResult, + -- * Pretty-printing + prettyTestResult, +) +where + +import Prelude hiding ((<>)) + +import Data.Char (toLower) import qualified Data.Enumeration.Invertible as E -import qualified Test.QuickCheck as QC -import Disco.Effects.Random -import Polysemy +import Disco.Effects.Random +import Polysemy -import Disco.Value +import Disco.AST.Typed +import Disco.Effects.Input +import Disco.Effects.LFresh +import Disco.Error +import Disco.Pretty +import Disco.Syntax.Prims +import Disco.Typecheck.Erase (eraseProperty) +import Disco.Types (TyDefCtx) +import Disco.Value +import Polysemy.Reader -- | Toggles which outcome (finding or not finding the thing being -- searched for) qualifies as success, without changing the thing @@ -33,21 +53,125 @@ invertPropResult :: TestResult -> TestResult invertPropResult res@(TestResult b r env) | TestRuntimeError _ <- r = res - | otherwise = TestResult (not b) r env + | otherwise = TestResult (not b) r env +randomLarge :: Member Random r => [Integer] -> Sem r [Integer] +randomLarge [] = return [] +randomLarge [_] = return [] +randomLarge (x : y : xs) = (:) <$> randomR (x, y) <*> randomLarge (y : xs) + -- | Select samples from an enumeration according to a search type. Also returns -- a 'SearchType' describing the results, which may be 'Exhaustive' if the -- enumeration is no larger than the number of samples requested. generateSamples :: Member Random r => SearchType -> E.IEnumeration a -> Sem r ([a], SearchType) -generateSamples Exhaustive e = return (E.enumerate e, Exhaustive) +generateSamples Exhaustive e = return (E.enumerate e, Exhaustive) generateSamples (Randomized n m) e | E.Finite k <- E.card e, k <= n + m = return (E.enumerate e, Exhaustive) - | otherwise = do - let small = [0 .. n] - rs <- runGen . mapM sizedNat $ [n .. n + m] - let samples = map (E.select e) $ small ++ rs - return (samples, Randomized n m) - where - sizedNat k = QC.resize (fromIntegral k) QC.arbitrarySizedNatural + | otherwise = do + let small = [0 .. n] + rs <- randomLarge [100, 1000, 10000, 100000, 1000000] + let samples = map (E.select e) $ small ++ rs + return (samples, Randomized n m) -- XXX do shrinking for randomly generated test cases? + +------------------------------------------------------------ +-- Pretty-printing for test results +------------------------------------------------------------ + +prettyResultCertainty :: Members '[LFresh, Reader PA] r => TestReason -> AProperty -> String -> Sem r (Doc ann) +prettyResultCertainty r prop res = + (if resultIsCertain r then "Certainly" else "Possibly") <+> text res <> ":" <+> pretty (eraseProperty prop) + +prettyTestReason :: + Members '[Input TyDefCtx, LFresh, Reader PA] r => + Bool -> + AProperty -> + TestReason -> + Sem r (Doc ann) +prettyTestReason _ _ TestBool = empty +prettyTestReason b _ (TestFound (TestResult _ _ env)) + | b = prettyTestEnv "Found example:" env + | not b = prettyTestEnv "Found counterexample:" env +prettyTestReason b _ (TestNotFound Exhaustive) + | b = "No counterexamples exist; all possible values were checked." + | not b = "No example exists; all possible values were checked." +prettyTestReason b _ (TestNotFound (Randomized n m)) + | b = "Checked" <+> text (show (n + m)) <+> "possibilities without finding a counterexample." + | not b = "No example was found; checked" <+> text (show (n + m)) <+> "possibilities." +prettyTestReason _ _ (TestEqual t a1 a2) = + bulletList + "-" + [ "Left side: " <> prettyValue t a1 + , "Right side: " <> prettyValue t a2 + ] +prettyTestReason _ _ (TestLt t a1 a2) = + bulletList + "-" + [ "Left side: " <> prettyValue t a1 + , "Right side: " <> prettyValue t a2 + ] +prettyTestReason _ _ (TestRuntimeError ee) = + nest 2 $ + "Test failed with an error:" + $+$ pretty (EvalErr ee) +-- \$+$ +-- prettyTestEnv "Example inputs that caused the error:" env +-- See #364 +prettyTestReason b (ATApp _ (ATPrim _ (PrimBOp _)) (ATTup _ [p1, p2])) (TestBin _ tr1 tr2) = + bulletList + "-" + [ nest 2 $ "Left side:" $+$ prettyTestResult' b p1 tr1 + , nest 2 $ "Right side:" $+$ prettyTestResult' b p2 tr2 + ] +-- See Note [prettyTestReason fallback] +prettyTestReason _ _ _ = empty + +-- ~~~~ Note [prettyTestReason fallback] +-- +-- prettyTestReason can do a decent job printing out reasons for a +-- test result when operators like /\, \/, etc. are written +-- explicitly; then it can structurally recurse on the original Prop +-- expression in parllel with the TestReason. However, it is possible +-- to e.g. write a function which returns a Prop, making the structure +-- of the Prop expression opaque. For example, consider this example +-- (from test/prop-higher-order): +-- +-- !!! all [true, true, true, false, true] +-- all : List(Prop) -> Prop +-- all ps = reduce(~/\~, true, ps) +-- +-- This test is false, and the TestReason ends up with a bunch of +-- nested TestBin LAnd. However, the proposition is literally a +-- function application so we cannot see that it matches the structure +-- of the test result. So we just give up and decline to print a +-- reason. + +prettyTestResult' :: + Members '[Input TyDefCtx, LFresh, Reader PA] r => + Bool -> + AProperty -> + TestResult -> + Sem r (Doc ann) +prettyTestResult' _ prop (TestResult bool tr _) = + prettyResultCertainty tr prop (map toLower (show bool)) + $+$ prettyTestReason bool prop tr + +prettyTestResult :: + Members '[Input TyDefCtx, LFresh, Reader PA] r => + AProperty -> + TestResult -> + Sem r (Doc ann) +prettyTestResult prop (TestResult b r env) = prettyTestResult' b prop (TestResult b r env) + +prettyTestEnv :: + Members '[Input TyDefCtx, LFresh, Reader PA] r => + String -> + TestEnv -> + Sem r (Doc ann) +prettyTestEnv _ (TestEnv []) = empty +prettyTestEnv s (TestEnv vs) = nest 2 $ text s $+$ vcat (map prettyBind vs) + where + maxNameLen = maximum . map (\(n, _, _) -> length n) $ vs + prettyBind (x, ty, v) = + text x <> text (replicate (maxNameLen - length x) ' ') <+> "=" <+> prettyValue ty v diff --git a/src/Disco/Report.hs b/src/Disco/Report.hs --- a/src/Disco/Report.hs +++ b/src/Disco/Report.hs @@ -1,14 +1,5 @@ - ----------------------------------------------------------------------------- --- | --- Module : Disco.Report --- Copyright : disco team and contributors --- Maintainer : byorgey@gmail.com --- --- SPDX-License-Identifier: BSD-3-Clause --- --- XXX --- + ----------------------------------------------------------------------------- -- The benefit of having our own deeply-embedded type for pretty @@ -18,16 +9,24 @@ -- interface of the pretty-printing library currently being used, so -- that a lot of code could just be kept unchanged. +-- | +-- Module : Disco.Report +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- XXX module Disco.Report where -import Data.List (intersperse) +import Data.List (intersperse) data Report - = RTxt String - | RSeq [Report] - | RVSeq [Report] - | RList [Report] - | RNest Report + = RTxt String + | RSeq [Report] + | RVSeq [Report] + | RList [Report] + | RNest Report deriving (Show) text :: String -> Report @@ -52,4 +51,3 @@ nest = RNest ------------------------------------------------------------ - diff --git a/src/Disco/Subst.hs b/src/Disco/Subst.hs --- a/src/Disco/Subst.hs +++ b/src/Disco/Subst.hs @@ -1,6 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + +-- SPDX-License-Identifier: BSD-3-Clause + -- | -- Module : Disco.Subst -- Copyright : disco team and contributors @@ -8,41 +13,39 @@ -- -- The "Disco.Subst" module defines a generic type of substitutions -- that map variable names to values. --- ------------------------------------------------------------------------------ - --- SPDX-License-Identifier: BSD-3-Clause - -module Disco.Subst - ( -- * Substitutions - - Substitution(..), dom - - -- ** Constructing/destructing substitutions - - , idS, (|->), fromList, toList - - -- ** Substitution operations +module Disco.Subst ( + -- * Substitutions + Substitution (..), + dom, - , (@@), compose, applySubst, lookup + -- ** Constructing/destructing substitutions + idS, + (|->), + fromList, + toList, - ) - where + -- ** Substitution operations + (@@), + compose, + applySubst, + lookup, +) +where -import Prelude hiding (lookup) +import Prelude hiding (lookup) -import Unbound.Generics.LocallyNameless (Name, Subst, substs) +import Unbound.Generics.LocallyNameless (Name, Subst, substs) -import Data.Coerce +import Data.Coerce -import Data.Map (Map) -import qualified Data.Map as M -import Data.Set (Set) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Set (Set) -import Disco.Effects.LFresh -import Disco.Pretty -import Polysemy -import Polysemy.Reader +import Disco.Effects.LFresh +import Disco.Pretty +import Polysemy +import Polysemy.Reader -- | A value of type @Substitution a@ is a substitution which maps some set of -- names (the /domain/, see 'dom') to values of type @a@. @@ -57,7 +60,7 @@ -- See also "Disco.Types", which defines 'S' as an alias for -- substitutions on types (the most common kind in the disco -- codebase). -newtype Substitution a = Substitution { getSubst :: Map (Name a) a } +newtype Substitution a = Substitution {getSubst :: Map (Name a) a} deriving (Eq, Ord, Show) instance Functor Substitution where @@ -69,7 +72,7 @@ ds <- punctuate "," es braces (hsep ds) -prettyMapping :: (Pretty a, Members '[Reader PA, LFresh] r) => Name a -> a -> Sem r Doc +prettyMapping :: (Pretty a, Members '[Reader PA, LFresh] r) => Name a -> a -> Sem r (Doc ann) prettyMapping x a = pretty x <+> "->" <+> pretty a -- | The domain of a substitution is the set of names for which the diff --git a/src/Disco/Syntax/Operators.hs b/src/Disco/Syntax/Operators.hs --- a/src/Disco/Syntax/Operators.hs +++ b/src/Disco/Syntax/Operators.hs @@ -1,6 +1,12 @@ -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} + ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + +-- SPDX-License-Identifier: BSD-3-Clause + -- | -- Module : Disco.Syntax.Operators -- Copyright : disco team and contributors @@ -8,77 +14,121 @@ -- -- Unary and binary operators along with information like precedence, -- fixity, and concrete syntax. --- ------------------------------------------------------------------------------ - --- SPDX-License-Identifier: BSD-3-Clause - -module Disco.Syntax.Operators - ( -- * Operators - UOp(..), BOp(..), TyOp(..) - - -- * Operator info - , UFixity(..), BFixity(..), OpFixity(..), OpInfo(..) +module Disco.Syntax.Operators ( + -- * Operators + UOp (..), + BOp (..), + TyOp (..), - -- * Operator tables and lookup - , opTable, uopMap, bopMap - , uPrec, bPrec, assoc, funPrec + -- * Operator info + UFixity (..), + BFixity (..), + OpFixity (..), + OpInfo (..), - ) where + -- * Operator tables and lookup + opTable, + uopMap, + bopMap, + uPrec, + bPrec, + assoc, + funPrec, +) where -import Data.Data (Data) -import GHC.Generics (Generic) -import Unbound.Generics.LocallyNameless +import Data.Data (Data) +import GHC.Generics (Generic) +import Unbound.Generics.LocallyNameless -import Data.Map (Map, (!)) -import qualified Data.Map as M +import Data.Map (Map, (!)) +import qualified Data.Map as M ------------------------------------------------------------ -- Operators ------------------------------------------------------------ -- | Unary operators. -data UOp = Neg -- ^ Arithmetic negation (@-@) - | Not -- ^ Logical negation (@not@) - | Fact -- ^ Factorial (@!@) +data UOp + = -- | Arithmetic negation (@-@) + Neg + | -- | Logical negation (@not@) + Not + | -- | Factorial (@!@) + Fact deriving (Show, Read, Eq, Ord, Generic, Data, Alpha, Subst t) -- | Binary operators. -data BOp = Add -- ^ Addition (@+@) - | Sub -- ^ Subtraction (@-@) - | SSub -- ^ Saturating Subtraction (@.-@ / @∸@) - | Mul -- ^ Multiplication (@*@) - | Div -- ^ Division (@/@) - | Exp -- ^ Exponentiation (@^@) - | IDiv -- ^ Integer division (@//@) - | Eq -- ^ Equality test (@==@) - | Neq -- ^ Not-equal (@/=@) - | Lt -- ^ Less than (@<@) - | Gt -- ^ Greater than (@>@) - | Leq -- ^ Less than or equal (@<=@) - | Geq -- ^ Greater than or equal (@>=@) - | Min -- ^ Minimum (@min@) - | Max -- ^ Maximum (@max@) - | And -- ^ Logical and (@&&@ / @and@) - | Or -- ^ Logical or (@||@ / @or@) - | Impl -- ^ Logical implies (@->@ / @implies@) - | Iff -- ^ Logical biconditional (@<->@ / @iff@) - | Mod -- ^ Modulo (@mod@) - | Divides -- ^ Divisibility test (@|@) - | Choose -- ^ Binomial and multinomial coefficients (@choose@) - | Cons -- ^ List cons (@::@) - | CartProd -- ^ Cartesian product of sets (@**@ / @⨯@) - | Union -- ^ Union of two sets (@union@ / @∪@) - | Inter -- ^ Intersection of two sets (@intersect@ / @∩@) - | Diff -- ^ Difference between two sets (@\@) - | Elem -- ^ Element test (@∈@) - | Subset -- ^ Subset test (@⊆@) - | ShouldEq -- ^ Equality assertion (@=!=@) +data BOp + = -- | Addition (@+@) + Add + | -- | Subtraction (@-@) + Sub + | -- | Saturating Subtraction (@.-@ / @∸@) + SSub + | -- | Multiplication (@*@) + Mul + | -- | Division (@/@) + Div + | -- | Exponentiation (@^@) + Exp + | -- | Integer division (@//@) + IDiv + | -- | Equality test (@==@) + Eq + | -- | Not-equal (@/=@) + Neq + | -- | Less than (@<@) + Lt + | -- | Greater than (@>@) + Gt + | -- | Less than or equal (@<=@) + Leq + | -- | Greater than or equal (@>=@) + Geq + | -- | Minimum (@min@) + Min + | -- | Maximum (@max@) + Max + | -- | Logical and (@&&@ / @and@) + And + | -- | Logical or (@||@ / @or@) + Or + | -- | Logical implies (@->@ / @implies@) + Impl + | -- | Logical biconditional (@<->@ / @iff@) + Iff + | -- | Modulo (@mod@) + Mod + | -- | Divisibility test (@|@) + Divides + | -- | Binomial and multinomial coefficients (@choose@) + Choose + | -- | List cons (@::@) + Cons + | -- | Cartesian product of sets (@**@ / @⨯@) + CartProd + | -- | Union of two sets (@union@ / @∪@) + Union + | -- | Intersection of two sets (@intersect@ / @∩@) + Inter + | -- | Difference between two sets (@\@) + Diff + | -- | Element test (@∈@) + Elem + | -- | Subset test (@⊆@) + Subset + | -- | Equality assertion (@=!=@) + ShouldEq + | -- | Less than assertion (@!<@) + ShouldLt deriving (Show, Read, Eq, Ord, Generic, Data, Alpha, Subst t) -- | Type operators. -data TyOp = Enumerate -- ^ List all values of a type - | Count -- ^ Count how many values there are of a type +data TyOp + = -- | List all values of a type + Enumerate + | -- | Count how many values there are of a type + Count deriving (Show, Eq, Ord, Generic, Data, Alpha, Subst t) ------------------------------------------------------------ @@ -87,34 +137,38 @@ -- | Fixities of unary operators (either pre- or postfix). data UFixity - = Pre -- ^ Unary prefix. - | Post -- ^ Unary postfix. + = -- | Unary prefix. + Pre + | -- | Unary postfix. + Post deriving (Eq, Ord, Enum, Bounded, Show, Generic) -- | Fixity/associativity of infix binary operators (either left, -- right, or non-associative). data BFixity - = InL -- ^ Left-associative infix. - | InR -- ^ Right-associative infix. - | In -- ^ Infix. + = -- | Left-associative infix. + InL + | -- | Right-associative infix. + InR + | -- | Infix. + In deriving (Eq, Ord, Enum, Bounded, Show, Generic) -- | Operators together with their fixity. -data OpFixity = - UOpF UFixity UOp +data OpFixity + = UOpF UFixity UOp | BOpF BFixity BOp deriving (Eq, Show, Generic) -- | An @OpInfo@ record contains information about an operator, such -- as the operator itself, its fixity, a list of concrete syntax -- representations, and a numeric precedence level. -data OpInfo = - OpInfo +data OpInfo = OpInfo { opFixity :: OpFixity - , opSyns :: [String] - , opPrec :: Int + , opSyns :: [String] + , opPrec :: Int } - deriving Show + deriving (Show) ------------------------------------------------------------ -- Operator table @@ -127,74 +181,92 @@ opTable :: [[OpInfo]] opTable = assignPrecLevels - [ [ uopInfo Pre Not ["not", "¬"] - ] - , [ uopInfo Post Fact ["!"] - ] - , [ bopInfo InR Exp ["^"] - ] - , [ uopInfo Pre Neg ["-"] - ] - , [ bopInfo In Choose ["choose"] - ] - , [ bopInfo InR CartProd ["><", "⨯"] - ] - , [ bopInfo InL Union ["union", "∪"] - , bopInfo InL Inter ["intersect", "∩"] - , bopInfo InL Diff ["\\"] - ] - , [ bopInfo InL Min ["min"] - , bopInfo InL Max ["max"] - ] - , [ bopInfo InL Mul ["*"] - , bopInfo InL Div ["/"] - , bopInfo InL Mod ["mod", "%"] - , bopInfo InL IDiv ["//"] - ] - , [ bopInfo InL Add ["+"] - , bopInfo InL Sub ["-"] - , bopInfo InL SSub [".-", "∸"] - ] - , [ bopInfo InR Cons ["::"] - ] - , [ bopInfo InR Eq ["=="] - , bopInfo InR ShouldEq ["=!="] - , bopInfo InR Neq ["/=", "≠"] - , bopInfo InR Lt ["<"] - , bopInfo InR Gt [">"] - , bopInfo InR Leq ["<=", "≤"] - , bopInfo InR Geq [">=", "≥"] - , bopInfo InR Divides ["divides"] - , bopInfo InL Subset ["subset", "⊆"] - , bopInfo InL Elem ["elem", "∈"] - ] - , [ bopInfo InR And ["/\\", "and", "∧", "&&"] - ] - , [ bopInfo InR Or ["\\/", "or", "∨", "||"] - ] - , [ bopInfo InR Impl ["->", "==>", "→", "implies"] - , bopInfo InR Iff ["<->", "<==>", "↔", "iff"] + [ + [ uopInfo Pre Not ["not", "¬"] + ] + , + [ uopInfo Post Fact ["!"] + ] + , + [ bopInfo InR Exp ["^"] + ] + , + [ uopInfo Pre Neg ["-"] + ] + , + [ bopInfo In Choose ["choose"] + ] + , + [ bopInfo InR CartProd ["><", "⨯"] + ] + , + [ bopInfo InL Union ["union", "∪"] + , bopInfo InL Inter ["intersect", "∩"] + , bopInfo InL Diff ["\\"] + ] + , + [ bopInfo InL Min ["min"] + , bopInfo InL Max ["max"] + ] + , + [ bopInfo InL Mul ["*"] + , bopInfo InL Div ["/"] + , bopInfo InL Mod ["mod", "%"] + , bopInfo InL IDiv ["//"] + ] + , + [ bopInfo InL Add ["+"] + , bopInfo InL Sub ["-"] + , bopInfo InL SSub [".-", "∸"] + ] + , + [ bopInfo InR Cons ["::"] + ] + , + [ bopInfo InR Eq ["=="] + , bopInfo InR ShouldEq ["=!="] + , bopInfo InR ShouldLt ["!<"] + , bopInfo InR Neq ["/=", "≠", "!="] + , bopInfo InR Lt ["<"] + , bopInfo InR Gt [">"] + , bopInfo InR Leq ["<=", "≤", "=<"] + , bopInfo InR Geq [">=", "≥", "=>"] + , bopInfo InR Divides ["divides"] + , bopInfo InL Subset ["subset", "⊆"] + , bopInfo InL Elem ["elem", "∈"] + ] + , + [ bopInfo InR And ["/\\", "and", "∧", "&&"] + ] + , + [ bopInfo InR Or ["\\/", "or", "∨", "||"] + ] + , + [ bopInfo InR Impl ["->", "==>", "→", "implies"] + , bopInfo InR Iff ["<->", "<==>", "↔", "iff"] + ] ] - ] - where - uopInfo fx op syns = OpInfo (UOpF fx op) syns (-1) - bopInfo fx op syns = OpInfo (BOpF fx op) syns (-1) + where + uopInfo fx op syns = OpInfo (UOpF fx op) syns (-1) + bopInfo fx op syns = OpInfo (BOpF fx op) syns (-1) - -- Start at precedence level 2 so we can give level 1 to ascription, and level 0 - -- to the ambient context + parentheses etc. - assignPrecLevels table = zipWith assignPrecs (reverse [2 .. length table+1]) table - assignPrecs p ops = map (assignPrec p) ops - assignPrec p op = op { opPrec = p } + -- Start at precedence level 2 so we can give level 1 to ascription, and level 0 + -- to the ambient context + parentheses etc. + assignPrecLevels table = zipWith assignPrecs (reverse [2 .. length table + 1]) table + assignPrec p op = op {opPrec = p} + assignPrecs p = map (assignPrec p) -- | A map from all unary operators to their associated 'OpInfo' records. uopMap :: Map UOp OpInfo -uopMap = M.fromList $ - [ (op, info) | opLevel <- opTable, info@(OpInfo (UOpF _ op) _ _) <- opLevel ] +uopMap = + M.fromList $ + [(op, info) | opLevel <- opTable, info@(OpInfo (UOpF _ op) _ _) <- opLevel] -- | A map from all binary operators to their associatied 'OpInfo' records. bopMap :: Map BOp OpInfo -bopMap = M.fromList $ - [ (op, info) | opLevel <- opTable, info@(OpInfo (BOpF _ op) _ _) <- opLevel ] +bopMap = + M.fromList $ + [(op, info) | opLevel <- opTable, info@(OpInfo (BOpF _ op) _ _) <- opLevel] -- | A convenient function for looking up the precedence of a unary operator. uPrec :: UOp -> Int @@ -209,9 +281,9 @@ assoc op = case M.lookup op bopMap of Just (OpInfo (BOpF fx _) _ _) -> fx - _ -> error $ "BOp " ++ show op ++ " not in bopMap!" + _ -> error $ "BOp " ++ show op ++ " not in bopMap!" -- | The precedence level of function application (higher than any -- other precedence level). funPrec :: Int -funPrec = length opTable+1 +funPrec = length opTable + 1 diff --git a/src/Disco/Syntax/Prims.hs b/src/Disco/Syntax/Prims.hs --- a/src/Disco/Syntax/Prims.hs +++ b/src/Disco/Syntax/Prims.hs @@ -1,6 +1,12 @@ -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} + ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + +-- SPDX-License-Identifier: BSD-3-Clause + -- | -- Module : Disco.Syntax.Prims -- Copyright : disco team and contributors @@ -8,24 +14,22 @@ -- -- Concrete syntax for the prims (i.e. built-in constants) supported -- by the language. --- ------------------------------------------------------------------------------ - --- SPDX-License-Identifier: BSD-3-Clause - -module Disco.Syntax.Prims - ( Prim(..) - , PrimInfo(..), primTable, toPrim, primMap - ) where +module Disco.Syntax.Prims ( + Prim (..), + PrimInfo (..), + primTable, + toPrim, + primMap, +) where -import GHC.Generics (Generic) -import Unbound.Generics.LocallyNameless +import GHC.Generics (Generic) +import Unbound.Generics.LocallyNameless -import Data.Map (Map) -import qualified Data.Map as M +import Data.Map (Map) +import qualified Data.Map as M -import Data.Data (Data) -import Disco.Syntax.Operators +import Data.Data (Data) +import Disco.Syntax.Operators ------------------------------------------------------------ -- Prims @@ -33,57 +37,120 @@ -- | Primitives, /i.e./ built-in constants. data Prim where - PrimUOp :: UOp -> Prim -- ^ Unary operator - PrimBOp :: BOp -> Prim -- ^ Binary operator - - PrimLeft :: Prim -- ^ Left injection into a sum type. - PrimRight :: Prim -- ^ Right injection into a sum type. - - PrimSqrt :: Prim -- ^ Integer square root (@sqrt@) - PrimFloor :: Prim -- ^ Floor of fractional type (@floor@) - PrimCeil :: Prim -- ^ Ceiling of fractional type (@ceiling@) - PrimAbs :: Prim -- ^ Absolute value (@abs@) - - PrimPower :: Prim -- ^ Power set (XXX or bag?) - - PrimList :: Prim -- ^ Container -> list conversion - PrimBag :: Prim -- ^ Container -> bag conversion - PrimSet :: Prim -- ^ Container -> set conversion - - PrimB2C :: Prim -- ^ bag -> set of counts conversion - PrimC2B :: Prim -- ^ set of counts -> bag conversion - PrimUC2B :: Prim -- ^ unsafe set of counts -> bag conversion - -- that assumes all distinct - PrimMapToSet :: Prim -- ^ Map k v -> Set (k × v) - PrimSetToMap :: Prim -- ^ Set (k × v) -> Map k v - - PrimSummary :: Prim -- ^ Get Adjacency list of Graph - PrimVertex :: Prim -- ^ Construct a graph Vertex - PrimEmptyGraph :: Prim -- ^ Empty graph - PrimOverlay :: Prim -- ^ Overlay two Graphs - PrimConnect :: Prim -- ^ Connect Graph to another with directed edges - - PrimInsert :: Prim -- ^ Insert into map - PrimLookup :: Prim -- ^ Get value associated with key in map - - PrimEach :: Prim -- ^ Each operation for containers - PrimReduce :: Prim -- ^ Reduce operation for containers - PrimFilter :: Prim -- ^ Filter operation for containers - PrimJoin :: Prim -- ^ Monadic join for containers - PrimMerge :: Prim -- ^ Generic merge operation for bags/sets - - PrimIsPrime :: Prim -- ^ Efficient primality test - PrimFactor :: Prim -- ^ Factorization - PrimFrac :: Prim -- ^ Turn a rational into a pair (num, denom) - - PrimCrash :: Prim -- ^ Crash - - PrimUntil :: Prim -- ^ @[x, y, z .. e]@ - - PrimHolds :: Prim -- ^ Test whether a proposition holds - - PrimLookupSeq :: Prim -- ^ Lookup OEIS sequence - PrimExtendSeq :: Prim -- ^ Extend OEIS sequence + PrimUOp :: + UOp -> + -- | Unary operator + Prim + PrimBOp :: + BOp -> + -- | Binary operator + Prim + PrimLeft :: + -- | Left injection into a sum type. + Prim + PrimRight :: + -- | Right injection into a sum type. + Prim + PrimSqrt :: + -- | Integer square root (@sqrt@) + Prim + PrimFloor :: + -- | Floor of fractional type (@floor@) + Prim + PrimCeil :: + -- | Ceiling of fractional type (@ceiling@) + Prim + PrimAbs :: + -- | Absolute value (@abs@) + Prim + PrimPower :: + -- | Power set (XXX or bag?) + Prim + PrimList :: + -- | Container -> list conversion + Prim + PrimBag :: + -- | Container -> bag conversion + Prim + PrimSet :: + -- | Container -> set conversion + Prim + PrimB2C :: + -- | bag -> set of counts conversion + Prim + PrimC2B :: + -- | set of counts -> bag conversion + Prim + PrimUC2B :: + -- | unsafe set of counts -> bag conversion + -- that assumes all distinct + Prim + PrimMapToSet :: + -- | Map k v -> Set (k × v) + Prim + PrimSetToMap :: + -- | Set (k × v) -> Map k v + Prim + PrimSummary :: + -- | Get Adjacency list of Graph + Prim + PrimVertex :: + -- | Construct a graph Vertex + Prim + PrimEmptyGraph :: + -- | Empty graph + Prim + PrimOverlay :: + -- | Overlay two Graphs + Prim + PrimConnect :: + -- | Connect Graph to another with directed edges + Prim + PrimInsert :: + -- | Insert into map + Prim + PrimLookup :: + -- | Get value associated with key in map + Prim + PrimEach :: + -- | Each operation for containers + Prim + PrimReduce :: + -- | Reduce operation for containers + Prim + PrimFilter :: + -- | Filter operation for containers + Prim + PrimJoin :: + -- | Monadic join for containers + Prim + PrimMerge :: + -- | Generic merge operation for bags/sets + Prim + PrimIsPrime :: + -- | Efficient primality test + Prim + PrimFactor :: + -- | Factorization + Prim + PrimFrac :: + -- | Turn a rational into a pair (num, denom) + Prim + PrimCrash :: + -- | Crash + Prim + PrimUntil :: + -- | @[x, y, z .. e]@ + Prim + PrimHolds :: + -- | Test whether a proposition holds + Prim + PrimLookupSeq :: + -- | Lookup OEIS sequence + Prim + PrimExtendSeq :: + -- | Extend OEIS sequence + Prim deriving (Show, Read, Eq, Ord, Generic, Alpha, Subst t, Data) ------------------------------------------------------------ @@ -96,84 +163,72 @@ -- the basic language. Unexposed prims can only be referenced by -- enabling the Primitives language extension and prefixing their -- name by @$@. -data PrimInfo = - PrimInfo - { thePrim :: Prim - , primSyntax :: String +data PrimInfo = PrimInfo + { thePrim :: Prim + , primSyntax :: String , primExposed :: Bool - -- Is the prim available in the normal syntax of the language? - -- - -- primExposed = True means that the bare primSyntax can be used - -- in the surface syntax, and the prim will be pretty-printed as - -- the primSyntax. - -- - -- primExposed = False means that the only way to enter it is to - -- enable the Primitives language extension and write a $ - -- followed by the primSyntax. The prim will be pretty-printed with a $ - -- prefix. - -- - -- In no case is a prim a reserved word. + -- Is the prim available in the normal syntax of the language? + -- + -- primExposed = True means that the bare primSyntax can be used + -- in the surface syntax, and the prim will be pretty-printed as + -- the primSyntax. + -- + -- primExposed = False means that the only way to enter it is to + -- enable the Primitives language extension and write a $ + -- followed by the primSyntax. The prim will be pretty-printed with a $ + -- prefix. + -- + -- In no case is a prim a reserved word. } -- | A table containing a 'PrimInfo' record for every non-operator -- 'Prim' recognized by the language. primTable :: [PrimInfo] primTable = - [ PrimInfo PrimLeft "left" True - , PrimInfo PrimRight "right" True - - , PrimInfo (PrimUOp Not) "not" True - , PrimInfo PrimSqrt "sqrt" True - , PrimInfo PrimFloor "floor" True - , PrimInfo PrimCeil "ceiling" True - , PrimInfo PrimAbs "abs" True - - , PrimInfo PrimPower "power" True - - , PrimInfo PrimList "list" True - , PrimInfo PrimBag "bag" True - , PrimInfo PrimSet "set" True - - , PrimInfo PrimB2C "bagCounts" True - , PrimInfo PrimC2B "bagFromCounts" True - , PrimInfo PrimUC2B "unsafeBagFromCounts" False - , PrimInfo PrimMapToSet "mapToSet" True - , PrimInfo PrimSetToMap "map" True - - , PrimInfo PrimSummary "summary" True - , PrimInfo PrimVertex "vertex" True - , PrimInfo PrimEmptyGraph "emptyGraph" True - , PrimInfo PrimOverlay "overlay" True - , PrimInfo PrimConnect "connect" True - - , PrimInfo PrimInsert "insert" True - , PrimInfo PrimLookup "lookup" True - - , PrimInfo PrimEach "each" True - , PrimInfo PrimReduce "reduce" True - , PrimInfo PrimFilter "filter" True - , PrimInfo PrimJoin "join" False - , PrimInfo PrimMerge "merge" False - - , PrimInfo PrimIsPrime "isPrime" False - , PrimInfo PrimFactor "factor" False - , PrimInfo PrimFrac "frac" False - - , PrimInfo PrimCrash "crash" False - - , PrimInfo PrimUntil "until" False - - , PrimInfo PrimHolds "holds" True - + [ PrimInfo PrimLeft "left" True + , PrimInfo PrimRight "right" True + , PrimInfo (PrimUOp Not) "not" True + , PrimInfo PrimSqrt "sqrt" True + , PrimInfo PrimFloor "floor" True + , PrimInfo PrimCeil "ceiling" True + , PrimInfo PrimAbs "abs" True + , PrimInfo PrimPower "power" True + , PrimInfo PrimList "list" True + , PrimInfo PrimBag "bag" True + , PrimInfo PrimSet "set" True + , PrimInfo PrimB2C "bagCounts" True + , PrimInfo PrimC2B "bagFromCounts" True + , PrimInfo PrimUC2B "unsafeBagFromCounts" False + , PrimInfo PrimMapToSet "mapToSet" True + , PrimInfo PrimSetToMap "map" True + , PrimInfo PrimSummary "summary" True + , PrimInfo PrimVertex "vertex" True + , PrimInfo PrimEmptyGraph "emptyGraph" True + , PrimInfo PrimOverlay "overlay" True + , PrimInfo PrimConnect "connect" True + , PrimInfo PrimInsert "insert" True + , PrimInfo PrimLookup "lookup" True + , PrimInfo PrimEach "each" True + , PrimInfo PrimReduce "reduce" True + , PrimInfo PrimFilter "filter" True + , PrimInfo PrimJoin "join" False + , PrimInfo PrimMerge "merge" False + , PrimInfo PrimIsPrime "isPrime" False + , PrimInfo PrimFactor "factor" False + , PrimInfo PrimFrac "frac" False + , PrimInfo PrimCrash "crash" False + , PrimInfo PrimUntil "until" False + , PrimInfo PrimHolds "holds" True , PrimInfo PrimLookupSeq "lookupSequence" False , PrimInfo PrimExtendSeq "extendSequence" False ] -- | Find any exposed prims with the given name. toPrim :: String -> [Prim] -toPrim x = [ p | PrimInfo p syn True <- primTable, syn == x ] +toPrim x = [p | PrimInfo p syn True <- primTable, syn == x] -- | A convenient map from each 'Prim' to its info record. primMap :: Map Prim PrimInfo -primMap = M.fromList $ - [ (p, pinfo) | pinfo@(PrimInfo p _ _) <- primTable ] +primMap = + M.fromList $ + [(p, pinfo) | pinfo@(PrimInfo p _ _) <- primTable] diff --git a/src/Disco/Typecheck.hs b/src/Disco/Typecheck.hs --- a/src/Disco/Typecheck.hs +++ b/src/Disco/Typecheck.hs @@ -1,1680 +1,1703 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE OverloadedStrings #-} - ------------------------------------------------------------------------------ --- | --- Module : Disco.Typecheck --- Copyright : disco team and contributors --- Maintainer : byorgey@gmail.com --- --- SPDX-License-Identifier: BSD-3-Clause --- --- Typecheck the Disco surface language and transform it into a --- type-annotated AST. --- ------------------------------------------------------------------------------ - -module Disco.Typecheck where - -import Control.Arrow ((&&&)) -import Control.Lens ((^..)) -import Control.Monad.Except -import Control.Monad.Trans.Maybe -import Data.Bifunctor (first) -import Data.Coerce -import qualified Data.Foldable as F -import Data.List (group, sort) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (isJust) -import Data.Set (Set) -import qualified Data.Set as S -import Prelude as P hiding (lookup) - -import Unbound.Generics.LocallyNameless (Alpha, Bind, Name, - bind, embed, - name2String, - string2Name, substs, - unembed) -import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) - -import Disco.Effects.Fresh -import Polysemy hiding (embed) -import Polysemy.Error -import Polysemy.Output -import Polysemy.Reader -import Polysemy.Writer - -import Disco.AST.Surface -import Disco.AST.Typed -import Disco.Context hiding (filter) -import qualified Disco.Context as Ctx -import Disco.Messages -import Disco.Module -import Disco.Names -import Disco.Subst (applySubst) -import qualified Disco.Subst as Subst -import Disco.Syntax.Operators -import Disco.Syntax.Prims -import Disco.Typecheck.Constraints -import Disco.Typecheck.Util -import Disco.Types -import Disco.Types.Rules - ------------------------------------------------------------- --- Container utilities ------------------------------------------------------------- - -containerTy :: Container -> Type -> Type -containerTy c ty = TyCon (containerToCon c) [ty] - -containerToCon :: Container -> Con -containerToCon ListContainer = CList -containerToCon BagContainer = CBag -containerToCon SetContainer = CSet - ------------------------------------------------------------- --- Telescopes ------------------------------------------------------------- - --- | Infer the type of a telescope, given a way to infer the type of --- each item along with a context of variables it binds; each such --- context is then added to the overall context when inferring --- subsequent items in the telescope. -inferTelescope - :: (Alpha b, Alpha tyb, Member (Reader TyCtx) r) - => (b -> Sem r (tyb, TyCtx)) -> Telescope b -> Sem r (Telescope tyb, TyCtx) -inferTelescope inferOne tel = do - (tel1, ctx) <- go (fromTelescope tel) - return (toTelescope tel1, ctx) - where - go [] = return ([], emptyCtx) - go (b:bs) = do - (tyb, ctx) <- inferOne b - extends ctx $ do - (tybs, ctx') <- go bs - return (tyb:tybs, ctx <> ctx') - ------------------------------------------------------------- --- Modules ------------------------------------------------------------- - --- | Check all the types and extract all relevant info (docs, --- properties, types) from a module, returning a 'ModuleInfo' record --- on success. This function does not handle imports at all; any --- imports should already be checked and passed in as the second --- argument. -checkModule - :: Members '[Output Message, Reader TyCtx, Reader TyDefCtx, Error LocTCError, Fresh] r - => ModuleName -> Map ModuleName ModuleInfo -> Module -> Sem r ModuleInfo -checkModule name imports (Module es _ m docs terms) = do - let (typeDecls, defns, tydefs) = partitionDecls m - importTyCtx = mconcat (imports ^.. traverse . miTys) - -- XXX this isn't right, if multiple modules define the same type synonyms. - -- Need to use a normal Ctx for tydefs too. - importTyDefnCtx = M.unions (imports ^.. traverse . miTydefs) - tyDefnCtx <- mapError noLoc $ makeTyDefnCtx tydefs - withTyDefns (tyDefnCtx `M.union` importTyDefnCtx) $ do - tyCtx <- mapError noLoc $ makeTyCtx name typeDecls - extends importTyCtx $ extends tyCtx $ do - mapM_ (checkTyDefn name) tydefs - adefns <- mapM (checkDefn name) defns - let defnCtx = ctxForModule name (map (getDefnName &&& id) adefns) - docCtx = ctxForModule name docs - dups = filterDups . map getDefnName $ adefns - case dups of - (x:_) -> throw $ noLoc $ DuplicateDefns (coerce x) - [] -> do - aprops <- mapError noLoc $ checkProperties docCtx -- XXX location? - aterms <- mapError noLoc $ mapM inferTop terms -- XXX location? - return $ ModuleInfo name imports (map ((name .-) . getDeclName) typeDecls) docCtx aprops tyCtx tyDefnCtx defnCtx aterms es - where getDefnName :: Defn -> Name ATerm - getDefnName (Defn n _ _ _) = n - - getDeclName :: TypeDecl -> Name Term - getDeclName (TypeDecl n _) = n - --------------------------------------------------- --- Type definitions - --- | Turn a list of type definitions into a 'TyDefCtx', checking --- for duplicate names among the definitions and also any type --- definitions already in the context. -makeTyDefnCtx :: Members '[Reader TyDefCtx, Error TCError] r => [TypeDefn] -> Sem r TyDefCtx -makeTyDefnCtx tydefs = do - oldTyDefs <- ask @TyDefCtx - let oldNames = M.keys oldTyDefs - newNames = map (\(TypeDefn x _ _) -> x) tydefs - dups = filterDups $ newNames ++ oldNames - - let convert (TypeDefn x args body) - = (x, TyDefBody args (flip substs body . zip (map string2Name args))) - - case dups of - (x:_) -> throw (DuplicateTyDefns x) - [] -> return . M.fromList $ map convert tydefs - --- | Check the validity of a type definition. -checkTyDefn :: Members '[Reader TyDefCtx, Error LocTCError] r => ModuleName -> TypeDefn -> Sem r () -checkTyDefn name defn@(TypeDefn x args body) = mapError (LocTCError (Just (name .- string2Name x))) $ do - - -- First, make sure the body is a valid type, i.e. everything inside - -- it is well-kinded. - checkTypeValid body - - -- Now make sure it is not directly cyclic (i.e. ensure it is a - -- "productive" definition). - _ <- checkCyclicTy (TyUser x (map (TyVar . string2Name) args)) S.empty - - -- Make sure it does not use any unbound type variables or undefined - -- types. - checkUnboundVars defn - - -- Make sure it does not use any polymorphic recursion (polymorphic - -- recursion isn't allowed at the moment since it can make the - -- subtyping checker diverge). - checkPolyRec defn - --- | Check if a given type is cyclic. A type 'ty' is cyclic if: --- --- 1. 'ty' is the name of a user-defined type. --- 2. Repeated expansions of the type yield nothing but other user-defined types. --- 3. An expansion of one of those types yields another type that has --- been previously encountered. --- --- In other words, repeatedly expanding the definition can get us --- back to exactly where we started. --- --- The function returns the set of TyDefs encountered during --- expansion if the TyDef is not cyclic. -checkCyclicTy :: Members '[Reader TyDefCtx, Error TCError] r => Type -> Set String -> Sem r (Set String) -checkCyclicTy (TyUser name args) set = do - case S.member name set of - True -> throw $ CyclicTyDef name - False -> do - ty <- lookupTyDefn name args - checkCyclicTy ty (S.insert name set) - -checkCyclicTy _ set = return set - --- | Ensure that a type definition does not use any unbound type --- variables or undefined types. -checkUnboundVars :: Members '[Reader TyDefCtx, Error TCError] r => TypeDefn -> Sem r () -checkUnboundVars (TypeDefn _ args body) = go body - where - go (TyAtom (AVar (U x))) - | name2String x `elem` args = return () - | otherwise = throw $ UnboundTyVar x - go (TyAtom _) = return () - go (TyUser name tys) = lookupTyDefn name tys >> mapM_ go tys - go (TyCon _ tys) = mapM_ go tys - --- | Check for polymorphic recursion: starting from a user-defined --- type, keep expanding its definition recursively, ensuring that --- any recursive references to the defined type have only type variables --- as arguments. -checkPolyRec :: Member (Error TCError) r => TypeDefn -> Sem r () -checkPolyRec (TypeDefn name args body) = go body - where - go (TyCon (CUser x) tys) - | x == name && not (all isTyVar tys) = - throw $ NoPolyRec name args tys - | otherwise = return () - go (TyCon _ tys) = mapM_ go tys - go _ = return () - --- | Keep only the duplicate elements from a list. --- --- >>> filterDups [1,3,2,1,1,4,2] --- [1,2] -filterDups :: Ord a => [a] -> [a] -filterDups = map head . filter ((>1) . length) . group . sort - --------------------------------------------------- --- Type declarations - --- | Given a list of type declarations from a module, first check that --- there are no duplicate type declarations, and that the types are --- well-formed; then create a type context containing the given --- declarations. -makeTyCtx :: Members '[Reader TyDefCtx, Error TCError] r => ModuleName -> [TypeDecl] -> Sem r TyCtx -makeTyCtx name decls = do - let dups = filterDups . map (\(TypeDecl x _) -> x) $ decls - case dups of - (x:_) -> throw (DuplicateDecls x) - [] -> do - checkCtx declCtx - return declCtx - where - declCtx = ctxForModule name $ map (\(TypeDecl x ty) -> (x,ty)) decls - --- | Check that all the types in a context are valid. -checkCtx :: Members '[Reader TyDefCtx, Error TCError] r => TyCtx -> Sem r () -checkCtx = mapM_ checkPolyTyValid . Ctx.elems - --------------------------------------------------- --- Top-level definitions - --- | Type check a top-level definition in the given module. -checkDefn - :: Members '[Reader TyCtx, Reader TyDefCtx, Error LocTCError, Fresh, Output Message] r - => ModuleName -> TermDefn -> Sem r Defn -checkDefn name (TermDefn x clauses) = mapError (LocTCError (Just (name .- x))) $ do - - -- Check that all clauses have the same number of patterns - checkNumPats clauses - - -- Get the declared type signature of x - Forall sig <- lookup (name .- x) >>= maybe (throw $ NoType x) return - -- If x isn't in the context, it's because no type was declared for it, so - -- throw an error. - (nms, ty) <- unbind sig - - -- Try to decompose the type into a chain of arrows like pty1 -> - -- pty2 -> pty3 -> ... -> bodyTy, according to the number of - -- patterns, and lazily unrolling type definitions along the way. - (patTys, bodyTy) <- decomposeDefnTy (numPats (head clauses)) ty - - ((acs, _), theta) <- solve $ do - aclauses <- forAll nms $ mapM (checkClause patTys bodyTy) clauses - return (aclauses, ty) - - return $ applySubst theta (Defn (coerce x) patTys bodyTy acs) - where - numPats = length . fst . unsafeUnbind - - checkNumPats [] = return () -- This can't happen, but meh - checkNumPats [_] = return () - checkNumPats (c:cs) - | all ((==0) . numPats) (c:cs) = throw (DuplicateDefns x) - | not (all ((== numPats c) . numPats) cs) = throw NumPatterns - -- XXX more info, this error actually means # of - -- patterns don't match across different clauses - | otherwise = return () - - -- | Check a clause of a definition against a list of pattern types and a body type. - checkClause - :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r - => [Type] -> Type -> Bind [Pattern] Term -> Sem r Clause - checkClause patTys bodyTy clause = do - (pats, body) <- unbind clause - - -- At this point we know that every clause has the same number of patterns, - -- which is the same as the length of the list patTys. So we can just use - -- zipWithM to check all the patterns. - (ctxs, aps) <- unzip <$> zipWithM checkPattern pats patTys - at <- extends (mconcat ctxs) $ check body bodyTy - return $ bind aps at - - -- Decompose a type that must be of the form t1 -> t2 -> ... -> tn -> t{n+1}. - decomposeDefnTy :: Members '[Reader TyDefCtx, Error TCError] r => Int -> Type -> Sem r ([Type], Type) - decomposeDefnTy 0 ty = return ([], ty) - decomposeDefnTy n (TyUser tyName args) = lookupTyDefn tyName args >>= decomposeDefnTy n - decomposeDefnTy n (ty1 :->: ty2) = first (ty1:) <$> decomposeDefnTy (n-1) ty2 - decomposeDefnTy _n _ty = throw NumPatterns - -- XXX include more info. More argument patterns than arrows in the type. - --------------------------------------------------- --- Properties - --- | Given a context mapping names to documentation, extract the --- properties attached to each name and typecheck them. -checkProperties - :: Members '[Reader TyCtx, Reader TyDefCtx, Error TCError, Fresh, Output Message] r - => Ctx Term Docs -> Sem r (Ctx ATerm [AProperty]) -checkProperties docs = - Ctx.coerceKeys . Ctx.filter (not . P.null) - <$> (traverse . traverse) checkProperty properties - where - properties :: Ctx Term [Property] - properties = fmap (\ds -> [p | DocProperty p <- ds]) docs - --- | Check the types of the terms embedded in a property. -checkProperty - :: Members '[Reader TyCtx, Reader TyDefCtx, Error TCError, Fresh, Output Message] r - => Property -> Sem r AProperty -checkProperty prop = do - (at, theta) <- solve $ check prop TyProp - -- XXX do we need to default container variables here? - return $ applySubst theta at - ------------------------------------------------------------- --- Type checking/inference ------------------------------------------------------------- - --------------------------------------------------- --- Checking types/kinds --------------------------------------------------- - --- | Check that a sigma type is a valid type. See 'checkTypeValid'. -checkPolyTyValid :: Members '[Reader TyDefCtx, Error TCError] r => PolyType -> Sem r () -checkPolyTyValid (Forall b) = do - let (_, ty) = unsafeUnbind b - checkTypeValid ty - --- | Disco doesn't need kinds per se, since all types must be fully --- applied. But we do need to check that every type is applied to --- the correct number of arguments. -checkTypeValid :: Members '[Reader TyDefCtx, Error TCError] r => Type -> Sem r () -checkTypeValid (TyAtom _) = return () -checkTypeValid (TyCon c tys) = do - k <- conArity c - if | n < k -> throw (NotEnoughArgs c) - | n > k -> throw (TooManyArgs c) - | otherwise -> mapM_ checkTypeValid tys - where - n = length tys - -conArity :: Members '[Reader TyDefCtx, Error TCError] r => Con -> Sem r Int -conArity (CContainer _) = return 1 -conArity CGraph = return 1 -conArity (CUser name) = do - d <- ask @TyDefCtx - case M.lookup name d of - Nothing -> throw (NotTyDef name) - Just (TyDefBody as _) -> return (length as) -conArity _ = return 2 -- (->, *, +, map) - --------------------------------------------------- --- Checking modes --------------------------------------------------- - --- | Typechecking can be in one of two modes: inference mode means we --- are trying to synthesize a valid type for a term; checking mode --- means we are trying to show that a term has a given type. -data Mode = Infer | Check Type - deriving Show - --- | Check that a term has the given type. Either throws an error, or --- returns the term annotated with types for all subterms. --- --- This function is provided for convenience; it simply calls --- 'typecheck' with an appropriate 'Mode'. -check - :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r - => Term -> Type -> Sem r ATerm -check t ty = typecheck (Check ty) t - --- | Check that a term has the given polymorphic type. -checkPolyTy - :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r - => Term -> PolyType -> Sem r ATerm -checkPolyTy t (Forall sig) = do - (as, tau) <- unbind sig - (at, cst) <- withConstraint $ check t tau - case as of - [] -> constraint cst - _ -> constraint $ CAll (bind as cst) - return at - --- | Infer the type of a term. If it succeeds, it returns the term --- with all subterms annotated. --- --- This function is provided for convenience; it simply calls --- 'typecheck' with an appropriate 'Mode'. -infer - :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r - => Term -> Sem r ATerm -infer = typecheck Infer - --- | Top-level type inference algorithm: infer a (polymorphic) type --- for a term by running type inference, solving the resulting --- constraints, and quantifying over any remaining type variables. -inferTop - :: Members '[Output Message, Reader TyCtx, Reader TyDefCtx, Error TCError, Fresh] r - => Term -> Sem r (ATerm, PolyType) -inferTop t = do - - -- Run inference on the term and try to solve the resulting - -- constraints. - (at, theta) <- solve $ infer t - - debug "Final annotated term (before substitution and container monomorphizing):" - debugPretty at - - -- Apply the resulting substitution. - let at' = applySubst theta at - - -- Find any remaining container variables. - cvs = containerVars (getType at') - - -- Replace them all with List. - at'' = applySubst (Subst.fromList $ zip (S.toList cvs) (repeat (TyAtom (ABase CtrList)))) at' - - -- Finally, quantify over any remaining type variables and return - -- the term along with the resulting polymorphic type. - return (at'', closeType (getType at'')) - --- | Top-level type checking algorithm: check that a term has a given --- polymorphic type by running type checking and solving the --- resulting constraints. -checkTop - :: Members '[Output Message, Reader TyCtx, Reader TyDefCtx, Error TCError, Fresh] r - => Term -> PolyType -> Sem r ATerm -checkTop t ty = do - (at, theta) <- solve $ checkPolyTy t ty - return $ applySubst theta at - --------------------------------------------------- --- The typecheck function --------------------------------------------------- - --- | The main workhorse of the typechecker. Instead of having two --- functions, one for inference and one for checking, 'typecheck' --- takes a 'Mode'. This cuts down on code duplication in many --- cases, and allows all the checking and inference code related to --- a given AST node to be placed together. -typecheck - :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r - => Mode -> Term -> Sem r ATerm - --- ~~~~ Note [Pattern coverage] --- In several places we have clauses like --- --- inferPrim (PrimBOp op) | op `elem` [And, Or, Impl, Iff] --- --- since the typing rules for all the given operators are the same. --- The only problem is that the pattern coverage checker (sensibly) --- doesn't look at guards in general, so it thinks that there are TBin --- cases still uncovered. --- --- However, we *don't* just want to add a catch-all case at the end, --- because the coverage checker is super helpful in alerting us when --- there's a missing typechecking case after modifying the language in --- some way. The (not ideal) solution for now is to add some --- additional explicit cases that simply call 'error', which will --- never be reached but which assure the coverage checker that we have --- handled those cases. --- --- The ideal solution would be to use or-patterns, if Haskell had them --- (see https://github.com/ghc-proposals/ghc-proposals/pull/43). - --------------------------------------------------- --- Defined types - --- To check at a user-defined type, expand its definition and recurse. --- This case has to be first, so in all other cases we know the type --- will not be a TyUser. -typecheck (Check (TyUser name args)) t = lookupTyDefn name args >>= check t - --------------------------------------------------- --- Parens - --- Recurse through parens; they are not represented explicitly in the --- resulting ATerm. -typecheck mode (TParens t) = typecheck mode t - --------------------------------------------------- --- Variables - --- Resolve variable names and infer their types. We don't need a --- checking case; checking the type of a variable will fall through to --- this case. -typecheck Infer (TVar x) = do - - -- Pick the first method that succeeds; if none do, throw an unbound - -- variable error. - mt <- runMaybeT . F.asum . map MaybeT $ [tryLocal, tryModule, tryPrim] - maybe (throw (Unbound x)) return mt - where - -- 1. See if the variable name is bound locally. - tryLocal = do - mty <- Ctx.lookup (localName x) - case mty of - Just (Forall sig) -> do - (_, ty) <- unbind sig - return . Just $ ATVar ty (localName (coerce x)) - Nothing -> return Nothing - - -- 2. See if the variable name is bound in some in-scope module, - -- throwing an ambiguity error if it is bound in multiple modules. - tryModule = do - bs <- Ctx.lookupNonLocal x - case bs of - [(m,Forall sig)] -> do - (_, ty) <- unbind sig - return . Just $ ATVar ty (m .- coerce x) - [] -> return Nothing - _ -> throw $ Ambiguous x (map fst bs) - - -- 3. See if we should convert it to a primitive. - tryPrim = - case toPrim (name2String x) of - (prim:_) -> Just <$> typecheck Infer (TPrim prim) - _ -> return Nothing - --------------------------------------------------- --- Primitives - -typecheck Infer (TPrim prim) = do - ty <- inferPrim prim - return $ ATPrim ty prim - - where - inferPrim :: Members '[Writer Constraint, Fresh] r => Prim -> Sem r Type - - ---------------------------------------- - -- Left/right - - inferPrim PrimLeft = do - a <- freshTy - b <- freshTy - return $ a :->: (a :+: b) - - inferPrim PrimRight = do - a <- freshTy - b <- freshTy - return $ b :->: (a :+: b) - - ---------------------------------------- - -- Logic - - --- XXX restore typing rules for logical operations on Props - --- once the evaluator can handle them. - - inferPrim (PrimBOp op) | op `elem` [And, Or, Impl, Iff] = do - return $ TyBool :*: TyBool :->: TyBool - -- a <- freshTy - -- constraint $ CQual (bopQual op) a - -- return $ a :*: a :->: a - - -- See Note [Pattern coverage] ----------------------------- - inferPrim (PrimBOp And) = error "inferPrim And should be unreachable" - inferPrim (PrimBOp Or) = error "inferPrim Or should be unreachable" - inferPrim (PrimBOp Impl) = error "inferPrim Impl should be unreachable" - inferPrim (PrimBOp Iff) = error "inferPrim Iff should be unreachable" - ------------------------------------------------------------ - - inferPrim (PrimUOp Not) = do - return $ TyBool :->: TyBool - -- a <- freshTy - -- constraint $ CQual QBool a - -- return $ a :->: a - - ---------------------------------------- - -- Container conversion - - inferPrim conv | conv `elem` [PrimList, PrimBag, PrimSet] = do - c <- freshAtom -- make a unification variable for the container type - a <- freshTy -- make a unification variable for the element type - - -- converting to a set or bag requires being able to sort the elements - when (conv /= PrimList) $ constraint $ CQual QCmp a - - return $ TyContainer c a :->: primCtrCon conv a - - where - primCtrCon PrimList = TyList - primCtrCon PrimBag = TyBag - primCtrCon _ = TySet - - -- See Note [Pattern coverage] ----------------------------- - inferPrim PrimList = error "inferPrim PrimList should be unreachable" - inferPrim PrimBag = error "inferPrim PrimBag should be unreachable" - inferPrim PrimSet = error "inferPrim PrimSet should be unreachable" - ------------------------------------------------------------ - - inferPrim PrimB2C = do - a <- freshTy - return $ TyBag a :->: TySet (a :*: TyN) - - inferPrim PrimC2B = do - a <- freshTy - c <- freshAtom - constraint $ CQual QCmp a - return $ TyContainer c (a :*: TyN) :->: TyBag a - - inferPrim PrimUC2B = do - a <- freshTy - c <- freshAtom - return $ TyContainer c (a :*: TyN) :->: TyBag a - - inferPrim PrimMapToSet = do - k <- freshTy - v <- freshTy - constraint $ CQual QSimple k - return $ TyMap k v :->: TySet (k :*: v) - - inferPrim PrimSetToMap = do - k <- freshTy - v <- freshTy - constraint $ CQual QSimple k - return $ TySet (k :*: v) :->: TyMap k v - - inferPrim PrimSummary = do - a <- freshTy - constraint $ CQual QSimple a - return $ TyGraph a :->: TyMap a (TySet a) - - inferPrim PrimVertex = do - a <- freshTy - constraint $ CQual QSimple a - return $ a :->: TyGraph a - - inferPrim PrimEmptyGraph = do - a <- freshTy - constraint $ CQual QSimple a - return $ TyGraph a - - inferPrim PrimOverlay = do - a <- freshTy - constraint $ CQual QSimple a - return $ TyGraph a :*: TyGraph a :->: TyGraph a - - inferPrim PrimConnect = do - a <- freshTy - constraint $ CQual QSimple a - return $ TyGraph a :*: TyGraph a :->: TyGraph a - - inferPrim PrimInsert = do - a <- freshTy - b <- freshTy - constraint $ CQual QSimple a - return $ a :*: b :*: TyMap a b :->: TyMap a b - - inferPrim PrimLookup = do - a <- freshTy - b <- freshTy - constraint $ CQual QSimple a - return $ a :*: TyMap a b :->: (TyUnit :+: b) - ---------------------------------------- - -- Container primitives - - inferPrim (PrimBOp Cons) = do - a <- freshTy - return $ a :*: TyList a :->: TyList a - - -- XXX see https://github.com/disco-lang/disco/issues/160 - -- each : (a -> b) × c a -> c b - inferPrim PrimEach = do - c <- freshAtom - a <- freshTy - b <- freshTy - return $ (a :->: b) :*: TyContainer c a :->: TyContainer c b - - -- XXX should eventually be (a * a -> a) * c a -> a, - -- with a check that the function has the right properties. - -- reduce : (a * a -> a) * a * c a -> a - inferPrim PrimReduce = do - c <- freshAtom - a <- freshTy - return $ (a :*: a :->: a) :*: a :*: TyContainer c a :->: a - - -- filter : (a -> Bool) × c a -> c a - inferPrim PrimFilter = do - c <- freshAtom - a <- freshTy - return $ (a :->: TyBool) :*: TyContainer c a :->: TyContainer c a - - -- join : c (c a) -> c a - inferPrim PrimJoin = do - c <- freshAtom - a <- freshTy - return $ TyContainer c (TyContainer c a) :->: TyContainer c a - - -- merge : (N × N -> N) × c a × c a -> c a (c = bag or set) - inferPrim PrimMerge = do - c <- freshAtom - a <- freshTy - constraint $ COr - [ CEq (TyAtom (ABase CtrBag)) (TyAtom c) - , CEq (TyAtom (ABase CtrSet)) (TyAtom c) - ] - let ca = TyContainer c a - return $ (TyN :*: TyN :->: TyN) :*: ca :*: ca :->: ca - - inferPrim (PrimBOp CartProd) = do - a <- freshTy - b <- freshTy - c <- freshAtom - return $ TyContainer c a :*: TyContainer c b :->: TyContainer c (a :*: b) - - inferPrim (PrimBOp setOp) | setOp `elem` [Union, Inter, Diff, Subset] = do - a <- freshTy - c <- freshAtom - constraint $ COr - [ CEq (TyAtom (ABase CtrBag)) (TyAtom c) - , CEq (TyAtom (ABase CtrSet)) (TyAtom c) - ] - let ca = TyContainer c a - let resTy = case setOp of {Subset -> TyBool; _ -> ca} - return $ ca :*: ca :->: resTy - - -- See Note [Pattern coverage] ----------------------------- - inferPrim (PrimBOp Union) = error "inferPrim Union should be unreachable" - inferPrim (PrimBOp Inter) = error "inferPrim Inter should be unreachable" - inferPrim (PrimBOp Diff) = error "inferPrim Diff should be unreachable" - inferPrim (PrimBOp Subset) = error "inferPrim Subset should be unreachable" - ------------------------------------------------------------ - - inferPrim (PrimBOp Elem) = do - a <- freshTy - c <- freshAtom - - constraint $ CQual QCmp a - - return $ a :*: TyContainer c a :->: TyBool - - ---------------------------------------- - -- Arithmetic - - inferPrim (PrimBOp IDiv) = do - a <- freshTy - resTy <- cInt a - return $ a :*: a :->: resTy - - inferPrim (PrimBOp Mod) = do - a <- freshTy - constraint $ CSub a TyZ - return $ a :*: a :->: a - - inferPrim (PrimBOp op) | op `elem` [Add, Mul, Sub, Div, SSub] = do - a <- freshTy - constraint $ CQual (bopQual op) a - return $ a :*: a :->: a - - -- See Note [Pattern coverage] ----------------------------- - inferPrim (PrimBOp Add ) = error "inferPrim Add should be unreachable" - inferPrim (PrimBOp Mul ) = error "inferPrim Mul should be unreachable" - inferPrim (PrimBOp Sub ) = error "inferPrim Sub should be unreachable" - inferPrim (PrimBOp Div ) = error "inferPrim Div should be unreachable" - inferPrim (PrimBOp SSub) = error "inferPrim SSub should be unreachable" - ------------------------------------------------------------ - - inferPrim (PrimUOp Neg) = do - a <- freshTy - constraint $ CQual QSub a - return $ a :->: a - - inferPrim (PrimBOp Exp) = do - a <- freshTy - b <- freshTy - resTy <- cExp a b - return $ a :*: b :->: resTy - - ---------------------------------------- - -- Number theory - - inferPrim PrimIsPrime = return $ TyN :->: TyBool - inferPrim PrimFactor = return $ TyN :->: TyBag TyN - - inferPrim PrimFrac = return $ TyQ :->: (TyZ :*: TyN) - - inferPrim (PrimBOp Divides) = do - a <- freshTy - constraint $ CQual QNum a - return $ a :*: a :->: TyBool - - ---------------------------------------- - -- Choose - - -- For now, a simple typing rule for multinomial coefficients that - -- requires everything to be Nat. However, they can be extended to - -- handle negative or fractional arguments. - inferPrim (PrimBOp Choose) = do - b <- freshTy - - -- b can be either Nat (a binomial coefficient) - -- or a list of Nat (a multinomial coefficient). - constraint $ COr [CEq b TyN, CEq b (TyList TyN)] - return $ TyN :*: b :->: TyN - - ---------------------------------------- - -- Ellipses - - -- Actually 'until' supports more types than this, e.g. Q instead - -- of N, but this is good enough. This case is here just for - -- completeness---in case someone enables primitives and uses it - -- directly---but typically 'until' is generated only during - -- desugaring of a container with ellipsis, after typechecking, in - -- which case it can be assigned a more appropriate type directly. - - inferPrim PrimUntil = return $ TyN :*: TyList TyN :->: TyList TyN - - ---------------------------------------- - -- Crash - - inferPrim PrimCrash = do - a <- freshTy - return $ TyString :->: a - - ---------------------------------------- - -- Propositions - - -- 'holds' converts a Prop into a Bool (but might not terminate). - inferPrim PrimHolds = return $ TyProp :->: TyBool - - -- An equality assertion =!= is just like a comparison ==, except - -- the result is a Prop. - inferPrim (PrimBOp ShouldEq) = do - ty <- freshTy - constraint $ CQual QCmp ty - return $ ty :*: ty :->: TyProp - - ---------------------------------------- - -- Comparisons - - -- Infer the type of a comparison. A comparison always has type - -- Bool, but we have to make sure the subterms have compatible - -- types. We also generate a QCmp qualifier, for two reasons: - -- one, we need to know whether e.g. a comparison was done at a - -- certain type, so we can decide whether the type is allowed to - -- be completely polymorphic or not. Also, comparison of Props is - -- not allowed. - inferPrim (PrimBOp op) | op `elem` [Eq, Neq, Lt, Gt, Leq, Geq] = do - ty <- freshTy - constraint $ CQual QCmp ty - return $ ty :*: ty :->: TyBool - - -- See Note [Pattern coverage] ----------------------------- - inferPrim (PrimBOp Eq) = error "inferPrim Eq should be unreachable" - inferPrim (PrimBOp Neq) = error "inferPrim Neq should be unreachable" - inferPrim (PrimBOp Lt) = error "inferPrim Lt should be unreachable" - inferPrim (PrimBOp Gt) = error "inferPrim Gt should be unreachable" - inferPrim (PrimBOp Leq) = error "inferPrim Leq should be unreachable" - inferPrim (PrimBOp Geq) = error "inferPrim Geq should be unreachable" - ------------------------------------------------------------ - - inferPrim (PrimBOp op) | op `elem` [Min, Max] = do - ty <- freshTy - constraint $ CQual QCmp ty - return $ ty :*: ty :->: ty - - -- See Note [Pattern coverage] ----------------------------- - inferPrim (PrimBOp Min) = error "inferPrim Min should be unreachable" - inferPrim (PrimBOp Max) = error "inferPrim Max should be unreachable" - ------------------------------------------------------------ - - ---------------------------------------- - -- Special arithmetic functions: fact, sqrt, floor, ceil, abs - - inferPrim (PrimUOp Fact) = return $ TyN :->: TyN - inferPrim PrimSqrt = return $ TyN :->: TyN - - inferPrim p | p `elem` [PrimFloor, PrimCeil] = do - argTy <- freshTy - resTy <- cInt argTy - return $ argTy :->: resTy - - -- See Note [Pattern coverage] ----------------------------- - inferPrim PrimFloor = error "inferPrim Floor should be unreachable" - inferPrim PrimCeil = error "inferPrim Ceil should be unreachable" - ------------------------------------------------------------ - - inferPrim PrimAbs = do - argTy <- freshTy - resTy <- freshTy - cAbs argTy resTy `cOr` cSize argTy resTy - return $ argTy :->: resTy - - ---------------------------------------- - -- power set/bag - - inferPrim PrimPower = do - a <- freshTy - c <- freshAtom - - constraint $ CQual QCmp a - constraint $ COr - [ CEq (TyAtom (ABase CtrSet)) (TyAtom c) - , CEq (TyAtom (ABase CtrBag)) (TyAtom c) - ] - - return $ TyContainer c a :->: TyContainer c (TyContainer c a) - - inferPrim PrimLookupSeq = return $ TyList TyN :->: (TyUnit :+: TyString) - inferPrim PrimExtendSeq = return $ TyList TyN :->: TyList TyN - --------------------------------------------------- --- Base types - --- A few trivial cases for base types. -typecheck Infer TUnit = return ATUnit -typecheck Infer (TBool b) = return $ ATBool TyBool b -typecheck Infer (TChar c) = return $ ATChar c -typecheck Infer (TString cs) = return $ ATString cs --- typecheck (Check (TyFin n)) (TNat x) = return $ ATNat (TyFin n) x -typecheck Infer (TNat n) = return $ ATNat TyN n -typecheck Infer (TRat r) = return $ ATRat r - -typecheck _ TWild = throw NoTWild - --------------------------------------------------- --- Abstractions (lambdas and quantifiers) - --- Lambdas and quantifiers are similar enough that we can share a --- bunch of the code, but their typing rules are a bit different. In --- particular a lambda --- --- \(x1:ty1), (x2:ty2) ... . body --- --- is going to have a type like ty1 -> ty2 -> ... -> resTy, whereas a --- quantifier like --- --- ∃(x1:ty1), (x2:ty2) ... . body --- --- is just going to have the type Prop. The similarity is that in --- both cases we have to generate unification variables for any --- binders with omitted type annotations, and typecheck the body under --- an extended context. - --- It's only helpful to do lambdas in checking mode, since the --- provided function type can provide information about the types of --- the arguments. For other quantifiers we can just fall back to --- inference mode. -typecheck (Check checkTy) tm@(TAbs Lam body) = do - (args, t) <- unbind body - - -- First check that the given type is of the form ty1 -> ty2 -> - -- ... -> resTy, where the types ty1, ty2 ... match up with any - -- types declared for the arguments to the lambda (e.g. (x:tyA) - -- (y:tyB) -> ...). - (ctx, typedArgs, resTy) <- checkArgs args checkTy tm - - -- Then check the type of the body under a context extended with - -- types for all the arguments. - extends ctx $ - ATAbs Lam checkTy <$> (bind (coerce typedArgs) <$> check t resTy) - - where - - -- Given the patterns and their optional type annotations in the - -- head of a lambda (e.g. @x (y:Z) (f : N -> N) -> ...@), and the - -- type at which we are checking the lambda, ensure that: - -- - -- - The type is of the form @ty1 -> ty2 -> ... -> resTy@ and - -- there are enough @ty1@, @ty2@, ... to match all the arguments. - -- - Each pattern successfully checks at its corresponding type. - -- - -- If it succeeds, return a context binding variables to their - -- types (as determined by the patterns and the input types) which - -- we can use to extend when checking the body, a list of the typed - -- patterns, and the result type of the function. - checkArgs - :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r - => [Pattern] -> Type -> Term -> Sem r (TyCtx, [APattern], Type) - - -- If we're all out of arguments, the remaining checking type is the - -- result, and there are no variables to bind in the context. - checkArgs [] ty _ = return (emptyCtx, [], ty) - - -- Take the next pattern and its annotation; the checking type must - -- be a function type ty1 -> ty2. - checkArgs (p : args) ty term = do - - -- Ensure that ty is a function type - (ty1, ty2) <- ensureConstr2 CArr ty (Left term) - - -- Check the argument pattern against the function domain. - (pCtx, pTyped) <- checkPattern p ty1 - - -- Check the rest of the arguments under the type ty2, returning a - -- context with the rest of the arguments and the final result type. - (ctx, typedArgs, resTy) <- checkArgs args ty2 term - - -- Pass the result type through, and put the pattern-bound variables - -- in the returned context. - return (pCtx <> ctx, pTyped : typedArgs, resTy) - --- In inference mode, we handle lambdas as well as quantifiers (∀, ∃). -typecheck Infer (TAbs q lam) = do - - -- Open it and get the argument patterns with any type annotations. - (args, t) <- unbind lam - - -- Replace any missing type annotations with fresh type variables, - -- and check each pattern at that variable to refine them, collecting - -- the types of each pattern's bound variables in a context. - tys <- mapM getAscrOrFresh args - (pCtxs, typedPats) <- unzip <$> zipWithM checkPattern args tys - - -- In the case of ∀, ∃, have to ensure that the argument types are - -- searchable. - when (q `elem` [All, Ex]) $ - -- What's the difference between this and `tys`? Nothing, after - -- the solver runs, but right now the patterns might have a - -- concrete type from annotations inside tuples. - forM_ (map getType typedPats) $ \ty -> - unless (isSearchable ty) $ - throw $ NoSearch ty - - -- Extend the context with the given arguments, and then do - -- something appropriate depending on the quantifier. - extends (mconcat pCtxs) $ do - case q of - -- For lambdas, infer the type of the body, and return an appropriate - -- function type. - Lam -> do - at <- infer t - return $ ATAbs Lam (mkFunTy tys (getType at)) (bind typedPats at) - - -- For other quantifiers, check that the body has type Prop, - -- and return Prop. - _ -> do -- ∀, ∃ - at <- check t TyProp - return $ ATAbs q TyProp (bind typedPats at) - where - getAscrOrFresh - :: Members '[Reader TyDefCtx, Error TCError, Fresh] r - => Pattern -> Sem r Type - getAscrOrFresh (PAscr _ ty) = checkTypeValid ty >> pure ty - getAscrOrFresh _ = freshTy - - -- mkFunTy [ty1, ..., tyn] out = ty1 -> (ty2 -> ... (tyn -> out)) - mkFunTy :: [Type] -> Type -> Type - mkFunTy tys out = foldr (:->:) out tys - --------------------------------------------------- --- Application - --- Infer the type of a function application by inferring the function --- type and then checking the argument type. We don't need a checking --- case because checking mode doesn't help. -typecheck Infer (TApp t t') = do - at <- infer t - let ty = getType at - (ty1, ty2) <- ensureConstr2 CArr ty (Left t) - ATApp ty2 at <$> check t' ty1 - --------------------------------------------------- --- Tuples - --- Check/infer the type of a tuple. -typecheck mode1 (TTup tup) = uncurry ATTup <$> typecheckTuple mode1 tup - where - typecheckTuple - :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r - => Mode -> [Term] -> Sem r (Type, [ATerm]) - typecheckTuple _ [] = error "Impossible! typecheckTuple []" - typecheckTuple mode [t] = (getType &&& (:[])) <$> typecheck mode t - typecheckTuple mode (t:ts) = do - (m,ms) <- ensureConstrMode2 CProd mode (Left $ TTup (t:ts)) - at <- typecheck m t - (ty, ats) <- typecheckTuple ms ts - return (getType at :*: ty, at : ats) - ----------------------------------------- --- Comparison chain - -typecheck Infer (TChain t ls) = - ATChain TyBool <$> infer t <*> inferChain t ls - - where - inferChain - :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r - => Term -> [Link] -> Sem r [ALink] - inferChain _ [] = return [] - inferChain t1 (TLink op t2 : links) = do - at2 <- infer t2 - _ <- check (TBin op t1 t2) TyBool - atl <- inferChain t2 links - return $ ATLink op at2 : atl - ----------------------------------------- --- Type operations - -typecheck Infer (TTyOp Enumerate t) = do - checkTypeValid t - return $ ATTyOp (TyList t) Enumerate t - -typecheck Infer (TTyOp Count t) = do - checkTypeValid t - return $ ATTyOp (TyUnit :+: TyN) Count t - --------------------------------------------------- --- Containers - --- Literal containers, including ellipses -typecheck mode t@(TContainer c xs ell) = do - eltMode <- ensureConstrMode1 (containerToCon c) mode (Left t) - axns <- mapM (\(x,n) -> (,) <$> typecheck eltMode x <*> traverse (`check` TyN) n) xs - aell <- typecheckEllipsis eltMode ell - resTy <- case mode of - Infer -> do - let tys = [ getType at | Just (Until at) <- [aell] ] ++ map (getType . fst) axns - tyv <- freshTy - constraints $ map (`CSub` tyv) tys - return $ containerTy c tyv - Check ty -> return ty - eltTy <- getEltTy c resTy - - -- See Note [Container literal constraints] - when (c /= ListContainer && not (P.null xs)) $ constraint $ CQual QCmp eltTy - when (isJust ell) $ constraint $ CQual QEnum eltTy - return $ ATContainer resTy c axns aell - - where - typecheckEllipsis - :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r - => Mode -> Maybe (Ellipsis Term) -> Sem r (Maybe (Ellipsis ATerm)) - typecheckEllipsis _ Nothing = return Nothing - typecheckEllipsis m (Just (Until tm)) = Just . Until <$> typecheck m tm - --- ~~~~ Note [Container literal constraints] --- --- It should only be possible to construct something of type Set(a) or --- Bag(a) when a is comparable, so we can normalize the set or bag --- value. For example, Set(N) is OK, but Set(N -> N) is not. On the --- other hand, List(a) is fine for any type a. We want to maintain --- the invariant that we can only actually obtain a value of type --- Set(a) or Bag(a) if a is comparable. This means we will be able to --- write polymorphic functions that take bags or sets as input without --- having to specify any constraints --- the only way to call such --- functions is with element types that actually support comparison. --- For example, 'unions' can simply have the type Set(Set(a)) -> --- Set(a). --- --- Hence, container literals (along with the 'set' and 'bag' --- conversion functions) serve as "gatekeepers" to make sure we can --- only construct containers with appropriate element types. So when --- we see a container literal, if it is a bag or set literal, we have --- to introduce an additional QCmp constraint for the element type. --- --- But not so fast --- with that rule, 'unions' does not type check! --- To see why, look at the definition: --- --- unions(ss) = foldr(~∪~, {}, list(ss)) --- --- The empty set literal in the definition means we end up generating --- a QCmp constraint on the element type anyway. But there is a --- solution: we refine our invariant to say that we can only --- actually obtain a *non-empty* value of type Set(a) or Bag(a) if a --- is comparable. Empty bags and sets are allowed to have any element --- type. This is safe because there is no way to generate a non-empty --- set from an empty one, without also making use of something like a --- non-empty set literal or conversion function. So we add a special --- case to the rule that says we only add a QCmp constraint in the --- case of a *non-empty* set or bag literal. Now the definition of --- 'unions' type checks perfectly well. - --- Container comprehensions -typecheck mode tcc@(TContainerComp c bqt) = do - eltMode <- ensureConstrMode1 (containerToCon c) mode (Left tcc) - (qs, t) <- unbind bqt - (aqs, cx) <- inferTelescope inferQual qs - extends cx $ do - at <- typecheck eltMode t - let resTy = case mode of - Infer -> containerTy c (getType at) - Check ty -> ty - return $ ATContainerComp resTy c (bind aqs at) - - where - inferQual - :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r - => Qual -> Sem r (AQual, TyCtx) - inferQual (QBind x (unembed -> t)) = do - at <- infer t - ty <- ensureConstr1 (containerToCon c) (getType at) (Left t) - return (AQBind (coerce x) (embed at), singleCtx (localName x) (toPolyType ty)) - - inferQual (QGuard (unembed -> t)) = do - at <- check t TyBool - return (AQGuard (embed at), emptyCtx) - --------------------------------------------------- --- Let - --- To check/infer a let expression. Note let is non-recursive. -typecheck mode (TLet l) = do - (bs, t2) <- unbind l - - -- Infer the types of all the variables bound by the let... - (as, ctx) <- inferTelescope inferBinding bs - - -- ...then check/infer the body under an extended context. - extends ctx $ do - at2 <- typecheck mode t2 - return $ ATLet (getType at2) (bind as at2) - - where - - -- Infer the type of a binding (@x [: ty] = t@), returning a - -- type-annotated binding along with a (singleton) context for the - -- bound variable. The optional type annotation on the variable - -- determines whether we use inference or checking mode for the - -- body. - inferBinding - :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r - => Binding -> Sem r (ABinding, TyCtx) - inferBinding (Binding mty x (unembed -> t)) = do - at <- case mty of - Just (unembed -> ty) -> checkPolyTy t ty - Nothing -> infer t - return (ABinding mty (coerce x) (embed at), singleCtx (localName x) (toPolyType $ getType at)) - --------------------------------------------------- --- Case - --- Check/infer a case expression. -typecheck _ (TCase []) = throw EmptyCase -typecheck mode (TCase bs) = do - bs' <- mapM typecheckBranch bs - resTy <- case mode of - Check ty -> return ty - Infer -> do - x <- freshTy - constraints $ map ((`CSub` x) . getType) bs' - return x - return $ ATCase resTy bs' - - where - typecheckBranch - :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r - => Branch -> Sem r ABranch - typecheckBranch b = do - (gs, t) <- unbind b - (ags, ctx) <- inferTelescope inferGuard gs - extends ctx $ - bind ags <$> typecheck mode t - - -- Infer the type of a guard, returning the type-annotated guard - -- along with a context of types for any variables bound by the - -- guard. - inferGuard - :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r - => Guard -> Sem r (AGuard, TyCtx) - inferGuard (GBool (unembed -> t)) = do - at <- check t TyBool - return (AGBool (embed at), emptyCtx) - inferGuard (GPat (unembed -> t) p) = do - at <- infer t - (ctx, apt) <- checkPattern p (getType at) - return (AGPat (embed at) apt, ctx) - inferGuard (GLet (Binding mty x (unembed -> t))) = do - at <- case mty of - Just (unembed -> ty) -> checkPolyTy t ty - Nothing -> infer t - return - ( AGLet (ABinding mty (coerce x) (embed at)) - , singleCtx (localName x) (toPolyType (getType at)) - ) - --------------------------------------------------- --- Type ascription - --- Ascriptions are what let us flip from inference mode into --- checking mode. -typecheck Infer (TAscr t ty) = checkPolyTyValid ty >> checkPolyTy t ty - --------------------------------------------------- --- Inference fallback - --- Finally, to check anything else, we can fall back to inferring its --- type and then check that the inferred type is a *subtype* of the --- given type. We have to be careful to call 'setType' to change the --- type at the root of the term to the requested type. -typecheck (Check ty) t = do - at <- infer t - constraint $ CSub (getType at) ty - return $ setType ty at - ------------------------------------------------------------- --- Patterns ------------------------------------------------------------- - --- | Check that a pattern has the given type, and return a context of --- pattern variables bound in the pattern along with their types. -checkPattern - :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r - => Pattern -> Type -> Sem r (TyCtx, APattern) - -checkPattern p (TyUser name args) = lookupTyDefn name args >>= checkPattern p - -checkPattern (PVar x) ty = return (singleCtx (localName x) (toPolyType ty), APVar ty (coerce x)) - -checkPattern PWild ty = return (emptyCtx, APWild ty) - -checkPattern (PAscr p ty1) ty2 = do - -- We have a pattern that promises to match ty1 and someone is asking - -- us if it can also match ty2. So we just have to ensure what we're - -- being asked for is a subtype of what we can promise to cover... - constraint $ CSub ty2 ty1 - -- ... and then make sure the pattern can actually match what it promised to. - checkPattern p ty1 - -checkPattern PUnit ty = do - ensureEq ty TyUnit - return (emptyCtx, APUnit) - -checkPattern (PBool b) ty = do - ensureEq ty TyBool - return (emptyCtx, APBool b) - -checkPattern (PChar c) ty = do - ensureEq ty TyC - return (emptyCtx, APChar c) - -checkPattern (PString s) ty = do - ensureEq ty TyString - return (emptyCtx, APString s) - -checkPattern (PTup tup) tupTy = do - listCtxtAps <- checkTuplePat tup tupTy - let (ctxs, aps) = unzip listCtxtAps - return (mconcat ctxs, APTup (foldr1 (:*:) (map getType aps)) aps) - - where - checkTuplePat - :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r - => [Pattern] -> Type -> Sem r [(TyCtx, APattern)] - checkTuplePat [] _ = error "Impossible! checkTuplePat []" - checkTuplePat [p] ty = do -- (:[]) <$> check t ty - (ctx, apt) <- checkPattern p ty - return [(ctx, apt)] - checkTuplePat (p:ps) ty = do - (ty1, ty2) <- ensureConstr2 CProd ty (Right $ PTup (p:ps)) - (ctx, apt) <- checkPattern p ty1 - rest <- checkTuplePat ps ty2 - return ((ctx, apt) : rest) - -checkPattern p@(PInj L pat) ty = do - (ty1, ty2) <- ensureConstr2 CSum ty (Right p) - (ctx, apt) <- checkPattern pat ty1 - return (ctx, APInj (ty1 :+: ty2) L apt) -checkPattern p@(PInj R pat) ty = do - (ty1, ty2) <- ensureConstr2 CSum ty (Right p) - (ctx, apt) <- checkPattern pat ty2 - return (ctx, APInj (ty1 :+: ty2) R apt) - --- we can match any supertype of TyN against a Nat pattern, OR --- any TyFin. - --- XXX this isn't quite right, what if we're checking at a type --- variable but we need to solve it to be a TyFin? Can this ever --- happen? We would need a COr, except we can't express the --- constraint "exists m. ty = TyFin m" --- --- Yes, this can happen, and here's an example: --- --- > (\x. {? true when x is 3, false otherwise ?}) (2 : Z5) --- Unsolvable NoUnify --- > (\(x : Z5). {? true when x is 3, false otherwise ?}) (2 : Z5) --- false - --- checkPattern (PNat n) (TyFin m) = return (emptyCtx, APNat (TyFin m) n) -checkPattern (PNat n) ty = do - constraint $ CSub TyN ty - return (emptyCtx, APNat ty n) - -checkPattern p@(PCons p1 p2) ty = do - tyl <- ensureConstr1 CList ty (Right p) - (ctx1, ap1) <- checkPattern p1 tyl - (ctx2, ap2) <- checkPattern p2 (TyList tyl) - return (ctx1 <> ctx2, APCons (TyList tyl) ap1 ap2) - -checkPattern p@(PList ps) ty = do - tyl <- ensureConstr1 CList ty (Right p) - listCtxtAps <- mapM (`checkPattern` tyl) ps - let (ctxs, aps) = unzip listCtxtAps - return (mconcat ctxs, APList (TyList tyl) aps) - -checkPattern (PAdd s p t) ty = do - constraint $ CQual QNum ty - (ctx, apt) <- checkPattern p ty - at <- check t ty - return (ctx, APAdd ty s apt at) - -checkPattern (PMul s p t) ty = do - constraint $ CQual QNum ty - (ctx, apt) <- checkPattern p ty - at <- check t ty - return (ctx, APMul ty s apt at) - -checkPattern (PSub p t) ty = do - constraint $ CQual QNum ty - (ctx, apt) <- checkPattern p ty - at <- check t ty - return (ctx, APSub ty apt at) - -checkPattern (PNeg p) ty = do - constraint $ CQual QSub ty - tyInner <- cPos ty - (ctx, apt) <- checkPattern p tyInner - return (ctx, APNeg ty apt) - -checkPattern (PFrac p q) ty = do - constraint $ CQual QDiv ty - tyP <- cInt ty - tyQ <- cPos tyP - (ctx1, ap1) <- checkPattern p tyP - (ctx2, ap2) <- checkPattern q tyQ - return (ctx1 <> ctx2, APFrac ty ap1 ap2) - ------------------------------------------------------------- --- Constraints for abs, floor/ceiling/idiv, and exp ------------------------------------------------------------- - --- | Constraints needed on a function type for it to be the type of --- the absolute value function. -cAbs :: Members '[Writer Constraint, Fresh] r => Type -> Type -> Sem r () -cAbs argTy resTy = do - resTy' <- cPos argTy - constraint $ CEq resTy resTy' - --- | Constraints needed on a function type for it to be the type of --- the container size operation. -cSize :: Members '[Writer Constraint, Fresh] r => Type -> Type -> Sem r () -cSize argTy resTy = do - a <- freshTy - c <- freshAtom - constraint $ CEq (TyContainer c a) argTy - constraint $ CEq TyN resTy - --- | Given an input type @ty@, return a type which represents the --- output type of the absolute value function, and generate --- appropriate constraints. -cPos :: Members '[Writer Constraint, Fresh] r => Type -> Sem r Type -cPos ty = do - constraint $ CQual QNum ty -- The input type has to be numeric. - case ty of - -- If the input type is a concrete base type, we can just - -- compute the correct output type. - TyAtom (ABase b) -> return $ TyAtom (ABase (pos b)) - - -- Otherwise, generate a fresh type variable for the output type - -- along with some constraints. - _ -> do - res <- freshTy - - -- Valid types for absolute value are Z -> N, Q -> F, or T -> T - -- (e.g. Z5 -> Z5). - constraint $ COr - [ cAnd [CSub ty TyZ, CSub TyN res] - , cAnd [CSub ty TyQ, CSub TyF res] - , CEq ty res - ] - return res - where - pos Z = N - pos Q = F - pos t = t - --- | Given an input type @ty@, return a type which represents the --- output type of the floor or ceiling functions, and generate --- appropriate constraints. -cInt :: Members '[Writer Constraint, Fresh] r => Type -> Sem r Type -cInt ty = do - constraint $ CQual QNum ty - case ty of - -- If the input type is a concrete base type, we can just - -- compute the correct output type. - TyAtom (ABase b) -> return $ TyAtom (ABase (int b)) - - -- Otherwise, generate a fresh type variable for the output type - -- along with some constraints. - _ -> do - res <- freshTy - - -- Valid types for absolute value are F -> N, Q -> Z, or T -> T - -- (e.g. Z5 -> Z5). - constraint $ COr - [ cAnd [CSub ty TyF, CSub TyN res] - , cAnd [CSub ty TyQ, CSub TyZ res] - , CEq ty res - ] - return res - - where - int F = N - int Q = Z - int t = t - --- | Given input types to the exponentiation operator, return a type --- which represents the output type, and generate appropriate --- constraints. -cExp :: Members '[Writer Constraint, Fresh] r => Type -> Type -> Sem r Type -cExp ty1 TyN = do - constraint $ CQual QNum ty1 - return ty1 - --- We could include a special case for TyZ, but for that we would need --- a function to find a supertype of a given type that satisfies QDiv. - -cExp ty1 ty2 = do - - -- Create a fresh type variable to represent the result type. The - -- base type has to be a subtype. - resTy <- freshTy - constraint $ CSub ty1 resTy - - -- Either the exponent type is N, in which case the result type has - -- to support multiplication, or else the exponent is Z, in which - -- case the result type also has to support division. - constraint $ COr - [ cAnd [CQual QNum resTy, CEq ty2 TyN] - , cAnd [CQual QDiv resTy, CEq ty2 TyZ] - ] - return resTy - ------------------------------------------------------------- --- Decomposing type constructors ------------------------------------------------------------- - --- | Get the argument (element) type of a (known) container type. Returns a --- fresh variable with a suitable constraint if the given type is --- not literally a container type. -getEltTy :: Members '[Writer Constraint, Fresh] r => Container -> Type -> Sem r Type -getEltTy _ (TyContainer _ e) = return e -getEltTy c ty = do - eltTy <- freshTy - constraint $ CEq (containerTy c eltTy) ty - return eltTy - --- | Ensure that a type's outermost constructor matches the provided --- constructor, returning the types within the matched constructor --- or throwing a type error. If the type provided is a type --- variable, appropriate constraints are generated to guarantee the --- type variable's outermost constructor matches the provided --- constructor, and a list of fresh type variables is returned whose --- count matches the arity of the provided constructor. -ensureConstr - :: forall r. Members '[Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r - => Con -> Type -> Either Term Pattern -> Sem r [Type] -ensureConstr c ty targ = matchConTy c ty - where - matchConTy :: Con -> Type -> Sem r [Type] - - -- expand type definitions lazily - matchConTy c1 (TyUser name args) = lookupTyDefn name args >>= matchConTy c1 - - matchConTy c1 (TyCon c2 tys) = do - matchCon c1 c2 - return tys - - matchConTy c1 tyv@(TyAtom (AVar (U _))) = do - tyvs <- mapM (const freshTy) (arity c1) - constraint $ CEq tyv (TyCon c1 tyvs) - return tyvs - - matchConTy _ _ = matchError - - -- | Check whether two constructors match, which could include - -- unifying container variables if we are matching two container - -- types; otherwise, simply ensure that the constructors are - -- equal. Throw a 'matchError' if they do not match. - matchCon :: Con -> Con -> Sem r () - matchCon c1 c2 | c1 == c2 = return () - matchCon (CContainer v@(AVar (U _))) (CContainer ctr2) = - constraint $ CEq (TyAtom v) (TyAtom ctr2) - matchCon (CContainer ctr1) (CContainer v@(AVar (U _))) = - constraint $ CEq (TyAtom ctr1) (TyAtom v) - matchCon _ _ = matchError - - matchError :: Sem r a - matchError = case targ of - Left term -> throw (NotCon c term ty) - Right pat -> throw (PatternType c pat ty) - --- | A variant of ensureConstr that expects to get exactly one --- argument type out, and throws an error if we get any other --- number. -ensureConstr1 - :: Members '[Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r - => Con -> Type -> Either Term Pattern -> Sem r Type -ensureConstr1 c ty targ = do - tys <- ensureConstr c ty targ - case tys of - [ty1] -> return ty1 - _ -> error $ - "Impossible! Wrong number of arg types in ensureConstr1 " ++ show c ++ " " - ++ show ty ++ ": " ++ show tys - --- | A variant of ensureConstr that expects to get exactly two --- argument types out, and throws an error if we get any other --- number. -ensureConstr2 - :: Members '[Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r - => Con -> Type -> Either Term Pattern -> Sem r (Type, Type) -ensureConstr2 c ty targ = do - tys <- ensureConstr c ty targ - case tys of - [ty1, ty2] -> return (ty1, ty2) - _ -> error $ - "Impossible! Wrong number of arg types in ensureConstr2 " ++ show c ++ " " - ++ show ty ++ ": " ++ show tys - --- | A variant of 'ensureConstr' that works on 'Mode's instead of --- 'Type's. Behaves similarly to 'ensureConstr' if the 'Mode' is --- 'Check'; otherwise it generates an appropriate number of copies --- of 'Infer'. -ensureConstrMode - :: Members '[Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r - => Con -> Mode -> Either Term Pattern -> Sem r [Mode] -ensureConstrMode c Infer _ = return $ map (const Infer) (arity c) -ensureConstrMode c (Check ty) tp = map Check <$> ensureConstr c ty tp - --- | A variant of 'ensureConstrMode' that expects to get a single --- 'Mode' and throws an error if it encounters any other number. -ensureConstrMode1 - :: Members '[Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r - => Con -> Mode -> Either Term Pattern -> Sem r Mode -ensureConstrMode1 c m targ = do - ms <- ensureConstrMode c m targ - case ms of - [m1] -> return m1 - _ -> error $ - "Impossible! Wrong number of arg types in ensureConstrMode1 " ++ show c ++ " " - ++ show m ++ ": " ++ show ms - --- | A variant of 'ensureConstrMode' that expects to get two 'Mode's --- and throws an error if it encounters any other number. -ensureConstrMode2 - :: Members '[Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r - => Con -> Mode -> Either Term Pattern -> Sem r (Mode, Mode) -ensureConstrMode2 c m targ = do - ms <- ensureConstrMode c m targ - case ms of - [m1, m2] -> return (m1, m2) - _ -> error $ - "Impossible! Wrong number of arg types in ensureConstrMode2 " ++ show c ++ " " - ++ show m ++ ": " ++ show ms - --- | Ensure that two types are equal: --- 1. Do nothing if they are literally equal --- 2. Generate an equality constraint otherwise -ensureEq :: Member (Writer Constraint) r => Type -> Type -> Sem r () -ensureEq ty1 ty2 - | ty1 == ty2 = return () - | otherwise = constraint $ CEq ty1 ty2 +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + +-- | +-- Module : Disco.Typecheck +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Typecheck the Disco surface language and transform it into a +-- type-annotated AST. +module Disco.Typecheck where + +import Control.Arrow ((&&&)) +import Control.Lens ((^..)) +import Control.Monad.Except +import Control.Monad.Trans.Maybe +import Data.Bifunctor (first) +import Data.Coerce +import qualified Data.Foldable as F +import Data.List (group, sort) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (isJust) +import Data.Set (Set) +import qualified Data.Set as S +import Prelude as P hiding (lookup) + +import Unbound.Generics.LocallyNameless ( + Alpha, + Bind, + Name, + bind, + embed, + name2String, + string2Name, + substs, + unembed, + ) +import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) + +import Disco.Effects.Fresh +import Polysemy hiding (embed) +import Polysemy.Error +import Polysemy.Output +import Polysemy.Reader +import Polysemy.Writer + +import Disco.AST.Surface +import Disco.AST.Typed +import Disco.Context hiding (filter) +import qualified Disco.Context as Ctx +import Disco.Messages +import Disco.Module +import Disco.Names +import Disco.Subst (applySubst) +import qualified Disco.Subst as Subst +import Disco.Syntax.Operators +import Disco.Syntax.Prims +import Disco.Typecheck.Constraints +import Disco.Typecheck.Util +import Disco.Types +import Disco.Types.Rules + +------------------------------------------------------------ +-- Container utilities +------------------------------------------------------------ + +containerTy :: Container -> Type -> Type +containerTy c ty = TyCon (containerToCon c) [ty] + +containerToCon :: Container -> Con +containerToCon ListContainer = CList +containerToCon BagContainer = CBag +containerToCon SetContainer = CSet + +------------------------------------------------------------ +-- Telescopes +------------------------------------------------------------ + +-- | Infer the type of a telescope, given a way to infer the type of +-- each item along with a context of variables it binds; each such +-- context is then added to the overall context when inferring +-- subsequent items in the telescope. +inferTelescope :: + (Alpha b, Alpha tyb, Member (Reader TyCtx) r) => + (b -> Sem r (tyb, TyCtx)) -> + Telescope b -> + Sem r (Telescope tyb, TyCtx) +inferTelescope inferOne tel = do + (tel1, ctx) <- go (fromTelescope tel) + return (toTelescope tel1, ctx) + where + go [] = return ([], emptyCtx) + go (b : bs) = do + (tyb, ctx) <- inferOne b + extends ctx $ do + (tybs, ctx') <- go bs + return (tyb : tybs, ctx <> ctx') + +------------------------------------------------------------ +-- Modules +------------------------------------------------------------ + +-- | Check all the types and extract all relevant info (docs, +-- properties, types) from a module, returning a 'ModuleInfo' record +-- on success. This function does not handle imports at all; any +-- imports should already be checked and passed in as the second +-- argument. +checkModule :: + Members '[Output (Message ann), Reader TyCtx, Reader TyDefCtx, Error LocTCError, Fresh] r => + ModuleName -> + Map ModuleName ModuleInfo -> + Module -> + Sem r ModuleInfo +checkModule name imports (Module es _ m docs terms) = do + let (typeDecls, defns, tydefs) = partitionDecls m + importTyCtx = mconcat (imports ^.. traverse . miTys) + -- XXX this isn't right, if multiple modules define the same type synonyms. + -- Need to use a normal Ctx for tydefs too. + importTyDefnCtx = M.unions (imports ^.. traverse . miTydefs) + tyDefnCtx <- mapError noLoc $ makeTyDefnCtx tydefs + withTyDefns (tyDefnCtx `M.union` importTyDefnCtx) $ do + tyCtx <- mapError noLoc $ makeTyCtx name typeDecls + extends importTyCtx $ extends tyCtx $ do + mapM_ (checkTyDefn name) tydefs + adefns <- mapM (checkDefn name) defns + let defnCtx = ctxForModule name (map (getDefnName &&& id) adefns) + docCtx = ctxForModule name docs + dups = filterDups . map getDefnName $ adefns + case dups of + (x : _) -> throw $ noLoc $ DuplicateDefns (coerce x) + [] -> do + aprops <- mapError noLoc $ checkProperties docCtx -- XXX location? + aterms <- mapError noLoc $ mapM inferTop terms -- XXX location? + return $ ModuleInfo name imports (map ((name .-) . getDeclName) typeDecls) docCtx aprops tyCtx tyDefnCtx defnCtx aterms es + where + getDefnName :: Defn -> Name ATerm + getDefnName (Defn n _ _ _) = n + + getDeclName :: TypeDecl -> Name Term + getDeclName (TypeDecl n _) = n + +-------------------------------------------------- +-- Type definitions + +-- | Turn a list of type definitions into a 'TyDefCtx', checking +-- for duplicate names among the definitions and also any type +-- definitions already in the context. +makeTyDefnCtx :: Members '[Reader TyDefCtx, Error TCError] r => [TypeDefn] -> Sem r TyDefCtx +makeTyDefnCtx tydefs = do + oldTyDefs <- ask @TyDefCtx + let oldNames = M.keys oldTyDefs + newNames = map (\(TypeDefn x _ _) -> x) tydefs + dups = filterDups $ newNames ++ oldNames + + let convert (TypeDefn x args body) = + (x, TyDefBody args (flip substs body . zip (map string2Name args))) + + case dups of + (x : _) -> throw (DuplicateTyDefns x) + [] -> return . M.fromList $ map convert tydefs + +-- | Check the validity of a type definition. +checkTyDefn :: Members '[Reader TyDefCtx, Error LocTCError] r => ModuleName -> TypeDefn -> Sem r () +checkTyDefn name defn@(TypeDefn x args body) = mapError (LocTCError (Just (name .- string2Name x))) $ do + -- First, make sure the body is a valid type, i.e. everything inside + -- it is well-kinded. + checkTypeValid body + + -- Now make sure it is not directly cyclic (i.e. ensure it is a + -- "productive" definition). + _ <- checkCyclicTy (TyUser x (map (TyVar . string2Name) args)) S.empty + + -- Make sure it does not use any unbound type variables or undefined + -- types. + checkUnboundVars defn + + -- Make sure it does not use any polymorphic recursion (polymorphic + -- recursion isn't allowed at the moment since it can make the + -- subtyping checker diverge). + checkPolyRec defn + +-- | Check if a given type is cyclic. A type 'ty' is cyclic if: +-- +-- 1. 'ty' is the name of a user-defined type. +-- 2. Repeated expansions of the type yield nothing but other user-defined types. +-- 3. An expansion of one of those types yields another type that has +-- been previously encountered. +-- +-- In other words, repeatedly expanding the definition can get us +-- back to exactly where we started. +-- +-- The function returns the set of TyDefs encountered during +-- expansion if the TyDef is not cyclic. +checkCyclicTy :: Members '[Reader TyDefCtx, Error TCError] r => Type -> Set String -> Sem r (Set String) +checkCyclicTy (TyUser name args) set = do + case S.member name set of + True -> throw $ CyclicTyDef name + False -> do + ty <- lookupTyDefn name args + checkCyclicTy ty (S.insert name set) +checkCyclicTy _ set = return set + +-- | Ensure that a type definition does not use any unbound type +-- variables or undefined types. +checkUnboundVars :: Members '[Reader TyDefCtx, Error TCError] r => TypeDefn -> Sem r () +checkUnboundVars (TypeDefn _ args body) = go body + where + go (TyAtom (AVar (U x))) + | name2String x `elem` args = return () + | otherwise = throw $ UnboundTyVar x + go (TyAtom _) = return () + go (TyUser name tys) = lookupTyDefn name tys >> mapM_ go tys + go (TyCon _ tys) = mapM_ go tys + +-- | Check for polymorphic recursion: starting from a user-defined +-- type, keep expanding its definition recursively, ensuring that +-- any recursive references to the defined type have only type variables +-- as arguments. +checkPolyRec :: Member (Error TCError) r => TypeDefn -> Sem r () +checkPolyRec (TypeDefn name args body) = go body + where + go (TyCon (CUser x) tys) + | x == name && not (all isTyVar tys) = + throw $ NoPolyRec name args tys + | otherwise = return () + go (TyCon _ tys) = mapM_ go tys + go _ = return () + +-- | Keep only the duplicate elements from a list. +-- +-- >>> filterDups [1,3,2,1,1,4,2] +-- [1,2] +filterDups :: Ord a => [a] -> [a] +filterDups = map head . filter ((> 1) . length) . group . sort + +-------------------------------------------------- +-- Type declarations + +-- | Given a list of type declarations from a module, first check that +-- there are no duplicate type declarations, and that the types are +-- well-formed; then create a type context containing the given +-- declarations. +makeTyCtx :: Members '[Reader TyDefCtx, Error TCError] r => ModuleName -> [TypeDecl] -> Sem r TyCtx +makeTyCtx name decls = do + let dups = filterDups . map (\(TypeDecl x _) -> x) $ decls + case dups of + (x : _) -> throw (DuplicateDecls x) + [] -> do + checkCtx declCtx + return declCtx + where + declCtx = ctxForModule name $ map (\(TypeDecl x ty) -> (x, ty)) decls + +-- | Check that all the types in a context are valid. +checkCtx :: Members '[Reader TyDefCtx, Error TCError] r => TyCtx -> Sem r () +checkCtx = mapM_ checkPolyTyValid . Ctx.elems + +-------------------------------------------------- +-- Top-level definitions + +-- | Type check a top-level definition in the given module. +checkDefn :: + Members '[Reader TyCtx, Reader TyDefCtx, Error LocTCError, Fresh, Output (Message ann)] r => + ModuleName -> + TermDefn -> + Sem r Defn +checkDefn name (TermDefn x clauses) = mapError (LocTCError (Just (name .- x))) $ do + -- Check that all clauses have the same number of patterns + checkNumPats clauses + + -- Get the declared type signature of x + Forall sig <- lookup (name .- x) >>= maybe (throw $ NoType x) return + -- If x isn't in the context, it's because no type was declared for it, so + -- throw an error. + (nms, ty) <- unbind sig + + -- Try to decompose the type into a chain of arrows like pty1 -> + -- pty2 -> pty3 -> ... -> bodyTy, according to the number of + -- patterns, and lazily unrolling type definitions along the way. + (patTys, bodyTy) <- decomposeDefnTy (numPats (head clauses)) ty + + ((acs, _), theta) <- solve $ do + aclauses <- forAll nms $ mapM (checkClause patTys bodyTy) clauses + return (aclauses, ty) + + return $ applySubst theta (Defn (coerce x) patTys bodyTy acs) + where + numPats = length . fst . unsafeUnbind + + checkNumPats [] = return () -- This can't happen, but meh + checkNumPats [_] = return () + checkNumPats (c : cs) + | all ((== 0) . numPats) (c : cs) = throw (DuplicateDefns x) + | not (all ((== numPats c) . numPats) cs) = throw NumPatterns + -- XXX more info, this error actually means # of + -- patterns don't match across different clauses + | otherwise = return () + + -- \| Check a clause of a definition against a list of pattern types and a body type. + checkClause :: + Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r => + [Type] -> + Type -> + Bind [Pattern] Term -> + Sem r Clause + checkClause patTys bodyTy clause = do + (pats, body) <- unbind clause + + -- At this point we know that every clause has the same number of patterns, + -- which is the same as the length of the list patTys. So we can just use + -- zipWithM to check all the patterns. + (ctxs, aps) <- unzip <$> zipWithM checkPattern pats patTys + at <- extends (mconcat ctxs) $ check body bodyTy + return $ bind aps at + + -- Decompose a type that must be of the form t1 -> t2 -> ... -> tn -> t{n+1}. + decomposeDefnTy :: Members '[Reader TyDefCtx, Error TCError] r => Int -> Type -> Sem r ([Type], Type) + decomposeDefnTy 0 ty = return ([], ty) + decomposeDefnTy n (TyUser tyName args) = lookupTyDefn tyName args >>= decomposeDefnTy n + decomposeDefnTy n (ty1 :->: ty2) = first (ty1 :) <$> decomposeDefnTy (n - 1) ty2 + decomposeDefnTy _n _ty = throw NumPatterns + +-- XXX include more info. More argument patterns than arrows in the type. + +-------------------------------------------------- +-- Properties + +-- | Given a context mapping names to documentation, extract the +-- properties attached to each name and typecheck them. +checkProperties :: + Members '[Reader TyCtx, Reader TyDefCtx, Error TCError, Fresh, Output (Message ann)] r => + Ctx Term Docs -> + Sem r (Ctx ATerm [AProperty]) +checkProperties docs = + Ctx.coerceKeys . Ctx.filter (not . P.null) + <$> (traverse . traverse) checkProperty properties + where + properties :: Ctx Term [Property] + properties = fmap (\ds -> [p | DocProperty p <- ds]) docs + +-- | Check the types of the terms embedded in a property. +checkProperty :: + Members '[Reader TyCtx, Reader TyDefCtx, Error TCError, Fresh, Output (Message ann)] r => + Property -> + Sem r AProperty +checkProperty prop = do + (at, theta) <- solve $ check prop TyProp + -- XXX do we need to default container variables here? + return $ applySubst theta at + +------------------------------------------------------------ +-- Type checking/inference +------------------------------------------------------------ + +-------------------------------------------------- +-- Checking types/kinds +-------------------------------------------------- + +-- | Check that a sigma type is a valid type. See 'checkTypeValid'. +checkPolyTyValid :: Members '[Reader TyDefCtx, Error TCError] r => PolyType -> Sem r () +checkPolyTyValid (Forall b) = do + let (_, ty) = unsafeUnbind b + checkTypeValid ty + +-- | Disco doesn't need kinds per se, since all types must be fully +-- applied. But we do need to check that every type is applied to +-- the correct number of arguments. +checkTypeValid :: Members '[Reader TyDefCtx, Error TCError] r => Type -> Sem r () +checkTypeValid (TyAtom _) = return () +checkTypeValid (TyCon c tys) = do + k <- conArity c + if + | n < k -> throw (NotEnoughArgs c) + | n > k -> throw (TooManyArgs c) + | otherwise -> mapM_ checkTypeValid tys + where + n = length tys + +conArity :: Members '[Reader TyDefCtx, Error TCError] r => Con -> Sem r Int +conArity (CContainer _) = return 1 +conArity CGraph = return 1 +conArity (CUser name) = do + d <- ask @TyDefCtx + case M.lookup name d of + Nothing -> throw (NotTyDef name) + Just (TyDefBody as _) -> return (length as) +conArity _ = return 2 -- (->, *, +, map) + +-------------------------------------------------- +-- Checking modes +-------------------------------------------------- + +-- | Typechecking can be in one of two modes: inference mode means we +-- are trying to synthesize a valid type for a term; checking mode +-- means we are trying to show that a term has a given type. +data Mode = Infer | Check Type + deriving (Show) + +-- | Check that a term has the given type. Either throws an error, or +-- returns the term annotated with types for all subterms. +-- +-- This function is provided for convenience; it simply calls +-- 'typecheck' with an appropriate 'Mode'. +check :: + Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r => + Term -> + Type -> + Sem r ATerm +check t ty = typecheck (Check ty) t + +-- | Check that a term has the given polymorphic type. +checkPolyTy :: + Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r => + Term -> + PolyType -> + Sem r ATerm +checkPolyTy t (Forall sig) = do + (as, tau) <- unbind sig + (at, cst) <- withConstraint $ check t tau + case as of + [] -> constraint cst + _ -> constraint $ CAll (bind as cst) + return at + +-- | Infer the type of a term. If it succeeds, it returns the term +-- with all subterms annotated. +-- +-- This function is provided for convenience; it simply calls +-- 'typecheck' with an appropriate 'Mode'. +infer :: + Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r => + Term -> + Sem r ATerm +infer = typecheck Infer + +-- | Top-level type inference algorithm: infer a (polymorphic) type +-- for a term by running type inference, solving the resulting +-- constraints, and quantifying over any remaining type variables. +inferTop :: + Members '[Output (Message ann), Reader TyCtx, Reader TyDefCtx, Error TCError, Fresh] r => + Term -> + Sem r (ATerm, PolyType) +inferTop t = do + -- Run inference on the term and try to solve the resulting + -- constraints. + (at, theta) <- solve $ infer t + + debug "Final annotated term (before substitution and container monomorphizing):" + debugPretty at + + -- Apply the resulting substitution. + let at' = applySubst theta at + + -- Find any remaining container variables. + cvs = containerVars (getType at') + + -- Replace them all with List. + at'' = applySubst (Subst.fromList $ zip (S.toList cvs) (repeat (TyAtom (ABase CtrList)))) at' + + -- Finally, quantify over any remaining type variables and return + -- the term along with the resulting polymorphic type. + return (at'', closeType (getType at'')) + +-- | Top-level type checking algorithm: check that a term has a given +-- polymorphic type by running type checking and solving the +-- resulting constraints. +checkTop :: + Members '[Output (Message ann), Reader TyCtx, Reader TyDefCtx, Error TCError, Fresh] r => + Term -> + PolyType -> + Sem r ATerm +checkTop t ty = do + (at, theta) <- solve $ checkPolyTy t ty + return $ applySubst theta at + +-------------------------------------------------- +-- The typecheck function +-------------------------------------------------- + +-- | The main workhorse of the typechecker. Instead of having two +-- functions, one for inference and one for checking, 'typecheck' +-- takes a 'Mode'. This cuts down on code duplication in many +-- cases, and allows all the checking and inference code related to +-- a given AST node to be placed together. +typecheck :: + Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r => + Mode -> + Term -> + Sem r ATerm +-- ~~~~ Note [Pattern coverage] +-- In several places we have clauses like +-- +-- inferPrim (PrimBOp op) | op `elem` [And, Or, Impl, Iff] +-- +-- since the typing rules for all the given operators are the same. +-- The only problem is that the pattern coverage checker (sensibly) +-- doesn't look at guards in general, so it thinks that there are TBin +-- cases still uncovered. +-- +-- However, we *don't* just want to add a catch-all case at the end, +-- because the coverage checker is super helpful in alerting us when +-- there's a missing typechecking case after modifying the language in +-- some way. The (not ideal) solution for now is to add some +-- additional explicit cases that simply call 'error', which will +-- never be reached but which assure the coverage checker that we have +-- handled those cases. +-- +-- The ideal solution would be to use or-patterns, if Haskell had them +-- (see https://github.com/ghc-proposals/ghc-proposals/pull/43). + +-------------------------------------------------- +-- Defined types + +-- To check at a user-defined type, expand its definition and recurse. +-- This case has to be first, so in all other cases we know the type +-- will not be a TyUser. +typecheck (Check (TyUser name args)) t = lookupTyDefn name args >>= check t +-------------------------------------------------- +-- Parens + +-- Recurse through parens; they are not represented explicitly in the +-- resulting ATerm. +typecheck mode (TParens t) = typecheck mode t +-------------------------------------------------- +-- Variables + +-- Resolve variable names and infer their types. We don't need a +-- checking case; checking the type of a variable will fall through to +-- this case. +typecheck Infer (TVar x) = do + -- Pick the first method that succeeds; if none do, throw an unbound + -- variable error. + mt <- runMaybeT . F.asum . map MaybeT $ [tryLocal, tryModule, tryPrim] + maybe (throw (Unbound x)) return mt + where + -- 1. See if the variable name is bound locally. + tryLocal = do + mty <- Ctx.lookup (localName x) + case mty of + Just (Forall sig) -> do + (_, ty) <- unbind sig + return . Just $ ATVar ty (localName (coerce x)) + Nothing -> return Nothing + + -- 2. See if the variable name is bound in some in-scope module, + -- throwing an ambiguity error if it is bound in multiple modules. + tryModule = do + bs <- Ctx.lookupNonLocal x + case bs of + [(m, Forall sig)] -> do + (_, ty) <- unbind sig + return . Just $ ATVar ty (m .- coerce x) + [] -> return Nothing + _ -> throw $ Ambiguous x (map fst bs) + + -- 3. See if we should convert it to a primitive. + tryPrim = + case toPrim (name2String x) of + (prim : _) -> Just <$> typecheck Infer (TPrim prim) + _ -> return Nothing + +-------------------------------------------------- +-- Primitives + +typecheck Infer (TPrim prim) = do + ty <- inferPrim prim + return $ ATPrim ty prim + where + inferPrim :: Members '[Writer Constraint, Fresh] r => Prim -> Sem r Type + + ---------------------------------------- + -- Left/right + + inferPrim PrimLeft = do + a <- freshTy + b <- freshTy + return $ a :->: (a :+: b) + inferPrim PrimRight = do + a <- freshTy + b <- freshTy + return $ b :->: (a :+: b) + + ---------------------------------------- + -- Logic + + inferPrim (PrimBOp op) | op `elem` [And, Or, Impl, Iff] = do + a <- freshTy + constraint $ CQual (bopQual op) a + return $ a :*: a :->: a + + -- See Note [Pattern coverage] ----------------------------- + inferPrim (PrimBOp And) = error "inferPrim And should be unreachable" + inferPrim (PrimBOp Or) = error "inferPrim Or should be unreachable" + inferPrim (PrimBOp Impl) = error "inferPrim Impl should be unreachable" + inferPrim (PrimBOp Iff) = error "inferPrim Iff should be unreachable" + ------------------------------------------------------------ + + inferPrim (PrimUOp Not) = do + a <- freshTy + constraint $ CQual QBool a + return $ a :->: a + + ---------------------------------------- + -- Container conversion + + inferPrim conv | conv `elem` [PrimList, PrimBag, PrimSet] = do + c <- freshAtom -- make a unification variable for the container type + a <- freshTy -- make a unification variable for the element type + + -- converting to a set or bag requires being able to sort the elements + when (conv /= PrimList) $ constraint $ CQual QCmp a + + return $ TyContainer c a :->: primCtrCon conv a + where + primCtrCon PrimList = TyList + primCtrCon PrimBag = TyBag + primCtrCon _ = TySet + + -- See Note [Pattern coverage] ----------------------------- + inferPrim PrimList = error "inferPrim PrimList should be unreachable" + inferPrim PrimBag = error "inferPrim PrimBag should be unreachable" + inferPrim PrimSet = error "inferPrim PrimSet should be unreachable" + ------------------------------------------------------------ + + inferPrim PrimB2C = do + a <- freshTy + return $ TyBag a :->: TySet (a :*: TyN) + inferPrim PrimC2B = do + a <- freshTy + c <- freshAtom + constraint $ CQual QCmp a + return $ TyContainer c (a :*: TyN) :->: TyBag a + inferPrim PrimUC2B = do + a <- freshTy + c <- freshAtom + return $ TyContainer c (a :*: TyN) :->: TyBag a + inferPrim PrimMapToSet = do + k <- freshTy + v <- freshTy + constraint $ CQual QSimple k + return $ TyMap k v :->: TySet (k :*: v) + inferPrim PrimSetToMap = do + k <- freshTy + v <- freshTy + constraint $ CQual QSimple k + return $ TySet (k :*: v) :->: TyMap k v + inferPrim PrimSummary = do + a <- freshTy + constraint $ CQual QSimple a + return $ TyGraph a :->: TyMap a (TySet a) + inferPrim PrimVertex = do + a <- freshTy + constraint $ CQual QSimple a + return $ a :->: TyGraph a + inferPrim PrimEmptyGraph = do + a <- freshTy + constraint $ CQual QSimple a + return $ TyGraph a + inferPrim PrimOverlay = do + a <- freshTy + constraint $ CQual QSimple a + return $ TyGraph a :*: TyGraph a :->: TyGraph a + inferPrim PrimConnect = do + a <- freshTy + constraint $ CQual QSimple a + return $ TyGraph a :*: TyGraph a :->: TyGraph a + inferPrim PrimInsert = do + a <- freshTy + b <- freshTy + constraint $ CQual QSimple a + return $ a :*: b :*: TyMap a b :->: TyMap a b + inferPrim PrimLookup = do + a <- freshTy + b <- freshTy + constraint $ CQual QSimple a + return $ a :*: TyMap a b :->: (TyUnit :+: b) + ---------------------------------------- + -- Container primitives + + inferPrim (PrimBOp Cons) = do + a <- freshTy + return $ a :*: TyList a :->: TyList a + + -- XXX see https://github.com/disco-lang/disco/issues/160 + -- each : (a -> b) × c a -> c b + inferPrim PrimEach = do + c <- freshAtom + a <- freshTy + b <- freshTy + return $ (a :->: b) :*: TyContainer c a :->: TyContainer c b + + -- XXX should eventually be (a * a -> a) * c a -> a, + -- with a check that the function has the right properties. + -- reduce : (a * a -> a) * a * c a -> a + inferPrim PrimReduce = do + c <- freshAtom + a <- freshTy + return $ (a :*: a :->: a) :*: a :*: TyContainer c a :->: a + + -- filter : (a -> Bool) × c a -> c a + inferPrim PrimFilter = do + c <- freshAtom + a <- freshTy + return $ (a :->: TyBool) :*: TyContainer c a :->: TyContainer c a + + -- join : c (c a) -> c a + inferPrim PrimJoin = do + c <- freshAtom + a <- freshTy + return $ TyContainer c (TyContainer c a) :->: TyContainer c a + + -- merge : (N × N -> N) × c a × c a -> c a (c = bag or set) + inferPrim PrimMerge = do + c <- freshAtom + a <- freshTy + constraint $ + COr + [ CEq (TyAtom (ABase CtrBag)) (TyAtom c) + , CEq (TyAtom (ABase CtrSet)) (TyAtom c) + ] + let ca = TyContainer c a + return $ (TyN :*: TyN :->: TyN) :*: ca :*: ca :->: ca + inferPrim (PrimBOp CartProd) = do + a <- freshTy + b <- freshTy + c <- freshAtom + return $ TyContainer c a :*: TyContainer c b :->: TyContainer c (a :*: b) + inferPrim (PrimBOp setOp) | setOp `elem` [Union, Inter, Diff, Subset] = do + a <- freshTy + c <- freshAtom + constraint $ + COr + [ CEq (TyAtom (ABase CtrBag)) (TyAtom c) + , CEq (TyAtom (ABase CtrSet)) (TyAtom c) + ] + let ca = TyContainer c a + let resTy = case setOp of Subset -> TyBool; _ -> ca + return $ ca :*: ca :->: resTy + + -- See Note [Pattern coverage] ----------------------------- + inferPrim (PrimBOp Union) = error "inferPrim Union should be unreachable" + inferPrim (PrimBOp Inter) = error "inferPrim Inter should be unreachable" + inferPrim (PrimBOp Diff) = error "inferPrim Diff should be unreachable" + inferPrim (PrimBOp Subset) = error "inferPrim Subset should be unreachable" + ------------------------------------------------------------ + + inferPrim (PrimBOp Elem) = do + a <- freshTy + c <- freshAtom + + constraint $ CQual QCmp a + + return $ a :*: TyContainer c a :->: TyBool + + ---------------------------------------- + -- Arithmetic + + inferPrim (PrimBOp IDiv) = do + a <- freshTy + resTy <- cInt a + return $ a :*: a :->: resTy + inferPrim (PrimBOp Mod) = do + a <- freshTy + constraint $ CSub a TyZ + return $ a :*: a :->: a + inferPrim (PrimBOp op) | op `elem` [Add, Mul, Sub, Div, SSub] = do + a <- freshTy + constraint $ CQual (bopQual op) a + return $ a :*: a :->: a + + -- See Note [Pattern coverage] ----------------------------- + inferPrim (PrimBOp Add) = error "inferPrim Add should be unreachable" + inferPrim (PrimBOp Mul) = error "inferPrim Mul should be unreachable" + inferPrim (PrimBOp Sub) = error "inferPrim Sub should be unreachable" + inferPrim (PrimBOp Div) = error "inferPrim Div should be unreachable" + inferPrim (PrimBOp SSub) = error "inferPrim SSub should be unreachable" + ------------------------------------------------------------ + + inferPrim (PrimUOp Neg) = do + a <- freshTy + constraint $ CQual QSub a + return $ a :->: a + inferPrim (PrimBOp Exp) = do + a <- freshTy + b <- freshTy + resTy <- cExp a b + return $ a :*: b :->: resTy + + ---------------------------------------- + -- Number theory + + inferPrim PrimIsPrime = return $ TyN :->: TyBool + inferPrim PrimFactor = return $ TyN :->: TyBag TyN + inferPrim PrimFrac = return $ TyQ :->: (TyZ :*: TyN) + inferPrim (PrimBOp Divides) = do + a <- freshTy + constraint $ CQual QNum a + return $ a :*: a :->: TyBool + + ---------------------------------------- + -- Choose + + -- For now, a simple typing rule for multinomial coefficients that + -- requires everything to be Nat. However, they can be extended to + -- handle negative or fractional arguments. + inferPrim (PrimBOp Choose) = do + b <- freshTy + + -- b can be either Nat (a binomial coefficient) + -- or a list of Nat (a multinomial coefficient). + constraint $ COr [CEq b TyN, CEq b (TyList TyN)] + return $ TyN :*: b :->: TyN + + ---------------------------------------- + -- Ellipses + + -- Actually 'until' supports more types than this, e.g. Q instead + -- of N, but this is good enough. This case is here just for + -- completeness---in case someone enables primitives and uses it + -- directly---but typically 'until' is generated only during + -- desugaring of a container with ellipsis, after typechecking, in + -- which case it can be assigned a more appropriate type directly. + + inferPrim PrimUntil = return $ TyN :*: TyList TyN :->: TyList TyN + ---------------------------------------- + -- Crash + + inferPrim PrimCrash = do + a <- freshTy + return $ TyString :->: a + + ---------------------------------------- + -- Propositions + + -- 'holds' converts a Prop into a Bool (but might not terminate). + inferPrim PrimHolds = return $ TyProp :->: TyBool + -- An equality assertion =!= is just like a comparison ==, except + -- the result is a Prop. + inferPrim (PrimBOp ShouldEq) = do + ty <- freshTy + constraint $ CQual QCmp ty + return $ ty :*: ty :->: TyProp + inferPrim (PrimBOp ShouldLt) = do + ty <- freshTy + constraint $ CQual QCmp ty + return $ ty :*: ty :->: TyProp + + ---------------------------------------- + -- Comparisons + + -- Infer the type of a comparison. A comparison always has type + -- Bool, but we have to make sure the subterms have compatible + -- types. We also generate a QCmp qualifier, for two reasons: + -- one, we need to know whether e.g. a comparison was done at a + -- certain type, so we can decide whether the type is allowed to + -- be completely polymorphic or not. Also, comparison of Props is + -- not allowed. + inferPrim (PrimBOp op) | op `elem` [Eq, Neq, Lt, Gt, Leq, Geq] = do + ty <- freshTy + constraint $ CQual QCmp ty + return $ ty :*: ty :->: TyBool + + -- See Note [Pattern coverage] ----------------------------- + inferPrim (PrimBOp Eq) = error "inferPrim Eq should be unreachable" + inferPrim (PrimBOp Neq) = error "inferPrim Neq should be unreachable" + inferPrim (PrimBOp Lt) = error "inferPrim Lt should be unreachable" + inferPrim (PrimBOp Gt) = error "inferPrim Gt should be unreachable" + inferPrim (PrimBOp Leq) = error "inferPrim Leq should be unreachable" + inferPrim (PrimBOp Geq) = error "inferPrim Geq should be unreachable" + ------------------------------------------------------------ + + inferPrim (PrimBOp op) | op `elem` [Min, Max] = do + ty <- freshTy + constraint $ CQual QCmp ty + return $ ty :*: ty :->: ty + + -- See Note [Pattern coverage] ----------------------------- + inferPrim (PrimBOp Min) = error "inferPrim Min should be unreachable" + inferPrim (PrimBOp Max) = error "inferPrim Max should be unreachable" + ------------------------------------------------------------ + + ---------------------------------------- + -- Special arithmetic functions: fact, sqrt, floor, ceil, abs + + inferPrim (PrimUOp Fact) = return $ TyN :->: TyN + inferPrim PrimSqrt = return $ TyN :->: TyN + inferPrim p | p `elem` [PrimFloor, PrimCeil] = do + argTy <- freshTy + resTy <- cInt argTy + return $ argTy :->: resTy + + -- See Note [Pattern coverage] ----------------------------- + inferPrim PrimFloor = error "inferPrim Floor should be unreachable" + inferPrim PrimCeil = error "inferPrim Ceil should be unreachable" + ------------------------------------------------------------ + + inferPrim PrimAbs = do + argTy <- freshTy + resTy <- freshTy + cAbs argTy resTy `cOr` cSize argTy resTy + return $ argTy :->: resTy + + ---------------------------------------- + -- power set/bag + + inferPrim PrimPower = do + a <- freshTy + c <- freshAtom + + constraint $ CQual QCmp a + constraint $ + COr + [ CEq (TyAtom (ABase CtrSet)) (TyAtom c) + , CEq (TyAtom (ABase CtrBag)) (TyAtom c) + ] + + return $ TyContainer c a :->: TyContainer c (TyContainer c a) + inferPrim PrimLookupSeq = return $ TyList TyN :->: (TyUnit :+: TyString) + inferPrim PrimExtendSeq = return $ TyList TyN :->: TyList TyN + +-------------------------------------------------- +-- Base types + +-- A few trivial cases for base types. +typecheck Infer TUnit = return ATUnit +typecheck Infer (TBool b) = return $ ATBool TyBool b +typecheck Infer (TChar c) = return $ ATChar c +typecheck Infer (TString cs) = return $ ATString cs +-- typecheck (Check (TyFin n)) (TNat x) = return $ ATNat (TyFin n) x +typecheck Infer (TNat n) = return $ ATNat TyN n +typecheck Infer (TRat r) = return $ ATRat r +typecheck _ TWild = throw NoTWild +-------------------------------------------------- +-- Abstractions (lambdas and quantifiers) + +-- Lambdas and quantifiers are similar enough that we can share a +-- bunch of the code, but their typing rules are a bit different. In +-- particular a lambda +-- +-- \(x1:ty1), (x2:ty2) ... . body +-- +-- is going to have a type like ty1 -> ty2 -> ... -> resTy, whereas a +-- quantifier like +-- +-- ∃(x1:ty1), (x2:ty2) ... . body +-- +-- is just going to have the type Prop. The similarity is that in +-- both cases we have to generate unification variables for any +-- binders with omitted type annotations, and typecheck the body under +-- an extended context. + +-- It's only helpful to do lambdas in checking mode, since the +-- provided function type can provide information about the types of +-- the arguments. For other quantifiers we can just fall back to +-- inference mode. +typecheck (Check checkTy) tm@(TAbs Lam body) = do + (args, t) <- unbind body + + -- First check that the given type is of the form ty1 -> ty2 -> + -- ... -> resTy, where the types ty1, ty2 ... match up with any + -- types declared for the arguments to the lambda (e.g. (x:tyA) + -- (y:tyB) -> ...). + (ctx, typedArgs, resTy) <- checkArgs args checkTy tm + + -- Then check the type of the body under a context extended with + -- types for all the arguments. + extends ctx $ + ATAbs Lam checkTy <$> (bind (coerce typedArgs) <$> check t resTy) + where + -- Given the patterns and their optional type annotations in the + -- head of a lambda (e.g. @x (y:Z) (f : N -> N) -> ...@), and the + -- type at which we are checking the lambda, ensure that: + -- + -- - The type is of the form @ty1 -> ty2 -> ... -> resTy@ and + -- there are enough @ty1@, @ty2@, ... to match all the arguments. + -- - Each pattern successfully checks at its corresponding type. + -- + -- If it succeeds, return a context binding variables to their + -- types (as determined by the patterns and the input types) which + -- we can use to extend when checking the body, a list of the typed + -- patterns, and the result type of the function. + checkArgs :: + Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r => + [Pattern] -> + Type -> + Term -> + Sem r (TyCtx, [APattern], Type) + + -- If we're all out of arguments, the remaining checking type is the + -- result, and there are no variables to bind in the context. + checkArgs [] ty _ = return (emptyCtx, [], ty) + -- Take the next pattern and its annotation; the checking type must + -- be a function type ty1 -> ty2. + checkArgs (p : args) ty term = do + -- Ensure that ty is a function type + (ty1, ty2) <- ensureConstr2 CArr ty (Left term) + + -- Check the argument pattern against the function domain. + (pCtx, pTyped) <- checkPattern p ty1 + + -- Check the rest of the arguments under the type ty2, returning a + -- context with the rest of the arguments and the final result type. + (ctx, typedArgs, resTy) <- checkArgs args ty2 term + + -- Pass the result type through, and put the pattern-bound variables + -- in the returned context. + return (pCtx <> ctx, pTyped : typedArgs, resTy) + +-- In inference mode, we handle lambdas as well as quantifiers (∀, ∃). +typecheck Infer (TAbs q lam) = do + -- Open it and get the argument patterns with any type annotations. + (args, t) <- unbind lam + + -- Replace any missing type annotations with fresh type variables, + -- and check each pattern at that variable to refine them, collecting + -- the types of each pattern's bound variables in a context. + tys <- mapM getAscrOrFresh args + (pCtxs, typedPats) <- unzip <$> zipWithM checkPattern args tys + + -- In the case of ∀, ∃, have to ensure that the argument types are + -- searchable. + when (q `elem` [All, Ex]) $ + -- What's the difference between this and `tys`? Nothing, after + -- the solver runs, but right now the patterns might have a + -- concrete type from annotations inside tuples. + forM_ (map getType typedPats) $ \ty -> + unless (isSearchable ty) $ + throw $ + NoSearch ty + + -- Extend the context with the given arguments, and then do + -- something appropriate depending on the quantifier. + extends (mconcat pCtxs) $ do + case q of + -- For lambdas, infer the type of the body, and return an appropriate + -- function type. + Lam -> do + at <- infer t + return $ ATAbs Lam (mkFunTy tys (getType at)) (bind typedPats at) + + -- For other quantifiers, check that the body has type Prop, + -- and return Prop. + _ -> do + -- ∀, ∃ + at <- check t TyProp + return $ ATAbs q TyProp (bind typedPats at) + where + getAscrOrFresh :: + Members '[Reader TyDefCtx, Error TCError, Fresh] r => + Pattern -> + Sem r Type + getAscrOrFresh (PAscr _ ty) = checkTypeValid ty >> pure ty + getAscrOrFresh _ = freshTy + + -- mkFunTy [ty1, ..., tyn] out = ty1 -> (ty2 -> ... (tyn -> out)) + mkFunTy :: [Type] -> Type -> Type + mkFunTy tys out = foldr (:->:) out tys + +-------------------------------------------------- +-- Application + +-- Infer the type of a function application by inferring the function +-- type and then checking the argument type. We don't need a checking +-- case because checking mode doesn't help. +typecheck Infer (TApp t t') = do + at <- infer t + let ty = getType at + (ty1, ty2) <- ensureConstr2 CArr ty (Left t) + ATApp ty2 at <$> check t' ty1 + +-------------------------------------------------- +-- Tuples + +-- Check/infer the type of a tuple. +typecheck mode1 (TTup tup) = uncurry ATTup <$> typecheckTuple mode1 tup + where + typecheckTuple :: + Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r => + Mode -> + [Term] -> + Sem r (Type, [ATerm]) + typecheckTuple _ [] = error "Impossible! typecheckTuple []" + typecheckTuple mode [t] = (getType &&& (: [])) <$> typecheck mode t + typecheckTuple mode (t : ts) = do + (m, ms) <- ensureConstrMode2 CProd mode (Left $ TTup (t : ts)) + at <- typecheck m t + (ty, ats) <- typecheckTuple ms ts + return (getType at :*: ty, at : ats) + +---------------------------------------- +-- Comparison chain + +typecheck Infer (TChain t ls) = + ATChain TyBool <$> infer t <*> inferChain t ls + where + inferChain :: + Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r => + Term -> + [Link] -> + Sem r [ALink] + inferChain _ [] = return [] + inferChain t1 (TLink op t2 : links) = do + at2 <- infer t2 + _ <- check (TBin op t1 t2) TyBool + atl <- inferChain t2 links + return $ ATLink op at2 : atl + +---------------------------------------- +-- Type operations + +typecheck Infer (TTyOp Enumerate t) = do + checkTypeValid t + return $ ATTyOp (TyList t) Enumerate t +typecheck Infer (TTyOp Count t) = do + checkTypeValid t + return $ ATTyOp (TyUnit :+: TyN) Count t + +-------------------------------------------------- +-- Containers + +-- Literal containers, including ellipses +typecheck mode t@(TContainer c xs ell) = do + eltMode <- ensureConstrMode1 (containerToCon c) mode (Left t) + axns <- mapM (\(x, n) -> (,) <$> typecheck eltMode x <*> traverse (`check` TyN) n) xs + aell <- typecheckEllipsis eltMode ell + resTy <- case mode of + Infer -> do + let tys = [getType at | Just (Until at) <- [aell]] ++ map (getType . fst) axns + tyv <- freshTy + constraints $ map (`CSub` tyv) tys + return $ containerTy c tyv + Check ty -> return ty + eltTy <- getEltTy c resTy + + -- See Note [Container literal constraints] + when (c /= ListContainer && not (P.null xs)) $ constraint $ CQual QCmp eltTy + when (isJust ell) $ constraint $ CQual QEnum eltTy + return $ ATContainer resTy c axns aell + where + typecheckEllipsis :: + Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r => + Mode -> + Maybe (Ellipsis Term) -> + Sem r (Maybe (Ellipsis ATerm)) + typecheckEllipsis _ Nothing = return Nothing + typecheckEllipsis m (Just (Until tm)) = Just . Until <$> typecheck m tm + +-- ~~~~ Note [Container literal constraints] +-- +-- It should only be possible to construct something of type Set(a) or +-- Bag(a) when a is comparable, so we can normalize the set or bag +-- value. For example, Set(N) is OK, but Set(N -> N) is not. On the +-- other hand, List(a) is fine for any type a. We want to maintain +-- the invariant that we can only actually obtain a value of type +-- Set(a) or Bag(a) if a is comparable. This means we will be able to +-- write polymorphic functions that take bags or sets as input without +-- having to specify any constraints --- the only way to call such +-- functions is with element types that actually support comparison. +-- For example, 'unions' can simply have the type Set(Set(a)) -> +-- Set(a). +-- +-- Hence, container literals (along with the 'set' and 'bag' +-- conversion functions) serve as "gatekeepers" to make sure we can +-- only construct containers with appropriate element types. So when +-- we see a container literal, if it is a bag or set literal, we have +-- to introduce an additional QCmp constraint for the element type. +-- +-- But not so fast --- with that rule, 'unions' does not type check! +-- To see why, look at the definition: +-- +-- unions(ss) = foldr(~∪~, {}, list(ss)) +-- +-- The empty set literal in the definition means we end up generating +-- a QCmp constraint on the element type anyway. But there is a +-- solution: we refine our invariant to say that we can only +-- actually obtain a *non-empty* value of type Set(a) or Bag(a) if a +-- is comparable. Empty bags and sets are allowed to have any element +-- type. This is safe because there is no way to generate a non-empty +-- set from an empty one, without also making use of something like a +-- non-empty set literal or conversion function. So we add a special +-- case to the rule that says we only add a QCmp constraint in the +-- case of a *non-empty* set or bag literal. Now the definition of +-- 'unions' type checks perfectly well. + +-- Container comprehensions +typecheck mode tcc@(TContainerComp c bqt) = do + eltMode <- ensureConstrMode1 (containerToCon c) mode (Left tcc) + (qs, t) <- unbind bqt + (aqs, cx) <- inferTelescope inferQual qs + extends cx $ do + at <- typecheck eltMode t + let resTy = case mode of + Infer -> containerTy c (getType at) + Check ty -> ty + return $ ATContainerComp resTy c (bind aqs at) + where + inferQual :: + Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r => + Qual -> + Sem r (AQual, TyCtx) + inferQual (QBind x (unembed -> t)) = do + at <- infer t + ty <- ensureConstr1 (containerToCon c) (getType at) (Left t) + return (AQBind (coerce x) (embed at), singleCtx (localName x) (toPolyType ty)) + inferQual (QGuard (unembed -> t)) = do + at <- check t TyBool + return (AQGuard (embed at), emptyCtx) + +-------------------------------------------------- +-- Let + +-- To check/infer a let expression. Note let is non-recursive. +typecheck mode (TLet l) = do + (bs, t2) <- unbind l + + -- Infer the types of all the variables bound by the let... + (as, ctx) <- inferTelescope inferBinding bs + + -- ...then check/infer the body under an extended context. + extends ctx $ do + at2 <- typecheck mode t2 + return $ ATLet (getType at2) (bind as at2) + where + -- Infer the type of a binding (@x [: ty] = t@), returning a + -- type-annotated binding along with a (singleton) context for the + -- bound variable. The optional type annotation on the variable + -- determines whether we use inference or checking mode for the + -- body. + inferBinding :: + Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r => + Binding -> + Sem r (ABinding, TyCtx) + inferBinding (Binding mty x (unembed -> t)) = do + at <- case mty of + Just (unembed -> ty) -> checkPolyTy t ty + Nothing -> infer t + return (ABinding mty (coerce x) (embed at), singleCtx (localName x) (toPolyType $ getType at)) + +-------------------------------------------------- +-- Case + +-- Check/infer a case expression. +typecheck _ (TCase []) = throw EmptyCase +typecheck mode (TCase bs) = do + bs' <- mapM typecheckBranch bs + resTy <- case mode of + Check ty -> return ty + Infer -> do + x <- freshTy + constraints $ map ((`CSub` x) . getType) bs' + return x + return $ ATCase resTy bs' + where + typecheckBranch :: + Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r => + Branch -> + Sem r ABranch + typecheckBranch b = do + (gs, t) <- unbind b + (ags, ctx) <- inferTelescope inferGuard gs + extends ctx $ + bind ags <$> typecheck mode t + + -- Infer the type of a guard, returning the type-annotated guard + -- along with a context of types for any variables bound by the + -- guard. + inferGuard :: + Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r => + Guard -> + Sem r (AGuard, TyCtx) + inferGuard (GBool (unembed -> t)) = do + at <- check t TyBool + return (AGBool (embed at), emptyCtx) + inferGuard (GPat (unembed -> t) p) = do + at <- infer t + (ctx, apt) <- checkPattern p (getType at) + return (AGPat (embed at) apt, ctx) + inferGuard (GLet (Binding mty x (unembed -> t))) = do + at <- case mty of + Just (unembed -> ty) -> checkPolyTy t ty + Nothing -> infer t + return + ( AGLet (ABinding mty (coerce x) (embed at)) + , singleCtx (localName x) (toPolyType (getType at)) + ) + +-------------------------------------------------- +-- Type ascription + +-- Ascriptions are what let us flip from inference mode into +-- checking mode. +typecheck Infer (TAscr t ty) = checkPolyTyValid ty >> checkPolyTy t ty +-------------------------------------------------- +-- Inference fallback + +-- Finally, to check anything else, we can fall back to inferring its +-- type and then check that the inferred type is a *subtype* of the +-- given type. We have to be careful to call 'setType' to change the +-- type at the root of the term to the requested type. +typecheck (Check ty) t = do + at <- infer t + constraint $ CSub (getType at) ty + return $ setType ty at + +------------------------------------------------------------ +-- Patterns +------------------------------------------------------------ + +-- | Check that a pattern has the given type, and return a context of +-- pattern variables bound in the pattern along with their types. +checkPattern :: + Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r => + Pattern -> + Type -> + Sem r (TyCtx, APattern) +checkPattern (PNonlinear p x) _ = throw $ NonlinearPattern p x +checkPattern p (TyUser name args) = lookupTyDefn name args >>= checkPattern p +checkPattern (PVar x) ty = return (singleCtx (localName x) (toPolyType ty), APVar ty (coerce x)) +checkPattern PWild ty = return (emptyCtx, APWild ty) +checkPattern (PAscr p ty1) ty2 = do + -- We have a pattern that promises to match ty1 and someone is asking + -- us if it can also match ty2. So we just have to ensure what we're + -- being asked for is a subtype of what we can promise to cover... + constraint $ CSub ty2 ty1 + -- ... and then make sure the pattern can actually match what it promised to. + checkPattern p ty1 +checkPattern PUnit ty = do + ensureEq ty TyUnit + return (emptyCtx, APUnit) +checkPattern (PBool b) ty = do + ensureEq ty TyBool + return (emptyCtx, APBool b) +checkPattern (PChar c) ty = do + ensureEq ty TyC + return (emptyCtx, APChar c) +checkPattern (PString s) ty = do + ensureEq ty TyString + return (emptyCtx, APString s) +checkPattern (PTup tup) tupTy = do + listCtxtAps <- checkTuplePat tup tupTy + let (ctxs, aps) = unzip listCtxtAps + return (mconcat ctxs, APTup (foldr1 (:*:) (map getType aps)) aps) + where + checkTuplePat :: + Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r => + [Pattern] -> + Type -> + Sem r [(TyCtx, APattern)] + checkTuplePat [] _ = error "Impossible! checkTuplePat []" + checkTuplePat [p] ty = do + -- (:[]) <$> check t ty + (ctx, apt) <- checkPattern p ty + return [(ctx, apt)] + checkTuplePat (p : ps) ty = do + (ty1, ty2) <- ensureConstr2 CProd ty (Right $ PTup (p : ps)) + (ctx, apt) <- checkPattern p ty1 + rest <- checkTuplePat ps ty2 + return ((ctx, apt) : rest) +checkPattern p@(PInj L pat) ty = do + (ty1, ty2) <- ensureConstr2 CSum ty (Right p) + (ctx, apt) <- checkPattern pat ty1 + return (ctx, APInj (ty1 :+: ty2) L apt) +checkPattern p@(PInj R pat) ty = do + (ty1, ty2) <- ensureConstr2 CSum ty (Right p) + (ctx, apt) <- checkPattern pat ty2 + return (ctx, APInj (ty1 :+: ty2) R apt) + +-- we can match any supertype of TyN against a Nat pattern, OR +-- any TyFin. + +-- XXX this isn't quite right, what if we're checking at a type +-- variable but we need to solve it to be a TyFin? Can this ever +-- happen? We would need a COr, except we can't express the +-- constraint "exists m. ty = TyFin m" +-- +-- Yes, this can happen, and here's an example: +-- +-- > (\x. {? true when x is 3, false otherwise ?}) (2 : Z5) +-- Unsolvable NoUnify +-- > (\(x : Z5). {? true when x is 3, false otherwise ?}) (2 : Z5) +-- false + +-- checkPattern (PNat n) (TyFin m) = return (emptyCtx, APNat (TyFin m) n) +checkPattern (PNat n) ty = do + constraint $ CSub TyN ty + return (emptyCtx, APNat ty n) +checkPattern p@(PCons p1 p2) ty = do + tyl <- ensureConstr1 CList ty (Right p) + (ctx1, ap1) <- checkPattern p1 tyl + (ctx2, ap2) <- checkPattern p2 (TyList tyl) + return (ctx1 <> ctx2, APCons (TyList tyl) ap1 ap2) +checkPattern p@(PList ps) ty = do + tyl <- ensureConstr1 CList ty (Right p) + listCtxtAps <- mapM (`checkPattern` tyl) ps + let (ctxs, aps) = unzip listCtxtAps + return (mconcat ctxs, APList (TyList tyl) aps) +checkPattern (PAdd s p t) ty = do + constraint $ CQual QNum ty + (ctx, apt) <- checkPattern p ty + at <- check t ty + return (ctx, APAdd ty s apt at) +checkPattern (PMul s p t) ty = do + constraint $ CQual QNum ty + (ctx, apt) <- checkPattern p ty + at <- check t ty + return (ctx, APMul ty s apt at) +checkPattern (PSub p t) ty = do + constraint $ CQual QNum ty + (ctx, apt) <- checkPattern p ty + at <- check t ty + return (ctx, APSub ty apt at) +checkPattern (PNeg p) ty = do + constraint $ CQual QSub ty + tyInner <- cPos ty + (ctx, apt) <- checkPattern p tyInner + return (ctx, APNeg ty apt) +checkPattern (PFrac p q) ty = do + constraint $ CQual QDiv ty + tyP <- cInt ty + tyQ <- cPos tyP + (ctx1, ap1) <- checkPattern p tyP + (ctx2, ap2) <- checkPattern q tyQ + return (ctx1 <> ctx2, APFrac ty ap1 ap2) + +------------------------------------------------------------ +-- Constraints for abs, floor/ceiling/idiv, and exp +------------------------------------------------------------ + +-- | Constraints needed on a function type for it to be the type of +-- the absolute value function. +cAbs :: Members '[Writer Constraint, Fresh] r => Type -> Type -> Sem r () +cAbs argTy resTy = do + resTy' <- cPos argTy + constraint $ CEq resTy resTy' + +-- | Constraints needed on a function type for it to be the type of +-- the container size operation. +cSize :: Members '[Writer Constraint, Fresh] r => Type -> Type -> Sem r () +cSize argTy resTy = do + a <- freshTy + c <- freshAtom + constraint $ CEq (TyContainer c a) argTy + constraint $ CEq TyN resTy + +-- | Given an input type @ty@, return a type which represents the +-- output type of the absolute value function, and generate +-- appropriate constraints. +cPos :: Members '[Writer Constraint, Fresh] r => Type -> Sem r Type +cPos ty = do + constraint $ CQual QNum ty -- The input type has to be numeric. + case ty of + -- If the input type is a concrete base type, we can just + -- compute the correct output type. + TyAtom (ABase b) -> return $ TyAtom (ABase (pos b)) + -- Otherwise, generate a fresh type variable for the output type + -- along with some constraints. + _ -> do + res <- freshTy + + -- Valid types for absolute value are Z -> N, Q -> F, or T -> T + -- (e.g. Z5 -> Z5). + constraint $ + COr + [ cAnd [CSub ty TyZ, CSub TyN res] + , cAnd [CSub ty TyQ, CSub TyF res] + , CEq ty res + ] + return res + where + pos Z = N + pos Q = F + pos t = t + +-- | Given an input type @ty@, return a type which represents the +-- output type of the floor or ceiling functions, and generate +-- appropriate constraints. +cInt :: Members '[Writer Constraint, Fresh] r => Type -> Sem r Type +cInt ty = do + constraint $ CQual QNum ty + case ty of + -- If the input type is a concrete base type, we can just + -- compute the correct output type. + TyAtom (ABase b) -> return $ TyAtom (ABase (int b)) + -- Otherwise, generate a fresh type variable for the output type + -- along with some constraints. + _ -> do + res <- freshTy + + -- Valid types for absolute value are F -> N, Q -> Z, or T -> T + -- (e.g. Z5 -> Z5). + constraint $ + COr + [ cAnd [CSub ty TyF, CSub TyN res] + , cAnd [CSub ty TyQ, CSub TyZ res] + , CEq ty res + ] + return res + where + int F = N + int Q = Z + int t = t + +-- | Given input types to the exponentiation operator, return a type +-- which represents the output type, and generate appropriate +-- constraints. +cExp :: Members '[Writer Constraint, Fresh] r => Type -> Type -> Sem r Type +cExp ty1 TyN = do + constraint $ CQual QNum ty1 + return ty1 + +-- We could include a special case for TyZ, but for that we would need +-- a function to find a supertype of a given type that satisfies QDiv. + +cExp ty1 ty2 = do + -- Create a fresh type variable to represent the result type. The + -- base type has to be a subtype. + resTy <- freshTy + constraint $ CSub ty1 resTy + + -- Either the exponent type is N, in which case the result type has + -- to support multiplication, or else the exponent is Z, in which + -- case the result type also has to support division. + constraint $ + COr + [ cAnd [CQual QNum resTy, CEq ty2 TyN] + , cAnd [CQual QDiv resTy, CEq ty2 TyZ] + ] + return resTy + +------------------------------------------------------------ +-- Decomposing type constructors +------------------------------------------------------------ + +-- | Get the argument (element) type of a (known) container type. Returns a +-- fresh variable with a suitable constraint if the given type is +-- not literally a container type. +getEltTy :: Members '[Writer Constraint, Fresh] r => Container -> Type -> Sem r Type +getEltTy _ (TyContainer _ e) = return e +getEltTy c ty = do + eltTy <- freshTy + constraint $ CEq (containerTy c eltTy) ty + return eltTy + +-- | Ensure that a type's outermost constructor matches the provided +-- constructor, returning the types within the matched constructor +-- or throwing a type error. If the type provided is a type +-- variable, appropriate constraints are generated to guarantee the +-- type variable's outermost constructor matches the provided +-- constructor, and a list of fresh type variables is returned whose +-- count matches the arity of the provided constructor. +ensureConstr :: + forall r. + Members '[Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r => + Con -> + Type -> + Either Term Pattern -> + Sem r [Type] +ensureConstr c ty targ = matchConTy c ty + where + matchConTy :: Con -> Type -> Sem r [Type] + + -- expand type definitions lazily + matchConTy c1 (TyUser name args) = lookupTyDefn name args >>= matchConTy c1 + matchConTy c1 (TyCon c2 tys) = do + matchCon c1 c2 + return tys + matchConTy c1 tyv@(TyAtom (AVar (U _))) = do + tyvs <- mapM (const freshTy) (arity c1) + constraint $ CEq tyv (TyCon c1 tyvs) + return tyvs + matchConTy _ _ = matchError + + -- \| Check whether two constructors match, which could include + -- unifying container variables if we are matching two container + -- types; otherwise, simply ensure that the constructors are + -- equal. Throw a 'matchError' if they do not match. + matchCon :: Con -> Con -> Sem r () + matchCon c1 c2 | c1 == c2 = return () + matchCon (CContainer v@(AVar (U _))) (CContainer ctr2) = + constraint $ CEq (TyAtom v) (TyAtom ctr2) + matchCon (CContainer ctr1) (CContainer v@(AVar (U _))) = + constraint $ CEq (TyAtom ctr1) (TyAtom v) + matchCon _ _ = matchError + + matchError :: Sem r a + matchError = case targ of + Left term -> throw (NotCon c term ty) + Right pat -> throw (PatternType c pat ty) + +-- | A variant of ensureConstr that expects to get exactly one +-- argument type out, and throws an error if we get any other +-- number. +ensureConstr1 :: + Members '[Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r => + Con -> + Type -> + Either Term Pattern -> + Sem r Type +ensureConstr1 c ty targ = do + tys <- ensureConstr c ty targ + case tys of + [ty1] -> return ty1 + _ -> + error $ + "Impossible! Wrong number of arg types in ensureConstr1 " + ++ show c + ++ " " + ++ show ty + ++ ": " + ++ show tys + +-- | A variant of ensureConstr that expects to get exactly two +-- argument types out, and throws an error if we get any other +-- number. +ensureConstr2 :: + Members '[Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r => + Con -> + Type -> + Either Term Pattern -> + Sem r (Type, Type) +ensureConstr2 c ty targ = do + tys <- ensureConstr c ty targ + case tys of + [ty1, ty2] -> return (ty1, ty2) + _ -> + error $ + "Impossible! Wrong number of arg types in ensureConstr2 " + ++ show c + ++ " " + ++ show ty + ++ ": " + ++ show tys + +-- | A variant of 'ensureConstr' that works on 'Mode's instead of +-- 'Type's. Behaves similarly to 'ensureConstr' if the 'Mode' is +-- 'Check'; otherwise it generates an appropriate number of copies +-- of 'Infer'. +ensureConstrMode :: + Members '[Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r => + Con -> + Mode -> + Either Term Pattern -> + Sem r [Mode] +ensureConstrMode c Infer _ = return $ map (const Infer) (arity c) +ensureConstrMode c (Check ty) tp = map Check <$> ensureConstr c ty tp + +-- | A variant of 'ensureConstrMode' that expects to get a single +-- 'Mode' and throws an error if it encounters any other number. +ensureConstrMode1 :: + Members '[Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r => + Con -> + Mode -> + Either Term Pattern -> + Sem r Mode +ensureConstrMode1 c m targ = do + ms <- ensureConstrMode c m targ + case ms of + [m1] -> return m1 + _ -> + error $ + "Impossible! Wrong number of arg types in ensureConstrMode1 " + ++ show c + ++ " " + ++ show m + ++ ": " + ++ show ms + +-- | A variant of 'ensureConstrMode' that expects to get two 'Mode's +-- and throws an error if it encounters any other number. +ensureConstrMode2 :: + Members '[Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r => + Con -> + Mode -> + Either Term Pattern -> + Sem r (Mode, Mode) +ensureConstrMode2 c m targ = do + ms <- ensureConstrMode c m targ + case ms of + [m1, m2] -> return (m1, m2) + _ -> + error $ + "Impossible! Wrong number of arg types in ensureConstrMode2 " + ++ show c + ++ " " + ++ show m + ++ ": " + ++ show ms + +-- | Ensure that two types are equal: +-- 1. Do nothing if they are literally equal +-- 2. Generate an equality constraint otherwise +ensureEq :: Member (Writer Constraint) r => Type -> Type -> Sem r () +ensureEq ty1 ty2 + | ty1 == ty2 = return () + | otherwise = constraint $ CEq ty1 ty2 diff --git a/src/Disco/Typecheck/Constraints.hs b/src/Disco/Typecheck/Constraints.hs --- a/src/Disco/Typecheck/Constraints.hs +++ b/src/Disco/Typecheck/Constraints.hs @@ -1,7 +1,10 @@ -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Disco.Typecheck.Constraints -- Copyright : disco team and contributors @@ -10,73 +13,69 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- Constraints generated by type inference & checking. --- ------------------------------------------------------------------------------ - -module Disco.Typecheck.Constraints - ( Constraint(..) - , cAnd - ) - where +module Disco.Typecheck.Constraints ( + Constraint (..), + cAnd, +) +where -import qualified Data.List.NonEmpty as NE -import Data.Semigroup -import GHC.Generics (Generic) -import Unbound.Generics.LocallyNameless hiding (lunbind) +import qualified Data.List.NonEmpty as NE +import Data.Semigroup +import GHC.Generics (Generic) +import Unbound.Generics.LocallyNameless hiding (lunbind) -import Disco.Effects.LFresh +import Disco.Effects.LFresh -import Disco.Pretty hiding ((<>)) -import Disco.Syntax.Operators (BFixity (In, InL, InR)) -import Disco.Types -import Disco.Types.Rules +import Disco.Pretty hiding ((<>)) +import Disco.Syntax.Operators (BFixity (In, InL, InR)) +import Disco.Types +import Disco.Types.Rules -- | Constraints are generated as a result of type inference and checking. -- These constraints are accumulated during the inference and checking phase -- and are subsequently solved by the constraint solver. data Constraint where - CSub :: Type -> Type -> Constraint - CEq :: Type -> Type -> Constraint - CQual :: Qualifier -> Type -> Constraint - CAnd :: [Constraint] -> Constraint - CTrue :: Constraint - COr :: [Constraint] -> Constraint - CAll :: Bind [Name Type] Constraint -> Constraint - + CSub :: Type -> Type -> Constraint + CEq :: Type -> Type -> Constraint + CQual :: Qualifier -> Type -> Constraint + CAnd :: [Constraint] -> Constraint + CTrue :: Constraint + COr :: [Constraint] -> Constraint + CAll :: Bind [Name Type] Constraint -> Constraint deriving (Show, Generic, Alpha, Subst Type) instance Pretty Constraint where pretty = \case - CSub ty1 ty2 -> withPA (PA 4 In) $ lt (pretty ty1) <+> "<:" <+> rt (pretty ty2) - CEq ty1 ty2 -> withPA (PA 4 In) $ lt (pretty ty1) <+> "=" <+> rt (pretty ty2) - CQual q ty -> withPA (PA 10 InL) $ lt (pretty q) <+> rt (pretty ty) - CAnd [c] -> pretty c - -- Use rt for both, since we don't need to print parens for /\ at all - CAnd (c:cs) -> withPA (PA 3 InR) $ rt (pretty c) <+> "/\\" <+> rt (pretty (CAnd cs)) - CAnd [] -> "True" - CTrue -> "True" - COr [c] -> pretty c - COr (c:cs) -> withPA (PA 2 InR) $ lt (pretty c) <+> "\\/" <+> rt (pretty (COr cs)) - COr [] -> "False" - CAll b -> lunbind b $ \(xs, c) -> + CSub ty1 ty2 -> withPA (PA 4 In) $ lt (pretty ty1) <+> "<:" <+> rt (pretty ty2) + CEq ty1 ty2 -> withPA (PA 4 In) $ lt (pretty ty1) <+> "=" <+> rt (pretty ty2) + CQual q ty -> withPA (PA 10 InL) $ lt (pretty q) <+> rt (pretty ty) + CAnd [c] -> pretty c + -- Use rt for both, since we don't need to print parens for /\ at all + CAnd (c : cs) -> withPA (PA 3 InR) $ rt (pretty c) <+> "/\\" <+> rt (pretty (CAnd cs)) + CAnd [] -> "True" + CTrue -> "True" + COr [c] -> pretty c + COr (c : cs) -> withPA (PA 2 InR) $ lt (pretty c) <+> "\\/" <+> rt (pretty (COr cs)) + COr [] -> "False" + CAll b -> lunbind b $ \(xs, c) -> "∀" <+> intercalate "," (map pretty xs) <> "." <+> pretty c -- A helper function for creating a single constraint from a list of constraints. cAnd :: [Constraint] -> Constraint cAnd cs = case filter nontrivial cs of - [] -> CTrue + [] -> CTrue [c] -> c cs' -> CAnd cs' - where - nontrivial CTrue = False - nontrivial _ = True + where + nontrivial CTrue = False + nontrivial _ = True instance Semigroup Constraint where - c1 <> c2 = cAnd [c1,c2] - sconcat = cAnd . NE.toList - stimes = stimesIdempotent + c1 <> c2 = cAnd [c1, c2] + sconcat = cAnd . NE.toList + stimes = stimesIdempotent instance Monoid Constraint where - mempty = CTrue + mempty = CTrue mappend = (<>) mconcat = cAnd diff --git a/src/Disco/Typecheck/Erase.hs b/src/Disco/Typecheck/Erase.hs --- a/src/Disco/Typecheck/Erase.hs +++ b/src/Disco/Typecheck/Erase.hs @@ -1,4 +1,7 @@ ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Disco.Typecheck.Erase -- Copyright : (c) 2016 disco team (see LICENSE) @@ -7,82 +10,83 @@ -- -- Typecheck the Disco surface language and transform it into a -- type-annotated AST. --- ------------------------------------------------------------------------------ - module Disco.Typecheck.Erase where -import Unbound.Generics.LocallyNameless -import Unbound.Generics.LocallyNameless.Unsafe +import Unbound.Generics.LocallyNameless +import Unbound.Generics.LocallyNameless.Unsafe -import Control.Arrow ((***)) -import Data.Coerce +import Control.Arrow ((***)) +import Data.Coerce -import Disco.AST.Desugared -import Disco.AST.Surface -import Disco.AST.Typed -import Disco.Names (QName (..)) +import Disco.AST.Desugared +import Disco.AST.Surface +import Disco.AST.Typed +import Disco.Names (QName (..)) -- | Erase all the type annotations from a term. erase :: ATerm -> Term erase (ATVar _ (QName _ x)) = TVar (coerce x) -erase (ATPrim _ x) = TPrim x -erase (ATLet _ bs) = TLet $ bind (mapTelescope eraseBinding tel) (erase at) - where (tel,at) = unsafeUnbind bs -erase ATUnit = TUnit -erase (ATBool _ b) = TBool b -erase (ATChar c) = TChar c -erase (ATString s) = TString s -erase (ATNat _ i) = TNat i -erase (ATRat r) = TRat r -erase (ATAbs q _ b) = TAbs q $ bind (map erasePattern x) (erase at) - where (x,at) = unsafeUnbind b -erase (ATApp _ t1 t2) = TApp (erase t1) (erase t2) -erase (ATTup _ ats) = TTup (map erase ats) -erase (ATCase _ brs) = TCase (map eraseBranch brs) -erase (ATChain _ at lnks) = TChain (erase at) (map eraseLink lnks) -erase (ATTyOp _ op ty) = TTyOp op ty -erase (ATContainer _ c ats aell) = TContainer c (map (erase *** fmap erase) ats) ((fmap . fmap) erase aell) -erase (ATContainerComp _ c b) = TContainerComp c $ bind (mapTelescope eraseQual tel) (erase at) - where (tel,at) = unsafeUnbind b -erase (ATTest _ x) = erase x +erase (ATPrim _ x) = TPrim x +erase (ATLet _ bs) = TLet $ bind (mapTelescope eraseBinding tel) (erase at) + where + (tel, at) = unsafeUnbind bs +erase ATUnit = TUnit +erase (ATBool _ b) = TBool b +erase (ATChar c) = TChar c +erase (ATString s) = TString s +erase (ATNat _ i) = TNat i +erase (ATRat r) = TRat r +erase (ATAbs q _ b) = TAbs q $ bind (map erasePattern x) (erase at) + where + (x, at) = unsafeUnbind b +erase (ATApp _ t1 t2) = TApp (erase t1) (erase t2) +erase (ATTup _ ats) = TTup (map erase ats) +erase (ATCase _ brs) = TCase (map eraseBranch brs) +erase (ATChain _ at lnks) = TChain (erase at) (map eraseLink lnks) +erase (ATTyOp _ op ty) = TTyOp op ty +erase (ATContainer _ c ats aell) = TContainer c (map (erase *** fmap erase) ats) ((fmap . fmap) erase aell) +erase (ATContainerComp _ c b) = TContainerComp c $ bind (mapTelescope eraseQual tel) (erase at) + where + (tel, at) = unsafeUnbind b +erase (ATTest _ x) = erase x eraseBinding :: ABinding -> Binding eraseBinding (ABinding mty x (unembed -> at)) = Binding mty (coerce x) (embed (erase at)) erasePattern :: APattern -> Pattern -erasePattern (APVar _ n) = PVar (coerce n) -erasePattern (APWild _) = PWild -erasePattern APUnit = PUnit -erasePattern (APBool b) = PBool b -erasePattern (APChar c) = PChar c -erasePattern (APString s) = PString s -erasePattern (APTup _ alp) = PTup $ map erasePattern alp -erasePattern (APInj _ s apt) = PInj s (erasePattern apt) -erasePattern (APNat _ n) = PNat n +erasePattern (APVar _ n) = PVar (coerce n) +erasePattern (APWild _) = PWild +erasePattern APUnit = PUnit +erasePattern (APBool b) = PBool b +erasePattern (APChar c) = PChar c +erasePattern (APString s) = PString s +erasePattern (APTup _ alp) = PTup $ map erasePattern alp +erasePattern (APInj _ s apt) = PInj s (erasePattern apt) +erasePattern (APNat _ n) = PNat n erasePattern (APCons _ ap1 ap2) = PCons (erasePattern ap1) (erasePattern ap2) -erasePattern (APList _ alp) = PList $ map erasePattern alp -erasePattern (APAdd _ s p t) = PAdd s (erasePattern p) (erase t) -erasePattern (APMul _ s p t) = PMul s (erasePattern p) (erase t) -erasePattern (APSub _ p t) = PSub (erasePattern p) (erase t) -erasePattern (APNeg _ p) = PNeg (erasePattern p) -erasePattern (APFrac _ p1 p2) = PFrac (erasePattern p1) (erasePattern p2) +erasePattern (APList _ alp) = PList $ map erasePattern alp +erasePattern (APAdd _ s p t) = PAdd s (erasePattern p) (erase t) +erasePattern (APMul _ s p t) = PMul s (erasePattern p) (erase t) +erasePattern (APSub _ p t) = PSub (erasePattern p) (erase t) +erasePattern (APNeg _ p) = PNeg (erasePattern p) +erasePattern (APFrac _ p1 p2) = PFrac (erasePattern p1) (erasePattern p2) eraseBranch :: ABranch -> Branch eraseBranch b = bind (mapTelescope eraseGuard tel) (erase at) - where (tel,at) = unsafeUnbind b + where + (tel, at) = unsafeUnbind b eraseGuard :: AGuard -> Guard -eraseGuard (AGBool (unembed -> at)) = GBool (embed (erase at)) +eraseGuard (AGBool (unembed -> at)) = GBool (embed (erase at)) eraseGuard (AGPat (unembed -> at) p) = GPat (embed (erase at)) (erasePattern p) -eraseGuard (AGLet b) = GLet (eraseBinding b) +eraseGuard (AGLet b) = GLet (eraseBinding b) eraseLink :: ALink -> Link eraseLink (ATLink bop at) = TLink bop (erase at) eraseQual :: AQual -> Qual eraseQual (AQBind x (unembed -> at)) = QBind (coerce x) (embed (erase at)) -eraseQual (AQGuard (unembed -> at)) = QGuard (embed (erase at)) +eraseQual (AQGuard (unembed -> at)) = QGuard (embed (erase at)) eraseProperty :: AProperty -> Property eraseProperty = erase @@ -92,32 +96,33 @@ eraseDTerm :: DTerm -> Term eraseDTerm (DTVar _ (QName _ x)) = TVar (coerce x) -eraseDTerm (DTPrim _ x) = TPrim x -eraseDTerm DTUnit = TUnit -eraseDTerm (DTBool _ b) = TBool b -eraseDTerm (DTChar c) = TChar c -eraseDTerm (DTNat _ n) = TNat n -eraseDTerm (DTRat r) = TRat r -eraseDTerm (DTAbs q _ b) = TAbs q $ bind [PVar . coerce $ x] (eraseDTerm dt) - where (x, dt) = unsafeUnbind b -eraseDTerm (DTApp _ d1 d2) = TApp (eraseDTerm d1) (eraseDTerm d2) +eraseDTerm (DTPrim _ x) = TPrim x +eraseDTerm DTUnit = TUnit +eraseDTerm (DTBool _ b) = TBool b +eraseDTerm (DTChar c) = TChar c +eraseDTerm (DTNat _ n) = TNat n +eraseDTerm (DTRat r) = TRat r +eraseDTerm (DTAbs q _ b) = TAbs q $ bind [PVar . coerce $ x] (eraseDTerm dt) + where + (x, dt) = unsafeUnbind b +eraseDTerm (DTApp _ d1 d2) = TApp (eraseDTerm d1) (eraseDTerm d2) eraseDTerm (DTPair _ d1 d2) = TTup [eraseDTerm d1, eraseDTerm d2] -eraseDTerm (DTCase _ bs) = TCase (map eraseDBranch bs) +eraseDTerm (DTCase _ bs) = TCase (map eraseDBranch bs) eraseDTerm (DTTyOp _ op ty) = TTyOp op ty -eraseDTerm (DTNil _) = TList [] Nothing -eraseDTerm (DTTest _ x) = eraseDTerm x +eraseDTerm (DTNil _) = TList [] Nothing +eraseDTerm (DTTest _ x) = eraseDTerm x eraseDBranch :: DBranch -> Branch eraseDBranch b = bind (mapTelescope eraseDGuard tel) (eraseDTerm d) - where - (tel, d) = unsafeUnbind b + where + (tel, d) = unsafeUnbind b eraseDGuard :: DGuard -> Guard eraseDGuard (DGPat (unembed -> d) p) = GPat (embed (eraseDTerm d)) (eraseDPattern p) eraseDPattern :: DPattern -> Pattern -eraseDPattern (DPVar _ x) = PVar (coerce x) -eraseDPattern (DPWild _) = PWild -eraseDPattern DPUnit = PUnit -eraseDPattern (DPPair _ x1 x2) = PTup (map (PVar . coerce) [x1,x2]) -eraseDPattern (DPInj _ s x) = PInj s (PVar (coerce x)) +eraseDPattern (DPVar _ x) = PVar (coerce x) +eraseDPattern (DPWild _) = PWild +eraseDPattern DPUnit = PUnit +eraseDPattern (DPPair _ x1 x2) = PTup (map (PVar . coerce) [x1, x2]) +eraseDPattern (DPInj _ s x) = PInj s (PVar (coerce x)) diff --git a/src/Disco/Typecheck/Graph.hs b/src/Disco/Typecheck/Graph.hs --- a/src/Disco/Typecheck/Graph.hs +++ b/src/Disco/Typecheck/Graph.hs @@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Disco.Typecheck.Graph -- Copyright : disco team and contributors @@ -11,65 +14,67 @@ -- A thin layer on top of graphs from the @fgl@ package, which -- allows dealing with vertices by label instead of by integer -- @Node@ values. ------------------------------------------------------------------------------ - module Disco.Typecheck.Graph where -import Prelude hiding (map, (<>)) -import qualified Prelude as P +import Prelude hiding (map, (<>)) +import qualified Prelude as P -import Control.Arrow ((&&&)) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (fromJust, isJust, mapMaybe) -import Data.Set (Set) -import qualified Data.Set as S -import Data.Tuple (swap) +import Control.Arrow ((&&&)) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromJust, isJust, mapMaybe) +import Data.Set (Set) +import qualified Data.Set as S +import Data.Tuple (swap) -import qualified Data.Graph.Inductive.Graph as G -import Data.Graph.Inductive.PatriciaTree (Gr) -import qualified Data.Graph.Inductive.Query.DFS as G (components, - condensation, topsort') +import qualified Data.Graph.Inductive.Graph as G +import Data.Graph.Inductive.PatriciaTree (Gr) +import qualified Data.Graph.Inductive.Query.DFS as G ( + components, + condensation, + topsort', + ) -import Disco.Pretty -import Disco.Util ((!)) +import Disco.Pretty +import Disco.Util ((!)) -- | Directed graphs, with vertices labelled by @a@ and unlabelled -- edges. data Graph a = G (Gr a ()) (Map a G.Node) (Map G.Node a) - deriving Show + deriving (Show) instance Pretty a => Pretty (Graph a) where pretty (G g _ _) = parens (prettyVertices <> ", " <> prettyEdges) + where -- (V = {(0, x), (1, N)}, E = {0 -> 1, 2 -> 3}) - where - vs = G.labNodes g - es = G.labEdges g - prettyVertex (n,a) = parens (text (show n) <> ", " <> pretty a) - prettyVertices = "V = " <> braces (intercalate "," (P.map prettyVertex vs)) - prettyEdge (v1,v2,_) = text (show v1) <+> "->" <+> text (show v2) - prettyEdges = "E = " <> braces (intercalate "," (P.map prettyEdge es)) + vs = G.labNodes g + es = G.labEdges g + prettyVertex (n, a) = parens (text (show n) <> ", " <> pretty a) + prettyVertices = "V = " <> braces (intercalate "," (P.map prettyVertex vs)) + prettyEdge (v1, v2, _) = text (show v1) <+> "->" <+> text (show v2) + prettyEdges = "E = " <> braces (intercalate "," (P.map prettyEdge es)) + -- | Create a graph with the given set of vertices and directed edges. -- If any edges refer to vertices that are not in the given vertex -- set, they will simply be dropped. -mkGraph :: (Show a, Ord a) => Set a -> Set (a,a) -> Graph a +mkGraph :: (Show a, Ord a) => Set a -> Set (a, a) -> Graph a mkGraph vs es = G (G.mkGraph vs' es') a2n n2a - where - vs' = zip [0..] (S.toList vs) - n2a = M.fromList vs' - a2n = M.fromList . P.map swap $ vs' - es' = mapMaybe mkEdge (S.toList es) - mkEdge (a1,a2) = (,,) <$> M.lookup a1 a2n <*> M.lookup a2 a2n <*> pure () + where + vs' = zip [0 ..] (S.toList vs) + n2a = M.fromList vs' + a2n = M.fromList . P.map swap $ vs' + es' = mapMaybe mkEdge (S.toList es) + mkEdge (a1, a2) = (,,) <$> M.lookup a1 a2n <*> M.lookup a2 a2n <*> pure () -- | Return the set of vertices (nodes) of a graph. nodes :: Graph a -> Set a nodes (G _ m _) = M.keysSet m -- | Return the set of directed edges of a graph. -edges :: Ord a => Graph a -> Set (a,a) -edges (G g _ m) = S.fromList $ P.map (\(n1,n2,()) -> (m ! n1, m ! n2)) (G.labEdges g) +edges :: Ord a => Graph a -> Set (a, a) +edges (G g _ m) = S.fromList $ P.map (\(n1, n2, ()) -> (m ! n1, m ! n2)) (G.labEdges g) -- | Map a function over all the vertices of a graph. @Graph@ is not -- a @Functor@ instance because of the @Ord@ constraint on @b@. @@ -79,8 +84,8 @@ -- | Delete a vertex. delete :: (Show a, Ord a) => a -> Graph a -> Graph a delete a (G g a2n n2a) = G (G.delNode n g) (M.delete a a2n) (M.delete n n2a) - where - n = a2n ! a + where + n = a2n ! a -- | The @condensation@ of a graph is the graph of its strongly -- connected components, /i.e./ each strongly connected component is @@ -90,11 +95,11 @@ -- component A to any vertex in component B in the original graph. condensation :: Ord a => Graph a -> Graph (Set a) condensation (G g _ n2a) = G g' as2n n2as - where - g' = G.nmap (S.fromList . P.map (n2a !)) (G.condensation g) - vs' = G.labNodes g' - n2as = M.fromList vs' - as2n = M.fromList . P.map swap $ vs' + where + g' = G.nmap (S.fromList . P.map (n2a !)) (G.condensation g) + vs' = G.labNodes g' + n2as = M.fromList vs' + as2n = M.fromList . P.map swap $ vs' -- | Get a list of the weakly connected components of a graph, -- providing the set of vertices in each. Equivalently, return the @@ -116,7 +121,7 @@ sequenceGraph :: Ord a => Graph (Maybe a) -> Maybe (Graph a) sequenceGraph g = case all isJust (nodes g) of False -> Nothing - True -> Just $ map fromJust g + True -> Just $ map fromJust g -- | Get a list of all the /successors/ of a given node in the graph, -- /i.e./ all the nodes reachable from the given node by a directed @@ -140,16 +145,16 @@ -- but much more efficient. cessors :: (Show a, Ord a) => Graph a -> (Map a (Set a), Map a (Set a)) cessors g@(G gg _ _) = (succs, preds) - where - as = G.topsort' gg - succs = foldr collectSuccs M.empty as -- build successors map - collectSuccs a m = M.insert a succsSet m - where - ss = suc g a - succsSet = S.fromList ss `S.union` S.unions (P.map (m !) ss) + where + as = G.topsort' gg + succs = foldr collectSuccs M.empty as -- build successors map + collectSuccs a m = M.insert a succsSet m + where + ss = suc g a + succsSet = S.fromList ss `S.union` S.unions (P.map (m !) ss) - preds = foldr collectPreds M.empty (reverse as) -- build predecessors map - collectPreds a m = M.insert a predsSet m - where - ss = pre g a - predsSet = S.fromList ss `S.union` S.unions (P.map (m !) ss) + preds = foldr collectPreds M.empty (reverse as) -- build predecessors map + collectPreds a m = M.insert a predsSet m + where + ss = pre g a + predsSet = S.fromList ss `S.union` S.unions (P.map (m !) ss) diff --git a/src/Disco/Typecheck/Solve.hs b/src/Disco/Typecheck/Solve.hs --- a/src/Disco/Typecheck/Solve.hs +++ b/src/Disco/Typecheck/Solve.hs @@ -1,1083 +1,1182 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - ------------------------------------------------------------------------------ --- | --- Module : Disco.Typecheck.Solve --- Copyright : disco team and contributors --- Maintainer : byorgey@gmail.com --- --- SPDX-License-Identifier: BSD-3-Clause --- --- Constraint solver for the constraints generated during type --- checking/inference. ------------------------------------------------------------------------------ - -module Disco.Typecheck.Solve where - -import Unbound.Generics.LocallyNameless (Alpha, Name, Subst, fv, - name2Integer, string2Name, - substs) - -import Data.Coerce -import GHC.Generics (Generic) - -import Control.Arrow ((&&&), (***)) -import Control.Lens hiding (use, (%=), (.=)) -import Control.Monad (unless, zipWithM) -import Data.Bifunctor (first, second) -import Data.Either (partitionEithers) -import Data.List (find, foldl', intersect, - partition) -import Data.Map (Map, (!)) -import qualified Data.Map as M -import Data.Maybe (fromJust, fromMaybe, - mapMaybe) -import Data.Monoid (First (..)) -import Data.Set (Set) -import qualified Data.Set as S -import Data.Tuple - -import Disco.Effects.Fresh -import Disco.Effects.State -import Polysemy -import Polysemy.Error -import Polysemy.Input -import Polysemy.Output - -import Disco.Messages -import Disco.Pretty hiding ((<>)) -import Disco.Subst -import qualified Disco.Subst as Subst -import Disco.Typecheck.Constraints -import Disco.Typecheck.Graph (Graph) -import qualified Disco.Typecheck.Graph as G -import Disco.Typecheck.Unify -import Disco.Types -import Disco.Types.Qualifiers -import Disco.Types.Rules - --------------------------------------------------- --- Solver errors - --- | Type of errors which can be generated by the constraint solving --- process. -data SolveError where - NoWeakUnifier :: SolveError - NoUnify :: SolveError - UnqualBase :: Qualifier -> BaseTy -> SolveError - Unqual :: Qualifier -> Type -> SolveError - QualSkolem :: Qualifier -> Name Type -> SolveError - deriving Show - -instance Semigroup SolveError where - e <> _ = e - --------------------------------------------------- --- Error utilities - -runSolve :: Sem (Fresh ': Error SolveError ': r) a -> Sem r (Either SolveError a) -runSolve = runError . runFresh - --- | Run a list of actions, and return the results from those which do --- not throw an error. If all of them throw an error, rethrow the --- first one. -filterErrors :: Member (Error e) r => [Sem r a] -> Sem r [a] -filterErrors ms = do - es <- mapM try ms - case partitionEithers es of - (e:_, []) -> throw e - (_, as) -> return as - --- | A variant of 'asum' which picks the first action that succeeds, --- or re-throws the error of the last one if none of them --- do. Precondition: the list must not be empty. -asum' :: Member (Error e) r => [Sem r a] -> Sem r a -asum' [] = error "Impossible: asum' []" -asum' [m] = m -asum' (m:ms) = m `catch` (\_ -> asum' ms) - --------------------------------------------------- --- Simple constraints - -data SimpleConstraint where - (:<:) :: Type -> Type -> SimpleConstraint - (:=:) :: Type -> Type -> SimpleConstraint - deriving (Show, Eq, Ord, Generic, Alpha, Subst Type) - -instance Pretty SimpleConstraint where - pretty = \case - ty1 :<: ty2 -> pretty ty1 <+> "<:" <+> pretty ty2 - ty1 :=: ty2 -> pretty ty1 <+> "=" <+> pretty ty2 - --------------------------------------------------- --- Simplifier types - --- Uses TH to generate lenses so it has to go here before other stuff. - ---------------------------------- --- Variable maps - --- | Information about a particular type variable. More information --- may be added in the future (e.g. polarity). -data TyVarInfo = TVI - { _tyVarIlk :: First Ilk -- ^ The ilk (unification or skolem) of the variable, if known - , _tyVarSort :: Sort -- ^ The sort (set of qualifiers) of the type variable. - } - deriving (Show) - -makeLenses ''TyVarInfo - -instance Pretty TyVarInfo where - pretty (TVI (First ilk) s) = maybe (pure "?") pretty ilk <> "%" <> pretty s - --- | Create a 'TyVarInfo' given an 'Ilk' and a 'Sort'. -mkTVI :: Ilk -> Sort -> TyVarInfo -mkTVI = TVI . First . Just - --- | We can learn different things about a type variable from --- different places; the 'Semigroup' instance allows combining --- information about a type variable into a single record. -instance Semigroup TyVarInfo where - TVI i1 s1 <> TVI i2 s2 = TVI (i1 <> i2) (s1 <> s2) - --- | A 'TyVarInfoMap' records what we know about each type variable; --- it is a mapping from type variable names to 'TyVarInfo' records. -newtype TyVarInfoMap = VM { unVM :: Map (Name Type) TyVarInfo } - deriving (Show) - -instance Pretty TyVarInfoMap where - pretty (VM m) = pretty m - --- | Utility function for acting on a 'TyVarInfoMap' by acting on the --- underlying 'Map'. -onVM :: - (Map (Name Type) TyVarInfo -> Map (Name Type) TyVarInfo) -> - TyVarInfoMap -> TyVarInfoMap -onVM f (VM m) = VM (f m) - --- | Look up a given variable name in a 'TyVarInfoMap'. -lookupVM :: Name Type -> TyVarInfoMap -> Maybe TyVarInfo -lookupVM v = M.lookup v . unVM - --- | Remove the mapping for a particular variable name (if it exists) --- from a 'TyVarInfoMap'. -deleteVM :: Name Type -> TyVarInfoMap -> TyVarInfoMap -deleteVM = onVM . M.delete - --- | Given a list of type variable names, add them all to the --- 'TyVarInfoMap' as 'Skolem' variables (with a trivial sort). -addSkolems :: [Name Type] -> TyVarInfoMap -> TyVarInfoMap -addSkolems vs = onVM $ \vm -> foldl' (flip (\v -> M.insert v (mkTVI Skolem mempty))) vm vs - --- | The @Semigroup@ instance for 'TyVarInfoMap' unions the two maps, --- combining the info records for any variables occurring in both --- maps. -instance Semigroup TyVarInfoMap where - VM sm1 <> VM sm2 = VM (M.unionWith (<>) sm1 sm2) - -instance Monoid TyVarInfoMap where - mempty = VM M.empty - mappend = (<>) - --- | Get the sort of a particular variable recorded in a --- 'TyVarInfoMap'. Returns the trivial (empty) sort for a variable --- not in the map. -getSort :: TyVarInfoMap -> Name Type -> Sort -getSort (VM m) v = maybe topSort (view tyVarSort) (M.lookup v m) - --- | Get the 'Ilk' of a variable recorded in a 'TyVarInfoMap'. --- Returns @Nothing@ if the variable is not in the map, or if its --- ilk is not known. -getIlk :: TyVarInfoMap -> Name Type -> Maybe Ilk -getIlk (VM m) v = (m ^? ix v . tyVarIlk) >>= getFirst - --- | Extend the sort of a type variable by combining its existing sort --- with the given one. Has no effect if the variable is not already --- in the map. -extendSort :: Name Type -> Sort -> TyVarInfoMap -> TyVarInfoMap -extendSort x s = onVM (at x . _Just . tyVarSort %~ (`S.union` s)) - ---------------------------------- --- Simplifier state - --- The simplification stage maintains a mutable state consisting of --- the current qualifier map (containing wanted qualifiers for type --- variables), the list of remaining SimpleConstraints, and the --- current substitution. It also keeps track of seen constraints, so --- expansion of recursive types can stop when encountering a --- previously seen constraint. -data SimplifyState = SS - { _ssVarMap :: TyVarInfoMap - , _ssConstraints :: [SimpleConstraint] - , _ssSubst :: S - , _ssSeen :: Set SimpleConstraint - } - -makeLenses ''SimplifyState - -lkup :: (Ord k, Show k, Show (Map k a)) => String -> Map k a -> k -> a -lkup messg m k = fromMaybe (error errMsg) (M.lookup k m) - where - errMsg = unlines - [ "Key lookup error:" - , " Key = " ++ show k - , " Map = " ++ show m - , " Location: " ++ messg - ] - --------------------------------------------------- --- Top-level solver algorithm - -solveConstraint - :: Members '[Fresh, Error SolveError, Output Message, Input TyDefCtx] r - => Constraint -> Sem r S -solveConstraint c = do - - -- Step 1. Open foralls (instantiating with skolem variables) and - -- collect wanted qualifiers; also expand disjunctions. Result in a - -- list of possible constraint sets; each one consists of equational - -- and subtyping constraints in addition to qualifiers. - - debug "Solving:" - debugPretty c - - debug "------------------------------" - debug "Decomposing constraints..." - - qcList <- decomposeConstraint c - - -- Now try continuing with each set and pick the first one that has - -- a solution. - asum' (map (uncurry solveConstraintChoice) qcList) - -solveConstraintChoice - :: Members '[Fresh, Error SolveError, Output Message, Input TyDefCtx] r - => TyVarInfoMap -> [SimpleConstraint] -> Sem r S -solveConstraintChoice quals cs = do - - debugPretty quals - debug $ vcat (map pretty' cs) - - tyDefns <- input @TyDefCtx - - -- Step 2. Check for weak unification to ensure termination. (a la - -- Traytel et al). - - let toEqn (t1 :<: t2) = (t1,t2) - toEqn (t1 :=: t2) = (t1,t2) - _ <- note NoWeakUnifier $ weakUnify tyDefns (map toEqn cs) - - -- Step 3. Simplify constraints, resulting in a set of atomic - -- subtyping constraints. Also simplify/update qualifier set - -- accordingly. - - debug "------------------------------" - debug "Running simplifier..." - - (vm, atoms, theta_simp) <- simplify quals cs - debug "Done running simplifier. Results:" - - debugPretty vm - debug $ vcat $ map (pretty' . (\(x,y) -> TyAtom x :<: TyAtom y)) atoms - debugPretty theta_simp - - -- Step 4. Turn the atomic constraints into a directed constraint - -- graph. - - debug "------------------------------" - debug "Generating constraint graph..." - - -- Some variables might have qualifiers but not participate in any - -- equality or subtyping relations (see issue #153); make sure to - -- extract them and include them in the constraint graph as isolated - -- vertices - let mkAVar (v, First (Just Skolem)) = AVar (S v) - mkAVar (v, _ ) = AVar (U v) - vars = S.fromList . map (mkAVar . second (view tyVarIlk)) . M.assocs . unVM $ vm - g = mkConstraintGraph vars atoms - - debugPretty g - - -- Step 5. - -- Check for any weakly connected components containing more - -- than one skolem, or a skolem and a base type; such components are - -- not allowed. Other WCCs with a single skolem simply unify to - -- that skolem. - - debug "------------------------------" - debug "Checking WCCs for skolems..." - - (g', theta_skolem) <- checkSkolems vm g - debugPretty theta_skolem - - -- We don't need to ensure that theta_skolem respects sorts since - -- checkSkolems will only unify skolem vars with unsorted variables. - - - -- Step 6. Eliminate cycles from the graph, turning each strongly - -- connected component into a single node, unifying all the atoms in - -- each component. - - debug "------------------------------" - debug "Collapsing SCCs..." - - (g'', theta_cyc) <- elimCycles tyDefns g' - - debugPretty g'' - debugPretty theta_cyc - - -- Check that the resulting substitution respects sorts... - let sortOK (x, TyAtom (ABase ty)) = hasSort ty (getSort vm x) - sortOK (_, TyAtom (AVar (U _))) = True - sortOK p = error $ "Impossible! sortOK " ++ show p - unless (all sortOK (Subst.toList theta_cyc)) - $ throw NoUnify - - -- ... and update the sort map if we unified any type variables. - -- Just make sure that if theta_cyc maps x |-> y, then y picks up - -- the sort of x. - - debug "Old sort map:" - debugPretty vm - - let vm' = foldr updateVarMap vm (Subst.toList theta_cyc) - where - updateVarMap :: (Name Type, Type) -> TyVarInfoMap -> TyVarInfoMap - updateVarMap (x, TyAtom (AVar (U y))) vmm = extendSort y (getSort vmm x) vmm - updateVarMap _ vmm = vmm - - debug "Updated sort map:" - debugPretty vm - - -- Steps 7 & 8: solve the graph, iteratively finding satisfying - -- assignments for each type variable based on its successor and - -- predecessor base types in the graph; then unify all the type - -- variables in any remaining weakly connected components. - - debug "------------------------------" - debug "Solving for type variables..." - - theta_sol <- solveGraph vm' g'' - debugPretty theta_sol - - debug "------------------------------" - debug "Composing final substitution..." - - let theta_final = theta_sol @@ theta_cyc @@ theta_skolem @@ theta_simp - debugPretty theta_final - - return theta_final - - --------------------------------------------------- --- Step 1. Constraint decomposition. - -decomposeConstraint - :: Members '[Fresh, Error SolveError, Input TyDefCtx] r - => Constraint -> Sem r [(TyVarInfoMap, [SimpleConstraint])] -decomposeConstraint (CSub t1 t2) = return [(mempty, [t1 :<: t2])] -decomposeConstraint (CEq t1 t2) = return [(mempty, [t1 :=: t2])] -decomposeConstraint (CQual q ty) = (:[]) . (, []) <$> decomposeQual ty q -decomposeConstraint (CAnd cs) = map mconcat . sequence <$> mapM decomposeConstraint cs -decomposeConstraint CTrue = return [mempty] -decomposeConstraint (CAll ty) = do - (vars, c) <- unbind ty - let c' = substs (mkSkolems vars) c - (map . first . addSkolems) vars <$> decomposeConstraint c' - - where - mkSkolems :: [Name Type] -> [(Name Type, Type)] - mkSkolems = map (id &&& TySkolem) - -decomposeConstraint (COr cs) = concat <$> filterErrors (map decomposeConstraint cs) - -decomposeQual - :: Members '[Fresh, Error SolveError, Input TyDefCtx] r - => Type -> Qualifier -> Sem r TyVarInfoMap -decomposeQual = go S.empty - where - go :: Members '[Fresh, Error SolveError, Input TyDefCtx] r - => Set (String, [Type], Qualifier) -> Type -> Qualifier -> Sem r TyVarInfoMap - - -- For a type atom, call out to checkQual. - go _ (TyAtom a) q = checkQual q a - - -- Coinductively check user-defined types for a qualifier. Keep - -- track of a set of user-defined types and qualifiers we have - -- seen. Every time we encounter a new one, add it to the set and - -- recurse on its unfolding. If we ever encounter one we have - -- already seen, we can assume by coinduction that the qualifier - -- is satisfied. - go seen (TyCon (CUser t) tys) q = do - case (t, tys, q) `S.member` seen of - True -> return mempty - False -> do - tyDefns <- input @TyDefCtx - case M.lookup t tyDefns of - Nothing -> error $ show t ++ " not in ty defn map!!" - Just (TyDefBody _ body) -> do - let ty' = body tys - go (S.insert (t, tys, q) seen) ty' q - - -- If we have a container type where the container is still a variable, - -- just replace it with List for the purposes of generating constraints--- - -- all containers (lists, bags, sets) have the same qualifier rules. - go seen (TyCon (CContainer (AVar _)) tys) q = go seen (TyCon CList tys) q - - -- Otherwise, decompose a type constructor according to the qualRules. - go seen ty@(TyCon c tys) q = case qualRules c q of - Nothing -> throw $ Unqual q ty - Just qs -> mconcat <$> zipWithM (maybe (return mempty) . go seen) tys qs - -checkQual - :: Members '[Fresh, Error SolveError] r - => Qualifier -> Atom -> Sem r TyVarInfoMap -checkQual q (AVar (U v)) = return . VM . M.singleton v $ mkTVI Unification (S.singleton q) -checkQual q (AVar (S v)) = throw $ QualSkolem q v -checkQual q (ABase bty) = - case hasQual bty q of - True -> return mempty - False -> throw $ UnqualBase q bty - --------------------------------------------------- --- Step 3. Constraint simplification. - --- | This step does unification of equality constraints, as well as --- structural decomposition of subtyping constraints. For example, --- if we have a constraint (x -> y) <: (z -> Int), then we can --- decompose it into two constraints, (z <: x) and (y <: Int); if we --- have a constraint v <: (a,b), then we substitute v ↦ (x,y) (where --- x and y are fresh type variables) and continue; and so on. --- --- After this step, the remaining constraints will all be atomic --- constraints, that is, only of the form (v1 <: v2), (v <: b), or --- (b <: v), where v is a type variable and b is a base type. - -simplify - :: Members '[Error SolveError, Output Message, Input TyDefCtx] r - => TyVarInfoMap -> [SimpleConstraint] -> Sem r (TyVarInfoMap, [(Atom, Atom)], S) -simplify origVM cs - = (\(SS vm' cs' s' _) -> (vm', map extractAtoms cs', s')) - -- contFreshMT :: Monad m => FreshMT m a -> Integer -> m a - -- "Run a FreshMT computation given a starting index for fresh name generation." - <$> runFresh' n (execState (SS origVM cs idS S.empty) simplify') - where - - fvNums :: Alpha a => [a] -> [Integer] - fvNums = map (name2Integer :: Name Type -> Integer) . toListOf fv - - -- Find first unused integer in constraint free vars and sort map - -- domain, and use it to start the fresh var generation, so we don't - -- generate any "fresh" names that interfere with existing names - n1 = maximum0 . fvNums $ cs - n = succ . maximum . (n1:) . fvNums . M.keys . unVM $ origVM - - maximum0 [] = 0 - maximum0 xs = maximum xs - - -- Extract the type atoms from an atomic constraint. - extractAtoms :: SimpleConstraint -> (Atom, Atom) - extractAtoms (TyAtom a1 :<: TyAtom a2) = (a1, a2) - extractAtoms c = error $ "Impossible: simplify left non-atomic or non-subtype constraint " ++ show c - - -- Iterate picking one simplifiable constraint and simplifying it - -- until none are left. - simplify' - :: Members '[State SimplifyState, Fresh, Error SolveError, Output Message, Input TyDefCtx] r - => Sem r () - simplify' = do - -- q <- gets fst - -- debug (pretty q) - -- debug "" - - mc <- pickSimplifiable - case mc of - Nothing -> return () - Just s -> do - - debug $ "Simplifying:" <+> pretty' s - - simplifyOne s - simplify' - - -- Pick out one simplifiable constraint, removing it from the list - -- of constraints in the state. Return Nothing if no more - -- constraints can be simplified. - pickSimplifiable - :: Members '[State SimplifyState, Fresh, Error SolveError] r - => Sem r (Maybe SimpleConstraint) - pickSimplifiable = do - curCs <- use ssConstraints - case pick simplifiable curCs of - Nothing -> return Nothing - Just (a,as) -> do - ssConstraints .= as - return (Just a) - - -- Pick the first element from a list satisfying the given - -- predicate, returning the element and the list with the element - -- removed. - pick :: (a -> Bool) -> [a] -> Maybe (a,[a]) - pick _ [] = Nothing - pick p (a:as) - | p a = Just (a,as) - | otherwise = second (a:) <$> pick p as - - -- Check if a constraint can be simplified. An equality - -- constraint can always be "simplified" via unification. A - -- subtyping constraint can be simplified if either it involves a - -- type constructor (in which case we can decompose it), or if it - -- involves two base types (in which case it can be removed if the - -- relationship holds). - simplifiable :: SimpleConstraint -> Bool - simplifiable (_ :=: _) = True - simplifiable (TyCon {} :<: TyCon {}) = True - simplifiable (TyVar {} :<: TyCon {}) = True - simplifiable (TyCon {} :<: TyVar {}) = True - simplifiable (TyCon (CUser _) _ :<: _) = True - simplifiable (_ :<: TyCon (CUser _) _) = True - simplifiable (TyAtom (ABase _) :<: TyAtom (ABase _)) = True - - simplifiable _ = False - - -- Simplify the given simplifiable constraint. If the constraint - -- has already been seen before (due to expansion of a recursive - -- type), just throw it away and stop. - simplifyOne - :: Members '[State SimplifyState, Fresh, Error SolveError, Input TyDefCtx] r - => SimpleConstraint -> Sem r () - simplifyOne c = do - seen <- use ssSeen - case c `S.member` seen of - True -> return () - False -> do - ssSeen %= S.insert c - simplifyOne' c - - simplifyOne' - :: Members '[State SimplifyState, Fresh, Error SolveError, Input TyDefCtx] r - => SimpleConstraint -> Sem r () - - -- If we have an equality constraint, run unification on it. The - -- resulting substitution is applied to the remaining constraints - -- as well as prepended to the current substitution. - - simplifyOne' (ty1 :=: ty2) = do - tyDefns <- input @TyDefCtx - case unify tyDefns [(ty1, ty2)] of - Nothing -> throw NoUnify - Just s' -> extendSubst s' - - -- If we see a constraint of the form (T <: a), where T is a - -- user-defined type and a is a type variable, then just turn it - -- into an equality (T = a). This is sound but probably not - -- complete. The alternative seems quite complicated, possibly - -- even undecidable. See https://github.com/disco-lang/disco/issues/207 . - simplifyOne' (ty1@(TyCon (CUser _) _) :<: ty2@TyVar{}) - = simplifyOne' (ty1 :=: ty2) - - -- Otherwise, expand the user-defined type and continue. - simplifyOne' (TyCon (CUser t) ts :<: ty2) = do - tyDefns <- input @TyDefCtx - case M.lookup t tyDefns of - Nothing -> error $ show t ++ " not in ty defn map!" - Just (TyDefBody _ body) -> - ssConstraints %= ((body ts :<: ty2) :) - - -- Turn a <: T into a = T. See comment above. - simplifyOne' (ty1@TyVar{} :<: ty2@(TyCon (CUser _) _)) - = simplifyOne' (ty1 :=: ty2) - - simplifyOne' (ty1 :<: TyCon (CUser t) ts) = do - tyDefns <- input @TyDefCtx - case M.lookup t tyDefns of - Nothing -> error $ show t ++ " not in ty defn map!" - Just (TyDefBody _ body) -> - ssConstraints %= ((ty1 :<: body ts) :) - - -- Given a subtyping constraint between two type constructors, - -- decompose it if the constructors are the same (or fail if they - -- aren't), taking into account the variance of each argument to - -- the constructor. Container types are a special case; - -- recursively generate a subtyping constraint for their - -- constructors as well. - simplifyOne' (TyCon c1@(CContainer ctr1) tys1 :<: TyCon (CContainer ctr2) tys2) = - ssConstraints %= - (( (TyAtom ctr1 :<: TyAtom ctr2) - : zipWith3 variance (arity c1) tys1 tys2 - ) - ++) - - simplifyOne' (TyCon c1 tys1 :<: TyCon c2 tys2) - | c1 /= c2 = throw NoUnify - | otherwise = - ssConstraints %= (zipWith3 variance (arity c1) tys1 tys2 ++) - - -- Given a subtyping constraint between a variable and a type - -- constructor, expand the variable into the same constructor - -- applied to fresh type variables. - simplifyOne' con@(TyVar a :<: TyCon c _) = expandStruct a c con - simplifyOne' con@(TyCon c _ :<: TyVar a ) = expandStruct a c con - - -- Given a subtyping constraint between two base types, just check - -- whether the first is indeed a subtype of the second. (Note - -- that we only pattern match here on type atoms, which could - -- include variables, but this will only ever get called if - -- 'simplifiable' was true, which checks that both are base - -- types.) - simplifyOne' (TyAtom (ABase b1) :<: TyAtom (ABase b2)) = do - case isSubB b1 b2 of - True -> return () - False -> throw NoUnify - - simplifyOne' (s :<: t) = - error $ "Impossible! simplifyOne' " ++ show s ++ " :<: " ++ show t - - expandStruct - :: Members '[State SimplifyState, Fresh, Error SolveError, Input TyDefCtx] r - => Name Type -> Con -> SimpleConstraint -> Sem r () - expandStruct a c con = do - as <- mapM (const (TyVar <$> fresh (string2Name "a"))) (arity c) - let s' = a |-> TyCon c as - ssConstraints %= (con:) - extendSubst s' - - -- 1. compose s' with current subst - -- 2. apply s' to constraints - -- 3. apply s' to qualifier map and decompose - extendSubst - :: Members '[State SimplifyState, Fresh, Error SolveError, Input TyDefCtx] r - => S -> Sem r () - extendSubst s' = do - ssSubst %= (s'@@) - ssConstraints %= applySubst s' - substVarMap s' - - substVarMap - :: Members '[State SimplifyState, Fresh, Error SolveError, Input TyDefCtx] r - => S -> Sem r () - substVarMap s' = do - vm <- use ssVarMap - - -- 1. Get quals for each var in domain of s' and match them with - -- the types being substituted for those vars. - - let tySorts :: [(Type, Sort)] - tySorts = map (second (view tyVarSort)) . mapMaybe (traverse (`lookupVM` vm) . swap) $ Subst.toList s' - - tyQualList :: [(Type, Qualifier)] - tyQualList = concatMap (sequenceA . second S.toList) tySorts - - -- 2. Decompose the resulting qualifier constraints - - vm' <- mconcat <$> mapM (uncurry decomposeQual) tyQualList - - -- 3. delete domain of s' from vm and merge in decomposed quals. - - ssVarMap .= vm' <> foldl' (flip deleteVM) vm (dom s') - - -- The above works even when unifying two variables. Say we have - -- the TyVarInfoMap - -- - -- a |-> {add} - -- b |-> {sub} - -- - -- and we get back theta = [a |-> b]. The domain of theta - -- consists solely of a, so we look up a in the TyVarInfoMap and get - -- {add}. We therefore generate the constraint 'add (theta a)' - -- = 'add b' which can't be decomposed at all, and hence yields - -- the TyVarInfoMap {b |-> {add}}. We then delete a from the - -- original TyVarInfoMap and merge the result with the new TyVarInfoMap, - -- yielding {b |-> {sub,add}}. - - - -- Create a subtyping constraint based on the variance of a type - -- constructor argument position: in the usual order for - -- covariant, and reversed for contravariant. - variance Co ty1 ty2 = ty1 :<: ty2 - variance Contra ty1 ty2 = ty2 :<: ty1 - --------------------------------------------------- --- Step 4: Build constraint graph - --- | Given a list of atoms and atomic subtype constraints (each pair --- @(a1,a2)@ corresponds to the constraint @a1 <: a2@) build the --- corresponding constraint graph. -mkConstraintGraph :: (Show a, Ord a) => Set a -> [(a, a)] -> Graph a -mkConstraintGraph as cs = G.mkGraph nodes (S.fromList cs) - where - nodes = as `S.union` S.fromList (cs ^.. traverse . each) - --------------------------------------------------- --- Step 5: Check skolems - --- | Check for any weakly connected components containing more than --- one skolem, or a skolem and a base type, or a skolem and any --- variables with nontrivial sorts; such components are not allowed. --- If there are any WCCs with a single skolem, no base types, and --- only unsorted variables, just unify them all with the skolem and --- remove those components. -checkSkolems - :: Members '[Error SolveError, Output Message, Input TyDefCtx] r - => TyVarInfoMap -> Graph Atom -> Sem r (Graph UAtom, S) -checkSkolems vm graph = do - let skolemWCCs :: [Set Atom] - skolemWCCs = filter (any isSkolem) $ G.wcc graph - - ok wcc = S.size (S.filter isSkolem wcc) <= 1 - && all (\case { ABase _ -> False - ; AVar (S _) -> True - ; AVar (U v) -> maybe True (S.null . view tyVarSort) (lookupVM v vm) }) - wcc - - (good, bad) = partition ok skolemWCCs - - unless (null bad) $ throw NoUnify - - -- take all good sets and - -- (1) delete them from the graph - -- (2) unify them all with the skolem - unifyWCCs graph idS good - - where - noSkolems :: Atom -> UAtom - noSkolems (ABase b) = UB b - noSkolems (AVar (U v)) = UV v - noSkolems (AVar (S v)) = error $ "Skolem " ++ show v ++ " remaining in noSkolems" - - unifyWCCs - :: Members '[Error SolveError, Output Message, Input TyDefCtx] r - => Graph Atom -> S -> [Set Atom] -> Sem r (Graph UAtom, S) - unifyWCCs g s [] = return (G.map noSkolems g, s) - unifyWCCs g s (u:us) = do - debug $ "Unifying" <+> pretty' (u:us) <> "..." - - tyDefns <- input @TyDefCtx - - let g' = foldl' (flip G.delete) g u - - ms' = unifyAtoms tyDefns (S.toList u) - case ms' of - Nothing -> throw NoUnify - Just s' -> unifyWCCs g' (atomToTypeSubst s' @@ s) us - --------------------------------------------------- --- Step 6: Eliminate cycles - --- | Eliminate cycles in the constraint set by collapsing each --- strongly connected component to a single node, (unifying all the --- types in the SCC). A strongly connected component is a maximal --- set of nodes where every node is reachable from every other by a --- directed path; since we are using directed edges to indicate a --- subtyping constraint, this means every node must be a subtype of --- every other, and the only way this can happen is if all are in --- fact equal. --- --- Of course, this step can fail if the types in a SCC are not --- unifiable. If it succeeds, it returns the collapsed graph (which --- is now guaranteed to be acyclic, i.e. a DAG) and a substitution. -elimCycles - :: Members '[Error SolveError] r - => TyDefCtx -> Graph UAtom -> Sem r (Graph UAtom, S) -elimCycles tyDefns = elimCyclesGen uatomToTypeSubst (unifyUAtoms tyDefns) - -elimCyclesGen - :: forall a b r. (Subst a a, Ord a, Members '[Error SolveError] r) - => (Substitution a -> Substitution b) -> ([a] -> Maybe (Substitution a)) - -> Graph a -> Sem r (Graph a, Substitution b) -elimCyclesGen genSubst genUnify g - = note NoUnify - $ (G.map fst &&& (genSubst . compose . S.map snd . G.nodes)) <$> g' - where - - g' :: Maybe (Graph (a, Substitution a)) - g' = G.sequenceGraph $ G.map unifySCC (G.condensation g) - - unifySCC :: Set a -> Maybe (a, Substitution a) - unifySCC uatoms = case S.toList uatoms of - [] -> error "Impossible! unifySCC on the empty set" - as@(a:_) -> (flip applySubst a &&& id) <$> genUnify as - ------------------------------------------------------------- --- Steps 7 and 8: Constraint resolution ------------------------------------------------------------- - --- | Rels stores the set of base types and variables related to a --- given variable in the constraint graph (either predecessors or --- successors, but not both). -data Rels = Rels - { baseRels :: Set BaseTy - , varRels :: Set (Name Type) - } - deriving (Show, Eq) - --- | A RelMap associates each variable to its sets of base type and --- variable predecessors and successors in the constraint graph. -newtype RelMap = RelMap { unRelMap :: Map (Name Type, Dir) Rels} - -instance Pretty RelMap where - pretty (RelMap rm) = vcat (map prettyVar byVar) - where - vars = S.map fst (M.keysSet rm) - byVar = map (\x -> (rm!(x,SubTy), x, rm!(x,SuperTy))) (S.toList vars) - - prettyVar (subs, x, sups) = hsep [prettyRel subs, "<:", pretty x, "<:", prettyRel sups] - prettyRel rs = pretty (baseRels rs) <> ", " <> pretty (varRels rs) - --- | Modify a @RelMap@ to record the fact that we have solved for a --- type variable. In particular, delete the variable from the --- @RelMap@ as a key, and also update the relative sets of every --- other variable to remove this variable and add the base type we --- chose for it. -substRel :: Name Type -> BaseTy -> RelMap -> RelMap -substRel x ty - = RelMap - . M.delete (x,SuperTy) - . M.delete (x,SubTy) - . M.map (\r@(Rels b v) -> if x `S.member` v then Rels (S.insert ty b) (S.delete x v) else r) - . unRelMap - --- | Essentially dirtypesBySort vm rm dir t s x finds all the --- dir-types (sub- or super-) of t which have sort s, relative to --- the variables in x. This is \overbar{T}_S^X (resp. \underbar...) --- from Traytel et al. -dirtypesBySort :: TyVarInfoMap -> RelMap -> Dir -> BaseTy -> Sort -> Set (Name Type) -> [BaseTy] -dirtypesBySort vm (RelMap relMap) dir t s x - - -- Keep only those supertypes t' of t - = keep (dirtypes dir t) $ \t' -> - -- which have the right sort, and such that - hasSort t' s && - - -- for all variables beta \in x, - forAll x (\beta -> - - -- there is at least one type t'' which is a subtype of t' - -- which would be a valid solution for beta, that is, - exists (dirtypes (other dir) t') $ \t'' -> - - -- t'' has the sort beta is supposed to have, and - hasSort t'' (getSort vm beta) && - - -- t'' is a supertype of every base type predecessor of beta. - forAll (baseRels (lkup "dirtypesBySort, beta rel" relMap (beta, other dir))) - (isDirB dir t'')) - - -- The above comments are written assuming dir = Super; of course, - -- if dir = Sub then just swap "super" and "sub" everywhere. - - where - forAll, exists :: Foldable t => t a -> (a -> Bool) -> Bool - forAll = flip all - exists = flip any - keep = flip filter - --- | Sort-aware infimum or supremum. -limBySort :: TyVarInfoMap -> RelMap -> Dir -> [BaseTy] -> Sort -> Set (Name Type) -> Maybe BaseTy -limBySort vm rm dir ts s x - = (\is -> find (\lim -> all (\u -> isDirB dir u lim) is) is) - . isects - . map (\t -> dirtypesBySort vm rm dir t s x) - $ ts - where - isects = foldr1 intersect - -lubBySort, glbBySort :: TyVarInfoMap -> RelMap -> [BaseTy] -> Sort -> Set (Name Type) -> Maybe BaseTy -lubBySort vm rm = limBySort vm rm SuperTy -glbBySort vm rm = limBySort vm rm SubTy - --- | From the constraint graph, build the sets of sub- and super- base --- types of each type variable, as well as the sets of sub- and --- supertype variables. For each type variable x in turn, try to --- find a common supertype of its base subtypes which is consistent --- with the sort of x and with the sorts of all its sub-variables, --- as well as symmetrically a common subtype of its supertypes, etc. --- Assign x one of the two: if it has only successors, assign it --- their inf; otherwise, assign it the sup of its predecessors. If --- it has both, we have a choice of whether to assign it the sup of --- predecessors or inf of successors; both lead to a sound & --- complete algorithm. We choose to assign it the sup of its --- predecessors in this case, since it seems nice to default to --- "simpler" types lower down in the subtyping chain. -solveGraph - :: Members '[Fresh, Error SolveError, Output Message] r - => TyVarInfoMap -> Graph UAtom -> Sem r S -solveGraph vm g = atomToTypeSubst . unifyWCC <$> go topRelMap - where - unifyWCC :: Substitution BaseTy -> Substitution Atom - unifyWCC s = compose (map mkEquateSubst wccVarGroups) @@ fmap ABase s - where - wccVarGroups :: [Set (Name Type)] - wccVarGroups = map (S.map getVar) . filter (all uisVar) . applySubst s $ G.wcc g - getVar (UV v) = v - getVar (UB b) = error - $ "Impossible! Base type " ++ show b ++ " in solveGraph.getVar" - - mkEquateSubst :: Set (Name Type) -> Substitution Atom - mkEquateSubst = mkEquations . S.toList - - mkEquations (a:as) = Subst.fromList . map (\v -> (coerce v, AVar (U a))) $ as - mkEquations [] = error "Impossible! Empty set of names in mkEquateSubst" - - -- After picking concrete base types for all the type - -- variables we can, the only thing possibly remaining in - -- the graph are components containing only type variables - -- and no base types. It is sound, and simplifies the - -- generated types considerably, to simply unify any type - -- variables which are related by subtyping constraints. - -- That is, we collect all the type variables in each - -- weakly connected component and unify them. - -- - -- As an example where this final step makes a difference, - -- consider a term like @\x. (\y.y) x@. A fresh type - -- variable is generated for the type of @x@, and another - -- for the type of @y@; the application of @(\y.y)@ to @x@ - -- induces a subtyping constraint between the two type - -- variables. The most general type would be something - -- like @forall a b. (a <: b) => a -> b@, but we want to - -- avoid generating unnecessary subtyping constraints (the - -- type system might not even support subtyping qualifiers - -- like this). Instead, we unify the two type variables - -- and the resulting type is @forall a. a -> a@. - - -- Get the successor and predecessor sets for all the type variables. - topRelMap :: RelMap - topRelMap - = RelMap - . M.map (uncurry Rels . (S.fromAscList *** S.fromAscList) - . partitionEithers . map uatomToEither . S.toList) - $ M.mapKeys (,SuperTy) subMap `M.union` M.mapKeys (,SubTy) superMap - - subMap, superMap :: Map (Name Type) (Set UAtom) - (subMap, superMap) = (onlyVars *** onlyVars) $ G.cessors g - - onlyVars :: Map UAtom (Set UAtom) -> Map (Name Type) (Set UAtom) - onlyVars = M.mapKeys fromVar . M.filterWithKey (\a _ -> uisVar a) - where - fromVar (UV x) = x - fromVar _ = error "Impossible! UB but uisVar." - - go - :: Members '[Fresh, Error SolveError, Output Message] r - => RelMap -> Sem r (Substitution BaseTy) - go relMap@(RelMap rm) = debugPretty relMap >> case as of - - -- No variables left that have base type constraints. - [] -> return idS - - -- Solve one variable at a time. See below. - (a:_) -> do - debug $ "Solving for" <+> pretty' a - case solveVar a of - Nothing -> do - debug $ "Couldn't solve for" <+> pretty' a - throw NoUnify - - -- If we solved for a, delete it from the maps, apply the - -- resulting substitution to the remainder (updating the - -- relMap appropriately), and recurse. The substitution we - -- want will be the composition of the substitution for a - -- with the substitution generated by the recursive call. - -- - -- Note we don't need to delete a from the TyVarInfoMap; we - -- never use the set of keys from the TyVarInfoMap for - -- anything (indeed, some variables might not be keys if - -- they have an empty sort), so it doesn't matter if old - -- variables hang around in it. - Just s -> do - debugPretty s - (@@ s) <$> go (substRel a (fromJust $ Subst.lookup (coerce a) s) relMap) - - where - -- NOTE we can't solve a bunch in parallel! Might end up - -- assigning them conflicting solutions if some depend on - -- others. For example, consider the situation - -- - -- Z - -- | - -- a3 - -- / \ - -- a1 N - -- - -- If we try to solve in parallel we will end up assigning a1 - -- -> Z (since it only has base types as an upper bound) and - -- a3 -> N (since it has both upper and lower bounds, and by - -- default we pick the lower bound), but this is wrong since - -- we should have a1 < a3. - -- - -- If instead we solve them one at a time, we could e.g. first - -- solve a1 -> Z, and then we would find a3 -> Z as well. - -- Alternately, if we first solve a3 -> N then we will have a1 - -- -> N as well. Both are acceptable. - -- - -- In fact, this exact graph comes from (^x.x+1) which was - -- erroneously being inferred to have type Z -> N when I first - -- wrote the code. - - -- Get only the variables we can solve on this pass, which - -- have base types in their predecessor or successor set. If - -- there are no such variables, then start picking any - -- remaining variables with a sort and pick types for them - -- (disco doesn't have qualified polymorphism so we can't just - -- leave them). - asBase - = map fst - . filter (not . S.null . baseRels . lkup "solveGraph.go.as" rm) - $ M.keys rm - as = case asBase of - [] -> filter ((/= topSort) . getSort vm) . map fst $ M.keys rm - _ -> asBase - - -- Solve for a variable, failing if it has no solution, otherwise returning - -- a substitution for it. - solveVar :: Name Type -> Maybe (Substitution BaseTy) - solveVar v = - case ((v,SuperTy), (v,SubTy)) & over both (S.toList . baseRels . lkup "solveGraph.solveVar" rm) of - -- No sub- or supertypes; the only way this can happen is - -- if it has a nontrivial sort. - -- - -- Traytel et al. don't seem to have a rule saying what to - -- do in this case (see Fig. 16 on p. 16 of their long - -- version). We used to just pick a type that inhabits - -- the sort, but this is wrong; see - -- https://github.com/disco-lang/disco/issues/192. - -- - -- For now, let's assume that any situation in which we - -- have no base sub- or supertypes but we do have - -- nontrivial sorts means that we are dealing with numeric - -- types; so we can just call N a base subtype and go from there. - - ([], []) -> - -- Debug.trace (show v ++ " has no sub- or supertypes. Assuming N as a subtype.") - (coerce v |->) <$> lubBySort vm relMap [N] (getSort vm v) - (varRels (lkup "solveVar none, rels" rm (v,SubTy))) - - -- Only supertypes. Just assign a to their inf, if one exists. - (bsupers, []) -> - -- Debug.trace (show v ++ " has only supertypes (" ++ show bsupers ++ ")") $ - (coerce v |->) <$> glbBySort vm relMap bsupers (getSort vm v) - (varRels (lkup "solveVar bsupers, rels" rm (v,SuperTy))) - - -- Only subtypes. Just assign a to their sup. - ([], bsubs) -> - -- Debug.trace (show v ++ " has only subtypes (" ++ show bsubs ++ ")") $ - -- Debug.trace ("sortmap: " ++ show vm) $ - -- Debug.trace ("relmap: " ++ show relMap) $ - -- Debug.trace ("sort for " ++ show v ++ ": " ++ show (getSort vm v)) $ - -- Debug.trace ("relvars: " ++ show (varRels (relMap ! (v,SubTy)))) $ - (coerce v |->) <$> lubBySort vm relMap bsubs (getSort vm v) - (varRels (lkup "solveVar bsubs, rels" rm (v,SubTy))) - - -- Both successors and predecessors. Both must have a - -- valid bound, and the bounds must not overlap. Assign a - -- to the sup of its predecessors. - (bsupers, bsubs) -> do - ub <- glbBySort vm relMap bsupers (getSort vm v) - (varRels (rm ! (v,SuperTy))) - lb <- lubBySort vm relMap bsubs (getSort vm v) - (varRels (rm ! (v,SubTy))) - case isSubB lb ub of - True -> Just (coerce v |-> lb) - False -> Nothing +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + +-- | +-- Module : Disco.Typecheck.Solve +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Constraint solver for the constraints generated during type +-- checking/inference. +module Disco.Typecheck.Solve where + +import Unbound.Generics.LocallyNameless ( + Alpha, + Name, + Subst, + fv, + name2Integer, + string2Name, + substs, + ) + +import Data.Coerce +import GHC.Generics (Generic) + +import Control.Arrow ((&&&), (***)) +import Control.Lens hiding (use, (%=), (.=)) +import Control.Monad (unless, zipWithM) +import Data.Bifunctor (first, second) +import Data.Either (partitionEithers) +import Data.List ( + find, + foldl', + intersect, + partition, + ) +import Data.Map (Map, (!)) +import qualified Data.Map as M +import Data.Maybe ( + fromJust, + fromMaybe, + mapMaybe, + ) +import Data.Monoid (First (..)) +import Data.Set (Set) +import qualified Data.Set as S +import Data.Tuple + +import Disco.Effects.Fresh +import Disco.Effects.State +import Polysemy +import Polysemy.Error +import Polysemy.Input +import Polysemy.Output + +import Disco.Messages +import Disco.Pretty hiding ((<>)) +import Disco.Subst +import qualified Disco.Subst as Subst +import Disco.Typecheck.Constraints +import Disco.Typecheck.Graph (Graph) +import qualified Disco.Typecheck.Graph as G +import Disco.Typecheck.Unify +import Disco.Types +import Disco.Types.Qualifiers +import Disco.Types.Rules + +-------------------------------------------------- +-- Solver errors + +-- | Type of errors which can be generated by the constraint solving +-- process. +data SolveError where + NoWeakUnifier :: SolveError + NoUnify :: SolveError + UnqualBase :: Qualifier -> BaseTy -> SolveError + Unqual :: Qualifier -> Type -> SolveError + QualSkolem :: Qualifier -> Name Type -> SolveError + deriving (Show) + +instance Semigroup SolveError where + e <> _ = e + +-------------------------------------------------- +-- Error utilities + +runSolve :: Sem (Fresh ': Error SolveError ': r) a -> Sem r (Either SolveError a) +runSolve = runError . runFresh + +-- | Run a list of actions, and return the results from those which do +-- not throw an error. If all of them throw an error, rethrow the +-- first one. +filterErrors :: Member (Error e) r => [Sem r a] -> Sem r [a] +filterErrors ms = do + es <- mapM try ms + case partitionEithers es of + (e : _, []) -> throw e + (_, as) -> return as + +-- | A variant of 'asum' which picks the first action that succeeds, +-- or re-throws the error of the last one if none of them +-- do. Precondition: the list must not be empty. +asum' :: Member (Error e) r => [Sem r a] -> Sem r a +asum' [] = error "Impossible: asum' []" +asum' [m] = m +asum' (m : ms) = m `catch` (\_ -> asum' ms) + +-------------------------------------------------- +-- Simple constraints + +data SimpleConstraint where + (:<:) :: Type -> Type -> SimpleConstraint + (:=:) :: Type -> Type -> SimpleConstraint + deriving (Show, Eq, Ord, Generic, Alpha, Subst Type) + +instance Pretty SimpleConstraint where + pretty = \case + ty1 :<: ty2 -> pretty ty1 <+> "<:" <+> pretty ty2 + ty1 :=: ty2 -> pretty ty1 <+> "=" <+> pretty ty2 + +-------------------------------------------------- +-- Simplifier types + +-- Uses TH to generate lenses so it has to go here before other stuff. + +--------------------------------- +-- Variable maps + +-- | Information about a particular type variable. More information +-- may be added in the future (e.g. polarity). +data TyVarInfo = TVI + { _tyVarIlk :: First Ilk + -- ^ The ilk (unification or skolem) of the variable, if known + , _tyVarSort :: Sort + -- ^ The sort (set of qualifiers) of the type variable. + } + deriving (Show) + +makeLenses ''TyVarInfo + +instance Pretty TyVarInfo where + pretty (TVI (First ilk) s) = maybe (pure "?") pretty ilk <> "%" <> pretty s + +-- | Create a 'TyVarInfo' given an 'Ilk' and a 'Sort'. +mkTVI :: Ilk -> Sort -> TyVarInfo +mkTVI = TVI . First . Just + +-- | We can learn different things about a type variable from +-- different places; the 'Semigroup' instance allows combining +-- information about a type variable into a single record. +instance Semigroup TyVarInfo where + TVI i1 s1 <> TVI i2 s2 = TVI (i1 <> i2) (s1 <> s2) + +-- | A 'TyVarInfoMap' records what we know about each type variable; +-- it is a mapping from type variable names to 'TyVarInfo' records. +newtype TyVarInfoMap = VM {unVM :: Map (Name Type) TyVarInfo} + deriving (Show) + +instance Pretty TyVarInfoMap where + pretty (VM m) = pretty m + +-- | Utility function for acting on a 'TyVarInfoMap' by acting on the +-- underlying 'Map'. +onVM :: + (Map (Name Type) TyVarInfo -> Map (Name Type) TyVarInfo) -> + TyVarInfoMap -> + TyVarInfoMap +onVM f (VM m) = VM (f m) + +-- | Look up a given variable name in a 'TyVarInfoMap'. +lookupVM :: Name Type -> TyVarInfoMap -> Maybe TyVarInfo +lookupVM v = M.lookup v . unVM + +-- | Remove the mapping for a particular variable name (if it exists) +-- from a 'TyVarInfoMap'. +deleteVM :: Name Type -> TyVarInfoMap -> TyVarInfoMap +deleteVM = onVM . M.delete + +-- | Given a list of type variable names, add them all to the +-- 'TyVarInfoMap' as 'Skolem' variables (with a trivial sort). +addSkolems :: [Name Type] -> TyVarInfoMap -> TyVarInfoMap +addSkolems vs = onVM $ \vm -> foldl' (flip (\v -> M.insert v (mkTVI Skolem mempty))) vm vs + +-- | The @Semigroup@ instance for 'TyVarInfoMap' unions the two maps, +-- combining the info records for any variables occurring in both +-- maps. +instance Semigroup TyVarInfoMap where + VM sm1 <> VM sm2 = VM (M.unionWith (<>) sm1 sm2) + +instance Monoid TyVarInfoMap where + mempty = VM M.empty + mappend = (<>) + +-- | Get the sort of a particular variable recorded in a +-- 'TyVarInfoMap'. Returns the trivial (empty) sort for a variable +-- not in the map. +getSort :: TyVarInfoMap -> Name Type -> Sort +getSort (VM m) v = maybe topSort (view tyVarSort) (M.lookup v m) + +-- | Get the 'Ilk' of a variable recorded in a 'TyVarInfoMap'. +-- Returns @Nothing@ if the variable is not in the map, or if its +-- ilk is not known. +getIlk :: TyVarInfoMap -> Name Type -> Maybe Ilk +getIlk (VM m) v = (m ^? ix v . tyVarIlk) >>= getFirst + +-- | Extend the sort of a type variable by combining its existing sort +-- with the given one. Has no effect if the variable is not already +-- in the map. +extendSort :: Name Type -> Sort -> TyVarInfoMap -> TyVarInfoMap +extendSort x s = onVM (at x . _Just . tyVarSort %~ (`S.union` s)) + +--------------------------------- +-- Simplifier state + +-- The simplification stage maintains a mutable state consisting of +-- the current qualifier map (containing wanted qualifiers for type +-- variables), the list of remaining SimpleConstraints, and the +-- current substitution. It also keeps track of seen constraints, so +-- expansion of recursive types can stop when encountering a +-- previously seen constraint. +data SimplifyState = SS + { _ssVarMap :: TyVarInfoMap + , _ssConstraints :: [SimpleConstraint] + , _ssSubst :: S + , _ssSeen :: Set SimpleConstraint + } + +makeLenses ''SimplifyState + +lkup :: (Ord k, Show k, Show (Map k a)) => String -> Map k a -> k -> a +lkup messg m k = fromMaybe (error errMsg) (M.lookup k m) + where + errMsg = + unlines + [ "Key lookup error:" + , " Key = " ++ show k + , " Map = " ++ show m + , " Location: " ++ messg + ] + +-------------------------------------------------- +-- Top-level solver algorithm + +solveConstraint :: + Members '[Fresh, Error SolveError, Output (Message ann), Input TyDefCtx] r => + Constraint -> + Sem r S +solveConstraint c = do + -- Step 1. Open foralls (instantiating with skolem variables) and + -- collect wanted qualifiers; also expand disjunctions. Result in a + -- list of possible constraint sets; each one consists of equational + -- and subtyping constraints in addition to qualifiers. + + debug "Solving:" + debugPretty c + + debug "------------------------------" + debug "Decomposing constraints..." + + qcList <- decomposeConstraint c + + -- Now try continuing with each set and pick the first one that has + -- a solution. + asum' (map (uncurry solveConstraintChoice) qcList) + +solveConstraintChoice :: + Members '[Fresh, Error SolveError, Output (Message ann), Input TyDefCtx] r => + TyVarInfoMap -> + [SimpleConstraint] -> + Sem r S +solveConstraintChoice quals cs = do + debugPretty quals + debug $ vcat (map pretty' cs) + + tyDefns <- input @TyDefCtx + + -- Step 2. Check for weak unification to ensure termination. (a la + -- Traytel et al). + + let toEqn (t1 :<: t2) = (t1, t2) + toEqn (t1 :=: t2) = (t1, t2) + _ <- note NoWeakUnifier $ weakUnify tyDefns (map toEqn cs) + + -- Step 3. Simplify constraints, resulting in a set of atomic + -- subtyping constraints. Also simplify/update qualifier set + -- accordingly. + + debug "------------------------------" + debug "Running simplifier..." + + (vm, atoms, theta_simp) <- simplify quals cs + debug "Done running simplifier. Results:" + + debugPretty vm + debug $ vcat $ map (pretty' . (\(x, y) -> TyAtom x :<: TyAtom y)) atoms + debugPretty theta_simp + + -- Step 4. Turn the atomic constraints into a directed constraint + -- graph. + + debug "------------------------------" + debug "Generating constraint graph..." + + -- Some variables might have qualifiers but not participate in any + -- equality or subtyping relations (see issue #153); make sure to + -- extract them and include them in the constraint graph as isolated + -- vertices + let mkAVar (v, First (Just Skolem)) = AVar (S v) + mkAVar (v, _) = AVar (U v) + vars = S.fromList . map (mkAVar . second (view tyVarIlk)) . M.assocs . unVM $ vm + g = mkConstraintGraph vars atoms + + debugPretty g + + -- Step 5. + -- Check for any weakly connected components containing more + -- than one skolem, or a skolem and a base type; such components are + -- not allowed. Other WCCs with a single skolem simply unify to + -- that skolem. + + debug "------------------------------" + debug "Checking WCCs for skolems..." + + (g', theta_skolem) <- checkSkolems vm g + debugPretty theta_skolem + + -- We don't need to ensure that theta_skolem respects sorts since + -- checkSkolems will only unify skolem vars with unsorted variables. + + -- Step 6. Eliminate cycles from the graph, turning each strongly + -- connected component into a single node, unifying all the atoms in + -- each component. + + debug "------------------------------" + debug "Collapsing SCCs..." + + (g'', theta_cyc) <- elimCycles tyDefns g' + + debugPretty g'' + debugPretty theta_cyc + + -- Check that the resulting substitution respects sorts... + let sortOK (x, TyAtom (ABase ty)) = hasSort ty (getSort vm x) + sortOK (_, TyAtom (AVar (U _))) = True + sortOK p = error $ "Impossible! sortOK " ++ show p + unless (all sortOK (Subst.toList theta_cyc)) $ + throw NoUnify + + -- ... and update the sort map if we unified any type variables. + -- Just make sure that if theta_cyc maps x |-> y, then y picks up + -- the sort of x. + + debug "Old sort map:" + debugPretty vm + + let vm' = foldr updateVarMap vm (Subst.toList theta_cyc) + where + updateVarMap :: (Name Type, Type) -> TyVarInfoMap -> TyVarInfoMap + updateVarMap (x, TyAtom (AVar (U y))) vmm = extendSort y (getSort vmm x) vmm + updateVarMap _ vmm = vmm + + debug "Updated sort map:" + debugPretty vm + + debug "------------------------------" + debug "Checking edges between base types..." + + -- Step 6b. Collapsing SCCs can create some edges between base + -- types. Check that any such edges are consistent, then remove + -- them, since they no longer give us any information about type + -- variables. See https://github.com/disco-lang/disco/issues/357. + + g''' <- checkBaseEdges g'' + + -- Steps 7 & 8: solve the graph, iteratively finding satisfying + -- assignments for each type variable based on its successor and + -- predecessor base types in the graph; then unify all the type + -- variables in any remaining weakly connected components. + + debug "------------------------------" + debug "Solving for type variables..." + + theta_sol <- solveGraph vm' g''' + debugPretty theta_sol + + debug "------------------------------" + debug "Composing final substitution..." + + let theta_final = theta_sol @@ theta_cyc @@ theta_skolem @@ theta_simp + debugPretty theta_final + + return theta_final + +-------------------------------------------------- +-- Step 1. Constraint decomposition. + +decomposeConstraint :: + Members '[Fresh, Error SolveError, Input TyDefCtx] r => + Constraint -> + Sem r [(TyVarInfoMap, [SimpleConstraint])] +decomposeConstraint (CSub t1 t2) = return [(mempty, [t1 :<: t2])] +decomposeConstraint (CEq t1 t2) = return [(mempty, [t1 :=: t2])] +decomposeConstraint (CQual q ty) = (: []) . (,[]) <$> decomposeQual ty q +decomposeConstraint (CAnd cs) = map mconcat . sequence <$> mapM decomposeConstraint cs +decomposeConstraint CTrue = return [mempty] +decomposeConstraint (CAll ty) = do + (vars, c) <- unbind ty + let c' = substs (mkSkolems vars) c + (map . first . addSkolems) vars <$> decomposeConstraint c' + where + mkSkolems :: [Name Type] -> [(Name Type, Type)] + mkSkolems = map (id &&& TySkolem) +decomposeConstraint (COr cs) = concat <$> filterErrors (map decomposeConstraint cs) + +decomposeQual :: + Members '[Fresh, Error SolveError, Input TyDefCtx] r => + Type -> + Qualifier -> + Sem r TyVarInfoMap +decomposeQual = go S.empty + where + go :: + Members '[Fresh, Error SolveError, Input TyDefCtx] r => + Set (String, [Type], Qualifier) -> + Type -> + Qualifier -> + Sem r TyVarInfoMap + + -- For a type atom, call out to checkQual. + go _ (TyAtom a) q = checkQual q a + -- Coinductively check user-defined types for a qualifier. Keep + -- track of a set of user-defined types and qualifiers we have + -- seen. Every time we encounter a new one, add it to the set and + -- recurse on its unfolding. If we ever encounter one we have + -- already seen, we can assume by coinduction that the qualifier + -- is satisfied. + go seen (TyCon (CUser t) tys) q = do + case (t, tys, q) `S.member` seen of + True -> return mempty + False -> do + tyDefns <- input @TyDefCtx + case M.lookup t tyDefns of + Nothing -> error $ show t ++ " not in ty defn map!!" + Just (TyDefBody _ body) -> do + let ty' = body tys + go (S.insert (t, tys, q) seen) ty' q + + -- If we have a container type where the container is still a variable, + -- just replace it with List for the purposes of generating constraints--- + -- all containers (lists, bags, sets) have the same qualifier rules. + go seen (TyCon (CContainer (AVar _)) tys) q = go seen (TyCon CList tys) q + -- Otherwise, decompose a type constructor according to the qualRules. + go seen ty@(TyCon c tys) q = case qualRules c q of + Nothing -> throw $ Unqual q ty + Just qs -> mconcat <$> zipWithM (maybe (return mempty) . go seen) tys qs + +checkQual :: + Members '[Fresh, Error SolveError] r => + Qualifier -> + Atom -> + Sem r TyVarInfoMap +checkQual q (AVar (U v)) = return . VM . M.singleton v $ mkTVI Unification (S.singleton q) +checkQual q (AVar (S v)) = throw $ QualSkolem q v +checkQual q (ABase bty) = + case hasQual bty q of + True -> return mempty + False -> throw $ UnqualBase q bty + +-------------------------------------------------- +-- Step 3. Constraint simplification. + +-- | This step does unification of equality constraints, as well as +-- structural decomposition of subtyping constraints. For example, +-- if we have a constraint (x -> y) <: (z -> Int), then we can +-- decompose it into two constraints, (z <: x) and (y <: Int); if we +-- have a constraint v <: (a,b), then we substitute v ↦ (x,y) (where +-- x and y are fresh type variables) and continue; and so on. +-- +-- After this step, the remaining constraints will all be atomic +-- constraints, that is, only of the form (v1 <: v2), (v <: b), or +-- (b <: v), where v is a type variable and b is a base type. +simplify :: + Members '[Error SolveError, Output (Message ann), Input TyDefCtx] r => + TyVarInfoMap -> + [SimpleConstraint] -> + Sem r (TyVarInfoMap, [(Atom, Atom)], S) +simplify origVM cs = + (\(SS vm' cs' s' _) -> (vm', map extractAtoms cs', s')) + -- contFreshMT :: Monad m => FreshMT m a -> Integer -> m a + -- "Run a FreshMT computation given a starting index for fresh name generation." + <$> runFresh' n (execState (SS origVM cs idS S.empty) simplify') + where + fvNums :: Alpha a => [a] -> [Integer] + fvNums = map (name2Integer :: Name Type -> Integer) . toListOf fv + + -- Find first unused integer in constraint free vars and sort map + -- domain, and use it to start the fresh var generation, so we don't + -- generate any "fresh" names that interfere with existing names + n1 = maximum0 . fvNums $ cs + n = succ . maximum . (n1 :) . fvNums . M.keys . unVM $ origVM + + maximum0 [] = 0 + maximum0 xs = maximum xs + + -- Extract the type atoms from an atomic constraint. + extractAtoms :: SimpleConstraint -> (Atom, Atom) + extractAtoms (TyAtom a1 :<: TyAtom a2) = (a1, a2) + extractAtoms c = error $ "Impossible: simplify left non-atomic or non-subtype constraint " ++ show c + + -- Iterate picking one simplifiable constraint and simplifying it + -- until none are left. + simplify' :: + Members '[State SimplifyState, Fresh, Error SolveError, Output (Message ann), Input TyDefCtx] r => + Sem r () + simplify' = do + -- q <- gets fst + -- debug (pretty q) + -- debug "" + + mc <- pickSimplifiable + case mc of + Nothing -> return () + Just s -> do + debug $ "Simplifying:" <+> pretty' s + + simplifyOne s + simplify' + + -- Pick out one simplifiable constraint, removing it from the list + -- of constraints in the state. Return Nothing if no more + -- constraints can be simplified. + pickSimplifiable :: + Members '[State SimplifyState, Fresh, Error SolveError] r => + Sem r (Maybe SimpleConstraint) + pickSimplifiable = do + curCs <- use ssConstraints + case pick simplifiable curCs of + Nothing -> return Nothing + Just (a, as) -> do + ssConstraints .= as + return (Just a) + + -- Pick the first element from a list satisfying the given + -- predicate, returning the element and the list with the element + -- removed. + pick :: (a -> Bool) -> [a] -> Maybe (a, [a]) + pick _ [] = Nothing + pick p (a : as) + | p a = Just (a, as) + | otherwise = second (a :) <$> pick p as + + -- Check if a constraint can be simplified. An equality + -- constraint can always be "simplified" via unification. A + -- subtyping constraint can be simplified if either it involves a + -- type constructor (in which case we can decompose it), or if it + -- involves two base types (in which case it can be removed if the + -- relationship holds). + simplifiable :: SimpleConstraint -> Bool + simplifiable (_ :=: _) = True + simplifiable (TyCon {} :<: TyCon {}) = True + simplifiable (TyVar {} :<: TyCon {}) = True + simplifiable (TyCon {} :<: TyVar {}) = True + simplifiable (TyCon (CUser _) _ :<: _) = True + simplifiable (_ :<: TyCon (CUser _) _) = True + simplifiable (TyAtom (ABase _) :<: TyAtom (ABase _)) = True + simplifiable _ = False + + -- Simplify the given simplifiable constraint. If the constraint + -- has already been seen before (due to expansion of a recursive + -- type), just throw it away and stop. + simplifyOne :: + Members '[State SimplifyState, Fresh, Error SolveError, Input TyDefCtx] r => + SimpleConstraint -> + Sem r () + simplifyOne c = do + seen <- use ssSeen + case c `S.member` seen of + True -> return () + False -> do + ssSeen %= S.insert c + simplifyOne' c + + simplifyOne' :: + Members '[State SimplifyState, Fresh, Error SolveError, Input TyDefCtx] r => + SimpleConstraint -> + Sem r () + + -- If we have an equality constraint, run unification on it. The + -- resulting substitution is applied to the remaining constraints + -- as well as prepended to the current substitution. + + simplifyOne' (ty1 :=: ty2) = do + tyDefns <- input @TyDefCtx + case unify tyDefns [(ty1, ty2)] of + Nothing -> throw NoUnify + Just s' -> extendSubst s' + + -- If we see a constraint of the form (T <: a), where T is a + -- user-defined type and a is a type variable, then just turn it + -- into an equality (T = a). This is sound but probably not + -- complete. The alternative seems quite complicated, possibly + -- even undecidable. See https://github.com/disco-lang/disco/issues/207 . + simplifyOne' (ty1@(TyCon (CUser _) _) :<: ty2@TyVar {}) = + simplifyOne' (ty1 :=: ty2) + -- Otherwise, expand the user-defined type and continue. + simplifyOne' (TyCon (CUser t) ts :<: ty2) = do + tyDefns <- input @TyDefCtx + case M.lookup t tyDefns of + Nothing -> error $ show t ++ " not in ty defn map!" + Just (TyDefBody _ body) -> + ssConstraints %= ((body ts :<: ty2) :) + + -- Turn a <: T into a = T. See comment above. + simplifyOne' (ty1@TyVar {} :<: ty2@(TyCon (CUser _) _)) = + simplifyOne' (ty1 :=: ty2) + simplifyOne' (ty1 :<: TyCon (CUser t) ts) = do + tyDefns <- input @TyDefCtx + case M.lookup t tyDefns of + Nothing -> error $ show t ++ " not in ty defn map!" + Just (TyDefBody _ body) -> + ssConstraints %= ((ty1 :<: body ts) :) + + -- Given a subtyping constraint between two type constructors, + -- decompose it if the constructors are the same (or fail if they + -- aren't), taking into account the variance of each argument to + -- the constructor. Container types are a special case; + -- recursively generate a subtyping constraint for their + -- constructors as well. + simplifyOne' (TyCon c1@(CContainer ctr1) tys1 :<: TyCon (CContainer ctr2) tys2) = + ssConstraints + %= ( ( (TyAtom ctr1 :<: TyAtom ctr2) + : zipWith3 variance (arity c1) tys1 tys2 + ) + ++ + ) + simplifyOne' (TyCon c1 tys1 :<: TyCon c2 tys2) + | c1 /= c2 = throw NoUnify + | otherwise = + ssConstraints %= (zipWith3 variance (arity c1) tys1 tys2 ++) + -- Given a subtyping constraint between a variable and a type + -- constructor, expand the variable into the same constructor + -- applied to fresh type variables. + simplifyOne' con@(TyVar a :<: TyCon c _) = expandStruct a c con + simplifyOne' con@(TyCon c _ :<: TyVar a) = expandStruct a c con + -- Given a subtyping constraint between two base types, just check + -- whether the first is indeed a subtype of the second. (Note + -- that we only pattern match here on type atoms, which could + -- include variables, but this will only ever get called if + -- 'simplifiable' was true, which checks that both are base + -- types.) + simplifyOne' (TyAtom (ABase b1) :<: TyAtom (ABase b2)) = do + case isSubB b1 b2 of + True -> return () + False -> throw NoUnify + simplifyOne' (s :<: t) = + error $ "Impossible! simplifyOne' " ++ show s ++ " :<: " ++ show t + + expandStruct :: + Members '[State SimplifyState, Fresh, Error SolveError, Input TyDefCtx] r => + Name Type -> + Con -> + SimpleConstraint -> + Sem r () + expandStruct a c con = do + as <- mapM (const (TyVar <$> fresh (string2Name "a"))) (arity c) + let s' = a |-> TyCon c as + ssConstraints %= (con :) + extendSubst s' + + -- 1. compose s' with current subst + -- 2. apply s' to constraints + -- 3. apply s' to qualifier map and decompose + extendSubst :: + Members '[State SimplifyState, Fresh, Error SolveError, Input TyDefCtx] r => + S -> + Sem r () + extendSubst s' = do + ssSubst %= (s' @@) + ssConstraints %= applySubst s' + substVarMap s' + + substVarMap :: + Members '[State SimplifyState, Fresh, Error SolveError, Input TyDefCtx] r => + S -> + Sem r () + substVarMap s' = do + vm <- use ssVarMap + + -- 1. Get quals for each var in domain of s' and match them with + -- the types being substituted for those vars. + + let tySorts :: [(Type, Sort)] + tySorts = map (second (view tyVarSort)) . mapMaybe (traverse (`lookupVM` vm) . swap) $ Subst.toList s' + + tyQualList :: [(Type, Qualifier)] + tyQualList = concatMap (sequenceA . second S.toList) tySorts + + -- 2. Decompose the resulting qualifier constraints + + vm' <- mconcat <$> mapM (uncurry decomposeQual) tyQualList + + -- 3. delete domain of s' from vm and merge in decomposed quals. + + ssVarMap .= vm' <> foldl' (flip deleteVM) vm (dom s') + + -- The above works even when unifying two variables. Say we have + -- the TyVarInfoMap + -- + -- a |-> {add} + -- b |-> {sub} + -- + -- and we get back theta = [a |-> b]. The domain of theta + -- consists solely of a, so we look up a in the TyVarInfoMap and get + -- {add}. We therefore generate the constraint 'add (theta a)' + -- = 'add b' which can't be decomposed at all, and hence yields + -- the TyVarInfoMap {b |-> {add}}. We then delete a from the + -- original TyVarInfoMap and merge the result with the new TyVarInfoMap, + -- yielding {b |-> {sub,add}}. + + -- Create a subtyping constraint based on the variance of a type + -- constructor argument position: in the usual order for + -- covariant, and reversed for contravariant. + variance Co ty1 ty2 = ty1 :<: ty2 + variance Contra ty1 ty2 = ty2 :<: ty1 + +-------------------------------------------------- +-- Step 4: Build constraint graph + +-- | Given a list of atoms and atomic subtype constraints (each pair +-- @(a1,a2)@ corresponds to the constraint @a1 <: a2@) build the +-- corresponding constraint graph. +mkConstraintGraph :: (Show a, Ord a) => Set a -> [(a, a)] -> Graph a +mkConstraintGraph as cs = G.mkGraph nodes (S.fromList cs) + where + nodes = as `S.union` S.fromList (cs ^.. traverse . each) + +-------------------------------------------------- +-- Step 5: Check skolems + +-- | Check for any weakly connected components containing more than +-- one skolem, or a skolem and a base type, or a skolem and any +-- variables with nontrivial sorts; such components are not allowed. +-- If there are any WCCs with a single skolem, no base types, and +-- only unsorted variables, just unify them all with the skolem and +-- remove those components. +checkSkolems :: + Members '[Error SolveError, Output (Message ann), Input TyDefCtx] r => + TyVarInfoMap -> + Graph Atom -> + Sem r (Graph UAtom, S) +checkSkolems vm graph = do + let skolemWCCs :: [Set Atom] + skolemWCCs = filter (any isSkolem) $ G.wcc graph + + ok wcc = + S.size (S.filter isSkolem wcc) <= 1 + && all + ( \case + ABase _ -> False + AVar (S _) -> True + AVar (U v) -> maybe True (S.null . view tyVarSort) (lookupVM v vm) + ) + wcc + + (good, bad) = partition ok skolemWCCs + + unless (null bad) $ throw NoUnify + + -- take all good sets and + -- (1) delete them from the graph + -- (2) unify them all with the skolem + unifyWCCs graph idS good + where + noSkolems :: Atom -> UAtom + noSkolems (ABase b) = UB b + noSkolems (AVar (U v)) = UV v + noSkolems (AVar (S v)) = error $ "Skolem " ++ show v ++ " remaining in noSkolems" + + unifyWCCs :: + Members '[Error SolveError, Output (Message ann), Input TyDefCtx] r => + Graph Atom -> + S -> + [Set Atom] -> + Sem r (Graph UAtom, S) + unifyWCCs g s [] = return (G.map noSkolems g, s) + unifyWCCs g s (u : us) = do + debug $ "Unifying" <+> pretty' (u : us) <> "..." + + tyDefns <- input @TyDefCtx + + let g' = foldl' (flip G.delete) g u + + ms' = unifyAtoms tyDefns (S.toList u) + case ms' of + Nothing -> throw NoUnify + Just s' -> unifyWCCs g' (atomToTypeSubst s' @@ s) us + +-------------------------------------------------- +-- Step 6: Eliminate cycles + +-- | Eliminate cycles in the constraint set by collapsing each +-- strongly connected component to a single node, (unifying all the +-- types in the SCC). A strongly connected component is a maximal +-- set of nodes where every node is reachable from every other by a +-- directed path; since we are using directed edges to indicate a +-- subtyping constraint, this means every node must be a subtype of +-- every other, and the only way this can happen is if all are in +-- fact equal. +-- +-- Of course, this step can fail if the types in a SCC are not +-- unifiable. If it succeeds, it returns the collapsed graph (which +-- is now guaranteed to be acyclic, i.e. a DAG) and a substitution. +elimCycles :: + Members '[Error SolveError] r => + TyDefCtx -> + Graph UAtom -> + Sem r (Graph UAtom, S) +elimCycles tyDefns = elimCyclesGen uatomToTypeSubst (unifyUAtoms tyDefns) + +elimCyclesGen :: + forall a b r. + (Subst a a, Ord a, Members '[Error SolveError] r) => + (Substitution a -> Substitution b) -> + ([a] -> Maybe (Substitution a)) -> + Graph a -> + Sem r (Graph a, Substitution b) +elimCyclesGen genSubst genUnify g = + note NoUnify $ + (G.map fst &&& (genSubst . compose . S.map snd . G.nodes)) <$> g' + where + g' :: Maybe (Graph (a, Substitution a)) + g' = G.sequenceGraph $ G.map unifySCC (G.condensation g) + + unifySCC :: Set a -> Maybe (a, Substitution a) + unifySCC uatoms = case S.toList uatoms of + [] -> error "Impossible! unifySCC on the empty set" + as@(a : _) -> (flip applySubst a &&& id) <$> genUnify as + +------------------------------------------------------------ +-- Step 6a: check base type edges +------------------------------------------------------------ + +isBaseEdge :: (UAtom, UAtom) -> Either (BaseTy, BaseTy) (UAtom, UAtom) +isBaseEdge (UB b1, UB b2) = Left (b1, b2) +isBaseEdge e = Right e + +checkBaseEdge :: Members '[Error SolveError] r => (BaseTy, BaseTy) -> Sem r () +checkBaseEdge (b1, b2) + | isSubB b1 b2 = return () + | otherwise = throw NoUnify + +checkBaseEdges :: Members '[Error SolveError] r => Graph UAtom -> Sem r (Graph UAtom) +checkBaseEdges g = do + let (baseEdges, varEdges) = partitionEithers . map isBaseEdge . S.toList . G.edges $ g + mapM_ checkBaseEdge baseEdges + return $ G.mkGraph (G.nodes g) (S.fromList varEdges) + +------------------------------------------------------------ +-- Steps 7 and 8: Constraint resolution +------------------------------------------------------------ + +-- | Rels stores the set of base types and variables related to a +-- given variable in the constraint graph (either predecessors or +-- successors, but not both). +data Rels = Rels + { baseRels :: Set BaseTy + , varRels :: Set (Name Type) + } + deriving (Show, Eq) + +-- | A RelMap associates each variable to its sets of base type and +-- variable predecessors and successors in the constraint graph. +newtype RelMap = RelMap {unRelMap :: Map (Name Type, Dir) Rels} + +instance Pretty RelMap where + pretty (RelMap rm) = vcat (map prettyVar byVar) + where + vars = S.map fst (M.keysSet rm) + byVar = map (\x -> (rm ! (x, SubTy), x, rm ! (x, SuperTy))) (S.toList vars) + + prettyVar (subs, x, sups) = hsep [prettyRel subs, "<:", pretty x, "<:", prettyRel sups] + prettyRel rs = pretty (baseRels rs) <> ", " <> pretty (varRels rs) + +-- | Modify a @RelMap@ to record the fact that we have solved for a +-- type variable. In particular, delete the variable from the +-- @RelMap@ as a key, and also update the relative sets of every +-- other variable to remove this variable and add the base type we +-- chose for it. +substRel :: Name Type -> BaseTy -> RelMap -> RelMap +substRel x ty = + RelMap + . M.delete (x, SuperTy) + . M.delete (x, SubTy) + . M.map (\r@(Rels b v) -> if x `S.member` v then Rels (S.insert ty b) (S.delete x v) else r) + . unRelMap + +-- | Essentially dirtypesBySort vm rm dir t s x finds all the +-- dir-types (sub- or super-) of t which have sort s, relative to +-- the variables in x. This is \overbar{T}_S^X (resp. \underbar...) +-- from Traytel et al. +dirtypesBySort :: TyVarInfoMap -> RelMap -> Dir -> BaseTy -> Sort -> Set (Name Type) -> [BaseTy] +dirtypesBySort vm (RelMap relMap) dir t s x = + -- Keep only those supertypes t' of t + keep (dirtypes dir t) $ \t' -> + -- which have the right sort, and such that + hasSort t' s + && + -- for all variables beta \in x, + forAll + x + ( \beta -> + -- there is at least one type t'' which is a subtype of t' + -- which would be a valid solution for beta, that is, + exists (dirtypes (other dir) t') $ \t'' -> + -- t'' has the sort beta is supposed to have, and + hasSort t'' (getSort vm beta) + && + -- t'' is a supertype of every base type predecessor of beta. + forAll + (baseRels (lkup "dirtypesBySort, beta rel" relMap (beta, other dir))) + (isDirB dir t'') + ) + where + -- The above comments are written assuming dir = Super; of course, + -- if dir = Sub then just swap "super" and "sub" everywhere. + + forAll, exists :: Foldable t => t a -> (a -> Bool) -> Bool + forAll = flip all + exists = flip any + keep = flip filter + +-- | Sort-aware infimum or supremum. +limBySort :: TyVarInfoMap -> RelMap -> Dir -> [BaseTy] -> Sort -> Set (Name Type) -> Maybe BaseTy +limBySort vm rm dir ts s x = + (\is -> find (\lim -> all (\u -> isDirB dir u lim) is) is) + . isects + . map (\t -> dirtypesBySort vm rm dir t s x) + $ ts + where + isects = foldr1 intersect + +lubBySort, glbBySort :: TyVarInfoMap -> RelMap -> [BaseTy] -> Sort -> Set (Name Type) -> Maybe BaseTy +lubBySort vm rm = limBySort vm rm SuperTy +glbBySort vm rm = limBySort vm rm SubTy + +-- | From the constraint graph, build the sets of sub- and super- base +-- types of each type variable, as well as the sets of sub- and +-- supertype variables. For each type variable x in turn, try to +-- find a common supertype of its base subtypes which is consistent +-- with the sort of x and with the sorts of all its sub-variables, +-- as well as symmetrically a common subtype of its supertypes, etc. +-- Assign x one of the two: if it has only successors, assign it +-- their inf; otherwise, assign it the sup of its predecessors. If +-- it has both, we have a choice of whether to assign it the sup of +-- predecessors or inf of successors; both lead to a sound & +-- complete algorithm. We choose to assign it the sup of its +-- predecessors in this case, since it seems nice to default to +-- "simpler" types lower down in the subtyping chain. +solveGraph :: + Members '[Fresh, Error SolveError, Output (Message ann)] r => + TyVarInfoMap -> + Graph UAtom -> + Sem r S +solveGraph vm g = atomToTypeSubst . unifyWCC <$> go topRelMap + where + unifyWCC :: Substitution BaseTy -> Substitution Atom + unifyWCC s = compose (map mkEquateSubst wccVarGroups) @@ fmap ABase s + where + wccVarGroups :: [Set (Name Type)] + wccVarGroups = map (S.map getVar) . filter (all uisVar) . applySubst s $ G.wcc g + getVar (UV v) = v + getVar (UB b) = + error $ + "Impossible! Base type " ++ show b ++ " in solveGraph.getVar" + + mkEquateSubst :: Set (Name Type) -> Substitution Atom + mkEquateSubst = mkEquations . S.toList + + mkEquations (a : as) = Subst.fromList . map (\v -> (coerce v, AVar (U a))) $ as + mkEquations [] = error "Impossible! Empty set of names in mkEquateSubst" + + -- After picking concrete base types for all the type + -- variables we can, the only thing possibly remaining in + -- the graph are components containing only type variables + -- and no base types. It is sound, and simplifies the + -- generated types considerably, to simply unify any type + -- variables which are related by subtyping constraints. + -- That is, we collect all the type variables in each + -- weakly connected component and unify them. + -- + -- As an example where this final step makes a difference, + -- consider a term like @\x. (\y.y) x@. A fresh type + -- variable is generated for the type of @x@, and another + -- for the type of @y@; the application of @(\y.y)@ to @x@ + -- induces a subtyping constraint between the two type + -- variables. The most general type would be something + -- like @forall a b. (a <: b) => a -> b@, but we want to + -- avoid generating unnecessary subtyping constraints (the + -- type system might not even support subtyping qualifiers + -- like this). Instead, we unify the two type variables + -- and the resulting type is @forall a. a -> a@. + + -- Get the successor and predecessor sets for all the type variables. + topRelMap :: RelMap + topRelMap = + RelMap + . M.map + ( uncurry Rels + . (S.fromAscList *** S.fromAscList) + . partitionEithers + . map uatomToEither + . S.toList + ) + $ M.mapKeys (,SuperTy) subMap `M.union` M.mapKeys (,SubTy) superMap + + subMap, superMap :: Map (Name Type) (Set UAtom) + (subMap, superMap) = (onlyVars *** onlyVars) $ G.cessors g + + onlyVars :: Map UAtom (Set UAtom) -> Map (Name Type) (Set UAtom) + onlyVars = M.mapKeys fromVar . M.filterWithKey (\a _ -> uisVar a) + where + fromVar (UV x) = x + fromVar _ = error "Impossible! UB but uisVar." + + go :: + Members '[Fresh, Error SolveError, Output (Message ann)] r => + RelMap -> + Sem r (Substitution BaseTy) + go relMap@(RelMap rm) = + debugPretty relMap >> case as of + -- No variables left that have base type constraints. + [] -> return idS + -- Solve one variable at a time. See below. + (a : _) -> do + debug $ "Solving for" <+> pretty' a + case solveVar a of + Nothing -> do + debug $ "Couldn't solve for" <+> pretty' a + throw NoUnify + + -- If we solved for a, delete it from the maps, apply the + -- resulting substitution to the remainder (updating the + -- relMap appropriately), and recurse. The substitution we + -- want will be the composition of the substitution for a + -- with the substitution generated by the recursive call. + -- + -- Note we don't need to delete a from the TyVarInfoMap; we + -- never use the set of keys from the TyVarInfoMap for + -- anything (indeed, some variables might not be keys if + -- they have an empty sort), so it doesn't matter if old + -- variables hang around in it. + Just s -> do + debugPretty s + (@@ s) <$> go (substRel a (fromJust $ Subst.lookup (coerce a) s) relMap) + where + -- NOTE we can't solve a bunch in parallel! Might end up + -- assigning them conflicting solutions if some depend on + -- others. For example, consider the situation + -- + -- Z + -- | + -- a3 + -- / \ + -- a1 N + -- + -- If we try to solve in parallel we will end up assigning a1 + -- -> Z (since it only has base types as an upper bound) and + -- a3 -> N (since it has both upper and lower bounds, and by + -- default we pick the lower bound), but this is wrong since + -- we should have a1 < a3. + -- + -- If instead we solve them one at a time, we could e.g. first + -- solve a1 -> Z, and then we would find a3 -> Z as well. + -- Alternately, if we first solve a3 -> N then we will have a1 + -- -> N as well. Both are acceptable. + -- + -- In fact, this exact graph comes from (^x.x+1) which was + -- erroneously being inferred to have type Z -> N when I first + -- wrote the code. + + -- Get only the variables we can solve on this pass, which + -- have base types in their predecessor or successor set. If + -- there are no such variables, then start picking any + -- remaining variables with a sort and pick types for them + -- (disco doesn't have qualified polymorphism so we can't just + -- leave them). + asBase = + map fst + . filter (not . S.null . baseRels . lkup "solveGraph.go.as" rm) + $ M.keys rm + as = case asBase of + [] -> filter ((/= topSort) . getSort vm) . map fst $ M.keys rm + _ -> asBase + + -- Solve for a variable, failing if it has no solution, otherwise returning + -- a substitution for it. + solveVar :: Name Type -> Maybe (Substitution BaseTy) + solveVar v = + case ((v, SuperTy), (v, SubTy)) & over both (S.toList . baseRels . lkup "solveGraph.solveVar" rm) of + -- No sub- or supertypes; the only way this can happen is + -- if it has a nontrivial sort. + -- + -- Traytel et al. don't seem to have a rule saying what to + -- do in this case (see Fig. 16 on p. 16 of their long + -- version). We used to just pick a type that inhabits + -- the sort, but this is wrong; see + -- https://github.com/disco-lang/disco/issues/192. + -- + -- If the sort is 'bool', we'll pick the Boolean base + -- type, since there are no other sorts which could cause + -- a conflict as in #192. + -- + -- Otherwise, we assume that any situation in which we + -- have no base sub- or supertypes but we do have + -- nontrivial sorts means that we are dealing with numeric + -- types; so we can just call N a base subtype and go from + -- there. + + ([], []) -> + if getSort vm v == S.fromList [QBool] + then Just (coerce v |-> B) + else -- Debug.trace (show v ++ " has no sub- or supertypes. Assuming N as a subtype.") + + (coerce v |->) + <$> lubBySort + vm + relMap + [N] + (getSort vm v) + (varRels (lkup "solveVar none, rels" rm (v, SubTy))) + -- Only supertypes. Just assign a to their inf, if one exists. + (bsupers, []) -> + -- Debug.trace (show v ++ " has only supertypes (" ++ show bsupers ++ ")") $ + (coerce v |->) + <$> glbBySort + vm + relMap + bsupers + (getSort vm v) + (varRels (lkup "solveVar bsupers, rels" rm (v, SuperTy))) + -- Only subtypes. Just assign a to their sup. + ([], bsubs) -> + -- Debug.trace (show v ++ " has only subtypes (" ++ show bsubs ++ ")") $ + -- Debug.trace ("sortmap: " ++ show vm) $ + -- Debug.trace ("relmap: " ++ show relMap) $ + -- Debug.trace ("sort for " ++ show v ++ ": " ++ show (getSort vm v)) $ + -- Debug.trace ("relvars: " ++ show (varRels (relMap ! (v,SubTy)))) $ + (coerce v |->) + <$> lubBySort + vm + relMap + bsubs + (getSort vm v) + (varRels (lkup "solveVar bsubs, rels" rm (v, SubTy))) + -- Both successors and predecessors. Both must have a + -- valid bound, and the bounds must not overlap. Assign a + -- to the sup of its predecessors. + (bsupers, bsubs) -> do + ub <- + glbBySort + vm + relMap + bsupers + (getSort vm v) + (varRels (rm ! (v, SuperTy))) + lb <- + lubBySort + vm + relMap + bsubs + (getSort vm v) + (varRels (rm ! (v, SubTy))) + case isSubB lb ub of + True -> Just (coerce v |-> lb) + False -> Nothing diff --git a/src/Disco/Typecheck/Unify.hs b/src/Disco/Typecheck/Unify.hs --- a/src/Disco/Typecheck/Unify.hs +++ b/src/Disco/Typecheck/Unify.hs @@ -1,4 +1,7 @@ ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Disco.Typecheck.Unify -- Copyright : disco team and contributors @@ -7,21 +10,18 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- Unification. --- ------------------------------------------------------------------------------ - module Disco.Typecheck.Unify where -import Unbound.Generics.LocallyNameless (Name, fv) +import Unbound.Generics.LocallyNameless (Name, fv) -import Control.Lens (anyOf) -import Control.Monad.State -import qualified Data.Map as M -import Data.Set (Set) -import qualified Data.Set as S +import Control.Lens (anyOf) +import Control.Monad.State +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S -import Disco.Subst -import Disco.Types +import Disco.Subst +import Disco.Types -- XXX todo: might be better if unification took sorts into account -- directly. As it is, however, I think it works properly; @@ -51,92 +51,89 @@ -- | Given a list of equations between types, return a substitution -- which makes all the equations satisfied (or fail if it is not -- possible), up to the given comparison on base types. -unify' :: (BaseTy -> BaseTy -> Bool) -> TyDefCtx - -> [(Type, Type)] -> Maybe S +unify' :: + (BaseTy -> BaseTy -> Bool) -> + TyDefCtx -> + [(Type, Type)] -> + Maybe S unify' baseEq tyDefns eqs = evalStateT (go eqs) S.empty - where - go :: [(Type, Type)] -> StateT (Set (Type,Type)) Maybe S - go [] = return idS - go (e:es) = do - u <- unifyOne e - case u of - Left sub -> (@@ sub) <$> go (applySubst sub es) - Right newEs -> go (newEs ++ es) - - unifyOne :: (Type, Type) -> StateT (Set (Type,Type)) Maybe (Either S [(Type, Type)]) - unifyOne pair = do - seen <- get - case pair `S.member` seen of - True -> return $ Left idS - False -> unifyOne' pair - - unifyOne' :: (Type, Type) -> StateT (Set (Type,Type)) Maybe (Either S [(Type, Type)]) - - unifyOne' (ty1, ty2) - | ty1 == ty2 = return $ Left idS - - unifyOne' (TyVar x, ty2) - | occurs x ty2 = mzero - | otherwise = return $ Left (x |-> ty2) - unifyOne' (ty1, x@(TyVar _)) - = unifyOne (x, ty1) - - -- At this point we know ty2 isn't the same skolem nor a unification variable. - -- Skolems don't unify with anything. - unifyOne' (TySkolem _, _) = mzero - unifyOne' (_, TySkolem _) = mzero + where + go :: [(Type, Type)] -> StateT (Set (Type, Type)) Maybe S + go [] = return idS + go (e : es) = do + u <- unifyOne e + case u of + Left sub -> (@@ sub) <$> go (applySubst sub es) + Right newEs -> go (newEs ++ es) - -- Unify two container types: unify the container descriptors as - -- well as the type arguments - unifyOne' p@(TyCon (CContainer ctr1) tys1, TyCon (CContainer ctr2) tys2) = do - modify (S.insert p) - return $ Right ((TyAtom ctr1, TyAtom ctr2) : zip tys1 tys2) + unifyOne :: (Type, Type) -> StateT (Set (Type, Type)) Maybe (Either S [(Type, Type)]) + unifyOne pair = do + seen <- get + case pair `S.member` seen of + True -> return $ Left idS + False -> unifyOne' pair - -- If one of the types to be unified is a user-defined type, - -- unfold its definition before continuing the matching - unifyOne' p@(TyCon (CUser t) tys1, ty2) = do - modify (S.insert p) - case M.lookup t tyDefns of - Nothing -> mzero - Just (TyDefBody _ body) -> return $ Right [(body tys1, ty2)] + unifyOne' :: (Type, Type) -> StateT (Set (Type, Type)) Maybe (Either S [(Type, Type)]) - unifyOne' p@(ty1, TyCon (CUser t) tys2) = do - modify (S.insert p) - case M.lookup t tyDefns of - Nothing -> mzero - Just (TyDefBody _ body) -> return $ Right [(ty1, body tys2)] + unifyOne' (ty1, ty2) + | ty1 == ty2 = return $ Left idS + unifyOne' (TyVar x, ty2) + | occurs x ty2 = mzero + | otherwise = return $ Left (x |-> ty2) + unifyOne' (ty1, x@(TyVar _)) = + unifyOne (x, ty1) + -- At this point we know ty2 isn't the same skolem nor a unification variable. + -- Skolems don't unify with anything. + unifyOne' (TySkolem _, _) = mzero + unifyOne' (_, TySkolem _) = mzero + -- Unify two container types: unify the container descriptors as + -- well as the type arguments + unifyOne' p@(TyCon (CContainer ctr1) tys1, TyCon (CContainer ctr2) tys2) = do + modify (S.insert p) + return $ Right ((TyAtom ctr1, TyAtom ctr2) : zip tys1 tys2) - -- Unify any other pair of type constructor applications: the type - -- constructors must match exactly - unifyOne' p@(TyCon c1 tys1, TyCon c2 tys2) - | c1 == c2 = do - modify (S.insert p) - return $ Right (zip tys1 tys2) - | otherwise = mzero - unifyOne' (TyAtom (ABase b1), TyAtom (ABase b2)) - | baseEq b1 b2 = return $ Left idS - | otherwise = mzero - unifyOne' _ = mzero -- Atom = Cons + -- If one of the types to be unified is a user-defined type, + -- unfold its definition before continuing the matching + unifyOne' p@(TyCon (CUser t) tys1, ty2) = do + modify (S.insert p) + case M.lookup t tyDefns of + Nothing -> mzero + Just (TyDefBody _ body) -> return $ Right [(body tys1, ty2)] + unifyOne' p@(ty1, TyCon (CUser t) tys2) = do + modify (S.insert p) + case M.lookup t tyDefns of + Nothing -> mzero + Just (TyDefBody _ body) -> return $ Right [(ty1, body tys2)] + -- Unify any other pair of type constructor applications: the type + -- constructors must match exactly + unifyOne' p@(TyCon c1 tys1, TyCon c2 tys2) + | c1 == c2 = do + modify (S.insert p) + return $ Right (zip tys1 tys2) + | otherwise = mzero + unifyOne' (TyAtom (ABase b1), TyAtom (ABase b2)) + | baseEq b1 b2 = return $ Left idS + | otherwise = mzero + unifyOne' _ = mzero -- Atom = Cons equate :: TyDefCtx -> [Type] -> Maybe S equate tyDefns tys = unify tyDefns eqns - where - eqns = zip tys (tail tys) + where + eqns = zip tys (tail tys) occurs :: Name Type -> Type -> Bool -occurs x = anyOf fv (==x) - +occurs x = anyOf fv (== x) unifyAtoms :: TyDefCtx -> [Atom] -> Maybe (Substitution Atom) unifyAtoms tyDefns = fmap (fmap fromTyAtom) . equate tyDefns . map TyAtom - where - fromTyAtom (TyAtom a) = a - fromTyAtom _ = error "fromTyAtom on non-TyAtom!" + where + fromTyAtom (TyAtom a) = a + fromTyAtom _ = error "fromTyAtom on non-TyAtom!" unifyUAtoms :: TyDefCtx -> [UAtom] -> Maybe (Substitution UAtom) unifyUAtoms tyDefns = fmap (fmap fromTyAtom) . equate tyDefns . map (TyAtom . uatomToAtom) - where - fromTyAtom (TyAtom (ABase b)) = UB b - fromTyAtom (TyAtom (AVar (U v))) = UV v - fromTyAtom _ = error "fromTyAtom on wrong thing!" + where + fromTyAtom (TyAtom (ABase b)) = UB b + fromTyAtom (TyAtom (AVar (U v))) = UV v + fromTyAtom _ = error "fromTyAtom on wrong thing!" diff --git a/src/Disco/Typecheck/Util.hs b/src/Disco/Typecheck/Util.hs --- a/src/Disco/Typecheck/Util.hs +++ b/src/Disco/Typecheck/Util.hs @@ -1,5 +1,4 @@ ------------------------------------------------------------------------------ -- | -- Module : Disco.Typecheck.Util -- Copyright : (c) 2016 disco team (see LICENSE) @@ -8,30 +7,27 @@ -- -- Definition of type contexts, type errors, and various utilities -- used during type checking. --- ------------------------------------------------------------------------------ - module Disco.Typecheck.Util where -import Disco.Effects.Fresh -import Polysemy -import Polysemy.Error -import Polysemy.Output -import Polysemy.Reader -import Polysemy.Writer -import Unbound.Generics.LocallyNameless (Name, bind, string2Name) +import Disco.Effects.Fresh +import Polysemy +import Polysemy.Error +import Polysemy.Output +import Polysemy.Reader +import Polysemy.Writer +import Unbound.Generics.LocallyNameless (Name, bind, string2Name) -import qualified Data.Map as M -import Data.Tuple (swap) -import Prelude hiding (lookup) +import qualified Data.Map as M +import Data.Tuple (swap) +import Prelude hiding (lookup) -import Disco.AST.Surface -import Disco.Context -import Disco.Messages -import Disco.Names (ModuleName, QName) -import Disco.Typecheck.Constraints -import Disco.Typecheck.Solve -import Disco.Types +import Disco.AST.Surface +import Disco.Context +import Disco.Messages +import Disco.Names (ModuleName, QName) +import Disco.Typecheck.Constraints +import Disco.Typecheck.Solve +import Disco.Types ------------------------------------------------------------ -- Contexts @@ -47,7 +43,7 @@ -- | A typechecking error, wrapped up together with the name of the -- thing that was being checked when the error occurred. data LocTCError = LocTCError (Maybe (QName Term)) TCError - deriving Show + deriving (Show) -- | Wrap a @TCError@ into a @LocTCError@ with no explicit provenance -- information. @@ -56,38 +52,60 @@ -- | Potential typechecking errors. data TCError - = Unbound (Name Term) -- ^ Encountered an unbound variable - | Ambiguous (Name Term) [ModuleName] -- ^ Encountered an ambiguous name. - | NoType (Name Term) -- ^ No type is specified for a definition - | NotCon Con Term Type -- ^ The type of the term should have an - -- outermost constructor matching Con, but - -- it has type 'Type' instead - | EmptyCase -- ^ Case analyses cannot be empty. - | PatternType Con Pattern Type -- ^ The given pattern should have the type, but it doesn't. - -- instead it has a kind of type given by the Con. - | DuplicateDecls (Name Term) -- ^ Duplicate declarations. - | DuplicateDefns (Name Term) -- ^ Duplicate definitions. - | DuplicateTyDefns String -- ^ Duplicate type definitions. - | CyclicTyDef String -- ^ Cyclic type definition. - | NumPatterns -- ^ # of patterns does not match type in definition - | NoSearch Type -- ^ Type can't be quantified over. - | Unsolvable SolveError -- ^ The constraint solver couldn't find a solution. - | NotTyDef String -- ^ An undefined type name was used. - | NoTWild -- ^ Wildcards are not allowed in terms. - | NotEnoughArgs Con -- ^ Not enough arguments provided to type constructor. - | TooManyArgs Con -- ^ Too many arguments provided to type constructor. - | UnboundTyVar (Name Type) -- ^ Unbound type variable - | NoPolyRec String [String] [Type] -- ^ Polymorphic recursion is not allowed - | NoError -- ^ Not an error. The identity of the - -- @Monoid TCError@ instance. - deriving Show + = -- | Encountered an unbound variable + Unbound (Name Term) + | -- | Encountered an ambiguous name. + Ambiguous (Name Term) [ModuleName] + | -- | No type is specified for a definition + NoType (Name Term) + | -- | The type of the term should have an + -- outermost constructor matching Con, but + -- it has type 'Type' instead + NotCon Con Term Type + | -- | Case analyses cannot be empty. + EmptyCase + | -- | The given pattern should have the type, but it doesn't. + -- instead it has a kind of type given by the Con. + PatternType Con Pattern Type + | -- | Duplicate declarations. + DuplicateDecls (Name Term) + | -- | Duplicate definitions. + DuplicateDefns (Name Term) + | -- | Duplicate type definitions. + DuplicateTyDefns String + | -- | Cyclic type definition. + CyclicTyDef String + | -- | # of patterns does not match type in definition + NumPatterns + | -- | Duplicate variable in a pattern + NonlinearPattern Pattern (Name Term) + | -- | Type can't be quantified over. + NoSearch Type + | -- | The constraint solver couldn't find a solution. + Unsolvable SolveError + | -- | An undefined type name was used. + NotTyDef String + | -- | Wildcards are not allowed in terms. + NoTWild + | -- | Not enough arguments provided to type constructor. + NotEnoughArgs Con + | -- | Too many arguments provided to type constructor. + TooManyArgs Con + | -- | Unbound type variable + UnboundTyVar (Name Type) + | -- | Polymorphic recursion is not allowed + NoPolyRec String [String] [Type] + | -- | Not an error. The identity of the + -- @Monoid TCError@ instance. + NoError + deriving (Show) instance Semigroup TCError where _ <> r = r -- | 'TCError' is a monoid where we simply discard the first error. instance Monoid TCError where - mempty = NoError + mempty = NoError mappend = (<>) ------------------------------------------------------------ @@ -126,14 +144,15 @@ -- | Run a computation and solve its generated constraint, returning -- the resulting substitution (or failing with an error). Note that -- this locally dispatches the constraint writer effect. -solve - :: Members '[Reader TyDefCtx, Error TCError, Output Message] r - => Sem (Writer Constraint ': r) a -> Sem r (a, S) +solve :: + Members '[Reader TyDefCtx, Error TCError, Output (Message ann)] r => + Sem (Writer Constraint ': r) a -> + Sem r (a, S) solve m = do (a, c) <- withConstraint m res <- runSolve . inputToReader . solveConstraint $ c case res of - Left e -> throw (Unsolvable e) + Left e -> throw (Unsolvable e) Right s -> return (a, s) ------------------------------------------------------------ @@ -143,12 +162,14 @@ -- | Look up the definition of a named type. Throw a 'NotTyDef' error -- if it is not found. lookupTyDefn :: - Members '[Reader TyDefCtx, Error TCError] r - => String -> [Type] -> Sem r Type + Members '[Reader TyDefCtx, Error TCError] r => + String -> + [Type] -> + Sem r Type lookupTyDefn x args = do d <- ask @TyDefCtx case M.lookup x d of - Nothing -> throw (NotTyDef x) + Nothing -> throw (NotTyDef x) Just (TyDefBody _ body) -> return $ body args -- | Run a subcomputation with an extended type definition context. diff --git a/src/Disco/Types.hs b/src/Disco/Types.hs --- a/src/Disco/Types.hs +++ b/src/Disco/Types.hs @@ -1,12 +1,16 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE UndecidableInstances #-} - {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + +-- SPDX-License-Identifier: BSD-3-Clause + -- | -- Module : Disco.Types -- Copyright : disco team and contributors @@ -14,104 +18,111 @@ -- -- The "Disco.Types" module defines the set of types used in the disco -- language type system, along with various utility functions. --- ------------------------------------------------------------------------------ - --- SPDX-License-Identifier: BSD-3-Clause - -module Disco.Types - ( - -- * Disco language types - -- ** Atomic types - - BaseTy(..), isCtr, Var(..), Ilk(..), pattern U, pattern S - , Atom(..) - , isVar, isBase, isSkolem - , UAtom(..), uisVar, uatomToAtom, uatomToEither - - -- ** Type constructors - - , Con(..) - , pattern CList, pattern CBag, pattern CSet - - -- ** Types - - , Type(..) - - , pattern TyVar - , pattern TySkolem - , pattern TyVoid - , pattern TyUnit - , pattern TyBool - , pattern TyProp - , pattern TyN - , pattern TyZ - , pattern TyF - , pattern TyQ - , pattern TyC - -- , pattern TyFin - , pattern (:->:) - , pattern (:*:) - , pattern (:+:) - , pattern TyList - , pattern TyBag - , pattern TySet - , pattern TyGraph - , pattern TyMap - , pattern TyContainer - , pattern TyUser - , pattern TyString +module Disco.Types ( + -- * Disco language types - -- ** Quantified types + -- ** Atomic types + BaseTy (..), + isCtr, + Var (..), + Ilk (..), + pattern U, + pattern S, + Atom (..), + isVar, + isBase, + isSkolem, + UAtom (..), + uisVar, + uatomToAtom, + uatomToEither, - , PolyType(..) - , toPolyType, closeType + -- ** Type constructors + Con (..), + pattern CList, + pattern CBag, + pattern CSet, - -- * Type predicates + -- ** Types + Type (..), + pattern TyVar, + pattern TySkolem, + pattern TyVoid, + pattern TyUnit, + pattern TyBool, + pattern TyProp, + pattern TyN, + pattern TyZ, + pattern TyF, + pattern TyQ, + pattern TyC, + -- , pattern TyFin + pattern (:->:), + pattern (:*:), + pattern (:+:), + pattern TyList, + pattern TyBag, + pattern TySet, + pattern TyGraph, + pattern TyMap, + pattern TyContainer, + pattern TyUser, + pattern TyString, - , isNumTy, isEmptyTy, isFiniteTy, isSearchable + -- ** Quantified types + PolyType (..), + toPolyType, + closeType, - -- * Type substitutions + -- * Type predicates + isNumTy, + isEmptyTy, + isFiniteTy, + isSearchable, - , Substitution, atomToTypeSubst, uatomToTypeSubst + -- * Type substitutions + Substitution, + atomToTypeSubst, + uatomToTypeSubst, - -- * Strictness - , Strictness(..), strictness + -- * Strictness + Strictness (..), + strictness, - -- * Utilities - , isTyVar - , containerVars - , countType - , unpair - , S - , TyDefBody(..) - , TyDefCtx + -- * Utilities + isTyVar, + containerVars, + countType, + unpair, + S, + TyDefBody (..), + TyDefCtx, - -- * HasType class - , HasType(..) - ) - where + -- * HasType class + HasType (..), +) +where -import Data.Coerce -import Data.Data (Data) -import Disco.Data () -import GHC.Generics (Generic) -import Unbound.Generics.LocallyNameless hiding (lunbind) +import Data.Coerce +import Data.Data (Data) +import Disco.Data () +import GHC.Generics (Generic) +import Unbound.Generics.LocallyNameless hiding (lunbind) -import Control.Lens (toListOf) -import Data.List (nub) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Set (Set) -import qualified Data.Set as S -import Data.Void -import Math.Combinatorics.Exact.Binomial (choose) +import Control.Lens (toListOf) +import Data.List (nub) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S +import Data.Void +import Math.Combinatorics.Exact.Binomial (choose) -import Disco.Effects.LFresh +import Disco.Effects.LFresh -import Disco.Pretty hiding ((<>)) -import Disco.Subst (Substitution) -import Disco.Types.Qualifiers +import Disco.Pretty hiding ((<>)) +import Disco.Subst (Substitution) +import Disco.Types.Qualifiers -------------------------------------------------- -- Disco types @@ -123,34 +134,24 @@ -- | Base types are the built-in types which form the basis of the -- disco type system, out of which more complex types can be built. data BaseTy where - -- | The void type, with no inhabitants. Void :: BaseTy - -- | The unit type, with one inhabitant. Unit :: BaseTy - -- | Booleans. - B :: BaseTy - + B :: BaseTy -- | Propositions. - P :: BaseTy - + P :: BaseTy -- | Natural numbers. - N :: BaseTy - + N :: BaseTy -- | Integers. - Z :: BaseTy - + Z :: BaseTy -- | Fractionals (i.e. nonnegative rationals). - F :: BaseTy - + F :: BaseTy -- | Rationals. - Q :: BaseTy - + Q :: BaseTy -- | Unicode characters. - C :: BaseTy - + C :: BaseTy -- Finite types. The single argument is a natural number defining -- the exact number of inhabitants. -- Fin :: Integer -> BaseTy @@ -161,29 +162,26 @@ -- particular this allows us to reuse all the existing constraint -- solving machinery for container subtyping. CtrSet :: BaseTy - -- | Bag container type. CtrBag :: BaseTy - -- | List container type. CtrList :: BaseTy - deriving (Show, Eq, Ord, Generic, Data, Alpha, Subst BaseTy, Subst Atom, Subst UAtom, Subst Type) instance Pretty BaseTy where pretty = \case - Void -> text "Void" - Unit -> text "Unit" - B -> text "Bool" - P -> text "Prop" - N -> text "ℕ" - Z -> text "ℤ" - Q -> text "ℚ" - F -> text "𝔽" - C -> text "Char" + Void -> text "Void" + Unit -> text "Unit" + B -> text "Bool" + P -> text "Prop" + N -> text "ℕ" + Z -> text "ℤ" + Q -> text "ℚ" + F -> text "𝔽" + C -> text "Char" CtrList -> text "List" - CtrBag -> text "Bag" - CtrSet -> text "Set" + CtrBag -> text "Bag" + CtrSet -> text "Set" -- | Test whether a 'BaseTy' is a container (set, bag, or list). isCtr :: BaseTy -> Bool @@ -218,7 +216,7 @@ instance Pretty Ilk where pretty = \case - Skolem -> "S" + Skolem -> "S" Unification -> "U" -- | 'Var' represents /type variables/, that is, variables which stand @@ -247,24 +245,24 @@ -- simplification step, we want to be able to work with collections -- of constraints that are guaranteed to contain only atomic types. data Atom where - AVar :: Var -> Atom + AVar :: Var -> Atom ABase :: BaseTy -> Atom deriving (Show, Eq, Ord, Generic, Data, Alpha, Subst Type) instance Subst Atom Atom where isvar (AVar (U x)) = Just (SubstName (coerce x)) - isvar _ = Nothing + isvar _ = Nothing instance Pretty Atom where pretty = \case AVar (U v) -> pretty v AVar (S v) -> text "$" <> pretty v - ABase b -> pretty b + ABase b -> pretty b -- | Is this atomic type a variable? isVar :: Atom -> Bool isVar (AVar _) = True -isVar _ = False +isVar _ = False -- | Is this atomic type a base type? isBase :: Atom -> Bool @@ -273,7 +271,7 @@ -- | Is this atomic type a skolem variable? isSkolem :: Atom -> Bool isSkolem (AVar (S _)) = True -isSkolem _ = False +isSkolem _ = False -- | /Unifiable/ atomic types are the same as atomic types but without -- skolem variables. Hence, a unifiable atomic type is either a base @@ -287,13 +285,13 @@ -- these things, we can just focus on base types and unification -- variables. data UAtom where - UB :: BaseTy -> UAtom + UB :: BaseTy -> UAtom UV :: Name Type -> UAtom deriving (Show, Eq, Ord, Generic, Alpha, Subst BaseTy) instance Subst UAtom UAtom where isvar (UV x) = Just (SubstName (coerce x)) - isvar _ = Nothing + isvar _ = Nothing instance Pretty UAtom where pretty (UB b) = pretty b @@ -302,7 +300,7 @@ -- | Is this unifiable atomic type a (unification) variable? uisVar :: UAtom -> Bool uisVar (UV _) = True -uisVar _ = False +uisVar _ = False -- | Convert a unifiable atomic type into a regular atomic type. uatomToAtom :: UAtom -> Atom @@ -322,12 +320,11 @@ -- argument types. data Con where -- | Function type constructor, @T1 -> T2@. - CArr :: Con + CArr :: Con -- | Product type constructor, @T1 * T2@. CProd :: Con -- | Sum type constructor, @T1 + T2@. - CSum :: Con - + CSum :: Con -- | Container type (list, bag, or set) constructor. Note this -- looks like it could contain any 'Atom', but it will only ever -- contain either a type variable or a 'CtrList', 'CtrBag', or @@ -335,29 +332,24 @@ -- -- See also 'CList', 'CBag', and 'CSet'. CContainer :: Atom -> Con - - -- | Key value maps, Map k v CMap :: Con - -- | Graph constructor, Graph a CGraph :: Con - -- | The name of a user defined algebraic datatype. CUser :: String -> Con - deriving (Show, Eq, Ord, Generic, Data, Alpha) instance Pretty Con where pretty = \case - CMap -> text "Map" - CGraph -> text "Graph" - CUser s -> text s - CList -> text "List" - CBag -> text "Bag" - CSet -> text "Set" + CMap -> text "Map" + CGraph -> text "Graph" + CUser s -> text s + CList -> text "List" + CBag -> text "Bag" + CSet -> text "Set" CContainer v -> pretty v - c -> error $ "Impossible: got Con " ++ show c ++ " in pretty @Con" + c -> error $ "Impossible: got Con " ++ show c ++ " in pretty @Con" -- | 'CList' is provided for convenience; it represents a list type -- constructor (/i.e./ @List a@). @@ -395,49 +387,49 @@ -- pattern-match on types when convenient. For example, using these -- synonyms the foregoing example can be written @TyN :->: TyVar a@. data Type where - -- | Atomic types (variables and base types), /e.g./ @N@, @Bool@, /etc./ TyAtom :: Atom -> Type - -- | Application of a type constructor to type arguments, /e.g./ @N -- -> Bool@ is the application of the arrow type constructor to the -- arguments @N@ and @Bool@. - TyCon :: Con -> [Type] -> Type - + TyCon :: Con -> [Type] -> Type deriving (Show, Eq, Ord, Generic, Data, Alpha) instance Pretty Type where - pretty (TyAtom a) = pretty a - pretty (ty1 :->: ty2) = withPA tarrPA $ - lt (pretty ty1) <+> text "→" <+> rt (pretty ty2) - pretty (ty1 :*: ty2) = withPA tmulPA $ - lt (pretty ty1) <+> text "×" <+> rt (pretty ty2) - pretty (ty1 :+: ty2) = withPA taddPA $ - lt (pretty ty1) <+> text "+" <+> rt (pretty ty2) - pretty (TyCon c []) = pretty c - pretty (TyCon c tys) = do + pretty (TyAtom a) = pretty a + pretty (ty1 :->: ty2) = + withPA tarrPA $ + lt (pretty ty1) <+> text "→" <+> rt (pretty ty2) + pretty (ty1 :*: ty2) = + withPA tmulPA $ + lt (pretty ty1) <+> text "×" <+> rt (pretty ty2) + pretty (ty1 :+: ty2) = + withPA taddPA $ + lt (pretty ty1) <+> text "+" <+> rt (pretty ty2) + pretty (TyCon c []) = pretty c + pretty (TyCon c tys) = do ds <- setPA initPA $ punctuate (text ",") (map pretty tys) pretty c <> parens (hsep ds) instance Subst Type Qualifier instance Subst Type Rational where subst _ _ = id - substs _ = id + substs _ = id instance Subst Type Void where subst _ _ = id - substs _ = id + substs _ = id instance Subst Type Con where - isCoerceVar (CContainer (AVar (U x))) - = Just (SubstCoerce x substCtrTy) - where - substCtrTy (TyAtom a) = Just (CContainer a) - substCtrTy _ = Nothing - isCoerceVar _ = Nothing + isCoerceVar (CContainer (AVar (U x))) = + Just (SubstCoerce x substCtrTy) + where + substCtrTy (TyAtom a) = Just (CContainer a) + substCtrTy _ = Nothing + isCoerceVar _ = Nothing instance Subst Type Type where isvar (TyAtom (AVar (U x))) = Just (SubstName x) - isvar _ = Nothing + isvar _ = Nothing -pattern TyVar :: Name Type -> Type +pattern TyVar :: Name Type -> Type pattern TyVar v = TyAtom (AVar (U v)) pattern TySkolem :: Name Type -> Type @@ -470,7 +462,6 @@ pattern TyC :: Type pattern TyC = TyAtom (ABase C) - -- pattern TyFin :: Integer -> Type -- pattern TyFin n = TyAtom (ABase (Fin n)) @@ -492,7 +483,7 @@ pattern TyList :: Type -> Type pattern TyList elTy = TyCon CList [elTy] -pattern TyBag :: Type -> Type +pattern TyBag :: Type -> Type pattern TyBag elTy = TyCon CBag [elTy] pattern TySet :: Type -> Type @@ -515,21 +506,40 @@ pattern TyString = TyList TyC {-# COMPLETE - TyVar, TySkolem, TyVoid, TyUnit, TyBool, TyProp, TyN, TyZ, TyF, TyQ, TyC, - (:->:), (:*:), (:+:), TyList, TyBag, TySet, TyGraph, TyMap, TyUser #-} + TyVar + , TySkolem + , TyVoid + , TyUnit + , TyBool + , TyProp + , TyN + , TyZ + , TyF + , TyQ + , TyC + , (:->:) + , (:*:) + , (:+:) + , TyList + , TyBag + , TySet + , TyGraph + , TyMap + , TyUser + #-} -- | Is this a type variable? isTyVar :: Type -> Bool isTyVar (TyAtom (AVar _)) = True -isTyVar _ = False +isTyVar _ = False -- orphans instance (Ord a, Subst t a) => Subst t (Set a) where subst x t = S.map (subst x t) - substs s = S.map (substs s) + substs s = S.map (substs s) instance (Ord k, Subst t a) => Subst t (Map k a) where subst x t = M.map (subst x t) - substs s = M.map (substs s) + substs s = M.map (substs s) -- | The definition of a user-defined type contains: -- @@ -555,14 +565,13 @@ -- | Pretty-print a type definition. instance Pretty (String, TyDefBody) where - - pretty (tyName, TyDefBody ps body) - = "type" <+> (text tyName <> prettyArgs ps) <+> text "=" <+> pretty (body (map (TyVar . string2Name) ps)) - where - prettyArgs [] = empty - prettyArgs _ = do - ds <- punctuate (text ",") (map text ps) - parens (hsep ds) + pretty (tyName, TyDefBody ps body) = + "type" <+> (text tyName <> prettyArgs ps) <+> text "=" <+> pretty (body (map (TyVar . string2Name) ps)) + where + prettyArgs [] = empty + prettyArgs _ = do + ds <- punctuate (text ",") (map text ps) + parens (hsep ds) --------------------------------- -- Universally quantified types @@ -597,52 +606,50 @@ -- | Compute the number of inhabitants of a type. @Nothing@ means the -- type is countably infinite. countType :: Type -> Maybe Integer -countType TyVoid = Just 0 -countType TyUnit = Just 1 -countType TyBool = Just 2 +countType TyVoid = Just 0 +countType TyUnit = Just 1 +countType TyBool = Just 2 -- countType (TyFin n) = Just n -countType TyC = Just (17 * 2^(16 :: Integer)) +countType TyC = Just (17 * 2 ^ (16 :: Integer)) countType (ty1 :+: ty2) = (+) <$> countType ty1 <*> countType ty2 countType (ty1 :*: ty2) - | isEmptyTy ty1 = Just 0 - | isEmptyTy ty2 = Just 0 - | otherwise = (*) <$> countType ty1 <*> countType ty2 + | isEmptyTy ty1 = Just 0 + | isEmptyTy ty2 = Just 0 + | otherwise = (*) <$> countType ty1 <*> countType ty2 countType (ty1 :->: ty2) = case (countType ty1, countType ty2) of (Just 0, _) -> Just 1 (_, Just 0) -> Just 0 (_, Just 1) -> Just 1 - (c1, c2) -> (^) <$> c2 <*> c1 + (c1, c2) -> (^) <$> c2 <*> c1 countType (TyList ty) - | isEmptyTy ty = Just 1 - | otherwise = Nothing + | isEmptyTy ty = Just 1 + | otherwise = Nothing countType (TyBag ty) - | isEmptyTy ty = Just 1 - | otherwise = Nothing -countType (TySet ty) = (2^) <$> countType ty - - -- t = number of elements in vertex type. - -- n = number of vertices in the graph. - -- For each n in [0..t], we can choose which n values to use for the - -- vertices; then for each ordered pair of vertices (u,v) - -- (including the possibility that u = v), we choose whether or - -- not there is a directed edge u -> v. - -- - -- https://oeis.org/A135748 - -countType (TyGraph ty) = - (\t -> sum $ map (\n -> (t `choose` n) * 2^(n*n)) [0 .. t]) <$> - countType ty + | isEmptyTy ty = Just 1 + | otherwise = Nothing +countType (TySet ty) = (2 ^) <$> countType ty +-- t = number of elements in vertex type. +-- n = number of vertices in the graph. +-- For each n in [0..t], we can choose which n values to use for the +-- vertices; then for each ordered pair of vertices (u,v) +-- (including the possibility that u = v), we choose whether or +-- not there is a directed edge u -> v. +-- +-- https://oeis.org/A135748 +countType (TyGraph ty) = + (\t -> sum $ map (\n -> (t `choose` n) * 2 ^ (n * n)) [0 .. t]) + <$> countType ty countType (TyMap tyKey tyValue) - | isEmptyTy tyKey = Just 1 -- If we can't have any keys or values, - | isEmptyTy tyValue = Just 1 -- only option is empty map - | otherwise = (\k v -> (v+1) ^ k) <$> countType tyKey <*> countType tyValue - -- (v+1)^k since for each key, we can choose among v values to associate with it, - -- or we can choose to not have the key in the map. + | isEmptyTy tyKey = Just 1 -- If we can't have any keys or values, + | isEmptyTy tyValue = Just 1 -- only option is empty map + | otherwise = (\k v -> (v + 1) ^ k) <$> countType tyKey <*> countType tyValue +-- (v+1)^k since for each key, we can choose among v values to associate with it, +-- or we can choose to not have the key in the map. -- All other types are infinite. (TyN, TyZ, TyQ, TyF) -countType _ = Nothing +countType _ = Nothing -------------------------------------------------- -- Type predicates @@ -651,19 +658,19 @@ -- | Check whether a type is a numeric type (@N@, @Z@, @F@, @Q@, or @Zn@). isNumTy :: Type -> Bool -- isNumTy (TyFin _) = True -isNumTy ty = ty `elem` [TyN, TyZ, TyF, TyQ] +isNumTy ty = ty `elem` [TyN, TyZ, TyF, TyQ] -- | Decide whether a type is empty, /i.e./ uninhabited. isEmptyTy :: Type -> Bool isEmptyTy ty | Just 0 <- countType ty = True - | otherwise = False + | otherwise = False -- | Decide whether a type is finite. isFiniteTy :: Type -> Bool isFiniteTy ty | Just _ <- countType ty = True - | otherwise = False + | otherwise = False -- XXX coinductively check whether user-defined types are searchable -- e.g. L = Unit + N * L ought to be searchable. @@ -671,16 +678,16 @@ -- | Decide whether a type is searchable, i.e. effectively enumerable. isSearchable :: Type -> Bool -isSearchable TyProp = False +isSearchable TyProp = False isSearchable ty - | isNumTy ty = True - | isFiniteTy ty = True -isSearchable (TyList ty) = isSearchable ty -isSearchable (TySet ty) = isSearchable ty -isSearchable (ty1 :+: ty2) = isSearchable ty1 && isSearchable ty2 -isSearchable (ty1 :*: ty2) = isSearchable ty1 && isSearchable ty2 + | isNumTy ty = True + | isFiniteTy ty = True +isSearchable (TyList ty) = isSearchable ty +isSearchable (TySet ty) = isSearchable ty +isSearchable (ty1 :+: ty2) = isSearchable ty1 && isSearchable ty2 +isSearchable (ty1 :*: ty2) = isSearchable ty1 && isSearchable ty2 isSearchable (ty1 :->: ty2) = isFiniteTy ty1 && isSearchable ty2 -isSearchable _ = False +isSearchable _ = False -------------------------------------------------- -- Strictness @@ -695,7 +702,7 @@ strictness :: Type -> Strictness strictness ty | isNumTy ty = Strict - | otherwise = Lazy + | otherwise = Lazy -------------------------------------------------- -- Utilities @@ -705,7 +712,7 @@ -- types. unpair :: Type -> [Type] unpair (ty1 :*: ty2) = ty1 : unpair ty2 -unpair ty = [ty] +unpair ty = [ty] -- | Define @S@ as a substitution on types (the most common kind) -- for convenience. @@ -722,8 +729,8 @@ -- | Return a set of all the free container variables in a type. containerVars :: Type -> Set (Name Type) -containerVars (TyCon (CContainer (AVar (U x))) tys) - = x `S.insert` foldMap containerVars tys +containerVars (TyCon (CContainer (AVar (U x))) tys) = + x `S.insert` foldMap containerVars tys containerVars (TyCon _ tys) = foldMap containerVars tys containerVars _ = S.empty @@ -733,7 +740,6 @@ -- | A type class for things whose type can be extracted or set. class HasType t where - -- | Get the type of a thing. getType :: t -> Type @@ -741,40 +747,3 @@ -- implementation is for 'setType' to do nothing. setType :: Type -> t -> t setType _ = id - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/src/Disco/Types/Qualifiers.hs b/src/Disco/Types/Qualifiers.hs --- a/src/Disco/Types/Qualifiers.hs +++ b/src/Disco/Types/Qualifiers.hs @@ -1,28 +1,28 @@ -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + +-- SPDX-License-Identifier: BSD-3-Clause + -- | -- Module : Disco.Types.Qualifiers -- Copyright : disco team and contributors -- Maintainer : byorgey@gmail.com -- -- Type qualifiers and sorts. --- ------------------------------------------------------------------------------ - --- SPDX-License-Identifier: BSD-3-Clause - module Disco.Types.Qualifiers where -import GHC.Generics -import Unbound.Generics.LocallyNameless +import GHC.Generics +import Unbound.Generics.LocallyNameless -import Data.Set (Set) -import qualified Data.Set as S +import Data.Set (Set) +import qualified Data.Set as S -import Disco.Pretty -import Disco.Syntax.Operators +import Disco.Pretty +import Disco.Syntax.Operators ------------------------------------------------------------ -- Qualifiers @@ -44,25 +44,33 @@ -- These qualifiers can appear in a 'CQual' constraint; see -- "Disco.Typecheck.Constraint". data Qualifier - = QNum -- ^ Numeric, i.e. a semiring supporting + and * - | QSub -- ^ Subtractive, i.e. supports - - | QDiv -- ^ Divisive, i.e. supports / - | QCmp -- ^ Comparable, i.e. supports decidable ordering/comparison (see Note [QCmp]) - | QEnum -- ^ Enumerable, i.e. supports ellipsis notation [x .. y] - | QBool -- ^ Boolean, i.e. supports and, or, not (Bool or Prop) - | QBasic -- ^ Things that do not involve Prop. - | QSimple -- ^ Things for which we can derive a *Haskell* Ord instance + = -- | Numeric, i.e. a semiring supporting + and * + QNum + | -- | Subtractive, i.e. supports - + QSub + | -- | Divisive, i.e. supports / + QDiv + | -- | Comparable, i.e. supports decidable ordering/comparison (see Note [QCmp]) + QCmp + | -- | Enumerable, i.e. supports ellipsis notation [x .. y] + QEnum + | -- | Boolean, i.e. supports and, or, not (Bool or Prop) + QBool + | -- | Things that do not involve Prop. + QBasic + | -- | Things for which we can derive a *Haskell* Ord instance + QSimple deriving (Show, Eq, Ord, Generic, Alpha) instance Pretty Qualifier where pretty = \case - QNum -> "num" - QSub -> "sub" - QDiv -> "div" - QCmp -> "cmp" - QEnum -> "enum" - QBool -> "bool" - QBasic -> "basic" + QNum -> "num" + QSub -> "sub" + QDiv -> "div" + QCmp -> "cmp" + QEnum -> "enum" + QBool -> "bool" + QBasic -> "basic" QSimple -> "simple" -- ~~~~ Note [QCmp] @@ -71,7 +79,9 @@ -- comparisons at runtime any more, if we disallow functions from -- being QCmp. With the switch to eager semantics + disallowing -- function comparison, it's now the case that QCmp should mean --- *decidable* (terminating) comparison. + +-- * decidable* (terminating) comparison. + -- -- It used to be the case that every type in disco supported -- (semi-decidable) linear ordering, so in one sense the QCmp @@ -93,15 +103,16 @@ -- | A helper function that returns the appropriate qualifier for a -- binary arithmetic operation. bopQual :: BOp -> Qualifier -bopQual Add = QNum -bopQual Mul = QNum -bopQual Div = QDiv -bopQual Sub = QSub +bopQual Add = QNum +bopQual Mul = QNum +bopQual Div = QDiv +bopQual Sub = QSub bopQual SSub = QNum --- bopQual And = QBool --- bopQual Or = QBool --- bopQual Impl = QBool -bopQual _ = error "No qualifier for binary operation" +bopQual And = QBool +bopQual Or = QBool +bopQual Impl = QBool +bopQual Iff = QBool +bopQual _ = error "No qualifier for binary operation" ------------------------------------------------------------ -- Sorts diff --git a/src/Disco/Types/Rules.hs b/src/Disco/Types/Rules.hs --- a/src/Disco/Types/Rules.hs +++ b/src/Disco/Types/Rules.hs @@ -1,4 +1,9 @@ ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + +-- SPDX-License-Identifier: BSD-3-Clause + -- | -- Module : Disco.Types.Rules -- Copyright : disco team and contributors @@ -6,45 +11,46 @@ -- -- "Disco.Types.Rules" defines some generic rules about arity, -- subtyping, and sorts for disco base types. --- ------------------------------------------------------------------------------ - --- SPDX-License-Identifier: BSD-3-Clause - -module Disco.Types.Rules - ( -- * Arity - - Variance(..), arity - - -- * Qualifiers - , Qualifier(..), bopQual - - -- * Sorts - , Sort, topSort - - -- * Subtyping rules +module Disco.Types.Rules ( + -- * Arity + Variance (..), + arity, - , Dir(..), other + -- * Qualifiers + Qualifier (..), + bopQual, - , isSubA, isSubB, isDirB - , supertypes, subtypes, dirtypes + -- * Sorts + Sort, + topSort, - -- * Qualifier and sort rules + -- * Subtyping rules + Dir (..), + other, + isSubA, + isSubB, + isDirB, + supertypes, + subtypes, + dirtypes, - , hasQual, hasSort - , qualRules, sortRules - , pickSortBaseTy - ) - where + -- * Qualifier and sort rules + hasQual, + hasSort, + qualRules, + sortRules, + pickSortBaseTy, +) +where -import Control.Monad ((>=>)) -import Data.List (foldl') -import Data.Map (Map) -import qualified Data.Map as M -import qualified Data.Set as S +import Control.Monad ((>=>)) +import Data.List (foldl') +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Set as S -import Disco.Types -import Disco.Types.Qualifiers +import Disco.Types +import Disco.Types.Qualifiers ------------------------------------------------------------ -- Arity @@ -65,16 +71,17 @@ -- That is, @S1 -> T1 <: S2 -> T2@ (@<:@ means "is a subtype of") if -- and only if @S2 <: S1@ and @T1 <: T2@. arity :: Con -> [Variance] -arity CArr = [Contra, Co] -arity CProd = [Co, Co] -arity CSum = [Co, Co] +arity CArr = [Contra, Co] +arity CProd = [Co, Co] +arity CSum = [Co, Co] arity (CContainer _) = [Co] -arity CMap = [Contra, Co] -arity CGraph = [Co] -arity (CUser _) = error "Impossible! arity CUser" - -- CUsers should always be replaced by their definitions before arity - -- is called. +arity CMap = [Contra, Co] +arity CGraph = [Co] +arity (CUser _) = error "Impossible! arity CUser" +-- CUsers should always be replaced by their definitions before arity +-- is called. + ------------------------------------------------------------ -- Subtyping rules ------------------------------------------------------------ @@ -86,7 +93,7 @@ -- | Swap directions. other :: Dir -> Dir -other SubTy = SuperTy +other SubTy = SuperTy other SuperTy = SubTy -------------------------------------------------- @@ -96,45 +103,45 @@ -- @True@ if either they are equal, or if they are base types and -- 'isSubB' returns true. isSubA :: Atom -> Atom -> Bool -isSubA a1 a2 | a1 == a2 = True +isSubA a1 a2 | a1 == a2 = True isSubA (ABase t1) (ABase t2) = isSubB t1 t2 -isSubA _ _ = False +isSubA _ _ = False -- | Check whether one base type is a subtype of another. isSubB :: BaseTy -> BaseTy -> Bool isSubB b1 b2 | b1 == b2 = True -isSubB N Z = True -isSubB N F = True -isSubB N Q = True -isSubB Z Q = True -isSubB F Q = True -isSubB B P = True -isSubB _ _ = False +isSubB N Z = True +isSubB N F = True +isSubB N Q = True +isSubB Z Q = True +isSubB F Q = True +isSubB B P = True +isSubB _ _ = False -- | Check whether one base type is a sub- or supertype of another. isDirB :: Dir -> BaseTy -> BaseTy -> Bool -isDirB SubTy b1 b2 = isSubB b1 b2 +isDirB SubTy b1 b2 = isSubB b1 b2 isDirB SuperTy b1 b2 = isSubB b2 b1 -- | List all the supertypes of a given base type. supertypes :: BaseTy -> [BaseTy] -supertypes N = [N, Z, F, Q] -supertypes Z = [Z, Q] -supertypes F = [F, Q] -supertypes B = [B, P] +supertypes N = [N, Z, F, Q] +supertypes Z = [Z, Q] +supertypes F = [F, Q] +supertypes B = [B, P] supertypes ty = [ty] -- | List all the subtypes of a given base type. subtypes :: BaseTy -> [BaseTy] -subtypes Q = [Q, F, Z, N] -subtypes F = [F, N] -subtypes Z = [Z, N] -subtypes P = [P, B] +subtypes Q = [Q, F, Z, N] +subtypes F = [F, N] +subtypes Z = [Z, N] +subtypes P = [P, B] subtypes ty = [ty] -- | List all the sub- or supertypes of a given base type. dirtypes :: Dir -> BaseTy -> [BaseTy] -dirtypes SubTy = subtypes +dirtypes SubTy = subtypes dirtypes SuperTy = supertypes ------------------------------------------------------------ @@ -143,19 +150,19 @@ -- | Check whether a given base type satisfies a qualifier. hasQual :: BaseTy -> Qualifier -> Bool -hasQual P QCmp = False -- can't compare Props -hasQual _ QCmp = True -hasQual P QBasic = False -hasQual _ QBasic = True -hasQual P QSimple = False -hasQual _ QSimple = True +hasQual P QCmp = False -- can't compare Props +hasQual _ QCmp = True +hasQual P QBasic = False +hasQual _ QBasic = True +hasQual P QSimple = False +hasQual _ QSimple = True -- hasQual (Fin _) q | q `elem` [QNum, QSub, QEnum] = True -- hasQual (Fin n) QDiv = isPrime n -hasQual b QNum = b `elem` [N, Z, F, Q] -hasQual b QSub = b `elem` [Z, Q] -hasQual b QDiv = b `elem` [F, Q] -hasQual b QEnum = b `elem` [N, Z, F, Q, C] -hasQual b QBool = b `elem` [B, P] +hasQual b QNum = b `elem` [N, Z, F, Q] +hasQual b QSub = b `elem` [Z, Q] +hasQual b QDiv = b `elem` [F, Q] +hasQual b QEnum = b `elem` [N, Z, F, Q, C] +hasQual b QBool = b `elem` [B, P] -- | Check whether a base type has a certain sort, which simply -- amounts to whether it satisfies every qualifier in the sort. @@ -177,57 +184,65 @@ -- set of qualifiers (i.e. a general sort) on a type argument. In -- that case one would just have to encode 'sortRules' directly. qualRulesMap :: Map Con (Map Qualifier [Maybe Qualifier]) -qualRulesMap = M.fromList - [ CProd ==> M.fromList - [ QCmp ==> [Just QCmp, Just QCmp], - QSimple ==> [Just QSimple, Just QSimple] - ] - , CSum ==> M.fromList - [ QCmp ==> [Just QCmp, Just QCmp], - QSimple ==> [Just QSimple, Just QSimple] - ] - , CList ==> M.fromList - [ QCmp ==> [Just QCmp], - QSimple ==> [Just QSimple] - ] - , CBag ==> M.fromList - [ QCmp ==> [Just QCmp], - QSimple ==> [Just QSimple] - ] - , CSet ==> M.fromList - [ QCmp ==> [Just QCmp], - QSimple ==> [Just QSimple] - ] - , CGraph ==> M.fromList - [ QCmp ==> [Just QCmp], - QNum ==> [Nothing] - ] - , CMap ==> M.fromList - [ QCmp ==> [Just QCmp, Just QCmp] +qualRulesMap = + M.fromList + [ CProd + ==> M.fromList + [ QCmp ==> [Just QCmp, Just QCmp] + , QSimple ==> [Just QSimple, Just QSimple] + ] + , CSum + ==> M.fromList + [ QCmp ==> [Just QCmp, Just QCmp] + , QSimple ==> [Just QSimple, Just QSimple] + ] + , CList + ==> M.fromList + [ QCmp ==> [Just QCmp] + , QSimple ==> [Just QSimple] + ] + , CBag + ==> M.fromList + [ QCmp ==> [Just QCmp] + , QSimple ==> [Just QSimple] + ] + , CSet + ==> M.fromList + [ QCmp ==> [Just QCmp] + , QSimple ==> [Just QSimple] + ] + , CGraph + ==> M.fromList + [ QCmp ==> [Just QCmp] + , QNum ==> [Nothing] + ] + , CMap + ==> M.fromList + [ QCmp ==> [Just QCmp, Just QCmp] + ] ] - ] - where - (==>) :: a -> b -> (a,b) - (==>) = (,) + where + (==>) :: a -> b -> (a, b) + (==>) = (,) - -- We could (theoretically) make graphs and maps also be simple values if we require the map's values are also simple. +-- We could (theoretically) make graphs and maps also be simple values if we require the map's values are also simple. - -- Eventually we can easily imagine adding an opt-in mode where - -- numeric operations can be used on pairs and functions, then the - -- qualRules would become dependent on what language extension/mode - -- was chosen. For example we could have rules like - -- - -- [ CArr ==> M.fromList - -- [ QNum ==> [Nothing, Just QNum] -- (a -> b) can be +, * iff b can - -- , QSub ==> [Nothing, Just QSub] -- ditto for subtraction - -- , QDiv ==> [Nothing, Just QDiv] -- and division - -- ] - -- , CProd ==> M.fromList - -- [ QNum ==> [Just QNum, Just QNum] -- (a,b) can be +, * iff a and b can - -- , QSub ==> [Just QSub, Just QSub] -- etc. - -- , QDiv ==> [Just QDiv, Just QDiv] - -- ] - -- ] +-- Eventually we can easily imagine adding an opt-in mode where +-- numeric operations can be used on pairs and functions, then the +-- qualRules would become dependent on what language extension/mode +-- was chosen. For example we could have rules like +-- +-- [ CArr ==> M.fromList +-- [ QNum ==> [Nothing, Just QNum] -- (a -> b) can be +, * iff b can +-- , QSub ==> [Nothing, Just QSub] -- ditto for subtraction +-- , QDiv ==> [Nothing, Just QDiv] -- and division +-- ] +-- , CProd ==> M.fromList +-- [ QNum ==> [Just QNum, Just QNum] -- (a,b) can be +, * iff a and b can +-- , QSub ==> [Just QSub, Just QSub] -- etc. +-- , QDiv ==> [Just QDiv, Just QDiv] +-- ] +-- ] -- | Given a constructor T and a qualifier we want to hold of a type T -- t1 t2 ..., return a list of qualifiers that need to hold of t1, @@ -236,7 +251,7 @@ -- T t1 t2 ... is basic (contains no Prop) iff t1, t2 ... all are. qualRules c QBasic = Just (map (const (Just QBasic)) (arity c)) -- Otherwise, just look up in the qualRulesMap. -qualRules c q = (M.lookup c >=> M.lookup q) qualRulesMap +qualRules c q = (M.lookup c >=> M.lookup q) qualRulesMap -- | @sortRules T s = [s1, ..., sn]@ means that sort @s@ holds of -- type @(T t1 ... tn)@ if and only if @s1 t1 /\ ... /\ sn tn@. @@ -259,12 +274,12 @@ -- | Pick a base type (generally the "simplest") that satisfies a given sort. pickSortBaseTy :: Sort -> BaseTy pickSortBaseTy s - | QDiv `S.member` s && QSub `S.member` s = Q - | QDiv `S.member` s = F - | QSub `S.member` s = Z - | QNum `S.member` s = N - | QCmp `S.member` s = N - | QEnum `S.member` s = N - | QBool `S.member` s = B + | QDiv `S.member` s && QSub `S.member` s = Q + | QDiv `S.member` s = F + | QSub `S.member` s = Z + | QNum `S.member` s = N + | QCmp `S.member` s = N + | QEnum `S.member` s = N + | QBool `S.member` s = B | QSimple `S.member` s = N - | otherwise = Unit + | otherwise = Unit diff --git a/src/Disco/Util.hs b/src/Disco/Util.hs --- a/src/Disco/Util.hs +++ b/src/Disco/Util.hs @@ -1,4 +1,7 @@ ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Disco.Util -- Copyright : disco team and contributors @@ -7,9 +10,6 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- Miscellaneous utilities. --- ------------------------------------------------------------------------------ - module Disco.Util where import qualified Data.Map as M @@ -18,7 +18,7 @@ -- | A synonym for pairing which makes convenient syntax for -- constructing literal maps via M.fromList. -(==>) :: a -> b -> (a,b) +(==>) :: a -> b -> (a, b) (==>) = (,) for :: [a] -> (a -> b) -> [b] @@ -27,4 +27,4 @@ (!) :: (Show k, Ord k) => M.Map k v -> k -> v m ! k = case M.lookup k m of Nothing -> error $ "key " ++ show k ++ " is not an element in the map" - Just v -> v + Just v -> v diff --git a/src/Disco/Value.hs b/src/Disco/Value.hs --- a/src/Disco/Value.hs +++ b/src/Disco/Value.hs @@ -1,10 +1,13 @@ -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Disco.Value -- Copyright : disco team and contributors @@ -13,75 +16,94 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- Disco runtime values and environments. --- ------------------------------------------------------------------------------ - -module Disco.Value - ( -- * Values - - Value(.., VNil, VCons, VFun) - , SimpleValue(..) - , toSimpleValue, fromSimpleValue - - -- ** Conversion +module Disco.Value ( + -- * Values + Value (.., VNil, VCons, VFun), + SimpleValue (..), + toSimpleValue, + fromSimpleValue, - , ratv, vrat - , intv, vint - , charv, vchar - , enumv - , pairv, vpair - , listv, vlist + -- ** Conversion + ratv, + vrat, + intv, + vint, + charv, + vchar, + enumv, + pairv, + vpair, + listv, + vlist, - -- * Props & testing - , ValProp(..), TestResult(..), TestReason_(..), TestReason - , SearchType(..), SearchMotive(.., SMExists, SMForall) - , TestVars(..), TestEnv(..), emptyTestEnv, getTestEnv, extendPropEnv, extendResultEnv - , testIsOk, testIsError, testReason, testEnv + -- * Props & testing + ValProp (..), + TestResult (..), + TestReason_ (..), + TestReason, + SearchType (..), + SearchMotive (.., SMExists, SMForall), + TestVars (..), + TestEnv (..), + emptyTestEnv, + getTestEnv, + extendPropEnv, + extendResultEnv, + testIsOk, + testIsError, + testReason, + testEnv, + resultIsCertain, + LOp (..), + interpLOp, -- * Environments - - , Env + Env, -- * Memory - , Cell(..), Mem, emptyMem, allocate, allocateRec, lkup, set + Cell (..), + Mem, + emptyMem, + allocate, + allocateRec, + lkup, + set, -- * Pretty-printing - - , prettyValue', prettyValue, prettyTestFailure, prettyTestResult - ) where + prettyValue', + prettyValue, +) where -import Prelude hiding ((<>)) -import qualified Prelude as P +import Prelude hiding ((<>)) +import qualified Prelude as P -import Control.Monad (forM) -import Data.Bifunctor (first) -import Data.Char (chr, ord, toLower) -import Data.IntMap (IntMap) -import qualified Data.IntMap as IM -import Data.List (foldl') -import Data.Map (Map) -import qualified Data.Map as M -import Data.Ratio +import Control.Monad (forM) +import Data.Bifunctor (first) +import Data.Char (chr, ord, toLower) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IM +import Data.List (foldl') +import Data.Map (Map) +import qualified Data.Map as M +import Data.Ratio -import Algebra.Graph (Graph, foldg) +import Algebra.Graph (Graph, foldg) -import Disco.AST.Core -import Disco.AST.Generic (Side (..)) -import Disco.AST.Typed (AProperty) -import Disco.Context as Ctx -import Disco.Error -import Disco.Names -import Disco.Pretty -import Disco.Syntax.Operators (BOp (Add, Mul)) -import Disco.Typecheck.Erase (eraseProperty) -import Disco.Types +import Disco.AST.Core +import Disco.AST.Generic (Side (..)) +import Disco.Context as Ctx +import Disco.Error +import Disco.Names +import Disco.Pretty +import Disco.Syntax.Operators (BOp (Add, Mul)) +import Disco.Types -import Disco.Effects.LFresh -import Polysemy -import Polysemy.Input -import Polysemy.Reader -import Polysemy.State -import Unbound.Generics.LocallyNameless (Name) +import Disco.Effects.LFresh +import Polysemy +import Polysemy.Input +import Polysemy.Reader +import Polysemy.State +import Unbound.Generics.LocallyNameless (Name) ------------------------------------------------------------ -- Value type @@ -90,37 +112,28 @@ -- | Different types of values which can result from the evaluation -- process. data Value where - -- | A numeric value, which also carries a flag saying how -- fractional values should be diplayed. - VNum :: RationalDisplay -> Rational -> Value - + VNum :: RationalDisplay -> Rational -> Value -- | A built-in function constant. - VConst :: Op -> Value - + VConst :: Op -> Value -- | An injection into a sum type. - VInj :: Side -> Value -> Value - + VInj :: Side -> Value -> Value -- | The unit value. - VUnit :: Value - + VUnit :: Value -- | A pair of values. - VPair :: Value -> Value -> Value - + VPair :: Value -> Value -> Value -- | A closure, i.e. a function body together with its -- environment. - VClo :: Env -> [Name Core] -> Core -> Value - + VClo :: Env -> [Name Core] -> Core -> Value -- | A disco type can be a value. For now, there are only a very -- limited number of places this could ever show up (in -- particular, as an argument to @enumerate@ or @count@). - VType :: Type -> Value - + VType :: Type -> Value -- | A reference, i.e. a pointer to a memory cell. This is used to -- implement (optional, user-requested) laziness as well as -- recursion. - VRef :: Int -> Value - + VRef :: Int -> Value -- | A literal function value. @VFun@ is only used when -- enumerating function values in order to decide comparisons at -- higher-order function types. For example, in order to @@ -131,30 +144,25 @@ -- We assume that all @VFun@ values are /strict/, that is, their -- arguments should be fully evaluated to RNF before being -- passed to the function. - VFun_ :: ValFun -> Value - + VFun_ :: ValFun -> Value -- | A proposition. - VProp :: ValProp -> Value - + VProp :: ValProp -> Value -- | A literal bag, containing a finite list of (perhaps only -- partially evaluated) values, each paired with a count. This is -- also used to represent sets (with the invariant that all counts -- are equal to 1). VBag :: [(Value, Integer)] -> Value - -- | A graph, stored using an algebraic repesentation. VGraph :: Graph SimpleValue -> Value - -- | A map from keys to values. Differs from functions because we can -- actually construct the set of entries, while functions only have this -- property when the key type is finite. VMap :: Map SimpleValue Value -> Value - - deriving Show + deriving (Show) -- | Convenient pattern for the empty list. pattern VNil :: Value -pattern VNil = VInj L VUnit +pattern VNil = VInj L VUnit -- | Convenient pattern for list cons. pattern VCons :: Value -> Value -> Value @@ -170,31 +178,31 @@ -- only reason for actually doing this would be constructing graphs -- of graphs or maps of maps, or the like. data SimpleValue where - SNum :: RationalDisplay -> Rational -> SimpleValue - SUnit :: SimpleValue - SInj :: Side -> SimpleValue -> SimpleValue - SPair :: SimpleValue -> SimpleValue -> SimpleValue - SBag :: [(SimpleValue, Integer)] -> SimpleValue - SType :: Type -> SimpleValue + SNum :: RationalDisplay -> Rational -> SimpleValue + SUnit :: SimpleValue + SInj :: Side -> SimpleValue -> SimpleValue + SPair :: SimpleValue -> SimpleValue -> SimpleValue + SBag :: [(SimpleValue, Integer)] -> SimpleValue + SType :: Type -> SimpleValue deriving (Show, Eq, Ord) toSimpleValue :: Value -> SimpleValue toSimpleValue = \case - VNum d n -> SNum d n - VUnit -> SUnit - VInj s v1 -> SInj s (toSimpleValue v1) + VNum d n -> SNum d n + VUnit -> SUnit + VInj s v1 -> SInj s (toSimpleValue v1) VPair v1 v2 -> SPair (toSimpleValue v1) (toSimpleValue v2) - VBag bs -> SBag (map (first toSimpleValue) bs) - VType t -> SType t - t -> error $ "A non-simple value was passed as simple: " ++ show t + VBag bs -> SBag (map (first toSimpleValue) bs) + VType t -> SType t + t -> error $ "A non-simple value was passed as simple: " ++ show t fromSimpleValue :: SimpleValue -> Value -fromSimpleValue (SNum d n) = VNum d n -fromSimpleValue SUnit = VUnit -fromSimpleValue (SInj s v) = VInj s (fromSimpleValue v) +fromSimpleValue (SNum d n) = VNum d n +fromSimpleValue SUnit = VUnit +fromSimpleValue (SInj s v) = VInj s (fromSimpleValue v) fromSimpleValue (SPair v1 v2) = VPair (fromSimpleValue v1) (fromSimpleValue v2) -fromSimpleValue (SBag bs) = VBag $ map (first fromSimpleValue) bs -fromSimpleValue (SType t) = VType t +fromSimpleValue (SBag bs) = VBag $ map (first fromSimpleValue) bs +fromSimpleValue (SType t) = VType t -- | A @ValFun@ is just a Haskell function @Value -> Value@. It is a -- @newtype@ just so we can have a custom @Show@ instance for it and @@ -220,7 +228,7 @@ vrat :: Value -> Rational vrat (VNum _ r) = r -vrat v = error $ "vrat " ++ show v +vrat v = error $ "vrat " ++ show v -- | A convenience function for creating a default @VNum@ value with a -- default (@Fractional@) flag. @@ -229,7 +237,7 @@ vint :: Value -> Integer vint (VNum _ n) = numerator n -vint v = error $ "vint " ++ show v +vint v = error $ "vint " ++ show v vchar :: Value -> Char vchar = chr . fromIntegral . vint @@ -242,34 +250,33 @@ enumv :: Enum e => e -> Value enumv e = VInj (toEnum $ fromEnum e) VUnit -pairv :: (a -> Value) -> (b -> Value) -> (a,b) -> Value -pairv av bv (a,b) = VPair (av a) (bv b) +pairv :: (a -> Value) -> (b -> Value) -> (a, b) -> Value +pairv av bv (a, b) = VPair (av a) (bv b) -vpair :: (Value -> a) -> (Value -> b) -> Value -> (a,b) +vpair :: (Value -> a) -> (Value -> b) -> Value -> (a, b) vpair va vb (VPair a b) = (va a, vb b) -vpair _ _ v = error $ "vpair " ++ show v +vpair _ _ v = error $ "vpair " ++ show v listv :: (a -> Value) -> [a] -> Value -listv _ [] = VNil -listv eltv (a:as) = VCons (eltv a) (listv eltv as) +listv _ [] = VNil +listv eltv (a : as) = VCons (eltv a) (listv eltv as) vlist :: (Value -> a) -> Value -> [a] -vlist _ VNil = [] +vlist _ VNil = [] vlist velt (VCons v vs) = velt v : vlist velt vs -vlist _ v = error $ "vlist " ++ show v - +vlist _ v = error $ "vlist " ++ show v ------------------------------------------------------------ -- Propositions ------------------------------------------------------------ data SearchType - = Exhaustive - -- ^ All possibilities were checked. - | Randomized Integer Integer - -- ^ A number of small cases were checked exhaustively and + = -- | All possibilities were checked. + Exhaustive + | -- | A number of small cases were checked exhaustively and -- then a number of additional cases were checked at random. - deriving Show + Randomized Integer Integer + deriving (Show) -- | The answer (success or failure) we're searching for, and -- the result (success or failure) we return when we find it. @@ -278,7 +285,7 @@ -- @(True, True)@ corresponds to "exists". The other values -- arise from negations. newtype SearchMotive = SearchMotive (Bool, Bool) - deriving Show + deriving (Show) pattern SMForall :: SearchMotive pattern SMForall = SearchMotive (False, False) @@ -302,37 +309,53 @@ getTestEnv (TestVars tvs) e = fmap TestEnv . forM tvs $ \(s, ty, name) -> do let value = Ctx.lookup' (localName name) e case value of - Just v -> return (s, ty, v) + Just v -> return (s, ty, v) Nothing -> Left (UnboundPanic name) +-- | Binary logical operators. +data LOp = LAnd | LOr | LImpl deriving (Eq, Ord, Show, Enum, Bounded) + +interpLOp :: LOp -> Bool -> Bool -> Bool +interpLOp LAnd = (&&) +interpLOp LOr = (||) +interpLOp LImpl = (==>) + where + True ==> False = False + _ ==> _ = True + -- | The possible outcomes of a property test, parametrized over -- the type of values. A @TestReason@ explains why a proposition -- succeeded or failed. data TestReason_ a - = TestBool - -- ^ The prop evaluated to a boolean. - | TestEqual Type a a - -- ^ The test was an equality test. Records the values being + = -- | The prop evaluated to a boolean. + TestBool + | -- | The test was an equality test. Records the values being -- compared and also their type (which is needed for printing). - | TestNotFound SearchType - -- ^ The search didn't find any examples/counterexamples. - | TestFound TestResult - -- ^ The search found an example/counterexample. - | TestRuntimeError EvalError - -- ^ The prop failed at runtime. This is always a failure, no + TestEqual Type a a + | -- | The test was a less than test. Records the values being + -- compared and also their type (which is needed for printing). + TestLt Type a a + | -- | The search didn't find any examples/counterexamples. + TestNotFound SearchType + | -- | The search found an example/counterexample. + TestFound TestResult + | -- | A binary logical operator was used to combine the given two results. + TestBin LOp TestResult TestResult + | -- | The prop failed at runtime. This is always a failure, no -- matter which quantifiers or negations it's under. + TestRuntimeError EvalError deriving (Show, Functor, Foldable, Traversable) type TestReason = TestReason_ Value -- | The possible outcomes of a proposition. data TestResult = TestResult Bool TestReason TestEnv - deriving Show + deriving (Show) -- | Whether the property test resulted in a runtime error. testIsError :: TestResult -> Bool testIsError (TestResult _ (TestRuntimeError _) _) = True -testIsError _ = False +testIsError _ = False -- | Whether the property test resulted in success. testIsOk :: TestResult -> Bool @@ -345,17 +368,42 @@ testEnv :: TestResult -> TestEnv testEnv (TestResult _ _ e) = e +testIsCertain :: TestResult -> Bool +testIsCertain (TestResult _ r _) = resultIsCertain r + +resultIsCertain :: TestReason -> Bool +resultIsCertain TestBool = True +resultIsCertain TestEqual {} = True +resultIsCertain TestLt {} = True +resultIsCertain (TestNotFound Exhaustive) = True +resultIsCertain (TestNotFound (Randomized _ _)) = False +resultIsCertain (TestFound r) = testIsCertain r +resultIsCertain (TestRuntimeError _) = True +resultIsCertain (TestBin op tr1 tr2) + | c1 && c2 = True + | c1 && ((op == LOr) == ok1) = True + | c2 && ((op /= LAnd) == ok2) = True + | otherwise = False + where + c1 = testIsCertain tr1 + c2 = testIsCertain tr2 + ok1 = testIsOk tr1 + ok2 = testIsOk tr2 + -- | A @ValProp@ is the normal form of a Disco value of type @Prop@. data ValProp - = VPDone TestResult - -- ^ A prop that has already either succeeded or failed. - | VPSearch SearchMotive [Type] Value TestEnv - -- ^ A pending search. - deriving Show + = -- | A prop that has already either succeeded or failed. + VPDone TestResult + | -- | A pending search. + VPSearch SearchMotive [Type] Value TestEnv + | -- | A binary logical operator combining two prop values. + VPBin LOp ValProp ValProp + deriving (Show) extendPropEnv :: TestEnv -> ValProp -> ValProp extendPropEnv g (VPDone (TestResult b r e)) = VPDone (TestResult b r (g P.<> e)) -extendPropEnv g (VPSearch sm tys v e) = VPSearch sm tys v (g P.<> e) +extendPropEnv g (VPSearch sm tys v e) = VPSearch sm tys v (g P.<> e) +extendPropEnv g (VPBin op vp1 vp2) = VPBin op (extendPropEnv g vp1) (extendPropEnv g vp2) extendResultEnv :: TestEnv -> TestResult -> TestResult extendResultEnv g (TestResult b r e) = TestResult b r (g P.<> e) @@ -365,16 +413,17 @@ ------------------------------------------------------------ -- | An environment is a mapping from names to values. -type Env = Ctx Core Value +type Env = Ctx Core Value ------------------------------------------------------------ -- Memory ------------------------------------------------------------ -- | 'Mem' represents a memory, containing 'Cell's -data Mem = Mem { next :: Int, mu :: IntMap Cell } deriving Show -data Cell = Blackhole | E Env Core | V Value deriving Show +data Mem = Mem {next :: Int, mu :: IntMap Cell} deriving (Show) +data Cell = Blackhole | E Env Core | V Value deriving (Show) + emptyMem :: Mem emptyMem = Mem 0 IM.empty @@ -384,7 +433,7 @@ allocate :: Members '[State Mem] r => Env -> Core -> Sem r Int allocate e t = do Mem n m <- get - put $ Mem (n+1) (IM.insert n (E e t) m) + put $ Mem (n + 1) (IM.insert n (E e t) m) return n -- | Allocate new memory cells for a group of mutually recursive @@ -393,11 +442,11 @@ allocateRec e bs = do Mem n m <- get let newRefs = zip [n ..] bs - e' = foldl' (flip (\(i,(x,_)) -> Ctx.insert x (VRef i))) e newRefs - m' = foldl' (flip (\(i,(_,c)) -> IM.insert i (E e' c))) m newRefs + e' = foldl' (flip (\(i, (x, _)) -> Ctx.insert x (VRef i))) e newRefs + m' = foldl' (flip (\(i, (_, c)) -> IM.insert i (E e' c))) m newRefs n' = n + length bs put $ Mem n' m' - return [n .. n'-1] + return [n .. n' - 1] -- | Look up the cell at a given index. lkup :: Members '[State Mem] r => Int -> Sem r (Maybe Cell) @@ -411,60 +460,51 @@ -- Pretty-printing values ------------------------------------------------------------ -prettyValue' :: Member (Input TyDefCtx) r => Type -> Value -> Sem r Doc +prettyValue' :: Member (Input TyDefCtx) r => Type -> Value -> Sem r (Doc ann) prettyValue' ty v = runLFresh . runReader initPA $ prettyValue ty v -prettyValue :: Members '[Input TyDefCtx, LFresh, Reader PA] r => Type -> Value -> Sem r Doc - +prettyValue :: Members '[Input TyDefCtx, LFresh, Reader PA] r => Type -> Value -> Sem r (Doc ann) -- Lazily expand any user-defined types prettyValue (TyUser x args) v = do tydefs <- input - let (TyDefBody _ body) = tydefs M.! x -- This can't fail if typechecking succeeded + let (TyDefBody _ body) = tydefs M.! x -- This can't fail if typechecking succeeded prettyValue (body args) v - -prettyValue _ VUnit = "■" -prettyValue TyProp _ = prettyPlaceholder TyProp -prettyValue TyBool (VInj s _) = text $ map toLower (show (s == R)) +prettyValue _ VUnit = "■" +prettyValue TyProp _ = prettyPlaceholder TyProp +prettyValue TyBool (VInj s _) = text $ map toLower (show (s == R)) prettyValue TyBool v = error $ "Non-VInj passed with Bool type to prettyValue: " ++ show v -prettyValue TyC (vchar -> c) = text (show c) +prettyValue TyC (vchar -> c) = text (show c) prettyValue (TyList TyC) (vlist vchar -> cs) = doubleQuotes . text . concatMap prettyChar $ cs - where - prettyChar = drop 1 . reverse . drop 1 . reverse . show . (:[]) -prettyValue (TyList ty) (vlist id -> xs) = do + where + prettyChar = drop 1 . reverse . drop 1 . reverse . show . (: []) +prettyValue (TyList ty) (vlist id -> xs) = do ds <- punctuate (text ",") (map (prettyValue ty) xs) brackets (hsep ds) - -prettyValue ty@(_ :*: _) v = parens (prettyTuple ty v) - -prettyValue (ty1 :+: _) (VInj L v) = "left" <> prettyVP ty1 v -prettyValue (_ :+: ty2) (VInj R v) = "right" <> prettyVP ty2 v +prettyValue ty@(_ :*: _) v = parens (prettyTuple ty v) +prettyValue (ty1 :+: _) (VInj L v) = "left" <> prettyVP ty1 v +prettyValue (_ :+: ty2) (VInj R v) = "right" <> prettyVP ty2 v prettyValue (_ :+: _) v = error $ "Non-VInj passed with sum type to prettyValue: " ++ show v - prettyValue _ (VNum d r) - | denominator r == 1 = text $ show (numerator r) - | otherwise = text $ case d of + | denominator r == 1 = text $ show (numerator r) + | otherwise = text $ case d of Fraction -> show (numerator r) ++ "/" ++ show (denominator r) - Decimal -> prettyDecimal r - -prettyValue ty@(_ :->: _) _ = prettyPlaceholder ty - -prettyValue (TySet ty) (VBag xs) = braces $ prettySequence ty "," (map fst xs) + Decimal -> prettyDecimal r +prettyValue ty@(_ :->: _) _ = prettyPlaceholder ty +prettyValue (TySet ty) (VBag xs) = braces $ prettySequence ty "," (map fst xs) prettyValue (TySet _) v = error $ "Non-VBag passed with Set type to prettyValue: " ++ show v -prettyValue (TyBag ty) (VBag xs) = prettyBag ty xs +prettyValue (TyBag ty) (VBag xs) = prettyBag ty xs prettyValue (TyBag _) v = error $ "Non-VBag passed with Bag type to prettyValue: " ++ show v - -prettyValue (TyMap tyK tyV) (VMap m) = +prettyValue (TyMap tyK tyV) (VMap m) = "map" <> parens (braces (prettySequence (tyK :*: tyV) "," (assocsToValues m))) - where - assocsToValues = map (\(k,v) -> VPair (fromSimpleValue k) v) . M.assocs + where + assocsToValues = map (\(k, v) -> VPair (fromSimpleValue k) v) . M.assocs prettyValue (TyMap _ _) v = error $ "Non-map value with map type passed to prettyValue: " ++ show v - -prettyValue (TyGraph ty) (VGraph g) = +prettyValue (TyGraph ty) (VGraph g) = foldg "emptyGraph" (("vertex" <>) . prettyVP ty . fromSimpleValue) @@ -473,102 +513,34 @@ g prettyValue (TyGraph _) v = error $ "Non-graph value with graph type passed to prettyValue: " ++ show v - -prettyValue ty@TyAtom{} v = +prettyValue ty@TyAtom {} v = error $ "Invalid atomic type passed to prettyValue: " ++ show ty ++ " " ++ show v - -prettyValue ty@TyCon{} v = +prettyValue ty@TyCon {} v = error $ "Invalid type constructor passed to prettyValue: " ++ show ty ++ " " ++ show v -- | Pretty-print a value with guaranteed parentheses. Do nothing for -- tuples; add an extra set of parens for other values. -prettyVP :: Members '[Input TyDefCtx, LFresh, Reader PA] r => Type -> Value -> Sem r Doc +prettyVP :: Members '[Input TyDefCtx, LFresh, Reader PA] r => Type -> Value -> Sem r (Doc ann) prettyVP ty@(_ :*: _) = prettyValue ty -prettyVP ty = parens . prettyValue ty +prettyVP ty = parens . prettyValue ty -prettyPlaceholder :: Members '[Reader PA, LFresh] r => Type -> Sem r Doc +prettyPlaceholder :: Members '[Reader PA, LFresh] r => Type -> Sem r (Doc ann) prettyPlaceholder ty = "<" <> pretty ty <> ">" -prettyTuple :: Members '[Input TyDefCtx, LFresh, Reader PA] r => Type -> Value -> Sem r Doc +prettyTuple :: Members '[Input TyDefCtx, LFresh, Reader PA] r => Type -> Value -> Sem r (Doc ann) prettyTuple (ty1 :*: ty2) (VPair v1 v2) = prettyValue ty1 v1 <> "," <+> prettyTuple ty2 v2 -prettyTuple ty v = prettyValue ty v +prettyTuple ty v = prettyValue ty v -- | 'prettySequence' pretty-prints a lists of values separated by a delimiter. -prettySequence :: Members '[Input TyDefCtx, LFresh, Reader PA] r => Type -> Doc -> [Value] -> Sem r Doc +prettySequence :: Members '[Input TyDefCtx, LFresh, Reader PA] r => Type -> Doc ann -> [Value] -> Sem r (Doc ann) prettySequence ty del vs = hsep =<< punctuate (return del) (map (prettyValue ty) vs) -- | Pretty-print a literal bag value. -prettyBag :: Members '[Input TyDefCtx, LFresh, Reader PA] r => Type -> [(Value,Integer)] -> Sem r Doc +prettyBag :: Members '[Input TyDefCtx, LFresh, Reader PA] r => Type -> [(Value, Integer)] -> Sem r (Doc ann) prettyBag _ [] = bag empty prettyBag ty vs - | all ((==1) . snd) vs = bag $ prettySequence ty "," (map fst vs) - | otherwise = bag $ hsep =<< punctuate (return ",") (map prettyCount vs) - where - prettyCount (v,1) = prettyValue ty v - prettyCount (v,n) = prettyValue ty v <+> "#" <+> text (show n) - ------------------------------------------------------------- --- Pretty-printing for test results ------------------------------------------------------------- - -prettyTestFailure - :: Members '[Input TyDefCtx, LFresh, Reader PA] r - => AProperty -> TestResult -> Sem r Doc -prettyTestFailure _ (TestResult True _ _) = empty -prettyTestFailure prop (TestResult False r env) = - prettyFailureReason prop r - $+$ - prettyTestEnv "Counterexample:" env - -prettyTestResult - :: Members '[Input TyDefCtx, LFresh, Reader PA] r - => AProperty -> TestResult -> Sem r Doc -prettyTestResult prop r | not (testIsOk r) = prettyTestFailure prop r -prettyTestResult prop (TestResult _ r _) = - ("Test passed:" <+> pretty (eraseProperty prop)) - $+$ - prettySuccessReason r - -prettySuccessReason - :: Members '[Input TyDefCtx, LFresh, Reader PA] r - => TestReason -> Sem r Doc -prettySuccessReason (TestFound (TestResult _ _ vs)) = prettyTestEnv "Found example:" vs -prettySuccessReason (TestNotFound Exhaustive) = "No counterexamples exist." -prettySuccessReason (TestNotFound (Randomized n m)) = - "Checked" <+> text (show (n + m)) <+> "possibilities without finding a counterexample." -prettySuccessReason _ = empty - -prettyFailureReason - :: Members '[Input TyDefCtx, LFresh, Reader PA] r - => AProperty -> TestReason -> Sem r Doc -prettyFailureReason prop TestBool = "Test is false:" <+> pretty (eraseProperty prop) -prettyFailureReason prop (TestEqual ty v1 v2) = - "Test result mismatch for:" <+> pretty (eraseProperty prop) - $+$ - bulletList "-" - [ "Left side: " <> prettyValue ty v1 - , "Right side: " <> prettyValue ty v2 - ] -prettyFailureReason prop (TestRuntimeError e) = - "Test failed:" <+> pretty (eraseProperty prop) - $+$ - pretty (EvalErr e) -prettyFailureReason prop (TestFound (TestResult _ r _)) = prettyFailureReason prop r -prettyFailureReason prop (TestNotFound Exhaustive) = - "No example exists:" <+> pretty (eraseProperty prop) - $+$ - "All possible values were checked." -prettyFailureReason prop (TestNotFound (Randomized n m)) = do - "No example was found:" <+> pretty (eraseProperty prop) - $+$ - ("Checked" <+> text (show (n + m)) <+> "possibilities.") - -prettyTestEnv - :: Members '[Input TyDefCtx, LFresh, Reader PA] r - => String -> TestEnv -> Sem r Doc -prettyTestEnv _ (TestEnv []) = empty -prettyTestEnv s (TestEnv vs) = text s $+$ nest 2 (vcat (map prettyBind vs)) - where - maxNameLen = maximum . map (\(n, _, _) -> length n) $ vs - prettyBind (x, ty, v) = - text x <> text (replicate (maxNameLen - length x) ' ') <+> "=" <+> prettyValue ty v + | all ((== 1) . snd) vs = bag $ prettySequence ty "," (map fst vs) + | otherwise = bag $ hsep =<< punctuate (return ",") (map prettyCount vs) + where + prettyCount (v, 1) = prettyValue ty v + prettyCount (v, n) = prettyValue ty v <+> "#" <+> text (show n) diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -2,7 +2,7 @@ # For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/ # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) -resolver: lts-18.13 +resolver: lts-21.13 # Local packages, usually specified by relative directory name packages: @@ -10,15 +10,12 @@ # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) extra-deps: - - unbound-generics-0.4.0 - - simple-enumeration-0.2 - - oeis-0.3.10 - - capability-0.4.0.0@sha256:d86d85a1691ef0165c77c47ea72eac75c99d21fb82947efe8b2f758991cf1837,3345 - - polysemy-1.6.0.0@sha256:29a73b1bf3d0049b12041016b7ee25e76bd8f6e99f9c37c2dde2b46368246697,6184 - - polysemy-plugin-0.4.0.0 - - polysemy-zoo-0.7.0.1@sha256:60c2921df95f61d43222a75adde4f330e9510320b416132838a354cd81b4bcc5,3846 - - compact-0.2.0.0@sha256:75ef98cb51201b4a0d6de95cbbb62be6237c092a3d594737346c70c5d56c2380,2413 - - constraints-0.12 # needed since polysemy-zoo hasn't updated upper bound to allow 0.13 + - unbound-generics-0.4.2 + # unbound-generics-0.4.3 contains breaking changes (adding methods to Subst class) + - simple-enumeration-0.2.1@sha256:8625b269c1650d3dd0e3887351c153049f4369853e0d525219e07480ea004b9f,1178 + - polysemy-zoo-0.8.2.0 + # - HTTP-4000.3.16@sha256:6042643c15a0b43e522a6693f1e322f05000d519543a84149cb80aeffee34f71,5947 + # HTTP-4000.3 needed for oeis-0.3.10 # Override default flag values for local packages and extra-deps flags: {} diff --git a/test/compile-misc/expected b/test/compile-misc/expected --- a/test/compile-misc/expected +++ b/test/compile-misc/expected @@ -2,8 +2,8 @@ λx, y. x (λ_. (λk. (λy. (λp, q. p) (fst y) (snd y)) (frac (2 / 3))) (λ_1. matchErr)) unit (λ_. (λk. case (3 < 2) of { - left _1 -> k unit - right px -> (λ_2. 1) px - }) (λ_1. (λk. 17) (λ_2. matchErr))) unit + left _1 -> k unit + right px -> (λ_2. 1) px + }) (λ_1. (λk. 17) (λ_2. matchErr))) unit (10 choose right (5, left unit)) 5! diff --git a/test/containers-filter/expected b/test/containers-filter/expected --- a/test/containers-filter/expected +++ b/test/containers-filter/expected @@ -1,4 +1,3 @@ -Loading list.disco... [4, 5, 6, 7, 8, 9, 10] ⟅4, 5, 6, 7, 8, 9, 10⟆ {4, 5, 6, 7, 8, 9, 10} diff --git a/test/containers-reduce/containers-reduce.disco b/test/containers-reduce/containers-reduce.disco --- a/test/containers-reduce/containers-reduce.disco +++ b/test/containers-reduce/containers-reduce.disco @@ -1,6 +1,6 @@ import num -!!! ∀ x : ℕ. (x > 0) ==> reduce(~*~, 1, factor x) == x +!!! ∀ x : ℕ. reduce(~*~, 1, factor (x+1)) == (x+1) dummy : Unit dummy = unit diff --git a/test/error-nonlinear/expected b/test/error-nonlinear/expected new file mode 100644 --- /dev/null +++ b/test/error-nonlinear/expected @@ -0,0 +1,5 @@ +While checking REPL.f: + Error: pattern (x, x) contains duplicate variable x. + https://disco-lang.readthedocs.io/en/latest/reference/nonlinear.html +Error: pattern (x, left(y, x)) contains duplicate variable x. +https://disco-lang.readthedocs.io/en/latest/reference/nonlinear.html diff --git a/test/error-nonlinear/input b/test/error-nonlinear/input new file mode 100644 --- /dev/null +++ b/test/error-nonlinear/input @@ -0,0 +1,3 @@ +f : N*N -> N +f(x,x) = 3 +{? 5 when (2, left(3,5)) is (x, left(y,x)), 7 otherwise ?} diff --git a/test/error-parse-RHS/expected b/test/error-parse-RHS/expected --- a/test/error-parse-RHS/expected +++ b/test/error-parse-RHS/expected @@ -5,10 +5,10 @@ unexpected end of input expecting expression or operator -1:18: +1:22: | -1 | g(x) = {? 5 if x =< 5, 6 otherwise ?} - | ^^ -unexpected "=<" -expecting "?}", "if", "let", "when", ',', expression, operator, or type annotation +1 | g(x) = {? 5 if x > 5 .+ 4, 6 otherwise ?} + | ^^ +unexpected ".+" +expecting "?}", "if", "is", "let", "when", ',', expression, operator, or type annotation diff --git a/test/error-parse-RHS/input b/test/error-parse-RHS/input --- a/test/error-parse-RHS/input +++ b/test/error-parse-RHS/input @@ -2,4 +2,4 @@ f(x) = x + g : N -> N -g(x) = {? 5 if x =< 5, 6 otherwise ?} +g(x) = {? 5 if x > 5 .+ 4, 6 otherwise ?} diff --git a/test/error-pattype/expected b/test/error-pattype/expected --- a/test/error-pattype/expected +++ b/test/error-pattype/expected @@ -10,7 +10,7 @@ (x1, y) is supposed to have type ℕ, - but instead it has a product type. + but instead it has a pair type. https://disco-lang.readthedocs.io/en/latest/reference/pattern-type.html While checking REPL.h: Error: the shape of two types does not match. diff --git a/test/lib-oeis/expected b/test/lib-oeis/expected deleted file mode 100644 --- a/test/lib-oeis/expected +++ /dev/null @@ -1,8 +0,0 @@ -Loading oeis.disco... -right("https://oeis.org/A000045") -left(■) -left(■) -[1, 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 23, 25, 27, 29, 31, 33, 35, 37, 39, 41, 43, 45, 47, 49, 51, 53, 55, 57, 59, 61, 63, 65, 67, 69, 71, 73, 75, 77, 79, 81, 83, 85, 87, 89, 91, 93, 95, 97, 99, 101, 103, 105, 107, 109, 111, 113, 115, 117, 119, 121, 123, 125, 127, 129, 131] -[] -[1, 10011] -[1, 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 23, 25, 27, 29, 31, 33, 35, 37, 39, 41, 43, 45, 47, 49, 51, 53, 55, 57, 59, 61, 63, 65, 67, 69, 71, 73, 75, 77, 79, 81, 83, 85, 87, 89, 91, 93, 95, 97, 99, 101, 103, 105, 107, 109, 111, 113, 115, 117, 119, 121, 123, 125, 127, 129, 131] diff --git a/test/lib-oeis/input b/test/lib-oeis/input deleted file mode 100644 --- a/test/lib-oeis/input +++ /dev/null @@ -1,22 +0,0 @@ -import oeis - --- valid sequence -lookupSequence [1,1,2,3,5] - --- empty list -lookupSequence [] - --- unknown sequence -lookupSequence [1,10011] - --- known sequence -extendSequence [1,3,5,7] - --- empty list -extendSequence [] - --- unknown sequence -extendSequence [1,10011] - --- extend a long sequence -extendSequence [1,3,5,7,9,11,13,15,17,19,21,23,25,27,29,31,33,35,37,39,41,43,45,47,49,51,53,55,57,59,61,63,65,67,69,71,73,75,77,79,81,83,85,87,89,91,93,95,97,99] diff --git a/test/list-comp/expected b/test/list-comp/expected --- a/test/list-comp/expected +++ b/test/list-comp/expected @@ -1,4 +1,3 @@ -Loading list.disco... Loading num.disco... [1, 2, 3] [] diff --git a/test/list-poly/expected b/test/list-poly/expected --- a/test/list-poly/expected +++ b/test/list-poly/expected @@ -1,4 +1,3 @@ -Loading list.disco... [1, 2, 3, 4, 5] [5, 4, 3, 2, 1] [1, 2, 3, 4, 5] diff --git a/test/logic-cmp/expected b/test/logic-cmp/expected --- a/test/logic-cmp/expected +++ b/test/logic-cmp/expected @@ -5,6 +5,7 @@ true true false +false true false false @@ -12,7 +13,10 @@ true false false +false true +true +false true false true diff --git a/test/logic-cmp/input b/test/logic-cmp/input --- a/test/logic-cmp/input +++ b/test/logic-cmp/input @@ -5,16 +5,20 @@ 1 <= 2 2 <= 2 3 <= 2 +3 =< 2 3 > 1 3 > 3 3 > 4 3 >= 1 3 >= 3 3 >= 4 +3 => 4 3 == 5 3 == 3 3 /= 5 3 /= 3 +3 != 5 +3 != 3 (1,2) < (1,3) (1,3) < (2,1) (2,2) < (2,1) diff --git a/test/map-basic/expected b/test/map-basic/expected --- a/test/map-basic/expected +++ b/test/map-basic/expected @@ -1,4 +1,3 @@ -Loading list.disco... map : Set(ℕ × a) → Map(ℕ, a) map({(1, 3), (4, 6)}) : Map(ℕ, ℕ) map({(1, 3), (4, 6)}) diff --git a/test/parse-patguard/expected b/test/parse-patguard/expected new file mode 100644 --- /dev/null +++ b/test/parse-patguard/expected @@ -0,0 +1,7 @@ +1:18: + | +1 | {? 1 if 3 is (x, ?} + | ^^ +unexpected "?}" +expecting expression + diff --git a/test/parse-patguard/input b/test/parse-patguard/input new file mode 100644 --- /dev/null +++ b/test/parse-patguard/input @@ -0,0 +1,1 @@ +{? 1 if 3 is (x, ?} diff --git a/test/parse-quantifiers/expected b/test/parse-quantifiers/expected --- a/test/parse-quantifiers/expected +++ b/test/parse-quantifiers/expected @@ -1,37 +1,96 @@ TAbs_ Lam () (<[PVar_ () x]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TNat_ () 3])) TAbs_ Lam () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TNat_ () 3])) -TAbs_ Lam () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N)),PVar_ () y]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) -TAbs_ Lam () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N)),PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) -TAbs_ Lam () (<[PVar_ () x,PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) +TAbs_ Lam () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N))]> TAbs_ Lam () (<[PVar_ () y]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 1@0,TVar_ () 0@0]))) +TAbs_ Lam () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N))]> TAbs_ Lam () (<[PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 1@0,TVar_ () 0@0]))) +TAbs_ Lam () (<[PVar_ () x]> TAbs_ Lam () (<[PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 1@0,TVar_ () 0@0]))) TAbs_ Lam () (<[PVar_ () x]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TNat_ () 3])) TAbs_ Lam () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TNat_ () 3])) -TAbs_ Lam () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N)),PVar_ () y]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) -TAbs_ Lam () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N)),PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) -TAbs_ Lam () (<[PVar_ () x,PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) +TAbs_ Lam () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N))]> TAbs_ Lam () (<[PVar_ () y]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 1@0,TVar_ () 0@0]))) +TAbs_ Lam () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N))]> TAbs_ Lam () (<[PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 1@0,TVar_ () 0@0]))) +TAbs_ Lam () (<[PVar_ () x]> TAbs_ Lam () (<[PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 1@0,TVar_ () 0@0]))) 8 Error: the shape of two types does not match. https://disco-lang.readthedocs.io/en/latest/reference/shape-mismatch.html 8 8 -8 -TAbs_ Ex () (<[PVar_ () x]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TNat_ () 3])) +1:16: + | +1 | :parse exists x. x > 3 + | ^ +Variables introduced by ∀ or ∃ must have a type + TAbs_ Ex () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TNat_ () 3])) -TAbs_ Ex () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N)),PVar_ () y]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) +1:23: + | +1 | :parse exists (x:N), y. x > y + | ^ +Variables introduced by ∀ or ∃ must have a type + TAbs_ Ex () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N)),PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) -TAbs_ Ex () (<[PVar_ () x,PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) -TAbs_ Ex () (<[PVar_ () x]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TNat_ () 3])) +1:16: + | +1 | :parse exists x, (y:F). x > y + | ^ +Variables introduced by ∀ or ∃ must have a type + +1:11: + | +1 | :parse ∃ x. x > 3 + | ^ +Variables introduced by ∀ or ∃ must have a type + TAbs_ Ex () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TNat_ () 3])) -TAbs_ Ex () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N)),PVar_ () y]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) +1:18: + | +1 | :parse ∃ (x:N), y. x > y + | ^ +Variables introduced by ∀ or ∃ must have a type + TAbs_ Ex () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N)),PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) -TAbs_ Ex () (<[PVar_ () x,PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) -TAbs_ All () (<[PVar_ () x]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TNat_ () 3])) +1:11: + | +1 | :parse ∃ x, (y:F). x > y + | ^ +Variables introduced by ∀ or ∃ must have a type + +1:16: + | +1 | :parse forall x. x > 3 + | ^ +Variables introduced by ∀ or ∃ must have a type + TAbs_ All () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TNat_ () 3])) -TAbs_ All () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N)),PVar_ () y]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) +1:23: + | +1 | :parse forall (x:N), y. x > y + | ^ +Variables introduced by ∀ or ∃ must have a type + TAbs_ All () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N)),PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) -TAbs_ All () (<[PVar_ () x,PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) -TAbs_ All () (<[PVar_ () x]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TNat_ () 3])) +1:16: + | +1 | :parse forall x, (y:F). x > y + | ^ +Variables introduced by ∀ or ∃ must have a type + +1:11: + | +1 | :parse ∀ x. x > 3 + | ^ +Variables introduced by ∀ or ∃ must have a type + TAbs_ All () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TNat_ () 3])) -TAbs_ All () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N)),PVar_ () y]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) +1:18: + | +1 | :parse ∀ (x:N), y. x > y + | ^ +Variables introduced by ∀ or ∃ must have a type + TAbs_ All () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N)),PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) -TAbs_ All () (<[PVar_ () x,PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) +1:11: + | +1 | :parse ∀ x, (y:F). x > y + | ^ +Variables introduced by ∀ or ∃ must have a type + TAbs_ All () (<[PTup_ () [PAscr_ () (PVar_ () x) (TyAtom (ABase N)),PAscr_ () (PVar_ () y) (TyAtom (ABase N)),PAscr_ () (PVar_ () z) (TyAtom (ABase N))]]> TApp_ () (TPrim_ () (PrimBOp Impl)) (TTup_ () [TApp_ () (TPrim_ () (PrimBOp And)) (TTup_ () [TParens_ () (TApp_ () (TPrim_ () (PrimBOp Eq)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])),TParens_ () (TApp_ () (TPrim_ () (PrimBOp Eq)) (TTup_ () [TVar_ () 0@1,TVar_ () 0@2]))]),TApp_ () (TPrim_ () (PrimBOp Eq)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@2])])) diff --git a/test/parse-quantifiers/input b/test/parse-quantifiers/input --- a/test/parse-quantifiers/input +++ b/test/parse-quantifiers/input @@ -1,17 +1,16 @@ :parse λ x. x > 3 :parse λ (x:N). x > 3 -:parse λ (x:N), y. x > y -:parse λ (x:N), (y:F). x > y -:parse λ x, (y:F). x > y +:parse λ (x:N). λy. x > y +:parse λ x:N. λy:F. x > y +:parse λ x. λy:F. x > y :parse \ x. x > 3 :parse \ (x:N). x > 3 -:parse \ (x:N), y. x > y -:parse \ (x:N), (y:F). x > y -:parse \ x, (y:F). x > y -(\x, y. x + y) 3 5 +:parse \ (x:N). \y. x > y +:parse \ (x:N). \(y:F). x > y +:parse \ x. \(y:F). x > y +(\x. \y. x + y) 3 5 (\(x : N, y : N). x + y) 3 5 (\(x : N, y : N). x + y) (3, 5) -(\(x:N), (y:N). x + y) 3 5 (\(x:N). \(y:N). x + y) 3 5 :parse exists x. x > 3 :parse exists (x:N). x > 3 diff --git a/test/poly-bad/input b/test/poly-bad/input --- a/test/poly-bad/input +++ b/test/poly-bad/input @@ -1,6 +1,6 @@ let f : a -> a = \x. x+1 in f let f : a -> a = \x. x+x in f -let f : a -> b -> a = \x, y. y in f +let f : a -> b -> a = \x. \y. y in f let f : a*b -> b = \p. {? a when p is (a,_) ?} in f let f : List(a) -> List(a) = \x. list (bag x) in f -let f : a -> a -> Bool = \x, y. x < y in f +let f : a -> a -> Bool = \x. \y. x < y in f diff --git a/test/poly-infer-sort/expected b/test/poly-infer-sort/expected --- a/test/poly-infer-sort/expected +++ b/test/poly-infer-sort/expected @@ -3,9 +3,9 @@ let f : (a → a) → a → a = λg. λx. g(g(x)) in f(λx. x / x) : 𝔽 → 𝔽 let f : (a → a) → a → a = λg. λx. g(g(x)) in f(λx. -x / x) : ℚ → ℚ λx. x : a → a -λx, y. x : a1 → a → a1 -λx, y, z. x + y + z : ℕ → ℕ → ℕ → ℕ -λx, y : ℕ. x - y : ℤ → ℕ → ℤ -λw, x : ℕ, y, z : 𝔽. w - x + y + z : ℚ → ℕ → ℚ → 𝔽 → ℚ +λx. λy. x : a1 → a → a1 +λx. λy. λz. x + y + z : ℕ → ℕ → ℕ → ℕ +λx. λy : ℕ. x - y : ℤ → ℕ → ℤ +λw. λx : ℕ. λy. λz : 𝔽. w - x + y + z : ℚ → ℕ → ℚ → 𝔽 → ℚ Error: typechecking failed. https://disco-lang.readthedocs.io/en/latest/reference/typecheck-fail.html diff --git a/test/poly-infer-sort/input b/test/poly-infer-sort/input --- a/test/poly-infer-sort/input +++ b/test/poly-infer-sort/input @@ -3,8 +3,8 @@ :type let f : (a -> a) -> a -> a = \g. (\x. g (g x)) in f (\x. x/x) :type let f : (a -> a) -> a -> a = \g. (\x. g (g x)) in f (\x. -x/x) :type \x.x -:type \x, y. x -:type \x, y, z. x + y + z -:type \x, (y:Nat). x - y -:type \w, (x:Nat), y, (z : Frac). w - x + y + z -\x, (y:Bool). x - y +:type \x. \y. x +:type \x. \y. \z. x + y + z +:type \x. \(y:Nat). x - y +:type \w. \x:Nat. \y. \z : Frac. w - x + y + z +\x. \y:Bool. x - y diff --git a/test/poly-instantiate/expected b/test/poly-instantiate/expected --- a/test/poly-instantiate/expected +++ b/test/poly-instantiate/expected @@ -1,12 +1,12 @@ Loading poly-instantiate.disco... Loaded. foldr : (a → r → r) → r → List(a) → r -foldr(λx, y. x) : a → List(a) → a -foldr(λx, y. y) : r → List(a) → r -foldr(λx, y. x + 1) : ℕ → List(ℕ) → ℕ -foldr(λx, y. y + 1) : ℕ → List(a) → ℕ -foldr(λx, y. y + 1)(1) : List(a) → ℕ -foldr(λx, y. y + 1)(-1) : List(a) → ℤ -foldr(λx, y. x)(false) : List(Bool) → Bool -foldr(λx, y. x + 1)(1 / 2) : List(ℕ) → 𝔽 -foldr(λx, y. x - 1)(1 / 2) : List(ℤ) → ℚ +foldr(λx. λy. x) : a → List(a) → a +foldr(λx. λy. y) : r → List(a) → r +foldr(λx. λy. x + 1) : ℕ → List(ℕ) → ℕ +foldr(λx. λy. y + 1) : ℕ → List(a) → ℕ +foldr(λx. λy. y + 1)(1) : List(a) → ℕ +foldr(λx. λy. y + 1)(-1) : List(a) → ℤ +foldr(λx. λy. x)(false) : List(Bool) → Bool +foldr(λx. λy. x + 1)(1 / 2) : List(ℕ) → 𝔽 +foldr(λx. λy. x - 1)(1 / 2) : List(ℤ) → ℚ diff --git a/test/poly-instantiate/input b/test/poly-instantiate/input --- a/test/poly-instantiate/input +++ b/test/poly-instantiate/input @@ -1,11 +1,11 @@ :load test/poly-instantiate/poly-instantiate.disco :type foldr -:type foldr (\x, y. x) -:type foldr (\x, y. y) -:type foldr (\x, y. x+1) -:type foldr (\x, y. y+1) -:type foldr (\x, y. y+1) 1 -:type foldr (\x, y. y+1) (-1) -:type foldr (\x, y. x) false -:type foldr (\x, y. x+1) (1/2) -:type foldr (\x, y. x-1) (1/2) +:type foldr (\x. \y. x) +:type foldr (\x. \y. y) +:type foldr (\x. \y. x+1) +:type foldr (\x. \y. y+1) +:type foldr (\x. \y. y+1) 1 +:type foldr (\x. \y. y+1) (-1) +:type foldr (\x. \y. x) false +:type foldr (\x. \y. x+1) (1/2) +:type foldr (\x. \y. x-1) (1/2) diff --git a/test/pretty-issue258/expected b/test/pretty-issue258/expected deleted file mode 100644 --- a/test/pretty-issue258/expected +++ /dev/null @@ -1,12 +0,0 @@ -Loading catalan.disco... -Loading list.disco... -Loading oeis.disco... -Loaded. -treesOfSize : ℕ → List(BT) -treesOfSize(0) = [left(■)] -treesOfSize(k + 1) = [right(l, r) | x in [0 .. k], l in treesOfSize(x), r in treesOfSize(k .- x)] -Loading tree.disco... -Loaded. -treeFold : r11 × (ℕ × r11 × r11 → r11) × Tree → r11 -treeFold(x, f, left(■)) = x -treeFold(x, f, right(n, l, r)) = f(n, treeFold(x, f, l), treeFold(x, f, r)) diff --git a/test/pretty-issue258/input b/test/pretty-issue258/input deleted file mode 100644 --- a/test/pretty-issue258/input +++ /dev/null @@ -1,4 +0,0 @@ -:load example/catalan.disco -:defn treesOfSize -:load example/tree.disco -:defn treeFold diff --git a/test/prop-basic/expected b/test/prop-basic/expected --- a/test/prop-basic/expected +++ b/test/prop-basic/expected @@ -1,12 +1,12 @@ Loading prop-basic.disco... Loaded. - - Test passed: injective(λx. x * 2) + - Possibly true: injective(λx. x * 2) Checked 100 possibilities without finding a counterexample. - - Test passed: idempotent(λx. x max 10) + - Possibly true: idempotent(λx. x max 10) Checked 100 possibilities without finding a counterexample. - - Test passed: commutative(λ(a, b). a * b) + - Possibly true: commutative(λ(a, b). a * b) Checked 100 possibilities without finding a counterexample. - - Test passed: associative(λ(a, b). a + b) + - Possibly true: associative(λ(a, b). a + b) Checked 100 possibilities without finding a counterexample. - - Test passed: identityFor(0, λ(a, b). a max b) + - Possibly true: identityFor(0, λ(a, b). a max b) Checked 100 possibilities without finding a counterexample. diff --git a/test/prop-binary/expected b/test/prop-binary/expected new file mode 100644 --- /dev/null +++ b/test/prop-binary/expected @@ -0,0 +1,401 @@ + - Certainly true: (∃n. 2 * n == 0) /\ (∃n. 2 * n == 0) + - Left side: + Certainly true: ∃n. 2 * n == 0 + Found example: + n = 0 + - Right side: + Certainly true: ∃n. 2 * n == 0 + Found example: + n = 0 + - Possibly true: (∃n. 2 * n == 0) /\ (∀n. n >= 0) + - Left side: + Certainly true: ∃n. 2 * n == 0 + Found example: + n = 0 + - Right side: + Possibly true: ∀n. n >= 0 + Checked 100 possibilities without finding a counterexample. + - Certainly false: (∃n. 2 * n == 0) /\ (∀n. n > 0) + - Left side: + Certainly true: ∃n. 2 * n == 0 + Found example: + n = 0 + - Right side: + Certainly false: ∀n. n > 0 + Found counterexample: + n = 0 + - Possibly false: (∃n. 2 * n == 0) /\ (∃n. 2 * n == 1) + - Left side: + Certainly true: ∃n. 2 * n == 0 + Found example: + n = 0 + - Right side: + Possibly false: ∃n. 2 * n == 1 + No example was found; checked 100 possibilities. + - Possibly true: (∀n. n >= 0) /\ (∃n. 2 * n == 0) + - Left side: + Possibly true: ∀n. n >= 0 + Checked 100 possibilities without finding a counterexample. + - Right side: + Certainly true: ∃n. 2 * n == 0 + Found example: + n = 0 + - Possibly true: (∀n. n >= 0) /\ (∀n. n >= 0) + - Left side: + Possibly true: ∀n. n >= 0 + Checked 100 possibilities without finding a counterexample. + - Right side: + Possibly true: ∀n. n >= 0 + Checked 100 possibilities without finding a counterexample. + - Certainly false: (∀n. n >= 0) /\ (∀n. n > 0) + - Left side: + Possibly true: ∀n. n >= 0 + Checked 100 possibilities without finding a counterexample. + - Right side: + Certainly false: ∀n. n > 0 + Found counterexample: + n = 0 + - Possibly false: (∀n. n >= 0) /\ (∃n. 2 * n == 1) + - Left side: + Possibly true: ∀n. n >= 0 + Checked 100 possibilities without finding a counterexample. + - Right side: + Possibly false: ∃n. 2 * n == 1 + No example was found; checked 100 possibilities. + - Certainly false: (∀n. n > 0) /\ (∃n. 2 * n == 0) + - Left side: + Certainly false: ∀n. n > 0 + Found counterexample: + n = 0 + - Right side: + Certainly true: ∃n. 2 * n == 0 + Found example: + n = 0 + - Certainly false: (∀n. n > 0) /\ (∀n. n >= 0) + - Left side: + Certainly false: ∀n. n > 0 + Found counterexample: + n = 0 + - Right side: + Possibly true: ∀n. n >= 0 + Checked 100 possibilities without finding a counterexample. + - Certainly false: (∀n. n > 0) /\ (∀n. n > 0) + - Left side: + Certainly false: ∀n. n > 0 + Found counterexample: + n = 0 + - Right side: + Certainly false: ∀n. n > 0 + Found counterexample: + n = 0 + - Certainly false: (∀n. n > 0) /\ (∃n. 2 * n == 1) + - Left side: + Certainly false: ∀n. n > 0 + Found counterexample: + n = 0 + - Right side: + Possibly false: ∃n. 2 * n == 1 + No example was found; checked 100 possibilities. + - Possibly false: (∃n. 2 * n == 1) /\ (∃n. 2 * n == 0) + - Left side: + Possibly false: ∃n. 2 * n == 1 + No example was found; checked 100 possibilities. + - Right side: + Certainly true: ∃n. 2 * n == 0 + Found example: + n = 0 + - Possibly false: (∃n. 2 * n == 1) /\ (∀n. n >= 0) + - Left side: + Possibly false: ∃n. 2 * n == 1 + No example was found; checked 100 possibilities. + - Right side: + Possibly true: ∀n. n >= 0 + Checked 100 possibilities without finding a counterexample. + - Certainly false: (∃n. 2 * n == 1) /\ (∀n. n > 0) + - Left side: + Possibly false: ∃n. 2 * n == 1 + No example was found; checked 100 possibilities. + - Right side: + Certainly false: ∀n. n > 0 + Found counterexample: + n = 0 + - Possibly false: (∃n. 2 * n == 1) /\ (∃n. 2 * n == 1) + - Left side: + Possibly false: ∃n. 2 * n == 1 + No example was found; checked 100 possibilities. + - Right side: + Possibly false: ∃n. 2 * n == 1 + No example was found; checked 100 possibilities. + - Certainly true: (∃n. 2 * n == 0) \/ (∃n. 2 * n == 0) + - Left side: + Certainly true: ∃n. 2 * n == 0 + Found example: + n = 0 + - Right side: + Certainly true: ∃n. 2 * n == 0 + Found example: + n = 0 + - Certainly true: (∃n. 2 * n == 0) \/ (∀n. n >= 0) + - Left side: + Certainly true: ∃n. 2 * n == 0 + Found example: + n = 0 + - Right side: + Possibly true: ∀n. n >= 0 + Checked 100 possibilities without finding a counterexample. + - Certainly true: (∃n. 2 * n == 0) \/ (∀n. n > 0) + - Left side: + Certainly true: ∃n. 2 * n == 0 + Found example: + n = 0 + - Right side: + Certainly false: ∀n. n > 0 + Found counterexample: + n = 0 + - Certainly true: (∃n. 2 * n == 0) \/ (∃n. 2 * n == 1) + - Left side: + Certainly true: ∃n. 2 * n == 0 + Found example: + n = 0 + - Right side: + Possibly false: ∃n. 2 * n == 1 + No example was found; checked 100 possibilities. + - Certainly true: (∀n. n >= 0) \/ (∃n. 2 * n == 0) + - Left side: + Possibly true: ∀n. n >= 0 + Checked 100 possibilities without finding a counterexample. + - Right side: + Certainly true: ∃n. 2 * n == 0 + Found example: + n = 0 + - Possibly true: (∀n. n >= 0) \/ (∀n. n >= 0) + - Left side: + Possibly true: ∀n. n >= 0 + Checked 100 possibilities without finding a counterexample. + - Right side: + Possibly true: ∀n. n >= 0 + Checked 100 possibilities without finding a counterexample. + - Possibly true: (∀n. n >= 0) \/ (∀n. n > 0) + - Left side: + Possibly true: ∀n. n >= 0 + Checked 100 possibilities without finding a counterexample. + - Right side: + Certainly false: ∀n. n > 0 + Found counterexample: + n = 0 + - Possibly true: (∀n. n >= 0) \/ (∃n. 2 * n == 1) + - Left side: + Possibly true: ∀n. n >= 0 + Checked 100 possibilities without finding a counterexample. + - Right side: + Possibly false: ∃n. 2 * n == 1 + No example was found; checked 100 possibilities. + - Certainly true: (∀n. n > 0) \/ (∃n. 2 * n == 0) + - Left side: + Certainly false: ∀n. n > 0 + Found counterexample: + n = 0 + - Right side: + Certainly true: ∃n. 2 * n == 0 + Found example: + n = 0 + - Possibly true: (∀n. n > 0) \/ (∀n. n >= 0) + - Left side: + Certainly false: ∀n. n > 0 + Found counterexample: + n = 0 + - Right side: + Possibly true: ∀n. n >= 0 + Checked 100 possibilities without finding a counterexample. + - Certainly false: (∀n. n > 0) \/ (∀n. n > 0) + - Left side: + Certainly false: ∀n. n > 0 + Found counterexample: + n = 0 + - Right side: + Certainly false: ∀n. n > 0 + Found counterexample: + n = 0 + - Possibly false: (∀n. n > 0) \/ (∃n. 2 * n == 1) + - Left side: + Certainly false: ∀n. n > 0 + Found counterexample: + n = 0 + - Right side: + Possibly false: ∃n. 2 * n == 1 + No example was found; checked 100 possibilities. + - Certainly true: (∃n. 2 * n == 1) \/ (∃n. 2 * n == 0) + - Left side: + Possibly false: ∃n. 2 * n == 1 + No example was found; checked 100 possibilities. + - Right side: + Certainly true: ∃n. 2 * n == 0 + Found example: + n = 0 + - Possibly true: (∃n. 2 * n == 1) \/ (∀n. n >= 0) + - Left side: + Possibly false: ∃n. 2 * n == 1 + No example was found; checked 100 possibilities. + - Right side: + Possibly true: ∀n. n >= 0 + Checked 100 possibilities without finding a counterexample. + - Possibly false: (∃n. 2 * n == 1) \/ (∀n. n > 0) + - Left side: + Possibly false: ∃n. 2 * n == 1 + No example was found; checked 100 possibilities. + - Right side: + Certainly false: ∀n. n > 0 + Found counterexample: + n = 0 + - Possibly false: (∃n. 2 * n == 1) \/ (∃n. 2 * n == 1) + - Left side: + Possibly false: ∃n. 2 * n == 1 + No example was found; checked 100 possibilities. + - Right side: + Possibly false: ∃n. 2 * n == 1 + No example was found; checked 100 possibilities. + - Certainly true: (∃n. 2 * n == 0) -> (∃n. 2 * n == 0) + - Left side: + Certainly true: ∃n. 2 * n == 0 + Found example: + n = 0 + - Right side: + Certainly true: ∃n. 2 * n == 0 + Found example: + n = 0 + - Possibly true: (∃n. 2 * n == 0) -> (∀n. n >= 0) + - Left side: + Certainly true: ∃n. 2 * n == 0 + Found example: + n = 0 + - Right side: + Possibly true: ∀n. n >= 0 + Checked 100 possibilities without finding a counterexample. + - Certainly false: (∃n. 2 * n == 0) -> (∀n. n > 0) + - Left side: + Certainly true: ∃n. 2 * n == 0 + Found example: + n = 0 + - Right side: + Certainly false: ∀n. n > 0 + Found counterexample: + n = 0 + - Possibly false: (∃n. 2 * n == 0) -> (∃n. 2 * n == 1) + - Left side: + Certainly true: ∃n. 2 * n == 0 + Found example: + n = 0 + - Right side: + Possibly false: ∃n. 2 * n == 1 + No example was found; checked 100 possibilities. + - Certainly true: (∀n. n >= 0) -> (∃n. 2 * n == 0) + - Left side: + Possibly true: ∀n. n >= 0 + Checked 100 possibilities without finding a counterexample. + - Right side: + Certainly true: ∃n. 2 * n == 0 + Found example: + n = 0 + - Possibly true: (∀n. n >= 0) -> (∀n. n >= 0) + - Left side: + Possibly true: ∀n. n >= 0 + Checked 100 possibilities without finding a counterexample. + - Right side: + Possibly true: ∀n. n >= 0 + Checked 100 possibilities without finding a counterexample. + - Possibly false: (∀n. n >= 0) -> (∀n. n > 0) + - Left side: + Possibly true: ∀n. n >= 0 + Checked 100 possibilities without finding a counterexample. + - Right side: + Certainly false: ∀n. n > 0 + Found counterexample: + n = 0 + - Possibly false: (∀n. n >= 0) -> (∃n. 2 * n == 1) + - Left side: + Possibly true: ∀n. n >= 0 + Checked 100 possibilities without finding a counterexample. + - Right side: + Possibly false: ∃n. 2 * n == 1 + No example was found; checked 100 possibilities. + - Certainly true: (∀n. n > 0) -> (∃n. 2 * n == 0) + - Left side: + Certainly false: ∀n. n > 0 + Found counterexample: + n = 0 + - Right side: + Certainly true: ∃n. 2 * n == 0 + Found example: + n = 0 + - Certainly true: (∀n. n > 0) -> (∀n. n >= 0) + - Left side: + Certainly false: ∀n. n > 0 + Found counterexample: + n = 0 + - Right side: + Possibly true: ∀n. n >= 0 + Checked 100 possibilities without finding a counterexample. + - Certainly true: (∀n. n > 0) -> (∀n. n > 0) + - Left side: + Certainly false: ∀n. n > 0 + Found counterexample: + n = 0 + - Right side: + Certainly false: ∀n. n > 0 + Found counterexample: + n = 0 + - Certainly true: (∀n. n > 0) -> (∃n. 2 * n == 1) + - Left side: + Certainly false: ∀n. n > 0 + Found counterexample: + n = 0 + - Right side: + Possibly false: ∃n. 2 * n == 1 + No example was found; checked 100 possibilities. + - Certainly true: (∃n. 2 * n == 1) -> (∃n. 2 * n == 0) + - Left side: + Possibly false: ∃n. 2 * n == 1 + No example was found; checked 100 possibilities. + - Right side: + Certainly true: ∃n. 2 * n == 0 + Found example: + n = 0 + - Possibly true: (∃n. 2 * n == 1) -> (∀n. n >= 0) + - Left side: + Possibly false: ∃n. 2 * n == 1 + No example was found; checked 100 possibilities. + - Right side: + Possibly true: ∀n. n >= 0 + Checked 100 possibilities without finding a counterexample. + - Possibly true: (∃n. 2 * n == 1) -> (∀n. n > 0) + - Left side: + Possibly false: ∃n. 2 * n == 1 + No example was found; checked 100 possibilities. + - Right side: + Certainly false: ∀n. n > 0 + Found counterexample: + n = 0 + - Possibly true: (∃n. 2 * n == 1) -> (∃n. 2 * n == 1) + - Left side: + Possibly false: ∃n. 2 * n == 1 + No example was found; checked 100 possibilities. + - Right side: + Possibly false: ∃n. 2 * n == 1 + No example was found; checked 100 possibilities. + - Possibly true: (∃n. 2 * n == 1) -> (∃n. 2 * n == 1) /\ (5 == 5 \/ (∀n. n < 5)) + - Left side: + Possibly false: ∃n. 2 * n == 1 + No example was found; checked 100 possibilities. + - Right side: + Possibly false: (∃n. 2 * n == 1) /\ (5 == 5 \/ (∀n. n < 5)) + - Left side: + Possibly false: ∃n. 2 * n == 1 + No example was found; checked 100 possibilities. + - Right side: + Certainly true: 5 == 5 \/ (∀n. n < 5) + - Left side: + Certainly true: 5 == 5 + - Right side: + Certainly false: ∀n. n < 5 + Found counterexample: + n = 5 diff --git a/test/prop-binary/input b/test/prop-binary/input new file mode 100644 --- /dev/null +++ b/test/prop-binary/input @@ -0,0 +1,49 @@ +:test (exists n:N. 2n == 0) /\ (exists n:N. 2n == 0) +:test (exists n:N. 2n == 0) /\ (forall n:N. n >= 0) +:test (exists n:N. 2n == 0) /\ (forall n:N. n > 0) +:test (exists n:N. 2n == 0) /\ (exists n:N. 2n == 1) +:test (forall n:N. n >= 0) /\ (exists n:N. 2n == 0) +:test (forall n:N. n >= 0) /\ (forall n:N. n >= 0) +:test (forall n:N. n >= 0) /\ (forall n:N. n > 0) +:test (forall n:N. n >= 0) /\ (exists n:N. 2n == 1) +:test (forall n:N. n > 0) /\ (exists n:N. 2n == 0) +:test (forall n:N. n > 0) /\ (forall n:N. n >= 0) +:test (forall n:N. n > 0) /\ (forall n:N. n > 0) +:test (forall n:N. n > 0) /\ (exists n:N. 2n == 1) +:test (exists n:N. 2n == 1) /\ (exists n:N. 2n == 0) +:test (exists n:N. 2n == 1) /\ (forall n:N. n >= 0) +:test (exists n:N. 2n == 1) /\ (forall n:N. n > 0) +:test (exists n:N. 2n == 1) /\ (exists n:N. 2n == 1) +:test (exists n:N. 2n == 0) \/ (exists n:N. 2n == 0) +:test (exists n:N. 2n == 0) \/ (forall n:N. n >= 0) +:test (exists n:N. 2n == 0) \/ (forall n:N. n > 0) +:test (exists n:N. 2n == 0) \/ (exists n:N. 2n == 1) +:test (forall n:N. n >= 0) \/ (exists n:N. 2n == 0) +:test (forall n:N. n >= 0) \/ (forall n:N. n >= 0) +:test (forall n:N. n >= 0) \/ (forall n:N. n > 0) +:test (forall n:N. n >= 0) \/ (exists n:N. 2n == 1) +:test (forall n:N. n > 0) \/ (exists n:N. 2n == 0) +:test (forall n:N. n > 0) \/ (forall n:N. n >= 0) +:test (forall n:N. n > 0) \/ (forall n:N. n > 0) +:test (forall n:N. n > 0) \/ (exists n:N. 2n == 1) +:test (exists n:N. 2n == 1) \/ (exists n:N. 2n == 0) +:test (exists n:N. 2n == 1) \/ (forall n:N. n >= 0) +:test (exists n:N. 2n == 1) \/ (forall n:N. n > 0) +:test (exists n:N. 2n == 1) \/ (exists n:N. 2n == 1) +:test (exists n:N. 2n == 0) -> (exists n:N. 2n == 0) +:test (exists n:N. 2n == 0) -> (forall n:N. n >= 0) +:test (exists n:N. 2n == 0) -> (forall n:N. n > 0) +:test (exists n:N. 2n == 0) -> (exists n:N. 2n == 1) +:test (forall n:N. n >= 0) -> (exists n:N. 2n == 0) +:test (forall n:N. n >= 0) -> (forall n:N. n >= 0) +:test (forall n:N. n >= 0) -> (forall n:N. n > 0) +:test (forall n:N. n >= 0) -> (exists n:N. 2n == 1) +:test (forall n:N. n > 0) -> (exists n:N. 2n == 0) +:test (forall n:N. n > 0) -> (forall n:N. n >= 0) +:test (forall n:N. n > 0) -> (forall n:N. n > 0) +:test (forall n:N. n > 0) -> (exists n:N. 2n == 1) +:test (exists n:N. 2n == 1) -> (exists n:N. 2n == 0) +:test (exists n:N. 2n == 1) -> (forall n:N. n >= 0) +:test (exists n:N. 2n == 1) -> (forall n:N. n > 0) +:test (exists n:N. 2n == 1) -> (exists n:N. 2n == 1) +:test (exists n:N. 2n == 1) -> ((exists n:N. 2n == 1) /\ (5 == 5 \/ (forall n:N. n < 5))) diff --git a/test/prop-fail/expected b/test/prop-fail/expected --- a/test/prop-fail/expected +++ b/test/prop-fail/expected @@ -1,21 +1,20 @@ Loading bad-tests.disco... Running tests... badmap: - - Test failed: badmap(λx. x / 0)([3, 4, 5]) =!= [6, 7, 8] - Error: division by zero. - - Test result mismatch for: badmap(λx. x)([1, 2]) =!= [1, 2] + - Certainly false: badmap(λx. x / 0)([3, 4, 5]) =!= [6, 7, 8] + Test failed with an error: + Error: division by zero. + - Certainly false: badmap(λx. x)([1, 2]) =!= [1, 2] - Left side: [1, 1, 2, 2, 3] - Right side: [1, 2] - - Test is false: badmap(λx. x + 1)([3, 4]) > [5, 6] + - Certainly false: badmap(λx. x + 1)([3, 4]) > [5, 6] divide: - - Test failed: ∀a, b. divide(a)(b) * b =!= a - Error: division by zero. - Counterexample: - a = 0 - b = 0 - - Test is false: ∀a. divide(a)(2) < a - Counterexample: + - Certainly false: ∀a, b. divide(a)(b) * b =!= a + Test failed with an error: + Error: division by zero. + - Certainly false: ∀a. divide(a)(2) < a + Found counterexample: a = 0 - - No example was found: ∃a. divide(a)(2) =!= abs(a) + 1 - Checked 50 possibilities. + - Possibly false: ∃a. divide(a)(2) =!= abs(a) + 1 + No example was found; checked 50 possibilities. Loaded. diff --git a/test/prop-higher-order/expected b/test/prop-higher-order/expected --- a/test/prop-higher-order/expected +++ b/test/prop-higher-order/expected @@ -1,19 +1,10 @@ Loading higher-order.disco... -Running tests... - pand: OK - por: OK Loaded. - - Test passed: ∀x. por(x =!= 0, ∃n. n * x >= 1) + - Possibly true: ∀x. x =!= 0 \/ (∃n. n * x >= 1) Checked 100 possibilities without finding a counterexample. - - Test passed: ∀f. any([∀x. f(x) =!= not x, ∀x. f(x) =!= x, ∀x. f(x) =!= false, ∀x. f(x) =!= true]) - No counterexamples exist. - - Test is false: all([true, true, true, false, true]) - Counterexample: - and_side = right(■) - and_side = right(■) - and_side = right(■) - and_side = left(■) - - Test passed: ∃k. hasFactors(2 ^ k + 1) + - Certainly true: ∀f. any([∀x. f(x) =!= not x, ∀x. f(x) =!= x, ∀x. f(x) =!= false, ∀x. f(x) =!= true]) + No counterexamples exist; all possible values were checked. + - Certainly false: all([true, true, true, false, true]) + - Certainly true: ∃k. hasFactors(2 ^ k + 1) Found example: k = 3 - n = 3 diff --git a/test/prop-higher-order/higher-order.disco b/test/prop-higher-order/higher-order.disco --- a/test/prop-higher-order/higher-order.disco +++ b/test/prop-higher-order/higher-order.disco @@ -1,30 +1,8 @@ -||| 'and' for propositions. - -!!! pand(true, true) - -pand : Prop * Prop -> Prop -pand(p, q) = forall and_side : Unit + Unit. {? - p when and_side is left _, - q otherwise - ?} - all : List(Prop) -> Prop -all ps = reduce(pand, true, ps) - -||| 'or' for propositions. - -!!! por(false, true) -!!! por(true, false) -!!! por(true, true) - -por : Prop * Prop -> Prop -por(p, q) = exists or_side : Unit + Unit. {? - p when or_side is left _, - q otherwise - ?} +all ps = reduce(~/\~, true, ps) any : List(Prop) -> Prop -any ps = reduce(por, false, ps) +any ps = reduce(~\/~, false, ps) ||| Assert that a proposition holds on some number in a range. diff --git a/test/prop-higher-order/input b/test/prop-higher-order/input --- a/test/prop-higher-order/input +++ b/test/prop-higher-order/input @@ -1,5 +1,5 @@ :load test/prop-higher-order/higher-order.disco -:test forall x:F. por(x =!= 0, exists n:N. n * x >= 1) +:test forall x:F. (x =!= 0) \/ (exists n:N. n * x >= 1) :test forall f:Bool->Bool. any [forall (x: Bool). f x =!= not x, forall (x: Bool). f x =!= x, forall (x: Bool). f x =!= false, forall (x: Bool). f x =!= true] :test all [true, true, true, false, true] :test exists k:N. hasFactors(2^k + 1) diff --git a/test/prop-tests/prop-tests.disco b/test/prop-tests/prop-tests.disco --- a/test/prop-tests/prop-tests.disco +++ b/test/prop-tests/prop-tests.disco @@ -48,7 +48,7 @@ !!! ∀ v:Void. 2 == 3 -- this is true! !!! ∀ u:Unit. u == u -- there is only one Unit value !!! ∀ l:List(Void). l == l -!!! ∀ l:List(Unit). l == reverse l +-- !!! ∀ l:List(Unit). l == reverse l -- too slow! !!! ∀ bs : List(Bool). toBin (fromBin bs) == bs !!! ∀ q : F. q >= 0 !!! ∀ p : N * N. {? x + y when p is (x,y) ?} >= 0 diff --git a/test/prop-type/expected b/test/prop-type/expected --- a/test/prop-type/expected +++ b/test/prop-type/expected @@ -4,9 +4,6 @@ ∃x : ℕ. ∃y : ℕ. x > y : Prop ∀x : ℕ, y : ℕ, z : ℕ. x + y + z == x + (y + z) : Prop ∃x : ℕ. ∀y : ℕ. x <= y : Prop -Error: typechecking failed. -https://disco-lang.readthedocs.io/en/latest/reference/typecheck-fail.html -Error: typechecking failed. -https://disco-lang.readthedocs.io/en/latest/reference/typecheck-fail.html -Error: typechecking failed. -https://disco-lang.readthedocs.io/en/latest/reference/typecheck-fail.html +not(∀x : Bool. true \/ x) : Prop +(∀x : Void. false) /\ true : Prop +(∀x : Void. false) \/ true : Prop diff --git a/test/repl-ann/expected b/test/repl-ann/expected --- a/test/repl-ann/expected +++ b/test/repl-ann/expected @@ -1,3 +1,3 @@ Loading num.disco... factor : ℕ → Bag(ℕ) -(λx : ℤ, y : a. (~-~ : ℤ × ℤ → ℤ)((x : ℤ, 7 : ℤ) : ℤ × ℤ) : ℤ) : ℤ → a3 → ℤ +(λx : ℤ. (λy : a. (~-~ : ℤ × ℤ → ℤ)((x : ℤ, 7 : ℤ) : ℤ × ℤ) : ℤ) : a3 → ℤ) : ℤ → a3 → ℤ diff --git a/test/repl-ann/input b/test/repl-ann/input --- a/test/repl-ann/input +++ b/test/repl-ann/input @@ -1,3 +1,3 @@ import num :ann factor -:ann \x, y. x - 7 +:ann \x. \y. x - 7 diff --git a/test/repl-doc/expected b/test/repl-doc/expected --- a/test/repl-doc/expected +++ b/test/repl-doc/expected @@ -1,3 +1,7 @@ +append : List(a) × List(a) → List(a) + +Append two lists into a single list. + Loading doc.disco... Running tests... f: OK diff --git a/test/repl-doc/input b/test/repl-doc/input --- a/test/repl-doc/input +++ b/test/repl-doc/input @@ -1,3 +1,4 @@ +:doc append :load test/repl-doc/doc.disco :doc P :doc f diff --git a/test/repl-proptest/expected b/test/repl-proptest/expected --- a/test/repl-proptest/expected +++ b/test/repl-proptest/expected @@ -1,12 +1,12 @@ - - Test passed: not false - - Test passed: {1, 2} =!= {2, 1} - - Test passed: ∃a, b. (a /\ b) =!= (a \/ b) + - Certainly true: not false + - Certainly true: {1, 2} =!= {2, 1} + - Left side: {1, 2} + - Right side: {1, 2} + - Certainly true: ∃a, b. (a /\ b) =!= (a \/ b) Found example: a = false b = false - - Test result mismatch for: ∀a, b. (a /\ b) =!= (a \/ b) - - Left side: false - - Right side: true - Counterexample: + - Certainly false: ∀a, b. (a /\ b) =!= (a \/ b) + Found counterexample: a = false b = true diff --git a/test/syntax-clause/input b/test/syntax-clause/input --- a/test/syntax-clause/input +++ b/test/syntax-clause/input @@ -1,3 +1,3 @@ :load test/syntax-clause/clauses.disco -zipWithN (\x, y. x*y + 1) [1,2,3] [4,5,6] +zipWithN (\x. \y. x*y + 1) [1,2,3] [4,5,6] append ([1,2,3], [4,5,6]) diff --git a/test/syntax-ellipsis/expected b/test/syntax-ellipsis/expected new file mode 100644 --- /dev/null +++ b/test/syntax-ellipsis/expected @@ -0,0 +1,10 @@ +[1, 2, 3, 4] +[1, 2, 3, 4] +[1, 2, 3, 4] +[1, 2, 3, 4] +[1, 2, 3, 4] +[1, 2, 3, 4] +[1, 2, 3, 4] +[1, 2, 3, 4] +[1, 2, 3, 4] +[1, 2, 3, 4] diff --git a/test/syntax-ellipsis/input b/test/syntax-ellipsis/input new file mode 100644 --- /dev/null +++ b/test/syntax-ellipsis/input @@ -0,0 +1,10 @@ +[1 .. 4] +[1 ,.. 4] +[1, .. 4] +[1,..4] +[1 , .. , 4] +[1 .. , 4] +[1, 2 .. 4] +[1, 2, .. 4] +[1, 2, .., 4] +[1, 2 .., 4] diff --git a/test/syntax-lambda-pat/expected b/test/syntax-lambda-pat/expected --- a/test/syntax-lambda-pat/expected +++ b/test/syntax-lambda-pat/expected @@ -4,4 +4,4 @@ 10 ((1, 3), 2, 4) 42 -λf, (a, b). f(a)(b) : (a2 → a1 → a) → a2 × a1 → a +λf. λ(a, b). f(a)(b) : (a2 → a1 → a) → a2 × a1 → a diff --git a/test/syntax-lambda-pat/input b/test/syntax-lambda-pat/input --- a/test/syntax-lambda-pat/input +++ b/test/syntax-lambda-pat/input @@ -2,6 +2,6 @@ let f2 = \(x:N, y:N). x + y in f2 (1, 2) let f3 = \((x, y) : N*N). x + y in f3 (1, 2) let h = \left (x, y). x in h (left (10, -10)) -let fwop = \(x1, y1), (x2, y2). ((x1, x2), (y1, y2)) in fwop (1, 2) (3, 4) -let uncurry = \f, (a, b). f a b in uncurry (\a, b. a + b) (40, 2) -:type \f, (a, b). f a b +let fwop = \((x1, y1), (x2, y2)). ((x1, x2), (y1, y2)) in fwop((1, 2), (3, 4)) +let uncurry = \f. \(a, b). f a b in uncurry (\a. \b. a + b) (40, 2) +:type \f. \(a, b). f a b diff --git a/test/syntax-lambda/expected b/test/syntax-lambda/expected --- a/test/syntax-lambda/expected +++ b/test/syntax-lambda/expected @@ -6,9 +6,17 @@ let f = λx. x + 1 : ℕ in f : ℕ → ℕ (9, 8) 5 -λx : ℤ, y : ℕ. x * y : ℤ → ℕ → ℤ +λx : ℤ. λy : ℕ. x * y : ℤ → ℕ → ℤ [false, true, true] -let f = λg : ℤ → ℕ → Bool. [g(1)(1), g(1)(2), g(-1)(0)] in f(λx, y : ℤ. x + 1 == y) : List(Bool) +let f = λg : ℤ → ℕ → Bool. [g(1)(1), g(1)(2), g(-1)(0)] in f(λx. λy : ℤ. x + 1 == y) : List(Bool) 3 TAbs_ Lam () (<[PWild_ ()]> TNat_ () 3) 3 +1:13: + | +1 | :parse \x, y. x + | ^ +Anonymous functions (lambdas) can only have a single argument. +Instead of \x, y. ... you can write \x. \y. ... +https://disco-lang.readthedocs.io/en/latest/reference/anonymous-func.html + diff --git a/test/syntax-lambda/input b/test/syntax-lambda/input --- a/test/syntax-lambda/input +++ b/test/syntax-lambda/input @@ -4,11 +4,12 @@ :type let f = (λx. x + 1) : N -> N in f :type let f = λx. (x + 1 : N) in f :type let f = λx. x + 1 : N in f -let g = λx:N, b:Bool.{? x*x if b, x+2 otherwise ?} in (g 3 true, g 6 false) +let g = λx:N. λb:Bool.{? x*x if b, x+2 otherwise ?} in (g 3 true, g 6 false) let q = \ (f : (N -> N) -> N) . f (\(x:N) . x*x) in q (\g. g 1 + g 2) -:type (\ x:Z, y:N . x * y) -let f = \(g : Z -> N -> Bool).[g 1 1, g 1 2, g (-1) 0] in f (\x, y:Z. x + 1 == y) -:type let f = \(g : Z -> N -> Bool).[g 1 1, g 1 2, g (-1) 0] in f (\x, y:Z. x + 1 == y) +:type (\ x:Z. \y:N . x * y) +let f = \(g : Z -> N -> Bool).[g 1 1, g 1 2, g (-1) 0] in f (\x. \y:Z. x + 1 == y) +:type let f = \(g : Z -> N -> Bool).[g 1 1, g 1 2, g (-1) 0] in f (\x. \y:Z. x + 1 == y) let f : N -> N -> N = \x.\y.x+y in f 1 2 :parse \_.3 (\_.3) "hello" +:parse \x, y. x diff --git a/test/types-192/expected b/test/types-192/expected --- a/test/types-192/expected +++ b/test/types-192/expected @@ -1,1 +1,1 @@ -λx, y, z. x + y / z : 𝔽 → 𝔽 → 𝔽 → 𝔽 +λx. λy. λz. x + y / z : 𝔽 → 𝔽 → 𝔽 → 𝔽 diff --git a/test/types-192/input b/test/types-192/input --- a/test/types-192/input +++ b/test/types-192/input @@ -1,1 +1,1 @@ -:type \x,y,z. x + y / z +:type \x. \y. \z. x + y / z diff --git a/test/types-306/expected b/test/types-306/expected --- a/test/types-306/expected +++ b/test/types-306/expected @@ -1,13 +1,13 @@ -Error: the shape of two types does not match. -https://disco-lang.readthedocs.io/en/latest/reference/shape-mismatch.html -Error: the shape of two types does not match. -https://disco-lang.readthedocs.io/en/latest/reference/shape-mismatch.html +Error: values of type a3 → a4 cannot be compared. +https://disco-lang.readthedocs.io/en/latest/reference/not-qual.html +Error: values of type a8 → a9 cannot be compared. +https://disco-lang.readthedocs.io/en/latest/reference/not-qual.html Error: values of type Bool → Bool cannot be compared. https://disco-lang.readthedocs.io/en/latest/reference/not-qual.html -Error: values of type a5 → a6 cannot be compared. +Error: values of type a6 → a7 cannot be compared. https://disco-lang.readthedocs.io/en/latest/reference/not-qual.html -Error: the shape of two types does not match. -https://disco-lang.readthedocs.io/en/latest/reference/shape-mismatch.html -Error: the shape of two types does not match. -https://disco-lang.readthedocs.io/en/latest/reference/shape-mismatch.html +Error: values of type a3 → a4 cannot be compared. +https://disco-lang.readthedocs.io/en/latest/reference/not-qual.html +Error: values of type a16 → a17 are not boolean. +https://disco-lang.readthedocs.io/en/latest/reference/not-qual.html {} diff --git a/test/types-357/expected b/test/types-357/expected new file mode 100644 --- /dev/null +++ b/test/types-357/expected @@ -0,0 +1,6 @@ +While checking REPL.f: + Error: typechecking failed. + https://disco-lang.readthedocs.io/en/latest/reference/typecheck-fail.html +While checking REPL.sumto: + Error: typechecking failed. + https://disco-lang.readthedocs.io/en/latest/reference/typecheck-fail.html diff --git a/test/types-357/input b/test/types-357/input new file mode 100644 --- /dev/null +++ b/test/types-357/input @@ -0,0 +1,5 @@ +f : Z -> N +f(n) = 2n + +sumto : N -> N +sumto(n) = (n^2 + n)*(0.5) diff --git a/test/types-char-string/expected b/test/types-char-string/expected --- a/test/types-char-string/expected +++ b/test/types-char-string/expected @@ -12,7 +12,7 @@ 2 3 (λx. {? 1 when x is 'a' - ?})("Disco") +?})("Disco") 1:3: | 1 | ' a' diff --git a/test/types-ops/expected b/test/types-ops/expected --- a/test/types-ops/expected +++ b/test/types-ops/expected @@ -1,4 +1,3 @@ -Loading list.disco... right(0) right(1) right(2) diff --git a/test/types-tydef-param/types-tydef-param.disco b/test/types-tydef-param/types-tydef-param.disco --- a/test/types-tydef-param/types-tydef-param.disco +++ b/test/types-tydef-param/types-tydef-param.disco @@ -13,12 +13,12 @@ type Tree(a) = Unit + a * Tree(a) * Tree(a) -foldTree : r -> (a -> r -> r -> r) -> Tree(a) -> r +foldTree : r -> (a * r * r -> r) -> Tree(a) -> r foldTree z f (left(■)) = z -foldTree z f (right (a,l,r)) = f a (foldTree z f l) (foldTree z f r) +foldTree z f (right (a,l,r)) = f (a, foldTree z f l, foldTree z f r) sumTree : Tree(N) -> N -sumTree = foldTree 0 (\a, l, r. a+l+r) +sumTree = foldTree 0 (\(a, l, r). a+l+r) t : Tree(N) t = right (5, right (2, left(■), left(■)), right (7, right (1, left(■), left(■)), left(■))) @@ -29,9 +29,9 @@ alt1 : AltList(N, Bool) alt1 = right (3, right (true, right (5, right (false, right (7, left(■)))))) -foldAltList : r -> (a -> r -> r) -> (b -> r -> r) -> AltList(a, b) -> r +foldAltList : r -> (a * r -> r) -> (b * r -> r) -> AltList(a, b) -> r foldAltList z _ _ (left(■)) = z -foldAltList z f g (right (a, l)) = f a (foldAltList z g f l) +foldAltList z f g (right (a, l)) = f(a, foldAltList z g f l) sumAltList : AltList(N,Bool) -> N -sumAltList = foldAltList 0 (\x, y. x+y) (\b, r. r) +sumAltList = foldAltList 0 (\(x,y). x+y) (\(b,r). r)