language-dickinson 1.0.0.0 → 1.0.0.1
raw patch · 19 files changed
+225/−161 lines, 19 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +4/−0
- bench/Bench.hs +10/−2
- examples/fortune.dck +1/−0
- language-dickinson.cabal +2/−1
- lib/adjectives.dck +1/−0
- lib/color.dck +104/−104
- lib/noun.dck +21/−9
- src/Control/Monad/Ext.hs +1/−1
- src/Language/Dickinson/Eval.hs +1/−0
- src/Language/Dickinson/Pipeline.hs +7/−2
- src/Language/Dickinson/Type.hs +4/−2
- src/Language/Dickinson/TypeCheck.hs +9/−4
- test/Eval.hs +1/−0
- test/Golden.hs +2/−1
- test/data/color.dck +0/−2
- test/data/orPattern.pretty +0/−15
- test/eval/orExample.dck +0/−18
- test/examples/declension.dck +28/−0
- test/examples/quote.dck +29/−0
CHANGELOG.md view
@@ -1,5 +1,9 @@ # dickinson +# 1.0.0.1++ * Fix bug when calling `:flatten` on tuples.+ # 1.0.0.0 * Fix bug in typechecker
bench/Bench.hs view
@@ -11,6 +11,7 @@ import Language.Dickinson.Check.Duplicate import Language.Dickinson.Check.Internal import Language.Dickinson.Check.Scope+import Language.Dickinson.Error import Language.Dickinson.Eval import Language.Dickinson.File import Language.Dickinson.Lexer@@ -62,9 +63,12 @@ , benchPipeline "examples/fortune.dck" , benchPipeline "examples/catherineOfSienaBot.dck" ]- , bgroup "validate"- [ benchValidate "test/eval/orExample.dck"+ , bgroup "fileValidate"+ [ benchValidate "test/examples/declension.dck" ]+ , env amalDecline $ \d ->+ bgroup "validate"+ [ bench "test/examples/declension.dck" $ nf validateRun d ] , env amalFortune $ \f -> bgroup "typecheck" [ bench "examples/fortune.dck" $ nf tyRun f ]@@ -95,6 +99,7 @@ amalgamated = (,) <$> amalgamateRename [] "examples/shakespeare.dck" <*> amalgamateRename [] "examples/catherineOfSienaBot.dck"+ amalDecline = amalgamateRename [] "test/examples/declension.dck" plainExpr :: (UniqueCtx, Dickinson a) -> Dickinson a plainExpr = fst . uncurry renameDickinson@@ -105,3 +110,6 @@ maxUniqueDickinson :: Dickinson AlexPosn -> Int maxUniqueDickinson (Dickinson _ ds) = maximum (maxUniqueDeclaration <$> ds)++validateRun :: [Declaration a] -> Either (DickinsonError a) ()+validateRun = runTypeM . validateDecl
examples/fortune.dck view
@@ -26,6 +26,7 @@ (| "Correction is mercy.") (| "Guilt redeems, not love.") (| "There is no such thing as metaphors.")+ (| "Compliments turn to insults when you're insolent enough to believe your input matters.") (| "Excess is a sin.") (| "Hunger is hope.") (| "Spurn your family.")
language-dickinson.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: language-dickinson-version: 1.0.0.0+version: 1.0.0.1 license: BSD3 license-file: LICENSE copyright: Copyright: (c) 2020 Vanessa McHale@@ -26,6 +26,7 @@ test/eval/*.dck test/error/*.dck test/demo/*.dck+ test/examples/*.dck examples/*.dck extra-doc-files:
lib/adjectives.dck view
@@ -7,6 +7,7 @@ (| "plain") (| "bromide") (| "banal")+ (| "redolent") (| "pithy") (| "orotund") (| "stentorian")))
lib/color.dck view
@@ -2,107 +2,107 @@ %- (:def color- (:oneof- (| "aubergine")- (| "cerulean")- (| "azure")- (| "melon")- (| "ochre")- (| "green")- (| "emerald")- (| "gold")- (| "silver")- (| "brown")- (| "smaragdine")- (| "black")- (| "white")- (| "yellow")- (| "highlighter")- (| "prasine")- (| "sand")- (| "ebony")- (| "purple")- (| "violet")- (| "lilac")- (| "puce")- (| "alabaster")- (| "amber")- (| "apricot")- (| "lime")- (| "umber")- (| "aquamarine")- (| "turquoise")- (| "ash")- (| "roan")- (| "gray")- (| "viridian")- (| "blue")- (| "sky blue")- (| "baby pink")- (| "coffee")- (| "coral")- (| "pink")- (| "blood orange")- (| "blush")- (| "maroon")- (| "verdant")- (| "lavender")- (| "navy blue")- (| "bubble gum pink")- (| "tyrian purple")- (| "cobalt blue")- (| "viridescent")- (| "byzantium")- (| "cadmium yellow")- (| "canary yellow")- (| "crimson")- (| "carmine red")- (| "charcoal")- (| "chartreuse")- (| "cherry red")- (| "red")- (| "chlorophyll")- (| "cinnabar")- (| "claret")- (| "citron")- (| "burgundy")- (| "coke white")- (| "copper")- (| "coquelicot")- (| "cordovan")- (| "cyan")- (| "magenta")- (| "cream")- (| "grape")- (| "cyclamen")- (| "khaki")- (| "orange")- (| "salmon")- (| "cerise")- (| "fuchsia")- (| "mauve")- (| "saffron")- (| "tumeric yellow")- (| "ruby red")- (| "ecru")- (| "mahogany")- (| "rose")- (| "cardinal red")- (| "vermilion")- (| "auburn")- (| "blood red")- (| "banana yellow")- (| "feldgrau")- (| "firehouse red")- (| "brick red")- (| "flax")- (| "russet")- (| "flavescent")- (| "buff")- (| "ivory")- (| "xanthous")- (| "lemon")- (| "fluorescent yellow")- (| "neon green")- (| "fluorescent pink")- (| "fulvous")))+ (:oneof+ (| "aubergine")+ (| "cerulean")+ (| "azure")+ (| "melon")+ (| "ochre")+ (| "green")+ (| "emerald")+ (| "gold")+ (| "silver")+ (| "brown")+ (| "smaragdine")+ (| "black")+ (| "white")+ (| "yellow")+ (| "highlighter")+ (| "prasine")+ (| "sand")+ (| "ebony")+ (| "purple")+ (| "violet")+ (| "lilac")+ (| "puce")+ (| "alabaster")+ (| "amber")+ (| "apricot")+ (| "lime")+ (| "umber")+ (| "aquamarine")+ (| "turquoise")+ (| "ash")+ (| "roan")+ (| "gray")+ (| "viridian")+ (| "blue")+ (| "sky blue")+ (| "baby pink")+ (| "coffee")+ (| "coral")+ (| "pink")+ (| "blood orange")+ (| "blush")+ (| "maroon")+ (| "verdant")+ (| "lavender")+ (| "navy blue")+ (| "bubble gum pink")+ (| "tyrian purple")+ (| "cobalt blue")+ (| "viridescent")+ (| "byzantium")+ (| "cadmium yellow")+ (| "canary yellow")+ (| "crimson")+ (| "carmine red")+ (| "charcoal")+ (| "chartreuse")+ (| "cherry red")+ (| "red")+ (| "chlorophyll")+ (| "cinnabar")+ (| "claret")+ (| "citron")+ (| "burgundy")+ (| "coke white")+ (| "copper")+ (| "coquelicot")+ (| "cordovan")+ (| "cyan")+ (| "magenta")+ (| "cream")+ (| "grape")+ (| "cyclamen")+ (| "khaki")+ (| "orange")+ (| "salmon")+ (| "cerise")+ (| "fuchsia")+ (| "mauve")+ (| "saffron")+ (| "tumeric yellow")+ (| "ruby red")+ (| "ecru")+ (| "mahogany")+ (| "rose")+ (| "cardinal red")+ (| "vermilion")+ (| "auburn")+ (| "blood red")+ (| "banana yellow")+ (| "feldgrau")+ (| "firehouse red")+ (| "brick red")+ (| "flax")+ (| "russet")+ (| "flavescent")+ (| "buff")+ (| "ivory")+ (| "xanthous")+ (| "lemon")+ (| "fluorescent yellow")+ (| "neon green")+ (| "fluorescent pink")+ (| "fulvous")))
lib/noun.dck view
@@ -1,12 +1,24 @@ %- -(:def noun+(:def rhetoricalDevice (:oneof- (| "valetudinarian")- (| "heliophagy")- (| "valedictorian")- (| "apothegm")- (| "apotheosis")- (| "aphelion")- (| "perihelion")- (| "folderol")))+ (| "stichomythia")+ (| "antanaclasis")+ (| "metaphor")+ (| "simile")+ (| "alliteration")+ (| "synecdoche")+ (| "metonymy")))++(:def noun+ (:flatten+ (:oneof+ (| rhetoricalDevice)+ (| "valetudinarian")+ (| "heliophagy")+ (| "valedictorian")+ (| "apothegm")+ (| "apotheosis")+ (| "aphelion")+ (| "perihelion")+ (| "folderol"))))
src/Control/Monad/Ext.hs view
@@ -7,7 +7,7 @@ import qualified Data.List.NonEmpty as NE zipWithM :: (Applicative m) => (a -> b -> m c) -> NonEmpty a -> NonEmpty b -> m (NonEmpty c)-zipWithM f xs ys = sequenceA (NE.zipWith f xs ys)+zipWithM f xs ys = sequenceA (NE.zipWith f xs ys) zipWithM_ :: (Applicative m) => (a -> b -> m c) -> NonEmpty a -> NonEmpty b -> m () zipWithM_ f xs ys = sequenceA_ (NE.zipWith f xs ys)
src/Language/Dickinson/Eval.hs view
@@ -258,6 +258,7 @@ 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+mapChoice f (Tuple l es) = Tuple l (mapChoice f <$> es) mapChoice _ _ = error "Internal error in function mapChoice." setFrequency :: NonEmpty (Double, Expression a) -> NonEmpty (Double, Expression a)
src/Language/Dickinson/Pipeline.hs view
@@ -2,6 +2,7 @@ module Language.Dickinson.Pipeline ( checkEvalM , format+ , validateDecl ) where import Control.Exception.Value (eitherThrow)@@ -19,9 +20,13 @@ checkEvalM :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => [Declaration a] -> m T.Text checkEvalM ds = do- maybeThrow $ checkScope ds- tyTraverse ds+ validateDecl ds evalDickinsonAsMain ds format :: BSL.ByteString -> T.Text format = prettyText . eitherThrow . parse++validateDecl :: (HasTyEnv s, MonadState (s a) m, MonadError (DickinsonError a) m) => [Declaration a] -> m ()+validateDecl d = do+ maybeThrow $ checkScope d+ tyTraverse d
src/Language/Dickinson/Type.hs view
@@ -116,7 +116,9 @@ pretty (Dickinson is ds) = concatWith (\x y -> x <> hardline <> hardline <> y) (fmap pretty is <> ["%-"] <> fmap pretty ds) prettyLetLeaf :: Pretty t => (t, Expression a) -> Doc b-prettyLetLeaf (n, e) = group (brackets (pretty n <+> pretty e))+prettyLetLeaf (n, e@MultiInterp{}) = group (brackets (pretty n <^> pretty e))+prettyLetLeaf (n, e@Choice{}) = group (brackets (pretty n <^> pretty e))+prettyLetLeaf (n, e) = group (brackets (pretty n <+> pretty e)) prettyChoiceBranch :: (Double, Expression a) -> Doc b prettyChoiceBranch (d, e) = parens (pipe <+> pretty d <+> pretty e)@@ -169,7 +171,7 @@ pretty StrChunk{} = error "Internal error: naked StrChunk" pretty (Tuple _ es) = tupled (toList (pretty <$> es)) pretty (Match _ n brs) = parens (":match" <+> pretty n <^> vsep (toList (fmap prettyLetLeaf brs)))- pretty (Flatten _ e) = parens (":flatten" <^> pretty e)+ pretty (Flatten _ e) = group (parens (":flatten" <^> pretty e)) pretty (Annot _ e ty) = pretty e <+> colon <+> pretty ty pretty (Constructor _ tn) = pretty tn
src/Language/Dickinson/TypeCheck.hs view
@@ -8,6 +8,8 @@ , tyTraverse , tyRun , emptyTyEnv+ , runTypeM+ , TypeM , TyEnv , HasTyEnv (..) ) where@@ -44,7 +46,7 @@ tyEnvLens f s = fmap (\x -> s { unTyEnv = x }) (f (unTyEnv s)) -- id tyInsert :: (HasTyEnv s, MonadState (s a) m) => Name a -> DickinsonTy a -> m ()-tyInsert (Name _ (Unique i) _) ty = modifying tyEnvLens (IM.insert i ty)+tyInsert (Name _ (Unique i) _) ty = {-# SCC "tyInsert" #-} modifying tyEnvLens (IM.insert i ty) tyMatch :: (HasTyEnv s, MonadState (s a) m, MonadError (DickinsonError a) m) => NonEmpty (Expression a) -> m (DickinsonTy a) tyMatch (e :| es) = do@@ -54,8 +56,11 @@ type TypeM a = ExceptT (DickinsonError a) (State (TyEnv a)) tyRun :: [Declaration a] -> Either (DickinsonError a) ()-tyRun = flip evalState emptyTyEnv . runExceptT . (tyTraverse :: [Declaration a] -> TypeM a ())+tyRun = runTypeM . tyTraverse +runTypeM :: TypeM a x -> Either (DickinsonError a) x+runTypeM = flip evalState emptyTyEnv . runExceptT+ emptyTyEnv :: TyEnv a emptyTyEnv = TyEnv IM.empty @@ -94,7 +99,7 @@ typeOf (Literal l _) = pure (TyText l) typeOf (StrChunk l _) = pure (TyText l) typeOf (Choice _ brs) = tyMatch (snd <$> brs)-typeOf (Var l n@(Name _ (Unique i) _)) = do+typeOf (Var l n@(Name _ (Unique i) _)) = do tyEnv <- use tyEnvLens case IM.lookup i tyEnv of Just ty -> pure ty@@ -124,7 +129,7 @@ typeOf (Match _ e brs@((_,e') :| _)) = do ty <- typeOf e forM_ (fst <$> brs) $ \p ->- bindPattern p ty+ {-# SCC "bindPattern" #-} bindPattern p ty res <- typeOf e' traverse_ (tyAssert res) (snd <$> brs) pure res
test/Eval.hs view
@@ -26,6 +26,7 @@ , testCase "test/data/flattenLambda.dck" example , testCase "Match on ADT constructors" matchAdtEval , testCase "Work with or-patterns" orPatternEval+ , resultCase "test/examples/quote.dck" ] forceResult :: a -> Assertion
test/Golden.hs view
@@ -36,7 +36,8 @@ , withDckFile "test/data/multiQuoteify.dck" , withDckFile "test/data/lambdaMultiQuote.dck" , withDckFile "test/eval/matchSex.dck"- , withDckFile "test/data/orPattern.dck"+ , withDckFile "test/examples/quote.dck"+ , withDckFile "test/examples/declension.dck" ] prettyBSL :: Dickinson a -> BSL.ByteString
− test/data/color.dck
@@ -1,2 +0,0 @@-(:def color- ("color"))
− test/data/orPattern.pretty
@@ -1,15 +0,0 @@-%---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))
− test/eval/orExample.dck
@@ -1,18 +0,0 @@-%---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"]- )))
+ test/examples/declension.dck view
@@ -0,0 +1,28 @@+; http://www.oldenglishaerobics.net/resources/magic_letter.pdf++%-++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, Masculine, Singular) "þes"]+ [(Accusative, Masculine, Singular) "þisne"]+ [(Genitive, (Masculine|Neuter), Singular) "þisses"]+ [(Dative, (Masculine|Neuter), Singular) "þissum"]+ [(Instrumental, (Masculine|Neuter), Singular) "þys"]+ [((Nominative|Accusative), Neuter, Singular) "þis"]+ [(Nominative, Feminine, Singular) "þeos"]+ [(Accusative, Feminine, Singular) "þas"]+ [((Genitive|Dative|Instrumental), Feminine, Singular) "þisse"]+ [((Nominative|Accusative), _, Plural) "þas"]+ [(Genitive, _, Plural) "þissa"]+ [(Dative, _, Plural) "þissum"]+ )))
+ test/examples/quote.dck view
@@ -0,0 +1,29 @@+%-++(:def fionaAppleQuote+ (:oneof+ (| + '''+ "You're more likely to get cut with a dull tool than a sharp one."+ ''')+ (|+ '''+ "You forgot the difference between equanimity and passivity."+ ''')))++(:def quote+ (:oneof+ (| ("« Le beau est ce qu'on désire sans vouloir le manger. »", "Simone Weil"))+ (| (fionaAppleQuote, "Fiona Apple"))))++(:def formatQuote+ (:lambda q (text, text)+ (:match q+ [(quote, name)+ '''+ ${quote}+ — ${name}+ '''])))++(:def main+ $ formatQuote (:flatten quote))