language-dickinson 0.1.1.2 → 0.1.2.0
raw patch · 25 files changed
+356/−214 lines, 25 filesdep +template-haskelldep ~prettyprinterPVP ok
version bump matches the API change (PVP)
Dependencies added: template-haskell
Dependency ranges changed: prettyprinter
API changes (from Hackage documentation)
+ Language.Dickinson.TH: dickinson :: [FilePath] -> FilePath -> Q Exp
+ Language.Dickinson.TH: run :: [Declaration AlexPosn] -> IO Text
Files
- CHANGELOG.md +5/−0
- bench/Bench.hs +8/−8
- examples/fionaBot.dck +6/−0
- examples/fortune.dck +3/−0
- language-dickinson.cabal +21/−8
- lib/adjectives.dck +1/−0
- public/Language/Dickinson/TH.hs +35/−0
- run/Main.hs +1/−1
- run/REPL.hs +1/−1
- src/Language/Dickinson/Check.hs +1/−3
- src/Language/Dickinson/Check/Duplicate.hs +49/−0
- src/Language/Dickinson/Check/Pattern.hs +26/−3
- src/Language/Dickinson/Check/Scope.hs +98/−0
- src/Language/Dickinson/DuplicateCheck.hs +0/−49
- src/Language/Dickinson/File.hs +15/−7
- src/Language/Dickinson/Lexer.x +4/−0
- src/Language/Dickinson/Name.hs +7/−6
- src/Language/Dickinson/Pipeline.hs +7/−7
- src/Language/Dickinson/Rename/Amalgamate.hs +8/−6
- src/Language/Dickinson/ScopeCheck.hs +0/−98
- src/Language/Dickinson/Type.hs +17/−9
- src/Language/Dickinson/Unique.hs +3/−1
- test/Spec.hs +16/−7
- test/TH.hs +19/−0
- test/error/badMatch.dck +5/−0
CHANGELOG.md view
@@ -1,5 +1,10 @@ # dickinson +## 0.1.2.0++ * Fail on bad patterns, e.g. `(:match xy (x, x) x)`+ * Add `Language.Dickinson.QuasiQuoter` module+ ## 0.1.1.2 * Ignore lines starting with `#!` (for shell shebangs)
bench/Bench.hs view
@@ -1,22 +1,22 @@ module Main (main) where -import Control.Exception (throw)-import Control.Exception.Value (eitherThrow)-import Control.Monad (void)+import Control.Exception (throw)+import Control.Exception.Value (eitherThrow)+import Control.Monad (void) import Criterion.Main-import Data.Binary (decode, encode)-import qualified Data.ByteString.Lazy as BSL-import qualified Data.Text as T+import Data.Binary (decode, encode)+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Text as T import Language.Dickinson.Check+import Language.Dickinson.Check.Duplicate import Language.Dickinson.Check.Internal-import Language.Dickinson.DuplicateCheck+import Language.Dickinson.Check.Scope import Language.Dickinson.Eval import Language.Dickinson.File import Language.Dickinson.Lexer import Language.Dickinson.Parser import Language.Dickinson.Pipeline import Language.Dickinson.Rename-import Language.Dickinson.ScopeCheck import Language.Dickinson.Type import Language.Dickinson.TypeCheck import Language.Dickinson.Unique
examples/fionaBot.dck view
@@ -16,6 +16,7 @@ (| "I'm full as a tick") (| "I wanna make a mistake") (| "Scratch me out, free yourself.")+ (| "I watch you live to have my fun.") (| "Run, free yourself of me.") (| '''@@ -40,6 +41,11 @@ ''' All that love must've been lacking something If I got bored trying to figure you out+ ''')+ (|+ '''+ How can I ask anyone to love me+ When all I do is beg to be left alone? ''') (| '''
examples/fortune.dck view
@@ -28,10 +28,13 @@ (| "Spurn your family.") (| "Salvation is finality.") (| "Knowledge begets humility.")+ (| "Mushrooms are made of flesh.") (| "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.") (| "Did you remember to put apotheosis on your to-do list?") (| "Cultivate weakness.")
language-dickinson.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: language-dickinson-version: 0.1.1.2+version: 0.1.2.0 license: BSD3 license-file: LICENSE copyright: Copyright: (c) 2020 Vanessa McHale@@ -55,6 +55,17 @@ base >=4.9 && <5, dickinson -any + if !flag(cross)+ exposed-modules: Language.Dickinson.TH++ if !flag(cross)+ other-extensions: TemplateHaskell++ if !flag(cross)+ build-depends:+ template-haskell -any,+ text -any+ if impl(ghc >=8.0) ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates@@ -81,14 +92,15 @@ Language.Dickinson.Eval Language.Dickinson.Error Language.Dickinson.Check- Language.Dickinson.ScopeCheck- Language.Dickinson.DuplicateCheck+ Language.Dickinson.Check.Scope+ Language.Dickinson.Check.Internal+ Language.Dickinson.Check.Pattern+ Language.Dickinson.Check.Duplicate Language.Dickinson.Unique Language.Dickinson.File Language.Dickinson.Pipeline Language.Dickinson.Import Language.Dickinson.Lib- Language.Dickinson.Check.Internal Data.Tuple.Ext Control.Exception.Value Data.Text.Prettyprint.Doc.Ext@@ -96,7 +108,6 @@ hs-source-dirs: src other-modules: Paths_language_dickinson- Language.Dickinson.Check.Pattern Language.Dickinson.Lib.Get Control.Monad.Ext Data.Foldable.Ext@@ -106,7 +117,7 @@ other-extensions: DeriveAnyClass DeriveFunctor DeriveGeneric FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving OverloadedStrings- StandaloneDeriving TupleSections+ StandaloneDeriving TupleSections DeriveDataTypeable ghc-options: -Wall -O2 build-depends:@@ -208,9 +219,10 @@ Golden Eval TypeCheck+ TH default-language: Haskell2010- other-extensions: OverloadedStrings+ other-extensions: OverloadedStrings TemplateHaskell ghc-options: -threaded -rtsopts "-with-rtsopts=-N -K1K" -Wall build-depends: base -any,@@ -222,7 +234,8 @@ text -any, filepath -any, tasty-golden -any,- pretty-simple -any+ pretty-simple -any,+ language-dickinson -any if impl(ghc >=8.0) ghc-options:
lib/adjectives.dck view
@@ -8,4 +8,5 @@ (| "bromide") (| "banal") (| "pithy")+ (| "orotund") (| "stentorian")))
+ public/Language/Dickinson/TH.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE TemplateHaskell #-}++-- | @since 0.1.2.0+module Language.Dickinson.TH ( dickinson+ , run+ ) where++import Control.Exception.Value (eitherThrow)+import Data.Data (Data)+import Data.Foldable (traverse_)+import qualified Data.Text as T+import Data.Typeable (cast)+import Language.Dickinson.Eval+import Language.Dickinson.File+import Language.Dickinson.Lexer+import Language.Dickinson.Type+import Language.Haskell.TH (Exp, Q)+import Language.Haskell.TH.Syntax (Exp (AppE, VarE))+import qualified Language.Haskell.TH.Syntax as TH++run :: [Declaration AlexPosn] -> IO T.Text+run = fmap eitherThrow . evalIO . evalDickinsonAsMain++dickinson :: [FilePath] -> FilePath -> Q Exp+dickinson is fp = do+ traverse_ TH.addDependentFile (fp:is) -- TODO: resolve dependencies+ ds <- TH.runIO (validateAmalgamate is fp)+ liftDataWithText ds++liftText :: T.Text -> Q Exp+liftText txt = AppE (VarE 'T.pack) <$> TH.lift (T.unpack txt)++-- see this mess: https://stackoverflow.com/a/38182444+liftDataWithText :: Data a => a -> Q Exp+liftDataWithText = TH.dataToExpQ (fmap liftText . cast)
run/Main.hs view
@@ -81,7 +81,7 @@ run :: Act -> IO () run (Run fp is) = do { pGo <- defaultLibPath ; TIO.putStrLn =<< pipeline (pGo is) fp } run (REPL _) = dickinsonRepl-run (Check fs i) = do { pathMod <- defaultLibPath ; traverse_ (validateFile (pathMod i)) fs } -- FIXME: reuse+run (Check fs i) = do { pathMod <- defaultLibPath ; traverse_ (validateFile (pathMod i)) fs } run (Lint fs) = traverse_ warnFile fs run (Format fp False) = fmtFile fp run (Format fp True) = fmtInplace fp
run/REPL.hs view
@@ -21,6 +21,7 @@ import Data.Text.Prettyprint.Doc (Pretty (pretty), hardline) import Data.Text.Prettyprint.Doc.Render.Text (putDoc) import Data.Tuple.Ext (fst4)+import Language.Dickinson.Check.Scope import Language.Dickinson.Error import Language.Dickinson.Eval import Language.Dickinson.File@@ -28,7 +29,6 @@ import Language.Dickinson.Lib import Language.Dickinson.Parser import Language.Dickinson.Rename-import Language.Dickinson.ScopeCheck import Language.Dickinson.Type import Language.Dickinson.TypeCheck import Language.Dickinson.Unique
src/Language/Dickinson/Check.hs view
@@ -26,8 +26,6 @@ <|> checkNames (concatMap collectConstructors ds) where defNameM (Define _ n _) = Just n defNameM TyDecl{} = Nothing- defExprM (Define _ _ e) = Just e- defExprM TyDecl{} = Nothing tyDeclNameM Define{} = Nothing tyDeclNameM (TyDecl _ n _) = Just n @@ -50,7 +48,7 @@ checkMultipleExpr (Flatten _ e) = checkMultipleExpr e checkMultipleExpr (Let _ bs e) = checkNames (toList $ fmap fst bs)- <|> foldMapAlternative checkMultipleExpr (snd <$> bs)+ <|> foldMapAlternative (checkMultipleExpr . snd) bs <|> checkMultipleExpr e checkMultipleExpr (Annot _ e _) = checkMultipleExpr e checkMultipleExpr Constructor{} = Nothing
+ src/Language/Dickinson/Check/Duplicate.hs view
@@ -0,0 +1,49 @@+module Language.Dickinson.Check.Duplicate ( checkDuplicates+ ) where++import Control.Applicative ((<|>))+import Data.Foldable (toList)+import Data.Foldable.Ext (foldMapAlternative)+import Data.Function (on)+import Data.List (groupBy, sortBy)+import Data.Maybe (mapMaybe)+import qualified Data.Text as T+import Language.Dickinson.Error+import Language.Dickinson.Type++checkNames :: [(a, T.Text)] -> Maybe (DickinsonWarning a)+checkNames ns = foldMapAlternative announce (groupBy ((==) `on` snd) $ sortBy (compare `on` snd) ns)+ where announce (_:(l, y):_) = Just $ DuplicateStr l y+ announce _ = Nothing++-- | Check that there are not duplicates in branches.+checkDuplicates :: [Declaration a] -> Maybe (DickinsonWarning a)+checkDuplicates = foldMapAlternative checkDeclDuplicates++checkDeclDuplicates :: Declaration a -> Maybe (DickinsonWarning a)+checkDeclDuplicates (Define _ _ e) = checkExprDuplicates e+checkDeclDuplicates TyDecl{} = Nothing++extrText :: Expression a -> Maybe (a, T.Text)+extrText (Literal l t) = pure (l, t)+extrText _ = Nothing++collectText :: [(b, Expression a)] -> [(a, T.Text)]+collectText = mapMaybe (extrText . snd)++checkExprDuplicates :: Expression a -> Maybe (DickinsonWarning a)+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/Check/Pattern.hs view
@@ -1,10 +1,12 @@-module Language.Dickinson.Check.Pattern ( checkNames- , traversePattern+module Language.Dickinson.Check.Pattern ( traversePattern+ , checkPatternDecl ) where +import Control.Applicative ((<|>)) import Data.Foldable (toList) import Data.Foldable.Ext (foldMapAlternative) import Data.List (group, sort)+import Data.Maybe (mapMaybe) import Language.Dickinson.Error import Language.Dickinson.Name import Language.Dickinson.Type@@ -13,9 +15,30 @@ traversePattern (PatternVar _ n) = [n] traversePattern (PatternTuple _ ps) = traversePattern =<< toList ps traversePattern Wildcard{} = []+traversePattern PatternCons{} = [] --- TODO: use this 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++checkPatternExpr :: Expression a -> Maybe (DickinsonError a)+checkPatternExpr Var{} = Nothing+checkPatternExpr Literal{} = Nothing+checkPatternExpr StrChunk{} = Nothing+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 (Choice _ brs) = foldMapAlternative (checkPatternExpr . snd) brs+checkPatternExpr (Concat _ es) = foldMapAlternative checkPatternExpr es+checkPatternExpr (Tuple _ es) = foldMapAlternative checkPatternExpr es+checkPatternExpr (Lambda _ _ _ e) = checkPatternExpr e+checkPatternExpr (Flatten _ e) = checkPatternExpr e+checkPatternExpr (Let _ bs e) = foldMapAlternative (checkPatternExpr . snd) bs <|> checkPatternExpr e+checkPatternExpr (Annot _ e _) = checkPatternExpr e+checkPatternExpr Constructor{} = Nothing++checkPatternDecl :: [Declaration a] -> Maybe (DickinsonError a) -- Expression+checkPatternDecl ds =+ foldMapAlternative checkPatternExpr (mapMaybe defExprM ds)
+ src/Language/Dickinson/Check/Scope.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE FlexibleContexts #-}++module Language.Dickinson.Check.Scope ( checkScope+ , checkScopeExpr+ , checkScopeDecl+ ) where++import Control.Applicative (Alternative, (<|>))+import Control.Monad.Except (MonadError)+import Control.Monad.State (State, evalState, get, modify)+import Data.Foldable (asum, traverse_)+import qualified Data.IntSet as IS+import Language.Dickinson.Check.Pattern+import Language.Dickinson.Error+import Language.Dickinson.Name+import Language.Dickinson.Type+import Language.Dickinson.Unique++type CheckM = State IS.IntSet++runCheckM :: CheckM a -> a+runCheckM = flip evalState IS.empty++insertName :: Name a -> CheckM ()+insertName (Name _ (Unique i) _) = modify (IS.insert i)++deleteName :: Name a -> CheckM ()+deleteName (Name _ (Unique i) _) = modify (IS.delete i)++-- | Checks that there are not any identifiers that aren't in scope; needs to run+-- after the renamer+checkScope :: [Declaration a] -> Maybe (DickinsonError a)+checkScope = runCheckM . checkDickinson++checkScopeExpr :: MonadError (DickinsonError a) m => Expression a -> m ()+checkScopeExpr = maybeThrow . runCheckM . checkExpr++checkScopeDecl :: MonadError (DickinsonError a) m => Declaration a -> m ()+checkScopeDecl = maybeThrow . runCheckM . checkDecl++checkDickinson :: [Declaration a] -> CheckM (Maybe (DickinsonError a))+checkDickinson d = traverse_ insDecl d *> mapSumM checkDecl d++insDecl :: Declaration a -> CheckM ()+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 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+ then pure Nothing+ else pure $ Just (UnfoundName l n)+checkExpr (Let _ bs e) = do+ let ns = fst <$> bs+ 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++mapSumM :: (Traversable t, Alternative f, Applicative m) => (a -> m (f b)) -> t a -> m (f b)+mapSumM = (fmap asum .) . traverse
− src/Language/Dickinson/DuplicateCheck.hs
@@ -1,49 +0,0 @@-module Language.Dickinson.DuplicateCheck ( checkDuplicates- ) where--import Control.Applicative ((<|>))-import Data.Foldable (toList)-import Data.Foldable.Ext (foldMapAlternative)-import Data.Function (on)-import Data.List (groupBy, sortBy)-import Data.Maybe (mapMaybe)-import qualified Data.Text as T-import Language.Dickinson.Error-import Language.Dickinson.Type--checkNames :: [(a, T.Text)] -> Maybe (DickinsonWarning a)-checkNames ns = foldMapAlternative announce (groupBy ((==) `on` snd) $ sortBy (compare `on` snd) ns)- where announce (_:(l, y):_) = Just $ DuplicateStr l y- announce _ = Nothing---- | Check that there are not duplicates in branches.-checkDuplicates :: [Declaration a] -> Maybe (DickinsonWarning a)-checkDuplicates = foldMapAlternative checkDeclDuplicates--checkDeclDuplicates :: Declaration a -> Maybe (DickinsonWarning a)-checkDeclDuplicates (Define _ _ e) = checkExprDuplicates e-checkDeclDuplicates TyDecl{} = Nothing--extrText :: Expression a -> Maybe (a, T.Text)-extrText (Literal l t) = pure (l, t)-extrText _ = Nothing--collectText :: [(b, Expression a)] -> [(a, T.Text)]-collectText = mapMaybe (extrText . snd)--checkExprDuplicates :: Expression a -> Maybe (DickinsonWarning a)-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/File.hs view
@@ -4,6 +4,7 @@ , evalFile , checkFile , validateFile+ , validateAmalgamate , warnFile , tcFile , amalgamateRename@@ -13,17 +14,19 @@ ) where import Control.Applicative ((<|>))+import Control.Composition ((.*)) import Control.Exception (Exception) import Control.Exception.Value-import Control.Monad ((<=<))+import Control.Monad (void, (<=<)) import Control.Monad.Except (ExceptT, MonadError, runExceptT) import Control.Monad.IO.Class (MonadIO) import Control.Monad.State (MonadState, StateT, evalStateT) import qualified Data.ByteString.Lazy as BSL-import Data.Semigroup ((<>))+import Data.Functor (($>)) import Data.Text as T import Language.Dickinson.Check-import Language.Dickinson.DuplicateCheck+import Language.Dickinson.Check.Duplicate+import Language.Dickinson.Check.Scope import Language.Dickinson.Error import Language.Dickinson.Eval import Language.Dickinson.Lexer@@ -31,7 +34,6 @@ import Language.Dickinson.Pipeline import Language.Dickinson.Rename import Language.Dickinson.Rename.Amalgamate-import Language.Dickinson.ScopeCheck import Language.Dickinson.Type import Language.Dickinson.TypeCheck import System.Random (StdGen, newStdGen, randoms)@@ -76,10 +78,13 @@ -- | Check scoping and types validateFile :: [FilePath] -> FilePath -> IO ()-validateFile is fp = do+validateFile = void .* validateAmalgamate++validateAmalgamate :: [FilePath] -> FilePath -> IO [Declaration AlexPosn]+validateAmalgamate is fp = do d <- amalgamateRename is fp maybeThrowIO $ checkScope d- eitherThrowIO $ tyRun d+ eitherThrowIO (tyRun d) $> d -- | Run some lints warnFile :: FilePath -> IO ()@@ -94,7 +99,10 @@ tcFile is = eitherThrowIO . tyRun <=< amalgamateRename is evalFile :: [FilePath] -> FilePath -> IO T.Text-evalFile is = fmap eitherThrow . evalIO . (evalDickinsonAsMain <=< amalgamateRenameM is)+evalFile is fp = (\g -> evalFileGen g is fp) =<< newStdGen++evalFileGen :: StdGen -> [FilePath] -> FilePath -> IO T.Text+evalFileGen g is = fmap eitherThrow . evalAllWithGen g . (evalDickinsonAsMain <=< amalgamateRenameM is) resolveFile :: [FilePath] -> FilePath -> IO [Declaration AlexPosn] resolveFile is = fmap eitherThrow . evalIO . (traverse resolveDeclarationM <=< amalgamateRenameM is)
src/Language/Dickinson/Lexer.x view
@@ -1,5 +1,6 @@ { {-# LANGUAGE DeriveAnyClass #-}+ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-}@@ -20,6 +21,7 @@ ) where import Control.Arrow ((&&&))+import Data.Data (Data) import Control.DeepSeq (NFData) import Control.Monad.Fail (MonadFail (..)) import Data.Bifunctor (first)@@ -297,6 +299,8 @@ deriving instance NFData AlexPosn deriving instance Binary AlexPosn++deriving instance Data AlexPosn data Token a = EOF { loc :: a } | TokIdent { loc :: a, ident :: Name a }
src/Language/Dickinson/Name.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-} module Language.Dickinson.Name ( TyName , Name (..)@@ -11,10 +12,10 @@ import Control.DeepSeq (NFData (..)) import Data.Binary (Binary (..))+import Data.Data (Data) import Data.Foldable (toList) import qualified Data.IntMap as IM import Data.List.NonEmpty (NonEmpty (..))-import Data.Semigroup ((<>)) import qualified Data.Text as T import Data.Text.Prettyprint.Doc (Pretty (pretty)) import Data.Text.Prettyprint.Doc.Ext (intercalate)@@ -28,7 +29,7 @@ data Name a = Name { name :: NonEmpty T.Text , unique :: !Unique , loc :: a- } deriving (Functor, Generic, Binary, Show)+ } deriving (Functor, Generic, Binary, Show, Data) instance NFData a => NFData (Name a) where rnf (Name _ u x) = rnf x `seq` u `seq` ()
src/Language/Dickinson/Pipeline.hs view
@@ -4,16 +4,16 @@ , format ) where -import Control.Exception.Value (eitherThrow)-import Control.Monad.Except (MonadError)-import Control.Monad.State.Lazy (MonadState)-import qualified Data.ByteString.Lazy as BSL-import qualified Data.Text as T-import Data.Text.Prettyprint.Doc.Ext (prettyText)+import Control.Exception.Value (eitherThrow)+import Control.Monad.Except (MonadError)+import Control.Monad.State.Lazy (MonadState)+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Text as T+import Data.Text.Prettyprint.Doc.Ext (prettyText)+import Language.Dickinson.Check.Scope import Language.Dickinson.Error import Language.Dickinson.Eval import Language.Dickinson.Parser-import Language.Dickinson.ScopeCheck import Language.Dickinson.Type import Language.Dickinson.TypeCheck
src/Language/Dickinson/Rename/Amalgamate.hs view
@@ -4,11 +4,13 @@ , fileDecls ) where -import Control.Monad ((<=<))-import Control.Monad.Except (MonadError)-import Control.Monad.IO.Class (MonadIO)-import Control.Monad.State (MonadState)-import Data.Semigroup ((<>))+import Control.Monad ((<=<))+import Control.Monad.Except (MonadError)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.State (MonadState)+import Data.Functor (($>))+import Data.Semigroup ((<>))+import Language.Dickinson.Check.Pattern import Language.Dickinson.Error import Language.Dickinson.Lexer import Language.Dickinson.Lib.Get@@ -27,7 +29,7 @@ => [FilePath] -- ^ Includes -> Dickinson AlexPosn -> m [Declaration AlexPosn]-amalgamateM _ (Dickinson [] ds) = pure ds+amalgamateM _ (Dickinson [] ds) = maybeThrow (checkPatternDecl ds) $> ds amalgamateM is (Dickinson imps ds) = do ids <- traverse (withImportM is) imps pure (concat ids <> ds)
− src/Language/Dickinson/ScopeCheck.hs
@@ -1,98 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--module Language.Dickinson.ScopeCheck ( checkScope- , checkScopeExpr- , checkScopeDecl- ) where--import Control.Applicative (Alternative, (<|>))-import Control.Monad.Except (MonadError)-import Control.Monad.State (State, evalState, get, modify)-import Data.Foldable (asum, traverse_)-import qualified Data.IntSet as IS-import Language.Dickinson.Check.Pattern-import Language.Dickinson.Error-import Language.Dickinson.Name-import Language.Dickinson.Type-import Language.Dickinson.Unique--type CheckM = State IS.IntSet--runCheckM :: CheckM a -> a-runCheckM = flip evalState IS.empty--insertName :: Name a -> CheckM ()-insertName (Name _ (Unique i) _) = modify (IS.insert i)--deleteName :: Name a -> CheckM ()-deleteName (Name _ (Unique i) _) = modify (IS.delete i)---- | Checks that there are not any identifiers that aren't in scope; needs to run--- after the renamer-checkScope :: [Declaration a] -> Maybe (DickinsonError a)-checkScope = runCheckM . checkDickinson--checkScopeExpr :: MonadError (DickinsonError a) m => Expression a -> m ()-checkScopeExpr = maybeThrow . runCheckM . checkExpr--checkScopeDecl :: MonadError (DickinsonError a) m => Declaration a -> m ()-checkScopeDecl = maybeThrow . runCheckM . checkDecl--checkDickinson :: [Declaration a] -> CheckM (Maybe (DickinsonError a))-checkDickinson d = traverse_ insDecl d *> mapSumM checkDecl d--insDecl :: Declaration a -> CheckM ()-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 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- then pure Nothing- else pure $ Just (UnfoundName l n)-checkExpr (Let _ bs e) = do- let ns = fst <$> bs- 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--mapSumM :: (Traversable t, Alternative f, Applicative m) => (a -> m (f b)) -> t a -> m (f b)-mapSumM = (fmap asum .) . traverse
src/Language/Dickinson/Type.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-} module Language.Dickinson.Type ( Dickinson (..) , Declaration (..)@@ -9,10 +10,13 @@ , Expression (..) , Pattern (..) , DickinsonTy (..)+ -- * Accesors+ , defExprM ) where import Control.DeepSeq (NFData) import Data.Binary (Binary)+import Data.Data (Data) import Data.Foldable (toList) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE@@ -38,7 +42,7 @@ , tyName :: Name a , tyCons :: NonEmpty (TyName a) }- deriving (Generic, NFData, Binary, Functor, Show)+ deriving (Generic, NFData, Binary, Functor, Show, Data) data Import a = Import { importAnn :: a , declMod :: Name a@@ -49,7 +53,7 @@ | PatternTuple a (NonEmpty (Pattern a)) | PatternCons a (TyName a) | Wildcard a- deriving (Generic, NFData, Binary, Functor, Show)+ deriving (Generic, NFData, Binary, Functor, Show, Data) data Expression a = Literal { exprAnn :: a, litText :: T.Text } | StrChunk { exprAnn :: a, chunkText :: T.Text }@@ -85,14 +89,14 @@ , exprTy :: DickinsonTy a } | Constructor { exprAnn :: a, constructorName :: TyName a }- deriving (Generic, NFData, Binary, Functor, Show)+ deriving (Generic, NFData, Binary, Functor, Show, Data) -- TODO: builtins? data DickinsonTy a = TyText a | TyFun a (DickinsonTy a) (DickinsonTy a) | TyTuple a (NonEmpty (DickinsonTy a)) | TyNamed a (Name a)- deriving (Generic, NFData, Binary, Show, Functor)+ deriving (Generic, NFData, Binary, Show, Functor, Data) instance Eq (DickinsonTy a) where (==) TyText{} TyText{} = True@@ -126,7 +130,7 @@ prettyMultiInterp :: [Expression a] -> Doc b prettyMultiInterp = mconcat . fmap prettyChunk- where prettyChunk (StrChunk _ t) = textHard t -- FIXME: convert "\n" to hardline...+ where prettyChunk (StrChunk _ t) = textHard t prettyChunk e = "${" <> pretty e <> "}" textHard :: T.Text -> Doc a@@ -173,3 +177,7 @@ pretty (TyFun _ t t') = parens ("⟶" <+> pretty t <+> pretty t') pretty (TyTuple _ ts) = tupled (toList (pretty <$> ts)) pretty (TyNamed _ n) = pretty n++defExprM :: Declaration a -> Maybe (Expression a)+defExprM (Define _ _ e) = Just e+defExprM TyDecl{} = Nothing
src/Language/Dickinson/Unique.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Language.Dickinson.Unique ( Unique (..)@@ -7,11 +8,12 @@ import Control.DeepSeq (NFData) import Data.Binary (Binary (..))+import Data.Data (Data) import Data.Text.Prettyprint.Doc (Pretty) -- | For interning identifiers. newtype Unique = Unique { unUnique :: Int }- deriving (Eq, Ord, Pretty, NFData, Binary, Show)+ deriving (Eq, Ord, Pretty, NFData, Binary, Show, Data) -- | Dummy unique for sake of testing dummyUnique :: Unique
test/Spec.hs view
@@ -2,27 +2,29 @@ module Main (main) where -import Control.Exception.Value (eitherThrow)-import qualified Data.ByteString.Lazy as BSL-import Data.Either (isRight)-import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe (isJust, isNothing)+import Control.Exception.Value (eitherThrow)+import qualified Data.ByteString.Lazy as BSL+import Data.Either (isRight)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Maybe (isJust, isNothing) import Eval import Golden import Language.Dickinson.Check+import Language.Dickinson.Check.Duplicate import Language.Dickinson.Check.Internal-import Language.Dickinson.DuplicateCheck+import Language.Dickinson.Check.Pattern+import Language.Dickinson.Check.Scope import Language.Dickinson.File import Language.Dickinson.Import import Language.Dickinson.Lexer import Language.Dickinson.Name import Language.Dickinson.Parser import Language.Dickinson.Rename-import Language.Dickinson.ScopeCheck import Language.Dickinson.Type import Language.Dickinson.Unique import Test.Tasty import Test.Tasty.HUnit+import TH import TypeCheck main :: IO ()@@ -65,6 +67,8 @@ , parseNoError "test/data/multiQuoteify.dck" , findPath , sanityCheckTest "test/data/adt.dck"+ , detectSuspiciousPattern "test/error/badMatch.dck"+ , thTests ] findPath :: TestTree@@ -84,6 +88,11 @@ detectDuplicate fp = testCase ("Detects duplicate name (" ++ fp ++ ")") $ do (Dickinson _ parsed) <- readNoFail fp assertBool fp $ isJust (checkMultiple parsed)++detectSuspiciousPattern :: FilePath -> TestTree+detectSuspiciousPattern fp = testCase fp $ do+ (Dickinson _ parsed) <- readNoFail fp+ assertBool fp $ isJust (checkPatternDecl parsed) detectScopeError :: FilePath -> TestTree detectScopeError fp = testCase "Finds scoping error" $ do
+ test/TH.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module TH ( thTests+ ) where++import Language.Dickinson+import Language.Dickinson.TH+import Test.Tasty+import Test.Tasty.HUnit++thDecl :: [Declaration AlexPosn]+thDecl = $(dickinson [] "test/eval/context.dck")++thTests :: TestTree+thTests =+ testCase "Returns result" $ do+ res <- run thDecl+ res @?= "woman"
+ test/error/badMatch.dck view
@@ -0,0 +1,5 @@+%-++(:def main+ (:match ("Hello", "World") (t, t)+ t))