diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,12 @@ # dickinson +## 0.1.1.2 + + * Ignore lines starting with `#!` (for shell shebangs) + * Fix bug in evaluator which caused `:flatten` to work improperly. + * Fix bug which caused `:match` within `:flatten` to work improperly. + * Formatter is now usable; added `--inplace` flag to `emd fmt` + ## 0.1.1.1 * Run typechecker before evaluator in executable/REPL diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -1,20 +1,32 @@ module Main (main) where 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 Language.Dickinson.Check +import Language.Dickinson.Check.Internal import Language.Dickinson.DuplicateCheck +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 +benchResult :: FilePath -> Benchmark +benchResult fp = bench fp $ nfIO (evalFile [] fp) + +benchPipeline :: FilePath -> Benchmark +benchPipeline fp = bench fp $ nfIO (pipeline [] fp) + main :: IO () main = defaultMain [ env parses $ \ ~(c, s) -> @@ -46,19 +58,36 @@ , bench "bench/data/multiple.dck" $ nf checkDuplicates p -- TODO: better example ] , bgroup "result" - [ bench "test/eval/context.dck" $ nfIO (evalFile [] "test/eval/context.dck") - , bench "examples/shakespeare.dck" $ nfIO (evalFile [] "examples/shakespeare.dck") + [ benchResult "test/eval/context.dck" + , benchResult "examples/shakespeare.dck" , bench "examples/doggo.dck" $ nfIO (evalFile ["prelude"] "examples/doggo.dck") , bench "test/demo/animal.dck" $ nfIO (evalFile ["lib"] "test/demo/animal.dck") - , bench "examples/fortune.dck" $ nfIO (evalFile [] "examples/fortune.dck") + , benchResult "examples/fortune.dck" ] , bgroup "pipeline" - [ bench "examples/shakespeare.dck" $ nfIO (pipeline [] "examples/shakespeare.dck") - , bench "examples/fortune.dck" $ nfIO (pipeline [] "examples/fortune.dck") + [ benchPipeline "examples/shakespeare.dck" + , benchPipeline "examples/fortune.dck" + , benchPipeline "examples/catherineOfSienaBot.dck" ] , bgroup "tcFile" - [ bench "examples/fortune.dck" $ nfIO (tcFile [] "examples/fortune.dck") + [ bench "examples/fortune.dck" $ nfIO (tcFile [] "examples/fortune.dck") -- TODO: tc with syntax tree in env? ] + , env amalFortune $ \f -> + bgroup "typecheck" + [ bench "examples/fortune.dck" $ nf tyRun f ] + , env amalgamated $ \ ~(s, c) -> + bgroup "check + eval" + [ bench "examples/shakespeare.dck" $ nfIO (txtIO s) + , bench "examples/catherineOfSienaBot.dck" $ nfIO (txtIO c) + ] + , env amalgamated $ \ ~(s, c) -> + bgroup "eval" + [ bench "examples/shakespeare.dck" $ nfIO (evalIO $ evalDickinsonAsMain s) + , bench "examples/catherineOfSienaBot.dck" $ nfIO (evalIO $ evalDickinsonAsMain c) + ] + , env multiParsed $ \p -> + bgroup "maxUnique" + [ bench "bench/data/multiple.dck" $ nf maxUniqueDickinson p ] ] where libFile = BSL.readFile "lib/color.dck" @@ -69,6 +98,17 @@ encoded = encode . void <$> multiParsed encodeShakespeare = encode . void . either throw id . parse <$> shakespeare encodeEnv = (,) <$> encoded <*> encodeShakespeare + amalFortune = amalgamateRename [] "examples/fortune.dck" + amalgamated = (,) + <$> amalgamateRename [] "examples/shakespeare.dck" + <*> amalgamateRename [] "examples/catherineOfSienaBot.dck" plainExpr :: (UniqueCtx, Dickinson a) -> Dickinson a plainExpr = fst . uncurry renameDickinson + +-- FIXME: StdGen in env? +txtIO :: [Declaration AlexPosn] -> IO T.Text +txtIO = fmap eitherThrow . evalIO . checkEvalM + +maxUniqueDickinson :: Dickinson AlexPosn -> Int +maxUniqueDickinson (Dickinson _ ds) = maximum (maxUniqueDeclaration <$> ds) diff --git a/examples/catherineOfSienaBot.dck b/examples/catherineOfSienaBot.dck --- a/examples/catherineOfSienaBot.dck +++ b/examples/catherineOfSienaBot.dck @@ -24,6 +24,14 @@ (| "If you have conceived the virtue of courage within you, you will always be strong and constant.") (| ''' + Their disordered love for themselves, out of which grew all their wickedness, will burn and torture them intolerably, + for along with pride it is the head and source of all evil. + ''') + (| "Just as a mirror reflect's a person's face, just so, the fruit of their labors will be reflected in their bodies.") + (| "The soul by its nature always craves what is good.") + (| "Conscience always pulls in one direction, and sensuality in the other.") + (| + ''' I bound her into a body formed from the vilest earth so that when she saw her beauty she would not lift up her head in pride. ''') @@ -31,12 +39,14 @@ ''' I am the rewarder of every labor, and I give to all in accordance with their state in life and effort. ''') + (| "Every good is rewarded and every sin punished.") (| "One cannot be deprived of the practice of doing good unless one so chooses.") (| ''' The more they have to endure, the more delighted they are. Indeed, suffering many difficulties is for them a kind of refreshment. ''') + (| "Every evil is grounded in selfish love of oneself.") (| "You should build your foundation by slaying and annhilating your self-will.") (| "Humility comes from knowledge and holy hatred of oneself.") (| "All the sufferings the soul bears or can bear in this life are not enough to punish one smallest sin.") @@ -44,11 +54,105 @@ (| "Suffering and sorrow increase in proportion to love.") (| "Everywhere, on all levels of society, all are giving birth to sin.") (| "All virtues are bound together.") + (| "Neither the devil nor any other creature can force you to the least sin unless you want it.") + (| "Though the world may persecute you, I am at your side and never will my providence fail you.") + (| "Weep for the damnation of the foolish and be glad for the perfection of my beloved children.") + (| "In whatever situation people may be, let their will be good and holy.") (| ''' + Just as venom is painful to the body and ultimately causes death unless a person makes the effort to vomit + it out and take some medicine, so it is with the scorpion of the world's pleasure. + ''') + (| + ''' + Because the world's troubles sometimes weary them, they begin to dislike the world. And if they take advantage + of this fear enlightened by faith, they will progress to the love of virtue. + ''') + (| "Perseverance is the virtue that receives glory.") + (| "While you are alive you have a season of mercy, but once you are dead it is your season of justice.") + ; (| "The soul cannot stand still: she either to advance toward virtue or turn back.") FIXME + (| "Ordinary people are deluded in their sensual love.") + (| "The soul in the purity of her conscience sees guilt even when there was no guilt.") + (| "The world holds them in reverence because they have despised the world.") + (| "Sufferings increase and strengthen virtue.") + (| "Those in power rule with great injustice and vanity.") + (| + ''' + And they are happier to see many different ways than if they were to see everyone walking the same way, + because this way they see the greatness of my goodness more fully revealed. In everything they find joy + and the fragrance of the rose. This is true not only of good things; even when they see something that is + clearly sinful they do not pass judgment, but rather feel a holy and genuine compassion, praying for the + sinner and saying with perfect humility "Today it is your turn; tomorrow it will be mine unless divine + grace holds up." + ''') + (| "There is no one who can judge the hidden heart.") + (| "The perfect receive eternal life, and the wicked eternal damnation.") + (| "The heart is source of all emotions.") + (| "You reach perfection through knowledge and contempt of yourself.") + (| "If she were anything at all of herself, she would be able to get rid of what she did not want.") + (| "The more the heart loves, the more sorrow it has.") + (| + ''' + The devil fled. But he returned with another attack, wanting to exalt you in pride. He said "You are perfect + and pleasing to God. You no longer need to torture yourself or weep over your sins." + ''') + (| + ''' + It is far better to walk in the spiritual counsel of a humble and unschooled person with a holy and upright + conscience than by that of a well-read but proud scholar. + ''') + (| + ''' Just as you can better see the blemish on your face when you look at yourself in a mirror, so the soul who in true self-knowledge rises up with desire to look at herself in the gentle mirror of God with the eye of understanding sees all the more clearly her own defects because of the purity she sees in him. + ''') + (| + ''' + Even if your neighbors' sins are clearly shown to your spirit not just once or twice but many times, you + should still not confront them with specific sins. Rather, when they come to visit you, you should correct + their bad habits in a general way and kindly plant the virtues, adding severity to your kindness when you + must. + ''') + (| "Penance is good for beating down the body when it wants to fight against the spirit.") + (| "Things can be better known by looking at their opposites.") + (| "You cannot live without love.") + (| "Your being was given to you for love.") + (| "Your dull bodily senses are deceived.") + (| "No cloak can hide anything from my sight.") + (| "Those whose reprimands are only words unsupported by good and well-ordered life are doing wrong.") + (| "Pleasures are for worldly people.") + (| "The body is a dead thing because it has no life in itself.") + (| "Hundred is a perfect number.") + (| "It is in every respect dangerous to be content with mediocre obedience.") + (| "All, no matter what their state in life, can have perfect merit.") + (| + ''' + So it is with prelates or anyone else in authority. If they see the members who are their subjects rotting + because of the filth of deadly sin and apply only the ointment of soft words without reproof, they will + never get well. Rather, they will infect the other members with whom they form one body under their shepherd. + ''') + (| "There is no service without hope, for servants serve in the hope of pleasing") + (| "Those who trust in themselves are afraid of their own shadow; they expect both heaven and earth to let them down.") + (| "Those who were perfect took on qualities of the sun.") + (| "Everyone who is virtuous is worthy of love.") + (| "There is no one in this life, no matter how perfect, who cannot grow to greater perfection.") + (| "As long as you are alive you can still grow in perfection and merit.") + (| "One's catch will be as perfect as one's cast.") + (| "The human body cannot live on nothing but greens.") + (| "People are humble as they are obedient and obedient as they are humble.") + (| + ''' + It is impossible to keep one's mind pure while indulging in a great social life, bodily delicacy, and + inordinate eating. + ''') + (| + ''' + If you turn to purgatory, there you will find my gentle immeasurable providence. + ''') + (| + ''' + Those who go the way of great self-contempt are, it is true, more apt to reach perfection. ''') (| ''' diff --git a/examples/fionaBot.dck b/examples/fionaBot.dck --- a/examples/fionaBot.dck +++ b/examples/fionaBot.dck @@ -1,6 +1,6 @@ %- -; see https://twitter.com/fionalyric for a fully fleshed-out implementation of this idea +; see https://twitter.com/fionalyric for a fleshed-out implementation of this idea (:def fiona (:oneof @@ -13,19 +13,35 @@ (| "What does she think of me?") (| "You raped me in the same bed your daughter was born in.") (| "I want to suffer for my sins") + (| "I'm full as a tick") + (| "I wanna make a mistake") + (| "Scratch me out, free yourself.") + (| "Run, free yourself of me.") + (| + ''' + Oh darling, it's so sweet + You think you know how crazy, how crazy I am. + ''') (| "I need to be redeemed to the one I've sinned against") (| ''' + He said "It's all in your head," + And I said "so's everything" but he didn't get it. + ''') + (| + ''' My feel for you, boy Is decaying in front of me Like the carrion of a murdered prey ''') + (| "I don't feel anything until I smash it up") + (| "I may need a chaperone") (| ''' All that love must've been lacking something If I got bored trying to figure you out ''') - (| + (| ''' So I will keep a deliberate pace Let the damned breeze dry my face @@ -36,7 +52,7 @@ If I let you get too close ''') (| "Hunger hurts but starving works.") - (| + (| ''' What's so impressive about a diamond Except the mining diff --git a/examples/fortune.dck b/examples/fortune.dck --- a/examples/fortune.dck +++ b/examples/fortune.dck @@ -24,18 +24,23 @@ (| "Guilt redeems, not love.") (| "There is no such thing as metaphors.") (| "Excess is a sin.") + (| "Hunger is hope.") (| "Spurn your family.") (| "Salvation is finality.") (| "Knowledge begets humility.") (| "Love animals.") - ; judgment + (| "Today is a good day to practice bilocation.") + (| "Drugs have no mystic content.") (| "Irony is the weakest brand of pessimism") (| "Sex wastes the male body.") + (| "Did you remember to put apotheosis on your to-do list?") (| "Cultivate weakness.") (| "Beauty is a moral imperative.") - (| "We are all damned by our own personalities. That is beauty.") + (| "We are all united in being damned by our own personalities. That is beauty.") + (| "What do you know about dietetics?") (| "Hobbies are sublunary") (| "To err is immoral.") + (| "Bats can give humans rabies.") (| $ quote ("« Le beau est ce qu'on désire sans vouloir le manger. »", "Simone Weil")) (| $ quote ("\"You're more likely to get cut with a dull tool than a sharp one.\"", "Fiona Apple")) (| $ quote ("\"You forgot the difference between equanimity and passivity.\"", "Fiona Apple")) diff --git a/language-dickinson.cabal b/language-dickinson.cabal --- a/language-dickinson.cabal +++ b/language-dickinson.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: language-dickinson -version: 0.1.1.1 +version: 0.1.1.2 license: BSD3 license-file: LICENSE copyright: Copyright: (c) 2020 Vanessa McHale @@ -85,6 +85,7 @@ Language.Dickinson.DuplicateCheck Language.Dickinson.Unique Language.Dickinson.File + Language.Dickinson.Pipeline Language.Dickinson.Import Language.Dickinson.Lib Language.Dickinson.Check.Internal @@ -153,6 +154,7 @@ REPL REPL.Save REPL.Completions + Format Paths_language_dickinson autogen-modules: Paths_language_dickinson @@ -247,7 +249,8 @@ dickinson -any, binary -any, criterion -any, - bytestring -any + bytestring -any, + text -any if impl(ghc >=8.0) ghc-options: diff --git a/lib/adjectives.dck b/lib/adjectives.dck --- a/lib/adjectives.dck +++ b/lib/adjectives.dck @@ -2,4 +2,10 @@ (:def adjective (:oneof + (| "sententious") + (| "poetic") + (| "plain") + (| "bromide") + (| "banal") + (| "pithy") (| "stentorian"))) diff --git a/lib/noun.dck b/lib/noun.dck --- a/lib/noun.dck +++ b/lib/noun.dck @@ -3,5 +3,10 @@ (:def noun (:oneof (| "valetudinarian") + (| "heliophagy") (| "valedictorian") + (| "apothegm") + (| "apotheosis") + (| "aphelion") + (| "perihelion") (| "folderol"))) diff --git a/lib/profession.dck b/lib/profession.dck new file mode 100644 --- /dev/null +++ b/lib/profession.dck @@ -0,0 +1,24 @@ +%- + +(:def profession + (:oneof + (| "professor") + (| "psychiatrist") + (| "physician") + (| "poet") + (| "psychologist") + (| "banker") + (| "sociologist") + (| "scientist") + (| "biologist") + (| "ecologist") + (| "mathematician") + (| "statistician") + (| "epidemiologist") + (| "sanitation worker") + (| "teacher") + (| "police officer") + (| "lawyer") + (| "engineer") + (| "writer") + (| "artist"))) diff --git a/man/emd.1 b/man/emd.1 --- a/man/emd.1 +++ b/man/emd.1 @@ -10,6 +10,8 @@ \f[B]Dickinson\f[R] is a text-generation language .SH SYNOPSIS .PP +emd fortune.dck +.PP emd repl .PP emd run literature.dck @@ -17,6 +19,17 @@ emd run project.dck --include lib .PP man $(emd man) +.SS SHEBANG +.PP +Dickinson ignores lines starting with \f[C]#!\f[R] so we can put +.IP +.nf +\f[C] +#!/usr/bin/env emd +\f[R] +.fi +.PP +at the top of a file and \f[C]emd\f[R] will be used as an interpreter. .SH SUBCOMMANDS .PP \f[B]repl\f[R] - Start a repl diff --git a/run/Format.hs b/run/Format.hs new file mode 100644 --- /dev/null +++ b/run/Format.hs @@ -0,0 +1,15 @@ +module Format ( fmtFile + , fmtInplace + ) where + +import Control.Monad ((<=<)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import Data.Text.IO as TIO +import Language.Dickinson.Pipeline + +fmtFile :: FilePath -> IO () +fmtFile = TIO.putStrLn . format <=< BSL.readFile + +fmtInplace :: FilePath -> IO () +fmtInplace fp = TIO.writeFile fp . format . BSL.fromStrict =<< BS.readFile fp diff --git a/run/Main.hs b/run/Main.hs --- a/run/Main.hs +++ b/run/Main.hs @@ -1,7 +1,9 @@ module Main (main) where +import Data.Foldable (traverse_) import Data.Semigroup import qualified Data.Text.IO as TIO +import Format import Language.Dickinson (dickinsonVersionString) import Language.Dickinson.File import Language.Dickinson.Lib @@ -13,9 +15,9 @@ -- TODO debug/verbosity options... data Act = Run !FilePath ![FilePath] | REPL ![FilePath] - | Check !FilePath ![FilePath] - | Lint !FilePath - | Format !FilePath + | Check ![FilePath] ![FilePath] + | Lint ![FilePath] + | Format !FilePath Bool | Man main :: IO () @@ -32,7 +34,9 @@ ) <|> runP formatP :: Parser Act -formatP = Format <$> dckFile +formatP = Format + <$> dckFile + <*> switch (long "inplace" <> short 'i' <> help "Overwrite file in-place") replP :: Parser Act replP = REPL <$> many dckFile @@ -41,10 +45,10 @@ runP = Run <$> dckFile <*> includes checkP :: Parser Act -checkP = Check <$> dckFile <*> includes +checkP = Check <$> some dckFile <*> includes lintP :: Parser Act -lintP = Lint <$> dckFile +lintP = Lint <$> some dckFile dckFile :: Parser FilePath dckFile = argument str @@ -75,9 +79,10 @@ versionMod = infoOption dickinsonVersionString (short 'V' <> long "version" <> help "Show version") run :: Act -> IO () -run (Run fp is) = do { pGo <- defaultLibPath ; TIO.putStrLn =<< pipeline (pGo is) fp } -run (REPL _) = dickinsonRepl -run (Check f i) = do { pathMod <- defaultLibPath ; validateFile (pathMod i) f } -- FIXME: reuse -run (Lint f) = warnFile f -run (Format fp) = fmtFile fp -run Man = putStrLn =<< ( "emd.1") . ( "man") <$> getDataDir +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 (Lint fs) = traverse_ warnFile fs +run (Format fp False) = fmtFile fp +run (Format fp True) = fmtInplace fp +run Man = putStrLn . ( "emd.1") . ( "man") =<< getDataDir diff --git a/run/REPL.hs b/run/REPL.hs --- a/run/REPL.hs +++ b/run/REPL.hs @@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} module REPL ( dickinsonRepl ) where @@ -118,7 +117,7 @@ listNames = liftIO . traverse_ TIO.putStrLn =<< names names :: Repl AlexPosn [T.Text] -names = lift $ namesState +names = lift namesState bindDisplay :: T.Text -> Repl AlexPosn () bindDisplay t = do diff --git a/run/REPL/Completions.hs b/run/REPL/Completions.hs --- a/run/REPL/Completions.hs +++ b/run/REPL/Completions.hs @@ -14,7 +14,7 @@ namesState = gets (M.keys . topLevel) namesStr :: StateT (EvalSt a) IO [String] -namesStr = fmap T.unpack <$> gets (M.keys . topLevel) +namesStr = gets (fmap T.unpack . M.keys . topLevel) cyclicSimple :: [String] -> [Completion] cyclicSimple [] = [] diff --git a/src/Language/Dickinson/Check/Internal.hs b/src/Language/Dickinson/Check/Internal.hs --- a/src/Language/Dickinson/Check/Internal.hs +++ b/src/Language/Dickinson/Check/Internal.hs @@ -1,5 +1,6 @@ module Language.Dickinson.Check.Internal ( sanityCheck , sanityCheckLexer + , maxUniqueDeclaration ) where import Control.Monad (when) @@ -28,6 +29,8 @@ when (storedMax < computedMax) $ error "Sanity check failed!" +-- TODO: see http://hackage.haskell.org/package/uniplate-1.6.12/docs/Data-Generics-Uniplate-Operations.html +-- TODO: recursion schemes? would need benchmark... maxUniqueDeclaration :: Declaration a -> Int maxUniqueDeclaration (Define _ (Name _ (Unique i) _) e) = max i (maxUniqueExpression e) maxUniqueDeclaration (TyDecl _ (Name _ (Unique i) _) tns) = diff --git a/src/Language/Dickinson/Eval.hs b/src/Language/Dickinson/Eval.hs --- a/src/Language/Dickinson/Eval.hs +++ b/src/Language/Dickinson/Eval.hs @@ -49,7 +49,7 @@ -- Used in the REPL, for instance , lexerState :: AlexUserState -- For error messages - , tyEnv :: (TyEnv a) + , tyEnv :: TyEnv a } @@ -250,6 +250,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 _ _ = error "Internal error in function mapChoice." setFrequency :: NonEmpty (Double, Expression a) -> NonEmpty (Double, Expression a) setFrequency = fmap (\(_, e) -> (fromIntegral $ {-# SCC "countNodes" #-} countNodes e, e)) @@ -262,6 +263,7 @@ countNodes (MultiInterp _ es) = product (fmap countNodes es) countNodes (Concat _ es) = product (fmap countNodes es) countNodes (Annot _ e _) = countNodes e +countNodes _ = error "Internal error in function countNodes" concatOrFail :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => (T.Text -> T.Text) -> a -> [Expression a] -> m (Expression a) concatOrFail process l = fmap (Literal l . process . mconcat) . traverse evalExpressionAsTextM @@ -279,7 +281,7 @@ resolveFlattenM e@Literal{} = pure e resolveFlattenM e@StrChunk{} = pure e resolveFlattenM e@Constructor{} = pure e -resolveFlattenM (Var _ n) = lookupName n +resolveFlattenM (Var _ n) = resolveFlattenM =<< lookupName n resolveFlattenM (Choice l pes) = do let ps = fst <$> pes es <- traverse resolveFlattenM (snd <$> pes) @@ -300,9 +302,10 @@ resolveFlattenM e''' _ -> error "Ill-typed expression" resolveFlattenM e@Lambda{} = pure e -resolveFlattenM (Match _ e p e') = - (bindPattern p =<< resolveFlattenM e) *> - resolveFlattenM e' +resolveFlattenM (Match _ e p e') = do + modSt <- bindPattern p =<< resolveFlattenM e + withSt modSt $ + resolveFlattenM e' resolveFlattenM (Flatten l e) = Flatten l <$> resolveFlattenM e resolveFlattenM (Annot _ e _) = resolveFlattenM e diff --git a/src/Language/Dickinson/File.hs b/src/Language/Dickinson/File.hs --- a/src/Language/Dickinson/File.hs +++ b/src/Language/Dickinson/File.hs @@ -8,35 +8,33 @@ , tcFile , amalgamateRename , amalgamateRenameM - , fmtFile , pipeline , resolveFile ) where -import Control.Applicative ((<|>)) -import Control.Exception (Exception) +import Control.Applicative ((<|>)) +import Control.Exception (Exception) import Control.Exception.Value -import Control.Monad ((<=<)) -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.Text as T -import Data.Text.Prettyprint.Doc (hardline, pretty) -import Data.Text.Prettyprint.Doc.Render.Text (putDoc) +import Control.Monad ((<=<)) +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.Text as T import Language.Dickinson.Check import Language.Dickinson.DuplicateCheck import Language.Dickinson.Error import Language.Dickinson.Eval import Language.Dickinson.Lexer import Language.Dickinson.Parser +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) +import System.Random (StdGen, newStdGen, randoms) data AmalgamateSt = AmalgamateSt { amalgamateRenames :: Renames , amalgamateLexerState :: AlexUserState @@ -72,10 +70,6 @@ -> IO [Declaration AlexPosn] amalgamateRename is fp = flip evalStateT initAmalgamateSt $ fmap eitherThrow $ runExceptT $ amalgamateRenameM is fp --- TODO: smart formatter -fmtFile :: FilePath -> IO () -fmtFile = putDoc . (<> hardline) . pretty . eitherThrow . parse <=< BSL.readFile - -- | Check scoping checkFile :: [FilePath] -> FilePath -> IO () checkFile = ioChecker checkScope @@ -106,8 +100,5 @@ resolveFile is = fmap eitherThrow . evalIO . (traverse resolveDeclarationM <=< amalgamateRenameM is) pipeline :: [FilePath] -> FilePath -> IO T.Text -pipeline is fp = fmap eitherThrow $ evalIO $ do - ds <- amalgamateRenameM is fp - maybeThrow $ checkScope ds - tyTraverse ds - evalDickinsonAsMain ds +pipeline is fp = fmap eitherThrow $ evalIO $ + checkEvalM =<< amalgamateRenameM is fp diff --git a/src/Language/Dickinson/Lexer.x b/src/Language/Dickinson/Lexer.x --- a/src/Language/Dickinson/Lexer.x +++ b/src/Language/Dickinson/Lexer.x @@ -72,6 +72,7 @@ tokens :- + <0> "#!".* ; -- ignore shebangs <0> { $white+ ; @@ -154,7 +155,7 @@ mod_ust (\(x,push,y,z) -> (x,st:push,y,z)) exitInterp :: Alex () -exitInterp = do +exitInterp = do (_,iSt:_,_,_) <- get_ust case iSt of InStr -> set_scd string diff --git a/src/Language/Dickinson/Pipeline.hs b/src/Language/Dickinson/Pipeline.hs new file mode 100644 --- /dev/null +++ b/src/Language/Dickinson/Pipeline.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Language.Dickinson.Pipeline ( checkEvalM + , 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 Language.Dickinson.Error +import Language.Dickinson.Eval +import Language.Dickinson.Parser +import Language.Dickinson.ScopeCheck +import Language.Dickinson.Type +import Language.Dickinson.TypeCheck + +checkEvalM :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => [Declaration a] -> m T.Text +checkEvalM ds = do + maybeThrow $ checkScope ds + tyTraverse ds + evalDickinsonAsMain ds + +format :: BSL.ByteString -> T.Text +format = prettyText . eitherThrow . parse diff --git a/src/Language/Dickinson/Type.hs b/src/Language/Dickinson/Type.hs --- a/src/Language/Dickinson/Type.hs +++ b/src/Language/Dickinson/Type.hs @@ -14,7 +14,7 @@ import Control.DeepSeq (NFData) import Data.Binary (Binary) import Data.Foldable (toList) -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Semigroup ((<>)) import qualified Data.Text as T @@ -117,6 +117,9 @@ prettyChoiceBranch :: (Double, Expression a) -> Doc b prettyChoiceBranch (d, e) = parens (pipe <+> pretty d <+> pretty e) +prettyChoiceOneof :: Expression a -> Doc b +prettyChoiceOneof e = parens (pipe <+> pretty e) + prettyInterp :: Expression a -> Doc b prettyInterp (StrChunk _ t) = pretty (escReplace t) prettyInterp e = "${" <> pretty e <> "}" @@ -141,14 +144,18 @@ . T.replace "\n" "\\n" . T.replace "${" "\\${" +allEq :: Eq a => NonEmpty a -> Bool +allEq (x :| xs) = all (== x) xs + -- figure out indentation instance Pretty (Expression a) where pretty (Var _ n) = pretty n pretty (Literal _ l) = dquotes $ pretty (escReplace l) pretty (Let _ ls e) = group (parens (":let" <^> vsep (toList (fmap prettyLetLeaf ls) ++ [pretty e]))) - -- TODO: if they're all equal, use :oneof -- also comments lol - pretty (Choice _ brs) = parens (":branch" <#> indent 2 (hardSep (toList $ fmap prettyChoiceBranch brs))) + pretty (Choice _ brs) + | allEq (fst <$> brs) = parens (":oneof" <#> indent 2 (hardSep (toList $ fmap prettyChoiceOneof (snd <$> brs)))) + | otherwise = parens (":branch" <#> indent 2 (hardSep (toList $ fmap prettyChoiceBranch brs))) 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)) diff --git a/test/Eval.hs b/test/Eval.hs --- a/test/Eval.hs +++ b/test/Eval.hs @@ -3,6 +3,7 @@ module Eval ( evalTests ) where +import Control.Monad ((<=<)) import qualified Data.Text as T import Language.Dickinson.File import Test.Tasty (TestTree, testGroup) @@ -22,6 +23,7 @@ , resolveCase "test/data/hangIndefinitely.dck" , testCase "Should handle interpolated multiline strings" multiQuoteEval , testCase "Should handle nested interpolations" multiInterpolatedNestedEval + , testCase "test/data/flattenLambda.dck" example ] forceResult :: a -> Assertion @@ -34,14 +36,13 @@ resolveCase fp = testCase fp $ resolve fp resolve :: FilePath -> Assertion -resolve fp = do - res <- resolveFile ["prelude", "lib"] fp - forceResult res +resolve = forceResult <=< resolveFile ["prelude", "lib"] result :: FilePath -> Assertion -result fp = do - res <- evalFile ["prelude", "lib"] fp - forceResult res +result = forceResult <=< evalFile ["prelude", "lib"] + +example :: Assertion +example = forceResult =<< evalFile ["examples"] "test/data/flattenLambda.dck" evalTo :: FilePath -> T.Text -> Assertion evalTo fp t = do diff --git a/test/data/flattenLambda.dck b/test/data/flattenLambda.dck new file mode 100644 --- /dev/null +++ b/test/data/flattenLambda.dck @@ -0,0 +1,5 @@ +(:include fortune) + +%- + +(:def main (:flatten fortune)) diff --git a/test/data/lexDollarSign.pretty b/test/data/lexDollarSign.pretty --- a/test/data/lexDollarSign.pretty +++ b/test/data/lexDollarSign.pretty @@ -1,11 +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}$"))) + (:oneof + (| "$") + (| "$a") + (| "$$") + (| "$${a}") + (| "$\${a}") + (| "$a${a}") + (| "${a}$"))) diff --git a/test/data/multiQuoteify.pretty b/test/data/multiQuoteify.pretty --- a/test/data/multiQuoteify.pretty +++ b/test/data/multiQuoteify.pretty @@ -9,5 +9,5 @@ '''))) (:def main - (:branch - (| 1.0 ($ ($ quote "God created war so that Americans would learn geography.") "Mark Twain")))) + (:oneof + (| ($ ($ quote "God created war so that Americans would learn geography.") "Mark Twain")))) diff --git a/test/data/nestLet.pretty b/test/data/nestLet.pretty --- a/test/data/nestLet.pretty +++ b/test/data/nestLet.pretty @@ -5,6 +5,6 @@ [a (:let [a "man"] a)] [b (:let [a "woman"] a)] [c (:let [a "non-binary"] a)] - (:branch - (| 1.0 (:let [b a] b)) - (| 1.0 b)))) + (:oneof + (| (:let [b a] b)) + (| b))))