language-dickinson 0.1.0.0 → 0.1.0.1
raw patch · 53 files changed
+573/−200 lines, 53 filesdep ~basePVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
Dependency ranges changed: base
API changes (from Hackage documentation)
+ Language.Dickinson: MultiInterp :: a -> [Expression a] -> Expression a
+ Language.Dickinson: [exprMultiInterp] :: Expression a -> [Expression a]
Files
- CHANGELOG.md +9/−0
- README.md +1/−1
- bench/Bench.hs +2/−0
- examples/fionaBot.dck +12/−0
- examples/fortune.dck +4/−0
- examples/hotTake.dck +0/−67
- language-dickinson.cabal +9/−3
- man/emd.1 +2/−0
- public/Language/Dickinson.hs +1/−1
- run/Main.hs +0/−2
- run/REPL.hs +10/−8
- run/REPL/Completions.hs +57/−0
- src/Language/Dickinson/Check.hs +16/−13
- src/Language/Dickinson/Check/Internal.hs +2/−0
- src/Language/Dickinson/DuplicateCheck.hs +16/−17
- src/Language/Dickinson/Error.hs +3/−3
- src/Language/Dickinson/Eval.hs +50/−15
- src/Language/Dickinson/File.hs +4/−0
- src/Language/Dickinson/Lexer.x +53/−34
- src/Language/Dickinson/Lib/Get.hs +1/−1
- src/Language/Dickinson/Name.hs +1/−0
- src/Language/Dickinson/Parser.y +24/−0
- src/Language/Dickinson/Rename.hs +8/−2
- src/Language/Dickinson/ScopeCheck.hs +20/−2
- src/Language/Dickinson/Type.hs +29/−21
- src/Language/Dickinson/TypeCheck.hs +7/−3
- test/Eval.hs +12/−3
- test/Golden.hs +2/−0
- test/Spec.hs +6/−0
- test/data/adt.dck +2/−2
- test/data/adt.pretty +2/−2
- test/data/lexDollarSign.dck +11/−0
- test/data/lexDollarSign.pretty +11/−0
- test/data/multiStr.dck +16/−0
- test/data/multiStr.pretty +15/−0
- test/demo/animal.dck +6/−0
- test/demo/circular.dck +7/−0
- test/demo/improbableScope.dck +13/−0
- test/demo/mutual.dck +14/−0
- test/demo/sillyOption.dck +6/−0
- test/demo/tyAnnot.dck +6/−0
- test/error/constructorScope.dck +6/−0
- test/error/double.dck +7/−0
- test/error/illTyped.dck +8/−0
- test/error/lexErr.dck +4/−0
- test/error/tyConsDouble.dck +5/−0
- test/error/tyDouble.dck +5/−0
- test/error/tyScope.dck +6/−0
- test/eval/choice.dck +6/−0
- test/eval/context.dck +15/−0
- test/eval/local.dck +9/−0
- test/eval/main.dck +5/−0
- test/eval/match.dck +27/−0
CHANGELOG.md view
@@ -1,5 +1,14 @@ # dickinson +## 0.1.0.1++ * Fix source distribution so nix builds it automatically+ * Fix a bug in the evaluator that caused valid expressions to be rejected+ in the REPL+ * Show an error in the REPL when trying to `:view` a name not in scope.+ * Throw error when tuple pattern doesn't match type of expression+ * Fix `$` within strings so it doesn't need to be escaped+ ## 0.1.0.0 Initial release
README.md view
@@ -32,7 +32,7 @@ ### Examples -An riff on the Unix fortune program is available+A riff on the Unix fortune program is available [here](https://github.com/vmchale/dickinson/blob/master/examples/fortune.dck). Try
bench/Bench.hs view
@@ -55,9 +55,11 @@ ] , bgroup "pipeline" [ bench "examples/shakespeare.dck" $ nfIO (pipeline [] "examples/shakespeare.dck")+ , 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") ] ]
+ examples/fionaBot.dck view
@@ -0,0 +1,12 @@+%-++(: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.")+ (| "Hunger hurts but starving works.")+ (| "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")))++(:def main+ fiona)
examples/fortune.dck view
@@ -19,8 +19,12 @@ (| "Wash your hands with soap and water for at least 20 seconds.") (| "Cleanliness is next to godliness.") (| "Do not complain.")+ (| "Guilt redeems, not love.") (| "There is no such thing as metaphors.") (| "Excess is a sin.")+ (| "Spurn your family.")+ (| "Salvation is finality.")+ (| "Love animals.") (| "Sex wastes the male body.") (| "Cultivate weakness.") (| "Beauty is a moral imperative.")
− examples/hotTake.dck
@@ -1,67 +0,0 @@-%---(:def unpopularize- (:lambda opinion text- (:branch- (| 0.9 opinion)- (| 0.1 "Unpopular opinion: ${opinion}"))))--(:def slur- (:let- [badWord- (:oneof- (| "crackhead")- (| "'Privileged'"))]- "${badWord} is a slur"))--; queering/ _ is queer--(:def normalize- (:let- [norm- (:oneof- (| "bidets")- (| "breastfeeding your boyfriend")- (| "not wearing deodorant")- (| "being a virgin")- (| "DWIs"))]- "Normalize ${norm}"))--(:def abolish- (:let- [target- (:oneof- (| "credit scores")- (| "the stock market")- (| "parking tickets"))]- "Abolish ${target}"))--(:def problematic- (:let- [bad- (:oneof- (| "Grades are")- (| "The GRE is")- (| "Masks are"))]- "${bad} problematic"))--(:def toxic- (:let- [badThing- (:oneof- (| "brushing your teeth is")- (| "masculinity is")- (| "museums are"))]- "${badThing} toxic."))--; cancel _--(:def main- $ unpopularize- (:flatten- (:oneof- (| normalize)- (| toxic)- (| problematic)- (| slur)- (| abolish))))
language-dickinson.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: language-dickinson-version: 0.1.0.0+version: 0.1.0.1 license: BSD3 license-file: LICENSE copyright: Copyright: (c) 2020 Vanessa McHale@@ -23,6 +23,9 @@ test/data/*.pretty test/data/*.dck test/data/*.rename+ test/eval/*.dck+ test/error/*.dck+ test/demo/*.dck examples/*.dck extra-doc-files:@@ -98,8 +101,8 @@ default-language: Haskell2010 other-extensions: DeriveAnyClass DeriveFunctor DeriveGeneric FlexibleContexts- GeneralizedNewtypeDeriving OverloadedStrings StandaloneDeriving- TupleSections+ FlexibleInstances GeneralizedNewtypeDeriving OverloadedStrings+ StandaloneDeriving TupleSections ghc-options: -Wall -O2 build-depends:@@ -146,8 +149,10 @@ other-modules: REPL REPL.Save+ REPL.Completions default-language: Haskell2010+ other-extensions: FlexibleContexts OverloadedStrings TupleSections ghc-options: -Wall -rtsopts -with-rtsopts=-A4M build-depends: base -any,@@ -192,6 +197,7 @@ TypeCheck default-language: Haskell2010+ other-extensions: OverloadedStrings ghc-options: -threaded -rtsopts "-with-rtsopts=-N -K1K" -Wall build-depends: base -any,
man/emd.1 view
@@ -41,6 +41,8 @@ \f[B]:t\f[R] \f[B]:type\f[R] - Display the type of an expression .PP \f[B]:v\f[R] \f[B]:view\f[R] - Show the definition of a name+.PP+\f[B]:h\f[R] \f[B]:help\f[R] - Display help .SH OPTIONS .TP \f[B]-h\f[R] \f[B]--help\f[R]
public/Language/Dickinson.hs view
@@ -1,4 +1,4 @@--- | This modules contains some bits and pieces to work with Dickinson code.+-- | This module contains some bits and pieces to work with Dickinson code. module Language.Dickinson ( -- * Parser parse , ParseError (..)
run/Main.hs view
@@ -19,8 +19,6 @@ main :: IO () main = run =<< execParser wrapper --- TODO: cache/"compile"?- act :: Parser Act act = hsubparser (command "run" (info runP (progDesc "Execute a file"))
run/REPL.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-} module REPL ( dickinsonRepl ) where@@ -33,8 +34,10 @@ import Language.Dickinson.Unique import Lens.Micro (_1) import Lens.Micro.Mtl (use, (.=))+import REPL.Completions import REPL.Save-import System.Console.Haskeline (InputT, defaultSettings, getInputLine, historyFile, runInputT)+import System.Console.Haskeline (InputT, completeFilename, defaultSettings, fallbackCompletion,+ getInputLine, historyFile, runInputT, setComplete) import System.Directory (getHomeDirectory) import System.FilePath ((</>)) import System.Random (newStdGen, randoms)@@ -49,7 +52,8 @@ g <- newStdGen emdDir <- (</> ".emd_history") <$> getHomeDirectory let initSt = EvalSt (randoms g) mempty initRenames mempty alexInitUserState emptyTyEnv- let emdSettings = defaultSettings { historyFile = Just emdDir }+ let myCompleter = emdCompletions `fallbackCompletion` completeFilename+ let emdSettings = setComplete myCompleter $ defaultSettings { historyFile = Just emdDir } flip evalStateT initSt $ runInputT emdSettings x loop :: Repl AlexPosn ()@@ -65,7 +69,6 @@ Just (":r":fp:_) -> loadReplSt fp *> loop Just (":type":e:_) -> typeExpr e *> loop Just (":t":e:_) -> typeExpr e *> loop- Just (":v":n:_) -> bindDisplay (T.pack n) *> loop Just (":view":n:_) -> bindDisplay (T.pack n) *> loop Just [":q"] -> pure () Just [":quit"] -> pure ()@@ -85,8 +88,8 @@ , helpOption ":load, :l" "<file>" "Load file contents" , helpOption ":r" "<file>" "Restore REPL state from a file" , helpOption ":type, :t" "<expression>" "Display the type of an expression"- , helpOption ":view, :v" "<name>" "Show the value of a name"- , helpOption ":quite, :q" "" "Quit REPL"+ , helpOption ":view" "<name>" "Show the value of a name"+ , helpOption ":quit, :q" "" "Quit REPL" , helpOption ":list" "" "List all names that are in scope" ] @@ -114,7 +117,7 @@ listNames = liftIO . traverse_ TIO.putStrLn =<< names names :: Repl AlexPosn [T.Text]-names = lift $ gets (M.keys . topLevel)+names = lift $ namesState bindDisplay :: T.Text -> Repl AlexPosn () bindDisplay t = do@@ -126,7 +129,7 @@ case IM.lookup i exprs of Just e -> liftIO $ putDoc (pretty e <> hardline) Nothing -> error "Internal error."- Nothing -> pure () -- TODO: error+ Nothing -> liftIO $ putDoc $ (<> hardline) $ pretty (NoText t :: DickinsonError AlexPosn) setSt :: AlexUserState -> Repl AlexPosn () setSt newSt = lift $ do@@ -183,7 +186,6 @@ putErr (Right x) f = f x putErr (Left y) _ = liftIO $ putDoc (pretty y <> hardline) --- TODO: check loadFile :: FilePath -> Repl AlexPosn () loadFile fp = do pathMod <- liftIO defaultLibPath
+ run/REPL/Completions.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE TupleSections #-}++module REPL.Completions ( emdCompletions+ , namesState+ ) where++import Control.Monad.State (StateT, gets)+import qualified Data.Map as M+import qualified Data.Text as T+import Language.Dickinson.Eval+import System.Console.Haskeline (Completion, CompletionFunc, simpleCompletion)++namesState :: StateT (EvalSt a) IO [T.Text]+namesState = gets (M.keys . topLevel)++namesStr :: StateT (EvalSt a) IO [String]+namesStr = fmap T.unpack <$> gets (M.keys . topLevel)++cyclicSimple :: [String] -> [Completion]+cyclicSimple [] = []+cyclicSimple xs = cycle $ fmap simpleCompletion xs++emdCompletions :: CompletionFunc (StateT (EvalSt a) IO)+emdCompletions (":","") = pure (":", cyclicSimple [ "help", "h", "save", "load", "l", "r", "type", "t", "view", "quit", "q", "list" ])+emdCompletions ("l:", "") = pure ("l:", cyclicSimple [ "oad", "", "ist" ])+emdCompletions ("ol:", "") = pure ("ol:", [simpleCompletion "ad"])+emdCompletions ("aol:", "") = pure ("aol:", [simpleCompletion "d"])+emdCompletions ("daol:", "") = pure ("daol:", [simpleCompletion ""])+emdCompletions ("il:", "") = pure ("il:", [simpleCompletion "st"])+emdCompletions ("sil:", "") = pure ("sil:", [simpleCompletion "t"])+emdCompletions ("tsil:", "") = pure ("tsil:", [simpleCompletion ""])+emdCompletions ("h:", "") = pure ("h:", cyclicSimple ["elp", ""])+emdCompletions ("eh:", "") = pure ("eh:", [simpleCompletion "lp"])+emdCompletions ("leh:", "") = pure ("leh:", [simpleCompletion "p"])+emdCompletions ("pleh:", "") = pure ("pleh:", [simpleCompletion ""])+emdCompletions ("s:", "") = pure ("s:", [simpleCompletion "ave"])+emdCompletions ("as:", "") = pure ("as:", [simpleCompletion "ve"])+emdCompletions ("vas:", "") = pure ("vas:", [simpleCompletion "e"])+emdCompletions ("evas:", "") = pure ("evas:", [simpleCompletion ""])+emdCompletions ("r:", "") = pure ("r:", [simpleCompletion ""])+emdCompletions ("t:", "") = pure ("t:", cyclicSimple ["ype", ""])+emdCompletions ("yt:", "") = pure ("yt:", [simpleCompletion "pe"])+emdCompletions ("pyt:", "") = pure ("pyt:", [simpleCompletion "e"])+emdCompletions ("epyt:", "") = pure ("epyt:", [simpleCompletion ""])+emdCompletions ("v:", "") = pure ("v:", [simpleCompletion "iew"])+emdCompletions ("iv:", "") = pure ("iv:", [simpleCompletion "ew"])+emdCompletions ("eiv:", "") = pure ("eiv:", [simpleCompletion "w"])+emdCompletions ("weiv:", "") = pure ("weiv:", [simpleCompletion ""])+emdCompletions ("q:", "") = pure ("q:", cyclicSimple ["uit", ""])+emdCompletions ("uq:", "") = pure ("uq:", [simpleCompletion "it"])+emdCompletions ("iuq:", "") = pure ("iuq:", [simpleCompletion "t"])+emdCompletions ("tiuq:", "") = pure ("tiuq:", [simpleCompletion ""])+emdCompletions (" weiv:", "") = do { ns <- namesStr ; pure (" weiv:", cyclicSimple ns) } -- TODO: when it matches part of the identifiers!+emdCompletions (" epyt:", "") = do { ns <- namesStr ; pure (" epyt:", cyclicSimple ns) }+emdCompletions (" t:", "") = do { ns <- namesStr ; pure (" t:", cyclicSimple ns) }+emdCompletions ("", "") = ("",) . cyclicSimple <$> namesStr+emdCompletions _ = pure (undefined, [])
src/Language/Dickinson/Check.hs view
@@ -16,7 +16,8 @@ announce _ = Nothing -- runs after the renamer--- | Checks that there are not name clashes at the top level.+-- | Checks that there are not name clashes at the top level or within let+-- bindings. checkMultiple :: [Declaration a] -> Maybe (DickinsonWarning a) checkMultiple ds = checkNames (mapMaybe defNameM ds)@@ -35,19 +36,21 @@ collectConstructors (TyDecl _ _ cs) = toList cs checkMultipleExpr :: Expression a -> Maybe (DickinsonWarning a)-checkMultipleExpr Var{} = Nothing-checkMultipleExpr Literal{} = Nothing-checkMultipleExpr StrChunk{} = Nothing-checkMultipleExpr (Interp _ es) = foldMapAlternative checkMultipleExpr es-checkMultipleExpr (Apply _ e e') = checkMultipleExpr e <|> checkMultipleExpr e'-checkMultipleExpr (Match _ e _ e') = checkMultipleExpr e <|> checkMultipleExpr e'-checkMultipleExpr (Choice _ brs) = foldMapAlternative (checkMultipleExpr . snd) brs-checkMultipleExpr (Concat _ es) = foldMapAlternative checkMultipleExpr es-checkMultipleExpr (Tuple _ es) = foldMapAlternative checkMultipleExpr es-checkMultipleExpr (Lambda _ _ _ e) = checkMultipleExpr e-checkMultipleExpr (Flatten _ e) = checkMultipleExpr e-checkMultipleExpr (Let _ bs e) =+checkMultipleExpr Var{} = Nothing+checkMultipleExpr Literal{} = Nothing+checkMultipleExpr StrChunk{} = Nothing+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 (Choice _ brs) = foldMapAlternative (checkMultipleExpr . snd) brs+checkMultipleExpr (Concat _ es) = foldMapAlternative checkMultipleExpr es+checkMultipleExpr (Tuple _ es) = foldMapAlternative checkMultipleExpr es+checkMultipleExpr (Lambda _ _ _ e) = checkMultipleExpr e+checkMultipleExpr (Flatten _ e) = checkMultipleExpr e+checkMultipleExpr (Let _ bs e) = checkNames (toList $ fmap fst bs) <|> foldMapAlternative checkMultipleExpr (snd <$> bs) <|> checkMultipleExpr e checkMultipleExpr (Annot _ e _) = checkMultipleExpr e+checkMultipleExpr Constructor{} = Nothing
src/Language/Dickinson/Check/Internal.hs view
@@ -11,6 +11,7 @@ import Lens.Micro.Mtl (use) -- TODO: sanity check for the lexer+-- | Sanity check for the renamer. sanityCheck :: (HasRenames s, MonadState s m) => [Declaration a] -> m () sanityCheck d = do storedMax <- use (rename.maxLens)@@ -35,6 +36,7 @@ maxUniqueExpression StrChunk{} = 0 maxUniqueExpression (Var _ (Name _ (Unique i) _)) = i maxUniqueExpression (Choice _ pes) = maximum (maxUniqueExpression . snd <$> pes)+maxUniqueExpression (MultiInterp _ es) = maximum (fmap maxUniqueExpression es) maxUniqueExpression (Interp _ es) = maximum (fmap maxUniqueExpression es) maxUniqueExpression (Concat _ es) = maximum (fmap maxUniqueExpression es) maxUniqueExpression (Apply _ e e') = max (maxUniqueExpression e) (maxUniqueExpression e')
src/Language/Dickinson/DuplicateCheck.hs view
@@ -16,7 +16,7 @@ where announce (_:(l, y):_) = Just $ DuplicateStr l y announce _ = Nothing --- | Check that there are no duplicate names as the top-level+-- | Check that there are not duplicates in branches. checkDuplicates :: [Declaration a] -> Maybe (DickinsonWarning a) checkDuplicates = foldMapAlternative checkDeclDuplicates @@ -31,20 +31,19 @@ collectText :: [(b, Expression a)] -> [(a, T.Text)] collectText = mapMaybe (extrText . snd) --- TODO: check duplicate tydecl names!!- checkExprDuplicates :: Expression a -> Maybe (DickinsonWarning a)-checkExprDuplicates Var{} = Nothing-checkExprDuplicates Literal{} = Nothing-checkExprDuplicates StrChunk{} = Nothing-checkExprDuplicates (Interp _ es) = foldMapAlternative checkExprDuplicates es-checkExprDuplicates (Concat _ es) = foldMapAlternative checkExprDuplicates es-checkExprDuplicates (Tuple _ es) = foldMapAlternative checkExprDuplicates es-checkExprDuplicates (Apply _ e e') = checkExprDuplicates e <|> checkExprDuplicates e'-checkExprDuplicates (Choice _ brs) = checkNames (collectText $ toList brs)-checkExprDuplicates (Let _ brs es) = foldMapAlternative checkExprDuplicates (snd <$> brs) <|> checkExprDuplicates es-checkExprDuplicates (Lambda _ _ _ e) = checkExprDuplicates e-checkExprDuplicates (Match _ e _ e') = checkExprDuplicates e <|> checkExprDuplicates e'-checkExprDuplicates (Flatten _ e) = checkExprDuplicates e-checkExprDuplicates (Annot _ e _) = checkExprDuplicates e-checkExprDuplicates Constructor{} = Nothing+checkExprDuplicates Var{} = Nothing+checkExprDuplicates Literal{} = Nothing+checkExprDuplicates StrChunk{} = Nothing+checkExprDuplicates (Interp _ es) = foldMapAlternative checkExprDuplicates es+checkExprDuplicates (MultiInterp _ es) = foldMapAlternative checkExprDuplicates es+checkExprDuplicates (Concat _ es) = foldMapAlternative checkExprDuplicates es+checkExprDuplicates (Tuple _ es) = foldMapAlternative checkExprDuplicates es+checkExprDuplicates (Apply _ e e') = checkExprDuplicates e <|> checkExprDuplicates e'+checkExprDuplicates (Choice _ brs) = checkNames (collectText $ toList brs)+checkExprDuplicates (Let _ brs es) = foldMapAlternative checkExprDuplicates (snd <$> brs) <|> checkExprDuplicates es+checkExprDuplicates (Lambda _ _ _ e) = checkExprDuplicates e+checkExprDuplicates (Match _ e _ e') = checkExprDuplicates e <|> checkExprDuplicates e'+checkExprDuplicates (Flatten _ e) = checkExprDuplicates e+checkExprDuplicates (Annot _ e _) = checkExprDuplicates e+checkExprDuplicates Constructor{} = Nothing
src/Language/Dickinson/Error.hs view
@@ -25,10 +25,10 @@ | ModuleNotFound a (Name a) | TypeMismatch (Expression a) (DickinsonTy a) (DickinsonTy a) | ExpectedLambda (Expression a) (DickinsonTy a)- | MultiBind a (Name a) (Pattern a) -- When a variable is bound more than once in a pattern...+ | MultiBind a (Name a) (Pattern a) -- When a variable is bound more than once in a pattern | MalformedTuple a- | InternalError | UnfoundConstructor a (TyName a)+ | UnfoundType a (Name a) deriving (Generic, NFData) data DickinsonWarning a = MultipleNames a (Name a) -- TODO: throw both?@@ -51,8 +51,8 @@ pretty (ExpectedLambda e ty) = "Expected" <+> squotes (pretty e) <+> "to be of function type, found type" <+> pretty ty pretty (MultiBind l n p) = pretty l <+> "Name" <+> pretty n <+> "is bound more than once in" <+> pretty p pretty (MalformedTuple l) = pretty l <+> "Malformed tuple"- pretty InternalError = "Internal error. Please report this as a bug: https://github.com/vmchale/dickinson/issues" pretty (UnfoundConstructor l tn) = pretty l <+> "Constructor" <+> pretty tn <+> "not found"+ pretty (UnfoundType l ty) = pretty l <+> "Type" <+> pretty ty <+> "not found" instance (Pretty a, Typeable a) => Exception (DickinsonError a)
src/Language/Dickinson/Eval.hs view
@@ -17,9 +17,9 @@ import Control.Composition (thread) import Control.Monad ((<=<))-import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError)+import Control.Monad.Except (MonadError, throwError) import qualified Control.Monad.Ext as Ext-import Control.Monad.State.Lazy (MonadState, State, evalState, get, gets, modify, put)+import Control.Monad.State.Lazy (MonadState, get, gets, modify, put) import Data.Foldable (toList, traverse_) import qualified Data.IntMap as IM import Data.List.NonEmpty (NonEmpty, (<|))@@ -46,7 +46,7 @@ , renameCtx :: Renames -- TODO: map to uniques or an expression? , topLevel :: M.Map T.Text Unique- -- For imports & such.+ -- Used in the REPL, for instance , lexerState :: AlexUserState -- For error messages , tyEnv :: (TyEnv a)@@ -147,6 +147,7 @@ -> m () loadDickinson = traverse_ addDecl +-- Used in the REPL balanceMax :: (HasRenames s, HasLexerState s) => MonadState s m => m () balanceMax = do m0 <- use (rename.maxLens)@@ -165,6 +166,8 @@ extrText (StrChunk _ t) = pure t extrText e = do { ty <- typeOf e ; throwError $ TypeMismatch e (TyText $ exprAnn e) ty } +-- Work with a temporary state, handling the max sensibly so as to prevent name+-- collisions withSt :: (HasRenames s, MonadState s m) => (s -> s) -> m b -> m b withSt modSt act = do preSt <- get@@ -177,10 +180,10 @@ bindPattern :: (MonadError (DickinsonError a) m, MonadState (EvalSt a) m) => Pattern a -> Expression a -> m (EvalSt a -> EvalSt a) bindPattern (PatternVar _ n) e = pure $ nameMod n e bindPattern Wildcard{} _ = pure id-bindPattern (PatternTuple _ ps) (Tuple _ es) = thread <$> Ext.zipWithM bindPattern ps es+bindPattern (PatternTuple _ 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 --- To partially apply lambdas+-- To partially apply lambdas (needed for curried functions) tryEvalExpressionM :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => Expression a -> m (Expression a) tryEvalExpressionM e@Literal{} = pure e tryEvalExpressionM e@StrChunk{} = pure e@@ -233,7 +236,7 @@ withSt modSt $ evalExpressionM e' evalExpressionM (Flatten _ e) = do- e' <- resolveExpressionM e+ e' <- resolveFlattenM e evalExpressionM ({-# SCC "mapChoice.setFrequency" #-} mapChoice setFrequency e') evalExpressionM (Annot _ e _) = evalExpressionM e @@ -265,12 +268,45 @@ resolveDeclarationM :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => Declaration a -> m (Declaration a) resolveDeclarationM (Define l n e) = Define l n <$> resolveExpressionM e --- | Resolve let bindings and such; no not perform choices or concatenations.+-- | To aid the @:flatten@ function: resolve an expression, leaving+-- choices/branches intact.+resolveFlattenM :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => Expression a -> m (Expression a)+resolveFlattenM e@Literal{} = pure e+resolveFlattenM e@StrChunk{} = pure e+resolveFlattenM e@Constructor{} = pure e+resolveFlattenM (Var _ n) = lookupName n+resolveFlattenM (Choice l pes) = do+ 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+ let stMod = thread $ fmap (uncurry nameMod) bs+ withSt stMod $+ resolveFlattenM e+resolveFlattenM (Apply _ e e') = do+ e'' <- resolveFlattenM e+ case e'' of+ Lambda _ n _ e''' ->+ withSt (nameMod n e') $+ resolveFlattenM e'''+ _ -> error "Ill-typed expression"+resolveFlattenM e@Lambda{} = pure e+resolveFlattenM (Match _ e p e') =+ (bindPattern p =<< resolveFlattenM e) *>+ resolveFlattenM e'+resolveFlattenM (Flatten l e) =+ Flatten l <$> resolveFlattenM e+resolveFlattenM (Annot _ e _) = resolveFlattenM e++-- | 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) resolveExpressionM e@Literal{} = pure e resolveExpressionM e@StrChunk{} = pure e resolveExpressionM e@Constructor{} = pure e-resolveExpressionM (Var _ n) = resolveExpressionM =<< lookupName n+resolveExpressionM v@(Var _ n) = maybe (pure v) resolveExpressionM =<< tryLookupName n resolveExpressionM (Choice l pes) = do let ps = fst <$> pes es <- traverse resolveExpressionM (snd <$> pes)@@ -282,17 +318,16 @@ let stMod = thread $ fmap (uncurry nameMod) bs withSt stMod $ resolveExpressionM e-resolveExpressionM (Apply _ e e') = do+resolveExpressionM (Apply l e e') = do e'' <- resolveExpressionM e case e'' of Lambda _ n _ e''' -> withSt (nameMod n e') $- resolveExpressionM e''' -- TODO: is this right?- _ -> error "Ill-typed expression"-resolveExpressionM e@Lambda{} = pure e -- TODO: is this right?-resolveExpressionM (Match _ e p e') =- (bindPattern p =<< resolveExpressionM e) *>- resolveExpressionM e'+ resolveExpressionM 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 (Flatten l e) = Flatten l <$> resolveExpressionM e resolveExpressionM (Annot _ e _) = resolveExpressionM e
src/Language/Dickinson/File.hs view
@@ -8,6 +8,7 @@ , amalgamateRenameM , fmtFile , pipeline+ , resolveFile ) where import Control.Applicative ((<|>))@@ -91,6 +92,9 @@ evalFile :: [FilePath] -> FilePath -> IO T.Text evalFile is = fmap eitherThrow . evalIO . (evalDickinsonAsMain <=< amalgamateRenameM is)++resolveFile :: [FilePath] -> FilePath -> IO [Declaration AlexPosn]+resolveFile is = fmap eitherThrow . evalIO . (traverse resolveDeclarationM <=< amalgamateRenameM is) pipeline :: [FilePath] -> FilePath -> IO T.Text pipeline is fp = fmap eitherThrow $ evalIO $ do
src/Language/Dickinson/Lexer.x view
@@ -52,9 +52,9 @@ @escape_str = \\ [$str_special n] -- single-line string-@string = \" ([^ $str_special] | @escape_str)* \"+@string = \" ([^ $str_special] | "$" [^\{\"\$] | @escape_str)* (\" | \$\") -$str_chunk = [^ \"\\\$]+$str_chunk = [^\"\\\$] @str_interp_in = ($str_chunk | @escape_str)+ @@ -66,48 +66,63 @@ @name = (@lower_name \.)* @lower_name @tyname = [A-Z] @follow_char* +@multi_str_in = ([^\'] | $white)*+ tokens :- - <0> $white+ ;- <0> ";".* ;+ <0> { - <0> \( { mkSym LParen }- <0> \) { mkSym RParen }- <0> \> { mkSym RBracket }- <0> \| { mkSym VBar }- <0> \[ { mkSym LSqBracket }- <0> \] { mkSym RSqBracket }- <0> \$ { mkSym DollarSign }- <0> \, { mkSym Comma }- <0> \_ { mkSym Underscore }- <0> "⟶" { mkSym Arrow }- <0> "->" { mkSym Arrow }- <0> \: { mkSym Colon }- <0> \%\- { mkSym DeclBreak }- <0> "=" { mkSym Eq }+ $white+ ;+ ";".* ; - -- keywords- <0> ":let" { mkKeyword KwLet }- <0> ":branch" { mkKeyword KwBranch }- <0> ":oneof" { mkKeyword KwOneof }- <0> ":def" { mkKeyword KwDef }- <0> ":include" { mkKeyword KwInclude }- <0> ":lambda" { mkKeyword KwLambda }- <0> "text" { mkKeyword KwText }- <0> ":match" { mkKeyword KwMatch }- <0> ":flatten" { mkKeyword KwFlatten }- <0> "tydecl" { mkKeyword KwTyDecl }+ \( { mkSym LParen }+ \) { mkSym RParen }+ \> { mkSym RBracket }+ \| { mkSym VBar }+ \[ { mkSym LSqBracket }+ \] { mkSym RSqBracket }+ \$ { mkSym DollarSign }+ \, { mkSym Comma }+ \_ { mkSym Underscore }+ "⟶" { mkSym Arrow }+ "->" { mkSym Arrow }+ \: { mkSym Colon }+ \%\- { mkSym DeclBreak }+ "=" { mkSym Eq } - <0> @name { tok (\p s -> TokIdent p <$> newIdentAlex p (mkText s)) }- <0> @tyname { tok (\p s -> TokTyCons p <$> newIdentAlex p (mkText s)) }+ -- keywords+ ":let" { mkKeyword KwLet }+ ":branch" { mkKeyword KwBranch }+ ":oneof" { mkKeyword KwOneof }+ ":def" { mkKeyword KwDef }+ ":include" { mkKeyword KwInclude }+ ":lambda" { mkKeyword KwLambda }+ "text" { mkKeyword KwText }+ ":match" { mkKeyword KwMatch }+ ":flatten" { mkKeyword KwFlatten }+ "tydecl" { mkKeyword KwTyDecl } - -- strings+ -- identifiers+ @name { tok (\p s -> TokIdent p <$> newIdentAlex p (mkText s)) }+ @tyname { tok (\p s -> TokTyCons p <$> newIdentAlex p (mkText s)) }++ }++ -- interpolated strings <0> \" { mkSym StrBegin `andBegin` string } <string> @str_interp_in { tok (\p s -> alex $ TokStrChunk p (escReplace $ mkText s)) } <string> @interp { mkSym BeginInterp `andBegin` 0 }+ <string> "$" { tok (\p s -> alex $ TokStrChunk p (mkText s)) } <0> \} { mkSym EndInterp `andBegin` string } <string> \" { mkSym StrEnd `andBegin` 0 } + -- TODO: track "depth" in interpolations++ <0> "'''" { mkSym MultiStrBegin `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 }+ -- strings <0> @string { tok (\p s -> alex $ TokString p (escReplace . T.tail . T.init $ mkText s)) } @@ -123,7 +138,7 @@ . T.replace "\\$" "$" mkText :: BSL.ByteString -> T.Text-mkText = decodeUtf8 . BSL.toStrict+mkText = {-# SCC "mkText" #-} decodeUtf8 . BSL.toStrict alex :: a -> Alex a alex = pure@@ -184,6 +199,8 @@ | EndInterp | StrBegin | StrEnd+ | MultiStrBegin+ | MultiStrEnd | Arrow | DollarSign | Comma@@ -204,6 +221,8 @@ pretty EndInterp = rbrace pretty StrBegin = dquote pretty StrEnd = dquote+ pretty MultiStrBegin = "'''"+ pretty MultiStrEnd = "'''" pretty Arrow = "⟶" pretty DollarSign = "$" pretty Comma = comma@@ -249,9 +268,9 @@ | TokIdent { loc :: a, ident :: Name a } | TokTyCons { loc :: a, tyIdent :: TyName a } | TokDouble { loc :: a, double :: Double }+ | TokStrChunk { loc :: a, str :: T.Text } -- separate tok for full strings for sake of speed | TokString { loc :: a, str :: T.Text }- | TokStrChunk { loc :: a, str :: T.Text } | TokKeyword { loc :: a, kw :: Keyword } | TokSym { loc :: a, sym :: Sym } deriving (Eq, Generic, NFData)
src/Language/Dickinson/Lib/Get.hs view
@@ -31,7 +31,7 @@ (st, x) <- fAct lSt (lexerStateLens .= st) $> x --- Parse an import. Does NOT perform renaming!+-- | Parse an import. Does not perform renaming! parseImport :: (MonadError (DickinsonError AlexPosn) m, MonadIO m) => [FilePath] -- ^ Include path -> Import AlexPosn
src/Language/Dickinson/Name.hs view
@@ -23,6 +23,7 @@ type TyName a = Name a +-- TODO: separate type for module name -- | A (possibly qualified) name. data Name a = Name { name :: NonEmpty T.Text , unique :: !Unique
src/Language/Dickinson/Parser.y view
@@ -52,6 +52,8 @@ rsqbracket { TokSym $$ RSqBracket } rbracket { TokSym $$ RBracket } strBegin { TokSym $$ StrBegin }+ multiStrBegin { TokSym $$ MultiStrBegin }+ multiStrEnd { TokSym $$ MultiStrEnd } strEnd { TokSym $$ StrEnd } arrow { TokSym $$ Arrow } dollar { TokSym $$ DollarSign }@@ -146,6 +148,7 @@ | ident { Var (loc $1) (ident $1) } | stringLiteral { Literal (loc $1) (str $1) } | strBegin some(Interp) strEnd { Interp $1 (toList $ NE.reverse $2) }+ | multiStrBegin some(Interp) multiStrEnd { MultiInterp $1 (processMultiChunks $ toList $ NE.reverse $2) } | rbracket many(Expression) { Concat $1 (reverse $2) } | dollar Expression Expression { Apply $1 $2 $3 } | lparen sepBy(Expression,comma) rparen { Tuple $1 (NE.reverse $2) }@@ -167,6 +170,27 @@ | Declaration { Left $1 } {++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)++mapStrChunk :: (T.Text -> T.Text) -> Expression a -> Expression a+mapStrChunk f (StrChunk l t) = StrChunk l (f t)+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 [] = []++processMultiChunks :: [Expression a] -> [Expression a]+processMultiChunks = fmap (mapStrChunk stripMulti) . squishStrChunks weight :: NonEmpty (Expression a) -> NonEmpty (Double, Expression a) weight es = (recip, ) <$> es
src/Language/Dickinson/Rename.hs view
@@ -81,28 +81,33 @@ u' <- replaceUnique u pure $ Name n u' l +-- exported so we can test it alone renameDickinson :: Int -> Dickinson a -> (Dickinson a, Int) renameDickinson m ds = runRenameM m $ renameDickinsonM ds +-- | The renamer ensures global uniqueness and is used during evaluation to+-- clone expressions with bound variables. renameDickinsonM :: (MonadState s m, HasRenames s) => Dickinson a -> m (Dickinson a) renameDickinsonM (Dickinson i d) = Dickinson i <$> renameDeclarationsM d renameDeclarationsM :: (MonadState s m, HasRenames s) => [Declaration a] -> m [Declaration a] renameDeclarationsM = traverse renameDeclarationM <=< traverse insDeclM --- broadcast first...+-- broadcast first... This allows definitions to be declared in any order. insDeclM :: (MonadState s m, HasRenames s) => Declaration a -> m (Declaration a) insDeclM (Define p n e) = do (n', modR) <- withName n modifying rename modR pure $ Define p n' e-insDeclM d@TyDecl{} = pure d -- FIXME: scoping!! (two type decls should be illegal?)+insDeclM d@TyDecl{} = pure d -- TODO: decide on spec for scoping. (two type decls should be illegal) renameDeclarationM :: (MonadState s m, HasRenames s) => Declaration a -> m (Declaration a) renameDeclarationM (Define p n e) = Define p n <$> renameExpressionM e renameDeclarationM d@TyDecl{} = pure d +-- allows us to work with a temporary change to the renamer state, tracking the+-- max sensibly withRenames :: (HasRenames s, MonadState s m) => (Renames -> Renames) -> m a -> m a withRenames modSt act = do preSt <- use rename@@ -146,6 +151,7 @@ in let es = fmap snd branches in NE.zip ds <$> traverse renameExpressionM es renameExpressionM (Interp p es) = Interp p <$> traverse renameExpressionM es+renameExpressionM (MultiInterp p es) = MultiInterp p <$> traverse renameExpressionM es renameExpressionM (Concat p es) = Concat p <$> traverse renameExpressionM es renameExpressionM (Tuple p es) = Tuple p <$> traverse renameExpressionM es renameExpressionM (Apply p e e') = Apply p <$> renameExpressionM e <*> renameExpressionM e'
src/Language/Dickinson/ScopeCheck.hs view
@@ -42,24 +42,42 @@ checkDickinson d = traverse_ insDecl d *> mapSumM checkDecl d insDecl :: Declaration a -> CheckM ()-insDecl (Define _ n _) = insertName n+insDecl (Define _ n _) = insertName n+insDecl (TyDecl _ n tys) = insertName n *> traverse_ insertName tys checkDecl :: Declaration a -> CheckM (Maybe (DickinsonError a)) checkDecl (Define _ _ e) = checkExpr e+checkDecl TyDecl{} = pure Nothing +checkType :: DickinsonTy a -> CheckM (Maybe (DickinsonError a))+checkType TyText{} = pure Nothing+checkType (TyFun _ ty ty') = (<|>) <$> checkType ty <*> checkType ty'+checkType (TyTuple _ tys) = mapSumM checkType tys+checkType (TyNamed l n@(Name _ (Unique k) _)) = do+ b <- get+ if k `IS.member` b+ then pure Nothing+ else pure $ Just (UnfoundType l n)+ checkExpr :: Expression a -> CheckM (Maybe (DickinsonError a)) checkExpr Literal{} = pure Nothing checkExpr StrChunk{} = pure Nothing checkExpr (Apply _ e e') = (<|>) <$> checkExpr e <*> checkExpr e' checkExpr (Interp _ es) = mapSumM checkExpr es+checkExpr (MultiInterp _ es) = mapSumM checkExpr es checkExpr (Choice _ brs) = mapSumM checkExpr (snd <$> brs) checkExpr (Concat _ es) = mapSumM checkExpr es checkExpr (Tuple _ es) = mapSumM checkExpr es checkExpr (Flatten _ e) = checkExpr e-checkExpr (Annot _ e _) = checkExpr e+checkExpr (Annot _ e ty) = (<|>) <$> checkExpr e <*> checkType ty checkExpr (Lambda _ n _ e) = do insertName n checkExpr e <* deleteName n+checkExpr (Constructor _ n@(Name _ (Unique i) l)) = do+ b <- get+ if i `IS.member` b+ then pure Nothing+ else pure $ Just (UnfoundConstructor l n) checkExpr (Var _ n@(Name _ (Unique i) l)) = do b <- get if i `IS.member` b
src/Language/Dickinson/Type.hs view
@@ -18,8 +18,9 @@ import qualified Data.List.NonEmpty as NE import Data.Semigroup ((<>)) import qualified Data.Text as T-import Data.Text.Prettyprint.Doc (Doc, Pretty (pretty), brackets, colon, concatWith, dquotes, group,- hardline, hsep, indent, parens, pipe, rangle, tupled, vsep, (<+>))+import Data.Text.Prettyprint.Doc (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 Language.Dickinson.Name@@ -52,34 +53,35 @@ data Expression a = Literal { exprAnn :: a, litText :: T.Text } | StrChunk { exprAnn :: a, chunkText :: T.Text } | Choice { exprAnn :: a- , choices :: (NonEmpty (Double, Expression a))+ , choices :: NonEmpty (Double, Expression a) } | Let { exprAnn :: a- , letBinds :: (NonEmpty (Name a, Expression a))- , letExpr :: (Expression a)+ , letBinds :: NonEmpty (Name a, Expression a)+ , letExpr :: Expression a }- | Var { exprAnn :: a, exprVar :: (Name a) }+ | Var { exprAnn :: a, exprVar :: Name a } | Interp { exprAnn :: a, exprInterp :: [Expression a] }+ | MultiInterp { exprAnn :: a, exprMultiInterp :: [Expression a] } | Lambda { exprAnn :: a- , lambdaVar :: (Name a)- , lambdaTy :: (DickinsonTy a)- , lambdaExpr :: (Expression a)+ , lambdaVar :: Name a+ , lambdaTy :: DickinsonTy a+ , lambdaExpr :: Expression a } | Apply { exprAnn :: a- , exprFun :: (Expression a)- , exprArg :: (Expression a)+ , exprFun :: Expression a+ , exprArg :: Expression a } | Concat { exprAnn :: a, exprConcats :: [Expression a] }- | Tuple { exprAnn :: a, exprTup :: (NonEmpty (Expression a)) }+ | Tuple { exprAnn :: a, exprTup :: NonEmpty (Expression a) } | Match { exprAnn :: a- , exprMatch :: (Expression a)- , exprPat :: (Pattern a)- , exprIn :: (Expression a)+ , exprMatch :: Expression a+ , exprPat :: Pattern a+ , exprIn :: Expression a }- | Flatten { exprAnn :: a, exprFlat :: (Expression a) }+ | Flatten { exprAnn :: a, exprFlat :: Expression a } | Annot { exprAnn :: a- , expr :: (Expression a)- , exprTy :: (DickinsonTy a)+ , expr :: Expression a+ , exprTy :: DickinsonTy a } | Constructor { exprAnn :: a, constructorName :: TyName a } deriving (Generic, NFData, Binary, Functor, Show)@@ -100,7 +102,7 @@ instance Pretty (Declaration a) where pretty (Define _ n e) = parens (":def" <+> pretty n <#> indent 2 (pretty e))- pretty (TyDecl _ n cs) = "tydecl" <+> pretty n <+> "=" <+> (concatWith (\x y -> x <+> pipe <+> y)) (toList (pretty <$> cs))+ pretty (TyDecl _ n cs) = "tydecl" <+> pretty n <+> "=" <+> concatWith (\x y -> x <+> pipe <+> y) (toList (pretty <$> cs)) instance Pretty (Import a) where pretty (Import _ n) = parens (":include" <+> pretty n)@@ -114,21 +116,26 @@ prettyChoiceBranch :: (Double, Expression a) -> Doc b prettyChoiceBranch (d, e) = parens (pipe <+> pretty d <+> pretty e) - prettyInterp :: Expression a -> Doc b prettyInterp (StrChunk _ t) = pretty (escReplace t) prettyInterp e = "${" <> pretty e <> "}" +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+ instance Pretty (Pattern a) where pretty (PatternVar _ n) = pretty n pretty (PatternTuple _ ps) = tupled (toList (pretty <$> ps)) pretty Wildcard{} = "_"+ pretty (PatternCons _ c) = pretty c escReplace :: T.Text -> T.Text escReplace = T.replace "\"" "\\\"" . T.replace "\n" "\\n"- . T.replace "$" "\\$"+ . T.replace "${" "\\${" -- figure out indentation instance Pretty (Expression a) where@@ -141,6 +148,7 @@ pretty (Lambda _ n ty e) = parens (":lambda" <+> pretty n <+> pretty ty <#*> pretty e) pretty (Apply _ e e') = parens ("$" <+> pretty e <+> pretty e') pretty (Interp _ es) = group (dquotes (foldMap prettyInterp es))+ pretty (MultiInterp _ es) = group (align ("'''" <> prettyMultiInterp es <> "'''")) pretty (Concat _ es) = parens (rangle <+> hsep (pretty <$> es)) pretty StrChunk{} = error "Internal error: naked StrChunk" pretty (Tuple _ es) = tupled (toList (pretty <$> es))
src/Language/Dickinson/TypeCheck.hs view
@@ -33,7 +33,7 @@ unless (ty' == ty) $ throwError (TypeMismatch e ty ty') -newtype TyEnv a = TyEnv { unTyEnv :: (IM.IntMap (DickinsonTy a)) }+newtype TyEnv a = TyEnv { unTyEnv :: IM.IntMap (DickinsonTy a) } deriving (Binary) class HasTyEnv f where@@ -71,10 +71,12 @@ tyAddDecl Define{} = pure () tyAddDecl (TyDecl l tn cs) = traverse_ (\c -> tyInsert c (TyNamed l tn)) cs -bindPattern :: (MonadState (s a) m, HasTyEnv s, MonadError (DickinsonError a) m) => Pattern a -> (DickinsonTy a) -> m ()+bindPattern :: (MonadState (s a) m, HasTyEnv s, MonadError (DickinsonError a) m) => Pattern a -> DickinsonTy a -> m () bindPattern (PatternVar _ n) ty = tyInsert n ty bindPattern Wildcard{} _ = pure ()-bindPattern (PatternTuple _ ps) (TyTuple _ tys) = Ext.zipWithM_ bindPattern ps tys -- FIXME: length ps = length tys+bindPattern (PatternTuple l ps) (TyTuple _ tys)+ | length ps == length tys = Ext.zipWithM_ bindPattern ps tys+ | otherwise = throwError $ MalformedTuple l bindPattern (PatternTuple l _) _ = throwError $ MalformedTuple l -- run after global renamer@@ -87,6 +89,8 @@ case IM.lookup i tyEnv of Just ty -> pure ty Nothing -> throwError $ UnfoundName l n+typeOf (MultiInterp l es) =+ traverse_ (tyAssert (TyText undefined)) es $> TyText l typeOf (Interp l es) = traverse_ (tyAssert (TyText undefined)) es $> TyText l typeOf (Concat l es) =
test/Eval.hs view
@@ -17,18 +17,27 @@ , resultCase "test/demo/tyAnnot.dck" , resultCase "test/data/quoteify.dck" , resultCase "test/data/hangIndefinitely.dck"+ , resolveCase "test/data/hangIndefinitely.dck" ] -forceText :: a -> Assertion-forceText = (`seq` pure ())+forceResult :: a -> Assertion+forceResult = (`seq` pure ()) resultCase :: FilePath -> TestTree resultCase fp = testCase fp $ result fp +resolveCase :: FilePath -> TestTree+resolveCase fp = testCase fp $ resolve fp++resolve :: FilePath -> Assertion+resolve fp = do+ res <- resolveFile ["prelude", "lib"] fp+ forceResult res+ result :: FilePath -> Assertion result fp = do res <- evalFile ["prelude", "lib"] fp- forceText res+ forceResult res constEval :: Assertion constEval = do
test/Golden.hs view
@@ -31,6 +31,8 @@ , renameDckFile "test/data/tupleRename.dck" , renameDckFile "test/eval/match.dck" , renameDckFile "test/data/quoteify.dck"+ , withDckFile "test/data/lexDollarSign.dck"+ , withDckFile "test/data/multiStr.dck" ] prettyBSL :: Dickinson a -> BSL.ByteString
test/Spec.hs view
@@ -43,16 +43,22 @@ , parseNoError "lib/color.dck" , parseNoError "lib/birds.dck" , lexNoError "test/data/import.dck"+ , lexNoError "test/data/lexDollarSign.dck" , parseNoError "test/data/import.dck" , detectDuplicate "test/data/multiple.dck" , detectDuplicate "test/error/double.dck" , detectDuplicate "test/error/tyDouble.dck" , detectDuplicate "test/error/tyConsDouble.dck" , lexNoError "examples/shakespeare.dck"+ , lexNoError "test/data/multiStr.dck"+ , parseNoError "test/data/multiStr.dck" , parseNoError "examples/shakespeare.dck" , detectScopeError "test/demo/improbableScope.dck" , detectBadBranch "test/demo/sillyOption.dck" , noScopeError "test/demo/circular.dck"+ , noScopeError "test/data/adt.dck"+ , detectScopeError "test/error/tyScope.dck"+ , detectScopeError "test/error/constructorScope.dck" , findPath ]
test/data/adt.dck view
@@ -1,9 +1,9 @@ %- -tydecl sex = Boy | Girl- (:def boy Boy : sex)++tydecl sex = Boy | Girl (:def main "Hello, World!")
test/data/adt.pretty view
@@ -1,9 +1,9 @@ %- -tydecl sex = Boy | Girl- (:def boy Boy : sex)++tydecl sex = Boy | Girl (:def main "Hello, World!")
+ test/data/lexDollarSign.dck view
@@ -0,0 +1,11 @@+%-++(:def main+ (:oneof+ (| "$")+ (| "$a")+ (| "$$")+ (| "$${a}")+ (| "$\${a}")+ (| "$a${a}")+ (| "${a}$")))
+ test/data/lexDollarSign.pretty view
@@ -0,0 +1,11 @@+%-++(:def main+ (:branch+ (| 0.14285714285714285 "$")+ (| 0.14285714285714285 "$a")+ (| 0.14285714285714285 "$$")+ (| 0.14285714285714285 "$${a}")+ (| 0.14285714285714285 "$\${a}")+ (| 0.14285714285714285 "$a${a}")+ (| 0.14285714285714285 "${a}$")))
+ test/data/multiStr.dck view
@@ -0,0 +1,16 @@+%-++(:def strangeChar+ '''+ I saw my boss' dog today+ ''')++(:def empty+ '''+ ''')++(:def main+ '''+ This is a multi-line string+ '''+ )
+ test/data/multiStr.pretty view
@@ -0,0 +1,15 @@+%-++(:def strangeChar+ '''+ I saw my boss' dog today+ ''')++(:def empty+ '''+ ''')++(:def main+ '''+ This is a multi-line string+ ''')
+ test/demo/animal.dck view
@@ -0,0 +1,6 @@+(:include animal)++%-++(:def main+ animal)
+ test/demo/circular.dck view
@@ -0,0 +1,7 @@+%-++(:def main+ (a))++(:def a+ "a")
+ test/demo/improbableScope.dck view
@@ -0,0 +1,13 @@+(:include color)++%-++(:def invalid+ (:let + [yes "yes"]+ (:branch+ (| 1.0 yes)+ (| 0.001 no))))++(:def main+ ("hello ${invalid}"))
+ test/demo/mutual.dck view
@@ -0,0 +1,14 @@+%-++(:def a+ (:branch+ (| 0.75 "a")+ (| 0.25 (> "a" b))))++(:def b+ (:branch+ (| 0.75 "b")+ (| 0.25 (> "b" a))))++(:def main+ (> a b))
+ test/demo/sillyOption.dck view
@@ -0,0 +1,6 @@+%-++(:def silly+ (:branch+ (| 1.0 "hello")+ (| 1.0 "hello")))
+ test/demo/tyAnnot.dck view
@@ -0,0 +1,6 @@+(:include animal)++%-++(:def main+ (animal : text))
+ test/error/constructorScope.dck view
@@ -0,0 +1,6 @@+%-++tydecl sex = Boy | Girl++(:def boy + NonBinary : sex)
+ test/error/double.dck view
@@ -0,0 +1,7 @@+%-++(:def one+ "name")++(:def one+ "name")
+ test/error/illTyped.dck view
@@ -0,0 +1,8 @@+%-++(:def silly+ (:lambda func (-> text text)+ ("Helo, ${func}")))++(:def main+ silly)
+ test/error/lexErr.dck view
@@ -0,0 +1,4 @@+&$++(:def main+ "hello")
+ test/error/tyConsDouble.dck view
@@ -0,0 +1,5 @@+%-++tydecl sex = Boy | Girl++tydecl gender = Boy | Girl | NonBinary
+ test/error/tyDouble.dck view
@@ -0,0 +1,5 @@+%-++tydecl sex = Boy | Girl++tydecl sex = Boy | Girl | NonBinary
+ test/error/tyScope.dck view
@@ -0,0 +1,6 @@+%-++tydecl sex = Boy | Girl++(:def boy + Boy : gender)
+ test/eval/choice.dck view
@@ -0,0 +1,6 @@+%-++(:def main+ (:oneof+ (| "woman")+ (| "man")))
+ test/eval/context.dck view
@@ -0,0 +1,15 @@+%-++(:def letBinding+ (:let+ [a "woman"]+ (:branch+ (| 1.0 a)+ (| 1.0 a))))++(:def main+ (:let+ [a letBinding]+ (:branch+ (| 1.0 letBinding)+ (| 1.0 a))))
+ test/eval/local.dck view
@@ -0,0 +1,9 @@+%-++(:def main+ (:let+ [a "man"]+ [b "woman"]+ (:branch+ (| 1.0 a)+ (| 1.0 b))))
+ test/eval/main.dck view
@@ -0,0 +1,5 @@+%-++(:def main+ (:oneof+ (| "man")))
+ test/eval/match.dck view
@@ -0,0 +1,27 @@+%-++(:def fst+ (:lambda xy (text, text)+ (:match xy (x, _)+ x)))++(:def snd+ (:lambda xy (text, text)+ (:match xy (_, y)+ y)))++; TODO tydecl sex = Boy | Girl++; see https://github.com/vmchale/doggo-command-line/blob/master/src/main.rs+(:def greeter+ (:lambda dog (text, text)+ (:let+ [name ($fst dog)]+ [pronoun ($snd dog)]+ (: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")))