language-dickinson (empty) → 0.1.0.0
raw patch · 80 files changed
+4482/−0 lines, 80 filesdep +arraydep +basedep +binary
Dependencies added: array, base, binary, bytestring, composition-prelude, containers, criterion, deepseq, directory, filepath, haskeline, language-dickinson, microlens, microlens-mtl, mtl, optparse-applicative, pretty-simple, prettyprinter, random, semigroups, tasty, tasty-golden, tasty-hunit, text, transformers, zstd
Files
- CHANGELOG.md +5/−0
- LICENSE +11/−0
- README.md +41/−0
- bench/Bench.hs +74/−0
- examples/doggo.dck +18/−0
- examples/fortune.dck +39/−0
- examples/hotTake.dck +67/−0
- examples/shakespeare.dck +158/−0
- language-dickinson.cabal +247/−0
- lib/animal.dck +54/−0
- lib/birds.dck +14/−0
- lib/color.dck +108/−0
- lib/fruit.dck +21/−0
- lib/gemstone.dck +11/−0
- lib/nut.dck +9/−0
- lib/states.dck +11/−0
- lib/vegetable.dck +14/−0
- man/emd.1 +77/−0
- prelude/curry.dck +13/−0
- prelude/tuple.dck +16/−0
- public/Language/Dickinson.hs +36/−0
- run/Main.hs +86/−0
- run/REPL.hs +195/−0
- run/REPL/Save.hs +34/−0
- src/Control/Exception/Value.hs +16/−0
- src/Control/Monad/Ext.hs +13/−0
- src/Data/Foldable/Ext.hs +7/−0
- src/Data/Text/Prettyprint/Doc/Ext.hs +73/−0
- src/Data/Tuple/Ext.hs +5/−0
- src/Language/Dickinson/Check.hs +53/−0
- src/Language/Dickinson/Check/Internal.hs +66/−0
- src/Language/Dickinson/Check/Pattern.hs +21/−0
- src/Language/Dickinson/DuplicateCheck.hs +50/−0
- src/Language/Dickinson/Error.hs +66/−0
- src/Language/Dickinson/Eval.hs +298/−0
- src/Language/Dickinson/File.hs +99/−0
- src/Language/Dickinson/Import.hs +28/−0
- src/Language/Dickinson/Lexer.x +292/−0
- src/Language/Dickinson/Lib.hs +16/−0
- src/Language/Dickinson/Lib/Get.hs +59/−0
- src/Language/Dickinson/Name.hs +47/−0
- src/Language/Dickinson/Parser.y +225/−0
- src/Language/Dickinson/Rename.hs +173/−0
- src/Language/Dickinson/Rename/Amalgamate.hs +39/−0
- src/Language/Dickinson/ScopeCheck.hs +80/−0
- src/Language/Dickinson/Type.hs +156/−0
- src/Language/Dickinson/TypeCheck.hs +121/−0
- src/Language/Dickinson/Unique.hs +20/−0
- test/Eval.hs +46/−0
- test/Golden.hs +54/−0
- test/Spec.hs +98/−0
- test/TypeCheck.hs +26/−0
- test/data/adt.dck +9/−0
- test/data/adt.pretty +9/−0
- test/data/color.dck +2/−0
- test/data/const.dck +11/−0
- test/data/escaped.dck +4/−0
- test/data/escaped.pretty +4/−0
- test/data/hangIndefinitely.dck +22/−0
- test/data/higherOrder.dck +10/−0
- test/data/higherOrder.rename +100/−0
- test/data/import.dck +6/−0
- test/data/import.pretty +6/−0
- test/data/lambda.dck +10/−0
- test/data/lambda.rename +98/−0
- test/data/let.dck +9/−0
- test/data/let.rename +65/−0
- test/data/multiLet.dck +16/−0
- test/data/multiLet.rename +113/−0
- test/data/multiple.dck +16/−0
- test/data/nestInterp.dck +4/−0
- test/data/nestInterp.pretty +4/−0
- test/data/nestLet.dck +10/−0
- test/data/nestLet.pretty +10/−0
- test/data/nestLet.rename +148/−0
- test/data/quoteify.dck +10/−0
- test/data/quoteify.rename +93/−0
- test/data/tuple.dck +14/−0
- test/data/tupleRename.dck +8/−0
- test/data/tupleRename.rename +65/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# dickinson++## 0.1.0.0++Initial release
+ LICENSE view
@@ -0,0 +1,11 @@+Copyright Vanessa McHale (c) 2020++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,41 @@+# Dickinson++Dickinson is a text-generation language.++## Installation++To install, first download [cabal-install](https://www.haskell.org/cabal/) and+[GHC](https://www.haskell.org/ghc/download.html). Then:++```+cabal install language-dickinson+```++### Editor Integration++Editor integration is available for vim.++Using [vim-plug](https://github.com/junegunn/vim-plug):++```vimscript+Plug 'vmchale/dickinson' , { 'rtp' : 'vim' }+```++## Documentation++A user guide is available in+[markdown](https://github.com/vmchale/dickinson/blob/master/doc/user-guide.md)+and as+a [pdf](https://github.com/vmchale/dickinson/blob/master/doc/user-guide.pdf).++See `man/emd.1` for man pages.++### Examples++An riff on the Unix fortune program is available+[here](https://github.com/vmchale/dickinson/blob/master/examples/fortune.dck).+Try++```+emd run examples/fortune.dck+```
+ bench/Bench.hs view
@@ -0,0 +1,74 @@+module Main (main) where++import Control.Exception (throw)+import Control.Monad (void)+import Criterion.Main+import Data.Binary (decode, encode)+import qualified Data.ByteString.Lazy as BSL+import Language.Dickinson.Check+import Language.Dickinson.DuplicateCheck+import Language.Dickinson.File+import Language.Dickinson.Lexer+import Language.Dickinson.Parser+import Language.Dickinson.Rename+import Language.Dickinson.ScopeCheck+import Language.Dickinson.Type+import Language.Dickinson.Unique++main :: IO ()+main =+ defaultMain [ env parses $ \ ~(c, s) ->+ bgroup "parse"+ [ bench "lib/color.dck" $ nf parse c+ , bench "lex lib/color.dck" $ nf lexDickinson c+ , bench "examples/shakespeare.dck" $ nf parse s+ ]+ , env libParsed $ \p ->+ bgroup "renamer"+ [ bench "bench/data/nestLet.dck" $ nf plainExpr p+ ]+ , env (plainExpr <$> libParsed) $ \ ~(Dickinson _ r) ->+ bgroup "scope checker"+ [ bench "bench/data/nestLet.dck" $ nf checkScope r+ ]+ , env (void <$> multiParsed) $ \p ->+ bgroup "encoder"+ [ bench "bench/data/multiple.dck" $ nf encode p+ ]+ , env encodeEnv $ \ ~(e, es) ->+ bgroup "decoder"+ [ bench "bench/data/multiple.dck" $ nf (decode :: BSL.ByteString -> Dickinson ()) e+ , bench "examples/shakespeare.dck" $ nf (decode :: BSL.ByteString -> Dickinson ()) es+ ]+ , env multiParsed $ \ ~(Dickinson _ p) ->+ bgroup "check"+ [ bench "bench/data/multiple.dck" $ nf checkMultiple p+ , bench "bench/data/multiple.dck" $ nf checkDuplicates p -- TODO: better example+ ]+ , bgroup "result"+ [ bench "test/eval/context.dck" $ nfIO (evalFile [] "test/eval/context.dck")+ , bench "examples/shakespeare.dck" $ nfIO (evalFile [] "examples/shakespeare.dck")+ , bench "examples/doggo.dck" $ nfIO (evalFile ["prelude"] "examples/doggo.dck")+ , bench "test/demo/animal.dck" $ nfIO (evalFile ["lib"] "test/demo/animal.dck")+ , bench "examples/hotTake.dck" $ nfIO (evalFile [] "examples/hotTake.dck")+ , bench "examples/fortune.dck" $ nfIO (evalFile [] "examples/fortune.dck")+ ]+ , bgroup "pipeline"+ [ bench "examples/shakespeare.dck" $ nfIO (pipeline [] "examples/shakespeare.dck")+ ]+ , bgroup "tcFile"+ [ bench "examples/hotTake.dck" $ nfIO (tcFile [] "examples/hotTake.dck")+ ]+ ]++ where libFile = BSL.readFile "lib/color.dck"+ shakespeare = BSL.readFile "examples/shakespeare.dck"+ parses = (,) <$> libFile <*> shakespeare+ libParsed = either throw id . parseWithMax <$> BSL.readFile "bench/data/nestLet.dck"+ multiParsed = either throw id . parse <$> BSL.readFile "bench/data/multiple.dck"+ encoded = encode . void <$> multiParsed+ encodeShakespeare = encode . void . either throw id . parse <$> shakespeare+ encodeEnv = (,) <$> encoded <*> encodeShakespeare++plainExpr :: (UniqueCtx, Dickinson a) -> Dickinson a+plainExpr = fst . uncurry renameDickinson
+ examples/doggo.dck view
@@ -0,0 +1,18 @@+(:include tuple)++%-++; tydecl sex = Boy | Girl++; see https://github.com/vmchale/doggo-command-line/blob/master/src/main.rs+(:def greeter+ (:lambda dog (text, text)+ (:match dog+ (name, pronoun)+ (:oneof+ (| "${name} is a heckin' fine floofer")+ (| "${name} is a good woofer")+ (| "${name} eats toilet paper sometimes but ${pronoun} tries.")))))++(:def main+ ($ greeter ("Maxine", "she")))
+ examples/fortune.dck view
@@ -0,0 +1,39 @@+; This is a riff on the Unix fortune program.+; See https://en.wikipedia.org/wiki/Fortune_%28Unix%29 for more context++%-++(:def quote+ (:lambda q (text, text)+ (:match q (qu, name)+ "${qu}\n — ${name}")))++(:def fortune+ (:oneof+ (| "Fight god constantly.")+ (| "You will be let down by someone close to you.")+ (| "I'm not high-strung. I'm strung precisely as I am meant to be.")+ (| "Do not fail.")+ (| "Trim the fat.")+ (| "The world rewards vigilance")+ (| "Wash your hands with soap and water for at least 20 seconds.")+ (| "Cleanliness is next to godliness.")+ (| "Do not complain.")+ (| "There is no such thing as metaphors.")+ (| "Excess is a sin.")+ (| "Sex wastes the male body.")+ (| "Cultivate weakness.")+ (| "Beauty is a moral imperative.")+ (| "We are all damned by our own personalities. That is beauty.")+ (| "To err is immoral.")+ (| $ quote ("« Le beau est ce qu'on désire sans vouloir le manger. »", "Simone Weil"))+ (| $ quote ("\"You're more likely to get cut with a dull tool than a sharp one.\"", "Fiona Apple"))+ (| $ quote ("\"You forgot the difference between equanimity and passivity.\"", "Fiona Apple"))+ (| $ quote ("\"I don't believe in empirical science. I only believe in a priori truth.\"", "Kurt Gödel")) ; german? hm+ (| "Obedience is a virtue.")+ (| "\"You have potential,\" is an insult.")+ (| "Leisure is a sin")+ (| "Strive on all fronts")))++(:def main+ fortune)
+ examples/hotTake.dck view
@@ -0,0 +1,67 @@+%-++(:def unpopularize+ (:lambda opinion text+ (:branch+ (| 0.9 opinion)+ (| 0.1 "Unpopular opinion: ${opinion}"))))++(:def slur+ (:let+ [badWord+ (:oneof+ (| "crackhead")+ (| "'Privileged'"))]+ "${badWord} is a slur"))++; queering/ _ is queer++(:def normalize+ (:let+ [norm+ (:oneof+ (| "bidets")+ (| "breastfeeding your boyfriend")+ (| "not wearing deodorant")+ (| "being a virgin")+ (| "DWIs"))]+ "Normalize ${norm}"))++(:def abolish+ (:let+ [target+ (:oneof+ (| "credit scores")+ (| "the stock market")+ (| "parking tickets"))]+ "Abolish ${target}"))++(:def problematic+ (:let+ [bad+ (:oneof+ (| "Grades are")+ (| "The GRE is")+ (| "Masks are"))]+ "${bad} problematic"))++(:def toxic+ (:let+ [badThing+ (:oneof+ (| "brushing your teeth is")+ (| "masculinity is")+ (| "museums are"))]+ "${badThing} toxic."))++; cancel _++(:def main+ $ unpopularize+ (:flatten+ (:oneof+ (| normalize)+ (| toxic)+ (| problematic)+ (| slur)+ (| abolish))))
+ examples/shakespeare.dck view
@@ -0,0 +1,158 @@+; ported from madlang+%-++(:def adjective+ (:oneof+ (| "artless")+ (| "base-court")+ (| "bawdy")+ (| "bat-fowling")+ (| "beslubbering")+ (| "beef-witted")+ (| "bootless")+ (| "beetle-headed")+ (| "churlish")+ (| "boil-brained")+ (| "cockered")+ (| "clapper-clawed")+ (| "clouted")+ (| "clay-brained")+ (| "craven")+ (| "common-kissing")+ (| "currish")+ (| "crook-pated")+ (| "dankish")+ (| "dismal-dreaming")+ (| "dissembling")+ (| "dizzy-eyed")+ (| "droning")+ (| "doghearted")+ (| "errant")+ (| "dread-bolted")+ (| "earth-vexing")+ (| "elf-skinned")+ (| "fawning")+ (| "fobbing")+ (| "froward")+ (| "fat-kidneyed")+ (| "frothy")+ (| "fen-sucked")+ (| "gleeking")+ (| "flap-mouthed")+ (| "goatish")+ (| "fly-bitten")+ (| "gorbellied")+ (| "folly-fallen")+ (| "impertinent")+ (| "fool-born")+ (| "infectious")+ (| "full-gorged")+ (| "jarring")+ (| "guts-griping")+ (| "loggerheaded")+ (| "half-faced")+ (| "lumpish")+ (| "hasty-witted")+ (| "mammering")+ (| "hedge-born")+ (| "mangled")+ (| "hell-hated")+ (| "mewling")+ (| "idle-headed")+ (| "paunchy")+ (| "ill-breeding")+ (| "pribbling")+ (| "ill-nurtured")+ (| "puking")+ (| "knotty-pated")+ (| "puny")+ (| "milk-livered")+ (| "qualling")+ (| "motley-minded")+ (| "rank")+ (| "onion-eyed")+ (| "reeky")+ (| "plume-plucked")+ (| "roguish")+ (| "pottle-deep")+ (| "ruttish")+ (| "pox-marked")+ (| "saucy")+ (| "reeling-ripe")+ (| "spleeny")+ (| "rough-hewn")+ (| "spongy")+ (| "rude-growing")+ (| "surly")+ (| "rump-fed")+ (| "tottering")+ (| "shard-borne")+ (| "vain")+ (| "spur-galled")+ (| "venomed")+ (| "swag-bellied")+ (| "villainous")+ (| "tardy-gaited")+ (| "warped")+ (| "tickle-brained")+ (| "wayward")+ (| "toad-spotted")+ (| "weedy")+ (| "unchin-spotted")+ (| "yeasty")+ (| "weather-bitten")))++(:def noun+ (:oneof+ (| "apple-john")+ (| "baggage")+ (| "barnacle")+ (| "bladder")+ (| "boar-pig")+ (| "bugbear")+ (| "bum-bailey")+ (| "canker-blossom")+ (| "clack-dish")+ (| "clotpole")+ (| "coxcomb")+ (| "codpiece")+ (| "death-token")+ (| "dewberry")+ (| "flap-dragon")+ (| "flax-wench")+ (| "flirt-fill")+ (| "foot-licker")+ (| "fustilarian")+ (| "giglet")+ (| "gudgeon")+ (| "haggard")+ (| "harpy")+ (| "hedge-pig")+ (| "horn-beast")+ (| "hugger-mugger")+ (| "joithead")+ (| "lewdster")+ (| "lout")+ (| "maggot-pie")+ (| "malt-worm")+ (| "mammet")+ (| "measle")+ (| "minnow")+ (| "miscreant")+ (| "moldwarp")+ (| "mumble-news")+ (| "nut-hook")+ (| "pigeon-egg")+ (| "pignut")+ (| "puttock")+ (| "pumpion")+ (| "ratsbane")+ (| "scut")+ (| "skainsmate")+ (| "strumpet")+ (| "warlot")+ (| "vassal")+ (| "whey-face")))++(:def main+ ("Thou ${adjective} ${adjective} ${noun}!"))
+ language-dickinson.cabal view
@@ -0,0 +1,247 @@+cabal-version: 2.0+name: language-dickinson+version: 0.1.0.0+license: BSD3+license-file: LICENSE+copyright: Copyright: (c) 2020 Vanessa McHale+maintainer: vamchale@gmail.com+author: Vanessa McHale+tested-with:+ ghc ==8.0.2 ghc ==8.2.2 ghc ==8.4.4 ghc ==8.6.5 ghc ==8.8.3+ ghc ==8.10.1++synopsis: A language for generative literature+description: Dickinson is a language for generative (random) literature+category: Language, Text+build-type: Simple+data-files:+ man/emd.1+ lib/*.dck+ prelude/*.dck++extra-source-files:+ test/data/*.pretty+ test/data/*.dck+ test/data/*.rename+ examples/*.dck++extra-doc-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/vmchale/dickinson++flag cross+ description: Enable to ease cross-compiling+ default: False+ manual: True++library+ exposed-modules: Language.Dickinson+ hs-source-dirs: public+ other-modules: Paths_language_dickinson+ autogen-modules: Paths_language_dickinson+ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ base >=4.9 && <5,+ dickinson -any++ if impl(ghc >=8.0)+ ghc-options:+ -Wincomplete-uni-patterns -Wincomplete-record-updates+ -Wredundant-constraints -Widentities++ if impl(ghc >=8.4)+ ghc-options: -Wmissing-export-lists++ if impl(ghc >=8.2)+ ghc-options: -Wcpp-undef++ if impl(ghc >=8.10)+ ghc-options: -Wunused-packages++library dickinson+ exposed-modules:+ Language.Dickinson.Lexer+ Language.Dickinson.Name+ Language.Dickinson.Type+ Language.Dickinson.TypeCheck+ Language.Dickinson.Parser+ Language.Dickinson.Rename+ Language.Dickinson.Rename.Amalgamate+ Language.Dickinson.Eval+ Language.Dickinson.Error+ Language.Dickinson.Check+ Language.Dickinson.ScopeCheck+ Language.Dickinson.DuplicateCheck+ Language.Dickinson.Unique+ Language.Dickinson.File+ Language.Dickinson.Import+ Language.Dickinson.Lib+ Data.Tuple.Ext+ Control.Exception.Value+ Data.Text.Prettyprint.Doc.Ext++ hs-source-dirs: src+ other-modules:+ Paths_language_dickinson+ Language.Dickinson.Check.Pattern+ Language.Dickinson.Check.Internal+ Language.Dickinson.Lib.Get+ Control.Monad.Ext+ Data.Foldable.Ext++ autogen-modules: Paths_language_dickinson+ default-language: Haskell2010+ other-extensions:+ DeriveAnyClass DeriveFunctor DeriveGeneric FlexibleContexts+ GeneralizedNewtypeDeriving OverloadedStrings StandaloneDeriving+ TupleSections++ ghc-options: -Wall -O2+ build-depends:+ base >=4.9 && <5,+ bytestring -any,+ text -any,+ array -any,+ mtl -any,+ transformers -any,+ containers -any,+ random -any,+ prettyprinter -any,+ deepseq -any,+ microlens -any,+ microlens-mtl -any,+ composition-prelude >=1.1.0.1,+ binary >=0.8.4.0,+ filepath -any,+ directory -any++ if !flag(cross)+ build-tool-depends: alex:alex -any, happy:happy -any++ if !impl(ghc >=8.0)+ build-depends: semigroups -any++ if impl(ghc >=8.0)+ ghc-options:+ -Wincomplete-uni-patterns -Wincomplete-record-updates+ -Wredundant-constraints -Widentities++ if impl(ghc >=8.4)+ ghc-options: -Wmissing-export-lists++ if impl(ghc >=8.2)+ ghc-options: -Wcpp-undef++ if impl(ghc >=8.10)+ ghc-options: -Wunused-packages++executable emd+ main-is: Main.hs+ hs-source-dirs: run+ other-modules:+ REPL+ REPL.Save++ default-language: Haskell2010+ ghc-options: -Wall -rtsopts -with-rtsopts=-A4M+ build-depends:+ base -any,+ dickinson -any,+ optparse-applicative -any,+ bytestring -any,+ prettyprinter -any,+ text -any,+ haskeline >=0.8,+ mtl -any,+ random -any,+ microlens-mtl -any,+ microlens -any,+ containers -any,+ filepath -any,+ directory -any,+ language-dickinson -any,+ binary -any,+ zstd -any++ if impl(ghc >=8.0)+ ghc-options:+ -Wincomplete-uni-patterns -Wincomplete-record-updates+ -Wredundant-constraints -Widentities++ if impl(ghc >=8.4)+ ghc-options: -Wmissing-export-lists++ if impl(ghc >=8.2)+ ghc-options: -Wcpp-undef++ if impl(ghc >=8.10)+ ghc-options: -Wunused-packages++test-suite dickinson-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs: test+ other-modules:+ Golden+ Eval+ TypeCheck++ default-language: Haskell2010+ ghc-options: -threaded -rtsopts "-with-rtsopts=-N -K1K" -Wall+ build-depends:+ base -any,+ dickinson -any,+ tasty -any,+ tasty-hunit -any,+ bytestring -any,+ prettyprinter -any,+ text -any,+ filepath -any,+ tasty-golden -any,+ pretty-simple -any++ if impl(ghc >=8.0)+ ghc-options:+ -Wincomplete-uni-patterns -Wincomplete-record-updates+ -Wredundant-constraints -Widentities++ if impl(ghc >=8.4)+ ghc-options: -Wmissing-export-lists++ if impl(ghc >=8.2)+ ghc-options: -Wcpp-undef++ if impl(ghc >=8.10)+ ghc-options: -Wunused-packages++benchmark dickinson-bench+ type: exitcode-stdio-1.0+ main-is: Bench.hs+ hs-source-dirs: bench+ default-language: Haskell2010+ ghc-options: -Wall -rtsopts -with-rtsopts=-A4M+ build-depends:+ base -any,+ dickinson -any,+ binary -any,+ criterion -any,+ bytestring -any++ if impl(ghc >=8.0)+ ghc-options:+ -Wincomplete-uni-patterns -Wincomplete-record-updates+ -Wredundant-constraints -Widentities++ if impl(ghc >=8.4)+ ghc-options: -Wmissing-export-lists++ if impl(ghc >=8.2)+ ghc-options: -Wcpp-undef++ if impl(ghc >=8.10)+ ghc-options: -Wunused-packages
+ lib/animal.dck view
@@ -0,0 +1,54 @@+(:include birds)++%-++(:def animal+ (:flatten+ (:oneof+ (| "hippopotamus")+ (| "rhinoceros")+ (| "giraffe")+ (| "deer")+ (| "toad")+ (| "eel")+ (| "fish")+ (| "shark")+ (| "frog")+ (| "amphisbaenians")+ (| "caecilian")+ (| "alligator")+ (| "reptile")+ (| "zebra")+ (| "shrew")+ (| "mouse")+ (| "rat")+ (| "capybara")+ (| "wolf")+ (| "coyote")+ (| "whale") ; whale generator+ (| "beluga")+ (| "orca")+ (| "narwhal")+ (| "guinea pig")+ (| "hamster")+ (| "fisher")+ (| "chinchilla")+ (| "mink")+ (| "fox")+ (| "lynx")+ (| "beaver")+ (| "sable")+ (| "weasel")+ (| "stoat")+ (| "ermine")+ (| "sheep")+ (| "goat") ; TODO livestock+ (| "horse")+ (| "lion")+ (| "tuatara")+ (| "lizard")+ (| "snake")+ (| "salamander")+ (| "buffalo")+ (| "bison")+ (| bird))))
+ lib/birds.dck view
@@ -0,0 +1,14 @@+%-++(:def bird+ (:oneof+ (| "kite")+ (| "swallow")+ (| "sparrow")+ (| "crow")+ (| "raven")+ (| "gull")+ (| "rook")+ (| "ibis")+ (| "pelican")+ (| "tern")))
+ lib/color.dck view
@@ -0,0 +1,108 @@+; ported from the madlang color library+%-++(:def color+ (:oneof+ (| "aubergine")+ (| "cerulean")+ (| "azure")+ (| "melon")+ (| "ochre")+ (| "green")+ (| "emerald")+ (| "gold")+ (| "silver")+ (| "brown")+ (| "smaragdine")+ (| "black")+ (| "white")+ (| "yellow")+ (| "highlighter")+ (| "prasine")+ (| "sand")+ (| "ebony")+ (| "purple")+ (| "violet")+ (| "lilac")+ (| "puce")+ (| "alabaster")+ (| "amber")+ (| "apricot")+ (| "lime")+ (| "umber")+ (| "aquamarine")+ (| "turquoise")+ (| "ash")+ (| "roan")+ (| "gray")+ (| "viridian")+ (| "blue")+ (| "sky blue")+ (| "baby pink")+ (| "coffee")+ (| "coral")+ (| "pink")+ (| "blood orange")+ (| "blush")+ (| "maroon")+ (| "verdant")+ (| "lavender")+ (| "navy blue")+ (| "bubble gum pink")+ (| "tyrian purple")+ (| "cobalt blue")+ (| "viridescent")+ (| "byzantium")+ (| "cadmium yellow")+ (| "canary yellow")+ (| "crimson")+ (| "carmine red")+ (| "charcoal")+ (| "chartreuse")+ (| "cherry red")+ (| "red")+ (| "chlorophyll")+ (| "cinnabar")+ (| "claret")+ (| "citron")+ (| "burgundy")+ (| "coke white")+ (| "copper")+ (| "coquelicot")+ (| "cordovan")+ (| "cyan")+ (| "magenta")+ (| "cream")+ (| "grape")+ (| "cyclamen")+ (| "khaki")+ (| "orange")+ (| "salmon")+ (| "cerise")+ (| "fuchsia")+ (| "mauve")+ (| "saffron")+ (| "tumeric yellow")+ (| "ruby red")+ (| "ecru")+ (| "mahogany")+ (| "rose")+ (| "cardinal red")+ (| "vermilion")+ (| "auburn")+ (| "blood red")+ (| "banana yellow")+ (| "feldgrau")+ (| "firehouse red")+ (| "brick red")+ (| "flax")+ (| "russet")+ (| "flavescent")+ (| "buff")+ (| "ivory")+ (| "xanthous")+ (| "lemon")+ (| "fluorescent yellow")+ (| "neon green")+ (| "fluorescent pink")+ (| "fulvous")))
+ lib/fruit.dck view
@@ -0,0 +1,21 @@+%-++(:def fruit+ (:oneof+ (| "banana")+ (| "pear")+ (| "mango")+ (| "papaya")+ (| "watermelon")+ (| "canteloupe")+ (| "honeydew melon")+ (| "apple")+ (| "nectarine")+ (| "peach")+ (| "apricot")+ (| "plum")+ (| "fig")+ (| "durian")+ (| "jackfruit")+ (| "orange")+ (| "date")))
+ lib/gemstone.dck view
@@ -0,0 +1,11 @@+%-++(:def gemstone+ (:oneof+ (| "opal")+ (| "turquoise")+ (| "diamond")+ (| "emerald")+ (| "amethyst")+ (| "sapphire")+ (| "carnelian")))
+ lib/nut.dck view
@@ -0,0 +1,9 @@+%-++(:def nut+ (:oneof+ (| "cashew")+ (| "brazil nut")+ (| "macadamia nut")+ (| "peanut")+ (| "almond")))
+ lib/states.dck view
@@ -0,0 +1,11 @@+; US states+%-++(:def state+ (:oneof+ (| "Maryland")+ (| "Illinois")+ (| "Wisconsin")+ (| "Texas")+ (| "California")+ (| "New Hampshire")))
+ lib/vegetable.dck view
@@ -0,0 +1,14 @@+%-++(:def vegetable+ (:oneof+ (| "carrots")+ (| "kale")+ (| "lettuce")+ (| "broccoli")+ (| "cauliflower")+ (| "spinach")))++(:def legume+ (:oneof+ (| "lentils")))
+ man/emd.1 view
@@ -0,0 +1,77 @@+.\" Automatically generated by Pandoc 2.9.2.1+.\"+.TH "emd (1)" "" "" "" ""+.hy+.SH NAME+.PP+emd - [Emily] Dickinson+.SH DESCRIPTION+.PP+\f[B]Dickinson\f[R] is a text-generation language+.SH SYNOPSIS+.PP+emd repl+.PP+emd run literature.dck+.PP+emd run project.dck --include lib+.SH SUBCOMMANDS+.PP+\f[B]repl\f[R] - Start a repl+.PP+\f[B]run\f[R] - Run a file+.PP+\f[B]check\f[R] - Check that a program is correct without running it+.PP+\f[B]lint\f[R] - Give suggestions for common mistakes+.PP+\f[B]fmt\f[R] - Format Dickinson code+.SS REPL COMMANDS+.PP+\f[B]:save\f[R] - Save curent state in a file+.PP+\f[B]:l\f[R] \f[B]:load\f[R] - Load a file+.PP+\f[B]:r\f[R] - Restore a REPL state stored in a file+.PP+\f[B]:q\f[R] \f[B]:quit\f[R] - Quit session+.PP+\f[B]:list\f[R] - List all names that are in scope+.PP+\f[B]:t\f[R] \f[B]:type\f[R] - Display the type of an expression+.PP+\f[B]:v\f[R] \f[B]:view\f[R] - Show the definition of a name+.SH OPTIONS+.TP+\f[B]-h\f[R] \f[B]--help\f[R]+Display help+.TP+\f[B]-V\f[R] \f[B]--version\f[R]+Display version information+.TP+\f[B]-I\f[R] \f[B]--include\f[R]+Directory to search for libraries+.SH EDITOR INTEGRATION+.PP+A vim plugin is available; see+.PP+https://github.com/vmchale/dickinson/tree/master/vim+.SH SHELL COMPLETIONS+.PP+To get shell completions in your current session:+.PP+\f[C]eval \[dq]$(emd --bash-completion-script emd)\[dq]\f[R]+.PP+Put this in your \f[C]\[ti]/.bashrc\f[R] or+\f[C]\[ti]/.bash_profile\f[R] to install them.+.SH BUGS+.PP+Please report any bugs you may come across to+https://github.com/vmchale/dickinson/issues.+.SH COPYRIGHT+.PP+Copyright 2020.+Vanessa McHale.+All Rights Reserved.+.SH AUTHORS+Vanessa McHale<vamchale@gmail.com>.
+ prelude/curry.dck view
@@ -0,0 +1,13 @@+%-++(:def curry+ (:lambda f (⟶ (text, text) text)+ (:lambda x text+ (:lambda y text+ ($ f (x, y))))))++(:def uncurry+ (:lambda f (⟶ text (⟶ text text))+ (:lambda x (text, text)+ (:match x (y, z)+ ($ $ f y z)))))
+ prelude/tuple.dck view
@@ -0,0 +1,16 @@+%-++(:def fst+ (:lambda xy (text, text)+ (:match xy (x, _)+ x)))++(:def snd+ (:lambda xy (text, text)+ (:match xy (_, y)+ y)))++(:def fst3+ (:lambda xyz (text, text, text)+ (:match xyz (x, _, _)+ x)))
+ public/Language/Dickinson.hs view
@@ -0,0 +1,36 @@+-- | This modules contains some bits and pieces to work with Dickinson code.+module Language.Dickinson ( -- * Parser+ parse+ , ParseError (..)+ -- * Lexer+ , lexDickinson+ , AlexPosn+ , Token (..)+ -- * AST+ , Dickinson+ , Declaration (..)+ , Expression (..)+ , Pattern (..)+ , DickinsonTy (..)+ , Name+ , TyName+ -- * Imports+ , resolveImport+ -- * Version info+ , dickinsonVersion+ , dickinsonVersionString+ ) where++import qualified Data.Version as V+import Language.Dickinson.Import+import Language.Dickinson.Lexer+import Language.Dickinson.Name+import Language.Dickinson.Parser+import Language.Dickinson.Type+import qualified Paths_language_dickinson as P++dickinsonVersion :: V.Version+dickinsonVersion = P.version++dickinsonVersionString :: String+dickinsonVersionString = V.showVersion dickinsonVersion
+ run/Main.hs view
@@ -0,0 +1,86 @@+module Main (main) where++import Data.Semigroup+import qualified Data.Text.IO as TIO+import Language.Dickinson (dickinsonVersionString)+import Language.Dickinson.File+import Language.Dickinson.Lib+import Options.Applicative+import REPL++-- TODO debug/verbosity options...+data Act = Run !FilePath ![FilePath]+ | REPL ![FilePath]+ | Check !FilePath ![FilePath]+ | Lint !FilePath+ | Typecheck !FilePath ![FilePath]+ | Format !FilePath++main :: IO ()+main = run =<< execParser wrapper++-- TODO: cache/"compile"?++act :: Parser Act+act = hsubparser+ (command "run" (info runP (progDesc "Execute a file"))+ <> command "repl" (info replP (progDesc "Start a REPL"))+ <> command "check" (info checkP (progDesc "Check that some code is valid."))+ <> command "lint" (info lintP (progDesc "Examine a file for common errors."))+ <> command "typecheck" (info typecheckP (progDesc "Type information for a program (for debugging)"))+ <> command "fmt" (info formatP (progDesc "Format Dickinson code"))+ )++formatP :: Parser Act+formatP = Format <$> dckFile++replP :: Parser Act+replP = REPL <$> many dckFile++runP :: Parser Act+runP = Run <$> dckFile <*> includes++checkP :: Parser Act+checkP = Check <$> dckFile <*> includes++lintP :: Parser Act+lintP = Lint <$> dckFile++typecheckP :: Parser Act+typecheckP = Typecheck <$> dckFile <*> includes++dckFile :: Parser FilePath+dckFile = argument str+ (metavar "FILE"+ <> help "Source file"+ <> dckCompletions)++includes :: Parser [FilePath]+includes = many $ strOption+ (metavar "DIR"+ <> long "include"+ <> short 'I'+ <> dirCompletions)++dckCompletions :: HasCompleter f => Mod f a+dckCompletions = completer . bashCompleter $ "file -X '!*.dck' -o plusdirs"++dirCompletions :: HasCompleter f => Mod f a+dirCompletions = completer . bashCompleter $ "directory"++wrapper :: ParserInfo Act+wrapper = info (helper <*> versionMod <*> act)+ (fullDesc+ <> progDesc "Dickinson text-generation language. See also 'man emd'"+ <> header "Dickinson - a text-generation language")++versionMod :: Parser (a -> a)+versionMod = infoOption dickinsonVersionString (short 'V' <> long "version" <> help "Show version")++run :: Act -> IO ()+run (Run fp is) = do { pGo <- defaultLibPath ; TIO.putStrLn =<< pipeline (pGo is) fp }+run (REPL _) = dickinsonRepl+run (Check f i) = do { pathMod <- defaultLibPath ; checkFile (pathMod i) f }+run (Lint f) = warnFile f+run (Typecheck f i) = do { pathMod <- defaultLibPath ; tcFile (pathMod i) f }+run (Format fp) = fmtFile fp
+ run/REPL.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module REPL ( dickinsonRepl+ ) where++import Control.Monad.Except (ExceptT, runExceptT)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.State.Lazy (StateT, evalStateT, get, gets, lift, put)+import qualified Data.ByteString.Lazy as BSL+import Data.Foldable (traverse_)+import qualified Data.IntMap as IM+import qualified Data.Map as M+import Data.Maybe (fromJust)+import Data.Semigroup ((<>))+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import qualified Data.Text.Lazy as TL+import Data.Text.Lazy.Encoding (encodeUtf8)+import Data.Text.Prettyprint.Doc (Pretty (pretty), hardline)+import Data.Text.Prettyprint.Doc.Render.Text (putDoc)+import Data.Tuple.Ext (fst3)+import Language.Dickinson.Error+import Language.Dickinson.Eval+import Language.Dickinson.File+import Language.Dickinson.Lexer (AlexPosn, AlexUserState, alexInitUserState)+import Language.Dickinson.Lib+import Language.Dickinson.Parser+import Language.Dickinson.Rename+import Language.Dickinson.ScopeCheck+import Language.Dickinson.Type+import Language.Dickinson.TypeCheck+import Language.Dickinson.Unique+import Lens.Micro (_1)+import Lens.Micro.Mtl (use, (.=))+import REPL.Save+import System.Console.Haskeline (InputT, defaultSettings, getInputLine, historyFile, runInputT)+import System.Directory (getHomeDirectory)+import System.FilePath ((</>))+import System.Random (newStdGen, randoms)++dickinsonRepl :: IO ()+dickinsonRepl = runRepl loop++type Repl a = InputT (StateT (EvalSt a) IO)++runRepl :: Repl a x -> IO x+runRepl x = do+ g <- newStdGen+ emdDir <- (</> ".emd_history") <$> getHomeDirectory+ let initSt = EvalSt (randoms g) mempty initRenames mempty alexInitUserState emptyTyEnv+ let emdSettings = defaultSettings { historyFile = Just emdDir }+ flip evalStateT initSt $ runInputT emdSettings x++loop :: Repl AlexPosn ()+loop = do+ inp <- getInputLine "emd> "+ case words <$> inp of+ Just [] -> loop+ Just (":h":_) -> showHelp *> loop+ Just (":help":_) -> showHelp *> loop+ Just (":save":fp:_) -> saveReplSt fp *> loop+ Just (":l":fs) -> traverse loadFile fs *> loop+ Just (":load":fs) -> traverse loadFile fs *> loop+ Just (":r":fp:_) -> loadReplSt fp *> loop+ Just (":type":e:_) -> typeExpr e *> loop+ Just (":t":e:_) -> typeExpr e *> loop+ Just (":v":n:_) -> bindDisplay (T.pack n) *> loop+ Just (":view":n:_) -> bindDisplay (T.pack n) *> loop+ Just [":q"] -> pure ()+ Just [":quit"] -> pure ()+ Just [":list"] -> listNames *> loop+ Just [":dump"] -> dumpSt *> loop+ -- TODO: erase/delete names?+ Just{} -> printExpr (fromJust inp) *> loop+ Nothing -> pure ()++rightPad :: Int -> String -> String+rightPad n str = take n $ str ++ repeat ' '++showHelp :: Repl AlexPosn ()+showHelp = liftIO $ putStr $ concat+ [ helpOption ":help, :h" "" "Show this help"+ , helpOption ":save" "<file>" "Save current state"+ , helpOption ":load, :l" "<file>" "Load file contents"+ , helpOption ":r" "<file>" "Restore REPL state from a file"+ , helpOption ":type, :t" "<expression>" "Display the type of an expression"+ , helpOption ":view, :v" "<name>" "Show the value of a name"+ , helpOption ":quite, :q" "" "Quit REPL"+ , helpOption ":list" "" "List all names that are in scope"+ ]++helpOption :: String -> String -> String -> String+helpOption cmd args desc =+ rightPad 15 cmd ++ rightPad 14 args ++ desc ++ "\n"++saveReplSt :: FilePath -> Repl AlexPosn ()+saveReplSt fp = do+ eSt <- lift get+ liftIO $ BSL.writeFile fp (encodeReplSt eSt)++loadReplSt :: FilePath -> Repl AlexPosn ()+loadReplSt fp = do+ contents <- liftIO $ BSL.readFile fp+ g <- liftIO newStdGen+ lift $ put (decodeReplSt (randoms g) contents)++dumpSt :: Repl AlexPosn ()+dumpSt = do+ st <- lift get+ liftIO $ putDoc $ pretty st <> hardline++listNames :: Repl AlexPosn ()+listNames = liftIO . traverse_ TIO.putStrLn =<< names++names :: Repl AlexPosn [T.Text]+names = lift $ gets (M.keys . topLevel)++bindDisplay :: T.Text -> Repl AlexPosn ()+bindDisplay t = do+ preBinds <- lift $ gets topLevel+ let u = M.lookup t preBinds+ case u of+ Just (Unique i) -> do+ exprs <- lift $ gets boundExpr+ case IM.lookup i exprs of+ Just e -> liftIO $ putDoc (pretty e <> hardline)+ Nothing -> error "Internal error."+ Nothing -> pure () -- TODO: error++setSt :: AlexUserState -> Repl AlexPosn ()+setSt newSt = lift $ do+ m' <- use (rename.maxLens)+ let newM = 1 + max (fst3 newSt) m'+ lexerStateLens .= newSt+ lexerStateLens._1 .= newM+ rename.maxLens .= newM++strBytes :: String -> BSL.ByteString+strBytes = encodeUtf8 . TL.pack++typeExpr :: String -> Repl AlexPosn ()+typeExpr str = do+ let bsl = strBytes str+ aSt <- lift $ gets lexerState+ case parseExpressionWithCtx bsl aSt of+ Left err -> liftIO $ putDoc (pretty err <> hardline)+ Right (newSt, e) -> do+ setSt newSt+ mErr <- lift $ runExceptT $ typeOf =<< resolveExpressionM =<< renameExpressionM e+ lift balanceMax+ putErr mErr (liftIO . putDoc . (<> hardline) . pretty)++printExpr :: String -> Repl AlexPosn ()+printExpr str = do+ let bsl = strBytes str+ aSt <- lift $ gets lexerState+ case parseReplWithCtx bsl aSt of+ Left err -> liftIO $ putDoc (pretty err <> hardline)+ Right (newSt, p) -> do+ setSt newSt+ case p of+ Right e -> do+ mErr <- lift $ runExceptT $ do+ e' <- resolveExpressionM =<< renameExpressionM e+ checkScopeExpr e'+ evalExpressionAsTextM e'+ lift balanceMax+ putErr mErr (liftIO . TIO.putStrLn)+ Left decl -> do+ mErr <- lift $ runExceptT $ do+ d <- renameDeclarationM decl+ checkScopeDecl =<< resolveDeclarationM d+ addDecl' d+ lift balanceMax+ putErr mErr (const $ pure ())++ where addDecl' :: Declaration AlexPosn -> ExceptT (DickinsonError AlexPosn) (StateT (EvalSt AlexPosn) IO) ()+ addDecl' = addDecl+++putErr :: Pretty e => Either e b -> (b -> Repl a ()) -> Repl a ()+putErr (Right x) f = f x+putErr (Left y) _ = liftIO $ putDoc (pretty y <> hardline)++-- TODO: check+loadFile :: FilePath -> Repl AlexPosn ()+loadFile fp = do+ pathMod <- liftIO defaultLibPath+ mErr <- lift $ runExceptT $ do+ d <- amalgamateRenameM (pathMod ["."]) fp+ maybeThrow $ checkScope d+ loadDickinson d+ lift balanceMax+ putErr mErr (const $ pure ())
+ run/REPL/Save.hs view
@@ -0,0 +1,34 @@+module REPL.Save ( decodeReplSt+ , encodeReplSt+ ) where++import qualified Codec.Compression.Zstd.Lazy as Zstd+import Data.Binary (Binary, Get, Put, get, put)+import Data.Binary.Get (runGet)+import Data.Binary.Put (runPut)+import qualified Data.ByteString.Lazy as BSL+import Data.Semigroup ((<>))+import Language.Dickinson.Eval++getReplState :: Binary a => [Double] -> Get (EvalSt a)+getReplState ds =+ EvalSt ds+ <$> get+ <*> get+ <*> get+ <*> get+ <*> get++putReplState :: Binary a => EvalSt a -> Put+putReplState (EvalSt _ be rs t lSt ty) =+ put be+ <> put rs+ <> put t+ <> put lSt+ <> put ty++decodeReplSt :: Binary a => [Double] -> BSL.ByteString -> EvalSt a+decodeReplSt ds = runGet (getReplState ds) . Zstd.decompress++encodeReplSt :: Binary a => EvalSt a -> BSL.ByteString+encodeReplSt = Zstd.compress 3 . runPut . putReplState
+ src/Control/Exception/Value.hs view
@@ -0,0 +1,16 @@+module Control.Exception.Value ( eitherThrow+ , eitherThrowIO+ , maybeThrowIO+ ) where++import Control.Exception (Exception, throw, throwIO)++eitherThrow :: Exception e => Either e x -> x+eitherThrow = either throw id++eitherThrowIO :: Exception e => Either e x -> IO x+eitherThrowIO = either throwIO pure++maybeThrowIO :: Exception e => Maybe e -> IO ()+maybeThrowIO (Just e) = throwIO e+maybeThrowIO Nothing = pure ()
+ src/Control/Monad/Ext.hs view
@@ -0,0 +1,13 @@+module Control.Monad.Ext ( zipWithM+ , zipWithM_+ ) where++import Data.Foldable (sequenceA_)+import Data.List.NonEmpty+import qualified Data.List.NonEmpty as NE++zipWithM :: (Applicative m) => (a -> b -> m c) -> NonEmpty a -> NonEmpty b -> m (NonEmpty c)+zipWithM f xs ys = sequenceA (NE.zipWith f xs ys)++zipWithM_ :: (Applicative m) => (a -> b -> m c) -> NonEmpty a -> NonEmpty b -> m ()+zipWithM_ f xs ys = sequenceA_ (NE.zipWith f xs ys)
+ src/Data/Foldable/Ext.hs view
@@ -0,0 +1,7 @@+module Data.Foldable.Ext ( foldMapAlternative ) where++import Control.Applicative (Alternative)+import Data.Foldable (asum)++foldMapAlternative :: (Traversable t, Alternative f) => (a -> f b) -> t a -> f b+foldMapAlternative f xs = asum (f <$> xs)
+ src/Data/Text/Prettyprint/Doc/Ext.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.Text.Prettyprint.Doc.Ext ( prettyText+ , prettyLazyText+ , smartDickinson+ , dickinsonText+ , dickinsonLazyText+ , intercalate+ , hardSep+ , prettyDumpBinds+ -- * Operators+ , (<#>)+ , (<:>)+ , (<^>)+ , (<#*>)+ ) where++import qualified Data.IntMap as IM+import Data.List (intersperse)+import Data.Semigroup ((<>))+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Text.Prettyprint.Doc (Doc, LayoutOptions (LayoutOptions),+ PageWidth (AvailablePerLine), Pretty (pretty), SimpleDocStream,+ concatWith, flatAlt, hardline, indent,+ layoutSmart, softline, vsep, (<+>))+import Data.Text.Prettyprint.Doc.Render.Text (renderLazy, renderStrict)++infixr 6 <#>+infixr 6 <:>+infixr 6 <^>++(<#>) :: Doc a -> Doc a -> Doc a+(<#>) x y = x <> hardline <> y++(<:>) :: Doc a -> Doc a -> Doc a+(<:>) x y = x <> softline <> y++(<#*>) :: Doc a -> Doc a -> Doc a+(<#*>) x y = x <> hardline <> indent 2 y++(<^>) :: Doc a -> Doc a -> Doc a+(<^>) x y = flatAlt (x <> hardline <> indent 2 y) (x <+> y)++prettyDumpBinds :: Pretty b => IM.IntMap b -> Doc a+prettyDumpBinds b = vsep (prettyBind <$> IM.toList b)++prettyBind :: Pretty b => (Int, b) -> Doc a+prettyBind (i, j) = pretty i <+> "→" <+> pretty j++hardSep :: [Doc ann] -> Doc ann+hardSep = concatWith (<#>)++intercalate :: Doc a -> [Doc a] -> Doc a+intercalate x = mconcat . intersperse x++dickinsonLayoutOptions :: LayoutOptions+dickinsonLayoutOptions = LayoutOptions (AvailablePerLine 160 0.8)++smartDickinson :: Doc a -> SimpleDocStream a+smartDickinson = layoutSmart dickinsonLayoutOptions++dickinsonText :: Doc a -> T.Text+dickinsonText = renderStrict . smartDickinson++dickinsonLazyText :: Doc a -> TL.Text+dickinsonLazyText = renderLazy . smartDickinson++prettyText :: Pretty a => a -> T.Text+prettyText = dickinsonText . pretty++prettyLazyText :: Pretty a => a -> TL.Text+prettyLazyText = dickinsonLazyText . pretty
+ src/Data/Tuple/Ext.hs view
@@ -0,0 +1,5 @@+module Data.Tuple.Ext ( fst3+ ) where++fst3 :: (a, b, c) -> a+fst3 (x, _, _) = x
+ src/Language/Dickinson/Check.hs view
@@ -0,0 +1,53 @@+module Language.Dickinson.Check ( checkMultiple+ ) where++import Control.Applicative (Alternative (..))+import Data.Foldable (toList)+import Data.Foldable.Ext (foldMapAlternative)+import Data.List (group, sort)+import Data.Maybe (mapMaybe)+import Language.Dickinson.Error+import Language.Dickinson.Name+import Language.Dickinson.Type++checkNames :: [Name a] -> Maybe (DickinsonWarning a)+checkNames ns = foldMapAlternative announce (group $ sort ns)+ where announce (_:y:_) = Just $ MultipleNames (loc y) y+ announce _ = Nothing++-- runs after the renamer+-- | Checks that there are not name clashes at the top level.+checkMultiple :: [Declaration a] -> Maybe (DickinsonWarning a)+checkMultiple ds =+ checkNames (mapMaybe defNameM ds)+ <|> checkNames (mapMaybe tyDeclNameM ds)+ <|> foldMapAlternative checkMultipleExpr (mapMaybe defExprM ds)+ <|> checkNames (concatMap collectConstructors ds)+ where defNameM (Define _ n _) = Just n+ defNameM TyDecl{} = Nothing+ defExprM (Define _ _ e) = Just e+ defExprM TyDecl{} = Nothing+ tyDeclNameM Define{} = Nothing+ tyDeclNameM (TyDecl _ n _) = Just n++collectConstructors :: Declaration a -> [TyName a]+collectConstructors Define{} = []+collectConstructors (TyDecl _ _ cs) = toList cs++checkMultipleExpr :: Expression a -> Maybe (DickinsonWarning a)+checkMultipleExpr Var{} = Nothing+checkMultipleExpr Literal{} = Nothing+checkMultipleExpr StrChunk{} = Nothing+checkMultipleExpr (Interp _ es) = foldMapAlternative checkMultipleExpr es+checkMultipleExpr (Apply _ e e') = checkMultipleExpr e <|> checkMultipleExpr e'+checkMultipleExpr (Match _ e _ e') = checkMultipleExpr e <|> checkMultipleExpr e'+checkMultipleExpr (Choice _ brs) = foldMapAlternative (checkMultipleExpr . snd) brs+checkMultipleExpr (Concat _ es) = foldMapAlternative checkMultipleExpr es+checkMultipleExpr (Tuple _ es) = foldMapAlternative checkMultipleExpr es+checkMultipleExpr (Lambda _ _ _ e) = checkMultipleExpr e+checkMultipleExpr (Flatten _ e) = checkMultipleExpr e+checkMultipleExpr (Let _ bs e) =+ checkNames (toList $ fmap fst bs)+ <|> foldMapAlternative checkMultipleExpr (snd <$> bs)+ <|> checkMultipleExpr e+checkMultipleExpr (Annot _ e _) = checkMultipleExpr e
+ src/Language/Dickinson/Check/Internal.hs view
@@ -0,0 +1,66 @@+module Language.Dickinson.Check.Internal ( sanityCheck+ ) where++import Control.Monad (when)+import Control.Monad.State (MonadState)+import Data.List.NonEmpty ((<|))+import Language.Dickinson.Name+import Language.Dickinson.Rename+import Language.Dickinson.Type+import Language.Dickinson.Unique+import Lens.Micro.Mtl (use)++-- TODO: sanity check for the lexer+sanityCheck :: (HasRenames s, MonadState s m) => [Declaration a] -> m ()+sanityCheck d = do+ storedMax <- use (rename.maxLens)+ let computedMax = maximum (maxUniqueDeclaration <$> d)+ when (storedMax < computedMax) $+ error "Sanity check failed!"++maxUniqueDeclaration :: Declaration a -> Int+maxUniqueDeclaration (Define _ (Name _ (Unique i) _) e) = max i (maxUniqueExpression e)+maxUniqueDeclaration (TyDecl _ (Name _ (Unique i) _) tns) =+ maximum ( i <| fmap (unUnique . unique) tns)++maxUniqueType :: DickinsonTy a -> Int+maxUniqueType TyText{} = 0+maxUniqueType (TyFun _ ty ty') = max (maxUniqueType ty) (maxUniqueType ty')+maxUniqueType (TyTuple _ ts) = maximum (fmap maxUniqueType ts)+maxUniqueType (TyNamed _ (Name _ (Unique k) _)) = k++maxUniqueExpression :: Expression a -> Int+maxUniqueExpression Literal{} = 0+maxUniqueExpression (Constructor _ (Name _ (Unique k) _)) = k+maxUniqueExpression StrChunk{} = 0+maxUniqueExpression (Var _ (Name _ (Unique i) _)) = i+maxUniqueExpression (Choice _ pes) = maximum (maxUniqueExpression . snd <$> pes)+maxUniqueExpression (Interp _ es) = maximum (fmap maxUniqueExpression es)+maxUniqueExpression (Concat _ es) = maximum (fmap maxUniqueExpression es)+maxUniqueExpression (Apply _ e e') = max (maxUniqueExpression e) (maxUniqueExpression e')+maxUniqueExpression (Annot _ e ty) = max (maxUniqueExpression e) (maxUniqueType ty)+maxUniqueExpression (Flatten _ e) = maxUniqueExpression e+maxUniqueExpression (Tuple _ es) = maximum (fmap maxUniqueExpression es)+maxUniqueExpression (Lambda _ (Name _ (Unique i) _) ty e) =+ maximum [ i+ , maxUniqueExpression e+ , maxUniqueType ty+ ]+maxUniqueExpression (Match _ e p e') =+ maximum+ [ maxUniqueExpression e+ , maxUniquePattern p+ , maxUniqueExpression e'+ ]+maxUniqueExpression (Let _ bs e) =+ maximum+ [ maxUniqueExpression e+ , maximum (maxUniqueExpression . snd <$> bs)+ , maximum (unUnique . unique . fst <$> bs)+ ]++maxUniquePattern :: Pattern a -> Int+maxUniquePattern (PatternVar _ (Name _ (Unique i) _)) = i+maxUniquePattern Wildcard{} = 0+maxUniquePattern (PatternTuple _ ps) = maximum (fmap maxUniquePattern ps)+maxUniquePattern (PatternCons _ (Name _ (Unique k) _)) = k
+ src/Language/Dickinson/Check/Pattern.hs view
@@ -0,0 +1,21 @@+module Language.Dickinson.Check.Pattern ( checkNames+ , traversePattern+ ) where++import Data.Foldable (toList)+import Data.Foldable.Ext (foldMapAlternative)+import Data.List (group, sort)+import Language.Dickinson.Error+import Language.Dickinson.Name+import Language.Dickinson.Type++traversePattern :: Pattern a -> [Name a]+traversePattern (PatternVar _ n) = [n]+traversePattern (PatternTuple _ ps) = traversePattern =<< toList ps+traversePattern Wildcard{} = []++-- TODO: use this+checkNames :: Pattern a -> Maybe (DickinsonError a)+checkNames p = foldMapAlternative announce (group $ sort (traversePattern p))+ where announce (_:y:_) = Just $ MultiBind (loc y) y p+ announce _ = Nothing
+ src/Language/Dickinson/DuplicateCheck.hs view
@@ -0,0 +1,50 @@+module Language.Dickinson.DuplicateCheck ( checkDuplicates+ ) where++import Control.Applicative ((<|>))+import Data.Foldable (toList)+import Data.Foldable.Ext (foldMapAlternative)+import Data.Function (on)+import Data.List (groupBy, sortBy)+import Data.Maybe (mapMaybe)+import qualified Data.Text as T+import Language.Dickinson.Error+import Language.Dickinson.Type++checkNames :: [(a, T.Text)] -> Maybe (DickinsonWarning a)+checkNames ns = foldMapAlternative announce (groupBy ((==) `on` snd) $ sortBy (compare `on` snd) ns)+ where announce (_:(l, y):_) = Just $ DuplicateStr l y+ announce _ = Nothing++-- | Check that there are no duplicate names as the top-level+checkDuplicates :: [Declaration a] -> Maybe (DickinsonWarning a)+checkDuplicates = foldMapAlternative checkDeclDuplicates++checkDeclDuplicates :: Declaration a -> Maybe (DickinsonWarning a)+checkDeclDuplicates (Define _ _ e) = checkExprDuplicates e+checkDeclDuplicates TyDecl{} = Nothing++extrText :: Expression a -> Maybe (a, T.Text)+extrText (Literal l t) = pure (l, t)+extrText _ = Nothing++collectText :: [(b, Expression a)] -> [(a, T.Text)]+collectText = mapMaybe (extrText . snd)++-- TODO: check duplicate tydecl names!!++checkExprDuplicates :: Expression a -> Maybe (DickinsonWarning a)+checkExprDuplicates Var{} = Nothing+checkExprDuplicates Literal{} = Nothing+checkExprDuplicates StrChunk{} = Nothing+checkExprDuplicates (Interp _ es) = foldMapAlternative checkExprDuplicates es+checkExprDuplicates (Concat _ es) = foldMapAlternative checkExprDuplicates es+checkExprDuplicates (Tuple _ es) = foldMapAlternative checkExprDuplicates es+checkExprDuplicates (Apply _ e e') = checkExprDuplicates e <|> checkExprDuplicates e'+checkExprDuplicates (Choice _ brs) = checkNames (collectText $ toList brs)+checkExprDuplicates (Let _ brs es) = foldMapAlternative checkExprDuplicates (snd <$> brs) <|> checkExprDuplicates es+checkExprDuplicates (Lambda _ _ _ e) = checkExprDuplicates e+checkExprDuplicates (Match _ e _ e') = checkExprDuplicates e <|> checkExprDuplicates e'+checkExprDuplicates (Flatten _ e) = checkExprDuplicates e+checkExprDuplicates (Annot _ e _) = checkExprDuplicates e+checkExprDuplicates Constructor{} = Nothing
+ src/Language/Dickinson/Error.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.Dickinson.Error ( DickinsonError (..)+ , DickinsonWarning (..)+ , maybeThrow+ ) where++import Control.DeepSeq (NFData)+import Control.Exception (Exception)+import Control.Monad.Except (MonadError, throwError)+import Data.Semigroup ((<>))+import qualified Data.Text as T+import Data.Text.Prettyprint.Doc (Pretty (pretty), dquotes, squotes, (<+>))+import Data.Typeable (Typeable)+import GHC.Generics (Generic)+import Language.Dickinson.Name+import Language.Dickinson.Parser+import Language.Dickinson.Type++data DickinsonError a = UnfoundName a (Name a)+ | NoText T.Text -- separate from UnfoundName since there is no loc+ | ParseErr FilePath (ParseError a)+ | ModuleNotFound a (Name a)+ | TypeMismatch (Expression a) (DickinsonTy a) (DickinsonTy a)+ | ExpectedLambda (Expression a) (DickinsonTy a)+ | MultiBind a (Name a) (Pattern a) -- When a variable is bound more than once in a pattern...+ | MalformedTuple a+ | InternalError+ | UnfoundConstructor a (TyName a)+ deriving (Generic, NFData)++data DickinsonWarning a = MultipleNames a (Name a) -- TODO: throw both?+ | DuplicateStr a T.Text+ deriving (Generic, NFData)++maybeThrow :: MonadError e m => Maybe e -> m ()+maybeThrow (Just err) = throwError err+maybeThrow Nothing = pure ()++instance (Pretty a) => Show (DickinsonError a) where+ show = show . pretty++instance (Pretty a) => Pretty (DickinsonError a) where+ pretty (UnfoundName l n) = pretty l <+> pretty n <+> "is not in scope."+ pretty (NoText t) = squotes (pretty t) <+> "not defined"+ pretty (ParseErr _ e) = pretty e+ pretty (TypeMismatch e ty ty') = "Expected" <+> pretty e <+> "to have type" <+> squotes (pretty ty) <> ", found type" <+> squotes (pretty ty')+ pretty (ModuleNotFound l n) = pretty l <+> "Module" <+> pretty n <+> "not found"+ pretty (ExpectedLambda e ty) = "Expected" <+> squotes (pretty e) <+> "to be of function type, found type" <+> pretty ty+ pretty (MultiBind l n p) = pretty l <+> "Name" <+> pretty n <+> "is bound more than once in" <+> pretty p+ pretty (MalformedTuple l) = pretty l <+> "Malformed tuple"+ pretty InternalError = "Internal error. Please report this as a bug: https://github.com/vmchale/dickinson/issues"+ pretty (UnfoundConstructor l tn) = pretty l <+> "Constructor" <+> pretty tn <+> "not found"++instance (Pretty a, Typeable a) => Exception (DickinsonError a)++instance (Pretty a) => Show (DickinsonWarning a) where+ show = show . pretty++instance (Pretty a) => Pretty (DickinsonWarning a) where+ pretty (MultipleNames l n) = pretty n <+> "at" <+> pretty l <+> "has already been defined"+ pretty (DuplicateStr l t) = pretty l <+> "duplicate string" <+> dquotes (pretty t)++instance (Pretty a, Typeable a) => Exception (DickinsonWarning a)
+ src/Language/Dickinson/Eval.hs view
@@ -0,0 +1,298 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.Dickinson.Eval ( EvalSt (..)+ , addDecl+ , loadDickinson+ , evalDickinsonAsMain+ , resolveExpressionM+ , resolveDeclarationM+ , evalExpressionM+ , evalExpressionAsTextM+ , findDecl+ , findMain+ , lexerStateLens+ , balanceMax+ ) where++import Control.Composition (thread)+import Control.Monad ((<=<))+import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError)+import qualified Control.Monad.Ext as Ext+import Control.Monad.State.Lazy (MonadState, State, evalState, get, gets, modify, put)+import Data.Foldable (toList, traverse_)+import qualified Data.IntMap as IM+import Data.List.NonEmpty (NonEmpty, (<|))+import qualified Data.List.NonEmpty as NE+import qualified Data.Map as M+import qualified Data.Text as T+import Data.Text.Prettyprint.Doc (Doc, Pretty (..), vsep, (<+>))+import Data.Text.Prettyprint.Doc.Ext+import Language.Dickinson.Error+import Language.Dickinson.Lexer+import Language.Dickinson.Name+import Language.Dickinson.Rename+import Language.Dickinson.Type+import Language.Dickinson.TypeCheck+import Language.Dickinson.Unique+import Lens.Micro (Lens', over, set, _1)+import Lens.Micro.Mtl (use, (.=))++-- | The state during evaluation+data EvalSt a = EvalSt+ { probabilities :: [Double]+ -- map to expression+ , boundExpr :: IM.IntMap (Expression a)+ , renameCtx :: Renames+ -- TODO: map to uniques or an expression?+ , topLevel :: M.Map T.Text Unique+ -- For imports & such.+ , lexerState :: AlexUserState+ -- For error messages+ , tyEnv :: (TyEnv a)+ }+++instance HasLexerState (EvalSt a) where+ lexerStateLens f s = fmap (\x -> s { lexerState = x }) (f (lexerState s))++prettyBound :: (Int, Expression a) -> Doc b+prettyBound (i, e) = pretty i <+> "←" <#*> pretty e++prettyTl :: (T.Text, Unique) -> Doc a+prettyTl (t, i) = pretty t <+> ":" <+> pretty i++instance Pretty (EvalSt a) where+ pretty (EvalSt _ b r t st _) =+ "bound expressions:" <#> vsep (prettyBound <$> IM.toList b)+ <#> pretty r+ <#> "top-level names:" <#> vsep (prettyTl <$> M.toList t)+ <#> prettyAlexState st++prettyAlexState :: AlexUserState -> Doc a+prettyAlexState (m, _, nEnv) =+ "max:" <+> pretty m+ <#> prettyDumpBinds nEnv++instance HasRenames (EvalSt a) where+ rename f s = fmap (\x -> s { renameCtx = x }) (f (renameCtx s))++instance HasTyEnv EvalSt where+ tyEnvLens = (\f s -> fmap (\x -> s { tyEnv = x }) (f (tyEnv s))) . tyEnvLens++probabilitiesLens :: Lens' (EvalSt a) [Double]+probabilitiesLens f s = fmap (\x -> s { probabilities = x }) (f (probabilities s))++boundExprLens :: Lens' (EvalSt a) (IM.IntMap (Expression a))+boundExprLens f s = fmap (\x -> s { boundExpr = x }) (f (boundExpr s))++topLevelLens :: Lens' (EvalSt a) (M.Map T.Text Unique)+topLevelLens f s = fmap (\x -> s { topLevel = x }) (f (topLevel s))++nameMod :: Name a -> Expression a -> EvalSt a -> EvalSt a+nameMod (Name _ (Unique u) _) e = over boundExprLens (IM.insert u e)++bindName :: (MonadState (EvalSt a) m) => Name a -> Expression a -> m ()+bindName n e = modify (nameMod n e)++topLevelMod :: Name a -> EvalSt a -> EvalSt a+topLevelMod (Name n u _) = over topLevelLens (M.insert (T.intercalate "." $ toList n) u)++topLevelAdd :: (MonadState (EvalSt a) m) => Name a -> m ()+topLevelAdd n = modify (topLevelMod n)++tryLookupName :: (MonadState (EvalSt a) m) => Name a -> m (Maybe (Expression a))+tryLookupName (Name _ (Unique u) _) = go =<< gets (IM.lookup u.boundExpr)+ where go (Just x) = Just <$> {-# SCC "renameClone" #-} renameExpressionM x+ go Nothing = pure Nothing++lookupName :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => Name a -> m (Expression a)+lookupName n@(Name _ _ l) = maybe err pure =<< tryLookupName n+ where err = throwError (UnfoundName l n)++normalize :: (Foldable t, Functor t, Fractional a) => t a -> t a+normalize xs = {-# SCC "normalize" #-} (/tot) <$> xs+ where tot = sum xs++cdf :: (Num a) => NonEmpty a -> [a]+cdf = {-# SCC "cdf" #-} NE.drop 2 . NE.scanl (+) 0 . (0 <|)++pick :: (MonadState (EvalSt a) m) => NonEmpty (Double, Expression a) -> m (Expression a)+pick brs = {-# SCC "pick" #-} do+ threshold <- gets (head.probabilities)+ modify (over probabilitiesLens tail)+ let ds = cdf (normalize (fst <$> brs))+ es = toList (snd <$> brs)+ pure $ snd . head . dropWhile ((<= threshold) . fst) $ zip ds es++findDecl :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => T.Text -> m (Expression a)+findDecl t = do+ tops <- gets topLevel+ case M.lookup t tops of+ Just (Unique i) -> do { es <- gets boundExpr ; pure (es IM.! i) }+ Nothing -> throwError (NoText t)++findMain :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => m (Expression a)+findMain = findDecl "main"++evalDickinsonAsMain :: (MonadError (DickinsonError a) m, MonadState (EvalSt a) m)+ => [Declaration a]+ -> m T.Text+evalDickinsonAsMain d =+ loadDickinson d *>+ (evalExpressionAsTextM =<< findMain)++loadDickinson :: (MonadError (DickinsonError a) m, MonadState (EvalSt a) m)+ => [Declaration a]+ -> m ()+loadDickinson = traverse_ addDecl++balanceMax :: (HasRenames s, HasLexerState s) => MonadState s m => m ()+balanceMax = do+ m0 <- use (rename.maxLens)+ m1 <- use (lexerStateLens._1)+ let m' = max m0 m1+ rename.maxLens .= m'+ lexerStateLens._1 .= m'++addDecl :: (MonadState (EvalSt a) m)+ => Declaration a+ -> m ()+addDecl (Define _ n e) = bindName n e *> topLevelAdd n++extrText :: (HasTyEnv s, MonadState (s a) m, MonadError (DickinsonError a) m) => Expression a -> m T.Text+extrText (Literal _ t) = pure t+extrText (StrChunk _ t) = pure t+extrText e = do { ty <- typeOf e ; throwError $ TypeMismatch e (TyText $ exprAnn e) ty }++withSt :: (HasRenames s, MonadState s m) => (s -> s) -> m b -> m b+withSt modSt act = do+ preSt <- get+ modify modSt+ res <- act+ postMax <- use (rename.maxLens)+ put (set (rename.maxLens) postMax preSt)+ pure res++bindPattern :: (MonadError (DickinsonError a) m, MonadState (EvalSt a) m) => Pattern a -> Expression a -> m (EvalSt a -> EvalSt a)+bindPattern (PatternVar _ n) e = pure $ nameMod n e+bindPattern Wildcard{} _ = pure id+bindPattern (PatternTuple _ ps) (Tuple _ es) = thread <$> Ext.zipWithM bindPattern ps es+bindPattern (PatternTuple l _) _ = throwError $ MalformedTuple l++-- To partially apply lambdas+tryEvalExpressionM :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => Expression a -> m (Expression a)+tryEvalExpressionM e@Literal{} = pure e+tryEvalExpressionM e@StrChunk{} = pure e+tryEvalExpressionM v@(Var _ n) = maybe (pure v) tryEvalExpressionM =<< tryLookupName n+tryEvalExpressionM (Choice _ pes) = tryEvalExpressionM =<< pick pes+tryEvalExpressionM (Tuple l es) = Tuple l <$> traverse tryEvalExpressionM es+tryEvalExpressionM (Lambda l n ty e) = Lambda l n ty <$> tryEvalExpressionM e+tryEvalExpressionM (Annot l e ty) = Annot l <$> tryEvalExpressionM e <*> pure ty+tryEvalExpressionM (Flatten l e) = Flatten l <$> tryEvalExpressionM e+tryEvalExpressionM (Apply l e e') = do+ e'' <- tryEvalExpressionM e+ case e'' of+ Lambda _ n _ e''' ->+ withSt (nameMod n e') $+ tryEvalExpressionM e'''+ _ -> pure $ Apply l e'' e+tryEvalExpressionM (Interp l es) = Interp l <$> traverse tryEvalExpressionM es+tryEvalExpressionM (Concat l es) = Concat l <$> traverse tryEvalExpressionM es+tryEvalExpressionM c@Constructor{} = pure c+tryEvalExpressionM (Let _ bs e) = do+ let stMod = thread $ fmap (uncurry nameMod) bs+ withSt stMod $+ tryEvalExpressionM e+tryEvalExpressionM (Match l e p e') =+ Match l <$> tryEvalExpressionM e <*> pure p <*> tryEvalExpressionM e'++evalExpressionM :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => Expression a -> m (Expression a)+evalExpressionM e@Literal{} = pure e+evalExpressionM e@StrChunk{} = pure e+evalExpressionM e@Constructor{} = pure e+evalExpressionM (Var _ n) = evalExpressionM =<< lookupName n+evalExpressionM (Choice _ pes) = evalExpressionM =<< pick pes+evalExpressionM (Interp l es) = concatOrFail l es+evalExpressionM (Concat l es) = concatOrFail l es+evalExpressionM (Tuple l es) = Tuple l <$> traverse evalExpressionM es+evalExpressionM (Let _ bs e) = do+ let stMod = thread $ fmap (uncurry nameMod) bs+ withSt stMod $+ evalExpressionM e+evalExpressionM (Apply _ e e') = do+ e'' <- evalExpressionM e+ case e'' of+ Lambda _ n _ e''' ->+ withSt (nameMod n e') $+ evalExpressionM =<< tryEvalExpressionM e''' -- tryEvalExpressionM is a special function to "pull" eval through lambdas...+ _ -> error "Ill-typed expression"+evalExpressionM e@Lambda{} = pure e+evalExpressionM (Match _ e p e') = do+ modSt <- bindPattern p =<< evalExpressionM e+ withSt modSt $+ evalExpressionM e'+evalExpressionM (Flatten _ e) = do+ e' <- resolveExpressionM e+ evalExpressionM ({-# SCC "mapChoice.setFrequency" #-} mapChoice setFrequency e')+evalExpressionM (Annot _ e _) = evalExpressionM e++mapChoice :: (NonEmpty (Double, Expression a) -> NonEmpty (Double, Expression a)) -> Expression a -> Expression a+mapChoice f (Choice l pes) = Choice l (f pes)+mapChoice _ e@Literal{} = e+mapChoice _ e@StrChunk{} = e+mapChoice f (Interp l es) = Interp l (mapChoice f <$> es)+mapChoice f (Concat l es) = Concat l (mapChoice f <$> es)+mapChoice f (Annot l e ty) = Annot l (mapChoice f e) ty++setFrequency :: NonEmpty (Double, Expression a) -> NonEmpty (Double, Expression a)+setFrequency = fmap (\(_, e) -> (fromIntegral $ {-# SCC "countNodes" #-} countNodes e, e))++countNodes :: Expression a -> Int+countNodes Literal{} = 1+countNodes StrChunk{} = 1+countNodes (Choice _ pes) = sum (fmap (countNodes . snd) pes)+countNodes (Interp _ es) = product (fmap countNodes es)+countNodes (Concat _ es) = product (fmap countNodes es)+countNodes (Annot _ e _) = countNodes e++concatOrFail :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => a -> [Expression a] -> m (Expression a)+concatOrFail l = fmap (Literal l . mconcat) . traverse evalExpressionAsTextM++evalExpressionAsTextM :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => Expression a -> m T.Text+evalExpressionAsTextM = extrText <=< evalExpressionM++resolveDeclarationM :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => Declaration a -> m (Declaration a)+resolveDeclarationM (Define l n e) = Define l n <$> resolveExpressionM e++-- | Resolve let bindings and such; no not perform choices or concatenations.+resolveExpressionM :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => Expression a -> m (Expression a)+resolveExpressionM e@Literal{} = pure e+resolveExpressionM e@StrChunk{} = pure e+resolveExpressionM e@Constructor{} = pure e+resolveExpressionM (Var _ n) = resolveExpressionM =<< lookupName n+resolveExpressionM (Choice l pes) = do+ let ps = fst <$> pes+ es <- traverse resolveExpressionM (snd <$> pes)+ pure $ Choice l (NE.zip ps es)+resolveExpressionM (Interp l es) = Interp l <$> traverse resolveExpressionM es+resolveExpressionM (Concat l es) = Concat l <$> traverse resolveExpressionM es+resolveExpressionM (Tuple l es) = Tuple l <$> traverse resolveExpressionM es+resolveExpressionM (Let _ bs e) = do+ let stMod = thread $ fmap (uncurry nameMod) bs+ withSt stMod $+ resolveExpressionM e+resolveExpressionM (Apply _ e e') = do+ e'' <- resolveExpressionM e+ case e'' of+ Lambda _ n _ e''' ->+ withSt (nameMod n e') $+ resolveExpressionM e''' -- TODO: is this right?+ _ -> error "Ill-typed expression"+resolveExpressionM e@Lambda{} = pure e -- TODO: is this right?+resolveExpressionM (Match _ e p e') =+ (bindPattern p =<< resolveExpressionM e) *>+ resolveExpressionM e'+resolveExpressionM (Flatten l e) =+ Flatten l <$> resolveExpressionM e+resolveExpressionM (Annot _ e _) = resolveExpressionM e
+ src/Language/Dickinson/File.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE FlexibleContexts #-}++module Language.Dickinson.File ( evalFile+ , checkFile+ , warnFile+ , tcFile+ , amalgamateRename+ , amalgamateRenameM+ , fmtFile+ , pipeline+ ) where++import Control.Applicative ((<|>))+import Control.Exception (Exception)+import Control.Exception.Value+import Control.Monad ((<=<))+import Control.Monad.Except (ExceptT, MonadError, runExceptT)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.State (MonadState, StateT, evalStateT)+import qualified Data.ByteString.Lazy as BSL+import Data.Semigroup ((<>))+import Data.Text as T+import Data.Text.Prettyprint.Doc (hardline, pretty)+import Data.Text.Prettyprint.Doc.Render.Text (putDoc)+import Language.Dickinson.Check+import Language.Dickinson.DuplicateCheck+import Language.Dickinson.Error+import Language.Dickinson.Eval+import Language.Dickinson.Lexer+import Language.Dickinson.Parser+import Language.Dickinson.Rename+import Language.Dickinson.Rename.Amalgamate+import Language.Dickinson.ScopeCheck+import Language.Dickinson.Type+import Language.Dickinson.TypeCheck+import System.Random (StdGen, newStdGen, randoms)++data AmalgamateSt = AmalgamateSt { amalgamateRenames :: Renames+ , amalgamateLexerState :: AlexUserState+ }++type AllM = StateT (EvalSt AlexPosn) (ExceptT (DickinsonError AlexPosn) IO)++evalIO :: AllM x -> IO (Either (DickinsonError AlexPosn) x)+evalIO me = (\g -> evalAllWithGen g me) =<< newStdGen++evalAllWithGen :: StdGen+ -> AllM x+ -> IO (Either (DickinsonError AlexPosn) x)+evalAllWithGen g me = runExceptT $ evalStateT me (EvalSt (randoms g) mempty initRenames mempty alexInitUserState emptyTyEnv)++initAmalgamateSt :: AmalgamateSt+initAmalgamateSt = AmalgamateSt initRenames alexInitUserState++instance HasLexerState AmalgamateSt where+ lexerStateLens f s = fmap (\x -> s { amalgamateLexerState = x }) (f (amalgamateLexerState s))++instance HasRenames AmalgamateSt where+ rename f s = fmap (\x -> s { amalgamateRenames = x }) (f (amalgamateRenames s))++amalgamateRenameM :: (HasRenames s, HasLexerState s, MonadIO m, MonadError (DickinsonError AlexPosn) m, MonadState s m)+ => [FilePath]+ -> FilePath+ -> m [Declaration AlexPosn]+amalgamateRenameM is = (balanceMax *>) . renameDeclarationsM <=< fileDecls is++amalgamateRename :: [FilePath]+ -> FilePath+ -> IO [Declaration AlexPosn]+amalgamateRename is fp = flip evalStateT initAmalgamateSt $ fmap eitherThrow $ runExceptT $ amalgamateRenameM is fp++-- TODO: smart formatter+fmtFile :: FilePath -> IO ()+fmtFile = putDoc . (<> hardline) . pretty . eitherThrow . parse <=< BSL.readFile++-- | Check scoping+checkFile :: [FilePath] -> FilePath -> IO ()+checkFile = ioChecker checkScope++-- | Run some lints+warnFile :: FilePath -> IO ()+warnFile = maybeThrowIO . (\x -> checkDuplicates x <|> checkMultiple x) . (\(Dickinson _ d) -> d)+ <=< eitherThrowIO . parse+ <=< BSL.readFile++ioChecker :: Exception e => ([Declaration AlexPosn] -> Maybe e) -> [FilePath] -> FilePath -> IO ()+ioChecker checker is = maybeThrowIO . checker <=< amalgamateRename is++tcFile :: [FilePath] -> FilePath -> IO ()+tcFile is = eitherThrowIO . tyRun <=< amalgamateRename is++evalFile :: [FilePath] -> FilePath -> IO T.Text+evalFile is = fmap eitherThrow . evalIO . (evalDickinsonAsMain <=< amalgamateRenameM is)++pipeline :: [FilePath] -> FilePath -> IO T.Text+pipeline is fp = fmap eitherThrow $ evalIO $ do+ ds <- amalgamateRenameM is fp+ maybeThrow $ checkScope ds+ evalDickinsonAsMain ds
+ src/Language/Dickinson/Import.hs view
@@ -0,0 +1,28 @@+module Language.Dickinson.Import ( resolveImport+ ) where++import Control.Monad (filterM)+import Control.Monad.IO.Class (MonadIO (..))+import Data.Maybe (listToMaybe)+import Data.Semigroup ((<>))+import qualified Data.Text as T+import Language.Dickinson.Name+import System.Directory (doesFileExist)+import System.FilePath ((</>))++-- TODO: dependency analysis++-- | The canonical way of resolving imports from a name.+--+-- Returns 'Nothing' if no such file exists.+resolveImport :: MonadIO m+ => [FilePath] -- ^ Places to look+ -> Name a+ -> m (Maybe FilePath)+resolveImport incl n = liftIO+ . fmap listToMaybe+ . filterM doesFileExist+ . fmap (</> getFileName n) $ incl++getFileName :: Name a -> FilePath+getFileName = (<> ".dck") . foldr (</>) mempty . fmap T.unpack . name
+ src/Language/Dickinson/Lexer.x view
@@ -0,0 +1,292 @@+{+ {-# LANGUAGE DeriveAnyClass #-}+ {-# LANGUAGE DeriveGeneric #-}+ {-# LANGUAGE OverloadedStrings #-}+ {-# LANGUAGE StandaloneDeriving #-}+ module Language.Dickinson.Lexer ( alexMonadScan+ , runAlex+ , runAlexSt+ , withAlexSt+ , lexDickinson+ , alexInitUserState+ , AlexPosn (..)+ , AlexUserState+ , Alex (..)+ , Token (..)+ , Keyword (..)+ , Sym (..)+ , HasLexerState (..)+ ) where++import Control.Arrow ((&&&))+import Control.DeepSeq (NFData)+import Data.Bifunctor (first)+import Data.Binary (Binary)+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Char8 as ASCII+import Data.Functor (($>))+import qualified Data.IntMap as IM+import qualified Data.List.NonEmpty as NE+import qualified Data.Map as M+import Data.Semigroup ((<>))+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8)+import Data.Text.Prettyprint.Doc (Pretty (pretty), pipe, lparen, rparen, rbrace, rbracket, lbracket, colon, dquotes, dquote, rangle, comma)+import GHC.Generics (Generic)+import Language.Dickinson.Name+import Language.Dickinson.Unique+import Lens.Micro (Lens')++}++%wrapper "monadUserState-bytestring"++$digit = [0-9]++@num = ($digit+ \. $digit+) | ($digit+)++$latin = [a-zA-Z]++$str_special = [\\\"\$]++@escape_str = \\ [$str_special n]++-- single-line string+@string = \" ([^ $str_special] | @escape_str)* \"++$str_chunk = [^ \"\\\$]++@str_interp_in = ($str_chunk | @escape_str)+++@interp = \$\{++@follow_char = [$latin $digit]++@lower_name = [a-z] @follow_char*+@name = (@lower_name \.)* @lower_name+@tyname = [A-Z] @follow_char*++tokens :-++ <0> $white+ ;+ <0> ";".* ;++ <0> \( { mkSym LParen }+ <0> \) { mkSym RParen }+ <0> \> { mkSym RBracket }+ <0> \| { mkSym VBar }+ <0> \[ { mkSym LSqBracket }+ <0> \] { mkSym RSqBracket }+ <0> \$ { mkSym DollarSign }+ <0> \, { mkSym Comma }+ <0> \_ { mkSym Underscore }+ <0> "⟶" { mkSym Arrow }+ <0> "->" { mkSym Arrow }+ <0> \: { mkSym Colon }+ <0> \%\- { mkSym DeclBreak }+ <0> "=" { mkSym Eq }++ -- keywords+ <0> ":let" { mkKeyword KwLet }+ <0> ":branch" { mkKeyword KwBranch }+ <0> ":oneof" { mkKeyword KwOneof }+ <0> ":def" { mkKeyword KwDef }+ <0> ":include" { mkKeyword KwInclude }+ <0> ":lambda" { mkKeyword KwLambda }+ <0> "text" { mkKeyword KwText }+ <0> ":match" { mkKeyword KwMatch }+ <0> ":flatten" { mkKeyword KwFlatten }+ <0> "tydecl" { mkKeyword KwTyDecl }++ <0> @name { tok (\p s -> TokIdent p <$> newIdentAlex p (mkText s)) }+ <0> @tyname { tok (\p s -> TokTyCons p <$> newIdentAlex p (mkText s)) }++ -- strings+ <0> \" { mkSym StrBegin `andBegin` string }+ <string> @str_interp_in { tok (\p s -> alex $ TokStrChunk p (escReplace $ mkText s)) }+ <string> @interp { mkSym BeginInterp `andBegin` 0 }+ <0> \} { mkSym EndInterp `andBegin` string }+ <string> \" { mkSym StrEnd `andBegin` 0 }++ -- strings+ <0> @string { tok (\p s -> alex $ TokString p (escReplace . T.tail . T.init $ mkText s)) }++ -- numbers (as doubles)+ <0> @num { tok (\p s -> alex $ TokDouble p (read $ ASCII.unpack s)) } -- shouldn't cause any problems cuz digits++{++escReplace :: T.Text -> T.Text+escReplace =+ T.replace "\\\"" "\""+ . T.replace "\\n" "\n"+ . T.replace "\\$" "$"++mkText :: BSL.ByteString -> T.Text+mkText = decodeUtf8 . BSL.toStrict++alex :: a -> Alex a+alex = pure++set_ust :: AlexUserState -> Alex ()+set_ust st = Alex (Right . (go &&& (const ())))+ where go s = s { alex_ust = st }++gets_alex :: (AlexState -> a) -> Alex a+gets_alex f = Alex (Right . (id &&& f))++get_ust :: Alex AlexUserState+get_ust = gets_alex alex_ust++get_pos :: Alex AlexPosn+get_pos = gets_alex alex_pos++alexEOF = EOF <$> get_pos++tok f (p,_,s,_) len = f p (BSL.take len s)++constructor c t = tok (\p _ -> alex $ c p t)++mkKeyword = constructor TokKeyword++mkSym = constructor TokSym++type AlexUserState = (UniqueCtx, M.Map T.Text Int, NameEnv AlexPosn)++class HasLexerState a where+ lexerStateLens :: Lens' a AlexUserState++newIdentAlex :: AlexPosn -> T.Text -> Alex (Name AlexPosn)+newIdentAlex pos t = do+ st <- get_ust+ let (st', n) = newIdent pos t st+ set_ust st' $> (n $> pos)++newIdent :: AlexPosn -> T.Text -> AlexUserState -> (AlexUserState, Name AlexPosn)+newIdent pos t pre@(max', names, uniqs) =+ case M.lookup t names of+ Just i -> (pre, Name tQual (Unique i) pos)+ Nothing -> let i = max' + 1+ in let newName = Name tQual (Unique i) pos+ in ((i, M.insert t i names, IM.insert i newName uniqs), newName)+ where tQual = NE.fromList (T.splitOn "." t)++alexInitUserState :: AlexUserState+alexInitUserState = (0, mempty, mempty)++data Sym = LParen+ | RParen+ | VBar+ | LSqBracket+ | RSqBracket+ | RBracket+ | BeginInterp+ | EndInterp+ | StrBegin+ | StrEnd+ | Arrow+ | DollarSign+ | Comma+ | Underscore+ | Colon+ | DeclBreak+ | Eq+ deriving (Eq, Generic, NFData)++instance Pretty Sym where+ pretty LParen = lparen+ pretty RParen = rparen+ pretty VBar = pipe+ pretty LSqBracket = lbracket+ pretty RSqBracket = rbracket+ pretty RBracket = rangle+ pretty BeginInterp = "${"+ pretty EndInterp = rbrace+ pretty StrBegin = dquote+ pretty StrEnd = dquote+ pretty Arrow = "⟶"+ pretty DollarSign = "$"+ pretty Comma = comma+ pretty Underscore = "_"+ pretty Colon = colon+ pretty DeclBreak = "%-"+ pretty Eq = "="++data Keyword = KwDef+ | KwLet+ | KwBranch+ | KwOneof+ | KwInclude+ | KwLambda+ | KwText+ | KwMatch+ | KwFlatten+ | KwTyDecl+ deriving (Eq, Generic, NFData)++instance Pretty Keyword where+ pretty KwDef = ":def"+ pretty KwLet = ":let"+ pretty KwBranch = ":branch"+ pretty KwOneof = ":oneof"+ pretty KwInclude = ":include"+ pretty KwLambda = ":lambda"+ pretty KwText = "text"+ pretty KwMatch = ":match"+ pretty KwFlatten = ":flatten"+ pretty KwTyDecl = "tydecl"++instance Pretty AlexPosn where+ pretty (AlexPn _ line col) = pretty line <> colon <> pretty col++deriving instance Generic AlexPosn++deriving instance NFData AlexPosn++deriving instance Binary AlexPosn++data Token a = EOF { loc :: a }+ | TokIdent { loc :: a, ident :: Name a }+ | TokTyCons { loc :: a, tyIdent :: TyName a }+ | TokDouble { loc :: a, double :: Double }+ -- separate tok for full strings for sake of speed+ | TokString { loc :: a, str :: T.Text }+ | TokStrChunk { loc :: a, str :: T.Text }+ | TokKeyword { loc :: a, kw :: Keyword }+ | TokSym { loc :: a, sym :: Sym }+ deriving (Eq, Generic, NFData)++instance Pretty (Token a) where+ pretty EOF{} = mempty+ pretty (TokIdent _ n) = pretty n+ pretty (TokTyCons _ tn) = pretty tn+ pretty (TokDouble _ d) = pretty d+ pretty (TokString _ str') = dquotes (pretty str')+ pretty (TokStrChunk _ str') = pretty str'+ pretty (TokKeyword _ kw') = pretty kw'+ pretty (TokSym _ sym') = pretty sym'++loop :: Alex [Token AlexPosn]+loop = do+ tok' <- alexMonadScan+ case tok' of+ EOF{} -> pure []+ _ -> (tok' :) <$> loop++lexDickinson :: BSL.ByteString -> Either String [Token AlexPosn]+lexDickinson = flip runAlex loop++runAlexSt :: BSL.ByteString -> Alex a -> Either String (AlexUserState, a)+runAlexSt inp = withAlexSt inp alexInitUserState++withAlexSt :: BSL.ByteString -> AlexUserState -> Alex a -> Either String (AlexUserState, a)+withAlexSt inp ust (Alex f) = first alex_ust <$> f+ (AlexState { alex_bpos = 0+ , alex_pos = alexStartPos+ , alex_inp = inp+ , alex_chr = '\n'+ , alex_ust = ust+ , alex_scd = 0+ })++}
+ src/Language/Dickinson/Lib.hs view
@@ -0,0 +1,16 @@+module Language.Dickinson.Lib ( defaultLibPath+ , libPath+ ) where++import Paths_language_dickinson (getDataDir)+import System.FilePath ((</>))++libPath :: IO [FilePath]+libPath = defaultLibPath <*> pure []++defaultLibPath :: IO ([FilePath] -> [FilePath])+defaultLibPath = do+ datadir <- getDataDir+ let preludeDir = datadir </> "prelude"+ libDir = datadir </> "lib"+ pure $ (preludeDir :) . (libDir :)
+ src/Language/Dickinson/Lib/Get.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE FlexibleContexts #-}++module Language.Dickinson.Lib.Get ( parseImportM+ , parseFpM+ ) where++import Control.Composition ((.*))+import Control.Monad.Except (MonadError, throwError)+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.State (MonadState)+import qualified Data.ByteString.Lazy as BSL+import Data.Functor (($>))+import Language.Dickinson.Error+import Language.Dickinson.Import+import Language.Dickinson.Lexer+import Language.Dickinson.Parser+import Language.Dickinson.Type+import Lens.Micro.Mtl (use, (.=))++parseImportM :: (HasLexerState s, MonadState s m, MonadError (DickinsonError AlexPosn) m, MonadIO m)+ => [FilePath] -- ^ Include path+ -> Import AlexPosn+ -> m (Dickinson AlexPosn)+parseImportM = liftLexerState .* parseImport++liftLexerState :: (HasLexerState s, MonadState s m)+ => (AlexUserState -> m (AlexUserState, a))+ -> m a+liftLexerState fAct = do+ lSt <- use lexerStateLens+ (st, x) <- fAct lSt+ (lexerStateLens .= st) $> x++-- Parse an import. Does NOT perform renaming!+parseImport :: (MonadError (DickinsonError AlexPosn) m, MonadIO m)+ => [FilePath] -- ^ Include path+ -> Import AlexPosn+ -> AlexUserState -- ^ Lexer state+ -> m (AlexUserState, Dickinson AlexPosn)+parseImport is (Import l n) lSt = do+ preFp <- resolveImport is n+ case preFp of+ Just fp -> parseFp fp lSt+ Nothing -> throwError $ ModuleNotFound l n++parseFp :: (MonadError (DickinsonError AlexPosn) m, MonadIO m)+ => FilePath -- ^ Source file+ -> AlexUserState -- ^ Lexer state+ -> m (AlexUserState, Dickinson AlexPosn)+parseFp fp lSt = do+ bsl <- liftIO $ BSL.readFile fp+ case parseWithCtx bsl lSt of+ Right x -> pure x+ Left err -> throwError (ParseErr fp err)++parseFpM :: (HasLexerState s, MonadState s m, MonadError (DickinsonError AlexPosn) m, MonadIO m)+ => FilePath -- ^ Source file+ -> m (Dickinson AlexPosn)+parseFpM fp = liftLexerState (parseFp fp)
+ src/Language/Dickinson/Name.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.Dickinson.Name ( TyName+ , Name (..)+ , NameEnv+ , isMain+ ) where++import Control.DeepSeq (NFData (..))+import Data.Binary (Binary (..))+import Data.Foldable (toList)+import qualified Data.IntMap as IM+import Data.List.NonEmpty (NonEmpty (..))+import Data.Semigroup ((<>))+import qualified Data.Text as T+import Data.Text.Prettyprint.Doc (Pretty (pretty))+import Data.Text.Prettyprint.Doc.Ext (intercalate)+import GHC.Generics (Generic)+import Language.Dickinson.Unique++type TyName a = Name a++-- | A (possibly qualified) name.+data Name a = Name { name :: NonEmpty T.Text+ , unique :: !Unique+ , loc :: a+ } deriving (Functor, Generic, Binary, Show)++instance NFData a => NFData (Name a) where+ rnf (Name _ u x) = rnf x `seq` u `seq` ()++isMain :: Name a -> Bool+isMain = (== ("main" :| [])) . name++instance Eq (Name a) where+ (==) (Name _ u _) (Name _ u' _) = u == u'++instance Ord (Name a) where+ compare (Name _ u _) (Name _ u' _) = compare u u'++instance Pretty (Name a) where+ pretty (Name t _ _) = intercalate "." (toList (pretty <$> t))++type NameEnv a = IM.IntMap (Name a)
+ src/Language/Dickinson/Parser.y view
@@ -0,0 +1,225 @@+{++ {-# LANGUAGE DeriveAnyClass #-}+ {-# LANGUAGE DeriveGeneric #-}+ {-# LANGUAGE OverloadedStrings #-}+ {-# LANGUAGE TupleSections #-}+ module Language.Dickinson.Parser ( parse+ , parseWithMax+ , parseWithCtx+ , parseWithInitCtx+ , parseReplWithCtx+ , parseExpressionWithCtx+ , ParseError (..)+ ) where++import Data.Bifunctor (first)+import Control.DeepSeq (NFData)+import Control.Exception (Exception)+import Control.Monad.Except (ExceptT, runExceptT, throwError)+import Control.Monad.Trans.Class (lift)+import qualified Data.ByteString.Lazy as BSL+import Data.Foldable (toList)+import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty (NonEmpty ((:|)), (<|))+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8)+import Data.Text.Prettyprint.Doc (Pretty (pretty), (<+>))+import Data.Tuple.Ext (fst3)+import Data.Typeable (Typeable)+import GHC.Generics (Generic)+import Language.Dickinson.Lexer+import Language.Dickinson.Name hiding (loc)+import Language.Dickinson.Type+import Language.Dickinson.Unique++}++%name parseDickinson Dickinson+%name parseExpression Expression+%name parseRepl DeclarationOrExpression+%tokentype { Token AlexPosn }+%error { parseError }+%monad { Parse } { (>>=) } { pure }+%lexer { lift alexMonadScan >>= } { EOF _ }++%token++ lparen { TokSym $$ LParen }+ rparen { TokSym $$ RParen }+ vbar { TokSym $$ VBar }+ lsqbracket { TokSym $$ LSqBracket }+ rsqbracket { TokSym $$ RSqBracket }+ rbracket { TokSym $$ RBracket }+ strBegin { TokSym $$ StrBegin }+ strEnd { TokSym $$ StrEnd }+ arrow { TokSym $$ Arrow }+ dollar { TokSym $$ DollarSign }+ comma { TokSym $$ Comma }+ underscore { TokSym $$ Underscore }+ colon { TokSym $$ Colon }+ declBreak { TokSym $$ DeclBreak }+ eq { TokSym $$ Eq }++ beginInterp { TokSym $$ BeginInterp }+ endInterp { TokSym $$ EndInterp }++ def { TokKeyword $$ KwDef }+ let { TokKeyword $$ KwLet }+ branch { TokKeyword $$ KwBranch }+ oneof { TokKeyword $$ KwOneof }+ include { TokKeyword $$ KwInclude }+ lambda { TokKeyword $$ KwLambda }+ match { TokKeyword $$ KwMatch }+ flatten { TokKeyword $$ KwFlatten }+ tydecl { TokKeyword $$ KwTyDecl }++ text { TokKeyword $$ KwText }++ ident { $$@(TokIdent _ _) }+ tyIdent { $$@(TokTyCons _ _) }++ strChunk { $$@(TokStrChunk _ _) }+ stringLiteral { $$@(TokString _ _) }++ num { TokDouble _ $$ }++%%++many(p)+ : many(p) p { $2 : $1 }+ | { [] }++some(p)+ : many(p) p { $2 :| $1 }++sepBy(p,q)+ : sepBy(p,q) q p { $3 <| $1 }+ | p q p { $3 :| [$1] }++parens(p)+ : lparen p rparen { $2 }++brackets(p)+ : lsqbracket p rsqbracket { $2 }++Dickinson :: { Dickinson AlexPosn }+ : many(parens(Import)) declBreak many(Declaration) { Dickinson (reverse $1) (reverse $3) }++TyCons :: { NonEmpty (TyName AlexPosn) }+ : sepBy(tyIdent,vbar) { fmap tyIdent $1 }++Declaration :: { Declaration AlexPosn }+ : lparen def Name Expression rparen { Define $2 $3 $4 }+ | tydecl Name eq TyCons { TyDecl $1 $2 (NE.reverse $4) }++Import :: { Import AlexPosn }+ : include Name { Import $1 $2 }++Name :: { Name AlexPosn }+ : ident { ident $1 }++Type :: { DickinsonTy AlexPosn }+ : text { TyText $1 }+ | arrow Type Type { TyFun $1 $2 $3 }+ | lparen sepBy(Type,comma) rparen { TyTuple $1 (NE.reverse $2) }+ | ident { TyNamed (loc $1) (ident $1) }+ | parens(Type) { $1 }++Bind :: { (Name AlexPosn, Expression AlexPosn) }+ : Name Expression { ($1, $2) }++Interp :: { Expression AlexPosn }+Interp : strChunk { StrChunk (loc $1) (str $1) }+ | beginInterp Expression endInterp { $2 }++Pattern :: { Pattern AlexPosn }+ : ident { PatternVar (loc $1) (ident $1) }+ | lparen sepBy(Pattern,comma) rparen { PatternTuple $1 (NE.reverse $2) }+ | underscore { Wildcard $1 }++Expression :: { Expression AlexPosn }+ : branch some(parens(WeightedLeaf)) { Choice $1 (NE.reverse $2) }+ | oneof some(parens(Leaf)) { Choice $1 (NE.reverse (weight $2)) }+ | let some(brackets(Bind)) Expression { Let $1 (NE.reverse $2) $3 }+ | lambda Name Type Expression { Lambda $1 $2 $3 $4 }+ | ident { Var (loc $1) (ident $1) }+ | stringLiteral { Literal (loc $1) (str $1) }+ | strBegin some(Interp) strEnd { Interp $1 (toList $ NE.reverse $2) }+ | rbracket many(Expression) { Concat $1 (reverse $2) }+ | dollar Expression Expression { Apply $1 $2 $3 }+ | lparen sepBy(Expression,comma) rparen { Tuple $1 (NE.reverse $2) }+ | match Expression Pattern Expression { Match $1 $2 $3 $4 }+ | flatten Expression { Flatten $1 $2 }+ | Expression colon Type { Annot $2 $1 $3 }+ | tyIdent { Constructor (loc $1) (tyIdent $1) }+ | parens(Expression) { $1 }++WeightedLeaf :: { (Double, Expression AlexPosn) }+ : vbar num Expression { ($2, $3) }+ | num Expression { ($1, $2) }++Leaf :: { Expression AlexPosn }+ : vbar Expression { $2 }++DeclarationOrExpression :: { Either (Declaration AlexPosn) (Expression AlexPosn) }+ : Expression { Right $1 }+ | Declaration { Left $1 }++{++weight :: NonEmpty (Expression a) -> NonEmpty (Double, Expression a)+weight es = (recip, ) <$> es+ where recip = 1 / (fromIntegral $ length es)++parseError :: Token AlexPosn -> Parse a+parseError = throwError . Unexpected++data ParseError a = Unexpected (Token a)+ | LexErr String+ deriving (Generic, NFData)++instance Pretty a => Pretty (ParseError a) where+ pretty (Unexpected tok) = pretty (loc tok) <+> "Unexpected" <+> pretty tok+ pretty (LexErr str) = pretty (T.pack str)++instance Pretty a => Show (ParseError a) where+ show = show . pretty++instance (Pretty a, Typeable a) => Exception (ParseError a)++type Parse = ExceptT (ParseError AlexPosn) Alex++parse :: BSL.ByteString -> Either (ParseError AlexPosn) (Dickinson AlexPosn)+parse = fmap snd . parseWithMax++parseReplWithCtx :: BSL.ByteString -> AlexUserState -> Either (ParseError AlexPosn) (AlexUserState, Either (Declaration AlexPosn) (Expression AlexPosn))+parseReplWithCtx = parseWithInitSt parseRepl++parseExpressionWithCtx :: BSL.ByteString -> AlexUserState -> Either (ParseError AlexPosn) (AlexUserState, Expression AlexPosn)+parseExpressionWithCtx = parseWithInitSt parseExpression++parseWithInitCtx :: BSL.ByteString -> Either (ParseError AlexPosn) (AlexUserState, Dickinson AlexPosn)+parseWithInitCtx bsl = parseWithCtx bsl alexInitUserState++parseWithCtx :: BSL.ByteString -> AlexUserState -> Either (ParseError AlexPosn) (AlexUserState, Dickinson AlexPosn)+parseWithCtx = parseWithInitSt parseDickinson++parseWithMax :: BSL.ByteString -> Either (ParseError AlexPosn) (UniqueCtx, Dickinson AlexPosn)+parseWithMax = parseWrapper parseDickinson++parseWithInitSt :: Parse a -> BSL.ByteString -> AlexUserState -> Either (ParseError AlexPosn) (AlexUserState, a)+parseWithInitSt parser str st = liftErr $ withAlexSt str st (runExceptT parser)+ where liftErr (Left err) = Left (LexErr err)+ liftErr (Right (_, Left err)) = Left err+ liftErr (Right (i, Right x)) = Right (i, x)++parseWrapper :: Parse a -> BSL.ByteString -> Either (ParseError AlexPosn) (UniqueCtx, a)+parseWrapper parser str = fmap (first fst3) $ liftErr $ runAlexSt str (runExceptT parser)++liftErr :: Either String (b, Either (ParseError a) c) -> Either (ParseError a) (b, c)+liftErr (Left err) = Left (LexErr err)+liftErr (Right (_, Left err)) = Left err+liftErr (Right (i, Right x)) = Right (i, x)++}
+ src/Language/Dickinson/Rename.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.Dickinson.Rename ( renameDickinson+ , renameDickinsonM+ , renameDeclarationsM+ , renameDeclarationM+ , renameExpressionM+ , initRenames+ , maxLens+ , boundLens+ , replaceUnique+ , RenameM+ , Renames (..)+ , HasRenames (..)+ ) where++import Control.Composition (thread)+import Control.Monad ((<=<))+import Control.Monad.Ext (zipWithM)+import Control.Monad.State (MonadState, State, runState)+import Data.Bifunctor (second)+import Data.Binary (Binary)+import qualified Data.IntMap as IM+import qualified Data.List.NonEmpty as NE+import Data.Semigroup (Semigroup (..))+import Data.Text.Prettyprint.Doc (Pretty (..), (<+>))+import Data.Text.Prettyprint.Doc.Ext+import GHC.Generics (Generic)+import Language.Dickinson.Name+import Language.Dickinson.Type+import Language.Dickinson.Unique+import Lens.Micro (Lens')+import Lens.Micro.Mtl (modifying, use, (%=), (.=))++-- | Renamer state passed between various stages of compilation+data Renames = Renames { max_ :: Int, bound :: IM.IntMap Int }+ deriving (Generic, Binary)++instance Pretty Renames where+ pretty (Renames m b) = "max:" <+> pretty m <#> "renames:" <#*> prettyDumpBinds b++boundLens :: Lens' Renames (IM.IntMap Int)+boundLens f s = fmap (\x -> s { bound = x }) (f (bound s))++maxLens :: Lens' Renames Int+maxLens f s = fmap (\x -> s { max_ = x }) (f (max_ s))++class HasRenames a where+ rename :: Lens' a Renames++instance HasRenames Renames where+ rename = id++instance Semigroup Renames where+ (<>) (Renames m1 b1) (Renames m2 b2) = Renames (max m1 m2) (b1 <> b2)++instance Monoid Renames where+ mempty = Renames 0 mempty+ mappend = (<>)++type RenameM a = State Renames++initRenames :: Renames+initRenames = Renames 0 mempty++runRenameM :: Int -> RenameM a x -> (x, UniqueCtx)+runRenameM i x = second max_ (runState x (Renames i mempty))++-- Make sure you don't have cycles in the renames map!+replaceUnique :: (MonadState s m, HasRenames s) => Unique -> m Unique+replaceUnique u@(Unique i) = do+ rSt <- use (rename.boundLens)+ case IM.lookup i rSt of+ Nothing -> pure u+ Just j -> replaceUnique (Unique j)++replaceVar :: (MonadState s m, HasRenames s) => Name a -> m (Name a)+replaceVar (Name n u l) = {-# SCC "replaceVar" #-} do+ u' <- replaceUnique u+ pure $ Name n u' l++renameDickinson :: Int -> Dickinson a -> (Dickinson a, Int)+renameDickinson m ds = runRenameM m $ renameDickinsonM ds++renameDickinsonM :: (MonadState s m, HasRenames s) => Dickinson a -> m (Dickinson a)+renameDickinsonM (Dickinson i d) = Dickinson i <$> renameDeclarationsM d++renameDeclarationsM :: (MonadState s m, HasRenames s) => [Declaration a] -> m [Declaration a]+renameDeclarationsM = traverse renameDeclarationM <=< traverse insDeclM++-- broadcast first...+insDeclM :: (MonadState s m, HasRenames s) => Declaration a -> m (Declaration a)+insDeclM (Define p n e) = do+ (n', modR) <- withName n+ modifying rename modR+ pure $ Define p n' e+insDeclM d@TyDecl{} = pure d -- FIXME: scoping!! (two type decls should be illegal?)++renameDeclarationM :: (MonadState s m, HasRenames s) => Declaration a -> m (Declaration a)+renameDeclarationM (Define p n e) =+ Define p n <$> renameExpressionM e+renameDeclarationM d@TyDecl{} = pure d++withRenames :: (HasRenames s, MonadState s m) => (Renames -> Renames) -> m a -> m a+withRenames modSt act = do+ preSt <- use rename+ rename %= modSt+ res <- act+ postMax <- use (rename.maxLens)+ rename .= setMax postMax preSt+ pure res++withName :: (HasRenames s, MonadState s m) => Name a -> m (Name a, Renames -> Renames)+withName (Name t (Unique i) l) = do+ m <- use (rename.maxLens)+ let newUniq = m+1+ rename.maxLens .= newUniq+ pure (Name t (Unique newUniq) l, mapBound (IM.insert i (m+1)))++mapBound :: (IM.IntMap Int -> IM.IntMap Int) -> Renames -> Renames+mapBound f (Renames m b) = Renames m (f b)++setMax :: Int -> Renames -> Renames+setMax i (Renames _ b) = Renames i b++renamePatternM :: (MonadState s m, HasRenames s) => Pattern a -> m (Renames -> Renames, Pattern a)+renamePatternM w@Wildcard{} = pure (id, w)+renamePatternM (PatternTuple l ps) = do+ ps' <- traverse renamePatternM ps+ let modR = thread (fst <$> ps')+ ps'' = snd <$> ps'+ pure (modR, PatternTuple l ps'')+renamePatternM (PatternVar l n) = do+ (n', modR) <- withName n+ pure (modR, PatternVar l n')++renameExpressionM :: (MonadState s m, HasRenames s) => Expression a -> m (Expression a)+renameExpressionM e@Literal{} = pure e+renameExpressionM e@StrChunk{} = pure e+renameExpressionM (Var p n) = Var p <$> replaceVar n+renameExpressionM (Choice p branches) = Choice p <$> branches'+ where branches' =+ let ds = fst <$> branches+ in let es = fmap snd branches+ in NE.zip ds <$> traverse renameExpressionM es+renameExpressionM (Interp p es) = Interp p <$> traverse renameExpressionM es+renameExpressionM (Concat p es) = Concat p <$> traverse renameExpressionM es+renameExpressionM (Tuple p es) = Tuple p <$> traverse renameExpressionM es+renameExpressionM (Apply p e e') = Apply p <$> renameExpressionM e <*> renameExpressionM e'+renameExpressionM (Lambda p n ty e) = do+ (n', modR) <- withName n+ Lambda p n' ty <$> withRenames modR (renameExpressionM e)+renameExpressionM (Match l e p e') = do+ preE <- renameExpressionM e+ (modP, p') <- renamePatternM p+ Match l preE p' <$> withRenames modP (renameExpressionM e')+renameExpressionM (Let p bs e) = do+ newBs <- traverse withName (fst <$> bs)+ let localRenames = snd <$> newBs+ newBinds = thread localRenames+ newNames = fst <$> newBs+ preNewBound = snd <$> bs+ newBound <-+ zipWithM (\r e' -> withRenames r (renameExpressionM e')) localRenames preNewBound+ withRenames newBinds $+ Let p (NE.zip newNames newBound) <$> renameExpressionM e+renameExpressionM (Flatten l e) =+ Flatten l <$> renameExpressionM e+renameExpressionM (Annot l e ty) =+ Annot l <$> renameExpressionM e <*> pure ty+renameExpressionM c@Constructor{} = pure c
+ src/Language/Dickinson/Rename/Amalgamate.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE FlexibleContexts #-}++module Language.Dickinson.Rename.Amalgamate ( amalgamateM+ , fileDecls+ ) where++import Control.Monad ((<=<))+import Control.Monad.Except (MonadError)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.State (MonadState)+import Data.Semigroup ((<>))+import Language.Dickinson.Error+import Language.Dickinson.Lexer+import Language.Dickinson.Lib.Get+import Language.Dickinson.Type++withImportM :: (HasLexerState s, MonadIO m, MonadError (DickinsonError AlexPosn) m, MonadState s m)+ => [FilePath] -- ^ Includes+ -> Import AlexPosn+ -> m [Declaration AlexPosn]+withImportM is i = do+ dck <- parseImportM is i+ amalgamateM is dck++-- sequence?+amalgamateM :: (HasLexerState s, MonadIO m, MonadError (DickinsonError AlexPosn) m, MonadState s m)+ => [FilePath] -- ^ Includes+ -> Dickinson AlexPosn+ -> m [Declaration AlexPosn]+amalgamateM _ (Dickinson [] ds) = pure ds+amalgamateM is (Dickinson imps ds) = do+ ids <- traverse (withImportM is) imps+ pure (concat ids <> ds)++fileDecls :: (HasLexerState s, MonadIO m, MonadError (DickinsonError AlexPosn) m, MonadState s m)+ => [FilePath] -- ^ Includes+ -> FilePath -- ^ Source file+ -> m [Declaration AlexPosn]+fileDecls is = amalgamateM is <=< parseFpM
+ src/Language/Dickinson/ScopeCheck.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE FlexibleContexts #-}++module Language.Dickinson.ScopeCheck ( checkScope+ , checkScopeExpr+ , checkScopeDecl+ ) where++import Control.Applicative (Alternative, (<|>))+import Control.Monad.Except (MonadError)+import Control.Monad.State (State, evalState, get, modify)+import Data.Foldable (asum, traverse_)+import qualified Data.IntSet as IS+import Language.Dickinson.Check.Pattern+import Language.Dickinson.Error+import Language.Dickinson.Name+import Language.Dickinson.Type+import Language.Dickinson.Unique++type CheckM = State IS.IntSet++runCheckM :: CheckM a -> a+runCheckM = flip evalState IS.empty++insertName :: Name a -> CheckM ()+insertName (Name _ (Unique i) _) = modify (IS.insert i)++deleteName :: Name a -> CheckM ()+deleteName (Name _ (Unique i) _) = modify (IS.delete i)++-- | Checks that there are not any identifiers that aren't in scope; needs to run+-- after the renamer+checkScope :: [Declaration a] -> Maybe (DickinsonError a)+checkScope = runCheckM . checkDickinson++checkScopeExpr :: MonadError (DickinsonError a) m => Expression a -> m ()+checkScopeExpr = maybeThrow . runCheckM . checkExpr++checkScopeDecl :: MonadError (DickinsonError a) m => Declaration a -> m ()+checkScopeDecl = maybeThrow . runCheckM . checkDecl++checkDickinson :: [Declaration a] -> CheckM (Maybe (DickinsonError a))+checkDickinson d = traverse_ insDecl d *> mapSumM checkDecl d++insDecl :: Declaration a -> CheckM ()+insDecl (Define _ n _) = insertName n++checkDecl :: Declaration a -> CheckM (Maybe (DickinsonError a))+checkDecl (Define _ _ e) = checkExpr e++checkExpr :: Expression a -> CheckM (Maybe (DickinsonError a))+checkExpr Literal{} = pure Nothing+checkExpr StrChunk{} = pure Nothing+checkExpr (Apply _ e e') = (<|>) <$> checkExpr e <*> checkExpr e'+checkExpr (Interp _ es) = mapSumM checkExpr es+checkExpr (Choice _ brs) = mapSumM checkExpr (snd <$> brs)+checkExpr (Concat _ es) = mapSumM checkExpr es+checkExpr (Tuple _ es) = mapSumM checkExpr es+checkExpr (Flatten _ e) = checkExpr e+checkExpr (Annot _ e _) = checkExpr e+checkExpr (Lambda _ n _ e) = do+ insertName n+ checkExpr e <* deleteName n+checkExpr (Var _ n@(Name _ (Unique i) l)) = do+ b <- get+ if i `IS.member` b+ then pure Nothing+ else pure $ Just (UnfoundName l n)+checkExpr (Let _ bs e) = do+ let ns = fst <$> bs+ traverse_ insertName ns+ (<|>) <$> checkExpr e <*> mapSumM checkExpr (snd <$> bs)+ <* traverse_ deleteName ns+checkExpr (Match _ e p e') =+ ((<|>) <$> checkExpr e) <*> do+ let ns = traversePattern p+ traverse_ insertName ns+ checkExpr e' <* traverse_ deleteName ns++mapSumM :: (Traversable t, Alternative f, Applicative m) => (a -> m (f b)) -> t a -> m (f b)+mapSumM = (fmap asum .) . traverse
+ src/Language/Dickinson/Type.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.Dickinson.Type ( Dickinson (..)+ , Declaration (..)+ , Import (..)+ , Expression (..)+ , Pattern (..)+ , DickinsonTy (..)+ ) where++import Control.DeepSeq (NFData)+import Data.Binary (Binary)+import Data.Foldable (toList)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NE+import Data.Semigroup ((<>))+import qualified Data.Text as T+import Data.Text.Prettyprint.Doc (Doc, Pretty (pretty), brackets, colon, concatWith, dquotes, group,+ hardline, hsep, indent, parens, pipe, rangle, tupled, vsep, (<+>))+import Data.Text.Prettyprint.Doc.Ext (hardSep, (<#*>), (<#>), (<^>))+import GHC.Generics (Generic)+import Language.Dickinson.Name++data Dickinson a = Dickinson { modImports :: [Import a]+ , modDefs :: [Declaration a]+ } deriving (Generic, NFData, Binary, Functor, Show)++data Declaration a = Define { declAnn :: a+ , defName :: Name a+ , defExpr :: Expression a+ }+ | TyDecl { declAnn :: a+ , tyName :: Name a+ , tyCons :: NonEmpty (TyName a)+ }+ deriving (Generic, NFData, Binary, Functor, Show)++data Import a = Import { importAnn :: a+ , declMod :: Name a+ }+ deriving (Generic, NFData, Binary, Functor, Show)++data Pattern a = PatternVar a (Name a)+ | PatternTuple a (NonEmpty (Pattern a))+ | PatternCons a (TyName a)+ | Wildcard a+ deriving (Generic, NFData, Binary, Functor, Show)++data Expression a = Literal { exprAnn :: a, litText :: T.Text }+ | StrChunk { exprAnn :: a, chunkText :: T.Text }+ | Choice { exprAnn :: a+ , choices :: (NonEmpty (Double, Expression a))+ }+ | Let { exprAnn :: a+ , letBinds :: (NonEmpty (Name a, Expression a))+ , letExpr :: (Expression a)+ }+ | Var { exprAnn :: a, exprVar :: (Name a) }+ | Interp { exprAnn :: a, exprInterp :: [Expression a] }+ | Lambda { exprAnn :: a+ , lambdaVar :: (Name a)+ , lambdaTy :: (DickinsonTy a)+ , lambdaExpr :: (Expression a)+ }+ | Apply { exprAnn :: a+ , exprFun :: (Expression a)+ , exprArg :: (Expression a)+ }+ | Concat { exprAnn :: a, exprConcats :: [Expression a] }+ | Tuple { exprAnn :: a, exprTup :: (NonEmpty (Expression a)) }+ | Match { exprAnn :: a+ , exprMatch :: (Expression a)+ , exprPat :: (Pattern a)+ , exprIn :: (Expression a)+ }+ | Flatten { exprAnn :: a, exprFlat :: (Expression a) }+ | Annot { exprAnn :: a+ , expr :: (Expression a)+ , exprTy :: (DickinsonTy a)+ }+ | Constructor { exprAnn :: a, constructorName :: TyName a }+ deriving (Generic, NFData, Binary, Functor, Show)+ -- TODO: builtins?++data DickinsonTy a = TyText a+ | TyFun a (DickinsonTy a) (DickinsonTy a)+ | TyTuple a (NonEmpty (DickinsonTy a))+ | TyNamed a (Name a)+ deriving (Generic, NFData, Binary, Show, Functor)++instance Eq (DickinsonTy a) where+ (==) TyText{} TyText{} = True+ (==) (TyFun _ ty ty') (TyFun _ ty'' ty''') = (ty == ty'') && (ty' == ty''')+ (==) (TyTuple _ tys) (TyTuple _ tys') = and (NE.zipWith (==) tys tys')+ (==) (TyNamed _ n) (TyNamed _ n') = n == n'+ (==) _ _ = False++instance Pretty (Declaration a) where+ pretty (Define _ n e) = parens (":def" <+> pretty n <#> indent 2 (pretty e))+ pretty (TyDecl _ n cs) = "tydecl" <+> pretty n <+> "=" <+> (concatWith (\x y -> x <+> pipe <+> y)) (toList (pretty <$> cs))++instance Pretty (Import a) where+ pretty (Import _ n) = parens (":include" <+> pretty n)++instance Pretty (Dickinson a) where+ pretty (Dickinson is ds) = concatWith (\x y -> x <> hardline <> hardline <> y) (fmap pretty is <> ["%-"] <> fmap pretty ds)++prettyLetLeaf :: (Name a, Expression a) -> Doc b+prettyLetLeaf (n, e) = group (brackets (pretty n <+> pretty e))++prettyChoiceBranch :: (Double, Expression a) -> Doc b+prettyChoiceBranch (d, e) = parens (pipe <+> pretty d <+> pretty e)+++prettyInterp :: Expression a -> Doc b+prettyInterp (StrChunk _ t) = pretty (escReplace t)+prettyInterp e = "${" <> pretty e <> "}"++instance Pretty (Pattern a) where+ pretty (PatternVar _ n) = pretty n+ pretty (PatternTuple _ ps) = tupled (toList (pretty <$> ps))+ pretty Wildcard{} = "_"++escReplace :: T.Text -> T.Text+escReplace =+ T.replace "\"" "\\\""+ . T.replace "\n" "\\n"+ . T.replace "$" "\\$"++-- figure out indentation+instance Pretty (Expression a) where+ pretty (Var _ n) = pretty n+ pretty (Literal _ l) = dquotes $ pretty (escReplace l)+ pretty (Let _ ls e) = group (parens (":let" <^> vsep (toList (fmap prettyLetLeaf ls) ++ [pretty e])))+ -- TODO: if they're all equal, use :oneof+ -- also comments lol+ pretty (Choice _ brs) = parens (":branch" <#> indent 2 (hardSep (toList $ fmap prettyChoiceBranch brs)))+ pretty (Lambda _ n ty e) = parens (":lambda" <+> pretty n <+> pretty ty <#*> pretty e)+ pretty (Apply _ e e') = parens ("$" <+> pretty e <+> pretty e')+ pretty (Interp _ es) = group (dquotes (foldMap prettyInterp es))+ pretty (Concat _ es) = parens (rangle <+> hsep (pretty <$> es))+ pretty StrChunk{} = error "Internal error: naked StrChunk"+ pretty (Tuple _ es) = tupled (toList (pretty <$> es))+ pretty (Match _ n p e) = parens (":match" <+> pretty n <^> pretty p <^> pretty e)+ pretty (Flatten _ e) = parens (":flatten" <^> pretty e)+ pretty (Annot _ e ty) = pretty e <+> colon <+> pretty ty+ pretty (Constructor _ tn) = pretty tn++instance Pretty (DickinsonTy a) where+ pretty TyText{} = "text"+ pretty (TyFun _ t t') = parens ("⟶" <+> pretty t <+> pretty t')+ pretty (TyTuple _ ts) = tupled (toList (pretty <$> ts))+ pretty (TyNamed _ n) = pretty n
+ src/Language/Dickinson/TypeCheck.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Language.Dickinson.TypeCheck ( typeOf+ , tyAdd+ , tyTraverse+ , tyRun+ , emptyTyEnv+ , TyEnv+ , HasTyEnv (..)+ ) where++import Control.Monad (unless)+import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError)+import qualified Control.Monad.Ext as Ext+import Control.Monad.State (MonadState, State, evalState)+import Data.Binary (Binary)+import Data.Foldable (traverse_)+import Data.Functor (($>))+import qualified Data.IntMap as IM+import Data.List.NonEmpty (NonEmpty ((:|)))+import Language.Dickinson.Error+import Language.Dickinson.Name+import Language.Dickinson.Type+import Language.Dickinson.Unique+import Lens.Micro (Lens')+import Lens.Micro.Mtl (modifying, use)++tyAssert :: (HasTyEnv s, MonadError (DickinsonError a) m, MonadState (s a) m) => DickinsonTy a -> Expression a -> m ()+tyAssert ty e = do+ ty' <- typeOf e+ unless (ty' == ty) $+ throwError (TypeMismatch e ty ty')++newtype TyEnv a = TyEnv { unTyEnv :: (IM.IntMap (DickinsonTy a)) }+ deriving (Binary)++class HasTyEnv f where+ tyEnvLens :: Lens' (f a) (IM.IntMap (DickinsonTy a))++instance HasTyEnv TyEnv where+ tyEnvLens f s = fmap (\x -> s { unTyEnv = x }) (f (unTyEnv s)) -- id++tyInsert :: (HasTyEnv s, MonadState (s a) m) => Name a -> DickinsonTy a -> m ()+tyInsert (Name _ (Unique i) _) ty = modifying tyEnvLens (IM.insert i ty)++tyMatch :: (HasTyEnv s, MonadState (s a) m, MonadError (DickinsonError a) m) => NonEmpty (Expression a) -> m (DickinsonTy a)+tyMatch (e :| es) = do+ ty <- typeOf e+ traverse_ (tyAssert (TyText undefined)) es $> ty++type TypeM a = ExceptT (DickinsonError a) (State (TyEnv a))++tyRun :: [Declaration a] -> Either (DickinsonError a) ()+tyRun = flip evalState emptyTyEnv . runExceptT . (tyTraverse :: [Declaration a] -> TypeM a ())++emptyTyEnv :: TyEnv a+emptyTyEnv = TyEnv IM.empty++tyTraverse :: (HasTyEnv s, MonadState (s a) m, MonadError (DickinsonError a) m) => [Declaration a] -> m ()+tyTraverse ds =+ traverse_ tyAddDecl ds *>+ traverse_ tyAdd ds++tyAdd :: (HasTyEnv s, MonadState (s a) m, MonadError (DickinsonError a) m) => Declaration a -> m ()+tyAdd (Define _ n e) = tyInsert n =<< typeOf e+tyAdd TyDecl{} = pure ()++tyAddDecl :: (HasTyEnv s, MonadState (s a) m) => Declaration a -> m ()+tyAddDecl Define{} = pure ()+tyAddDecl (TyDecl l tn cs) = traverse_ (\c -> tyInsert c (TyNamed l tn)) cs++bindPattern :: (MonadState (s a) m, HasTyEnv s, MonadError (DickinsonError a) m) => Pattern a -> (DickinsonTy a) -> m ()+bindPattern (PatternVar _ n) ty = tyInsert n ty+bindPattern Wildcard{} _ = pure ()+bindPattern (PatternTuple _ ps) (TyTuple _ tys) = Ext.zipWithM_ bindPattern ps tys -- FIXME: length ps = length tys+bindPattern (PatternTuple l _) _ = throwError $ MalformedTuple l++-- run after global renamer+typeOf :: (HasTyEnv s, MonadState (s a) m, MonadError (DickinsonError a) m) => Expression a -> m (DickinsonTy a)+typeOf (Literal l _) = pure (TyText l)+typeOf (StrChunk l _) = pure (TyText l)+typeOf (Choice _ brs) = tyMatch (snd <$> brs)+typeOf (Var l n@(Name _ (Unique i) _)) = do+ tyEnv <- use tyEnvLens+ case IM.lookup i tyEnv of+ Just ty -> pure ty+ Nothing -> throwError $ UnfoundName l n+typeOf (Interp l es) =+ traverse_ (tyAssert (TyText undefined)) es $> TyText l+typeOf (Concat l es) =+ traverse_ (tyAssert (TyText undefined)) es $> TyText l+typeOf (Lambda l n ty e) =+ tyInsert n ty *>+ (TyFun l ty <$> typeOf e)+typeOf (Tuple l es) = TyTuple l <$> traverse typeOf es+typeOf (Apply _ e e') = do+ ty <- typeOf e+ case ty of+ TyFun _ ty' ty'' -> do+ tyAssert ty' e'+ pure ty''+ _ -> throwError $ ExpectedLambda e ty+typeOf (Let _ bs e) = do+ es' <- traverse typeOf (snd <$> bs)+ let ns = fst <$> bs+ Ext.zipWithM_ tyInsert ns es'+ typeOf e+typeOf (Match _ e p e') = do+ ty <- typeOf e+ bindPattern p ty+ typeOf e'+typeOf (Flatten _ e) = typeOf e+typeOf (Annot _ e ty) =+ tyAssert ty e $> ty+typeOf (Constructor l tn@(Name _ (Unique k) _)) = do+ tyEnv <- use tyEnvLens+ case IM.lookup k tyEnv of+ Just ty -> pure ty+ Nothing -> throwError $ UnfoundConstructor l tn
+ src/Language/Dickinson/Unique.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Language.Dickinson.Unique ( Unique (..)+ , UniqueCtx+ , dummyUnique+ ) where++import Control.DeepSeq (NFData)+import Data.Binary (Binary (..))+import Data.Text.Prettyprint.Doc (Pretty)++-- | For interning identifiers.+newtype Unique = Unique { unUnique :: Int }+ deriving (Eq, Ord, Pretty, NFData, Binary, Show)++-- | Dummy unique for sake of testing+dummyUnique :: Unique+dummyUnique = Unique 0++type UniqueCtx = Int
+ test/Eval.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}++module Eval ( evalTests+ ) where++import Language.Dickinson.File+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, testCase, (@?=))++evalTests :: TestTree+evalTests = testGroup "Evaluation test"+ [ testCase "Should evalutate to a constant" constEval+ , testCase "Should allow declarations in other orders" scopeEval+ , testCase "Should allow higher-order functions" higherOrderEval+ , resultCase "test/demo/animal.dck"+ , resultCase "test/data/tuple.dck"+ , resultCase "test/demo/tyAnnot.dck"+ , resultCase "test/data/quoteify.dck"+ , resultCase "test/data/hangIndefinitely.dck"+ ]++forceText :: a -> Assertion+forceText = (`seq` pure ())++resultCase :: FilePath -> TestTree+resultCase fp = testCase fp $ result fp++result :: FilePath -> Assertion+result fp = do+ res <- evalFile ["prelude", "lib"] fp+ forceText res++constEval :: Assertion+constEval = do+ res <- evalFile [] "test/eval/context.dck"+ res @?= "woman"++scopeEval :: Assertion+scopeEval = do+ res <- evalFile [] "test/demo/circular.dck"+ res @?= "a"++higherOrderEval :: Assertion+higherOrderEval = do+ res <- evalFile [] "test/data/higherOrder.dck"+ res @?= "It's me"
+ test/Golden.hs view
@@ -0,0 +1,54 @@+module Golden ( goldenTests+ ) where++import Control.Exception.Value (eitherThrow)+import qualified Data.ByteString.Lazy as BSL+import Data.Functor (void)+import Data.Text.Lazy.Encoding (encodeUtf8)+import Data.Text.Prettyprint.Doc (pretty)+import Data.Text.Prettyprint.Doc.Ext+import Language.Dickinson.Parser+import Language.Dickinson.Rename+import Language.Dickinson.Type+import System.FilePath ((-<.>))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Golden (goldenVsString)+import Text.Pretty.Simple (defaultOutputOptionsNoColor, outputOptionsIndentAmount, pShowOpt)++goldenTests :: TestTree+goldenTests =+ testGroup "Golden tests"+ [ withDckFile "test/data/nestLet.dck"+ , withDckFile "test/data/import.dck"+ , withDckFile "test/data/adt.dck"+ , withDckFile "test/data/escaped.dck"+ , withDckFile "test/data/nestInterp.dck"+ , renameDckFile "test/data/nestLet.dck"+ , renameDckFile "test/data/let.dck"+ , renameDckFile "test/data/multiLet.dck"+ , renameDckFile "test/data/lambda.dck"+ , renameDckFile "test/data/higherOrder.dck"+ , renameDckFile "test/data/tupleRename.dck"+ , renameDckFile "test/eval/match.dck"+ , renameDckFile "test/data/quoteify.dck"+ ]++prettyBSL :: Dickinson a -> BSL.ByteString+prettyBSL = encodeUtf8 . dickinsonLazyText . pretty++debugBSL :: Show a => a -> BSL.ByteString+debugBSL = encodeUtf8 . pShowOpt defaultOutputOptionsNoColor { outputOptionsIndentAmount = 2 }++-- TODO: sanity check?++withDckFile :: FilePath -> TestTree+withDckFile fp =+ goldenVsString ("Matches golden output " ++ fp) (fp -<.> "pretty") act++ where act = prettyBSL . eitherThrow . parse <$> BSL.readFile fp++renameDckFile :: FilePath -> TestTree+renameDckFile fp =+ goldenVsString ("Matches golden output " ++ fp) (fp -<.> "rename") act++ where act = debugBSL . void . fst . uncurry renameDickinson . eitherThrow . parseWithMax <$> BSL.readFile fp
+ test/Spec.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Control.Exception (throw)+import qualified Data.ByteString.Lazy as BSL+import Data.Either (isRight)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Maybe (isJust, isNothing)+import Eval+import Golden+import Language.Dickinson.Check+import Language.Dickinson.DuplicateCheck+import Language.Dickinson.Import+import Language.Dickinson.Lexer+import Language.Dickinson.Name+import Language.Dickinson.Parser+import Language.Dickinson.Rename+import Language.Dickinson.ScopeCheck+import Language.Dickinson.Type+import Language.Dickinson.Unique+import Test.Tasty+import Test.Tasty.HUnit+import TypeCheck++main :: IO ()+main =+ defaultMain $+ testGroup "All tests"+ [ goldenTests+ , parserTests+ , evalTests+ , tcTests+ ]++parserTests :: TestTree+parserTests =+ testGroup "Parser tests"+ [ lexNoError "test/data/let.dck"+ , parseNoError "test/data/const.dck"+ , parseNoError "test/data/let.dck"+ , parseNoError "test/data/nestLet.dck"+ , parseNoError "lib/color.dck"+ , parseNoError "lib/birds.dck"+ , lexNoError "test/data/import.dck"+ , parseNoError "test/data/import.dck"+ , detectDuplicate "test/data/multiple.dck"+ , detectDuplicate "test/error/double.dck"+ , detectDuplicate "test/error/tyDouble.dck"+ , detectDuplicate "test/error/tyConsDouble.dck"+ , lexNoError "examples/shakespeare.dck"+ , parseNoError "examples/shakespeare.dck"+ , detectScopeError "test/demo/improbableScope.dck"+ , detectBadBranch "test/demo/sillyOption.dck"+ , noScopeError "test/demo/circular.dck"+ , findPath+ ]++findPath :: TestTree+findPath = testCase "Finds import at correct path" $ do+ res <- resolveImport ["lib", "."] (Name ("color" :| []) dummyUnique undefined)+ res @?= Just "lib/color.dck"++readNoFail :: FilePath -> IO (Dickinson AlexPosn)+readNoFail = fmap (either throw id . parse) . BSL.readFile++detectBadBranch :: FilePath -> TestTree+detectBadBranch fp = testCase "Detects suspicious branch" $ do+ (Dickinson _ parsed) <- readNoFail fp+ assertBool fp $ isJust (checkDuplicates parsed)++detectDuplicate :: FilePath -> TestTree+detectDuplicate fp = testCase ("Detects duplicate name (" ++ fp ++ ")") $ do+ (Dickinson _ parsed) <- readNoFail fp+ assertBool fp $ isJust (checkMultiple parsed)++detectScopeError :: FilePath -> TestTree+detectScopeError fp = testCase "Finds scoping error" $ do+ (Dickinson _ renamed) <- parseRename fp+ assertBool fp $ isJust (checkScope renamed)++noScopeError :: FilePath -> TestTree+noScopeError fp = testCase "Reports valid scoping" $ do+ (Dickinson _ renamed) <- parseRename fp+ assertBool fp $ isNothing (checkScope renamed)++parseNoError :: FilePath -> TestTree+parseNoError fp = testCase ("Parsing doesn't fail (" ++ fp ++ ")") $ do+ contents <- BSL.readFile fp+ assertBool "Doesn't fail parsing" $ isRight (parse contents)++lexNoError :: FilePath -> TestTree+lexNoError fp = testCase ("Lexing doesn't fail (" ++ fp ++ ")") $ do+ contents <- BSL.readFile fp+ assertBool "Doesn't fail lexing" $ isRight (lexDickinson contents)++parseRename :: FilePath -> IO (Dickinson AlexPosn)+parseRename = fmap (fst . uncurry renameDickinson . either throw id . parseWithMax) . BSL.readFile
+ test/TypeCheck.hs view
@@ -0,0 +1,26 @@+module TypeCheck ( tcTests+ ) where++import Language.Dickinson.File+import Test.Tasty+import Test.Tasty.HUnit++tcTests :: TestTree+tcTests = testGroup "Typecheck test"+ [ testCase "Works on :match" testMatchTc+ , testCase "Currying" testCurry+ , testCase "See ADTs" testAdtTc+ , testCase "Currying (prelude functions)" testCurryPrelude+ ]++testCurry :: Assertion+testCurry = tcFile [] "test/data/quoteify.dck"++testMatchTc :: Assertion+testMatchTc = tcFile [] "test/eval/match.dck"++testAdtTc :: Assertion+testAdtTc = tcFile [] "test/data/adt.dck"++testCurryPrelude :: Assertion+testCurryPrelude = tcFile [] "prelude/curry.dck"
+ test/data/adt.dck view
@@ -0,0 +1,9 @@+%-++tydecl sex = Boy | Girl++(:def boy + Boy : sex)++(:def main+ "Hello, World!")
+ test/data/adt.pretty view
@@ -0,0 +1,9 @@+%-++tydecl sex = Boy | Girl++(:def boy+ Boy : sex)++(:def main+ "Hello, World!")
+ test/data/color.dck view
@@ -0,0 +1,2 @@+(:def color+ ("color"))
+ test/data/const.dck view
@@ -0,0 +1,11 @@+%-++(:def branchFunction+ (:branch+ (| 1.0 "man")+ (| 1.0 "woman")))++(:def dumbFunction+ (:oneof+ (| "some")+ (| "word")))
+ test/data/escaped.dck view
@@ -0,0 +1,4 @@+%-++(:def main+ (> "\n\"" "Hello ${me}\" \n"))
+ test/data/escaped.pretty view
@@ -0,0 +1,4 @@+%-++(:def main+ (> "\n\"" "Hello ${me}\" \n"))
+ test/data/hangIndefinitely.dck view
@@ -0,0 +1,22 @@+%-++(:def fst+ (:lambda xy (text, text)+ (:match xy (x, _)+ x)))++(:def snd+ (:lambda xy (text, text)+ (:match xy (_,x)+ x)))++(:def greeter+ (:lambda dog (text, text)+ (:let+ [name ($fst dog)]+ [pronoun ($snd dog)]+ (:oneof+ (| "${name} eats toilet paper sometimes but ${pronoun} tries.")))))++(:def main+ ($ greeter ("Maxine", "she")))
+ test/data/higherOrder.dck view
@@ -0,0 +1,10 @@+%-++(:def top+ (:lambda f (-> text text)+ ($f "me")))++(:def main+ (:let+ [fun (:lambda a (text) "It's ${a}")]+ ($ top fun)))
+ test/data/higherOrder.rename view
@@ -0,0 +1,100 @@+Dickinson+ { modImports = []+ , modDefs =+ [ Define+ { declAnn = ()+ , defName = Name+ { name = "top" :| []+ , unique = Unique { unUnique = 6 }+ , loc = ()+ }+ , defExpr = Lambda+ { exprAnn = ()+ , lambdaVar = Name+ { name = "f" :| []+ , unique = Unique { unUnique = 8 }+ , loc = ()+ }+ , lambdaTy = TyFun () ( TyText () ) ( TyText () )+ , lambdaExpr = Apply+ { exprAnn = ()+ , exprFun = Var+ { exprAnn = ()+ , exprVar = Name+ { name = "f" :| []+ , unique = Unique { unUnique = 8 }+ , loc = ()+ }+ }+ , exprArg = Literal+ { exprAnn = ()+ , litText = "me"+ }+ }+ }+ }+ , Define+ { declAnn = ()+ , defName = Name+ { name = "main" :| []+ , unique = Unique { unUnique = 7 }+ , loc = ()+ }+ , defExpr = Let+ { exprAnn = ()+ , letBinds =+ ( Name+ { name = "fun" :| []+ , unique = Unique { unUnique = 9 }+ , loc = ()+ }+ , Lambda+ { exprAnn = ()+ , lambdaVar = Name+ { name = "a" :| []+ , unique = Unique { unUnique = 10 }+ , loc = ()+ }+ , lambdaTy = TyText ()+ , lambdaExpr = Interp+ { exprAnn = ()+ , exprInterp =+ [ StrChunk+ { exprAnn = ()+ , chunkText = "It's "+ }+ , Var+ { exprAnn = ()+ , exprVar = Name+ { name = "a" :| []+ , unique = Unique { unUnique = 10 }+ , loc = ()+ }+ }+ ]+ }+ }+ ) :| []+ , letExpr = Apply+ { exprAnn = ()+ , exprFun = Var+ { exprAnn = ()+ , exprVar = Name+ { name = "top" :| []+ , unique = Unique { unUnique = 6 }+ , loc = ()+ }+ }+ , exprArg = Var+ { exprAnn = ()+ , exprVar = Name+ { name = "fun" :| []+ , unique = Unique { unUnique = 9 }+ , loc = ()+ }+ }+ }+ }+ }+ ]+ }
+ test/data/import.dck view
@@ -0,0 +1,6 @@+(:include color)++%-++(:def main+ (color))
+ test/data/import.pretty view
@@ -0,0 +1,6 @@+(:include color)++%-++(:def main+ color)
+ test/data/lambda.dck view
@@ -0,0 +1,10 @@+%-++(:def greeter+ (:lambda name (text)+ ("Hello, ${name}!")))++(:def main+ (:let + [boy (:oneof (| "tom") (| "harry"))]+ ($ greeter boy)))
+ test/data/lambda.rename view
@@ -0,0 +1,98 @@+Dickinson+ { modImports = []+ , modDefs =+ [ Define+ { declAnn = ()+ , defName = Name+ { name = "greeter" :| []+ , unique = Unique { unUnique = 5 }+ , loc = ()+ }+ , defExpr = Lambda+ { exprAnn = ()+ , lambdaVar = Name+ { name = "name" :| []+ , unique = Unique { unUnique = 7 }+ , loc = ()+ }+ , lambdaTy = TyText ()+ , lambdaExpr = Interp+ { exprAnn = ()+ , exprInterp =+ [ StrChunk+ { exprAnn = ()+ , chunkText = "Hello, "+ }+ , Var+ { exprAnn = ()+ , exprVar = Name+ { name = "name" :| []+ , unique = Unique { unUnique = 7 }+ , loc = ()+ }+ }+ , StrChunk+ { exprAnn = ()+ , chunkText = "!"+ }+ ]+ }+ }+ }+ , Define+ { declAnn = ()+ , defName = Name+ { name = "main" :| []+ , unique = Unique { unUnique = 6 }+ , loc = ()+ }+ , defExpr = Let+ { exprAnn = ()+ , letBinds =+ ( Name+ { name = "boy" :| []+ , unique = Unique { unUnique = 8 }+ , loc = ()+ }+ , Choice+ { exprAnn = ()+ , choices =+ ( 0.5+ , Literal+ { exprAnn = ()+ , litText = "tom"+ }+ ) :|+ [+ ( 0.5+ , Literal+ { exprAnn = ()+ , litText = "harry"+ }+ )+ ]+ }+ ) :| []+ , letExpr = Apply+ { exprAnn = ()+ , exprFun = Var+ { exprAnn = ()+ , exprVar = Name+ { name = "greeter" :| []+ , unique = Unique { unUnique = 5 }+ , loc = ()+ }+ }+ , exprArg = Var+ { exprAnn = ()+ , exprVar = Name+ { name = "boy" :| []+ , unique = Unique { unUnique = 8 }+ , loc = ()+ }+ }+ }+ }+ }+ ]+ }
+ test/data/let.dck view
@@ -0,0 +1,9 @@+%-++(:def letBinding+ (:let+ [a "man"]+ [b "woman"]+ (:branch+ (| 1.0 a)+ (| 1.0 b))))
+ test/data/let.rename view
@@ -0,0 +1,65 @@+Dickinson+ { modImports = []+ , modDefs =+ [ Define+ { declAnn = ()+ , defName = Name+ { name = "letBinding" :| []+ , unique = Unique { unUnique = 4 }+ , loc = ()+ }+ , defExpr = Let+ { exprAnn = ()+ , letBinds =+ ( Name+ { name = "a" :| []+ , unique = Unique { unUnique = 5 }+ , loc = ()+ }+ , Literal+ { exprAnn = ()+ , litText = "man"+ }+ ) :|+ [+ ( Name+ { name = "b" :| []+ , unique = Unique { unUnique = 6 }+ , loc = ()+ }+ , Literal+ { exprAnn = ()+ , litText = "woman"+ }+ )+ ]+ , letExpr = Choice+ { exprAnn = ()+ , choices =+ ( 1.0+ , Var+ { exprAnn = ()+ , exprVar = Name+ { name = "a" :| []+ , unique = Unique { unUnique = 5 }+ , loc = ()+ }+ }+ ) :|+ [+ ( 1.0+ , Var+ { exprAnn = ()+ , exprVar = Name+ { name = "b" :| []+ , unique = Unique { unUnique = 6 }+ , loc = ()+ }+ }+ )+ ]+ }+ }+ }+ ]+ }
+ test/data/multiLet.dck view
@@ -0,0 +1,16 @@+%-++(:def letBinding+ (:let+ [a "man"]+ [b "woman"]+ (:branch+ (| 1.0 a)+ (| 1.0 b))))++(:def main+ (:let+ [a "non-binary"]+ (:branch+ (| 1.0 letBinding)+ (| 1.0 a))))
+ test/data/multiLet.rename view
@@ -0,0 +1,113 @@+Dickinson+ { modImports = []+ , modDefs =+ [ Define+ { declAnn = ()+ , defName = Name+ { name = "letBinding" :| []+ , unique = Unique { unUnique = 5 }+ , loc = ()+ }+ , defExpr = Let+ { exprAnn = ()+ , letBinds =+ ( Name+ { name = "a" :| []+ , unique = Unique { unUnique = 7 }+ , loc = ()+ }+ , Literal+ { exprAnn = ()+ , litText = "man"+ }+ ) :|+ [+ ( Name+ { name = "b" :| []+ , unique = Unique { unUnique = 8 }+ , loc = ()+ }+ , Literal+ { exprAnn = ()+ , litText = "woman"+ }+ )+ ]+ , letExpr = Choice+ { exprAnn = ()+ , choices =+ ( 1.0+ , Var+ { exprAnn = ()+ , exprVar = Name+ { name = "a" :| []+ , unique = Unique { unUnique = 7 }+ , loc = ()+ }+ }+ ) :|+ [+ ( 1.0+ , Var+ { exprAnn = ()+ , exprVar = Name+ { name = "b" :| []+ , unique = Unique { unUnique = 8 }+ , loc = ()+ }+ }+ )+ ]+ }+ }+ }+ , Define+ { declAnn = ()+ , defName = Name+ { name = "main" :| []+ , unique = Unique { unUnique = 6 }+ , loc = ()+ }+ , defExpr = Let+ { exprAnn = ()+ , letBinds =+ ( Name+ { name = "a" :| []+ , unique = Unique { unUnique = 9 }+ , loc = ()+ }+ , Literal+ { exprAnn = ()+ , litText = "non-binary"+ }+ ) :| []+ , letExpr = Choice+ { exprAnn = ()+ , choices =+ ( 1.0+ , Var+ { exprAnn = ()+ , exprVar = Name+ { name = "letBinding" :| []+ , unique = Unique { unUnique = 5 }+ , loc = ()+ }+ }+ ) :|+ [+ ( 1.0+ , Var+ { exprAnn = ()+ , exprVar = Name+ { name = "a" :| []+ , unique = Unique { unUnique = 9 }+ , loc = ()+ }+ }+ )+ ]+ }+ }+ }+ ]+ }
+ test/data/multiple.dck view
@@ -0,0 +1,16 @@+%-++(:def letBinding+ (:let+ [a "man"]+ [a "woman"]+ (:branch+ (| 1.0 a)+ (| 1.0 a))))++(:def main+ (:let+ [a "man"]+ (:branch+ (| 1.0 letBinding)+ (| 1.0 a))))
+ test/data/nestInterp.dck view
@@ -0,0 +1,4 @@+%-++(:def main+ "Nested ${(> "interpolated ${again}" string)} string")
+ test/data/nestInterp.pretty view
@@ -0,0 +1,4 @@+%-++(:def main+ "Nested ${(> "interpolated ${again}" string)} string")
+ test/data/nestLet.dck view
@@ -0,0 +1,10 @@+%-++(:def letBinding+ (:let+ [a (:let [a "man"] a)]+ [b (:let [a "woman"] a)]+ [c (:let [a "non-binary"] a)]+ (:branch+ (| 1.0 (:let [b a] b))+ (| 1.0 b))))
+ test/data/nestLet.pretty view
@@ -0,0 +1,10 @@+%-++(:def letBinding+ (:let+ [a (:let [a "man"] a)]+ [b (:let [a "woman"] a)]+ [c (:let [a "non-binary"] a)]+ (:branch+ (| 1.0 (:let [b a] b))+ (| 1.0 b))))
+ test/data/nestLet.rename view
@@ -0,0 +1,148 @@+Dickinson+ { modImports = []+ , modDefs =+ [ Define+ { declAnn = ()+ , defName = Name+ { name = "letBinding" :| []+ , unique = Unique { unUnique = 5 }+ , loc = ()+ }+ , defExpr = Let+ { exprAnn = ()+ , letBinds =+ ( Name+ { name = "a" :| []+ , unique = Unique { unUnique = 6 }+ , loc = ()+ }+ , Let+ { exprAnn = ()+ , letBinds =+ ( Name+ { name = "a" :| []+ , unique = Unique { unUnique = 9 }+ , loc = ()+ }+ , Literal+ { exprAnn = ()+ , litText = "man"+ }+ ) :| []+ , letExpr = Var+ { exprAnn = ()+ , exprVar = Name+ { name = "a" :| []+ , unique = Unique { unUnique = 9 }+ , loc = ()+ }+ }+ }+ ) :|+ [+ ( Name+ { name = "b" :| []+ , unique = Unique { unUnique = 7 }+ , loc = ()+ }+ , Let+ { exprAnn = ()+ , letBinds =+ ( Name+ { name = "a" :| []+ , unique = Unique { unUnique = 10 }+ , loc = ()+ }+ , Literal+ { exprAnn = ()+ , litText = "woman"+ }+ ) :| []+ , letExpr = Var+ { exprAnn = ()+ , exprVar = Name+ { name = "a" :| []+ , unique = Unique { unUnique = 10 }+ , loc = ()+ }+ }+ }+ )+ ,+ ( Name+ { name = "c" :| []+ , unique = Unique { unUnique = 8 }+ , loc = ()+ }+ , Let+ { exprAnn = ()+ , letBinds =+ ( Name+ { name = "a" :| []+ , unique = Unique { unUnique = 11 }+ , loc = ()+ }+ , Literal+ { exprAnn = ()+ , litText = "non-binary"+ }+ ) :| []+ , letExpr = Var+ { exprAnn = ()+ , exprVar = Name+ { name = "a" :| []+ , unique = Unique { unUnique = 11 }+ , loc = ()+ }+ }+ }+ )+ ]+ , letExpr = Choice+ { exprAnn = ()+ , choices =+ ( 1.0+ , Let+ { exprAnn = ()+ , letBinds =+ ( Name+ { name = "b" :| []+ , unique = Unique { unUnique = 12 }+ , loc = ()+ }+ , Var+ { exprAnn = ()+ , exprVar = Name+ { name = "a" :| []+ , unique = Unique { unUnique = 6 }+ , loc = ()+ }+ }+ ) :| []+ , letExpr = Var+ { exprAnn = ()+ , exprVar = Name+ { name = "b" :| []+ , unique = Unique { unUnique = 12 }+ , loc = ()+ }+ }+ }+ ) :|+ [+ ( 1.0+ , Var+ { exprAnn = ()+ , exprVar = Name+ { name = "b" :| []+ , unique = Unique { unUnique = 7 }+ , loc = ()+ }+ }+ )+ ]+ }+ }+ }+ ]+ }
+ test/data/quoteify.dck view
@@ -0,0 +1,10 @@+%-++(:def quote+ (:lambda qu text+ (:lambda name text+ "${qu}\n — ${name}")))++(:def main+ (:oneof+ (| ($ $ quote "God created war so that Americans would learn geography." "Mark Twain"))))
+ test/data/quoteify.rename view
@@ -0,0 +1,93 @@+Dickinson+ { modImports = []+ , modDefs =+ [ Define+ { declAnn = ()+ , defName = Name+ { name = "quote" :| []+ , unique = Unique { unUnique = 5 }+ , loc = ()+ }+ , defExpr = Lambda+ { exprAnn = ()+ , lambdaVar = Name+ { name = "qu" :| []+ , unique = Unique { unUnique = 7 }+ , loc = ()+ }+ , lambdaTy = TyText ()+ , lambdaExpr = Lambda+ { exprAnn = ()+ , lambdaVar = Name+ { name = "name" :| []+ , unique = Unique { unUnique = 8 }+ , loc = ()+ }+ , lambdaTy = TyText ()+ , lambdaExpr = Interp+ { exprAnn = ()+ , exprInterp =+ [ Var+ { exprAnn = ()+ , exprVar = Name+ { name = "qu" :| []+ , unique = Unique { unUnique = 7 }+ , loc = ()+ }+ }+ , StrChunk+ { exprAnn = ()+ , chunkText = "+ — "+ }+ , Var+ { exprAnn = ()+ , exprVar = Name+ { name = "name" :| []+ , unique = Unique { unUnique = 8 }+ , loc = ()+ }+ }+ ]+ }+ }+ }+ }+ , Define+ { declAnn = ()+ , defName = Name+ { name = "main" :| []+ , unique = Unique { unUnique = 6 }+ , loc = ()+ }+ , defExpr = Choice+ { exprAnn = ()+ , choices =+ ( 1.0+ , Apply+ { exprAnn = ()+ , exprFun = Apply+ { exprAnn = ()+ , exprFun = Var+ { exprAnn = ()+ , exprVar = Name+ { name = "quote" :| []+ , unique = Unique { unUnique = 5 }+ , loc = ()+ }+ }+ , exprArg = Literal+ { exprAnn = ()+ , litText = "God created war so that Americans would learn geography."+ }+ }+ , exprArg = Literal+ { exprAnn = ()+ , litText = "Mark Twain"+ }+ }+ ) :| []+ }+ }+ ]+ }
+ test/data/tuple.dck view
@@ -0,0 +1,14 @@+%-++(:def fst+ (:lambda xy (text, text)+ (:match xy (x, _)+ x)))++(:def dog+ (:oneof+ (| ("he", "boy"))+ (| ("she", "girl"))))++(:def main+ ($ fst dog))
+ test/data/tupleRename.dck view
@@ -0,0 +1,8 @@+%-++(:def prolix+ (:let+ [xy "hello"]+ (:lambda xy (text, text)+ (:match xy (x, _)+ x))))
+ test/data/tupleRename.rename view
@@ -0,0 +1,65 @@+Dickinson+ { modImports = []+ , modDefs =+ [ Define+ { declAnn = ()+ , defName = Name+ { name = "prolix" :| []+ , unique = Unique { unUnique = 4 }+ , loc = ()+ }+ , defExpr = Let+ { exprAnn = ()+ , letBinds =+ ( Name+ { name = "xy" :| []+ , unique = Unique { unUnique = 5 }+ , loc = ()+ }+ , Literal+ { exprAnn = ()+ , litText = "hello"+ }+ ) :| []+ , letExpr = Lambda+ { exprAnn = ()+ , lambdaVar = Name+ { name = "xy" :| []+ , unique = Unique { unUnique = 6 }+ , loc = ()+ }+ , lambdaTy = TyTuple ()+ ( TyText () :| [ TyText () ] )+ , lambdaExpr = Match+ { exprAnn = ()+ , exprMatch = Var+ { exprAnn = ()+ , exprVar = Name+ { name = "xy" :| []+ , unique = Unique { unUnique = 6 }+ , loc = ()+ }+ }+ , exprPat = PatternTuple ()+ ( PatternVar ()+ ( Name+ { name = "x" :| []+ , unique = Unique { unUnique = 7 }+ , loc = ()+ }+ ) :| [ Wildcard () ]+ )+ , exprIn = Var+ { exprAnn = ()+ , exprVar = Name+ { name = "x" :| []+ , unique = Unique { unUnique = 7 }+ , loc = ()+ }+ }+ }+ }+ }+ }+ ]+ }