language-dickinson 1.3.0.4 → 1.4.0.0

raw patch · 26 files changed

+306/−34 lines, 26 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• examples/divinationBot.dck +120/−0
• language-dickinson.cabal +2/−1
• lib/adjectives.dck +2/−2
• lib/noun.dck +2/−0
• run/REPL.hs +1/−1
• run/REPL/Save.cpphs +3/−1
• src/Language/Dickinson/Check.hs +7/−2
• src/Language/Dickinson/Check/Duplicate.hs +2/−0
• src/Language/Dickinson/Check/Exhaustive.hs +2/−0
• src/Language/Dickinson/Check/Internal.hs +1/−0
• src/Language/Dickinson/Check/Pattern.hs +2/−0
• src/Language/Dickinson/Check/Scope.hs +7/−0
• src/Language/Dickinson/Error.hs +1/−1
• src/Language/Dickinson/Eval.hs +72/−19
• src/Language/Dickinson/File.hs +1/−1
• src/Language/Dickinson/Lexer.x +6/−0
• src/Language/Dickinson/Parser.y +5/−5
• src/Language/Dickinson/Probability.hs +9/−0
• src/Language/Dickinson/Rename.hs +12/−1
• src/Language/Dickinson/Type.hs +7/−0
• src/Language/Dickinson/TypeCheck.hs +6/−0
• test/Eval.hs +4/−0
• test/error/mutual.dck +7/−0
• test/error/scoping.dck +9/−0
• test/eval/chooseHigherOrder.dck +9/−0

@@ -1,5 +1,12 @@ # dickinson +## 1.4.0.0++  * Add `:bind` construct, like `:let` but stricter+  * Fix renamer bug, hopefully+  * Add `:pick` builtin construct+  * Fix bug in `install.mk`+ ## 1.3.0.4    * Add some libraries for declension and conjugation in English

@@ -0,0 +1,120 @@+%-++; @botmancy from twitter but more sensical\+; http://phrontistery.info/divine.html+; https://en.wikipedia.org/wiki/Methods_of_divination+; bones, topo-, xylo-, crystallo-+tydecl means = Fish+             | Stars+             | Plants+             | Books+             | Birds+             | Snakes+             | Sun+             | Animals+             | Lips+             | Dreams+             | Fire+             | Air+             | Placenta+             | Poo+             | Fingers+             | Cat+             | Number+             | Wood+             | Walk+             | Anthro+             | Bark+             | Rock+             | Large+             | Pearl+             | Small+             | Teeth+             | Bones+             | Land++(:def prefix+  (:lambda x means+    (:match x+      [Fish "ichthyo"]+      [Stars "astro"]+      [Plants "botano"]+      [Books "biblio"]+      [Birds "ornitho"]+      [Snakes "ophio"]+      [Sun "helio"]+      [Animals "zoo"]+      [Lips "labio"]+      [Dreams "oneiro"]+      [Fire "pyro"]+      [Air "aero"]+      [Placenta "amnio"]+      [Poo "scato"]+      [Fingers "dactylo"]+      [Cat "ailuro"]+      [Number "numero"]+      [Wood "xylo"]+      [Walk "ambulo"]+      [Anthro "anthro"]+      [Bark "ololyg"]+      [Rock "litho"]+      [Large "marco"]+      [Pearl "margarito"]+      [Small "micro"]+      [Teeth "odonto"]+      [Bones "osteo"]+      [Land "topo"])))++(:def english+  (:lambda x means+    (:match x+      [Fish "fish"]+      [Stars "stars"]+      [Plants "plants"]+      [Books "the Bible"]+      [Birds "birds"]+      [Snakes "snakes"]+      [Sun "sun"]+      [Animals "animals"]+      [Lips "lips"]+      [Dreams "dreams"]+      [Fire "fire"]+      [Air "the weather"]+      [Placenta "placenta"]+      [Poo "excrement"]+      [Fingers "finger movements"]+      [Cat "cats"]+      [Number "numbers"]+      [Wood "pieces of wood"]+      [Walk "walking"]+      [Anthro "human entrails"]+      [Bark "howling of dogs"]+      [Rock "rocks"]+      [Large "large objects"]+      [Pearl "pearls"]+      [Small "micro"]+      [Teeth "teeth"]+      [Bones "bones"]+      [Land "landforms"])))++(:def mod+  (:branch+    (| 1.0 "")+    (| 0.2 "inspection of ")+    (| 0.2 "observation of ") ; observing?+    (| 0.3 "means of ")))++(:def means+  (:pick means))++(:def postfix+  (:branch+    (| 1.0 "mancy")+    (| 0.065 "scopy")+    (| 0.03 "spication")+    (| 0.015 "logy")))++(:def main+  (:bind+    [means means]+      "${$prefix means}${postfix} - divination by ${mod}${$english means}"))

@@ -1,6 +1,6 @@ cabal-version:      2.0 name:               language-dickinson-version:            1.3.0.4+version:            1.4.0.0 license:            BSD3 license-file:       LICENSE copyright:          Copyright: (c) 2020 Vanessa McHale@@ -115,6 +115,7 @@         Language.Dickinson.Lib.Get         Language.Dickinson.Pattern         Language.Dickinson.Check.Common+        Language.Dickinson.Probability         Control.Monad.Ext         Data.Foldable.Ext         Data.List.Ext

@@ -313,7 +313,7 @@       (| "oleaginous")       (| "obstreperous")       (| "otic")-      (| "opprobious")+      (| "opprobrious")       (| "peripatetic")       (| "punctual")       (| "polythetic")@@ -366,7 +366,7 @@       (| "lugubrious")       (| "laodicean")       (| "lazy")-      (| "quiscient")+      (| "quiescent")       (| "quaggy")       (| "queasy")       (| "quirky")

@@ -11,6 +11,7 @@     (| "simile")     (| "alliteration")     (| "synecdoche")+    (| "zeugma")     (| "metonymy")))  (:def nounPhrase@@ -33,6 +34,7 @@       (| "valetudinarian")       (| "car")       (| "head")+      (| "punnet")       (| "sitophobia")       (| "tail")       (| "joke")

@@ -57,7 +57,7 @@ runRepl x = do     g <- newStdGen     emdDir <- (</> ".emd_history") <$> getHomeDirectory-    let initSt = EvalSt (randoms g) mempty initRenames mempty alexInitUserState emptyTyEnv+    let initSt = EvalSt (randoms g) mempty initRenames mempty alexInitUserState emptyTyEnv mempty     let myCompleter = emdCompletions `fallbackCompletion` completeFilename     let emdSettings = setComplete myCompleter $ defaultSettings { historyFile = Just emdDir }     flip evalStateT initSt $ runInputT emdSettings x

@@ -31,14 +31,16 @@         <*> get         <*> (addScd <$> get)         <*> get+        <*> get  putReplState :: Binary a => EvalSt a -> Put-putReplState (EvalSt _ be rs t lSt ty) =+putReplState (EvalSt _ be rs t lSt ty cons) =        put be     <> put rs     <> put t     <> put (dropScd lSt)     <> put ty+    <> put cons  decodeReplSt :: Binary a => [Double] -> BSL.ByteString -> EvalSt a #ifdef ZSTD

@@ -51,5 +51,10 @@         checkNames (toList $ fmap fst bs)     <|> foldMapAlternative (checkMultipleExpr . snd) bs     <|> checkMultipleExpr e-checkMultipleExpr (Annot _ e _)    = checkMultipleExpr e-checkMultipleExpr Constructor{}    = Nothing+checkMultipleExpr (Bind _ bs e)      =+        checkNames (toList $ fmap fst bs)+    <|> foldMapAlternative (checkMultipleExpr . snd) bs+    <|> checkMultipleExpr e+checkMultipleExpr (Annot _ e _)      = checkMultipleExpr e+checkMultipleExpr Constructor{}      = Nothing+checkMultipleExpr Random{}           = Nothing

@@ -45,9 +45,11 @@ 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 (Bind _ brs es)    = foldMapAlternative checkExprDuplicates (snd <$> brs) <|> checkExprDuplicates es checkExprDuplicates (Lambda _ _ _ e)   = checkExprDuplicates e checkExprDuplicates (Match _ e brs)    = checkExprDuplicates e <|> foldMapAlternative (checkExprDuplicates . snd) brs checkExprDuplicates (Flatten _ e)      = checkExprDuplicates e checkExprDuplicates (Annot _ e _)      = checkExprDuplicates e checkExprDuplicates Constructor{}      = Nothing checkExprDuplicates BuiltinFn{}        = Nothing+checkExprDuplicates Random{}           = Nothing

@@ -54,11 +54,13 @@ checkExprM StrChunk{}         = pure Nothing checkExprM Constructor{}      = pure Nothing checkExprM BuiltinFn{}        = pure Nothing+checkExprM Random{}           = pure Nothing checkExprM (Flatten _ e)      = checkExprM e checkExprM (Annot _ e _)      = checkExprM e checkExprM (Lambda _ _ _ e)   = checkExprM e checkExprM (Choice _ brs)     = mapSumM checkExprM (snd <$> brs) checkExprM (Let _ brs e)      = (<|>) <$> mapSumM checkExprM (snd <$> brs) <*> checkExprM e+checkExprM (Bind _ brs e)     = (<|>) <$> mapSumM checkExprM (snd <$> brs) <*> checkExprM e checkExprM (Interp _ es)      = mapSumM checkExprM es checkExprM (MultiInterp _ es) = mapSumM checkExprM es checkExprM (Apply _ e e')     = (<|>) <$> checkExprM e <*> checkExprM e'

@@ -45,6 +45,7 @@ maxUniqueExpression :: Expression a -> Int maxUniqueExpression BuiltinFn{}                           = 0 maxUniqueExpression Literal{}                             = 0+maxUniqueExpression (Random _ (Name _ (Unique k) _))      = k maxUniqueExpression (Constructor _ (Name _ (Unique k) _)) = k maxUniqueExpression StrChunk{}                            = 0 maxUniqueExpression (Var _ (Name _ (Unique i) _))         = i

@@ -60,8 +60,10 @@ checkPatternExpr (Lambda _ _ _ e)   = checkPatternExpr e checkPatternExpr (Flatten _ e)      = checkPatternExpr e checkPatternExpr (Let _ bs e)       = foldMapAlternative (checkPatternExpr . snd) bs <|> checkPatternExpr e+checkPatternExpr (Bind _ bs e)      = foldMapAlternative (checkPatternExpr . snd) bs <|> checkPatternExpr e checkPatternExpr (Annot _ e _)      = checkPatternExpr e checkPatternExpr Constructor{}      = Nothing+checkPatternExpr Random{}           = Nothing  checkPatternDecl :: [Declaration a] -> Maybe (DickinsonError a) checkPatternDecl ds =

@@ -90,8 +90,15 @@     traverse_ insertName ns     (<|>) <$> checkExpr e <*> mapSumM checkExpr (snd <$> bs)         <* traverse_ deleteName ns+checkExpr (Bind _ bs e) = do+    let ns = fst <$> bs+    traverse_ insertName ns+    (<|>) <$> checkExpr e <*> mapSumM checkExpr (snd <$> bs)+        <* traverse_ deleteName ns checkExpr (Match _ e brs) =     ((<|>) <$> checkExpr e) <*> mapSumM checkPair brs+checkExpr (Random l n) =+    checkType (TyNamed l n)  checkPair :: (Pattern a, Expression a) -> CheckM (Maybe (DickinsonError a)) checkPair (p, e) = do

@@ -48,7 +48,7 @@     show = show . pretty  instance (Pretty a) => Pretty (DickinsonError a) where-    pretty (UnfoundName l n)         = pretty l <+> pretty n <+> "is not in scope."+    pretty (UnfoundName l n)         = pretty l <+> squotes (pretty n) <+> "is not in scope."     pretty (NoText t)                = squotes (pretty t) <+> "not defined"     pretty (ParseErr _ e)            = pretty e     pretty (TypeMismatch e ty ty')   = pretty (exprAnn e) <+> "Expected" <+> pretty e <+> "to have type" <+> squotes (pretty ty) <> ", found type" <+> squotes (pretty ty')

@@ -15,30 +15,31 @@                                , balanceMax                                ) where -import           Control.Composition           (thread)-import           Control.Monad                 ((<=<))-import           Control.Monad.Except          (MonadError, throwError)-import qualified Control.Monad.Ext             as Ext-import           Control.Monad.State.Lazy      (MonadState, get, gets, modify, put)-import           Data.Char                     (toUpper)-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           Control.Composition            (thread)+import           Control.Monad                  ((<=<))+import           Control.Monad.Except           (MonadError, throwError)+import qualified Control.Monad.Ext              as Ext+import           Control.Monad.State.Lazy       (MonadState, get, gets, modify, put)+import           Data.Char                      (toUpper)+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.Ext import           Language.Dickinson.Error-import           Language.Dickinson.Lexer+import           Language.Dickinson.Lexer       hiding (loc) import           Language.Dickinson.Name import           Language.Dickinson.Pattern+import           Language.Dickinson.Probability 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, (.=))-import           Prettyprinter                 (Doc, Pretty (..), vsep, (<+>))+import           Lens.Micro                     (Lens', over, set, _1)+import           Lens.Micro.Mtl                 (modifying, use, (.=))+import           Prettyprinter                  (Doc, Pretty (..), vsep, (<+>))  -- | The state during evaluation data EvalSt a = EvalSt@@ -52,6 +53,8 @@     , lexerState    :: AlexUserState     -- For error messages     , tyEnv         :: TyEnv a+    -- For :pick expressions+    , constructors  :: IM.IntMap (NonEmpty (TyName a))     }  instance HasLexerState (EvalSt a) where@@ -64,7 +67,7 @@ prettyTl (t, i) = pretty t <+> ":" <+> pretty i  instance Pretty (EvalSt a) where-    pretty (EvalSt _ b r t st _) =+    pretty (EvalSt _ b r t st _ _) =         "bound expressions:" <#> vsep (prettyBound <$> IM.toList b)             <#> pretty r             <#> "top-level names:" <#> vsep (prettyTl <$> M.toList t)@@ -87,6 +90,9 @@ boundExprLens :: Lens' (EvalSt a) (IM.IntMap (Expression a)) boundExprLens f s = fmap (\x -> s { boundExpr = x }) (f (boundExpr s)) +constructorsLens :: Lens' (EvalSt a) (IM.IntMap (NonEmpty (TyName a)))+constructorsLens f s = fmap (\x -> s { constructors = x }) (f (constructors s))+ topLevelLens :: Lens' (EvalSt a) (M.Map T.Text Unique) topLevelLens f s = fmap (\x -> s { topLevel = x }) (f (topLevel s)) @@ -160,8 +166,8 @@ addDecl :: (MonadState (EvalSt a) m)         => Declaration a         -> m ()-addDecl (Define _ n e) = bindName n e *> topLevelAdd n-addDecl TyDecl{}       = pure ()+addDecl (Define _ n e)                      = bindName n e *> topLevelAdd n+addDecl (TyDecl _ (Name _ (Unique k) _) cs) = modifying constructorsLens (IM.insert k cs)  extrText :: (HasTyEnv s, MonadState (s a) m, MonadError (DickinsonError a) m) => Expression a -> m T.Text extrText (Literal _ t)  = pure t@@ -211,6 +217,12 @@ tryEvalExpressionM (MultiInterp l es) = MultiInterp l <$> traverse tryEvalExpressionM es tryEvalExpressionM (Concat l es)      = Concat l <$> traverse tryEvalExpressionM es tryEvalExpressionM c@Constructor{}    = pure c+tryEvalExpressionM (Bind _ bs e)       = do+    let ns = fst <$> bs+    newBs <- traverse tryEvalExpressionM (snd <$> bs)+    let stMod = thread $ fmap (uncurry nameMod) (NE.zip ns newBs)+    withSt stMod $+        tryEvalExpressionM e tryEvalExpressionM (Let _ bs e)       = do     let stMod = thread $ fmap (uncurry nameMod) bs     withSt stMod $@@ -219,6 +231,11 @@     let ps = fst <$> brs     es <- traverse (tryEvalExpressionM . snd) brs     Match l <$> tryEvalExpressionM e <*> pure (NE.zip ps es)+tryEvalExpressionM (Random _ n@(Name _ (Unique k) l)) = do+    cs <- gets constructors+    case IM.lookup k cs of+        Just ns -> pick (asConstructors ns)+        Nothing -> throwError (UnfoundType l n)  evalExpressionM :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => Expression a -> m (Expression a) evalExpressionM e@Literal{}     = pure e@@ -235,6 +252,12 @@     let stMod = thread $ fmap (uncurry nameMod) bs     withSt stMod $         evalExpressionM e+evalExpressionM (Bind _ bs e) = do+    let ns = fst <$> bs+    newBs <- traverse evalExpressionM (snd <$> bs)+    let stMod = thread $ fmap (uncurry nameMod) (NE.zip ns newBs)+    withSt stMod $+        evalExpressionM e evalExpressionM (Apply _ e e') = do     e'' <- evalExpressionM e     case e'' of@@ -255,7 +278,15 @@     e' <- resolveFlattenM e     evalExpressionM ({-# SCC "mapChoice.setFrequency" #-} mapChoice setFrequency e') evalExpressionM (Annot _ e _) = evalExpressionM e+evalExpressionM (Random _ n@(Name _ (Unique k) l)) = do+    cs <- gets constructors+    case IM.lookup k cs of+        Just ns -> pick (asConstructors ns)+        Nothing -> throwError (UnfoundType l n) +asConstructors :: NonEmpty (Name a) -> NonEmpty (Double, Expression a)+asConstructors ns = weight ((\n -> Constructor (loc n) n) <$> ns)+ 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@@ -320,6 +351,12 @@ 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 (Bind _ bs e)       = do+    let ns = fst <$> bs+    newBs <- traverse resolveFlattenM (snd <$> bs)+    let stMod = thread $ fmap (uncurry nameMod) (NE.zip ns newBs)+    withSt stMod $+        resolveFlattenM e resolveFlattenM (Let _ bs e)       = do     let stMod = thread $ fmap (uncurry nameMod) bs     withSt stMod $@@ -343,6 +380,11 @@ resolveFlattenM (Flatten l e) =     Flatten l <$> resolveFlattenM e resolveFlattenM (Annot _ e _) = resolveFlattenM e+resolveFlattenM (Random l n@(Name _ (Unique k) l')) = do+    cs <- gets constructors+    case IM.lookup k cs of+        Just ns -> pure $ Choice l (asConstructors ns)+        Nothing -> throwError (UnfoundType l' n)  -- | Resolve let bindings and such; do not perform choices or concatenations. resolveExpressionM :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => Expression a -> m (Expression a)@@ -359,6 +401,12 @@ 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 (Bind _ bs e) = do+    let ns = fst <$> bs+    newBs <- traverse resolveExpressionM (snd <$> bs)+    let stMod = thread $ fmap (uncurry nameMod) (NE.zip ns newBs)+    withSt stMod $+        resolveExpressionM e resolveExpressionM (Let _ bs e) = do     let stMod = thread $ fmap (uncurry nameMod) bs     withSt stMod $@@ -378,6 +426,11 @@ resolveExpressionM (Flatten l e) =     Flatten l <$> resolveExpressionM e resolveExpressionM (Annot _ e _) = resolveExpressionM e+resolveExpressionM (Random l n@(Name _ (Unique k) l')) = do+    cs <- gets constructors+    case IM.lookup k cs of+        Just ns -> pure $ Choice l (asConstructors ns)+        Nothing -> throwError (UnfoundType l' n)  applyBuiltin :: Builtin -> T.Text -> T.Text applyBuiltin AllCaps    = T.toUpper

@@ -52,7 +52,7 @@ evalAllWithGen :: StdGen                -> AllM x                -> IO (Either (DickinsonError AlexPosn) x)-evalAllWithGen g me = runExceptT $ evalStateT me (EvalSt (randoms g) mempty initRenames mempty alexInitUserState emptyTyEnv)+evalAllWithGen g me = runExceptT $ evalStateT me (EvalSt (randoms g) mempty initRenames mempty alexInitUserState emptyTyEnv mempty)  initAmalgamateSt :: AmalgamateSt initAmalgamateSt = AmalgamateSt initRenames alexInitUserState

@@ -107,6 +107,8 @@         ":match"                   { mkKeyword KwMatch }         ":flatten"                 { mkKeyword KwFlatten }         "tydecl"                   { mkKeyword KwTyDecl }+        ":pick"                    { mkKeyword KwRand }+        ":bind"                    { mkKeyword KwBind }          -- builtins         capitalize                 { mkBuiltin Capitalize }@@ -292,6 +294,8 @@              | KwMatch              | KwFlatten              | KwTyDecl+             | KwRand+             | KwBind              deriving (Eq, Generic, NFData)  instance Pretty Builtin where@@ -311,6 +315,8 @@     pretty KwMatch   = ":match"     pretty KwFlatten = ":flatten"     pretty KwTyDecl  = "tydecl"+    pretty KwRand    = ":pick"+    pretty KwBind    = ":bind"  instance Pretty AlexPosn where     pretty (AlexPn _ line col) = pretty line <> colon <> pretty col

@@ -3,7 +3,6 @@     {-# LANGUAGE DeriveAnyClass #-}     {-# LANGUAGE DeriveGeneric #-}     {-# LANGUAGE OverloadedStrings #-}-    {-# LANGUAGE TupleSections #-}     module Language.Dickinson.Parser ( parse                                      , parseWithMax                                      , parseWithCtx@@ -32,6 +31,7 @@ import GHC.Generics (Generic) import Language.Dickinson.Lexer import Language.Dickinson.Name hiding (loc)+import Language.Dickinson.Probability import Language.Dickinson.Type import Language.Dickinson.Unique @@ -77,6 +77,8 @@     match { TokKeyword $$ KwMatch }     flatten { TokKeyword $$ KwFlatten }     tydecl { TokKeyword $$ KwTyDecl }+    random { TokKeyword $$ KwRand }+    bind { TokKeyword $$ KwBind }      builtin { $$@(TokBuiltin _ _) } @@ -153,6 +155,7 @@            : 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 }+           | bind some(brackets(Bind)) Expression { Bind $1 (NE.reverse $2) $3 }            | lambda Name Type Expression { Lambda $1 $2 $3 $4 }            | ident { Var (loc $1) (ident $1) }            | builtin { BuiltinFn (loc $1) (builtin $1) }@@ -164,6 +167,7 @@            | lparen sepBy(Expression,comma) rparen { Tuple $1 (NE.reverse $2) }            | match Expression some(brackets(PatternBind)) { Match $1 $2 (NE.reverse $3) }            | flatten Expression { Flatten $1 $2 }+           | random ident { Random $1 (ident $2) }            | Expression colon Type { Annot $2 $1 $3 }            | tyIdent { Constructor (loc $1) (tyIdent $1) }            | parens(Expression) { $1 }@@ -210,10 +214,6 @@     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-    where recip = 1 / (fromIntegral $ length es)  parseError :: Token AlexPosn -> Parse a parseError = throwError . Unexpected

@@ -0,0 +1,9 @@+{-# LANGUAGE TupleSections #-}+module Language.Dickinson.Probability ( weight+                                      ) where++import           Data.List.NonEmpty (NonEmpty)++weight :: NonEmpty a -> NonEmpty (Double, a)+weight es = (recip', ) <$> es+    where recip' = 1 / fromIntegral (length es)

@@ -173,6 +173,16 @@         (modP, p') <- renamePatternM p         (p' ,) <$> withRenames modP (renameExpressionM e')     pure $ Match l preE brs'+renameExpressionM (Bind p bs e) = do+    newBs <- traverse withName (fst <$> bs)+    let localRenames = snd <$> newBs+        newBinds = thread localRenames+        newNames = fst <$> newBs+        preNewBound = snd <$> bs+    newBound <-+        traverse renameExpressionM preNewBound+    withRenames newBinds $+        Bind p (NE.zip newNames newBound) <$> renameExpressionM e renameExpressionM (Let p bs e) = do     newBs <- traverse withName (fst <$> bs)     let localRenames = snd <$> newBs@@ -180,7 +190,7 @@         newNames = fst <$> newBs         preNewBound = snd <$> bs     newBound <--        zipWithM (\r e' -> withRenames r (renameExpressionM e')) localRenames preNewBound+        traverse renameExpressionM preNewBound     withRenames newBinds $         Let p (NE.zip newNames newBound) <$> renameExpressionM e renameExpressionM (Flatten l e) =@@ -189,3 +199,4 @@     Annot l <$> renameExpressionM e <*> pure ty renameExpressionM c@Constructor{} = pure c renameExpressionM c@BuiltinFn{} = pure c+renameExpressionM c@Random{} = pure c

@@ -65,6 +65,10 @@                         , letBinds :: NonEmpty (Name a, Expression a)                         , letExpr  :: Expression a                         }+                  | Bind { exprAnn :: a+                        , letBinds :: NonEmpty (Name a, Expression a)+                        , letExpr  :: Expression a+                        }                   | Var { exprAnn :: a, exprVar :: Name a }                   | Interp { exprAnn :: a, exprInterp :: [Expression a] }                   | MultiInterp { exprAnn :: a, exprMultiInterp :: [Expression a] }@@ -90,6 +94,7 @@                           }                   | Constructor { exprAnn :: a, constructorName :: TyName a }                   | BuiltinFn { exprAnn :: a, exprBuiltin :: Builtin }+                  | Random { exprAnn :: a, tySelName :: Name a }                   deriving (Generic, NFData, Binary, Functor, Show, Data)                   -- TODO: builtins? @@ -186,6 +191,7 @@     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])))+    pretty (Bind _ ls e)      = group (parens (":bind" <^> vsep (toList (fmap prettyLetLeaf ls) ++ [pretty e])))     -- also comments lol     pretty (Choice _ brs)         | allEq (fst <$> brs) = parens (":oneof" <#> indent 2 (hardSep (toList $ fmap prettyChoiceOneof (snd <$> brs))))@@ -203,6 +209,7 @@     pretty (Annot _ e ty)     = pretty e <+> colon <+> pretty ty     pretty (Constructor _ tn) = pretty tn     pretty (BuiltinFn _ b)    = pretty b+    pretty (Random _ tn)      = group (parens (":pick" <+> pretty tn))  instance Pretty (DickinsonTy a) where     pretty = prettyType pretty

@@ -126,6 +126,11 @@     let ns = fst <$> bs     Ext.zipWithM_ tyInsert ns es'     typeOf e+typeOf (Bind _ bs e) = do+    es' <- traverse typeOf (snd <$> bs)+    let ns = fst <$> bs+    Ext.zipWithM_ tyInsert ns es'+    typeOf e typeOf (Match _ e brs@((_,e') :| _)) = do     ty <- typeOf e     forM_ (fst <$> brs) $ \p ->@@ -143,3 +148,4 @@         Nothing -> throwError $ UnfoundConstructor l tn typeOf (BuiltinFn l _) = pure $ -- all builtins have type (-> text text)     TyFun l (TyText l) (TyText l)+typeOf (Random l n) = pure $ TyNamed l n

@@ -31,6 +31,10 @@     , resultCase "test/examples/lambda.dck"     , resultCase "test/examples/library.dck"     , testCase "Escapes even stripped multiline strings" cowsayEval+    , resultCase "test/error/scoping.dck"+    , resultCase "examples/divinationBot.dck"+    -- , resultCase "test/error/mutual.dck"+    , resultCase "test/eval/chooseHigherOrder.dck"     ]  forceResult :: a -> Assertion

@@ -0,0 +1,7 @@+%-++(:def main+  (:let+    [a "hello"]+    [b a]+    b))

@@ -0,0 +1,9 @@+%-++(:def a+  "a")++(:def main+  (:let+    [a a]+      "${a}"))

@@ -0,0 +1,9 @@+%-++(:def mod+  (:oneof+    (| :lambda x text x)+    (| :lambda x text "a ${x}")))++(:def main+  $mod "b")