diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index f9a8f8d..452608d 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -1,6 +1,6 @@ # This GitHub workflow config has been generated by a script via # -# haskell-ci 'github' 'cabal.project' +# haskell-ci 'github' 'hibet.cabal' # # To regenerate the script (for example after adjusting tested-with) run # @@ -8,9 +8,9 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.16 +# version: 0.19.20240708 # -# REGENDATA ("0.16",["github","cabal.project"]) +# REGENDATA ("0.19.20240708",["github","hibet.cabal"]) # name: Haskell-CI on: @@ -23,24 +23,14 @@ jobs: timeout-minutes: 60 container: - image: buildpack-deps:bionic + image: buildpack-deps:jammy continue-on-error: ${{ matrix.allow-failure }} strategy: matrix: include: - - compiler: ghc-9.2.7 + - compiler: ghc-9.4.8 compilerKind: ghc - compilerVersion: 9.2.7 - setup-method: ghcup - allow-failure: false - - compiler: ghc-9.0.2 - compilerKind: ghc - compilerVersion: 9.0.2 - setup-method: ghcup - allow-failure: false - - compiler: ghc-8.10.7 - compilerKind: ghc - compilerVersion: 8.10.7 + compilerVersion: 9.4.8 setup-method: ghcup allow-failure: false fail-fast: false @@ -50,10 +40,10 @@ jobs: apt-get update apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 mkdir -p "$HOME/.ghcup/bin" - curl -sL https://downloads.haskell.org/ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 > "$HOME/.ghcup/bin/ghcup" + curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" chmod a+x "$HOME/.ghcup/bin/ghcup" "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) - "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) + "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) env: HCKIND: ${{ matrix.compilerKind }} HCNAME: ${{ matrix.compiler }} @@ -65,11 +55,13 @@ jobs: echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" HCDIR=/opt/$HCKIND/$HCVER - HC=$HOME/.ghcup/bin/$HCKIND-$HCVER + HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") + HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') + HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') echo "HC=$HC" >> "$GITHUB_ENV" - echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV" - echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV" - echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" + echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" + echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" + echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" @@ -126,7 +118,7 @@ jobs: chmod a+x $HOME/.cabal/bin/cabal-plan cabal-plan --version - name: checkout - uses: actions/checkout@v3 + uses: actions/checkout@v4 with: path: source - name: initial cabal.project for sdist @@ -154,7 +146,7 @@ jobs: echo " ghc-options: -Werror=missing-methods" >> cabal.project cat >> cabal.project <> cabal.project.local + $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(hibet)$/; }' >> cabal.project.local cat cabal.project cat cabal.project.local - name: dump install plan @@ -162,7 +154,7 @@ jobs: $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all cabal-plan - name: restore cache - uses: actions/cache/restore@v3 + uses: actions/cache/restore@v4 with: key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} path: ~/.cabal/store @@ -192,7 +184,7 @@ jobs: rm -f cabal.project.local $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all - name: save cache - uses: actions/cache/save@v3 + uses: actions/cache/save@v4 if: always() with: key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} diff --git a/.gitignore b/.gitignore index 00ff0b6..1ae62e5 100644 --- a/.gitignore +++ b/.gitignore @@ -54,6 +54,7 @@ TAGS # other .DS_Store .gitignore +*.html # custom thinking.txt @@ -67,3 +68,4 @@ PKGBUILD hibet/ pkg/ .hie/ + diff --git a/CHANGELOG.md b/CHANGELOG.md index 5062ff0..2299d5b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,12 @@ and this project adheres to [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [1.4.0] - 2024-10-21 + +* Bump stack version to lts-21.25 and GHC-9.4.8 +* Change effect system to `effectful` one + + ## [1.3.7] - 2023-04-06 * Bump stack version to lts-20.17 and GHC-9.2.7 diff --git a/README.md b/README.md index 405dfca..a54ebbc 100644 --- a/README.md +++ b/README.md @@ -117,4 +117,4 @@ or use arrows of keyboard. ## Contribution -Contribution is welcome! +Contributions are welcoming! diff --git a/hibet.cabal b/hibet.cabal index 7be6f09..1047e41 100644 --- a/hibet.cabal +++ b/hibet.cabal @@ -1,269 +1,244 @@ -cabal-version: 3.0 -name: hibet -version: 1.3.7 -description: tibetan-english translator -synopsis: translator -homepage: https://github.com/willbasky/Hibet -bug-reports: https://github.com/willbasky/Hibet/issues -license: BSD-3-Clause -license-file: LICENSE -author: willbasky -maintainer: willgame(at)mail(dot)ru -copyright: 2023 willbasky -category: Utility -build-type: Simple -extra-doc-files: README.md - , CHANGELOG.md -data-files: dicts/*.txt - , stuff/titles.toml - , stuff/tibetan-syllables +cabal-version: 3.0 +name: hibet +version: 1.4.0 +description: tibetan-english translator +synopsis: translator +homepage: https://github.com/willbasky/Hibet +bug-reports: https://github.com/willbasky/Hibet/issues +license: BSD-3-Clause +license-file: LICENSE +author: willbasky +maintainer: willgame(at)mail(dot)ru +copyright: 2023 willbasky +category: Utility +build-type: Simple +extra-doc-files: + CHANGELOG.md + README.md + +data-files: + dicts/*.txt + stuff/tibetan-syllables + stuff/titles.toml + extra-source-files: test/env/data/dicts/*.txt test/env/data/stuff/tibetan-syllables test/env/data/stuff/titles.toml -tested-with: - , GHC==8.10.7 - , GHC==9.0.2 - , GHC==9.2.7 - -source-repository head - type: git - location: https://github.com/willbasky/Hibet.git -common common-rdp - build-depends: - record-dot-preprocessor - , record-hasfield +tested-with: GHC ==9.4.8 - ghc-options: - -fplugin=RecordDotPreprocessor +source-repository head + type: git + location: https://github.com/willbasky/Hibet.git +common common-dot + default-extensions: OverloadedRecordDot common common-options - build-depends: base >= 4.11 && < 5 - - ghc-options: -Wall - -Wcompat - -Widentities - -Wincomplete-uni-patterns - -Wincomplete-record-updates - -Wredundant-constraints - -- -split-sections - -fhide-source-paths - -- -Wmissing-export-lists - -Wpartial-fields - -Wmissing-deriving-strategies - -fwrite-ide-info - -hiedir=.hie - -Wunused-packages - -- -ddump-if-trace - - default-language: Haskell2010 - + build-depends: base >=4.11 && <5 + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-uni-patterns + -Wincomplete-record-updates -Wredundant-constraints + -fhide-source-paths -Wpartial-fields -Wmissing-deriving-strategies + -fwrite-ide-info -hiedir=.hie -Wunused-packages + + -- -split-sections + -- -Wmissing-export-lists + -- -ddump-if-trace + -- -O2 + -- -eventlog + -- -finfo-table-map + -- -fdistinct-constructor-tables + + default-language: Haskell2010 default-extensions: - DataKinds - DeriveGeneric - DerivingStrategies - DuplicateRecordFields - FlexibleContexts - FlexibleInstances - GADTs - LambdaCase - MultiParamTypeClasses - OverloadedStrings - RankNTypes - RecordWildCards - PolyKinds - ScopedTypeVariables - TemplateHaskell - TupleSections - TypeApplications - TypeFamilies - TypeOperators - TypeSynonymInstances - UndecidableInstances + DataKinds + DeriveGeneric + DerivingStrategies + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + GADTs + LambdaCase + MultiParamTypeClasses + OverloadedStrings + PolyKinds + RankNTypes + RecordWildCards + ScopedTypeVariables + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + TypeSynonymInstances + UndecidableInstances library import: - common-options - , common-rdp - ghc-options: - -fplugin=Polysemy.Plugin - hs-source-dirs: src - exposed-modules: - App - Cli - Effects.File - Effects.Console - Effects.PrettyPrint - Env - Dictionary - Label - Parse - Parse.SyllableLines - Parse.TibetanWord - Parse.WylieWord - Parse.WylieText - Parse.Type - Pretty - Translator - Type - Utility - - other-modules: Paths_hibet - , Sandbox - autogen-modules: Paths_hibet + common-options + , common-dot + ghc-options: -fplugin=Effectful.Plugin + hs-source-dirs: src + exposed-modules: + App + Cli + Dictionary + Effects.Common + Effects.Console + Effects.File + Effects.PrettyPrint + Env + Label + Parse + Parse.SyllableLines + Parse.TibetanWord + Parse.Type + Parse.WylieText + Parse.WylieWord + Pretty + Translator + Type + Utility + + other-modules: + Paths_hibet + Sandbox + + autogen-modules: Paths_hibet build-depends: - bytestring - , containers - , deepseq - , directory - , extra - , filepath - , gitrev - , haskeline - , hashable - , incipit-core - , megaparsec - , neat-interpolation - , optparse-applicative - , pager - , parallel - , path - , path-io - , polysemy - , polysemy-conc - , polysemy-plugin - , prettyprinter - , prettyprinter-ansi-terminal - , radixtree ^>=0.6.0.0 - , terminal-size - , text - , text-rope - , tomland ^>=1.3.3.2 - , unordered-containers - + , bytestring ^>=0.11.5 + , containers ^>=0.6.7 + , deepseq ^>=1.4.8 + , directory ^>=1.3.7 + , effectful ^>=2.4.0 + , effectful-core ^>=2.4.0 + , effectful-plugin ^>=1.1.0 + , effectful-th ^>=1.0.0 + , extra ^>=1.8 + , filepath ^>=1.4.2 + , gitrev ^>=1.3.1 + , hashable ^>=1.4.7 + , haskeline ^>=0.8.2 + , log-effectful ^>=1.0.0 + , megaparsec ^>=9.6.1 + , neat-interpolation ^>=0.5.1 + , optparse-applicative ^>=0.18.1 + , pager ^>=0.1.1 + , parallel ^>=3.2.2 + , path ^>=0.9.5 + , path-io ^>=1.8.2 + , prettyprinter ^>=1.7.1 + , prettyprinter-ansi-terminal ^>=1.1.3 + , radixtree ^>=0.6.0.0 + , resourcet-effectful ^>=1.0.1 + , terminal-size ^>=0.3.4 + , text ^>=2.0.2 + , text-rope ^>=0.3 + , tomland ^>=1.3.3.2 + , unordered-containers ^>=0.2.20 executable hibet - import: common-options - hs-source-dirs: app - main-is: Main.hs - ghc-options: -Wall - -- -O2 -eventlog - -- ^ for threadscope - -threaded - -rtsopts - -with-rtsopts=-N - -Wincomplete-uni-patterns - -Wincomplete-record-updates - -Wcompat - -Widentities - -Wredundant-constraints - -fhide-source-paths - -Wmissing-export-lists - -Wpartial-fields - build-depends: - hibet + import: common-options + hs-source-dirs: app + main-is: Main.hs + ghc-options: + -Wall -threaded -rtsopts -Wincomplete-uni-patterns + -Wincomplete-record-updates -Wcompat -Widentities + -Wredundant-constraints -fhide-source-paths -Wmissing-export-lists + -Wpartial-fields -with-rtsopts=-N16 -with-rtsopts=-qn8 + -with-rtsopts=-A64m -with-rtsopts=-AL128m -with-rtsopts=-I0 + -with-rtsopts=-T + -- -O2 -eventlog + -- ^ for threadscope + build-depends: hibet test-suite hibet-pretty - import: common-options - type: exitcode-stdio-1.0 - hs-source-dirs: test/pretty - main-is: Main.hs - ghc-options: -Wall - -threaded - -rtsopts - -with-rtsopts=-N + import: common-options + type: exitcode-stdio-1.0 + hs-source-dirs: test/pretty + main-is: Main.hs + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: - hibet - , hspec - , prettyprinter + , hibet + , hspec + , prettyprinter test-suite hibet-labels - import: common-options - type: exitcode-stdio-1.0 - hs-source-dirs: test/labels - main-is: Main.hs - ghc-options: -Wall - -threaded - -rtsopts - -with-rtsopts=-N + import: common-options + type: exitcode-stdio-1.0 + hs-source-dirs: test/labels + main-is: Main.hs + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: - hibet - , bytestring - , containers - , hspec + , bytestring + , containers + , hibet + , hspec test-suite hibet-env import: - common-options - , common-rdp - type: exitcode-stdio-1.0 - hs-source-dirs: test/env - main-is: Main.hs - ghc-options: -Wall - -threaded - -rtsopts - -with-rtsopts=-N - build-depends: - hibet - , bytestring - , hspec - , containers - , polysemy - , text - , unordered-containers - -- , directory + common-options + , common-dot - other-modules: Paths_hibet - Paths + type: exitcode-stdio-1.0 + hs-source-dirs: test/env + main-is: Main.hs + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + , bytestring + , effectful-core + , hibet + , hspec + , text + , unordered-containers + + other-modules: + Paths + Paths_hibet + autogen-modules: Paths_hibet test-suite hibet-parse - import: common-options - type: exitcode-stdio-1.0 - hs-source-dirs: test/parse - main-is: Main.hs - ghc-options: -Wall - -threaded - -rtsopts - -with-rtsopts=-N + import: common-options + type: exitcode-stdio-1.0 + hs-source-dirs: test/parse + main-is: Main.hs + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: - hibet - , hspec - -- , megaparsec - - other-modules: Paths_hibet + , hibet + , hspec + other-modules: Paths_hibet + autogen-modules: Paths_hibet benchmark hibet-benchmark - import: common-options - type: exitcode-stdio-1.0 - hs-source-dirs: benchmark - main-is: Main.hs - + import: common-options + type: exitcode-stdio-1.0 + hs-source-dirs: benchmark + main-is: Main.hs build-depends: - hibet - , criterion - , path - , path-io >= 1.4.0 - , text - , bytestring - , file-embed - , text-rope - -- , weigh - -- , streamly - -- , unordered-containers - -- , conduit - -- , async - - other-modules: Paths_hibet - Lines - Common - - ghc-options: -threaded - -rtsopts - -with-rtsopts=-N - - + , bytestring + , criterion + , file-embed + , hibet + , path + , path-io >=1.4.0 + , text + , text-rope + + -- , weigh + -- , streamly + -- , unordered-containers + -- , conduit + -- , async + + other-modules: + Common + Lines + Paths_hibet + autogen-modules: Paths_hibet + + ghc-options: -threaded -rtsopts -with-rtsopts=-N diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 0000000..6514da4 --- /dev/null +++ b/hie.yaml @@ -0,0 +1,31 @@ +cradle: + stack: + - path: "./src" + component: "hibet:lib" + + - path: "./app/Main.hs" + component: "hibet:exe:hibet" + + - path: "./test/pretty" + component: "hibet:test:hibet-pretty" + + - path: "./test/labels" + component: "hibet:test:hibet-labels" + + - path: "./test/env" + component: "hibet:test:hibet-env" + + - path: "./test/parse" + component: "hibet:test:hibet-parse" + + - path: "./benchmark/Main.hs" + component: "hibet:bench:hibet-benchmark" + + - path: "./benchmark/Paths_hibet.hs" + component: "hibet:bench:hibet-benchmark" + + - path: "./benchmark/Lines.hs" + component: "hibet:bench:hibet-benchmark" + + - path: "./benchmark/Common.hs" + component: "hibet:bench:hibet-benchmark" diff --git a/src/App.hs b/src/App.hs index d1c8c65..6aecd31 100644 --- a/src/App.hs +++ b/src/App.hs @@ -1,82 +1,111 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} module App ( app ) where import Cli (parser, runCommand) -import Effects.Console -import Effects.File -import Effects.PrettyPrint import Env (Env, makeEnv) import Type (HibetError (..)) -import Utility (debugEnabledEnvVar) - +import qualified Data.Text.IO as TIO import Data.Function ((&)) -import IncipitCore (Async, asyncToIOFinal) -import Polysemy (Embed, Final, Members, Sem, embedToFinal, runFinal) -import Polysemy.Conc (Race, Sync, interpretRace, interpretSync, withAsync_) -import Polysemy.Error (Error, runError) -import Polysemy.Resource (Resource, runResource) -import Polysemy.Trace (Trace, ignoreTrace, traceToStdout) +import System.IO ( hFlush, stdout, putStrLn ) + +import Effects.Console ( Console, execParser, runConsole ) +import Effects.File ( FileSystem, runFileSystemIO ) +import Effects.PrettyPrint ( PrettyPrint, runPrettyPrint ) +import Effectful ( runEff, type (:>), Eff, IOE ) +import Effectful.Error.Static + ( CallStack, prettyCallStack, Error, runError ) +import Effectful.Concurrent ( runConcurrent, Concurrent ) +import Effectful.Concurrent.Async (withAsync) +import Effectful.Concurrent.MVar ( MVar, newEmptyMVar, putMVar ) +import Effectful.Reader.Dynamic ( runReader ) +import Effectful.Resource ( runResource, Resource ) +import Effectful.Log + ( defaultLogLevel, + showLogMessage, + shutdownLogger, + waitForLogger, + mkLogger, + runLog, + Logger, + Log ) +import Control.Exception (finally) app :: IO () app = do - isDebug <- debugEnabledEnvVar - handleHibetError =<< interpretHibet hibet isDebug + errs <- withStdOutLogger $ \logger -> do + interpretHibet hibet logger + handleHibetError errs type HibetEffects = - [ - FileIO - , Error HibetError - , Resource - , Console - , PrettyPrint - , Trace - , Sync Env - , Race - , Async - , Embed IO - , Final IO - ] + '[ + Concurrent + , Resource + , Console + , FileSystem + , PrettyPrint + , Error HibetError + , Log + , IOE + ] + -interpretHibet :: Sem HibetEffects () - -> Bool -- isDebug - -> IO (Either HibetError ()) -interpretHibet program isDebug = program - & runFile - & runError @HibetError - & runResource - & runConsole - & runPrettyPrint - & (if isDebug then traceToStdout else ignoreTrace) - & interpretSync @Env - & interpretRace - & asyncToIOFinal - & embedToFinal - & runFinal +interpretHibet :: Eff HibetEffects a + -> Logger + -> IO (Either (CallStack, HibetError) a) +interpretHibet program logger = + program + & runConcurrent + & runResource + & runConsole + & runFileSystemIO + & runPrettyPrint + & runError @HibetError + & runLog "hibet" logger defaultLogLevel + & runEff -hibet :: Members HibetEffects r => Sem r () +hibet :: Eff HibetEffects () hibet = do - withAsync_ prepareEnv $ do - com <- execParser parser - runCommand com + mv <- newEmptyMVar + withAsync (prepareEnv mv) $ \_ -> + runReader mv $ do + com <- execParser parser + runCommand com -prepareEnv :: Members - [ FileIO - , Error HibetError - , Trace - , Sync Env - , Embed IO - ] r => Sem r () -prepareEnv = do +prepareEnv :: + ( FileSystem :> es + , Error HibetError :> es + , Concurrent :> es + ) => MVar Env -> Eff es () +prepareEnv mv = do !env <- makeEnv - putEnvMVar env + putMVar mv env -handleHibetError :: Either HibetError a -> IO () +handleHibetError :: + Either (CallStack, HibetError) a + -> IO () handleHibetError = \case Right _ -> pure () - Left err -> do - putStrLn "Hibet application failed with exception:" + Left (stack, err) -> do + TIO.putStrLn "Hibet application failed with exception:" print err + TIO.putStrLn "The stack is:" + System.IO.putStrLn $ prettyCallStack stack + +withStdOutLogger :: (Logger -> IO r) -> IO r +withStdOutLogger act = do + logger <- mkLogger "stdout" $ \msg -> do + TIO.putStrLn $ showLogMessage Nothing msg + hFlush stdout + withLogger logger act + +withLogger :: Logger -> (Logger -> IO r) -> IO r +withLogger logger act = act logger `finally` cleanup + where + cleanup = waitForLogger logger >> shutdownLogger logger +-- Prevent GHC from inlining this function so its callers are +-- {-# NOINLINE withLogger #-} diff --git a/src/Cli.hs b/src/Cli.hs index 7eb4b05..7ad8f18 100644 --- a/src/Cli.hs +++ b/src/Cli.hs @@ -8,12 +8,12 @@ module Cli import Effects.Console import Effects.PrettyPrint -import Env (Env) +import Env (Env(..), modifyEnv, readEnv) import Label (LabelFull (..), Labels (..), Title(unTitle)) import Paths_hibet (version) import Pretty import Translator (translator) -import Type (HibetError (..)) +-- import Type (HibetError (..)) import Utility (showT) import Dictionary (selectDict) @@ -29,14 +29,15 @@ import Options.Applicative (Parser, ParserInfo, auto, command, fullDesc, help, h infoHeader, infoOption, long, metavar, option, progDesc, short, subparser) import Options.Applicative.Help.Chunk (stringChunk) -import Polysemy (Members, Member, Sem) -import Polysemy.Conc (Sync) -import qualified Polysemy.Conc.Effect.Sync as Sync -import Polysemy.Error (Error) -import Polysemy.Resource (Resource) import Prelude hiding (lookup) -import Polysemy.Trace (Trace) +import Effectful ( type (:>), Eff, IOE ) +import Effectful.Resource ( Resource ) +-- import Effectful.Log ( Log ) +import Effectful.Reader.Dynamic (Reader) +import Effectful.Concurrent.MVar (MVar, Concurrent) + +-- import Polysemy.Trace (Trace) --------------------------------------------------------------------------- -- CLI @@ -54,15 +55,16 @@ data Command data Opt = Names | Meta (Maybe Int) -- | Run 'hibet' with cli command -runCommand :: Members - [ Sync Env - , Trace - , Resource - , PrettyPrint - , Console - , Error HibetError - ] r - => Command -> Sem r () +runCommand :: + ( IOE :> es + , Reader (MVar Env) :> es + , Concurrent :> es + -- , Log :> es + , Resource :> es + , PrettyPrint :> es + , Console :> es + ) + => Command -> Eff es () runCommand com = do case com of Shell selectedDicts -> do @@ -74,17 +76,22 @@ runCommand com = do env <- readEnv printDebug env.radixWylie -updateEnv :: Member (Sync Env) r +updateEnv :: + ( Reader (MVar Env) :> es + , Concurrent :> es + ) => [Int] - -> Sem r () + -> Eff es () updateEnv selectedDicts = do - env <- Sync.takeBlock - let selectedEnv = env{dictionaryMeta + modifyEnv $ \env -> + pure $ env{dictionaryMeta = selectDict selectedDicts env.dictionaryMeta} - Sync.putBlock selectedEnv -runShow :: Members [Sync Env, PrettyPrint] r - => Opt -> Sem r () +runShow :: + ( Reader (MVar Env) :> es + , Concurrent :> es + , PrettyPrint :> es) + => Opt -> Eff es () runShow opt = do env <- readEnv let Labels labels = env.labels diff --git a/src/Dictionary.hs b/src/Dictionary.hs index 040252a..a21d505 100644 --- a/src/Dictionary.hs +++ b/src/Dictionary.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE BangPatterns #-} module Dictionary @@ -76,7 +77,7 @@ selectDict selected dicts = case selected of toDictionaryMeta :: [LabelFull] -> FilePath -> Dictionary -> DictionaryMeta toDictionaryMeta labels filepath dict = DictionaryMeta dict title number where - (title, number) = findTitle $ T.pack $ takeBaseName filepath + (!title, !number) = findTitle $ T.pack $ takeBaseName filepath -- Match filpath with labels findTitle :: Text -> (Title, Int) findTitle path = maybe (Title "Invalid title",0) (\lf -> (lf.label, lf.lfId)) @@ -87,9 +88,9 @@ searchTranslation :: Text -> DictionaryMeta -> Maybe Answer searchTranslation query dm = if null ts then Nothing else Just $ Answer ts dm.number dm.title where - ts = HMS.foldrWithKey search [] dm.dictionary - search :: Text -> [Target] -> [Target] -> [Target] - search q v acc = if q == query then v <> acc else acc + ts = HMS.foldlWithKey' search [] dm.dictionary + search :: [Target] -> Text -> [Target] -> [Target] + search acc q v = if q == query then v <> acc else acc sortOutput :: [Answer] -> [Answer] sortOutput = sortBy (\a1 a2-> compare a1.dictNumber a2.dictNumber) diff --git a/src/Effects/Common.hs b/src/Effects/Common.hs new file mode 100644 index 0000000..8091dc0 --- /dev/null +++ b/src/Effects/Common.hs @@ -0,0 +1,15 @@ +module Effects.Common where + +import Type (HibetError(..)) +import Utility ( showT ) + +import Effectful ( MonadIO(liftIO), type (:>), Eff, IOE ) +import Effectful.Error.Static ( Error, catchError, throwError, prettyCallStack ) + +adapt :: + ( IOE :> es + , Error HibetError :> es + ) + => IO a -> Eff es a +adapt m = catchError (liftIO m) $ + \stack err -> throwError $ EffectError (showT err) (showT $ prettyCallStack stack) diff --git a/src/Effects/Console.hs b/src/Effects/Console.hs index 12ea69b..32bbe1b 100644 --- a/src/Effects/Console.hs +++ b/src/Effects/Console.hs @@ -1,47 +1,40 @@ module Effects.Console where +import Type (HibetError(..)) +import Effects.Common (adapt) + import Options.Applicative (ParserInfo) import qualified Options.Applicative as Opt -import Polysemy (Embed, Member, Sem) -import qualified Polysemy as P -import Polysemy.Conc (Sync) -import qualified Polysemy.Conc.Effect.Sync as Sync -import qualified System.Console.Haskeline as Console +import qualified System.Console.Haskeline as Haskeline import System.Console.Haskeline.History (History) import System.Console.Haskeline.IO (InputState) -import qualified System.Console.Haskeline.IO as Console +import qualified System.Console.Haskeline.IO as Haskeline import qualified System.Exit as Exit +import Effectful.TH ( makeEffect ) +import Effectful ( type (:>), Effect, Eff, IOE ) +import Effectful.Error.Static ( Error ) +import Effectful.Dispatch.Dynamic ( interpret ) -data Console m a where - InitializeInput :: Console m InputState +data Console :: Effect where GetInput :: InputState -> String -> Console m (Maybe String) - CancelInput :: InputState -> Console m () CloseInput :: InputState -> Console m () GetHistory :: InputState -> Console m History ExitSuccess :: Console m () ExecParser :: ParserInfo a -> Console m a -P.makeSem ''Console +makeEffect ''Console -runConsole :: Member (Embed IO) r - => Sem (Console : r) a - -> Sem r a -runConsole = P.interpret $ \case - InitializeInput -> P.embed $ Console.initializeInput Console.defaultSettings +runConsole :: + ( IOE :> es + , Error HibetError :> es + ) + => Eff (Console : es) a + -> Eff es a +runConsole = interpret $ \_ -> \case GetInput state str -> - P.embed $ Console.queryInput state $ Console.getInputLine str - CancelInput state -> P.embed $ Console.cancelInput state - CloseInput state -> P.embed $ Console.closeInput state - GetHistory state -> P.embed $ Console.queryInput state Console.getHistory - ExitSuccess -> P.embed Exit.exitSuccess - ExecParser info -> P.embed $ Opt.execParser info - --- Helpers - -readEnv :: Member (Sync a) r => Sem r a -readEnv = Sync.block - -putEnvMVar :: Member (Sync a) r => a -> Sem r () -putEnvMVar = Sync.putBlock - + adapt $ Haskeline.queryInput state $ Haskeline.getInputLine str + CloseInput state -> adapt $ Haskeline.closeInput state + GetHistory state -> adapt $ Haskeline.queryInput state Haskeline.getHistory + ExitSuccess -> adapt Exit.exitSuccess + ExecParser info -> adapt $ Opt.execParser info diff --git a/src/Effects/File.hs b/src/Effects/File.hs index 3e10386..7cc7718 100644 --- a/src/Effects/File.hs +++ b/src/Effects/File.hs @@ -1,58 +1,46 @@ module Effects.File where import Type (HibetError (..)) -import Utility (showT) +import Effects.Common (adapt) -import Control.Exception (SomeException, fromException) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL -import Path (Abs, Dir, File, Path, PathException) +import Path (Abs, Dir, File, Path) import qualified Path import Path.IO (listDir) import Paths_hibet (getDataFileName) -import Polysemy (Embed, Member, Members, Sem) -import qualified Polysemy as P -import Polysemy.Error (Error, note, throw) - -data FileIO m a where - ReadFile :: FilePath -> FileIO m BS.ByteString - ReadFileLazy :: FilePath -> FileIO m BSL.ByteString - GetPath :: FilePath -> FileIO m FilePath - ListDirectory :: Path b Dir -> FileIO m ([Path Abs Dir], [Path Abs File]) - ParseAbsDir :: FilePath -> FileIO r (Path Abs Dir) - -P.makeSem ''FileIO - -runFile :: Members [Embed IO, Error HibetError] r => - Sem (FileIO : r) a -> Sem r a -runFile = P.interpret $ \case - ReadFile path -> P.embed $ BS.readFile path - ReadFileLazy path -> P.embed $ BSL.readFile path - GetPath path -> P.embed $ getDataFileName path - ListDirectory path -> P.embed $ listDir @IO path - ParseAbsDir path -> parseAbsDirS path - - --- Helpers - -irrefutablePathException :: (Member (Error HibetError) r) - => Either SomeException a - -> Sem r a -irrefutablePathException x = case x of - Left e -> do - err <- note (UnknownError $ showT e) $ fromException @PathException e - throw $ PathError err - Right a -> pure a - -parseAbsDirS :: - Member (Error HibetError) r => - FilePath -> - Sem r (Path Abs Dir) -parseAbsDirS x = irrefutablePathException $ Path.parseAbsDir x - -parseAbsFileS :: - Member (Error HibetError) r => - FilePath -> - Sem r (Path Abs File) -parseAbsFileS x = irrefutablePathException $ Path.parseAbsFile x +import Effectful.TH ( makeEffect ) +import Effectful + ( type (:>), + Effect, + Dispatch(Dynamic), + DispatchOf, + Eff, + IOE ) +import Effectful.Error.Static ( Error ) +import Effectful.Dispatch.Dynamic ( interpret ) + +data FileSystem :: Effect where + ReadFileBS :: FilePath -> FileSystem m BS.ByteString + ReadFileLazyBS :: FilePath -> FileSystem m BSL.ByteString + GetPath :: FilePath -> FileSystem m FilePath + ListDirectory :: Path b Dir -> FileSystem m ([Path Abs Dir], [Path Abs File]) + ParseAbsDir :: FilePath -> FileSystem r (Path Abs Dir) + +type instance DispatchOf FileSystem = 'Dynamic + +makeEffect ''FileSystem + +runFileSystemIO :: + ( IOE :> es + , Error HibetError :> es + ) + => Eff (FileSystem : es) a + -> Eff es a +runFileSystemIO = interpret $ \_ -> \case + ReadFileBS path -> adapt $ BS.readFile path + ReadFileLazyBS path -> adapt $ BSL.readFile path + GetPath path -> adapt $ getDataFileName path + ListDirectory path -> adapt $ listDir @IO path + ParseAbsDir path -> adapt $ Path.parseAbsDir path diff --git a/src/Effects/PrettyPrint.hs b/src/Effects/PrettyPrint.hs index 9fe5a35..5ee68bb 100644 --- a/src/Effects/PrettyPrint.hs +++ b/src/Effects/PrettyPrint.hs @@ -1,13 +1,13 @@ module Effects.PrettyPrint where import Pretty +import Type (HibetError(..)) +import Effects.Common (adapt) import Control.Monad (when) import Data.Maybe (isNothing) import Data.Text (Text) import qualified Data.Text as T -import Polysemy (Embed, Member, Sem) -import qualified Polysemy as P import Prettyprinter (Doc, LayoutOptions (..), PageWidth (..), defaultLayoutOptions, layoutSmart, pretty) import Prettyprinter.Render.Terminal (AnsiStyle, putDoc, renderStrict) @@ -15,25 +15,36 @@ import qualified System.Console.Terminal.Size as Terminal import System.Environment (lookupEnv, setEnv) import System.Pager (printOrPage) import Data.Foldable (traverse_) +import qualified Data.ByteString.Char8 as BSC8 + +import Effectful.TH ( makeEffect ) +import Effectful ( type (:>), Effect, Eff, IOE ) +import Effectful.Error.Static ( Error ) +import Effectful.Dispatch.Dynamic ( interpret, localSeqUnliftIO ) data Line = NewLine | CurrentLine -data PrettyPrint m a where +data PrettyPrint :: Effect where PutColorDoc :: Colorize -> Line -> Text -> PrettyPrint m () Pprint :: Doc AnsiStyle -> PrettyPrint m () PrintDebug :: Show a => a -> PrettyPrint m () -P.makeSem ''PrettyPrint - -runPrettyPrint :: Member (Embed IO) r => Sem (PrettyPrint : r) a -> Sem r a -runPrettyPrint = P.interpret $ \case - PutColorDoc col isNewLine txt -> P.embed $ do - let txtLn = case isNewLine of - NewLine -> txt `T.snoc` '\n' - CurrentLine -> txt - putDoc $ col $ pretty txtLn - - Pprint doc -> P.embed $ do +makeEffect ''PrettyPrint + +runPrettyPrint :: + ( IOE :> es + , Error HibetError :> es + ) + => Eff (PrettyPrint : es) a + -> Eff es a +runPrettyPrint = interpret $ \env -> \case + PutColorDoc col isNewLine txt -> adapt $ do + let txtLn = case isNewLine of + NewLine -> txt `T.snoc` '\n' + CurrentLine -> txt + putDoc $ col $ pretty txtLn + + Pprint doc -> localSeqUnliftIO env $ \_ -> do -- enable colors in `less` lessConf <- lookupEnv "LESS" when (isNothing lessConf) $ setEnv "LESS" "-R" @@ -41,10 +52,9 @@ runPrettyPrint = P.interpret $ \case let layoutOptions = defaultLayoutOptions {layoutPageWidth = AvailablePerLine width' 1} printOrPage . (`T.snoc` '\n') . renderStrict $ layoutSmart layoutOptions doc - PrintDebug str -> P.embed $ print str - + PrintDebug str -> adapt $ BSC8.putStrLn $ BSC8.pack $ show str -putColorList :: Member PrettyPrint r +putColorList :: (PrettyPrint:> es) => [(Colorize, Text)] - -> Sem r () + -> Eff es () putColorList = traverse_ (\(c,d) -> putColorDoc c CurrentLine d) diff --git a/src/Env.hs b/src/Env.hs index d394772..499ab79 100644 --- a/src/Env.hs +++ b/src/Env.hs @@ -1,14 +1,18 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE BangPatterns #-} module Env ( makeEnv , Env(..) + , readEnv + , putEnvMVar + , modifyEnv ) where import Dictionary (DictionaryMeta, makeDictionary, toDictionaryMeta) -import Effects.File (FileIO) +import Effects.File (FileSystem) import qualified Effects.File as File import Label (Labels (..), getLabels) import Parse (TibetWylieMap, WylieTibetMap, mkTibetanRadex, mkWylieRadex, splitSyllables) @@ -23,12 +27,15 @@ import qualified Data.Text.Lazy.Encoding as TLE import Data.Tuple (swap) import GHC.Generics (Generic) import Path (Abs, File, Path, fromAbsFile) -import Polysemy (Members, Sem) -import Polysemy.Error (Error, fromEither, throw) -import Polysemy.Trace (Trace) + +import Effectful ( type (:>), Eff ) +import Effectful.Error.Static ( Error, throwError ) +import Effectful.Concurrent (Concurrent) +import Effectful.Reader.Dynamic (Reader) +import Effectful.Concurrent.MVar (MVar, modifyMVar_, readMVar, putMVar) +import Effectful.Reader.Dynamic (ask) -- fo debug --- import Polysemy.Trace (trace) -- import qualified Data.Bimap as Bi -- import Parse (WylieSyllable(WylieSyllable)) @@ -46,13 +53,17 @@ data Env = Env deriving anyclass (NFData) -makeEnv :: Members [FileIO, Error HibetError, Trace] r => Sem r Env +makeEnv :: + ( FileSystem :> es + , Error HibetError :> es + ) + => Eff es Env makeEnv = do sylsPath <- File.getPath "stuff/tibetan-syllables" -- trace sylsPath - syls <- TE.decodeUtf8 <$> File.readFile sylsPath - labels@(Labels ls) <- getLabels <$> (File.readFile =<< File.getPath "stuff/titles.toml") + syls <- TE.decodeUtf8 <$> File.readFileBS sylsPath + labels@(Labels ls) <- getLabels <$> (File.readFileBS =<< File.getPath "stuff/titles.toml") dir <- File.getPath "dicts/" absDir <- File.parseAbsDir dir @@ -61,6 +72,7 @@ makeEnv = do let dictsMeta = parMap (rparWith rdeepseq) (\(f,t) -> toDictionaryMeta ls f $ makeDictionary $ TL.toStrict t) filesAndTexts + sylList <- fromEither $ splitSyllables syls pure $ runEval $ do wtMap <- rparWith rdeepseq $ HM.fromList sylList @@ -76,19 +88,40 @@ makeEnv = do , labels = labels } -getFilesTexts :: Members - [ FileIO - , Error HibetError] r - => [Path Abs File] -> Sem r [(FilePath, TL.Text)] +getFilesTexts :: + ( FileSystem :> es + , Error HibetError :> es + ) + => [Path Abs File] + -> Eff es [(FilePath, TL.Text)] getFilesTexts fp = do let paths = map fromAbsFile fp - let contents = map (fmap TLE.decodeUtf8 . File.readFileLazy) paths + let contents = map (fmap TLE.decodeUtf8 . File.readFileLazyBS) paths txts <- sequenceA contents if length paths == length txts then pure $ zip paths txts - else throw $ UnknownError "Not all dictionary files was read successfully" + else throwError $ UnknownError "Some dictionary files fails to be read" +fromEither :: (Error HibetError :> es) + => Either HibetError a + -> Eff es a +fromEither (Left err) = throwError err +fromEither (Right res) = pure res +readEnv :: (Reader (MVar Env) :> es, Concurrent :> es) => Eff es Env +readEnv = do + env <- ask + readMVar env + +modifyEnv :: (Reader (MVar Env) :> es, Concurrent :> es) => (Env -> Eff es Env) -> Eff es () +modifyEnv f = do + env <- ask + modifyMVar_ env f + +putEnvMVar :: (Reader (MVar a) :> es, Concurrent :> es) => a -> Eff es () +putEnvMVar value = do + env <- ask + putMVar env value -- getFilesTextsPar fs = mapM (\f -> do -- let path = fromAbsFile f @@ -108,3 +141,4 @@ getFilesTexts fp = do -- parTraverseC strat f = withStrategy (parTraversable strat) . traverse f -- traverse :: Applicative f => (a -> f b) -> t a -> f (t b) -- mapM :: Monad m => (a -> m b) -> t a -> m (t b) + diff --git a/src/Translator.hs b/src/Translator.hs index a59a99d..6f031d3 100644 --- a/src/Translator.hs +++ b/src/Translator.hs @@ -1,13 +1,14 @@ + + module Translator ( translator ) where import Dictionary (Answer, searchTranslation, sortOutput) -import Effects.Console (Console, cancelInput, closeInput, exitSuccess, getHistory, getInput, - initializeInput, readEnv) +import Effects.Console (Console, closeInput, exitSuccess, getHistory, getInput) import Effects.PrettyPrint (Line (NewLine), PrettyPrint, pprint, putColorDoc) -import Env (Env) +import Env (Env(..), readEnv) import Parse (ScriptType (Tibet, Wylie), fromScripts, parseEither, parseTibetanInput, parseWylieInput, tibetanWord, toTibetan, toWylie, wylieWord) import Pretty (blue, red, viewTranslations, withHeaderSpaces, yellow) @@ -21,51 +22,55 @@ import Data.Maybe (mapMaybe) import Data.Text (Text) import qualified Data.Text as T import qualified Debug.Trace as Debug -import Polysemy (Members, Sem) -import Polysemy.Conc (Sync) -import Polysemy.Error (Error) -import Polysemy.Resource (Resource, bracketOnError) -import Polysemy.Trace (Trace, trace) import Prettyprinter (Doc) import Prettyprinter.Render.Terminal (AnsiStyle) import System.Console.Haskeline.History (History, historyLines) import System.Console.Haskeline.IO (InputState) +import qualified System.Console.Haskeline.IO as Haskeline +import qualified System.Console.Haskeline as Haskeline + +import Effectful ( type (:>), Eff, IOE ) +import Effectful.Resource ( allocate, release, Resource ) +-- import Effectful.Log ( logInfo_, Log ) +import Effectful.Reader.Dynamic (Reader) +import Effectful.Concurrent.MVar (MVar, Concurrent) + -- | Load environment and start loop dialog -translator :: Members - [ PrettyPrint - , Trace - , Resource - , Console - , Error HibetError - , Sync Env - ] r - => Sem r () +translator :: + ( IOE :> es + , PrettyPrint :> es + -- , Log :> es + , Resource :> es + , Console :> es + , Reader (MVar Env) :> es + , Concurrent :> es + ) + => Eff es () translator = bracketOnError - initializeInput - cancelInput -- This will only be called if an exception such as a SigINT is received. + (Haskeline.initializeInput Haskeline.defaultSettings) + Haskeline.cancelInput -- This will only be called if an exception such as a SigINT is received. $ \inputState -> do - putColorDoc blue NewLine "Please, input any word with tibetan script or wylie transcription!\nWhat is your request? " + putColorDoc blue NewLine "Input a word in the tibetan script or wylie transcription:" loopDialog inputState closeInput inputState -- Looped dialog with user -loopDialog :: Members - [ PrettyPrint - , Trace - , Console - , Error HibetError - , Sync Env - ] r +loopDialog :: + ( PrettyPrint :> es + , Console :> es + , Reader (MVar Env) :> es + , Concurrent :> es + ) => InputState - -> Sem r () + -> Eff es () loopDialog inputState = forever $ do mQuery <- getInput inputState "> " case T.strip . T.pack <$> mQuery of Nothing -> pure () Just ":q" -> do - putColorDoc yellow NewLine "Bye-bye!" + putColorDoc yellow NewLine "ཞེས་བསྟན་འཛིན་བཟང་པོ། Bye!" exitSuccess Just ":h" -> do history <- fromHistory <$> getHistory inputState @@ -73,14 +78,13 @@ loopDialog inputState = forever $ do Just input -> do env <- readEnv case getAnswer input env of - Left err -> do - trace $ show err + Left _ -> do + -- logInfo_ $ showT err putColorDoc red NewLine "Nothing found" Right (query, answer) -> if null answer then putColorDoc red NewLine "Nothing found" else pprint $ mkOutput query answer - getAnswer :: Text -> Env -> Either HibetError (Text, [Answer]) getAnswer query env = do -- 1. Detect script of input @@ -146,3 +150,12 @@ mkOutput query answers = withHeaderSpaces yellow query $ viewTranslations $ sortOutput answers + +bracketOnError :: (IOE :> es, Resource :> es) + => IO a + -> (a -> IO ()) + -> (a -> Eff es ()) -> Eff es () +bracketOnError alloc free inside = do + (releaseKey, resource) <- allocate alloc free + inside resource + release releaseKey diff --git a/src/Type.hs b/src/Type.hs index fe2957b..d28f4c0 100644 --- a/src/Type.hs +++ b/src/Type.hs @@ -6,12 +6,11 @@ module Type import Data.Text (Text) import Data.Void (Void) -import Path (PathException) import Text.Megaparsec.Error (ParseErrorBundle) data HibetError - = PathError PathException + = EffectError Text Text | MegaError (ParseErrorBundle Text Void) | NotFound | NotSyllable Text diff --git a/stack.yaml b/stack.yaml index 90ed806..f790f14 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,25 +1,21 @@ -resolver: lts-20.17 +resolver: lts-21.25 packages: - . extra-deps: -- polysemy-1.9.0.0 -- polysemy-conc-0.12.1.0 -- polysemy-resume-0.7.0.0 -- polysemy-time-0.6.0.0 -- incipit-base-0.5.1.0 -- incipit-core-0.5.1.0 - - radixtree-0.6.0.0 - tomland-1.3.3.2 -- validation-selective-0.1.0.2 +- validation-selective-0.2.0.0 +- log-effectful-1.0.0.0 +- resourcet-effectful-1.0.1.0 ghc-options: "$locals": -fhide-source-paths system-ghc: true +notify-if-nix-on-path: false # build: # library-profiling: true diff --git a/test/env/Main.hs b/test/env/Main.hs index ff1b274..138dcdc 100644 --- a/test/env/Main.hs +++ b/test/env/Main.hs @@ -1,240 +1,220 @@ module Main where import Dictionary -import Effects.File (FileIO (..)) +import Effectful (Eff, IOE, runEff) +import Effectful.Error.Static + ( Error + , runErrorNoCallStack + ) +import Effects.File (FileSystem (..)) import qualified Effects.File as EF -import Env (makeEnv) -import Label (LabelFull (..), Labels (..), Title (..)) -import Parse (ScriptType (..), Script(Script), WylieTibetMap, splitSyllables) -import Paths (dictDir, dictPath1, dictPath2, sylPath, titlePath) +import Env (Env (..), makeEnv) +import Label (Title (..)) +import Parse (Script (Script), ScriptType (..), WylieTibetMap, splitSyllables) +import Paths (dictPath1, dictPath2, sylPath, titlePath) import Type (HibetError (..)) -import Utility (mkAbsolute, pack) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import Data.Function ((&)) import qualified Data.HashMap.Strict as HM -import Data.List (sort) +import Data.List (sort, sortOn) import Data.Maybe (mapMaybe) -import qualified Data.Set as Set --- import qualified Data.Text as T import qualified Data.Text.Encoding as TE --- import Path.IO (listDir) -import Polysemy (Embed, Members, Sem) -import qualified Polysemy as P -import Polysemy.Error (Error, runError, throw) -import Polysemy.Trace (Trace, runTraceList) import Test.Hspec (Spec, describe, expectationFailure, hspec, it, shouldBe) --- import System.Directory --- import System.IO --- import qualified Debug.Trace as Trace - main :: IO () main = hspec $ do - mockMakeEnvSpec - syllables - translate + mockMakeEnvSpec + syllables + translate -mockMakeEnvSpec ::Spec +mockMakeEnvSpec :: Spec mockMakeEnvSpec = - describe "FileIO: " $ do - it "GetPath syllables" $ do - res <- snd <$> runFileMock (EF.getPath "stuff/tibetan-syllables") - res `shouldBe` Right sylPath - it "GetPath titles" $ do - res <- snd <$> runFileMock (EF.getPath "stuff/titles.toml") - res `shouldBe` Right titlePath - it "GetPath dicts" $ do - res <- snd <$> runFileMock (EF.getPath "dicts/") - res `shouldBe` Right dictDir - - it "Read file syllables" $ do - res <- snd <$> runFileMock (EF.readFile sylPath) - res `shouldBe` Right syllablesRaw - it "Read file titles" $ do - res <- snd <$> runFileMock (EF.readFile titlePath) - res `shouldBe` Right toml - it "Read file lazy dict 1" $ do - res <- snd <$> runFileMock (EF.readFileLazy dictPath1) - res `shouldBe` Right dict1 - it "Read file lazy dict 2" $ do - res <- snd <$> runFileMock (EF.readFileLazy dictPath2) - res `shouldBe` Right dict2 - - it "Make env. Meta" $ do - res <- snd <$> runFileMock makeEnv - case res of - Left err -> expectationFailure $ show err - Right env -> env.dictionaryMeta `shouldBe` [meta1,meta2] - it "Make env. Labels" $ do - res <- snd <$> runFileMock makeEnv - case res of - Left err -> expectationFailure $ show err - Right env -> env.labels `shouldBe` labels - it "Make env. WylieTibetMap" $ do - res <- snd <$> runFileMock makeEnv - case res of - Left err -> expectationFailure $ show err - Right env -> env.wylieTibetMap `shouldBe` wylieTibetHM + describe "FileIO: " $ do + it "Read file syllables" $ do + res <- runFileMock (EF.readFileBS sylPath) + res `shouldBe` Right syllablesRaw + it "Read file titles" $ do + res <- runFileMock (EF.readFileBS titlePath) + res `shouldBe` Right toml + it "Read file lazy dict 1" $ do + res <- runFileMock (EF.readFileLazyBS dictPath1) + res `shouldBe` Right dict1 + it "Read file lazy dict 2" $ do + res <- runFileMock (EF.readFileLazyBS dictPath2) + res `shouldBe` Right dict2 syllables :: Spec syllables = - describe "Syllables" $ do - it "Split syllables" $ do - case splitSyllables $ TE.decodeUtf8 syllablesRaw of - Left err -> expectationFailure $ show err - Right res -> sort res `shouldBe` sort wylieTibetSyl - it "Map and list of syllables" $ do - res <- snd <$> runFileMock makeEnv - case res of - Left err -> expectationFailure $ show err - Right env -> sort (HM.toList env.wylieTibetMap) `shouldBe` sort wylieTibetSyl + describe "Syllables" $ do + it "Split syllables" $ do + case splitSyllables $ TE.decodeUtf8 syllablesRaw of + Left err -> expectationFailure $ show err + Right res -> sort res `shouldBe` sort wylieTibetSyl translate :: Spec translate = - describe "Translate Wylie request" $ do - it "Search me" $ do - res <- snd <$> runFileMock makeEnv - case res of - Left err -> expectationFailure $ show err - Right env -> do - let query = "me" - let reply = mapMaybe (searchTranslation query) env.dictionaryMeta - reply `shouldBe` [Answer {targets = [Target "fire, flame, ember, Anaka, [the 50th year, Male Fire Dragon]"], dictNumber = 7, dictTitle = Title "Rangjung Yeshe"}] - it "Search re" $ do - res <- snd <$> runFileMock makeEnv - case res of - Left err -> expectationFailure $ show err - Right env -> do - let reply = mapMaybe (searchTranslation "re") env.dictionaryMeta - -- print rep.ly - reply `shouldBe` [Answer {targets = [Target "each; every; single; hope"], dictNumber = 5, dictTitle = Title "Hopkins"}, Answer {targets = [Target "noun + re + noun - Das: Under \"re\", 4) Occurs as a particle mostly put between two closely connected words for the purpose of giving the compound word a verbal signification; thus {snying rje} signifying compassion, can be split in two with the particle {re} between them and then it means: to take pity upon {snying re rje}; in the same manner {'o brgyal} fatigue becomes {'o re brgyal} = was fatigued. In like manner, we have {nyams re dga'}; {blo re bde}, [to be delighted]; {skyug re log}; {zhe re 'jigs}; {yi re mug}; {don re chung}. MSS: To this list we can add: {zhe re skyid}; {dang re spro}; {sems re skyo}, I'm feeling sad, how sad. [mss]"], dictNumber = 7, dictTitle = Title "Rangjung Yeshe"}] - it "Search re ba" $ do - res <- snd <$> runFileMock makeEnv - case res of - Left err -> expectationFailure $ show err - Right env -> do - let reply = mapMaybe (searchTranslation "re ba") env.dictionaryMeta - -- print rep.ly - reply `shouldBe` [Answer {targets = [Target "hope"], dictNumber = 5, dictTitle = Title "Hopkins"},Answer {targets = [Target "1) {re ba, re ba, re ba} intr. v. . to hope, aims; hopes, expectation. 2) woven cloth/ goat hair"], dictNumber = 7, dictTitle = Title "Rangjung Yeshe"}] - it "Search re ba byed pa" $ do - res <- snd <$> runFileMock makeEnv - case res of - Left err -> expectationFailure $ show err - Right env -> do - let reply = mapMaybe (searchTranslation "re ba byed pa") env.dictionaryMeta - -- print rep.ly - reply `shouldBe` [Answer {targets = [Target "to hope, wish, expect, demand, ask"], dictNumber = 7, dictTitle = Title "Rangjung Yeshe"}] - it "Search re ba med pa" $ do - res <- snd <$> runFileMock makeEnv - case res of - Left err -> expectationFailure $ show err - Right env -> do - let reply = mapMaybe (searchTranslation "re ba med pa") env.dictionaryMeta - -- print rep.ly - reply `shouldBe` [Answer {targets = [Target "hopeless; no hope"], dictNumber = 5, dictTitle = Title "Hopkins"}] - --- convert :: Spec --- convert = --- describe "Translate Wylie request" $ do --- it "Search me" $ do - -runFileMock :: Sem - '[ FileIO - , Error HibetError - , Trace - , Embed IO - ] a - -> IO ([String], Either HibetError a) -runFileMock program = program - & interpretFileMock - & runError @HibetError - & runTraceList - & P.runM - -interpretFileMock :: Members [Embed IO, Error HibetError] r => Sem (FileIO : r) a -> Sem r a -interpretFileMock = P.interpret $ \case - ReadFile path -> P.embed $ BS.readFile path - ReadFileLazy path -> P.embed $ BSL.readFile path - - GetPath path -> case path of - "stuff/tibetan-syllables" -> pure sylPath - "stuff/titles.toml" -> pure titlePath - "dicts/" -> pure dictDir - p -> throw $ UnknownError $ "Unknown get path: " <> pack p - - ListDirectory _ -> do - f1' <- EF.parseAbsFileS $ mkAbsolute dictPath1 - f2' <- EF.parseAbsFileS $ mkAbsolute dictPath2 - pure ([], [f1', f2']) - - ParseAbsDir _ -> EF.parseAbsDirS $ mkAbsolute dictDir - + describe "Translate Wylie request" $ do + it "Search mir" $ do + res <- runFileMock makeEnv + case res of + Left err -> expectationFailure $ show err + Right env -> do + let query = "mir" + let reply = mapMaybe (searchTranslation query) env.dictionaryMeta + sortOn dictNumber reply + `shouldBe` [ Answer + { targets = [Target "termin. case of mi"] + , dictNumber = 15 + , dictTitle = Title "James Valby" + } + , Answer + { targets = [Target "as/for/ to a human being"] + , dictNumber = 16 + , dictTitle = Title "Ives Waldo" + } + , Answer + { targets = + [ Target + "mi ru zhes pa'i ru yig bsdus pa ste/ srin po mir brdzus zhes pa lta bu/ (mir chags) ma'i mngal gyi byis pa/" + ] + , dictNumber = 37 + , dictTitle = Title "dag-yig gsar-bsgrigs" + } + ] + it "Search ri ma" $ do + res <- runFileMock makeEnv + case res of + Left err -> expectationFailure $ show err + Right env -> do + let reply = mapMaybe (searchTranslation "ri ma") env.dictionaryMeta + reply + `shouldBe` [ Answer + { targets = [Target "arid/ non-irrigated land"] + , dictNumber = 16 + , dictTitle = Title "Ives Waldo" + } + ] + it "Search re ba byed pa" $ do + res <- runFileMock makeEnv + case res of + Left err -> expectationFailure $ show err + Right env -> do + let reply = mapMaybe (searchTranslation "re ba byed pa") env.dictionaryMeta + sortOn dictNumber reply + `shouldBe` [ Answer + { targets = [Target "to hope, wish, expect, demand, ask"] + , dictNumber = 7 + , dictTitle = Title "Rangjung Yeshe" + } + , Answer + { targets = [Target "demand, ask, hope, wish, expect"] + , dictNumber = 15 + , dictTitle = Title "James Valby" + } + ] + it "Search re ba med pa" $ do + res <- runFileMock makeEnv + case res of + Left err -> expectationFailure $ show err + Right env -> do + let reply = mapMaybe (searchTranslation "re ba med pa") env.dictionaryMeta + sortOn dictNumber reply + `shouldBe` [ Answer + { targets = [Target "hopeless; no hope"] + , dictNumber = 5 + , dictTitle = Title "Hopkins" + } + , Answer + { targets = [Target "hopeless, despairing"] + , dictNumber = 15 + , dictTitle = Title "James Valby" + } + , Answer + { targets = [Target "hopeless, no hope of --"] + , dictNumber = 16 + , dictTitle = Title "Ives Waldo" + } + , Answer + { targets = [Target "{MSA}nirapekṣa; {MSA}niṣpratikāṅkṣa"] + , dictNumber = 41 + , dictTitle = Title "Hopkins Sanskrit" + } + ] + +runFileMock :: + Eff + '[ FileSystem + , Error HibetError + , -- , Log + IOE + ] + a + -> IO (Either HibetError a) +runFileMock program = + program + & EF.runFileSystemIO + & runErrorNoCallStack @HibetError + -- & runLog "hibet" logger defaultLogLevel + & runEff -- Data for mocking - syllablesRaw :: BS.ByteString -syllablesRaw = "bla|\224\189\150\224\190\179\nbla'am|\224\189\150\224\190\179\224\189\160\224\189\152\nblab|\224\189\150\224\190\179\224\189\150\nblabs|\224\189\150\224\190\179\224\189\150\224\189\166\nblad|\224\189\150\224\190\179\224\189\145\nblag|\224\189\150\224\190\179\224\189\130\nblags|\224\189\150\224\190\179\224\189\130\224\189\166\nbla'i|\224\189\150\224\190\179\224\189\160\224\189\178\nman|\224\189\152\224\189\147\nmaN|\224\189\152\224\189\142\nmAn|\224\189\152\224\189\177\224\189\147\nmAN|\224\189\152\224\189\177\224\189\142\nmana|\224\189\152\224\189\147\nmAna|\224\189\152\224\189\177\224\189\147\nmANa|\224\189\152\224\189\177\224\189\142\nre|\224\189\162\224\189\186\nme|\224\189\152\224\189\186\n" +syllablesRaw = + "bla|\224\189\150\224\190\179\nbla'am|\224\189\150\224\190\179\224\189\160\224\189\152\nblab|\224\189\150\224\190\179\224\189\150\nblabs|\224\189\150\224\190\179\224\189\150\224\189\166\nblad|\224\189\150\224\190\179\224\189\145\nblag|\224\189\150\224\190\179\224\189\130\nblags|\224\189\150\224\190\179\224\189\130\224\189\166\nbla'i|\224\189\150\224\190\179\224\189\160\224\189\178\nman|\224\189\152\224\189\147\nmaN|\224\189\152\224\189\142\nmAn|\224\189\152\224\189\177\224\189\147\nmAN|\224\189\152\224\189\177\224\189\142\nmana|\224\189\152\224\189\147\nmAna|\224\189\152\224\189\177\224\189\147\nmANa|\224\189\152\224\189\177\224\189\142\nre|\224\189\162\224\189\186\nme|\224\189\152\224\189\186\n" toml :: BS.ByteString -toml = "[[titles]]\n path = \"Hopkins-2015-T|E\"\n id = 5\n label = \"Hopkins\"\n about = \"The Uma Institute for Tibetan Studies Tibetan-Sanskrit-English Dictionary (Version: June 2015)|Jeffrey Hopkins, Editor.|Paul Hackett, Contributor and Technical Editor.| Contributors: Nathaniel Garson, William Magee, Andres Montano, John Powers, Craig Preston, Joe Wilson, Jongbok Yi|A PDF version of this dictionary is available for download at: www.uma-tibet.org\"\n abbreviations = \"Hopkins\"\n public = true\n listCredits = true\n available = true\n source = \"Tibetan\"\n target = [\"English\"]\n year = 2015\n\n[[titles]]\n path = \"RangjungYeshe-T|E\"\n id = 7\n label = \"Rangjung Yeshe\"\n about = \"Rangjung Yeshe Dictionary|Rangjung Yeshe Tibetan-English Dharma Dictionary 3.0 by Erik Pema Kunsang (2003)|online version: http://rywiki.tsadra.org\"\n abbreviations = \"RangjungYeshe\"\n public = true\n listCredits = true\n available = true\n source = \"Tibetan\"\n target = [\"English\"]\n" +toml = + "[[titles]]\n path = \"Hopkins-2015-T|E\"\n id = 5\n label = \"Hopkins\"\n about = \"The Uma Institute for Tibetan Studies Tibetan-Sanskrit-English Dictionary (Version: June 2015)|Jeffrey Hopkins, Editor.|Paul Hackett, Contributor and Technical Editor.| Contributors: Nathaniel Garson, William Magee, Andres Montano, John Powers, Craig Preston, Joe Wilson, Jongbok Yi|A PDF version of this dictionary is available for download at: www.uma-tibet.org\"\n abbreviations = \"Hopkins\"\n public = true\n listCredits = true\n available = true\n source = \"Tibetan\"\n target = [\"English\"]\n year = 2015\n\n[[titles]]\n path = \"RangjungYeshe-T|E\"\n id = 7\n label = \"Rangjung Yeshe\"\n about = \"Rangjung Yeshe Dictionary|Rangjung Yeshe Tibetan-English Dharma Dictionary 3.0 by Erik Pema Kunsang (2003)|online version: http://rywiki.tsadra.org\"\n abbreviations = \"RangjungYeshe\"\n public = true\n listCredits = true\n available = true\n source = \"Tibetan\"\n target = [\"English\"]\n" dict1 :: BSL.ByteString dict1 = "re|each; every; single; hope\nre ba|hope\nre ba med pa|hopeless; no hope\n" dict2 :: BSL.ByteString -dict2 = "re ba|1) {re ba, re ba, re ba} intr. v. . to hope, aims; hopes, expectation. 2) woven cloth/ goat hair\nre ba byed pa|to hope, wish, expect, demand, ask\nre ba chad|give up hope\nme|fire, flame, ember, Anaka, [the 50th year, Male Fire Dragon]\nre|noun + re + noun - Das: Under \"re\", 4) Occurs as a particle mostly put between two closely connected words for the purpose of giving the compound word a verbal signification; thus {snying rje} signifying compassion, can be split in two with the particle {re} between them and then it means: to take pity upon {snying re rje}; in the same manner {'o brgyal} fatigue becomes {'o re brgyal} = was fatigued. In like manner, we have {nyams re dga'}; {blo re bde}, [to be delighted]; {skyug re log}; {zhe re 'jigs}; {yi re mug}; {don re chung}. MSS: To this list we can add: {zhe re skyid}; {dang re spro}; {sems re skyo}, I'm feeling sad, how sad. [mss]\n" - -meta1 :: DictionaryMeta -meta1 = DictionaryMeta {dictionary = HM.fromList [("re ba",[Target "hope"]),("re ba med pa",[Target "hopeless; no hope"]),("re",[Target "each; every; single; hope"])], title = Title "Hopkins", number = 5} - -meta2 :: DictionaryMeta -meta2 = DictionaryMeta {dictionary = HM.fromList [("re ba",[Target "1) {re ba, re ba, re ba} intr. v. . to hope, aims; hopes, expectation. 2) woven cloth/ goat hair"]),("re",[Target "noun + re + noun - Das: Under \"re\", 4) Occurs as a particle mostly put between two closely connected words for the purpose of giving the compound word a verbal signification; thus {snying rje} signifying compassion, can be split in two with the particle {re} between them and then it means: to take pity upon {snying re rje}; in the same manner {'o brgyal} fatigue becomes {'o re brgyal} = was fatigued. In like manner, we have {nyams re dga'}; {blo re bde}, [to be delighted]; {skyug re log}; {zhe re 'jigs}; {yi re mug}; {don re chung}. MSS: To this list we can add: {zhe re skyid}; {dang re spro}; {sems re skyo}, I'm feeling sad, how sad. [mss]"]),("re ba byed pa",[Target "to hope, wish, expect, demand, ask"]),("me",[Target "fire, flame, ember, Anaka, [the 50th year, Male Fire Dragon]"]),("re ba chad",[Target "give up hope"])], title = Title "Rangjung Yeshe", number = 7} - -labels :: Labels -labels = Labels - {labelTitles = [LabelFull {path = "Hopkins-2015-T|E", lfId = 5, label = Title "Hopkins", about = "The Uma Institute for Tibetan Studies Tibetan-Sanskrit-English Dictionary (Version: June 2015)|Jeffrey Hopkins, Editor.|Paul Hackett, Contributor and Technical Editor.| Contributors: Nathaniel Garson, William Magee, Andres Montano, John Powers, Craig Preston, Joe Wilson, Jongbok Yi|A PDF version of this dictionary is available for download at: www.uma-tibet.org", available = True, source = "Tibetan", target = Set.fromList ["English"], year = Just 2015},LabelFull {path = "RangjungYeshe-T|E", lfId = 7, label = Title "Rangjung Yeshe", about = "Rangjung Yeshe Dictionary|Rangjung Yeshe Tibetan-English Dharma Dictionary 3.0 by Erik Pema Kunsang (2003)|online version: http://rywiki.tsadra.org", available = True, source = "Tibetan", target = Set.fromList ["English"], year = Nothing}]} +dict2 = + "re ba|1) {re ba, re ba, re ba} intr. v. . to hope, aims; hopes, expectation. 2) woven cloth/ goat hair\nre ba byed pa|to hope, wish, expect, demand, ask\nre ba chad|give up hope\nme|fire, flame, ember, Anaka, [the 50th year, Male Fire Dragon]\nre|noun + re + noun - Das: Under \"re\", 4) Occurs as a particle mostly put between two closely connected words for the purpose of giving the compound word a verbal signification; thus {snying rje} signifying compassion, can be split in two with the particle {re} between them and then it means: to take pity upon {snying re rje}; in the same manner {'o brgyal} fatigue becomes {'o re brgyal} = was fatigued. In like manner, we have {nyams re dga'}; {blo re bde}, [to be delighted]; {skyug re log}; {zhe re 'jigs}; {yi re mug}; {don re chung}. MSS: To this list we can add: {zhe re skyid}; {dang re spro}; {sems re skyo}, I'm feeling sad, how sad. [mss]\n" wylieTibetHM :: WylieTibetMap -wylieTibetHM = HM.fromList - [ (Script "bla",Script "\3926\4019") - , (Script "re",Script "\3938\3962") - , (Script "mAn",Script "\3928\3953\3923") - , (Script "maN",Script "\3928\3918") - , (Script "mAN",Script "\3928\3953\3918") - , (Script "man",Script "\3928\3923") - , (Script "me",Script "\3928\3962") - , (Script "blad",Script "\3926\4019\3921") - , (Script "blabs",Script "\3926\4019\3926\3942") - , (Script "blab",Script "\3926\4019\3926") - , (Script "bla'i",Script "\3926\4019\3936\3954") - , (Script "bla'am",Script "\3926\4019\3936\3928") - , (Script "mana",Script "\3928\3923") - , (Script "mAna",Script "\3928\3953\3923") - , (Script "mANa",Script "\3928\3953\3918") - , (Script "blags",Script "\3926\4019\3906\3942") - , (Script "blag",Script "\3926\4019\3906") - ] +wylieTibetHM = + HM.fromList + [ (Script "bla", Script "\3926\4019") + , (Script "re", Script "\3938\3962") + , (Script "mAn", Script "\3928\3953\3923") + , (Script "maN", Script "\3928\3918") + , (Script "mAN", Script "\3928\3953\3918") + , (Script "man", Script "\3928\3923") + , (Script "me", Script "\3928\3962") + , (Script "blad", Script "\3926\4019\3921") + , (Script "blabs", Script "\3926\4019\3926\3942") + , (Script "blab", Script "\3926\4019\3926") + , (Script "bla'i", Script "\3926\4019\3936\3954") + , (Script "bla'am", Script "\3926\4019\3936\3928") + , (Script "mana", Script "\3928\3923") + , (Script "mAna", Script "\3928\3953\3923") + , (Script "mANa", Script "\3928\3953\3918") + , (Script "blags", Script "\3926\4019\3906\3942") + , (Script "blag", Script "\3926\4019\3906") + ] wylieTibetSyl :: [(Script 'Wylie, Script 'Tibet)] wylieTibetSyl = - [ (Script "bla",Script "\3926\4019") - , (Script "re",Script "\3938\3962") - , (Script "mAn",Script "\3928\3953\3923") - , (Script "maN",Script "\3928\3918") - , (Script "mAN",Script "\3928\3953\3918") - , (Script "man",Script "\3928\3923") - , (Script "me",Script "\3928\3962") - , (Script "blad",Script "\3926\4019\3921") - , (Script "blabs",Script "\3926\4019\3926\3942") - , (Script "blab",Script "\3926\4019\3926") - , (Script "bla'i",Script "\3926\4019\3936\3954") - , (Script "bla'am",Script "\3926\4019\3936\3928") - , (Script "mana",Script "\3928\3923") - , (Script "mAna",Script "\3928\3953\3923") - , (Script "mANa",Script "\3928\3953\3918") - , (Script "blags",Script "\3926\4019\3906\3942") - , (Script "blag",Script "\3926\4019\3906") - ] + [ (Script "bla", Script "\3926\4019") + , (Script "re", Script "\3938\3962") + , (Script "mAn", Script "\3928\3953\3923") + , (Script "maN", Script "\3928\3918") + , (Script "mAN", Script "\3928\3953\3918") + , (Script "man", Script "\3928\3923") + , (Script "me", Script "\3928\3962") + , (Script "blad", Script "\3926\4019\3921") + , (Script "blabs", Script "\3926\4019\3926\3942") + , (Script "blab", Script "\3926\4019\3926") + , (Script "bla'i", Script "\3926\4019\3936\3954") + , (Script "bla'am", Script "\3926\4019\3936\3928") + , (Script "mana", Script "\3928\3923") + , (Script "mAna", Script "\3928\3953\3923") + , (Script "mANa", Script "\3928\3953\3918") + , (Script "blags", Script "\3926\4019\3906\3942") + , (Script "blag", Script "\3926\4019\3906") + ] diff --git a/test/labels/Main.hs b/test/labels/Main.hs index 4f24160..37c9eb0 100644 --- a/test/labels/Main.hs +++ b/test/labels/Main.hs @@ -7,7 +7,6 @@ import qualified Data.Set as Set import Test.Hspec (Spec, describe, hspec, it, shouldBe) - main :: IO () main = hspec $ do getLabelsSpec diff --git a/test/parse/Main.hs b/test/parse/Main.hs index e9c8785..4221b5c 100644 --- a/test/parse/Main.hs +++ b/test/parse/Main.hs @@ -6,10 +6,6 @@ import Parse.Type ( parseEither ) import Test.Hspec (Spec, describe, hspec, it, shouldBe) import Data.Either ( isLeft ) --- import Text.Megaparsec (parseTest) --- import qualified Text.Megaparsec.Char as MC - - main :: IO () main = hspec $ do tibetan diff --git a/test/pretty/Main.hs b/test/pretty/Main.hs index a499b7e..3b47b1d 100644 --- a/test/pretty/Main.hs +++ b/test/pretty/Main.hs @@ -9,14 +9,6 @@ import Prettyprinter.Render.Text (renderStrict) import Test.Hspec (Spec, describe, hspec, it, shouldBe) --- import Hedgehog (Gen, PropertyT, forAll, (===)) --- import Hedgehog.Gen (alphaNum, choice, element, frequency, sample, text) --- import qualified Hedgehog.Gen as G --- import Hedgehog.Range (constant) --- import Test.Hspec.Hedgehog (hedgehog) - - - main :: IO () main = hspec $ do viewTranslationsSpec