language-dickinson 0.1.2.0 → 1.0.0.0

raw patch · 36 files changed

+363/−137 lines, 36 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• README.md +2/−1
• bench/Bench.hs +5/−12
• examples/doggo.dck +0/−18
• examples/fortune.dck +11/−3
• language-dickinson.cabal +3/−2
• prelude/curry.dck +2/−2
• prelude/tuple.dck +6/−6
• public/Language/Dickinson/TH.hs +1/−1
• run/REPL.hs +24/−7
• src/Language/Dickinson/Check.hs +1/−1
• src/Language/Dickinson/Check/Duplicate.hs +1/−1
• src/Language/Dickinson/Check/Internal.hs +4/−3
• src/Language/Dickinson/Check/Pattern.hs +25/−2
• src/Language/Dickinson/Check/Scope.hs +14/−11
• src/Language/Dickinson/Error.hs +10/−4
• src/Language/Dickinson/Eval.hs +22/−9
• src/Language/Dickinson/Parser.y +6/−1
• src/Language/Dickinson/Pattern.hs +23/−0
• src/Language/Dickinson/Rename.hs +13/−4
• src/Language/Dickinson/Type.hs +13/−12
• src/Language/Dickinson/TypeCheck.hs +17/−5
• test/Eval.hs +10/−2
• test/Golden.hs +2/−0
• test/TypeCheck.hs +15/−4
• test/data/hangIndefinitely.dck +4/−4
• test/data/orPattern.dck +17/−0
• test/data/orPattern.pretty +15/−0
• test/data/tuple.dck +2/−2
• test/data/tupleRename.dck +2/−2
• test/data/tupleRename.rename +17/−12
• test/data/tyChoice.dck +10/−0
• test/error/badMatch.dck +2/−2
• test/eval/match.dck +4/−4
• test/eval/matchSex.dck +35/−0
• test/eval/orExample.dck +18/−0

@@ -1,5 +1,12 @@ # dickinson +# 1.0.0.0++  * Fix bug in typechecker+  * Pattern matching now has branches+  * Better error message when `:view` is called without any arguments+  * Introduce or-patterns+ ## 0.1.2.0    * Fail on bad patterns, e.g. `(:match xy (x, x) x)`

@@ -34,7 +34,8 @@ 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).+a [pdf](https://github.com/vmchale/dickinson/blob/master/doc/user-guide.pdf). It+is hosted on [github pages](https://vmchale.github.io/dickinson/) in HTML form.  See `man/emd.1` for man pages. 

@@ -21,12 +21,12 @@ import           Language.Dickinson.TypeCheck import           Language.Dickinson.Unique -benchResult :: FilePath -> Benchmark-benchResult fp = bench fp $ nfIO (evalFile [] fp)- benchPipeline :: FilePath -> Benchmark benchPipeline fp = bench fp $ nfIO (pipeline [] fp) +benchValidate :: FilePath -> Benchmark+benchValidate fp = bench fp $ nfIO (validateFile [] fp)+ main :: IO () main =     defaultMain [ env parses $ \ ~(c, s) ->@@ -57,20 +57,13 @@                     [ bench "bench/data/multiple.dck" $ nf checkMultiple p                     , bench "bench/data/multiple.dck" $ nf checkDuplicates p -- TODO: better example                     ]-                , bgroup "result"-                    [ benchResult "test/eval/context.dck"-                    , benchResult "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")-                    , benchResult "examples/fortune.dck"-                    ]                 , bgroup "pipeline"                     [ benchPipeline "examples/shakespeare.dck"                     , benchPipeline "examples/fortune.dck"                     , benchPipeline "examples/catherineOfSienaBot.dck"                     ]-                , bgroup "tcFile"-                    [ bench "examples/fortune.dck" $ nfIO (tcFile [] "examples/fortune.dck") -- TODO: tc with syntax tree in env?+                , bgroup "validate"+                    [ benchValidate "test/eval/orExample.dck"                     ]                 , env amalFortune $ \f ->                   bgroup "typecheck"

@@ -1,18 +0,0 @@-(: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")))

@@ -1,3 +1,5 @@+#!/usr/bin/env emd+ ; This is a riff on the Unix fortune program. ; See https://en.wikipedia.org/wiki/Fortune_%28Unix%29 for more context @@ -5,8 +7,9 @@  (:def quote   (:lambda q (text, text)-    (:match q (qu, name)-      "${qu}\n    — ${name}")))+    (:match q+      [(qu, name)+        "${qu}\n    — ${name}"])))  (:def fortune   (:oneof@@ -32,7 +35,6 @@     (| "Love animals.")     (| "Today is a good day to practice bilocation.")     (| "Drugs have no mystic content.")-    (| "Violent people are contemptible.")     (| "Irony is the weakest brand of pessimism")     (| "Sin rots the flesh.")     (| "Sex wastes the male body.")@@ -43,7 +45,13 @@     (| "What do you know about dietetics?")     (| "Hobbies are sublunary")     (| "To err is immoral.")+    (| "No man is holy.")     (| "Bats can give humans rabies.")+    ; contrition and certitude+    (| $ quote+      ('''+       No more pennies to fill my pockets+       ''', "Arrow de Wilde"))     (| $ 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"))

@@ -1,6 +1,6 @@ cabal-version:      2.0 name:               language-dickinson-version:            0.1.2.0+version:            1.0.0.0 license:            BSD3 license-file:       LICENSE copyright:          Copyright: (c) 2020 Vanessa McHale@@ -109,6 +109,7 @@     other-modules:         Paths_language_dickinson         Language.Dickinson.Lib.Get+        Language.Dickinson.Pattern         Control.Monad.Ext         Data.Foldable.Ext @@ -122,9 +123,9 @@     ghc-options:      -Wall -O2     build-depends:         base >=4.9 && <5,+        array -any,         bytestring -any,         text -any,-        array -any,         mtl -any,         transformers -any,         containers -any,

@@ -9,5 +9,5 @@ (:def uncurry   (:lambda f (⟶ text (⟶ text text))     (:lambda x (text, text)-      (:match x (y, z)-        ($ $ f y z)))))+      (:match x +        [(y, z) ($ $ f y z)]))))

@@ -2,15 +2,15 @@  (:def fst   (:lambda xy (text, text)-    (:match xy (x, _)-      x)))+    (:match xy+      [(x, _) x])))  (:def snd   (:lambda xy (text, text)-    (:match xy (_, y)-      y)))+    (:match xy+      [(_, y) y])))  (:def fst3   (:lambda xyz (text, text, text)-    (:match xyz (x, _, _)-      x)))+    (:match xyz+      [(x, _, _) x])))

@@ -23,7 +23,7 @@  dickinson :: [FilePath] -> FilePath -> Q Exp dickinson is fp = do-    traverse_ TH.addDependentFile (fp:is) -- TODO: resolve dependencies+    traverse_ TH.addDependentFile [fp] -- TODO: resolve dependencies     ds <- TH.runIO (validateAmalgamate is fp)     liftDataWithText ds 

@@ -7,10 +7,11 @@ import           Control.Monad                         (void) import           Control.Monad.Except                  (ExceptT, runExceptT) import           Control.Monad.IO.Class                (liftIO)-import           Control.Monad.State.Lazy              (StateT, evalStateT, get, gets, lift, put)+import           Control.Monad.State.Lazy              (MonadState, 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.IntSet                           as IS import qualified Data.Map                              as M import           Data.Maybe                            (fromJust) import           Data.Semigroup                        ((<>))@@ -19,6 +20,7 @@ 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.Ext         (prettyText) import           Data.Text.Prettyprint.Doc.Render.Text (putDoc) import           Data.Tuple.Ext                        (fst4) import           Language.Dickinson.Check.Scope@@ -47,6 +49,10 @@  type Repl a = InputT (StateT (EvalSt a) IO) +toCheckSt :: MonadState (EvalSt a) m => m IS.IntSet+toCheckSt = gets (IM.keysSet . fth . lexerState)+    where fth (_,_,_,x) = x+ runRepl :: Repl a x -> IO x runRepl x = do     g <- newStdGen@@ -63,17 +69,22 @@         Just []             -> loop         Just (":h":_)       -> showHelp *> loop         Just (":help":_)    -> showHelp *> loop-        Just (":save":fp:_) -> saveReplSt fp *> loop+        Just (":save":[fp]) -> saveReplSt fp *> loop+        Just (":save":_)    -> liftIO (putStrLn ":save takes one argument") *> loop         Just (":l":fs)      -> traverse loadFile fs *> loop         Just (":load":fs)   -> traverse loadFile fs *> loop-        Just (":r":fp:_)    -> loadReplSt fp *> loop+        Just (":r":[fp])    -> loadReplSt fp *> loop+        Just (":r":_)       -> liftIO (putStrLn ":r takes one argument") *> loop         Just (":type":e:_)  -> typeExpr e *> loop         Just (":t":e:_)     -> typeExpr e *> loop         Just (":view":n:_)  -> bindDisplay (T.pack n) *> loop+        Just (":view":_)    -> liftIO (putStrLn ":view takes a name as an argument") *> loop         Just [":q"]         -> pure ()         Just [":quit"]      -> pure ()         Just [":list"]      -> listNames *> loop+        Just (":list":_)    -> liftIO (putStrLn ":list takes no arguments") *> loop         Just [":dump"]      -> dumpSt *> loop+        Just (":dump":_)    -> liftIO (putStrLn ":dump takes no arguments") *> loop         -- TODO: erase/delete names?         Just{}              -> printExpr (fromJust inp) *> loop         Nothing             -> pure ()@@ -150,6 +161,7 @@         Left err -> liftIO $ putDoc (pretty err <> hardline)         Right (newSt, e) -> do             setSt newSt+            -- TODO: no scope check?             mErr <- lift $ runExceptT $ typeOf =<< resolveExpressionM =<< renameExpressionM e             lift balanceMax             putErr mErr (liftIO . putDoc . (<> hardline) . pretty)@@ -166,15 +178,20 @@                     Right e -> do                         mErr <- lift $ runExceptT $ do                             e' <- resolveExpressionM =<< renameExpressionM e-                            checkScopeExpr e'+                            checkSt <- toCheckSt+                            checkScopeExprWith checkSt e'                             void $ typeOf e' -- TODO: typeOf e but context?-                            evalExpressionAsTextM e'+                            res <- evalExpressionM e'+                            case res of+                                (Literal _ t) -> pure t+                                e''           -> pure $ prettyText e''                         lift balanceMax                         putErr mErr (liftIO . TIO.putStrLn)                     Left decl -> do                         mErr <- lift $ runExceptT $ do                             d <- renameDeclarationM decl-                            checkScopeDecl =<< resolveDeclarationM d+                            checkSt <- toCheckSt+                            checkScopeDeclWith checkSt =<< resolveDeclarationM d                             tyAddDecl d                             tyAdd d                             addDecl' d@@ -187,7 +204,7 @@  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)+putErr (Left y) _  = liftIO $ TIO.putStrLn (prettyText y)  loadFile :: FilePath -> Repl AlexPosn () loadFile fp = do

@@ -40,7 +40,7 @@ checkMultipleExpr (Interp _ es)      = foldMapAlternative checkMultipleExpr es checkMultipleExpr (MultiInterp _ es) = foldMapAlternative checkMultipleExpr es checkMultipleExpr (Apply _ e e')     = checkMultipleExpr e <|> checkMultipleExpr e'-checkMultipleExpr (Match _ e _ e')   = checkMultipleExpr e <|> checkMultipleExpr e'+checkMultipleExpr (Match _ e brs)    = checkMultipleExpr e <|> foldMapAlternative (checkMultipleExpr . snd) brs checkMultipleExpr (Choice _ brs)     = foldMapAlternative (checkMultipleExpr . snd) brs checkMultipleExpr (Concat _ es)      = foldMapAlternative checkMultipleExpr es checkMultipleExpr (Tuple _ es)       = foldMapAlternative checkMultipleExpr es

@@ -43,7 +43,7 @@ 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 (Match _ e brs)    = checkExprDuplicates e <|> foldMapAlternative (checkExprDuplicates . snd) brs checkExprDuplicates (Flatten _ e)      = checkExprDuplicates e checkExprDuplicates (Annot _ e _)      = checkExprDuplicates e checkExprDuplicates Constructor{}      = Nothing

@@ -60,11 +60,11 @@             , maxUniqueExpression e             , maxUniqueType ty             ]-maxUniqueExpression (Match _ e p e')                      =+maxUniqueExpression (Match _ e brs)                       =     maximum         [ maxUniqueExpression e-        , maxUniquePattern p-        , maxUniqueExpression e'+        , maximum (fmap (maxUniquePattern . fst) brs)+        , maximum (fmap (maxUniqueExpression . snd) brs)         ] maxUniqueExpression (Let _ bs e) =     maximum@@ -78,3 +78,4 @@ maxUniquePattern Wildcard{}                            = 0 maxUniquePattern (PatternTuple _ ps)                   = maximum (fmap maxUniquePattern ps) maxUniquePattern (PatternCons _ (Name _ (Unique k) _)) = k+maxUniquePattern (OrPattern _ ps)                      = maximum (fmap maxUniquePattern ps)

@@ -16,12 +16,35 @@ traversePattern (PatternTuple _ ps) = traversePattern =<< toList ps traversePattern Wildcard{}          = [] traversePattern PatternCons{}       = []+traversePattern (OrPattern _ ps)    = traversePattern =<< toList ps +checkPattern :: Pattern a -> Maybe (DickinsonError a)+checkPattern p = checkCoherent p <|> checkNames p+ 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 +noVar :: Pattern a -> Bool+noVar PatternVar{}        = False+noVar (PatternTuple _ ps) = all noVar ps+noVar Wildcard{}          = True+noVar PatternCons{}       = True+noVar (OrPattern _ ps)    = all noVar ps++-- in theory I guess if an or-pattern bound a variable in all its leaves (and+-- all were the same type) I guess it would work+--+-- but this throws out any or-patterns containing wildcards or variables+checkCoherent :: Pattern a -> Maybe (DickinsonError a)+checkCoherent PatternVar{}                  = Nothing+checkCoherent (PatternTuple _ ps)           = foldMapAlternative checkCoherent ps+checkCoherent Wildcard{}                    = Nothing+checkCoherent PatternCons{}                 = Nothing+checkCoherent o@(OrPattern l _) | noVar o   = Nothing+                                | otherwise = Just $ SuspectPattern l o+ checkPatternExpr :: Expression a -> Maybe (DickinsonError a) checkPatternExpr Var{}              = Nothing checkPatternExpr Literal{}          = Nothing@@ -29,7 +52,7 @@ checkPatternExpr (Interp _ es)      = foldMapAlternative checkPatternExpr es checkPatternExpr (MultiInterp _ es) = foldMapAlternative checkPatternExpr es checkPatternExpr (Apply _ e e')     = checkPatternExpr e <|> checkPatternExpr e'-checkPatternExpr (Match _ e p e')   = checkNames p <|> checkPatternExpr e <|> checkPatternExpr e'+checkPatternExpr (Match _ e brs)    = foldMapAlternative (checkPattern . fst) brs <|> checkPatternExpr e <|> foldMapAlternative (checkPatternExpr . snd) brs checkPatternExpr (Choice _ brs)     = foldMapAlternative (checkPatternExpr . snd) brs checkPatternExpr (Concat _ es)      = foldMapAlternative checkPatternExpr es checkPatternExpr (Tuple _ es)       = foldMapAlternative checkPatternExpr es@@ -39,6 +62,6 @@ checkPatternExpr (Annot _ e _)      = checkPatternExpr e checkPatternExpr Constructor{}      = Nothing -checkPatternDecl :: [Declaration a] -> Maybe (DickinsonError a) -- Expression+checkPatternDecl :: [Declaration a] -> Maybe (DickinsonError a) checkPatternDecl ds =     foldMapAlternative checkPatternExpr (mapMaybe defExprM ds)

@@ -1,8 +1,8 @@ {-# LANGUAGE FlexibleContexts #-}  module Language.Dickinson.Check.Scope ( checkScope-                                      , checkScopeExpr-                                      , checkScopeDecl+                                      , checkScopeExprWith+                                      , checkScopeDeclWith                                       ) where  import           Control.Applicative              (Alternative, (<|>))@@ -32,11 +32,11 @@ checkScope :: [Declaration a] -> Maybe (DickinsonError a) checkScope = runCheckM . checkDickinson -checkScopeExpr :: MonadError (DickinsonError a) m => Expression a -> m ()-checkScopeExpr = maybeThrow . runCheckM . checkExpr+checkScopeExprWith :: MonadError (DickinsonError a) m => IS.IntSet -> Expression a -> m ()+checkScopeExprWith is = maybeThrow . flip evalState is . checkExpr -checkScopeDecl :: MonadError (DickinsonError a) m => Declaration a -> m ()-checkScopeDecl = maybeThrow . runCheckM . checkDecl+checkScopeDeclWith :: MonadError (DickinsonError a) m => IS.IntSet -> Declaration a -> m ()+checkScopeDeclWith is = maybeThrow . flip evalState is . checkDecl  checkDickinson :: [Declaration a] -> CheckM (Maybe (DickinsonError a)) checkDickinson d = traverse_ insDecl d *> mapSumM checkDecl d@@ -88,11 +88,14 @@     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+checkExpr (Match _ e brs) =+    ((<|>) <$> checkExpr e) <*> mapSumM checkPair brs++checkPair :: (Pattern a, Expression a) -> CheckM (Maybe (DickinsonError a))+checkPair (p, 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

@@ -24,11 +24,14 @@                       | ParseErr FilePath (ParseError a)                       | ModuleNotFound a (Name a)                       | TypeMismatch (Expression a) (DickinsonTy a) (DickinsonTy a)+                      | PatternTypeMismatch (Pattern 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                       | UnfoundConstructor a (TyName a)                       | UnfoundType a (Name a)+                      | PatternFail a (Expression a)+                      | SuspectPattern a (Pattern a)                       deriving (Generic, NFData)  data DickinsonWarning a = MultipleNames a (Name a) -- TODO: throw both?@@ -47,12 +50,15 @@     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')-    pretty (ModuleNotFound l n)      = pretty l <+> "Module" <+> pretty n <+> "not found"+    pretty (PatternTypeMismatch p ty ty') = pretty (patAnn p) <+> "Constructor" <+> squotes (pretty p) <+> "has type" <+> squotes (pretty ty') <+> "but must be of type" <+> squotes (pretty ty)+    pretty (ModuleNotFound l n)      = pretty l <+> "Module" <+> squotes (pretty n) <+> "not found"     pretty (ExpectedLambda e ty)     = pretty (exprAnn e) <+> "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 (MultiBind l n p)         = pretty l <+> "Name" <+> squotes (pretty n) <+> "is bound more than once in" <+> pretty p     pretty (MalformedTuple l)        = pretty l <+> "Malformed tuple"-    pretty (UnfoundConstructor l tn) = pretty l <+> "Constructor" <+> pretty tn <+> "not found"-    pretty (UnfoundType l ty)        = pretty l <+> "Type" <+> pretty ty <+> "not found"+    pretty (UnfoundConstructor l tn) = pretty l <+> "Constructor" <+> squotes (pretty tn) <+> "not found"+    pretty (UnfoundType l ty)        = pretty l <+> "Type" <+> squotes (pretty ty) <+> "not found"+    pretty (PatternFail l e)         = pretty l <+> "Expression" <+> pretty e <+> "failed to match"+    pretty (SuspectPattern l p)      = pretty l <+> "Pattern" <+> squotes (pretty p) <+> "is an or-pattern but it contains a variable."  instance (Pretty a, Typeable a) => Exception (DickinsonError a) 

@@ -31,6 +31,7 @@ import           Language.Dickinson.Error import           Language.Dickinson.Lexer import           Language.Dickinson.Name+import           Language.Dickinson.Pattern import           Language.Dickinson.Rename import           Language.Dickinson.Type import           Language.Dickinson.TypeCheck@@ -160,6 +161,7 @@         => Declaration a         -> m () addDecl (Define _ n e) = bindName n e *> topLevelAdd n+addDecl TyDecl{}       = pure ()  extrText :: (HasTyEnv s, MonadState (s a) m, MonadError (DickinsonError a) m) => Expression a -> m T.Text extrText (Literal _ t)  = pure t@@ -180,6 +182,8 @@ 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 PatternCons{} _                  = pure id+bindPattern OrPattern{} _                    = pure id bindPattern (PatternTuple _ ps) (Tuple _ es) = thread <$> Ext.zipWithM bindPattern ps es -- don't need to verify length because in theory typechecker already did bindPattern (PatternTuple l _) _             = throwError $ MalformedTuple l @@ -208,8 +212,10 @@     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'+tryEvalExpressionM (Match l e brs) = do+    let ps = fst <$> brs+    es <- traverse (tryEvalExpressionM . snd) brs+    Match l <$> tryEvalExpressionM e <*> pure (NE.zip ps es)  evalExpressionM :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => Expression a -> m (Expression a) evalExpressionM e@Literal{}     = pure e@@ -233,8 +239,10 @@                 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+evalExpressionM (Match l e brs) = do+    eEval <- evalExpressionM e+    (p, e') <- matchPattern l eEval (toList brs)+    modSt <- bindPattern p eEval     withSt modSt $         evalExpressionM e' evalExpressionM (Flatten _ e) = do@@ -274,6 +282,7 @@  resolveDeclarationM :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => Declaration a -> m (Declaration a) resolveDeclarationM (Define l n e) = Define l n <$> resolveExpressionM e+resolveDeclarationM d@TyDecl{}     = pure d  -- | To aid the @:flatten@ function: resolve an expression, leaving -- choices/branches intact.@@ -283,7 +292,7 @@ resolveFlattenM e@Constructor{} = pure e resolveFlattenM (Var _ n)       = resolveFlattenM =<< lookupName n resolveFlattenM (Choice l pes) = do-    let ps = fst <$> pes+    let ps = fst <$> pes -- TODO: do these need to be renamed     es <- traverse resolveFlattenM (snd <$> pes)     pure $ Choice l (NE.zip ps es) resolveFlattenM (Interp l es)      = Interp l <$> traverse resolveFlattenM es@@ -302,8 +311,10 @@                 resolveFlattenM e'''         _ -> error "Ill-typed expression" resolveFlattenM e@Lambda{} = pure e-resolveFlattenM (Match _ e p e') = do-    modSt <- bindPattern p =<< resolveFlattenM e+resolveFlattenM (Match l e brs) = do+    eEval <- resolveFlattenM e+    (p, e') <- matchPattern l eEval (toList brs)+    modSt <- bindPattern p eEval     withSt modSt $         resolveFlattenM e' resolveFlattenM (Flatten l e) =@@ -336,8 +347,10 @@                 resolveExpressionM e'''         _ -> Apply l e'' <$> resolveExpressionM e' resolveExpressionM (Lambda l n ty e) = Lambda l n ty <$> resolveExpressionM e-resolveExpressionM (Match l e p e') =-    Match l <$> resolveExpressionM e <*> pure p <*> resolveExpressionM e'+resolveExpressionM (Match l e brs) = do+    let ps = fst <$> brs+    es <- traverse (resolveExpressionM . snd) brs+    Match l <$> resolveExpressionM e <*> pure (NE.zip ps es) resolveExpressionM (Flatten l e) =     Flatten l <$> resolveExpressionM e resolveExpressionM (Annot _ e _) = resolveExpressionM e

@@ -133,6 +133,9 @@ Bind :: { (Name AlexPosn, Expression AlexPosn) }      : Name Expression { ($1, $2) } +PatternBind :: { (Pattern AlexPosn, Expression AlexPosn) }+            : Pattern Expression { ($1, $2) }+ Interp :: { Expression AlexPosn } Interp : strChunk { StrChunk (loc $1) (str $1) }        | beginInterp Expression endInterp { $2 }@@ -141,6 +144,8 @@         : ident { PatternVar (loc $1) (ident $1) }         | lparen sepBy(Pattern,comma) rparen { PatternTuple $1 (NE.reverse $2) }         | underscore { Wildcard $1 }+        | tyIdent { PatternCons (loc $1) (tyIdent $1) }+        | lparen sepBy(Pattern,vbar) rparen { OrPattern $1 (NE.reverse $2) }  Expression :: { Expression AlexPosn }            : branch some(parens(WeightedLeaf)) { Choice $1 (NE.reverse $2) }@@ -154,7 +159,7 @@            | 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 }+           | match Expression some(brackets(PatternBind)) { Match $1 $2 (NE.reverse $3) }            | flatten Expression { Flatten $1 $2 }            | Expression colon Type { Annot $2 $1 $3 }            | tyIdent { Constructor (loc $1) (tyIdent $1) }

@@ -0,0 +1,23 @@+{-# LANGUAGE FlexibleContexts #-}++module Language.Dickinson.Pattern ( matchPattern+                                  ) where++import           Control.Monad.Except     (MonadError, throwError)+import           Data.List.NonEmpty       as NE+import           Language.Dickinson.Error+import           Language.Dickinson.Type++-- incoherency warning: or-patterns with wildcards & vars?+matches :: Pattern a -> Expression a -> Bool+matches Wildcard{} _                           = True+matches (PatternCons _ tn') (Constructor _ tn) = tn == tn'+matches PatternVar{} _                         = True+matches (PatternTuple _ ps) (Tuple _ es)       = and (NE.zipWith matches ps es) -- already check they're the same length during amalgamation+matches (OrPattern _ ps) e                     = any (`matches` e) ps+matches _ _                                    = False++matchPattern :: MonadError (DickinsonError a) m => a -> Expression a -> [(Pattern a, Expression a)] -> m (Pattern a, Expression a)+matchPattern l e (p:ps) | matches (fst p) e = pure p+                        | otherwise = matchPattern l e ps+matchPattern l e [] = throwError $ PatternFail l e

@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass    #-} {-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections     #-}  module Language.Dickinson.Rename ( renameDickinson                                  , renameDickinsonM@@ -17,7 +18,7 @@                                  ) where  import           Control.Composition           (thread)-import           Control.Monad                 ((<=<))+import           Control.Monad                 (forM, (<=<)) import           Control.Monad.Ext             (zipWithM) import           Control.Monad.State           (MonadState, State, runState) import           Data.Bifunctor                (second)@@ -141,6 +142,12 @@ renamePatternM (PatternVar l n) = do     (n', modR) <- withName n     pure (modR, PatternVar l n')+renamePatternM c@PatternCons{}     = pure (id, c) -- TODO: correct?+renamePatternM (OrPattern l ps) = do+    ps' <- traverse renamePatternM ps+    let modR = thread (fst <$> ps')+        ps'' = snd <$> ps'+    pure (modR, OrPattern l ps'')  -- | @since 0.1.1.0 renameExpressionM :: (MonadState s m, HasRenames s) => Expression a -> m (Expression a)@@ -160,10 +167,12 @@ 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+renameExpressionM (Match l e brs) = do     preE <- renameExpressionM e-    (modP, p') <- renamePatternM p-    Match l preE p' <$> withRenames modP (renameExpressionM e')+    brs' <- forM brs $ \(p, e') -> do+        (modP, p') <- renamePatternM p+        (p' ,) <$> withRenames modP (renameExpressionM e')+    pure $ Match l preE brs' renameExpressionM (Let p bs e) = do     newBs <- traverse withName (fst <$> bs)     let localRenames = snd <$> newBs

@@ -23,8 +23,8 @@ 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,-                                                     (<+>))+                                                     encloseSep, group, hardline, hsep, indent, lparen, parens, pipe,+                                                     rangle, rparen, tupled, vsep, (<+>)) import           Data.Text.Prettyprint.Doc.Ext      (hardSep, (<#*>), (<#>), (<^>)) import           Data.Text.Prettyprint.Doc.Internal (unsafeTextWithoutNewlines) import           GHC.Generics                       (Generic)@@ -49,10 +49,11 @@                        }                        deriving (Generic, NFData, Binary, Functor, Show) -data Pattern a = PatternVar a (Name a)-               | PatternTuple a (NonEmpty (Pattern a))-               | PatternCons a (TyName a)-               | Wildcard a+data Pattern a = PatternVar { patAnn :: a, patName :: Name a }+               | PatternTuple { patAnn :: a, patTup :: NonEmpty (Pattern a) }+               | PatternCons { patAnn :: a, patCons :: TyName a }+               | Wildcard { patAnn :: a }+               | OrPattern { patAnn :: a, patOr :: NonEmpty (Pattern a) }                deriving (Generic, NFData, Binary, Functor, Show, Data)  data Expression a = Literal { exprAnn :: a, litText :: T.Text }@@ -78,10 +79,9 @@                           }                   | 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+                  | Match { exprAnn    :: a+                          , exprMatch  :: Expression a+                          , exprBranch :: NonEmpty (Pattern a, Expression a)                           }                   | Flatten { exprAnn :: a, exprFlat :: Expression a }                   | Annot { exprAnn :: a@@ -115,7 +115,7 @@ 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 :: Pretty t => (t, Expression a) -> Doc b prettyLetLeaf (n, e) = group (brackets (pretty n <+> pretty e))  prettyChoiceBranch :: (Double, Expression a) -> Doc b@@ -141,6 +141,7 @@     pretty (PatternTuple _ ps) = tupled (toList (pretty <$> ps))     pretty Wildcard{}          = "_"     pretty (PatternCons _ c)   = pretty c+    pretty (OrPattern _ ps)    = group (encloseSep lparen rparen pipe (toList $ fmap pretty ps))  escReplace :: T.Text -> T.Text escReplace =@@ -167,7 +168,7 @@     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 (Match _ n brs)    = parens (":match" <+> pretty n <^> vsep (toList (fmap prettyLetLeaf brs)))     pretty (Flatten _ e)      = parens (":flatten" <^> pretty e)     pretty (Annot _ e ty)     = pretty e <+> colon <+> pretty ty     pretty (Constructor _ tn) = pretty tn

@@ -12,7 +12,7 @@                                     , HasTyEnv (..)                                     ) where -import           Control.Monad             (unless)+import           Control.Monad             (forM_, unless) import           Control.Monad.Except      (ExceptT, MonadError, runExceptT, throwError) import qualified Control.Monad.Ext         as Ext import           Control.Monad.State       (MonadState, State, evalState)@@ -49,7 +49,7 @@ 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+    traverse_ (tyAssert ty) es $> ty  type TypeM a = ExceptT (DickinsonError a) (State (TyEnv a)) @@ -79,6 +79,15 @@     | length ps == length tys = Ext.zipWithM_ bindPattern ps tys     | otherwise = throwError $ MalformedTuple l bindPattern (PatternTuple l _) _                = throwError $ MalformedTuple l+bindPattern p@(PatternCons l tn@(Name _ (Unique k) _)) ty = do+    tyEnv <- use tyEnvLens+    case IM.lookup k tyEnv of+        Just ty' ->+            unless (ty' == ty) $+                throwError (PatternTypeMismatch p ty ty')+        Nothing -> throwError $ UnfoundConstructor l tn+bindPattern (OrPattern _ ps) ty =+    traverse_ (\p -> bindPattern p ty) ps  -- run after global renamer typeOf :: (HasTyEnv s, MonadState (s a) m, MonadError (DickinsonError a) m) => Expression a -> m (DickinsonTy a)@@ -112,10 +121,13 @@     let ns = fst <$> bs     Ext.zipWithM_ tyInsert ns es'     typeOf e-typeOf (Match _ e p e') = do+typeOf (Match _ e brs@((_,e') :| _)) = do     ty <- typeOf e-    bindPattern p ty-    typeOf e'+    forM_ (fst <$> brs) $ \p ->+        bindPattern p ty+    res <- typeOf e'+    traverse_ (tyAssert res) (snd <$> brs)+    pure res typeOf (Flatten _ e) = typeOf e typeOf (Annot _ e ty) =     tyAssert ty e $> ty

@@ -24,6 +24,8 @@     , testCase "Should handle interpolated multiline strings" multiQuoteEval     , testCase "Should handle nested interpolations" multiInterpolatedNestedEval     , testCase "test/data/flattenLambda.dck" example+    , testCase "Match on ADT constructors" matchAdtEval+    , testCase "Work with or-patterns" orPatternEval     ]  forceResult :: a -> Assertion@@ -39,10 +41,10 @@ resolve = forceResult <=< resolveFile ["prelude", "lib"]  result :: FilePath -> Assertion-result = forceResult <=< evalFile ["prelude", "lib"]+result = forceResult <=< pipeline ["prelude", "lib"]  example :: Assertion-example = forceResult =<< evalFile ["examples"] "test/data/flattenLambda.dck"+example = forceResult =<< pipeline ["examples"] "test/data/flattenLambda.dck"  evalTo :: FilePath -> T.Text -> Assertion evalTo fp t = do@@ -55,6 +57,9 @@ scopeEval :: Assertion scopeEval = evalTo "test/demo/circular.dck" "a" +matchAdtEval :: Assertion+matchAdtEval = evalTo "test/eval/matchSex.dck" "Maxine is a good girl. She tries her best."+ higherOrderEval :: Assertion higherOrderEval = evalTo "test/data/higherOrder.dck" "It's me" @@ -63,3 +68,6 @@  multiInterpolatedNestedEval :: Assertion multiInterpolatedNestedEval = evalTo "test/data/interpolateNested.dck" "This is an interpolated string sort of."++orPatternEval :: Assertion+orPatternEval = evalTo "test/data/orPattern.dck" "hit"

@@ -35,6 +35,8 @@         , withDckFile "test/data/multiStr.dck"         , withDckFile "test/data/multiQuoteify.dck"         , withDckFile "test/data/lambdaMultiQuote.dck"+        , withDckFile "test/eval/matchSex.dck"+        , withDckFile "test/data/orPattern.dck"         ]  prettyBSL :: Dickinson a -> BSL.ByteString

@@ -11,16 +11,27 @@     , testCase "Currying" testCurry     , testCase "See ADTs" testAdtTc     , testCase "Currying (prelude functions)" testCurryPrelude+    , testCase "Works with :choice branches" testChoice+    , testCase "Checks ADTs and matches" testAdtMatch     ] +testChoice :: Assertion+testChoice = tcPlain "test/data/tyChoice.dck"+ testCurry :: Assertion-testCurry = tcFile [] "test/data/quoteify.dck"+testCurry = tcPlain "test/data/quoteify.dck"  testMatchTc :: Assertion-testMatchTc = tcFile [] "test/eval/match.dck"+testMatchTc = tcPlain "test/eval/match.dck" +testAdtMatch :: Assertion+testAdtMatch = tcPlain "test/eval/matchSex.dck"+ testAdtTc :: Assertion-testAdtTc = tcFile [] "test/data/adt.dck"+testAdtTc = tcPlain "test/data/adt.dck"  testCurryPrelude :: Assertion-testCurryPrelude = tcFile [] "prelude/curry.dck"+testCurryPrelude = tcPlain "prelude/curry.dck"++tcPlain :: FilePath -> Assertion+tcPlain = tcFile []

@@ -2,13 +2,13 @@  (:def fst   (:lambda xy (text, text)-    (:match xy (x, _)-      x)))+    (:match xy +      [(x, _) x])))  (:def snd   (:lambda xy (text, text)-    (:match xy (_,x)-      x)))+    (:match xy +      [(_,x) x])))  (:def greeter   (:lambda dog (text, text)

@@ -0,0 +1,17 @@+%-++tydecl case = Nominative | Accusative | Dative | Genitive++tydecl gender = Masculine | Feminine | Neuter++; shamelessly yote from http://www.oldenglishaerobics.net/resources/magic_letter.pdf+; third person neuter singular pronoun+(:def decline+  (:lambda c case+    (:match c+      [(Nominative|Accusative) "hit"]+      [Dative "his"]+      [Genitive "him"])))++(:def main+  $ decline Accusative)

@@ -0,0 +1,15 @@+%-++tydecl case = Nominative | Accusative | Dative | Genitive++tydecl gender = Masculine | Feminine | Neuter++(:def decline+  (:lambda c case+    (:match c+      [(Nominative|Accusative) "hit"]+      [Dative "his"]+      [Genitive "him"])))++(:def main+  ($ decline Accusative))

@@ -2,8 +2,8 @@  (:def fst   (:lambda xy (text, text)-    (:match xy (x, _)-      x)))+    (:match xy +      [(x, _) x])))  (:def dog   (:oneof

@@ -4,5 +4,5 @@   (:let     [xy "hello"]       (:lambda xy (text, text)-        (:match xy (x, _)-          x))))+        (:match xy +          [(x, _) x]))))

@@ -40,23 +40,28 @@                 , loc = ()                 }               }-            , exprPat = PatternTuple ()-              ( PatternVar ()-                ( Name+            , exprBranch =+              ( PatternTuple+                { patAnn = ()+                , patTup = PatternVar+                  { patAnn = ()+                  , patName = Name+                    { name = "x" :| []+                    , unique = Unique { unUnique = 7 }+                    , loc = ()+                    }+                  } :|+                  [ Wildcard { patAnn = () } ]+                }+              , Var+                { exprAnn = ()+                , exprVar = Name                   { name = "x" :| []                   , unique = Unique { unUnique = 7 }                   , loc = ()                   }-                ) :| [ Wildcard () ]-              )-            , exprIn = Var-              { exprAnn = ()-              , exprVar = Name-                { name = "x" :| []-                , unique = Unique { unUnique = 7 }-                , loc = ()                 }-              }+              ) :| []             }           }         }

@@ -0,0 +1,10 @@+%-++(:def weird+  (:oneof+    (|+      (:lambda x text+        "${x}, Alice"))+    (|+      (:lambda y text+        "${y}. Bob"))))

@@ -1,5 +1,5 @@ %-  (:def main-  (:match ("Hello", "World") (t, t)-    t))+  (:match ("Hello", "World") +    [(t, t) t]))

@@ -2,13 +2,13 @@  (:def fst   (:lambda xy (text, text)-    (:match xy (x, _)-      x)))+    (:match xy +      [(x, _) x])))  (:def snd   (:lambda xy (text, text)-    (:match xy (_, y)-      y)))+    (:match xy +      [(_, y) y])))  ; TODO tydecl sex = Boy | Girl 

@@ -0,0 +1,35 @@+%-++(:def address+  (:lambda dog sex+    (:match dog+      [Boy "boy"]+      [_ "girl"])))++tydecl sex = Boy | Girl++tydecl animal = Dog | Cat++(:def obliquePronoun+  (:lambda dog sex+    (:match dog+      [Boy "He"]+      [g "She"])))++(:def possPronoun+  (:lambda dog sex+    (:match dog+      [Girl "her"]+      [Boy "his"])))++; see https://github.com/vmchale/doggo-command-line/blob/master/src/main.rs+(:def greeter+  (:lambda dog (text, sex)+    (:match dog+      [(name, boyGirl)+        (:oneof+          (| "${name} is a good ${($ address boyGirl)}. ${($ obliquePronoun boyGirl)} tries ${($ possPronoun boyGirl)} best."))])))++(:def main+  ($ greeter ("Maxine", Girl)))+

@@ -0,0 +1,18 @@+%-++tydecl case = Nominative | Accusative | Dative | Genitive | Instrumental++tydecl gender = Masculine | Feminine | Neuter++tydecl number = Singular | Plural++; demonstrative pronouns+; "this" or "these"+(:def decline+  (:lambda x (case, gender, number)+    (:match x+      [((Nominative|Accusative), _, Plural) "þas"]+      [((Nominative|Accusative), Neuter, Singular) "þis"]+      [((Genitive|Dative|Instrumental), Feminine, Plural) "þisse"]+      [(Dative, (Masculine|Neuter), Singular) "þissum"]+      )))