Skip to content

Commit

Permalink
upgrade to output-blocks (#8)
Browse files Browse the repository at this point in the history
  • Loading branch information
@nimec01
nimec01 authored Nov 7, 2024
1 parent 278d13c commit f2f029b
Show file tree
Hide file tree
Showing 9 changed files with 64 additions and 48 deletions.
2 changes: 1 addition & 1 deletion app/draw.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -20,7 +20,7 @@ main = do
scope:f:xs' -> do
inst <- B.readFile f
alloyInstance <- runExceptT $ AD.parseInstance inst
let sd = failWith id . parseInstance scope . failWith show $ alloyInstance
let sd = failWith show . parseInstance scope . failWith id $ alloyInstance
withArgs xs' $ mainWith (drawDiagram Unstyled sd)
_ -> error "usage: two parameters required: String (scope) FilePath (Alloy instance)"

Expand Down
8 changes: 4 additions & 4 deletions app/enumeratedArrowsDirectDemo.hs
View file
Original file line number Diff line number Diff line change
@@ -1,13 +1,13 @@
{-# LANGUAGE FlexibleContexts #-}
module Main (main) where
import Control.Monad.Output (
import Control.OutputCapable.Blocks (
LangM,
Language (English),
Rated,
ReportT,
)
import Control.Monad.Output.Generic (($>>=))
import Control.Monad.Output.Debug (testTask)
import Control.OutputCapable.Blocks.Generic (($>>=))
import Control.OutputCapable.Blocks.Debug (testTask)
import Data.Functor (($>))
import Data.Time.Clock.POSIX(getPOSIXTime)
import System.Directory(createDirectoryIfMissing
Expand All @@ -28,7 +28,7 @@ import System.IO (hSetBuffering, stdout, BufferMode(NoBuffering))
main :: IO ()
main = do
t <- getSeed
testTask English (generate t) (describe t) partial full submission
testTask Nothing English (generate t) (describe t) partial full submission
where
getSeed :: IO Int
getSeed = round <$> getPOSIXTime
Expand Down
8 changes: 4 additions & 4 deletions app/enumeratedArrowsQuizDemo.hs
View file
Original file line number Diff line number Diff line change
@@ -1,13 +1,13 @@
{-# LANGUAGE FlexibleContexts #-}
module Main (main) where
import Control.Monad.Output (
import Control.OutputCapable.Blocks (
LangM,
Language (English),
Rated,
ReportT,
)
import Control.Monad.Output.Generic (($>>=))
import Control.Monad.Output.Debug (testTask)
import Control.OutputCapable.Blocks.Generic (($>>=))
import Control.OutputCapable.Blocks.Debug (testTask)
import Data.Functor (($>))
import Data.Time.Clock.POSIX(getPOSIXTime)
import System.Directory(createDirectoryIfMissing
Expand All @@ -29,7 +29,7 @@ import System.IO (hSetBuffering, stdout, BufferMode(NoBuffering))
main :: IO ()
main = do
t <- getSeed
testTask English (generate t) (describe t) partial full submission
testTask Nothing English (generate t) (describe t) partial full submission
where
getSeed :: IO Int
getSeed = round <$> getPOSIXTime
Expand Down
9 changes: 5 additions & 4 deletions package.yaml
View file
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
---
name: sd-generate
extra-source-files: [ ]
extra-source-files: []
dependencies:
- base
- bifunctors
Expand All @@ -21,14 +21,15 @@ dependencies:
- hashable
- pretty-simple
- lens
- output-monad
- output-blocks >= 0.2
- file-embed
- filepath
- MonadRandom
- monad-loops
- modelling-tasks
- random-shuffle
- time
- exceptions
default-extensions:
- TupleSections
- DuplicateRecordFields
Expand Down Expand Up @@ -65,7 +66,7 @@ executables:
- app
dependencies:
- sd-generate
- output-monad
- output-blocks >= 0.2
- time
- directory
ghc-options:
Expand All @@ -77,7 +78,7 @@ executables:
- app
dependencies:
- sd-generate
- output-monad
- output-blocks >= 0.2
- time
- directory
ghc-options:
Expand Down
27 changes: 18 additions & 9 deletions sd-generate.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -64,6 +64,7 @@ library
, containers
, diagrams-lib
, diagrams-svg
, exceptions
, extra
, file-embed
, filepath
Expand All @@ -74,7 +75,7 @@ library
, modelling-tasks
, monad-loops
, mtl
, output-monad
, output-blocks >=0.2
, pretty-simple
, random-shuffle
, string-interpolate
Expand Down Expand Up @@ -109,6 +110,7 @@ executable draw
, containers
, diagrams-lib
, diagrams-svg
, exceptions
, extra
, file-embed
, filepath
Expand All @@ -119,7 +121,7 @@ executable draw
, modelling-tasks
, monad-loops
, mtl
, output-monad
, output-blocks >=0.2
, pretty-simple
, random-shuffle
, sd-generate
Expand Down Expand Up @@ -155,6 +157,7 @@ executable drawing
, containers
, diagrams-lib
, diagrams-svg
, exceptions
, extra
, file-embed
, filepath
Expand All @@ -165,7 +168,7 @@ executable drawing
, modelling-tasks
, monad-loops
, mtl
, output-monad
, output-blocks >=0.2
, pretty-simple
, random-shuffle
, sd-generate
Expand Down Expand Up @@ -202,6 +205,7 @@ executable enumeratedArrowsDirectDemo
, diagrams-lib
, diagrams-svg
, directory
, exceptions
, extra
, file-embed
, filepath
Expand All @@ -212,7 +216,7 @@ executable enumeratedArrowsDirectDemo
, modelling-tasks
, monad-loops
, mtl
, output-monad
, output-blocks >=0.2
, pretty-simple
, random-shuffle
, sd-generate
Expand Down Expand Up @@ -249,6 +253,7 @@ executable enumeratedArrowsQuizDemo
, diagrams-lib
, diagrams-svg
, directory
, exceptions
, extra
, file-embed
, filepath
Expand All @@ -259,7 +264,7 @@ executable enumeratedArrowsQuizDemo
, modelling-tasks
, monad-loops
, mtl
, output-monad
, output-blocks >=0.2
, pretty-simple
, random-shuffle
, sd-generate
Expand Down Expand Up @@ -295,6 +300,7 @@ executable sampling
, containers
, diagrams-lib
, diagrams-svg
, exceptions
, extra
, file-embed
, filepath
Expand All @@ -305,7 +311,7 @@ executable sampling
, modelling-tasks
, monad-loops
, mtl
, output-monad
, output-blocks >=0.2
, pretty-simple
, random-shuffle
, sd-generate
Expand Down Expand Up @@ -341,6 +347,7 @@ executable transformAlloy
, containers
, diagrams-lib
, diagrams-svg
, exceptions
, extra
, file-embed
, filepath
Expand All @@ -351,7 +358,7 @@ executable transformAlloy
, modelling-tasks
, monad-loops
, mtl
, output-monad
, output-blocks >=0.2
, pretty-simple
, random-shuffle
, sd-generate
Expand Down Expand Up @@ -387,6 +394,7 @@ executable transformPlantUML
, containers
, diagrams-lib
, diagrams-svg
, exceptions
, extra
, file-embed
, filepath
Expand All @@ -397,7 +405,7 @@ executable transformPlantUML
, modelling-tasks
, monad-loops
, mtl
, output-monad
, output-blocks >=0.2
, pretty-simple
, random-shuffle
, sd-generate
Expand Down Expand Up @@ -444,6 +452,7 @@ test-suite sd-generate-test
, diagrams-lib
, diagrams-svg
, directory
, exceptions
, extra
, file-embed
, filepath
Expand All @@ -455,7 +464,7 @@ test-suite sd-generate-test
, modelling-tasks
, monad-loops
, mtl
, output-monad
, output-blocks >=0.2
, pretty-simple
, random-shuffle
, sd-generate
Expand Down
19 changes: 10 additions & 9 deletions src/Modelling/StateDiagram/EnumArrows.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -59,15 +59,15 @@ import Modelling.StateDiagram.PlantUMLDiagrams
,checkDrawabilityPlantUML)
import System.FilePath(combine)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Output (
GenericOutputMonad (..),
import Control.OutputCapable.Blocks (
GenericOutputCapable (..),
LangM,
OutputMonad,
OutputCapable,
Rated,
($=<<),
english,
translate,
printSolutionAndAssert
printSolutionAndAssert, ArticleToUse (DefiniteArticle)
)
import Control.Monad.Random
( MonadRandom,
Expand Down Expand Up @@ -302,7 +302,7 @@ enumArrows :: MonadIO m => EnumArrowsConfig -> Int -> m EnumArrowsInstance
enumArrows config timestamp
= evalRandT (enumArrowsInstance config) (mkStdGen timestamp)

enumArrowsTask :: (OutputMonad m, MonadIO m) => FilePath -> EnumArrowsInstance -> LangM m
enumArrowsTask :: (OutputCapable m, MonadIO m) => FilePath -> EnumArrowsInstance -> LangM m
enumArrowsTask path task
= do
paragraph $ translate $ do
Expand Down Expand Up @@ -364,7 +364,7 @@ enumArrowsInstance EnumArrowsConfig { sdConfig
inst <- liftIO $ getInstances (Just maxInstances) (sdConfigToAlloy sdConfig)
r <- liftIO (randomRIO (0, fromIntegral maxInstances - 1) :: IO Int)
liftIO $ putStrLn ("instance " ++ show r ++ " selected of " ++ show (length inst) ++ " instances")
let chart = map (failWith id . parseInstance "this") inst !! r
let chart = map (failWith show . parseInstance "this") inst !! r
stop <- liftIO getPOSIXTime
liftIO $ putStrLn ("instance generation took " ++ show (stop - start) ++ " seconds")
return $
Expand Down Expand Up @@ -468,7 +468,7 @@ checkEnumArrowsConfig EnumArrowsConfig{ sdConfig
= Just "Flattening does not support history nodes."
| otherwise = checkSDConfig sdConfig

enumArrowsSyntax :: (OutputMonad m) => EnumArrowsInstance -> [(String,String)] -> LangM m
enumArrowsSyntax :: (OutputCapable m) => EnumArrowsInstance -> [(String,String)] -> LangM m
enumArrowsSyntax task answer
= do
assertion (length (nubOrd $ map fst answer) == length answer) $ translate $ do
Expand All @@ -482,9 +482,10 @@ enumArrowsSyntax task answer
english "No empty list of tuples was supplied."
return ()

enumArrowsEvaluation :: (OutputMonad m) => EnumArrowsInstance -> [(String,String)] -> Rated m
enumArrowsEvaluation :: (OutputCapable m) => EnumArrowsInstance -> [(String,String)] -> Rated m
enumArrowsEvaluation task answer
= printSolutionAndAssert
DefiniteArticle
(Just $ show (concatMap (uncurry zip) $ taskSolution task))
(rate (taskSolution task) answer)

Expand Down Expand Up @@ -529,7 +530,7 @@ rate solution submission
%
fromIntegral (sum $ map (length . snd) solution)

enumArrowsFeedback :: (OutputMonad m) => EnumArrowsInstance -> [(String,String)] -> LangM m
enumArrowsFeedback :: (OutputCapable m) => EnumArrowsInstance -> [(String,String)] -> LangM m
enumArrowsFeedback task submission
= let
solution = taskSolution task
Expand Down
Loading

1 comment on commit f2f029b

@github-actions
Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

@check-spelling-bot Report

🔴 Please review

See the 📜action log or 📝 job summary for details.

Unrecognized words (5)

enum
hsc
Perim
SDe
SDg

To accept these unrecognized words as correct, you could run the following commands

... in a clone of the [email protected]:fmidue/sd-generate.git repository
on the main branch (ℹ️ how do I use this?):

curl -s -S -L 'https://raw.githubusercontent.com/check-spelling/check-spelling/v0.0.22/apply.pl' |
perl - 'https://github.com/fmidue/sd-generate/actions/runs/11721876665/attempts/1'
Available 📚 dictionaries could cover words not in the 📘 dictionary
Dictionary Entries Covers Uniquely
cspell:dart/src/dart.txt 3 1
cspell:rust/dict/rust.txt 30 1
cspell:csharp/csharp.txt 32 1
cspell:cpp/src/lang-keywords.txt 44 1
cspell:swift/src/swift.txt 53 1

Consider adding them (in .github/workflows/spelling.yml) for uses: check-spelling/[email protected] in its with:

      with:
        extra_dictionaries:
          cspell:dart/src/dart.txt
          cspell:rust/dict/rust.txt
          cspell:csharp/csharp.txt
          cspell:cpp/src/lang-keywords.txt
          cspell:swift/src/swift.txt

To stop checking additional dictionaries, add (in .github/workflows/spelling.yml) for uses: check-spelling/[email protected] in its with:

check_extra_dictionaries: ''
Errors (1)

See the 📜action log or 📝 job summary for details.

❌ Errors Count
❌ forbidden-pattern 1

See ❌ Event descriptions for more information.

If the flagged items are false positives

If items relate to a ...

  • binary file (or some other file you wouldn't want to check at all).

    Please add a file path to the excludes.txt file matching the containing file.

    File paths are Perl 5 Regular Expressions - you can test yours before committing to verify it will match your files.

    ^ refers to the file's path from the root of the repository, so ^README\.md$ would exclude README.md (on whichever branch you're using).

  • well-formed pattern.

    If you can write a pattern that would match it,
    try adding it to the patterns.txt file.

    Patterns are Perl 5 Regular Expressions - you can test yours before committing to verify it will match your lines.

    Note that patterns can't match multiline strings.

Please sign in to comment.