language-dickinson 0.1.0.1 → 0.1.1.0

raw patch · 34 files changed

+496/−130 lines, 34 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• README.md +8/−0
• bench/Bench.hs +1/−3
• examples/catherineOfSienaBot.dck +61/−0
• examples/fionaBot.dck +43/−0
• examples/fortune.dck +6/−0
• language-dickinson.cabal +15/−4
• lib/adjectives.dck +5/−0
• lib/cowsay.dck +14/−0
• lib/noun.dck +7/−0
• man/emd.1 +5/−1
• public/Language/Dickinson.hs +4/−0
• run/Main.hs +7/−2
• run/REPL.hs +2/−2
• run/REPL/Save.cpphs +55/−0
• run/REPL/Save.hs +0/−34
• src/Data/Tuple/Ext.hs +3/−3
• src/Language/Dickinson/Check/Internal.hs +10/−1
• src/Language/Dickinson/Eval.hs +32/−25
• src/Language/Dickinson/File.hs +2/−1
• src/Language/Dickinson/Lexer.x +47/−14
• src/Language/Dickinson/Parser.y +19/−13
• src/Language/Dickinson/Rename.hs +2/−0
• src/Language/Dickinson/Type.hs +19/−15
• test/Eval.hs +18/−9
• test/Golden.hs +2/−0
• test/Spec.hs +15/−3
• test/data/interpolateNested.dck +11/−0
• test/data/lambdaMultiQuote.dck +14/−0
• test/data/lambdaMultiQuote.pretty +14/−0
• test/data/multiQuoteify.dck +13/−0
• test/data/multiQuoteify.pretty +13/−0
• test/data/multiStr.dck +11/−0
• test/data/multiStr.pretty +11/−0

@@ -1,5 +1,12 @@ # dickinson +## 0.1.1.0++  * Export renamer in `Language.Dickinson`+  * Fix build with GHC ≤ 8.2.2+  * Add `man` subcommand+  * Introduce multiline strings+ ## 0.1.0.1    * Fix source distribution so nix builds it automatically

@@ -11,6 +11,14 @@ cabal install language-dickinson ``` +Manpages are installed at++```+emd man+```++So `man $(emd man)` will pull them up in bash, for instance.+ ### Editor Integration  Editor integration is available for vim.

@@ -50,7 +50,6 @@                     , 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"@@ -58,8 +57,7 @@                     , bench "examples/fortune.dck" $ nfIO (pipeline [] "examples/fortune.dck")                     ]                 , bgroup "tcFile"-                    [ bench "examples/hotTake.dck" $ nfIO (tcFile [] "examples/hotTake.dck")-                    , bench "examples/fortune.dck" $ nfIO (tcFile [] "examples/fortune.dck")+                    [ bench "examples/fortune.dck" $ nfIO (tcFile [] "examples/fortune.dck")                     ]                 ] 

@@ -0,0 +1,61 @@+; Taken from an English translation since I don't know Tuscan++%-++; From The Dialogue+(:def dialogue+  (:oneof+    (| "Sin is the opposite of being")+    (| "Perseverance is necessary if you want to see your desires realized.")+    (| "Their selfish sensuality, which is the source of every harm that can come to soul or body.")+    (| "She has let go of and drowned her own will, and when that will is dead there is peace and quiet.")+    (| "Penance ought to be undertaken as a means to growth.")+    (| "Virtue can be proved only by its opposite.")+    (| "Sensuality is the opposite of spirit.")+    (| "Because love, while in the mortal body, does not perfectly possess what it loves, it suffers")+    (| "This Sun never leaves its orbit, never divides.")+    (| "Love is your food.")+    (| "You like a perverse beast find your pleasure in delicate foods, and make a god of your belly?")+    (| "You loved us before we existed.")+    (| "By your mercy we were created.")+    (| "If you follow this truth you will have the life of grace and never die of hunger.")+    (| "If you have conceived the virtue of courage within you, you will always be strong and constant.")+    (|+      '''+      I bound her into a body formed from the vilest earth so that when she saw her beauty she would not+      lift up her head in pride.+      ''')+    (|+      '''+      I am the rewarder of every labor, and I give to all in accordance with their state in life and effort.+      ''')+    (| "One cannot be deprived of the practice of doing good unless one so chooses.")+    (|+      '''+      The more they have to endure, the more delighted they are. Indeed, suffering many difficulties is for+      them a kind of refreshment.+      ''')+    (| "You should build your foundation by slaying and annhilating your self-will.")+    (| "Humility comes from knowledge and holy hatred of oneself.")+    (|+      '''+      Memory is beleagured by the body's imperfection; understanding is blocked and fettered by the heaviness+      of the body.+      ''')+    (|+      '''+      The despair of Judas displeased more and was a greater insult to my son than his betrayal had been.+      Therefore, such as these are reproved for this false judgment of considering their sin to be greater+      than my mercy, and for this they are punished with the demons and tortured eternally with them.+      ''')+    (|+      '''+      Then my justice reproves them harshly for their injustice and false judgment. And not simply in+      general terms for their pervasive habits of injustice and false judgment during their earthly lives,+      but even more for that particular unjust judgment by which at the very end they have judged their own+      wretchedness to be greater than my mercy.+      ''')+    ))++(:def main+  dialogue)

@@ -1,10 +1,53 @@ %- +; see https://twitter.com/fionalyric for a fully fleshed-out implementation of this idea+ (:def fiona   (:oneof     (| "You forgot the difference between equanimity and passivity.")     (| "You're more likely to get cut with a dull tool than a sharp one.")+    (| "I've finally grown weary of waiting to be consumed by you.")+    (| "The child is gone.")+    (| "If you're right you'll agree.")+    (| "I just wanna feel everything")+    (| "What does she think of me?")+    (| "You raped me in the same bed your daughter was born in.")+    (| "I want to suffer for my sins")+    (| "I need to be redeemed to the one I've sinned against")+    (|+      '''+      My feel for you, boy+      Is decaying in front of me+      Like the carrion of a murdered prey+      ''')+    (|+      '''+      All that love must've been lacking something+      If I got bored trying to figure you out+      ''')+    (| +      '''+      So I will keep a deliberate pace+      Let the damned breeze dry my face+      ''')+    (| "I think he let me down when he didn't disappoint me.")+    (|+      '''+      If I let you get too close+      ''')     (| "Hunger hurts but starving works.")+    (| +     '''+     What's so impressive about a diamond+     Except the mining+     ''')+    (| "Now I only move to move.")+    (|+      '''+      I would beg to disagree+      But begging disagrees with me+      ''')+    (| "Fetch the bolt cutters")     (| "I ran out of white doves' feathers\nTo soak up the hot piss that comes from your mouth")     (| "Just tolerate my little fist\nTugging on your forest chest"))) 

@@ -14,21 +14,27 @@     (| "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.")+    (| "Empathy opposes impartiality")     (| "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.")+    (| "Correction is mercy.")     (| "Guilt redeems, not love.")     (| "There is no such thing as metaphors.")     (| "Excess is a sin.")     (| "Spurn your family.")     (| "Salvation is finality.")+    (| "Knowledge begets humility.")     (| "Love animals.")+    ; judgment+    (| "Irony is the weakest brand of pessimism")     (| "Sex wastes the male body.")     (| "Cultivate weakness.")     (| "Beauty is a moral imperative.")     (| "We are all damned by our own personalities. That is beauty.")+    (| "Hobbies are sublunary")     (| "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"))

@@ -1,6 +1,6 @@ cabal-version:      2.0 name:               language-dickinson-version:            0.1.0.1+version:            0.1.1.0 license:            BSD3 license-file:       LICENSE copyright:          Copyright: (c) 2020 Vanessa McHale@@ -41,6 +41,9 @@     default:     False     manual:      True +flag zstd+    description: Use zstd to compress saved REPL states+ library     exposed-modules:  Language.Dickinson     hs-source-dirs:   public@@ -84,6 +87,7 @@         Language.Dickinson.File         Language.Dickinson.Import         Language.Dickinson.Lib+        Language.Dickinson.Check.Internal         Data.Tuple.Ext         Control.Exception.Value         Data.Text.Prettyprint.Doc.Ext@@ -92,7 +96,6 @@     other-modules:         Paths_language_dickinson         Language.Dickinson.Check.Pattern-        Language.Dickinson.Check.Internal         Language.Dickinson.Lib.Get         Control.Monad.Ext         Data.Foldable.Ext@@ -150,7 +153,9 @@         REPL         REPL.Save         REPL.Completions+        Paths_language_dickinson +    autogen-modules:  Paths_language_dickinson     default-language: Haskell2010     other-extensions: FlexibleContexts OverloadedStrings TupleSections     ghc-options:      -Wall -rtsopts -with-rtsopts=-A4M@@ -170,8 +175,14 @@         filepath -any,         directory -any,         language-dickinson -any,-        binary -any,-        zstd -any+        binary -any++    if !flag(cross)+        build-tool-depends: cpphs:cpphs -any++    if flag(zstd)+        cpp-options:   -DZSTD+        build-depends: zstd -any      if impl(ghc >=8.0)         ghc-options:

@@ -0,0 +1,5 @@+%-++(:def adjective+  (:oneof+    (| "stentorian")))

@@ -0,0 +1,14 @@+%-++(:def cowsay+  (:lambda txt text+    '''+    +    ${txt}+    ------+          \   ^__^+           \  (oo)\_______+              (__)\       )\/\+                  ||----w |+                  ||     ||+    '''))

@@ -0,0 +1,7 @@+%-++(:def noun+  (:oneof+    (| "valetudinarian")+    (| "valedictorian")+    (| "folderol")))

@@ -1,4 +1,4 @@-.\" Automatically generated by Pandoc 2.9.2.1+.\" Automatically generated by Pandoc 2.10 .\" .TH "emd (1)" "" "" "" "" .hy@@ -15,6 +15,8 @@ emd run literature.dck .PP emd run project.dck --include lib+.PP+man $(emd man) .SH SUBCOMMANDS .PP \f[B]repl\f[R] - Start a repl@@ -26,6 +28,8 @@ \f[B]lint\f[R] - Give suggestions for common mistakes .PP \f[B]fmt\f[R] - Format Dickinson code+.PP+\f[B]man\f[R] - Point to where manpages are installed .SS REPL COMMANDS .PP \f[B]:save\f[R] - Save curent state in a file

@@ -14,6 +14,9 @@                           , DickinsonTy (..)                           , Name                           , TyName+                          -- * Renamer+                          , HasRenames (..)+                          , renameExpressionM                           -- * Imports                           , resolveImport                           -- * Version info@@ -26,6 +29,7 @@ import           Language.Dickinson.Lexer import           Language.Dickinson.Name import           Language.Dickinson.Parser+import           Language.Dickinson.Rename import           Language.Dickinson.Type import qualified Paths_language_dickinson  as P 

@@ -1,12 +1,14 @@ module Main (main) where  import           Data.Semigroup-import qualified Data.Text.IO            as TIO-import           Language.Dickinson      (dickinsonVersionString)+import qualified Data.Text.IO             as TIO+import           Language.Dickinson       (dickinsonVersionString) import           Language.Dickinson.File import           Language.Dickinson.Lib import           Options.Applicative+import           Paths_language_dickinson (getDataDir) import           REPL+import           System.FilePath          ((</>))  -- TODO debug/verbosity options... data Act = Run !FilePath ![FilePath]@@ -15,6 +17,7 @@          | Lint !FilePath          | Typecheck !FilePath ![FilePath]          | Format !FilePath+         | Man  main :: IO () main = run =<< execParser wrapper@@ -27,6 +30,7 @@     <> 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"))+    <> command "man" (info (pure Man) (progDesc "Dump path to manpages"))     )  formatP :: Parser Act@@ -82,3 +86,4 @@ run (Lint f)        = warnFile f run (Typecheck f i) = do { pathMod <- defaultLibPath ; tcFile (pathMod i) f } run (Format fp)     = fmtFile fp+run Man             = putStrLn =<< (</> "emd.1") . (</> "man") <$> getDataDir

@@ -20,7 +20,7 @@ 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           Data.Tuple.Ext                        (fst4) import           Language.Dickinson.Error import           Language.Dickinson.Eval import           Language.Dickinson.File@@ -134,7 +134,7 @@ setSt :: AlexUserState -> Repl AlexPosn () setSt newSt = lift $ do     m' <- use (rename.maxLens)-    let newM = 1 + max (fst3 newSt) m'+    let newM = 1 + max (fst4 newSt) m'     lexerStateLens .= newSt     lexerStateLens._1 .= newM     rename.maxLens .= newM

@@ -0,0 +1,55 @@+module REPL.Save ( decodeReplSt+                 , encodeReplSt+                 ) where++#ifdef ZSTD+import qualified Codec.Compression.Zstd.Lazy as Zstd+#endif+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 qualified Data.Map                    as M+import           Data.Semigroup              ((<>))+import qualified Data.Text                   as T+import           Language.Dickinson.Eval+import           Language.Dickinson.Lexer+import           Language.Dickinson.Name+import           Language.Dickinson.Unique++dropScd :: AlexUserState -> (UniqueCtx, M.Map T.Text Int, NameEnv AlexPosn)+dropScd (x, _, y, z) = (x, y, z)++addScd :: (UniqueCtx, M.Map T.Text Int, NameEnv AlexPosn) -> AlexUserState+addScd (x, y, z) = (x, scdInitState, y, z)++getReplState :: Binary a => [Double] -> Get (EvalSt a)+getReplState ds =+    EvalSt ds+        <$> get+        <*> get+        <*> get+        <*> (addScd <$> get)+        <*> get++putReplState :: Binary a => EvalSt a -> Put+putReplState (EvalSt _ be rs t lSt ty) =+       put be+    <> put rs+    <> put t+    <> put (dropScd lSt)+    <> put ty++decodeReplSt :: Binary a => [Double] -> BSL.ByteString -> EvalSt a+#ifdef ZSTD+decodeReplSt ds = runGet (getReplState ds) . Zstd.decompress+#else+decodeReplSt ds = runGet (getReplState ds)+#endif++encodeReplSt :: Binary a => EvalSt a -> BSL.ByteString+#ifdef ZSTD+encodeReplSt = Zstd.compress 3 . runPut . putReplState+#else+encodeReplSt = runPut . putReplState+#endif

@@ -1,34 +0,0 @@-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

@@ -1,5 +1,5 @@-module Data.Tuple.Ext ( fst3+module Data.Tuple.Ext ( fst4                       ) where -fst3 :: (a, b, c) -> a-fst3 (x, _, _) = x+fst4 :: (a, b, c, d) -> a+fst4 (x, _, _, _) = x

@@ -1,16 +1,25 @@ module Language.Dickinson.Check.Internal ( sanityCheck+                                         , sanityCheckLexer                                          ) where  import           Control.Monad             (when) import           Control.Monad.State       (MonadState) import           Data.List.NonEmpty        ((<|))+import           Language.Dickinson.Lexer import           Language.Dickinson.Name import           Language.Dickinson.Rename import           Language.Dickinson.Type import           Language.Dickinson.Unique+import           Lens.Micro                (_1) import           Lens.Micro.Mtl            (use) --- TODO: sanity check for the lexer+sanityCheckLexer :: (HasLexerState s, MonadState s m) => [Declaration a] -> m ()+sanityCheckLexer d = do+    storedMax <- use (lexerStateLens._1)+    let computedMax = maximum (maxUniqueDeclaration <$> d)+    when (storedMax < computedMax) $+        error "Sanity check failed!"+ -- | Sanity check for the renamer. sanityCheck :: (HasRenames s, MonadState s m) => [Declaration a] -> m () sanityCheck d = do

@@ -70,7 +70,7 @@             <#> prettyAlexState st  prettyAlexState :: AlexUserState -> Doc a-prettyAlexState (m, _, nEnv) =+prettyAlexState (m, _, _, nEnv) =         "max:" <+> pretty m     <#> prettyDumpBinds nEnv @@ -200,10 +200,11 @@             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+tryEvalExpressionM (Interp l es)      = Interp l <$> traverse tryEvalExpressionM es+tryEvalExpressionM (MultiInterp l es) = MultiInterp 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@@ -216,8 +217,9 @@ 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 (MultiInterp l es) = concatOrFail (T.tail . T.init) l es+evalExpressionM (Interp l es)   = concatOrFail id l es+evalExpressionM (Concat l es)   = concatOrFail id l es evalExpressionM (Tuple l es)    = Tuple l <$> traverse evalExpressionM es evalExpressionM (Let _ bs e) = do     let stMod = thread $ fmap (uncurry nameMod) bs@@ -241,27 +243,30 @@ 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+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 (MultiInterp l es) = MultiInterp 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+countNodes Literal{}          = 1+countNodes StrChunk{}         = 1+countNodes (Choice _ pes)     = sum (fmap (countNodes . snd) pes)+countNodes (Interp _ es)      = product (fmap countNodes es)+countNodes (MultiInterp _ 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+concatOrFail :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => (T.Text -> T.Text) -> a -> [Expression a] -> m (Expression a)+concatOrFail process l = fmap (Literal l . process . mconcat) . traverse evalExpressionAsTextM + evalExpressionAsTextM :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => Expression a -> m T.Text evalExpressionAsTextM = extrText <=< evalExpressionM @@ -279,10 +284,11 @@     let ps = fst <$> pes     es <- traverse resolveFlattenM (snd <$> pes)     pure $ Choice l (NE.zip ps es)-resolveFlattenM (Interp l es) = Interp l <$> traverse resolveFlattenM es-resolveFlattenM (Concat l es) = Concat l <$> traverse resolveFlattenM es-resolveFlattenM (Tuple l es) = Tuple l <$> traverse resolveFlattenM es-resolveFlattenM (Let _ bs e) = do+resolveFlattenM (Interp l es)      = Interp l <$> traverse resolveFlattenM es+resolveFlattenM (MultiInterp l es) = MultiInterp l <$> traverse resolveFlattenM es+resolveFlattenM (Concat l es)      = Concat l <$> traverse resolveFlattenM es+resolveFlattenM (Tuple l es)       = Tuple l <$> traverse resolveFlattenM es+resolveFlattenM (Let _ bs e)       = do     let stMod = thread $ fmap (uncurry nameMod) bs     withSt stMod $         resolveFlattenM e@@ -312,6 +318,7 @@     es <- traverse resolveExpressionM (snd <$> pes)     pure $ Choice l (NE.zip ps es) resolveExpressionM (Interp l es) = Interp l <$> traverse resolveExpressionM es+resolveExpressionM (MultiInterp l es) = MultiInterp 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

@@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} -module Language.Dickinson.File ( evalFile+module Language.Dickinson.File ( evalIO+                               , evalFile                                , checkFile                                , warnFile                                , tcFile

@@ -9,6 +9,7 @@                                     , withAlexSt                                     , lexDickinson                                     , alexInitUserState+                                    , scdInitState                                     , AlexPosn (..)                                     , AlexUserState                                     , Alex (..)@@ -20,6 +21,7 @@  import Control.Arrow ((&&&)) import Control.DeepSeq (NFData)+import Control.Monad.Fail (MonadFail (..)) import Data.Bifunctor (first) import Data.Binary (Binary) import qualified Data.ByteString.Lazy as BSL@@ -66,7 +68,7 @@ @name = (@lower_name \.)* @lower_name @tyname = [A-Z] @follow_char* -@multi_str_in = ([^\'] | $white)*+@multi_str_in = ([^\'\$] | $white)*  tokens :- @@ -109,19 +111,17 @@     }      -- interpolated strings-    <0> \"                         { mkSym StrBegin `andBegin` string }+    <0> \"                         { doSym StrBegin (pushScd InStr) `andBegin` string }     <string> @str_interp_in        { tok (\p s -> alex $ TokStrChunk p (escReplace $ mkText s)) }-    <string> @interp               { mkSym BeginInterp `andBegin` 0 }-    <string> "$"                   { tok (\p s -> alex $ TokStrChunk p (mkText s)) }-    <0> \}                         { mkSym EndInterp `andBegin` string }-    <string> \"                    { mkSym StrEnd `andBegin` 0 }--    -- TODO: track "depth" in interpolations+    <string,multiStr> @interp      { mkSym BeginInterp `andBegin` 0 }+    <string,multiStr> "$"          { tok (\p s -> alex $ TokStrChunk p (mkText s)) }+    <0> \}                         { doSym EndInterp exitInterp }+    <string> \"                    { doSym StrEnd popScd `andBegin` 0 } -    <0> "'''"                      { mkSym MultiStrBegin `andBegin` multiStr }+    <0> "'''"                      { doSym MultiStrBegin (pushScd InMultiStr) `andBegin` multiStr }     <multiStr> @multi_str_in       { tok (\p s -> alex $ TokStrChunk p (mkText s)) }     <multiStr> \' [^\']            { tok (\p s -> alex $ TokStrChunk p (mkText s)) }-    <multiStr> "'''"               { mkSym MultiStrEnd `andBegin` 0 }+    <multiStr> "'''"               { doSym MultiStrEnd popScd `andBegin` 0 }      -- strings     <0> @string                    { tok (\p s -> alex $ TokString p (escReplace . T.tail . T.init $ mkText s)) }@@ -131,6 +131,9 @@  { +instance MonadFail Alex where+    fail = alexError+ escReplace :: T.Text -> T.Text escReplace =       T.replace "\\\"" "\""@@ -143,10 +146,32 @@ alex :: a -> Alex a alex = pure +popScd :: Alex ()+popScd = mod_ust (\(x,pop,y,z) -> (x,tail pop,y,z))++pushScd :: ScdState -> Alex ()+pushScd st =+    mod_ust (\(x,push,y,z) -> (x,st:push,y,z))++exitInterp :: Alex ()+exitInterp = do +    (_,iSt:_,_,_) <- get_ust+    case iSt of+        InStr -> set_scd string+        InMultiStr -> set_scd multiStr++set_scd :: Int -> Alex ()+set_scd st = Alex (Right . (go &&& (const ())))+    where go s = s { alex_scd = st }+ set_ust :: AlexUserState -> Alex () set_ust st = Alex (Right . (go &&& (const ())))     where go s = s { alex_ust = st } +mod_ust :: (AlexUserState -> AlexUserState) -> Alex ()+mod_ust f = Alex (Right . (go &&& (const ())))+    where go s = s { alex_ust = f (alex_ust s) }+ gets_alex :: (AlexState -> a) -> Alex a gets_alex f = Alex (Right . (id &&& f)) @@ -166,8 +191,13 @@  mkSym = constructor TokSym -type AlexUserState = (UniqueCtx, M.Map T.Text Int, NameEnv AlexPosn)+doSym t act = tok (\p _ -> TokSym p t <$ act) +data ScdState = InStr+              | InMultiStr++type AlexUserState = (UniqueCtx, [ScdState], M.Map T.Text Int, NameEnv AlexPosn)+ class HasLexerState a where     lexerStateLens :: Lens' a AlexUserState @@ -178,16 +208,19 @@     set_ust st' $> (n $> pos)  newIdent :: AlexPosn -> T.Text -> AlexUserState -> (AlexUserState, Name AlexPosn)-newIdent pos t pre@(max', names, uniqs) =+newIdent pos t pre@(max', scd, names, uniqs) = {-# SCC "newIdent" #-}     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)+                in ((i, scd, M.insert t i names, IM.insert i newName uniqs), newName)     where tQual = NE.fromList (T.splitOn "." t) +scdInitState :: [ScdState]+scdInitState = mempty+ alexInitUserState :: AlexUserState-alexInitUserState = (0, mempty, mempty)+alexInitUserState = (0, scdInitState, mempty, mempty)  data Sym = LParen          | RParen

@@ -22,10 +22,12 @@ import Data.Foldable (toList) import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty ((:|)), (<|))+import Data.Maybe (mapMaybe)+import Data.Semigroup ((<>)) 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.Tuple.Ext (fst4) import Data.Typeable (Typeable) import GHC.Generics (Generic) import Language.Dickinson.Lexer@@ -174,23 +176,27 @@ countSpaces :: T.Text -> Int countSpaces = T.length . T.takeWhile (== ' ') -stripMulti :: T.Text -> T.Text-stripMulti t =-    let ls = T.lines t-        in let sp = minimum (maxBound : (fmap countSpaces $ tail ls))-            in T.unlines (fmap (T.drop sp) ls)+-- minimum indentation (relevant in a string containing newline characters)+minIndent :: T.Text -> Int+minIndent t = minimum (maxBound : fmap countSpaces (T.lines t)) +minIndentExpr :: Expression a -> Maybe Int+minIndentExpr (StrChunk _ t) | "\n" `T.isInfixOf` t  = Just $ minIndent $ T.tail $ T.dropWhile (/= '\n') t -- tail because T.lines "\n   hello" is ["", "    hello"]+minIndentExpr _                                      = Nothing+ mapStrChunk :: (T.Text -> T.Text) -> Expression a -> Expression a mapStrChunk f (StrChunk l t) = StrChunk l (f t)-mapStrChunk _ e = e+mapStrChunk _ e              = e -squishStrChunks :: [Expression a] -> [Expression a]-squishStrChunks (StrChunk l t:StrChunk _ t':ts) = squishStrChunks (StrChunk l (t <> t') : ts)-squishStrChunks (t:ts)                          = t : squishStrChunks ts-squishStrChunks []                              = []+minIndentChunks :: [Expression a] -> Int+minIndentChunks es =+    minimum (maxBound : mapMaybe minIndentExpr es)  processMultiChunks :: [Expression a] -> [Expression a]-processMultiChunks = fmap (mapStrChunk stripMulti) . squishStrChunks+processMultiChunks es = {-# SCC "processMultiChunks" #-}+    let toStrip = minIndentChunks es+        in let needle = "\n" <> T.replicate toStrip " "+            in mapStrChunk (T.replace needle "\n") <$> es  weight :: NonEmpty (Expression a) -> NonEmpty (Double, Expression a) weight es = (recip, ) <$> es@@ -239,7 +245,7 @@           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)+parseWrapper parser str = fmap (first fst4) $ liftErr $ runAlexSt str (runExceptT parser)  liftErr :: Either String (b, Either (ParseError a) c) -> Either (ParseError a) (b, c) liftErr (Left err)            = Left (LexErr err)

@@ -47,6 +47,7 @@ maxLens :: Lens' Renames Int maxLens f s = fmap (\x -> s { max_ = x }) (f (max_ s)) +-- | @since 0.1.1.0 class HasRenames a where     rename :: Lens' a Renames @@ -141,6 +142,7 @@     (n', modR) <- withName n     pure (modR, PatternVar l n') +-- | @since 0.1.1.0 renameExpressionM :: (MonadState s m, HasRenames s) => Expression a -> m (Expression a) renameExpressionM e@Literal{} = pure e renameExpressionM e@StrChunk{} = pure e

@@ -11,18 +11,19 @@                                , 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), align, 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           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), align, brackets, colon, concatWith, dquotes,+                                                     group, hardline, hsep, indent, parens, pipe, rangle, tupled, vsep,+                                                     (<+>))+import           Data.Text.Prettyprint.Doc.Ext      (hardSep, (<#*>), (<#>), (<^>))+import           Data.Text.Prettyprint.Doc.Internal (unsafeTextWithoutNewlines)+import           GHC.Generics                       (Generic) import           Language.Dickinson.Name  data Dickinson a = Dickinson { modImports :: [Import a]@@ -121,9 +122,12 @@ prettyInterp e              = "${" <> pretty e <> "}"  prettyMultiInterp :: [Expression a] -> Doc b-prettyMultiInterp = concatWith (<#>) . concatMap prettyChunk-    where prettyChunk (StrChunk _ t) = fmap pretty (T.lines t) -- TODO: squish StrChunks together (so that ' blocks are not separated...)-          prettyChunk _              = undefined -- TODO: handle this when interpolated multiline strings hit+prettyMultiInterp = mconcat . fmap prettyChunk+    where prettyChunk (StrChunk _ t) = textHard t -- FIXME: convert "\n" to hardline...+          prettyChunk e              = "${" <> pretty e <> "}"++textHard :: T.Text -> Doc a+textHard = concatWith (<#>) . map unsafeTextWithoutNewlines . T.splitOn "\n"  instance Pretty (Pattern a) where     pretty (PatternVar _ n)    = pretty n

@@ -3,6 +3,7 @@ module Eval ( evalTests             ) where +import qualified Data.Text               as T import           Language.Dickinson.File import           Test.Tasty              (TestTree, testGroup) import           Test.Tasty.HUnit        (Assertion, testCase, (@?=))@@ -16,8 +17,11 @@     , resultCase "test/data/tuple.dck"     , resultCase "test/demo/tyAnnot.dck"     , resultCase "test/data/quoteify.dck"+    , resultCase "test/data/multiQuoteify.dck"     , resultCase "test/data/hangIndefinitely.dck"     , resolveCase "test/data/hangIndefinitely.dck"+    , testCase "Should handle interpolated multiline strings" multiQuoteEval+    , testCase "Should handle nested interpolations" multiInterpolatedNestedEval     ]  forceResult :: a -> Assertion@@ -39,17 +43,22 @@     res <- evalFile ["prelude", "lib"] fp     forceResult res +evalTo :: FilePath -> T.Text -> Assertion+evalTo fp t = do+    res <- evalFile [] fp+    res @?= t+ constEval :: Assertion-constEval = do-    res <- evalFile [] "test/eval/context.dck"-    res @?= "woman"+constEval = evalTo "test/eval/context.dck" "woman"  scopeEval :: Assertion-scopeEval = do-    res <- evalFile [] "test/demo/circular.dck"-    res @?= "a"+scopeEval = evalTo "test/demo/circular.dck" "a"  higherOrderEval :: Assertion-higherOrderEval = do-    res <- evalFile [] "test/data/higherOrder.dck"-    res @?= "It's me"+higherOrderEval = evalTo "test/data/higherOrder.dck" "It's me"++multiQuoteEval :: Assertion+multiQuoteEval = evalTo "test/data/multiQuoteify.dck" "God created war so that Americans would learn geography.\n    — Mark Twain"++multiInterpolatedNestedEval :: Assertion+multiInterpolatedNestedEval = evalTo "test/data/interpolateNested.dck" "This is an interpolated string sort of."

@@ -33,6 +33,8 @@         , renameDckFile "test/data/quoteify.dck"         , withDckFile "test/data/lexDollarSign.dck"         , withDckFile "test/data/multiStr.dck"+        , withDckFile "test/data/multiQuoteify.dck"+        , withDckFile "test/data/lambdaMultiQuote.dck"         ]  prettyBSL :: Dickinson a -> BSL.ByteString

@@ -2,7 +2,7 @@  module Main (main) where -import           Control.Exception                 (throw)+import           Control.Exception.Value           (eitherThrow) import qualified Data.ByteString.Lazy              as BSL import           Data.Either                       (isRight) import           Data.List.NonEmpty                (NonEmpty (..))@@ -10,7 +10,9 @@ import           Eval import           Golden import           Language.Dickinson.Check+import           Language.Dickinson.Check.Internal import           Language.Dickinson.DuplicateCheck+import           Language.Dickinson.File import           Language.Dickinson.Import import           Language.Dickinson.Lexer import           Language.Dickinson.Name@@ -59,7 +61,10 @@         , noScopeError "test/data/adt.dck"         , detectScopeError "test/error/tyScope.dck"         , detectScopeError "test/error/constructorScope.dck"+        , lexNoError "test/data/multiQuoteify.dck"+        , parseNoError "test/data/multiQuoteify.dck"         , findPath+        , sanityCheckTest "test/data/adt.dck"         ]  findPath :: TestTree@@ -68,7 +73,7 @@     res @?= Just "lib/color.dck"  readNoFail :: FilePath -> IO (Dickinson AlexPosn)-readNoFail = fmap (either throw id . parse) . BSL.readFile+readNoFail = fmap (eitherThrow . parse) . BSL.readFile  detectBadBranch :: FilePath -> TestTree detectBadBranch fp = testCase "Detects suspicious branch" $ do@@ -101,4 +106,11 @@     assertBool "Doesn't fail lexing" $ isRight (lexDickinson contents)  parseRename :: FilePath -> IO (Dickinson AlexPosn)-parseRename = fmap (fst . uncurry renameDickinson . either throw id . parseWithMax) . BSL.readFile+parseRename = fmap (fst . uncurry renameDickinson . eitherThrow . parseWithMax) . BSL.readFile++-- sanity check the renamer+sanityCheckTest :: FilePath -> TestTree+sanityCheckTest fp = testCase fp $+    fmap eitherThrow $ evalIO $ do+        ds <- amalgamateRenameM [] fp+        sanityCheck ds

@@ -0,0 +1,11 @@+%-++(:def of "of")++(:def main+  (:let+    [interpolated "interpolated"]+    [sortOf "sort ${of}"]+      '''+      This is an ${> interpolated " string ${sortOf}."}+      '''))

@@ -0,0 +1,14 @@+%-++(:def cowsay+  (:lambda txt text+    '''+    +    ${txt}+    ------+          \   ^__^+           \  (oo)\_______+              (__)\       )\/\+                  ||----w |+                  ||     ||+    '''))

@@ -0,0 +1,14 @@+%-++(:def cowsay+  (:lambda txt text+    '''+    +    ${txt}+    ------+          \   ^__^+           \  (oo)\_______+              (__)\       )\/\+                  ||----w |+                  ||     ||+    '''))

@@ -0,0 +1,13 @@+%-++(:def quote+  (:lambda qu text+    (:lambda name text+      '''+      ${qu}+          — ${name}+      ''')))++(:def main+  (:oneof+    (| ($ $ quote "God created war so that Americans would learn geography." "Mark Twain"))))

@@ -0,0 +1,13 @@+%-++(:def quote+  (:lambda qu text+    (:lambda name text+      '''+      ${qu}+          — ${name}+      ''')))++(:def main+  (:branch+    (| 1.0 ($ ($ quote "God created war so that Americans would learn geography.") "Mark Twain"))))

@@ -5,6 +5,17 @@   I saw my boss' dog today   ''') +(:def doubleIndent+    '''+    I saw my boss' dog today+    ''')++(:def indented+    '''+    hello+      world+    ''')+ (:def empty   '''   ''')

@@ -5,6 +5,17 @@   I saw my boss' dog today   ''') +(:def doubleIndent+  '''+  I saw my boss' dog today+  ''')++(:def indented+  '''+  hello+    world+  ''')+ (:def empty   '''   ''')