diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 0000000..b436f65 --- /dev/null +++ b/.gitattributes @@ -0,0 +1,5 @@ +# Auto detect text files and perform LF normalization +* text=auto + +# IGNORE LANGUAGE STATISTICS +docs/** linguist-documentation \ No newline at end of file diff --git a/.github/ISSUE_TEMPLATE/bug_report.md b/.github/ISSUE_TEMPLATE/bug_report.md new file mode 100644 index 0000000..dd84ea7 --- /dev/null +++ b/.github/ISSUE_TEMPLATE/bug_report.md @@ -0,0 +1,38 @@ +--- +name: Bug report +about: Create a report to help us improve +title: '' +labels: '' +assignees: '' + +--- + +**Describe the bug** +A clear and concise description of what the bug is. + +**To Reproduce** +Steps to reproduce the behavior: +1. Go to '...' +2. Click on '....' +3. Scroll down to '....' +4. See error + +**Expected behavior** +A clear and concise description of what you expected to happen. + +**Screenshots** +If applicable, add screenshots to help explain your problem. + +**Desktop (please complete the following information):** + - OS: [e.g. iOS] + - Browser [e.g. chrome, safari] + - Version [e.g. 22] + +**Smartphone (please complete the following information):** + - Device: [e.g. iPhone6] + - OS: [e.g. iOS8.1] + - Browser [e.g. stock browser, safari] + - Version [e.g. 22] + +**Additional context** +Add any other context about the problem here. diff --git a/.github/ISSUE_TEMPLATE/feature_request.md b/.github/ISSUE_TEMPLATE/feature_request.md new file mode 100644 index 0000000..bbcbbe7 --- /dev/null +++ b/.github/ISSUE_TEMPLATE/feature_request.md @@ -0,0 +1,20 @@ +--- +name: Feature request +about: Suggest an idea for this project +title: '' +labels: '' +assignees: '' + +--- + +**Is your feature request related to a problem? Please describe.** +A clear and concise description of what the problem is. Ex. I'm always frustrated when [...] + +**Describe the solution you'd like** +A clear and concise description of what you want to happen. + +**Describe alternatives you've considered** +A clear and concise description of any alternative solutions or features you've considered. + +**Additional context** +Add any other context or screenshots about the feature request here. diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml new file mode 100644 index 0000000..ec63118 --- /dev/null +++ b/.github/workflows/haskell.yml @@ -0,0 +1,128 @@ +name: CI + +on: + push: + branches: [ "main" ] + paths: [ "src/**", "test/**", "app/**", "package.yaml", "stack.yaml", "stack.yaml.lock", "UniHs.cabal", "Setup.hs" ] +# pull_request: +# branches: [ "main" ] + + workflow_dispatch: + # inputs: + +env: + env_var: ${{ vars.ENV_CONTEXT_VAR }} + +concurrency: ci-${{ github.ref }} +jobs: + build: + name: GHC ${{ matrix.ghc-version }} on ${{ matrix.os }} + runs-on: ${{ matrix.os }} + + permissions: + contents: read + + strategy: + fail-fast: false + matrix: + os: [ubuntu-latest, windows-latest, macos-latest] + ghc-version: ['${{ vars.GHC_VERSION }}'] + + steps: + - uses: actions/checkout@v3 + + - name: Set up GHC ${{ matrix.ghc-version }} + uses: haskell-actions/setup@v2 + id: setup + with: + ghc-version: ${{ matrix.ghc-version }} + cabal-version: 'latest' + cabal-update: true + + - name: Configure the build + run: | + cabal configure --enable-tests --enable-benchmarks --disable-documentation + cabal build --dry-run + + - name: Restore cached dependencies + uses: actions/cache/restore@v3 + id: cache + env: + key: ${{ runner.os }}-ghc-${{ steps.setup.outputs.ghc-version }}-cabal-${{ steps.setup.outputs.cabal-version }} + with: + path: ${{ steps.setup.outputs.cabal-store }} + key: ${{ env.key }}-plan-${{ hashFiles('**/plan.json') }} + restore-keys: ${{ env.key }}- + + - name: Install dependencies + if: steps.cache.outputs.cache-hit != 'true' + run: cabal build all --only-dependencies + + - name: Save cached dependencies + uses: actions/cache/save@v3 + if: steps.cache.outputs.cache-hit != 'true' + with: + path: ${{ steps.setup.outputs.cabal-store }} + key: ${{ steps.cache.outputs.cache-primary-key }} + + - name: Build + run: cabal build all + + - name: Run tests + run: cabal test all + + - name: Check cabal file + run: cabal check + + deploy-haddock: + name: Deploy Haddock Documentation + runs-on: 'ubuntu-latest' + + permissions: + contents: write + + steps: + - uses: actions/checkout@v3 + + - name: Set up GHC ${{ vars.GHC_VERSION }} + uses: haskell-actions/setup@v2 + id: setup + with: + ghc-version: ${{ vars.GHC_VERSION }} + cabal-version: 'latest' + cabal-update: true + + - name: Configure the build + run: | + cabal configure --enable-documentation + cabal build --dry-run + + - name: Restore cached dependencies + uses: actions/cache/restore@v3 + id: cache + env: + key: ${{ runner.os }}-ghc-${{ steps.setup.outputs.ghc-version }}-cabal-${{ steps.setup.outputs.cabal-version }}-haddock + with: + path: ${{ steps.setup.outputs.cabal-store }} + key: ${{ env.key }}-plan-${{ hashFiles('**/plan.json') }} + restore-keys: ${{ env.key }}- + + - name: Build documentation + run: | + cabal haddock all --builddir=docs_build + echo "docs=$(find docs_build -path "*/doc/html/UniHs")" >> "$GITHUB_ENV" + + - name: Save cached dependencies + uses: actions/cache/save@v3 + if: steps.cache.outputs.cache-hit != 'true' + with: + path: ${{ steps.setup.outputs.cabal-store }} + key: ${{ steps.cache.outputs.cache-primary-key }} + + - name: Deploy documentation + uses: JamesIves/github-pages-deploy-action@v4 + with: + clean: true + branch: gh-pages + folder: ${{ env.docs }} + \ No newline at end of file diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..4d1e3c3 --- /dev/null +++ b/.gitignore @@ -0,0 +1,26 @@ +dist +dist-* +cabal-dev +*.o +*.hi +*.hie +*.chi +*.chs.h +*.dyn_o +*.dyn_hi +.hpc +.hsenv +.cabal-sandbox/ +cabal.sandbox.config +*.prof +*.aux +*.hp +*.eventlog +.stack-work/ +cabal.project.local +cabal.project.local~ +.HTF/ +.ghc.environment.* +.vscode +Scripts +.DS_Store diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 index 0000000..7ed6b58 --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,69 @@ +# HLint configuration file +# https://github.com/ndmitchell/hlint +########################## + +# This file contains a template configuration file, which is typically +# placed as .hlint.yaml in the root of your project + + +# Specify additional command line arguments +# +- arguments: [--color, --cpp-simple, -XQuasiQuotes] + + +# Control which extensions/flags/modules/functions can be used +# +# - extensions: +# - default: false # all extension are banned by default +# - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used +# - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module +# +# - flags: +# - {name: -w, within: []} # -w is allowed nowhere +# +# - modules: +# - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' +# - {name: Control.Arrow, within: []} # Certain modules are banned entirely +# +# - functions: +# - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules + + +# Add custom hints for this project +# +# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar" +# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x} + +# The hints are named by the string they display in warning messages. +# For example, if you see a warning starting like +# +# Main.hs:116:51: Warning: Redundant == +# +# You can refer to that hint with `{name: Redundant ==}` (see below). + +# Turn on hints that are off by default +# +# Ban "module X(module X) where", to require a real export list +# - warn: {name: Use explicit module export list} +# +# Replace a $ b $ c with a . b $ c +- group: {name: dollar, enabled: true} +# +# Generalise map to fmap, ++ to <> +# - group: {name: generalise, enabled: true} +# +# Warn on use of partial functions +- group: {name: partial, enabled: true} + + +# Ignore some builtin hints +# - ignore: {name: Use let} +# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules + + +# Define some custom infix operators +# - fixity: infixr 3 ~^#^~ + + +# To generate a suitable file for HLint do: +# $ hlint --default > .hlint.yaml diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..d6a05a3 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog for `UniHs` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.1.0.0 - YYYY-MM-DD diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..4880edf --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Phillip Smith (c) 2023 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Phillip Smith nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Plan.md b/Plan.md new file mode 100644 index 0000000..cfeb4a2 --- /dev/null +++ b/Plan.md @@ -0,0 +1,17 @@ +# Application Planner + +## Assessment Items Creator + +Process: +1. Get current working directory. Find a parent folder that is a course (e.g. MATH2800) +2. In this course folder, if found, find (or create) an "Assessments" Folder. +3. In the Assessments folder, parse all folder names in the format "Assessment \d+". Create the next folder in the sequence. If none exist, or the largest is <= 0, create "Assessment 01". +4. In the new assessment folder, copy the template assessment folder into the new directory. + +## Dev Notes +- Finalise config functions. Implement the effects of reading a config action: copying and text replacement +- Update `-Here` semantics (and other similar commands) to accept config template names. Also, look at `fileContentReplacementMappings`. + Maybe use a data type to avoid the relative path in the key? Or maybe not? + +## Issues +- Need to perform check before string replacing file, because it may not be a plaintext document. \ No newline at end of file diff --git a/README.md b/README.md new file mode 100644 index 0000000..211b2ec --- /dev/null +++ b/README.md @@ -0,0 +1,7 @@ +# UniHs + +[![Build](https://github.com/TimeTravelPenguin/UniHs/actions/workflows/haskell.yml/badge.svg)](https://github.com/TimeTravelPenguin/UniHs/actions/workflows/haskell.yml) + +A simple tool to do university-related tasks + +[Documentation](https://timetravelpenguin.github.io/UniHs/) diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/UniHs.cabal b/UniHs.cabal new file mode 100644 index 0000000..b2dc3ec --- /dev/null +++ b/UniHs.cabal @@ -0,0 +1,138 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.36.0. +-- +-- see: https://github.com/sol/hpack + +name: UniHs +version: 0.1.0.0 +synopsis: Maintain and create assessment template directories from templates +description: Please see the README on GitHub at +category: Application +homepage: https://github.com/TimeTravelPenguin/UniHs#readme +bug-reports: https://github.com/TimeTravelPenguin/UniHs/issues +author: Phillip Smith +maintainer: TimeTravelPenguin@gmail.com +copyright: Copyright (c) 2022 Phillip Smith +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/TimeTravelPenguin/UniHs + +library + exposed-modules: + Actions.CourseDirectory + App + Commands + Data.Configuration + Data.CourseDirectory + Data.Options + Exceptions + Helpers.IO + Helpers.Maybe + Helpers.Sequence + Parsing.Configuration + Parsing.CourseDirectory + Printing + StringFormatters + other-modules: + Paths_UniHs + hs-source-dirs: + src + default-extensions: + ImportQualifiedPost + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + QuickCheck <2.15 + , aeson <2.2.1 + , aeson-pretty <0.9 + , ansi-terminal <1.1 + , base >=4.7 && <5 + , bytestring <0.12 + , colour <=2.3.6 + , containers <0.7 + , either <5.1 + , extra <1.8 + , filepath <1.5 + , lens <5.3 + , megaparsec <9.5 + , mtl <2.4 + , optparse-applicative <0.19 + , path <0.10 + , path-io <1.9 + , pretty-simple <4.2 + , safe <0.4 + , text <2.1 + , transformers <0.6.2 + default-language: Haskell2010 + +executable UniHs-exe + main-is: Main.hs + other-modules: + Paths_UniHs + hs-source-dirs: + app + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + QuickCheck <2.15 + , UniHs + , aeson <2.2.1 + , aeson-pretty <0.9 + , ansi-terminal <1.1 + , base >=4.7 && <5 + , bytestring <0.12 + , colour <=2.3.6 + , containers <0.7 + , either <5.1 + , extra <1.8 + , filepath <1.5 + , lens <5.3 + , megaparsec <9.5 + , mtl <2.4 + , optparse-applicative <0.19 + , path <0.10 + , path-io <1.9 + , pretty-simple <4.2 + , safe <0.4 + , text <2.1 + , transformers <0.6.2 + default-language: Haskell2010 + +test-suite UniHs-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_UniHs + hs-source-dirs: + test + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + QuickCheck <2.15 + , UniHs + , aeson <2.2.1 + , aeson-pretty <0.9 + , ansi-terminal <1.1 + , base >=4.7 && <5 + , bytestring <0.12 + , colour <=2.3.6 + , containers <0.7 + , either <5.1 + , extra <1.8 + , filepath <1.5 + , lens <5.3 + , megaparsec <9.5 + , mtl <2.4 + , optparse-applicative <0.19 + , path <0.10 + , path-io <1.9 + , pretty-simple <4.2 + , safe <0.4 + , text <2.1 + , transformers <0.6.2 + default-language: Haskell2010 diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..20a3def --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Main (main) where + +import Actions.CourseDirectory (createNewAssessmentInLocation, showErr) +import App (App, appOptions, mkApp) +import Control.Lens ((^.)) +import Control.Monad (void) +import Control.Monad.State.Strict (MonadIO (liftIO)) +import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT) +import Control.Monad.Trans.Reader (ReaderT (runReaderT), reader) +import Data.Configuration (ConfigurationPath (NewConfiguration)) +import Data.Options ( + AssessmentCopyToLocation, + ProgramCommand (CreateAssessment, GradingCLI), + appArgs, + currentWorkingDir, + programCommand, + ) +import Exceptions (AppExceptionMonad) +import Parsing.Configuration (findOrCreateDefaultConfig) +import Path (Abs, Dir, Path, fromAbsDir) +import Path.IO (ensureDir, getAppUserDataDir, getCurrentDir) +import Printing ( + sgrGray, + sgrHyperlinkFile, + sgrPutStr, + sgrPutStrLn, + sgrYellow, + startSGRScope, + ) +import StringFormatters (cleanAbsDirPathString, cleanAbsFilePathString) + +showStartingDirMsg :: IO () +showStartingDirMsg = do + startSGRScope sgrGray $ do + dir <- liftIO getCurrentDir + sgrPutStrLn . unwords $ ["\nUniHs starting in:", cleanAbsDirPathString dir] + +printConfigCreatedMessage :: String -> IO () +printConfigCreatedMessage configPath = do + startSGRScope sgrYellow $ do + sgrPutStr "Created a new default config at \"" + sgrHyperlinkFile configPath + sgrPutStrLn "\".\n" + + putStrLn "Please modify before re-running the application." + +main :: IO () +main = do + startupWithConfig + +getConfig :: IO (AppExceptionMonad ConfigurationPath) +getConfig = runExceptT $ do + appDir <- liftIO $ getAppUserDataDir "uni-hs" + liftIO $ ensureDir appDir + liftIO $ findOrCreateDefaultConfig appDir "config.json" + +startupWithConfig :: IO () +startupWithConfig = do + configPath <- getConfig + showStartingDirMsg + case configPath of + Left err -> print err + Right (NewConfiguration path) -> + printConfigCreatedMessage $ cleanAbsFilePathString path + Right cfg -> do + void . runExceptT $ do + app <- ExceptT $ mkApp cfg + runReaderT runApp app + +runApp :: (MonadIO m) => ReaderT App m () +runApp = do + command <- reader (^. appOptions . appArgs . programCommand) + cwd <- reader (^. appOptions . currentWorkingDir) + liftIO $ case command of + CreateAssessment loc -> newAssessment loc cwd + GradingCLI -> print "This feature is currently not implemented." + +newAssessment :: AssessmentCopyToLocation -> Path Abs Dir -> IO () +newAssessment loc cwd = do + newAssess <- createNewAssessmentInLocation loc cwd + case newAssess of + Left ex -> showErr ex + Right assess -> do + let p = fromAbsDir assess + startSGRScope sgrYellow $ do + sgrPutStr "Assessment created in: \"" + sgrHyperlinkFile p + sgrPutStrLn "\".\n" diff --git a/defaultTemplate/defaultArticle.tex b/defaultTemplate/defaultArticle.tex new file mode 100644 index 0000000..850ab8d --- /dev/null +++ b/defaultTemplate/defaultArticle.tex @@ -0,0 +1,11 @@ +\documentclass[11pt]{article} + +\title{%%COURSE%% Assessment %%ASSESSNO%%} + +\date{\today} +\author{%%NAME%%} + +\begin{document} + \maketitle + Hello, there! This is just a simple \LaTeX template! +\end{document} \ No newline at end of file diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 0000000..d4d60d7 --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,51 @@ +# Number of spaces per indentation step +indentation: 2 + +# Max line length for automatic line breaking +column-limit: none + +# Styling of arrows in type signatures (choices: trailing, leading, or leading-args) +function-arrows: trailing + +# How to place commas in multi-line lists, records, etc. (choices: leading or trailing) +comma-style: leading + +# Styling of import/export lists (choices: leading, trailing, or diff-friendly) +import-export-style: diff-friendly + +# Whether to full-indent or half-indent 'where' bindings past the preceding body +indent-wheres: false + +# Whether to leave a space before an opening record brace +record-brace-space: false + +# Number of spaces between top-level declarations +newlines-between-decls: 1 + +# How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact) +haddock-style: single-line + +# How to print module docstring +haddock-style-module: multi-line + +# Styling of let blocks (choices: auto, inline, newline, or mixed) +let-style: inline + +# How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space) +in-style: right-align + +# Whether to put parentheses around a single constraint (choices: auto, always, or never) +single-constraint-parens: never + +# Output Unicode syntax (choices: detect, always, or never) +unicode: never + +# Give the programmer more choice on where to insert blank lines +respectful: true + +# Fixity information for operators +fixities: [] + +# Module reexports Fourmolu should know about +reexports: [] + diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..fe5e18d --- /dev/null +++ b/package.yaml @@ -0,0 +1,81 @@ +name: UniHs +version: 0.1.0.0 +github: "TimeTravelPenguin/UniHs" +license: MIT +author: "Phillip Smith" +maintainer: "TimeTravelPenguin@gmail.com" +copyright: "Copyright (c) 2022 Phillip Smith" + +extra-source-files: + - README.md + - CHANGELOG.md + +# Metadata used when publishing your package +synopsis: Maintain and create assessment template directories from templates +category: Application + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + +dependencies: + - base >= 4.7 && < 5 + - aeson < 2.2.1 + - aeson-pretty < 0.9 + - ansi-terminal < 1.1 + - bytestring < 0.12 + - containers < 0.7 + - colour <= 2.3.6 + - either < 5.1 + - extra < 1.8 + - filepath < 1.5 + - transformers < 0.6.2 + - lens < 5.3 + - megaparsec < 9.5 + - mtl < 2.4 + - optparse-applicative < 0.19 + - path < 0.10 + - path-io < 1.9 + - pretty-simple < 4.2 + - QuickCheck < 2.15 + - safe < 0.4 + - text < 2.1 + +ghc-options: + - -Wall + - -Wcompat + - -Widentities + - -Wincomplete-record-updates + - -Wincomplete-uni-patterns + - -Wmissing-export-lists + - -Wmissing-home-modules + - -Wpartial-fields + - -Wredundant-constraints + +library: + source-dirs: src + default-extensions: + - ImportQualifiedPost + +executables: + UniHs-exe: + main: Main.hs + source-dirs: app + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - UniHs + +tests: + UniHs-test: + main: Spec.hs + source-dirs: test + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - UniHs diff --git a/src/Actions/CourseDirectory.hs b/src/Actions/CourseDirectory.hs new file mode 100644 index 0000000..81208b5 --- /dev/null +++ b/src/Actions/CourseDirectory.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Actions.CourseDirectory ( + CourseDirectoryError (..), + getCourseDirectoryInPath, + ensureAssessmentsDirectory, + createNewAssessmentInLocation, + showErr, +) where + +import Control.Lens ((&), (.~), (^.), (^?), _Just) +import Control.Monad.Except (ExceptT, liftEither, runExceptT, withExceptT) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Maybe (MaybeT (runMaybeT), hoistMaybe, maybeToExceptT) +import Data.CourseDirectory ( + AssessmentItem (..), + AssessmentsDirectory (..), + CourseDirectory (..), + assessmentItemNumber, + assessmentsDirectoryPath, + courseAssessmentsDirectoryRoot, + courseDirectoryPath, + mkAssessmentItem, + ) +import Data.Either (isRight) +import Data.List (find) +import Data.Options (AssessmentCopyToLocation (..)) +import Data.Sequence (Seq, (<|)) +import Data.Sequence qualified as Seq +import Data.Void (Void) +import Helpers.Sequence (rights) +import Parsing.CourseDirectory (isAssessmentItemFolder, isCourseCode, isYear) +import Path (Abs, Dir, Path, Rel, parent, reldir, ()) +import Path.IO (ensureDir, listDir, resolveDir) +import Printing (sgrHyperlinkFile, sgrPutStr, sgrPutStrLn, sgrRed, startSGRScope) +import Safe.Foldable (maximumDef) +import StringFormatters (cleanDirNameString) +import Text.Megaparsec (MonadParsec (eof), Parsec, parse) +import Text.Megaparsec.Char (string) + +type Parser = Parsec Void FilePath + +-- FIXME: REMOVE THIS +data CourseDirectoryError + = CourseDirNotFound (Path Abs Dir) + | CourseAssessmentsDirNotFound (Path Abs Dir) + | FailedToCreateDirectory (Path Abs Dir) (Path Rel Dir) + | OtherException String + +showErr :: CourseDirectoryError -> IO () +showErr (CourseDirNotFound path) = + startSGRScope sgrRed $ do + sgrPutStr "Error: CourseDirNotFound. " + sgrPutStr "Could not find a course directory in the path " + sgrHyperlinkFile (show path) + sgrPutStrLn "." +showErr (CourseAssessmentsDirNotFound path) = + startSGRScope sgrRed $ do + sgrPutStr "Error: CourseAssessmentsDirNotFound. " + sgrPutStr "Could not find an Assessments directory at the path" + sgrHyperlinkFile (show path) + sgrPutStrLn "." +showErr (FailedToCreateDirectory path rel) = + startSGRScope sgrRed $ do + sgrPutStr "Error: FailedToCreateDirectory." + sgrPutStr "Could not create the directory" + sgrHyperlinkFile (show $ path rel) + sgrPutStrLn "." +showErr (OtherException msg) = + startSGRScope sgrRed $ do + sgrPutStr "Error: OtherException." + sgrPutStrLn msg + +-- TODO: Move this. This doesn't feel like an appropriate location. +findCourseDirInPath :: Path Abs Dir -> Maybe (Path Abs Dir) +findCourseDirInPath currentDir + | parentIsYearDir && isCourseDir = Just currentDir + | currentDir == currentParent = Nothing + | otherwise = findCourseDirInPath currentParent + where + currentParent = parent currentDir + parentIsYearDir = isYear . cleanDirNameString $ currentParent + currentDirName = cleanDirNameString currentDir + isCourseDir = isCourseCode currentDirName + +getAssessmentsRootInDirectory :: (MonadIO m) => Path Abs Dir -> MaybeT m (Path Abs Dir) +getAssessmentsRootInDirectory dir = do + (folders, _) <- listDir dir + let folderNames = map cleanDirNameString folders + parser = parse (string "Assessments" <* eof :: Parser FilePath) "" + selector = find (isRight . parser) + selectedDir <- hoistMaybe $ selector folderNames + liftIO $ resolveDir dir selectedDir + +getCourseAssessmentItemsPaths :: (MonadIO m) => Path Abs Dir -> m (Seq (Path Abs Dir)) +getCourseAssessmentItemsPaths dir = do + (folders, _) <- listDir dir + let isValidFolder = isAssessmentItemFolder . cleanDirNameString + validFolders = filter isValidFolder folders + return $ Seq.fromList validFolders + +getAssessmentItems :: (MonadIO m) => Path Abs Dir -> m (Seq AssessmentItem) +getAssessmentItems assessDirPath = + rights + . fmap mkAssessmentItem + <$> getCourseAssessmentItemsPaths assessDirPath + +getAssessmentsDirectory :: (MonadIO m) => Path Abs Dir -> MaybeT m AssessmentsDirectory +getAssessmentsDirectory courseDirPath = do + assessmentDirPath <- getAssessmentsRootInDirectory courseDirPath + assessItems <- getAssessmentItems assessmentDirPath + return $ AssessmentsDirectory assessmentDirPath assessItems + +getCourseDirectoryInPath :: (MonadIO m) => Path Abs Dir -> ExceptT CourseDirectoryError m CourseDirectory +getCourseDirectoryInPath path = do + courseDir <- maybeToExceptT (CourseDirNotFound path) . hoistMaybe $ findCourseDirInPath path + assess <- runMaybeT (getAssessmentsDirectory courseDir) + return $ CourseDirectory courseDir assess + +ensureAssessmentsDirectory :: (MonadIO m) => CourseDirectory -> m CourseDirectory +ensureAssessmentsDirectory dir = do + let courseAssDir = dir ^. courseAssessmentsDirectoryRoot + assessRoot <- case courseAssDir of + Just assessDir -> return $ assessDir ^. assessmentsDirectoryPath + Nothing -> liftIO $ resolveDir (dir ^. courseDirectoryPath) "Assessments" + ensureDir assessRoot + assessments <- runMaybeT . getAssessmentsDirectory $ dir ^. courseDirectoryPath + return $ dir & (courseAssessmentsDirectoryRoot .~ assessments) + +-- | Return the next assessment index greater than zero. +nextAssessmentIdx :: Seq AssessmentItem -> Integer +nextAssessmentIdx = (+) 1 . maximumDef 0 . (0 <|) . fmap (^. assessmentItemNumber) + +createNewAssessmentAt :: (MonadIO m) => Path Abs Dir -> m (Path Abs Dir) +createNewAssessmentAt dir = do + nextIdx <- nextAssessmentIdx <$> getAssessmentItems dir + newAssesDir <- resolveDir dir $ unwords ["Assessment", show nextIdx] + ensureDir newAssesDir + return newAssesDir + +ensureCourseDirectoryInPath :: (MonadIO m) => Path Abs Dir -> ExceptT CourseDirectoryError m CourseDirectory +ensureCourseDirectoryInPath dir = do + courseDir <- getCourseDirectoryInPath dir + ensureAssessmentsDirectory courseDir + +-- createNewAssessmentInAssessRootOf :: MonadIO m => Path Abs Dir -> m (Either CourseDirectoryError (Path Abs Dir)) +createNewAssessmentInAssessRootOf dir = do + courseDir <- ensureCourseDirectoryInPath dir + let assesPath = courseDir ^. courseAssessmentsDirectoryRoot ^? _Just . assessmentsDirectoryPath + case assesPath of + Nothing -> liftEither . Left $ FailedToCreateDirectory (courseDir ^. courseDirectoryPath) [reldir|Assessments|] + Just path -> withExceptT OtherException $ createNewAssessmentAt path + +createNewAssessmentInLocation :: (MonadIO m) => AssessmentCopyToLocation -> Path Abs Dir -> m (Either CourseDirectoryError (Path Abs Dir)) +createNewAssessmentInLocation loc dir = runExceptT $ do + case loc of + AssessmentsRootDir -> createNewAssessmentInAssessRootOf dir + CurrentWorkingDirectory -> withExceptT OtherException $ createNewAssessmentAt dir diff --git a/src/App.hs b/src/App.hs new file mode 100644 index 0000000..6a6af1e --- /dev/null +++ b/src/App.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} + +module App ( + App, + appOptions, + appConfig, + mkApp, +) where + +import Control.Lens (makeLenses) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT) +import Data.Configuration (Configuration, ConfigurationPath) +import Data.Options (ProgramOptions, getProgramOptions) +import Exceptions (AppExceptionMonad) +import Parsing.Configuration (parseApplicationConfig) + +data App = App + { _appOptions :: ProgramOptions + , _appConfig :: Configuration + } + +makeLenses ''App + +mkApp :: (MonadIO m) => ConfigurationPath -> m (AppExceptionMonad App) +mkApp configPath = + runExceptT $ do + config <- ExceptT . liftIO $ parseApplicationConfig configPath + options <- liftIO getProgramOptions + return $ App options config diff --git a/src/Commands.hs b/src/Commands.hs new file mode 100644 index 0000000..bb6c6ea --- /dev/null +++ b/src/Commands.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE RankNTypes #-} + +module Commands (ConfigurationReader, runProgram) where + +import Actions.CourseDirectory (createNewAssessmentInLocation, showErr) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Reader (ReaderT) +import Data.Configuration (Configuration) +import Data.Options ( + AppArgs (AppArgs), + AssessmentCopyToLocation, + ProgramCommand (CreateAssessment, GradingCLI), + ProgramOptions (ProgramOptions), + getProgramOptions, + ) +import Path (Abs, Dir, Path) +import Printing (sgrHyperlinkFile, sgrPutStr, sgrPutStrLn, sgrYellow, startSGRScope) +import StringFormatters (cleanAbsDirPathString) + +type ConfigurationReader a = forall m. (MonadIO m) => ReaderT Configuration m a + +-- | TODO: Need to implement configuration logics +runProgram :: ConfigurationReader () +runProgram = do + (ProgramOptions (AppArgs command) cwd) <- liftIO getProgramOptions + liftIO $ case command of + CreateAssessment loc -> newAssessmentInLocation loc cwd + GradingCLI -> print "This feature is currently not implemented." + +newAssessmentInLocation :: AssessmentCopyToLocation -> Path Abs Dir -> IO () +newAssessmentInLocation loc dir = do + newAssess <- createNewAssessmentInLocation loc dir + case newAssess of + Left ex -> showErr ex + Right assess -> do + let assessStr = cleanAbsDirPathString assess + startSGRScope sgrYellow $ do + sgrPutStr "Assessment created in: \"" + sgrHyperlinkFile assessStr + sgrPutStrLn "\".\n" diff --git a/src/Data/Configuration.hs b/src/Data/Configuration.hs new file mode 100644 index 0000000..9de770c --- /dev/null +++ b/src/Data/Configuration.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.Configuration ( + -- * Type Alias + ReplacementActionName, + ReplacementSearchString, + TemplateName, + + -- * Data Types + + -- ** Text Replacement Action + TextReplacementAction (..), + replacementActionName, + replacementActionSearchString, + replacementText, + + -- ** Template Configuration + AuthorInfo (..), + TemplateConfiguration (..), + authorInfo, + templateDirectoryPath, + relativeOutputPath, + fileContentReplacementMap, + + -- ** Configuration + Configuration (..), + contentReplacementActions, + templateConfigurations, + + -- ** Other datatypes + ConfigurationPath (NewConfiguration, ExistingConfiguration), + configurationPath, + isNewConfiguration, +) where + +import Control.Lens (makeLenses) +import Data.Aeson (FromJSON, ToJSON) +import Data.List.NonEmpty (NonEmpty) +import Data.Map.Strict (Map) +import Data.Sequence (Seq) +import Data.Text (Text) +import GHC.Generics (Generic) +import Path (Abs, Dir, File, Path, Rel) + +type ReplacementActionName = Text +type ReplacementSearchString = Text +type TemplateName = Text + +-- TODO: Clean these docs + +-- | A text replacement action to perform on the contents of a file, +-- as read from a configuration file. +data TextReplacementAction = TextReplacementAction + { _replacementActionName :: ReplacementActionName + -- ^ The unique name for the replacement action + , _replacementActionSearchString :: ReplacementSearchString + -- ^ The String to find and replace with a file + , _replacementText :: Text + -- ^ The value to substitute in place of the found search string. + -- There are some special values that can be used based on the current directory: + -- + -- +------------------------+-----------------------------------------------------+ + -- | _replacementText Value | Substituted Value | + -- +========================+=====================================================+ + -- | %%THECOURSE%% | The course code found in the current directory. | + -- +------------------------+-----------------------------------------------------+ + -- | %%THEASSESSNO%% | The numeric value of the current assessment folder. | + -- +------------------------+-----------------------------------------------------+ + -- | %%THEAUTHOR%% | The author as specified in the used template. | + -- | | If no author is given, no replacement will be made. | + -- +------------------------+-----------------------------------------------------+ + -- + -- Any other values will be substituted as is. + } + deriving (Show, Eq, Generic, FromJSON, ToJSON) + +-- | Information about authors for `TemplateConfiguration`s. +data AuthorInfo + = -- | A single author + SingularAuthor Text + | -- | A non-empty collection of authors + MultipleAuthors (NonEmpty Text) + deriving (Show, Eq, Generic, FromJSON, ToJSON) + +-- | A template to specify a directory of files to copy to a new location. +data TemplateConfiguration = TemplateConfiguration + { _authorInfo :: Maybe AuthorInfo + -- ^ The author of the current template + , _templateDirectoryPath :: Path Abs Dir + -- ^ The absolute path to the directory of files consisting of the template + , _relativeOutputPath :: Path Rel Dir + -- ^ The path relative to the assessment root (or current directory when using --here) + -- where the contents of the template folder will be copied into. + -- An empty path will copy directly into the root directory, without a new folder. + , _fileContentReplacementMap :: Map (Path Rel File) (Seq Text) + -- ^ A mapping of files relative to the template directory with `TextReplacementAction`s to perform. + -- Keys are the relative file paths and values are `Seq Text` of names to `TextReplacementActions`. + } + deriving (Show, Eq, Generic, FromJSON, ToJSON) + +-- | A template configuration used to copy a directory when creating a new assessment. +data Configuration = Configuration + { _contentReplacementActions :: Seq TextReplacementAction + -- ^ A collection of replacement actions to perform on specified file contents + , -- TODO: Allow for copy templates to be compositions, which are lists of existing copy template names + _templateConfigurations :: Map TemplateName TemplateConfiguration + -- ^ A mapping of template configuration names to configurations + } + deriving (Show, Eq, Generic, FromJSON, ToJSON) + +data ConfigurationPath + = NewConfiguration (Path Abs File) + | ExistingConfiguration (Path Abs File) + deriving (Show, Eq, Generic, FromJSON, ToJSON) + +configurationPath :: ConfigurationPath -> Path Abs File +configurationPath (NewConfiguration path) = path +configurationPath (ExistingConfiguration path) = path + +isNewConfiguration :: ConfigurationPath -> Bool +isNewConfiguration cfg = + case cfg of + NewConfiguration _ -> True + ExistingConfiguration _ -> False + +makeLenses ''TextReplacementAction +makeLenses ''TemplateConfiguration +makeLenses ''Configuration + +{- +instance ToJSON TextReplacementAction +instance FromJSON TextReplacementAction +instance ToJSON CopyTemplate +instance FromJSON CopyTemplate +instance ToJSON CopyConfiguration +instance FromJSON CopyConfiguration +-} + +{- +instance ToJSON TextReplacementAction where + toJSON v = + object + [ "ActionName" .= (v ^. replacementActionName) + , "SearchString" .= (v ^. replacementActionSearchString) + ] + +instance FromJSON TextReplacementAction where + parseJSON = withObject "TextReplacementAction" $ \v -> + TextReplacementAction + <$> v .: "ActionName" + <*> v .: "SearchString" + +instance ToJSON CopyTemplate where + toJSON v = + object + [ "TemplateFolderDirectory" .= (v ^. templateFolderDirectory) + , "RelativeOutputPath" .= (v ^. relativeOutputPath) + , "FileContentReplacementMap" .= (v ^. fileContentReplacementMap) + ] + +instance FromJSON CopyTemplate where + parseJSON = withObject "CopyTemplate" $ \v -> + CopyTemplate + <$> v .: "TemplateFolderDirectory" + <*> v .: "RelativeOutputPath" + <*> v .: "FileContentReplacementMap" + +instance ToJSON CopyConfiguration where + toJSON v = + object + [ "CopyTemplates" .= (v ^. copyTemplates) + , "ContentReplacementActions" .= (v ^. contentReplacementActions) + ] + +instance FromJSON CopyConfiguration where + parseJSON = withObject "CopyConfiguration" $ \v -> + CopyConfiguration + <$> v .: "ContentReplacementActions" + <*> v .: "CopyTemplates" +-} diff --git a/src/Data/CourseDirectory.hs b/src/Data/CourseDirectory.hs new file mode 100644 index 0000000..90a1897 --- /dev/null +++ b/src/Data/CourseDirectory.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.CourseDirectory ( + SubjectCode, + SubjectIdentifier, + CourseCode (CourseCode), + CourseDirectory (CourseDirectory), + AssessmentsDirectory (AssessmentsDirectory), + AssessmentItem (AssessmentItem), + mkCourseCode, + mkAssessmentItem, + -- Lenses + assessmentItemNumber, + assessmentItemDirectory, + assessmentsDirectoryPath, + assessmentItems, + courseDirectoryPath, + courseAssessmentsDirectoryRoot, + subjectCode, + numericIdentifier, +) where + +import Control.Lens (makeLenses) +import Data.Either.Combinators (rightToMaybe) +import Data.Sequence (Seq) +import Data.Void (Void) +import Parsing.CourseDirectory (parseAssessmentItemFolderNumber, parseCourseCode) +import Path (Abs, Dir, Path) +import StringFormatters (cleanDirNameString) +import Text.Megaparsec (ParseErrorBundle) + +type SubjectCode = String + +type SubjectIdentifier = Integer + +data CourseCode = CourseCode + { _subjectCode :: SubjectCode + , _numericIdentifier :: SubjectIdentifier + } + deriving (Eq) + +data CourseDirectory = CourseDirectory + { _courseDirectoryPath :: Path Abs Dir + , _courseAssessmentsDirectoryRoot :: Maybe AssessmentsDirectory + } + deriving (Eq, Show) + +data AssessmentsDirectory = AssessmentsDirectory + { _assessmentsDirectoryPath :: Path Abs Dir + , _assessmentItems :: Seq AssessmentItem + } + deriving (Eq, Show) + +data AssessmentItem = AssessmentItem + { _assessmentItemNumber :: Integer + , _assessmentItemDirectory :: Path Abs Dir + } + deriving (Eq, Show) + +makeLenses ''AssessmentItem +makeLenses ''AssessmentsDirectory +makeLenses ''CourseDirectory +makeLenses ''CourseCode + +-- TODO: Move these mk functions to Parsing +mkCourseCode :: String -> Maybe CourseCode +mkCourseCode = + rightToMaybe + . fmap (\(subj, ident) -> CourseCode subj $ read ident) + . parseCourseCode + +mkAssessmentItem :: Path Abs Dir -> Either (ParseErrorBundle String Void) AssessmentItem +mkAssessmentItem assessPath = do + let folderName = cleanDirNameString assessPath + num <- parseAssessmentItemFolderNumber folderName + return $ AssessmentItem num assessPath diff --git a/src/Data/Options.hs b/src/Data/Options.hs new file mode 100644 index 0000000..1ceb903 --- /dev/null +++ b/src/Data/Options.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE TemplateHaskell #-} + +{- | +Module : Data.Options + +Module contains functionality for parsing command line arguments +-} +module Data.Options ( + -- * Types + + -- | These types encapsulates the provided command line arguments. + ProgramCommand (..), + AssessmentCopyToLocation (..), + AppArgs (..), + programCommand, + ProgramOptions (..), + appArgs, + currentWorkingDir, + + -- * Parser functions + argParser, + parseProgramCommand, + parseCommandGradingCLI, + parseFlagAssessmentCopyToLocation, + parseCommandNewAssessment, + + -- * Option Parsing + getProgramOptions, +) where + +import Options.Applicative ( + CommandFields, + Mod, + Parser, + ParserInfo, + command, + execParser, + flag, + fullDesc, + header, + help, + helper, + info, + long, + progDesc, + subparser, + (<**>), + ) + +import Control.Lens (makeLenses) +import Path (Abs, Dir, Path) +import Path.IO (AnyPath (makeAbsolute), getCurrentDir) + +-- | Datatype for which command the program will execute. +data ProgramCommand + = -- | Create a new assessment directory + CreateAssessment + AssessmentCopyToLocation + -- ^ Whether or not to copy an assessment template here, or into a new assessment directory (via *--here* flag) + | -- | Start the CLI to add, edit, or use hypothetical grades for various features + GradingCLI + deriving (Show) + +-- | Data type for @--here@ flag. See `parseFlagAssessmentCopyToLocation`. +data AssessmentCopyToLocation = AssessmentsRootDir | CurrentWorkingDirectory deriving (Show) + +-- | Data type containing data for parsed command line arguments. +newtype AppArgs = AppArgs + { _programCommand :: ProgramCommand + } + deriving (Show) + +-- | Options used at runtime containing parsed AppArgs +data ProgramOptions = ProgramOptions + { _appArgs :: AppArgs + , _currentWorkingDir :: Path Abs Dir + } + deriving (Show) + +makeLenses ''AppArgs +makeLenses ''ProgramOptions + +-- | Parses @assess@ command for `CreateAssessment`. +parseCommandNewAssessment :: Mod CommandFields ProgramCommand +parseCommandNewAssessment = + command + "assess" + ( info + (CreateAssessment <$> parseFlagAssessmentCopyToLocation <**> helper) + ( progDesc "Create a new assessment folder in the current course (parent) directory, unless using --here" + ) + ) + +-- | Parses @--here@ flag for `AssessmentCopyToLocation`. Using the flag results in `Here`. Otherwise, `NewCourseAssessment`. +parseFlagAssessmentCopyToLocation :: Parser AssessmentCopyToLocation +parseFlagAssessmentCopyToLocation = + flag + AssessmentsRootDir + CurrentWorkingDirectory + ( long "here" + <> help "Create a new assessment folder in the current course (parent) directory" + ) + +-- | Parses @grades@ command for `GradingCLI`. +parseCommandGradingCLI :: Mod CommandFields ProgramCommand +parseCommandGradingCLI = + command + "grades" + ( info + (pure GradingCLI <**> helper) + ( progDesc "Start the CLI to add, edit, or use hypothetical grades for various features" + ) + ) + +-- | Parses a `ProgramCommand`. +parseProgramCommand :: Parser ProgramCommand +parseProgramCommand = subparser (parseCommandNewAssessment <> parseCommandGradingCLI) + +-- | Application argument parser used to parse `AppArgs`. +argParser :: Parser AppArgs +argParser = AppArgs <$> parseProgramCommand + +-- | Contains application information. +appInfo :: ParserInfo AppArgs +appInfo = + info + (argParser <**> helper) + ( fullDesc + <> progDesc "A tool for performing simple university related tasks." + <> header "UniHs.exe is made by Phillip Smith" + ) + +-- | Used to create a `ProgramOptions` by parsing `AppArgs` from the commandline. +getProgramOptions :: IO ProgramOptions +getProgramOptions = do + cwd <- getCurrentDir >>= makeAbsolute + parser <- execParser appInfo + return $ ProgramOptions parser cwd diff --git a/src/Exceptions.hs b/src/Exceptions.hs new file mode 100644 index 0000000..e8152b5 --- /dev/null +++ b/src/Exceptions.hs @@ -0,0 +1,29 @@ +module Exceptions ( + -- * Application exception + + -- | The monad in which application exceptions are thrown + AppExceptionMonad, + AppExceptionMonadT, + + -- ** Application exceptions + AppException ( + -- \| The application directory could not be determined + UndeterminedAppDirectory, + -- \| The configuration file is invalid + InvalidConfiguration, + -- \| The file does not exist + FileDoesNotExist + ), +) where + +import Control.Monad.Except (ExceptT) +import Path (Abs, File, Path) + +type AppExceptionMonad = Either AppException +type AppExceptionMonadT = ExceptT AppException + +data AppException + = UndeterminedAppDirectory + | InvalidConfiguration (Path Abs File) + | FileDoesNotExist (Path Abs File) + deriving (Show) diff --git a/src/Helpers/IO.hs b/src/Helpers/IO.hs new file mode 100644 index 0000000..402aeef --- /dev/null +++ b/src/Helpers/IO.hs @@ -0,0 +1,21 @@ +module Helpers.IO (getApplicationDirectory, encodeFilePretty) where + +import Control.Monad.Trans.Except (runExceptT) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT), hoistMaybe, maybeToExceptT) +import Data.Aeson (ToJSON) +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.ByteString.Lazy qualified as BL +import Exceptions (AppException (UndeterminedAppDirectory), AppExceptionMonad) +import Path (Abs, Dir, Path, parseAbsDir) +import System.Environment (executablePath) + +getApplicationDirectory :: IO (AppExceptionMonad (Path Abs Dir)) +getApplicationDirectory = do + runExceptT $ do + appDir <- maybeToExceptT UndeterminedAppDirectory $ MaybeT =<< hoistMaybe executablePath + parseAbsDir appDir + +encodeFilePretty :: (ToJSON a) => FilePath -> a -> IO () +encodeFilePretty filePath obj = do + let encoded = encodePretty obj + BL.writeFile filePath encoded diff --git a/src/Helpers/Maybe.hs b/src/Helpers/Maybe.hs new file mode 100644 index 0000000..e4396ee --- /dev/null +++ b/src/Helpers/Maybe.hs @@ -0,0 +1,10 @@ +module Helpers.Maybe (catMaybesOrDefault) where + +import Data.Maybe (catMaybes) + +catMaybesOrDefault :: [a] -> [Maybe a] -> [a] +catMaybesOrDefault def xs = + let justs = catMaybes xs + in case justs of + [] -> def + _ -> justs diff --git a/src/Helpers/Sequence.hs b/src/Helpers/Sequence.hs new file mode 100644 index 0000000..c9294dd --- /dev/null +++ b/src/Helpers/Sequence.hs @@ -0,0 +1,18 @@ +module Helpers.Sequence (rights, nextMissingNonNegative) where + +import Data.IntSet (IntSet, member) +import Data.Sequence (Seq (..)) + +rights :: Seq (Either a b) -> Seq b +rights Empty = Empty +rights (Left _ :<| xs) = rights xs +rights (Right x :<| xs) = x :<| rights xs +{-# INLINEABLE rights #-} + +nextMissingNonNegative :: IntSet -> Int +nextMissingNonNegative = go 0 + where + go n nums = + if member n nums + then go (n + 1) nums + else n diff --git a/src/Parsing/Configuration.hs b/src/Parsing/Configuration.hs new file mode 100644 index 0000000..e9b8e17 --- /dev/null +++ b/src/Parsing/Configuration.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Parsing.Configuration ( + ifNewConfiguration, + createDemoTemplateFileIfNotExist, + createDefaultConfigFile, + findOrCreateDefaultConfig, + parseApplicationConfig, +) where + +import Control.Lens ((&), (.~), (^.)) +import Control.Monad (unless) +import Data.Aeson (decodeFileStrict) +import Data.Configuration ( + AuthorInfo (SingularAuthor), + Configuration (..), + ConfigurationPath (..), + TemplateConfiguration (TemplateConfiguration, _authorInfo, _fileContentReplacementMap, _relativeOutputPath, _templateDirectoryPath), + TextReplacementAction (TextReplacementAction), + configurationPath, + fileContentReplacementMap, + replacementActionName, + templateDirectoryPath, + ) +import Data.Either.Extra (maybeToEither) +import Data.Map.Strict qualified as Map +import Data.Semigroup (Arg (Arg)) +import Data.Sequence qualified as Seq +import Exceptions (AppException (InvalidConfiguration), AppExceptionMonad) +import Helpers.IO (encodeFilePretty) +import Path (Abs, Dir, File, Path, fromAbsFile, parent, reldir, relfile) +import Path.IO (doesFileExist, ensureDir, resolveDir, resolveFile) + +ifNewConfiguration :: ConfigurationPath -> (Path Abs File -> t) -> (Path Abs File -> t) -> t +ifNewConfiguration cfg p q = + case cfg of + NewConfiguration config -> p config + ExistingConfiguration config -> q config + +-- Creates demo file for the default config. It will make all parents in the filepath if they do not exist. +createDemoTemplateFile :: Path Abs File -> IO () +createDemoTemplateFile filePath = do + ensureDir (parent filePath) + writeFile + (fromAbsFile filePath) + "\\documentclass[11pt]{article}\n\ + \\n\\title{%%COURSE%% Assessment %%ASSESSNO%%}\n\ + \\\date{\\today}\n\ + \\\author{%%NAME%%}\n\ + \\n\\begin{document}\n\ + \ \\maketitle\n\ + \ Hello, there! This is just a simple \\LaTeX template!\n\ + \\\end{document}" + +createDemoTemplateFileIfNotExist :: Path Abs File -> IO () +createDemoTemplateFileIfNotExist filePath = do + fileExists <- doesFileExist filePath + unless fileExists $ createDemoTemplateFile filePath + +createDefaultConfigFile :: Path Abs Dir -> IO (Path Abs File) +createDefaultConfigFile configPath = do + -- Make a new template directory in config dir + assessmentTemplatePath <- resolveDir configPath "DemoTemplates" + + -- Create demo template sub-folders + mathTemplateDir <- resolveDir assessmentTemplatePath "MathTemplate" + compSciTemplateDir <- resolveDir assessmentTemplatePath "CompSciTemplate" + + -- Create demo assessment template files in each sub-dir + mathTemplate <- resolveFile mathTemplateDir "main.tex" + compSciTemplate <- resolveFile compSciTemplateDir "main.tex" + + -- Parent directories will be created along with files + createDemoTemplateFileIfNotExist mathTemplate + createDemoTemplateFileIfNotExist compSciTemplate + + let replacementActions = + [ TextReplacementAction "CourseCode" "%%COURSE%%" "%%THECOURSE%%" + , TextReplacementAction "AssessmentNumber" "%%ASSESSNO%%" "%%THEASSESSNO%%" + , TextReplacementAction "AuthorName" "%%NAME%%" "%%THEAUTHOR%%" + ] + mkActionsMap path = + Map.fromArgSet + [ Arg path $ + (^. replacementActionName) + <$> Seq.fromList replacementActions + ] + templateConfig = + TemplateConfiguration + { _authorInfo = Just $ SingularAuthor "Your name" + , _templateDirectoryPath = mathTemplateDir + , _relativeOutputPath = [reldir|tex/|] + , _fileContentReplacementMap = mkActionsMap [relfile|tex/file.tex|] + } + config = + Configuration + { _contentReplacementActions = Seq.fromList replacementActions + , _templateConfigurations = + Map.fromArgSet + [ Arg "MathTemplate" templateConfig + , Arg "CompSciTemplate" $ + templateConfig + & (templateDirectoryPath .~ compSciTemplateDir) + . (fileContentReplacementMap .~ mkActionsMap [relfile|tex/files/the_file.tex|]) + ] + } + + configFile <- resolveFile configPath "config.json" + encodeFilePretty (fromAbsFile configFile) config + return configFile + +-- | Creates a default "config.json" in the provided directory, if one is not found. +-- TODO: MOVE +findOrCreateDefaultConfig :: Path Abs Dir -> FilePath -> IO ConfigurationPath +findOrCreateDefaultConfig dir cfgName = do + configFile <- resolveFile dir cfgName + configExists <- doesFileExist configFile + if not configExists + then NewConfiguration <$> createDefaultConfigFile dir + else return $ ExistingConfiguration configFile + +parseApplicationConfig :: ConfigurationPath -> IO (AppExceptionMonad Configuration) +parseApplicationConfig configPath = + maybeToEither (InvalidConfiguration $ configurationPath configPath) + <$> case configPath of + NewConfiguration path -> decode path + ExistingConfiguration path -> decode path + where + decode = decodeFileStrict . fromAbsFile diff --git a/src/Parsing/CourseDirectory.hs b/src/Parsing/CourseDirectory.hs new file mode 100644 index 0000000..3ed7cd2 --- /dev/null +++ b/src/Parsing/CourseDirectory.hs @@ -0,0 +1,61 @@ +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +module Parsing.CourseDirectory ( + Parser, + pYear, + isYear, + pCourseCode, + parseCourseCode, + isCourseCode, + pAssessmentItemFolderNumber, + parseAssessmentItemFolderNumber, + isAssessmentItemFolder, +) +where + +import Control.Monad (void) +import Data.Either (isRight) +import Data.Void (Void) +import Text.Megaparsec ( + MonadParsec (eof), + ParseErrorBundle, + Parsec, + count, + parse, + some, + (), + ) +import Text.Megaparsec.Char (digitChar, spaceChar, string, upperChar) + +type Parser = Parsec Void String + +pYear :: Parser String +pYear = count 4 digitChar + +isYear :: String -> Bool +isYear = isRight . parse (pYear <* eof) "" + +pCourseCode :: Parser (String, String) +pCourseCode = do + courseCode <- count 4 upperChar "Course Code" + courseNum <- count 4 digitChar "Course Number" + return (courseCode, read courseNum) + +parseCourseCode :: String -> Either (ParseErrorBundle String Void) (String, String) +parseCourseCode = parse (pCourseCode <* eof) "" + +isCourseCode :: String -> Bool +isCourseCode = isRight . parseCourseCode + +pAssessmentItemFolderNumber :: Parser Integer +pAssessmentItemFolderNumber = do + void (string "Assessment") "Assessment Item Base Name" + void (some spaceChar) "Assessment Item Space" + folderNumber <- some digitChar "Assessment Item Number" + return $ read folderNumber + +parseAssessmentItemFolderNumber :: String -> Either (ParseErrorBundle String Void) Integer +parseAssessmentItemFolderNumber = parse (pAssessmentItemFolderNumber <* eof) "" + +isAssessmentItemFolder :: String -> Bool +isAssessmentItemFolder = isRight . parseAssessmentItemFolderNumber diff --git a/src/Printing.hs b/src/Printing.hs new file mode 100644 index 0000000..7e3fd0a --- /dev/null +++ b/src/Printing.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLists #-} + +module Printing ( + Message, + URI, + SGRStack, + startSGRScope, + nestedSGRScope, + sgrHyperlink, + sgrHyperlinkFile, + sgrGray, + sgrYellow, + sgrBlue, + sgrRed, + sgrPutStr, + sgrPutStrLn, + debug, +) where + +import Control.Monad.State.Strict ( + MonadIO (liftIO), + MonadState (get, put), + StateT, + evalStateT, + withStateT, + ) +import Data.Colour.RGBSpace (RGB) +import Data.Foldable (toList) +import Data.Sequence (Seq, (><)) +import Data.Sequence qualified as Seq +import Data.Word (Word16) +import System.Console.ANSI ( + Color (Blue, Red, White, Yellow), + ColorIntensity (Dull, Vivid), + ConsoleIntensity (BoldIntensity), + ConsoleLayer (Background, Foreground), + SGR (Reset, SetColor, SetConsoleIntensity), + hGetLayerColor, + hyperlink, + setSGR, + ) +import System.IO (stdout) + +type Message = String +type URI = String + +type SGRStack = StateT (Seq SGR) IO + +sgrGray :: [SGR] +sgrGray = [SetColor Foreground Dull White] + +sgrYellow :: [SGR] +sgrYellow = [SetColor Foreground Dull Yellow] + +sgrBlue :: [SGR] +sgrBlue = [SetColor Foreground Vivid Blue, SetConsoleIntensity BoldIntensity] + +sgrRed :: [SGR] +sgrRed = [SetColor Foreground Vivid Red] + +-- | Set the current graphics options using the current stack state +setSGRScope :: SGRStack () +setSGRScope = do + sgrs <- fmap toList get + liftIO $ setSGR [Reset] + liftIO $ setSGR sgrs + +-- TODO: Use this and test +getCurrentDefaults :: IO (Maybe [RGB Word16]) +getCurrentDefaults = do + mBC <- hGetLayerColor stdout Background + mFC <- hGetLayerColor stdout Foreground + return $ sequence [mBC, mFC] + +-- | Start a new SGR scope with the provided initial SGR paramaters. +startSGRScope :: [SGR] -> SGRStack a -> IO a +startSGRScope sgrs f = do + res <- evalStateT (setSGRScope >> f) (Seq.fromList sgrs) + setSGR [Reset] + return res + +-- | Start an inner SGR scope, appending the provided options to the stack. +-- These options are set in order, after previously provided options. +nestedSGRScope :: [SGR] -> SGRStack a -> SGRStack a +nestedSGRScope sgrs f = do + prevSGR <- get + res <- withStateT (>< Seq.fromList sgrs) (setSGRScope >> f) + put prevSGR + setSGRScope + return res + +sgrPutStr :: Message -> SGRStack () +sgrPutStr = liftIO . putStr + +sgrPutStrLn :: Message -> SGRStack () +sgrPutStrLn msg = do + prevSGR <- get + sgrPutStr msg + nestedSGRScope [Reset] $ do + liftIO $ putStrLn mempty + put prevSGR + setSGRScope + +sgrHyperlink :: URI -> Message -> SGRStack () +sgrHyperlink uri msg = do + nestedSGRScope sgrBlue (liftIO $ hyperlink uri msg) + +sgrHyperlinkFile :: URI -> SGRStack () +sgrHyperlinkFile uri = sgrHyperlink ("file://" <> uri) uri + +debug :: String -> IO () +debug msg = do + startSGRScope [SetColor Foreground Vivid Red] $ do + sgrPutStrLn $ unwords ["DEBUG:", msg] diff --git a/src/StringFormatters.hs b/src/StringFormatters.hs new file mode 100644 index 0000000..c539b3a --- /dev/null +++ b/src/StringFormatters.hs @@ -0,0 +1,29 @@ +module StringFormatters ( + surround, + surround1, + cleanAbsDirPathString, + cleanRelDirPathString, + cleanDirNameString, + cleanAbsFilePathString, +) where + +import Path (Abs, Dir, File, Path, Rel, dirname, fromAbsDir, fromAbsFile, fromRelDir) +import System.FilePath (dropTrailingPathSeparator) + +surround :: String -> String -> String -> String +surround p q x = concat [p, x, q] + +surround1 :: String -> String -> String +surround1 p = surround p p + +cleanAbsDirPathString :: Path Abs Dir -> FilePath +cleanAbsDirPathString = dropTrailingPathSeparator . fromAbsDir + +cleanRelDirPathString :: Path Rel Dir -> FilePath +cleanRelDirPathString = dropTrailingPathSeparator . fromRelDir + +cleanDirNameString :: Path b Dir -> FilePath +cleanDirNameString = cleanRelDirPathString . dirname + +cleanAbsFilePathString :: Path Abs File -> FilePath +cleanAbsFilePathString = dropTrailingPathSeparator . fromAbsFile diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..6f39ce6 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,68 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +#resolver: lts-21.23 +resolver: nightly-2023-12-07 +# resolver: ghc-9.6.3 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +#resolver: +# url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/4.yaml + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +# extra-deps: +# - todo-0.2.0.3 + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of Stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=2.9" +# +# Override the architecture used by Stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by Stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000..9c48651 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,12 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: [] +snapshots: +- completed: + sha256: ea200ce76bd0713b746001f1acaa55541d9ee936c668251b5f5d83e7848b8fff + size: 708926 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2023/12/7.yaml + original: nightly-2023-12-07 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..d1bcc16 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,42 @@ +import Data.CourseDirectory.Parsing (isYear) +import Test.QuickCheck ( + Arbitrary (arbitrary), + Gen, + arbitraryUnicodeChar, + chooseInteger, + listOf1, + quickCheck, + ) + +newtype ValidYear = ValidYear String deriving (Show) +newtype InvalidYear = InvalidYear String deriving (Show) + +yearGen :: Gen String +yearGen = do + let gen = chooseInteger (0, 9) + y1 <- gen + y2 <- gen + y3 <- gen + y4 <- gen + return $ concatMap show [y1, y2, y3, y4] + +instance Arbitrary ValidYear where + arbitrary = ValidYear <$> yearGen + +instance Arbitrary InvalidYear where + arbitrary = do + pre <- listOf1 arbitraryUnicodeChar + year <- yearGen + pos <- listOf1 arbitraryUnicodeChar + return . InvalidYear $ concatMap show [pre, year, pos] + +yearValidParse :: ValidYear -> Bool +yearValidParse (ValidYear year) = isYear year + +yearInvalidParse :: InvalidYear -> Bool +yearInvalidParse (InvalidYear year) = not $ isYear year + +main :: IO () +main = do + quickCheck yearValidParse + quickCheck yearInvalidParse